Skip to content
Fetching contributors…
Cannot retrieve contributors at this time
252 lines (219 sloc) 7.07 KB
;;;; 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)))
Jump to Line
Something went wrong with that request. Please try again.