suzanne.soy/compatibility
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

original commit: b4aa4d4afb76d2ab57a2fa8ca0ad5ad3173e466a
This commit is contained in:
Matthew Flatt 2010-04-12 13:54:40 +00:00
parent 07e1c1fda1
commit b2b3c44aa4
1 changed files with 116 additions and 32 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

148
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)
@ -468,7 +529,9 @@
(_ (_
(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