From 4ba02b716c64e0e93fb777588ae20f86925fc8ab Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Thu, 11 Sep 2008 23:53:23 +0000 Subject: [PATCH 01/28] Use the new function syntax for define/contract in a couple of tests. svn: r11664 original commit: b783ac9b70b80e056bcb0c44120734ae02038f70 --- collects/tests/mzscheme/contract-mzlib-test.ss | 12 +++++++++--- 1 file changed, 9 insertions(+), 3 deletions(-) diff --git a/collects/tests/mzscheme/contract-mzlib-test.ss b/collects/tests/mzscheme/contract-mzlib-test.ss index 3088456..44b73ae 100644 --- a/collects/tests/mzscheme/contract-mzlib-test.ss +++ b/collects/tests/mzscheme/contract-mzlib-test.ss @@ -1595,13 +1595,19 @@ of the contract library does not change over time. (i #f)) "top-level") + (test/spec-failed + 'define/contract5 + '(let () + (define/contract (i x) (-> integer? integer?) 1) + (i #f)) + "top-level") + (test/spec-passed 'define/contract6 '(let () - (define/contract contracted-func + (define/contract (contracted-func label t) (string? string? . -> . string?) - (lambda (label t) - t)) + t) (contracted-func "I'm a string constant with side effects" "ans"))) From 68c83b2a54c1c032c54ef44d99f635eeef3f8694 Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Fri, 12 Sep 2008 00:02:46 +0000 Subject: [PATCH 02/28] Check nested and non-nested define/contracts and how they interact. svn: r11665 original commit: 32d4b3463007fbc097b06e79eebc50906c6b3582 --- .../tests/mzscheme/contract-mzlib-test.ss | 47 ++++++++++++++++++- 1 file changed, 46 insertions(+), 1 deletion(-) diff --git a/collects/tests/mzscheme/contract-mzlib-test.ss b/collects/tests/mzscheme/contract-mzlib-test.ss index 44b73ae..7c3bac1 100644 --- a/collects/tests/mzscheme/contract-mzlib-test.ss +++ b/collects/tests/mzscheme/contract-mzlib-test.ss @@ -1621,7 +1621,52 @@ of the contract library does not change over time. x)) (eval '(require 'contract-test-suite-define1)))) - + (test/spec-failed + 'define/contract8 + '(let () + (define/contract (a n) + (-> number? number?) + (define/contract (b m) + (-> number? number?) + (+ m 1)) + (b (zero? n))) + (a 5)) + "a") + + (test/spec-failed + 'define/contract8 + '(let () + (define/contract (a n) + (-> number? number?) + (define/contract (b m) + (-> number? number?) + #t) + (b (add1 n))) + (a 5)) + "b") + + (test/spec-passed + 'define/contract9 + '(let () + (define/contract (f n) + (-> number? number?) + (+ n 1)) + (define/contract (g b m) + (-> boolean? number? number?) + (if b (f m) (f #t))) + (g #t 3))) + + (test/spec-failed + 'define/contract9 + '(let () + (define/contract (f n) + (-> number? number?) + (+ n 1)) + (define/contract (g b m) + (-> boolean? number? number?) + (if b (f m) (f #t))) + (g #f 3)) + "g") ; ; From e05c164435b2d3556cd06c484f6eccb604dc4880 Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Fri, 12 Sep 2008 00:21:38 +0000 Subject: [PATCH 03/28] Write some with-contract tests. svn: r11666 original commit: d9c47de816d3cff6ad3cea0cbeac309506007c70 --- .../tests/mzscheme/contract-mzlib-test.ss | 57 +++++++++++++++++++ 1 file changed, 57 insertions(+) diff --git a/collects/tests/mzscheme/contract-mzlib-test.ss b/collects/tests/mzscheme/contract-mzlib-test.ss index 7c3bac1..f8cf5db 100644 --- a/collects/tests/mzscheme/contract-mzlib-test.ss +++ b/collects/tests/mzscheme/contract-mzlib-test.ss @@ -1668,6 +1668,63 @@ of the contract library does not change over time. (g #f 3)) "g") + (test/spec-passed + 'with-contract1 + '(let () + (with-contract odd-even + ([odd? (-> number? boolean?)] + [even? (-> number? boolean?)]) + (define (odd? n) + (if (zero? n) #f (even? (sub1 n)))) + (define (even? n) + (if (zero? n) #t (odd? (sub1 n))))) + (odd? 5))) + + (test/spec-failed + 'with-contract2 + '(let () + (with-contract odd-even + ([odd? (-> number? boolean?)] + [even? (-> number? boolean?)]) + (define (odd? n) + (if (zero? n) #f (even? (sub1 n)))) + (define (even? n) + (if (zero? n) #t (odd? (sub1 n))))) + (odd? #t)) + "top-level") + + (test/spec-failed + 'with-contract3 + '(let () + (with-contract odd-even + ([odd? (-> number? boolean?)] + [even? (-> number? boolean?)]) + (define (odd? n) + (if (zero? n) n (even? (sub1 n)))) + (define (even? n) + (if (zero? n) #t (odd? (sub1 n))))) + (odd? 4)) + "odd-even") + + ;; Functions within the same with-contract region can call + ;; each other however they want, so here we have even? + ;; call odd? with a boolean, even though its contract in + ;; the odd-even contract says it only takes numbers. + (test/spec-passed + 'with-contract4 + '(let () + (with-contract odd-even + ([odd? (-> number? boolean?)] + [even? (-> number? boolean?)]) + (define (odd? n) + (cond + [(not (number? n)) #f] + [(zero? n) #f] + [else (even? (sub1 n))])) + (define (even? n) + (if (zero? n) #t (odd? (zero? n))))) + (odd? 5))) + ; ; ; From ed9a3876749ae1e8ea566dbe6c3b036d1bfa76bd Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Fri, 12 Sep 2008 03:42:36 +0000 Subject: [PATCH 04/28] Accidentally committed this in r11663. svn: r11669 original commit: 65e13861bb88209e9445d15f6a2fc9b9beab9345 --- collects/tests/mzscheme/contract-mzlib-test.ss | 2 -- 1 file changed, 2 deletions(-) diff --git a/collects/tests/mzscheme/contract-mzlib-test.ss b/collects/tests/mzscheme/contract-mzlib-test.ss index f8cf5db..c675095 100644 --- a/collects/tests/mzscheme/contract-mzlib-test.ss +++ b/collects/tests/mzscheme/contract-mzlib-test.ss @@ -1,5 +1,3 @@ - -#lang scheme/load #| This file started out as a copy of contract-test.ss. From e243118608a4b095aac13976f4784a2e65bacf4b Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Fri, 12 Sep 2008 03:49:20 +0000 Subject: [PATCH 05/28] Fix numbering, add back a test similar to the infinite loop case that was here before to illustrate how define/contract now correctly does not contract internal references. svn: r11670 original commit: d03ce01a5a9dfb9a736d65865fd04a198785526e --- .../tests/mzscheme/contract-mzlib-test.ss | 19 ++++++++++++++----- 1 file changed, 14 insertions(+), 5 deletions(-) diff --git a/collects/tests/mzscheme/contract-mzlib-test.ss b/collects/tests/mzscheme/contract-mzlib-test.ss index c675095..f005a34 100644 --- a/collects/tests/mzscheme/contract-mzlib-test.ss +++ b/collects/tests/mzscheme/contract-mzlib-test.ss @@ -1602,6 +1602,15 @@ of the contract library does not change over time. (test/spec-passed 'define/contract6 + '(let () + (define/contract (i x) (-> integer? integer?) + (cond + [(not (integer? x)) 1] + [else (i #f)])) + (i 1))) + + (test/spec-passed + 'define/contract7 '(let () (define/contract (contracted-func label t) (string? string? . -> . string?) @@ -1611,7 +1620,7 @@ of the contract library does not change over time. "ans"))) (test/spec-passed - 'define/contract7 + 'define/contract8 '(let () (eval '(module contract-test-suite-define1 mzscheme (require mzlib/contract) @@ -1620,7 +1629,7 @@ of the contract library does not change over time. (eval '(require 'contract-test-suite-define1)))) (test/spec-failed - 'define/contract8 + 'define/contract9 '(let () (define/contract (a n) (-> number? number?) @@ -1632,7 +1641,7 @@ of the contract library does not change over time. "a") (test/spec-failed - 'define/contract8 + 'define/contract10 '(let () (define/contract (a n) (-> number? number?) @@ -1644,7 +1653,7 @@ of the contract library does not change over time. "b") (test/spec-passed - 'define/contract9 + 'define/contract11 '(let () (define/contract (f n) (-> number? number?) @@ -1655,7 +1664,7 @@ of the contract library does not change over time. (g #t 3))) (test/spec-failed - 'define/contract9 + 'define/contract12 '(let () (define/contract (f n) (-> number? number?) From f060e3a47cb153233e3328b90ae6e863359a07d8 Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Fri, 12 Sep 2008 23:39:19 +0000 Subject: [PATCH 06/28] Couple more tests. Also, change things to mzscheme/mzlib. I really should go put the old version of define/contract in mzlib/contract.ss, have it not import with-contract or the new define/contract, and fix the unit tests appropriately. svn: r11708 original commit: 32f0b99f12588db11aeca3461f8e68c764884a08 --- .../tests/mzscheme/contract-mzlib-test.ss | 40 ++++++++++++++++--- 1 file changed, 34 insertions(+), 6 deletions(-) diff --git a/collects/tests/mzscheme/contract-mzlib-test.ss b/collects/tests/mzscheme/contract-mzlib-test.ss index be7e35d..5003992 100644 --- a/collects/tests/mzscheme/contract-mzlib-test.ss +++ b/collects/tests/mzscheme/contract-mzlib-test.ss @@ -1678,14 +1678,42 @@ of the contract library does not change over time. (test/spec-failed 'define/contract13 '(begin - (eval '(module foo scheme/base - (require scheme/contract) - (define/contract (foo n) + (eval '(module foo-dc13 mzscheme + (require mzlib/contract) + (define/contract (foo-dc13 n) (-> number? number?) (+ n 1)) - (foo #t))) - (eval '(require 'foo))) - "module foo") + (foo-dc13 #t))) + (eval '(require 'foo-dc13))) + "module foo-dc13") + + (test/spec-failed + 'define/contract14 + '(begin + (eval '(module foo-dc14 mzscheme + (require mzlib/contract) + (provide foo-dc14) + (define/contract (foo-dc14 n) + (-> number? number?) + (+ n 1)))) + (eval '(module bar-dc14 mzscheme + (require 'foo-dc14) + (foo-dc14 #t))) + (eval '(require 'bar-dc14))) + "module bar-dc14") + + (test/spec-failed + 'define/contract15 + '(begin + (eval '(module foo-dc15 mzscheme + (require mzlib/contract) + (provide foo-dc15) + (define/contract (foo-dc15 n) + (-> number? number?) + (+ n 1)))) + (eval '(require 'foo-dc15)) + (eval '(foo-dc15 #t))) + "the top level") (test/spec-passed 'with-contract1 From 44116e67e90034c497bccabbcb96b901ce4321a6 Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Fri, 12 Sep 2008 23:51:51 +0000 Subject: [PATCH 07/28] Okay, here's the old stuff put back, will fix up the unit tests when I get home. svn: r11709 original commit: c484131597b684e1a17dd8aae520c8a2bd1f93e2 --- collects/mzlib/contract.ss | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/collects/mzlib/contract.ss b/collects/mzlib/contract.ss index 9f69097..373846b 100644 --- a/collects/mzlib/contract.ss +++ b/collects/mzlib/contract.ss @@ -34,10 +34,14 @@ lazy-depth-to-look) (except-out (all-from-out scheme/private/contract) + old-define/contract + define/contract + with-contract check-between/c string-len/c check-unary-between/c) - (rename-out [string-len/c string/len])) + (rename-out [string-len/c string/len] + [old-define/contract define/contract])) ;; from contract-guts.ss From 4c6ee3623ecd15d28ec4f4845f20e64a82f67996 Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Sat, 13 Sep 2008 02:03:34 +0000 Subject: [PATCH 08/28] Revert this all the way back to where it was, I'll fix it up in a sec. svn: r11713 original commit: 14ef34e8e38e32029783d8207a684859fba7e3c0 --- .../tests/mzscheme/contract-mzlib-test.ss | 186 ++---------------- 1 file changed, 18 insertions(+), 168 deletions(-) diff --git a/collects/tests/mzscheme/contract-mzlib-test.ss b/collects/tests/mzscheme/contract-mzlib-test.ss index 5003992..c32dc4c 100644 --- a/collects/tests/mzscheme/contract-mzlib-test.ss +++ b/collects/tests/mzscheme/contract-mzlib-test.ss @@ -81,7 +81,7 @@ of the contract library does not change over time. (equal? blame (cond - [(regexp-match #rx"(^| )(.*) broke" msg) + [(regexp-match #rx"(^| )([^ ]*) broke" msg) => (λ (x) (caddr x))] [else (format "no blame in error message: \"~a\"" msg)]))) @@ -103,8 +103,8 @@ of the contract library does not change over time. (and (exn? exn) (,has-proper-blame? (exn-message exn)))))))))) - (define (test/pos-blame name expression) (test/spec-failed name expression "module pos")) - (define (test/neg-blame name expression) (test/spec-failed name expression "module neg")) + (define (test/pos-blame name expression) (test/spec-failed name expression "pos")) + (define (test/neg-blame name expression) (test/spec-failed name expression "neg")) (define (test/well-formed stx) (contract-eval @@ -126,7 +126,7 @@ of the contract library does not change over time. (contract-eval `(,test #t flat-contract? ,contract)) (test/spec-failed (format "~a fail" name) `(contract ,contract ',fail 'pos 'neg) - "module pos") + "pos") (test/spec-passed/result (format "~a pass" name) `(contract ,contract ',pass 'pos 'neg) @@ -1577,50 +1577,42 @@ of the contract library does not change over time. '(let () (define/contract i integer? #t) i) - "definition i") + "i") (test/spec-failed 'define/contract3 '(let () (define/contract i (-> integer? integer?) (lambda (x) #t)) (i 1)) - "definition i") + "i") (test/spec-failed 'define/contract4 '(let () (define/contract i (-> integer? integer?) (lambda (x) 1)) (i #f)) - "the top level") + "<>") (test/spec-failed 'define/contract5 '(let () - (define/contract (i x) (-> integer? integer?) 1) - (i #f)) - "the top level") + (define/contract i (-> integer? integer?) (lambda (x) (i #t))) + (i 1)) + "<>") (test/spec-passed 'define/contract6 '(let () - (define/contract (i x) (-> integer? integer?) - (cond - [(not (integer? x)) 1] - [else (i #f)])) - (i 1))) - - (test/spec-passed - 'define/contract7 - '(let () - (define/contract (contracted-func label t) + (define/contract contracted-func (string? string? . -> . string?) - t) + (lambda (label t) + t)) (contracted-func "I'm a string constant with side effects" "ans"))) (test/spec-passed - 'define/contract8 + 'define/contract7 '(let () (eval '(module contract-test-suite-define1 mzscheme (require mzlib/contract) @@ -1628,149 +1620,7 @@ of the contract library does not change over time. x)) (eval '(require 'contract-test-suite-define1)))) - (test/spec-failed - 'define/contract9 - '(let () - (define/contract (a n) - (-> number? number?) - (define/contract (b m) - (-> number? number?) - (+ m 1)) - (b (zero? n))) - (a 5)) - "function a") - - (test/spec-failed - 'define/contract10 - '(let () - (define/contract (a n) - (-> number? number?) - (define/contract (b m) - (-> number? number?) - #t) - (b (add1 n))) - (a 5)) - "function b") - - (test/spec-passed - 'define/contract11 - '(let () - (define/contract (f n) - (-> number? number?) - (+ n 1)) - (define/contract (g b m) - (-> boolean? number? number?) - (if b (f m) (f #t))) - (g #t 3))) - - (test/spec-failed - 'define/contract12 - '(let () - (define/contract (f n) - (-> number? number?) - (+ n 1)) - (define/contract (g b m) - (-> boolean? number? number?) - (if b (f m) (f #t))) - (g #f 3)) - "function g") - (test/spec-failed - 'define/contract13 - '(begin - (eval '(module foo-dc13 mzscheme - (require mzlib/contract) - (define/contract (foo-dc13 n) - (-> number? number?) - (+ n 1)) - (foo-dc13 #t))) - (eval '(require 'foo-dc13))) - "module foo-dc13") - - (test/spec-failed - 'define/contract14 - '(begin - (eval '(module foo-dc14 mzscheme - (require mzlib/contract) - (provide foo-dc14) - (define/contract (foo-dc14 n) - (-> number? number?) - (+ n 1)))) - (eval '(module bar-dc14 mzscheme - (require 'foo-dc14) - (foo-dc14 #t))) - (eval '(require 'bar-dc14))) - "module bar-dc14") - - (test/spec-failed - 'define/contract15 - '(begin - (eval '(module foo-dc15 mzscheme - (require mzlib/contract) - (provide foo-dc15) - (define/contract (foo-dc15 n) - (-> number? number?) - (+ n 1)))) - (eval '(require 'foo-dc15)) - (eval '(foo-dc15 #t))) - "the top level") - - (test/spec-passed - 'with-contract1 - '(let () - (with-contract odd-even - ([odd? (-> number? boolean?)] - [even? (-> number? boolean?)]) - (define (odd? n) - (if (zero? n) #f (even? (sub1 n)))) - (define (even? n) - (if (zero? n) #t (odd? (sub1 n))))) - (odd? 5))) - - (test/spec-failed - 'with-contract2 - '(let () - (with-contract odd-even - ([odd? (-> number? boolean?)] - [even? (-> number? boolean?)]) - (define (odd? n) - (if (zero? n) #f (even? (sub1 n)))) - (define (even? n) - (if (zero? n) #t (odd? (sub1 n))))) - (odd? #t)) - "the top level") - - (test/spec-failed - 'with-contract3 - '(let () - (with-contract odd-even - ([odd? (-> number? boolean?)] - [even? (-> number? boolean?)]) - (define (odd? n) - (if (zero? n) n (even? (sub1 n)))) - (define (even? n) - (if (zero? n) #t (odd? (sub1 n))))) - (odd? 4)) - "region odd-even") - - ;; Functions within the same with-contract region can call - ;; each other however they want, so here we have even? - ;; call odd? with a boolean, even though its contract in - ;; the odd-even contract says it only takes numbers. - (test/spec-passed - 'with-contract4 - '(let () - (with-contract odd-even - ([odd? (-> number? boolean?)] - [even? (-> number? boolean?)]) - (define (odd? n) - (cond - [(not (number? n)) #f] - [(zero? n) #f] - [else (even? (sub1 n))])) - (define (even? n) - (if (zero? n) #t (odd? (zero? n))))) - (odd? 5))) ; ; @@ -4793,7 +4643,7 @@ so that propagation occurs. (provide/contract (x integer?)))) (eval '(require 'contract-test-suite3)) (eval 'x)) - "module 'contract-test-suite3") + "'contract-test-suite3") (test/spec-passed 'provide/contract4 @@ -4970,7 +4820,7 @@ so that propagation occurs. (make-s 1 2) [s-a #f]))) (eval '(require 'pc11b-n))) - "module 'n") + 'n) |# (test/spec-passed @@ -5038,7 +4888,7 @@ so that propagation occurs. (define i #f) (provide/contract [i integer?]))) (eval '(require 'pos))) - "module 'pos") + "'pos") ;; this is really a positive violation, but name the module `neg' just for an addl test (test/spec-failed @@ -5049,7 +4899,7 @@ so that propagation occurs. (define i #f) (provide/contract [i integer?]))) (eval '(require 'neg))) - "module 'neg") + "'neg") ;; this test doesn't pass yet ... waiting for support from define-struct From 74026b5e5120c6435e9074b0c8b0e9e4b5136a33 Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Sat, 13 Sep 2008 02:11:05 +0000 Subject: [PATCH 09/28] Slight change just because we're now printing what kind of thing triggered the broken contract. svn: r11714 original commit: 16bce22386654e186f8e806aa5ee289fff380925 --- .../tests/mzscheme/contract-mzlib-test.ss | 20 +++++++++---------- 1 file changed, 10 insertions(+), 10 deletions(-) diff --git a/collects/tests/mzscheme/contract-mzlib-test.ss b/collects/tests/mzscheme/contract-mzlib-test.ss index c32dc4c..9b5a801 100644 --- a/collects/tests/mzscheme/contract-mzlib-test.ss +++ b/collects/tests/mzscheme/contract-mzlib-test.ss @@ -81,7 +81,7 @@ of the contract library does not change over time. (equal? blame (cond - [(regexp-match #rx"(^| )([^ ]*) broke" msg) + [(regexp-match #rx"(^| )(.*) broke" msg) => (λ (x) (caddr x))] [else (format "no blame in error message: \"~a\"" msg)]))) @@ -103,8 +103,8 @@ of the contract library does not change over time. (and (exn? exn) (,has-proper-blame? (exn-message exn)))))))))) - (define (test/pos-blame name expression) (test/spec-failed name expression "pos")) - (define (test/neg-blame name expression) (test/spec-failed name expression "neg")) + (define (test/pos-blame name expression) (test/spec-failed name expression "module pos")) + (define (test/neg-blame name expression) (test/spec-failed name expression "module neg")) (define (test/well-formed stx) (contract-eval @@ -126,7 +126,7 @@ of the contract library does not change over time. (contract-eval `(,test #t flat-contract? ,contract)) (test/spec-failed (format "~a fail" name) `(contract ,contract ',fail 'pos 'neg) - "pos") + "module pos") (test/spec-passed/result (format "~a pass" name) `(contract ,contract ',pass 'pos 'neg) @@ -1577,14 +1577,14 @@ of the contract library does not change over time. '(let () (define/contract i integer? #t) i) - "i") + "definition i") (test/spec-failed 'define/contract3 '(let () (define/contract i (-> integer? integer?) (lambda (x) #t)) (i 1)) - "i") + "definition i") (test/spec-failed 'define/contract4 @@ -4643,7 +4643,7 @@ so that propagation occurs. (provide/contract (x integer?)))) (eval '(require 'contract-test-suite3)) (eval 'x)) - "'contract-test-suite3") + "module 'contract-test-suite3") (test/spec-passed 'provide/contract4 @@ -4820,7 +4820,7 @@ so that propagation occurs. (make-s 1 2) [s-a #f]))) (eval '(require 'pc11b-n))) - 'n) + "module 'n") |# (test/spec-passed @@ -4888,7 +4888,7 @@ so that propagation occurs. (define i #f) (provide/contract [i integer?]))) (eval '(require 'pos))) - "'pos") + "module 'pos") ;; this is really a positive violation, but name the module `neg' just for an addl test (test/spec-failed @@ -4899,7 +4899,7 @@ so that propagation occurs. (define i #f) (provide/contract [i integer?]))) (eval '(require 'neg))) - "'neg") + "module 'neg") ;; this test doesn't pass yet ... waiting for support from define-struct From f00388ac413efd726a854853575700dff5a8df8d Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Sat, 13 Sep 2008 02:51:09 +0000 Subject: [PATCH 10/28] Actually, move the old-style define/contract to its own file in mzlib, and change around mzlib/contract.ss appropriately. svn: r11715 original commit: 0870c7ae1ddd58de472e2990f6b194686e61b083 --- collects/mzlib/contract.ss | 17 ++++-- collects/mzlib/private/contract-define.ss | 70 +++++++++++++++++++++++ 2 files changed, 81 insertions(+), 6 deletions(-) create mode 100644 collects/mzlib/private/contract-define.ss diff --git a/collects/mzlib/contract.ss b/collects/mzlib/contract.ss index 373846b..944fcd4 100644 --- a/collects/mzlib/contract.ss +++ b/collects/mzlib/contract.ss @@ -15,6 +15,13 @@ (require "private/contract-object.ss") (provide (all-from-out "private/contract-object.ss")) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; old-style define/contract +;; + +(require "private/contract-define.ss") +(provide (all-from-out "private/contract-define.ss")) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; @@ -22,7 +29,9 @@ ;; except the arrow contracts ;; -(require scheme/private/contract +(require (except-in scheme/private/contract + define/contract + with-contract) scheme/private/contract-guts scheme/private/contract-ds scheme/private/contract-opt @@ -34,14 +43,10 @@ lazy-depth-to-look) (except-out (all-from-out scheme/private/contract) - old-define/contract - define/contract - with-contract check-between/c string-len/c check-unary-between/c) - (rename-out [string-len/c string/len] - [old-define/contract define/contract])) + (rename-out [string-len/c string/len])) ;; from contract-guts.ss diff --git a/collects/mzlib/private/contract-define.ss b/collects/mzlib/private/contract-define.ss new file mode 100644 index 0000000..d1f3ea6 --- /dev/null +++ b/collects/mzlib/private/contract-define.ss @@ -0,0 +1,70 @@ +#lang scheme/base + +(provide define/contract) + +(require (for-syntax scheme/base) + (only-in scheme/contract contract) + (for-syntax (prefix-in a: scheme/private/contract-helpers))) + +;; First, we have the old define/contract implementation, which +;; is still used in mzlib/contract. + +(define-for-syntax (make-define/contract-transformer contract-id id) + (make-set!-transformer + (λ (stx) + (with-syntax ([neg-blame-str (a:build-src-loc-string stx)] + [contract-id contract-id] + [id id]) + (syntax-case stx (set!) + [(set! id arg) + (raise-syntax-error 'define/contract + "cannot set! a define/contract variable" + stx + (syntax id))] + [(f arg ...) + (syntax/loc stx + ((contract contract-id + id + (format "definition ~a" (syntax->datum (quote-syntax f))) + neg-blame-str + (quote-syntax f)) + arg + ...))] + [ident + (identifier? (syntax ident)) + (syntax/loc stx + (contract contract-id + id + (format "definition ~a" (syntax->datum (quote-syntax ident))) + neg-blame-str + (quote-syntax ident)))]))))) + +;; (define/contract id contract expr) +;; defines `id' with `contract'; initially binding +;; it to the result of `expr'. These variables may not be set!'d. +(define-syntax (define/contract define-stx) + (syntax-case define-stx () + [(_ name contract-expr expr) + (identifier? (syntax name)) + (with-syntax ([contract-id + (a:mangle-id define-stx + "define/contract-contract-id" + (syntax name))] + [id (a:mangle-id define-stx + "define/contract-id" + (syntax name))]) + (syntax/loc define-stx + (begin + (define contract-id contract-expr) + (define-syntax name + (make-define/contract-transformer (quote-syntax contract-id) + (quote-syntax id))) + (define id (let ([name expr]) name)) ;; let for procedure naming + )))] + [(_ name contract-expr expr) + (raise-syntax-error 'define/contract "expected identifier in first position" + define-stx + (syntax name))])) + + + From 7a657d334ff6ebf663874b0c65ddc28368e45104 Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Fri, 14 Nov 2008 16:48:17 +0000 Subject: [PATCH 11/28] Add all changes from branches/with-contract (which this branch will replace eventually), plus a couple of fixes in contract-test.ss. svn: r12451 original commit: 3212d1171217a93eb2865a602092d5b5d842ff40 --- collects/mzlib/contract.ss | 11 +++++++++- .../tests/mzscheme/contract-mzlib-test.ss | 20 +++++++++---------- 2 files changed, 20 insertions(+), 11 deletions(-) diff --git a/collects/mzlib/contract.ss b/collects/mzlib/contract.ss index bf96a1c..a191881 100644 --- a/collects/mzlib/contract.ss +++ b/collects/mzlib/contract.ss @@ -15,6 +15,13 @@ (require "private/contract-object.ss") (provide (all-from-out "private/contract-object.ss")) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; old-style define/contract +;; + +(require "private/contract-define.ss") +(provide (all-from-out "private/contract-define.ss")) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; @@ -22,7 +29,9 @@ ;; except the arrow contracts ;; -(require scheme/private/contract +(require (except-in scheme/private/contract + define/contract + with-contract) scheme/private/contract-guts scheme/private/contract-ds scheme/private/contract-opt diff --git a/collects/tests/mzscheme/contract-mzlib-test.ss b/collects/tests/mzscheme/contract-mzlib-test.ss index 4d0b8c9..47e25f7 100644 --- a/collects/tests/mzscheme/contract-mzlib-test.ss +++ b/collects/tests/mzscheme/contract-mzlib-test.ss @@ -81,7 +81,7 @@ of the contract library does not change over time. (equal? blame (cond - [(regexp-match #rx"(^| )([^ ]*) broke" msg) + [(regexp-match #rx"(^| )(.*) broke" msg) => (λ (x) (caddr x))] [else (format "no blame in error message: \"~a\"" msg)]))) @@ -103,8 +103,8 @@ of the contract library does not change over time. (and (exn? exn) (,has-proper-blame? (exn-message exn)))))))))) - (define (test/pos-blame name expression) (test/spec-failed name expression "pos")) - (define (test/neg-blame name expression) (test/spec-failed name expression "neg")) + (define (test/pos-blame name expression) (test/spec-failed name expression "module pos")) + (define (test/neg-blame name expression) (test/spec-failed name expression "module neg")) (define (test/well-formed stx) (contract-eval @@ -126,7 +126,7 @@ of the contract library does not change over time. (contract-eval `(,test #t flat-contract? ,contract)) (test/spec-failed (format "~a fail" name) `(contract ,contract ',fail 'pos 'neg) - "pos") + "module pos") (test/spec-passed/result (format "~a pass" name) `(contract ,contract ',pass 'pos 'neg) @@ -1577,14 +1577,14 @@ of the contract library does not change over time. '(let () (define/contract i integer? #t) i) - "i") + "definition i") (test/spec-failed 'define/contract3 '(let () (define/contract i (-> integer? integer?) (lambda (x) #t)) (i 1)) - "i") + "definition i") (test/spec-failed 'define/contract4 @@ -4643,7 +4643,7 @@ so that propagation occurs. (provide/contract (x integer?)))) (eval '(require 'contract-test-suite3)) (eval 'x)) - "'contract-test-suite3") + "module 'contract-test-suite3") (test/spec-passed 'provide/contract4 @@ -4820,7 +4820,7 @@ so that propagation occurs. (make-s 1 2) [s-a #f]))) (eval '(require 'pc11b-n))) - 'n) + "module 'n") |# (test/spec-passed @@ -4888,7 +4888,7 @@ so that propagation occurs. (define i #f) (provide/contract [i integer?]))) (eval '(require 'pos))) - "'pos") + "module 'pos") ;; this is really a positive violation, but name the module `neg' just for an addl test (test/spec-failed @@ -4899,7 +4899,7 @@ so that propagation occurs. (define i #f) (provide/contract [i integer?]))) (eval '(require 'neg))) - "'neg") + "module 'neg") ;; this test doesn't pass yet ... waiting for support from define-struct From ba3812ca9c326ea695fb8d624b6666e0e6576cd7 Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Fri, 14 Nov 2008 16:49:10 +0000 Subject: [PATCH 12/28] Missed a file. svn: r12452 original commit: eca59f6b1d98b59301a68c56f902f571340a5a16 --- collects/mzlib/private/contract-define.ss | 70 +++++++++++++++++++++++ 1 file changed, 70 insertions(+) create mode 100644 collects/mzlib/private/contract-define.ss diff --git a/collects/mzlib/private/contract-define.ss b/collects/mzlib/private/contract-define.ss new file mode 100644 index 0000000..d1f3ea6 --- /dev/null +++ b/collects/mzlib/private/contract-define.ss @@ -0,0 +1,70 @@ +#lang scheme/base + +(provide define/contract) + +(require (for-syntax scheme/base) + (only-in scheme/contract contract) + (for-syntax (prefix-in a: scheme/private/contract-helpers))) + +;; First, we have the old define/contract implementation, which +;; is still used in mzlib/contract. + +(define-for-syntax (make-define/contract-transformer contract-id id) + (make-set!-transformer + (λ (stx) + (with-syntax ([neg-blame-str (a:build-src-loc-string stx)] + [contract-id contract-id] + [id id]) + (syntax-case stx (set!) + [(set! id arg) + (raise-syntax-error 'define/contract + "cannot set! a define/contract variable" + stx + (syntax id))] + [(f arg ...) + (syntax/loc stx + ((contract contract-id + id + (format "definition ~a" (syntax->datum (quote-syntax f))) + neg-blame-str + (quote-syntax f)) + arg + ...))] + [ident + (identifier? (syntax ident)) + (syntax/loc stx + (contract contract-id + id + (format "definition ~a" (syntax->datum (quote-syntax ident))) + neg-blame-str + (quote-syntax ident)))]))))) + +;; (define/contract id contract expr) +;; defines `id' with `contract'; initially binding +;; it to the result of `expr'. These variables may not be set!'d. +(define-syntax (define/contract define-stx) + (syntax-case define-stx () + [(_ name contract-expr expr) + (identifier? (syntax name)) + (with-syntax ([contract-id + (a:mangle-id define-stx + "define/contract-contract-id" + (syntax name))] + [id (a:mangle-id define-stx + "define/contract-id" + (syntax name))]) + (syntax/loc define-stx + (begin + (define contract-id contract-expr) + (define-syntax name + (make-define/contract-transformer (quote-syntax contract-id) + (quote-syntax id))) + (define id (let ([name expr]) name)) ;; let for procedure naming + )))] + [(_ name contract-expr expr) + (raise-syntax-error 'define/contract "expected identifier in first position" + define-stx + (syntax name))])) + + + From 83ff7d7e624f4b2549904dd1691585c77f4dab64 Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Fri, 5 Dec 2008 17:55:47 +0000 Subject: [PATCH 13/28] Now to move the contract info appropriately into sigs from signatures. svn: r12712 original commit: beb5f195300b0db3dda7c4f8273563ecaeba65f0 --- collects/mzlib/unit.ss | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/collects/mzlib/unit.ss b/collects/mzlib/unit.ss index 8a2d829..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)]) From 66dad85db56a4946a80870ca6865370d6881c4ea Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Mon, 8 Dec 2008 17:06:53 +0000 Subject: [PATCH 14/28] 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 15/28] 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 16/28] 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 17/28] 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 18/28] 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 19/28] 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 20/28] 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 21/28] 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 22/28] 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 23/28] 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 24/28] 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 25/28] 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 95759e51962ed3627e3ccc1e2cf17520f283e911 Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Wed, 14 Jan 2009 21:35:07 +0000 Subject: [PATCH 26/28] Change this more to how it should be. svn: r13124 original commit: c7ee5b600c1023f612df6c4549f0bde66eef1416 --- collects/mzlib/private/contract-define.ss | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/collects/mzlib/private/contract-define.ss b/collects/mzlib/private/contract-define.ss index d1f3ea6..12891e1 100644 --- a/collects/mzlib/private/contract-define.ss +++ b/collects/mzlib/private/contract-define.ss @@ -25,7 +25,7 @@ (syntax/loc stx ((contract contract-id id - (format "definition ~a" (syntax->datum (quote-syntax f))) + (syntax->datum (quote-syntax f)) neg-blame-str (quote-syntax f)) arg @@ -35,7 +35,7 @@ (syntax/loc stx (contract contract-id id - (format "definition ~a" (syntax->datum (quote-syntax ident))) + (syntax->datum (quote-syntax ident)) neg-blame-str (quote-syntax ident)))]))))) From 650f7a3219e295e8dfcf76413c0d27637256c578 Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Thu, 15 Jan 2009 05:32:46 +0000 Subject: [PATCH 27/28] 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 28/28] 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)))