suzanne.soy/compatibility
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

.

Browse Source 
original commit: 5d5f0cbc15c4f5125cf82391eff076a2e1ca4a4f
This commit is contained in:
Eli Barzilay 2004-06-11 16:27:02 +00:00
parent a6fbe74920
commit 6002419fdc
1 changed files with 128 additions and 81 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

185
collects/mzlib/foreign.ss
View File

@ -130,7 +130,7 @@
[(eq? key (car args)) (loop (cdr args) (cons '() r))] [(eq? key (car args)) (loop (cdr args) (cons '() r))]
[else (set-car! r (cons (car args) (car r))) [else (set-car! r (cons (car args) (car r)))
(loop (cdr args) r)]))) (loop (cdr args) r)])))
(define (filtered-map f l) (define (filtmap f l)
(let loop ([l l] [r '()]) (let loop ([l l] [r '()])
(if (null? l) (if (null? l)
(reverse! r) (reverse! r)
@ -141,11 +141,13 @@
(let ([xs (map (lambda (x) (let ([xs (map (lambda (x)
(syntax-case* x (-> ::) id=? [:: '::] [-> '->] [_ x])) (syntax-case* x (-> ::) id=? [:: '::] [-> '->] [_ x]))
(syntax->list #'(x ...)))] (syntax->list #'(x ...)))]
[inputs #f] [output #f] [pre '()] [post '()] [inputs #f] [output #f] [bind '()] [pre '()] [post '()]
[input-names #f] [output-type #f] [output-expr #f]) [input-names #f] [output-type #f] [output-expr #f]
[1st-arg #f] [prev-arg #f])
(define (bind! x) (set! bind (append! bind (list x))))
(define (pre! x) (set! pre (append! pre (list x)))) (define (pre! x) (set! pre (append! pre (list x))))
(define (post! x) (set! post (append! post (list x)))) (define (post! x) (set! post (append! post (list x))))
(define (custom-type type0) (define (custom-type-keys type0)
(define stops (define stops
(map (lambda (s) (datum->syntax-object type0 s #f)) (map (lambda (s) (datum->syntax-object type0 s #f))
'(#%app #%top #%datum))) '(#%app #%top #%datum)))
@ -153,26 +155,38 @@
(syntax-case* x (=>) id=? (syntax-case* x (=>) id=?
[(id => body) (identifier? #'id) (list #'id #'body)] [(id => body) (identifier? #'id) (list #'id #'body)]
[_else x])) [_else x]))
(let loop ([t (local-expand type0 'expression stops)] (let ([keys '()])
[empty? #t] [type #f] [pre #f] [post #f]) (define (setkey! key val . id?)
(syntax-case* t (type: pre: post:) id=? (cond
[(assq key keys)
(err "bad expansion of custom type (two `~a:'s)" key type0)]
[(and (pair? id?) (car id?) (not (identifier? val)))
(err (string-append "bad expansion of custom type "
"(`~a:' expects an identifier)")
key type0)]
[else (set! keys (cons (cons key val) keys))]))
(let loop ([t (local-expand type0 'expression stops)])
(define (next rest . args) (apply setkey! args) (loop rest))
(syntax-case* t (type: bind: pre: post: 1st-arg: prev-arg:) id=?
[(type: t x ...) [(type: t x ...)
(if type (next #'(x ...) 'type (syntax-case #'t () [#f #f] [_ #'t]))]
(err "bad expansion of custom type (two type:s)" type0) [(bind: id x ...) (next #'(x ...) 'bind #'id #t)]
(loop #'(x ...) #f [(pre: p x ...) (next #'(x ...) 'pre (with-arg #'p))]
(syntax-case #'t () [#f #f] [_ #'t]) pre post))] [(post: p x ...) (next #'(x ...) 'post (with-arg #'p))]
[(pre: p x ...) [(1st-arg: id x ...) (next #'(x ...) '1st #'id #t)]
(if pre [(prev-arg: id x ...) (next #'(x ...) 'prev #'id #t)]
(err "bad expansion of custom type (two pre:s)" type0) [() (and (pair? keys) keys)]
(loop #'(x ...) #f type (with-arg #'p) post))] [_else #f]))))
[(post: p x ...)
(if post
(err "bad expansion of custom type (two post:s)" type0)
(loop #'(x ...) #f type pre (with-arg #'p)))]
[() (and (not empty?) (list type pre post))]
[_else #f])))
(define (t-n-e clause type name expr) (define (t-n-e clause type name expr)
(let ([s (custom-type type)]) (let ([keys (custom-type-keys type)])
(define (getkey key)
(cond [(assq key keys) => cdr] [else #f]))
(define (add-renamer body from to)
(with-syntax ([body body] [from from] [to to])
#'(let-syntax ([to (syntax-id-rules ()
[(_?_ . _rest_) (from . _rest_)]
[_?_ from])])
body)))
(define (arg x . no-expr?) (define (arg x . no-expr?)
(define use-expr? (define use-expr?
(and (list? x) (= 2 (length x)) (identifier? (car x)))) (and (list? x) (= 2 (length x)) (identifier? (car x))))
@ -184,15 +198,33 @@
(err "got an expression for a custom type that do not use it" (err "got an expression for a custom type that do not use it"
clause) clause)
(set! expr (void)))) (set! expr (void))))
(if use-expr? (set! x (if use-expr? (add-renamer (cadr x) name (car x)) x))
#`(let ([#,(car x) #,name]) #,(cadr x)) (cond [(getkey '1st) =>
x)) (lambda (v)
(when s (if 1st-arg
(set! type (car s)) (set! x (add-renamer x 1st-arg v))
(when (cadr s) (pre! #`[#,name #,(arg (cadr s) #t)])) (err "got a custom type that wants 1st arg too early"
(when (caddr s) (post! #`[#,name #,(arg (caddr s))]))) clause)))])
(cond [(getkey 'prev) =>
(lambda (v)
(if prev-arg
(set! x (add-renamer x prev-arg v))
(err "got a custom type that wants prev arg too early"
clause)))])
x)
(when keys
(set! type (getkey 'type))
(cond [(getkey 'bind) =>
(lambda (x) (bind! #`[#,x #,name]))])
(cond [(getkey 'pre) =>
(lambda (x) (pre! #`[#,name #,(arg x #t)]))])
(cond [(getkey 'post) =>
(lambda (x) (post! #`[#,name #,(arg x)]))]))
(unless (or type expr) (unless (or type expr)
(err "got ignored input, with no expression" clause)) (err "got ignored input with no expression" clause))
(when type ; remember these for later usages
(unless 1st-arg (set! 1st-arg name))
(set! prev-arg name))
(list type name expr))) (list type name expr)))
(let ([dd (split-by ':: xs)]) (let ([dd (split-by ':: xs)])
(case (length dd) (case (length dd)
@ -254,43 +286,41 @@
[type (t-n-e output-type #'type temp output-expr)]))) [type (t-n-e output-type #'type temp output-expr)])))
(if (or (caddr output) input-names (ormap caddr inputs) (if (or (caddr output) input-names (ormap caddr inputs)
(ormap (lambda (x) (not (car x))) inputs) (ormap (lambda (x) (not (car x))) inputs)
(pair? pre) (pair? post)) (pair? bind) (pair? pre) (pair? post))
(let ([input-names (or input-names (let* ([input-names (or input-names
(filtered-map (lambda (i) (filtmap (lambda (i)
(and (not (caddr i)) (cadr i))) (and (not (caddr i)) (cadr i)))
inputs))] inputs))]
[output-expr (let ([o (caddr output)]) [output-expr (let ([o (caddr output)])
(or (and (not (void? o)) o) (or (and (not (void? o)) o)
(cadr output)))] (cadr output)))]
[args (filtmap (lambda (i) (and (caddr i)
(not (void? (caddr i)))
#`[#,(cadr i) #,(caddr i)]))
inputs)]
[ffi-args (filtmap (lambda (x) (and (car x) (cadr x)))
inputs)]
;; the actual wrapper body
[body (quasisyntax/loc stx
(lambda #,input-names
(let* (#,@args
#,@bind
#,@pre
[#,(cadr output) (ffi #,@ffi-args)]
#,@post)
#,output-expr)))]
;; if there is a string 'ffi-name property, use it as a name ;; if there is a string 'ffi-name property, use it as a name
[name (let ([n (cond [(syntax-property stx 'ffi-name) [body (let ([n (cond [(syntax-property stx 'ffi-name)
=> syntax-object->datum] => syntax-object->datum]
[else #f])]) [else #f])])
(if (string? n) (if (string? n)
(lambda (x)
(syntax-property (syntax-property
x 'inferred-name body 'inferred-name
(string->symbol (string-append "ffi-wrapper:" n)))) (string->symbol (string-append "ffi-wrapper:" n)))
(lambda (x) x)))]) body))])
#`(ffi-fun (list #,@(filtered-map car inputs)) #,(car output) #`(ffi-fun (list #,@(filtmap car inputs)) #,(car output)
(lambda (ffi) (lambda (ffi) #,body)))
#,(name (quasisyntax/loc stx #`(ffi-fun (list #,@(filtmap car inputs)) #,(car output))))]))
(lambda #,input-names
(let* (#,@(filtered-map
(lambda (i)
(and (caddr i)
(not (void? (caddr i)))
#`[#,(cadr i) #,(caddr i)]))
inputs)
#,@pre
[#,(cadr output)
(ffi #,@(filtered-map
(lambda (x)
(and (car x) (cadr x)))
inputs))]
#,@post)
#,output-expr)))))))
#`(ffi-fun (list #,@(filtered-map car inputs)) #,(car output))))]))
;; ---------------------------------------------------------------------------- ;; ----------------------------------------------------------------------------
;; String types ;; String types
@ -425,15 +455,23 @@
;; Custom function type macros ;; Custom function type macros
;; These macros get expanded by the _fun type. They can expand to a form that ;; These macros get expanded by the _fun type. They can expand to a form that
;; looks like (keyword: value ...), where the keyword is `type:' for the type ;; looks like (keyword: value ...), where the keyword is one of:
;; that will be used, pre: for a binding that will be inserted before the ffi ;; * `type:' for the type that will be used,
;; call, and post: for a binding after the ffi call. These two bindings can be ;; * `bind:' for an additional binding that holds the initial value,
;; of the form (id => expr) to use the existing value. Note that if the pre: ;; * `1st-arg:' is used to name an identifier that will be bound to the value
;; expression is not (id => expr), then it means that there is no input for ;; of the 1st foreign argument in pre/post chunks (good for
;; this argument. Also note that if a custom type is used as an output type of ;; common cases where the first argument has a special meaning,
;; a function, then only the post: code is used. The resulting wrapper looks ;; eg, for method calls),
;; like: ;; * `prev-arg:' similar to 1st-arg: but for the previous argument,
;; * `pre:' for a binding that will be inserted before the ffi call,
;; * `post:' for a binding after the ffi call.
;; The pre: and post: bindings can be of the form (id => expr) to use the
;; existing value. Note that if the pre: expression is not (id => expr), then
;; it means that there is no input for this argument. Also note that if a
;; custom type is used as an output type of a function, then only the post:
;; code is used. The resulting wrapper looks like:
;; (let* (...bindings for arguments... ;; (let* (...bindings for arguments...
;; ...bindings for bind: identifiers...
;; ...bindings for pre-code... ;; ...bindings for pre-code...
;; (ret-name ffi-call) ;; (ret-name ffi-call)
;; ...bindings for post-code...) ;; ...bindings for post-code...)
@ -454,16 +492,25 @@
(define-syntax _ptr (define-syntax _ptr
(syntax-rules (i o io) (syntax-rules (i o io)
[(_ i t) (type: _pointer [(_ i t) (type: _pointer
pre: (x => (let ([p (malloc t)]) pre: (x => (let ([p (malloc t)]) (ptr-set! p t x) p)))]
(ptr-set! p t x) p)))]
[(_ o t) (type: _pointer [(_ o t) (type: _pointer
pre: (malloc t) pre: (malloc t)
post: (x => (ptr-ref x t)))] post: (x => (ptr-ref x t)))]
[(_ io t) (type: _pointer [(_ io t) (type: _pointer
pre: (x => (let ([p (malloc t)]) pre: (x => (let ([p (malloc t)]) (ptr-set! p t x) p))
(ptr-set! p t x) p))
post: (x => (ptr-ref x t)))])) post: (x => (ptr-ref x t)))]))
;; (_box <type>)
;; This is similar to a (_ptr io <type>) argument, where the input is expected
;; to be a box, which is unboxed on entry and modified on exit.
(provide _box)
(define-syntax _box
(syntax-rules (i o io)
[(_ t) (type: _pointer
bind: tmp ; need to save the box so we can get back to it
pre: (x => (let ([p (malloc t)]) (ptr-set! p t (unbox x)) p))
post: (x => (begin (box-set! tmp (ptr-ref x t)) tmp)))]))
;; (_list <mode> <type> [<len>]) ;; (_list <mode> <type> [<len>])
;; Similar to _ptr, except that it is used for converting lists to/from C ;; Similar to _ptr, except that it is used for converting lists to/from C
;; vectors. The length is needed for output values where it is used in the ;; vectors. The length is needed for output values where it is used in the