.
original commit: 0e83a42addc6d0f33dc4f1e87cc22396d212d6dc
This commit is contained in:
Matthew Flatt
parent
be718d5973
commit
0badcf8400
|
|
@ -14,6 +14,7 @@
|
|||
(define-struct signature (name ; sym
|
||||
src ; sym
|
||||
elems ; list of syms and signatures
|
||||
ctxs ; list of stx
|
||||
structs)) ; list of struct-infos
|
||||
(define-struct parsed-unit (imports renames vars stxes body stx-checks))
|
||||
|
||||
|
|
@ -54,40 +55,46 @@
|
|||
what)))
|
||||
|
||||
(define rename-signature
|
||||
(lambda (sig name)
|
||||
(lambda (sig name main-ctx)
|
||||
(make-signature name
|
||||
(signature-src sig)
|
||||
(signature-elems sig)
|
||||
(if main-ctx
|
||||
(map (lambda (ctx) (or ctx main-ctx)) (signature-ctxs sig))
|
||||
(signature-ctxs sig))
|
||||
(signature-structs sig))))
|
||||
|
||||
(define intern-signature
|
||||
(lambda (name desc)
|
||||
(make-signature
|
||||
name
|
||||
name
|
||||
(map
|
||||
(lambda (elem)
|
||||
(cond
|
||||
[(symbol? elem) elem]
|
||||
[(and (pair? elem) (symbol? (car elem)))
|
||||
(intern-signature (car elem) (cdr elem))]
|
||||
[else (error "intern failed")]))
|
||||
(vector->list (car desc)))
|
||||
(map
|
||||
(lambda (elem)
|
||||
(make-struct-def (vector-ref elem 0)
|
||||
(vector-ref elem 1)
|
||||
(cddr (vector->list elem))))
|
||||
(vector->list (cdr desc))))))
|
||||
(let ([elems (vector->list (car desc))])
|
||||
(make-signature
|
||||
name
|
||||
name
|
||||
(map
|
||||
(lambda (elem)
|
||||
(cond
|
||||
[(symbol? elem) elem]
|
||||
[(and (pair? elem) (symbol? (car elem)))
|
||||
(intern-signature (car elem) (cdr elem))]
|
||||
[else (error "intern failed")]))
|
||||
elems)
|
||||
(map (lambda (elem) #f) elems)
|
||||
(map
|
||||
(lambda (elem)
|
||||
(make-struct-def (vector-ref elem 0)
|
||||
(vector-ref elem 1)
|
||||
(cddr (vector->list elem))))
|
||||
(vector->list (cdr desc)))))))
|
||||
|
||||
(define get-sig
|
||||
(lambda (who expr name sigid)
|
||||
(lambda (who expr name sigid main-ctx)
|
||||
(if (not (identifier? sigid))
|
||||
(parse-signature who expr
|
||||
(if name
|
||||
name
|
||||
inline-sig-name)
|
||||
sigid)
|
||||
sigid
|
||||
main-ctx)
|
||||
(let ([v (syntax-local-value sigid (lambda () #f))])
|
||||
(unless v
|
||||
(undef-sig-error who expr sigid))
|
||||
|
|
@ -97,7 +104,7 @@
|
|||
(set-sigdef-interned! v (intern-signature (syntax-e sigid) (sigdef-content v))))
|
||||
(let ([s (sigdef-interned v)])
|
||||
(if name
|
||||
(rename-signature s (stx->sym name))
|
||||
(rename-signature s (stx->sym name) (and main-ctx sigid))
|
||||
s))))))
|
||||
|
||||
(define check-unique
|
||||
|
|
@ -112,11 +119,11 @@
|
|||
(error-k dup)))))
|
||||
|
||||
(define parse-signature
|
||||
(lambda (who expr name body)
|
||||
(let-values ([(elems struct-defs)
|
||||
(let loop ([body body][accum null][struct-accum null])
|
||||
(lambda (who expr name body main-ctx)
|
||||
(let-values ([(elems ctxs struct-defs)
|
||||
(let loop ([body body][accum null][ctx-accum null][struct-accum null])
|
||||
(syntax-case body ()
|
||||
[() (values (reverse! accum) (reverse! struct-accum))]
|
||||
[() (values (reverse! accum) (reverse! ctx-accum) (reverse! struct-accum))]
|
||||
[(something . rest)
|
||||
(syntax-case (syntax something) ()
|
||||
[:
|
||||
|
|
@ -129,6 +136,7 @@
|
|||
(loop
|
||||
(syntax rest)
|
||||
(cons (syntax id) accum)
|
||||
(cons (syntax id) ctx-accum)
|
||||
struct-accum)]
|
||||
[(struct name (field ...) omission ...)
|
||||
(literal? struct)
|
||||
|
|
@ -193,16 +201,20 @@
|
|||
omit-names)
|
||||
(filter (cdr names))]
|
||||
[else (cons (car names) (filter (cdr names)))]))])
|
||||
(loop (syntax rest)
|
||||
(append
|
||||
(if (null? omit-names)
|
||||
names
|
||||
(filter names))
|
||||
accum)
|
||||
(cons (make-struct-def (syntax-e name)
|
||||
(and super-name (syntax-e super-name))
|
||||
names)
|
||||
struct-accum)))))]
|
||||
(let ([elems (if (null? omit-names)
|
||||
names
|
||||
(filter names))])
|
||||
(loop (syntax rest)
|
||||
(append
|
||||
elems
|
||||
accum)
|
||||
(append
|
||||
(map (lambda (elem) name) elems)
|
||||
ctx-accum)
|
||||
(cons (make-struct-def (syntax-e name)
|
||||
(and super-name (syntax-e super-name))
|
||||
names)
|
||||
struct-accum))))))]
|
||||
[(struct . _)
|
||||
(literal? struct)
|
||||
(syntax-error #f expr
|
||||
|
|
@ -211,9 +223,10 @@
|
|||
[(unit name : sig)
|
||||
(and (literal? unit)
|
||||
(identifier? (syntax name)))
|
||||
(let ([s (get-sig who expr (syntax name) (syntax sig))])
|
||||
(let ([s (get-sig who expr (syntax name) (syntax sig) (and main-ctx (syntax sig)))])
|
||||
(loop (syntax rest)
|
||||
(cons s accum)
|
||||
(cons (syntax name) ctx-accum)
|
||||
struct-accum))]
|
||||
[(unit . _)
|
||||
(literal? unit)
|
||||
|
|
@ -222,9 +235,15 @@
|
|||
(syntax something))]
|
||||
[(open sig)
|
||||
(literal? open)
|
||||
(let ([s (get-sig who expr #f (syntax sig))])
|
||||
(let ([s (get-sig who expr #f (syntax sig) (and main-ctx (syntax sig)))])
|
||||
(loop (syntax rest)
|
||||
(append (signature-elems s) accum)
|
||||
(append
|
||||
(map (lambda (e ctx)
|
||||
(or ctx (syntax sig)))
|
||||
(signature-elems s)
|
||||
(signature-ctxs s))
|
||||
ctx-accum)
|
||||
(append (signature-structs s) struct-accum)))]
|
||||
[(open . _)
|
||||
(literal? open)
|
||||
|
|
@ -247,15 +266,20 @@
|
|||
(syntax-error #f expr
|
||||
"duplicate name in signature"
|
||||
name)))
|
||||
(make-signature (stx->sym name)
|
||||
(stx->sym name)
|
||||
(sort-signature-elems
|
||||
(map (lambda (id)
|
||||
(if (identifier? id)
|
||||
(syntax-e id)
|
||||
id))
|
||||
elems))
|
||||
struct-defs))))
|
||||
(let ([sorted (sort-signature-elems (map cons
|
||||
(map (lambda (id)
|
||||
(if (identifier? id)
|
||||
(syntax-e id)
|
||||
id))
|
||||
elems)
|
||||
(if main-ctx
|
||||
(map (lambda (ctx) (or ctx main-ctx)) ctxs)
|
||||
(map (lambda (id) #f) ctxs))))])
|
||||
(make-signature (stx->sym name)
|
||||
(stx->sym name)
|
||||
(map car sorted)
|
||||
(map cdr sorted)
|
||||
struct-defs)))))
|
||||
|
||||
(define (intern-vector intern-box v)
|
||||
(if (and intern-box
|
||||
|
|
@ -311,30 +335,37 @@
|
|||
(lambda (elems)
|
||||
(map car
|
||||
(quicksort (map
|
||||
(lambda (i)
|
||||
(cons i (symbol->string (if (symbol? i) i (signature-name i)))))
|
||||
(lambda (ip)
|
||||
(let ([i (car ip)])
|
||||
(cons ip (symbol->string (if (symbol? i)
|
||||
i
|
||||
(signature-name i))))))
|
||||
elems)
|
||||
;; Less-than; put subs at front
|
||||
(lambda (a b)
|
||||
(if (symbol? (car a))
|
||||
(if (symbol? (car b))
|
||||
(if (symbol? (caar a))
|
||||
(if (symbol? (caar b))
|
||||
(string<? (cdr a) (cdr b))
|
||||
#f)
|
||||
(if (symbol? (car b))
|
||||
(if (symbol? (caar b))
|
||||
#t
|
||||
(string<? (cdr a) (cdr b)))))))))
|
||||
|
||||
(define flatten-signature
|
||||
(lambda (id sig)
|
||||
(lambda (id sig main-ctx)
|
||||
(apply
|
||||
append
|
||||
(map
|
||||
(lambda (elem)
|
||||
(lambda (elem ctx)
|
||||
(if (symbol? elem)
|
||||
(list
|
||||
(if id
|
||||
(string->symbol (string-append id ":" (symbol->string elem)))
|
||||
elem))
|
||||
(let ([sym
|
||||
(if id
|
||||
(string->symbol (string-append id ":" (symbol->string elem)))
|
||||
elem)])
|
||||
(list
|
||||
(if main-ctx
|
||||
(datum->syntax-object (or ctx main-ctx) sym)
|
||||
sym)))
|
||||
(flatten-signature (let* ([n (signature-name elem)]
|
||||
[s (if n
|
||||
(symbol->string n)
|
||||
|
|
@ -342,17 +373,19 @@
|
|||
(if (and id s)
|
||||
(string-append id ":" s)
|
||||
(or id s)))
|
||||
elem)))
|
||||
(signature-elems sig)))))
|
||||
elem
|
||||
(or ctx main-ctx))))
|
||||
(signature-elems sig)
|
||||
(signature-ctxs sig)))))
|
||||
|
||||
(define flatten-signatures
|
||||
(lambda (sigs)
|
||||
(lambda (sigs main-ctx)
|
||||
(apply append (map (lambda (s)
|
||||
(let* ([name (signature-name s)]
|
||||
[id (if name
|
||||
(symbol->string name)
|
||||
#f)])
|
||||
(flatten-signature id s)))
|
||||
(flatten-signature id s main-ctx)))
|
||||
sigs))))
|
||||
|
||||
(define signature-parts
|
||||
|
|
@ -513,7 +546,7 @@
|
|||
(signature-src sig)))))))
|
||||
|
||||
(define parse-imports
|
||||
(lambda (who untagged-legal? really-import? expr clause)
|
||||
(lambda (who untagged-legal? really-import? expr clause keep-ctx?)
|
||||
(let ([bad
|
||||
(lambda (why . rest)
|
||||
(apply
|
||||
|
|
@ -532,14 +565,14 @@
|
|||
[id
|
||||
(and (identifier? (syntax id))
|
||||
untagged-legal?)
|
||||
(rename-signature (get-sig who expr #f item) #f)]
|
||||
(rename-signature (get-sig who expr #f item (and keep-ctx? (syntax id))) #f (syntax id))]
|
||||
[(id : sig)
|
||||
(and (identifier? (syntax id))
|
||||
(literal? :))
|
||||
(get-sig who expr (syntax id) (syntax sig))]
|
||||
(get-sig who expr (syntax id) (syntax sig) (and keep-ctx? (syntax sig)))]
|
||||
[any
|
||||
untagged-legal?
|
||||
(rename-signature (get-sig who expr #f item) #f)]
|
||||
(rename-signature (get-sig who expr #f item (and keep-ctx? (syntax any))) #f (syntax any))]
|
||||
[_else
|
||||
(bad "" item)]))
|
||||
clause)))))
|
||||
|
|
@ -554,9 +587,9 @@
|
|||
(eq? 'import (syntax-e (stx-car (car body)))))
|
||||
(syntax-error #f expr
|
||||
"expected `import' clause"))
|
||||
(let* ([imports (parse-imports 'unit/sig #t #t expr (stx-cdr (car body)))]
|
||||
[imported-names (flatten-signatures imports)]
|
||||
[exported-names (flatten-signature #f sig)]
|
||||
(let* ([imports (parse-imports 'unit/sig #t #t expr (stx-cdr (car body)) #t)]
|
||||
[imported-names (flatten-signatures imports #f)]
|
||||
[exported-names (flatten-signature #f sig #f)]
|
||||
[body (cdr body)])
|
||||
(let-values ([(renames body)
|
||||
(if (and (stx-pair? body)
|
||||
|
|
@ -689,7 +722,7 @@
|
|||
(link . links)
|
||||
(export . exports))
|
||||
(and (literal? import) (literal? link) (literal? export))
|
||||
(let* ([imports (parse-imports 'compound-unit/sig #f #t expr (syntax imports))])
|
||||
(let* ([imports (parse-imports 'compound-unit/sig #f #t expr (syntax imports) #f)])
|
||||
(let ([link-list (syntax->list (syntax links))])
|
||||
(unless link-list
|
||||
(syntax-error #f expr
|
||||
|
|
@ -710,7 +743,7 @@
|
|||
(unless (identifier? (syntax tag))
|
||||
(bad ": link tag is not an identifier" line))
|
||||
(make-link (syntax-e (syntax tag))
|
||||
(get-sig 'compound-unit/sig (syntax expr) #f (syntax sig))
|
||||
(get-sig 'compound-unit/sig (syntax expr) #f (syntax sig) #f)
|
||||
(syntax expr)
|
||||
(syntax->list (syntax (linkage ...)))))]
|
||||
[(tag . x)
|
||||
|
|
@ -829,7 +862,8 @@
|
|||
(values (list (syntax name))
|
||||
(get-sig 'compound-unit/sig expr
|
||||
#f
|
||||
(syntax sig)))]
|
||||
(syntax sig)
|
||||
#f))]
|
||||
[((elem ...) : sig)
|
||||
(and (andmap (lambda (s)
|
||||
(and (identifier? s)
|
||||
|
|
@ -839,7 +873,8 @@
|
|||
(values (syntax (elem ...))
|
||||
(get-sig 'compound-unit/sig expr
|
||||
#f
|
||||
(syntax sig)))]
|
||||
(syntax sig)
|
||||
#f))]
|
||||
[(elem1 elem ...)
|
||||
(andmap (lambda (s)
|
||||
(and (identifier? s)
|
||||
|
|
@ -909,10 +944,10 @@
|
|||
var))))
|
||||
(lambda (base last id sig)
|
||||
(make-sig-explode-pair
|
||||
(rename-signature sig last)
|
||||
(rename-signature sig last #f)
|
||||
(if base
|
||||
(list (cons base (flatten-signature id sig)))
|
||||
(flatten-signature id sig))))))
|
||||
(list (cons base (flatten-signature id sig #f)))
|
||||
(flatten-signature id sig #f))))))
|
||||
(link-links link))))
|
||||
links)
|
||||
(let ([export-list (syntax->list (syntax exports))])
|
||||
|
|
@ -930,7 +965,7 @@
|
|||
(and (literal? :)
|
||||
(upath? (syntax name))
|
||||
(or (identifier? (syntax sig))
|
||||
(parse-signature 'compound-unit/sig expr #f (syntax sig))))
|
||||
(parse-signature 'compound-unit/sig expr #f (syntax sig) #f)))
|
||||
#t]
|
||||
[_else
|
||||
(upath? p)]))]
|
||||
|
|
@ -959,8 +994,8 @@
|
|||
(cons base
|
||||
(map
|
||||
list
|
||||
(flatten-signature name sig)
|
||||
(flatten-signature #f sig))))
|
||||
(flatten-signature name sig #f)
|
||||
(flatten-signature #f sig #f))))
|
||||
(syntax-error
|
||||
#f expr
|
||||
"cannot export imported variables"
|
||||
|
|
@ -1028,8 +1063,9 @@
|
|||
sig
|
||||
(if (stx-null? exname)
|
||||
last
|
||||
(syntax-e (stx-car exname)))))
|
||||
(let ([flat (flatten-signature name sig)])
|
||||
(syntax-e (stx-car exname)))
|
||||
#f))
|
||||
(let ([flat (flatten-signature name sig #f)])
|
||||
(cons base
|
||||
(map
|
||||
list
|
||||
|
|
@ -1039,7 +1075,8 @@
|
|||
(if (stx-null? exname)
|
||||
last
|
||||
(syntax-e (stx-car exname))))
|
||||
sig)))))
|
||||
sig
|
||||
#f)))))
|
||||
(syntax-error
|
||||
#f expr
|
||||
"cannot export imported variables"
|
||||
|
|
@ -1072,7 +1109,7 @@
|
|||
(explode-named-sig (sig-explode-pair-sigpart sep) interned-vectors))
|
||||
(link-links link)))
|
||||
links)
|
||||
(flatten-signatures imports)
|
||||
(flatten-signatures imports #f)
|
||||
(map (lambda (link)
|
||||
(apply
|
||||
append
|
||||
|
|
@ -1083,13 +1120,15 @@
|
|||
(map sig-explode-pair-exploded exports)
|
||||
(explode-named-sigs imports interned-vectors)
|
||||
(explode-sig
|
||||
(make-signature
|
||||
'dummy
|
||||
'dummy
|
||||
(apply
|
||||
append
|
||||
(map sig-explode-pair-sigpart exports))
|
||||
null)
|
||||
(let ([elems (apply
|
||||
append
|
||||
(map sig-explode-pair-sigpart exports))])
|
||||
(make-signature
|
||||
'dummy
|
||||
'dummy
|
||||
elems
|
||||
(map (lambda (x) #f) elems)
|
||||
null))
|
||||
interned-vectors)
|
||||
interned-vectors))))))]
|
||||
[_else (raise-syntax-error
|
||||
|
|
@ -1099,7 +1138,7 @@
|
|||
|
||||
(define parse-invoke-vars
|
||||
(lambda (who rest expr)
|
||||
(parse-imports who #t #f expr rest)))
|
||||
(parse-imports who #t #f expr rest #f)))
|
||||
|
||||
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
|
|
|
|||
|
|
@ -20,7 +20,7 @@
|
|||
[(_ name sig)
|
||||
(identifier? (syntax name))
|
||||
(let ([sig (get-sig 'define-signature expr (syntax-e (syntax name))
|
||||
(syntax sig))])
|
||||
(syntax sig) #f)])
|
||||
(with-syntax ([content (explode-sig sig #f)])
|
||||
(syntax (define-syntax name
|
||||
(make-sig (quote content))))))])))
|
||||
|
|
@ -31,7 +31,7 @@
|
|||
[(_ name sig . body)
|
||||
(identifier? (syntax name))
|
||||
(let ([sig (get-sig 'let-signature expr (syntax-e (syntax name))
|
||||
(syntax sig))])
|
||||
(syntax sig) #f)])
|
||||
(with-syntax ([content (explode-sig sig #f)])
|
||||
(syntax (letrec-syntax ([name (make-sig (quote content))])
|
||||
. body))))])))
|
||||
|
|
@ -40,7 +40,7 @@
|
|||
(lambda (expr)
|
||||
(syntax-case expr ()
|
||||
[(_ sig . rest)
|
||||
(let ([sig (get-sig 'unit/sig expr #f (syntax sig))])
|
||||
(let ([sig (get-sig 'unit/sig expr #f (syntax sig) #f)])
|
||||
(let ([a-unit (parse-unit expr (syntax rest) sig
|
||||
(kernel-form-identifier-list (quote-syntax here))
|
||||
(quote-syntax define-values)
|
||||
|
|
@ -48,7 +48,7 @@
|
|||
(check-signature-unit-body sig a-unit (parsed-unit-renames a-unit) 'unit/sig expr)
|
||||
(with-syntax ([imports (datum->syntax-object
|
||||
expr
|
||||
(flatten-signatures (parsed-unit-imports a-unit))
|
||||
(flatten-signatures (parsed-unit-imports a-unit) 'must-have-ctx)
|
||||
expr)]
|
||||
[exports (datum->syntax-object
|
||||
expr
|
||||
|
|
@ -132,7 +132,7 @@
|
|||
expr)]
|
||||
[flat-sigs (datum->syntax-object
|
||||
expr
|
||||
(flatten-signatures sigs)
|
||||
(flatten-signatures sigs #f)
|
||||
expr)])
|
||||
(syntax/loc
|
||||
expr
|
||||
|
|
@ -151,9 +151,9 @@
|
|||
(syntax-case expr ()
|
||||
[(_ e (im-sig ...) ex-sig)
|
||||
(let ([im-sigs (map (lambda (sig)
|
||||
(get-sig 'unit->unit/sig expr #f sig))
|
||||
(get-sig 'unit->unit/sig expr #f sig #f))
|
||||
(syntax->list (syntax (im-sig ...))))]
|
||||
[ex-sig (get-sig 'unit->unit/sig expr #f (syntax ex-sig))])
|
||||
[ex-sig (get-sig 'unit->unit/sig expr #f (syntax ex-sig) #f)])
|
||||
(with-syntax ([exploded-imports (datum->syntax-object
|
||||
expr
|
||||
(explode-named-sigs im-sigs #f)
|
||||
|
|
@ -232,7 +232,7 @@
|
|||
(syntax-case stx ()
|
||||
[(_ name)
|
||||
(identifier? (syntax name))
|
||||
(let ([sig (get-sig 'signature->symbols stx #f (syntax name))])
|
||||
(let ([sig (get-sig 'signature->symbols stx #f (syntax name) #f)])
|
||||
(with-syntax ([e (let cleanup ([p (explode-sig sig #f)])
|
||||
;; Strip struct info:
|
||||
(list->vector
|
||||
|
|
@ -260,18 +260,18 @@
|
|||
(unless (or (not (syntax-e (syntax prefix)))
|
||||
(identifier? (syntax prefix)))
|
||||
(badsyntax (syntax prefix) "prefix is not an identifier"))
|
||||
(let ([ex-sig (get-sig formname (syntax orig) #f (syntax signame))])
|
||||
(let ([ex-sig (get-sig formname (syntax orig) #f (syntax signame) (syntax signame))])
|
||||
(let ([ex-exploded (explode-sig ex-sig #f)]
|
||||
[ex-flattened (flatten-signature #f ex-sig)])
|
||||
[ex-flattened (flatten-signature #f ex-sig #'signame)])
|
||||
(let ([im-sigs
|
||||
(parse-invoke-vars formname (syntax imports) (syntax orig))])
|
||||
(let ([im-explodeds (explode-named-sigs im-sigs #f)]
|
||||
[im-flattened (flatten-signatures im-sigs)]
|
||||
[im-flattened (flatten-signatures im-sigs #f)]
|
||||
[d->s (lambda (x) (datum->syntax-object (syntax orig) x (syntax orig)))])
|
||||
(with-syntax ([dv/iu (if (syntax-e (syntax global?))
|
||||
(quote-syntax namespace-variable-bind/invoke-unit)
|
||||
(quote-syntax define-values/invoke-unit))]
|
||||
[ex-flattened (d->s ex-flattened)]
|
||||
[ex-flattened ex-flattened]
|
||||
[ex-exploded (d->s ex-exploded)]
|
||||
[im-explodeds (d->s im-explodeds)]
|
||||
[im-flattened (d->s im-flattened)]
|
||||
|
|
@ -318,8 +318,8 @@
|
|||
(with-syntax ([orig stx])
|
||||
(syntax-case stx ()
|
||||
[(_ signame)
|
||||
(let ([sig (get-sig 'provide-signature-elements stx #f (syntax signame))])
|
||||
(let ([flattened (flatten-signature #f sig)]
|
||||
(let ([sig (get-sig 'provide-signature-elements stx #f (syntax signame) (syntax signame))])
|
||||
(let ([flattened (flatten-signature #f sig (syntax signame))]
|
||||
[structs (map struct-def-name (signature-structs sig))])
|
||||
(with-syntax ([flattened (map (lambda (x) (datum->syntax-object (syntax signame) x #f))
|
||||
(append flattened structs))])
|
||||
|
|
|
|||
|
|
@ -588,6 +588,98 @@
|
|||
(import)
|
||||
(define foo 120)))
|
||||
(eval 'foo)))
|
||||
|
||||
;; -- Macro interaction ----------------------------------------
|
||||
|
||||
(define-syntax let-values/invoke-unit/sig
|
||||
(syntax-rules ()
|
||||
[(_ (sig unit) exp ...)
|
||||
(let ()
|
||||
(define-values/invoke-unit/sig sig unit)
|
||||
(let () exp ...))]))
|
||||
|
||||
(define-signature b (y z))
|
||||
(define-signature a (x (open b)))
|
||||
(define-signature c (x (unit i : b)))
|
||||
|
||||
(define u@ (unit/sig a
|
||||
(import)
|
||||
(define x 1)
|
||||
(define y 2)
|
||||
(define z 3)))
|
||||
|
||||
(test '(1 2 3) 'macro-unitsig
|
||||
(let-values/invoke-unit/sig ((x y z) u@) (list x y z)))
|
||||
(test '(1 2 3) 'macro-unitsig
|
||||
(let-values/invoke-unit/sig ((x (open b)) u@) (list x y z)))
|
||||
|
||||
(define-syntax goo
|
||||
(syntax-rules ()
|
||||
[(_ id body)
|
||||
(let-values/invoke-unit/sig ((x id) u@) body)]))
|
||||
|
||||
(test '(0 2 0) 'macro-unitsig
|
||||
(let ([x 0][y 0][z 0])
|
||||
(goo y (list x y z))))
|
||||
|
||||
(test '(0 2 3) 'macro-unitsig
|
||||
(let ([x 0][y 0][z 0])
|
||||
(goo (open b) (list x y z))))
|
||||
|
||||
(define-syntax goow
|
||||
(syntax-rules ()
|
||||
[(_ sid body)
|
||||
(let-values/invoke-unit/sig ((x (open sid)) u@) body)]))
|
||||
|
||||
(test '(0 2 3) 'macro-unitsig
|
||||
(let ([x 0][y 0][z 0])
|
||||
(goow b (list x y z))))
|
||||
|
||||
(define t@ (compound-unit/sig
|
||||
(import)
|
||||
(link [u1 : a (u@)]
|
||||
[u2 : b (u@)])
|
||||
(export (open u1) (unit u2 i))))
|
||||
|
||||
(test '(1 2 3) 'macro-unitsig
|
||||
(let-values/invoke-unit/sig (c t@) (list x i:y i:z)))
|
||||
|
||||
(define-syntax moo
|
||||
(syntax-rules ()
|
||||
[(_ id body)
|
||||
(let-values/invoke-unit/sig ((x id) t@) body)]))
|
||||
|
||||
(test '(0 2 3) 'macro-unitsig
|
||||
(let ([x 0][i:y 0][i:z 0])
|
||||
(moo (unit i : b) (list x i:y i:z))))
|
||||
|
||||
(define-syntax moow
|
||||
(syntax-rules ()
|
||||
[(_ id body)
|
||||
(let-values/invoke-unit/sig ((x (unit i : id)) t@) body)]))
|
||||
|
||||
(test '(0 2 3) 'macro-unitsig
|
||||
(let ([x 0][i:y 0][i:z 0])
|
||||
(moow b (list x i:y i:z))))
|
||||
|
||||
(test '(0 2 3) 'macro-unitsig
|
||||
(let ([x 0][i:y 0][i:z 0])
|
||||
(moow (y z) (list x i:y i:z))))
|
||||
|
||||
(test '(0 0 3) 'macro-unitsig
|
||||
(let ([x 0][i:y 0][i:z 0])
|
||||
(moow (z) (list x i:y i:z))))
|
||||
|
||||
(define-syntax moot
|
||||
(syntax-rules ()
|
||||
[(_ id body)
|
||||
(let-values/invoke-unit/sig ((id (unit i : b)) t@) body)]))
|
||||
|
||||
(test '(1 0 0) 'macro-unitsig
|
||||
(let ([x 0][i:y 0][i:z 0])
|
||||
(moot x (list x i:y i:z))))
|
||||
|
||||
;; --------------------------------------------------
|
||||
|
||||
(report-errs)
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user