From 9f7857034305fb688c9069f4780e84fd865680e2 Mon Sep 17 00:00:00 2001 From: Andy Keep Date: Sat, 7 Apr 2018 15:18:27 -0400 Subject: [PATCH] Changed the base language to allow for a list of conventions. Changed the base language foregin and fcallable forms to accept a list of conventions, which are each symbols, instead of a single convention, which was a list of conventions, mostly to make it clear in the grammar what is going on. base-lang.ss, cp0.ss cpcheck.ss, cpcommonize.ss, cpletrec.ss, cpnanopass.ss, cprep.ss, cpvalid.ss, interpret.ss, syntax.ss, Fixed a place where we were checking for eq? of two conventions, which now should be equal? since it is a list (assuming this list will always be in a consistent order). cpcommonize.ss Removed a spurious definition of convention? np-languages.ss original commit: dabf5a8abeaef12cdfcb36d9aac236dda9ac9158 --- s/base-lang.ss | 8 ++++---- s/cp0.ss | 36 ++++++++++++++++++------------------ s/cpcheck.ss | 8 ++++---- s/cpcommonize.ss | 24 ++++++++++++------------ s/cpletrec.ss | 8 ++++---- s/cpnanopass.ss | 4 ++-- s/cprep.ss | 4 ++-- s/cpvalid.ss | 16 ++++++++-------- s/interpret.ss | 8 ++++---- s/np-languages.ss | 4 ---- s/syntax.ss | 4 ++-- 11 files changed, 60 insertions(+), 64 deletions(-) diff --git a/s/base-lang.ss b/s/base-lang.ss index 5a6ca29807..cde6e9c23d 100644 --- a/s/base-lang.ss +++ b/s/base-lang.ss @@ -155,7 +155,7 @@ (define convention? (lambda (x) - (and (list? x) (andmap symbol? x)))) + (symbol? x))) (define-record-type preinfo (nongenerative #{preinfo e23pkvo5btgapnzomqgegm-2}) @@ -211,7 +211,7 @@ ; source language used by the passes leading up to the compiler or interpreter (define-language Lsrc - (nongenerative-id #{Lsrc czsa1fcfzdeh493n-2}) + (nongenerative-id #{Lsrc czsa1fcfzdeh493n-3}) (terminals (preinfo (preinfo)) ($prelex (x)) @@ -248,8 +248,8 @@ (record-ref rtd type index e) (record-set! rtd type index e1 e2) (cte-optimization-loc box e) - (foreign conv name e (arg-type* ...) result-type) - (fcallable conv e (arg-type* ...) result-type) + (foreign (conv ...) name e (arg-type* ...) result-type) + (fcallable (conv ...) e (arg-type* ...) result-type) (profile src) => (profile) ; used only in cpvalid (cpvalid-defer e)) diff --git a/s/cp0.ss b/s/cp0.ss index c7b3acdfa9..90bd1542ce 100644 --- a/s/cp0.ss +++ b/s/cp0.ss @@ -949,13 +949,13 @@ [(record-cd ,rcd ,rtd-expr ,e) (memoize (pure? e))] [(letrec ([,x* ,e*] ...) ,body) (memoize (and (andmap pure? e*) (pure? body)))] [(record-type ,rtd ,e) (memoize (pure? e))] - [(foreign ,conv ,name ,e (,arg-type* ...) ,result-type) (memoize (pure? e))] + [(foreign (,conv ...) ,name ,e (,arg-type* ...) ,result-type) (memoize (pure? e))] [(letrec* ([,x* ,e*] ...) ,body) (memoize (and (andmap pure? e*) (pure? body)))] [(immutable-list (,e* ...) ,e) (memoize (and (andmap pure? e*) (pure? e)))] [(profile ,src) #t] [(cte-optimization-loc ,box ,e) (memoize (pure? e))] [(moi) #t] - [(fcallable ,conv ,e (,arg-type* ...) ,result-type) (memoize (pure? e))] + [(fcallable (,conv ...) ,e (,arg-type* ...) ,result-type) (memoize (pure? e))] [(pariah) #t] [else ($oops who "unrecognized record ~s" e)])))) @@ -1008,13 +1008,13 @@ [(record-cd ,rcd ,rtd-expr ,e) (memoize (ivory? e))] [(letrec ([,x* ,e*] ...) ,body) (memoize (and (andmap ivory? e*) (ivory? body)))] [(record-type ,rtd ,e) (memoize (ivory? e))] - [(foreign ,conv ,name ,e (,arg-type* ...) ,result-type) (memoize (ivory? e))] + [(foreign (,conv ...) ,name ,e (,arg-type* ...) ,result-type) (memoize (ivory? e))] [(letrec* ([,x* ,e*] ...) ,body) (memoize (and (andmap ivory? e*) (ivory? body)))] [(immutable-list (,e* ...) ,e) (memoize (and (andmap ivory? e*) (ivory? e)))] [(profile ,src) #t] [(cte-optimization-loc ,box ,e) (memoize (ivory? e))] [(moi) #t] - [(fcallable ,conv ,e (,arg-type* ...) ,result-type) (memoize (ivory? e))] + [(fcallable (,conv ...) ,e (,arg-type* ...) ,result-type) (memoize (ivory? e))] [(pariah) #t] [else ($oops who "unrecognized record ~s" e)])))) @@ -1052,14 +1052,14 @@ [(record-cd ,rcd ,rtd-expr ,e) (memoize (simple? e))] [(record-ref ,rtd ,type ,index ,e) (memoize (simple? e))] [(record-set! ,rtd ,type ,index ,e1 ,e2) #f] - [(foreign ,conv ,name ,e (,arg-type* ...) ,result-type) (memoize (simple? e))] + [(foreign (,conv ...) ,name ,e (,arg-type* ...) ,result-type) (memoize (simple? e))] [(record-type ,rtd ,e) (memoize (simple? e))] [(record ,rtd ,rtd-expr ,e* ...) (memoize (and (simple? rtd-expr) (andmap simple? e*)))] [(pariah) #f] [(profile ,src) #f] [(cte-optimization-loc ,box ,e) (memoize (simple? e))] [(moi) #t] - [(fcallable ,conv ,e (,arg-type* ...) ,result-type) (memoize (simple? e))] + [(fcallable (,conv ...) ,e (,arg-type* ...) ,result-type) (memoize (simple? e))] [else ($oops who "unrecognized record ~s" e)])))) (define-who simple/profile? @@ -1097,14 +1097,14 @@ [(record-cd ,rcd ,rtd-expr ,e) (memoize (simple/profile? e))] [(record-ref ,rtd ,type ,index ,e) (memoize (simple/profile? e))] [(record-set! ,rtd ,type ,index ,e1 ,e2) #f] - [(foreign ,conv ,name ,e (,arg-type* ...) ,result-type) (memoize (simple/profile? e))] + [(foreign (,conv ...) ,name ,e (,arg-type* ...) ,result-type) (memoize (simple/profile? e))] [(record-type ,rtd ,e) (memoize (simple/profile? e))] [(record ,rtd ,rtd-expr ,e* ...) (memoize (and (simple/profile? rtd-expr) (andmap simple/profile? e*)))] [(pariah) #t] [(profile ,src) #t] [(cte-optimization-loc ,box ,e) (memoize (simple/profile? e))] [(moi) #t] - [(fcallable ,conv ,e (,arg-type* ...) ,result-type) (memoize (simple/profile? e))] + [(fcallable (,conv ...) ,e (,arg-type* ...) ,result-type) (memoize (simple/profile? e))] [else ($oops who "unrecognized record ~s" e)])))) (define-who boolean-valued? @@ -1137,8 +1137,8 @@ [(profile ,src) #f] [(set! ,maybe-src ,x ,e) #f] [(moi) #f] - [(foreign ,conv ,name ,e (,arg-type* ...) ,result-type) #f] - [(fcallable ,conv ,e (,arg-type* ...) ,result-type) #f] + [(foreign (,conv ...) ,name ,e (,arg-type* ...) ,result-type) #f] + [(fcallable (,conv ...) ,e (,arg-type* ...) ,result-type) #f] [(pariah) #f] [else ($oops who "unrecognized record ~s" e)]))))) @@ -2058,8 +2058,8 @@ [(set! ,maybe-src ,x0 ,e0) (list e)] [(case-lambda ,preinfo ,cl* ...) (list e)] [,pr (list e)] - [(foreign ,conv ,name ,e0 (,arg-type* ...) ,result-type) (list e)] - [(fcallable ,conv ,e0 (,arg-type* ...) ,result-type) (list e)] + [(foreign (,conv ...) ,name ,e0 (,arg-type* ...) ,result-type) (list e)] + [(fcallable (,conv ...) ,e0 (,arg-type* ...) ,result-type) (list e)] [(record-type ,rtd0 ,e0) (list e)] [(record-cd ,rcd0 ,rtd-expr0 ,e0) (list e)] [(immutable-list (,e0* ...) ,e0) (list e)] @@ -3363,8 +3363,8 @@ (nanopass-case (Lsrc Expr) xres [(case-lambda ,preinfo ,cl ...) #t] [,pr (all-set? (prim-mask proc) (primref-flags pr))] - [(foreign ,conv ,name ,e (,arg-type* ...) ,result-type) #t] - [(fcallable ,conv ,e (,arg-type* ...) ,result-type) #t] + [(foreign (,conv ...) ,name ,e (,arg-type* ...) ,result-type) #t] + [(fcallable (,conv ...) ,e (,arg-type* ...) ,result-type) #t] [(record-set! ,rtd ,type ,index ,e1 ,e2) #t] [(immutable-list (,e* ...) ,e) #t] [else #f]))) @@ -4609,13 +4609,13 @@ true-rec (begin (bump sc 1) pr))] [(app) (fold-primref pr ctxt sc wd name moi)])] - [(foreign ,conv ,name ,e (,arg-type* ...) ,result-type) + [(foreign (,conv ...) ,name ,e (,arg-type* ...) ,result-type) (context-case ctxt - [(value app) (bump sc 1) `(foreign ,conv ,name ,(cp0 e 'value env sc wd #f moi) (,arg-type* ...) ,result-type)] + [(value app) (bump sc 1) `(foreign (,conv ...) ,name ,(cp0 e 'value env sc wd #f moi) (,arg-type* ...) ,result-type)] [(effect test) (cp0 `(seq ,e ,true-rec) ctxt env sc wd #f moi)])] - [(fcallable ,conv ,e (,arg-type* ...) ,result-type) + [(fcallable (,conv ...) ,e (,arg-type* ...) ,result-type) (context-case ctxt - [(value app) (bump sc 1) `(fcallable ,conv ,(cp0 e 'value env sc wd #f moi) (,arg-type* ...) ,result-type)] + [(value app) (bump sc 1) `(fcallable (,conv ...) ,(cp0 e 'value env sc wd #f moi) (,arg-type* ...) ,result-type)] [(effect) (cp0 e 'effect env sc wd #f moi)] [(test) (make-seq ctxt (cp0 e 'effect env sc wd #f moi) true-rec)])] [(record ,rtd ,rtd-expr ,e* ...) diff --git a/s/cpcheck.ss b/s/cpcheck.ss index 9bb2cbfeed..18b4f3e440 100644 --- a/s/cpcheck.ss +++ b/s/cpcheck.ss @@ -130,11 +130,11 @@ [(set! ,maybe-src ,x ,[e #f -> e]) `(set! ,maybe-src ,x ,e)] [(seq ,[e1 #f -> e1] ,[e2]) `(seq ,e1 ,e2)] [(if ,[e1 #f -> e1] ,[e2 #f -> e2] ,[e3 #f -> e3]) `(if ,e1 ,e2 ,e3)] - [(foreign ,conv ,name ,e (,arg-type* ...) ,result-type) + [(foreign (,conv ...) ,name ,e (,arg-type* ...) ,result-type) (check! ctxt (list (length arg-type*))) - `(foreign ,conv ,name ,(Expr e #f) (,arg-type* ...) ,result-type)] - [(fcallable ,conv ,[e #f -> e] (,arg-type* ...) ,result-type) - `(fcallable ,conv ,e (,arg-type* ...) ,result-type)] + `(foreign (,conv ...) ,name ,(Expr e #f) (,arg-type* ...) ,result-type)] + [(fcallable (,conv ...) ,[e #f -> e] (,arg-type* ...) ,result-type) + `(fcallable (,conv ...) ,e (,arg-type* ...) ,result-type)] [(call ,preinfo0 (case-lambda ,preinfo1 (clause (,x* ...) ,interface ,body) diff --git a/s/cpcommonize.ss b/s/cpcommonize.ss index d08cc205b8..a1fdc6a990 100644 --- a/s/cpcommonize.ss +++ b/s/cpcommonize.ss @@ -73,10 +73,10 @@ (values `(seq ,e1 ,e2) (fx+ size1 size2))] [(if ,[e1 size1] ,[e2 size2] ,[e3 size3]) (values `(if ,e1 ,e2 ,e3) (fx+ size1 size2 size3))] - [(foreign ,conv ,name ,[e size] (,arg-type* ...) ,result-type) - (values `(foreign ,conv ,name ,e (,arg-type* ...) ,result-type) (fx+ 1 size))] - [(fcallable ,conv ,[e size] (,arg-type* ...) ,result-type) - (values `(fcallable ,conv ,e (,arg-type* ...) ,result-type) (fx+ 1 size))] + [(foreign (,conv ...) ,name ,[e size] (,arg-type* ...) ,result-type) + (values `(foreign (,conv ...) ,name ,e (,arg-type* ...) ,result-type) (fx+ 1 size))] + [(fcallable (,conv ...) ,[e size] (,arg-type* ...) ,result-type) + (values `(fcallable (,conv ...) ,e (,arg-type* ...) ,result-type) (fx+ 1 size))] ; ($top-level-value 'x) adds just 1 to the size [(call ,preinfo ,pr (quote ,d)) (guard (eq? (primref-name pr) '$top-level-value)) @@ -379,24 +379,24 @@ (with-env x1* x2* `(letrec ([,x1* ,(map f e1* e2*) ,size1*] ...) ,(f body1 body2))))] [else #f])] - [(foreign ,conv1 ,name1 ,e1 (,arg-type1* ...) ,result-type1) + [(foreign (,conv1 ...) ,name1 ,e1 (,arg-type1* ...) ,result-type1) (nanopass-case (Lcommonize1 Expr) e2 - [(foreign ,conv2 ,name2 ,e2 (,arg-type2* ...) ,result-type2) - (and (eq? conv1 conv2) + [(foreign (,conv2 ...) ,name2 ,e2 (,arg-type2* ...) ,result-type2) + (and (equal? conv1 conv2) (equal? name1 name2) (fx= (length arg-type1*) (length arg-type2*)) (andmap same-type? arg-type1* arg-type2*) (same-type? result-type1 result-type2) - `(foreign ,conv1 ,name1 ,(f e1 e2) (,arg-type1* ...) ,result-type1))] + `(foreign (,conv1 ...) ,name1 ,(f e1 e2) (,arg-type1* ...) ,result-type1))] [else #f])] - [(fcallable ,conv1 ,e1 (,arg-type1* ...) ,result-type1) + [(fcallable (,conv1 ...) ,e1 (,arg-type1* ...) ,result-type1) (nanopass-case (Lcommonize1 Expr) e2 - [(fcallable ,conv2 ,e2 (,arg-type2* ...) ,result-type2) - (and (eq? conv1 conv2) + [(fcallable (,conv2 ...) ,e2 (,arg-type2* ...) ,result-type2) + (and (equal? conv1 conv2) (fx= (length arg-type1*) (length arg-type2*)) (andmap same-type? arg-type1* arg-type2*) (same-type? result-type1 result-type2) - `(fcallable ,conv1 ,(f e1 e2) (,arg-type1* ...) ,result-type1))] + `(fcallable (,conv1 ...) ,(f e1 e2) (,arg-type1* ...) ,result-type1))] [else #f])] [(cte-optimization-loc ,box1 ,e1) (nanopass-case (Lcommonize1 Expr) e2 diff --git a/s/cpletrec.ss b/s/cpletrec.ss index 37f7f52d5c..1c6ff967e0 100644 --- a/s/cpletrec.ss +++ b/s/cpletrec.ss @@ -348,11 +348,11 @@ Handling letrec and letrec* (with-initialized-ids x* (lambda (x*) (cpletrec-letrec #t x* e* body)))] - [(foreign ,conv ,name ,[e pure?] (,arg-type* ...) ,result-type) - (values `(foreign ,conv ,name ,e (,arg-type* ...) ,result-type) + [(foreign (,conv ...) ,name ,[e pure?] (,arg-type* ...) ,result-type) + (values `(foreign (,conv ...) ,name ,e (,arg-type* ...) ,result-type) (and (fx= (optimize-level) 3) pure?))] - [(fcallable ,conv ,[e pure?] (,arg-type* ...) ,result-type) - (values `(fcallable ,conv ,e (,arg-type* ...) ,result-type) + [(fcallable (,conv ...) ,[e pure?] (,arg-type* ...) ,result-type) + (values `(fcallable (,conv ...) ,e (,arg-type* ...) ,result-type) (and (fx= (optimize-level) 3) pure?))] [(record-ref ,rtd ,type ,index ,[e pure?]) (values `(record-ref ,rtd ,type ,index ,e) #f)] diff --git a/s/cpnanopass.ss b/s/cpnanopass.ss index 2ae10538e4..a1ce75dd55 100644 --- a/s/cpnanopass.ss +++ b/s/cpnanopass.ss @@ -1045,11 +1045,11 @@ [(call ,preinfo ,e ,[e*] ...) `(call ,(make-info-call (preinfo-src preinfo) (preinfo-sexpr preinfo) (fx< (optimize-level) 3) #f #f) ,(Expr e) ,e* ...)] - [(foreign ,conv ,name ,[e] (,arg-type* ...) ,result-type) + [(foreign (,conv ...) ,name ,[e] (,arg-type* ...) ,result-type) (let ([info (make-info-foreign conv arg-type* result-type)]) (info-foreign-name-set! info name) `(foreign ,info ,e))] - [(fcallable ,conv ,[e] (,arg-type* ...) ,result-type) + [(fcallable (,conv ...) ,[e] (,arg-type* ...) ,result-type) `(fcallable ,(make-info-foreign conv arg-type* result-type) ,e)]) (CaseLambdaExpr ir #f)) diff --git a/s/cprep.ss b/s/cprep.ss index c230caaa6f..a855069ad6 100644 --- a/s/cprep.ss +++ b/s/cprep.ss @@ -187,11 +187,11 @@ [(letrec* ([,x* ,[e*]] ...) ,body) `(letrec* ,(map (lambda (x e) `(,(get-name x) ,e)) x* e*) ,@(uncprep-sequence body '()))] - [(foreign ,conv ,name ,[e] (,arg-type* ...) ,result-type) + [(foreign (,conv ...) ,name ,[e] (,arg-type* ...) ,result-type) `($foreign-procedure ,(uncprep-fp-conv conv) ,name ,e ,(map uncprep-fp-specifier arg-type*) ,(uncprep-fp-specifier result-type))] - [(fcallable ,conv ,[e] (,arg-type* ...) ,result-type) + [(fcallable (,conv ...) ,[e] (,arg-type* ...) ,result-type) `($foreign-callable ,(uncprep-fp-conv conv) ,e ,(map uncprep-fp-specifier arg-type*) ,(uncprep-fp-specifier result-type))] diff --git a/s/cpvalid.ss b/s/cpvalid.ss index 7bec60404c..d99d8f54c5 100644 --- a/s/cpvalid.ss +++ b/s/cpvalid.ss @@ -328,10 +328,10 @@ (let-values ([(e* vals-dl?) (undefer* e* proxy dl?)]) (defer-or-not (or body-dl? vals-dl?) `(letrec* ([,x* ,e*] ...) ,body)))] - [(foreign ,conv ,name ,[undefer : e dl?] (,arg-type* ...) ,result-type) - (defer-or-not dl? `(foreign ,conv ,name ,e (,arg-type* ...) ,result-type))] - [(fcallable ,conv ,[undefer : e dl?] (,arg-type* ...) ,result-type) - (defer-or-not dl? `(fcallable ,conv ,e (,arg-type* ...) ,result-type))] + [(foreign (,conv ...) ,name ,[undefer : e dl?] (,arg-type* ...) ,result-type) + (defer-or-not dl? `(foreign (,conv ...) ,name ,e (,arg-type* ...) ,result-type))] + [(fcallable (,conv ...) ,[undefer : e dl?] (,arg-type* ...) ,result-type) + (defer-or-not dl? `(fcallable (,conv ...) ,e (,arg-type* ...) ,result-type))] [(cte-optimization-loc ,box ,[undefer : e dl?]) (defer-or-not dl? `(cte-optimization-loc ,box ,e))] [(pariah) (values x #f)] @@ -547,10 +547,10 @@ (defer-or-not (or dl0? dl1? dl2?) `(if ,e0 ,e1 ,e2))] [(seq ,[cpvalid : e1 dl1?] ,[cpvalid : e2 dl2?]) (defer-or-not (or dl1? dl2?) `(seq ,e1 ,e2))] - [(foreign ,conv ,name ,[cpvalid : e dl?] (,arg-type* ...) ,result-type) - (defer-or-not dl? `(foreign ,conv ,name ,e (,arg-type* ...) ,result-type))] - [(fcallable ,conv ,[cpvalid : e dl?] (,arg-type* ...) ,result-type) - (defer-or-not dl? `(fcallable ,conv ,e (,arg-type* ...) ,result-type))] + [(foreign (,conv ...) ,name ,[cpvalid : e dl?] (,arg-type* ...) ,result-type) + (defer-or-not dl? `(foreign (,conv ...) ,name ,e (,arg-type* ...) ,result-type))] + [(fcallable (,conv ...) ,[cpvalid : e dl?] (,arg-type* ...) ,result-type) + (defer-or-not dl? `(fcallable (,conv ...) ,e (,arg-type* ...) ,result-type))] [(cte-optimization-loc ,box ,[cpvalid : e dl?]) (defer-or-not dl? `(cte-optimization-loc ,box ,e))] [(pariah) (values x #f)] diff --git a/s/interpret.ss b/s/interpret.ss index ec382314d3..d258d8c237 100644 --- a/s/interpret.ss +++ b/s/interpret.ss @@ -459,7 +459,7 @@ [(seq ,e1 ,e2) (let ((e1 (ip2 e1)) (e2 (ip2 e2))) ($rt lambda () ($rt e1) ($rt e2)))] - [(foreign ,conv ,name ,e (,arg-type* ...) ,result-type) + [(foreign (,conv ...) ,name ,e (,arg-type* ...) ,result-type) (unless $compiler-is-loaded? ($oops 'interpret "cannot compile foreign-procedure: compiler is not loaded")) (let ([p ($compile-backend @@ -468,11 +468,11 @@ (with-output-language (Lsrc Expr) `(case-lambda ,(make-preinfo-lambda) (clause (,t) 1 - (foreign ,conv ,name (ref #f ,t) + (foreign (,conv ...) ,name (ref #f ,t) (,arg-type* ...) ,result-type))))))]) (let ([e (ip2 e)]) ($rt lambda () ((p) ($rt e)))))] - [(fcallable ,conv ,e (,arg-type* ...) ,result-type) + [(fcallable (,conv ...) ,e (,arg-type* ...) ,result-type) (unless $compiler-is-loaded? ($oops 'interpret "cannot compile foreign-callable: compiler is not loaded")) (let ([p ($compile-backend @@ -481,7 +481,7 @@ (with-output-language (Lsrc Expr) `(case-lambda ,(make-preinfo-lambda) (clause (,t) 1 - (fcallable ,conv (ref #f ,t) (,arg-type* ...) ,result-type))))))]) + (fcallable (,conv ...) (ref #f ,t) (,arg-type* ...) ,result-type))))))]) (let ([e (ip2 e)]) ($rt lambda () ((p) ($rt e)))))] [else (unexpected-record x)]))) diff --git a/s/np-languages.ss b/s/np-languages.ss index 10e4dc94e9..d1ba761924 100644 --- a/s/np-languages.ss +++ b/s/np-languages.ss @@ -78,10 +78,6 @@ (import (nanopass)) (include "base-lang.ss") - ; convention is a list of symbols (we're assuming the front end already verified - ; the convention is a valid one for this machine-type) - (define convention? (lambda (x) (and (list? x) (andmap symbol? x)))) - ; r6rs says a quote subform should be a datum, not must be a datum ; chez scheme allows a quote subform to be any value (define datum? (lambda (x) #t)) diff --git a/s/syntax.ss b/s/syntax.ss index 4edf85f59a..d1755b29a8 100644 --- a/s/syntax.ss +++ b/s/syntax.ss @@ -689,14 +689,14 @@ (define build-foreign-procedure (lambda (ae conv foreign-name foreign-addr params result) (build-profile ae - `(foreign ,conv ,foreign-name ,foreign-addr + `(foreign (,conv ...) ,foreign-name ,foreign-addr (,(map (lambda (x) (build-fp-specifier 'foreign-procedure 'parameter x #f)) params) ...) ,(build-fp-specifier 'foreign-procedure "result" result #t))))) (define build-foreign-callable (lambda (ae conv proc params result) (build-profile ae - `(fcallable ,conv ,proc + `(fcallable (,conv ...) ,proc (,(map (lambda (x) (build-fp-specifier 'foreign-callable 'parameter x #f)) params) ...) ,(build-fp-specifier 'foreign-callable "result" result #t))))))