From fa74471fad0cb01f2ac4d797df38ed13f2cb7586 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Sun, 15 Feb 2009 17:45:53 +0000 Subject: [PATCH] sync to trunk svn: r13609 original commit: 738b8311afd40047e22fcf0181e34cef541e7ece --- collects/mzlib/unit.ss | 138 +++++++++++++++++++++++++++-------------- 1 file changed, 93 insertions(+), 45 deletions(-) diff --git a/collects/mzlib/unit.ss b/collects/mzlib/unit.ss index 3c17202..95f2bce 100644 --- a/collects/mzlib/unit.ss +++ b/collects/mzlib/unit.ss @@ -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)