reorganizing code
original commit: f2f87e214ae5428eb6348f487ad42960683e23f8
This commit is contained in:
Eli Barzilay
parent
0c20f39b6b
commit
19a09f7e8d
|
|
@ -70,81 +70,6 @@
|
|||
[(_ name expr)
|
||||
(begin (provide name) (define name expr))]))
|
||||
|
||||
;; ----------------------------------------------------------------------------
|
||||
;; Compile-time support for fun-expanders
|
||||
|
||||
;; The `_fun' macro tears its input apart and reassemble it using pieces from
|
||||
;; custom function types (macros). This whole deal needs some work to make it
|
||||
;; play nicely with code certificates, so Matthew wrote the following code.
|
||||
;; The idea is to create a define-fun-syntax which is not really a new kind of
|
||||
;; a syntax transformer which should always be expanded with
|
||||
;; `expand-fun-syntax'.
|
||||
|
||||
(begin-for-syntax
|
||||
(define fun-cert-key (gensym))
|
||||
(define-values (make-fun-syntax fun-syntax?
|
||||
fun-syntax-proc fun-syntax-certifier)
|
||||
(let-values ([(desc make pred? get set!)
|
||||
(make-struct-type
|
||||
'fun-syntax #f 2 0 #f '() (current-inspector) 0)])
|
||||
(values make pred?
|
||||
(make-struct-field-accessor get 0 'proc)
|
||||
(make-struct-field-accessor get 1 'certifier))))
|
||||
(define (expand-fun-syntax stx)
|
||||
(let loop ([stx stx])
|
||||
(define (do-expand id id?) ; id? == are we expanding an identifier?
|
||||
(define v (syntax-local-value id (lambda () #f)))
|
||||
(define set!-trans? (set!-transformer? v))
|
||||
(define proc (if set!-trans? (set!-transformer-procedure v) v))
|
||||
(if (and (fun-syntax? proc) (or (not id?) set!-trans?))
|
||||
;; Do essentially the same thing that `local-expand' does.
|
||||
;; First, create an "introducer" to mark introduced identifiers:
|
||||
(let* ([introduce (make-syntax-introducer)]
|
||||
[expanded
|
||||
;; Re-introduce mark related to expansion of `_fun':
|
||||
(syntax-local-introduce
|
||||
;; Re-add mark specific to this expansion, cancelling
|
||||
;; some marks applied before expanding (leaving only
|
||||
;; introuced syntax marked)
|
||||
(introduce
|
||||
;; Actually expand:
|
||||
(proc
|
||||
;; Add mark specific to this expansion:
|
||||
(introduce
|
||||
;; Remove mark related to expansion of `_fun':
|
||||
(syntax-local-introduce stx)))))])
|
||||
;; Certify based on definition of expander, then loop
|
||||
;; to continue expanding:
|
||||
(loop ((fun-syntax-certifier proc)
|
||||
expanded fun-cert-key introduce)))
|
||||
stx))
|
||||
(syntax-case stx ()
|
||||
[(id . rest) (identifier? #'id) (do-expand #'id #f)]
|
||||
[id (identifier? #'id) (do-expand #'id #t)]
|
||||
[_else stx]))))
|
||||
|
||||
;; Use define-fun-syntax instead of define-syntax for forms that
|
||||
;; are to be expanded by `_fun':
|
||||
(provide define-fun-syntax)
|
||||
(define-syntax define-fun-syntax
|
||||
(syntax-rules ()
|
||||
[(_ id trans)
|
||||
(define-syntax id
|
||||
(let* ([xformer trans]
|
||||
[set!-trans? (set!-transformer? xformer)])
|
||||
(unless (or (and (procedure? xformer)
|
||||
(procedure-arity-includes? xformer 1))
|
||||
set!-trans?)
|
||||
(raise-type-error 'define-fun-syntax
|
||||
"procedure (arity 1) or set!-transformer"
|
||||
xformer))
|
||||
(let ([f (make-fun-syntax (if set!-trans?
|
||||
(set!-transformer-procedure xformer)
|
||||
xformer)
|
||||
;; Capture definition-time certificates:
|
||||
(syntax-local-certifier))])
|
||||
(if set!-trans? (make-set!-transformer f) f))))]))
|
||||
|
||||
;; ----------------------------------------------------------------------------
|
||||
;; Getting and setting library objects
|
||||
|
||||
|
|
@ -245,50 +170,76 @@
|
|||
(define ffi-objects-ref-table (make-hash-table))
|
||||
|
||||
;; ----------------------------------------------------------------------------
|
||||
;; Function type
|
||||
;; Compile-time support for fun-expanders
|
||||
|
||||
;; 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))))))
|
||||
(begin-for-syntax
|
||||
|
||||
;; Syntax for the special _fun type:
|
||||
;; (_fun [{(name ... [. name]) | name} [-> expr] ::]
|
||||
;; {type | (name : type [= expr]) | ([name :] type = expr)} ...
|
||||
;; -> {type | (name : type)}
|
||||
;; [-> expr])
|
||||
;; Usage:
|
||||
;; `{(name ...) | ...} ::' specify explicit wrapper function formal arguments
|
||||
;; `-> expr' can be used instead of the last expr
|
||||
;; `type' input type (implies input, but see type macros next)
|
||||
;; `(name : type = expr)' specify name and type, `= expr' means computed input
|
||||
;; `-> type' output type (possibly with name)
|
||||
;; `-> expr' specify different output, can use previous names
|
||||
;; Also, see below for custom function types.
|
||||
;; The `_fun' macro tears its input apart and reassemble it using pieces from
|
||||
;; custom function types (macros). This whole deal needs some work to make
|
||||
;; it play nicely with code certificates, so Matthew wrote the following
|
||||
;; code. The idea is to create a define-fun-syntax which is not really a new
|
||||
;; kind of a syntax transformer which should always be expanded with
|
||||
;; `expand-fun-syntax'.
|
||||
|
||||
(begin-for-syntax ; utilities for _fun
|
||||
;; use module-or-top-identifier=? because we use keywords like `=' and want to
|
||||
;; make it possible to play with it at the toplevel
|
||||
(define fun-cert-key (gensym))
|
||||
(define-values (make-fun-syntax fun-syntax?
|
||||
fun-syntax-proc fun-syntax-certifier)
|
||||
(let-values ([(desc make pred? get set!)
|
||||
(make-struct-type
|
||||
'fun-syntax #f 2 0 #f '() (current-inspector) 0)])
|
||||
(values make pred?
|
||||
(make-struct-field-accessor get 0 'proc)
|
||||
(make-struct-field-accessor get 1 'certifier))))
|
||||
(define (expand-fun-syntax stx)
|
||||
(let loop ([stx stx])
|
||||
(define (do-expand id id?) ; id? == are we expanding an identifier?
|
||||
(define v (syntax-local-value id (lambda () #f)))
|
||||
(define set!-trans? (set!-transformer? v))
|
||||
(define proc (if set!-trans? (set!-transformer-procedure v) v))
|
||||
(if (and (fun-syntax? proc) (or (not id?) set!-trans?))
|
||||
;; Do essentially the same thing that `local-expand' does.
|
||||
;; First, create an "introducer" to mark introduced identifiers:
|
||||
(let* ([introduce (make-syntax-introducer)]
|
||||
[expanded
|
||||
;; Re-introduce mark related to expansion of `_fun':
|
||||
(syntax-local-introduce
|
||||
;; Re-add mark specific to this expansion, cancelling
|
||||
;; some marks applied before expanding (leaving only
|
||||
;; introuced syntax marked)
|
||||
(introduce
|
||||
;; Actually expand:
|
||||
(proc
|
||||
;; Add mark specific to this expansion:
|
||||
(introduce
|
||||
;; Remove mark related to expansion of `_fun':
|
||||
(syntax-local-introduce stx)))))])
|
||||
;; Certify based on definition of expander, then loop
|
||||
;; to continue expanding:
|
||||
(loop ((fun-syntax-certifier proc)
|
||||
expanded fun-cert-key introduce)))
|
||||
stx))
|
||||
(syntax-case stx ()
|
||||
[(id . rest) (identifier? #'id) (do-expand #'id #f)]
|
||||
[id (identifier? #'id) (do-expand #'id #t)]
|
||||
[_else stx])))
|
||||
|
||||
;; use module-or-top-identifier=? because we use keywords like `=' and want
|
||||
;; to make it possible to play with it at the toplevel
|
||||
(define id=? module-or-top-identifier=?)
|
||||
|
||||
(define (split-by key args)
|
||||
(let loop ([args args] [r (list '())])
|
||||
(cond [(null? args) (reverse! (map reverse! r))]
|
||||
[(eq? key (car args)) (loop (cdr args) (cons '() r))]
|
||||
[else (set-car! r (cons (car args) (car r)))
|
||||
(loop (cdr args) 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))))))
|
||||
|
||||
(define (add-renamer body from to)
|
||||
(with-syntax ([body body] [from from] [to to])
|
||||
#'(let-syntax ([to (syntax-id-rules ()
|
||||
|
|
@ -328,6 +279,58 @@
|
|||
[() (and (pair? keys) keys)]
|
||||
[_else #f])))))
|
||||
|
||||
;; Use define-fun-syntax instead of define-syntax for forms that
|
||||
;; are to be expanded by `_fun':
|
||||
(provide define-fun-syntax)
|
||||
(define-syntax define-fun-syntax
|
||||
(syntax-rules ()
|
||||
[(_ id trans)
|
||||
(define-syntax id
|
||||
(let* ([xformer trans]
|
||||
[set!-trans? (set!-transformer? xformer)])
|
||||
(unless (or (and (procedure? xformer)
|
||||
(procedure-arity-includes? xformer 1))
|
||||
set!-trans?)
|
||||
(raise-type-error 'define-fun-syntax
|
||||
"procedure (arity 1) or set!-transformer"
|
||||
xformer))
|
||||
(let ([f (make-fun-syntax (if set!-trans?
|
||||
(set!-transformer-procedure xformer)
|
||||
xformer)
|
||||
;; Capture definition-time certificates:
|
||||
(syntax-local-certifier))])
|
||||
(if set!-trans? (make-set!-transformer f) f))))]))
|
||||
|
||||
;; ----------------------------------------------------------------------------
|
||||
;; Function type
|
||||
|
||||
;; 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))))))
|
||||
|
||||
;; Syntax for the special _fun type:
|
||||
;; (_fun [{(name ... [. name]) | name} [-> expr] ::]
|
||||
;; {type | (name : type [= expr]) | ([name :] type = expr)} ...
|
||||
;; -> {type | (name : type)}
|
||||
;; [-> expr])
|
||||
;; Usage:
|
||||
;; `{(name ...) | ...} ::' specify explicit wrapper function formal arguments
|
||||
;; `-> expr' can be used instead of the last expr
|
||||
;; `type' input type (implies input, but see type macros next)
|
||||
;; `(name : type = expr)' specify name and type, `= expr' means computed input
|
||||
;; `-> type' output type (possibly with name)
|
||||
;; `-> expr' specify different output, can use previous names
|
||||
;; Also, see below for custom function types.
|
||||
|
||||
(provide _fun)
|
||||
(define-syntax (_fun stx)
|
||||
(define (err msg . sub) (apply raise-syntax-error '_fun msg stx sub))
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user