From a7d5a2aaef50df45414173e101d38188fea7f94e Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Wed, 10 Sep 2008 21:46:13 +0000 Subject: [PATCH 01/88] Reordering the definitions so that define/contract and its helpers are in one section and the same for provide/contract (instead of them being mixed as before). svn: r11636 --- collects/scheme/private/contract.ss | 91 +++++++++++++++-------------- 1 file changed, 46 insertions(+), 45 deletions(-) diff --git a/collects/scheme/private/contract.ss b/collects/scheme/private/contract.ss index e3e44173b8..9c5fcbaeb8 100644 --- a/collects/scheme/private/contract.ss +++ b/collects/scheme/private/contract.ss @@ -89,6 +89,52 @@ improve method arity mismatch contract violation error messages? 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))])) + + +; +; +; +; ; ; ; +; ; ; +; ; ; ; ; +; ; ;; ; ; ;;; ; ; ; ;; ; ;;; ; ;;; ;;; ; ;; ;;;; ; ; ;;; ;;; ;;;; +; ;; ; ;; ; ; ; ; ; ; ;; ; ; ; ; ; ; ; ;; ; ; ;; ; ; ; ; ; +; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; +; ; ; ; ; ; ; ; ; ; ; ;;;;;; ; ; ; ; ; ; ; ; ;;;; ; ; +; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; +; ;; ; ; ; ; ; ; ; ;; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; +; ; ;; ; ;;; ; ; ;; ; ;;;; ; ;;; ;;; ; ; ;; ; ;;;;; ;;; ;; +; ; ; +; ; ; +; ; + + ;; id->contract-src-info : identifier -> syntax ;; constructs the last argument to the -contract, given an identifier (define-for-syntax (id->contract-src-info id) @@ -136,51 +182,6 @@ improve method arity mismatch contract violation error messages? ;; delay expansion until it's a good time to lift expressions: (quasisyntax/loc stx (#%expression #,stx))))))) -;; (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))])) - - -; -; -; -; ; ; ; -; ; ; -; ; ; ; ; -; ; ;; ; ; ;;; ; ; ; ;; ; ;;; ; ;;; ;;; ; ;; ;;;; ; ; ;;; ;;; ;;;; -; ;; ; ;; ; ; ; ; ; ; ;; ; ; ; ; ; ; ; ;; ; ; ;; ; ; ; ; ; -; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; -; ; ; ; ; ; ; ; ; ; ; ;;;;;; ; ; ; ; ; ; ; ; ;;;; ; ; -; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; -; ;; ; ; ; ; ; ; ; ;; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; -; ; ;; ; ;;; ; ; ;; ; ;;;; ; ;;; ;;; ; ; ;; ; ;;;;; ;;; ;; -; ; ; -; ; ; -; ; - ;; (provide/contract p/c-ele ...) ;; p/c-ele = (id expr) | (rename id id expr) | (struct id (id expr) ...) From 55f89f2da8da71986c58467d8d90b8d54c31dcb8 Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Thu, 11 Sep 2008 02:09:28 +0000 Subject: [PATCH 02/88] This doesn't quite work (neither does syntax-parameterize), but at least it gives us an idea of where we're going and I can bug Ryan tomorrow :D svn: r11637 --- collects/scheme/private/contract.ss | 82 ++++++++++++++++++++++++++++- 1 file changed, 81 insertions(+), 1 deletion(-) diff --git a/collects/scheme/private/contract.ss b/collects/scheme/private/contract.ss index 9c5fcbaeb8..cc6cb06498 100644 --- a/collects/scheme/private/contract.ss +++ b/collects/scheme/private/contract.ss @@ -12,7 +12,8 @@ improve method arity mismatch contract violation error messages? (provide (rename-out [-contract contract]) recursive-contract provide/contract - define/contract) + define/contract + with-contract) (require (for-syntax scheme/base) (for-syntax "contract-opt-guts.ss") @@ -117,6 +118,85 @@ improve method arity mismatch contract violation error messages? (syntax name))])) + +; +; +; ; ; +; ; ; ; ; +; ; ; ; ; +; ; ; ; ; ;;;; ; ;;; ;;; ;;; ; ;;; ;;;; ; ;; ;;;; ;;; ;;;; +; ; ; ; ; ; ;; ; ; ; ; ; ;; ; ; ;; ; ; ; ; ; +; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; +; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;;; ; ; +; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;;; ; ; ; +; ; ; ; ; ; ; ; ; ;;;; ; ; ; ; ; ; ; ; ; ; ; +; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; +; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;; ; ; ; +; ; ; ; ;;; ; ; ;;; ;;; ; ; ;;; ; ;;;; ; ;;; ;;; +; +; +; + +(define-for-syntax current-contract-region (make-parameter #f)) + +(define-for-syntax (make-with-contract-transformer contract-id id pos-blame-id) + (make-set!-transformer + (lambda (stx) + (with-syntax ([neg-blame-id #`(if #,(current-contract-region) + #,(current-contract-region) + (module-source-as-symbol #'#,id))] + [pos-blame-id #`(quote #,(syntax-e pos-blame-id))] + [contract-id contract-id] + [id id]) + (syntax-case stx (set!) + [(set! id arg) + (raise-syntax-error 'with-contract + "cannot set! a with-contract variable" + stx + (syntax id))] + [(f arg ...) + (syntax/loc stx + ((-contract contract-id + id + pos-blame-id + neg-blame-id + (quote-syntax f)) + arg ...))] + [ident + (identifier? (syntax ident)) + (syntax/loc stx + (-contract contract-id + id + pos-blame-id + neg-blame-id + (quote-syntax ident)))]))))) + +(define-syntax (with-contract stx) + (let ([introducer (make-syntax-introducer)]) + (syntax-case stx () + [(_ blame ([name contract-expr] ...) body0 body ...) + (and (identifier? (syntax blame)) + (andmap identifier? (syntax->list (syntax (name ...))))) + (parameterize ([current-contract-region (syntax-e (syntax blame))]) + (with-syntax ([(id ...) + (map introducer (syntax->list (syntax (name ...))))] + [(contract-id ...) + (map (lambda (n) + (a:mangle-id stx "with-contract-contract-id" n)) + (syntax->list (syntax (name ...))))] + [(new-body ...) + (map introducer + (syntax->list (syntax (body0 body ...))))]) + (syntax/loc stx + (begin + (define contract-id contract-expr) ... + (define-syntax name + (make-with-contract-transformer + (quote-syntax contract-id) + (quote-syntax id) + (quote-syntax blame))) ... + new-body ...))))]))) + ; ; ; From 0d90b5274c719432656be818f7f4b37a3d2ccc41 Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Thu, 11 Sep 2008 13:19:23 +0000 Subject: [PATCH 03/88] svn merge -r11635:11640 http://svn.plt-scheme.org/plt/trunk svn: r11641 --- collects/repos-time-stamp/stamp.ss | 2 +- collects/tests/stepper/run-nightly-tests.ss | 5 ----- src/worksp/mred/mred.manifest | 2 +- src/worksp/mred/mred.rc | 8 ++++---- src/worksp/mzcom/mzcom.rc | 8 ++++---- src/worksp/mzcom/mzobj.rgs | 6 +++--- src/worksp/mzscheme/mzscheme.rc | 8 ++++---- src/worksp/starters/start.rc | 8 ++++---- 8 files changed, 21 insertions(+), 26 deletions(-) delete mode 100644 collects/tests/stepper/run-nightly-tests.ss diff --git a/collects/repos-time-stamp/stamp.ss b/collects/repos-time-stamp/stamp.ss index c1afd89f4a..c9d8b64812 100644 --- a/collects/repos-time-stamp/stamp.ss +++ b/collects/repos-time-stamp/stamp.ss @@ -1 +1 @@ -#lang scheme/base (provide stamp) (define stamp "10sep2008") +#lang scheme/base (provide stamp) (define stamp "11sep2008") diff --git a/collects/tests/stepper/run-nightly-tests.ss b/collects/tests/stepper/run-nightly-tests.ss deleted file mode 100644 index 468cd45296..0000000000 --- a/collects/tests/stepper/run-nightly-tests.ss +++ /dev/null @@ -1,5 +0,0 @@ -(module run-nightly-tests mzscheme - (require "through-tests.ss") - - (parameterize ([display-only-errors #t]) - (run-all-tests-except '(prims qq-splice time set! local-set! lazy1 lazy2 lazy3)))) \ No newline at end of file diff --git a/src/worksp/mred/mred.manifest b/src/worksp/mred/mred.manifest index 7e029962c4..671bf1859d 100644 --- a/src/worksp/mred/mred.manifest +++ b/src/worksp/mred/mred.manifest @@ -1,7 +1,7 @@ Date: Thu, 11 Sep 2008 13:51:03 +0000 Subject: [PATCH 04/88] Pull out the querying of current-contract-region (even though it doesn't work), as we shouldn't be forming the if clause (here a cond) in the syntax (as it should be evaluated at expansion time). svn: r11642 --- collects/scheme/private/contract.ss | 59 +++++++++++++++-------------- 1 file changed, 30 insertions(+), 29 deletions(-) diff --git a/collects/scheme/private/contract.ss b/collects/scheme/private/contract.ss index cc6cb06498..d31b62ce23 100644 --- a/collects/scheme/private/contract.ss +++ b/collects/scheme/private/contract.ss @@ -142,35 +142,36 @@ improve method arity mismatch contract violation error messages? (define-for-syntax (make-with-contract-transformer contract-id id pos-blame-id) (make-set!-transformer (lambda (stx) - (with-syntax ([neg-blame-id #`(if #,(current-contract-region) - #,(current-contract-region) - (module-source-as-symbol #'#,id))] - [pos-blame-id #`(quote #,(syntax-e pos-blame-id))] - [contract-id contract-id] - [id id]) - (syntax-case stx (set!) - [(set! id arg) - (raise-syntax-error 'with-contract - "cannot set! a with-contract variable" - stx - (syntax id))] - [(f arg ...) - (syntax/loc stx - ((-contract contract-id - id - pos-blame-id - neg-blame-id - (quote-syntax f)) - arg ...))] - [ident - (identifier? (syntax ident)) - (syntax/loc stx - (-contract contract-id - id - pos-blame-id - neg-blame-id - (quote-syntax ident)))]))))) - + (let ([neg-blame-id (cond + [(current-contract-region) => values] + [else #`(module-source-as-symbol #'#,id)])]) + (with-syntax ([neg-blame-id neg-blame-id] + [pos-blame-id #`(quote #,(syntax-e pos-blame-id))] + [contract-id contract-id] + [id id]) + (syntax-case stx (set!) + [(set! id arg) + (raise-syntax-error 'with-contract + "cannot set! a with-contract variable" + stx + (syntax id))] + [(f arg ...) + (syntax/loc stx + ((-contract contract-id + id + pos-blame-id + neg-blame-id + (quote-syntax f)) + arg ...))] + [ident + (identifier? (syntax ident)) + (syntax/loc stx + (-contract contract-id + id + pos-blame-id + neg-blame-id + (quote-syntax ident)))])))))) + (define-syntax (with-contract stx) (let ([introducer (make-syntax-introducer)]) (syntax-case stx () From 2d6f7878650a224fe9b18d97c3bdb598761333ce Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Thu, 11 Sep 2008 14:45:33 +0000 Subject: [PATCH 05/88] svn merge -r11640:11643 http://svn.plt-scheme.org/plt/trunk svn: r11644 --- .../tests/typed-scheme/fail/values-dots.ss | 4 +- .../tests/typed-scheme/succeed/nested-poly.ss | 2 +- .../tests/typed-scheme/succeed/values-dots.ss | 8 +- .../typed-scheme/unit-tests/all-tests.ss | 2 +- .../typed-scheme/unit-tests/infer-tests.ss | 7 +- .../typed-scheme/unit-tests/module-tests.ss | 2 +- .../unit-tests/parse-type-tests.ss | 8 +- .../unit-tests/remove-intersect-tests.ss | 5 +- .../typed-scheme/unit-tests/subst-tests.ss | 4 +- .../typed-scheme/unit-tests/subtype-tests.ss | 8 +- .../typed-scheme/unit-tests/test-utils.ss | 19 +-- .../unit-tests/type-annotation-test.ss | 6 +- .../unit-tests/type-equal-tests.ss | 3 +- .../unit-tests/typecheck-tests.ss | 18 +-- .../{private => env}/init-envs.ss | 15 ++- .../{private => env}/lexical-env.ss | 8 +- .../{private => env}/type-alias-env.ss | 3 +- .../typed-scheme/{private => env}/type-env.ss | 4 +- .../{private => env}/type-environments.ss | 3 +- .../{private => env}/type-name-env.ss | 5 +- .../{private => infer}/constraint-structs.ss | 3 +- .../{private => infer}/constraints.ss | 7 +- .../typed-scheme/{private => infer}/dmap.ss | 4 +- collects/typed-scheme/infer/infer-dummy.ss | 8 ++ .../{private => infer}/infer-unit.ss | 52 +++++---- .../typed-scheme/{private => infer}/infer.ss | 3 +- .../{private => infer}/promote-demote.ss | 19 ++- .../{private => infer}/restrict.ss | 6 +- collects/typed-scheme/infer/signatures.ss | 29 +++++ collects/typed-scheme/no-check.ss | 5 + collects/typed-scheme/no-check/lang/reader.ss | 13 +++ collects/typed-scheme/private/base-env.ss | 35 +++--- collects/typed-scheme/private/base-types.ss | 5 +- collects/typed-scheme/private/extra-procs.ss | 7 +- collects/typed-scheme/private/infer-dummy.ss | 7 -- collects/typed-scheme/private/mutated-vars.ss | 13 +-- collects/typed-scheme/private/parse-type.ss | 13 +-- collects/typed-scheme/private/prims.ss | 10 +- .../typed-scheme/private/remove-intersect.ss | 5 +- collects/typed-scheme/private/resolve-type.ss | 3 +- collects/typed-scheme/private/subtype.ss | 27 +++-- .../typed-scheme/private/type-annotation.ss | 8 +- .../typed-scheme/private/type-comparison.ss | 3 +- .../typed-scheme/private/type-contract.ss | 18 +-- .../private/type-effect-convenience.ss | 33 ++++-- .../private/type-effect-printer.ss | 16 ++- collects/typed-scheme/private/type-utils.ss | 24 ++-- collects/typed-scheme/private/union.ss | 8 +- .../{private => rep}/effect-rep.ss | 0 .../{private => rep}/free-variance.ss | 7 +- .../{private => rep}/interning.ss | 0 .../{private => rep}/rep-utils.ss | 10 +- .../typed-scheme/{private => rep}/type-rep.ss | 46 ++++++-- .../check-subforms-unit.ss | 13 +-- .../{private => typecheck}/def-binding.ss | 0 .../{private => typecheck}/defstruct-unit.ss | 0 .../{private => typecheck}/internal-forms.ss | 0 .../provide-handling.ss | 7 +- .../{private => typecheck}/signatures.ss | 32 +---- .../{private => typecheck}/tc-app-unit.ss | 110 +++++++++++++----- .../{private => typecheck}/tc-dots-unit.ss | 9 +- .../{private => typecheck}/tc-expr-unit.ss | 23 ++-- .../{private => typecheck}/tc-if-unit.ss | 21 ++-- .../{private => typecheck}/tc-lambda-unit.ss | 19 ++- .../{private => typecheck}/tc-let-unit.ss | 11 +- .../{private => typecheck}/tc-structs.ss | 17 ++- .../{private => typecheck}/tc-toplevel.ss | 19 +-- .../{private => typecheck}/typechecker.ss | 3 +- collects/typed-scheme/typed-scheme.ss | 28 ++--- .../{private => utils}/planet-requires.ss | 0 .../{private => utils}/syntax-traversal.ss | 0 .../typed-scheme/{private => utils}/tables.ss | 0 .../{private => utils}/tc-utils.ss | 4 +- .../{private => utils}/unit-utils.ss | 0 .../typed-scheme/{private => utils}/utils.ss | 36 +++++- 75 files changed, 559 insertions(+), 374 deletions(-) rename collects/typed-scheme/{private => env}/init-envs.ss (90%) rename collects/typed-scheme/{private => env}/lexical-env.ss (90%) rename collects/typed-scheme/{private => env}/type-alias-env.ss (96%) rename collects/typed-scheme/{private => env}/type-env.ss (95%) rename collects/typed-scheme/{private => env}/type-environments.ss (96%) rename collects/typed-scheme/{private => env}/type-name-env.ss (93%) rename collects/typed-scheme/{private => infer}/constraint-structs.ss (94%) rename collects/typed-scheme/{private => infer}/constraints.ss (94%) rename collects/typed-scheme/{private => infer}/dmap.ss (92%) create mode 100644 collects/typed-scheme/infer/infer-dummy.ss rename collects/typed-scheme/{private => infer}/infer-unit.ss (92%) rename collects/typed-scheme/{private => infer}/infer.ss (67%) rename collects/typed-scheme/{private => infer}/promote-demote.ss (80%) rename collects/typed-scheme/{private => infer}/restrict.ss (90%) create mode 100644 collects/typed-scheme/infer/signatures.ss create mode 100644 collects/typed-scheme/no-check.ss create mode 100644 collects/typed-scheme/no-check/lang/reader.ss delete mode 100644 collects/typed-scheme/private/infer-dummy.ss rename collects/typed-scheme/{private => rep}/effect-rep.ss (100%) rename collects/typed-scheme/{private => rep}/free-variance.ss (91%) rename collects/typed-scheme/{private => rep}/interning.ss (100%) rename collects/typed-scheme/{private => rep}/rep-utils.ss (96%) rename collects/typed-scheme/{private => rep}/type-rep.ss (92%) rename collects/typed-scheme/{private => typecheck}/check-subforms-unit.ss (89%) rename collects/typed-scheme/{private => typecheck}/def-binding.ss (100%) rename collects/typed-scheme/{private => typecheck}/defstruct-unit.ss (100%) rename collects/typed-scheme/{private => typecheck}/internal-forms.ss (100%) rename collects/typed-scheme/{private => typecheck}/provide-handling.ss (96%) rename collects/typed-scheme/{private => typecheck}/signatures.ss (56%) rename collects/typed-scheme/{private => typecheck}/tc-app-unit.ss (90%) rename collects/typed-scheme/{private => typecheck}/tc-dots-unit.ss (89%) rename collects/typed-scheme/{private => typecheck}/tc-expr-unit.ss (95%) rename collects/typed-scheme/{private => typecheck}/tc-if-unit.ss (95%) rename collects/typed-scheme/{private => typecheck}/tc-lambda-unit.ss (96%) rename collects/typed-scheme/{private => typecheck}/tc-let-unit.ss (96%) rename collects/typed-scheme/{private => typecheck}/tc-structs.ss (95%) rename collects/typed-scheme/{private => typecheck}/tc-toplevel.ss (94%) rename collects/typed-scheme/{private => typecheck}/typechecker.ss (89%) rename collects/typed-scheme/{private => utils}/planet-requires.ss (100%) rename collects/typed-scheme/{private => utils}/syntax-traversal.ss (100%) rename collects/typed-scheme/{private => utils}/tables.ss (100%) rename collects/typed-scheme/{private => utils}/tc-utils.ss (97%) rename collects/typed-scheme/{private => utils}/unit-utils.ss (100%) rename collects/typed-scheme/{private => utils}/utils.ss (82%) diff --git a/collects/tests/typed-scheme/fail/values-dots.ss b/collects/tests/typed-scheme/fail/values-dots.ss index 6c08fff545..f92743faf3 100644 --- a/collects/tests/typed-scheme/fail/values-dots.ss +++ b/collects/tests/typed-scheme/fail/values-dots.ss @@ -7,8 +7,8 @@ (: map-with-funcs (All (b ...) ((b ... b -> b) ... b -> (b ... b -> (values b ... b))))) (define (map-with-funcs . fs) (lambda bs - (apply values* (map (lambda: ([f : (b ... b -> b)]) - (apply f bs)) fs)))) + (apply values (map (lambda: ([f : (b ... b -> b)]) + (apply f bs)) fs)))) (map-with-funcs (lambda () 1)) diff --git a/collects/tests/typed-scheme/succeed/nested-poly.ss b/collects/tests/typed-scheme/succeed/nested-poly.ss index 785ee9a5df..ac8bb3cd8c 100644 --- a/collects/tests/typed-scheme/succeed/nested-poly.ss +++ b/collects/tests/typed-scheme/succeed/nested-poly.ss @@ -13,7 +13,7 @@ (B ... B -> (values A ... A)))))) (define (map-with-funcs . fs) (lambda as - (apply values* (map (lambda: ([f : (B ... B -> A)]) + (apply values (map (lambda: ([f : (B ... B -> A)]) (apply f as)) fs)))) diff --git a/collects/tests/typed-scheme/succeed/values-dots.ss b/collects/tests/typed-scheme/succeed/values-dots.ss index 0078526faa..1c853f50b0 100644 --- a/collects/tests/typed-scheme/succeed/values-dots.ss +++ b/collects/tests/typed-scheme/succeed/values-dots.ss @@ -5,16 +5,16 @@ (call-with-values (lambda () (values 1 2)) (lambda: ([x : Number] [y : Number]) (+ x y))) -(#{call-with-values* @ Integer Integer Integer} (lambda () (values 1 2)) (lambda: ([x : Integer] [y : Integer]) (+ x y))) +(#{call-with-values @ Integer Integer Integer} (lambda () (values 1 2)) (lambda: ([x : Integer] [y : Integer]) (+ x y))) -(call-with-values* (lambda () (values 1 2)) (lambda: ([x : Integer] [y : Integer]) (+ x y))) +(call-with-values (lambda () (values 1 2)) (lambda: ([x : Integer] [y : Integer]) (+ x y))) (: map-with-funcs (All (b ...) ((b ... b -> b) ... b -> (b ... b -> (values b ... b))))) (define (map-with-funcs . fs) (lambda bs - (apply values* (map (lambda: ([f : (b ... b -> b)]) - (apply f bs)) fs)))) + (apply values (map (lambda: ([f : (b ... b -> b)]) + (apply f bs)) fs)))) (map-with-funcs + - * /) diff --git a/collects/tests/typed-scheme/unit-tests/all-tests.ss b/collects/tests/typed-scheme/unit-tests/all-tests.ss index aca0a4d12c..1fe728d05b 100644 --- a/collects/tests/typed-scheme/unit-tests/all-tests.ss +++ b/collects/tests/typed-scheme/unit-tests/all-tests.ss @@ -12,7 +12,7 @@ "subst-tests.ss" "infer-tests.ss") -(require (private planet-requires infer infer-dummy)) +(require (utils planet-requires) (r:infer infer infer-dummy)) (require (schemeunit)) diff --git a/collects/tests/typed-scheme/unit-tests/infer-tests.ss b/collects/tests/typed-scheme/unit-tests/infer-tests.ss index f1d5e22b0d..aef624b748 100644 --- a/collects/tests/typed-scheme/unit-tests/infer-tests.ss +++ b/collects/tests/typed-scheme/unit-tests/infer-tests.ss @@ -1,7 +1,10 @@ #lang scheme/base (require "test-utils.ss" (for-syntax scheme/base)) -(require (private planet-requires type-effect-convenience type-rep union infer type-utils) - (prefix-in table: (private tables))) +(require (utils planet-requires) + (rep type-rep) + (r:infer infer) + (private type-effect-convenience union type-utils) + (prefix-in table: (utils tables))) (require (schemeunit)) diff --git a/collects/tests/typed-scheme/unit-tests/module-tests.ss b/collects/tests/typed-scheme/unit-tests/module-tests.ss index 51406fb008..490c1c2a89 100644 --- a/collects/tests/typed-scheme/unit-tests/module-tests.ss +++ b/collects/tests/typed-scheme/unit-tests/module-tests.ss @@ -1,6 +1,6 @@ #lang scheme (require "test-utils.ss") -(require (private planet-requires)) +(require (utils planet-requires)) (require (schemeunit)) (provide module-tests) diff --git a/collects/tests/typed-scheme/unit-tests/parse-type-tests.ss b/collects/tests/typed-scheme/unit-tests/parse-type-tests.ss index aa3882fd38..fedf84fb81 100644 --- a/collects/tests/typed-scheme/unit-tests/parse-type-tests.ss +++ b/collects/tests/typed-scheme/unit-tests/parse-type-tests.ss @@ -1,8 +1,10 @@ #lang scheme/base (require "test-utils.ss" (for-syntax scheme/base)) -(require (private planet-requires type-comparison parse-type type-rep - tc-utils type-environments type-alias-env subtype - type-name-env init-envs union type-utils)) +(require (utils planet-requires tc-utils) + (env type-alias-env type-environments type-name-env init-envs) + (rep type-rep) + (private type-comparison parse-type subtype + union type-utils)) (require (rename-in (private type-effect-convenience) [-> t:->]) (except-in (private base-types) Un) diff --git a/collects/tests/typed-scheme/unit-tests/remove-intersect-tests.ss b/collects/tests/typed-scheme/unit-tests/remove-intersect-tests.ss index ca83402b66..20da5c73c3 100644 --- a/collects/tests/typed-scheme/unit-tests/remove-intersect-tests.ss +++ b/collects/tests/typed-scheme/unit-tests/remove-intersect-tests.ss @@ -1,6 +1,9 @@ #lang scheme/base (require "test-utils.ss" (for-syntax scheme/base)) -(require (private type-rep type-effect-convenience planet-requires remove-intersect subtype union infer)) +(require (rep type-rep) + (utils planet-requires) + (r:infer infer) + (private type-effect-convenience remove-intersect subtype union)) (require (schemeunit)) diff --git a/collects/tests/typed-scheme/unit-tests/subst-tests.ss b/collects/tests/typed-scheme/unit-tests/subst-tests.ss index 6c89d4ef6f..10a35fc98a 100644 --- a/collects/tests/typed-scheme/unit-tests/subst-tests.ss +++ b/collects/tests/typed-scheme/unit-tests/subst-tests.ss @@ -1,7 +1,9 @@ #lang scheme/base (require "test-utils.ss" (for-syntax scheme/base)) -(require (private planet-requires type-utils type-effect-convenience type-rep)) +(require (utils planet-requires) + (rep type-rep) + (private type-utils type-effect-convenience)) (require (schemeunit)) (define-syntax-rule (s img var tgt result) diff --git a/collects/tests/typed-scheme/unit-tests/subtype-tests.ss b/collects/tests/typed-scheme/unit-tests/subtype-tests.ss index f4bc99125d..83bb3e9a51 100644 --- a/collects/tests/typed-scheme/unit-tests/subtype-tests.ss +++ b/collects/tests/typed-scheme/unit-tests/subtype-tests.ss @@ -2,8 +2,12 @@ (require "test-utils.ss") -(require (private subtype type-rep type-effect-convenience - planet-requires init-envs type-environments union infer infer-dummy)) +(require (private subtype type-effect-convenience union) + (rep type-rep) + (utils planet-requires) + (env init-envs type-environments) + (r:infer infer infer-dummy)) + (require (schemeunit) (for-syntax scheme/base)) diff --git a/collects/tests/typed-scheme/unit-tests/test-utils.ss b/collects/tests/typed-scheme/unit-tests/test-utils.ss index f5c848fa04..b160cacdf9 100644 --- a/collects/tests/typed-scheme/unit-tests/test-utils.ss +++ b/collects/tests/typed-scheme/unit-tests/test-utils.ss @@ -3,25 +3,12 @@ (require scheme/require-syntax scheme/match + typed-scheme/utils/utils (for-syntax scheme/base)) -(define-require-syntax private - (lambda (stx) - (syntax-case stx () - [(_ id ...) - (andmap identifier? (syntax->list #'(id ...))) - (with-syntax ([(id* ...) (map (lambda (id) (datum->syntax - id - (string->symbol - (string-append - "typed-scheme/private/" - (symbol->string (syntax-e id)))) - id id)) - (syntax->list #'(id ...)))]) - (syntax/loc stx (combine-in id* ...)))]))) - -(require (private planet-requires type-comparison utils type-utils)) +(require (utils planet-requires) (private type-comparison type-utils)) +(provide private typecheck (rename-out [infer r:infer]) utils env rep) (require (schemeunit)) (define (mk-suite ts) diff --git a/collects/tests/typed-scheme/unit-tests/type-annotation-test.ss b/collects/tests/typed-scheme/unit-tests/type-annotation-test.ss index 80e471b00c..167db51eb7 100644 --- a/collects/tests/typed-scheme/unit-tests/type-annotation-test.ss +++ b/collects/tests/typed-scheme/unit-tests/type-annotation-test.ss @@ -1,8 +1,10 @@ #lang scheme/base (require "test-utils.ss" (for-syntax scheme/base)) -(require (private planet-requires type-annotation tc-utils type-rep type-effect-convenience type-environments - parse-type init-envs type-name-env)) +(require (private type-annotation type-effect-convenience parse-type) + (env type-environments type-name-env init-envs) + (utils planet-requires tc-utils) + (rep type-rep)) (require (schemeunit)) diff --git a/collects/tests/typed-scheme/unit-tests/type-equal-tests.ss b/collects/tests/typed-scheme/unit-tests/type-equal-tests.ss index 6488d47b16..899b8e1e97 100644 --- a/collects/tests/typed-scheme/unit-tests/type-equal-tests.ss +++ b/collects/tests/typed-scheme/unit-tests/type-equal-tests.ss @@ -1,7 +1,8 @@ #lang scheme/base (require "test-utils.ss" (for-syntax scheme/base)) -(require (private planet-requires type-rep type-comparison type-effect-convenience union subtype)) +(require (utils planet-requires) (rep type-rep) + (private type-comparison type-effect-convenience union subtype)) (require (schemeunit)) (provide type-equal-tests) diff --git a/collects/tests/typed-scheme/unit-tests/typecheck-tests.ss b/collects/tests/typed-scheme/unit-tests/typecheck-tests.ss index a5263dd32b..fee35aa2fc 100644 --- a/collects/tests/typed-scheme/unit-tests/typecheck-tests.ss +++ b/collects/tests/typed-scheme/unit-tests/typecheck-tests.ss @@ -3,14 +3,16 @@ (require "test-utils.ss" (for-syntax scheme/base) (for-template scheme/base)) -(require (private base-env)) +(require (private base-env mutated-vars type-utils union prims type-effect-convenience type-annotation) + (typecheck typechecker) + (rep type-rep effect-rep) + (utils tc-utils planet-requires) + (env type-name-env type-environments init-envs)) -(require (private planet-requires typechecker - type-rep type-effect-convenience type-env - prims type-environments tc-utils union - type-name-env init-envs mutated-vars - effect-rep type-annotation type-utils) - (for-syntax (private tc-utils typechecker base-env type-env)) +(require (for-syntax (utils tc-utils) + (typecheck typechecker) + (env type-env) + (private base-env)) (for-template (private base-env base-types))) (require (schemeunit)) @@ -669,7 +671,7 @@ (tc-l #t (-val #t)) (tc-l "foo" -String) (tc-l foo (-val 'foo)) - (tc-l #:foo -Keyword) + (tc-l #:foo (-val '#:foo)) (tc-l #f (-val #f)) (tc-l #"foo" -Bytes) [tc-l () (-val null)] diff --git a/collects/typed-scheme/private/init-envs.ss b/collects/typed-scheme/env/init-envs.ss similarity index 90% rename from collects/typed-scheme/private/init-envs.ss rename to collects/typed-scheme/env/init-envs.ss index d0dac77c0c..4a03b9108d 100644 --- a/collects/typed-scheme/private/init-envs.ss +++ b/collects/typed-scheme/env/init-envs.ss @@ -1,11 +1,16 @@ #lang scheme/base (provide (all-defined-out)) +(require "../utils/utils.ss") -(require "type-env.ss" "type-rep.ss" "type-name-env.ss" "union.ss" "effect-rep.ss" - "type-effect-convenience.ss" "type-alias-env.ss" - "type-alias-env.ss") -(require mzlib/pconvert scheme/match mzlib/shared - (for-template mzlib/pconvert mzlib/shared scheme/base "type-rep.ss" "union.ss" "effect-rep.ss")) +(require "type-env.ss" + "type-name-env.ss" + (rep type-rep effect-rep) + (for-template (rep type-rep effect-rep) + (private union) + mzlib/pconvert mzlib/shared scheme/base) + (private type-effect-convenience union) + "type-alias-env.ss" + mzlib/pconvert scheme/match mzlib/shared) (define (initialize-type-name-env initial-type-names) (for-each (lambda (nm/ty) (register-resolved-type-alias (car nm/ty) (cadr nm/ty))) initial-type-names)) diff --git a/collects/typed-scheme/private/lexical-env.ss b/collects/typed-scheme/env/lexical-env.ss similarity index 90% rename from collects/typed-scheme/private/lexical-env.ss rename to collects/typed-scheme/env/lexical-env.ss index e5946a3126..63a1295b76 100644 --- a/collects/typed-scheme/private/lexical-env.ss +++ b/collects/typed-scheme/env/lexical-env.ss @@ -1,6 +1,12 @@ #lang scheme/base -(require "type-environments.ss" "tc-utils.ss" "type-env.ss" "mutated-vars.ss" "type-utils.ss" "type-effect-convenience.ss") +(require (except-in "../utils/utils.ss" extend)) +(require "type-environments.ss" + (utils tc-utils) + "type-env.ss" + (private mutated-vars) + (private type-utils) + (private type-effect-convenience)) (provide (all-defined-out)) diff --git a/collects/typed-scheme/private/type-alias-env.ss b/collects/typed-scheme/env/type-alias-env.ss similarity index 96% rename from collects/typed-scheme/private/type-alias-env.ss rename to collects/typed-scheme/env/type-alias-env.ss index 0be4da74a5..dd9183d32c 100644 --- a/collects/typed-scheme/private/type-alias-env.ss +++ b/collects/typed-scheme/env/type-alias-env.ss @@ -1,7 +1,8 @@ #lang scheme/base +(require (except-in "../utils/utils.ss" extend)) (require syntax/boundmap - "tc-utils.ss" + (utils tc-utils) mzlib/trace scheme/match) diff --git a/collects/typed-scheme/private/type-env.ss b/collects/typed-scheme/env/type-env.ss similarity index 95% rename from collects/typed-scheme/private/type-env.ss rename to collects/typed-scheme/env/type-env.ss index d9dafeeffc..59eb3cad7e 100644 --- a/collects/typed-scheme/private/type-env.ss +++ b/collects/typed-scheme/env/type-env.ss @@ -1,7 +1,9 @@ #lang scheme/base +(require (except-in "../utils/utils.ss" extend)) (require syntax/boundmap - "tc-utils.ss" "type-utils.ss") + (utils tc-utils) + (private type-utils)) (provide register-type finish-register-type diff --git a/collects/typed-scheme/private/type-environments.ss b/collects/typed-scheme/env/type-environments.ss similarity index 96% rename from collects/typed-scheme/private/type-environments.ss rename to collects/typed-scheme/env/type-environments.ss index 536fdfc9c9..0f159ec0bd 100644 --- a/collects/typed-scheme/private/type-environments.ss +++ b/collects/typed-scheme/env/type-environments.ss @@ -10,8 +10,9 @@ initial-tvar-env with-dotted-env/extend) +(require (prefix-in r: "../utils/utils.ss")) (require scheme/match - "tc-utils.ss") + (r:utils tc-utils)) ;; eq? has the type of equal?, and l is an alist (with conses!) (define-struct env (eq? l)) diff --git a/collects/typed-scheme/private/type-name-env.ss b/collects/typed-scheme/env/type-name-env.ss similarity index 93% rename from collects/typed-scheme/private/type-name-env.ss rename to collects/typed-scheme/env/type-name-env.ss index 370b77e7c6..d6773f0ea5 100644 --- a/collects/typed-scheme/private/type-name-env.ss +++ b/collects/typed-scheme/env/type-name-env.ss @@ -1,9 +1,10 @@ #lang scheme/base +(require "../utils/utils.ss") (require syntax/boundmap mzlib/trace - "tc-utils.ss" - "type-utils.ss") + (utils tc-utils) + (private type-utils)) (provide register-type-name lookup-type-name diff --git a/collects/typed-scheme/private/constraint-structs.ss b/collects/typed-scheme/infer/constraint-structs.ss similarity index 94% rename from collects/typed-scheme/private/constraint-structs.ss rename to collects/typed-scheme/infer/constraint-structs.ss index def84ae0a6..d5c970348b 100644 --- a/collects/typed-scheme/private/constraint-structs.ss +++ b/collects/typed-scheme/infer/constraint-structs.ss @@ -1,6 +1,7 @@ #lang scheme/base -(require "type-rep.ss" +(require (except-in "../utils/utils.ss" extend)) +(require (rep type-rep) scheme/contract) ;; S, T types diff --git a/collects/typed-scheme/private/constraints.ss b/collects/typed-scheme/infer/constraints.ss similarity index 94% rename from collects/typed-scheme/private/constraints.ss rename to collects/typed-scheme/infer/constraints.ss index 2697109ebe..3dff2c088a 100644 --- a/collects/typed-scheme/private/constraints.ss +++ b/collects/typed-scheme/infer/constraints.ss @@ -1,8 +1,9 @@ #lang scheme/unit -(require "type-effect-convenience.ss" "type-rep.ss" - "type-utils.ss" "union.ss" "tc-utils.ss" - "subtype.ss" "utils.ss" +(require (except-in "../utils/utils.ss" extend)) +(require (private type-effect-convenience type-utils union subtype) + (rep type-rep) + (utils tc-utils) "signatures.ss" "constraint-structs.ss" scheme/match) diff --git a/collects/typed-scheme/private/dmap.ss b/collects/typed-scheme/infer/dmap.ss similarity index 92% rename from collects/typed-scheme/private/dmap.ss rename to collects/typed-scheme/infer/dmap.ss index ef2112bae1..9592668061 100644 --- a/collects/typed-scheme/private/dmap.ss +++ b/collects/typed-scheme/infer/dmap.ss @@ -1,6 +1,8 @@ #lang scheme/unit -(require "signatures.ss" "utils.ss" "tc-utils.ss" "constraint-structs.ss" +(require (except-in "../utils/utils.ss" extend)) +(require "signatures.ss" "constraint-structs.ss" + (utils tc-utils) scheme/match) (import constraints^) diff --git a/collects/typed-scheme/infer/infer-dummy.ss b/collects/typed-scheme/infer/infer-dummy.ss new file mode 100644 index 0000000000..d83922a61e --- /dev/null +++ b/collects/typed-scheme/infer/infer-dummy.ss @@ -0,0 +1,8 @@ +#lang scheme/base +(require "../utils/utils.ss") + +(require (rep type-rep) (utils tc-utils)) + +(define infer-param (make-parameter (lambda e (int-err "infer not initialized")))) +(define (unify X S T) ((infer-param) X S T (make-Univ) null)) +(provide unify infer-param) \ No newline at end of file diff --git a/collects/typed-scheme/private/infer-unit.ss b/collects/typed-scheme/infer/infer-unit.ss similarity index 92% rename from collects/typed-scheme/private/infer-unit.ss rename to collects/typed-scheme/infer/infer-unit.ss index 27ec65707c..c640d363ba 100644 --- a/collects/typed-scheme/private/infer-unit.ss +++ b/collects/typed-scheme/infer/infer-unit.ss @@ -1,12 +1,14 @@ #lang scheme/unit -(require "type-effect-convenience.ss" "type-rep.ss" "effect-rep.ss" "rep-utils.ss" - "free-variance.ss" - (except-in "type-utils.ss" Dotted) - "union.ss" "tc-utils.ss" "type-name-env.ss" - "subtype.ss" "remove-intersect.ss" "signatures.ss" "utils.ss" +(require (except-in "../utils/utils.ss")) +(require (rep free-variance type-rep effect-rep rep-utils) + (private type-effect-convenience union subtype remove-intersect) + (utils tc-utils) + (env type-name-env) + (except-in (private type-utils) Dotted) "constraint-structs.ss" - (only-in "type-environments.ss" lookup current-tvars) + "signatures.ss" + (only-in (env type-environments) lookup current-tvars) scheme/match mzlib/etc mzlib/trace @@ -111,15 +113,15 @@ (define (cgen/arr V X t-arr s-arr) (define (cg S T) (cgen V X S T)) (match* (t-arr s-arr) - [((arr: ts t #f #f t-thn-eff t-els-eff) - (arr: ss s #f #f s-thn-eff s-els-eff)) + [((arr: ts t #f #f '() t-thn-eff t-els-eff) + (arr: ss s #f #f '() s-thn-eff s-els-eff)) (cset-meet* (list (cgen/list V X ss ts) (cg t s) (cgen/eff/list V X t-thn-eff s-thn-eff) (cgen/eff/list V X t-els-eff s-els-eff)))] - [((arr: ts t t-rest #f t-thn-eff t-els-eff) - (arr: ss s s-rest #f s-thn-eff s-els-eff)) + [((arr: ts t t-rest #f '() t-thn-eff t-els-eff) + (arr: ss s s-rest #f '() s-thn-eff s-els-eff)) (let ([arg-mapping (cond [(and t-rest s-rest (<= (length ts) (length ss))) (cgen/list V X (cons s-rest ss) (cons t-rest (extend ss ts t-rest)))] @@ -135,8 +137,8 @@ (list arg-mapping ret-mapping (cgen/eff/list V X t-thn-eff s-thn-eff) (cgen/eff/list V X t-els-eff s-els-eff))))] - [((arr: ts t #f (cons dty dbound) t-thn-eff t-els-eff) - (arr: ss s #f #f s-thn-eff s-els-eff)) + [((arr: ts t #f (cons dty dbound) '() t-thn-eff t-els-eff) + (arr: ss s #f #f '() s-thn-eff s-els-eff)) (unless (memq dbound X) (fail! S T)) (unless (<= (length ts) (length ss)) @@ -146,10 +148,10 @@ (gensym dbound))] [new-tys (for/list ([var vars]) (substitute (make-F var) dbound dty))] - [new-cset (cgen/arr V (append vars X) (make-arr (append ts new-tys) t #f #f t-thn-eff t-els-eff) s-arr)]) + [new-cset (cgen/arr V (append vars X) (make-arr (append ts new-tys) t #f #f null t-thn-eff t-els-eff) s-arr)]) (move-vars-to-dmap new-cset dbound vars))] - [((arr: ts t #f #f t-thn-eff t-els-eff) - (arr: ss s #f (cons dty dbound) s-thn-eff s-els-eff)) + [((arr: ts t #f #f '() t-thn-eff t-els-eff) + (arr: ss s #f (cons dty dbound) '() s-thn-eff s-els-eff)) (unless (memq dbound X) (fail! S T)) (unless (<= (length ss) (length ts)) @@ -159,10 +161,10 @@ (gensym dbound))] [new-tys (for/list ([var vars]) (substitute (make-F var) dbound dty))] - [new-cset (cgen/arr V (append vars X) t-arr (make-arr (append ss new-tys) s #f #f s-thn-eff s-els-eff))]) + [new-cset (cgen/arr V (append vars X) t-arr (make-arr (append ss new-tys) s #f #f null s-thn-eff s-els-eff))]) (move-vars-to-dmap new-cset dbound vars))] - [((arr: ts t #f (cons t-dty dbound) t-thn-eff t-els-eff) - (arr: ss s #f (cons s-dty dbound) s-thn-eff s-els-eff)) + [((arr: ts t #f (cons t-dty dbound) '() t-thn-eff t-els-eff) + (arr: ss s #f (cons s-dty dbound) '() s-thn-eff s-els-eff)) (unless (= (length ts) (length ss)) (fail! S T)) ;; If we want to infer the dotted bound, then why is it in both types? @@ -175,8 +177,8 @@ (list arg-mapping darg-mapping ret-mapping (cgen/eff/list V X t-thn-eff s-thn-eff) (cgen/eff/list V X t-els-eff s-els-eff))))] - [((arr: ts t #f (cons t-dty dbound) t-thn-eff t-els-eff) - (arr: ss s #f (cons s-dty dbound*) s-thn-eff s-els-eff)) + [((arr: ts t #f (cons t-dty dbound) '() t-thn-eff t-els-eff) + (arr: ss s #f (cons s-dty dbound*) '() s-thn-eff s-els-eff)) (unless (= (length ts) (length ss)) (fail! S T)) (let* ([arg-mapping (cgen/list V X ss ts)] @@ -186,8 +188,8 @@ (list arg-mapping darg-mapping ret-mapping (cgen/eff/list V X t-thn-eff s-thn-eff) (cgen/eff/list V X t-els-eff s-els-eff))))] - [((arr: ts t t-rest #f t-thn-eff t-els-eff) - (arr: ss s #f (cons s-dty dbound) s-thn-eff s-els-eff)) + [((arr: ts t t-rest #f '() t-thn-eff t-els-eff) + (arr: ss s #f (cons s-dty dbound) '() s-thn-eff s-els-eff)) (unless (memq dbound X) (fail! S T)) (if (<= (length ts) (length ss)) @@ -205,11 +207,11 @@ [new-tys (for/list ([var vars]) (substitute (make-F var) dbound s-dty))] [new-cset (cgen/arr V (append vars X) t-arr - (make-arr (append ss new-tys) s #f (cons s-dty dbound) s-thn-eff s-els-eff))]) + (make-arr (append ss new-tys) s #f (cons s-dty dbound) null s-thn-eff s-els-eff))]) (move-vars+rest-to-dmap new-cset dbound vars)))] ;; If dotted <: starred is correct, add it below. Not sure it is. - [((arr: ts t #f (cons t-dty dbound) t-thn-eff t-els-eff) - (arr: ss s s-rest #f s-thn-eff s-els-eff)) + [((arr: ts t #f (cons t-dty dbound) '() t-thn-eff t-els-eff) + (arr: ss s s-rest #f '() s-thn-eff s-els-eff)) (unless (memq dbound X) (fail! S T)) (cond [(< (length ts) (length ss)) diff --git a/collects/typed-scheme/private/infer.ss b/collects/typed-scheme/infer/infer.ss similarity index 67% rename from collects/typed-scheme/private/infer.ss rename to collects/typed-scheme/infer/infer.ss index d860e5f551..208943a32f 100644 --- a/collects/typed-scheme/private/infer.ss +++ b/collects/typed-scheme/infer/infer.ss @@ -1,9 +1,10 @@ #lang scheme/base +(require (except-in "../utils/utils.ss" infer)) (require "infer-unit.ss" "constraints.ss" "dmap.ss" "signatures.ss" "restrict.ss" "promote-demote.ss" (only-in scheme/unit provide-signature-elements) - "unit-utils.ss") + (utils unit-utils)) (provide-signature-elements restrict^ infer^) diff --git a/collects/typed-scheme/private/promote-demote.ss b/collects/typed-scheme/infer/promote-demote.ss similarity index 80% rename from collects/typed-scheme/private/promote-demote.ss rename to collects/typed-scheme/infer/promote-demote.ss index bbb1d7b229..8705122937 100644 --- a/collects/typed-scheme/private/promote-demote.ss +++ b/collects/typed-scheme/infer/promote-demote.ss @@ -1,8 +1,9 @@ #lang scheme/unit -(require "type-effect-convenience.ss" "type-rep.ss" - "type-utils.ss" "union.ss" - "signatures.ss" +(require "../utils/utils.ss") +(require (rep type-rep) + (private type-effect-convenience union type-utils) + "signatures.ss" scheme/list) (import) @@ -26,7 +27,7 @@ [#:Param in out (make-Param (var-demote in V) (vp out))] - [#:arr dom rng rest drest thn els + [#:arr dom rng rest drest kws thn els (cond [(apply V-in? V (append thn els)) (make-arr null (Un) Univ #f null null)] @@ -35,6 +36,8 @@ (vp rng) (var-demote (car drest) V) #f + (for/list ([(kw kwt) (in-pairs kws)]) + (cons kw (var-demote kwt V))) thn els)] [else @@ -44,6 +47,8 @@ (and drest (cons (var-demote (car drest) V) (cdr drest))) + (for/list ([(kw kwt) (in-pairs kws)]) + (cons kw (var-demote kwt V))) thn els)])])) @@ -61,7 +66,7 @@ [#:Param in out (make-Param (var-promote in V) (vd out))] - [#:arr dom rng rest drest thn els + [#:arr dom rng rest drest kws thn els (cond [(apply V-in? V (append thn els)) (make-arr null (Un) Univ #f null null)] @@ -70,6 +75,8 @@ (vd rng) (var-promote (car drest) V) #f + (for/list ([(kw kwt) (in-pairs kws)]) + (cons kw (var-promote kwt V))) thn els)] [else @@ -79,5 +86,7 @@ (and drest (cons (var-promote (car drest) V) (cdr drest))) + (for/list ([(kw kwt) (in-pairs kws)]) + (cons kw (var-promote kwt V))) thn els)])])) diff --git a/collects/typed-scheme/private/restrict.ss b/collects/typed-scheme/infer/restrict.ss similarity index 90% rename from collects/typed-scheme/private/restrict.ss rename to collects/typed-scheme/infer/restrict.ss index 2c86a687b7..e13656056c 100644 --- a/collects/typed-scheme/private/restrict.ss +++ b/collects/typed-scheme/infer/restrict.ss @@ -1,8 +1,8 @@ #lang scheme/unit -(require "type-rep.ss" - "type-utils.ss" "union.ss" - "subtype.ss" "remove-intersect.ss" +(require "../utils/utils.ss") +(require (rep type-rep) + (private type-utils union remove-intersect subtype) "signatures.ss" scheme/match) diff --git a/collects/typed-scheme/infer/signatures.ss b/collects/typed-scheme/infer/signatures.ss new file mode 100644 index 0000000000..6db02b38dc --- /dev/null +++ b/collects/typed-scheme/infer/signatures.ss @@ -0,0 +1,29 @@ +#lang scheme/base +(require scheme/unit) +(provide (all-defined-out)) + +(define-signature dmap^ + (dmap-meet)) + +(define-signature promote-demote^ + (var-promote var-demote)) + +(define-signature constraints^ + (exn:infer? + fail-sym + ;; inference failure - masked before it gets to the user program + (define-syntaxes (fail!) + (syntax-rules () + [(_ s t) (raise fail-sym)])) + cset-meet cset-meet* + no-constraint + empty-cset + insert + cset-combine + c-meet)) + +(define-signature restrict^ + (restrict)) + +(define-signature infer^ + (infer infer/vararg infer/dots)) diff --git a/collects/typed-scheme/no-check.ss b/collects/typed-scheme/no-check.ss new file mode 100644 index 0000000000..470a7bed8a --- /dev/null +++ b/collects/typed-scheme/no-check.ss @@ -0,0 +1,5 @@ +#lang scheme/base + +(require "private/prims.ss") +(provide (all-from-out scheme/base) + (all-from-out "private/prims.ss")) \ No newline at end of file diff --git a/collects/typed-scheme/no-check/lang/reader.ss b/collects/typed-scheme/no-check/lang/reader.ss new file mode 100644 index 0000000000..c35cbecc78 --- /dev/null +++ b/collects/typed-scheme/no-check/lang/reader.ss @@ -0,0 +1,13 @@ +#lang scheme/base +(require (prefix-in r: "../../typed-reader.ss") + (only-in syntax/module-reader wrap-read-all)) + +(define (*read in modpath line col pos) + (wrap-read-all 'typed-scheme/no-check in r:read modpath #f line col pos)) + +(define (*read-syntax src in modpath line col pos) + (wrap-read-all + 'typed-scheme/no-check in (lambda (in) (r:read-syntax src in)) + modpath src line col pos)) + +(provide (rename-out [*read read] [*read-syntax read-syntax])) diff --git a/collects/typed-scheme/private/base-env.ss b/collects/typed-scheme/private/base-env.ss index 59708588b1..6600a1f7f2 100644 --- a/collects/typed-scheme/private/base-env.ss +++ b/collects/typed-scheme/private/base-env.ss @@ -3,6 +3,7 @@ ;; these are libraries providing functions we add types to that are not in scheme/base (require "extra-procs.ss" + "../utils/utils.ss" (only-in scheme/list cons? take drop add-between last filter-map) (only-in rnrs/lists-6 fold-left) '#%paramz @@ -15,13 +16,12 @@ ;; these are all for constructing the types given to variables (require (for-syntax scheme/base - "init-envs.ss" - "effect-rep.ss" - (except-in "type-rep.ss" make-arr) + (env init-envs) + (except-in (rep effect-rep type-rep) make-arr) "type-effect-convenience.ss" (only-in "type-effect-convenience.ss" [make-arr* make-arr]) "union.ss" - "tc-structs.ss")) + (typecheck tc-structs))) (define-for-syntax (initialize-others) (d-s date @@ -57,6 +57,9 @@ [qq-append qq-append-ty] [id ty] ...)))])) +(define-for-syntax (one-of/c . args) + (apply Un (map -val args))) + (define-initial-env initial-env ;; make-promise @@ -145,9 +148,13 @@ [string-append (->* null -String -String)] [open-input-string (-> -String -Input-Port)] [open-output-file - (cl-> - [(-Pathlike) -Port] - [(-Pathlike Sym) -Port])] + (->key -Pathlike + #:mode (one-of/c 'binary 'text) #f + #:exists (one-of/c 'error 'append 'update 'can-update + 'replace 'truncate + 'must-truncate 'truncate/replace) + #f + -Output-Port)] [read (cl-> [(-Port) -Sexp] [() -Sexp])] @@ -205,9 +212,7 @@ [remove* (-poly (a b) (cl-> [((-lst a) (-lst a)) (-lst a)] [((-lst a) (-lst b) (a b . -> . B)) (-lst b)]))] - - [call-with-values (-poly (a b) (-> (-> a) (-> a b) b))] - + (error (make-Function (list (make-arr null (Un)) @@ -246,7 +251,6 @@ (- (cl->* (->* (list -Integer) -Integer -Integer) (->* (list N) N N))) (max (->* (list N) N N)) (min (->* (list N) N N)) - [values (make-Poly '(a) (-> (-v a) (-v a)))] [vector-ref (make-Poly (list 'a) ((make-Vector (-v a)) N . -> . (-v a)))] [build-vector (-poly (a) (-Integer (-Integer . -> . a) . -> . (make-Vector a)))] @@ -467,7 +471,7 @@ [(-Bytes N) -Bytes] [(-Bytes N N) -Bytes])] [bytes-length (-> -Bytes N)] - [open-input-file (-> -Pathlike -Input-Port)] + [open-input-file (->key -Pathlike #:mode (Un (-val 'binary) (-val 'text)) #f -Input-Port)] [close-input-port (-> -Input-Port -Void)] [close-output-port (-> -Output-Port -Void)] [read-line (cl-> @@ -553,8 +557,11 @@ [syntax-property (-poly (a) (cl->* (-> (-Syntax a) Univ Univ (-Syntax a)) (-> (-Syntax Univ) Univ Univ)))] - [values* (-polydots (a) (null (a a) . ->... . (make-ValuesDots null a 'a)))] - [call-with-values* (-polydots (b a) ((-> (make-ValuesDots null a 'a)) (null (a a) . ->... . b) . -> . b))] + [values (-polydots (a) (null (a a) . ->... . (make-ValuesDots null a 'a)))] + [call-with-values (-polydots (b a) ((-> (make-ValuesDots null a 'a)) (null (a a) . ->... . b) . -> . b))] + + [eof (-val eof)] + [read-accept-reader (-Param B B)] ) (begin-for-syntax diff --git a/collects/typed-scheme/private/base-types.ss b/collects/typed-scheme/private/base-types.ss index cc4bb42a3d..6058fd4b9c 100644 --- a/collects/typed-scheme/private/base-types.ss +++ b/collects/typed-scheme/private/base-types.ss @@ -1,9 +1,10 @@ #lang scheme/base +(require (except-in "../utils/utils.ss" extend)) (require (for-syntax scheme/base - "init-envs.ss" - (except-in "type-rep.ss" make-arr) + (env init-envs) + (except-in (rep type-rep) make-arr) "type-effect-convenience.ss" (only-in "type-effect-convenience.ss" [make-arr* make-arr]) "union.ss")) diff --git a/collects/typed-scheme/private/extra-procs.ss b/collects/typed-scheme/private/extra-procs.ss index 83aa9c4036..b5cd5378db 100644 --- a/collects/typed-scheme/private/extra-procs.ss +++ b/collects/typed-scheme/private/extra-procs.ss @@ -1,5 +1,5 @@ #lang scheme/base -(provide assert call-with-values* values*) +(provide assert call-with-values* values* foo) (define (assert v) (unless v @@ -15,4 +15,7 @@ (car as) (map car bss)))) (define call-with-values* call-with-values) -(define values* values) \ No newline at end of file +(define values* values) + +(define (foo x #:bar [bar #f]) + bar) \ No newline at end of file diff --git a/collects/typed-scheme/private/infer-dummy.ss b/collects/typed-scheme/private/infer-dummy.ss deleted file mode 100644 index 8645a31435..0000000000 --- a/collects/typed-scheme/private/infer-dummy.ss +++ /dev/null @@ -1,7 +0,0 @@ -#lang scheme/base - -(require "type-rep.ss") - -(define infer-param (make-parameter (lambda e (error 'infer "not initialized")))) -(define (unify X S T) ((infer-param) X S T (make-Univ) null)) -(provide unify infer-param) \ No newline at end of file diff --git a/collects/typed-scheme/private/mutated-vars.ss b/collects/typed-scheme/private/mutated-vars.ss index 6e7a2c2da9..a362bd5361 100644 --- a/collects/typed-scheme/private/mutated-vars.ss +++ b/collects/typed-scheme/private/mutated-vars.ss @@ -14,12 +14,11 @@ ;; syntax -> void (define (fmv/list lstx) (for-each find-mutated-vars (syntax->list lstx))) - ;(printf "called with ~a~n" (syntax->datum form)) + ;(when (and (pair? (syntax->datum form))) (printf "called with ~a~n" (syntax->datum form))) (kernel-syntax-case* form #f (define-type-alias-internal define-typed-struct-internal require/typed-internal) ;; what we care about: set! [(set! v e) (begin - ;(printf "mutated var found: ~a~n" (syntax-e #'v)) (module-identifier-mapping-put! table #'v #t))] [(define-values (var ...) expr) (find-mutated-vars #'expr)] @@ -28,15 +27,13 @@ [(begin0 . rest) (fmv/list #'rest)] [(#%plain-lambda _ . rest) (fmv/list #'rest)] [(case-lambda (_ . rest) ...) (for-each fmv/list (syntax->list #'(rest ...)))] - [(if e1 e2) (begin (find-mutated-vars #'e1) (find-mutated-vars #'e2))] - [(if e1 e2 e3) (begin (find-mutated-vars #'e1) (find-mutated-vars #'e1) (find-mutated-vars #'e3))] - [(with-continuation-mark e1 e2 e3) (begin (find-mutated-vars #'e1) - (find-mutated-vars #'e1) - (find-mutated-vars #'e3))] + [(if . es) (fmv/list #'es)] + [(with-continuation-mark . es) (fmv/list #'es)] [(let-values ([_ e] ...) . b) (begin (fmv/list #'(e ...)) (fmv/list #'b))] [(letrec-values ([_ e] ...) . b) (begin (fmv/list #'(e ...)) - (fmv/list #'b))] + (fmv/list #'b))] + [(#%expression e) (find-mutated-vars #'e)] ;; all the other forms don't have any expression subforms (like #%top) [_ (void)])) diff --git a/collects/typed-scheme/private/parse-type.ss b/collects/typed-scheme/private/parse-type.ss index 2b92c493d6..07adfd9e17 100644 --- a/collects/typed-scheme/private/parse-type.ss +++ b/collects/typed-scheme/private/parse-type.ss @@ -2,16 +2,15 @@ (provide parse-type parse-type/id) -(require (except-in "type-rep.ss" make-arr) +(require (except-in "../utils/utils.ss" extend)) +(require (except-in (rep type-rep) make-arr) "type-effect-convenience.ss" (only-in "type-effect-convenience.ss" [make-arr* make-arr]) - "tc-utils.ss" + (utils tc-utils) "union.ss" syntax/stx - (except-in "type-environments.ss") - "type-name-env.ss" - "type-alias-env.ss" - "type-utils.ss" + (env type-environments type-name-env type-alias-env) + "type-utils.ss" scheme/match) (define enable-mu-parsing (make-parameter #t)) @@ -213,7 +212,7 @@ ;(printf "found a type name ~a~n" #'id) (make-Name #'id)] [else - (tc-error/delayed "unbound type ~a" (syntax-e #'id)) + (tc-error/delayed "unbound type name ~a" (syntax-e #'id)) Univ])] [(All . rest) (eq? (syntax-e #'All) 'All) (tc-error "All: bad syntax")] diff --git a/collects/typed-scheme/private/prims.ss b/collects/typed-scheme/private/prims.ss index ef3e7cc5a7..9068659cfd 100644 --- a/collects/typed-scheme/private/prims.ss +++ b/collects/typed-scheme/private/prims.ss @@ -22,20 +22,20 @@ This file defines two sorts of primitives. All of them are provided into any mod (provide (all-defined-out) (rename-out [define-typed-struct define-struct:])) +(require (except-in "../utils/utils.ss" extend)) (require (for-syntax scheme/base - "type-rep.ss" + (rep type-rep) mzlib/match "parse-type.ss" syntax/struct syntax/stx - "utils.ss" - "tc-utils.ss" - "type-name-env.ss" + (utils utils tc-utils) + (env type-name-env) "type-contract.ss")) (require "require-contract.ss" - "internal-forms.ss" + (typecheck internal-forms) (except-in mzlib/contract ->) (only-in mzlib/contract [-> c->]) mzlib/struct diff --git a/collects/typed-scheme/private/remove-intersect.ss b/collects/typed-scheme/private/remove-intersect.ss index f9b273e80a..d244fb7302 100644 --- a/collects/typed-scheme/private/remove-intersect.ss +++ b/collects/typed-scheme/private/remove-intersect.ss @@ -1,7 +1,8 @@ #lang scheme/base -(require "type-rep.ss" "union.ss" "subtype.ss" - "type-utils.ss" "resolve-type.ss" "type-effect-convenience.ss" +(require (except-in "../utils/utils.ss" extend)) +(require (rep type-rep) + (private union subtype resolve-type type-effect-convenience type-utils) mzlib/plt-match mzlib/trace) (provide (rename-out [*remove remove]) overlap) diff --git a/collects/typed-scheme/private/resolve-type.ss b/collects/typed-scheme/private/resolve-type.ss index d68de69267..6526a42819 100644 --- a/collects/typed-scheme/private/resolve-type.ss +++ b/collects/typed-scheme/private/resolve-type.ss @@ -1,6 +1,7 @@ #lang scheme/base +(require "../utils/utils.ss") -(require "type-rep.ss" "type-name-env.ss" "tc-utils.ss" +(require (rep type-rep) (env type-name-env) (utils tc-utils) "type-utils.ss" mzlib/plt-match mzlib/trace) diff --git a/collects/typed-scheme/private/subtype.ss b/collects/typed-scheme/private/subtype.ss index 398fe7b226..1db8c33be8 100644 --- a/collects/typed-scheme/private/subtype.ss +++ b/collects/typed-scheme/private/subtype.ss @@ -1,12 +1,13 @@ #lang scheme/base +(require "../utils/utils.ss") -(require (except-in "type-rep.ss" sub-eff) "type-utils.ss" - "tc-utils.ss" - "effect-rep.ss" +(require (except-in (rep type-rep effect-rep) sub-eff) + (utils tc-utils) + "type-utils.ss" "type-comparison.ss" "resolve-type.ss" - "type-name-env.ss" - (only-in "infer-dummy.ss" unify) + (env type-name-env) + (only-in (infer infer-dummy) unify) mzlib/plt-match mzlib/trace) @@ -100,10 +101,13 @@ (match (list s t) ;; top for functions is above everything [(list _ (top-arr:)) A0] - [(list (arr: s1 s2 #f #f thn-eff els-eff) (arr: t1 t2 #f #f thn-eff els-eff)) - (let ([A1 (subtypes* A0 t1 s1)]) + [(list (arr: s1 s2 #f #f (list (cons kw s-kw-ty) ...) thn-eff els-eff) + (arr: t1 t2 #f #f (list (cons kw t-kw-ty) ...) thn-eff els-eff)) + (let* ([A1 (subtypes* A0 t1 s1)] + [A2 (subtypes* A1 t-kw-ty s-kw-ty)]) (subtype* A1 s2 t2))] - [(list (arr: s1 s2 s3 #f thn-eff els-eff) (arr: t1 t2 t3 #f thn-eff* els-eff*)) + [(list (arr: s1 s2 s3 #f (list (cons kw s-kw-ty) ...) thn-eff els-eff) + (arr: t1 t2 t3 #f (list (cons kw t-kw-ty) ...) thn-eff* els-eff*)) (unless (or (and (null? thn-eff*) (null? els-eff*)) (and (effects-equal? thn-eff thn-eff*) @@ -115,10 +119,11 @@ (andmap sub-eff els-eff els-eff*))) (fail! s t)) ;; either the effects have to be the same, or the supertype can't have effects - (let ([A (subtypes*/varargs A0 t1 s1 s3)]) + (let* ([A2 (subtypes*/varargs A0 t1 s1 s3)] + [A3 (subtypes* A2 t-kw-ty s-kw-ty)]) (if (not t3) - (subtype* A s2 t2) - (let ([A1 (subtype* A t3 s3)]) + (subtype* A3 s2 t2) + (let ([A1 (subtype* A3 t3 s3)]) (subtype* A1 s2 t2))))] [else (fail! s t)]))) diff --git a/collects/typed-scheme/private/type-annotation.ss b/collects/typed-scheme/private/type-annotation.ss index 1a72e73bdd..bbb8303412 100644 --- a/collects/typed-scheme/private/type-annotation.ss +++ b/collects/typed-scheme/private/type-annotation.ss @@ -1,7 +1,11 @@ #lang scheme/base -(require "type-rep.ss" "parse-type.ss" "tc-utils.ss" "subtype.ss" "utils.ss" - "type-env.ss" "type-effect-convenience.ss" "resolve-type.ss" "union.ss" +(require (except-in "../utils/utils.ss" extend)) +(require (rep type-rep) + (utils tc-utils) + (env type-env) + "parse-type.ss" "subtype.ss" + "type-effect-convenience.ss" "resolve-type.ss" "union.ss" scheme/match mzlib/trace) (provide type-annotation get-type diff --git a/collects/typed-scheme/private/type-comparison.ss b/collects/typed-scheme/private/type-comparison.ss index dab6743a78..dbc70e5f46 100644 --- a/collects/typed-scheme/private/type-comparison.ss +++ b/collects/typed-scheme/private/type-comparison.ss @@ -1,3 +1,4 @@ #lang scheme/base -(require "type-rep.ss" "type-utils.ss") +(require "../utils/utils.ss") +(require (rep type-rep) "type-utils.ss") (provide type-equal? tc-result-equal? typecontract define/fixup-contract? generate-contract-def change-contract-fixups) +(require (except-in "../utils/utils.ss" extend)) (require - "type-rep.ss" + (rep type-rep) + (typecheck internal-forms) + (utils tc-utils) + (env type-name-env) "parse-type.ss" - "utils.ss" - "type-name-env.ss" "require-contract.ss" - "internal-forms.ss" - "tc-utils.ss" "resolve-type.ss" "type-utils.ss" (only-in "type-effect-convenience.ss" Any-Syntax) @@ -80,13 +80,13 @@ (define (f a) (define-values (dom* rngs* rst) (match a - [(arr: dom (Values: rngs) #f #f _ _) + [(arr: dom (Values: rngs) #f #f '() _ _) (values (map t->c dom) (map t->c rngs) #f)] - [(arr: dom rng #f #f _ _) + [(arr: dom rng #f #f '() _ _) (values (map t->c dom) (list (t->c rng)) #f)] - [(arr: dom (Values: rngs) rst #f _ _) + [(arr: dom (Values: rngs) rst #f '() _ _) (values (map t->c dom) (map t->c rngs) (t->c rst))] - [(arr: dom rng rst #f _ _) + [(arr: dom rng rst #f '() _ _) (values (map t->c dom) (list (t->c rng)) (t->c rst))])) (with-syntax ([(dom* ...) dom*] diff --git a/collects/typed-scheme/private/type-effect-convenience.ss b/collects/typed-scheme/private/type-effect-convenience.ss index 9ae26d5479..13aa199c91 100644 --- a/collects/typed-scheme/private/type-effect-convenience.ss +++ b/collects/typed-scheme/private/type-effect-convenience.ss @@ -1,14 +1,16 @@ #lang scheme/base -(require "type-rep.ss" - "effect-rep.ss" +(require "../utils/utils.ss") + +(require (rep type-rep effect-rep) + (utils tc-utils) scheme/match "type-comparison.ss" "type-effect-printer.ss" "union.ss" "subtype.ss" "type-utils.ss" - "tc-utils.ss" scheme/promise + (for-syntax macro-debugger/stxclass/stxclass) (for-syntax scheme/base)) (provide (all-defined-out)) @@ -33,7 +35,7 @@ [(Latent-Remove-Effect: t) (make-Remove-Effect t v)] [(True-Effect:) eff] [(False-Effect:) eff] - [_ (error 'internal-tc-error "can't add var to effect ~a" eff)])) + [_ (int-err "can't add var ~a to effect ~a" v eff)])) (define-syntax (-> stx) (syntax-case* stx (:) (lambda (a b) (eq? (syntax-e a) (syntax-e b))) @@ -78,11 +80,26 @@ [(Function: as) as])) (make-Function (map car (map funty-arities args)))) +(define-syntax (->key stx) + (syntax-parse stx + [(_ ty:expr ... ((k:keyword kty:expr opt:boolean)) ...* rng) + #'(make-Function + (list + (make-arr* (list ty ...) + rng + #f + #f + (list (make-Keyword 'k kty opt) ...) + null + null)))])) + (define make-arr* - (case-lambda [(dom rng) (make-arr* dom rng #f (list) (list))] - [(dom rng rest) (make-arr dom rng rest #f (list) (list))] - [(dom rng rest eff1 eff2) (make-arr dom rng rest #f eff1 eff2)] - [(dom rng rest drest eff1 eff2) (make-arr dom rng rest drest eff1 eff2)])) + (case-lambda [(dom rng) (make-arr dom rng #f #f null (list) (list))] + [(dom rng rest) (make-arr dom rng rest #f null (list) (list))] + [(dom rng rest eff1 eff2) (make-arr dom rng rest #f null eff1 eff2)] + [(dom rng rest drest eff1 eff2) (make-arr dom rng rest drest null eff1 eff2)] + [(dom rng rest drest kws eff1 eff2) + (make-arr dom rng rest drest (sort #:key Keyword-kw kws keywordlist #'(kw ...))) - (syntax/loc stx (tc rec-id (lambda (e) (sub-eff rec-id e)) ty [kw pats ... es] ...))] + [(tc rec-id ty clauses ...) + (syntax-case #'(clauses ...) () + [([kw pats ... es] ...) #t] + [_ #f]) + (syntax/loc stx (tc rec-id (lambda (e) (sub-eff rec-id e)) ty clauses ...))] [(tc rec-id e-rec-id ty clauses ...) (begin (map add-clause (syntax->list #'(clauses ...))) @@ -296,7 +314,7 @@ ;; necessary to avoid infinite loops [#:Union elems (*Union (remove-dups (sort (map sb elems) typelist args))) (match f-ty - [(tc-result: (Function: (list (arr: doms rngs rests drests thn-effs els-effs) ...))) + [(tc-result: (Function: (list (arr: doms rngs rests drests '() thn-effs els-effs) ...))) (when (null? doms) (tc-error/expr #:return (ret (Un)) "empty case-lambda given as argument to apply")) @@ -204,7 +198,7 @@ (printf/log "Non-poly apply, ... arg\n") (ret (car rngs*))] [else (loop (cdr doms*) (cdr rngs*) (cdr rests*) (cdr drests*))])))] - [(tc-result: (Poly: vars (Function: (list (arr: doms rngs rests drests thn-effs els-effs) ..1)))) + [(tc-result: (Poly: vars (Function: (list (arr: doms rngs rests drests '() thn-effs els-effs) ..1)))) (let*-values ([(arg-tys) (map tc-expr/t fixed-args)] [(tail-ty tail-bound) (with-handlers ([exn:fail:syntax? (lambda _ (values (tc-expr/t tail) #f))]) (tc/dots tail))]) @@ -214,7 +208,7 @@ (let loop ([doms* doms] [rngs* rngs] [rests* rests] [drests* drests]) (cond [(null? doms*) (match f-ty - [(tc-result: (Poly-names: _ (Function: (list (arr: doms rngs rests drests _ _) ..1)))) + [(tc-result: (Poly-names: _ (Function: (list (arr: doms rngs rests drests '() _ _) ..1)))) (tc-error/expr #:return (ret (Un)) (string-append "Bad arguments to polymorphic function in apply:~n" @@ -259,14 +253,14 @@ (tc-error/expr #:return (ret (Un)) "Function has no cases")] [(tc-result: (PolyDots: (and vars (list fixed-vars ... dotted-var)) - (Function: (list (arr: doms rngs rests drests thn-effs els-effs) ..1)))) + (Function: (list (arr: doms rngs rests drests '() thn-effs els-effs) ..1)))) (let*-values ([(arg-tys) (map tc-expr/t fixed-args)] [(tail-ty tail-bound) (with-handlers ([exn:fail:syntax? (lambda _ (values (tc-expr/t tail) #f))]) (tc/dots tail))]) (let loop ([doms* doms] [rngs* rngs] [rests* rests] [drests* drests]) (cond [(null? doms*) (match f-ty - [(tc-result: (PolyDots-names: _ (Function: (list (arr: doms rngs rests drests _ _) ..1)))) + [(tc-result: (PolyDots-names: _ (Function: (list (arr: doms rngs rests drests '() _ _) ..1)))) (tc-error/expr #:return (ret (Un)) (string-append "Bad arguments to polymorphic function in apply:~n" @@ -378,8 +372,8 @@ (define (poly-fail t argtypes #:name [name #f]) (match t - [(or (Poly-names: msg-vars (Function: (list (arr: msg-doms msg-rngs msg-rests msg-drests _ _) ...))) - (PolyDots-names: msg-vars (Function: (list (arr: msg-doms msg-rngs msg-rests msg-drests _ _) ...)))) + [(or (Poly-names: msg-vars (Function: (list (arr: msg-doms msg-rngs msg-rests msg-drests '() _ _) ...))) + (PolyDots-names: msg-vars (Function: (list (arr: msg-doms msg-rngs msg-rests msg-drests '() _ _) ...)))) (let ([fcn-string (if name (format "function ~a (over ~~a)" (syntax->datum name)) "function over ~a")]) @@ -429,7 +423,8 @@ "Wrong number of arguments to parameter - expected 0 or 1, got ~a" (length argtypes))])] ;; single clause functions - [(tc-result: (and t (Function: (list (arr: dom rng rest #f latent-thn-effs latent-els-effs)))) + ;; FIXME - error on non-optional keywords + [(tc-result: (and t (Function: (list (arr: dom rng rest #f _ latent-thn-effs latent-els-effs)))) thn-eff els-eff) (let-values ([(thn-eff els-eff) (tc-args argtypes arg-thn-effs arg-els-effs dom rest @@ -437,7 +432,7 @@ (syntax->list args))]) (ret rng thn-eff els-eff))] ;; non-polymorphic case-lambda functions - [(tc-result: (and t (Function: (list (arr: doms rngs rests (and drests #f) latent-thn-effs latent-els-effs) ..1))) + [(tc-result: (and t (Function: (list (arr: doms rngs rests (and drests #f) '() latent-thn-effs latent-els-effs) ..1))) thn-eff els-eff) (let loop ([doms* doms] [rngs rngs] [rests* rests]) (cond [(null? doms*) @@ -453,19 +448,19 @@ ;; simple polymorphic functions, no rest arguments [(tc-result: (and t (or (Poly: vars - (Function: (list (arr: doms rngs (and rests #f) (and drests #f) thn-effs els-effs) ...))) + (Function: (list (arr: doms rngs (and rests #f) (and drests #f) '() thn-effs els-effs) ...))) (PolyDots: (list vars ... _) - (Function: (list (arr: doms rngs (and rests #f) (and drests #f) thn-effs els-effs) ...)))))) + (Function: (list (arr: doms rngs (and rests #f) (and drests #f) '() thn-effs els-effs) ...)))))) (handle-clauses (doms rngs) f-stx (lambda (dom _) (= (length dom) (length argtypes))) (lambda (dom rng) (infer (fv/list (cons rng dom)) argtypes dom rng (fv rng) expected)) t argtypes expected)] ;; polymorphic varargs [(tc-result: (and t - (or (Poly: vars (Function: (list (arr: doms rngs rests (and drests #f) thn-effs els-effs) ...))) + (or (Poly: vars (Function: (list (arr: doms rngs rests (and drests #f) '() thn-effs els-effs) ...))) ;; we want to infer the dotted-var here as well, and we don't use these separately ;; so we can just use "vars" instead of (list fixed-vars ... dotted-var) - (PolyDots: vars (Function: (list (arr: doms rngs rests (and drests #f) thn-effs els-effs) ...)))))) + (PolyDots: vars (Function: (list (arr: doms rngs rests (and drests #f) '() thn-effs els-effs) ...)))))) (printf/log "Polymorphic varargs function application (~a)\n" (syntax->datum f-stx)) (handle-clauses (doms rests rngs) f-stx (lambda (dom rest rng) (<= (length dom) (length argtypes))) @@ -474,7 +469,7 @@ ;; polymorphic ... type [(tc-result: (and t (PolyDots: (and vars (list fixed-vars ... dotted-var)) - (Function: (list (arr: doms rngs (and #f rests) (cons dtys dbounds) thn-effs els-effs) ...))))) + (Function: (list (arr: doms rngs (and #f rests) (cons dtys dbounds) '() thn-effs els-effs) ...))))) (printf/log "Polymorphic ... function application (~a)\n" (syntax->datum f-stx)) (handle-clauses (doms dtys dbounds rngs) f-stx (lambda (dom dty dbound rng) (and (<= (length dom) (length argtypes)) @@ -566,6 +561,47 @@ [(tc-result: t) (tc-error/expr #:return (ret (Un)) "expected a class value for object creation, got: ~a" t)])))) +(define (tc-keywords form arities kws kw-args pos-args expected) + (match arities + [(list (arr: dom rng rest #f ktys _ _)) + ;; assumes that everything is in sorted order + (let loop ([actual-kws kws] + [actuals (map tc-expr/t (syntax->list kw-args))] + [formals ktys]) + (match* (actual-kws formals) + [('() '()) + (void)] + [(_ '()) + (tc-error/expr #:return (ret (Un)) + "Unexpected keyword argument ~a" (car actual-kws))] + [('() (cons fst rst)) + (match fst + [(Keyword: k _ #t) + (tc-error/expr #:return (ret (Un)) + "Missing keyword argument ~a" k)] + [_ (loop actual-kws actuals rst)])] + [((cons k kws-rest) (cons (Keyword: k* t req?) form-rest)) + (cond [(eq? k k*) ;; we have a match + (unless (subtype (car actuals) t) + (tc-error/delayed + "Wrong function argument type, expected ~a, got ~a for keyword argument ~a" + t (car actuals) k)) + (loop kws-rest (cdr actuals) form-rest)] + [req? ;; this keyword argument was required + (tc-error/delayed "Missing keyword argument ~a" k*) + (loop kws-rest (cdr actuals) form-rest)] + [else ;; otherwise, ignore this formal param, and continue + (loop actual-kws actuals form-rest)])])) + (tc/funapp (car (syntax-e form)) kw-args (ret (make-Function arities)) (map tc-expr (syntax->list pos-args)) expected)] + [_ (int-err "case-lambda w/ keywords not supported")])) + + +(define (type->list t) + (match t + [(Pair: (Value: (? keyword? k)) b) (cons k (type->list b))] + [(Value: '()) null] + [_ (int-err "bad value in type->list: ~a" t)])) + (define (tc/app/internal form expected) (kernel-syntax-case* form #f (values apply not list list* call-with-values do-make-object make-object cons @@ -585,7 +621,7 @@ [(Values: ts) ts] [_ (list t)])) (match prod-t - [(Function: (list (arr: (list) vals _ #f _ _))) + [(Function: (list (arr: (list) vals _ #f '() _ _))) (tc/funapp #'con #'prod (tc-expr #'con) (map ret (values-ty->list vals)) expected)] [_ (tc-error/expr #:return (ret (Un)) "First argument to call with values must be a function that can accept no arguments, got: ~a" @@ -621,11 +657,23 @@ [(tc-result: t thn-eff els-eff) (ret B (map var->type-eff els-eff) (map var->type-eff thn-eff))])] ;; special case for `apply' - [(#%plain-app apply f . args) (tc/apply #'f #'args)] + [(#%plain-app apply f . args) (tc/apply #'f #'args)] + ;; special case for keywords + [(#%plain-app + (#%plain-app kpe kws num fn) + kw-list + (#%plain-app list . kw-arg-list) + . pos-args) + (eq? (syntax-e #'kpe) 'keyword-procedure-extract) + (match (tc-expr #'fn) + [(tc-result: (Function: arities)) + (tc-keywords form arities (type->list (tc-expr/t #'kws)) #'kw-arg-list #'pos-args expected)] + [t (tc-error/expr #:return (ret (Un)) + "Cannot apply expression of type ~a, since it is not a function type" t)])] ;; even more special case for match [(#%plain-app (letrec-values ([(lp) (#%plain-lambda args . body)]) lp*) . actuals) (and expected (not (andmap type-annotation (syntax->list #'args))) (free-identifier=? #'lp #'lp*)) - (let-loop-check #'form #'lp #'actuals #'args #'body expected)] + (let-loop-check form #'lp #'actuals #'args #'body expected)] ;; or/andmap of ... argument [(#%plain-app or/andmap f arg) (and diff --git a/collects/typed-scheme/private/tc-dots-unit.ss b/collects/typed-scheme/typecheck/tc-dots-unit.ss similarity index 89% rename from collects/typed-scheme/private/tc-dots-unit.ss rename to collects/typed-scheme/typecheck/tc-dots-unit.ss index 803ef905db..aa2c7c17b1 100644 --- a/collects/typed-scheme/private/tc-dots-unit.ss +++ b/collects/typed-scheme/typecheck/tc-dots-unit.ss @@ -1,10 +1,11 @@ #lang scheme/unit +(require (except-in "../utils/utils.ss" extend)) (require "signatures.ss" - "tc-utils.ss" - "type-environments.ss" - "type-utils.ss" - "type-rep.ss" + (utils tc-utils) + (env type-environments) + (private type-utils) + (rep type-rep) syntax/kerncase scheme/match) diff --git a/collects/typed-scheme/private/tc-expr-unit.ss b/collects/typed-scheme/typecheck/tc-expr-unit.ss similarity index 95% rename from collects/typed-scheme/private/tc-expr-unit.ss rename to collects/typed-scheme/typecheck/tc-expr-unit.ss index feb7129a36..c61bbd3d9f 100644 --- a/collects/typed-scheme/private/tc-expr-unit.ss +++ b/collects/typed-scheme/typecheck/tc-expr-unit.ss @@ -1,21 +1,15 @@ #lang scheme/unit +(require (rename-in "../utils/utils.ss" [private r:private])) (require syntax/kerncase scheme/match "signatures.ss" - "type-utils.ss" - "utils.ss" ;; doesn't need tests - "type-rep.ss" ;; doesn't need tests - "type-effect-convenience.ss" ;; maybe needs tests - "union.ss" - "subtype.ss" ;; has tests - "parse-type.ss" ;; has tests - "tc-utils.ss" ;; doesn't need tests - "lexical-env.ss" ;; maybe needs tests - "type-annotation.ss" ;; has tests - "effect-rep.ss" - (only-in "type-environments.ss" lookup current-tvars extend-env) + (r:private type-utils type-effect-convenience union subtype parse-type type-annotation) + (rep type-rep effect-rep) + (utils tc-utils) + (env lexical-env) + (only-in (env type-environments) lookup current-tvars extend-env) scheme/private/class-internal (only-in srfi/1 split-at)) @@ -41,7 +35,7 @@ [(null? v) (-val null)] [(symbol? v) (-val v)] [(string? v) -String] - [(keyword? v) -Keyword] + [(keyword? v) (-val v)] [(bytes? v) -Bytes] [(list? v) (-Tuple (map tc-literal v))] [(vector? v) (make-Vector (types-of-literals (vector->list v)))] @@ -101,7 +95,8 @@ ;; typecheck an expression, but throw away the effect ;; tc-expr/t : Expr -> Type (define (tc-expr/t e) (match (tc-expr e) - [(tc-result: t) t])) + [(tc-result: t) t] + [t (int-err "tc-expr returned ~a, not a tc-result, for ~a" t (syntax->datum e))])) (define (tc-expr/check/t e t) (match (tc-expr/check e t) diff --git a/collects/typed-scheme/private/tc-if-unit.ss b/collects/typed-scheme/typecheck/tc-if-unit.ss similarity index 95% rename from collects/typed-scheme/private/tc-if-unit.ss rename to collects/typed-scheme/typecheck/tc-if-unit.ss index f59b19fe60..e1d75c236c 100644 --- a/collects/typed-scheme/private/tc-if-unit.ss +++ b/collects/typed-scheme/typecheck/tc-if-unit.ss @@ -1,20 +1,15 @@ #lang scheme/unit -(require "planet-requires.ss" +(require (rename-in "../utils/utils.ss" [infer r:infer])) +(require (utils planet-requires) "signatures.ss" - "type-rep.ss" ;; doesn't need tests - "type-effect-convenience.ss" ;; maybe needs tests - "lexical-env.ss" ;; maybe needs tests - "effect-rep.ss" - "mutated-vars.ss" - "subtype.ss" - (only-in "remove-intersect.ss" + (rep type-rep effect-rep) + (private type-effect-convenience subtype union type-utils type-comparison mutated-vars) + (env lexical-env) + (only-in (private remove-intersect) [remove *remove]) - "infer.ss" - "union.ss" - "type-utils.ss" - "tc-utils.ss" - "type-comparison.ss" + (r:infer infer) + (utils tc-utils) syntax/kerncase mzlib/trace mzlib/plt-match) diff --git a/collects/typed-scheme/private/tc-lambda-unit.ss b/collects/typed-scheme/typecheck/tc-lambda-unit.ss similarity index 96% rename from collects/typed-scheme/private/tc-lambda-unit.ss rename to collects/typed-scheme/typecheck/tc-lambda-unit.ss index d91531536e..962c480e05 100644 --- a/collects/typed-scheme/private/tc-lambda-unit.ss +++ b/collects/typed-scheme/typecheck/tc-lambda-unit.ss @@ -1,20 +1,15 @@ #lang scheme/unit +(require (rename-in "../utils/utils.ss" [infer r:infer] [extend r:extend])) (require "signatures.ss" mzlib/trace scheme/list - (except-in "type-rep.ss" make-arr) ;; doesn't need tests - "type-effect-convenience.ss" ;; maybe needs tests - "type-environments.ss" ;; doesn't need tests - "lexical-env.ss" ;; maybe needs tests - "type-annotation.ss" ;; has tests - (except-in "utils.ss" extend) - "type-utils.ss" - "effect-rep.ss" - "tc-utils.ss" - "union.ss" + (except-in (rep type-rep effect-rep) make-arr) ;; doesn't need tests + (private type-effect-convenience type-annotation union type-utils) + (env type-environments lexical-env) + (utils tc-utils) mzlib/plt-match - (only-in "type-effect-convenience.ss" [make-arr* make-arr])) + (only-in (private type-effect-convenience) [make-arr* make-arr])) (require (for-template scheme/base "internal-forms.ss")) (import tc-expr^) @@ -180,7 +175,7 @@ (let loop ([expected expected]) (match expected [(Mu: _ _) (loop (unfold expected))] - [(Function: (list (arr: argss rets rests drests _ _) ...)) + [(Function: (list (arr: argss rets rests drests '() _ _) ...)) (for ([args argss] [ret rets] [rest rests] [drest drests]) (tc/lambda-clause/check (car (syntax->list formals)) (car (syntax->list bodies)) args ret rest drest)) expected] diff --git a/collects/typed-scheme/private/tc-let-unit.ss b/collects/typed-scheme/typecheck/tc-let-unit.ss similarity index 96% rename from collects/typed-scheme/private/tc-let-unit.ss rename to collects/typed-scheme/typecheck/tc-let-unit.ss index eb29285264..9bf2bf3fa7 100644 --- a/collects/typed-scheme/private/tc-let-unit.ss +++ b/collects/typed-scheme/typecheck/tc-let-unit.ss @@ -1,14 +1,9 @@ #lang scheme/unit +(require (rename-in "../utils/utils.ss" [infer r:infer])) (require "signatures.ss" - "type-effect-convenience.ss" - "lexical-env.ss" - "type-annotation.ss" - "type-alias-env.ss" - "type-env.ss" - "parse-type.ss" - "utils.ss" - "type-utils.ss" + (private type-effect-convenience type-annotation parse-type type-utils) + (env lexical-env type-alias-env type-env) syntax/free-vars mzlib/trace scheme/match diff --git a/collects/typed-scheme/private/tc-structs.ss b/collects/typed-scheme/typecheck/tc-structs.ss similarity index 95% rename from collects/typed-scheme/private/tc-structs.ss rename to collects/typed-scheme/typecheck/tc-structs.ss index 23c8a43038..86233c0df2 100644 --- a/collects/typed-scheme/private/tc-structs.ss +++ b/collects/typed-scheme/typecheck/tc-structs.ss @@ -1,15 +1,12 @@ #lang scheme/base -(require "type-rep.ss" ;; doesn't need tests - "type-effect-convenience.ss" ;; maybe needs tests - "type-env.ss" ;; maybe needs tests - "type-utils.ss" - "parse-type.ss" ;; has tests - "type-environments.ss" ;; doesn't need tests - "type-name-env.ss" ;; maybe needs tests - "union.ss" - "tc-utils.ss" - "resolve-type.ss" +(require (except-in "../utils/utils.ss" extend)) +(require (rep type-rep) + (private type-effect-convenience + type-utils parse-type + union resolve-type) + (env type-env type-environments type-name-env) + (utils tc-utils) "def-binding.ss" syntax/kerncase syntax/struct diff --git a/collects/typed-scheme/private/tc-toplevel.ss b/collects/typed-scheme/typecheck/tc-toplevel.ss similarity index 94% rename from collects/typed-scheme/private/tc-toplevel.ss rename to collects/typed-scheme/typecheck/tc-toplevel.ss index 23b3614c57..5f2d36f25b 100644 --- a/collects/typed-scheme/private/tc-toplevel.ss +++ b/collects/typed-scheme/typecheck/tc-toplevel.ss @@ -1,26 +1,17 @@ #lang scheme/unit +(require (rename-in "../utils/utils.ss" [infer r:infer])) (require syntax/kerncase mzlib/etc scheme/match "signatures.ss" "tc-structs.ss" - "type-utils.ss" - "utils.ss" ;; doesn't need tests - "type-effect-convenience.ss" ;; maybe needs tests - "internal-forms.ss" ;; doesn't need tests - "type-env.ss" ;; maybe needs tests - "parse-type.ss" ;; has tests - "tc-utils.ss" ;; doesn't need tests - "type-annotation.ss" ;; has tests - "type-name-env.ss" ;; maybe needs tests - "init-envs.ss" - "mutated-vars.ss" + (private type-utils type-effect-convenience parse-type type-annotation mutated-vars type-contract) + (env type-env init-envs type-name-env type-alias-env) + (utils tc-utils) + "provide-handling.ss" "def-binding.ss" - "provide-handling.ss" - "type-alias-env.ss" - "type-contract.ss" (for-template "internal-forms.ss" mzlib/contract diff --git a/collects/typed-scheme/private/typechecker.ss b/collects/typed-scheme/typecheck/typechecker.ss similarity index 89% rename from collects/typed-scheme/private/typechecker.ss rename to collects/typed-scheme/typecheck/typechecker.ss index 3ec16bcfcf..ed935ff901 100644 --- a/collects/typed-scheme/private/typechecker.ss +++ b/collects/typed-scheme/typecheck/typechecker.ss @@ -1,6 +1,7 @@ #lang scheme/base -(require "unit-utils.ss" +(require "../utils/utils.ss") +(require (utils unit-utils) mzlib/trace (only-in scheme/unit provide-signature-elements) "signatures.ss" "tc-toplevel.ss" diff --git a/collects/typed-scheme/typed-scheme.ss b/collects/typed-scheme/typed-scheme.ss index 19c9c9cb7d..0bcfc701b0 100644 --- a/collects/typed-scheme/typed-scheme.ss +++ b/collects/typed-scheme/typed-scheme.ss @@ -1,22 +1,18 @@ #lang scheme/base -(require "private/base-env.ss" - "private/base-types.ss" +(require (rename-in "utils/utils.ss" [infer r:infer])) + +(require (private base-env base-types) (for-syntax scheme/base - "private/type-utils.ss" - "private/typechecker.ss" - "private/type-rep.ss" - "private/provide-handling.ss" - "private/type-environments.ss" - "private/tc-utils.ss" - "private/type-name-env.ss" - "private/type-alias-env.ss" - (except-in "private/utils.ss" extend) - (only-in "private/infer-dummy.ss" infer-param) - "private/infer.ss" - "private/type-effect-convenience.ss" - "private/type-contract.ss" + (private type-utils type-contract type-effect-convenience) + (typecheck typechecker provide-handling) + (env type-environments type-name-env type-alias-env) + (r:infer infer) + (utils tc-utils) + (rep type-rep) + (except-in (utils utils) infer extend) + (only-in (r:infer infer-dummy) infer-param) scheme/nest syntax/kerncase scheme/match)) @@ -31,7 +27,7 @@ (provide (rename-out [module-begin #%module-begin] [top-interaction #%top-interaction] [#%plain-lambda lambda] - [#%plain-app #%app] + [#%app #%app] [require require])) (define-for-syntax catch-errors? #f) diff --git a/collects/typed-scheme/private/planet-requires.ss b/collects/typed-scheme/utils/planet-requires.ss similarity index 100% rename from collects/typed-scheme/private/planet-requires.ss rename to collects/typed-scheme/utils/planet-requires.ss diff --git a/collects/typed-scheme/private/syntax-traversal.ss b/collects/typed-scheme/utils/syntax-traversal.ss similarity index 100% rename from collects/typed-scheme/private/syntax-traversal.ss rename to collects/typed-scheme/utils/syntax-traversal.ss diff --git a/collects/typed-scheme/private/tables.ss b/collects/typed-scheme/utils/tables.ss similarity index 100% rename from collects/typed-scheme/private/tables.ss rename to collects/typed-scheme/utils/tables.ss diff --git a/collects/typed-scheme/private/tc-utils.ss b/collects/typed-scheme/utils/tc-utils.ss similarity index 97% rename from collects/typed-scheme/private/tc-utils.ss rename to collects/typed-scheme/utils/tc-utils.ss index 69709e3e46..132b220612 100644 --- a/collects/typed-scheme/private/tc-utils.ss +++ b/collects/typed-scheme/utils/tc-utils.ss @@ -70,12 +70,12 @@ (unless (null? stxs) (raise-typecheck-error (format "Summary: ~a errors encountered" (length stxs)) (apply append stxs))))])) -(define delay-errors? (make-parameter #t)) +(define delay-errors? (make-parameter #f)) (define (tc-error/delayed msg #:stx [stx* (current-orig-stx)] . rest) (let ([stx (locate-stx stx*)]) (unless (syntax? stx) - (error "syntax was not syntax" stx (syntax->datum stx*))) + (int-err "erroneous syntax was not a syntax object: ~a ~a" stx (syntax->datum stx*))) (if (delay-errors?) (set! delayed-errors (cons (make-err (apply format msg rest) (list stx)) delayed-errors)) (raise-typecheck-error (apply format msg rest) (list stx))))) diff --git a/collects/typed-scheme/private/unit-utils.ss b/collects/typed-scheme/utils/unit-utils.ss similarity index 100% rename from collects/typed-scheme/private/unit-utils.ss rename to collects/typed-scheme/utils/unit-utils.ss diff --git a/collects/typed-scheme/private/utils.ss b/collects/typed-scheme/utils/utils.ss similarity index 82% rename from collects/typed-scheme/private/utils.ss rename to collects/typed-scheme/utils/utils.ss index 80c3f8023d..6ca8a6a901 100644 --- a/collects/typed-scheme/private/utils.ss +++ b/collects/typed-scheme/utils/utils.ss @@ -2,6 +2,7 @@ (require (for-syntax scheme/base) mzlib/plt-match + scheme/require-syntax mzlib/struct) (provide with-syntax* syntax-map start-timing do-time reverse-begin printf/log @@ -16,7 +17,40 @@ in-list-forever extend debug - in-syntax) + in-syntax + ;; require macros + rep utils typecheck infer env private) + +(define-syntax (define-requirer stx) + (syntax-case stx () + [(_ nm) + #`(... + (define-require-syntax nm + (lambda (stx) + (syntax-case stx () + [(_ id ...) + (andmap identifier? (syntax->list #'(id ...))) + (with-syntax ([(id* ...) + (map (lambda (id) + (datum->syntax + id + (string->symbol + (string-append + "typed-scheme/" + #,(symbol->string (syntax-e #'nm)) + "/" + (symbol->string (syntax-e id)))) + id id)) + (syntax->list #'(id ...)))]) + (syntax/loc stx (combine-in id* ...)))]))))])) + + +(define-requirer rep) +(define-requirer infer) +(define-requirer typecheck) +(define-requirer utils) +(define-requirer env) +(define-requirer private) (define-sequence-syntax in-syntax (lambda () #'syntax->list) From cb07ceefff9d48eb03608c0e96d79b006631724f Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Thu, 11 Sep 2008 16:51:36 +0000 Subject: [PATCH 06/88] Thanks to Sam and Carl, finally got this working like I wanted it. svn: r11645 --- collects/scheme/private/contract.ss | 103 ++++++++++++++-------------- 1 file changed, 53 insertions(+), 50 deletions(-) diff --git a/collects/scheme/private/contract.ss b/collects/scheme/private/contract.ss index d31b62ce23..3dba683fd6 100644 --- a/collects/scheme/private/contract.ss +++ b/collects/scheme/private/contract.ss @@ -13,12 +13,15 @@ improve method arity mismatch contract violation error messages? recursive-contract provide/contract define/contract - with-contract) + with-contract + current-contract-region) (require (for-syntax scheme/base) (for-syntax "contract-opt-guts.ss") (for-syntax scheme/struct-info) (for-syntax scheme/list) + scheme/stxparam + scheme/stxparam-exptime scheme/promise) (require "contract-arrow.ss" @@ -137,40 +140,39 @@ improve method arity mismatch contract violation error messages? ; ; -(define-for-syntax current-contract-region (make-parameter #f)) +(define-syntax-parameter current-contract-region #f) (define-for-syntax (make-with-contract-transformer contract-id id pos-blame-id) (make-set!-transformer (lambda (stx) - (let ([neg-blame-id (cond - [(current-contract-region) => values] - [else #`(module-source-as-symbol #'#,id)])]) - (with-syntax ([neg-blame-id neg-blame-id] - [pos-blame-id #`(quote #,(syntax-e pos-blame-id))] - [contract-id contract-id] - [id id]) - (syntax-case stx (set!) - [(set! id arg) - (raise-syntax-error 'with-contract - "cannot set! a with-contract variable" - stx - (syntax id))] - [(f arg ...) - (syntax/loc stx - ((-contract contract-id - id - pos-blame-id - neg-blame-id - (quote-syntax f)) - arg ...))] - [ident - (identifier? (syntax ident)) - (syntax/loc stx - (-contract contract-id - id - pos-blame-id - neg-blame-id - (quote-syntax ident)))])))))) + #;(printf "~a\n" (syntax-parameter-value #'current-contract-region)) + (with-syntax ([neg-blame-id (or (syntax-parameter-value #'current-contract-region) + (a:module-source-as-symbol id))] + [pos-blame-id pos-blame-id] + [contract-id contract-id] + [id id]) + (syntax-case stx (set!) + [(set! id arg) + (raise-syntax-error 'with-contract + "cannot set! a with-contract variable" + stx + (syntax id))] + [(f arg ...) + (quasisyntax/loc stx + ((-contract contract-id + id + pos-blame-id + 'neg-blame-id + (quote-syntax f)) + arg ...))] + [ident + (identifier? (syntax ident)) + (quasisyntax/loc stx + (-contract contract-id + id + pos-blame-id + 'neg-blame-id + (quote-syntax ident)))]))))) (define-syntax (with-contract stx) (let ([introducer (make-syntax-introducer)]) @@ -178,25 +180,26 @@ improve method arity mismatch contract violation error messages? [(_ blame ([name contract-expr] ...) body0 body ...) (and (identifier? (syntax blame)) (andmap identifier? (syntax->list (syntax (name ...))))) - (parameterize ([current-contract-region (syntax-e (syntax blame))]) - (with-syntax ([(id ...) - (map introducer (syntax->list (syntax (name ...))))] - [(contract-id ...) - (map (lambda (n) - (a:mangle-id stx "with-contract-contract-id" n)) - (syntax->list (syntax (name ...))))] - [(new-body ...) - (map introducer - (syntax->list (syntax (body0 body ...))))]) - (syntax/loc stx - (begin - (define contract-id contract-expr) ... - (define-syntax name - (make-with-contract-transformer - (quote-syntax contract-id) - (quote-syntax id) - (quote-syntax blame))) ... - new-body ...))))]))) + (with-syntax ([(id ...) + (map (lambda (n) + (a:mangle-id stx "with-contract-id" n)) + (syntax->list (syntax (name ...))))] + [(contract-id ...) + (map (lambda (n) + (a:mangle-id stx "with-contract-contract-id" n)) + (syntax->list (syntax (name ...))))]) + (syntax/loc stx + (begin + (define-values (id ...) + (syntax-parameterize ([current-contract-region (quote blame)]) + body0 body ... + (values name ...))) + (define contract-id contract-expr) ... + (define-syntax name + (make-with-contract-transformer + (quote-syntax contract-id) + (quote-syntax id) + (quote-syntax (quote blame)))) ...)))]))) ; ; From e5ed38fedc53a1c45262537bd300553970aadfb8 Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Thu, 11 Sep 2008 16:52:08 +0000 Subject: [PATCH 07/88] This wasn't used in define/contract either. svn: r11646 --- collects/scheme/private/contract.ss | 26 +++++++++++++------------- 1 file changed, 13 insertions(+), 13 deletions(-) diff --git a/collects/scheme/private/contract.ss b/collects/scheme/private/contract.ss index 3dba683fd6..0070652af1 100644 --- a/collects/scheme/private/contract.ss +++ b/collects/scheme/private/contract.ss @@ -50,19 +50,6 @@ improve method arity mismatch contract violation error messages? ; ; ; -;; lookup-struct-info : syntax -> (union #f (list syntax syntax (listof syntax) ...)) -(define-for-syntax (lookup-struct-info stx provide-stx) - (let ([id (syntax-case stx () - [(a b) (syntax a)] - [_ stx])]) - (let ([v (syntax-local-value id (λ () #f))]) - (if (struct-info? v) - (extract-struct-info v) - (raise-syntax-error 'provide/contract - "expected a struct name" - provide-stx - id))))) - (define-for-syntax (make-define/contract-transformer contract-id id) (make-set!-transformer (λ (stx) @@ -219,6 +206,19 @@ improve method arity mismatch contract violation error messages? ; ; +;; lookup-struct-info : syntax -> (union #f (list syntax syntax (listof syntax) ...)) +(define-for-syntax (lookup-struct-info stx provide-stx) + (let ([id (syntax-case stx () + [(a b) (syntax a)] + [_ stx])]) + (let ([v (syntax-local-value id (λ () #f))]) + (if (struct-info? v) + (extract-struct-info v) + (raise-syntax-error 'provide/contract + "expected a struct name" + provide-stx + id))))) + ;; id->contract-src-info : identifier -> syntax ;; constructs the last argument to the -contract, given an identifier (define-for-syntax (id->contract-src-info id) From c1fa0fe0edc1057770a8db7258ddaa289a676863 Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Thu, 11 Sep 2008 17:01:01 +0000 Subject: [PATCH 08/88] Now have define/contract use the new with-contract form. svn: r11647 --- collects/scheme/private/contract.ss | 49 ++--------------------------- 1 file changed, 3 insertions(+), 46 deletions(-) diff --git a/collects/scheme/private/contract.ss b/collects/scheme/private/contract.ss index 0070652af1..8f7b02acbe 100644 --- a/collects/scheme/private/contract.ss +++ b/collects/scheme/private/contract.ss @@ -50,36 +50,6 @@ improve method arity mismatch contract violation error messages? ; ; ; -(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 - (syntax->datum (quote-syntax f)) - neg-blame-str - (quote-syntax f)) - arg - ...))] - [ident - (identifier? (syntax ident)) - (syntax/loc stx - (-contract contract-id - id - (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. @@ -87,21 +57,9 @@ improve method arity mismatch contract violation error messages? (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 - )))] + #'(with-contract name + ([name contract-expr]) + (define name expr))] [(_ name contract-expr expr) (raise-syntax-error 'define/contract "expected identifier in first position" define-stx @@ -132,7 +90,6 @@ improve method arity mismatch contract violation error messages? (define-for-syntax (make-with-contract-transformer contract-id id pos-blame-id) (make-set!-transformer (lambda (stx) - #;(printf "~a\n" (syntax-parameter-value #'current-contract-region)) (with-syntax ([neg-blame-id (or (syntax-parameter-value #'current-contract-region) (a:module-source-as-symbol id))] [pos-blame-id pos-blame-id] From 16399b7827591b4c6f29e25a3d2c6e8f529029e9 Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Thu, 11 Sep 2008 17:36:43 +0000 Subject: [PATCH 09/88] Add in nicer version for function definitions. svn: r11648 --- collects/scheme/private/contract.ss | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/collects/scheme/private/contract.ss b/collects/scheme/private/contract.ss index 8f7b02acbe..3e0731a0d4 100644 --- a/collects/scheme/private/contract.ss +++ b/collects/scheme/private/contract.ss @@ -60,6 +60,10 @@ improve method arity mismatch contract violation error messages? #'(with-contract name ([name contract-expr]) (define name expr))] + [(_ (name arg ...) contract body) + (identifier? (syntax name)) + #'(define/contract name contract + (lambda (arg ...) body))] [(_ name contract-expr expr) (raise-syntax-error 'define/contract "expected identifier in first position" define-stx From eb676359c921b9ac23455eee98c941d413f3f30d Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Thu, 11 Sep 2008 17:49:29 +0000 Subject: [PATCH 10/88] There might be a simpler way of writing this, but my kung macro isn't yet up to par if so. svn: r11649 --- collects/scheme/private/contract.ss | 14 ++++++++------ 1 file changed, 8 insertions(+), 6 deletions(-) diff --git a/collects/scheme/private/contract.ss b/collects/scheme/private/contract.ss index 3e0731a0d4..941f8299a2 100644 --- a/collects/scheme/private/contract.ss +++ b/collects/scheme/private/contract.ss @@ -20,9 +20,10 @@ improve method arity mismatch contract violation error messages? (for-syntax "contract-opt-guts.ss") (for-syntax scheme/struct-info) (for-syntax scheme/list) + (for-syntax syntax/define) + scheme/promise scheme/stxparam - scheme/stxparam-exptime - scheme/promise) + scheme/stxparam-exptime) (require "contract-arrow.ss" "contract-guts.ss" @@ -60,10 +61,11 @@ improve method arity mismatch contract violation error messages? #'(with-contract name ([name contract-expr]) (define name expr))] - [(_ (name arg ...) contract body) - (identifier? (syntax name)) - #'(define/contract name contract - (lambda (arg ...) body))] + [(_ name+arg-list contract body) + (let-values ([(name lam-expr) + (normalize-definition (datum->syntax #'stx (list 'define #'name+arg-list #'body)) + #'lambda #f #t)]) + #`(define/contract #,name contract #,lam-expr))] [(_ name contract-expr expr) (raise-syntax-error 'define/contract "expected identifier in first position" define-stx From 1621335290b1aa1fdcb7dc81a590274397b1a38f Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Thu, 11 Sep 2008 20:38:09 +0000 Subject: [PATCH 11/88] * Make define/contract have an implicit begin * Change with-contract's implicit begin into begin-with-definitions svn: r11650 --- collects/scheme/private/contract.ss | 16 +++++++++------- 1 file changed, 9 insertions(+), 7 deletions(-) diff --git a/collects/scheme/private/contract.ss b/collects/scheme/private/contract.ss index 941f8299a2..e9bb163de4 100644 --- a/collects/scheme/private/contract.ss +++ b/collects/scheme/private/contract.ss @@ -23,7 +23,8 @@ improve method arity mismatch contract violation error messages? (for-syntax syntax/define) scheme/promise scheme/stxparam - scheme/stxparam-exptime) + scheme/stxparam-exptime + mzlib/etc) (require "contract-arrow.ss" "contract-guts.ss" @@ -56,14 +57,14 @@ improve method arity mismatch contract violation error messages? ;; 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) + [(_ name contract-expr expr0 expr ...) (identifier? (syntax name)) #'(with-contract name ([name contract-expr]) - (define name expr))] - [(_ name+arg-list contract body) + (define name expr0 expr ...))] + [(_ name+arg-list contract body0 body ...) (let-values ([(name lam-expr) - (normalize-definition (datum->syntax #'stx (list 'define #'name+arg-list #'body)) + (normalize-definition (datum->syntax #'stx (list* 'define #'name+arg-list #'body0 #'(body ...))) #'lambda #f #t)]) #`(define/contract #,name contract #,lam-expr))] [(_ name contract-expr expr) @@ -142,8 +143,9 @@ improve method arity mismatch contract violation error messages? (begin (define-values (id ...) (syntax-parameterize ([current-contract-region (quote blame)]) - body0 body ... - (values name ...))) + (begin-with-definitions + body0 body ... + (values name ...)))) (define contract-id contract-expr) ... (define-syntax name (make-with-contract-transformer From 430374358ea50df38a1879550f6c1398c98866ee Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Thu, 11 Sep 2008 21:01:14 +0000 Subject: [PATCH 12/88] Allow unprotected identifiers to be exported from with-contract, plus do some error checking on that list. svn: r11651 --- collects/scheme/private/contract.ss | 59 +++++++++++++++++++++-------- 1 file changed, 44 insertions(+), 15 deletions(-) diff --git a/collects/scheme/private/contract.ss b/collects/scheme/private/contract.ss index e9bb163de4..5702043f1a 100644 --- a/collects/scheme/private/contract.ss +++ b/collects/scheme/private/contract.ss @@ -124,34 +124,63 @@ improve method arity mismatch contract violation error messages? pos-blame-id 'neg-blame-id (quote-syntax ident)))]))))) - + +(define-for-syntax (check-and-split-with-contract-args args) + (let loop ([args args] + [unprotected null] + [protected null] + [protections null]) + (cond + [(null? args) + (values unprotected protected protections)] + [(identifier? (car args)) + (loop (cdr args) + (cons (car args) unprotected) + protected + protections)] + [(let ([lst (syntax->list (car args))]) + (and (list? lst) + (= (length lst) 2) + lst)) + => + (lambda (l) + (loop (cdr args) + unprotected + (cons (first l) protected) + (cons (second l) protections)))] + [else + (raise-syntax-error 'with-contract + "expected an identifier or (identifier contract)" + (car args))]))) + (define-syntax (with-contract stx) (let ([introducer (make-syntax-introducer)]) (syntax-case stx () - [(_ blame ([name contract-expr] ...) body0 body ...) - (and (identifier? (syntax blame)) - (andmap identifier? (syntax->list (syntax (name ...))))) - (with-syntax ([(id ...) + [(_ blame (arg ...) body0 body ...) + (identifier? (syntax blame)) + (let-values ([(unprotected protected protections) + (check-and-split-with-contract-args (syntax->list #'(arg ...)))]) + (with-syntax ([((protected-id id contract-id) ...) (map (lambda (n) - (a:mangle-id stx "with-contract-id" n)) - (syntax->list (syntax (name ...))))] - [(contract-id ...) - (map (lambda (n) - (a:mangle-id stx "with-contract-contract-id" n)) - (syntax->list (syntax (name ...))))]) + (list n + (a:mangle-id stx "with-contract-id" n) + (a:mangle-id stx "with-contract-contract-id" n))) + protected)] + [(contract-expr ...) protections] + [(unprotected-id ...) unprotected]) (syntax/loc stx (begin - (define-values (id ...) + (define-values (unprotected-id ... id ...) (syntax-parameterize ([current-contract-region (quote blame)]) (begin-with-definitions body0 body ... - (values name ...)))) + (values unprotected-id ... protected-id ...)))) (define contract-id contract-expr) ... - (define-syntax name + (define-syntax protected-id (make-with-contract-transformer (quote-syntax contract-id) (quote-syntax id) - (quote-syntax (quote blame)))) ...)))]))) + (quote-syntax (quote blame)))) ...))))]))) ; ; From b21c6bbc841dbfe978fbadf77b2778af40dc2324 Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Thu, 11 Sep 2008 22:06:00 +0000 Subject: [PATCH 13/88] svn merge -r11644:11652 http://svn.plt-scheme.org/plt/trunk (Also setting up svn:mergeinfo appropriately for later merging.) svn: r11653 --- collects/tests/run-automated-tests.ss | 3 ++- collects/tests/stepper/automatic-tests.ss | 5 +++-- collects/tests/stepper/through-tests.ss | 15 --------------- 3 files changed, 5 insertions(+), 18 deletions(-) diff --git a/collects/tests/run-automated-tests.ss b/collects/tests/run-automated-tests.ss index 6e916361d0..2656de69b5 100755 --- a/collects/tests/run-automated-tests.ss +++ b/collects/tests/run-automated-tests.ss @@ -31,7 +31,8 @@ (define tests '([load "mzscheme/quiet.ss" (lib "scheme/init")] [require "typed-scheme/main.ss"] - [require "match/plt-match-tests.ss"])) + [require "match/plt-match-tests.ss"] + [require "stepper/automatic-tests.ss"])) (require scheme/runtime-path) diff --git a/collects/tests/stepper/automatic-tests.ss b/collects/tests/stepper/automatic-tests.ss index 7c14acc484..685b42d5a2 100644 --- a/collects/tests/stepper/automatic-tests.ss +++ b/collects/tests/stepper/automatic-tests.ss @@ -1,7 +1,8 @@ (module automatic-tests mzscheme (require "through-tests.ss") - (parameterize ([display-only-errors #t]) - (if (run-all-tests-except '(check-expect begin-let-bug prims qq-splice time set! local-set! lazy1 lazy2 lazy3)) + (parameterize ([display-only-errors #t] + [current-output-port (open-output-string)]) + (if (run-all-tests-except '(check-error begin-let-bug prims qq-splice time set! local-set! lazy1 lazy2 lazy3)) (exit 1) (exit 0)))) diff --git a/collects/tests/stepper/through-tests.ss b/collects/tests/stepper/through-tests.ss index 9a2165ee0e..d99ea1d9ed 100755 --- a/collects/tests/stepper/through-tests.ss +++ b/collects/tests/stepper/through-tests.ss @@ -1368,21 +1368,6 @@ (before-after (9 (list 'check-expect-failed 7 17) (list 'check-expect-passed 2 2) (check-expect (hilite (+ 2 2)) 4)) (9 (list 'check-expect-failed 7 17) (list 'check-expect-passed 2 2) (check-expect (hilite 4) 4)))))) - (t1 check-expect-2 - (test-upto-int/lam - "(check-expect (+ 3 4) (+ 8 9)) (check-expect (+ 3 1) 4) (+ 4 5)" - `((before-after ((hilite (+ 4 5))) - ((hilite 9))) - (before-after (9 (check-expect (+ 3 4) (hilite (+ 8 9)))) - (9 (check-expect (+ 3 4) (hilite 17)))) - (before-after (9 (check-expect (hilite (+ 3 4)) 17)) - (9 (check-expect (hilite 7) 17))) - (before-after (9 (check-expect (hilite (+ 3 1)) 4)) - (9 (check-expect (hilite 4) 4)))))) - - - - (t1 check-within (test-bwla-to-int/lam "(check-within (+ 3 4) (+ 8 10) (+ 10 90)) (check-expect (+ 1 1) 2)(+ 4 5)" From cfb01a1828edbb4e1af9ffc0e938715509388103 Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Thu, 11 Sep 2008 22:17:20 +0000 Subject: [PATCH 14/88] Revert that previous change. svn: r11654 --- collects/tests/run-automated-tests.ss | 3 +-- collects/tests/stepper/automatic-tests.ss | 5 ++--- collects/tests/stepper/through-tests.ss | 15 +++++++++++++++ 3 files changed, 18 insertions(+), 5 deletions(-) diff --git a/collects/tests/run-automated-tests.ss b/collects/tests/run-automated-tests.ss index 2656de69b5..6e916361d0 100755 --- a/collects/tests/run-automated-tests.ss +++ b/collects/tests/run-automated-tests.ss @@ -31,8 +31,7 @@ (define tests '([load "mzscheme/quiet.ss" (lib "scheme/init")] [require "typed-scheme/main.ss"] - [require "match/plt-match-tests.ss"] - [require "stepper/automatic-tests.ss"])) + [require "match/plt-match-tests.ss"])) (require scheme/runtime-path) diff --git a/collects/tests/stepper/automatic-tests.ss b/collects/tests/stepper/automatic-tests.ss index 685b42d5a2..7c14acc484 100644 --- a/collects/tests/stepper/automatic-tests.ss +++ b/collects/tests/stepper/automatic-tests.ss @@ -1,8 +1,7 @@ (module automatic-tests mzscheme (require "through-tests.ss") - (parameterize ([display-only-errors #t] - [current-output-port (open-output-string)]) - (if (run-all-tests-except '(check-error begin-let-bug prims qq-splice time set! local-set! lazy1 lazy2 lazy3)) + (parameterize ([display-only-errors #t]) + (if (run-all-tests-except '(check-expect begin-let-bug prims qq-splice time set! local-set! lazy1 lazy2 lazy3)) (exit 1) (exit 0)))) diff --git a/collects/tests/stepper/through-tests.ss b/collects/tests/stepper/through-tests.ss index d99ea1d9ed..9a2165ee0e 100755 --- a/collects/tests/stepper/through-tests.ss +++ b/collects/tests/stepper/through-tests.ss @@ -1368,6 +1368,21 @@ (before-after (9 (list 'check-expect-failed 7 17) (list 'check-expect-passed 2 2) (check-expect (hilite (+ 2 2)) 4)) (9 (list 'check-expect-failed 7 17) (list 'check-expect-passed 2 2) (check-expect (hilite 4) 4)))))) + (t1 check-expect-2 + (test-upto-int/lam + "(check-expect (+ 3 4) (+ 8 9)) (check-expect (+ 3 1) 4) (+ 4 5)" + `((before-after ((hilite (+ 4 5))) + ((hilite 9))) + (before-after (9 (check-expect (+ 3 4) (hilite (+ 8 9)))) + (9 (check-expect (+ 3 4) (hilite 17)))) + (before-after (9 (check-expect (hilite (+ 3 4)) 17)) + (9 (check-expect (hilite 7) 17))) + (before-after (9 (check-expect (hilite (+ 3 1)) 4)) + (9 (check-expect (hilite 4) 4)))))) + + + + (t1 check-within (test-bwla-to-int/lam "(check-within (+ 3 4) (+ 8 10) (+ 10 90)) (check-expect (+ 1 1) 2)(+ 4 5)" From ae2d69720cc64c7398ba5991ff33f00ceb8e593f Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Thu, 11 Sep 2008 22:21:45 +0000 Subject: [PATCH 15/88] svn merge -r11644:11643 . Yeah, these trunk merges will eventually come back. svn: r11655 --- .../tests/typed-scheme/fail/values-dots.ss | 4 +- .../tests/typed-scheme/succeed/nested-poly.ss | 2 +- .../tests/typed-scheme/succeed/values-dots.ss | 8 +- .../typed-scheme/unit-tests/all-tests.ss | 2 +- .../typed-scheme/unit-tests/infer-tests.ss | 7 +- .../typed-scheme/unit-tests/module-tests.ss | 2 +- .../unit-tests/parse-type-tests.ss | 8 +- .../unit-tests/remove-intersect-tests.ss | 5 +- .../typed-scheme/unit-tests/subst-tests.ss | 4 +- .../typed-scheme/unit-tests/subtype-tests.ss | 8 +- .../typed-scheme/unit-tests/test-utils.ss | 19 ++- .../unit-tests/type-annotation-test.ss | 6 +- .../unit-tests/type-equal-tests.ss | 3 +- .../unit-tests/typecheck-tests.ss | 18 ++- collects/typed-scheme/infer/infer-dummy.ss | 8 -- collects/typed-scheme/infer/signatures.ss | 29 ----- collects/typed-scheme/no-check.ss | 5 - collects/typed-scheme/no-check/lang/reader.ss | 13 --- collects/typed-scheme/private/base-env.ss | 35 +++--- collects/typed-scheme/private/base-types.ss | 5 +- .../check-subforms-unit.ss | 13 ++- .../{infer => private}/constraint-structs.ss | 3 +- .../{infer => private}/constraints.ss | 7 +- .../{typecheck => private}/def-binding.ss | 0 .../{typecheck => private}/defstruct-unit.ss | 0 .../typed-scheme/{infer => private}/dmap.ss | 4 +- .../{rep => private}/effect-rep.ss | 0 collects/typed-scheme/private/extra-procs.ss | 7 +- .../{rep => private}/free-variance.ss | 7 +- collects/typed-scheme/private/infer-dummy.ss | 7 ++ .../{infer => private}/infer-unit.ss | 52 ++++----- .../typed-scheme/{infer => private}/infer.ss | 3 +- .../{env => private}/init-envs.ss | 15 +-- .../{typecheck => private}/internal-forms.ss | 0 .../{rep => private}/interning.ss | 0 .../{env => private}/lexical-env.ss | 8 +- collects/typed-scheme/private/mutated-vars.ss | 13 ++- collects/typed-scheme/private/parse-type.ss | 13 ++- .../{utils => private}/planet-requires.ss | 0 collects/typed-scheme/private/prims.ss | 10 +- .../{infer => private}/promote-demote.ss | 19 +-- .../provide-handling.ss | 7 +- .../typed-scheme/private/remove-intersect.ss | 5 +- .../{rep => private}/rep-utils.ss | 10 +- collects/typed-scheme/private/resolve-type.ss | 3 +- .../{infer => private}/restrict.ss | 6 +- .../{typecheck => private}/signatures.ss | 32 ++++- collects/typed-scheme/private/subtype.ss | 27 ++--- .../{utils => private}/syntax-traversal.ss | 0 .../typed-scheme/{utils => private}/tables.ss | 0 .../{typecheck => private}/tc-app-unit.ss | 110 +++++------------- .../{typecheck => private}/tc-dots-unit.ss | 9 +- .../{typecheck => private}/tc-expr-unit.ss | 23 ++-- .../{typecheck => private}/tc-if-unit.ss | 21 ++-- .../{typecheck => private}/tc-lambda-unit.ss | 19 +-- .../{typecheck => private}/tc-let-unit.ss | 11 +- .../{typecheck => private}/tc-structs.ss | 17 +-- .../{typecheck => private}/tc-toplevel.ss | 19 ++- .../{utils => private}/tc-utils.ss | 4 +- .../{env => private}/type-alias-env.ss | 3 +- .../typed-scheme/private/type-annotation.ss | 8 +- .../typed-scheme/private/type-comparison.ss | 3 +- .../typed-scheme/private/type-contract.ss | 18 +-- .../private/type-effect-convenience.ss | 33 ++---- .../private/type-effect-printer.ss | 16 +-- .../typed-scheme/{env => private}/type-env.ss | 4 +- .../{env => private}/type-environments.ss | 3 +- .../{env => private}/type-name-env.ss | 5 +- .../typed-scheme/{rep => private}/type-rep.ss | 46 ++------ collects/typed-scheme/private/type-utils.ss | 24 ++-- .../{typecheck => private}/typechecker.ss | 3 +- collects/typed-scheme/private/union.ss | 8 +- .../{utils => private}/unit-utils.ss | 0 .../typed-scheme/{utils => private}/utils.ss | 36 +----- collects/typed-scheme/typed-scheme.ss | 28 +++-- 75 files changed, 374 insertions(+), 559 deletions(-) delete mode 100644 collects/typed-scheme/infer/infer-dummy.ss delete mode 100644 collects/typed-scheme/infer/signatures.ss delete mode 100644 collects/typed-scheme/no-check.ss delete mode 100644 collects/typed-scheme/no-check/lang/reader.ss rename collects/typed-scheme/{typecheck => private}/check-subforms-unit.ss (89%) rename collects/typed-scheme/{infer => private}/constraint-structs.ss (94%) rename collects/typed-scheme/{infer => private}/constraints.ss (94%) rename collects/typed-scheme/{typecheck => private}/def-binding.ss (100%) rename collects/typed-scheme/{typecheck => private}/defstruct-unit.ss (100%) rename collects/typed-scheme/{infer => private}/dmap.ss (92%) rename collects/typed-scheme/{rep => private}/effect-rep.ss (100%) rename collects/typed-scheme/{rep => private}/free-variance.ss (91%) create mode 100644 collects/typed-scheme/private/infer-dummy.ss rename collects/typed-scheme/{infer => private}/infer-unit.ss (92%) rename collects/typed-scheme/{infer => private}/infer.ss (67%) rename collects/typed-scheme/{env => private}/init-envs.ss (90%) rename collects/typed-scheme/{typecheck => private}/internal-forms.ss (100%) rename collects/typed-scheme/{rep => private}/interning.ss (100%) rename collects/typed-scheme/{env => private}/lexical-env.ss (90%) rename collects/typed-scheme/{utils => private}/planet-requires.ss (100%) rename collects/typed-scheme/{infer => private}/promote-demote.ss (80%) rename collects/typed-scheme/{typecheck => private}/provide-handling.ss (96%) rename collects/typed-scheme/{rep => private}/rep-utils.ss (96%) rename collects/typed-scheme/{infer => private}/restrict.ss (90%) rename collects/typed-scheme/{typecheck => private}/signatures.ss (56%) rename collects/typed-scheme/{utils => private}/syntax-traversal.ss (100%) rename collects/typed-scheme/{utils => private}/tables.ss (100%) rename collects/typed-scheme/{typecheck => private}/tc-app-unit.ss (90%) rename collects/typed-scheme/{typecheck => private}/tc-dots-unit.ss (89%) rename collects/typed-scheme/{typecheck => private}/tc-expr-unit.ss (95%) rename collects/typed-scheme/{typecheck => private}/tc-if-unit.ss (95%) rename collects/typed-scheme/{typecheck => private}/tc-lambda-unit.ss (96%) rename collects/typed-scheme/{typecheck => private}/tc-let-unit.ss (96%) rename collects/typed-scheme/{typecheck => private}/tc-structs.ss (95%) rename collects/typed-scheme/{typecheck => private}/tc-toplevel.ss (94%) rename collects/typed-scheme/{utils => private}/tc-utils.ss (97%) rename collects/typed-scheme/{env => private}/type-alias-env.ss (96%) rename collects/typed-scheme/{env => private}/type-env.ss (95%) rename collects/typed-scheme/{env => private}/type-environments.ss (96%) rename collects/typed-scheme/{env => private}/type-name-env.ss (93%) rename collects/typed-scheme/{rep => private}/type-rep.ss (92%) rename collects/typed-scheme/{typecheck => private}/typechecker.ss (89%) rename collects/typed-scheme/{utils => private}/unit-utils.ss (100%) rename collects/typed-scheme/{utils => private}/utils.ss (82%) diff --git a/collects/tests/typed-scheme/fail/values-dots.ss b/collects/tests/typed-scheme/fail/values-dots.ss index f92743faf3..6c08fff545 100644 --- a/collects/tests/typed-scheme/fail/values-dots.ss +++ b/collects/tests/typed-scheme/fail/values-dots.ss @@ -7,8 +7,8 @@ (: map-with-funcs (All (b ...) ((b ... b -> b) ... b -> (b ... b -> (values b ... b))))) (define (map-with-funcs . fs) (lambda bs - (apply values (map (lambda: ([f : (b ... b -> b)]) - (apply f bs)) fs)))) + (apply values* (map (lambda: ([f : (b ... b -> b)]) + (apply f bs)) fs)))) (map-with-funcs (lambda () 1)) diff --git a/collects/tests/typed-scheme/succeed/nested-poly.ss b/collects/tests/typed-scheme/succeed/nested-poly.ss index ac8bb3cd8c..785ee9a5df 100644 --- a/collects/tests/typed-scheme/succeed/nested-poly.ss +++ b/collects/tests/typed-scheme/succeed/nested-poly.ss @@ -13,7 +13,7 @@ (B ... B -> (values A ... A)))))) (define (map-with-funcs . fs) (lambda as - (apply values (map (lambda: ([f : (B ... B -> A)]) + (apply values* (map (lambda: ([f : (B ... B -> A)]) (apply f as)) fs)))) diff --git a/collects/tests/typed-scheme/succeed/values-dots.ss b/collects/tests/typed-scheme/succeed/values-dots.ss index 1c853f50b0..0078526faa 100644 --- a/collects/tests/typed-scheme/succeed/values-dots.ss +++ b/collects/tests/typed-scheme/succeed/values-dots.ss @@ -5,16 +5,16 @@ (call-with-values (lambda () (values 1 2)) (lambda: ([x : Number] [y : Number]) (+ x y))) -(#{call-with-values @ Integer Integer Integer} (lambda () (values 1 2)) (lambda: ([x : Integer] [y : Integer]) (+ x y))) +(#{call-with-values* @ Integer Integer Integer} (lambda () (values 1 2)) (lambda: ([x : Integer] [y : Integer]) (+ x y))) -(call-with-values (lambda () (values 1 2)) (lambda: ([x : Integer] [y : Integer]) (+ x y))) +(call-with-values* (lambda () (values 1 2)) (lambda: ([x : Integer] [y : Integer]) (+ x y))) (: map-with-funcs (All (b ...) ((b ... b -> b) ... b -> (b ... b -> (values b ... b))))) (define (map-with-funcs . fs) (lambda bs - (apply values (map (lambda: ([f : (b ... b -> b)]) - (apply f bs)) fs)))) + (apply values* (map (lambda: ([f : (b ... b -> b)]) + (apply f bs)) fs)))) (map-with-funcs + - * /) diff --git a/collects/tests/typed-scheme/unit-tests/all-tests.ss b/collects/tests/typed-scheme/unit-tests/all-tests.ss index 1fe728d05b..aca0a4d12c 100644 --- a/collects/tests/typed-scheme/unit-tests/all-tests.ss +++ b/collects/tests/typed-scheme/unit-tests/all-tests.ss @@ -12,7 +12,7 @@ "subst-tests.ss" "infer-tests.ss") -(require (utils planet-requires) (r:infer infer infer-dummy)) +(require (private planet-requires infer infer-dummy)) (require (schemeunit)) diff --git a/collects/tests/typed-scheme/unit-tests/infer-tests.ss b/collects/tests/typed-scheme/unit-tests/infer-tests.ss index aef624b748..f1d5e22b0d 100644 --- a/collects/tests/typed-scheme/unit-tests/infer-tests.ss +++ b/collects/tests/typed-scheme/unit-tests/infer-tests.ss @@ -1,10 +1,7 @@ #lang scheme/base (require "test-utils.ss" (for-syntax scheme/base)) -(require (utils planet-requires) - (rep type-rep) - (r:infer infer) - (private type-effect-convenience union type-utils) - (prefix-in table: (utils tables))) +(require (private planet-requires type-effect-convenience type-rep union infer type-utils) + (prefix-in table: (private tables))) (require (schemeunit)) diff --git a/collects/tests/typed-scheme/unit-tests/module-tests.ss b/collects/tests/typed-scheme/unit-tests/module-tests.ss index 490c1c2a89..51406fb008 100644 --- a/collects/tests/typed-scheme/unit-tests/module-tests.ss +++ b/collects/tests/typed-scheme/unit-tests/module-tests.ss @@ -1,6 +1,6 @@ #lang scheme (require "test-utils.ss") -(require (utils planet-requires)) +(require (private planet-requires)) (require (schemeunit)) (provide module-tests) diff --git a/collects/tests/typed-scheme/unit-tests/parse-type-tests.ss b/collects/tests/typed-scheme/unit-tests/parse-type-tests.ss index fedf84fb81..aa3882fd38 100644 --- a/collects/tests/typed-scheme/unit-tests/parse-type-tests.ss +++ b/collects/tests/typed-scheme/unit-tests/parse-type-tests.ss @@ -1,10 +1,8 @@ #lang scheme/base (require "test-utils.ss" (for-syntax scheme/base)) -(require (utils planet-requires tc-utils) - (env type-alias-env type-environments type-name-env init-envs) - (rep type-rep) - (private type-comparison parse-type subtype - union type-utils)) +(require (private planet-requires type-comparison parse-type type-rep + tc-utils type-environments type-alias-env subtype + type-name-env init-envs union type-utils)) (require (rename-in (private type-effect-convenience) [-> t:->]) (except-in (private base-types) Un) diff --git a/collects/tests/typed-scheme/unit-tests/remove-intersect-tests.ss b/collects/tests/typed-scheme/unit-tests/remove-intersect-tests.ss index 20da5c73c3..ca83402b66 100644 --- a/collects/tests/typed-scheme/unit-tests/remove-intersect-tests.ss +++ b/collects/tests/typed-scheme/unit-tests/remove-intersect-tests.ss @@ -1,9 +1,6 @@ #lang scheme/base (require "test-utils.ss" (for-syntax scheme/base)) -(require (rep type-rep) - (utils planet-requires) - (r:infer infer) - (private type-effect-convenience remove-intersect subtype union)) +(require (private type-rep type-effect-convenience planet-requires remove-intersect subtype union infer)) (require (schemeunit)) diff --git a/collects/tests/typed-scheme/unit-tests/subst-tests.ss b/collects/tests/typed-scheme/unit-tests/subst-tests.ss index 10a35fc98a..6c89d4ef6f 100644 --- a/collects/tests/typed-scheme/unit-tests/subst-tests.ss +++ b/collects/tests/typed-scheme/unit-tests/subst-tests.ss @@ -1,9 +1,7 @@ #lang scheme/base (require "test-utils.ss" (for-syntax scheme/base)) -(require (utils planet-requires) - (rep type-rep) - (private type-utils type-effect-convenience)) +(require (private planet-requires type-utils type-effect-convenience type-rep)) (require (schemeunit)) (define-syntax-rule (s img var tgt result) diff --git a/collects/tests/typed-scheme/unit-tests/subtype-tests.ss b/collects/tests/typed-scheme/unit-tests/subtype-tests.ss index 83bb3e9a51..f4bc99125d 100644 --- a/collects/tests/typed-scheme/unit-tests/subtype-tests.ss +++ b/collects/tests/typed-scheme/unit-tests/subtype-tests.ss @@ -2,12 +2,8 @@ (require "test-utils.ss") -(require (private subtype type-effect-convenience union) - (rep type-rep) - (utils planet-requires) - (env init-envs type-environments) - (r:infer infer infer-dummy)) - +(require (private subtype type-rep type-effect-convenience + planet-requires init-envs type-environments union infer infer-dummy)) (require (schemeunit) (for-syntax scheme/base)) diff --git a/collects/tests/typed-scheme/unit-tests/test-utils.ss b/collects/tests/typed-scheme/unit-tests/test-utils.ss index b160cacdf9..f5c848fa04 100644 --- a/collects/tests/typed-scheme/unit-tests/test-utils.ss +++ b/collects/tests/typed-scheme/unit-tests/test-utils.ss @@ -3,12 +3,25 @@ (require scheme/require-syntax scheme/match - typed-scheme/utils/utils (for-syntax scheme/base)) +(define-require-syntax private + (lambda (stx) + (syntax-case stx () + [(_ id ...) + (andmap identifier? (syntax->list #'(id ...))) + (with-syntax ([(id* ...) (map (lambda (id) (datum->syntax + id + (string->symbol + (string-append + "typed-scheme/private/" + (symbol->string (syntax-e id)))) + id id)) + (syntax->list #'(id ...)))]) + (syntax/loc stx (combine-in id* ...)))]))) + +(require (private planet-requires type-comparison utils type-utils)) -(require (utils planet-requires) (private type-comparison type-utils)) -(provide private typecheck (rename-out [infer r:infer]) utils env rep) (require (schemeunit)) (define (mk-suite ts) diff --git a/collects/tests/typed-scheme/unit-tests/type-annotation-test.ss b/collects/tests/typed-scheme/unit-tests/type-annotation-test.ss index 167db51eb7..80e471b00c 100644 --- a/collects/tests/typed-scheme/unit-tests/type-annotation-test.ss +++ b/collects/tests/typed-scheme/unit-tests/type-annotation-test.ss @@ -1,10 +1,8 @@ #lang scheme/base (require "test-utils.ss" (for-syntax scheme/base)) -(require (private type-annotation type-effect-convenience parse-type) - (env type-environments type-name-env init-envs) - (utils planet-requires tc-utils) - (rep type-rep)) +(require (private planet-requires type-annotation tc-utils type-rep type-effect-convenience type-environments + parse-type init-envs type-name-env)) (require (schemeunit)) diff --git a/collects/tests/typed-scheme/unit-tests/type-equal-tests.ss b/collects/tests/typed-scheme/unit-tests/type-equal-tests.ss index 899b8e1e97..6488d47b16 100644 --- a/collects/tests/typed-scheme/unit-tests/type-equal-tests.ss +++ b/collects/tests/typed-scheme/unit-tests/type-equal-tests.ss @@ -1,8 +1,7 @@ #lang scheme/base (require "test-utils.ss" (for-syntax scheme/base)) -(require (utils planet-requires) (rep type-rep) - (private type-comparison type-effect-convenience union subtype)) +(require (private planet-requires type-rep type-comparison type-effect-convenience union subtype)) (require (schemeunit)) (provide type-equal-tests) diff --git a/collects/tests/typed-scheme/unit-tests/typecheck-tests.ss b/collects/tests/typed-scheme/unit-tests/typecheck-tests.ss index fee35aa2fc..a5263dd32b 100644 --- a/collects/tests/typed-scheme/unit-tests/typecheck-tests.ss +++ b/collects/tests/typed-scheme/unit-tests/typecheck-tests.ss @@ -3,16 +3,14 @@ (require "test-utils.ss" (for-syntax scheme/base) (for-template scheme/base)) -(require (private base-env mutated-vars type-utils union prims type-effect-convenience type-annotation) - (typecheck typechecker) - (rep type-rep effect-rep) - (utils tc-utils planet-requires) - (env type-name-env type-environments init-envs)) +(require (private base-env)) -(require (for-syntax (utils tc-utils) - (typecheck typechecker) - (env type-env) - (private base-env)) +(require (private planet-requires typechecker + type-rep type-effect-convenience type-env + prims type-environments tc-utils union + type-name-env init-envs mutated-vars + effect-rep type-annotation type-utils) + (for-syntax (private tc-utils typechecker base-env type-env)) (for-template (private base-env base-types))) (require (schemeunit)) @@ -671,7 +669,7 @@ (tc-l #t (-val #t)) (tc-l "foo" -String) (tc-l foo (-val 'foo)) - (tc-l #:foo (-val '#:foo)) + (tc-l #:foo -Keyword) (tc-l #f (-val #f)) (tc-l #"foo" -Bytes) [tc-l () (-val null)] diff --git a/collects/typed-scheme/infer/infer-dummy.ss b/collects/typed-scheme/infer/infer-dummy.ss deleted file mode 100644 index d83922a61e..0000000000 --- a/collects/typed-scheme/infer/infer-dummy.ss +++ /dev/null @@ -1,8 +0,0 @@ -#lang scheme/base -(require "../utils/utils.ss") - -(require (rep type-rep) (utils tc-utils)) - -(define infer-param (make-parameter (lambda e (int-err "infer not initialized")))) -(define (unify X S T) ((infer-param) X S T (make-Univ) null)) -(provide unify infer-param) \ No newline at end of file diff --git a/collects/typed-scheme/infer/signatures.ss b/collects/typed-scheme/infer/signatures.ss deleted file mode 100644 index 6db02b38dc..0000000000 --- a/collects/typed-scheme/infer/signatures.ss +++ /dev/null @@ -1,29 +0,0 @@ -#lang scheme/base -(require scheme/unit) -(provide (all-defined-out)) - -(define-signature dmap^ - (dmap-meet)) - -(define-signature promote-demote^ - (var-promote var-demote)) - -(define-signature constraints^ - (exn:infer? - fail-sym - ;; inference failure - masked before it gets to the user program - (define-syntaxes (fail!) - (syntax-rules () - [(_ s t) (raise fail-sym)])) - cset-meet cset-meet* - no-constraint - empty-cset - insert - cset-combine - c-meet)) - -(define-signature restrict^ - (restrict)) - -(define-signature infer^ - (infer infer/vararg infer/dots)) diff --git a/collects/typed-scheme/no-check.ss b/collects/typed-scheme/no-check.ss deleted file mode 100644 index 470a7bed8a..0000000000 --- a/collects/typed-scheme/no-check.ss +++ /dev/null @@ -1,5 +0,0 @@ -#lang scheme/base - -(require "private/prims.ss") -(provide (all-from-out scheme/base) - (all-from-out "private/prims.ss")) \ No newline at end of file diff --git a/collects/typed-scheme/no-check/lang/reader.ss b/collects/typed-scheme/no-check/lang/reader.ss deleted file mode 100644 index c35cbecc78..0000000000 --- a/collects/typed-scheme/no-check/lang/reader.ss +++ /dev/null @@ -1,13 +0,0 @@ -#lang scheme/base -(require (prefix-in r: "../../typed-reader.ss") - (only-in syntax/module-reader wrap-read-all)) - -(define (*read in modpath line col pos) - (wrap-read-all 'typed-scheme/no-check in r:read modpath #f line col pos)) - -(define (*read-syntax src in modpath line col pos) - (wrap-read-all - 'typed-scheme/no-check in (lambda (in) (r:read-syntax src in)) - modpath src line col pos)) - -(provide (rename-out [*read read] [*read-syntax read-syntax])) diff --git a/collects/typed-scheme/private/base-env.ss b/collects/typed-scheme/private/base-env.ss index 6600a1f7f2..59708588b1 100644 --- a/collects/typed-scheme/private/base-env.ss +++ b/collects/typed-scheme/private/base-env.ss @@ -3,7 +3,6 @@ ;; these are libraries providing functions we add types to that are not in scheme/base (require "extra-procs.ss" - "../utils/utils.ss" (only-in scheme/list cons? take drop add-between last filter-map) (only-in rnrs/lists-6 fold-left) '#%paramz @@ -16,12 +15,13 @@ ;; these are all for constructing the types given to variables (require (for-syntax scheme/base - (env init-envs) - (except-in (rep effect-rep type-rep) make-arr) + "init-envs.ss" + "effect-rep.ss" + (except-in "type-rep.ss" make-arr) "type-effect-convenience.ss" (only-in "type-effect-convenience.ss" [make-arr* make-arr]) "union.ss" - (typecheck tc-structs))) + "tc-structs.ss")) (define-for-syntax (initialize-others) (d-s date @@ -57,9 +57,6 @@ [qq-append qq-append-ty] [id ty] ...)))])) -(define-for-syntax (one-of/c . args) - (apply Un (map -val args))) - (define-initial-env initial-env ;; make-promise @@ -148,13 +145,9 @@ [string-append (->* null -String -String)] [open-input-string (-> -String -Input-Port)] [open-output-file - (->key -Pathlike - #:mode (one-of/c 'binary 'text) #f - #:exists (one-of/c 'error 'append 'update 'can-update - 'replace 'truncate - 'must-truncate 'truncate/replace) - #f - -Output-Port)] + (cl-> + [(-Pathlike) -Port] + [(-Pathlike Sym) -Port])] [read (cl-> [(-Port) -Sexp] [() -Sexp])] @@ -212,7 +205,9 @@ [remove* (-poly (a b) (cl-> [((-lst a) (-lst a)) (-lst a)] [((-lst a) (-lst b) (a b . -> . B)) (-lst b)]))] - + + [call-with-values (-poly (a b) (-> (-> a) (-> a b) b))] + (error (make-Function (list (make-arr null (Un)) @@ -251,6 +246,7 @@ (- (cl->* (->* (list -Integer) -Integer -Integer) (->* (list N) N N))) (max (->* (list N) N N)) (min (->* (list N) N N)) + [values (make-Poly '(a) (-> (-v a) (-v a)))] [vector-ref (make-Poly (list 'a) ((make-Vector (-v a)) N . -> . (-v a)))] [build-vector (-poly (a) (-Integer (-Integer . -> . a) . -> . (make-Vector a)))] @@ -471,7 +467,7 @@ [(-Bytes N) -Bytes] [(-Bytes N N) -Bytes])] [bytes-length (-> -Bytes N)] - [open-input-file (->key -Pathlike #:mode (Un (-val 'binary) (-val 'text)) #f -Input-Port)] + [open-input-file (-> -Pathlike -Input-Port)] [close-input-port (-> -Input-Port -Void)] [close-output-port (-> -Output-Port -Void)] [read-line (cl-> @@ -557,11 +553,8 @@ [syntax-property (-poly (a) (cl->* (-> (-Syntax a) Univ Univ (-Syntax a)) (-> (-Syntax Univ) Univ Univ)))] - [values (-polydots (a) (null (a a) . ->... . (make-ValuesDots null a 'a)))] - [call-with-values (-polydots (b a) ((-> (make-ValuesDots null a 'a)) (null (a a) . ->... . b) . -> . b))] - - [eof (-val eof)] - [read-accept-reader (-Param B B)] + [values* (-polydots (a) (null (a a) . ->... . (make-ValuesDots null a 'a)))] + [call-with-values* (-polydots (b a) ((-> (make-ValuesDots null a 'a)) (null (a a) . ->... . b) . -> . b))] ) (begin-for-syntax diff --git a/collects/typed-scheme/private/base-types.ss b/collects/typed-scheme/private/base-types.ss index 6058fd4b9c..cc4bb42a3d 100644 --- a/collects/typed-scheme/private/base-types.ss +++ b/collects/typed-scheme/private/base-types.ss @@ -1,10 +1,9 @@ #lang scheme/base -(require (except-in "../utils/utils.ss" extend)) (require (for-syntax scheme/base - (env init-envs) - (except-in (rep type-rep) make-arr) + "init-envs.ss" + (except-in "type-rep.ss" make-arr) "type-effect-convenience.ss" (only-in "type-effect-convenience.ss" [make-arr* make-arr]) "union.ss")) diff --git a/collects/typed-scheme/typecheck/check-subforms-unit.ss b/collects/typed-scheme/private/check-subforms-unit.ss similarity index 89% rename from collects/typed-scheme/typecheck/check-subforms-unit.ss rename to collects/typed-scheme/private/check-subforms-unit.ss index e37c6f3719..1658e455f1 100644 --- a/collects/typed-scheme/typecheck/check-subforms-unit.ss +++ b/collects/typed-scheme/private/check-subforms-unit.ss @@ -1,12 +1,15 @@ #lang scheme/unit -(require (except-in "../utils/utils.ss" extend)) (require syntax/kerncase scheme/match "signatures.ss" - (private type-utils type-effect-convenience union subtype) - (utils tc-utils) - (rep type-rep)) + "type-utils.ss" + "type-rep.ss" ;; doesn't need tests + "type-effect-convenience.ss" ;; maybe needs tests + "union.ss" + "subtype.ss" ;; has tests + "tc-utils.ss" ;; doesn't need tests + ) (import tc-if^ tc-lambda^ tc-app^ tc-let^ tc-expr^) (export check-subforms^) @@ -18,7 +21,7 @@ (define body-ty #f) (define (get-result-ty t) (match t - [(Function: (list (arr: _ rngs #f _ '() _ _) ...)) (apply Un rngs)] + [(Function: (list (arr: _ rngs #f _ _ _) ...)) (apply Un rngs)] [_ (tc-error "Internal error in get-result-ty: not a function type: ~n~a" t)])) (let loop ([form form]) (parameterize ([current-orig-stx form]) diff --git a/collects/typed-scheme/infer/constraint-structs.ss b/collects/typed-scheme/private/constraint-structs.ss similarity index 94% rename from collects/typed-scheme/infer/constraint-structs.ss rename to collects/typed-scheme/private/constraint-structs.ss index d5c970348b..def84ae0a6 100644 --- a/collects/typed-scheme/infer/constraint-structs.ss +++ b/collects/typed-scheme/private/constraint-structs.ss @@ -1,7 +1,6 @@ #lang scheme/base -(require (except-in "../utils/utils.ss" extend)) -(require (rep type-rep) +(require "type-rep.ss" scheme/contract) ;; S, T types diff --git a/collects/typed-scheme/infer/constraints.ss b/collects/typed-scheme/private/constraints.ss similarity index 94% rename from collects/typed-scheme/infer/constraints.ss rename to collects/typed-scheme/private/constraints.ss index 3dff2c088a..2697109ebe 100644 --- a/collects/typed-scheme/infer/constraints.ss +++ b/collects/typed-scheme/private/constraints.ss @@ -1,9 +1,8 @@ #lang scheme/unit -(require (except-in "../utils/utils.ss" extend)) -(require (private type-effect-convenience type-utils union subtype) - (rep type-rep) - (utils tc-utils) +(require "type-effect-convenience.ss" "type-rep.ss" + "type-utils.ss" "union.ss" "tc-utils.ss" + "subtype.ss" "utils.ss" "signatures.ss" "constraint-structs.ss" scheme/match) diff --git a/collects/typed-scheme/typecheck/def-binding.ss b/collects/typed-scheme/private/def-binding.ss similarity index 100% rename from collects/typed-scheme/typecheck/def-binding.ss rename to collects/typed-scheme/private/def-binding.ss diff --git a/collects/typed-scheme/typecheck/defstruct-unit.ss b/collects/typed-scheme/private/defstruct-unit.ss similarity index 100% rename from collects/typed-scheme/typecheck/defstruct-unit.ss rename to collects/typed-scheme/private/defstruct-unit.ss diff --git a/collects/typed-scheme/infer/dmap.ss b/collects/typed-scheme/private/dmap.ss similarity index 92% rename from collects/typed-scheme/infer/dmap.ss rename to collects/typed-scheme/private/dmap.ss index 9592668061..ef2112bae1 100644 --- a/collects/typed-scheme/infer/dmap.ss +++ b/collects/typed-scheme/private/dmap.ss @@ -1,8 +1,6 @@ #lang scheme/unit -(require (except-in "../utils/utils.ss" extend)) -(require "signatures.ss" "constraint-structs.ss" - (utils tc-utils) +(require "signatures.ss" "utils.ss" "tc-utils.ss" "constraint-structs.ss" scheme/match) (import constraints^) diff --git a/collects/typed-scheme/rep/effect-rep.ss b/collects/typed-scheme/private/effect-rep.ss similarity index 100% rename from collects/typed-scheme/rep/effect-rep.ss rename to collects/typed-scheme/private/effect-rep.ss diff --git a/collects/typed-scheme/private/extra-procs.ss b/collects/typed-scheme/private/extra-procs.ss index b5cd5378db..83aa9c4036 100644 --- a/collects/typed-scheme/private/extra-procs.ss +++ b/collects/typed-scheme/private/extra-procs.ss @@ -1,5 +1,5 @@ #lang scheme/base -(provide assert call-with-values* values* foo) +(provide assert call-with-values* values*) (define (assert v) (unless v @@ -15,7 +15,4 @@ (car as) (map car bss)))) (define call-with-values* call-with-values) -(define values* values) - -(define (foo x #:bar [bar #f]) - bar) \ No newline at end of file +(define values* values) \ No newline at end of file diff --git a/collects/typed-scheme/rep/free-variance.ss b/collects/typed-scheme/private/free-variance.ss similarity index 91% rename from collects/typed-scheme/rep/free-variance.ss rename to collects/typed-scheme/private/free-variance.ss index 7e4014e3ca..db9cb4f87e 100644 --- a/collects/typed-scheme/rep/free-variance.ss +++ b/collects/typed-scheme/private/free-variance.ss @@ -1,8 +1,7 @@ #lang scheme/base -(require "../utils/utils.ss") (require (for-syntax scheme/base) - (utils tc-utils) + "tc-utils.ss" mzlib/etc) ;; this file contains support for calculating the free variables/indexes of types @@ -28,8 +27,8 @@ (define var-table (make-weak-hasheq)) ;; maps Type to List[Cons[Symbol,Variance]] -(define (free-idxs* t) (hash-ref index-table t (lambda _ (int-err "type ~a not in index-table" (syntax-e t))))) -(define (free-vars* t) (hash-ref var-table t (lambda _ (int-err "type ~a not in var-table" (syntax-e t))))) +(define (free-idxs* t) (hash-ref index-table t (lambda _ (error "type not in index-table" (syntax-e t))))) +(define (free-vars* t) (hash-ref var-table t (lambda _ (error "type not in var-table" (syntax-e t))))) (define empty-hash-table (make-immutable-hasheq null)) diff --git a/collects/typed-scheme/private/infer-dummy.ss b/collects/typed-scheme/private/infer-dummy.ss new file mode 100644 index 0000000000..8645a31435 --- /dev/null +++ b/collects/typed-scheme/private/infer-dummy.ss @@ -0,0 +1,7 @@ +#lang scheme/base + +(require "type-rep.ss") + +(define infer-param (make-parameter (lambda e (error 'infer "not initialized")))) +(define (unify X S T) ((infer-param) X S T (make-Univ) null)) +(provide unify infer-param) \ No newline at end of file diff --git a/collects/typed-scheme/infer/infer-unit.ss b/collects/typed-scheme/private/infer-unit.ss similarity index 92% rename from collects/typed-scheme/infer/infer-unit.ss rename to collects/typed-scheme/private/infer-unit.ss index c640d363ba..27ec65707c 100644 --- a/collects/typed-scheme/infer/infer-unit.ss +++ b/collects/typed-scheme/private/infer-unit.ss @@ -1,14 +1,12 @@ #lang scheme/unit -(require (except-in "../utils/utils.ss")) -(require (rep free-variance type-rep effect-rep rep-utils) - (private type-effect-convenience union subtype remove-intersect) - (utils tc-utils) - (env type-name-env) - (except-in (private type-utils) Dotted) +(require "type-effect-convenience.ss" "type-rep.ss" "effect-rep.ss" "rep-utils.ss" + "free-variance.ss" + (except-in "type-utils.ss" Dotted) + "union.ss" "tc-utils.ss" "type-name-env.ss" + "subtype.ss" "remove-intersect.ss" "signatures.ss" "utils.ss" "constraint-structs.ss" - "signatures.ss" - (only-in (env type-environments) lookup current-tvars) + (only-in "type-environments.ss" lookup current-tvars) scheme/match mzlib/etc mzlib/trace @@ -113,15 +111,15 @@ (define (cgen/arr V X t-arr s-arr) (define (cg S T) (cgen V X S T)) (match* (t-arr s-arr) - [((arr: ts t #f #f '() t-thn-eff t-els-eff) - (arr: ss s #f #f '() s-thn-eff s-els-eff)) + [((arr: ts t #f #f t-thn-eff t-els-eff) + (arr: ss s #f #f s-thn-eff s-els-eff)) (cset-meet* (list (cgen/list V X ss ts) (cg t s) (cgen/eff/list V X t-thn-eff s-thn-eff) (cgen/eff/list V X t-els-eff s-els-eff)))] - [((arr: ts t t-rest #f '() t-thn-eff t-els-eff) - (arr: ss s s-rest #f '() s-thn-eff s-els-eff)) + [((arr: ts t t-rest #f t-thn-eff t-els-eff) + (arr: ss s s-rest #f s-thn-eff s-els-eff)) (let ([arg-mapping (cond [(and t-rest s-rest (<= (length ts) (length ss))) (cgen/list V X (cons s-rest ss) (cons t-rest (extend ss ts t-rest)))] @@ -137,8 +135,8 @@ (list arg-mapping ret-mapping (cgen/eff/list V X t-thn-eff s-thn-eff) (cgen/eff/list V X t-els-eff s-els-eff))))] - [((arr: ts t #f (cons dty dbound) '() t-thn-eff t-els-eff) - (arr: ss s #f #f '() s-thn-eff s-els-eff)) + [((arr: ts t #f (cons dty dbound) t-thn-eff t-els-eff) + (arr: ss s #f #f s-thn-eff s-els-eff)) (unless (memq dbound X) (fail! S T)) (unless (<= (length ts) (length ss)) @@ -148,10 +146,10 @@ (gensym dbound))] [new-tys (for/list ([var vars]) (substitute (make-F var) dbound dty))] - [new-cset (cgen/arr V (append vars X) (make-arr (append ts new-tys) t #f #f null t-thn-eff t-els-eff) s-arr)]) + [new-cset (cgen/arr V (append vars X) (make-arr (append ts new-tys) t #f #f t-thn-eff t-els-eff) s-arr)]) (move-vars-to-dmap new-cset dbound vars))] - [((arr: ts t #f #f '() t-thn-eff t-els-eff) - (arr: ss s #f (cons dty dbound) '() s-thn-eff s-els-eff)) + [((arr: ts t #f #f t-thn-eff t-els-eff) + (arr: ss s #f (cons dty dbound) s-thn-eff s-els-eff)) (unless (memq dbound X) (fail! S T)) (unless (<= (length ss) (length ts)) @@ -161,10 +159,10 @@ (gensym dbound))] [new-tys (for/list ([var vars]) (substitute (make-F var) dbound dty))] - [new-cset (cgen/arr V (append vars X) t-arr (make-arr (append ss new-tys) s #f #f null s-thn-eff s-els-eff))]) + [new-cset (cgen/arr V (append vars X) t-arr (make-arr (append ss new-tys) s #f #f s-thn-eff s-els-eff))]) (move-vars-to-dmap new-cset dbound vars))] - [((arr: ts t #f (cons t-dty dbound) '() t-thn-eff t-els-eff) - (arr: ss s #f (cons s-dty dbound) '() s-thn-eff s-els-eff)) + [((arr: ts t #f (cons t-dty dbound) t-thn-eff t-els-eff) + (arr: ss s #f (cons s-dty dbound) s-thn-eff s-els-eff)) (unless (= (length ts) (length ss)) (fail! S T)) ;; If we want to infer the dotted bound, then why is it in both types? @@ -177,8 +175,8 @@ (list arg-mapping darg-mapping ret-mapping (cgen/eff/list V X t-thn-eff s-thn-eff) (cgen/eff/list V X t-els-eff s-els-eff))))] - [((arr: ts t #f (cons t-dty dbound) '() t-thn-eff t-els-eff) - (arr: ss s #f (cons s-dty dbound*) '() s-thn-eff s-els-eff)) + [((arr: ts t #f (cons t-dty dbound) t-thn-eff t-els-eff) + (arr: ss s #f (cons s-dty dbound*) s-thn-eff s-els-eff)) (unless (= (length ts) (length ss)) (fail! S T)) (let* ([arg-mapping (cgen/list V X ss ts)] @@ -188,8 +186,8 @@ (list arg-mapping darg-mapping ret-mapping (cgen/eff/list V X t-thn-eff s-thn-eff) (cgen/eff/list V X t-els-eff s-els-eff))))] - [((arr: ts t t-rest #f '() t-thn-eff t-els-eff) - (arr: ss s #f (cons s-dty dbound) '() s-thn-eff s-els-eff)) + [((arr: ts t t-rest #f t-thn-eff t-els-eff) + (arr: ss s #f (cons s-dty dbound) s-thn-eff s-els-eff)) (unless (memq dbound X) (fail! S T)) (if (<= (length ts) (length ss)) @@ -207,11 +205,11 @@ [new-tys (for/list ([var vars]) (substitute (make-F var) dbound s-dty))] [new-cset (cgen/arr V (append vars X) t-arr - (make-arr (append ss new-tys) s #f (cons s-dty dbound) null s-thn-eff s-els-eff))]) + (make-arr (append ss new-tys) s #f (cons s-dty dbound) s-thn-eff s-els-eff))]) (move-vars+rest-to-dmap new-cset dbound vars)))] ;; If dotted <: starred is correct, add it below. Not sure it is. - [((arr: ts t #f (cons t-dty dbound) '() t-thn-eff t-els-eff) - (arr: ss s s-rest #f '() s-thn-eff s-els-eff)) + [((arr: ts t #f (cons t-dty dbound) t-thn-eff t-els-eff) + (arr: ss s s-rest #f s-thn-eff s-els-eff)) (unless (memq dbound X) (fail! S T)) (cond [(< (length ts) (length ss)) diff --git a/collects/typed-scheme/infer/infer.ss b/collects/typed-scheme/private/infer.ss similarity index 67% rename from collects/typed-scheme/infer/infer.ss rename to collects/typed-scheme/private/infer.ss index 208943a32f..d860e5f551 100644 --- a/collects/typed-scheme/infer/infer.ss +++ b/collects/typed-scheme/private/infer.ss @@ -1,10 +1,9 @@ #lang scheme/base -(require (except-in "../utils/utils.ss" infer)) (require "infer-unit.ss" "constraints.ss" "dmap.ss" "signatures.ss" "restrict.ss" "promote-demote.ss" (only-in scheme/unit provide-signature-elements) - (utils unit-utils)) + "unit-utils.ss") (provide-signature-elements restrict^ infer^) diff --git a/collects/typed-scheme/env/init-envs.ss b/collects/typed-scheme/private/init-envs.ss similarity index 90% rename from collects/typed-scheme/env/init-envs.ss rename to collects/typed-scheme/private/init-envs.ss index 4a03b9108d..d0dac77c0c 100644 --- a/collects/typed-scheme/env/init-envs.ss +++ b/collects/typed-scheme/private/init-envs.ss @@ -1,16 +1,11 @@ #lang scheme/base (provide (all-defined-out)) -(require "../utils/utils.ss") -(require "type-env.ss" - "type-name-env.ss" - (rep type-rep effect-rep) - (for-template (rep type-rep effect-rep) - (private union) - mzlib/pconvert mzlib/shared scheme/base) - (private type-effect-convenience union) - "type-alias-env.ss" - mzlib/pconvert scheme/match mzlib/shared) +(require "type-env.ss" "type-rep.ss" "type-name-env.ss" "union.ss" "effect-rep.ss" + "type-effect-convenience.ss" "type-alias-env.ss" + "type-alias-env.ss") +(require mzlib/pconvert scheme/match mzlib/shared + (for-template mzlib/pconvert mzlib/shared scheme/base "type-rep.ss" "union.ss" "effect-rep.ss")) (define (initialize-type-name-env initial-type-names) (for-each (lambda (nm/ty) (register-resolved-type-alias (car nm/ty) (cadr nm/ty))) initial-type-names)) diff --git a/collects/typed-scheme/typecheck/internal-forms.ss b/collects/typed-scheme/private/internal-forms.ss similarity index 100% rename from collects/typed-scheme/typecheck/internal-forms.ss rename to collects/typed-scheme/private/internal-forms.ss diff --git a/collects/typed-scheme/rep/interning.ss b/collects/typed-scheme/private/interning.ss similarity index 100% rename from collects/typed-scheme/rep/interning.ss rename to collects/typed-scheme/private/interning.ss diff --git a/collects/typed-scheme/env/lexical-env.ss b/collects/typed-scheme/private/lexical-env.ss similarity index 90% rename from collects/typed-scheme/env/lexical-env.ss rename to collects/typed-scheme/private/lexical-env.ss index 63a1295b76..e5946a3126 100644 --- a/collects/typed-scheme/env/lexical-env.ss +++ b/collects/typed-scheme/private/lexical-env.ss @@ -1,12 +1,6 @@ #lang scheme/base -(require (except-in "../utils/utils.ss" extend)) -(require "type-environments.ss" - (utils tc-utils) - "type-env.ss" - (private mutated-vars) - (private type-utils) - (private type-effect-convenience)) +(require "type-environments.ss" "tc-utils.ss" "type-env.ss" "mutated-vars.ss" "type-utils.ss" "type-effect-convenience.ss") (provide (all-defined-out)) diff --git a/collects/typed-scheme/private/mutated-vars.ss b/collects/typed-scheme/private/mutated-vars.ss index a362bd5361..6e7a2c2da9 100644 --- a/collects/typed-scheme/private/mutated-vars.ss +++ b/collects/typed-scheme/private/mutated-vars.ss @@ -14,11 +14,12 @@ ;; syntax -> void (define (fmv/list lstx) (for-each find-mutated-vars (syntax->list lstx))) - ;(when (and (pair? (syntax->datum form))) (printf "called with ~a~n" (syntax->datum form))) + ;(printf "called with ~a~n" (syntax->datum form)) (kernel-syntax-case* form #f (define-type-alias-internal define-typed-struct-internal require/typed-internal) ;; what we care about: set! [(set! v e) (begin + ;(printf "mutated var found: ~a~n" (syntax-e #'v)) (module-identifier-mapping-put! table #'v #t))] [(define-values (var ...) expr) (find-mutated-vars #'expr)] @@ -27,13 +28,15 @@ [(begin0 . rest) (fmv/list #'rest)] [(#%plain-lambda _ . rest) (fmv/list #'rest)] [(case-lambda (_ . rest) ...) (for-each fmv/list (syntax->list #'(rest ...)))] - [(if . es) (fmv/list #'es)] - [(with-continuation-mark . es) (fmv/list #'es)] + [(if e1 e2) (begin (find-mutated-vars #'e1) (find-mutated-vars #'e2))] + [(if e1 e2 e3) (begin (find-mutated-vars #'e1) (find-mutated-vars #'e1) (find-mutated-vars #'e3))] + [(with-continuation-mark e1 e2 e3) (begin (find-mutated-vars #'e1) + (find-mutated-vars #'e1) + (find-mutated-vars #'e3))] [(let-values ([_ e] ...) . b) (begin (fmv/list #'(e ...)) (fmv/list #'b))] [(letrec-values ([_ e] ...) . b) (begin (fmv/list #'(e ...)) - (fmv/list #'b))] - [(#%expression e) (find-mutated-vars #'e)] + (fmv/list #'b))] ;; all the other forms don't have any expression subforms (like #%top) [_ (void)])) diff --git a/collects/typed-scheme/private/parse-type.ss b/collects/typed-scheme/private/parse-type.ss index 07adfd9e17..2b92c493d6 100644 --- a/collects/typed-scheme/private/parse-type.ss +++ b/collects/typed-scheme/private/parse-type.ss @@ -2,15 +2,16 @@ (provide parse-type parse-type/id) -(require (except-in "../utils/utils.ss" extend)) -(require (except-in (rep type-rep) make-arr) +(require (except-in "type-rep.ss" make-arr) "type-effect-convenience.ss" (only-in "type-effect-convenience.ss" [make-arr* make-arr]) - (utils tc-utils) + "tc-utils.ss" "union.ss" syntax/stx - (env type-environments type-name-env type-alias-env) - "type-utils.ss" + (except-in "type-environments.ss") + "type-name-env.ss" + "type-alias-env.ss" + "type-utils.ss" scheme/match) (define enable-mu-parsing (make-parameter #t)) @@ -212,7 +213,7 @@ ;(printf "found a type name ~a~n" #'id) (make-Name #'id)] [else - (tc-error/delayed "unbound type name ~a" (syntax-e #'id)) + (tc-error/delayed "unbound type ~a" (syntax-e #'id)) Univ])] [(All . rest) (eq? (syntax-e #'All) 'All) (tc-error "All: bad syntax")] diff --git a/collects/typed-scheme/utils/planet-requires.ss b/collects/typed-scheme/private/planet-requires.ss similarity index 100% rename from collects/typed-scheme/utils/planet-requires.ss rename to collects/typed-scheme/private/planet-requires.ss diff --git a/collects/typed-scheme/private/prims.ss b/collects/typed-scheme/private/prims.ss index 9068659cfd..ef3e7cc5a7 100644 --- a/collects/typed-scheme/private/prims.ss +++ b/collects/typed-scheme/private/prims.ss @@ -22,20 +22,20 @@ This file defines two sorts of primitives. All of them are provided into any mod (provide (all-defined-out) (rename-out [define-typed-struct define-struct:])) -(require (except-in "../utils/utils.ss" extend)) (require (for-syntax scheme/base - (rep type-rep) + "type-rep.ss" mzlib/match "parse-type.ss" syntax/struct syntax/stx - (utils utils tc-utils) - (env type-name-env) + "utils.ss" + "tc-utils.ss" + "type-name-env.ss" "type-contract.ss")) (require "require-contract.ss" - (typecheck internal-forms) + "internal-forms.ss" (except-in mzlib/contract ->) (only-in mzlib/contract [-> c->]) mzlib/struct diff --git a/collects/typed-scheme/infer/promote-demote.ss b/collects/typed-scheme/private/promote-demote.ss similarity index 80% rename from collects/typed-scheme/infer/promote-demote.ss rename to collects/typed-scheme/private/promote-demote.ss index 8705122937..bbb1d7b229 100644 --- a/collects/typed-scheme/infer/promote-demote.ss +++ b/collects/typed-scheme/private/promote-demote.ss @@ -1,9 +1,8 @@ #lang scheme/unit -(require "../utils/utils.ss") -(require (rep type-rep) - (private type-effect-convenience union type-utils) - "signatures.ss" +(require "type-effect-convenience.ss" "type-rep.ss" + "type-utils.ss" "union.ss" + "signatures.ss" scheme/list) (import) @@ -27,7 +26,7 @@ [#:Param in out (make-Param (var-demote in V) (vp out))] - [#:arr dom rng rest drest kws thn els + [#:arr dom rng rest drest thn els (cond [(apply V-in? V (append thn els)) (make-arr null (Un) Univ #f null null)] @@ -36,8 +35,6 @@ (vp rng) (var-demote (car drest) V) #f - (for/list ([(kw kwt) (in-pairs kws)]) - (cons kw (var-demote kwt V))) thn els)] [else @@ -47,8 +44,6 @@ (and drest (cons (var-demote (car drest) V) (cdr drest))) - (for/list ([(kw kwt) (in-pairs kws)]) - (cons kw (var-demote kwt V))) thn els)])])) @@ -66,7 +61,7 @@ [#:Param in out (make-Param (var-promote in V) (vd out))] - [#:arr dom rng rest drest kws thn els + [#:arr dom rng rest drest thn els (cond [(apply V-in? V (append thn els)) (make-arr null (Un) Univ #f null null)] @@ -75,8 +70,6 @@ (vd rng) (var-promote (car drest) V) #f - (for/list ([(kw kwt) (in-pairs kws)]) - (cons kw (var-promote kwt V))) thn els)] [else @@ -86,7 +79,5 @@ (and drest (cons (var-promote (car drest) V) (cdr drest))) - (for/list ([(kw kwt) (in-pairs kws)]) - (cons kw (var-promote kwt V))) thn els)])])) diff --git a/collects/typed-scheme/typecheck/provide-handling.ss b/collects/typed-scheme/private/provide-handling.ss similarity index 96% rename from collects/typed-scheme/typecheck/provide-handling.ss rename to collects/typed-scheme/private/provide-handling.ss index 4ca36a3460..1d4f67bfd1 100644 --- a/collects/typed-scheme/typecheck/provide-handling.ss +++ b/collects/typed-scheme/private/provide-handling.ss @@ -1,12 +1,11 @@ #lang scheme/base -(require (except-in "../utils/utils.ss" extend)) (require (only-in srfi/1/list s:member) syntax/kerncase mzlib/trace - (private type-contract) - (rep type-rep) - (utils tc-utils) + "type-contract.ss" + "type-rep.ss" + "tc-utils.ss" "def-binding.ss") (require (for-template scheme/base diff --git a/collects/typed-scheme/private/remove-intersect.ss b/collects/typed-scheme/private/remove-intersect.ss index d244fb7302..f9b273e80a 100644 --- a/collects/typed-scheme/private/remove-intersect.ss +++ b/collects/typed-scheme/private/remove-intersect.ss @@ -1,8 +1,7 @@ #lang scheme/base -(require (except-in "../utils/utils.ss" extend)) -(require (rep type-rep) - (private union subtype resolve-type type-effect-convenience type-utils) +(require "type-rep.ss" "union.ss" "subtype.ss" + "type-utils.ss" "resolve-type.ss" "type-effect-convenience.ss" mzlib/plt-match mzlib/trace) (provide (rename-out [*remove remove]) overlap) diff --git a/collects/typed-scheme/rep/rep-utils.ss b/collects/typed-scheme/private/rep-utils.ss similarity index 96% rename from collects/typed-scheme/rep/rep-utils.ss rename to collects/typed-scheme/private/rep-utils.ss index 2f49dba9f6..e3cf76e2d1 100644 --- a/collects/typed-scheme/rep/rep-utils.ss +++ b/collects/typed-scheme/private/rep-utils.ss @@ -1,18 +1,18 @@ #lang scheme/base -(require "../utils/utils.ss") (require mzlib/struct mzlib/plt-match syntax/boundmap - (utils planet-requires) + "planet-requires.ss" "free-variance.ss" + "utils.ss" "interning.ss" mzlib/etc (for-syntax scheme/base syntax/struct syntax/stx - (utils utils))) + "utils.ss")) (provide == dt de print-type* print-effect* Type Type? Effect Effect? defintern hash-id Type-seq Effect-seq) @@ -150,9 +150,7 @@ (lambda (s) (... (syntax-case s () - [(__ . fs) - (with-syntax ([flds** (syntax/loc s (_ . fs))]) - (quasisyntax/loc s (struct nm flds**)))])))) + [(__ . fs) (quasisyntax/loc s (struct nm #, (syntax/loc #'fs (_ . fs))))])))) (begin-for-syntax (hash-set! ht-stx 'kw-stx (list #'ex #'flds bfs-fold-rhs #'#,stx))) intern diff --git a/collects/typed-scheme/private/resolve-type.ss b/collects/typed-scheme/private/resolve-type.ss index 6526a42819..d68de69267 100644 --- a/collects/typed-scheme/private/resolve-type.ss +++ b/collects/typed-scheme/private/resolve-type.ss @@ -1,7 +1,6 @@ #lang scheme/base -(require "../utils/utils.ss") -(require (rep type-rep) (env type-name-env) (utils tc-utils) +(require "type-rep.ss" "type-name-env.ss" "tc-utils.ss" "type-utils.ss" mzlib/plt-match mzlib/trace) diff --git a/collects/typed-scheme/infer/restrict.ss b/collects/typed-scheme/private/restrict.ss similarity index 90% rename from collects/typed-scheme/infer/restrict.ss rename to collects/typed-scheme/private/restrict.ss index e13656056c..2c86a687b7 100644 --- a/collects/typed-scheme/infer/restrict.ss +++ b/collects/typed-scheme/private/restrict.ss @@ -1,8 +1,8 @@ #lang scheme/unit -(require "../utils/utils.ss") -(require (rep type-rep) - (private type-utils union remove-intersect subtype) +(require "type-rep.ss" + "type-utils.ss" "union.ss" + "subtype.ss" "remove-intersect.ss" "signatures.ss" scheme/match) diff --git a/collects/typed-scheme/typecheck/signatures.ss b/collects/typed-scheme/private/signatures.ss similarity index 56% rename from collects/typed-scheme/typecheck/signatures.ss rename to collects/typed-scheme/private/signatures.ss index 572becfda2..9f8b0dba0e 100644 --- a/collects/typed-scheme/typecheck/signatures.ss +++ b/collects/typed-scheme/private/signatures.ss @@ -2,11 +2,41 @@ (require scheme/unit) (provide (all-defined-out)) +(define-signature dmap^ + (dmap-meet)) + +(define-signature promote-demote^ + (var-promote var-demote)) + +(define-signature constraints^ + (exn:infer? + fail-sym + ;; inference failure - masked before it gets to the user program + (define-syntaxes (fail!) + (syntax-rules () + [(_ s t) (raise fail-sym)])) + cset-meet cset-meet* + no-constraint + empty-cset + insert + cset-combine + c-meet)) + +(define-signature restrict^ + (restrict)) + +(define-signature infer^ + (infer infer/vararg infer/dots)) + + + +;; cycle 2 + (define-signature typechecker^ (type-check tc-toplevel-form)) (define-signature tc-expr^ - (tc-expr tc-expr/check tc-expr/check/t check-below tc-literal tc-exprs tc-exprs/check tc-expr/t)) + (tc-expr tc-expr/check tc-expr/check/t check-below tc-literal tc-exprs tc-exprs/check tc-expr/t #;check-expr)) (define-signature check-subforms^ (check-subforms/ignore check-subforms/with-handlers check-subforms/with-handlers/check)) diff --git a/collects/typed-scheme/private/subtype.ss b/collects/typed-scheme/private/subtype.ss index 1db8c33be8..398fe7b226 100644 --- a/collects/typed-scheme/private/subtype.ss +++ b/collects/typed-scheme/private/subtype.ss @@ -1,13 +1,12 @@ #lang scheme/base -(require "../utils/utils.ss") -(require (except-in (rep type-rep effect-rep) sub-eff) - (utils tc-utils) - "type-utils.ss" +(require (except-in "type-rep.ss" sub-eff) "type-utils.ss" + "tc-utils.ss" + "effect-rep.ss" "type-comparison.ss" "resolve-type.ss" - (env type-name-env) - (only-in (infer infer-dummy) unify) + "type-name-env.ss" + (only-in "infer-dummy.ss" unify) mzlib/plt-match mzlib/trace) @@ -101,13 +100,10 @@ (match (list s t) ;; top for functions is above everything [(list _ (top-arr:)) A0] - [(list (arr: s1 s2 #f #f (list (cons kw s-kw-ty) ...) thn-eff els-eff) - (arr: t1 t2 #f #f (list (cons kw t-kw-ty) ...) thn-eff els-eff)) - (let* ([A1 (subtypes* A0 t1 s1)] - [A2 (subtypes* A1 t-kw-ty s-kw-ty)]) + [(list (arr: s1 s2 #f #f thn-eff els-eff) (arr: t1 t2 #f #f thn-eff els-eff)) + (let ([A1 (subtypes* A0 t1 s1)]) (subtype* A1 s2 t2))] - [(list (arr: s1 s2 s3 #f (list (cons kw s-kw-ty) ...) thn-eff els-eff) - (arr: t1 t2 t3 #f (list (cons kw t-kw-ty) ...) thn-eff* els-eff*)) + [(list (arr: s1 s2 s3 #f thn-eff els-eff) (arr: t1 t2 t3 #f thn-eff* els-eff*)) (unless (or (and (null? thn-eff*) (null? els-eff*)) (and (effects-equal? thn-eff thn-eff*) @@ -119,11 +115,10 @@ (andmap sub-eff els-eff els-eff*))) (fail! s t)) ;; either the effects have to be the same, or the supertype can't have effects - (let* ([A2 (subtypes*/varargs A0 t1 s1 s3)] - [A3 (subtypes* A2 t-kw-ty s-kw-ty)]) + (let ([A (subtypes*/varargs A0 t1 s1 s3)]) (if (not t3) - (subtype* A3 s2 t2) - (let ([A1 (subtype* A3 t3 s3)]) + (subtype* A s2 t2) + (let ([A1 (subtype* A t3 s3)]) (subtype* A1 s2 t2))))] [else (fail! s t)]))) diff --git a/collects/typed-scheme/utils/syntax-traversal.ss b/collects/typed-scheme/private/syntax-traversal.ss similarity index 100% rename from collects/typed-scheme/utils/syntax-traversal.ss rename to collects/typed-scheme/private/syntax-traversal.ss diff --git a/collects/typed-scheme/utils/tables.ss b/collects/typed-scheme/private/tables.ss similarity index 100% rename from collects/typed-scheme/utils/tables.ss rename to collects/typed-scheme/private/tables.ss diff --git a/collects/typed-scheme/typecheck/tc-app-unit.ss b/collects/typed-scheme/private/tc-app-unit.ss similarity index 90% rename from collects/typed-scheme/typecheck/tc-app-unit.ss rename to collects/typed-scheme/private/tc-app-unit.ss index 3c04db1429..b1758d54ba 100644 --- a/collects/typed-scheme/typecheck/tc-app-unit.ss +++ b/collects/typed-scheme/private/tc-app-unit.ss @@ -1,13 +1,19 @@ #lang scheme/unit -(require (only-in "../utils/utils.ss" debug in-syntax printf/log in-pairs rep utils private env [infer r:infer])) (require "signatures.ss" - (rep type-rep effect-rep) - (utils tc-utils) - (private subtype type-utils union type-effect-convenience type-effect-printer resolve-type - type-annotation) - (r:infer infer) - (env type-environments) + "type-rep.ss" + "effect-rep.ss" + "tc-utils.ss" + "subtype.ss" + "infer.ss" + (only-in "utils.ss" debug in-syntax printf/log in-pairs) + "union.ss" + "type-utils.ss" + "type-effect-convenience.ss" + "type-effect-printer.ss" + "type-annotation.ss" + "resolve-type.ss" + "type-environments.ss" (only-in srfi/1 alist-delete) (only-in scheme/private/class-internal make-object do-make-object) mzlib/trace mzlib/pretty syntax/kerncase scheme/match @@ -15,7 +21,7 @@ (for-template "internal-forms.ss" scheme/base (only-in scheme/private/class-internal make-object do-make-object))) -(require (r:infer constraint-structs)) +(require "constraint-structs.ss") (import tc-expr^ tc-lambda^ tc-dots^) (export tc-app^) @@ -153,7 +159,7 @@ (define-values (fixed-args tail) (split (syntax->list args))) (match f-ty - [(tc-result: (Function: (list (arr: doms rngs rests drests '() thn-effs els-effs) ...))) + [(tc-result: (Function: (list (arr: doms rngs rests drests thn-effs els-effs) ...))) (when (null? doms) (tc-error/expr #:return (ret (Un)) "empty case-lambda given as argument to apply")) @@ -198,7 +204,7 @@ (printf/log "Non-poly apply, ... arg\n") (ret (car rngs*))] [else (loop (cdr doms*) (cdr rngs*) (cdr rests*) (cdr drests*))])))] - [(tc-result: (Poly: vars (Function: (list (arr: doms rngs rests drests '() thn-effs els-effs) ..1)))) + [(tc-result: (Poly: vars (Function: (list (arr: doms rngs rests drests thn-effs els-effs) ..1)))) (let*-values ([(arg-tys) (map tc-expr/t fixed-args)] [(tail-ty tail-bound) (with-handlers ([exn:fail:syntax? (lambda _ (values (tc-expr/t tail) #f))]) (tc/dots tail))]) @@ -208,7 +214,7 @@ (let loop ([doms* doms] [rngs* rngs] [rests* rests] [drests* drests]) (cond [(null? doms*) (match f-ty - [(tc-result: (Poly-names: _ (Function: (list (arr: doms rngs rests drests '() _ _) ..1)))) + [(tc-result: (Poly-names: _ (Function: (list (arr: doms rngs rests drests _ _) ..1)))) (tc-error/expr #:return (ret (Un)) (string-append "Bad arguments to polymorphic function in apply:~n" @@ -253,14 +259,14 @@ (tc-error/expr #:return (ret (Un)) "Function has no cases")] [(tc-result: (PolyDots: (and vars (list fixed-vars ... dotted-var)) - (Function: (list (arr: doms rngs rests drests '() thn-effs els-effs) ..1)))) + (Function: (list (arr: doms rngs rests drests thn-effs els-effs) ..1)))) (let*-values ([(arg-tys) (map tc-expr/t fixed-args)] [(tail-ty tail-bound) (with-handlers ([exn:fail:syntax? (lambda _ (values (tc-expr/t tail) #f))]) (tc/dots tail))]) (let loop ([doms* doms] [rngs* rngs] [rests* rests] [drests* drests]) (cond [(null? doms*) (match f-ty - [(tc-result: (PolyDots-names: _ (Function: (list (arr: doms rngs rests drests '() _ _) ..1)))) + [(tc-result: (PolyDots-names: _ (Function: (list (arr: doms rngs rests drests _ _) ..1)))) (tc-error/expr #:return (ret (Un)) (string-append "Bad arguments to polymorphic function in apply:~n" @@ -372,8 +378,8 @@ (define (poly-fail t argtypes #:name [name #f]) (match t - [(or (Poly-names: msg-vars (Function: (list (arr: msg-doms msg-rngs msg-rests msg-drests '() _ _) ...))) - (PolyDots-names: msg-vars (Function: (list (arr: msg-doms msg-rngs msg-rests msg-drests '() _ _) ...)))) + [(or (Poly-names: msg-vars (Function: (list (arr: msg-doms msg-rngs msg-rests msg-drests _ _) ...))) + (PolyDots-names: msg-vars (Function: (list (arr: msg-doms msg-rngs msg-rests msg-drests _ _) ...)))) (let ([fcn-string (if name (format "function ~a (over ~~a)" (syntax->datum name)) "function over ~a")]) @@ -423,8 +429,7 @@ "Wrong number of arguments to parameter - expected 0 or 1, got ~a" (length argtypes))])] ;; single clause functions - ;; FIXME - error on non-optional keywords - [(tc-result: (and t (Function: (list (arr: dom rng rest #f _ latent-thn-effs latent-els-effs)))) + [(tc-result: (and t (Function: (list (arr: dom rng rest #f latent-thn-effs latent-els-effs)))) thn-eff els-eff) (let-values ([(thn-eff els-eff) (tc-args argtypes arg-thn-effs arg-els-effs dom rest @@ -432,7 +437,7 @@ (syntax->list args))]) (ret rng thn-eff els-eff))] ;; non-polymorphic case-lambda functions - [(tc-result: (and t (Function: (list (arr: doms rngs rests (and drests #f) '() latent-thn-effs latent-els-effs) ..1))) + [(tc-result: (and t (Function: (list (arr: doms rngs rests (and drests #f) latent-thn-effs latent-els-effs) ..1))) thn-eff els-eff) (let loop ([doms* doms] [rngs rngs] [rests* rests]) (cond [(null? doms*) @@ -448,19 +453,19 @@ ;; simple polymorphic functions, no rest arguments [(tc-result: (and t (or (Poly: vars - (Function: (list (arr: doms rngs (and rests #f) (and drests #f) '() thn-effs els-effs) ...))) + (Function: (list (arr: doms rngs (and rests #f) (and drests #f) thn-effs els-effs) ...))) (PolyDots: (list vars ... _) - (Function: (list (arr: doms rngs (and rests #f) (and drests #f) '() thn-effs els-effs) ...)))))) + (Function: (list (arr: doms rngs (and rests #f) (and drests #f) thn-effs els-effs) ...)))))) (handle-clauses (doms rngs) f-stx (lambda (dom _) (= (length dom) (length argtypes))) (lambda (dom rng) (infer (fv/list (cons rng dom)) argtypes dom rng (fv rng) expected)) t argtypes expected)] ;; polymorphic varargs [(tc-result: (and t - (or (Poly: vars (Function: (list (arr: doms rngs rests (and drests #f) '() thn-effs els-effs) ...))) + (or (Poly: vars (Function: (list (arr: doms rngs rests (and drests #f) thn-effs els-effs) ...))) ;; we want to infer the dotted-var here as well, and we don't use these separately ;; so we can just use "vars" instead of (list fixed-vars ... dotted-var) - (PolyDots: vars (Function: (list (arr: doms rngs rests (and drests #f) '() thn-effs els-effs) ...)))))) + (PolyDots: vars (Function: (list (arr: doms rngs rests (and drests #f) thn-effs els-effs) ...)))))) (printf/log "Polymorphic varargs function application (~a)\n" (syntax->datum f-stx)) (handle-clauses (doms rests rngs) f-stx (lambda (dom rest rng) (<= (length dom) (length argtypes))) @@ -469,7 +474,7 @@ ;; polymorphic ... type [(tc-result: (and t (PolyDots: (and vars (list fixed-vars ... dotted-var)) - (Function: (list (arr: doms rngs (and #f rests) (cons dtys dbounds) '() thn-effs els-effs) ...))))) + (Function: (list (arr: doms rngs (and #f rests) (cons dtys dbounds) thn-effs els-effs) ...))))) (printf/log "Polymorphic ... function application (~a)\n" (syntax->datum f-stx)) (handle-clauses (doms dtys dbounds rngs) f-stx (lambda (dom dty dbound rng) (and (<= (length dom) (length argtypes)) @@ -561,47 +566,6 @@ [(tc-result: t) (tc-error/expr #:return (ret (Un)) "expected a class value for object creation, got: ~a" t)])))) -(define (tc-keywords form arities kws kw-args pos-args expected) - (match arities - [(list (arr: dom rng rest #f ktys _ _)) - ;; assumes that everything is in sorted order - (let loop ([actual-kws kws] - [actuals (map tc-expr/t (syntax->list kw-args))] - [formals ktys]) - (match* (actual-kws formals) - [('() '()) - (void)] - [(_ '()) - (tc-error/expr #:return (ret (Un)) - "Unexpected keyword argument ~a" (car actual-kws))] - [('() (cons fst rst)) - (match fst - [(Keyword: k _ #t) - (tc-error/expr #:return (ret (Un)) - "Missing keyword argument ~a" k)] - [_ (loop actual-kws actuals rst)])] - [((cons k kws-rest) (cons (Keyword: k* t req?) form-rest)) - (cond [(eq? k k*) ;; we have a match - (unless (subtype (car actuals) t) - (tc-error/delayed - "Wrong function argument type, expected ~a, got ~a for keyword argument ~a" - t (car actuals) k)) - (loop kws-rest (cdr actuals) form-rest)] - [req? ;; this keyword argument was required - (tc-error/delayed "Missing keyword argument ~a" k*) - (loop kws-rest (cdr actuals) form-rest)] - [else ;; otherwise, ignore this formal param, and continue - (loop actual-kws actuals form-rest)])])) - (tc/funapp (car (syntax-e form)) kw-args (ret (make-Function arities)) (map tc-expr (syntax->list pos-args)) expected)] - [_ (int-err "case-lambda w/ keywords not supported")])) - - -(define (type->list t) - (match t - [(Pair: (Value: (? keyword? k)) b) (cons k (type->list b))] - [(Value: '()) null] - [_ (int-err "bad value in type->list: ~a" t)])) - (define (tc/app/internal form expected) (kernel-syntax-case* form #f (values apply not list list* call-with-values do-make-object make-object cons @@ -621,7 +585,7 @@ [(Values: ts) ts] [_ (list t)])) (match prod-t - [(Function: (list (arr: (list) vals _ #f '() _ _))) + [(Function: (list (arr: (list) vals _ #f _ _))) (tc/funapp #'con #'prod (tc-expr #'con) (map ret (values-ty->list vals)) expected)] [_ (tc-error/expr #:return (ret (Un)) "First argument to call with values must be a function that can accept no arguments, got: ~a" @@ -657,23 +621,11 @@ [(tc-result: t thn-eff els-eff) (ret B (map var->type-eff els-eff) (map var->type-eff thn-eff))])] ;; special case for `apply' - [(#%plain-app apply f . args) (tc/apply #'f #'args)] - ;; special case for keywords - [(#%plain-app - (#%plain-app kpe kws num fn) - kw-list - (#%plain-app list . kw-arg-list) - . pos-args) - (eq? (syntax-e #'kpe) 'keyword-procedure-extract) - (match (tc-expr #'fn) - [(tc-result: (Function: arities)) - (tc-keywords form arities (type->list (tc-expr/t #'kws)) #'kw-arg-list #'pos-args expected)] - [t (tc-error/expr #:return (ret (Un)) - "Cannot apply expression of type ~a, since it is not a function type" t)])] + [(#%plain-app apply f . args) (tc/apply #'f #'args)] ;; even more special case for match [(#%plain-app (letrec-values ([(lp) (#%plain-lambda args . body)]) lp*) . actuals) (and expected (not (andmap type-annotation (syntax->list #'args))) (free-identifier=? #'lp #'lp*)) - (let-loop-check form #'lp #'actuals #'args #'body expected)] + (let-loop-check #'form #'lp #'actuals #'args #'body expected)] ;; or/andmap of ... argument [(#%plain-app or/andmap f arg) (and diff --git a/collects/typed-scheme/typecheck/tc-dots-unit.ss b/collects/typed-scheme/private/tc-dots-unit.ss similarity index 89% rename from collects/typed-scheme/typecheck/tc-dots-unit.ss rename to collects/typed-scheme/private/tc-dots-unit.ss index aa2c7c17b1..803ef905db 100644 --- a/collects/typed-scheme/typecheck/tc-dots-unit.ss +++ b/collects/typed-scheme/private/tc-dots-unit.ss @@ -1,11 +1,10 @@ #lang scheme/unit -(require (except-in "../utils/utils.ss" extend)) (require "signatures.ss" - (utils tc-utils) - (env type-environments) - (private type-utils) - (rep type-rep) + "tc-utils.ss" + "type-environments.ss" + "type-utils.ss" + "type-rep.ss" syntax/kerncase scheme/match) diff --git a/collects/typed-scheme/typecheck/tc-expr-unit.ss b/collects/typed-scheme/private/tc-expr-unit.ss similarity index 95% rename from collects/typed-scheme/typecheck/tc-expr-unit.ss rename to collects/typed-scheme/private/tc-expr-unit.ss index c61bbd3d9f..feb7129a36 100644 --- a/collects/typed-scheme/typecheck/tc-expr-unit.ss +++ b/collects/typed-scheme/private/tc-expr-unit.ss @@ -1,15 +1,21 @@ #lang scheme/unit -(require (rename-in "../utils/utils.ss" [private r:private])) (require syntax/kerncase scheme/match "signatures.ss" - (r:private type-utils type-effect-convenience union subtype parse-type type-annotation) - (rep type-rep effect-rep) - (utils tc-utils) - (env lexical-env) - (only-in (env type-environments) lookup current-tvars extend-env) + "type-utils.ss" + "utils.ss" ;; doesn't need tests + "type-rep.ss" ;; doesn't need tests + "type-effect-convenience.ss" ;; maybe needs tests + "union.ss" + "subtype.ss" ;; has tests + "parse-type.ss" ;; has tests + "tc-utils.ss" ;; doesn't need tests + "lexical-env.ss" ;; maybe needs tests + "type-annotation.ss" ;; has tests + "effect-rep.ss" + (only-in "type-environments.ss" lookup current-tvars extend-env) scheme/private/class-internal (only-in srfi/1 split-at)) @@ -35,7 +41,7 @@ [(null? v) (-val null)] [(symbol? v) (-val v)] [(string? v) -String] - [(keyword? v) (-val v)] + [(keyword? v) -Keyword] [(bytes? v) -Bytes] [(list? v) (-Tuple (map tc-literal v))] [(vector? v) (make-Vector (types-of-literals (vector->list v)))] @@ -95,8 +101,7 @@ ;; typecheck an expression, but throw away the effect ;; tc-expr/t : Expr -> Type (define (tc-expr/t e) (match (tc-expr e) - [(tc-result: t) t] - [t (int-err "tc-expr returned ~a, not a tc-result, for ~a" t (syntax->datum e))])) + [(tc-result: t) t])) (define (tc-expr/check/t e t) (match (tc-expr/check e t) diff --git a/collects/typed-scheme/typecheck/tc-if-unit.ss b/collects/typed-scheme/private/tc-if-unit.ss similarity index 95% rename from collects/typed-scheme/typecheck/tc-if-unit.ss rename to collects/typed-scheme/private/tc-if-unit.ss index e1d75c236c..f59b19fe60 100644 --- a/collects/typed-scheme/typecheck/tc-if-unit.ss +++ b/collects/typed-scheme/private/tc-if-unit.ss @@ -1,15 +1,20 @@ #lang scheme/unit -(require (rename-in "../utils/utils.ss" [infer r:infer])) -(require (utils planet-requires) +(require "planet-requires.ss" "signatures.ss" - (rep type-rep effect-rep) - (private type-effect-convenience subtype union type-utils type-comparison mutated-vars) - (env lexical-env) - (only-in (private remove-intersect) + "type-rep.ss" ;; doesn't need tests + "type-effect-convenience.ss" ;; maybe needs tests + "lexical-env.ss" ;; maybe needs tests + "effect-rep.ss" + "mutated-vars.ss" + "subtype.ss" + (only-in "remove-intersect.ss" [remove *remove]) - (r:infer infer) - (utils tc-utils) + "infer.ss" + "union.ss" + "type-utils.ss" + "tc-utils.ss" + "type-comparison.ss" syntax/kerncase mzlib/trace mzlib/plt-match) diff --git a/collects/typed-scheme/typecheck/tc-lambda-unit.ss b/collects/typed-scheme/private/tc-lambda-unit.ss similarity index 96% rename from collects/typed-scheme/typecheck/tc-lambda-unit.ss rename to collects/typed-scheme/private/tc-lambda-unit.ss index 962c480e05..d91531536e 100644 --- a/collects/typed-scheme/typecheck/tc-lambda-unit.ss +++ b/collects/typed-scheme/private/tc-lambda-unit.ss @@ -1,15 +1,20 @@ #lang scheme/unit -(require (rename-in "../utils/utils.ss" [infer r:infer] [extend r:extend])) (require "signatures.ss" mzlib/trace scheme/list - (except-in (rep type-rep effect-rep) make-arr) ;; doesn't need tests - (private type-effect-convenience type-annotation union type-utils) - (env type-environments lexical-env) - (utils tc-utils) + (except-in "type-rep.ss" make-arr) ;; doesn't need tests + "type-effect-convenience.ss" ;; maybe needs tests + "type-environments.ss" ;; doesn't need tests + "lexical-env.ss" ;; maybe needs tests + "type-annotation.ss" ;; has tests + (except-in "utils.ss" extend) + "type-utils.ss" + "effect-rep.ss" + "tc-utils.ss" + "union.ss" mzlib/plt-match - (only-in (private type-effect-convenience) [make-arr* make-arr])) + (only-in "type-effect-convenience.ss" [make-arr* make-arr])) (require (for-template scheme/base "internal-forms.ss")) (import tc-expr^) @@ -175,7 +180,7 @@ (let loop ([expected expected]) (match expected [(Mu: _ _) (loop (unfold expected))] - [(Function: (list (arr: argss rets rests drests '() _ _) ...)) + [(Function: (list (arr: argss rets rests drests _ _) ...)) (for ([args argss] [ret rets] [rest rests] [drest drests]) (tc/lambda-clause/check (car (syntax->list formals)) (car (syntax->list bodies)) args ret rest drest)) expected] diff --git a/collects/typed-scheme/typecheck/tc-let-unit.ss b/collects/typed-scheme/private/tc-let-unit.ss similarity index 96% rename from collects/typed-scheme/typecheck/tc-let-unit.ss rename to collects/typed-scheme/private/tc-let-unit.ss index 9bf2bf3fa7..eb29285264 100644 --- a/collects/typed-scheme/typecheck/tc-let-unit.ss +++ b/collects/typed-scheme/private/tc-let-unit.ss @@ -1,9 +1,14 @@ #lang scheme/unit -(require (rename-in "../utils/utils.ss" [infer r:infer])) (require "signatures.ss" - (private type-effect-convenience type-annotation parse-type type-utils) - (env lexical-env type-alias-env type-env) + "type-effect-convenience.ss" + "lexical-env.ss" + "type-annotation.ss" + "type-alias-env.ss" + "type-env.ss" + "parse-type.ss" + "utils.ss" + "type-utils.ss" syntax/free-vars mzlib/trace scheme/match diff --git a/collects/typed-scheme/typecheck/tc-structs.ss b/collects/typed-scheme/private/tc-structs.ss similarity index 95% rename from collects/typed-scheme/typecheck/tc-structs.ss rename to collects/typed-scheme/private/tc-structs.ss index 86233c0df2..23c8a43038 100644 --- a/collects/typed-scheme/typecheck/tc-structs.ss +++ b/collects/typed-scheme/private/tc-structs.ss @@ -1,12 +1,15 @@ #lang scheme/base -(require (except-in "../utils/utils.ss" extend)) -(require (rep type-rep) - (private type-effect-convenience - type-utils parse-type - union resolve-type) - (env type-env type-environments type-name-env) - (utils tc-utils) +(require "type-rep.ss" ;; doesn't need tests + "type-effect-convenience.ss" ;; maybe needs tests + "type-env.ss" ;; maybe needs tests + "type-utils.ss" + "parse-type.ss" ;; has tests + "type-environments.ss" ;; doesn't need tests + "type-name-env.ss" ;; maybe needs tests + "union.ss" + "tc-utils.ss" + "resolve-type.ss" "def-binding.ss" syntax/kerncase syntax/struct diff --git a/collects/typed-scheme/typecheck/tc-toplevel.ss b/collects/typed-scheme/private/tc-toplevel.ss similarity index 94% rename from collects/typed-scheme/typecheck/tc-toplevel.ss rename to collects/typed-scheme/private/tc-toplevel.ss index 5f2d36f25b..23b3614c57 100644 --- a/collects/typed-scheme/typecheck/tc-toplevel.ss +++ b/collects/typed-scheme/private/tc-toplevel.ss @@ -1,17 +1,26 @@ #lang scheme/unit -(require (rename-in "../utils/utils.ss" [infer r:infer])) (require syntax/kerncase mzlib/etc scheme/match "signatures.ss" "tc-structs.ss" - (private type-utils type-effect-convenience parse-type type-annotation mutated-vars type-contract) - (env type-env init-envs type-name-env type-alias-env) - (utils tc-utils) - "provide-handling.ss" + "type-utils.ss" + "utils.ss" ;; doesn't need tests + "type-effect-convenience.ss" ;; maybe needs tests + "internal-forms.ss" ;; doesn't need tests + "type-env.ss" ;; maybe needs tests + "parse-type.ss" ;; has tests + "tc-utils.ss" ;; doesn't need tests + "type-annotation.ss" ;; has tests + "type-name-env.ss" ;; maybe needs tests + "init-envs.ss" + "mutated-vars.ss" "def-binding.ss" + "provide-handling.ss" + "type-alias-env.ss" + "type-contract.ss" (for-template "internal-forms.ss" mzlib/contract diff --git a/collects/typed-scheme/utils/tc-utils.ss b/collects/typed-scheme/private/tc-utils.ss similarity index 97% rename from collects/typed-scheme/utils/tc-utils.ss rename to collects/typed-scheme/private/tc-utils.ss index 132b220612..69709e3e46 100644 --- a/collects/typed-scheme/utils/tc-utils.ss +++ b/collects/typed-scheme/private/tc-utils.ss @@ -70,12 +70,12 @@ (unless (null? stxs) (raise-typecheck-error (format "Summary: ~a errors encountered" (length stxs)) (apply append stxs))))])) -(define delay-errors? (make-parameter #f)) +(define delay-errors? (make-parameter #t)) (define (tc-error/delayed msg #:stx [stx* (current-orig-stx)] . rest) (let ([stx (locate-stx stx*)]) (unless (syntax? stx) - (int-err "erroneous syntax was not a syntax object: ~a ~a" stx (syntax->datum stx*))) + (error "syntax was not syntax" stx (syntax->datum stx*))) (if (delay-errors?) (set! delayed-errors (cons (make-err (apply format msg rest) (list stx)) delayed-errors)) (raise-typecheck-error (apply format msg rest) (list stx))))) diff --git a/collects/typed-scheme/env/type-alias-env.ss b/collects/typed-scheme/private/type-alias-env.ss similarity index 96% rename from collects/typed-scheme/env/type-alias-env.ss rename to collects/typed-scheme/private/type-alias-env.ss index dd9183d32c..0be4da74a5 100644 --- a/collects/typed-scheme/env/type-alias-env.ss +++ b/collects/typed-scheme/private/type-alias-env.ss @@ -1,8 +1,7 @@ #lang scheme/base -(require (except-in "../utils/utils.ss" extend)) (require syntax/boundmap - (utils tc-utils) + "tc-utils.ss" mzlib/trace scheme/match) diff --git a/collects/typed-scheme/private/type-annotation.ss b/collects/typed-scheme/private/type-annotation.ss index bbb8303412..1a72e73bdd 100644 --- a/collects/typed-scheme/private/type-annotation.ss +++ b/collects/typed-scheme/private/type-annotation.ss @@ -1,11 +1,7 @@ #lang scheme/base -(require (except-in "../utils/utils.ss" extend)) -(require (rep type-rep) - (utils tc-utils) - (env type-env) - "parse-type.ss" "subtype.ss" - "type-effect-convenience.ss" "resolve-type.ss" "union.ss" +(require "type-rep.ss" "parse-type.ss" "tc-utils.ss" "subtype.ss" "utils.ss" + "type-env.ss" "type-effect-convenience.ss" "resolve-type.ss" "union.ss" scheme/match mzlib/trace) (provide type-annotation get-type diff --git a/collects/typed-scheme/private/type-comparison.ss b/collects/typed-scheme/private/type-comparison.ss index dbc70e5f46..dab6743a78 100644 --- a/collects/typed-scheme/private/type-comparison.ss +++ b/collects/typed-scheme/private/type-comparison.ss @@ -1,4 +1,3 @@ #lang scheme/base -(require "../utils/utils.ss") -(require (rep type-rep) "type-utils.ss") +(require "type-rep.ss" "type-utils.ss") (provide type-equal? tc-result-equal? typecontract define/fixup-contract? generate-contract-def change-contract-fixups) -(require (except-in "../utils/utils.ss" extend)) (require - (rep type-rep) - (typecheck internal-forms) - (utils tc-utils) - (env type-name-env) + "type-rep.ss" "parse-type.ss" + "utils.ss" + "type-name-env.ss" "require-contract.ss" + "internal-forms.ss" + "tc-utils.ss" "resolve-type.ss" "type-utils.ss" (only-in "type-effect-convenience.ss" Any-Syntax) @@ -80,13 +80,13 @@ (define (f a) (define-values (dom* rngs* rst) (match a - [(arr: dom (Values: rngs) #f #f '() _ _) + [(arr: dom (Values: rngs) #f #f _ _) (values (map t->c dom) (map t->c rngs) #f)] - [(arr: dom rng #f #f '() _ _) + [(arr: dom rng #f #f _ _) (values (map t->c dom) (list (t->c rng)) #f)] - [(arr: dom (Values: rngs) rst #f '() _ _) + [(arr: dom (Values: rngs) rst #f _ _) (values (map t->c dom) (map t->c rngs) (t->c rst))] - [(arr: dom rng rst #f '() _ _) + [(arr: dom rng rst #f _ _) (values (map t->c dom) (list (t->c rng)) (t->c rst))])) (with-syntax ([(dom* ...) dom*] diff --git a/collects/typed-scheme/private/type-effect-convenience.ss b/collects/typed-scheme/private/type-effect-convenience.ss index 13aa199c91..9ae26d5479 100644 --- a/collects/typed-scheme/private/type-effect-convenience.ss +++ b/collects/typed-scheme/private/type-effect-convenience.ss @@ -1,16 +1,14 @@ #lang scheme/base -(require "../utils/utils.ss") - -(require (rep type-rep effect-rep) - (utils tc-utils) +(require "type-rep.ss" + "effect-rep.ss" scheme/match "type-comparison.ss" "type-effect-printer.ss" "union.ss" "subtype.ss" "type-utils.ss" + "tc-utils.ss" scheme/promise - (for-syntax macro-debugger/stxclass/stxclass) (for-syntax scheme/base)) (provide (all-defined-out)) @@ -35,7 +33,7 @@ [(Latent-Remove-Effect: t) (make-Remove-Effect t v)] [(True-Effect:) eff] [(False-Effect:) eff] - [_ (int-err "can't add var ~a to effect ~a" v eff)])) + [_ (error 'internal-tc-error "can't add var to effect ~a" eff)])) (define-syntax (-> stx) (syntax-case* stx (:) (lambda (a b) (eq? (syntax-e a) (syntax-e b))) @@ -80,26 +78,11 @@ [(Function: as) as])) (make-Function (map car (map funty-arities args)))) -(define-syntax (->key stx) - (syntax-parse stx - [(_ ty:expr ... ((k:keyword kty:expr opt:boolean)) ...* rng) - #'(make-Function - (list - (make-arr* (list ty ...) - rng - #f - #f - (list (make-Keyword 'k kty opt) ...) - null - null)))])) - (define make-arr* - (case-lambda [(dom rng) (make-arr dom rng #f #f null (list) (list))] - [(dom rng rest) (make-arr dom rng rest #f null (list) (list))] - [(dom rng rest eff1 eff2) (make-arr dom rng rest #f null eff1 eff2)] - [(dom rng rest drest eff1 eff2) (make-arr dom rng rest drest null eff1 eff2)] - [(dom rng rest drest kws eff1 eff2) - (make-arr dom rng rest drest (sort #:key Keyword-kw kws keywordlist #'(kw ...))) + (syntax/loc stx (tc rec-id (lambda (e) (sub-eff rec-id e)) ty [kw pats ... es] ...))] [(tc rec-id e-rec-id ty clauses ...) (begin (map add-clause (syntax->list #'(clauses ...))) @@ -314,7 +296,7 @@ ;; necessary to avoid infinite loops [#:Union elems (*Union (remove-dups (sort (map sb elems) typelist #'(id ...))) - (with-syntax ([(id* ...) - (map (lambda (id) - (datum->syntax - id - (string->symbol - (string-append - "typed-scheme/" - #,(symbol->string (syntax-e #'nm)) - "/" - (symbol->string (syntax-e id)))) - id id)) - (syntax->list #'(id ...)))]) - (syntax/loc stx (combine-in id* ...)))]))))])) - - -(define-requirer rep) -(define-requirer infer) -(define-requirer typecheck) -(define-requirer utils) -(define-requirer env) -(define-requirer private) + in-syntax) (define-sequence-syntax in-syntax (lambda () #'syntax->list) diff --git a/collects/typed-scheme/typed-scheme.ss b/collects/typed-scheme/typed-scheme.ss index 0bcfc701b0..19c9c9cb7d 100644 --- a/collects/typed-scheme/typed-scheme.ss +++ b/collects/typed-scheme/typed-scheme.ss @@ -1,18 +1,22 @@ #lang scheme/base -(require (rename-in "utils/utils.ss" [infer r:infer])) - -(require (private base-env base-types) +(require "private/base-env.ss" + "private/base-types.ss" (for-syntax scheme/base - (private type-utils type-contract type-effect-convenience) - (typecheck typechecker provide-handling) - (env type-environments type-name-env type-alias-env) - (r:infer infer) - (utils tc-utils) - (rep type-rep) - (except-in (utils utils) infer extend) - (only-in (r:infer infer-dummy) infer-param) + "private/type-utils.ss" + "private/typechecker.ss" + "private/type-rep.ss" + "private/provide-handling.ss" + "private/type-environments.ss" + "private/tc-utils.ss" + "private/type-name-env.ss" + "private/type-alias-env.ss" + (except-in "private/utils.ss" extend) + (only-in "private/infer-dummy.ss" infer-param) + "private/infer.ss" + "private/type-effect-convenience.ss" + "private/type-contract.ss" scheme/nest syntax/kerncase scheme/match)) @@ -27,7 +31,7 @@ (provide (rename-out [module-begin #%module-begin] [top-interaction #%top-interaction] [#%plain-lambda lambda] - [#%app #%app] + [#%plain-app #%app] [require require])) (define-for-syntax catch-errors? #f) From 8017a74bffda477621b09802306ad43ebb8c54bf Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Thu, 11 Sep 2008 22:25:49 +0000 Subject: [PATCH 16/88] svn merge -r11641:11640 . Okay, that was the last (first?) trunk merge, so now I'll merge trunk "appropriately". svn: r11656 --- collects/repos-time-stamp/stamp.ss | 2 +- collects/tests/stepper/run-nightly-tests.ss | 5 +++++ src/worksp/mred/mred.manifest | 2 +- src/worksp/mred/mred.rc | 8 ++++---- src/worksp/mzcom/mzcom.rc | 8 ++++---- src/worksp/mzcom/mzobj.rgs | 6 +++--- src/worksp/mzscheme/mzscheme.rc | 8 ++++---- src/worksp/starters/start.rc | 8 ++++---- 8 files changed, 26 insertions(+), 21 deletions(-) create mode 100644 collects/tests/stepper/run-nightly-tests.ss diff --git a/collects/repos-time-stamp/stamp.ss b/collects/repos-time-stamp/stamp.ss index c9d8b64812..c1afd89f4a 100644 --- a/collects/repos-time-stamp/stamp.ss +++ b/collects/repos-time-stamp/stamp.ss @@ -1 +1 @@ -#lang scheme/base (provide stamp) (define stamp "11sep2008") +#lang scheme/base (provide stamp) (define stamp "10sep2008") diff --git a/collects/tests/stepper/run-nightly-tests.ss b/collects/tests/stepper/run-nightly-tests.ss new file mode 100644 index 0000000000..468cd45296 --- /dev/null +++ b/collects/tests/stepper/run-nightly-tests.ss @@ -0,0 +1,5 @@ +(module run-nightly-tests mzscheme + (require "through-tests.ss") + + (parameterize ([display-only-errors #t]) + (run-all-tests-except '(prims qq-splice time set! local-set! lazy1 lazy2 lazy3)))) \ No newline at end of file diff --git a/src/worksp/mred/mred.manifest b/src/worksp/mred/mred.manifest index 671bf1859d..7e029962c4 100644 --- a/src/worksp/mred/mred.manifest +++ b/src/worksp/mred/mred.manifest @@ -1,7 +1,7 @@ Date: Thu, 11 Sep 2008 22:43:19 +0000 Subject: [PATCH 17/88] Add identifier checking and contract verification where appropriate. svn: r11658 --- collects/scheme/private/contract.ss | 31 +++++++++++++++-------------- 1 file changed, 16 insertions(+), 15 deletions(-) diff --git a/collects/scheme/private/contract.ss b/collects/scheme/private/contract.ss index 5702043f1a..894bab994f 100644 --- a/collects/scheme/private/contract.ss +++ b/collects/scheme/private/contract.ss @@ -34,6 +34,19 @@ improve method arity mismatch contract violation error messages? (for-syntax (prefix-in a: "contract-helpers.ss"))) +;; These are useful for all below. + +(define-syntax (verify-contract stx) + (syntax-case stx () + [(_ x) (a:known-good-contract? #'x) #'x] + [(_ x) #'(verify-contract/proc x)])) + +(define (verify-contract/proc x) + (unless (or (contract? x) + (and (procedure? x) + (procedure-arity-includes? x 1))) + (error 'provide/contract "expected a contract or a procedure of arity one, got ~e" x)) + x) ; ; @@ -60,7 +73,7 @@ improve method arity mismatch contract violation error messages? [(_ name contract-expr expr0 expr ...) (identifier? (syntax name)) #'(with-contract name - ([name contract-expr]) + ([name (verify-contract contract-expr)]) (define name expr0 expr ...))] [(_ name+arg-list contract body0 body ...) (let-values ([(name lam-expr) @@ -141,6 +154,7 @@ improve method arity mismatch contract violation error messages? [(let ([lst (syntax->list (car args))]) (and (list? lst) (= (length lst) 2) + (identifier? (first lst)) lst)) => (lambda (l) @@ -175,7 +189,7 @@ improve method arity mismatch contract violation error messages? (begin-with-definitions body0 body ... (values unprotected-id ... protected-id ...)))) - (define contract-id contract-expr) ... + (define contract-id (verify-contract contract-expr)) ... (define-syntax protected-id (make-with-contract-transformer (quote-syntax contract-id) @@ -766,19 +780,6 @@ improve method arity mismatch contract violation error messages? (begin bodies ...))))])) -(define-syntax (verify-contract stx) - (syntax-case stx () - [(_ x) (a:known-good-contract? #'x) #'x] - [(_ x) #'(verify-contract/proc x)])) - -(define (verify-contract/proc x) - (unless (or (contract? x) - (and (procedure? x) - (procedure-arity-includes? x 1))) - (error 'provide/contract "expected a contract or a procedure of arity one, got ~e" x)) - x) - - (define (make-pc-struct-type struct-name struct:struct-name . ctcs) (let-values ([(struct:struct-name _make _pred _get _set) (make-struct-type struct-name From e1f430df720b6cf104c15501b1c7fdb85335ead3 Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Thu, 11 Sep 2008 22:58:25 +0000 Subject: [PATCH 18/88] We should use the name of the form in generating the error. svn: r11659 --- collects/scheme/private/contract.ss | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/collects/scheme/private/contract.ss b/collects/scheme/private/contract.ss index 894bab994f..7858c19569 100644 --- a/collects/scheme/private/contract.ss +++ b/collects/scheme/private/contract.ss @@ -38,14 +38,14 @@ improve method arity mismatch contract violation error messages? (define-syntax (verify-contract stx) (syntax-case stx () - [(_ x) (a:known-good-contract? #'x) #'x] - [(_ x) #'(verify-contract/proc x)])) + [(_ name x) (a:known-good-contract? #'x) #'x] + [(_ name x) #'(verify-contract/proc name x)])) -(define (verify-contract/proc x) +(define (verify-contract/proc name x) (unless (or (contract? x) (and (procedure? x) (procedure-arity-includes? x 1))) - (error 'provide/contract "expected a contract or a procedure of arity one, got ~e" x)) + (error name "expected a contract or a procedure of arity one, got ~e" x)) x) ; @@ -73,7 +73,7 @@ improve method arity mismatch contract violation error messages? [(_ name contract-expr expr0 expr ...) (identifier? (syntax name)) #'(with-contract name - ([name (verify-contract contract-expr)]) + ([name (verify-contract 'define/contract contract-expr)]) (define name expr0 expr ...))] [(_ name+arg-list contract body0 body ...) (let-values ([(name lam-expr) @@ -189,7 +189,7 @@ improve method arity mismatch contract violation error messages? (begin-with-definitions body0 body ... (values unprotected-id ... protected-id ...)))) - (define contract-id (verify-contract contract-expr)) ... + (define contract-id (verify-contract 'with-contract contract-expr)) ... (define-syntax protected-id (make-with-contract-transformer (quote-syntax contract-id) @@ -572,7 +572,7 @@ improve method arity mismatch contract violation error messages? #f (with-syntax ([field-contract-id field-contract-id] [field-contract field-contract]) - #'(define field-contract-id (verify-contract field-contract))))) + #'(define field-contract-id (verify-contract 'provide/contract field-contract))))) field-contract-ids field-contracts))] [(field-contracts ...) field-contracts] @@ -760,7 +760,7 @@ improve method arity mismatch contract violation error messages? #,@(if no-need-to-check-ctrct? (list) - (list #'(define contract-id (verify-contract ctrct)))) + (list #'(define contract-id (verify-contract 'provide/contract ctrct)))) (define-syntax id-rename (make-provide/contract-transformer (quote-syntax contract-id) (quote-syntax id) From f4dd7e85febef70f759848d35a0f526c9fd9a969 Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Thu, 11 Sep 2008 23:11:38 +0000 Subject: [PATCH 19/88] We should make sure the error here at least has define/contract in it (even if it's the wrong shape due to leaving the contract out in the call), and we _should_ check to see if we're in a expression context. (Can't remember what reasoning Ryan had about not doing this, but it seems to me that we still need to check, since this expands into defines of various sorts.) svn: r11660 --- collects/scheme/private/contract.ss | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/collects/scheme/private/contract.ss b/collects/scheme/private/contract.ss index 7858c19569..ea6b12c0d1 100644 --- a/collects/scheme/private/contract.ss +++ b/collects/scheme/private/contract.ss @@ -77,8 +77,8 @@ improve method arity mismatch contract violation error messages? (define name expr0 expr ...))] [(_ name+arg-list contract body0 body ...) (let-values ([(name lam-expr) - (normalize-definition (datum->syntax #'stx (list* 'define #'name+arg-list #'body0 #'(body ...))) - #'lambda #f #t)]) + (normalize-definition (datum->syntax #'define-stx (list* 'define/contract #'name+arg-list #'body0 #'(body ...))) + #'lambda #t #t)]) #`(define/contract #,name contract #,lam-expr))] [(_ name contract-expr expr) (raise-syntax-error 'define/contract "expected identifier in first position" From cc6d39e2171a76557a991970265b5ba37c1d7974 Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Thu, 11 Sep 2008 23:19:34 +0000 Subject: [PATCH 20/88] More error reporting. svn: r11661 --- collects/scheme/private/contract.ss | 14 +++++++++++++- 1 file changed, 13 insertions(+), 1 deletion(-) diff --git a/collects/scheme/private/contract.ss b/collects/scheme/private/contract.ss index ea6b12c0d1..fb90087946 100644 --- a/collects/scheme/private/contract.ss +++ b/collects/scheme/private/contract.ss @@ -194,7 +194,19 @@ improve method arity mismatch contract violation error messages? (make-with-contract-transformer (quote-syntax contract-id) (quote-syntax id) - (quote-syntax (quote blame)))) ...))))]))) + (quote-syntax (quote blame)))) ...))))] + [(_ blame (arg ...) body0 body ...) + (raise-syntax-error 'with-contract + "expected identifier" + #'blame)] + [(_ blame (arg ...)) + (raise-syntax-error 'with-contract + "empty body" + stx)] + [(_ blame bad-args body0 body ...) + (raise-syntax-error 'with-contract + "expected list of identifier and/or (identifier contract)" + #'bad-args)]))) ; ; From 68aa941b877c5f28ec05667e5f8e3462256a08d9 Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Thu, 11 Sep 2008 23:25:43 +0000 Subject: [PATCH 21/88] Since we allow non-identifiers here now (as long as they'd be appropriate name + argument lists a la define), this case will never fire. svn: r11662 --- collects/scheme/private/contract.ss | 6 +----- 1 file changed, 1 insertion(+), 5 deletions(-) diff --git a/collects/scheme/private/contract.ss b/collects/scheme/private/contract.ss index fb90087946..63b4a932f4 100644 --- a/collects/scheme/private/contract.ss +++ b/collects/scheme/private/contract.ss @@ -79,11 +79,7 @@ improve method arity mismatch contract violation error messages? (let-values ([(name lam-expr) (normalize-definition (datum->syntax #'define-stx (list* 'define/contract #'name+arg-list #'body0 #'(body ...))) #'lambda #t #t)]) - #`(define/contract #,name contract #,lam-expr))] - [(_ name contract-expr expr) - (raise-syntax-error 'define/contract "expected identifier in first position" - define-stx - (syntax name))])) + #`(define/contract #,name contract #,lam-expr))])) From d3a5ab555671521a1bf63cdc8036ee1a79d9dfcd Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Thu, 11 Sep 2008 23:47:29 +0000 Subject: [PATCH 22/88] Fix one test (now the top-level gets the blame appropriately) and remove a bogus test (since a defined function can call itself all it wants without the contract being checked, and thus that test is now an infinite loop). svn: r11663 --- collects/tests/mzscheme/contract-mzlib-test.ss | 11 +++-------- 1 file changed, 3 insertions(+), 8 deletions(-) diff --git a/collects/tests/mzscheme/contract-mzlib-test.ss b/collects/tests/mzscheme/contract-mzlib-test.ss index c32dc4c0af..30884567d7 100644 --- a/collects/tests/mzscheme/contract-mzlib-test.ss +++ b/collects/tests/mzscheme/contract-mzlib-test.ss @@ -1,3 +1,5 @@ + +#lang scheme/load #| This file started out as a copy of contract-test.ss. @@ -1591,14 +1593,7 @@ of the contract library does not change over time. '(let () (define/contract i (-> integer? integer?) (lambda (x) 1)) (i #f)) - "<>") - - (test/spec-failed - 'define/contract5 - '(let () - (define/contract i (-> integer? integer?) (lambda (x) (i #t))) - (i 1)) - "<>") + "top-level") (test/spec-passed 'define/contract6 From b783ac9b70b80e056bcb0c44120734ae02038f70 Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Thu, 11 Sep 2008 23:53:23 +0000 Subject: [PATCH 23/88] Use the new function syntax for define/contract in a couple of tests. svn: r11664 --- 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 30884567d7..44b73aed4f 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 32d4b3463007fbc097b06e79eebc50906c6b3582 Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Fri, 12 Sep 2008 00:02:46 +0000 Subject: [PATCH 24/88] Check nested and non-nested define/contracts and how they interact. svn: r11665 --- .../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 44b73aed4f..7c3bac1ffd 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 d9c47de816d3cff6ad3cea0cbeac309506007c70 Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Fri, 12 Sep 2008 00:21:38 +0000 Subject: [PATCH 25/88] Write some with-contract tests. svn: r11666 --- .../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 7c3bac1ffd..f8cf5dbd8d 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 65e13861bb88209e9445d15f6a2fc9b9beab9345 Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Fri, 12 Sep 2008 03:42:36 +0000 Subject: [PATCH 26/88] Accidentally committed this in r11663. svn: r11669 --- 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 f8cf5dbd8d..c675095350 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 d03ce01a5a9dfb9a736d65865fd04a198785526e Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Fri, 12 Sep 2008 03:49:20 +0000 Subject: [PATCH 27/88] 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 --- .../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 c675095350..f005a34eb5 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 33d3cb7cd0c7c59c44f443fe9590bd284194fa32 Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Fri, 12 Sep 2008 14:51:26 +0000 Subject: [PATCH 28/88] Have provide/contract-transformers appropriately check to see whether we are within a with-contract scope. Not quite sure if this code is 100% correct (in terms of being written apprropiately), but it does the job for now. svn: r11676 --- collects/scheme/private/contract.ss | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/collects/scheme/private/contract.ss b/collects/scheme/private/contract.ss index 63b4a932f4..743ff5fff8 100644 --- a/collects/scheme/private/contract.ss +++ b/collects/scheme/private/contract.ss @@ -265,7 +265,8 @@ improve method arity mismatch contract violation error messages? #`(-contract contract-id id pos-module-source - (module-source-as-symbol #'name) + (or '#,(syntax-parameter-value #'current-contract-region) + (module-source-as-symbol #'name)) #,(id->contract-src-info #'id))))))]) (when key (hash-set! saved-id-table key lifted-id)) From a44810f4f52af97713803b4f1ecc57fae3487134 Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Fri, 12 Sep 2008 15:19:29 +0000 Subject: [PATCH 29/88] More error checking, shouldn't have allowed (define/contract x number? 1 2), for example. svn: r11680 --- collects/scheme/private/contract.ss | 13 +++++++++++-- 1 file changed, 11 insertions(+), 2 deletions(-) diff --git a/collects/scheme/private/contract.ss b/collects/scheme/private/contract.ss index 743ff5fff8..c9e9031d42 100644 --- a/collects/scheme/private/contract.ss +++ b/collects/scheme/private/contract.ss @@ -70,11 +70,20 @@ improve method arity mismatch contract violation error messages? ;; 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 expr0 expr ...) + [(_ name contract-expr) + (raise-syntax-error 'define/contract + "no body after contract" + define-stx)] + [(_ name contract-expr expr) (identifier? (syntax name)) #'(with-contract name ([name (verify-contract 'define/contract contract-expr)]) - (define name expr0 expr ...))] + (define name expr))] + [(_ name contract-expr expr0 expr ...) + (identifier? (syntax name)) + (raise-syntax-error 'define/contract + "multiple expressions after identifier and contract" + define-stx)] [(_ name+arg-list contract body0 body ...) (let-values ([(name lam-expr) (normalize-definition (datum->syntax #'define-stx (list* 'define/contract #'name+arg-list #'body0 #'(body ...))) From c32c61ab74d8acd5d612a102b039b498a99dfd6b Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Fri, 12 Sep 2008 15:20:02 +0000 Subject: [PATCH 30/88] Initial work on documenting the new form and changing the documentation for define/contract appropriately. svn: r11681 --- .../scribblings/reference/contracts.scrbl | 38 +++++++++++++------ 1 file changed, 26 insertions(+), 12 deletions(-) diff --git a/collects/scribblings/reference/contracts.scrbl b/collects/scribblings/reference/contracts.scrbl index 347acf7549..ac8e811089 100644 --- a/collects/scribblings/reference/contracts.scrbl +++ b/collects/scribblings/reference/contracts.scrbl @@ -641,23 +641,37 @@ contract on the fields that the sub-struct shares with its parent are only used in the contract for the sub-struct's maker, and the selector or mutators for the super-struct are not provided.} -@defform[(define/contract id contract-expr init-value-expr)]{ +@defform/subs[ +(with-contract blame-id (wc-exports) body ...+) +([wc-exports + id + (id contract-expr)])]{ +Generates a local contract boundary. The @scheme[contract-expr] +form cannot appear in expression position. The @scheme[body] of the +form allows definition/expression interleaving like a @scheme[module] +body. Names bound within the @scheme[body] must be exported to be +accessible from outside the @scheme[with-contract] form. Such +@scheme[id]s can either be paired with a @scheme[contract-expr] or +exported without a contract. -Attaches the contract @scheme[contract-expr] to -@scheme[init-value-expr] and binds that to @scheme[id]. +The @scheme[blame-id] is used for the positive positions of +contracts paired with exported @scheme[id]s. Contracts broken +within the @scheme[with-contract] @scheme[body] will use the +@scheme[blame-id] for their negative position. + +@defform*[(define/contract id contract-expr init-value-expr) + (define/contract (head args) contract-expr body ...+]{ + +Works like @scheme[define], except that the contract +@scheme[contract-expr] is attached to the bound value. The @scheme[define/contract] form treats individual definitions as units of blame. The definition itself is responsible for positive (co-variant) positions of the contract and each reference to -@scheme[id] (including those in the initial value expression) must -meet the negative positions of the contract. - -Error messages with @scheme[define/contract] are not as clear as those -provided by @scheme[provide/contract], because -@scheme[define/contract] cannot detect the name of the definition -where the reference to the defined variable occurs. Instead, it uses -the source location of the reference to the variable as the name of -that definition.} +@scheme[id] outside of the definition must meet the negative positions +of the contract. It is equivalent to wrapping a single @scheme[define] +with a @scheme[with-contract] form that pairs the @scheme[contract-expr] +with the bound identifier.} @defform*[[(contract contract-expr to-protect-expr positive-blame-expr negative-blame-expr) From f191636cc71c051702678777fb14dca21364886f Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Fri, 12 Sep 2008 16:20:38 +0000 Subject: [PATCH 31/88] Use the same info here as the provide/contract -contract uses do. svn: r11685 --- collects/scheme/private/contract.ss | 24 ++++++++++++------------ 1 file changed, 12 insertions(+), 12 deletions(-) diff --git a/collects/scheme/private/contract.ss b/collects/scheme/private/contract.ss index c9e9031d42..9c27a916da 100644 --- a/collects/scheme/private/contract.ss +++ b/collects/scheme/private/contract.ss @@ -48,6 +48,16 @@ improve method arity mismatch contract violation error messages? (error name "expected a contract or a procedure of arity one, got ~e" x)) x) +;; id->contract-src-info : identifier -> syntax +;; constructs the last argument to the -contract, given an identifier +(define-for-syntax (id->contract-src-info id) + #`(list (make-srcloc #,id + #,(syntax-line id) + #,(syntax-column id) + #,(syntax-position id) + #,(syntax-span id)) + #,(format "~s" (syntax->datum id)))) + ; ; ; @@ -132,7 +142,7 @@ improve method arity mismatch contract violation error messages? id pos-blame-id 'neg-blame-id - (quote-syntax f)) + (quote-syntax #,(id->contract-src-info #'f))) arg ...))] [ident (identifier? (syntax ident)) @@ -141,7 +151,7 @@ improve method arity mismatch contract violation error messages? id pos-blame-id 'neg-blame-id - (quote-syntax ident)))]))))) + (quote-syntax #,(id->contract-src-info #'ident))))]))))) (define-for-syntax (check-and-split-with-contract-args args) (let loop ([args args] @@ -244,16 +254,6 @@ improve method arity mismatch contract violation error messages? provide-stx id))))) -;; id->contract-src-info : identifier -> syntax -;; constructs the last argument to the -contract, given an identifier -(define-for-syntax (id->contract-src-info id) - #`(list (make-srcloc #,id - #,(syntax-line id) - #,(syntax-column id) - #,(syntax-position id) - #,(syntax-span id)) - #,(format "~s" (syntax->datum id)))) - (define-for-syntax (make-provide/contract-transformer contract-id id pos-module-source) (make-set!-transformer (let ([saved-id-table (make-hasheq)]) From eb919c78d19bc43700789041639ea353afea3016 Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Fri, 12 Sep 2008 16:26:09 +0000 Subject: [PATCH 32/88] Doc fixes. svn: r11686 --- collects/scribblings/reference/contracts.scrbl | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/collects/scribblings/reference/contracts.scrbl b/collects/scribblings/reference/contracts.scrbl index ac8e811089..a1dabbb252 100644 --- a/collects/scribblings/reference/contracts.scrbl +++ b/collects/scribblings/reference/contracts.scrbl @@ -657,10 +657,10 @@ exported without a contract. The @scheme[blame-id] is used for the positive positions of contracts paired with exported @scheme[id]s. Contracts broken within the @scheme[with-contract] @scheme[body] will use the -@scheme[blame-id] for their negative position. +@scheme[blame-id] for their negative position.} -@defform*[(define/contract id contract-expr init-value-expr) - (define/contract (head args) contract-expr body ...+]{ +@defform*[[(define/contract id contract-expr init-value-expr) + (define/contract (head args) contract-expr body ...+)]]{ Works like @scheme[define], except that the contract @scheme[contract-expr] is attached to the bound value. From e2c770ab452299a05a09c3be56c50a39cfe8ffac Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Fri, 12 Sep 2008 16:39:11 +0000 Subject: [PATCH 33/88] So we _can_ do this, but since provides/requires are between modules, and thus it's the enclosing module that made the contract here, we should blame it for the misuse, not the contract boundary in which the call was made (though further thought should be put towards this). svn: r11687 --- collects/scheme/private/contract.ss | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/collects/scheme/private/contract.ss b/collects/scheme/private/contract.ss index 9c27a916da..61f804f9d6 100644 --- a/collects/scheme/private/contract.ss +++ b/collects/scheme/private/contract.ss @@ -274,8 +274,7 @@ improve method arity mismatch contract violation error messages? #`(-contract contract-id id pos-module-source - (or '#,(syntax-parameter-value #'current-contract-region) - (module-source-as-symbol #'name)) + (module-source-as-symbol #'name) #,(id->contract-src-info #'id))))))]) (when key (hash-set! saved-id-table key lifted-id)) From ea206c7b3d8226761ab8a276d05f7b60ab41288b Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Fri, 12 Sep 2008 16:48:33 +0000 Subject: [PATCH 34/88] Go back to the old style. svn: r11688 --- collects/scheme/private/contract.ss | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/collects/scheme/private/contract.ss b/collects/scheme/private/contract.ss index 61f804f9d6..24c9653e9b 100644 --- a/collects/scheme/private/contract.ss +++ b/collects/scheme/private/contract.ss @@ -142,7 +142,7 @@ improve method arity mismatch contract violation error messages? id pos-blame-id 'neg-blame-id - (quote-syntax #,(id->contract-src-info #'f))) + (quote-syntax f)) arg ...))] [ident (identifier? (syntax ident)) @@ -151,7 +151,7 @@ improve method arity mismatch contract violation error messages? id pos-blame-id 'neg-blame-id - (quote-syntax #,(id->contract-src-info #'ident))))]))))) + (quote-syntax ident)))]))))) (define-for-syntax (check-and-split-with-contract-args args) (let loop ([args args] From e53d5c43ffe99c808866571a0c10d07e313e0d61 Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Fri, 12 Sep 2008 16:59:00 +0000 Subject: [PATCH 35/88] Just indention. svn: r11689 --- collects/scheme/private/contract.ss | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/collects/scheme/private/contract.ss b/collects/scheme/private/contract.ss index 24c9653e9b..d052110e06 100644 --- a/collects/scheme/private/contract.ss +++ b/collects/scheme/private/contract.ss @@ -96,9 +96,11 @@ improve method arity mismatch contract violation error messages? define-stx)] [(_ name+arg-list contract body0 body ...) (let-values ([(name lam-expr) - (normalize-definition (datum->syntax #'define-stx (list* 'define/contract #'name+arg-list #'body0 #'(body ...))) - #'lambda #t #t)]) - #`(define/contract #,name contract #,lam-expr))])) + (normalize-definition + (datum->syntax #'define-stx (list* 'define/contract #'name+arg-list + #'body0 #'(body ...))) + #'lambda #t #t)]) + #`(define/contract #,name contract #,lam-expr))])) From ac576f50852c50e9c8ef521f3425154582778310 Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Fri, 12 Sep 2008 17:09:42 +0000 Subject: [PATCH 36/88] There's nothing quasi about the body, so just go with regular syntax (and change the quote-syntax uses to just #') svn: r11690 --- collects/scheme/private/contract.ss | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/collects/scheme/private/contract.ss b/collects/scheme/private/contract.ss index d052110e06..92022d436a 100644 --- a/collects/scheme/private/contract.ss +++ b/collects/scheme/private/contract.ss @@ -139,21 +139,21 @@ improve method arity mismatch contract violation error messages? stx (syntax id))] [(f arg ...) - (quasisyntax/loc stx + (syntax/loc stx ((-contract contract-id id pos-blame-id 'neg-blame-id - (quote-syntax f)) + #'f) arg ...))] [ident (identifier? (syntax ident)) - (quasisyntax/loc stx + (syntax/loc stx (-contract contract-id id pos-blame-id 'neg-blame-id - (quote-syntax ident)))]))))) + #'ident))]))))) (define-for-syntax (check-and-split-with-contract-args args) (let loop ([args args] From 3b44bca1d54db77fc0b5cadb082048a7a97e06d8 Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Fri, 12 Sep 2008 18:13:20 +0000 Subject: [PATCH 37/88] Remove the introducer, which isn't being used anyway. svn: r11692 --- collects/scheme/private/contract.ss | 35 ++++++++++++++--------------- 1 file changed, 17 insertions(+), 18 deletions(-) diff --git a/collects/scheme/private/contract.ss b/collects/scheme/private/contract.ss index 92022d436a..825cae14d1 100644 --- a/collects/scheme/private/contract.ss +++ b/collects/scheme/private/contract.ss @@ -185,12 +185,11 @@ improve method arity mismatch contract violation error messages? (car args))]))) (define-syntax (with-contract stx) - (let ([introducer (make-syntax-introducer)]) - (syntax-case stx () - [(_ blame (arg ...) body0 body ...) - (identifier? (syntax blame)) - (let-values ([(unprotected protected protections) - (check-and-split-with-contract-args (syntax->list #'(arg ...)))]) + (syntax-case stx () + [(_ blame (arg ...) body0 body ...) + (identifier? (syntax blame)) + (let-values ([(unprotected protected protections) + (check-and-split-with-contract-args (syntax->list #'(arg ...)))]) (with-syntax ([((protected-id id contract-id) ...) (map (lambda (n) (list n @@ -212,18 +211,18 @@ improve method arity mismatch contract violation error messages? (quote-syntax contract-id) (quote-syntax id) (quote-syntax (quote blame)))) ...))))] - [(_ blame (arg ...) body0 body ...) - (raise-syntax-error 'with-contract - "expected identifier" - #'blame)] - [(_ blame (arg ...)) - (raise-syntax-error 'with-contract - "empty body" - stx)] - [(_ blame bad-args body0 body ...) - (raise-syntax-error 'with-contract - "expected list of identifier and/or (identifier contract)" - #'bad-args)]))) + [(_ blame (arg ...) body0 body ...) + (raise-syntax-error 'with-contract + "expected identifier" + #'blame)] + [(_ blame (arg ...)) + (raise-syntax-error 'with-contract + "empty body" + stx)] + [(_ blame bad-args body0 body ...) + (raise-syntax-error 'with-contract + "expected list of identifier and/or (identifier contract)" + #'bad-args)])) ; ; From b309ced851641cb3c0a328ed78ef86c284f256a6 Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Fri, 12 Sep 2008 18:17:40 +0000 Subject: [PATCH 38/88] Appropriately check the context. svn: r11693 --- collects/scheme/private/contract.ss | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/collects/scheme/private/contract.ss b/collects/scheme/private/contract.ss index 825cae14d1..51f769ae63 100644 --- a/collects/scheme/private/contract.ss +++ b/collects/scheme/private/contract.ss @@ -79,6 +79,10 @@ improve method arity mismatch contract violation error messages? ;; 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) + (when (eq? (syntax-local-context) 'expression) + (raise-syntax-error 'define/contract + "used in expression context" + define-stx)) (syntax-case define-stx () [(_ name contract-expr) (raise-syntax-error 'define/contract @@ -185,6 +189,10 @@ improve method arity mismatch contract violation error messages? (car args))]))) (define-syntax (with-contract stx) + (when (eq? (syntax-local-context) 'expression) + (raise-syntax-error 'with-contract + "used in expression context" + stx)) (syntax-case stx () [(_ blame (arg ...) body0 body ...) (identifier? (syntax blame)) From 019c2c8c34080bccb46889f6c59879ffbe7004ef Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Fri, 12 Sep 2008 18:49:08 +0000 Subject: [PATCH 39/88] Handle strings as blame, now add a description of the type of contract boundary that triggered the contract error. svn: r11695 --- collects/scheme/private/contract-guts.ss | 5 ++-- collects/scheme/private/contract.ss | 37 ++++++++++++++++-------- 2 files changed, 28 insertions(+), 14 deletions(-) diff --git a/collects/scheme/private/contract-guts.ss b/collects/scheme/private/contract-guts.ss index 522a87e254..9a6f5d0f42 100644 --- a/collects/scheme/private/contract-guts.ss +++ b/collects/scheme/private/contract-guts.ss @@ -204,8 +204,9 @@ (pair? (cdr to-blame)) (null? (cddr to-blame)) (equal? 'quote (car to-blame))) - (format "'~s" (cadr to-blame))] - [else (format "~s" to-blame)]) + (format "module '~s" (cadr to-blame))] + [(string? to-blame) to-blame] + [else (format "module ~s" to-blame)]) formatted-contract-sexp specific-blame) msg))) diff --git a/collects/scheme/private/contract.ss b/collects/scheme/private/contract.ss index 51f769ae63..b932ac25a6 100644 --- a/collects/scheme/private/contract.ss +++ b/collects/scheme/private/contract.ss @@ -90,7 +90,7 @@ improve method arity mismatch contract violation error messages? define-stx)] [(_ name contract-expr expr) (identifier? (syntax name)) - #'(with-contract name + #'(with-contract #:type function name ([name (verify-contract 'define/contract contract-expr)]) (define name expr))] [(_ name contract-expr expr0 expr ...) @@ -132,7 +132,7 @@ improve method arity mismatch contract violation error messages? (make-set!-transformer (lambda (stx) (with-syntax ([neg-blame-id (or (syntax-parameter-value #'current-contract-region) - (a:module-source-as-symbol id))] + #`(quote #,(a:module-source-as-symbol id)))] [pos-blame-id pos-blame-id] [contract-id contract-id] [id id]) @@ -147,7 +147,7 @@ improve method arity mismatch contract violation error messages? ((-contract contract-id id pos-blame-id - 'neg-blame-id + neg-blame-id #'f) arg ...))] [ident @@ -156,7 +156,7 @@ improve method arity mismatch contract violation error messages? (-contract contract-id id pos-blame-id - 'neg-blame-id + neg-blame-id #'ident))]))))) (define-for-syntax (check-and-split-with-contract-args args) @@ -194,8 +194,9 @@ improve method arity mismatch contract violation error messages? "used in expression context" stx)) (syntax-case stx () - [(_ blame (arg ...) body0 body ...) - (identifier? (syntax blame)) + [(_ #:type type blame (arg ...) body0 body ...) + (and (identifier? #'blame) + (identifier? #'type)) (let-values ([(unprotected protected protections) (check-and-split-with-contract-args (syntax->list #'(arg ...)))]) (with-syntax ([((protected-id id contract-id) ...) @@ -204,12 +205,13 @@ improve method arity mismatch contract violation error messages? (a:mangle-id stx "with-contract-id" n) (a:mangle-id stx "with-contract-contract-id" n))) protected)] + [blame-str (format "~a ~a" (syntax-e #'type) (syntax-e #'blame))] [(contract-expr ...) protections] [(unprotected-id ...) unprotected]) (syntax/loc stx (begin (define-values (unprotected-id ... id ...) - (syntax-parameterize ([current-contract-region (quote blame)]) + (syntax-parameterize ([current-contract-region blame-str]) (begin-with-definitions body0 body ... (values unprotected-id ... protected-id ...)))) @@ -218,19 +220,30 @@ improve method arity mismatch contract violation error messages? (make-with-contract-transformer (quote-syntax contract-id) (quote-syntax id) - (quote-syntax (quote blame)))) ...))))] - [(_ blame (arg ...) body0 body ...) + blame-str)) ...))))] + [(_ #:type type blame (arg ...) body0 body ...) + (identifier? #'blame) (raise-syntax-error 'with-contract - "expected identifier" + "expected identifier for type" + #'type)] + [(_ #:type type blame (arg ...) body0 body ...) + (raise-syntax-error 'with-contract + "expected identifier for blame" #'blame)] + [(_ blame (arg ...) body0 body ...) + #'(with-contract #:type region blame (arg ...) body0 body ...)] [(_ blame (arg ...)) (raise-syntax-error 'with-contract "empty body" stx)] - [(_ blame bad-args body0 body ...) + [(_ blame bad-args etc ...) (raise-syntax-error 'with-contract "expected list of identifier and/or (identifier contract)" - #'bad-args)])) + #'bad-args)] + [(_ blame) + (raise-syntax-error 'with-contract + "only blame" + stx)])) ; ; From 19cfe4e49ed6cb8e0346df8f7ae2704eaf82d7d2 Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Fri, 12 Sep 2008 18:55:11 +0000 Subject: [PATCH 40/88] I hate this kind of error checking. svn: r11696 --- collects/scheme/private/contract.ss | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/collects/scheme/private/contract.ss b/collects/scheme/private/contract.ss index b932ac25a6..127f97c586 100644 --- a/collects/scheme/private/contract.ss +++ b/collects/scheme/private/contract.ss @@ -233,13 +233,20 @@ improve method arity mismatch contract violation error messages? [(_ blame (arg ...) body0 body ...) #'(with-contract #:type region blame (arg ...) body0 body ...)] [(_ blame (arg ...)) + (identifier? #'blame) (raise-syntax-error 'with-contract "empty body" stx)] [(_ blame bad-args etc ...) + (identifier? #'blame) (raise-syntax-error 'with-contract "expected list of identifier and/or (identifier contract)" #'bad-args)] + [(_ args etc ...) + (not (identifier? #'args)) + (raise-syntax-error 'with-contract + "expected identifier for blame" + #'args)] [(_ blame) (raise-syntax-error 'with-contract "only blame" From 4e8064e8a585cb1512550c3d253a4c38b1dff68f Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Fri, 12 Sep 2008 19:01:13 +0000 Subject: [PATCH 41/88] Change it so that it uses strings instead of symbols here. svn: r11697 --- collects/scheme/private/contract-helpers.ss | 18 +++++++++--------- collects/scheme/private/contract.ss | 6 +++--- 2 files changed, 12 insertions(+), 12 deletions(-) diff --git a/collects/scheme/private/contract-helpers.ss b/collects/scheme/private/contract-helpers.ss index 28d9a7ef21..d878e1c48d 100644 --- a/collects/scheme/private/contract-helpers.ss +++ b/collects/scheme/private/contract-helpers.ss @@ -1,6 +1,6 @@ #lang scheme/base -(provide module-source-as-symbol build-src-loc-string +(provide module-source-as-string build-src-loc-string mangle-id mangle-id-for-maker build-struct-names nums-up-to @@ -111,27 +111,27 @@ (define o (current-output-port)) -;; module-source-as-symbol : syntax -> symbol -;; constructs a symbol for use in the blame error messages +;; module-source-as-string : syntax -> symbol +;; constructs a string for use in the blame error messages ;; when blaming the module where stx's occurs. -(define (module-source-as-symbol stx) +(define (module-source-as-string stx) (let ([mpi (syntax-source-module stx)]) (cond [(not mpi) - 'top-level] + "tthe top level"] [else ;; note: the directory passed to collapse-module-path-index should be irrelevant (let ([collapsed - (with-handlers ((exn:fail? (λ (x) 'top-level))) ;; this with-handlers works around a bug elsewhere + (with-handlers ((exn:fail? (λ (x) "the top level"))) ;; this with-handlers works around a bug elsewhere (collapse-module-path-index mpi (current-directory)))]) (cond [(path? collapsed) (let ([resolved (resolved-module-path-name (module-path-index-resolve mpi))]) (cond - [(symbol? resolved) resolved] - [else `(file ,(path->string resolved))]))] + [(symbol? resolved) (format "module ~a" resolved)] + [else (format "module ~a" `(file ,(path->string resolved)))]))] [else - collapsed]))]))) + (format "module ~a" collapsed)]))]))) (define build-struct-names (lambda (name-stx fields omit-sel? omit-set? srcloc-stx) diff --git a/collects/scheme/private/contract.ss b/collects/scheme/private/contract.ss index 127f97c586..bce81d4d7c 100644 --- a/collects/scheme/private/contract.ss +++ b/collects/scheme/private/contract.ss @@ -132,7 +132,7 @@ improve method arity mismatch contract violation error messages? (make-set!-transformer (lambda (stx) (with-syntax ([neg-blame-id (or (syntax-parameter-value #'current-contract-region) - #`(quote #,(a:module-source-as-symbol id)))] + (a:module-source-as-string id))] [pos-blame-id pos-blame-id] [contract-id contract-id] [id id]) @@ -303,7 +303,7 @@ improve method arity mismatch contract violation error messages? #`(-contract contract-id id pos-module-source - (module-source-as-symbol #'name) + (module-source-as-string #'name) #,(id->contract-src-info #'id))))))]) (when key (hash-set! saved-id-table key lifted-id)) @@ -802,7 +802,7 @@ improve method arity mismatch contract violation error messages? (with-syntax ([code (quasisyntax/loc stx (begin - (define pos-module-source (module-source-as-symbol #'pos-stx)) + (define pos-module-source (module-source-as-string #'pos-stx)) #,@(if no-need-to-check-ctrct? (list) From af5628bb5a45dc3625587b6a580d45d6a8e0a460 Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Fri, 12 Sep 2008 19:32:39 +0000 Subject: [PATCH 42/88] Fix up syntax here. svn: r11698 --- collects/scribblings/reference/contracts.scrbl | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/collects/scribblings/reference/contracts.scrbl b/collects/scribblings/reference/contracts.scrbl index a1dabbb252..622c225a9e 100644 --- a/collects/scribblings/reference/contracts.scrbl +++ b/collects/scribblings/reference/contracts.scrbl @@ -642,8 +642,8 @@ only used in the contract for the sub-struct's maker, and the selector or mutators for the super-struct are not provided.} @defform/subs[ -(with-contract blame-id (wc-exports) body ...+) -([wc-exports +(with-contract blame-id (wc-export ...) body ...+) +([wc-export id (id contract-expr)])]{ Generates a local contract boundary. The @scheme[contract-expr] From 068bbd76002ad141ed89bdbe6b488e1b2996dfbd Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Fri, 12 Sep 2008 19:40:58 +0000 Subject: [PATCH 43/88] Fix typo. svn: r11699 --- collects/scheme/private/contract-helpers.ss | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/scheme/private/contract-helpers.ss b/collects/scheme/private/contract-helpers.ss index d878e1c48d..296f19ad41 100644 --- a/collects/scheme/private/contract-helpers.ss +++ b/collects/scheme/private/contract-helpers.ss @@ -118,7 +118,7 @@ (let ([mpi (syntax-source-module stx)]) (cond [(not mpi) - "tthe top level"] + "the top level"] [else ;; note: the directory passed to collapse-module-path-index should be irrelevant (let ([collapsed From e83a72d6ae3b71d97817e6aab5dfd34dfa435a5f Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Fri, 12 Sep 2008 20:46:41 +0000 Subject: [PATCH 44/88] * Fix converting modules whose source is (list 'quote 'name) to "module 'name" in contract messages * Differentiate between define/contract functions and normal definitions * Fix up contract tests svn: r11700 --- collects/scheme/private/contract-helpers.ss | 5 +++ collects/scheme/private/contract.ss | 12 +++++-- .../tests/mzscheme/contract-mzlib-test.ss | 34 +++++++++---------- collects/tests/mzscheme/contract-test.ss | 16 ++++----- 4 files changed, 39 insertions(+), 28 deletions(-) diff --git a/collects/scheme/private/contract-helpers.ss b/collects/scheme/private/contract-helpers.ss index 296f19ad41..377f567634 100644 --- a/collects/scheme/private/contract-helpers.ss +++ b/collects/scheme/private/contract-helpers.ss @@ -130,6 +130,11 @@ (cond [(symbol? resolved) (format "module ~a" resolved)] [else (format "module ~a" `(file ,(path->string resolved)))]))] + [(and (pair? collapsed) + (pair? (cdr collapsed)) + (null? (cddr collapsed)) + (eq? (car collapsed) 'quote)) + (format "module '~a" (cadr collapsed))] [else (format "module ~a" collapsed)]))]))) diff --git a/collects/scheme/private/contract.ss b/collects/scheme/private/contract.ss index bce81d4d7c..64456fffdc 100644 --- a/collects/scheme/private/contract.ss +++ b/collects/scheme/private/contract.ss @@ -90,9 +90,10 @@ improve method arity mismatch contract violation error messages? define-stx)] [(_ name contract-expr expr) (identifier? (syntax name)) - #'(with-contract #:type function name + (syntax/loc define-stx + (with-contract #:type definition name ([name (verify-contract 'define/contract contract-expr)]) - (define name expr))] + (define name expr)))] [(_ name contract-expr expr0 expr ...) (identifier? (syntax name)) (raise-syntax-error 'define/contract @@ -104,7 +105,12 @@ improve method arity mismatch contract violation error messages? (datum->syntax #'define-stx (list* 'define/contract #'name+arg-list #'body0 #'(body ...))) #'lambda #t #t)]) - #`(define/contract #,name contract #,lam-expr))])) + (with-syntax ([name name] + [lam-expr lam-expr]) + (syntax/loc define-stx + (with-contract #:type function name + ([name (verify-contract 'define/contract contract)]) + (define name lam-expr)))))])) diff --git a/collects/tests/mzscheme/contract-mzlib-test.ss b/collects/tests/mzscheme/contract-mzlib-test.ss index f005a34eb5..4290317995 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,28 +1577,28 @@ 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 '(let () (define/contract i (-> integer? integer?) (lambda (x) 1)) (i #f)) - "top-level") + "the top level") (test/spec-failed 'define/contract5 '(let () (define/contract (i x) (-> integer? integer?) 1) (i #f)) - "top-level") + "the top level") (test/spec-passed 'define/contract6 @@ -1638,7 +1638,7 @@ of the contract library does not change over time. (+ m 1)) (b (zero? n))) (a 5)) - "a") + "function a") (test/spec-failed 'define/contract10 @@ -1650,7 +1650,7 @@ of the contract library does not change over time. #t) (b (add1 n))) (a 5)) - "b") + "function b") (test/spec-passed 'define/contract11 @@ -1673,7 +1673,7 @@ of the contract library does not change over time. (-> boolean? number? number?) (if b (f m) (f #t))) (g #f 3)) - "g") + "function g") (test/spec-passed 'with-contract1 @@ -1698,7 +1698,7 @@ of the contract library does not change over time. (define (even? n) (if (zero? n) #t (odd? (sub1 n))))) (odd? #t)) - "top-level") + "the top level") (test/spec-failed 'with-contract3 @@ -1711,7 +1711,7 @@ of the contract library does not change over time. (define (even? n) (if (zero? n) #t (odd? (sub1 n))))) (odd? 4)) - "odd-even") + "region odd-even") ;; Functions within the same with-contract region can call ;; each other however they want, so here we have even? @@ -4753,7 +4753,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 @@ -4930,7 +4930,7 @@ so that propagation occurs. (make-s 1 2) [s-a #f]))) (eval '(require 'pc11b-n))) - 'n) + "module 'n") |# (test/spec-passed @@ -4998,7 +4998,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 @@ -5009,7 +5009,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 diff --git a/collects/tests/mzscheme/contract-test.ss b/collects/tests/mzscheme/contract-test.ss index 65ef9dfd1c..06085a08c2 100644 --- a/collects/tests/mzscheme/contract-test.ss +++ b/collects/tests/mzscheme/contract-test.ss @@ -75,7 +75,7 @@ (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)]))) @@ -97,8 +97,8 @@ (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 @@ -120,7 +120,7 @@ (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) @@ -5196,7 +5196,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 @@ -5373,7 +5373,7 @@ so that propagation occurs. (make-s 1 2) [s-a #f]))) (eval '(require 'pc11b-n))) - 'n) + "module 'n") |# (test/spec-passed @@ -5441,7 +5441,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 @@ -5452,7 +5452,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 2e22b772780c9522cd4ce3d422f5147b0fbec482 Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Fri, 12 Sep 2008 21:45:13 +0000 Subject: [PATCH 45/88] Add which argument or result caused the contract error for -> contracts (i.e. also ->*, but not ->d or case->). svn: r11701 --- collects/scheme/private/contract-arrow.ss | 50 +++++++++++++++-------- 1 file changed, 32 insertions(+), 18 deletions(-) diff --git a/collects/scheme/private/contract-arrow.ss b/collects/scheme/private/contract-arrow.ss index 7dc86ea518..9b3f0f4d5e 100644 --- a/collects/scheme/private/contract-arrow.ss +++ b/collects/scheme/private/contract-arrow.ss @@ -112,10 +112,8 @@ v4 todo: ;; and it produces a wrapper-making function. (define-struct/prop -> (doms/c optional-doms/c dom-rest/c mandatory-kwds/c mandatory-kwds optional-kwds/c optional-kwds rngs/c rng-any? func) ((proj-prop (λ (ctc) - (let* ([doms-proj (map (λ (x) ((proj-get x) x)) - (if (->-dom-rest/c ctc) - (append (->-doms/c ctc) (list (->-dom-rest/c ctc))) - (->-doms/c ctc)))] + (let* ([doms-proj (map (λ (x) ((proj-get x) x)) (->-doms/c ctc))] + [rest-proj ((λ (x) (and x ((proj-get x) x))) (->-dom-rest/c ctc))] [doms-optional-proj (map (λ (x) ((proj-get x) x)) (->-optional-doms/c ctc))] [rngs-proj (map (λ (x) ((proj-get x) x)) (->-rngs/c ctc))] [mandatory-kwds-proj (map (λ (x) ((proj-get x) x)) (->-mandatory-kwds/c ctc))] @@ -124,25 +122,41 @@ v4 todo: [optional-keywords (->-optional-kwds ctc)] [func (->-func ctc)] [dom-length (length (->-doms/c ctc))] - [optionals-length (length (->-optional-doms/c ctc))] - [has-rest? (and (->-dom-rest/c ctc) #t)]) + [optionals-length (length (->-optional-doms/c ctc))]) (λ (pos-blame neg-blame src-info orig-str) - (let ([partial-doms (map (λ (dom) (dom neg-blame pos-blame src-info orig-str)) - doms-proj)] - [partial-optional-doms (map (λ (dom) (dom neg-blame pos-blame src-info orig-str)) - doms-optional-proj)] - [partial-ranges (map (λ (rng) (rng pos-blame neg-blame src-info orig-str)) - rngs-proj)] - [partial-mandatory-kwds (map (λ (kwd) (kwd neg-blame pos-blame src-info orig-str)) - mandatory-kwds-proj)] - [partial-optional-kwds (map (λ (kwd) (kwd neg-blame pos-blame src-info orig-str)) - optional-kwds-proj)]) + (let ([partial-doms (for/list ([dom doms-proj] + [n (in-naturals 1)]) + (dom neg-blame pos-blame src-info + (format "required argument ~a of ~a" n orig-str)))] + [partial-rest (if rest-proj + (list (rest-proj neg-blame pos-blame src-info + (format "rest argument of ~a" orig-str))) + null)] + [partial-optional-doms (for/list ([dom doms-optional-proj] + [n (in-naturals 1)]) + (dom neg-blame pos-blame src-info + (format "optional argument ~a of ~a" + n orig-str)))] + [partial-ranges (for/list ([rng rngs-proj] + [n (in-naturals 1)]) + (rng pos-blame neg-blame src-info + (format "result ~a of ~a" n orig-str)))] + [partial-mandatory-kwds (for/list ([kwd mandatory-kwds-proj] + [kwd-lit mandatory-keywords]) + (kwd neg-blame pos-blame src-info + (format "keyword argument ~a of ~a" + kwd-lit orig-str)))] + [partial-optional-kwds (for/list ([kwd optional-kwds-proj] + [kwd-lit optional-keywords]) + (kwd neg-blame pos-blame src-info + (format "keyword argument ~a of ~a" + kwd-lit orig-str)))]) (apply func (λ (val mtd?) - (if has-rest? + (if rest-proj (check-procedure/more val mtd? dom-length mandatory-keywords optional-keywords src-info pos-blame orig-str) (check-procedure val mtd? dom-length optionals-length mandatory-keywords optional-keywords src-info pos-blame orig-str))) - (append partial-doms partial-optional-doms + (append partial-doms partial-rest partial-optional-doms partial-mandatory-kwds partial-optional-kwds partial-ranges))))))) (name-prop (λ (ctc) (single-arrow-name-maker From a34326808393110e533a4c55511e0a9d9b4d060e Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Fri, 12 Sep 2008 22:59:51 +0000 Subject: [PATCH 46/88] Just to make sure the srcloc info is correct. svn: r11706 --- collects/scheme/private/contract.ss | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/collects/scheme/private/contract.ss b/collects/scheme/private/contract.ss index 64456fffdc..cfd71b962b 100644 --- a/collects/scheme/private/contract.ss +++ b/collects/scheme/private/contract.ss @@ -237,7 +237,8 @@ improve method arity mismatch contract violation error messages? "expected identifier for blame" #'blame)] [(_ blame (arg ...) body0 body ...) - #'(with-contract #:type region blame (arg ...) body0 body ...)] + (syntax/loc stx + (with-contract #:type region blame (arg ...) body0 body ...))] [(_ blame (arg ...)) (identifier? #'blame) (raise-syntax-error 'with-contract From 41ee6c8ac73f3be893021257b4e057af7c312517 Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Fri, 12 Sep 2008 23:25:58 +0000 Subject: [PATCH 47/88] Hello, McFly, hello?! I can't believe there wasn't already a test in there that checked this kind of thing. Wait, of course there couldn't have been, because it was specific to define/contract and with-contract, and _I'm_ writing those tests. Ah, well, fixed! :p svn: r11707 --- collects/scheme/private/contract.ss | 2 +- collects/tests/mzscheme/contract-mzlib-test.ss | 12 ++++++++++++ 2 files changed, 13 insertions(+), 1 deletion(-) diff --git a/collects/scheme/private/contract.ss b/collects/scheme/private/contract.ss index cfd71b962b..000b3191fc 100644 --- a/collects/scheme/private/contract.ss +++ b/collects/scheme/private/contract.ss @@ -138,7 +138,7 @@ improve method arity mismatch contract violation error messages? (make-set!-transformer (lambda (stx) (with-syntax ([neg-blame-id (or (syntax-parameter-value #'current-contract-region) - (a:module-source-as-string id))] + (a:module-source-as-string stx))] [pos-blame-id pos-blame-id] [contract-id contract-id] [id id]) diff --git a/collects/tests/mzscheme/contract-mzlib-test.ss b/collects/tests/mzscheme/contract-mzlib-test.ss index 4290317995..be7e35d232 100644 --- a/collects/tests/mzscheme/contract-mzlib-test.ss +++ b/collects/tests/mzscheme/contract-mzlib-test.ss @@ -1674,6 +1674,18 @@ of the contract library does not change over time. (if b (f m) (f #t))) (g #f 3)) "function g") + + (test/spec-failed + 'define/contract13 + '(begin + (eval '(module foo scheme/base + (require scheme/contract) + (define/contract (foo n) + (-> number? number?) + (+ n 1)) + (foo #t))) + (eval '(require 'foo))) + "module foo") (test/spec-passed 'with-contract1 From 32f0b99f12588db11aeca3461f8e68c764884a08 Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Fri, 12 Sep 2008 23:39:19 +0000 Subject: [PATCH 48/88] 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 --- .../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 be7e35d232..5003992b73 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 c484131597b684e1a17dd8aae520c8a2bd1f93e2 Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Fri, 12 Sep 2008 23:51:51 +0000 Subject: [PATCH 49/88] Okay, here's the old stuff put back, will fix up the unit tests when I get home. svn: r11709 --- collects/mzlib/contract.ss | 6 ++- collects/scheme/contract.ss | 1 + collects/scheme/private/contract.ss | 67 ++++++++++++++++++++++++++++- 3 files changed, 72 insertions(+), 2 deletions(-) diff --git a/collects/mzlib/contract.ss b/collects/mzlib/contract.ss index 9f69097e62..373846be04 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 diff --git a/collects/scheme/contract.ss b/collects/scheme/contract.ss index ca55dbf472..617fd07c81 100644 --- a/collects/scheme/contract.ss +++ b/collects/scheme/contract.ss @@ -27,6 +27,7 @@ differences from v3: check-procedure check-procedure/more) (except-out (all-from-out "private/contract.ss") + old-define/contract check-between/c check-unary-between/c)) diff --git a/collects/scheme/private/contract.ss b/collects/scheme/private/contract.ss index 000b3191fc..c1ce86a3d1 100644 --- a/collects/scheme/private/contract.ss +++ b/collects/scheme/private/contract.ss @@ -12,6 +12,7 @@ improve method arity mismatch contract violation error messages? (provide (rename-out [-contract contract]) recursive-contract provide/contract + old-define/contract define/contract with-contract current-contract-region) @@ -57,7 +58,9 @@ improve method arity mismatch contract violation error messages? #,(syntax-position id) #,(syntax-span id)) #,(format "~s" (syntax->datum id)))) - + + + ; ; ; @@ -75,6 +78,68 @@ improve method arity mismatch contract violation error messages? ; ; ; +;; First, we have the old define/contract implementation, which +;; is still used in mzlib/contract. + +(define-for-syntax (old-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 + (syntax->datum (quote-syntax f)) + neg-blame-str + (quote-syntax f)) + arg + ...))] + [ident + (identifier? (syntax ident)) + (syntax/loc stx + (-contract contract-id + id + (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 (old-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 + (old-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))])) + + + ;; (define/contract id contract expr) ;; defines `id' with `contract'; initially binding ;; it to the result of `expr'. These variables may not be set!'d. From ed067cb351a4ea54318b65f2cf9708a1199adb8d Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Sat, 13 Sep 2008 01:37:43 +0000 Subject: [PATCH 50/88] Be specific in what we're iterating over. svn: r11711 --- collects/scheme/private/contract-arrow.ss | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/collects/scheme/private/contract-arrow.ss b/collects/scheme/private/contract-arrow.ss index 9b3f0f4d5e..7adabdb241 100644 --- a/collects/scheme/private/contract-arrow.ss +++ b/collects/scheme/private/contract-arrow.ss @@ -124,7 +124,7 @@ v4 todo: [dom-length (length (->-doms/c ctc))] [optionals-length (length (->-optional-doms/c ctc))]) (λ (pos-blame neg-blame src-info orig-str) - (let ([partial-doms (for/list ([dom doms-proj] + (let ([partial-doms (for/list ([dom (in-list doms-proj)] [n (in-naturals 1)]) (dom neg-blame pos-blame src-info (format "required argument ~a of ~a" n orig-str)))] @@ -132,22 +132,22 @@ v4 todo: (list (rest-proj neg-blame pos-blame src-info (format "rest argument of ~a" orig-str))) null)] - [partial-optional-doms (for/list ([dom doms-optional-proj] + [partial-optional-doms (for/list ([dom (in-list doms-optional-proj)] [n (in-naturals 1)]) (dom neg-blame pos-blame src-info (format "optional argument ~a of ~a" n orig-str)))] - [partial-ranges (for/list ([rng rngs-proj] + [partial-ranges (for/list ([rng (in-list rngs-proj)] [n (in-naturals 1)]) (rng pos-blame neg-blame src-info (format "result ~a of ~a" n orig-str)))] - [partial-mandatory-kwds (for/list ([kwd mandatory-kwds-proj] - [kwd-lit mandatory-keywords]) + [partial-mandatory-kwds (for/list ([kwd (in-list mandatory-kwds-proj)] + [kwd-lit (in-list mandatory-keywords)]) (kwd neg-blame pos-blame src-info (format "keyword argument ~a of ~a" kwd-lit orig-str)))] - [partial-optional-kwds (for/list ([kwd optional-kwds-proj] - [kwd-lit optional-keywords]) + [partial-optional-kwds (for/list ([kwd (in-list optional-kwds-proj)] + [kwd-lit (in-list optional-keywords)]) (kwd neg-blame pos-blame src-info (format "keyword argument ~a of ~a" kwd-lit orig-str)))]) From 2017df4435f8527277f42f336c0cf4c4820d9557 Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Sat, 13 Sep 2008 02:01:57 +0000 Subject: [PATCH 51/88] Add in with-contract and define/contract tests here. svn: r11712 --- collects/tests/mzscheme/contract-test.ss | 244 +++++++++++++++++++++++ 1 file changed, 244 insertions(+) diff --git a/collects/tests/mzscheme/contract-test.ss b/collects/tests/mzscheme/contract-test.ss index 06085a08c2..33c99789bd 100644 --- a/collects/tests/mzscheme/contract-test.ss +++ b/collects/tests/mzscheme/contract-test.ss @@ -2158,6 +2158,250 @@ +; +; +; +; ; ;;;; ; +; ;; ; ; ; +; ; ; ; ; ; +; ; ; ; ; ; +; ;; ; ;;; ;;;; ; ; ;; ;;; ; ;;; ;; ; ;; ;;;; ; ;; ;;; ;;; ;;;; +; ; ;; ; ; ; ;; ;;; ; ; ; ; ; ; ; ; ;;; ; ; ;;; ; ; ; ; ; +; ; ; ;;;;; ; ; ; ; ;;;;; ; ; ; ; ; ; ; ; ;; ; ; +; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;; ; ; ; +; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; +; ; ;;; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;; ; ; ; ; +; ;; ; ;;; ;;;;;;;;;; ;;; ;;; ; ;;; ;; ;;; ;;; ;; ;;; ;; ;; ;;; ;; +; +; +; + + (test/spec-passed + 'define/contract1 + '(let () + (define/contract i integer? 1) + i)) + + (test/spec-failed + 'define/contract2 + '(let () + (define/contract i integer? #t) + i) + "definition i") + + (test/spec-failed + 'define/contract3 + '(let () + (define/contract i (-> integer? integer?) (lambda (x) #t)) + (i 1)) + "definition 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") + + (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?) + t) + (contracted-func + "I'm a string constant with side effects" + "ans"))) + + (test/spec-passed + 'define/contract8 + '(let () + (eval '(module contract-test-suite-define1 scheme/base + (require scheme/contract) + (define/contract x string? "a") + 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 scheme/base + (require scheme/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 scheme/base + (require scheme/contract) + (provide foo-dc14) + (define/contract (foo-dc14 n) + (-> number? number?) + (+ n 1)))) + (eval '(module bar-dc14 scheme/base + (require 'foo-dc14) + (foo-dc14 #t))) + (eval '(require 'bar-dc14))) + "module bar-dc14") + + (test/spec-failed + 'define/contract15 + '(begin + (eval '(module foo-dc15 scheme/base + (require scheme/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))) + + ; ; ; From 14ef34e8e38e32029783d8207a684859fba7e3c0 Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Sat, 13 Sep 2008 02:03:34 +0000 Subject: [PATCH 52/88] Revert this all the way back to where it was, I'll fix it up in a sec. svn: r11713 --- .../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 5003992b73..c32dc4c0af 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 16bce22386654e186f8e806aa5ee289fff380925 Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Sat, 13 Sep 2008 02:11:05 +0000 Subject: [PATCH 53/88] Slight change just because we're now printing what kind of thing triggered the broken contract. svn: r11714 --- collects/scheme/private/contract.ss | 4 ++-- .../tests/mzscheme/contract-mzlib-test.ss | 20 +++++++++---------- 2 files changed, 12 insertions(+), 12 deletions(-) diff --git a/collects/scheme/private/contract.ss b/collects/scheme/private/contract.ss index c1ce86a3d1..44d6268080 100644 --- a/collects/scheme/private/contract.ss +++ b/collects/scheme/private/contract.ss @@ -97,7 +97,7 @@ improve method arity mismatch contract violation error messages? (syntax/loc stx ((-contract contract-id id - (syntax->datum (quote-syntax f)) + (format "definition ~a" (syntax->datum (quote-syntax f))) neg-blame-str (quote-syntax f)) arg @@ -107,7 +107,7 @@ improve method arity mismatch contract violation error messages? (syntax/loc stx (-contract contract-id id - (syntax->datum (quote-syntax ident)) + (format "definition ~a" (syntax->datum (quote-syntax ident))) neg-blame-str (quote-syntax ident)))]))))) diff --git a/collects/tests/mzscheme/contract-mzlib-test.ss b/collects/tests/mzscheme/contract-mzlib-test.ss index c32dc4c0af..9b5a801777 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 0870c7ae1ddd58de472e2990f6b194686e61b083 Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Sat, 13 Sep 2008 02:51:09 +0000 Subject: [PATCH 54/88] Actually, move the old-style define/contract to its own file in mzlib, and change around mzlib/contract.ss appropriately. svn: r11715 --- collects/mzlib/contract.ss | 17 ++++-- collects/mzlib/private/contract-define.ss | 70 +++++++++++++++++++++++ collects/mzlib/scribblings/contract.scrbl | 2 +- collects/scheme/contract.ss | 1 - collects/scheme/private/contract.ss | 63 -------------------- 5 files changed, 82 insertions(+), 71 deletions(-) create mode 100644 collects/mzlib/private/contract-define.ss diff --git a/collects/mzlib/contract.ss b/collects/mzlib/contract.ss index 373846be04..944fcd4808 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 0000000000..d1f3ea63ed --- /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))])) + + + diff --git a/collects/mzlib/scribblings/contract.scrbl b/collects/mzlib/scribblings/contract.scrbl index fd5922d366..b9385821e8 100644 --- a/collects/mzlib/scribblings/contract.scrbl +++ b/collects/mzlib/scribblings/contract.scrbl @@ -24,7 +24,7 @@ @mzlib[#:mode title contract] -The @schememodname[mzlib/list] library re-exports many bindings +The @schememodname[mzlib/contract] library re-exports many bindings from @schememodname[scheme/contract]: @twocolumns[ diff --git a/collects/scheme/contract.ss b/collects/scheme/contract.ss index 617fd07c81..ca55dbf472 100644 --- a/collects/scheme/contract.ss +++ b/collects/scheme/contract.ss @@ -27,7 +27,6 @@ differences from v3: check-procedure check-procedure/more) (except-out (all-from-out "private/contract.ss") - old-define/contract check-between/c check-unary-between/c)) diff --git a/collects/scheme/private/contract.ss b/collects/scheme/private/contract.ss index 44d6268080..de41f43383 100644 --- a/collects/scheme/private/contract.ss +++ b/collects/scheme/private/contract.ss @@ -12,7 +12,6 @@ improve method arity mismatch contract violation error messages? (provide (rename-out [-contract contract]) recursive-contract provide/contract - old-define/contract define/contract with-contract current-contract-region) @@ -78,68 +77,6 @@ improve method arity mismatch contract violation error messages? ; ; ; -;; First, we have the old define/contract implementation, which -;; is still used in mzlib/contract. - -(define-for-syntax (old-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 (old-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 - (old-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))])) - - - ;; (define/contract id contract expr) ;; defines `id' with `contract'; initially binding ;; it to the result of `expr'. These variables may not be set!'d. From 03347cc39017ce38250fbf9268c2ebccee3bbc10 Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Sat, 13 Sep 2008 04:37:51 +0000 Subject: [PATCH 55/88] Probably a better way to do this, but now the list is of odd length and I can't just remove define/contract (which is no longer a binding from scheme/contract) straightforwardly. svn: r11718 --- collects/mzlib/scribblings/contract.scrbl | 13 ++++++++----- 1 file changed, 8 insertions(+), 5 deletions(-) diff --git a/collects/mzlib/scribblings/contract.scrbl b/collects/mzlib/scribblings/contract.scrbl index b9385821e8..d1fec7255d 100644 --- a/collects/mzlib/scribblings/contract.scrbl +++ b/collects/mzlib/scribblings/contract.scrbl @@ -7,6 +7,8 @@ (*twocolumns (list (scheme id) ...))) @(define (*twocolumns l) (let* ([len (length l)] + [l (if (odd? len) (append l (list #f)) l)] + [len (length l)] [half (quotient len 2)] [a (for/list ([i (in-range half)] [e l]) @@ -16,10 +18,12 @@ [to-flow (compose make-flow list make-paragraph list)]) (make-table #f (map (lambda (a b) - (list (to-flow spacer) - (to-flow a) - (to-flow spacer) - (to-flow b))) + (append (list (to-flow spacer) + (to-flow a)) + (if b + (list (to-flow spacer) + (to-flow b)) + null))) a b)))) @mzlib[#:mode title contract] @@ -47,7 +51,6 @@ from @schememodname[scheme/contract]: contract-violation->string contract? define-contract-struct - define/contract false/c flat-contract flat-contract-predicate From 0d1b217bce3fb9793e334dfb83e2663c33f6bb72 Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Sat, 13 Sep 2008 04:45:44 +0000 Subject: [PATCH 56/88] Add docs for version of define/contract that is in mzlib/contract. svn: r11719 --- collects/mzlib/scribblings/contract.scrbl | 20 ++++++++++++++++++++ 1 file changed, 20 insertions(+) diff --git a/collects/mzlib/scribblings/contract.scrbl b/collects/mzlib/scribblings/contract.scrbl index d1fec7255d..5e586bd996 100644 --- a/collects/mzlib/scribblings/contract.scrbl +++ b/collects/mzlib/scribblings/contract.scrbl @@ -85,3 +85,23 @@ from @schememodname[scheme/contract]: vector-immutableof vector/c vectorof] + +It also provides the old version of @scheme[define/contract]: + +@defform[(define/contract id contract-expr init-value-expr)]{ + +Attaches the contract @scheme[contract-expr] to +@scheme[init-value-expr] and binds that to @scheme[id]. + +The @scheme[define/contract] form treats individual definitions as +units of blame. The definition itself is responsible for positive +(co-variant) positions of the contract and each reference to +@scheme[id] (including those in the initial value expression) must +meet the negative positions of the contract. + +Error messages with @scheme[define/contract] are not as clear as those +provided by @scheme[provide/contract], because +@scheme[define/contract] cannot detect the name of the definition +where the reference to the defined variable occurs. Instead, it uses +the source location of the reference to the variable as the name of +that definition.} From 051966923925ba3bfaacfcc77f9d57e7fbfb2452 Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Sun, 14 Sep 2008 06:00:48 +0000 Subject: [PATCH 57/88] Show some actual examples of how the two differ here. svn: r11743 --- collects/mzlib/scribblings/contract.scrbl | 34 ++++++++++++++++++++++- 1 file changed, 33 insertions(+), 1 deletion(-) diff --git a/collects/mzlib/scribblings/contract.scrbl b/collects/mzlib/scribblings/contract.scrbl index ba6047edbb..0ae069c2d1 100644 --- a/collects/mzlib/scribblings/contract.scrbl +++ b/collects/mzlib/scribblings/contract.scrbl @@ -1,5 +1,7 @@ #lang scribble/doc @(require "common.ss" + scheme/sandbox + scribble/eval scribble/struct (for-label mzlib/contract)) @@ -108,4 +110,34 @@ provided by @scheme[provide/contract], because @scheme[define/contract] cannot detect the name of the definition where the reference to the defined variable occurs. Instead, it uses the source location of the reference to the variable as the name of -that definition.} +that definition. + +@interaction[#:eval (parameterize ([sandbox-output 'string] + [sandbox-error-output 'string] + [sandbox-eval-limits #f]) + (make-evaluator 'mzscheme)) + (require mzlib/contract) + (define/contract f + (-> number? number?) + (lambda (x) (+ x 1))) + (define/contract g + (-> number? number?) + (lambda (x) (f #t))) + (f 4) + (f #t) + (g 4)] + +This is as opposed to the @scheme[define/contract] form from +@schememodname[scheme/contract], which gives more precise error +messages: + +@interaction[(require scheme/contract) + (define/contract f + (-> number? number?) + (lambda (x) (+ x 1))) + (define/contract g + (-> number? number?) + (lambda (x) (f #t))) + (f 4) + (f #t) + (g 4)]} From 0cdb21157e898a65e763dc2401548698a3d20da4 Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Sun, 14 Sep 2008 06:20:27 +0000 Subject: [PATCH 58/88] Mixing both on the same page is bad, so just have each's examples in their own sections. svn: r11744 --- collects/mzlib/scribblings/contract.scrbl | 22 +++------ .../scribblings/reference/contracts.scrbl | 45 ++++++++++++++++++- 2 files changed, 50 insertions(+), 17 deletions(-) diff --git a/collects/mzlib/scribblings/contract.scrbl b/collects/mzlib/scribblings/contract.scrbl index 0ae069c2d1..1b3a81ec9c 100644 --- a/collects/mzlib/scribblings/contract.scrbl +++ b/collects/mzlib/scribblings/contract.scrbl @@ -123,21 +123,11 @@ that definition. (define/contract g (-> number? number?) (lambda (x) (f #t))) + (define/contract i + (-> number? number?) + (lambda (x) + (if (number? x) (i #t) 0))) (f 4) (f #t) - (g 4)] - -This is as opposed to the @scheme[define/contract] form from -@schememodname[scheme/contract], which gives more precise error -messages: - -@interaction[(require scheme/contract) - (define/contract f - (-> number? number?) - (lambda (x) (+ x 1))) - (define/contract g - (-> number? number?) - (lambda (x) (f #t))) - (f 4) - (f #t) - (g 4)]} + (g 4) + (i 3)]} diff --git a/collects/scribblings/reference/contracts.scrbl b/collects/scribblings/reference/contracts.scrbl index 2334572658..7a6856129b 100644 --- a/collects/scribblings/reference/contracts.scrbl +++ b/collects/scribblings/reference/contracts.scrbl @@ -664,6 +664,29 @@ contracts paired with exported @scheme[id]s. Contracts broken within the @scheme[with-contract] @scheme[body] will use the @scheme[blame-id] for their negative position.} +@interaction[(require scheme/contract) + (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))))) + (even? 4) + (odd? "foo") + (with-contract bad-internal-call + ([f (-> number? number?)] + [g (-> number? number?)]) + (define (f x) + (+ x 1)) + (define (g x) + (if (zero? x) #t (f #t)))) + (f 4) + (f 'a) + (g "foo") + (g 0) + (g 3)] + @defform*[[(define/contract id contract-expr init-value-expr) (define/contract (head args) contract-expr body ...+)]]{ @@ -676,7 +699,27 @@ units of blame. The definition itself is responsible for positive @scheme[id] outside of the definition must meet the negative positions of the contract. It is equivalent to wrapping a single @scheme[define] with a @scheme[with-contract] form that pairs the @scheme[contract-expr] -with the bound identifier.} +with the bound identifier. + +@interaction[(require scheme/contract) + (define/contract a number? #t) + a + (define/contract (f x) + (-> number? number?) + (+ x 1)) + (f 4) + (f #t) + (define/contract (g #:foo [x 3] . y) + (->* () (#:foo number?) #:rest (listof number?) number?) + (+ x (apply + y))) + (g) + (g #:foo #t) + (g 1 2 3 'a) + (define/contract i + (-> number? number?) + (lambda (x) + (if (number? x) (i #t) 0))) + (i 3)]} @defform*[[(contract contract-expr to-protect-expr positive-blame-expr negative-blame-expr) From 6c2f2bc60de60a58d23b1201c5686426979ab5a5 Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Sun, 14 Sep 2008 06:27:22 +0000 Subject: [PATCH 59/88] One more time. Oh, well. svn: r11745 --- collects/mzlib/scribblings/contract.scrbl | 38 ++++----- .../scribblings/reference/contracts.scrbl | 84 +++++++++---------- 2 files changed, 61 insertions(+), 61 deletions(-) diff --git a/collects/mzlib/scribblings/contract.scrbl b/collects/mzlib/scribblings/contract.scrbl index 1b3a81ec9c..3478296362 100644 --- a/collects/mzlib/scribblings/contract.scrbl +++ b/collects/mzlib/scribblings/contract.scrbl @@ -112,22 +112,22 @@ where the reference to the defined variable occurs. Instead, it uses the source location of the reference to the variable as the name of that definition. -@interaction[#:eval (parameterize ([sandbox-output 'string] - [sandbox-error-output 'string] - [sandbox-eval-limits #f]) - (make-evaluator 'mzscheme)) - (require mzlib/contract) - (define/contract f - (-> number? number?) - (lambda (x) (+ x 1))) - (define/contract g - (-> number? number?) - (lambda (x) (f #t))) - (define/contract i - (-> number? number?) - (lambda (x) - (if (number? x) (i #t) 0))) - (f 4) - (f #t) - (g 4) - (i 3)]} +@examples[#:eval (parameterize ([sandbox-output 'string] + [sandbox-error-output 'string] + [sandbox-eval-limits #f]) + (make-evaluator 'mzscheme)) + (require mzlib/contract) + (define/contract f + (-> number? number?) + (lambda (x) (+ x 1))) + (define/contract g + (-> number? number?) + (lambda (x) (f #t))) + (define/contract i + (-> number? number?) + (lambda (x) + (if (number? x) (i #t) 0))) + (f 4) + (f #t) + (g 4) + (i 3)]} diff --git a/collects/scribblings/reference/contracts.scrbl b/collects/scribblings/reference/contracts.scrbl index 7a6856129b..eb83a88d43 100644 --- a/collects/scribblings/reference/contracts.scrbl +++ b/collects/scribblings/reference/contracts.scrbl @@ -662,30 +662,30 @@ exported without a contract. The @scheme[blame-id] is used for the positive positions of contracts paired with exported @scheme[id]s. Contracts broken within the @scheme[with-contract] @scheme[body] will use the -@scheme[blame-id] for their negative position.} +@scheme[blame-id] for their negative position. -@interaction[(require scheme/contract) - (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))))) - (even? 4) - (odd? "foo") - (with-contract bad-internal-call - ([f (-> number? number?)] - [g (-> number? number?)]) - (define (f x) - (+ x 1)) - (define (g x) - (if (zero? x) #t (f #t)))) - (f 4) - (f 'a) - (g "foo") - (g 0) - (g 3)] +@examples[(require scheme/contract) + (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))))) + (even? 4) + (odd? "foo") + (with-contract bad-internal-call + ([f (-> number? number?)] + [g (-> number? number?)]) + (define (f x) + (+ x 1)) + (define (g x) + (if (zero? x) #t (f #t)))) + (f 4) + (f 'a) + (g "foo") + (g 0) + (g 3)]} @defform*[[(define/contract id contract-expr init-value-expr) (define/contract (head args) contract-expr body ...+)]]{ @@ -701,25 +701,25 @@ of the contract. It is equivalent to wrapping a single @scheme[define] with a @scheme[with-contract] form that pairs the @scheme[contract-expr] with the bound identifier. -@interaction[(require scheme/contract) - (define/contract a number? #t) - a - (define/contract (f x) - (-> number? number?) - (+ x 1)) - (f 4) - (f #t) - (define/contract (g #:foo [x 3] . y) - (->* () (#:foo number?) #:rest (listof number?) number?) - (+ x (apply + y))) - (g) - (g #:foo #t) - (g 1 2 3 'a) - (define/contract i - (-> number? number?) - (lambda (x) - (if (number? x) (i #t) 0))) - (i 3)]} +@examples[(require scheme/contract) + (define/contract a number? #t) + a + (define/contract (f x) + (-> number? number?) + (+ x 1)) + (f 4) + (f #t) + (define/contract (g #:foo [x 3] . y) + (->* () (#:foo number?) #:rest (listof number?) number?) + (+ x (apply + y))) + (g) + (g #:foo #t) + (g 1 2 3 'a) + (define/contract i + (-> number? number?) + (lambda (x) + (if (number? x) (i #t) 0))) + (i 3)]} @defform*[[(contract contract-expr to-protect-expr positive-blame-expr negative-blame-expr) From e40c856660f2df25ee0c18e57328a8d954a6d57a Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Mon, 15 Sep 2008 19:41:54 +0000 Subject: [PATCH 60/88] Do head expansion, check to make sure exported identifiers were defined inside the with-contract form. svn: r11760 --- collects/scheme/private/contract.ss | 73 ++++++++++++++++++++--------- 1 file changed, 50 insertions(+), 23 deletions(-) diff --git a/collects/scheme/private/contract.ss b/collects/scheme/private/contract.ss index 95c61ae87b..7ddba6853c 100644 --- a/collects/scheme/private/contract.ss +++ b/collects/scheme/private/contract.ss @@ -21,6 +21,7 @@ improve method arity mismatch contract violation error messages? (for-syntax scheme/struct-info) (for-syntax scheme/list) (for-syntax syntax/define) + (for-syntax syntax/kerncase) scheme/promise scheme/stxparam mzlib/etc) @@ -159,6 +160,28 @@ improve method arity mismatch contract violation error messages? neg-blame-id #'ident))]))))) +(define-for-syntax (head-expand-all body-stxs) + (for/list ([stx body-stxs]) + (local-expand stx + (syntax-local-context) + (kernel-form-identifier-list)))) + +(define-for-syntax (check-exports ids body-stxs) + (let ([defd-ids (for/fold ([id-list null]) + ([stx body-stxs]) + (kernel-syntax-case stx #f + [(define-values ids expr) + (append (syntax->list #'ids) + id-list)] + [_ id-list]))]) + (for ([id (in-list ids)]) + (unless (findf (lambda (s) + (bound-identifier=? s id)) + defd-ids) + (raise-syntax-error 'with-contract + "identifier not defined in body" + id))))) + (define-for-syntax (check-and-split-with-contract-args args) (let loop ([args args] [unprotected null] @@ -198,29 +221,33 @@ improve method arity mismatch contract violation error messages? (and (identifier? #'blame) (identifier? #'type)) (let-values ([(unprotected protected protections) - (check-and-split-with-contract-args (syntax->list #'(arg ...)))]) - (with-syntax ([((protected-id id contract-id) ...) - (map (lambda (n) - (list n - (a:mangle-id stx "with-contract-id" n) - (a:mangle-id stx "with-contract-contract-id" n))) - protected)] - [blame-str (format "~a ~a" (syntax-e #'type) (syntax-e #'blame))] - [(contract-expr ...) protections] - [(unprotected-id ...) unprotected]) - (syntax/loc stx - (begin - (define-values (unprotected-id ... id ...) - (syntax-parameterize ([current-contract-region blame-str]) - (begin-with-definitions - body0 body ... - (values unprotected-id ... protected-id ...)))) - (define contract-id (verify-contract 'with-contract contract-expr)) ... - (define-syntax protected-id - (make-with-contract-transformer - (quote-syntax contract-id) - (quote-syntax id) - blame-str)) ...))))] + (check-and-split-with-contract-args (syntax->list #'(arg ...)))] + [(expanded-bodies) (head-expand-all (cons #'body0 + (syntax->list #'(body ...))))]) + (begin + (check-exports (append unprotected protected) expanded-bodies) + (with-syntax ([((protected-id id contract-id) ...) + (map (lambda (n) + (list n + (a:mangle-id stx "with-contract-id" n) + (a:mangle-id stx "with-contract-contract-id" n))) + protected)] + [blame-str (format "~a ~a" (syntax-e #'type) (syntax-e #'blame))] + [(contract-expr ...) protections] + [(unprotected-id ...) unprotected]) + (quasisyntax/loc stx + (begin + (define-values (unprotected-id ... id ...) + (syntax-parameterize ([current-contract-region blame-str]) + (begin-with-definitions + #,@expanded-bodies + (values unprotected-id ... protected-id ...)))) + (define contract-id (verify-contract 'with-contract contract-expr)) ... + (define-syntax protected-id + (make-with-contract-transformer + (quote-syntax contract-id) + (quote-syntax id) + blame-str)) ...)))))] [(_ #:type type blame (arg ...) body0 body ...) (identifier? #'blame) (raise-syntax-error 'with-contract From deccda53eabbf870afb9fe943d66c7db2f97302d Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Mon, 15 Sep 2008 19:53:41 +0000 Subject: [PATCH 61/88] Add duplicate checking to exports list. svn: r11761 --- collects/scheme/private/contract.ss | 8 +++++++- 1 file changed, 7 insertions(+), 1 deletion(-) diff --git a/collects/scheme/private/contract.ss b/collects/scheme/private/contract.ss index 7ddba6853c..e4786e3ef7 100644 --- a/collects/scheme/private/contract.ss +++ b/collects/scheme/private/contract.ss @@ -225,7 +225,13 @@ improve method arity mismatch contract violation error messages? [(expanded-bodies) (head-expand-all (cons #'body0 (syntax->list #'(body ...))))]) (begin - (check-exports (append unprotected protected) expanded-bodies) + (let* ([all-ids (append unprotected protected)] + [dupd-id (check-duplicate-identifier all-ids)]) + (when dupd-id + (raise-syntax-error 'with-contract + "identifier appears twice in exports" + dupd-id)) + (check-exports (append unprotected protected) expanded-bodies)) (with-syntax ([((protected-id id contract-id) ...) (map (lambda (n) (list n From e76da360e5fb6f536bee232ad809d8df2429698e Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Mon, 15 Sep 2008 21:47:24 +0000 Subject: [PATCH 62/88] Rework this somewhat so you get appropriate error messages with or without #:type. svn: r11763 --- collects/scheme/private/contract.ss | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/collects/scheme/private/contract.ss b/collects/scheme/private/contract.ss index e4786e3ef7..183ea1117c 100644 --- a/collects/scheme/private/contract.ss +++ b/collects/scheme/private/contract.ss @@ -263,28 +263,28 @@ improve method arity mismatch contract violation error messages? (raise-syntax-error 'with-contract "expected identifier for blame" #'blame)] - [(_ blame (arg ...) body0 body ...) - (syntax/loc stx - (with-contract #:type region blame (arg ...) body0 body ...))] - [(_ blame (arg ...)) + [(_ #:type type blame (arg ...)) (identifier? #'blame) (raise-syntax-error 'with-contract "empty body" stx)] - [(_ blame bad-args etc ...) + [(_ #:type type blame bad-args etc ...) (identifier? #'blame) (raise-syntax-error 'with-contract "expected list of identifier and/or (identifier contract)" #'bad-args)] - [(_ args etc ...) + [(_ #:type type args etc ...) (not (identifier? #'args)) (raise-syntax-error 'with-contract "expected identifier for blame" #'args)] - [(_ blame) + [(_ #:type type blame) (raise-syntax-error 'with-contract "only blame" - stx)])) + stx)] + [(_ etc ...) + (syntax/loc stx + (with-contract #:type region etc ...))])) ; ; From 32e0f2d3188331e5d98cb00235b772a70d5515f5 Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Mon, 15 Sep 2008 21:49:13 +0000 Subject: [PATCH 63/88] One more slight change here. svn: r11764 --- collects/scheme/private/contract.ss | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/collects/scheme/private/contract.ss b/collects/scheme/private/contract.ss index 183ea1117c..21edc914fa 100644 --- a/collects/scheme/private/contract.ss +++ b/collects/scheme/private/contract.ss @@ -254,11 +254,6 @@ improve method arity mismatch contract violation error messages? (quote-syntax contract-id) (quote-syntax id) blame-str)) ...)))))] - [(_ #:type type blame (arg ...) body0 body ...) - (identifier? #'blame) - (raise-syntax-error 'with-contract - "expected identifier for type" - #'type)] [(_ #:type type blame (arg ...) body0 body ...) (raise-syntax-error 'with-contract "expected identifier for blame" @@ -278,6 +273,11 @@ improve method arity mismatch contract violation error messages? (raise-syntax-error 'with-contract "expected identifier for blame" #'args)] + [(_ #:type type etc ...) + (not (identifier? #'type)) + (raise-syntax-error 'with-contract + "expected identifier for type" + #'type)] [(_ #:type type blame) (raise-syntax-error 'with-contract "only blame" From 402deaafe55f38f2a1f3d742e48a762725586a49 Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Mon, 15 Sep 2008 21:52:02 +0000 Subject: [PATCH 64/88] Another error case. svn: r11765 --- collects/scheme/private/contract.ss | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/collects/scheme/private/contract.ss b/collects/scheme/private/contract.ss index 21edc914fa..3c0cff2556 100644 --- a/collects/scheme/private/contract.ss +++ b/collects/scheme/private/contract.ss @@ -79,18 +79,22 @@ improve method arity mismatch contract violation error messages? "used in expression context" define-stx)) (syntax-case define-stx () + [(_ name) + (raise-syntax-error 'define/contract + "no contract or body" + define-stx)] [(_ name contract-expr) (raise-syntax-error 'define/contract "no body after contract" define-stx)] [(_ name contract-expr expr) - (identifier? (syntax name)) + (identifier? #'name) (syntax/loc define-stx (with-contract #:type definition name ([name (verify-contract 'define/contract contract-expr)]) (define name expr)))] [(_ name contract-expr expr0 expr ...) - (identifier? (syntax name)) + (identifier? #'name) (raise-syntax-error 'define/contract "multiple expressions after identifier and contract" define-stx)] From d424cc4ef2beaa6f1632b5f4b72061d0325ef153 Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Mon, 15 Sep 2008 22:10:17 +0000 Subject: [PATCH 65/88] This way we get rid of the phantom spaces in the fitting case. svn: r11767 --- collects/scheme/private/contract-guts.ss | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/collects/scheme/private/contract-guts.ss b/collects/scheme/private/contract-guts.ss index a99017cd72..66b497ce88 100644 --- a/collects/scheme/private/contract-guts.ss +++ b/collects/scheme/private/contract-guts.ss @@ -180,8 +180,7 @@ [formatted-contract-sexp (let ([one-line (let ([sp (open-output-string)]) - (parameterize ([pretty-print-print-line print-contract-liner] - [pretty-print-columns 'infinity]) + (parameterize ([pretty-print-columns 'infinity]) (pretty-print contract-sexp sp) (get-output-string sp)))]) (if (< (string-length one-line) 30) From 41b85b19deb34f0d561dbebadce660ee08d5a5e8 Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Wed, 17 Sep 2008 02:52:31 +0000 Subject: [PATCH 66/88] On the plane I tried to avoid verifying the contracts when it's not needed. svn: r11783 --- collects/scheme/private/contract.ss | 45 ++++++++++++++++++----------- 1 file changed, 28 insertions(+), 17 deletions(-) diff --git a/collects/scheme/private/contract.ss b/collects/scheme/private/contract.ss index 0b18ab00ef..eb5cf11a52 100644 --- a/collects/scheme/private/contract.ss +++ b/collects/scheme/private/contract.ss @@ -89,10 +89,13 @@ improve method arity mismatch contract violation error messages? define-stx)] [(_ name contract-expr expr) (identifier? #'name) - (syntax/loc define-stx - (with-contract #:type definition name - ([name (verify-contract 'define/contract contract-expr)]) - (define name expr)))] + (let ([contract (if (a:known-good-contract? #'contract-expr) + #'contract-expr + #'(verify-contract 'define/contract contract-expr))]) + (quasisyntax/loc define-stx + (with-contract #:type definition name + ([name #,contract]) + (define name expr))))] [(_ name contract-expr expr0 expr ...) (identifier? #'name) (raise-syntax-error 'define/contract @@ -224,10 +227,22 @@ improve method arity mismatch contract violation error messages? [(_ #:type type blame (arg ...) body0 body ...) (and (identifier? #'blame) (identifier? #'type)) - (let-values ([(unprotected protected protections) - (check-and-split-with-contract-args (syntax->list #'(arg ...)))] - [(expanded-bodies) (head-expand-all (cons #'body0 - (syntax->list #'(body ...))))]) + (let*-values ([(unprotected protected protections) + (check-and-split-with-contract-args (syntax->list #'(arg ...)))] + [(expanded-bodies) (head-expand-all (cons #'body0 + (syntax->list #'(body ...))))] + [(protected-ids ids contracts contract-defs) + (for/lists (protected-ids ids contracts contract-defs) + ([n protected] + [c protections]) + (let ([new-id (a:mangle-id stx "with-contract-id" n)]) + (if (a:known-good-contract? c) + (values n new-id c #f) + (let ([contract-id (a:mangle-id stx "with-contract-contract-id" n)]) + (values n new-id contract-id + (quasisyntax/loc stx + (define-values (#,contract-id) + (verify-contract 'with-contract #,c))))))))]) (begin (let* ([all-ids (append unprotected protected)] [dupd-id (check-duplicate-identifier all-ids)]) @@ -236,14 +251,10 @@ improve method arity mismatch contract violation error messages? "identifier appears twice in exports" dupd-id)) (check-exports (append unprotected protected) expanded-bodies)) - (with-syntax ([((protected-id id contract-id) ...) - (map (lambda (n) - (list n - (a:mangle-id stx "with-contract-id" n) - (a:mangle-id stx "with-contract-contract-id" n))) - protected)] + (with-syntax ([((protected-id id contract) ...) + (map list protected-ids ids contracts)] + [(contract-def ...) (filter values contract-defs)] [blame-str (format "~a ~a" (syntax-e #'type) (syntax-e #'blame))] - [(contract-expr ...) protections] [(unprotected-id ...) unprotected]) (quasisyntax/loc stx (begin @@ -252,10 +263,10 @@ improve method arity mismatch contract violation error messages? (begin-with-definitions #,@expanded-bodies (values unprotected-id ... protected-id ...)))) - (define contract-id (verify-contract 'with-contract contract-expr)) ... + contract-def ... (define-syntax protected-id (make-with-contract-transformer - (quote-syntax contract-id) + (quote-syntax contract) (quote-syntax id) blame-str)) ...)))))] [(_ #:type type blame (arg ...) body0 body ...) From fb9c65e5ef24a2c09f147da02b6626a14624143f Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Wed, 8 Oct 2008 16:16:18 +0000 Subject: [PATCH 67/88] Let's make this more structured so we can actually print this out nicely. svn: r11979 --- collects/scheme/private/contract-arrow.ss | 12 +++--- collects/scheme/private/contract-guts.ss | 46 +++++++++++++++-------- 2 files changed, 36 insertions(+), 22 deletions(-) diff --git a/collects/scheme/private/contract-arrow.ss b/collects/scheme/private/contract-arrow.ss index 32c555a76e..d21ee1a85d 100644 --- a/collects/scheme/private/contract-arrow.ss +++ b/collects/scheme/private/contract-arrow.ss @@ -119,27 +119,27 @@ v4 todo: (let ([partial-doms (for/list ([dom (in-list doms-proj)] [n (in-naturals 1)]) (dom neg-blame pos-blame src-info - (format "required argument ~a of ~a" n orig-str)))] + (cons (format "required argument ~a" n) orig-str)))] [partial-rest (if rest-proj (list (rest-proj neg-blame pos-blame src-info - (format "rest argument of ~a" orig-str))) + (cons "rest argument" orig-str))) null)] [partial-optional-doms (for/list ([dom (in-list doms-optional-proj)] [n (in-naturals 1)]) (dom neg-blame pos-blame src-info - (format "optional argument ~a of ~a" n orig-str)))] + (cons (format "optional argument ~a" n) orig-str)))] [partial-ranges (for/list ([rng (in-list rngs-proj)] [n (in-naturals 1)]) (rng pos-blame neg-blame src-info - (format "result ~a of ~a" n orig-str)))] + (cons (format "result ~a" n) orig-str)))] [partial-mandatory-kwds (for/list ([kwd (in-list mandatory-kwds-proj)] [kwd-lit (in-list mandatory-keywords)]) (kwd neg-blame pos-blame src-info - (format "keyword argument ~a of ~a" kwd-lit orig-str)))] + (cons (format "keyword argument ~a" kwd-lit) orig-str)))] [partial-optional-kwds (for/list ([kwd (in-list optional-kwds-proj)] [kwd-lit (in-list optional-keywords)]) (kwd neg-blame pos-blame src-info - (format "keyword argument ~a of ~a" kwd-lit orig-str)))]) + (cons (format "keyword argument ~a" kwd-lit) orig-str)))]) (apply func (λ (val mtd?) (if has-rest? diff --git a/collects/scheme/private/contract-guts.ss b/collects/scheme/private/contract-guts.ss index 66b497ce88..45b99da8a4 100644 --- a/collects/scheme/private/contract-guts.ss +++ b/collects/scheme/private/contract-guts.ss @@ -1,7 +1,8 @@ #lang scheme/base (require "contract-helpers.ss" - scheme/pretty) + scheme/pretty + (only-in scheme/list add-between)) (require (for-syntax scheme/base "contract-helpers.ss")) @@ -175,22 +176,35 @@ (lambda (x) (get x 0)) (lambda (x) (get x 1))))) -(define (default-contract-violation->string val src-info to-blame contract-sexp msg) +(define (default-contract-violation->string val src-info to-blame contract-sexp+extra msg) + (define (add-modifiers-to-contract modifiers contract-str) + (if (null? modifiers) + contract-str + (string-append "from " + (apply string-append (add-between modifiers " of ")) + " in " contract-str))) (let ([blame-src (src-info-as-string src-info)] [formatted-contract-sexp - (let ([one-line - (let ([sp (open-output-string)]) - (parameterize ([pretty-print-columns 'infinity]) - (pretty-print contract-sexp sp) - (get-output-string sp)))]) - (if (< (string-length one-line) 30) - one-line - (let ([sp (open-output-string)]) - (newline sp) - (parameterize ([pretty-print-print-line print-contract-liner] - [pretty-print-columns 50]) - (pretty-print contract-sexp sp)) - (get-output-string sp))))] + (let-values ([(modifiers contract-sexp) + (let loop ([dlist contract-sexp+extra] + [modifiers null]) + (if (and (pair? dlist) + (string? (car dlist))) + (loop (cdr dlist) (cons (car dlist) modifiers)) + (values (reverse modifiers) dlist)))]) + (let ([one-line + (let ([sp (open-output-string)]) + (parameterize ([pretty-print-columns 'infinity]) + (pretty-print contract-sexp sp) + (get-output-string sp)))]) + (if (< (string-length one-line) 30) + (add-modifiers-to-contract modifiers one-line) + (let ([sp (open-output-string)]) + (newline sp) + (parameterize ([pretty-print-print-line print-contract-liner] + [pretty-print-columns 50]) + (pretty-print contract-sexp sp)) + (add-modifiers-to-contract modifiers (get-output-string sp))))))] [specific-blame (cond [(syntax? src-info) @@ -513,4 +527,4 @@ #:property name-prop (λ (ctc) (predicate-contract-name ctc)) #:property flat-prop (λ (ctc) (predicate-contract-pred ctc))) -(define (build-flat-contract name pred) (make-predicate-contract name pred)) \ No newline at end of file +(define (build-flat-contract name pred) (make-predicate-contract name pred)) From 5ca6b6861794cea8dbc55aedede54f1628b3843a Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Wed, 8 Oct 2008 16:58:58 +0000 Subject: [PATCH 68/88] slight rewording svn: r11981 --- collects/scheme/private/contract-guts.ss | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/scheme/private/contract-guts.ss b/collects/scheme/private/contract-guts.ss index 45b99da8a4..19ed7ba2f9 100644 --- a/collects/scheme/private/contract-guts.ss +++ b/collects/scheme/private/contract-guts.ss @@ -180,7 +180,7 @@ (define (add-modifiers-to-contract modifiers contract-str) (if (null? modifiers) contract-str - (string-append "from " + (string-append "for " (apply string-append (add-between modifiers " of ")) " in " contract-str))) (let ([blame-src (src-info-as-string src-info)] From 3212d1171217a93eb2865a602092d5b5d842ff40 Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Fri, 14 Nov 2008 16:48:17 +0000 Subject: [PATCH 69/88] Add all changes from branches/with-contract (which this branch will replace eventually), plus a couple of fixes in contract-test.ss. svn: r12451 --- collects/mzlib/contract.ss | 11 +- collects/mzlib/scribblings/contract.scrbl | 42 +- collects/scheme/private/contract-arrow.ss | 43 +- collects/scheme/private/contract-guts.ss | 52 ++- collects/scheme/private/contract.ss | 371 +++++++++++++----- .../tests/mzscheme/contract-mzlib-test.ss | 20 +- collects/tests/mzscheme/contract-test.ss | 261 +++++++++++- 7 files changed, 652 insertions(+), 148 deletions(-) diff --git a/collects/mzlib/contract.ss b/collects/mzlib/contract.ss index bf96a1caf5..a19188176a 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/mzlib/scribblings/contract.scrbl b/collects/mzlib/scribblings/contract.scrbl index 65dbd92e98..3478296362 100644 --- a/collects/mzlib/scribblings/contract.scrbl +++ b/collects/mzlib/scribblings/contract.scrbl @@ -1,5 +1,7 @@ #lang scribble/doc @(require "common.ss" + scheme/sandbox + scribble/eval scribble/struct (for-label mzlib/contract)) @@ -56,7 +58,6 @@ from @schememodname[scheme/contract]: contract-violation->string contract? define-contract-struct - define/contract false/c flat-contract flat-contract-predicate @@ -91,3 +92,42 @@ from @schememodname[scheme/contract]: vector/c vectorof] +It also provides the old version of @scheme[define/contract]: + +@defform[(define/contract id contract-expr init-value-expr)]{ + +Attaches the contract @scheme[contract-expr] to +@scheme[init-value-expr] and binds that to @scheme[id]. + +The @scheme[define/contract] form treats individual definitions as +units of blame. The definition itself is responsible for positive +(co-variant) positions of the contract and each reference to +@scheme[id] (including those in the initial value expression) must +meet the negative positions of the contract. + +Error messages with @scheme[define/contract] are not as clear as those +provided by @scheme[provide/contract], because +@scheme[define/contract] cannot detect the name of the definition +where the reference to the defined variable occurs. Instead, it uses +the source location of the reference to the variable as the name of +that definition. + +@examples[#:eval (parameterize ([sandbox-output 'string] + [sandbox-error-output 'string] + [sandbox-eval-limits #f]) + (make-evaluator 'mzscheme)) + (require mzlib/contract) + (define/contract f + (-> number? number?) + (lambda (x) (+ x 1))) + (define/contract g + (-> number? number?) + (lambda (x) (f #t))) + (define/contract i + (-> number? number?) + (lambda (x) + (if (number? x) (i #t) 0))) + (f 4) + (f #t) + (g 4) + (i 3)]} diff --git a/collects/scheme/private/contract-arrow.ss b/collects/scheme/private/contract-arrow.ss index 0fcf37a5df..525a24ce19 100644 --- a/collects/scheme/private/contract-arrow.ss +++ b/collects/scheme/private/contract-arrow.ss @@ -102,10 +102,9 @@ v4 todo: #:omit-define-syntaxes #:property proj-prop (λ (ctc) - (let* ([doms-proj (map (λ (x) ((proj-get x) x)) - (if (->-dom-rest/c ctc) - (append (->-doms/c ctc) (list (->-dom-rest/c ctc))) - (->-doms/c ctc)))] + (let* ([doms-proj (map (λ (x) ((proj-get x) x)) (->-doms/c ctc))] + [rest-proj (and (->-dom-rest/c ctc) + ((λ (x) ((proj-get x) x)) (->-dom-rest/c ctc)))] [doms-optional-proj (map (λ (x) ((proj-get x) x)) (->-optional-doms/c ctc))] [rngs-proj (map (λ (x) ((proj-get x) x)) (->-rngs/c ctc))] [mandatory-kwds-proj (map (λ (x) ((proj-get x) x)) (->-mandatory-kwds/c ctc))] @@ -117,22 +116,36 @@ v4 todo: [optionals-length (length (->-optional-doms/c ctc))] [has-rest? (and (->-dom-rest/c ctc) #t)]) (λ (pos-blame neg-blame src-info orig-str) - (let ([partial-doms (map (λ (dom) (dom neg-blame pos-blame src-info orig-str)) - doms-proj)] - [partial-optional-doms (map (λ (dom) (dom neg-blame pos-blame src-info orig-str)) - doms-optional-proj)] - [partial-ranges (map (λ (rng) (rng pos-blame neg-blame src-info orig-str)) - rngs-proj)] - [partial-mandatory-kwds (map (λ (kwd) (kwd neg-blame pos-blame src-info orig-str)) - mandatory-kwds-proj)] - [partial-optional-kwds (map (λ (kwd) (kwd neg-blame pos-blame src-info orig-str)) - optional-kwds-proj)]) + (let ([partial-doms (for/list ([dom (in-list doms-proj)] + [n (in-naturals 1)]) + (dom neg-blame pos-blame src-info + (cons (format "required argument ~a" n) orig-str)))] + [partial-rest (if rest-proj + (list (rest-proj neg-blame pos-blame src-info + (cons "rest argument" orig-str))) + null)] + [partial-optional-doms (for/list ([dom (in-list doms-optional-proj)] + [n (in-naturals 1)]) + (dom neg-blame pos-blame src-info + (cons (format "optional argument ~a" n) orig-str)))] + [partial-ranges (for/list ([rng (in-list rngs-proj)] + [n (in-naturals 1)]) + (rng pos-blame neg-blame src-info + (cons (format "result ~a" n) orig-str)))] + [partial-mandatory-kwds (for/list ([kwd (in-list mandatory-kwds-proj)] + [kwd-lit (in-list mandatory-keywords)]) + (kwd neg-blame pos-blame src-info + (cons (format "keyword argument ~a" kwd-lit) orig-str)))] + [partial-optional-kwds (for/list ([kwd (in-list optional-kwds-proj)] + [kwd-lit (in-list optional-keywords)]) + (kwd neg-blame pos-blame src-info + (cons (format "keyword argument ~a" kwd-lit) orig-str)))]) (apply func (λ (val mtd?) (if has-rest? (check-procedure/more val mtd? dom-length mandatory-keywords optional-keywords src-info pos-blame orig-str) (check-procedure val mtd? dom-length optionals-length mandatory-keywords optional-keywords src-info pos-blame orig-str))) - (append partial-doms partial-optional-doms + (append partial-doms partial-rest partial-optional-doms partial-mandatory-kwds partial-optional-kwds partial-ranges)))))) diff --git a/collects/scheme/private/contract-guts.ss b/collects/scheme/private/contract-guts.ss index 6627e2dee7..185e87eac7 100644 --- a/collects/scheme/private/contract-guts.ss +++ b/collects/scheme/private/contract-guts.ss @@ -1,7 +1,8 @@ #lang scheme/base (require "contract-helpers.ss" - scheme/pretty) + scheme/pretty + (only-in scheme/list add-between)) (require (for-syntax scheme/base "contract-helpers.ss")) @@ -175,23 +176,35 @@ (lambda (x) (get x 0)) (lambda (x) (get x 1))))) -(define (default-contract-violation->string val src-info to-blame contract-sexp msg) +(define (default-contract-violation->string val src-info to-blame contract-sexp+extra msg) + (define (add-modifiers-to-contract modifiers contract-str) + (if (null? modifiers) + contract-str + (string-append "for " + (apply string-append (add-between modifiers " of ")) + " in " contract-str))) (let ([blame-src (src-info-as-string src-info)] [formatted-contract-sexp - (let ([one-line - (let ([sp (open-output-string)]) - (parameterize ([pretty-print-print-line print-contract-liner] - [pretty-print-columns 'infinity]) - (pretty-print contract-sexp sp) - (get-output-string sp)))]) - (if (< (string-length one-line) 30) - one-line - (let ([sp (open-output-string)]) - (newline sp) - (parameterize ([pretty-print-print-line print-contract-liner] - [pretty-print-columns 50]) - (pretty-print contract-sexp sp)) - (get-output-string sp))))] + (let-values ([(modifiers contract-sexp) + (let loop ([dlist contract-sexp+extra] + [modifiers null]) + (if (and (pair? dlist) + (string? (car dlist))) + (loop (cdr dlist) (cons (car dlist) modifiers)) + (values (reverse modifiers) dlist)))]) + (let ([one-line + (let ([sp (open-output-string)]) + (parameterize ([pretty-print-columns 'infinity]) + (pretty-print contract-sexp sp) + (get-output-string sp)))]) + (if (< (string-length one-line) 30) + (add-modifiers-to-contract modifiers one-line) + (let ([sp (open-output-string)]) + (newline sp) + (parameterize ([pretty-print-print-line print-contract-liner] + [pretty-print-columns 50]) + (pretty-print contract-sexp sp)) + (add-modifiers-to-contract modifiers (get-output-string sp))))))] [specific-blame (cond [(syntax? src-info) @@ -210,8 +223,9 @@ (pair? (cdr to-blame)) (null? (cddr to-blame)) (equal? 'quote (car to-blame))) - (format "'~s" (cadr to-blame))] - [else (format "~s" to-blame)]) + (format "module '~s" (cadr to-blame))] + [(string? to-blame) to-blame] + [else (format "module ~s" to-blame)]) formatted-contract-sexp specific-blame) msg))) @@ -516,4 +530,4 @@ #:property name-prop (λ (ctc) (predicate-contract-name ctc)) #:property flat-prop (λ (ctc) (predicate-contract-pred ctc))) -(define (build-flat-contract name pred) (make-predicate-contract name pred)) \ No newline at end of file +(define (build-flat-contract name pred) (make-predicate-contract name pred)) diff --git a/collects/scheme/private/contract.ss b/collects/scheme/private/contract.ss index c8d3d878b8..cee8b900cf 100644 --- a/collects/scheme/private/contract.ss +++ b/collects/scheme/private/contract.ss @@ -12,13 +12,19 @@ improve method arity mismatch contract violation error messages? (provide (rename-out [-contract contract]) recursive-contract provide/contract - define/contract) + define/contract + with-contract + current-contract-region) (require (for-syntax scheme/base) (for-syntax "contract-opt-guts.ss") (for-syntax scheme/struct-info) (for-syntax scheme/list) - scheme/promise) + (for-syntax syntax/define) + (for-syntax syntax/kerncase) + scheme/promise + scheme/stxparam + mzlib/etc) (require "contract-arrow.ss" "contract-guts.ss" @@ -28,6 +34,24 @@ improve method arity mismatch contract violation error messages? (for-syntax (prefix-in a: "contract-helpers.ss"))) +;; These are useful for all below. + +(define-syntax (verify-contract stx) + (syntax-case stx () + [(_ name x) (a:known-good-contract? #'x) #'x] + [(_ name x) #'(coerce-contract name x)])) + +;; id->contract-src-info : identifier -> syntax +;; constructs the last argument to the -contract, given an identifier +(define-for-syntax (id->contract-src-info id) + #`(list (make-srcloc #,id + #,(syntax-line id) + #,(syntax-column id) + #,(syntax-position id) + #,(syntax-span id)) + #,(format "~s" (syntax->datum id)))) + + ; ; @@ -46,6 +70,255 @@ improve method arity mismatch contract violation error messages? ; ; ; +;; (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) + (when (eq? (syntax-local-context) 'expression) + (raise-syntax-error 'define/contract + "used in expression context" + define-stx)) + (syntax-case define-stx () + [(_ name) + (raise-syntax-error 'define/contract + "no contract or body" + define-stx)] + [(_ name contract-expr) + (raise-syntax-error 'define/contract + "no body after contract" + define-stx)] + [(_ name contract-expr expr) + (identifier? #'name) + (let ([contract (if (a:known-good-contract? #'contract-expr) + #'contract-expr + #'(verify-contract 'define/contract contract-expr))]) + (quasisyntax/loc define-stx + (with-contract #:type definition name + ([name #,contract]) + (define name expr))))] + [(_ name contract-expr expr0 expr ...) + (identifier? #'name) + (raise-syntax-error 'define/contract + "multiple expressions after identifier and contract" + define-stx)] + [(_ name+arg-list contract body0 body ...) + (let-values ([(name lam-expr) + (normalize-definition + (datum->syntax #'define-stx (list* 'define/contract #'name+arg-list + #'body0 #'(body ...))) + #'lambda #t #t)]) + (with-syntax ([name name] + [lam-expr lam-expr]) + (syntax/loc define-stx + (with-contract #:type function name + ([name (verify-contract 'define/contract contract)]) + (define name lam-expr)))))])) + + + +; +; +; ; ; +; ; ; ; ; +; ; ; ; ; +; ; ; ; ; ;;;; ; ;;; ;;; ;;; ; ;;; ;;;; ; ;; ;;;; ;;; ;;;; +; ; ; ; ; ; ;; ; ; ; ; ; ;; ; ; ;; ; ; ; ; ; +; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; +; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;;; ; ; +; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;;; ; ; ; +; ; ; ; ; ; ; ; ; ;;;; ; ; ; ; ; ; ; ; ; ; ; +; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; +; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;; ; ; ; +; ; ; ; ;;; ; ; ;;; ;;; ; ; ;;; ; ;;;; ; ;;; ;;; +; +; +; + +(define-syntax-parameter current-contract-region #f) + +(define-for-syntax (make-with-contract-transformer contract-id id pos-blame-id) + (make-set!-transformer + (lambda (stx) + (with-syntax ([neg-blame-id (or (syntax-parameter-value #'current-contract-region) + #'(#%variable-reference))] + [pos-blame-id pos-blame-id] + [contract-id contract-id] + [id id]) + (syntax-case stx (set!) + [(set! id arg) + (raise-syntax-error 'with-contract + "cannot set! a with-contract variable" + stx + (syntax id))] + [(f arg ...) + (syntax/loc stx + ((-contract contract-id + id + pos-blame-id + neg-blame-id + #'f) + arg ...))] + [ident + (identifier? (syntax ident)) + (syntax/loc stx + (-contract contract-id + id + pos-blame-id + neg-blame-id + #'ident))]))))) + +(define-for-syntax (head-expand-all body-stxs) + (for/list ([stx body-stxs]) + (local-expand stx + (syntax-local-context) + (kernel-form-identifier-list)))) + +(define-for-syntax (check-exports ids body-stxs) + (let ([defd-ids (for/fold ([id-list null]) + ([stx body-stxs]) + (kernel-syntax-case stx #f + [(define-values ids expr) + (append (syntax->list #'ids) + id-list)] + [_ id-list]))]) + (for ([id (in-list ids)]) + (unless (findf (lambda (s) + (bound-identifier=? s id)) + defd-ids) + (raise-syntax-error 'with-contract + "identifier not defined in body" + id))))) + +(define-for-syntax (check-and-split-with-contract-args args) + (let loop ([args args] + [unprotected null] + [protected null] + [protections null]) + (cond + [(null? args) + (values unprotected protected protections)] + [(identifier? (car args)) + (loop (cdr args) + (cons (car args) unprotected) + protected + protections)] + [(let ([lst (syntax->list (car args))]) + (and (list? lst) + (= (length lst) 2) + (identifier? (first lst)) + lst)) + => + (lambda (l) + (loop (cdr args) + unprotected + (cons (first l) protected) + (cons (second l) protections)))] + [else + (raise-syntax-error 'with-contract + "expected an identifier or (identifier contract)" + (car args))]))) + +(define-syntax (with-contract stx) + (when (eq? (syntax-local-context) 'expression) + (raise-syntax-error 'with-contract + "used in expression context" + stx)) + (syntax-case stx () + [(_ #:type type blame (arg ...) body0 body ...) + (and (identifier? #'blame) + (identifier? #'type)) + (let*-values ([(unprotected protected protections) + (check-and-split-with-contract-args (syntax->list #'(arg ...)))] + [(expanded-bodies) (head-expand-all (cons #'body0 + (syntax->list #'(body ...))))] + [(protected-ids ids contracts contract-defs) + (for/lists (protected-ids ids contracts contract-defs) + ([n protected] + [c protections]) + (let ([new-id (a:mangle-id stx "with-contract-id" n)]) + (if (a:known-good-contract? c) + (values n new-id c #f) + (let ([contract-id (a:mangle-id stx "with-contract-contract-id" n)]) + (values n new-id contract-id + (quasisyntax/loc stx + (define-values (#,contract-id) + (verify-contract 'with-contract #,c))))))))]) + (begin + (let* ([all-ids (append unprotected protected)] + [dupd-id (check-duplicate-identifier all-ids)]) + (when dupd-id + (raise-syntax-error 'with-contract + "identifier appears twice in exports" + dupd-id)) + (check-exports (append unprotected protected) expanded-bodies)) + (with-syntax ([((protected-id id contract) ...) + (map list protected-ids ids contracts)] + [(contract-def ...) (filter values contract-defs)] + [blame-str (format "~a ~a" (syntax-e #'type) (syntax-e #'blame))] + [(unprotected-id ...) unprotected]) + (quasisyntax/loc stx + (begin + (define-values (unprotected-id ... id ...) + (syntax-parameterize ([current-contract-region blame-str]) + (begin-with-definitions + #,@expanded-bodies + (values unprotected-id ... protected-id ...)))) + contract-def ... + (define-syntax protected-id + (make-with-contract-transformer + (quote-syntax contract) + (quote-syntax id) + blame-str)) ...)))))] + [(_ #:type type blame (arg ...) body0 body ...) + (raise-syntax-error 'with-contract + "expected identifier for blame" + #'blame)] + [(_ #:type type blame (arg ...)) + (identifier? #'blame) + (raise-syntax-error 'with-contract + "empty body" + stx)] + [(_ #:type type blame bad-args etc ...) + (identifier? #'blame) + (raise-syntax-error 'with-contract + "expected list of identifier and/or (identifier contract)" + #'bad-args)] + [(_ #:type type args etc ...) + (not (identifier? #'args)) + (raise-syntax-error 'with-contract + "expected identifier for blame" + #'args)] + [(_ #:type type etc ...) + (not (identifier? #'type)) + (raise-syntax-error 'with-contract + "expected identifier for type" + #'type)] + [(_ #:type type blame) + (raise-syntax-error 'with-contract + "only blame" + stx)] + [(_ etc ...) + (syntax/loc stx + (with-contract #:type region etc ...))])) + +; +; +; +; ; ; ; +; ; ; +; ; ; ; ; +; ; ;; ; ; ;;; ; ; ; ;; ; ;;; ; ;;; ;;; ; ;; ;;;; ; ; ;;; ;;; ;;;; +; ;; ; ;; ; ; ; ; ; ; ;; ; ; ; ; ; ; ; ;; ; ; ;; ; ; ; ; ; +; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; +; ; ; ; ; ; ; ; ; ; ; ;;;;;; ; ; ; ; ; ; ; ; ;;;; ; ; +; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; +; ;; ; ; ; ; ; ; ; ;; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; +; ; ;; ; ;;; ; ; ;; ; ;;;; ; ;;; ;;; ; ; ;; ; ;;;;; ;;; ;; +; ; ; +; ; ; +; ; + + ;; lookup-struct-info : syntax -> (union #f (list syntax syntax (listof syntax) ...)) (define-for-syntax (lookup-struct-info stx provide-stx) (let ([id (syntax-case stx () @@ -59,46 +332,6 @@ improve method arity mismatch contract violation error messages? provide-stx id))))) -(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 - (syntax->datum (quote-syntax f)) - neg-blame-str - (quote-syntax f)) - arg - ...))] - [ident - (identifier? (syntax ident)) - (syntax/loc stx - (-contract contract-id - id - (syntax->datum (quote-syntax ident)) - neg-blame-str - (quote-syntax ident)))]))))) - -;; id->contract-src-info : identifier -> syntax -;; constructs the last argument to the -contract, given an identifier -(define-for-syntax (id->contract-src-info id) - #`(list (make-srcloc #,id - #,(syntax-line id) - #,(syntax-column id) - #,(syntax-position id) - #,(syntax-span id)) - #,(format "~s" (syntax->datum id)))) - (define-for-syntax (make-provide/contract-transformer contract-id id pos-module-source) (make-set!-transformer (let ([saved-id-table (make-hasheq)]) @@ -140,51 +373,6 @@ improve method arity mismatch contract violation error messages? ;; delay expansion until it's a good time to lift expressions: (quasisyntax/loc stx (#%expression #,stx))))))) -;; (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))])) - - -; -; -; -; ; ; ; -; ; ; -; ; ; ; ; -; ; ;; ; ; ;;; ; ; ; ;; ; ;;; ; ;;; ;;; ; ;; ;;;; ; ; ;;; ;;; ;;;; -; ;; ; ;; ; ; ; ; ; ; ;; ; ; ; ; ; ; ; ;; ; ; ;; ; ; ; ; ; -; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; -; ; ; ; ; ; ; ; ; ; ; ;;;;;; ; ; ; ; ; ; ; ; ;;;; ; ; -; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; -; ;; ; ; ; ; ; ; ; ;; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; -; ; ;; ; ;;; ; ; ;; ; ;;;; ; ;;; ;;; ; ; ;; ; ;;;;; ;;; ;; -; ; ; -; ; ; -; ; - ;; (provide/contract p/c-ele ...) ;; p/c-ele = (id expr) | (rename id id expr) | (struct id (id expr) ...) @@ -483,7 +671,7 @@ improve method arity mismatch contract violation error messages? #f (with-syntax ([field-contract-id field-contract-id] [field-contract field-contract]) - #'(define field-contract-id (verify-contract field-contract))))) + #'(define field-contract-id (verify-contract 'provide/contract field-contract))))) field-contract-ids field-contracts))] [(field-contracts ...) field-contracts] @@ -671,7 +859,7 @@ improve method arity mismatch contract violation error messages? #,@(if no-need-to-check-ctrct? (list) - (list #'(define contract-id (verify-contract ctrct)))) + (list #'(define contract-id (verify-contract 'provide/contract ctrct)))) (define-syntax id-rename (make-provide/contract-transformer (quote-syntax contract-id) (quote-syntax id) @@ -691,11 +879,6 @@ improve method arity mismatch contract violation error messages? (begin bodies ...))))])) -(define-syntax (verify-contract stx) - (syntax-case stx () - [(_ x) (a:known-good-contract? #'x) #'x] - [(_ x) #'(coerce-contract 'provide/contract x)])) - (define (make-pc-struct-type struct-name struct:struct-name . ctcs) (let-values ([(struct:struct-name _make _pred _get _set) (make-struct-type struct-name diff --git a/collects/tests/mzscheme/contract-mzlib-test.ss b/collects/tests/mzscheme/contract-mzlib-test.ss index 4d0b8c923d..47e25f73d8 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 diff --git a/collects/tests/mzscheme/contract-test.ss b/collects/tests/mzscheme/contract-test.ss index bdbba39713..4e52ee536b 100644 --- a/collects/tests/mzscheme/contract-test.ss +++ b/collects/tests/mzscheme/contract-test.ss @@ -1,3 +1,4 @@ + (load-relative "loadtest.ss") (Section 'contract) @@ -75,7 +76,7 @@ (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)]))) @@ -97,8 +98,8 @@ (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 @@ -120,7 +121,7 @@ (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) @@ -2160,6 +2161,250 @@ +; +; +; +; ; ;;;; ; +; ;; ; ; ; +; ; ; ; ; ; +; ; ; ; ; ; +; ;; ; ;;; ;;;; ; ; ;; ;;; ; ;;; ;; ; ;; ;;;; ; ;; ;;; ;;; ;;;; +; ; ;; ; ; ; ;; ;;; ; ; ; ; ; ; ; ; ;;; ; ; ;;; ; ; ; ; ; +; ; ; ;;;;; ; ; ; ; ;;;;; ; ; ; ; ; ; ; ; ;; ; ; +; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;; ; ; ; +; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; +; ; ;;; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;; ; ; ; ; +; ;; ; ;;; ;;;;;;;;;; ;;; ;;; ; ;;; ;; ;;; ;;; ;; ;;; ;; ;; ;;; ;; +; +; +; + + (test/spec-passed + 'define/contract1 + '(let () + (define/contract i integer? 1) + i)) + + (test/spec-failed + 'define/contract2 + '(let () + (define/contract i integer? #t) + i) + "definition i") + + (test/spec-failed + 'define/contract3 + '(let () + (define/contract i (-> integer? integer?) (lambda (x) #t)) + (i 1)) + "definition i") + + (test/spec-failed + 'define/contract4 + '(let () + (define/contract i (-> integer? integer?) (lambda (x) 1)) + (i #f)) + "module top-level") + + (test/spec-failed + 'define/contract5 + '(let () + (define/contract (i x) (-> integer? integer?) 1) + (i #f)) + "module top-level") + + (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?) + t) + (contracted-func + "I'm a string constant with side effects" + "ans"))) + + (test/spec-passed + 'define/contract8 + '(let () + (eval '(module contract-test-suite-define1 scheme/base + (require scheme/contract) + (define/contract x string? "a") + 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 scheme/base + (require scheme/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 scheme/base + (require scheme/contract) + (provide foo-dc14) + (define/contract (foo-dc14 n) + (-> number? number?) + (+ n 1)))) + (eval '(module bar-dc14 scheme/base + (require 'foo-dc14) + (foo-dc14 #t))) + (eval '(require 'bar-dc14))) + "module 'bar-dc14") + + (test/spec-failed + 'define/contract15 + '(begin + (eval '(module foo-dc15 scheme/base + (require scheme/contract) + (provide foo-dc15) + (define/contract (foo-dc15 n) + (-> number? number?) + (+ n 1)))) + (eval '(require 'foo-dc15)) + (eval '(foo-dc15 #t))) + "module 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)) + "module 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))) + + ; ; ; @@ -5380,7 +5625,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 @@ -5557,7 +5802,7 @@ so that propagation occurs. (make-s 1 2) [s-a #f]))) (eval '(require 'pc11b-n))) - 'n) + "module 'n") |# (test/spec-passed @@ -5625,7 +5870,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 @@ -5636,7 +5881,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 eca59f6b1d98b59301a68c56f902f571340a5a16 Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Fri, 14 Nov 2008 16:49:10 +0000 Subject: [PATCH 70/88] Missed a file. svn: r12452 --- 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 0000000000..d1f3ea63ed --- /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 1b4d2cb7bf4eb7a3340e8a29b370994d9eaf1b35 Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Fri, 5 Dec 2008 17:47:37 +0000 Subject: [PATCH 71/88] Start on adding contracts to units. Here we're just adding contract(ed) forms, but they're not (yet) used further in. svn: r12711 --- collects/mzlib/private/unit-compiletime.ss | 3 +- collects/mzlib/unit.ss | 41 +++++++++++++++++----- 2 files changed, 34 insertions(+), 10 deletions(-) diff --git a/collects/mzlib/private/unit-compiletime.ss b/collects/mzlib/private/unit-compiletime.ss index f05c7f8691..bf8b306a46 100644 --- a/collects/mzlib/private/unit-compiletime.ss +++ b/collects/mzlib/private/unit-compiletime.ss @@ -95,8 +95,9 @@ ;; (listof identifier) ;; (listof (cons (listof identifier) syntax-object)) ;; (listof (cons (listof identifier) syntax-object)) + ;; (listof (cons identifier syntax-object)) ;; identifier) - (define-struct/proc signature (siginfo vars val-defs stx-defs orig-binder) + (define-struct/proc signature (siginfo vars val-defs stx-defs ctc-pairs orig-binder) (lambda (_ stx) (parameterize ((error-syntax stx)) (raise-stx-err "illegal use of signature name")))) diff --git a/collects/mzlib/unit.ss b/collects/mzlib/unit.ss index 593155f322..8a2d8299c8 100644 --- a/collects/mzlib/unit.ss +++ b/collects/mzlib/unit.ss @@ -164,13 +164,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 +184,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 +209,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 +229,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 +269,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 +288,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 beb5f195300b0db3dda7c4f8273563ecaeba65f0 Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Fri, 5 Dec 2008 17:55:47 +0000 Subject: [PATCH 72/88] Now to move the contract info appropriately into sigs from signatures. svn: r12712 --- collects/mzlib/private/unit-compiletime.ss | 20 +++++++++++++++++--- collects/mzlib/unit.ss | 3 ++- 2 files changed, 19 insertions(+), 4 deletions(-) diff --git a/collects/mzlib/private/unit-compiletime.ss b/collects/mzlib/private/unit-compiletime.ss index bf8b306a46..079764d012 100644 --- a/collects/mzlib/private/unit-compiletime.ss +++ b/collects/mzlib/private/unit-compiletime.ss @@ -57,8 +57,10 @@ ;; - (cons identifier identifier) ;; A def is ;; - (listof (cons (listof int/ext) syntax-object)) + ;; A ctc-pair is + ;; - (cons int/ext syntax-object) ;; A sig is - ;; - (list (listof int/ext) (listof def) (listof def)) + ;; - (list (listof int/ext) (listof def) (listof def) (listof ctc-pair)) ;; A tagged-sig is ;; - (listof (cons #f siginfo) (cons #f identifier) sig) ;; - (listof (cons symbol siginfo) (cons symbol identifier) sig) @@ -220,6 +222,7 @@ (vars (signature-vars sig)) (vals (signature-val-defs sig)) (stxs (signature-stx-defs sig)) + (cps (signature-ctc-pairs sig)) (delta-introduce (if bind? (let ([f (syntax-local-make-delta-introducer spec)]) @@ -244,7 +247,12 @@ (cons (map (λ (id) (cons id id)) (car stx)) (cdr stx))) - stxs))))) + stxs) + (map + (λ (cp) + (cons (cons (car cp) (car cp)) + (cdr cp))) + cps))))) (define (sig-names sig) (append (car sig) @@ -265,12 +273,18 @@ (car def)) (g (cdr def)))) + ;; map-ctc-pair : (identifier -> identifier) (syntax-object -> syntax-object) ctc-pair -> ctc-pair + (define (map-ctc-pair f g cp) + (cons (cons (f (caar cp)) (g (cdar cp))) + (g (cdr cp)))) + ;; map-sig : (identifier -> identifier) (sytnax-object -> syntax-object) sig -> sig ;; applies f to the internal parts, and g to the external parts. (define (map-sig f g sig) (list (map (lambda (x) (cons (f (car x)) (g (cdr x)))) (car sig)) (map (lambda (x) (map-def f g x)) (cadr sig)) - (map (lambda (x) (map-def f g x)) (caddr sig)))) + (map (lambda (x) (map-def f g x)) (caddr sig)) + (map (lambda (x) (map-ctc-pair f g x)) (cadddr sig)))) ;; An import-spec is one of ;; - signature-name diff --git a/collects/mzlib/unit.ss b/collects/mzlib/unit.ss index 8a2d8299c8..48ba22921b 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 52b76b8dfafcb2f284db19fd6d9b3c8da87420ce Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Mon, 8 Dec 2008 17:09:33 +0000 Subject: [PATCH 73/88] Removing the work that's now on unit-contracts. svn: r12744 --- collects/mzlib/private/unit-compiletime.ss | 23 ++--------- collects/mzlib/unit.ss | 44 +++++----------------- 2 files changed, 14 insertions(+), 53 deletions(-) diff --git a/collects/mzlib/private/unit-compiletime.ss b/collects/mzlib/private/unit-compiletime.ss index 079764d012..f05c7f8691 100644 --- a/collects/mzlib/private/unit-compiletime.ss +++ b/collects/mzlib/private/unit-compiletime.ss @@ -57,10 +57,8 @@ ;; - (cons identifier identifier) ;; A def is ;; - (listof (cons (listof int/ext) syntax-object)) - ;; A ctc-pair is - ;; - (cons int/ext syntax-object) ;; A sig is - ;; - (list (listof int/ext) (listof def) (listof def) (listof ctc-pair)) + ;; - (list (listof int/ext) (listof def) (listof def)) ;; A tagged-sig is ;; - (listof (cons #f siginfo) (cons #f identifier) sig) ;; - (listof (cons symbol siginfo) (cons symbol identifier) sig) @@ -97,9 +95,8 @@ ;; (listof identifier) ;; (listof (cons (listof identifier) syntax-object)) ;; (listof (cons (listof identifier) syntax-object)) - ;; (listof (cons identifier syntax-object)) ;; identifier) - (define-struct/proc signature (siginfo vars val-defs stx-defs ctc-pairs orig-binder) + (define-struct/proc signature (siginfo vars val-defs stx-defs orig-binder) (lambda (_ stx) (parameterize ((error-syntax stx)) (raise-stx-err "illegal use of signature name")))) @@ -222,7 +219,6 @@ (vars (signature-vars sig)) (vals (signature-val-defs sig)) (stxs (signature-stx-defs sig)) - (cps (signature-ctc-pairs sig)) (delta-introduce (if bind? (let ([f (syntax-local-make-delta-introducer spec)]) @@ -247,12 +243,7 @@ (cons (map (λ (id) (cons id id)) (car stx)) (cdr stx))) - stxs) - (map - (λ (cp) - (cons (cons (car cp) (car cp)) - (cdr cp))) - cps))))) + stxs))))) (define (sig-names sig) (append (car sig) @@ -273,18 +264,12 @@ (car def)) (g (cdr def)))) - ;; map-ctc-pair : (identifier -> identifier) (syntax-object -> syntax-object) ctc-pair -> ctc-pair - (define (map-ctc-pair f g cp) - (cons (cons (f (caar cp)) (g (cdar cp))) - (g (cdr cp)))) - ;; map-sig : (identifier -> identifier) (sytnax-object -> syntax-object) sig -> sig ;; applies f to the internal parts, and g to the external parts. (define (map-sig f g sig) (list (map (lambda (x) (cons (f (car x)) (g (cdr x)))) (car sig)) (map (lambda (x) (map-def f g x)) (cadr sig)) - (map (lambda (x) (map-def f g x)) (caddr sig)) - (map (lambda (x) (map-ctc-pair f g x)) (cadddr sig)))) + (map (lambda (x) (map-def f g x)) (caddr sig)))) ;; An import-spec is one of ;; - signature-name diff --git a/collects/mzlib/unit.ss b/collects/mzlib/unit.ss index 48ba22921b..593155f322 100644 --- a/collects/mzlib/unit.ss +++ b/collects/mzlib/unit.ss @@ -123,8 +123,7 @@ (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-cid . ext-cid) . cbody) ...)) + ((((int-sid . ext-sid) ...) . sbody) ...)) (map-sig (lambda (x) x) (make-syntax-introducer) sig)]) @@ -165,17 +164,13 @@ (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-ctc-pairs) + super-val-defs super-stx-defs) (if super-sigid (let* ([super-sig (lookup-signature super-sigid)] [super-siginfo (signature-siginfo super-sig)]) @@ -185,20 +180,17 @@ (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)) - (map introduce-ctc-pair (signature-ctc-pairs super-sig)))) - (values '() '() '() '() '() '() '()))) + (map introduce-def (signature-stx-defs super-sig)))) + (values '() '() '() '() '() '()))) (let loop ((sig-exprs ses) (bindings null) (val-defs null) - (stx-defs null) - (ctc-pairs null)) + (stx-defs 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 @@ -210,8 +202,7 @@ ((super-name ...) super-names) ((var ...) all-bindings) ((((vid ...) . vbody) ...) all-val-defs) - ((((sid ...) . sbody) ...) all-stx-defs) - (((cid . cbody) ...) all-ctc-pairs)) + ((((sid ...) . sbody) ...) all-stx-defs)) #`(begin (define signature-tag (gensym)) (define-syntax #,sigid @@ -230,25 +221,12 @@ ((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 contracted) + (syntax-case (car sig-exprs) (define-values define-syntaxes) (x (identifier? #'x) - (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))) + (loop (cdr sig-exprs) (cons #'x bindings) val-defs stx-defs)) ((x . y) (and (identifier? #'x) (or (module-identifier=? #'x #'define-values) @@ -270,8 +248,7 @@ (if (module-identifier=? #'x #'define-syntaxes) (cons (cons (syntax->list #'(name ...)) b) stx-defs) - stx-defs) - ctc-pairs))))))) + stx-defs)))))))) ((x . y) (let ((trans (set!-trans-extract @@ -289,8 +266,7 @@ (loop (append results (cdr sig-exprs)) bindings val-defs - stx-defs - ctc-pairs)))) + stx-defs)))) (x (raise-stx-err "expected either an identifier or signature form" #'x)))))))) From 29487b251e4f0813c7c2f49d466eb473a19b9c57 Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Thu, 18 Dec 2008 17:13:13 +0000 Subject: [PATCH 74/88] I guess this documentation got lost at some point during the various branch moves, so add it back. svn: r12888 --- collects/mzlib/scribblings/contract.scrbl | 22 +----------- .../scribblings/reference/contracts.scrbl | 35 +++++++++++++------ 2 files changed, 25 insertions(+), 32 deletions(-) diff --git a/collects/mzlib/scribblings/contract.scrbl b/collects/mzlib/scribblings/contract.scrbl index 3478296362..884c553c44 100644 --- a/collects/mzlib/scribblings/contract.scrbl +++ b/collects/mzlib/scribblings/contract.scrbl @@ -110,24 +110,4 @@ provided by @scheme[provide/contract], because @scheme[define/contract] cannot detect the name of the definition where the reference to the defined variable occurs. Instead, it uses the source location of the reference to the variable as the name of -that definition. - -@examples[#:eval (parameterize ([sandbox-output 'string] - [sandbox-error-output 'string] - [sandbox-eval-limits #f]) - (make-evaluator 'mzscheme)) - (require mzlib/contract) - (define/contract f - (-> number? number?) - (lambda (x) (+ x 1))) - (define/contract g - (-> number? number?) - (lambda (x) (f #t))) - (define/contract i - (-> number? number?) - (lambda (x) - (if (number? x) (i #t) 0))) - (f 4) - (f #t) - (g 4) - (i 3)]} +that definition.} diff --git a/collects/scribblings/reference/contracts.scrbl b/collects/scribblings/reference/contracts.scrbl index ff8c1b6ff0..bf1495a6dd 100644 --- a/collects/scribblings/reference/contracts.scrbl +++ b/collects/scribblings/reference/contracts.scrbl @@ -661,23 +661,36 @@ contract on the fields that the sub-struct shares with its parent are only used in the contract for the sub-struct's maker, and the selector or mutators for the super-struct are not provided.} -@defform[(define/contract id contract-expr init-value-expr)]{ +@defform/subs[ + (with-contract blame-id (wc-export ...) body ...+) + ([wc-export + id + (id contract-expr)])]{ +Generates a local contract boundary. The @scheme[contract-expr] +form cannot appear in expression position. The @scheme[body] of the +form allows definition/expression interleaving like a @scheme[module] +body. Names bound within the @scheme[body] must be exported to be +accessible from outside the @scheme[with-contract] form. Such +@scheme[id]s can either be paired with a @scheme[contract-expr] or +exported without a contract. -Attaches the contract @scheme[contract-expr] to -@scheme[init-value-expr] and binds that to @scheme[id]. +The @scheme[blame-id] is used for the positive positions of +contracts paired with exported @scheme[id]s. Contracts broken +within the @scheme[with-contract] @scheme[body] will use the +@scheme[blame-id] for their negative position.} + +@defform*[[(define/contract id contract-expr init-value-expr) + (define/contract (head args) contract-expr body ...+)]]{ +Works like @scheme[define], except that the contract +@scheme[contract-expr] is attached to the bound value. The @scheme[define/contract] form treats individual definitions as units of blame. The definition itself is responsible for positive (co-variant) positions of the contract and each reference to @scheme[id] (including those in the initial value expression) must -meet the negative positions of the contract. - -Error messages with @scheme[define/contract] are not as clear as those -provided by @scheme[provide/contract], because -@scheme[define/contract] cannot detect the name of the definition -where the reference to the defined variable occurs. Instead, it uses -the source location of the reference to the variable as the name of -that definition.} +meet the negative positions of the contract. It is equivalent to +wrapping a single @scheme[define] with a @scheme[with-contract] form +that pairs the @scheme[contract-expr] with the bound identifier.} @defform*[[(contract contract-expr to-protect-expr positive-blame-expr negative-blame-expr) From 51da9beab4e87d9358fd870f2e32baf779729fdc Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Tue, 13 Jan 2009 19:01:21 +0000 Subject: [PATCH 75/88] This is a change I was toying with that shouldn't have gotten caught up in the trunk sync of 13084. svn: r13088 --- collects/scheme/private/contract.ss | 124 +++++++++++++++++----------- 1 file changed, 78 insertions(+), 46 deletions(-) diff --git a/collects/scheme/private/contract.ss b/collects/scheme/private/contract.ss index 1faade5843..abf622217c 100644 --- a/collects/scheme/private/contract.ss +++ b/collects/scheme/private/contract.ss @@ -51,48 +51,7 @@ improve method arity mismatch contract violation error messages? #,(syntax-span id)) #,(format "~s" (syntax->datum id)))) -(define-for-syntax (make-contracted-transformer contract-id id pos-module-source) - (make-set!-transformer - (let ([saved-id-table (make-hasheq)]) - (λ (stx) - (if (eq? 'expression (syntax-local-context)) - ;; In an expression context: - (let ([key (syntax-local-lift-context)]) - ;; Already lifted in this lifting context? - (let ([lifted-id - (or (hash-ref saved-id-table key #f) - ;; No: lift the contract creation: - (with-syntax ([contract-id contract-id] - [id id] - [neg-blame-id (or (syntax-parameter-value #'current-contract-region) - #'(#%variable-reference))] - [pos-module-source pos-module-source]) - (syntax-local-introduce - (syntax-local-lift-expression - #`(-contract contract-id - id - pos-module-source - neg-blame-id - #,(id->contract-src-info #'id))))))]) - (when key - (hash-set! saved-id-table key lifted-id)) - ;; Expand to a use of the lifted expression: - (with-syntax ([saved-id (syntax-local-introduce lifted-id)]) - (syntax-case stx (set!) - [name - (identifier? (syntax name)) - (syntax saved-id)] - [(set! id arg) - (raise-syntax-error 'provide/contract - "cannot set! a contracted variable" - stx - (syntax id))] - [(name . more) - (with-syntax ([app (datum->syntax stx '#%app)]) - (syntax/loc stx (app saved-id . more)))])))) - ;; In case of partial expansion for module-level and internal-defn contexts, - ;; delay expansion until it's a good time to lift expressions: - (quasisyntax/loc stx (#%expression #,stx))))))) + ; ; @@ -177,6 +136,37 @@ improve method arity mismatch contract violation error messages? (define-syntax-parameter current-contract-region #f) +(define-for-syntax (make-with-contract-transformer contract-id id pos-blame-id) + (make-set!-transformer + (lambda (stx) + (with-syntax ([neg-blame-id (or (syntax-parameter-value #'current-contract-region) + #'(#%variable-reference))] + [pos-blame-id pos-blame-id] + [contract-id contract-id] + [id id]) + (syntax-case stx (set!) + [(set! id arg) + (raise-syntax-error 'with-contract + "cannot set! a with-contract variable" + stx + (syntax id))] + [(f arg ...) + (syntax/loc stx + ((-contract contract-id + id + pos-blame-id + neg-blame-id + #'f) + arg ...))] + [ident + (identifier? (syntax ident)) + (syntax/loc stx + (-contract contract-id + id + pos-blame-id + neg-blame-id + #'ident))]))))) + (define-for-syntax (head-expand-all body-stxs) (for/list ([stx body-stxs]) (local-expand stx @@ -275,7 +265,7 @@ improve method arity mismatch contract violation error messages? (values unprotected-id ... protected-id ...)))) contract-def ... (define-syntax protected-id - (make-contracted-transformer + (make-with-contract-transformer (quote-syntax contract) (quote-syntax id) blame-str)) ...)))))] @@ -342,6 +332,48 @@ improve method arity mismatch contract violation error messages? provide-stx id))))) +(define-for-syntax (make-provide/contract-transformer contract-id id pos-module-source) + (make-set!-transformer + (let ([saved-id-table (make-hasheq)]) + (λ (stx) + (if (eq? 'expression (syntax-local-context)) + ;; In an expression context: + (let ([key (syntax-local-lift-context)]) + ;; Already lifted in this lifting context? + (let ([lifted-id + (or (hash-ref saved-id-table key #f) + ;; No: lift the contract creation: + (with-syntax ([contract-id contract-id] + [id id] + [pos-module-source pos-module-source]) + (syntax-local-introduce + (syntax-local-lift-expression + #`(-contract contract-id + id + pos-module-source + (#%variable-reference) + #,(id->contract-src-info #'id))))))]) + (when key + (hash-set! saved-id-table key lifted-id)) + ;; Expand to a use of the lifted expression: + (with-syntax ([saved-id (syntax-local-introduce lifted-id)]) + (syntax-case stx (set!) + [name + (identifier? (syntax name)) + (syntax saved-id)] + [(set! id arg) + (raise-syntax-error 'provide/contract + "cannot set! a provide/contract variable" + stx + (syntax id))] + [(name . more) + (with-syntax ([app (datum->syntax stx '#%app)]) + (syntax/loc stx (app saved-id . more)))])))) + ;; In case of partial expansion for module-level and internal-defn contexts, + ;; delay expansion until it's a good time to lift expressions: + (quasisyntax/loc stx (#%expression #,stx))))))) + + ;; (provide/contract p/c-ele ...) ;; p/c-ele = (id expr) | (rename id id expr) | (struct id (id expr) ...) ;; provides each `id' with the contract `expr'. @@ -829,9 +861,9 @@ improve method arity mismatch contract violation error messages? (list) (list #'(define contract-id (verify-contract 'provide/contract ctrct)))) (define-syntax id-rename - (make-contracted-transformer (quote-syntax contract-id) - (quote-syntax id) - (quote-syntax pos-module-source))) + (make-provide/contract-transformer (quote-syntax contract-id) + (quote-syntax id) + (quote-syntax pos-module-source))) (provide (rename-out [id-rename external-name]))))]) From 909dd82f7c20e5e38302cd5af20fd5ae65b6b11b Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Tue, 13 Jan 2009 19:36:54 +0000 Subject: [PATCH 76/88] Using splicing-syntax-parameterize and a syntax-introducer instead of what I had originally. svn: r13089 --- collects/scheme/private/contract.ss | 67 ++++++++++++++++------------- 1 file changed, 36 insertions(+), 31 deletions(-) diff --git a/collects/scheme/private/contract.ss b/collects/scheme/private/contract.ss index abf622217c..45ef42b3a2 100644 --- a/collects/scheme/private/contract.ss +++ b/collects/scheme/private/contract.ss @@ -24,6 +24,7 @@ improve method arity mismatch contract violation error messages? (for-syntax syntax/kerncase) scheme/promise scheme/stxparam + scheme/splicing mzlib/etc) (require "contract-arrow.ss" @@ -168,10 +169,16 @@ improve method arity mismatch contract violation error messages? #'ident))]))))) (define-for-syntax (head-expand-all body-stxs) - (for/list ([stx body-stxs]) - (local-expand stx - (syntax-local-context) - (kernel-form-identifier-list)))) + (apply append + (for/list ([stx body-stxs]) + (let ([exp-form (local-expand stx + (syntax-local-context) + (kernel-form-identifier-list))]) + (syntax-case exp-form (begin) + [(begin form ...) + (head-expand-all (syntax->list #'(form ...)))] + [_ + (list exp-form)]))))) (define-for-syntax (check-exports ids body-stxs) (let ([defd-ids (for/fold ([id-list null]) @@ -227,22 +234,22 @@ improve method arity mismatch contract violation error messages? [(_ #:type type blame (arg ...) body0 body ...) (and (identifier? #'blame) (identifier? #'type)) - (let*-values ([(unprotected protected protections) + (let*-values ([(marker) (make-syntax-introducer)] + [(unprotected protected protections) (check-and-split-with-contract-args (syntax->list #'(arg ...)))] - [(expanded-bodies) (head-expand-all (cons #'body0 - (syntax->list #'(body ...))))] - [(protected-ids ids contracts contract-defs) - (for/lists (protected-ids ids contracts contract-defs) + [(expanded-bodies) + (head-expand-all (cons #'body0 (syntax->list #'(body ...))))] + [(protected-ids contracts contract-defs) + (for/lists (protected-ids contracts contract-defs) ([n protected] [c protections]) - (let ([new-id (a:mangle-id stx "with-contract-id" n)]) - (if (a:known-good-contract? c) - (values n new-id c #f) - (let ([contract-id (a:mangle-id stx "with-contract-contract-id" n)]) - (values n new-id contract-id - (quasisyntax/loc stx - (define-values (#,contract-id) - (verify-contract 'with-contract #,c))))))))]) + (if (a:known-good-contract? c) + (values n c #f) + (let ([contract-id (a:mangle-id stx "with-contract-contract-id" n)]) + (values n contract-id + (quasisyntax/loc stx + (define-values (#,contract-id) + (verify-contract 'with-contract #,c)))))))]) (begin (let* ([all-ids (append unprotected protected)] [dupd-id (check-duplicate-identifier all-ids)]) @@ -251,24 +258,22 @@ improve method arity mismatch contract violation error messages? "identifier appears twice in exports" dupd-id)) (check-exports (append unprotected protected) expanded-bodies)) - (with-syntax ([((protected-id id contract) ...) - (map list protected-ids ids contracts)] - [(contract-def ...) (filter values contract-defs)] + (with-syntax ([(contract-def ...) (map marker (filter values contract-defs))] [blame-str (format "~a ~a" (syntax-e #'type) (syntax-e #'blame))] + [(marked-body ...) (map marker expanded-bodies)] [(unprotected-id ...) unprotected]) (quasisyntax/loc stx - (begin - (define-values (unprotected-id ... id ...) - (syntax-parameterize ([current-contract-region blame-str]) - (begin-with-definitions - #,@expanded-bodies - (values unprotected-id ... protected-id ...)))) + (splicing-syntax-parameterize ([current-contract-region blame-str]) + marked-body ... contract-def ... - (define-syntax protected-id - (make-with-contract-transformer - (quote-syntax contract) - (quote-syntax id) - blame-str)) ...)))))] + #,@(map (λ (p c) + #`(define-syntax #,p + (make-with-contract-transformer + (quote-syntax #,(if c (marker c) c)) + (quote-syntax #,(marker p)) + blame-str))) + protected-ids contracts) + )))))] [(_ #:type type blame (arg ...) body0 body ...) (raise-syntax-error 'with-contract "expected identifier for blame" From 1cede752f9a63eb2125ce759de53d5c68cf91026 Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Tue, 13 Jan 2009 19:41:52 +0000 Subject: [PATCH 77/88] Not sure whether we want just a simple rename transformer for non-contracted ids or whether we really want a set! transformer that still disallows set!ing. Hmm. svn: r13090 --- collects/scheme/private/contract.ss | 13 ++++++++----- 1 file changed, 8 insertions(+), 5 deletions(-) diff --git a/collects/scheme/private/contract.ss b/collects/scheme/private/contract.ss index 45ef42b3a2..088c5695ae 100644 --- a/collects/scheme/private/contract.ss +++ b/collects/scheme/private/contract.ss @@ -267,11 +267,14 @@ improve method arity mismatch contract violation error messages? marked-body ... contract-def ... #,@(map (λ (p c) - #`(define-syntax #,p - (make-with-contract-transformer - (quote-syntax #,(if c (marker c) c)) - (quote-syntax #,(marker p)) - blame-str))) + (if c + #`(define-syntax #,p + (make-with-contract-transformer + (quote-syntax #,(marker c)) + (quote-syntax #,(marker p)) + blame-str)) + #`(define-syntax #,p + (make-rename-transformer #,(marker p))))) protected-ids contracts) )))))] [(_ #:type type blame (arg ...) body0 body ...) From 4899d91b9761ad12f4012fa974c0c89ceba5ebd2 Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Tue, 13 Jan 2009 20:40:36 +0000 Subject: [PATCH 78/88] Lacked unprotected ids, and c should have never been false here anyway. svn: r13093 --- collects/scheme/private/contract.ss | 20 ++++++++++---------- 1 file changed, 10 insertions(+), 10 deletions(-) diff --git a/collects/scheme/private/contract.ss b/collects/scheme/private/contract.ss index 088c5695ae..87da95ec19 100644 --- a/collects/scheme/private/contract.ss +++ b/collects/scheme/private/contract.ss @@ -260,22 +260,22 @@ improve method arity mismatch contract violation error messages? (check-exports (append unprotected protected) expanded-bodies)) (with-syntax ([(contract-def ...) (map marker (filter values contract-defs))] [blame-str (format "~a ~a" (syntax-e #'type) (syntax-e #'blame))] - [(marked-body ...) (map marker expanded-bodies)] - [(unprotected-id ...) unprotected]) + [(marked-body ...) (map marker expanded-bodies)]) (quasisyntax/loc stx (splicing-syntax-parameterize ([current-contract-region blame-str]) marked-body ... contract-def ... #,@(map (λ (p c) - (if c - #`(define-syntax #,p - (make-with-contract-transformer - (quote-syntax #,(marker c)) - (quote-syntax #,(marker p)) - blame-str)) - #`(define-syntax #,p - (make-rename-transformer #,(marker p))))) + #`(define-syntax #,p + (make-with-contract-transformer + (quote-syntax #,(marker c)) + (quote-syntax #,(marker p)) + blame-str))) protected-ids contracts) + #,@(map (λ (u) + #`(define-syntax #,u + (make-rename-transformer #,(marker u)))) + unprotected) )))))] [(_ #:type type blame (arg ...) body0 body ...) (raise-syntax-error 'with-contract From 455999eaddfce827c0d3f5505c4f16a297a9dcd8 Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Tue, 13 Jan 2009 20:52:58 +0000 Subject: [PATCH 79/88] Add first-order contract checking at definition time. svn: r13095 --- collects/scheme/private/contract.ss | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/collects/scheme/private/contract.ss b/collects/scheme/private/contract.ss index 87da95ec19..b159b6858e 100644 --- a/collects/scheme/private/contract.ss +++ b/collects/scheme/private/contract.ss @@ -276,6 +276,12 @@ improve method arity mismatch contract violation error messages? #`(define-syntax #,u (make-rename-transformer #,(marker u)))) unprotected) + (define-values () + (begin + #,@(map (λ (p c) + #`(-contract #,(marker c) #,p blame-str 'ignored #,(id->contract-src-info p))) + protected-ids contracts) + (values))) )))))] [(_ #:type type blame (arg ...) body0 body ...) (raise-syntax-error 'with-contract From 9facb3ffaf762961313598ef0ea066dbed7aa416 Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Wed, 14 Jan 2009 20:58:38 +0000 Subject: [PATCH 80/88] Forgot a quote-syntax here, so unprotected ids weren't being transformed correctly. svn: r13121 --- collects/scheme/private/contract.ss | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/scheme/private/contract.ss b/collects/scheme/private/contract.ss index b159b6858e..71b8d9c6b8 100644 --- a/collects/scheme/private/contract.ss +++ b/collects/scheme/private/contract.ss @@ -274,7 +274,7 @@ improve method arity mismatch contract violation error messages? protected-ids contracts) #,@(map (λ (u) #`(define-syntax #,u - (make-rename-transformer #,(marker u)))) + (make-rename-transformer (quote-syntax #,(marker u))))) unprotected) (define-values () (begin From 8ef9977f571e0603e1deba77262943366414f45f Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Wed, 14 Jan 2009 21:21:59 +0000 Subject: [PATCH 81/88] Change contract error reporting back to how it was (at least how it is on unit-contracts, which avoids the spacing issue), and just change the blame notation so that we can still report the region/definition stuff. svn: r13122 --- collects/scheme/private/contract-arrow.ss | 43 +++++++------------- collects/scheme/private/contract-guts.ss | 49 ++++++++--------------- collects/scheme/private/contract.ss | 13 +++--- 3 files changed, 38 insertions(+), 67 deletions(-) diff --git a/collects/scheme/private/contract-arrow.ss b/collects/scheme/private/contract-arrow.ss index e29ee7f22c..ed9a29eda4 100644 --- a/collects/scheme/private/contract-arrow.ss +++ b/collects/scheme/private/contract-arrow.ss @@ -102,9 +102,10 @@ v4 todo: #:omit-define-syntaxes #:property proj-prop (λ (ctc) - (let* ([doms-proj (map (λ (x) ((proj-get x) x)) (->-doms/c ctc))] - [rest-proj (and (->-dom-rest/c ctc) - ((λ (x) ((proj-get x) x)) (->-dom-rest/c ctc)))] + (let* ([doms-proj (map (λ (x) ((proj-get x) x)) + (if (->-dom-rest/c ctc) + (append (->-doms/c ctc) (list (->-dom-rest/c ctc))) + (->-doms/c ctc)))] [doms-optional-proj (map (λ (x) ((proj-get x) x)) (->-optional-doms/c ctc))] [rngs-proj (map (λ (x) ((proj-get x) x)) (->-rngs/c ctc))] [mandatory-kwds-proj (map (λ (x) ((proj-get x) x)) (->-mandatory-kwds/c ctc))] @@ -116,36 +117,22 @@ v4 todo: [optionals-length (length (->-optional-doms/c ctc))] [has-rest? (and (->-dom-rest/c ctc) #t)]) (λ (pos-blame neg-blame src-info orig-str) - (let ([partial-doms (for/list ([dom (in-list doms-proj)] - [n (in-naturals 1)]) - (dom neg-blame pos-blame src-info - (cons (format "required argument ~a" n) orig-str)))] - [partial-rest (if rest-proj - (list (rest-proj neg-blame pos-blame src-info - (cons "rest argument" orig-str))) - null)] - [partial-optional-doms (for/list ([dom (in-list doms-optional-proj)] - [n (in-naturals 1)]) - (dom neg-blame pos-blame src-info - (cons (format "optional argument ~a" n) orig-str)))] - [partial-ranges (for/list ([rng (in-list rngs-proj)] - [n (in-naturals 1)]) - (rng pos-blame neg-blame src-info - (cons (format "result ~a" n) orig-str)))] - [partial-mandatory-kwds (for/list ([kwd (in-list mandatory-kwds-proj)] - [kwd-lit (in-list mandatory-keywords)]) - (kwd neg-blame pos-blame src-info - (cons (format "keyword argument ~a" kwd-lit) orig-str)))] - [partial-optional-kwds (for/list ([kwd (in-list optional-kwds-proj)] - [kwd-lit (in-list optional-keywords)]) - (kwd neg-blame pos-blame src-info - (cons (format "keyword argument ~a" kwd-lit) orig-str)))]) + (let ([partial-doms (map (λ (dom) (dom neg-blame pos-blame src-info orig-str)) + doms-proj)] + [partial-optional-doms (map (λ (dom) (dom neg-blame pos-blame src-info orig-str)) + doms-optional-proj)] + [partial-ranges (map (λ (rng) (rng pos-blame neg-blame src-info orig-str)) + rngs-proj)] + [partial-mandatory-kwds (map (λ (kwd) (kwd neg-blame pos-blame src-info orig-str)) + mandatory-kwds-proj)] + [partial-optional-kwds (map (λ (kwd) (kwd neg-blame pos-blame src-info orig-str)) + optional-kwds-proj)]) (apply func (λ (val mtd?) (if has-rest? (check-procedure/more val mtd? dom-length mandatory-keywords optional-keywords src-info pos-blame orig-str) (check-procedure val mtd? dom-length optionals-length mandatory-keywords optional-keywords src-info pos-blame orig-str))) - (append partial-doms partial-rest partial-optional-doms + (append partial-doms partial-optional-doms partial-mandatory-kwds partial-optional-kwds partial-ranges)))))) diff --git a/collects/scheme/private/contract-guts.ss b/collects/scheme/private/contract-guts.ss index 185e87eac7..b998a7521e 100644 --- a/collects/scheme/private/contract-guts.ss +++ b/collects/scheme/private/contract-guts.ss @@ -1,8 +1,7 @@ #lang scheme/base (require "contract-helpers.ss" - scheme/pretty - (only-in scheme/list add-between)) + scheme/pretty) (require (for-syntax scheme/base "contract-helpers.ss")) @@ -176,35 +175,22 @@ (lambda (x) (get x 0)) (lambda (x) (get x 1))))) -(define (default-contract-violation->string val src-info to-blame contract-sexp+extra msg) - (define (add-modifiers-to-contract modifiers contract-str) - (if (null? modifiers) - contract-str - (string-append "for " - (apply string-append (add-between modifiers " of ")) - " in " contract-str))) +(define (default-contract-violation->string val src-info to-blame contract-sexp msg) (let ([blame-src (src-info-as-string src-info)] [formatted-contract-sexp - (let-values ([(modifiers contract-sexp) - (let loop ([dlist contract-sexp+extra] - [modifiers null]) - (if (and (pair? dlist) - (string? (car dlist))) - (loop (cdr dlist) (cons (car dlist) modifiers)) - (values (reverse modifiers) dlist)))]) - (let ([one-line - (let ([sp (open-output-string)]) - (parameterize ([pretty-print-columns 'infinity]) - (pretty-print contract-sexp sp) - (get-output-string sp)))]) - (if (< (string-length one-line) 30) - (add-modifiers-to-contract modifiers one-line) - (let ([sp (open-output-string)]) - (newline sp) - (parameterize ([pretty-print-print-line print-contract-liner] - [pretty-print-columns 50]) - (pretty-print contract-sexp sp)) - (add-modifiers-to-contract modifiers (get-output-string sp))))))] + (let ([one-line + (let ([sp (open-output-string)]) + (parameterize ([pretty-print-columns 'infinity]) + (pretty-print contract-sexp sp) + (get-output-string sp)))]) + (if (< (string-length one-line) 30) + one-line + (let ([sp (open-output-string)]) + (newline sp) + (parameterize ([pretty-print-print-line print-contract-liner] + [pretty-print-columns 50]) + (pretty-print contract-sexp sp)) + (get-output-string sp))))] [specific-blame (cond [(syntax? src-info) @@ -223,9 +209,8 @@ (pair? (cdr to-blame)) (null? (cddr to-blame)) (equal? 'quote (car to-blame))) - (format "module '~s" (cadr to-blame))] - [(string? to-blame) to-blame] - [else (format "module ~s" to-blame)]) + (format "'~s" (cadr to-blame))] + [else (format "~s" to-blame)]) formatted-contract-sexp specific-blame) msg))) diff --git a/collects/scheme/private/contract.ss b/collects/scheme/private/contract.ss index 71b8d9c6b8..36fb29b5e8 100644 --- a/collects/scheme/private/contract.ss +++ b/collects/scheme/private/contract.ss @@ -135,13 +135,12 @@ improve method arity mismatch contract violation error messages? ; ; -(define-syntax-parameter current-contract-region #f) +(define-syntax-parameter current-contract-region (λ (stx) #'(#%variable-reference))) (define-for-syntax (make-with-contract-transformer contract-id id pos-blame-id) (make-set!-transformer (lambda (stx) - (with-syntax ([neg-blame-id (or (syntax-parameter-value #'current-contract-region) - #'(#%variable-reference))] + (with-syntax ([neg-blame-id #'(current-contract-region)] [pos-blame-id pos-blame-id] [contract-id contract-id] [id id]) @@ -259,10 +258,10 @@ improve method arity mismatch contract violation error messages? dupd-id)) (check-exports (append unprotected protected) expanded-bodies)) (with-syntax ([(contract-def ...) (map marker (filter values contract-defs))] - [blame-str (format "~a ~a" (syntax-e #'type) (syntax-e #'blame))] + [blame-stx #''(type blame)] [(marked-body ...) (map marker expanded-bodies)]) (quasisyntax/loc stx - (splicing-syntax-parameterize ([current-contract-region blame-str]) + (splicing-syntax-parameterize ([current-contract-region (λ (stx) #'blame-stx)]) marked-body ... contract-def ... #,@(map (λ (p c) @@ -270,7 +269,7 @@ improve method arity mismatch contract violation error messages? (make-with-contract-transformer (quote-syntax #,(marker c)) (quote-syntax #,(marker p)) - blame-str))) + (quote-syntax blame-stx)))) protected-ids contracts) #,@(map (λ (u) #`(define-syntax #,u @@ -279,7 +278,7 @@ improve method arity mismatch contract violation error messages? (define-values () (begin #,@(map (λ (p c) - #`(-contract #,(marker c) #,p blame-str 'ignored #,(id->contract-src-info p))) + #`(-contract #,(marker c) #,p blame-stx 'ignored #,(id->contract-src-info p))) protected-ids contracts) (values))) )))))] From d3f703b04368b74d5435fcb81d8de8521c4976e1 Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Wed, 14 Jan 2009 21:31:46 +0000 Subject: [PATCH 82/88] Fixing these back up to how they were before. svn: r13123 --- collects/tests/mzscheme/contract-mzlib-test.ss | 18 +++++++++--------- 1 file changed, 9 insertions(+), 9 deletions(-) diff --git a/collects/tests/mzscheme/contract-mzlib-test.ss b/collects/tests/mzscheme/contract-mzlib-test.ss index 47e25f73d8..2e22f4145b 100644 --- a/collects/tests/mzscheme/contract-mzlib-test.ss +++ b/collects/tests/mzscheme/contract-mzlib-test.ss @@ -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,14 +1577,14 @@ 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 @@ -4643,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 @@ -4820,7 +4820,7 @@ so that propagation occurs. (make-s 1 2) [s-a #f]))) (eval '(require 'pc11b-n))) - "module 'n") + "'n") |# (test/spec-passed @@ -4888,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 @@ -4899,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 c7ee5b600c1023f612df6c4549f0bde66eef1416 Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Wed, 14 Jan 2009 21:35:07 +0000 Subject: [PATCH 83/88] Change this more to how it should be. svn: r13124 --- 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 d1f3ea63ed..12891e145a 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 a4165d14b4a8e682bbd6f48e9bee31de3de15ee7 Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Wed, 14 Jan 2009 21:39:43 +0000 Subject: [PATCH 84/88] Change this to match how the error messages now come across. svn: r13125 --- collects/tests/mzscheme/contract-test.ss | 38 ++++++++++++------------ 1 file changed, 19 insertions(+), 19 deletions(-) diff --git a/collects/tests/mzscheme/contract-test.ss b/collects/tests/mzscheme/contract-test.ss index 2729791a88..d44000e75c 100644 --- a/collects/tests/mzscheme/contract-test.ss +++ b/collects/tests/mzscheme/contract-test.ss @@ -98,8 +98,8 @@ (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 @@ -121,7 +121,7 @@ (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) @@ -2190,28 +2190,28 @@ '(let () (define/contract i integer? #t) i) - "definition i") + "(definition i)") (test/spec-failed 'define/contract3 '(let () (define/contract i (-> integer? integer?) (lambda (x) #t)) (i 1)) - "definition i") + "(definition i)") (test/spec-failed 'define/contract4 '(let () (define/contract i (-> integer? integer?) (lambda (x) 1)) (i #f)) - "module top-level") + "top-level") (test/spec-failed 'define/contract5 '(let () (define/contract (i x) (-> integer? integer?) 1) (i #f)) - "module top-level") + "top-level") (test/spec-passed 'define/contract6 @@ -2251,7 +2251,7 @@ (+ m 1)) (b (zero? n))) (a 5)) - "function a") + "(function a)") (test/spec-failed 'define/contract10 @@ -2263,7 +2263,7 @@ #t) (b (add1 n))) (a 5)) - "function b") + "(function b)") (test/spec-passed 'define/contract11 @@ -2286,7 +2286,7 @@ (-> boolean? number? number?) (if b (f m) (f #t))) (g #f 3)) - "function g") + "(function g)") (test/spec-failed 'define/contract13 @@ -2298,7 +2298,7 @@ (+ n 1)) (foo-dc13 #t))) (eval '(require 'foo-dc13))) - "module 'foo-dc13") + "'foo-dc13") (test/spec-failed 'define/contract14 @@ -2313,7 +2313,7 @@ (require 'foo-dc14) (foo-dc14 #t))) (eval '(require 'bar-dc14))) - "module 'bar-dc14") + "'bar-dc14") (test/spec-failed 'define/contract15 @@ -2326,7 +2326,7 @@ (+ n 1)))) (eval '(require 'foo-dc15)) (eval '(foo-dc15 #t))) - "module top-level") + "top-level") ; @@ -2370,7 +2370,7 @@ (define (even? n) (if (zero? n) #t (odd? (sub1 n))))) (odd? #t)) - "module top-level") + "top-level") (test/spec-failed 'with-contract3 @@ -2383,7 +2383,7 @@ (define (even? n) (if (zero? n) #t (odd? (sub1 n))))) (odd? 4)) - "region odd-even") + "(region odd-even)") ;; Functions within the same with-contract region can call ;; each other however they want, so here we have even? @@ -5691,7 +5691,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 @@ -5868,7 +5868,7 @@ so that propagation occurs. (make-s 1 2) [s-a #f]))) (eval '(require 'pc11b-n))) - "module 'n") + "'n") |# (test/spec-passed @@ -5936,7 +5936,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 @@ -5947,7 +5947,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 8b5b007a512f189d47cb18257a7fcbf0af3b27ea Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Thu, 15 Jan 2009 09:11:50 +0000 Subject: [PATCH 85/88] We want to cover the marked version of the identifier (which has the proper value), not the "regular" version that's now a transformer to a contracted version of the marked identifier (and thus double-contracting here). svn: r13145 --- collects/scheme/private/contract.ss | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/scheme/private/contract.ss b/collects/scheme/private/contract.ss index 36fb29b5e8..6970090e55 100644 --- a/collects/scheme/private/contract.ss +++ b/collects/scheme/private/contract.ss @@ -278,7 +278,7 @@ improve method arity mismatch contract violation error messages? (define-values () (begin #,@(map (λ (p c) - #`(-contract #,(marker c) #,p blame-stx 'ignored #,(id->contract-src-info p))) + #`(-contract #,(marker c) #,(marker p) blame-stx 'ignored #,(id->contract-src-info p))) protected-ids contracts) (values))) )))))] From 39d9cfbb0aac1f619782a5f1867d3b68c75c18c3 Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Fri, 16 Jan 2009 20:41:51 +0000 Subject: [PATCH 86/88] Now that we're in with-contract land, use the same syntax parameter for units as well as with-contract and define/contract. svn: r13181 --- collects/mzlib/unit.ss | 10 ++++------ 1 file changed, 4 insertions(+), 6 deletions(-) diff --git a/collects/mzlib/unit.ss b/collects/mzlib/unit.ss index c2e0fa166f..4503056fd1 100644 --- a/collects/mzlib/unit.ss +++ b/collects/mzlib/unit.ss @@ -469,13 +469,11 @@ #,(syntax-span id)) #,(format "~s" (syntax-object->datum id)))) - (define-syntax-parameter current-unit-blame-stx (lambda (stx) #'(#%variable-reference))) - (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) + (current-contract-region) #,(id->contract-src-info var)))) (quasisyntax/loc (error-syntax) (quote-syntax (unbox #,loc))))) @@ -556,7 +554,7 @@ (vector-immutable (cons 'export-name (vector-immutable export-key ...)) ...) (list (cons 'dept depr) ...) - (syntax-parameterize ([current-unit-blame-stx (lambda (stx) #'(quote (unit name)))]) + (syntax-parameterize ([current-contract-region (lambda (stx) #'(quote (unit name)))]) (lambda () (let ([eloc (box undefined)] ... ...) (values @@ -693,7 +691,7 @@ (set-var-info-add-ctc! v (λ (e) - #`(contract #,(cdr (syntax-e ctc)) #,e (current-unit-blame-stx) + #`(contract #,(cdr (syntax-e ctc)) #,e (current-contract-region) 'cant-happen #,(id->contract-src-info e))))))) (syntax->list (localify #'evars def-ctx)) (syntax->list #'elocs) @@ -1219,7 +1217,7 @@ (lambda (i v c) (if c #`(contract #,c (unbox (vector-ref #,ov #,i)) - 'cant-happen (current-unit-blame-stx) + 'cant-happen (current-contract-region) #,(id->contract-src-info v)) #`(unbox (vector-ref #,ov #,i)))) (iota (length (car os))) From f6d571db407afe949e7d81f412e4bfc0f66d0044 Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Fri, 16 Jan 2009 20:46:39 +0000 Subject: [PATCH 87/88] Add a test that involves blame on a non-unit entity. svn: r13182 --- collects/tests/units/test-unit-contracts.ss | 10 ++++++++++ 1 file changed, 10 insertions(+) diff --git a/collects/tests/units/test-unit-contracts.ss b/collects/tests/units/test-unit-contracts.ss index dd5f04de6f..4b355450b5 100644 --- a/collects/tests/units/test-unit-contracts.ss +++ b/collects/tests/units/test-unit-contracts.ss @@ -152,3 +152,13 @@ (test-runtime-error exn:fail:contract? "unit9-1 provides wrong value for function f" (invoke-unit unit9)) + +(define-values/invoke-unit + (unit + (import) (export sig2) + (define f values)) + (import) + (export sig2)) + +(test-runtime-error exn:fail:contract? "top-level misuses f" + (f #t)) From 92fa69c387e00643c16bee1d329eddc5f5ce7bbf Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Fri, 16 Jan 2009 22:21:18 +0000 Subject: [PATCH 88/88] Add some tests that check interaction between with-contract (here through define/contract) and unit contracts. svn: r13183 --- collects/tests/mzscheme/contract-test.ss | 73 ++++++++++++++++++++++++ 1 file changed, 73 insertions(+) diff --git a/collects/tests/mzscheme/contract-test.ss b/collects/tests/mzscheme/contract-test.ss index d44000e75c..5b2dd5387c 100644 --- a/collects/tests/mzscheme/contract-test.ss +++ b/collects/tests/mzscheme/contract-test.ss @@ -2328,6 +2328,79 @@ (eval '(foo-dc15 #t))) "top-level") + ;; Let's see how units + define/contract interact + + (test/spec-failed + 'define/contract16 + '(begin + (eval '(module foo-dc16 scheme/base + (require scheme/contract) + (require scheme/unit) + (let () + (define/contract (foo n) + (-> number? number?) + (define-signature U^ + ((contracted [x (-> number? number?)]))) + (define-unit U@ + (import) + (export U^) + (define (x n) #t)) + (define-values/invoke-unit U@ + (import) + (export U^)) + (x n)) + (foo 3)))) + (eval '(require 'foo-dc16))) + "(unit U@)") + + (test/spec-failed + 'define/contract17 + '(begin + (eval '(module foo-dc17 scheme/base + (require scheme/contract) + (require scheme/unit) + (let () + (define/contract (foo n) + (-> number? number?) + (define-signature U^ + ((contracted [x (-> number? number?)]))) + (define-unit U@ + (import) + (export U^) + (define (x n) 3)) + (define-values/invoke-unit U@ + (import) + (export U^)) + (x (zero? n))) + (foo 3)))) + (eval '(require 'foo-dc17))) + "(function foo)") + + (test/spec-failed + 'define/contract18 + '(begin + (eval '(module foo-dc17 scheme/base + (require scheme/contract) + (require scheme/unit) + (let () + (define-signature U^ + ((contracted [x (-> number? number?)]))) + (define-unit U@ + (import) + (export U^) + ;; Can't define/contract x directly because + ;; x ends up bound to a transformer and thus + ;; is syntax. + (define/contract (y n) + (-> number? boolean?) #t) + (define x y)) + (define-values/invoke-unit U@ + (import) + (export U^)) + (x 3)))) + (eval '(require 'foo-dc18))) + "(unit U@)") + ; ;