suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

add define-values-for-export to scheme/unit; sort out different unit-signature 'struct' forms for mzlib vs. scheme vs. racket

Browse Source 
svn: r18792
This commit is contained in:
Matthew Flatt 2010-04-12 13:54:40 +00:00
parent 3f903c80cf
commit b4aa4d4afb
7 changed files with 191 additions and 69 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

12
collects/mzlib/private/unit-compiletime.ss
View File

@ -103,9 +103,10 @@
;; (listof identifier) ;; (listof identifier)
;; (listof (cons (listof identifier) syntax-object)) ;; (listof (cons (listof identifier) syntax-object))
;; (listof (cons (listof identifier) syntax-object)) ;; (listof (cons (listof identifier) syntax-object))
;; (listof (cons (listof identifier) syntax-object))
;; (listof (U syntax-object #f)) ;; (listof (U syntax-object #f))
;; identifier) ;; 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) (lambda (_ stx)
(parameterize ((error-syntax stx)) (parameterize ((error-syntax stx))
(raise-stx-err "illegal use of signature name")))) (raise-stx-err "illegal use of signature name"))))
@ -233,6 +234,7 @@
(vars (signature-vars sig)) (vars (signature-vars sig))
(vals (signature-val-defs sig)) (vals (signature-val-defs sig))
(stxs (signature-stx-defs sig)) (stxs (signature-stx-defs sig))
(p-vals (signature-post-val-defs sig))
(ctcs (signature-ctcs sig)) (ctcs (signature-ctcs sig))
(delta-introduce (if bind? (delta-introduce (if bind?
(let ([f (syntax-local-make-delta-introducer (let ([f (syntax-local-make-delta-introducer
@ -259,7 +261,8 @@
(car stx)) (car stx))
(cdr stx))) (cdr stx)))
stxs) stxs)
ctcs)))) ctcs
p-vals))))
(define (sig-names sig) (define (sig-names sig)
(append (car sig) (append (car sig)
@ -292,7 +295,10 @@
(list (map (lambda (x) (cons (f (car x)) (g (cdr x)))) (car sig)) (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)) (cadr sig))
(map (lambda (x) (map-def f g x)) (caddr 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 ;; An import-spec is one of
;; - signature-name ;; - signature-name

13
collects/mzlib/scribblings/unit.scrbl
View File

@ -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.} but with a different syntax for the options that limit exports.}
@deftogether[( @deftogether[(
@defidform[struct~] @defidform[struct~s]
@defidform[struct~/ctc] @defidform[struct~s/ctc]
)]{ )]{
The same as @|scheme-struct| and @|scheme-struct/ctc| from The same as @|scheme-struct| and @|scheme-struct/ctc| from
@schememodname[scheme/unit].} @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.}

146
collects/mzlib/unit.ss
View File

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

11
collects/racket/main.ss
View File

@ -1,7 +1,8 @@
#lang racket/private #lang racket/private
(require scheme) (require (except-in scheme struct struct/ctc)
(only-in mzlib/unit struct~r/ctc)
;; scheme includes `struct' via scheme/unit "private/struct.rkt")
(provide (all-from-out scheme))
(provide (all-from-out scheme)
(rename-out [struct~r/ctc struct/ctc])
struct)

7
collects/scheme/unit.ss
View File

@ -5,7 +5,8 @@
(for-syntax scheme/base (for-syntax scheme/base
syntax/struct)) syntax/struct))
(provide (except-out (all-from-out mzlib/unit) (provide (except-out (all-from-out mzlib/unit)
struct struct/ctc) struct struct/ctc
(rename-out [struct~ struct] struct~r struct~r/ctc)
[struct~/ctc struct/ctc]))) (rename-out [struct~s struct]
[struct~s/ctc struct/ctc])))

15
collects/scribblings/reference/units.scrbl
View File

@ -152,7 +152,7 @@ the corresponding import. Each @scheme[tagged-sig-id] in an
@scheme[import] clause.} @scheme[import] clause.}
@defform/subs[ @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 (define-signature id extension-decl
(sig-elem ...)) (sig-elem ...))
@ -163,7 +163,8 @@ the corresponding import. Each @scheme[tagged-sig-id] in an
[sig-elem [sig-elem
id id
(define-syntaxes (id ...) expr) (define-syntaxes (id ...) expr)
(define-values (value-id ...) expr) (define-values (id ...) expr)
(define-values-for-export (id ...) expr)
(contracted [id contract] ...) (contracted [id contract] ...)
(open sig-spec) (open sig-spec)
(sig-form-id . datum)])]{ (sig-form-id . datum)])]{
@ -191,6 +192,11 @@ of bindings for import or export:
signature. Free variables in the definition's @scheme[expr] are signature. Free variables in the definition's @scheme[expr] are
treated the same as for @scheme[define-syntaxes].} 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 @item{Each @scheme[contracted] form in a signature declaration means
that a unit exporting the signature must supply a variable definition that a unit exporting the signature must supply a variable definition
for each @scheme[id] in that form. If the signature is imported, then 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.} signature can be used as an implementation of the extended signature.}
@defkeywords[[(open sig-spec) _sig-elem define-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] [(contracted [id contract] ...) _sig-elem define-signature]
[(only sig-spec id ...) _sig-spec unit] [(only sig-spec id ...) _sig-spec unit]
[(except 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]{ @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*[ @defform*[
[(define-signature-form sig-form-id expr) [(define-signature-form sig-form-id expr)
(define-signature-form (sig-form-id id) body ...+)] (define-signature-form (sig-form-id id) body ...+)]
] ]{
Binds @scheme[sig-form-id] for use within a @scheme[define-signature] Binds @scheme[sig-form-id] for use within a @scheme[define-signature]
form. form.

54
collects/syntax/struct.ss
View File

@ -2,7 +2,7 @@
(module struct scheme/base (module struct scheme/base
(require (for-syntax scheme/base) (require (for-syntax scheme/base)
mzlib/etc mzlib/etc
mzlib/contract scheme/contract
"stx.ss" "stx.ss"
scheme/struct-info) scheme/struct-info)
(require (for-template mzscheme)) (require (for-template mzscheme))
@ -93,16 +93,23 @@
;; build-struct-names : id (list-of id) bool bool -> (list-of id) ;; build-struct-names : id (list-of id) bool bool -> (list-of id)
(define build-struct-names (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))] (let ([name (symbol->string (syntax-e name-stx))]
[fields (map symbol->string (map syntax-e fields))] [fields (map symbol->string (map syntax-e fields))]
[+ string-append]) [+ string-append])
(map (lambda (s) (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 (append
(list (list
(+ "struct:" name) (+ "struct:" name)
(+ "make-" name) (if ctr-name
(if (pair? ctr-name)
(cdr ctr-name)
ctr-name)
(+ "make-" name))
(+ name "?")) (+ name "?"))
(let loop ([l fields]) (let loop ([l fields])
(if (null? l) (if (null? l)
@ -117,15 +124,17 @@
(loop (cdr l)))))))))) (loop (cdr l))))))))))
(define build-struct-generation (define build-struct-generation
(opt-lambda (name-stx fields omit-sel? omit-set? [super-type #f] [prop-value-list null] (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)]) [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?)]) #: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 (build-struct-generation* names name-stx fields omit-sel? omit-set? super-type prop-value-list
immutable-positions mk-rec-prop-list)))) immutable-positions mk-rec-prop-list))))
(define build-struct-generation* (define build-struct-generation*
(opt-lambda (names name fields omit-sel? omit-set? [super-type #f] [prop-value-list 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)]) [immutable-positions null] [mk-rec-prop-list (lambda (struct: make- ? acc mut) null)])
(let ([num-fields (length fields)] (let ([num-fields (length fields)]
[acc/mut-makers (let loop ([l fields][n 0]) [acc/mut-makers (let loop ([l fields][n 0])
(if (null? l) (if (null? l)
@ -158,8 +167,10 @@
(define build-struct-expand-info (define build-struct-expand-info
(lambda (name-stx fields omit-sel? omit-set? base-name base-getters base-setters (lambda (name-stx fields omit-sel? omit-set? base-name base-getters base-setters
#:omit-constructor? [no-ctr? #f]) #:omit-constructor? [no-ctr? #f]
(let* ([names (build-struct-names name-stx fields omit-sel? omit-set?)] #: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? [names (if no-ctr?
(list* (car names) (list* (car names)
#f #f
@ -304,12 +315,14 @@
(loop (cdr field-names) (add1 n)))))))) (loop (cdr field-names) (add1 n))))))))
(define generate-struct-declaration (define generate-struct-declaration
(opt-lambda (orig-stx (lambda (orig-stx
name super-id field-names name super-id field-names
context context
make-make-struct-type make-make-struct-type
[no-sel? #f] [no-set? #f]) [no-sel? #f] [no-set? #f]
(let ([defined-names (build-struct-names name field-names no-sel? no-set? name)]) #: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-values ([(super-info stx-info) (get-stx-info orig-stx super-id defined-names)])
(let ([result (let ([result
#`(begin #`(begin
@ -326,6 +339,7 @@
(provide/contract (provide/contract
[build-struct-names [build-struct-names
(opt-> (identifier? (listof identifier?) boolean? boolean?) (->* (identifier? (listof identifier?) boolean? boolean?)
((union false/c syntax?)) ((or/c #f syntax?)
(listof identifier?))])) #:constructor-name (or/c #f identifier? (cons/c identifier? identifier?)))
(listof identifier?))]))