;;;; chicken-ffi-syntax.scm
;
; Copyright (c) 2008-2011, The Chicken Team
; Copyright (c) 2000-2007, Felix L. Winkelmann
; All rights reserved.
;
; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following
; conditions are met:
;
;   Redistributions of source code must retain the above copyright notice, this list of conditions and the following
;     disclaimer.
;   Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following
;     disclaimer in the documentation and/or other materials provided with the distribution.
;   Neither the name of the author nor the names of its contributors may be used to endorse or promote
;     products derived from this software without specific prior written permission.
;
; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS
; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
; POSSIBILITY OF SUCH DAMAGE.


(declare
  (unit chicken-ffi-syntax)
  (disable-interrupts)
  (fixnum) )

#+(not debugbuild)
(declare
  (no-bound-checks)
  (no-procedure-checks))

(##sys#provide
 'chicken-ffi-syntax)


(define ##sys#chicken-ffi-macro-environment
  (let ((me0 (##sys#macro-environment)))

(##sys#extend-macro-environment
 'define-external
 '()
 (##sys#er-transformer
  (lambda (form r c)
    (let* ((form (cdr form))
	   (quals (and (pair? form) (string? (car form))))
	   (var (and (not quals) (pair? form) (symbol? (car form)))) )
      (cond [var
	     (##sys#check-syntax 'define-external form '(symbol _ . #(_ 0 1)))
	     (let ([var (car form)])
	       `(,(r 'begin)
		 (##core#define-foreign-variable ,var ,(cadr form))
		 (##core#define-external-variable ,var ,(cadr form) #t)
		 ,@(if (pair? (cddr form))
		       `((##core#set! ,var ,(caddr form)))
		       '() ) ) ) ]
	    [else
	     (if quals
		 (##sys#check-syntax 'define-external form '(string (symbol . #((_ symbol) 0)) _ . #(_ 1)))
		 (##sys#check-syntax 'define-external form '((symbol . #((_ symbol) 0)) _ . #(_ 1))) )
	     (let* ([head (if quals (cadr form) (car form))]
		    [args (cdr head)] )
	       `(,(r 'define) ,(car head)
		 (##core#foreign-callback-wrapper
		  ',(car head)
		  ,(if quals (car form) "")
		  ',(if quals (caddr form) (cadr form))
		  ',(map (lambda (a) (car a)) args)
		  (,(r 'lambda) 
		   ,(map (lambda (a) (cadr a)) args)
		   ,@(if quals (cdddr form) (cddr form)) ) ) ) ) ] ) ) ) ) )



;;; External locations:

(##sys#extend-macro-environment
 'location
 '()
 (##sys#er-transformer
  (lambda (x r c)
    (##sys#check-syntax 'location x '(location _))
    `(##core#location ,(cadr x)))))

(##sys#extend-macro-environment
 'define-location
 '()
 (##sys#er-transformer
  (lambda (form r c)
    (##sys#check-syntax 'define-location form '(_ variable _ . #(_ 0 1)))
    (let ((var (cadr form))
	  (type (caddr form))
	  (init (optional (cdddr form) #f))
	  (name (r (gensym))))
      `(,(r 'begin)
	(##core#define-foreign-variable ,var ,type ,(symbol->string name))
	(##core#define-external-variable ,var ,type #f ,name)
	,@(if (pair? init)
	      `((##core#set! ,var ,(car init)))
	      '() ) ) ) ) ) )

(##sys#extend-macro-environment
 'let-location
 '()
 (##sys#er-transformer
  (lambda (form r c)
    (##sys#check-syntax 'let-location form '(_ #((variable _ . #(_ 0 1)) 0) . _))
    (let* ((bindings (cadr form))
	   (body (cddr form))
	   [aliases (map (lambda (_) (r (gensym))) bindings)])
      `(##core#let ,(append-map
		(lambda (b a)
		  (if (pair? (cddr b))
		      (list (cons a (cddr b)))
		      '() ) )
		bindings aliases)
	      ,(fold-right
		(lambda (b a rest)
		  (if (= 3 (length b))
		      `(##core#let-location
			,(car b)
			,(cadr b)
			,a
			,rest)
		      `(##core#let-location
			,(car b)
			,(cadr b)
			,rest) ) )
		`(##core#let () ,@body)
		bindings aliases) ) ) ) ) )


;;; Embedding code directly:

(##sys#extend-macro-environment
 'foreign-code
 '()
 (##sys#er-transformer
  (lambda (form r c)
    (##sys#check-syntax 'foreign-code form '(_ . #(string 0)))
    (let ([tmp (gensym 'code_)])
      `(##core#begin
	 (,(r 'declare)
	  (foreign-declare
	   ,(sprintf "static C_word ~A() { ~A\n; return C_SCHEME_UNDEFINED; }\n" 
		     tmp
		     (string-intersperse (cdr form) "\n")) ) )
	 (##core#inline ,tmp) ) ) ) ) )

(##sys#extend-macro-environment
 'foreign-value
 '()
 (##sys#er-transformer
  (lambda (form r c)
    (##sys#check-syntax 'foreign-value form '(_ _ _))
    (let ((tmp (gensym "code_"))
	  (code (cadr form)))
      `(##core#begin
	(##core#define-foreign-variable ,tmp
	 ,(caddr form)
	 ,(cond ((string? code) code)
		((symbol? code) (symbol->string code))
		(else (syntax-error 'foreign-value "bad argument type - not a string or symbol" code))))
	,tmp) ) ) ) )


;;; Include/parse foreign code fragments

(##sys#extend-macro-environment
 'foreign-declare
 '()
 (##sys#er-transformer
  (lambda (form r c)
    (##sys#check-syntax 'foreign-declare form '(_ . #(string 0)))
    `(##core#declare (foreign-declare ,@(cdr form))))))


;;; Aliases for internal forms

(##sys#extend-macro-environment
 'define-foreign-type
 '()
 (##sys#er-transformer
  (lambda (form r c)
    `(##core#define-foreign-type ,@(cdr form)))))

(##sys#extend-macro-environment
 'define-foreign-variable
 '()
 (##sys#er-transformer
  (lambda (form r c)
    `(##core#define-foreign-variable ,@(cdr form)))))

(##sys#extend-macro-environment
 'foreign-primitive
 '()
 (##sys#er-transformer
  (lambda (form r c)
    `(##core#foreign-primitive ,@(cdr form)))))

(##sys#extend-macro-environment
 'foreign-lambda
 '()
 (##sys#er-transformer
  (lambda (form r c)
    `(##core#foreign-lambda ,@(cdr form)))))

(##sys#extend-macro-environment
 'foreign-lambda*
 '()
 (##sys#er-transformer
  (lambda (form r c)
    `(##core#foreign-lambda* ,@(cdr form)))))

(##sys#extend-macro-environment
 'foreign-safe-lambda
 '()
 (##sys#er-transformer
  (lambda (form r c)
    `(##core#foreign-safe-lambda ,@(cdr form)))))

(##sys#extend-macro-environment
 'foreign-safe-lambda*
 '()
 (##sys#er-transformer
  (lambda (form r c)
    `(##core#foreign-safe-lambda* ,@(cdr form)))))

(##sys#extend-macro-environment
 'foreign-type-size
 '()
 (##sys#er-transformer
  (lambda (form r c)
    (##sys#check-syntax 'foreign-type-size form '(_ _))
    (let* ((t (##sys#strip-syntax (cadr form)))
	   (tmp (gensym "code_"))
	   (decl
	    (if (string? t)
		t
		(##compiler#foreign-type-declaration t ""))))
      `(##core#begin
	(##core#define-foreign-variable ,tmp size_t ,(string-append "sizeof(" decl ")"))
	,tmp) ) ) ) )


(##sys#macro-subset me0)))