sync to trunk
svn: r13609 original commit: 738b8311afd40047e22fcf0181e34cef541e7ece
This commit is contained in:
Sam Tobin-Hochstadt
parent
a434af8f5d
commit
fa74471fad
|
|
@ -1,11 +1,13 @@
|
|||
(module unit mzscheme
|
||||
(require-for-syntax mzlib/list
|
||||
stxclass
|
||||
syntax/boundmap
|
||||
syntax/context
|
||||
syntax/kerncase
|
||||
syntax/name
|
||||
syntax/struct
|
||||
syntax/stx
|
||||
"private/unit-contract-syntax.ss"
|
||||
"private/unit-compiletime.ss"
|
||||
"private/unit-syntax.ss")
|
||||
|
||||
|
|
@ -20,14 +22,15 @@
|
|||
(provide define-signature-form struct open
|
||||
define-signature provide-signature-elements
|
||||
only except rename import export prefix link tag init-depend extends contracted
|
||||
unit? (all-from "private/unit-contract.ss")
|
||||
unit?
|
||||
(rename :unit unit) define-unit
|
||||
compound-unit define-compound-unit compound-unit/infer define-compound-unit/infer
|
||||
invoke-unit define-values/invoke-unit
|
||||
invoke-unit/infer define-values/invoke-unit/infer
|
||||
unit-from-context define-unit-from-context
|
||||
define-unit-binding
|
||||
unit/new-import-export define-unit/new-import-export)
|
||||
unit/new-import-export define-unit/new-import-export
|
||||
unit/c define-unit/contract)
|
||||
|
||||
(define-syntax/err-param (define-signature-form stx)
|
||||
(syntax-case stx ()
|
||||
|
|
@ -1148,10 +1151,19 @@
|
|||
(dup (check-duplicate-identifier (apply append (map sig-int-names out-sigs))))
|
||||
(out-vec (generate-temporaries out-sigs))
|
||||
(tmarker (make-syntax-introducer))
|
||||
(vmarker (make-syntax-introducer))
|
||||
(tmp-bindings (map (λ (s) (map tmarker (map car (car s)))) out-sigs)))
|
||||
(tmp-bindings (map (λ (s) (map tmarker (map car (car s)))) out-sigs))
|
||||
(def-table (make-bound-identifier-mapping)))
|
||||
(when dup
|
||||
(raise-stx-err (format "duplicate binding for ~e" (syntax-e dup))))
|
||||
(for-each
|
||||
(λ (sig new-xs)
|
||||
(for-each
|
||||
(λ (old new)
|
||||
(bound-identifier-mapping-put! def-table old new))
|
||||
(map car (car sig))
|
||||
new-xs))
|
||||
out-sigs
|
||||
tmp-bindings)
|
||||
(with-syntax ((((key1 key ...) ...) (map tagged-info->keys out-tags))
|
||||
((((int-binding . ext-binding) ...) ...) (map car out-sigs))
|
||||
((out-vec ...) out-vec)
|
||||
|
|
@ -1164,34 +1176,26 @@
|
|||
(map (lambda (info) (car (siginfo-names (cdr info))))
|
||||
out-tags))
|
||||
(((tmp-binding ...) ...) tmp-bindings)
|
||||
(((val-binding ...) ...) (map (λ (s) (map vmarker (map car (car s)))) out-sigs))
|
||||
(((out-code ...) ...)
|
||||
(map
|
||||
(lambda (os ov)
|
||||
(map
|
||||
(lambda (i)
|
||||
#`((car (vector-ref #,ov #,i))))
|
||||
#`(vector-ref #,ov #,i))
|
||||
(iota (length (car os)))))
|
||||
out-sigs
|
||||
out-vec))
|
||||
(((val-code ...) ...)
|
||||
(map (λ (tbs os)
|
||||
(map (λ (tb c)
|
||||
(if c
|
||||
#`(car #,tb)
|
||||
tb))
|
||||
tbs
|
||||
(cadddr os)))
|
||||
tmp-bindings
|
||||
out-sigs))
|
||||
(((wrap-code ...) ...)
|
||||
(map (λ (os ov tbs)
|
||||
(define rename-bindings
|
||||
(get-member-bindings def-table os #'(#%variable-reference)))
|
||||
(map (λ (tb i v c)
|
||||
(if c
|
||||
#`(contract #,(vmarker c) (car #,tb) (cdr #,tb)
|
||||
(current-contract-region)
|
||||
#,(id->contract-src-info v))
|
||||
tb))
|
||||
#`(let ([v/c ((car #,tb))])
|
||||
#,(if c
|
||||
#`(contract (letrec-syntax #,rename-bindings #,c) (car v/c) (cdr v/c)
|
||||
(current-contract-region)
|
||||
#,(id->contract-src-info v))
|
||||
#'v/c)))
|
||||
tbs
|
||||
(iota (length (car os)))
|
||||
(map car (car os))
|
||||
|
|
@ -1215,8 +1219,6 @@
|
|||
(let ([out-vec (hash-table-get export-table key1)] ...)
|
||||
(unit-fn #f)
|
||||
(values out-code ... ...))))))
|
||||
(define-values (val-binding ... ...)
|
||||
(values val-code ... ...))
|
||||
(define-values (int-binding ... ...)
|
||||
(values wrap-code ... ...))
|
||||
(define-syntaxes . renames) ...
|
||||
|
|
@ -1264,32 +1266,38 @@
|
|||
|
||||
|
||||
|
||||
(define-for-syntax (build-define-unit-helper contracted?)
|
||||
(lambda (stx build err-msg)
|
||||
(syntax-case stx ()
|
||||
((_ name . rest)
|
||||
(begin
|
||||
(check-id #'name)
|
||||
(let-values (((exp i e d) (parameterize ([error-syntax (syntax-property (error-syntax) 'inferred-name (syntax-e #'name))])
|
||||
(build #'rest ))))
|
||||
(with-syntax ((((itag . isig) ...) i)
|
||||
(((etag . esig) ...) e)
|
||||
(((deptag . depsig) ...) d)
|
||||
(contracted? contracted?))
|
||||
(quasisyntax/loc (error-syntax)
|
||||
(begin
|
||||
(define u #,exp)
|
||||
(define-syntax name
|
||||
(make-set!-transformer
|
||||
(make-unit-info ((syntax-local-certifier) (quote-syntax u))
|
||||
(list (cons 'itag (quote-syntax isig)) ...)
|
||||
(list (cons 'etag (quote-syntax esig)) ...)
|
||||
(list (cons 'deptag (quote-syntax deptag)) ...)
|
||||
(quote-syntax name)
|
||||
contracted?)))))))))
|
||||
((_)
|
||||
(raise-stx-err err-msg)))))
|
||||
|
||||
;; build-define-unit : syntax-object
|
||||
;; (syntax-object -> (values syntax-object (listof identifier) (listof identifier))
|
||||
;; string ->
|
||||
;; syntax-object
|
||||
(define-for-syntax (build-define-unit stx build err-msg)
|
||||
(syntax-case stx ()
|
||||
((_ name . rest)
|
||||
(begin
|
||||
(check-id #'name)
|
||||
(let-values (((exp i e d) (parameterize ([error-syntax (syntax-property (error-syntax) 'inferred-name (syntax-e #'name))])
|
||||
(build #'rest ))))
|
||||
(with-syntax ((((itag . isig) ...) i)
|
||||
(((etag . esig) ...) e)
|
||||
(((deptag . depsig) ...) d))
|
||||
(quasisyntax/loc (error-syntax)
|
||||
(begin
|
||||
(define u #,exp)
|
||||
(define-syntax name
|
||||
(make-set!-transformer
|
||||
(make-unit-info ((syntax-local-certifier) (quote-syntax u))
|
||||
(list (cons 'itag (quote-syntax isig)) ...)
|
||||
(list (cons 'etag (quote-syntax esig)) ...)
|
||||
(list (cons 'deptag (quote-syntax deptag)) ...)
|
||||
(quote-syntax name))))))))))
|
||||
((_)
|
||||
(raise-stx-err err-msg))))
|
||||
(define-for-syntax build-define-unit (build-define-unit-helper #f))
|
||||
(define-for-syntax build-define-unit/contracted (build-define-unit-helper #t))
|
||||
|
||||
(define-for-syntax (build-define-unit-binding stx)
|
||||
|
||||
|
|
@ -1360,6 +1368,46 @@
|
|||
(check-ufc-syntax sig)
|
||||
(build-unit-from-context sig))
|
||||
"missing unit name and signature"))
|
||||
|
||||
(define-for-syntax (build-unit/contract stx)
|
||||
(syntax-parse stx
|
||||
[(:import-clause/contract :export-clause/contract dep:dep-clause . body)
|
||||
(let-values ([(exp isigs esigs deps)
|
||||
(build-unit
|
||||
(check-unit-syntax
|
||||
(syntax/loc stx
|
||||
((import i.s ...) (export e.s ...) dep . body))))])
|
||||
(with-syntax ([name (syntax-local-infer-name (error-syntax))]
|
||||
[(import-tagged-sig-id ...)
|
||||
(map (λ (i s)
|
||||
(if (identifier? i) #`(tag #,i #,s) s))
|
||||
(syntax->list #'(i.s.i ...))
|
||||
(syntax->list #'(i.s.s.name ...)))]
|
||||
[(export-tagged-sig-id ...)
|
||||
(map (λ (i s)
|
||||
(if (identifier? i) #`(tag #,i #,s) s))
|
||||
(syntax->list #'(e.s.i ...))
|
||||
(syntax->list #'(e.s.s.name ...)))])
|
||||
(with-syntax ([new-unit exp]
|
||||
[unit-contract
|
||||
(unit/c/core
|
||||
(syntax/loc stx
|
||||
((import (import-tagged-sig-id [i.x i.c] ...) ...)
|
||||
(export (export-tagged-sig-id [e.x e.c] ...) ...))))]
|
||||
[src-info (id->contract-src-info #'name)])
|
||||
(values
|
||||
(syntax/loc stx
|
||||
(contract unit-contract new-unit '(unit name) (current-contract-region) src-info))
|
||||
isigs esigs deps))))]
|
||||
[(ic:import-clause/contract ec:export-clause/contract . body)
|
||||
(build-unit/contract
|
||||
(syntax/loc stx
|
||||
(ic ec (init-depend) . body)))]))
|
||||
|
||||
(define-syntax/err-param (define-unit/contract stx)
|
||||
(build-define-unit/contracted stx (λ (stx)
|
||||
(build-unit/contract stx))
|
||||
"missing unit name"))
|
||||
|
||||
(define-for-syntax (unprocess-tagged-id ti)
|
||||
(if (car ti)
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user