diff --git a/collects/mzlib/unit.ss b/collects/mzlib/unit.ss
index b1ae2bf..5a0d8b5 100644
--- a/collects/mzlib/unit.ss
+++ b/collects/mzlib/unit.ss
@@ -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