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
|
||||||
|
|
||||||
|
|
@ -244,6 +169,138 @@
|
||||||
;; avoid them being GCed. See set-ffi-obj! above.
|
;; avoid them being GCed. See set-ffi-obj! above.
|
||||||
(define ffi-objects-ref-table (make-hash-table))
|
(define ffi-objects-ref-table (make-hash-table))
|
||||||
|
|
||||||
|
;; ----------------------------------------------------------------------------
|
||||||
|
;; Compile-time support for fun-expanders
|
||||||
|
|
||||||
|
(begin-for-syntax
|
||||||
|
|
||||||
|
;; 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'.
|
||||||
|
|
||||||
|
(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 ()
|
||||||
|
[(_?_ . _rest_) (from . _rest_)] [_?_ from])])
|
||||||
|
body)))
|
||||||
|
(define (custom-type->keys type err)
|
||||||
|
(define stops (map (lambda (s) (datum->syntax-object type s #f))
|
||||||
|
'(#%app #%top #%datum)))
|
||||||
|
;; Expand `type' using expand-fun-syntax
|
||||||
|
(define orig (expand-fun-syntax type))
|
||||||
|
(define (with-arg x)
|
||||||
|
(syntax-case* x (=>) id=?
|
||||||
|
[(id => body) (identifier? #'id)
|
||||||
|
;; Extract #'body from its context, use a key it needs certification:
|
||||||
|
(list #'id (syntax-recertify #'body orig #f fun-cert-key))]
|
||||||
|
[_else x]))
|
||||||
|
(let ([keys '()])
|
||||||
|
(define (setkey! key val . id?)
|
||||||
|
(cond
|
||||||
|
[(assq key keys)
|
||||||
|
(err "bad expansion of custom type (two `~a:'s)" key type)]
|
||||||
|
[(and (pair? id?) (car id?) (not (identifier? val)))
|
||||||
|
(err "bad expansion of custom type (`~a:' expects an identifier)"
|
||||||
|
key type)]
|
||||||
|
[else (set! keys (cons (cons key val) keys))]))
|
||||||
|
(let loop ([t orig])
|
||||||
|
(define (next rest . args) (apply setkey! args) (loop rest))
|
||||||
|
(syntax-case* t (type: expr: bind: pre: post: 1st-arg: prev-arg:) id=?
|
||||||
|
[(type: t x ...) (next #'(x ...) 'type #'t)]
|
||||||
|
[(expr: e x ...) (next #'(x ...) 'expr #'e)]
|
||||||
|
[(bind: id x ...) (next #'(x ...) 'bind #'id #t)]
|
||||||
|
[(1st-arg: id x ...) (next #'(x ...) '1st #'id #t)]
|
||||||
|
[(prev-arg: id x ...) (next #'(x ...) 'prev #'id #t)]
|
||||||
|
;; in the following two cases pass along orig for recertifying
|
||||||
|
[(pre: p x ...) (next #'(x ...) 'pre (with-arg #'p))]
|
||||||
|
[(post: p x ...) (next #'(x ...) 'post (with-arg #'p))]
|
||||||
|
[() (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
|
;; Function type
|
||||||
|
|
||||||
|
|
@ -274,60 +331,6 @@
|
||||||
;; `-> expr' specify different output, can use previous names
|
;; `-> expr' specify different output, can use previous names
|
||||||
;; Also, see below for custom function types.
|
;; Also, see below for custom function types.
|
||||||
|
|
||||||
(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 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 ()
|
|
||||||
[(_?_ . _rest_) (from . _rest_)] [_?_ from])])
|
|
||||||
body)))
|
|
||||||
(define (custom-type->keys type err)
|
|
||||||
(define stops (map (lambda (s) (datum->syntax-object type s #f))
|
|
||||||
'(#%app #%top #%datum)))
|
|
||||||
;; Expand `type' using expand-fun-syntax
|
|
||||||
(define orig (expand-fun-syntax type))
|
|
||||||
(define (with-arg x)
|
|
||||||
(syntax-case* x (=>) id=?
|
|
||||||
[(id => body) (identifier? #'id)
|
|
||||||
;; Extract #'body from its context, use a key it needs certification:
|
|
||||||
(list #'id (syntax-recertify #'body orig #f fun-cert-key))]
|
|
||||||
[_else x]))
|
|
||||||
(let ([keys '()])
|
|
||||||
(define (setkey! key val . id?)
|
|
||||||
(cond
|
|
||||||
[(assq key keys)
|
|
||||||
(err "bad expansion of custom type (two `~a:'s)" key type)]
|
|
||||||
[(and (pair? id?) (car id?) (not (identifier? val)))
|
|
||||||
(err "bad expansion of custom type (`~a:' expects an identifier)"
|
|
||||||
key type)]
|
|
||||||
[else (set! keys (cons (cons key val) keys))]))
|
|
||||||
(let loop ([t orig])
|
|
||||||
(define (next rest . args) (apply setkey! args) (loop rest))
|
|
||||||
(syntax-case* t (type: expr: bind: pre: post: 1st-arg: prev-arg:) id=?
|
|
||||||
[(type: t x ...) (next #'(x ...) 'type #'t)]
|
|
||||||
[(expr: e x ...) (next #'(x ...) 'expr #'e)]
|
|
||||||
[(bind: id x ...) (next #'(x ...) 'bind #'id #t)]
|
|
||||||
[(1st-arg: id x ...) (next #'(x ...) '1st #'id #t)]
|
|
||||||
[(prev-arg: id x ...) (next #'(x ...) 'prev #'id #t)]
|
|
||||||
;; in the following two cases pass along orig for recertifying
|
|
||||||
[(pre: p x ...) (next #'(x ...) 'pre (with-arg #'p))]
|
|
||||||
[(post: p x ...) (next #'(x ...) 'post (with-arg #'p))]
|
|
||||||
[() (and (pair? keys) keys)]
|
|
||||||
[_else #f])))))
|
|
||||||
|
|
||||||
(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