Hi all, I had a quick look at #1346 (which I haven't fixed yet) but then quickly noticed that define-external expands into "define" in an unhygienic way. You can notice this if you have a module with an import of ONLY (chicken foreign) but not scheme.
Of course this is not a very common thing to do, which is why we never ran into it. I've modified one test to trigger an error with the current version, and fixed several issues with it. The fix is probably not 100% complete (and the test certainly isn't), but it's certainly an improvement. The patch is somewhat large but straightforward. It replaces all uses of just "quote" (via the single quote character) to "##core#quote", uses of plain "let" to ##core#let, and it adds some missing macros to the syntax environment so that the macros can expand properly to the intended macro calls. I'm not sure if we should pick just the used definitions from the macro environment (which is what I did here with alist-ref), or if we should just take the entire original macro environment (which would be more convenient and less error-prone when we change any macros to make use of other, new macros but also slightly slower(?)). Cheers, Peter
From 07528942dd064843db9a55f56090b9507b9cc981 Mon Sep 17 00:00:00 2001
From: Peter Bex <pe...@more-magic.net>
Date: Tue, 9 Apr 2019 12:28:15 +0200
Subject: [PATCH] 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.
---
NEWS | 3 ++
chicken-ffi-syntax.scm | 18 ++++----
core.scm | 36 +++++++--------
support.scm | 113 ++++++++++++++++++++++++-----------------------
tests/compiler-tests.scm | 4 +-
5 files changed, 90 insertions(+), 84 deletions(-)
diff --git a/NEWS b/NEWS
index c8f21f8b..ad83d6ba 100644
--- a/NEWS
+++ b/NEWS
@@ -25,6 +25,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 06a4cf7f..cc440eb4 100644
--- a/core.scm
+++ b/core.scm
@@ -660,7 +660,7 @@
((##core#check)
(if unsafe
- ''#t
+ '(##core#quote #t)
(walk (cadr x) e dest ldest h ln tl?) ) )
((##core#the)
@@ -793,7 +793,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))))
@@ -879,7 +879,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)) )
@@ -911,7 +911,7 @@
`(##sys#cons
(##sys#ensure-transformer
,body
- ',var)
+ (##core#quote ,var))
(##sys#current-environment))))
'(##core#undefined) )
e dest ldest h ln #f)))
@@ -1102,7 +1102,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)))
@@ -1112,7 +1112,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)
@@ -1126,8 +1126,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
@@ -1239,8 +1239,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?))]
@@ -1280,7 +1280,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
@@ -1412,7 +1412,7 @@
`((##sys#make-c-string
(##core#let
() ,@(cddr lam))
- ',name)))
+ (##core#quote ,name))))
((member
rtype
'((const c-string*)
@@ -1435,7 +1435,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) ) ) ) )
@@ -1446,7 +1446,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)) )
@@ -1454,10 +1454,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
@@ -1833,14 +1833,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 44352e98..06ea9346 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))
)
--
2.11.0
signature.asc
Description: PGP signature
_______________________________________________ Chicken-hackers mailing list Chicken-hackers@nongnu.org https://lists.nongnu.org/mailman/listinfo/chicken-hackers
