added #:abi keyword spec to _fun
svn: r11542
This commit is contained in:
Eli Barzilay
parent
e67b138830
commit
ade8dfad31
|
|
@ -1,10 +1,8 @@
|
|||
#lang scheme/base
|
||||
|
||||
;; Foreign Scheme interface
|
||||
(require '#%foreign
|
||||
setup/dirs
|
||||
(for-syntax scheme/base
|
||||
syntax/stx))
|
||||
(require '#%foreign setup/dirs
|
||||
(for-syntax scheme/base scheme/list syntax/stx))
|
||||
|
||||
;; This module is full of unsafe bindings that are not provided to requiring
|
||||
;; modules. Instead, an `unsafe!' binding is provided that makes these unsafe
|
||||
|
|
@ -356,15 +354,8 @@
|
|||
(let loop ([args args] [r (list '())])
|
||||
(cond [(null? args) (reverse (map reverse r))]
|
||||
[(eq? key (car args)) (loop (cdr args) (cons '() r))]
|
||||
[else (loop (cdr args)
|
||||
(cons (cons (car args) (car r))
|
||||
(cdr r)))])))
|
||||
|
||||
(define (filtmap f l)
|
||||
(let loop ([l l] [r '()])
|
||||
(if (null? l)
|
||||
(reverse r)
|
||||
(let ([x (f (car l))]) (loop (cdr l) (if x (cons x r) r))))))
|
||||
[else (loop (cdr args)
|
||||
(cons (cons (car args) (car r)) (cdr r)))])))
|
||||
|
||||
(define (add-renamer body from to)
|
||||
(with-syntax ([body body] [from from] [to to])
|
||||
|
|
@ -476,15 +467,14 @@
|
|||
;; Creates a simple function type that can be used for callouts and callbacks,
|
||||
;; optionally applying a wrapper function to modify the result primitive
|
||||
;; (callouts) or the input procedure (callbacks).
|
||||
(define* (_cprocedure itypes otype . wrapper)
|
||||
(let ([wrapper (and (pair? wrapper) (car wrapper))])
|
||||
(if wrapper
|
||||
(make-ctype _fpointer
|
||||
(lambda (x) (ffi-callback (wrapper x) itypes otype))
|
||||
(lambda (x) (wrapper (ffi-call x itypes otype))))
|
||||
(make-ctype _fpointer
|
||||
(lambda (x) (ffi-callback x itypes otype))
|
||||
(lambda (x) (ffi-call x itypes otype))))))
|
||||
(define* (_cprocedure itypes otype [abi #f] [wrapper #f])
|
||||
(if wrapper
|
||||
(make-ctype _fpointer
|
||||
(lambda (x) (ffi-callback (wrapper x) itypes otype abi))
|
||||
(lambda (x) (wrapper (ffi-call x itypes otype abi))))
|
||||
(make-ctype _fpointer
|
||||
(lambda (x) (ffi-callback x itypes otype abi))
|
||||
(lambda (x) (ffi-call x itypes otype abi)))))
|
||||
|
||||
;; Syntax for the special _fun type:
|
||||
;; (_fun [{(name ... [. name]) | name} [-> expr] ::]
|
||||
|
|
@ -508,149 +498,168 @@
|
|||
(provide _fun)
|
||||
(define-syntax (_fun stx)
|
||||
(define (err msg . sub) (apply raise-syntax-error '_fun msg stx sub))
|
||||
(syntax-case stx ()
|
||||
[(_ x ...)
|
||||
(let ([xs (map (lambda (x)
|
||||
(syntax-case* x (-> ::) id=? [:: '::] [-> '->] [_ x]))
|
||||
(syntax->list #'(x ...)))]
|
||||
[inputs #f] [output #f] [bind '()] [pre '()] [post '()]
|
||||
[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 (post! x) (set! post (append post (list x))))
|
||||
(define ((t-n-e clause) type name expr)
|
||||
(let ([keys (custom-type->keys type err)])
|
||||
(define (getkey key) (cond [(assq key keys) => cdr] [else #f]))
|
||||
(define (arg x . no-expr?)
|
||||
(define use-expr?
|
||||
(and (list? x) (= 2 (length x)) (identifier? (car x))))
|
||||
;; when the current expr is not used with a (x => ...) form,
|
||||
;; either check that no expression is given or just make it
|
||||
;; disappear from the inputs.
|
||||
(unless use-expr?
|
||||
(if (and (pair? no-expr?) (car no-expr?) expr)
|
||||
(err "got an expression for a custom type that do not use it"
|
||||
clause)
|
||||
(set! expr (void))))
|
||||
(set! x (if use-expr? (add-renamer (cadr x) name (car x)) x))
|
||||
(cond [(getkey '1st) =>
|
||||
(lambda (v)
|
||||
(if 1st-arg
|
||||
(set! x (add-renamer x 1st-arg v))
|
||||
(err "got a custom type that wants 1st arg too early"
|
||||
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 [(and (not expr) (getkey 'expr)) =>
|
||||
(lambda (x) (set! expr x))])
|
||||
(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)]))]))
|
||||
;; turn a #f syntax to #f
|
||||
(set! type (and type (syntax-case type () [#f #f] [_ type])))
|
||||
(when type ; remember these for later usages
|
||||
(unless 1st-arg (set! 1st-arg name))
|
||||
(set! prev-arg name))
|
||||
(list type name expr)))
|
||||
;; parse "::"
|
||||
(let ([s (split-by ':: xs)])
|
||||
(case (length s)
|
||||
[(0) (err "something bad happened (::)")]
|
||||
[(1) #f]
|
||||
[(2) (if (and (= 1 (length (car s))) (not (eq? '-> (caar s))))
|
||||
(begin (set! xs (cadr s)) (set! input-names (caar s)))
|
||||
(err "bad wrapper formals"))]
|
||||
[else (err "saw two or more instances of `::'")]))
|
||||
;; parse "->"
|
||||
(let ([s (split-by '-> xs)])
|
||||
(case (length s)
|
||||
[(0) (err "something bad happened (->)")]
|
||||
[(1) (err "missing output type")]
|
||||
[(2 3) (set! inputs (car s))
|
||||
(case (length (cadr s))
|
||||
[(1) (set! output-type (caadr s))]
|
||||
[(0) (err "missing output type after `->'")]
|
||||
[else (err "extraneous output type" (cadadr s))])
|
||||
(unless (null? (cddr s))
|
||||
(case (length (caddr s))
|
||||
[(1) (set! output-expr (caaddr s))]
|
||||
[(0) (err "missing output expression after `->'")]
|
||||
[else (err "extraneous output expression"
|
||||
(cadr (caddr s)))]))]
|
||||
[else (err "saw three or more instances of `->'")]))
|
||||
(set! inputs
|
||||
(map (lambda (sub temp)
|
||||
(let ([t-n-e (t-n-e sub)])
|
||||
(syntax-case* sub (: =) id=?
|
||||
[(name : type) (t-n-e #'type #'name #f)]
|
||||
[(type = expr) (t-n-e #'type temp #'expr)]
|
||||
[(name : type = expr) (t-n-e #'type #'name #'expr)]
|
||||
[type (t-n-e #'type temp #f)])))
|
||||
inputs
|
||||
(generate-temporaries (map (lambda (x) 'tmp) inputs))))
|
||||
;; when processing the output type, only the post code matters
|
||||
(set! pre! (lambda (x) #f))
|
||||
(set! output
|
||||
(let ([temp (car (generate-temporaries #'(ret)))]
|
||||
[t-n-e (t-n-e output-type)])
|
||||
(syntax-case* output-type (: =) id=?
|
||||
[(name : type) (t-n-e #'type #'name output-expr)]
|
||||
[(type = expr) (if output-expr
|
||||
(err "extraneous output expression" #'expr)
|
||||
(t-n-e #'type temp #'expr))]
|
||||
[(name : type = expr)
|
||||
(if output-expr
|
||||
(err "extraneous output expression" #'expr)
|
||||
(t-n-e #'type #'name #'expr))]
|
||||
[type (t-n-e #'type temp output-expr)])))
|
||||
(if (or (caddr output) input-names (ormap caddr inputs)
|
||||
(ormap (lambda (x) (not (car x))) inputs)
|
||||
(pair? bind) (pair? pre) (pair? post))
|
||||
(let* ([input-names (or input-names
|
||||
(filtmap (lambda (i)
|
||||
(define xs #f)
|
||||
(define abi #f)
|
||||
(define inputs #f)
|
||||
(define output #f)
|
||||
(define bind '())
|
||||
(define pre '())
|
||||
(define post '())
|
||||
(define input-names #f)
|
||||
(define output-type #f)
|
||||
(define output-expr #f)
|
||||
(define 1st-arg #f)
|
||||
(define prev-arg #f)
|
||||
(define (bind! x) (set! bind (append bind (list x))))
|
||||
(define (pre! x) (set! pre (append pre (list x))))
|
||||
(define (post! x) (set! post (append post (list x))))
|
||||
(define ((t-n-e clause) type name expr)
|
||||
(let ([keys (custom-type->keys type err)])
|
||||
(define (getkey key) (cond [(assq key keys) => cdr] [else #f]))
|
||||
(define (arg x . no-expr?)
|
||||
(define use-expr?
|
||||
(and (list? x) (= 2 (length x)) (identifier? (car x))))
|
||||
;; when the current expr is not used with a (x => ...) form,
|
||||
;; either check that no expression is given or just make it
|
||||
;; disappear from the inputs.
|
||||
(unless use-expr?
|
||||
(if (and (pair? no-expr?) (car no-expr?) expr)
|
||||
(err "got an expression for a custom type that do not use it"
|
||||
clause)
|
||||
(set! expr (void))))
|
||||
(set! x (if use-expr? (add-renamer (cadr x) name (car x)) x))
|
||||
(cond [(getkey '1st) =>
|
||||
(lambda (v)
|
||||
(if 1st-arg
|
||||
(set! x (add-renamer x 1st-arg v))
|
||||
(err "got a custom type that wants 1st arg too early"
|
||||
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 [(and (not expr) (getkey 'expr)) => (lambda (x) (set! expr x))])
|
||||
(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)]))]))
|
||||
;; turn a #f syntax to #f
|
||||
(set! type (and type (syntax-case type () [#f #f] [_ type])))
|
||||
(when type ; remember these for later usages
|
||||
(unless 1st-arg (set! 1st-arg name))
|
||||
(set! prev-arg name))
|
||||
(list type name expr)))
|
||||
(define (do-fun)
|
||||
;; parse keywords
|
||||
(let loop ()
|
||||
(let ([k (and (pair? xs) (pair? (cdr xs)) (syntax-e (car xs)))])
|
||||
(when (keyword? k)
|
||||
(case k
|
||||
[(#:abi) (if abi
|
||||
(err "got a second #:abi keyword" (car xs))
|
||||
(begin (set! abi (cadr xs))
|
||||
(set! xs (cddr xs))
|
||||
(loop)))]
|
||||
[else (err "unknown keyword" (car xs))]))))
|
||||
(unless abi (set! abi #'#f))
|
||||
;; parse known punctuation
|
||||
(set! xs (map (lambda (x)
|
||||
(syntax-case* x (-> ::) id=? [:: '::] [-> '->] [_ x]))
|
||||
xs))
|
||||
;; parse "::"
|
||||
(let ([s (split-by ':: xs)])
|
||||
(case (length s)
|
||||
[(0) (err "something bad happened (::)")]
|
||||
[(1) (void)]
|
||||
[(2) (if (and (= 1 (length (car s))) (not (eq? '-> (caar s))))
|
||||
(begin (set! xs (cadr s)) (set! input-names (caar s)))
|
||||
(err "bad wrapper formals"))]
|
||||
[else (err "saw two or more instances of `::'")]))
|
||||
;; parse "->"
|
||||
(let ([s (split-by '-> xs)])
|
||||
(case (length s)
|
||||
[(0) (err "something bad happened (->)")]
|
||||
[(1) (err "missing output type")]
|
||||
[(2 3) (set! inputs (car s))
|
||||
(case (length (cadr s))
|
||||
[(1) (set! output-type (caadr s))]
|
||||
[(0) (err "missing output type after `->'")]
|
||||
[else (err "extraneous output type" (cadadr s))])
|
||||
(unless (null? (cddr s))
|
||||
(case (length (caddr s))
|
||||
[(1) (set! output-expr (caaddr s))]
|
||||
[(0) (err "missing output expression after `->'")]
|
||||
[else (err "extraneous output expression"
|
||||
(cadr (caddr s)))]))]
|
||||
[else (err "saw three or more instances of `->'")]))
|
||||
(set! inputs
|
||||
(map (lambda (sub temp)
|
||||
(let ([t-n-e (t-n-e sub)])
|
||||
(syntax-case* sub (: =) id=?
|
||||
[(name : type) (t-n-e #'type #'name #f)]
|
||||
[(type = expr) (t-n-e #'type temp #'expr)]
|
||||
[(name : type = expr) (t-n-e #'type #'name #'expr)]
|
||||
[type (t-n-e #'type temp #f)])))
|
||||
inputs
|
||||
(generate-temporaries (map (lambda (x) 'tmp) inputs))))
|
||||
;; when processing the output type, only the post code matters
|
||||
(set! pre! (lambda (x) #f))
|
||||
(set! output
|
||||
(let ([temp (car (generate-temporaries #'(ret)))]
|
||||
[t-n-e (t-n-e output-type)])
|
||||
(syntax-case* output-type (: =) id=?
|
||||
[(name : type) (t-n-e #'type #'name output-expr)]
|
||||
[(type = expr) (if output-expr
|
||||
(err "extraneous output expression" #'expr)
|
||||
(t-n-e #'type temp #'expr))]
|
||||
[(name : type = expr)
|
||||
(if output-expr
|
||||
(err "extraneous output expression" #'expr)
|
||||
(t-n-e #'type #'name #'expr))]
|
||||
[type (t-n-e #'type temp output-expr)])))
|
||||
(if (or (caddr output) input-names (ormap caddr inputs)
|
||||
(ormap (lambda (x) (not (car x))) inputs)
|
||||
(pair? bind) (pair? pre) (pair? post))
|
||||
(let* ([input-names (or input-names
|
||||
(filter-map (lambda (i)
|
||||
(and (not (caddr i)) (cadr i)))
|
||||
inputs))]
|
||||
[output-expr (let ([o (caddr output)])
|
||||
(or (and (not (void? o)) o)
|
||||
(cadr output)))]
|
||||
[args (filtmap (lambda (i) (and (caddr i)
|
||||
(not (void? (caddr i)))
|
||||
#`[#,(cadr i) #,(caddr i)]))
|
||||
[output-expr (let ([o (caddr output)])
|
||||
(or (and (not (void? o)) o)
|
||||
(cadr output)))]
|
||||
[args (filter-map (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
|
||||
[body (let ([n (cond [(syntax-property stx 'ffi-name)
|
||||
=> syntax->datum]
|
||||
[else #f])])
|
||||
(if (string? n)
|
||||
(syntax-property
|
||||
body 'inferred-name
|
||||
(string->symbol (string-append "ffi-wrapper:" n)))
|
||||
body))])
|
||||
#`(_cprocedure (list #,@(filtmap car inputs)) #,(car output)
|
||||
(lambda (ffi) #,body)))
|
||||
#`(_cprocedure (list #,@(filtmap car inputs)) #,(car output))))]))
|
||||
[ffi-args (filter-map (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
|
||||
[body (let ([n (cond [(syntax-property stx 'ffi-name)
|
||||
=> syntax->datum]
|
||||
[else #f])])
|
||||
(if (string? n)
|
||||
(syntax-property
|
||||
body 'inferred-name
|
||||
(string->symbol (string-append "ffi-wrapper:" n)))
|
||||
body))])
|
||||
#`(_cprocedure (list #,@(filter-map car inputs)) #,(car output) #,abi
|
||||
(lambda (ffi) #,body)))
|
||||
#`(_cprocedure (list #,@(filter-map car inputs)) #,(car output) #,abi)))
|
||||
(syntax-case stx ()
|
||||
[(_ x ...) (begin (set! xs (syntax->list #'(x ...))) (do-fun))]))
|
||||
|
||||
;; ----------------------------------------------------------------------------
|
||||
;; String types
|
||||
|
|
@ -1459,15 +1468,13 @@
|
|||
(define cstruct-info
|
||||
(let ([table (make-weak-hasheq)])
|
||||
(lambda (cstruct msg/fail-thunk . args)
|
||||
(cond [(eq? 'set! msg/fail-thunk)
|
||||
(cond [(eq? 'set! msg/fail-thunk)
|
||||
(hash-set! table cstruct (make-ephemeron cstruct args))]
|
||||
[(and cstruct ; might get a #f if there were no slots
|
||||
(hash-ref table cstruct (lambda () #f)))
|
||||
=> (lambda (xs)
|
||||
=> (lambda (xs)
|
||||
(let ([v (ephemeron-value xs)])
|
||||
(if v
|
||||
(apply values v)
|
||||
(msg/fail-thunk))))]
|
||||
(if v (apply values v) (msg/fail-thunk))))]
|
||||
[else (msg/fail-thunk)]))))
|
||||
|
||||
;; ----------------------------------------------------------------------------
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user