~ chicken-core (chicken-5) de342aacd5bd18a6533e4eb4e04c2955e0f02959
commit de342aacd5bd18a6533e4eb4e04c2955e0f02959
Author: Peter Bex <peter@more-magic.net>
AuthorDate: Tue Apr 9 12:28:15 2019 +0200
Commit: Kooda <kooda@upyum.com>
CommitDate: Mon May 6 13:17:51 2019 +0200
Improve hygiene of FFI macros
These macros would expand to renamed identifiers but those identifiers
were not in the syntactic environment of these macros, so they would
"escape" and require the user to import "scheme" and possible
"chicken.base" without prefixes to have them work.
Also, the helper procedures used single quotes in the code they
generated, which expands to unqualified "quote". Replace these
by ##core#quote.
Signed-off-by: Kooda <kooda@upyum.com>
diff --git a/NEWS b/NEWS
index 1a3b5a76..c37366f2 100644
--- a/NEWS
+++ b/NEWS
@@ -34,6 +34,9 @@
the compiler when later trying to import that same module (fixes
#1506, thanks to Kristian Lein-Mathisen).
+- Foreign function interface
+ - Improved hygiene in FFI macro expansions, which means you don't
+ have to import "scheme" or "(chicken base)" for them to work.
5.0.1
diff --git a/chicken-ffi-syntax.scm b/chicken-ffi-syntax.scm
index f0edba43..da7a6fc6 100644
--- a/chicken-ffi-syntax.scm
+++ b/chicken-ffi-syntax.scm
@@ -63,7 +63,9 @@
(##sys#extend-macro-environment
'define-external
- '()
+ `((define . ,(alist-ref 'define me0)) ; Or just me0?
+ (begin . ,(alist-ref 'begin me0))
+ (lambda . ,(alist-ref 'lambda me0)))
(compiler-only-er-transformer
(lambda (form r c)
(let* ((form (cdr form))
@@ -82,14 +84,14 @@
(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)] )
+ (let* ((head (if quals (cadr form) (car form)))
+ (args (cdr head)) )
`(,(r 'define) ,(car head)
(##core#foreign-callback-wrapper
- ',(car head)
+ (##core#quote ,(car head))
,(if quals (car form) "")
- ',(if quals (caddr form) (cadr form))
- ',(map (lambda (a) (car a)) args)
+ (##core#quote ,(if quals (caddr form) (cadr form)))
+ (##core#quote ,(map (lambda (a) (car a)) args))
(,(r 'lambda)
,(map (lambda (a) (cadr a)) args)
,@(if quals (cdddr form) (cddr form)) ) ) ) ) ] ) ) ) ) )
@@ -108,7 +110,7 @@
(##sys#extend-macro-environment
'define-location
- '()
+ `((begin . ,(alist-ref 'begin me0)))
(compiler-only-er-transformer
(lambda (form r c)
(##sys#check-syntax 'define-location form '(_ variable _ . #(_ 0 1)))
@@ -161,7 +163,7 @@
(##sys#extend-macro-environment
'foreign-code
- '()
+ `((declare . ,(alist-ref 'declare me0)))
(compiler-only-er-transformer
(lambda (form r c)
(##sys#check-syntax 'foreign-code form '(_ . #(string 0)))
diff --git a/core.scm b/core.scm
index 39ae7a82..c4aa81bc 100644
--- a/core.scm
+++ b/core.scm
@@ -664,7 +664,7 @@
((##core#check)
(if unsafe
- ''#t
+ '(quote #t)
(walk (cadr x) e dest ldest h ln tl?) ) )
((##core#the)
@@ -797,7 +797,7 @@
(walk
(if emit-debug-info
`(##core#begin
- (##core#debug-event C_DEBUG_ENTRY ',dest)
+ (##core#debug-event C_DEBUG_ENTRY (##core#quote ,dest))
,body0)
body0)
(append aliases e) #f #f dest ln #f))))
@@ -883,7 +883,7 @@
(walk
(if ##sys#enable-runtime-macros
`(##sys#extend-macro-environment
- ',var
+ (##core#quote ,var)
(##sys#current-environment) ,body) ;XXX possibly wrong se?
'(##core#undefined) )
e dest ldest h ln #f)) )
@@ -915,7 +915,7 @@
`(##sys#cons
(##sys#ensure-transformer
,body
- ',var)
+ (##core#quote ,var))
(##sys#current-environment))))
'(##core#undefined) )
e dest ldest h ln #f)))
@@ -1106,7 +1106,7 @@
(let ((type (second fv))
(tmp (gensym)))
(walk
- `(let ((,tmp ,(foreign-type-convert-argument val type)))
+ `(##core#let ((,tmp ,(foreign-type-convert-argument val type)))
(##core#inline_update
(,(third fv) ,type)
,(foreign-type-check tmp type)))
@@ -1116,7 +1116,7 @@
(let* ((type (third a))
(tmp (gensym)))
(walk
- `(let ((,tmp ,(foreign-type-convert-argument val type)))
+ `(##core#let ((,tmp ,(foreign-type-convert-argument val type)))
(##core#inline_loc_update
(,type)
,(second a)
@@ -1130,8 +1130,8 @@
(mark-variable var '##compiler#always-bound))
(when emit-debug-info
(set! val
- `(let ((,var ,val))
- (##core#debug-event C_DEBUG_GLOBAL_ASSIGN ',var)
+ `(##core#let ((,var ,val))
+ (##core#debug-event C_DEBUG_GLOBAL_ASSIGN (##core#quote ,var))
,var)))
;; We use `var0` instead of `var` because the {macro,current}-environment
;; are keyed by the raw and unqualified name
@@ -1243,8 +1243,8 @@
(hide-variable ret)
(walk
`(##core#begin
- (define ,arg ,(first conv))
- (define
+ (##core#set! ,arg ,(first conv))
+ (##core#set!
,ret
,(if (pair? (cdr conv)) (second conv) '##sys#values)) )
e dest ldest h ln tl?))]
@@ -1284,7 +1284,7 @@
(parameterize ((##sys#current-environment
(alist-cons var alias (##sys#current-environment))))
(walk
- `(let (,(let ((size (bytes->words (estimate-foreign-result-location-size type))))
+ `(##core#let (,(let ((size (bytes->words (estimate-foreign-result-location-size type))))
;; Add 2 words: 1 for the header, 1 for double-alignment:
;; Note: C_a_i_bytevector takes number of words, not bytes
(list
@@ -1416,7 +1416,7 @@
`((##sys#make-c-string
(##core#let
() ,@(cddr lam))
- ',name)))
+ (##core#quote ,name))))
((member
rtype
'((const c-string*)
@@ -1439,7 +1439,7 @@
((r (##core#let () ,@(cddr lam))))
(,(macro-alias 'and)
r
- (##sys#make-c-string r ',name)) ) ) )
+ (##sys#make-c-string r (##core#quote ,name))) ) ) )
(else (cddr lam)) ) )
rtype) ) )
e #f #f h ln #f) ) ) ) )
@@ -1450,7 +1450,7 @@
(cond ((assq (lookup sym) location-pointer-map)
=> (lambda (a)
(walk
- `(##sys#make-locative ,(second a) 0 #f 'location)
+ `(##sys#make-locative ,(second a) 0 #f (##core#quote location))
e #f #f h ln #f) ) )
((assq sym external-to-pointer)
=> (lambda (a) (walk (cdr a) e #f #f h ln #f)) )
@@ -1458,10 +1458,10 @@
`(##core#inline_ref (,(symbol->string sym) c-pointer)) )
(else
(walk
- `(##sys#make-locative ,sym 0 #f 'location)
+ `(##sys#make-locative ,sym 0 #f (##core#quote location))
e #f #f h ln #f) ) )
(walk
- `(##sys#make-locative ,sym 0 #f 'location)
+ `(##sys#make-locative ,sym 0 #f (##core#quote location))
e #f #f h ln #f) ) ) )
(else
@@ -1837,14 +1837,14 @@
`((##core#primitive ,f-id))
`(##core#inline ,f-id) ) ]
[rest (map (lambda (p t) (foreign-type-check (foreign-type-convert-argument p t) t)) params argtypes)] )
- `(lambda ,params
+ `(##core#lambda ,params
;; Do minor GC (if callback) to make room on stack:
,@(if callback '((##sys#gc #f)) '())
,(if (zero? rsize)
(foreign-type-convert-result (append head (cons '(##core#undefined) rest)) rtype)
(let ([ft (final-foreign-type rtype)]
[ws (bytes->words rsize)] )
- `(let ([,bufvar (##core#inline_allocate ("C_a_i_bytevector" ,(+ 2 ws)) ',ws)])
+ `(##core#let ([,bufvar (##core#inline_allocate ("C_a_i_bytevector" ,(+ 2 ws)) (##core#quote ,ws))])
,(foreign-type-convert-result
(finish-foreign-result ft (append head (cons bufvar rest)))
rtype) ) ) ) ) ) ) )
diff --git a/support.scm b/support.scm
index ebc181d6..734ff407 100644
--- a/support.scm
+++ b/support.scm
@@ -1003,37 +1003,37 @@
((float double number) (if unsafe param `(##sys#foreign-flonum-argument ,param)))
((blob scheme-pointer)
(let ((tmp (gensym)))
- `(let ((,tmp ,param))
- (if ,tmp
- ,(if unsafe
- tmp
- `(##sys#foreign-block-argument ,tmp) )
- '#f) ) ) )
+ `(##core#let ((,tmp ,param))
+ (##core#if ,tmp
+ ,(if unsafe
+ tmp
+ `(##sys#foreign-block-argument ,tmp) )
+ (##core#quote #f)) ) ) )
((nonnull-scheme-pointer nonnull-blob)
(if unsafe
param
`(##sys#foreign-block-argument ,param) ) )
((pointer-vector)
(let ((tmp (gensym)))
- `(let ((,tmp ,param))
- (if ,tmp
- ,(if unsafe
- tmp
- `(##sys#foreign-struct-wrapper-argument 'pointer-vector ,tmp) )
- '#f) ) ) )
+ `(##core#let ((,tmp ,param))
+ (##core#if ,tmp
+ ,(if unsafe
+ tmp
+ `(##sys#foreign-struct-wrapper-argument (##core#quote pointer-vector) ,tmp) )
+ (##core#quote #f)) ) ) )
((nonnull-pointer-vector)
(if unsafe
param
- `(##sys#foreign-struct-wrapper-argument 'pointer-vector ,param) ) )
+ `(##sys#foreign-struct-wrapper-argument (##core#quote pointer-vector) ,param) ) )
((u8vector u16vector s8vector s16vector u32vector s32vector
u64vector s64vector f32vector f64vector)
(let ((tmp (gensym)))
- `(let ((,tmp ,param))
- (if ,tmp
- ,(if unsafe
- tmp
- `(##sys#foreign-struct-wrapper-argument ',t ,tmp) )
- '#f) ) ) )
+ `(##core#let ((,tmp ,param))
+ (##core#if ,tmp
+ ,(if unsafe
+ tmp
+ `(##sys#foreign-struct-wrapper-argument (##core#quote ,t) ,tmp) )
+ (##core#quote #f)) ) ) )
((nonnull-u8vector nonnull-u16vector
nonnull-s8vector nonnull-s16vector
nonnull-u32vector nonnull-s32vector
@@ -1042,7 +1042,7 @@
(if unsafe
param
`(##sys#foreign-struct-wrapper-argument
- ',(##sys#slot (assq t tmap) 1)
+ (##core#quote ,(##sys#slot (assq t tmap) 1))
,param) ) )
((integer32 integer64 integer short long ssize_t)
(let* ((foreign-type (##sys#slot (assq t ftmap) 1))
@@ -1061,20 +1061,20 @@
,param (foreign-value ,size-expr int)))))
((c-pointer c-string-list c-string-list*)
(let ((tmp (gensym)))
- `(let ((,tmp ,param))
- (if ,tmp
- (##sys#foreign-pointer-argument ,tmp)
- '#f) ) ) )
+ `(##core#let ((,tmp ,param))
+ (##core#if ,tmp
+ (##sys#foreign-pointer-argument ,tmp)
+ (##core#quote #f)) ) ) )
((nonnull-c-pointer)
`(##sys#foreign-pointer-argument ,param) )
((c-string c-string* unsigned-c-string unsigned-c-string*)
(let ((tmp (gensym)))
- `(let ((,tmp ,param))
- (if ,tmp
- ,(if unsafe
- `(##sys#make-c-string ,tmp)
- `(##sys#make-c-string (##sys#foreign-string-argument ,tmp)) )
- '#f) ) ) )
+ `(##core#let ((,tmp ,param))
+ (##core#if ,tmp
+ ,(if unsafe
+ `(##sys#make-c-string ,tmp)
+ `(##sys#make-c-string (##sys#foreign-string-argument ,tmp)) )
+ (##core#quote #f)) ) ) )
((nonnull-c-string nonnull-c-string* nonnull-unsigned-c-string*)
(if unsafe
`(##sys#make-c-string ,param)
@@ -1090,30 +1090,30 @@
(case (car t)
((ref pointer function c-pointer)
(let ((tmp (gensym)))
- `(let ((,tmp ,param))
- (if ,tmp
- (##sys#foreign-pointer-argument ,tmp)
- '#f) ) ) )
+ `(##core#let ((,tmp ,param))
+ (##core#if ,tmp
+ (##sys#foreign-pointer-argument ,tmp)
+ (##core#quote #f)) ) ) )
((instance instance-ref)
(let ((tmp (gensym)))
- `(let ((,tmp ,param))
- (if ,tmp
- (slot-ref ,param 'this)
- '#f) ) ) )
+ `(##core#let ((,tmp ,param))
+ (##core#if ,tmp
+ (slot-ref ,param (##core#quote this))
+ (##core#quote #f)) ) ) )
((scheme-pointer)
(let ((tmp (gensym)))
- `(let ((,tmp ,param))
- (if ,tmp
- ,(if unsafe
- tmp
- `(##sys#foreign-block-argument ,tmp) )
- '#f) ) ) )
+ `(##core#let ((,tmp ,param))
+ (##core#if ,tmp
+ ,(if unsafe
+ tmp
+ `(##sys#foreign-block-argument ,tmp) )
+ (##core#quote #f)) ) ) )
((nonnull-scheme-pointer)
(if unsafe
param
`(##sys#foreign-block-argument ,param) ) )
((nonnull-instance)
- `(slot-ref ,param 'this) )
+ `(slot-ref ,param (##core#quote this)) )
((const) (repeat (cadr t)))
((enum)
(if unsafe
@@ -1224,14 +1224,14 @@
(define (finish-foreign-result type body) ; Used only in compiler.scm
(let ((type (strip-syntax type)))
(case type
- [(c-string unsigned-c-string) `(##sys#peek-c-string ,body '0)]
- [(nonnull-c-string) `(##sys#peek-nonnull-c-string ,body '0)]
- [(c-string* unsigned-c-string*) `(##sys#peek-and-free-c-string ,body '0)]
- [(nonnull-c-string* nonnull-unsigned-c-string*) `(##sys#peek-and-free-nonnull-c-string ,body '0)]
- [(symbol) `(##sys#intern-symbol (##sys#peek-c-string ,body '0))]
- [(c-string-list) `(##sys#peek-c-string-list ,body '#f)]
- [(c-string-list*) `(##sys#peek-and-free-c-string-list ,body '#f)]
- [else
+ ((c-string unsigned-c-string) `(##sys#peek-c-string ,body (##core#quote 0)))
+ ((nonnull-c-string) `(##sys#peek-nonnull-c-string ,body (##core#quote 0)))
+ ((c-string* unsigned-c-string*) `(##sys#peek-and-free-c-string ,body (##core#quote 0)))
+ ((nonnull-c-string* nonnull-unsigned-c-string*) `(##sys#peek-and-free-nonnull-c-string ,body (##core#quote 0)))
+ ((symbol) `(##sys#intern-symbol (##sys#peek-c-string ,body (##core#quote 0))))
+ ((c-string-list) `(##sys#peek-c-string-list ,body (##core#quote #f)))
+ ((c-string-list*) `(##sys#peek-and-free-c-string-list ,body (##core#quote #f)))
+ (else
(if (list? type)
(if (and (eq? (car type) 'const)
(= 2 (length type))
@@ -1247,12 +1247,13 @@
`(let ((,tmp ,body))
(and ,tmp
(not (##sys#null-pointer? ,tmp))
- (make ,(caddr type) 'this ,tmp) ) ) ) )
+ (make ,(caddr type)
+ (##core#quote this) ,tmp) ) ) ) )
((nonnull-instance)
- `(make ,(caddr type) 'this ,body) )
+ `(make ,(caddr type) (##core#quote this) ,body) )
(else body))
body))
- body)])))
+ body)))))
;;; Translate foreign-type into scrutinizer type:
diff --git a/tests/compiler-tests.scm b/tests/compiler-tests.scm
index b3ab13ed..6e5c8b27 100644
--- a/tests/compiler-tests.scm
+++ b/tests/compiler-tests.scm
@@ -148,14 +148,14 @@
;; Unused arguments in foreign callback wrappers are not optimized away (#584)
(module bla (foo)
-(import scheme chicken.base chicken.foreign)
+(import (prefix scheme s:) (only chicken.base assert) chicken.foreign)
(define-external
(blabla (int a) (c-string b) (int c) (int d) (c-string e) (int f))
int
f)
-(define (foo) ((foreign-safe-lambda* int () "C_return(blabla(1, \"2\", 3, 4, \"5\", 6));")))
+(s:define (foo) ((foreign-safe-lambda* int () "C_return(blabla(1, \"2\", 3, 4, \"5\", 6));")))
(assert (location blabla))
)
Trap