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 (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

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.}
@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.}

148
collects/mzlib/unit.ss
View File

@ -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

11
collects/racket/main.ss
View File

@ -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)

7
collects/scheme/unit.ss
View File

@ -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])))

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.}
@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.

54
collects/syntax/struct.ss
View File

@ -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?))]))