From 9dac995e36c99a6170a72ec9b784ca446ec17ca1 Mon Sep 17 00:00:00 2001 From: Eric Dobson Date: Sat, 14 Jul 2012 20:08:39 -0700 Subject: [PATCH] Fix things broken by bad rebasing. --- .../benchmarks/shootout/typed/matrix.rktl | 2 +- collects/typed-racket/typecheck/tc-app.rkt | 5 ---- .../typecheck/tc-app/tc-app-hetero.rkt | 27 ++++++++++++++++--- 3 files changed, 25 insertions(+), 9 deletions(-) diff --git a/collects/tests/racket/benchmarks/shootout/typed/matrix.rktl b/collects/tests/racket/benchmarks/shootout/typed/matrix.rktl index 7ad91fbb60..e917efc593 100644 --- a/collects/tests/racket/benchmarks/shootout/typed/matrix.rktl +++ b/collects/tests/racket/benchmarks/shootout/typed/matrix.rktl @@ -75,7 +75,7 @@ (let ((n (or (and (= (vector-length args) 1) (assert (string->number (vector-ref args 0)) exact-integer?)) 1))) - (let: ((mm : Matrix (vector (vector 0))) + (let: ((mm : Matrix (vector ((inst vector Natural) 0))) (m1 : Matrix (mkmatrix size size)) (m2 : Matrix (mkmatrix size size))) (let loop ((iter n)) diff --git a/collects/typed-racket/typecheck/tc-app.rkt b/collects/typed-racket/typecheck/tc-app.rkt index 9294fc3ea0..998dd34579 100644 --- a/collects/typed-racket/typecheck/tc-app.rkt +++ b/collects/typed-racket/typecheck/tc-app.rkt @@ -262,11 +262,6 @@ (add-typeof-expr lam (tc/rec-lambda/check form args body lp ts expected)) expected)])) -(define-syntax-class normal-op - (pattern i:identifier - #:when (not (syntax-property #'i 'type-inst)) - #:when (not (syntax-property #'i 'type-ascription)))) - ;; the main dispatching function diff --git a/collects/typed-racket/typecheck/tc-app/tc-app-hetero.rkt b/collects/typed-racket/typecheck/tc-app/tc-app-hetero.rkt index e37fab6aee..d940ab76ae 100644 --- a/collects/typed-racket/typecheck/tc-app/tc-app-hetero.rkt +++ b/collects/typed-racket/typecheck/tc-app/tc-app-hetero.rkt @@ -15,7 +15,7 @@ ;; end fixme (for-syntax syntax/parse scheme/base (utils tc-utils)) (private type-annotation) - (types utils abbrev union subtype resolve convenience type-table substitute) + (types utils abbrev union subtype resolve convenience type-table substitute generalize) (utils tc-utils) (only-in srfi/1 alist-delete) (except-in (env type-env-structs tvar-env index-env) extend) @@ -29,13 +29,18 @@ (only-in racket/private/class-internal do-make-object) (only-in syntax/location module-name-fixup))) -(import tc-expr^ tc-lambda^ tc-let^ tc-apply^) +(import tc-expr^ tc-lambda^ tc-let^ tc-apply^ tc-app^) (export tc-app-hetero^) + + + (define (tc/index expr) (syntax-parse expr [((~literal quote) i:number) - (values (tc-literal #'i) (syntax-e #'i))] + (let ((type (tc-literal #'i))) + (add-typeof-expr expr type) + (values type (syntax-e #'i)))] [_ (match (tc-expr expr) [(and type (tc-result1: (Value: (? number? i)))) @@ -87,6 +92,10 @@ (index-error i-val i-bound i-e vec-t expected) name])) +(define-syntax-class special-op + (pattern i:identifier + #:when (or (syntax-property #'i 'type-inst) + (syntax-property #'i 'type-ascription)))) (define (tc/app-hetero form expected) (syntax-parse form @@ -96,6 +105,7 @@ unsafe-struct-ref unsafe-struct*-ref unsafe-struct-set! unsafe-struct*-set! vector-immutable vector) + [(#%plain-app op:special-op args ...) #f] ;; unsafe struct-ref [(#%plain-app (~or unsafe-struct-ref unsafe-struct*-ref) struct:expr index:expr) (match (single-value #'struct) @@ -132,6 +142,17 @@ [t (in-list ts)]) (tc-expr/check e (ret t))) expected] + ;; If the expected type is a union, then we examine just the parts + ;; of the union that are vectors. If there's only one of those, + ;; we re-run this whole algorithm with that. Otherwise, we treat + ;; it like any other expected type. + [(tc-result1: (app resolve (Union: ts))) (=> continue) + (define u-ts (for/list ([t (in-list ts)] + #:when (eq? 'vector (Type-key t))) + t)) + (match u-ts + [(list t0) (tc/app/check form (ret t0))] + [_ (continue)])] ;; since vectors are mutable, if there is no expected type, we want to generalize the element type [(or #f (tc-result1: _)) (ret (make-HeterogenousVector (map (lambda (x) (generalize (tc-expr/t x)))