reorganizing code
original commit: f2f87e214ae5428eb6348f487ad42960683e23f8
This commit is contained in:
Eli Barzilay
parent
0c20f39b6b
commit
19a09f7e8d
|
|
@ -70,81 +70,6 @@
|
||||||
[(_ name expr)
|
[(_ name expr)
|
||||||
(begin (provide name) (define 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
|
;; Getting and setting library objects
|
||||||
|
|
||||||
|
|
@ -245,50 +170,76 @@
|
||||||
(define ffi-objects-ref-table (make-hash-table))
|
(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,
|
(begin-for-syntax
|
||||||
;; 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:
|
;; The `_fun' macro tears its input apart and reassemble it using pieces from
|
||||||
;; (_fun [{(name ... [. name]) | name} [-> expr] ::]
|
;; custom function types (macros). This whole deal needs some work to make
|
||||||
;; {type | (name : type [= expr]) | ([name :] type = expr)} ...
|
;; it play nicely with code certificates, so Matthew wrote the following
|
||||||
;; -> {type | (name : type)}
|
;; code. The idea is to create a define-fun-syntax which is not really a new
|
||||||
;; [-> expr])
|
;; kind of a syntax transformer which should always be expanded with
|
||||||
;; Usage:
|
;; `expand-fun-syntax'.
|
||||||
;; `{(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.
|
|
||||||
|
|
||||||
(begin-for-syntax ; utilities for _fun
|
(define fun-cert-key (gensym))
|
||||||
;; use module-or-top-identifier=? because we use keywords like `=' and want to
|
(define-values (make-fun-syntax fun-syntax?
|
||||||
;; make it possible to play with it at the toplevel
|
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 id=? module-or-top-identifier=?)
|
||||||
|
|
||||||
(define (split-by key args)
|
(define (split-by key args)
|
||||||
(let loop ([args args] [r (list '())])
|
(let loop ([args args] [r (list '())])
|
||||||
(cond [(null? args) (reverse! (map reverse! r))]
|
(cond [(null? args) (reverse! (map reverse! r))]
|
||||||
[(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 (filtmap 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)
|
||||||
(let ([x (f (car l))]) (loop (cdr l) (if x (cons x r) r))))))
|
(let ([x (f (car l))]) (loop (cdr l) (if x (cons x r) r))))))
|
||||||
|
|
||||||
(define (add-renamer body from to)
|
(define (add-renamer body from to)
|
||||||
(with-syntax ([body body] [from from] [to to])
|
(with-syntax ([body body] [from from] [to to])
|
||||||
#'(let-syntax ([to (syntax-id-rules ()
|
#'(let-syntax ([to (syntax-id-rules ()
|
||||||
|
|
@ -328,6 +279,58 @@
|
||||||
[() (and (pair? keys) keys)]
|
[() (and (pair? keys) keys)]
|
||||||
[_else #f])))))
|
[_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)
|
(provide _fun)
|
||||||
(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))
|
||||||
|
|
|
||||||
Loading…
Reference in New Issue
Block a user