From 65b12a2af3a487da88a0d354586e533516273d39 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Mon, 1 Mar 2010 23:43:15 +0000 Subject: [PATCH] Use `current-contract-region' appropriately. Maintain source locations. Fix PR 10776. svn: r18421 --- .../tests/typed-scheme/unit-tests/typecheck-tests.ss | 6 +++++- collects/typed-scheme/infer/infer-unit.ss | 2 +- collects/typed-scheme/types/subtype.ss | 8 +++++--- collects/typed-scheme/utils/require-contract.ss | 11 ++++++----- 4 files changed, 17 insertions(+), 10 deletions(-) diff --git a/collects/tests/typed-scheme/unit-tests/typecheck-tests.ss b/collects/tests/typed-scheme/unit-tests/typecheck-tests.ss index 9e847a689e..d6f0a656f6 100644 --- a/collects/tests/typed-scheme/unit-tests/typecheck-tests.ss +++ b/collects/tests/typed-scheme/unit-tests/typecheck-tests.ss @@ -6,7 +6,7 @@ (require (private base-env prims type-annotation base-types-extra base-env-numeric - base-env-indexing-old) + base-env-indexing) (typecheck typechecker) (rep type-rep filter-rep object-rep) (rename-in (types utils union convenience) @@ -791,6 +791,10 @@ [tc-e (let: ([x : (U (Vectorof Number) String) (vector 1 2 3)]) (if (vector? x) (vector-ref x 0) (string-length x))) -Number] + [tc-e (let () + (define: foo : (Integer * -> Integer) +) + (foo 1 2 3 4 5)) + -Integer] ) (test-suite "check-type tests" diff --git a/collects/typed-scheme/infer/infer-unit.ss b/collects/typed-scheme/infer/infer-unit.ss index b1609af198..0980881a24 100644 --- a/collects/typed-scheme/infer/infer-unit.ss +++ b/collects/typed-scheme/infer/infer-unit.ss @@ -20,7 +20,7 @@ (define (empty-set) '()) -(define current-seen (make-parameter (empty-set))) +(define current-seen (make-parameter (empty-set) #;pair?)) (define (seen-before s t) (cons (Type-seq s) (Type-seq t))) (define (remember s t A) (cons (seen-before s t) A)) diff --git a/collects/typed-scheme/types/subtype.ss b/collects/typed-scheme/types/subtype.ss index de10ce7f3b..582eb26e74 100644 --- a/collects/typed-scheme/types/subtype.ss +++ b/collects/typed-scheme/types/subtype.ss @@ -24,7 +24,7 @@ ;; data structures for remembering things on recursive calls (define (empty-set) '()) -(define current-seen (make-parameter (empty-set))) +(define current-seen (make-parameter (empty-set) #;pair?)) (define (seen-before s t) (cons (Type-seq s) (Type-seq t))) (define (remember s t A) (cons (seen-before s t) A)) @@ -301,8 +301,10 @@ (subtype* A0 other t*) (fail! s t)))] ;; for unions, we check the cross-product - [((Union: es) t) (and (andmap (lambda (elem) (subtype* A0 elem t)) es) A0)] - [(s (Union: es)) (and (ormap (lambda (elem) (subtype*/no-fail A0 s elem)) es) A0)] + [((Union: es) t) (or (and (andmap (lambda (elem) (subtype* A0 elem t)) es) A0) + (fail! s t))] + [(s (Union: es)) (or (and (ormap (lambda (elem) (subtype*/no-fail A0 s elem)) es) A0) + (fail! s t))] ;; subtyping on immutable structs is covariant [((Struct: nm _ flds #f _ _ _ _) (Struct: nm _ flds* #f _ _ _ _)) (subtypes* A0 flds flds*)] diff --git a/collects/typed-scheme/utils/require-contract.ss b/collects/typed-scheme/utils/require-contract.ss index f1d9737f2c..f2bc255bf2 100644 --- a/collects/typed-scheme/utils/require-contract.ss +++ b/collects/typed-scheme/utils/require-contract.ss @@ -1,9 +1,10 @@ #lang scheme/base (require scheme/contract + unstable/location (for-syntax scheme/base syntax/kerncase - syntax/parse + syntax/parse "../utils/tc-utils.ss" (prefix-in tr: "../private/typed-renaming.ss"))) @@ -43,15 +44,15 @@ (contract cnt (get-alternate nm.r) '(interface for #,(syntax->datum #'nm)) - 'never-happen + (current-contract-region) (quote nm) - (quote-syntax nm))))] + (quote-srcloc nm))))] [(require/contract (orig-nm:renameable nm:id) cnt lib) #`(begin (require (only-in lib [orig-nm orig-nm.r])) (define-ignored nm (contract cnt (get-alternate orig-nm.r) '#,(syntax->datum #'nm) - 'never-happen + (current-contract-region) (quote nm) - (quote-syntax nm))))])) + (quote-srcloc nm))))]))