From 66dad85db56a4946a80870ca6865370d6881c4ea Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Mon, 8 Dec 2008 17:06:53 +0000 Subject: [PATCH 01/14] Adding current unit contract work over here. svn: r12743 original commit: bf5dddbd13fa45fd1950289624bbd05e9ec92135 --- collects/mzlib/unit.ss | 44 ++++++++++++++++++++++++++++++++---------- 1 file changed, 34 insertions(+), 10 deletions(-) diff --git a/collects/mzlib/unit.ss b/collects/mzlib/unit.ss index 593155f..48ba229 100644 --- a/collects/mzlib/unit.ss +++ b/collects/mzlib/unit.ss @@ -123,7 +123,8 @@ (define-for-syntax (build-val+macro-defs sig) (with-syntax ([(((int-ivar . ext-ivar) ...) ((((int-vid . ext-vid) ...) . vbody) ...) - ((((int-sid . ext-sid) ...) . sbody) ...)) + ((((int-sid . ext-sid) ...) . sbody) ...) + (((int-cid . ext-cid) . cbody) ...)) (map-sig (lambda (x) x) (make-syntax-introducer) sig)]) @@ -164,13 +165,17 @@ (cons (map syntax-local-introduce (car d)) (syntax-local-introduce (cdr d)))) + (define-for-syntax (introduce-ctc-pair cp) + (cons (syntax-local-introduce (car cp)) + (syntax-local-introduce (cdr cp)))) + ;; build-define-syntax : identifier (or/c identifier #f) syntax-object -> syntax-object (define-for-syntax (build-define-signature sigid super-sigid sig-exprs) (unless (or (stx-null? sig-exprs) (stx-pair? sig-exprs)) (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-val-defs super-stx-defs super-ctc-pairs) (if super-sigid (let* ([super-sig (lookup-signature super-sigid)] [super-siginfo (signature-siginfo super-sig)]) @@ -180,17 +185,20 @@ (siginfo-rtime-ids super-siginfo)) (map syntax-local-introduce (signature-vars super-sig)) (map introduce-def (signature-val-defs super-sig)) - (map introduce-def (signature-stx-defs super-sig)))) - (values '() '() '() '() '() '()))) + (map introduce-def (signature-stx-defs super-sig)) + (map introduce-ctc-pair (signature-ctc-pairs super-sig)))) + (values '() '() '() '() '() '() '()))) (let loop ((sig-exprs ses) (bindings null) (val-defs null) - (stx-defs null)) + (stx-defs null) + (ctc-pairs 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-ctc-pairs (append super-ctc-pairs (reverse ctc-pairs))] [dup (check-duplicate-identifier (append all-bindings @@ -202,7 +210,8 @@ ((super-name ...) super-names) ((var ...) all-bindings) ((((vid ...) . vbody) ...) all-val-defs) - ((((sid ...) . sbody) ...) all-stx-defs)) + ((((sid ...) . sbody) ...) all-stx-defs) + (((cid . cbody) ...) all-ctc-pairs)) #`(begin (define signature-tag (gensym)) (define-syntax #,sigid @@ -221,12 +230,25 @@ ((syntax-local-certifier) (quote-syntax sbody))) ...) + (list (cons (quote-syntax cid) + ((syntax-local-certifier) + (quote-syntax cbody))) + ...) (quote-syntax #,sigid)))))))) (else - (syntax-case (car sig-exprs) (define-values define-syntaxes) + (syntax-case (car sig-exprs) (define-values define-syntaxes contracted) (x (identifier? #'x) - (loop (cdr sig-exprs) (cons #'x bindings) val-defs stx-defs)) + (loop (cdr sig-exprs) (cons #'x bindings) val-defs stx-defs ctc-pairs)) + ((x y z) + (and (identifier? #'x) + (module-identifier=? #'x #'contracted) + (identifier? #'y)) + (loop (cdr sig-exprs) + (cons #'y bindings) + val-defs + stx-defs + (cons (cons #'y #'z) ctc-pairs))) ((x . y) (and (identifier? #'x) (or (module-identifier=? #'x #'define-values) @@ -248,7 +270,8 @@ (if (module-identifier=? #'x #'define-syntaxes) (cons (cons (syntax->list #'(name ...)) b) stx-defs) - stx-defs)))))))) + stx-defs) + ctc-pairs))))))) ((x . y) (let ((trans (set!-trans-extract @@ -266,7 +289,8 @@ (loop (append results (cdr sig-exprs)) bindings val-defs - stx-defs)))) + stx-defs + ctc-pairs)))) (x (raise-stx-err "expected either an identifier or signature form" #'x)))))))) From bee6f21c4dec1655ef5f6bdf831d19d0a00f1cdd Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Tue, 9 Dec 2008 23:16:48 +0000 Subject: [PATCH 02/14] Do the let so that (hopefully) the contract errors will get reported on the identifier. With a small change in scheme/contract, it does, but even with this, it doesn't seem to. How odd. svn: r12760 original commit: 90ad3f9221a9b5c31a673dcc820304e7b6c86872 --- collects/mzlib/unit.ss | 16 ++++++++++------ 1 file changed, 10 insertions(+), 6 deletions(-) diff --git a/collects/mzlib/unit.ss b/collects/mzlib/unit.ss index 17370ea..90e6b59 100644 --- a/collects/mzlib/unit.ss +++ b/collects/mzlib/unit.ss @@ -451,10 +451,11 @@ (define-for-syntax process-unit-export (process-unit-import/export process-tagged-export)) - (define-for-syntax (make-import-unboxing loc ctc name) + (define-for-syntax (make-import-unboxing var loc ctc name) (if ctc (quasisyntax/loc (error-syntax) - (quote-syntax (contract #,ctc (unbox #,loc) 'cant-happen '#,name))) + (quote-syntax (let ([#,var (unbox #,loc)]) + (contract #,ctc #,var 'cant-happen '#,name)))) (quasisyntax/loc (error-syntax) (quote-syntax (unbox #,loc))))) @@ -538,8 +539,9 @@ (quasisyntax/loc (error-syntax) [#,ivs (make-id-mappers - #,@(map (lambda (l c) - (make-import-unboxing l c #'name)) + #,@(map (lambda (v l c) + (make-import-unboxing v l c #'name)) + (syntax->list ivs) (syntax->list ils) ics))])) (syntax->list #'((int-ivar ...) ...)) @@ -1220,11 +1222,13 @@ (map (lambda (os ov) (map - (lambda (i c) + (lambda (i iv c) (if c - #`(contract #,c (unbox (vector-ref #,ov #,i)) 'cant-happen (#%variable-reference)) + #`(let ([#,iv (unbox (vector-ref #,ov #,i))]) + (contract #,c #,iv 'cant-happen (#%variable-reference))) #`(unbox (vector-ref #,ov #,i)))) (iota (length (car os))) + (map car (car os)) (cadddr os))) out-sigs out-vec))) From e9627fb9e23b90527e425562c24e188e137fc901 Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Wed, 10 Dec 2008 17:19:39 +0000 Subject: [PATCH 03/14] I'd like a better way of handling export contracts (some of the work that should be doable at compile time is being done at run time), but at least this works for now and gives us a chance to play around with it. svn: r12763 original commit: 56854a84bd2958f23eae2d04a185ed29eafbc077 --- collects/mzlib/unit.ss | 37 ++++++++++++++++++++++++++----------- 1 file changed, 26 insertions(+), 11 deletions(-) diff --git a/collects/mzlib/unit.ss b/collects/mzlib/unit.ss index 90e6b59..e49627e 100644 --- a/collects/mzlib/unit.ss +++ b/collects/mzlib/unit.ss @@ -454,8 +454,8 @@ (define-for-syntax (make-import-unboxing var loc ctc name) (if ctc (quasisyntax/loc (error-syntax) - (quote-syntax (let ([#,var (unbox #,loc)]) - (contract #,ctc #,var 'cant-happen '#,name)))) + (quote-syntax (let ([#,var (contract #,ctc (unbox #,loc) 'cant-happen '#,name)]) + #,var))) (quasisyntax/loc (error-syntax) (quote-syntax (unbox #,loc))))) @@ -505,6 +505,8 @@ (map (lambda (x) (generate-temporaries (car x))) import-sigs)] [((eloc ...) ...) (map (lambda (x) (generate-temporaries (car x))) export-sigs)] + [((ectc ...) ...) + (map cadddr export-sigs)] [((import-key import-super-keys ...) ...) (map tagged-info->keys import-tagged-infos)] [((export-key ...) ...) @@ -559,6 +561,7 @@ (int-ivar ... ...) (int-evar ... ...) (eloc ... ...) + (ectc ... ...) . body))))) (unit-export ((export-key ...) (vector-immutable eloc ...)) ...)))))) import-tagged-sigids @@ -574,7 +577,7 @@ (define-syntax (unit-body stx) (syntax-case stx () - ((_ err-stx ivars evars elocs body ...) + ((_ err-stx ivars evars elocs ectcs body ...) (parameterize ((error-syntax #'err-stx)) (let* ([expand-context (generate-expand-context)] [def-ctx (syntax-local-make-definition-context)] @@ -646,7 +649,8 @@ table id (make-var-info (module-identifier=? #'dv (quote-syntax define-syntaxes)) #f - id))) + id + #'#f))) (syntax->list #'(id ...)))] [_ (void)]))) [_ (void)])) @@ -657,7 +661,7 @@ ;; Mark exported names and ;; check that all exported names are defined (as var): (for-each - (lambda (name loc) + (lambda (name loc ctc) (let ([v (bound-identifier-mapping-get defined-names-table name (lambda () #f))]) @@ -665,9 +669,11 @@ (raise-stx-err (format "undefined export ~a" (syntax-e name)))) (when (var-info-syntax? v) (raise-stx-err "cannot export syntax from a unit" name)) - (set-var-info-exported?! v loc))) + (set-var-info-exported?! v loc) + (set-var-info-ctc! v ctc))) local-evars - (syntax->list #'elocs)) + (syntax->list #'elocs) + (syntax->list #'ectcs)) ;; Check that none of the imports are defined (for-each @@ -704,8 +710,15 @@ (let ([ids (syntax->list #'ids)] [do-one (lambda (id tmp name) - (let ([export-loc + (let ([unit-name + (syntax-local-infer-name (error-syntax))] + [export-loc (var-info-exported? + (bound-identifier-mapping-get + defined-names-table + id))] + [ctc + (var-info-ctc (bound-identifier-mapping-get defined-names-table id))]) @@ -715,7 +728,9 @@ (quasisyntax/loc defn-or-expr (set-box! #,export-loc #,(if name - #`(let ([#,name #,tmp]) + #`(let ([#,name (if #,ctc + (contract #,ctc #,tmp '#,unit-name 'cant-happen) + #,tmp)]) #,name) tmp)))) (else @@ -1224,8 +1239,8 @@ (map (lambda (i iv c) (if c - #`(let ([#,iv (unbox (vector-ref #,ov #,i))]) - (contract #,c #,iv 'cant-happen (#%variable-reference))) + #`(let ([#,iv (contract #,c (unbox (vector-ref #,ov #,i)) 'cant-happen (#%variable-reference))]) + #,iv) #`(unbox (vector-ref #,ov #,i)))) (iota (length (car os))) (map car (car os)) From 6eaf47ef9a25ed0bcff4c1f6cd18607502ded342 Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Wed, 10 Dec 2008 18:51:40 +0000 Subject: [PATCH 04/14] Last changes, everything works up to here. svn: r12765 original commit: 8bc883d1cbf2921c4a42b2b19441de0155b742c2 --- collects/mzlib/unit.ss | 47 +++++++++++++++++++++++++----------------- 1 file changed, 28 insertions(+), 19 deletions(-) diff --git a/collects/mzlib/unit.ss b/collects/mzlib/unit.ss index e49627e..86e7062 100644 --- a/collects/mzlib/unit.ss +++ b/collects/mzlib/unit.ss @@ -451,11 +451,11 @@ (define-for-syntax process-unit-export (process-unit-import/export process-tagged-export)) - (define-for-syntax (make-import-unboxing var loc ctc name) + (define-for-syntax (make-import-unboxing int-var ext-var loc ctc name) (if ctc (quasisyntax/loc (error-syntax) - (quote-syntax (let ([#,var (contract #,ctc (unbox #,loc) 'cant-happen '#,name)]) - #,var))) + (quote-syntax (let ([#,int-var (contract #,ctc (unbox #,loc) 'cant-happen '#,name (quote-syntax #,ext-var))]) + #,int-var))) (quasisyntax/loc (error-syntax) (quote-syntax (unbox #,loc))))) @@ -537,16 +537,18 @@ (let-values ([(iloc ...) (vector->values (hash-table-get import-table import-key) 0 icount)] ...) - (letrec-syntaxes (#,@(map (lambda (ivs ils ics) + (letrec-syntaxes (#,@(map (lambda (ivs evs ils ics) (quasisyntax/loc (error-syntax) [#,ivs (make-id-mappers - #,@(map (lambda (v l c) - (make-import-unboxing v l c #'name)) + #,@(map (lambda (iv ev l c) + (make-import-unboxing iv ev l c #'name)) (syntax->list ivs) + (syntax->list evs) (syntax->list ils) ics))])) (syntax->list #'((int-ivar ...) ...)) + (syntax->list #'((ext-ivar ...) ...)) (syntax->list #'((iloc ...) ...)) (map cadddr import-sigs)) [(int-evar ...) @@ -560,6 +562,7 @@ (unit-body #,(error-syntax) (int-ivar ... ...) (int-evar ... ...) + (ext-evar ... ...) (eloc ... ...) (ectc ... ...) . body))))) @@ -577,7 +580,7 @@ (define-syntax (unit-body stx) (syntax-case stx () - ((_ err-stx ivars evars elocs ectcs body ...) + ((_ err-stx ivars evars ext-evars elocs ectcs body ...) (parameterize ((error-syntax #'err-stx)) (let* ([expand-context (generate-expand-context)] [def-ctx (syntax-local-make-definition-context)] @@ -650,7 +653,7 @@ (make-var-info (module-identifier=? #'dv (quote-syntax define-syntaxes)) #f id - #'#f))) + #f))) (syntax->list #'(id ...)))] [_ (void)]))) [_ (void)])) @@ -661,18 +664,23 @@ ;; Mark exported names and ;; check that all exported names are defined (as var): (for-each - (lambda (name loc ctc) + (lambda (name loc var ctc) (let ([v (bound-identifier-mapping-get defined-names-table name - (lambda () #f))]) + (lambda () #f))] + [unit-name (syntax-local-infer-name (error-syntax))]) (unless v (raise-stx-err (format "undefined export ~a" (syntax-e name)))) (when (var-info-syntax? v) (raise-stx-err "cannot export syntax from a unit" name)) (set-var-info-exported?! v loc) - (set-var-info-ctc! v ctc))) + (set-var-info-add-ctc! v (lambda (e) + #`(if #,ctc + (contract #,ctc #,e '#,unit-name 'cant-happen (quote-syntax #,var)) + #,e))))) local-evars (syntax->list #'elocs) + (syntax->list #'ext-evars) (syntax->list #'ectcs)) ;; Check that none of the imports are defined @@ -717,8 +725,8 @@ (bound-identifier-mapping-get defined-names-table id))] - [ctc - (var-info-ctc + [add-ctc + (var-info-add-ctc (bound-identifier-mapping-get defined-names-table id))]) @@ -728,9 +736,7 @@ (quasisyntax/loc defn-or-expr (set-box! #,export-loc #,(if name - #`(let ([#,name (if #,ctc - (contract #,ctc #,tmp '#,unit-name 'cant-happen) - #,tmp)]) + #`(let ([#,name #,(if add-ctc (add-ctc tmp) tmp)]) #,name) tmp)))) (else @@ -1239,11 +1245,13 @@ (map (lambda (i iv c) (if c - #`(let ([#,iv (contract #,c (unbox (vector-ref #,ov #,i)) 'cant-happen (#%variable-reference))]) + #`(let ([#,iv (contract #,c (unbox (vector-ref #,ov #,i)) + 'cant-happen (#%variable-reference) + (quote-syntax #,iv))]) #,iv) #`(unbox (vector-ref #,ov #,i)))) (iota (length (car os))) - (map car (car os)) + (map cdr (car os)) (cadddr os))) out-sigs out-vec))) @@ -1317,7 +1325,8 @@ ((_ name . rest) (begin (check-id #'name) - (let-values (((exp i e d) (build #'rest))) + (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)) From dcacda86fa5352e87ea9ccc8c968890581357d2d Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Tue, 16 Dec 2008 20:35:19 +0000 Subject: [PATCH 05/14] Remove unused argument svn: r12872 original commit: 821a3ae90057e9e0115df51e27d1572bfa8c50cd --- collects/mzlib/unit.ss | 7 +++---- 1 file changed, 3 insertions(+), 4 deletions(-) diff --git a/collects/mzlib/unit.ss b/collects/mzlib/unit.ss index 33e3356..8912813 100644 --- a/collects/mzlib/unit.ss +++ b/collects/mzlib/unit.ss @@ -461,7 +461,7 @@ #,(syntax-span id)) #,(format "~s" (syntax-object->datum id)))) - (define-for-syntax (make-import-unboxing int-var ext-var loc ctc name) + (define-for-syntax (make-import-unboxing ext-var loc ctc name) (if ctc (quasisyntax/loc (error-syntax) (quote-syntax (contract #,ctc (unbox #,loc) 'cant-happen '#,name #,(id->contract-src-info ext-var)))) @@ -550,9 +550,8 @@ (quasisyntax/loc (error-syntax) [#,ivs (make-id-mappers - #,@(map (lambda (iv ev l c) - (make-import-unboxing iv ev l c #'name)) - (syntax->list ivs) + #,@(map (lambda (ev l c) + (make-import-unboxing ev l c #'name)) (syntax->list evs) (syntax->list ils) ics))])) From 3301fdba75b4973e6b88254a8c598c621b1b33ce Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Thu, 8 Jan 2009 20:52:18 +0000 Subject: [PATCH 06/14] We do _not_ want (void) last, we want it first here. svn: r13040 original commit: e402d7ea36a8d8b85119c183458a76645776922d --- collects/mzlib/unit.ss | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/collects/mzlib/unit.ss b/collects/mzlib/unit.ss index 7843950..2265166 100644 --- a/collects/mzlib/unit.ss +++ b/collects/mzlib/unit.ss @@ -755,8 +755,8 @@ [else (list defn-or-expr)])) expanded-body))]) #'(begin-with-definitions - defn&expr ... - (void)))))))) + (void) + defn&expr ...))))))) (define-for-syntax (redirect-imports/exports import?) (lambda (table-stx From 679f32c6dca45a144274c147a6fb45bdf91cd19c Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Fri, 9 Jan 2009 00:33:43 +0000 Subject: [PATCH 07/14] Small fixes svn: r13043 original commit: a932bfc84a65d6a6d9a9cf124931ce0ca3b30117 --- collects/mzlib/unit.ss | 10 +++------- 1 file changed, 3 insertions(+), 7 deletions(-) diff --git a/collects/mzlib/unit.ss b/collects/mzlib/unit.ss index 2265166..db1b3e0 100644 --- a/collects/mzlib/unit.ss +++ b/collects/mzlib/unit.ss @@ -587,13 +587,10 @@ (parameterize ((error-syntax #'err-stx)) (let* ([expand-context (generate-expand-context)] [def-ctx (syntax-local-make-definition-context)] - [local-ivars (syntax->list (localify #'ivars def-ctx))] - [local-evars (syntax->list (localify #'evars def-ctx))] [stop-list (append (kernel-form-identifier-list) - (syntax->list #'ivars) - (syntax->list #'evars))] + (syntax->list #'ivars))] [definition? (lambda (id) (and (identifier? id) @@ -681,7 +678,7 @@ #`(if #,ctc (contract #,ctc #,e '#,unit-name 'cant-happen #,(id->contract-src-info var)) #,e))))) - local-evars + (syntax->list (localify #'evars def-ctx)) (syntax->list #'elocs) (syntax->list #'ext-evars) (syntax->list #'ectcs)) @@ -696,7 +693,7 @@ (raise-stx-err "definition for imported identifier" (var-info-id defid))))) - local-ivars) + (syntax->list (localify #'ivars def-ctx))) (with-syntax ([(defn&expr ...) (apply @@ -755,7 +752,6 @@ [else (list defn-or-expr)])) expanded-body))]) #'(begin-with-definitions - (void) defn&expr ...))))))) (define-for-syntax (redirect-imports/exports import?) From 81e4bee047f1a3f2886a1cbafa0a0f2445d6488e Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Fri, 9 Jan 2009 00:59:04 +0000 Subject: [PATCH 08/14] There's no need for the special-casing define-values with one binding, so simplify this. svn: r13044 original commit: 8d1b82bcd21e42fcc2df2827291a8264aef189d9 --- collects/mzlib/unit.ss | 18 ++++++------------ 1 file changed, 6 insertions(+), 12 deletions(-) diff --git a/collects/mzlib/unit.ss b/collects/mzlib/unit.ss index db1b3e0..671c66a 100644 --- a/collects/mzlib/unit.ss +++ b/collects/mzlib/unit.ss @@ -715,7 +715,7 @@ id)) ids tmps) expr))] [do-one - (lambda (id tmp name) + (lambda (id tmp) (let ([unit-name (syntax-local-infer-name (error-syntax))] [export-loc @@ -734,21 +734,15 @@ (list (quasisyntax/loc defn-or-expr (set-box! #,export-loc - #,(if name - #`(let ([#,name #,(if add-ctc (add-ctc tmp) tmp)]) - #,name) - tmp))) + (let ([#,id #,(if add-ctc (add-ctc tmp) tmp)]) + #,id))) (quasisyntax/loc defn-or-expr - (define-syntax #,id (make-id-mapper (quote-syntax #,tmp)))))) + (define-syntax #,id + (make-id-mapper (quote-syntax #,tmp)))))) (else ;; not an exported id null))))]) - (if (null? (cdr ids)) - (cons new-defn (do-one (car ids) (car tmps) (car ids))) - (cons new-defn (apply append - (map (lambda (id tmp) - (do-one id tmp #f)) - ids tmps)))))] + (cons new-defn (apply append (map do-one ids tmps))))] [else (list defn-or-expr)])) expanded-body))]) #'(begin-with-definitions From ea41bc867df5d948622184bc216fd0320bf72e6f Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Fri, 9 Jan 2009 19:08:03 +0000 Subject: [PATCH 09/14] Basically write begin-with-definitions here by hand, which _does_ work. So that should pretty much give us unit contracts, modulo whether we can separate out the projections so that contracts aren't checked twice inappropriately. svn: r13047 original commit: bae2c7b5e121448891289fde194ffbaaced33a24 --- collects/mzlib/unit.ss | 125 ++++++++++++++++++++++++++--------------- 1 file changed, 79 insertions(+), 46 deletions(-) diff --git a/collects/mzlib/unit.ss b/collects/mzlib/unit.ss index 671c66a..b5fe0fc 100644 --- a/collects/mzlib/unit.ss +++ b/collects/mzlib/unit.ss @@ -10,7 +10,6 @@ "private/unit-syntax.ss") (require mzlib/contract - mzlib/etc "private/unit-keywords.ss" "private/unit-runtime.ss") @@ -695,18 +694,24 @@ (var-info-id defid))))) (syntax->list (localify #'ivars def-ctx))) - (with-syntax ([(defn&expr ...) - (apply - append - (map (lambda (defn-or-expr) - (syntax-case defn-or-expr (define-values define-syntaxes) - [(define-values () expr) - defn-or-expr] - [(define-values ids expr) - (let* ([ids (syntax->list #'ids)] - [tmps (generate-temporaries ids)] - [new-defn (quasisyntax/loc defn-or-expr - (define-values #,(map (lambda (id tmp) + (let-values ([(stx-defns val-defns exprs) + (let sort-clauses ([remaining expanded-body] + [stx-clauses null] + [val-clauses null] + [exprs null]) + (if (null? remaining) + (values (reverse stx-clauses) + (reverse val-clauses) + (if (null? exprs) + (list #'(void)) + (reverse exprs))) + (let ([defn-or-expr (car remaining)]) + (syntax-case defn-or-expr (define-values define-syntaxes) + [(define-values (id ...) expr) + (let*-values ([(ids) (syntax->list #'(id ...))] + [(tmps) (generate-temporaries ids)] + [(new-val-clause) (quasisyntax/loc defn-or-expr + (#,(map (λ (id tmp) (if (var-info-exported? (bound-identifier-mapping-get defined-names-table @@ -714,39 +719,67 @@ tmp id)) ids tmps) expr))] - [do-one - (lambda (id tmp) - (let ([unit-name - (syntax-local-infer-name (error-syntax))] - [export-loc - (var-info-exported? - (bound-identifier-mapping-get - defined-names-table - id))] - [add-ctc - (var-info-add-ctc - (bound-identifier-mapping-get - defined-names-table - id))]) - (cond - (export-loc - ;; set! exported id: - (list - (quasisyntax/loc defn-or-expr - (set-box! #,export-loc - (let ([#,id #,(if add-ctc (add-ctc tmp) tmp)]) - #,id))) - (quasisyntax/loc defn-or-expr - (define-syntax #,id - (make-id-mapper (quote-syntax #,tmp)))))) - (else - ;; not an exported id - null))))]) - (cons new-defn (apply append (map do-one ids tmps))))] - [else (list defn-or-expr)])) - expanded-body))]) - #'(begin-with-definitions - defn&expr ...))))))) + [(extra-stx-clauses extra-exprs) + (let loop ([ids ids] + [tmps tmps] + [stx-clauses null] + [exprs null]) + (if (null? ids) + (values stx-clauses exprs) + (let* ([id (car ids)] + [tmp (car tmps)] + [unit-name + (syntax-local-infer-name (error-syntax))] + [export-loc + (var-info-exported? + (bound-identifier-mapping-get + defined-names-table + id))] + [add-ctc + (var-info-add-ctc + (bound-identifier-mapping-get + defined-names-table + id))]) + (cond + [export-loc + ;; set! exported id: + (loop (cdr ids) + (cdr tmps) + (cons (quasisyntax/loc defn-or-expr + ((#,id) (make-id-mapper (quote-syntax #,tmp)))) + stx-clauses) + (cons (quasisyntax/loc defn-or-expr + (set-box! #,export-loc + (let ([#,id #,(if add-ctc (add-ctc tmp) tmp)]) + #,id))) + exprs))] + [else + ;; not an exported id + (loop (cdr ids) + (cdr tmps) + stx-clauses + exprs)]))))]) + (sort-clauses (cdr remaining) + (append extra-stx-clauses stx-clauses) + (cons new-val-clause + (append (map (λ (s) #`(() (begin #,s (values)))) exprs) + val-clauses)) + extra-exprs))] + [(define-syntaxes (id ...) expr) + (sort-clauses (cdr remaining) + (cons (cdr (syntax->list defn-or-expr)) + stx-clauses) + val-clauses + exprs)] + [else + (sort-clauses (cdr remaining) + stx-clauses + val-clauses + (cons defn-or-expr exprs))]))))]) + (with-syntax ([(stx-clause ...) stx-defns] + [(val-clause ...) val-defns] + [(expr ...) exprs]) + #'(letrec-syntaxes+values (stx-clause ...) (val-clause ...) expr ...)))))))) (define-for-syntax (redirect-imports/exports import?) (lambda (table-stx From 4d8f6fdeb0bd1b2f24d7d027bc72fd4ded843f83 Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Fri, 9 Jan 2009 19:50:28 +0000 Subject: [PATCH 10/14] Tag the contracts so we know what are truly contracts and which are just placeholder #fs. svn: r13048 original commit: af69c0bbeccf2fab5e11b104cd8bb3a686f343f9 --- collects/mzlib/unit.ss | 17 ++++++++++++----- 1 file changed, 12 insertions(+), 5 deletions(-) diff --git a/collects/mzlib/unit.ss b/collects/mzlib/unit.ss index b5fe0fc..8509d92 100644 --- a/collects/mzlib/unit.ss +++ b/collects/mzlib/unit.ss @@ -514,7 +514,12 @@ [((eloc ...) ...) (map (lambda (x) (generate-temporaries (car x))) export-sigs)] [((ectc ...) ...) - (map cadddr export-sigs)] + (map (λ (sig) + (map (λ (ctc) + (if ctc + (cons 'contract ctc) + #f)) + (cadddr sig))) export-sigs)] [((import-key import-super-keys ...) ...) (map tagged-info->keys import-tagged-infos)] [((export-key ...) ...) @@ -673,10 +678,12 @@ (when (var-info-syntax? v) (raise-stx-err "cannot export syntax from a unit" name)) (set-var-info-exported?! v loc) - (set-var-info-add-ctc! v (lambda (e) - #`(if #,ctc - (contract #,ctc #,e '#,unit-name 'cant-happen #,(id->contract-src-info var)) - #,e))))) + (when (pair? (syntax-e ctc)) + (set-var-info-add-ctc! + v + (λ (e) + #`(contract #,(cdr (syntax-e ctc)) #,e '#,unit-name + 'cant-happen #,(id->contract-src-info var))))))) (syntax->list (localify #'evars def-ctx)) (syntax->list #'elocs) (syntax->list #'ext-evars) From 4380d8a399dd04c98989540a8af799561488357c Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Fri, 9 Jan 2009 22:22:24 +0000 Subject: [PATCH 11/14] Allow multiple identifier/contract pairs in the same contracted form. svn: r13054 original commit: 0db2eb851a46185f0f09a130f707e1cdd748c50e --- collects/mzlib/unit.ss | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/collects/mzlib/unit.ss b/collects/mzlib/unit.ss index 8509d92..4b68bd6 100644 --- a/collects/mzlib/unit.ss +++ b/collects/mzlib/unit.ss @@ -241,15 +241,15 @@ (x (identifier? #'x) (loop (cdr sig-exprs) (cons #'x bindings) val-defs stx-defs (cons #f ctcs))) - ((x y z) + ((x (y z) ...) (and (identifier? #'x) (module-identifier=? #'x #'contracted) - (identifier? #'y)) + (andmap identifier? (syntax->list #'(y ...)))) (loop (cdr sig-exprs) - (cons #'y bindings) + (append (syntax->list #'(y ...)) bindings) val-defs stx-defs - (cons #'z ctcs))) + (append (syntax->list #'(z ...)) ctcs))) ((x . y) (and (identifier? #'x) (or (module-identifier=? #'x #'define-values) From 4a1629bf415511e28cacd2692ea5165c24f8ab77 Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Wed, 14 Jan 2009 01:12:52 +0000 Subject: [PATCH 12/14] Going to try switching this back, but need to sync from trunk to get Matthew's changes to see if it works. svn: r13098 original commit: b5efb99548e940818a92f41c174bc713bfa80e6b --- collects/mzlib/unit.ss | 120 ++++++++++++----------------------------- 1 file changed, 35 insertions(+), 85 deletions(-) diff --git a/collects/mzlib/unit.ss b/collects/mzlib/unit.ss index 2f43f73..7caf798 100644 --- a/collects/mzlib/unit.ss +++ b/collects/mzlib/unit.ss @@ -9,7 +9,8 @@ "private/unit-compiletime.ss" "private/unit-syntax.ss") - (require mzlib/contract + (require mzlib/etc + mzlib/contract mzlib/stxparam "private/unit-keywords.ss" "private/unit-runtime.ss") @@ -706,90 +707,39 @@ (var-info-id defid))))) (syntax->list (localify #'ivars def-ctx))) - (let-values ([(stx-defns val-defns exprs) - (let sort-clauses ([remaining expanded-body] - [stx-clauses null] - [val-clauses null] - [exprs null]) - (if (null? remaining) - (values (reverse stx-clauses) - (reverse val-clauses) - (if (null? exprs) - (list #'(void)) - (reverse exprs))) - (let ([defn-or-expr (car remaining)]) - (syntax-case defn-or-expr (define-values define-syntaxes) - [(define-values (id ...) expr) - (let*-values ([(ids) (syntax->list #'(id ...))] - [(tmps) (generate-temporaries ids)] - [(new-val-clause) (quasisyntax/loc defn-or-expr - (#,(map (λ (id tmp) - (if (var-info-exported? - (bound-identifier-mapping-get - defined-names-table - id)) - tmp - id)) - ids tmps) expr))] - [(extra-stx-clauses extra-exprs) - (let loop ([ids ids] - [tmps tmps] - [stx-clauses null] - [exprs null]) - (if (null? ids) - (values stx-clauses exprs) - (let* ([id (car ids)] - [tmp (car tmps)] - [export-loc - (var-info-exported? - (bound-identifier-mapping-get - defined-names-table - id))] - [add-ctc - (var-info-add-ctc - (bound-identifier-mapping-get - defined-names-table - id))]) - (cond - [export-loc - ;; set! exported id: - (loop (cdr ids) - (cdr tmps) - (cons (quasisyntax/loc defn-or-expr - ((#,id) (make-id-mapper (quote-syntax #,tmp)))) - stx-clauses) - (cons (quasisyntax/loc defn-or-expr - (set-box! #,export-loc - (let ([#,id #,(if add-ctc (add-ctc tmp) tmp)]) - #,id))) - exprs))] - [else - ;; not an exported id - (loop (cdr ids) - (cdr tmps) - stx-clauses - exprs)]))))]) - (sort-clauses (cdr remaining) - (append extra-stx-clauses stx-clauses) - (cons new-val-clause - (append (map (λ (s) #`(() (begin #,s (values)))) exprs) - val-clauses)) - extra-exprs))] - [(define-syntaxes (id ...) expr) - (sort-clauses (cdr remaining) - (cons (cdr (syntax->list defn-or-expr)) - stx-clauses) - val-clauses - exprs)] - [else - (sort-clauses (cdr remaining) - stx-clauses - val-clauses - (cons defn-or-expr exprs))]))))]) - (with-syntax ([(stx-clause ...) stx-defns] - [(val-clause ...) val-defns] - [(expr ...) exprs]) - #'(letrec-syntaxes+values (stx-clause ...) (val-clause ...) expr ...)))))))) + (with-syntax ([(defn-or-expr ...) + (apply append + (map (λ (defn-or-expr) + (syntax-case defn-or-expr (define-values) + [(define-values (id ...) body) + (let* ([ids (syntax->list #'(id ...))] + [tmps (generate-temporaries ids)] + [do-one + (λ (id tmp) + (let ([var-info (bound-identifier-mapping-get + defined-names-table + id)]) + (cond + [(var-info-exported? var-info) + => + (λ (export-loc) + (let ([add-ctc (var-info-add-ctc var-info)]) + (list (quasisyntax/loc defn-or-expr + (set-box! #,export-loc + (let ([#,id #,(if add-ctc (add-ctc tmp) tmp)]) + #,id))) + (quasisyntax/loc defn-or-expr + (define-syntax #,id + (make-id-mapper (quote-syntax #,tmp)))))))] + [else (list (quasisyntax/loc defn-or-expr + (define-syntax #,id + (make-rename-transformer (quote-syntax #,tmp)))))])))]) + (cons (quasisyntax/loc defn-or-expr + (define-values #,tmps body)) + (apply append (map do-one ids tmps))))] + [else (list defn-or-expr)])) + expanded-body))]) + #'(begin-with-definitions defn-or-expr ...))))))) (define-for-syntax (redirect-imports/exports import?) (lambda (table-stx From 650f7a3219e295e8dfcf76413c0d27637256c578 Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Thu, 15 Jan 2009 05:32:46 +0000 Subject: [PATCH 13/14] Okay, let's try using the "internal" names instead of the "external", which might make some errors more obvious. svn: r13141 original commit: bd802748e03c3434195279056f4223b94ddfc48f --- collects/mzlib/unit.ss | 21 +++++++++------------ 1 file changed, 9 insertions(+), 12 deletions(-) diff --git a/collects/mzlib/unit.ss b/collects/mzlib/unit.ss index bc40664..ba185f0 100644 --- a/collects/mzlib/unit.ss +++ b/collects/mzlib/unit.ss @@ -471,12 +471,12 @@ (define-syntax-parameter current-unit-blame-stx (lambda (stx) #'(#%variable-reference))) - (define-for-syntax (make-import-unboxing ext-var loc ctc) + (define-for-syntax (make-import-unboxing var loc ctc) (if ctc (quasisyntax/loc (error-syntax) (quote-syntax (contract #,ctc (unbox #,loc) 'cant-happen (current-unit-blame-stx) - #,(id->contract-src-info ext-var)))) + #,(id->contract-src-info var)))) (quasisyntax/loc (error-syntax) (quote-syntax (unbox #,loc))))) @@ -564,17 +564,16 @@ (let-values ([(iloc ...) (vector->values (hash-table-get import-table import-key) 0 icount)] ...) - (letrec-syntaxes (#,@(map (lambda (ivs evs ils ics) + (letrec-syntaxes (#,@(map (lambda (ivs ils ics) (quasisyntax/loc (error-syntax) [#,ivs (make-id-mappers - #,@(map (lambda (ev l c) - (make-import-unboxing ev l c)) - (syntax->list evs) + #,@(map (lambda (iv l c) + (make-import-unboxing iv l c)) + (syntax->list ivs) (syntax->list ils) ics))])) (syntax->list #'((int-ivar ...) ...)) - (syntax->list #'((ext-ivar ...) ...)) (syntax->list #'((iloc ...) ...)) (map cadddr import-sigs))) (letrec-syntaxes+values (renames ... @@ -583,7 +582,6 @@ (unit-body #,(error-syntax) (int-ivar ... ...) (int-evar ... ...) - (ext-evar ... ...) (eloc ... ...) (ectc ... ...) . body))))) @@ -601,7 +599,7 @@ (define-syntax (unit-body stx) (syntax-case stx () - ((_ err-stx ivars evars ext-evars elocs ectcs body ...) + ((_ err-stx ivars evars elocs ectcs body ...) (parameterize ((error-syntax #'err-stx)) (let* ([expand-context (generate-expand-context)] [def-ctx (syntax-local-make-definition-context)] @@ -682,7 +680,7 @@ ;; Mark exported names and ;; check that all exported names are defined (as var): (for-each - (lambda (name loc var ctc) + (lambda (name loc ctc) (let ([v (bound-identifier-mapping-get defined-names-table name (lambda () #f))]) @@ -696,10 +694,9 @@ v (λ (e) #`(contract #,(cdr (syntax-e ctc)) #,e (current-unit-blame-stx) - 'cant-happen #,(id->contract-src-info var))))))) + 'cant-happen #,(id->contract-src-info e))))))) (syntax->list (localify #'evars def-ctx)) (syntax->list #'elocs) - (syntax->list #'ext-evars) (syntax->list #'ectcs)) ;; Check that none of the imports are defined From b4bd9f99b37f3c1618c09292347555cc8e8c63ad Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Thu, 15 Jan 2009 05:37:23 +0000 Subject: [PATCH 14/14] Missed a case. Oops. svn: r13142 original commit: 9df50b125a7aa278e087c17450794861735429e5 --- collects/mzlib/unit.ss | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/collects/mzlib/unit.ss b/collects/mzlib/unit.ss index ba185f0..c2e0fa1 100644 --- a/collects/mzlib/unit.ss +++ b/collects/mzlib/unit.ss @@ -1216,14 +1216,14 @@ (map (lambda (os ov) (map - (lambda (i iv c) + (lambda (i v c) (if c #`(contract #,c (unbox (vector-ref #,ov #,i)) 'cant-happen (current-unit-blame-stx) - #,(id->contract-src-info iv)) + #,(id->contract-src-info v)) #`(unbox (vector-ref #,ov #,i)))) (iota (length (car os))) - (map cdr (car os)) + (map car (car os)) (cadddr os))) out-sigs out-vec)))