add define-values-for-export to scheme/unit; sort out different unit-signature 'struct' forms for mzlib vs. scheme vs. racket
svn: r18792 original commit: b4aa4d4afb76d2ab57a2fa8ca0ad5ad3173e466a
This commit is contained in:
Matthew Flatt
parent
07e1c1fda1
commit
b2b3c44aa4
|
|
@ -8,6 +8,7 @@
|
|||
syntax/name
|
||||
syntax/parse
|
||||
syntax/struct
|
||||
scheme/struct-info
|
||||
syntax/stx
|
||||
unstable/location
|
||||
"private/unit-contract-syntax.ss"
|
||||
|
|
@ -27,6 +28,7 @@
|
|||
(provide define-signature-form struct struct/ctc open
|
||||
define-signature provide-signature-elements
|
||||
only except rename import export prefix link tag init-depend extends contracted
|
||||
define-values-for-export
|
||||
unit?
|
||||
(rename-out [:unit unit]) define-unit
|
||||
compound-unit define-compound-unit compound-unit/infer define-compound-unit/infer
|
||||
|
|
@ -37,7 +39,8 @@
|
|||
unit/new-import-export define-unit/new-import-export
|
||||
unit/s define-unit/s
|
||||
unit/c define-unit/contract
|
||||
struct~ struct~/ctc)
|
||||
struct~s struct~s/ctc
|
||||
struct~r struct~r/ctc)
|
||||
|
||||
(define-syntax/err-param (define-signature-form stx)
|
||||
(syntax-case stx ()
|
||||
|
|
@ -132,8 +135,26 @@
|
|||
((_)
|
||||
(raise-stx-err "missing name and fields")))))
|
||||
|
||||
(begin-for-syntax
|
||||
(define-struct self-name-struct-info (id)
|
||||
#:super struct:struct-info
|
||||
#:property prop:procedure (lambda (me stx)
|
||||
(syntax-case stx ()
|
||||
[(_ arg ...) (datum->syntax
|
||||
stx
|
||||
(cons (self-name-struct-info-id me)
|
||||
#'(arg ...))
|
||||
stx
|
||||
stx)]
|
||||
[_ (let ([id (self-name-struct-info-id me)])
|
||||
(datum->syntax id
|
||||
(syntax-e id)
|
||||
stx
|
||||
stx))]))
|
||||
#:omit-define-syntaxes))
|
||||
|
||||
;; Replacement `struct' signature form for `scheme/unit':
|
||||
(define-signature-form (struct~~ stx)
|
||||
(define-for-syntax (do-struct~ stx type-as-ctr?)
|
||||
(syntax-case stx ()
|
||||
((_ name (field ...) opt ...)
|
||||
(begin
|
||||
|
|
@ -198,19 +219,30 @@
|
|||
"expected a keyword to specify option: "
|
||||
"#:mutable, #:omit-constructor, #:omit-define-syntaxes, or #:omit-define-values")
|
||||
stx
|
||||
opt)]))))])
|
||||
opt)]))))]
|
||||
[(tmp-name) (and type-as-ctr?
|
||||
(car (generate-temporaries #'(name))))])
|
||||
(cons
|
||||
#`(define-syntaxes (name)
|
||||
#,(build-struct-expand-info
|
||||
#'name (syntax->list #'(field ...))
|
||||
#f (not mutable?)
|
||||
#f '(#f) '(#f)
|
||||
#:omit-constructor? no-ctr?))
|
||||
#,(let ([e (build-struct-expand-info
|
||||
#'name (syntax->list #'(field ...))
|
||||
#f (not mutable?)
|
||||
#f '(#f) '(#f)
|
||||
#:omit-constructor? no-ctr?
|
||||
#:constructor-name (and type-as-ctr? (cons #'name tmp-name)))])
|
||||
(if type-as-ctr?
|
||||
#`(make-self-name-struct-info
|
||||
(lambda () #,e)
|
||||
(quote-syntax #,tmp-name))
|
||||
e)))
|
||||
(let ([names (build-struct-names #'name (syntax->list #'(field ...))
|
||||
#f (not mutable?))])
|
||||
(if no-ctr?
|
||||
(cons (car names) (cddr names))
|
||||
names))))))
|
||||
#f (not mutable?)
|
||||
#:constructor-name (and type-as-ctr?
|
||||
(cons #'name tmp-name)))])
|
||||
(cond
|
||||
[no-ctr? (cons (car names) (cddr names))]
|
||||
[tmp-name (cons #`(define-values-for-export (#,tmp-name) name) names)]
|
||||
[else names]))))))
|
||||
((_ name fields opt ...)
|
||||
(raise-syntax-error #f
|
||||
"bad syntax; expected a parenthesized sequence of fields"
|
||||
|
|
@ -225,6 +257,11 @@
|
|||
"missing name and fields"
|
||||
stx))))
|
||||
|
||||
(define-signature-form (struct~s stx)
|
||||
(do-struct~ stx #f))
|
||||
(define-signature-form (struct~r stx)
|
||||
(do-struct~ stx #t))
|
||||
|
||||
(define-signature-form (struct/ctc stx)
|
||||
(parameterize ((error-syntax stx))
|
||||
(syntax-case stx ()
|
||||
|
|
@ -310,7 +347,7 @@
|
|||
(raise-stx-err "missing name and fields")))))
|
||||
|
||||
;; Replacement struct/ctc form for `scheme/unit':
|
||||
(define-signature-form (struct~/ctc stx)
|
||||
(define-for-syntax (do-struct~/ctc stx type-as-ctr?)
|
||||
(syntax-case stx ()
|
||||
((_ name ([field ctc] ...) opt ...)
|
||||
(begin
|
||||
|
|
@ -375,7 +412,9 @@
|
|||
"expected a keyword to specify option: "
|
||||
"#:mutable, #:omit-constructor, #:omit-define-syntaxes, or #:omit-define-values")
|
||||
stx
|
||||
opt)]))))])
|
||||
opt)]))))]
|
||||
[(tmp-name) (and type-as-ctr?
|
||||
(car (generate-temporaries #'(name))))])
|
||||
(define (add-contracts l)
|
||||
(let* ([pred (caddr l)]
|
||||
[ctor-ctc #`(-> ctc ... #,pred)]
|
||||
|
|
@ -400,10 +439,13 @@
|
|||
#'name (syntax->list #'(field ...))
|
||||
#f (not mutable?)
|
||||
#f '(#f) '(#f)
|
||||
#:omit-constructor? no-ctr?))
|
||||
#:omit-constructor? no-ctr?
|
||||
#:constructor-name (and type-as-ctr? (cons #'name tmp-name))))
|
||||
(let* ([names (add-contracts
|
||||
(build-struct-names #'name (syntax->list #'(field ...))
|
||||
#f (not mutable?)))]
|
||||
#f (not mutable?)
|
||||
#:constructor-name (and type-as-ctr?
|
||||
(cons #'name tmp-name))))]
|
||||
[cpairs (cons 'contracted
|
||||
(if no-ctr? (cddr names) (cdr names)))])
|
||||
(list (car names) cpairs))))))
|
||||
|
|
@ -421,28 +463,47 @@
|
|||
"missing name and fields"
|
||||
stx))))
|
||||
|
||||
(define-signature-form (struct~s/ctc stx)
|
||||
(do-struct~/ctc stx #f))
|
||||
(define-signature-form (struct~r/ctc stx)
|
||||
(do-struct~/ctc stx #t))
|
||||
|
||||
;; build-val+macro-defs : sig -> (list syntax-object^3)
|
||||
(define-for-syntax (build-val+macro-defs sig)
|
||||
(with-syntax ([(((int-ivar . ext-ivar) ...)
|
||||
((((int-vid . ext-vid) ...) . vbody) ...)
|
||||
((((int-sid . ext-sid) ...) . sbody) ...)
|
||||
(cbody ...))
|
||||
_
|
||||
_)
|
||||
(map-sig (lambda (x) x)
|
||||
(make-syntax-introducer)
|
||||
sig)])
|
||||
(list
|
||||
#'((ext-ivar ... ext-vid ... ... ext-sid ... ...)
|
||||
(values
|
||||
(make-rename-transformer
|
||||
(quote-syntax int-ivar)) ...
|
||||
(make-rename-transformer
|
||||
(quote-syntax int-vid)) ... ...
|
||||
(make-rename-transformer
|
||||
(quote-syntax int-sid)) ... ...))
|
||||
(make-rename-transformer (quote-syntax int-ivar)) ...
|
||||
(make-rename-transformer (quote-syntax int-vid)) ... ...
|
||||
(make-rename-transformer (quote-syntax int-sid)) ... ...))
|
||||
#'(((int-sid ...) sbody) ...)
|
||||
#'(((int-vid ...) vbody) ...))))
|
||||
|
||||
;; build-post-val-defs : sig -> (list syntax-object)
|
||||
(define-for-syntax (build-post-val-defs sig)
|
||||
(with-syntax ([(((int-ivar . ext-ivar) ...)
|
||||
((((int-vid . ext-vid) ...) . _) ...)
|
||||
((((int-sid . ext-sid) ...) . _) ...)
|
||||
_
|
||||
(((post-id ...) . post-rhs) ...))
|
||||
(map-sig (lambda (x) x)
|
||||
(make-syntax-introducer)
|
||||
sig)])
|
||||
(list
|
||||
#'((ext-ivar ... ext-vid ... ... ext-sid ... ...)
|
||||
(values
|
||||
(make-rename-transformer (quote-syntax int-ivar)) ...
|
||||
(make-rename-transformer (quote-syntax int-vid)) ... ...
|
||||
(make-rename-transformer (quote-syntax int-sid)) ... ...))
|
||||
#'(post-rhs ...))))
|
||||
|
||||
(define-signature-form (open stx)
|
||||
(define (build-sig-elems sig)
|
||||
|
|
@ -468,7 +529,9 @@
|
|||
(_
|
||||
(raise-stx-err (format "must match (~a export-spec)"
|
||||
(syntax-e (stx-car stx))))))))
|
||||
|
||||
|
||||
(define-signature-form (define-values-for-export stx)
|
||||
(raise-syntax-error #f "internal error" stx))
|
||||
|
||||
(define-for-syntax (introduce-def d)
|
||||
(cons (map syntax-local-introduce (car d))
|
||||
|
|
@ -480,7 +543,8 @@
|
|||
(raise-stx-err "expected syntax matching (sig-expr ...)" sig-exprs))
|
||||
(let ([ses (checked-syntax->list sig-exprs)])
|
||||
(define-values (super-names super-ctimes super-rtimes super-bindings
|
||||
super-val-defs super-stx-defs super-ctcs)
|
||||
super-val-defs super-stx-defs super-post-val-defs
|
||||
super-ctcs)
|
||||
(if super-sigid
|
||||
(let* ([super-sig (lookup-signature super-sigid)]
|
||||
[super-siginfo (signature-siginfo super-sig)])
|
||||
|
|
@ -491,22 +555,25 @@
|
|||
(map syntax-local-introduce (signature-vars super-sig))
|
||||
(map introduce-def (signature-val-defs super-sig))
|
||||
(map introduce-def (signature-stx-defs super-sig))
|
||||
(map introduce-def (signature-post-val-defs super-sig))
|
||||
(map (lambda (ctc)
|
||||
(if ctc
|
||||
(syntax-local-introduce ctc)
|
||||
ctc))
|
||||
(signature-ctcs super-sig))))
|
||||
(values '() '() '() '() '() '() '())))
|
||||
(values '() '() '() '() '() '() '() '())))
|
||||
(let loop ((sig-exprs ses)
|
||||
(bindings null)
|
||||
(val-defs null)
|
||||
(stx-defs null)
|
||||
(post-val-defs null)
|
||||
(ctcs null))
|
||||
(cond
|
||||
((null? sig-exprs)
|
||||
(let* ([all-bindings (append super-bindings (reverse bindings))]
|
||||
[all-val-defs (append super-val-defs (reverse val-defs))]
|
||||
[all-stx-defs (append super-stx-defs (reverse stx-defs))]
|
||||
[all-post-val-defs (append super-post-val-defs (reverse post-val-defs))]
|
||||
[all-ctcs (append super-ctcs (reverse ctcs))]
|
||||
[dup
|
||||
(check-duplicate-identifier
|
||||
|
|
@ -520,7 +587,8 @@
|
|||
((var ...) all-bindings)
|
||||
((ctc ...) all-ctcs)
|
||||
((((vid ...) . vbody) ...) all-val-defs)
|
||||
((((sid ...) . sbody) ...) all-stx-defs))
|
||||
((((sid ...) . sbody) ...) all-stx-defs)
|
||||
((((pvid ...) . pvbody) ...) all-post-val-defs))
|
||||
#`(begin
|
||||
(define signature-tag (gensym))
|
||||
(define-syntax #,sigid
|
||||
|
|
@ -539,6 +607,10 @@
|
|||
((syntax-local-certifier)
|
||||
(quote-syntax sbody)))
|
||||
...)
|
||||
(list (cons (list (quote-syntax pvid) ...)
|
||||
((syntax-local-certifier)
|
||||
(quote-syntax pvbody)))
|
||||
...)
|
||||
(list #,@(map (lambda (c)
|
||||
(if c
|
||||
#`((syntax-local-certifier)
|
||||
|
|
@ -558,7 +630,7 @@
|
|||
(syntax-case (car sig-exprs) (define-values define-syntaxes contracted)
|
||||
(x
|
||||
(identifier? #'x)
|
||||
(loop (cdr sig-exprs) (cons #'x bindings) val-defs stx-defs (cons #f ctcs)))
|
||||
(loop (cdr sig-exprs) (cons #'x bindings) val-defs stx-defs post-val-defs (cons #f ctcs)))
|
||||
((x (y z) ...)
|
||||
(and (identifier? #'x)
|
||||
(free-identifier=? #'x #'contracted)
|
||||
|
|
@ -567,6 +639,7 @@
|
|||
(append (syntax->list #'(y ...)) bindings)
|
||||
val-defs
|
||||
stx-defs
|
||||
post-val-defs
|
||||
(append (syntax->list #'(z ...)) ctcs)))
|
||||
((x . z)
|
||||
(and (identifier? #'x)
|
||||
|
|
@ -578,7 +651,8 @@
|
|||
((x . y)
|
||||
(and (identifier? #'x)
|
||||
(or (free-identifier=? #'x #'define-values)
|
||||
(free-identifier=? #'x #'define-syntaxes)))
|
||||
(free-identifier=? #'x #'define-syntaxes)
|
||||
(free-identifier=? #'x #'define-values-for-export)))
|
||||
(begin
|
||||
(check-def-syntax (car sig-exprs))
|
||||
(syntax-case #'y ()
|
||||
|
|
@ -597,14 +671,18 @@
|
|||
(cons (cons (syntax->list #'(name ...)) b)
|
||||
stx-defs)
|
||||
stx-defs)
|
||||
(if (free-identifier=? #'x #'define-values-for-export)
|
||||
(cons (cons (syntax->list #'(name ...)) b)
|
||||
post-val-defs)
|
||||
post-val-defs)
|
||||
ctcs)))))))
|
||||
((x . y)
|
||||
(let ((trans
|
||||
(set!-trans-extract
|
||||
(syntax-local-value
|
||||
;; redirect struct~ to struct~~
|
||||
;; redirect struct~ to struct~r
|
||||
(if (free-identifier=? #'x #'struct~)
|
||||
#'struct~~
|
||||
#'struct~r
|
||||
(syntax-local-introduce #'x))
|
||||
(lambda ()
|
||||
(raise-stx-err "unknown signature form" #'x))))))
|
||||
|
|
@ -619,6 +697,7 @@
|
|||
bindings
|
||||
val-defs
|
||||
stx-defs
|
||||
post-val-defs
|
||||
ctcs))))
|
||||
(x (raise-stx-err
|
||||
"expected either an identifier or signature form"
|
||||
|
|
@ -742,6 +821,8 @@
|
|||
(map build-val+macro-defs import-sigs)]
|
||||
[(((int-ivar . ext-ivar) ...) ...) (map car import-sigs)]
|
||||
[(((int-evar . ext-evar) ...) ...) (map car export-sigs)]
|
||||
[((((e-post-id ...) . _) ...) ...) (map (lambda (s) (list-ref s 4)) export-sigs)]
|
||||
[((post-renames (e-post-rhs ...)) ...) (map build-post-val-defs export-sigs)]
|
||||
[((iloc ...) ...)
|
||||
(map (lambda (x) (generate-temporaries (car x))) import-sigs)]
|
||||
[((eloc ...) ...)
|
||||
|
|
@ -812,7 +893,10 @@
|
|||
(int-evar ... ...)
|
||||
(eloc ... ...)
|
||||
(ectc ... ...)
|
||||
. body)))))
|
||||
(begin . body)
|
||||
(define-values (e-post-id ...)
|
||||
(letrec-syntaxes+values (post-renames ...) ()
|
||||
e-post-rhs)) ... ...)))))
|
||||
(unit-export ((export-key ...) (vector-immutable (λ () (unbox eloc)) ...)) ...)))))))
|
||||
import-tagged-sigids
|
||||
export-tagged-sigids
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user