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

better organization for keyword parsing in _fun

Browse Source 
svn: r17376
This commit is contained in:
Eli Barzilay 2009-12-21 08:00:33 +00:00
parent add4f479c6
commit 1530411d94
1 changed files with 74 additions and 63 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

73
collects/scheme/foreign.ss
View File

@ -524,13 +524,11 @@
[_ (raise-syntax-error '-> "should be used only in a _fun context")])) [_ (raise-syntax-error '-> "should be used only in a _fun context")]))
(provide _fun) (provide _fun)
(define-for-syntax _fun-keywords
`([#:abi ,#'#f] [#:keep ,#'#t] [#:atomic? ,#'#f] [#:save-errno ,#'#f]))
(define-syntax (_fun stx) (define-syntax (_fun stx)
(define (err msg . sub) (apply raise-syntax-error '_fun msg stx sub)) (define (err msg . sub) (apply raise-syntax-error '_fun msg stx sub))
(define xs #f) (define xs #f)
(define abi #f)
(define keep #f)
(define atomic? #f)
(define errno #f)
(define inputs #f) (define inputs #f)
(define output #f) (define output #f)
(define bind '()) (define bind '())
@ -544,6 +542,20 @@
(define (bind! x) (set! bind (append bind (list x)))) (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-values (getkey setkey!)
(let ([ks '()])
(values
(lambda (k)
(cond [(assq k ks) => cdr]
[(assq k _fun-keywords) => cadr]
[else (error '_fun "internal error: unknown keyword: ~e" k)]))
(lambda (k-stx v)
(let ([k (syntax-e k-stx)])
(cond [(assq k ks)
(err (format "duplicate ~s keyword" k) k-stx)]
[(assq k _fun-keywords)
(set! ks (cons (cons k v) ks))]
[else (err "unknown keyword" k-stx)]))))))
(define ((t-n-e clause) type name expr) (define ((t-n-e clause) type name expr)
(let ([keys (custom-type->keys type err)]) (let ([keys (custom-type->keys type err)])
(define (getkey key) (cond [(assq key keys) => cdr] [else #f])) (define (getkey key) (cond [(assq key keys) => cdr] [else #f]))
@ -587,21 +599,11 @@
(define (do-fun) (define (do-fun)
;; parse keywords ;; parse keywords
(let loop () (let loop ()
(let ([k (and (pair? xs) (pair? (cdr xs)) (syntax-e (car xs)))]) (let ([k (and (pair? xs) (pair? (cdr xs)) (car xs))])
(define-syntax-rule (kwds [key var] ...) (when (keyword? (syntax-e k))
(case k (setkey! k (cadr xs))
[(key) (if var (set! xs (cddr xs))
(err (format "got a second ~s keyword" 'key) (car xs)) (loop))))
(begin (set! var (cadr xs)) (set! xs (cddr xs)) (loop)))]
...
[else (err "unknown keyword" (car xs))]))
(when (keyword? k)
(kwds [#:abi abi] [#:keep keep] [#:atomic? atomic?]
[#:save-errno errno]))))
(unless abi (set! abi #'#f))
(unless keep (set! keep #'#t))
(unless atomic? (set! atomic? #'#f))
(unless errno (set! errno #'#f))
;; parse known punctuation ;; parse known punctuation
(set! xs (map (lambda (x) (set! xs (map (lambda (x)
(syntax-case* x (-> ::) id=? [:: '::] [-> '->] [_ x])) (syntax-case* x (-> ::) id=? [:: '::] [-> '->] [_ x]))
@ -657,22 +659,33 @@
(err "extraneous output expression" #'expr) (err "extraneous output expression" #'expr)
(t-n-e #'type #'name #'expr))] (t-n-e #'type #'name #'expr))]
[type (t-n-e #'type temp output-expr)]))) [type (t-n-e #'type temp output-expr)])))
(let ([make-cprocedure
(lambda (wrapper)
#`(_cprocedure* (list #,@(filter-map car inputs))
#,(car output)
#,(getkey '#:abi)
#,wrapper
#,(getkey '#:keep)
#,(getkey '#:atomic?)
#,(getkey '#:save-errno)))])
(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? bind) (pair? pre) (pair? post)) (pair? bind) (pair? pre) (pair? post))
(let* ([input-names (or input-names (let* ([input-names
(filter-map (lambda (i) (or input-names
(and (not (caddr i)) (cadr i))) (filter-map (lambda (i) (and (not (caddr i)) (cadr i)))
inputs))] inputs))]
[output-expr (let ([o (caddr output)]) [output-expr
(or (and (not (void? o)) o) (let ([o (caddr output)])
(cadr output)))] (or (and (not (void? o)) o) (cadr output)))]
[args (filter-map (lambda (i) [args
(filter-map (lambda (i)
(and (caddr i) (and (caddr i)
(not (void? (caddr i))) (not (void? (caddr i)))
#`[#,(cadr i) #,(caddr i)])) #`[#,(cadr i) #,(caddr i)]))
inputs)] inputs)]
[ffi-args (filter-map (lambda (x) (and (car x) (cadr x))) inputs)] [ffi-args
(filter-map (lambda (x) (and (car x) (cadr x))) inputs)]
;; the actual wrapper body ;; the actual wrapper body
[body (quasisyntax/loc stx [body (quasisyntax/loc stx
(lambda #,input-names (lambda #,input-names
@ -691,10 +704,8 @@
body 'inferred-name body 'inferred-name
(string->symbol (string-append "ffi-wrapper:" n))) (string->symbol (string-append "ffi-wrapper:" n)))
body))]) body))])
#`(_cprocedure* (list #,@(filter-map car inputs)) #,(car output) (make-cprocedure #`(lambda (ffi) #,body)))
#,abi (lambda (ffi) #,body) #,keep #,atomic? #,errno)) (make-cprocedure #'#f))))
#`(_cprocedure* (list #,@(filter-map car inputs)) #,(car output)
#,abi #f #,keep #,atomic? #,errno)))
(syntax-case stx () (syntax-case stx ()
[(_ x ...) (begin (set! xs (syntax->list #'(x ...))) (do-fun))])) [(_ x ...) (begin (set! xs (syntax->list #'(x ...))) (do-fun))]))