suzanne.soy/typed-racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Use `current-contract-region' appropriately.

Browse Source 
Maintain source locations.
Fix PR 10776.

svn: r18421

original commit: 65b12a2af3a487da88a0d354586e533516273d39
This commit is contained in:
Sam Tobin-Hochstadt 2010-03-01 23:43:15 +00:00
parent b94868a43b
commit 1e35d3a083
4 changed files with 17 additions and 10 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
collects/tests/typed-scheme/unit-tests/typecheck-tests.ss
View File

@ -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"

2
collects/typed-scheme/infer/infer-unit.ss
View File

@ -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))

8
collects/typed-scheme/types/subtype.ss
View File

@ -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*)]

11
collects/typed-scheme/utils/require-contract.ss
View File

@ -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))))]))