From b4aa4d4afb76d2ab57a2fa8ca0ad5ad3173e466a Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 12 Apr 2010 13:54:40 +0000 Subject: [PATCH] add define-values-for-export to scheme/unit; sort out different unit-signature 'struct' forms for mzlib vs. scheme vs. racket svn: r18792 --- collects/mzlib/private/unit-compiletime.ss | 12 +- collects/mzlib/scribblings/unit.scrbl | 13 +- collects/mzlib/unit.ss | 148 ++++++++++++++++----- collects/racket/main.ss | 11 +- collects/scheme/unit.ss | 7 +- collects/scribblings/reference/units.scrbl | 15 ++- collects/syntax/struct.ss | 54 +++++--- 7 files changed, 191 insertions(+), 69 deletions(-) diff --git a/collects/mzlib/private/unit-compiletime.ss b/collects/mzlib/private/unit-compiletime.ss index 5050851d67..f0c2630dc1 100644 --- a/collects/mzlib/private/unit-compiletime.ss +++ b/collects/mzlib/private/unit-compiletime.ss @@ -103,9 +103,10 @@ ;; (listof identifier) ;; (listof (cons (listof identifier) syntax-object)) ;; (listof (cons (listof identifier) syntax-object)) +;; (listof (cons (listof identifier) syntax-object)) ;; (listof (U syntax-object #f)) ;; identifier) -(define-struct/proc signature (siginfo vars val-defs stx-defs ctcs orig-binder) +(define-struct/proc signature (siginfo vars val-defs stx-defs post-val-defs ctcs orig-binder) (lambda (_ stx) (parameterize ((error-syntax stx)) (raise-stx-err "illegal use of signature name")))) @@ -233,6 +234,7 @@ (vars (signature-vars sig)) (vals (signature-val-defs sig)) (stxs (signature-stx-defs sig)) + (p-vals (signature-post-val-defs sig)) (ctcs (signature-ctcs sig)) (delta-introduce (if bind? (let ([f (syntax-local-make-delta-introducer @@ -259,7 +261,8 @@ (car stx)) (cdr stx))) stxs) - ctcs)))) + ctcs + p-vals)))) (define (sig-names sig) (append (car sig) @@ -292,7 +295,10 @@ (list (map (lambda (x) (cons (f (car x)) (g (cdr x)))) (car sig)) (map (lambda (x) (map-def f g x)) (cadr sig)) (map (lambda (x) (map-def f g x)) (caddr sig)) - (map (lambda (x) (map-ctc f g x)) (cadddr sig)))) + (map (lambda (x) (map-ctc f g x)) (cadddr sig)) + (map (lambda (x) (cons (map f (car x)) + (g (cdr x)))) + (list-ref sig 4)))) ;; An import-spec is one of ;; - signature-name diff --git a/collects/mzlib/scribblings/unit.scrbl b/collects/mzlib/scribblings/unit.scrbl index 2ff9e97ac9..e71b6305c6 100644 --- a/collects/mzlib/scribblings/unit.scrbl +++ b/collects/mzlib/scribblings/unit.scrbl @@ -39,10 +39,19 @@ A signature form like @scheme-struct/ctc from @schememodname[scheme/unit], but with a different syntax for the options that limit exports.} @deftogether[( -@defidform[struct~] -@defidform[struct~/ctc] +@defidform[struct~s] +@defidform[struct~s/ctc] )]{ The same as @|scheme-struct| and @|scheme-struct/ctc| from @schememodname[scheme/unit].} +@deftogether[( +@defidform[struct~r] +@defidform[struct~r/ctc] +)]{ + +Like @scheme[struct~s] and @scheme[struct~s/ctc], but the constructor is +named the same as the type, instead of with @schemeidfont{make-} prefix.} + + diff --git a/collects/mzlib/unit.ss b/collects/mzlib/unit.ss index b1ae2bfe81..5a0d8b5696 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 diff --git a/collects/racket/main.ss b/collects/racket/main.ss index b21974f826..2eccc36ade 100644 --- a/collects/racket/main.ss +++ b/collects/racket/main.ss @@ -1,7 +1,8 @@ #lang racket/private -(require scheme) - -;; scheme includes `struct' via scheme/unit - -(provide (all-from-out scheme)) +(require (except-in scheme struct struct/ctc) + (only-in mzlib/unit struct~r/ctc) + "private/struct.rkt") +(provide (all-from-out scheme) + (rename-out [struct~r/ctc struct/ctc]) + struct) diff --git a/collects/scheme/unit.ss b/collects/scheme/unit.ss index d816a20624..342b5812c7 100644 --- a/collects/scheme/unit.ss +++ b/collects/scheme/unit.ss @@ -5,7 +5,8 @@ (for-syntax scheme/base syntax/struct)) (provide (except-out (all-from-out mzlib/unit) - struct struct/ctc) - (rename-out [struct~ struct] - [struct~/ctc struct/ctc]))) + struct struct/ctc + struct~r struct~r/ctc) + (rename-out [struct~s struct] + [struct~s/ctc struct/ctc]))) diff --git a/collects/scribblings/reference/units.scrbl b/collects/scribblings/reference/units.scrbl index bb634c154c..0a893ac303 100644 --- a/collects/scribblings/reference/units.scrbl +++ b/collects/scribblings/reference/units.scrbl @@ -152,7 +152,7 @@ the corresponding import. Each @scheme[tagged-sig-id] in an @scheme[import] clause.} @defform/subs[ -#:literals (define-syntaxes define-values open extends contracted) +#:literals (define-syntaxes define-values define-values-for-export open extends contracted) (define-signature id extension-decl (sig-elem ...)) @@ -163,7 +163,8 @@ the corresponding import. Each @scheme[tagged-sig-id] in an [sig-elem id (define-syntaxes (id ...) expr) - (define-values (value-id ...) expr) + (define-values (id ...) expr) + (define-values-for-export (id ...) expr) (contracted [id contract] ...) (open sig-spec) (sig-form-id . datum)])]{ @@ -191,6 +192,11 @@ of bindings for import or export: signature. Free variables in the definition's @scheme[expr] are treated the same as for @scheme[define-syntaxes].} + @item{Each @scheme[define-values-for-export] form in a signature + declaration introduces code that effectively suffixes every unit that + exports the signature. Free variables in the definition's + @scheme[expr] are treated the same as for @scheme[define-syntaxes].} + @item{Each @scheme[contracted] form in a signature declaration means that a unit exporting the signature must supply a variable definition for each @scheme[id] in that form. If the signature is imported, then @@ -218,6 +224,7 @@ the extended signature. Furthermore, any implementation of the new signature can be used as an implementation of the extended signature.} @defkeywords[[(open sig-spec) _sig-elem define-signature] + [(define-values-for-export (id ...) expr) _sig-elem define-signature] [(contracted [id contract] ...) _sig-elem define-signature] [(only sig-spec id ...) _sig-spec unit] [(except sig-spec id ...) _sig-spec unit] @@ -232,7 +239,7 @@ signature can be used as an implementation of the extended signature.} @defidform[extends]{ -This form is allowed only within @scheme[define-signature].} +Allowed only within @scheme[define-signature].} @; ------------------------------------------------------------------------ @@ -618,7 +625,7 @@ like @scheme[define-unit].} @defform*[ [(define-signature-form sig-form-id expr) (define-signature-form (sig-form-id id) body ...+)] -] +]{ Binds @scheme[sig-form-id] for use within a @scheme[define-signature] form. diff --git a/collects/syntax/struct.ss b/collects/syntax/struct.ss index 6fb7b5e5e3..10d8875764 100644 --- a/collects/syntax/struct.ss +++ b/collects/syntax/struct.ss @@ -2,7 +2,7 @@ (module struct scheme/base (require (for-syntax scheme/base) mzlib/etc - mzlib/contract + scheme/contract "stx.ss" scheme/struct-info) (require (for-template mzscheme)) @@ -93,16 +93,23 @@ ;; build-struct-names : id (list-of id) bool bool -> (list-of id) (define build-struct-names - (opt-lambda (name-stx fields omit-sel? omit-set? [srcloc-stx #f]) + (lambda (name-stx fields omit-sel? omit-set? [srcloc-stx #f] + #:constructor-name [ctr-name #f]) (let ([name (symbol->string (syntax-e name-stx))] [fields (map symbol->string (map syntax-e fields))] [+ string-append]) (map (lambda (s) - (datum->syntax name-stx (string->symbol s) srcloc-stx)) + (if (string? s) + (datum->syntax name-stx (string->symbol s) srcloc-stx) + s)) (append (list (+ "struct:" name) - (+ "make-" name) + (if ctr-name + (if (pair? ctr-name) + (cdr ctr-name) + ctr-name) + (+ "make-" name)) (+ name "?")) (let loop ([l fields]) (if (null? l) @@ -117,15 +124,17 @@ (loop (cdr l)))))))))) (define build-struct-generation - (opt-lambda (name-stx fields omit-sel? omit-set? [super-type #f] [prop-value-list null] - [immutable-positions null] [mk-rec-prop-list (lambda (struct: make- ? acc mut) null)]) - (let ([names (build-struct-names name-stx fields omit-sel? omit-set?)]) + (lambda (name-stx fields omit-sel? omit-set? [super-type #f] [prop-value-list null] + [immutable-positions null] [mk-rec-prop-list (lambda (struct: make- ? acc mut) null)] + #:constructor-name [ctr-name #f]) + (let ([names (build-struct-names name-stx fields omit-sel? omit-set? + #:constructor-name ctr-name)]) (build-struct-generation* names name-stx fields omit-sel? omit-set? super-type prop-value-list immutable-positions mk-rec-prop-list)))) (define build-struct-generation* - (opt-lambda (names name fields omit-sel? omit-set? [super-type #f] [prop-value-list null] - [immutable-positions null] [mk-rec-prop-list (lambda (struct: make- ? acc mut) null)]) + (lambda (names name fields omit-sel? omit-set? [super-type #f] [prop-value-list null] + [immutable-positions null] [mk-rec-prop-list (lambda (struct: make- ? acc mut) null)]) (let ([num-fields (length fields)] [acc/mut-makers (let loop ([l fields][n 0]) (if (null? l) @@ -158,8 +167,10 @@ (define build-struct-expand-info (lambda (name-stx fields omit-sel? omit-set? base-name base-getters base-setters - #:omit-constructor? [no-ctr? #f]) - (let* ([names (build-struct-names name-stx fields omit-sel? omit-set?)] + #:omit-constructor? [no-ctr? #f] + #:constructor-name [ctr-name #f]) + (let* ([names (build-struct-names name-stx fields omit-sel? omit-set? + #:constructor-name ctr-name)] [names (if no-ctr? (list* (car names) #f @@ -304,12 +315,14 @@ (loop (cdr field-names) (add1 n)))))))) (define generate-struct-declaration - (opt-lambda (orig-stx - name super-id field-names - context - make-make-struct-type - [no-sel? #f] [no-set? #f]) - (let ([defined-names (build-struct-names name field-names no-sel? no-set? name)]) + (lambda (orig-stx + name super-id field-names + context + make-make-struct-type + [no-sel? #f] [no-set? #f] + #:constructor-name [ctr-name #f]) + (let ([defined-names (build-struct-names name field-names no-sel? no-set? name + #:constructor-name ctr-name)]) (let-values ([(super-info stx-info) (get-stx-info orig-stx super-id defined-names)]) (let ([result #`(begin @@ -326,6 +339,7 @@ (provide/contract [build-struct-names - (opt-> (identifier? (listof identifier?) boolean? boolean?) - ((union false/c syntax?)) - (listof identifier?))])) + (->* (identifier? (listof identifier?) boolean? boolean?) + ((or/c #f syntax?) + #:constructor-name (or/c #f identifier? (cons/c identifier? identifier?))) + (listof identifier?))]))