From b415e84cd6a53fd618b3493df3cef41e72ecca0b Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Fri, 2 Jul 2010 17:24:38 -0400 Subject: [PATCH] Fix inference for heterogenous vectors. original commit: 0e400291e78c46cf1f4ded2c668e2b989814fc5e --- .../typed-scheme/succeed/rec-het-vec-infer.rkt | 9 +++++++++ collects/typed-scheme/infer/infer-unit.rkt | 2 ++ collects/typed-scheme/typecheck/tc-funapp.rkt | 15 +++++++-------- 3 files changed, 18 insertions(+), 8 deletions(-) create mode 100644 collects/tests/typed-scheme/succeed/rec-het-vec-infer.rkt diff --git a/collects/tests/typed-scheme/succeed/rec-het-vec-infer.rkt b/collects/tests/typed-scheme/succeed/rec-het-vec-infer.rkt new file mode 100644 index 00000000..72c33824 --- /dev/null +++ b/collects/tests/typed-scheme/succeed/rec-het-vec-infer.rkt @@ -0,0 +1,9 @@ +#lang typed/racket + +(define-type (Set X) (Rec Set (U Null (Vector X Set)))) + +(: get-set-root (All (X) ((Set X) -> X))) +(define (get-set-root s) (error 'fail)) + +(: set-size (All (X) ((Set X) -> X))) +(define (set-size x) (get-set-root x)) \ No newline at end of file diff --git a/collects/typed-scheme/infer/infer-unit.rkt b/collects/typed-scheme/infer/infer-unit.rkt index c4a0064a..33e2f23c 100644 --- a/collects/typed-scheme/infer/infer-unit.rkt +++ b/collects/typed-scheme/infer/infer-unit.rkt @@ -361,6 +361,8 @@ [((List: ts) (Sequence: (list t*))) (cset-meet* (for/list ([t (in-list ts)]) (cg t t*)))] + [((HeterogenousVector: ts) (HeterogenousVector: ts*)) + (cset-meet (cgen/list V X Y ts ts*) (cgen/list V X Y ts* ts))] [((HeterogenousVector: ts) (Sequence: (list t*))) (cset-meet* (for/list ([t (in-list ts)]) (cg t t*)))] diff --git a/collects/typed-scheme/typecheck/tc-funapp.rkt b/collects/typed-scheme/typecheck/tc-funapp.rkt index 56365a4a..63f12298 100644 --- a/collects/typed-scheme/typecheck/tc-funapp.rkt +++ b/collects/typed-scheme/typecheck/tc-funapp.rkt @@ -4,16 +4,16 @@ "signatures.rkt" "tc-metafunctions.rkt" "tc-app-helper.rkt" "find-annotation.rkt" "tc-subst.rkt" "check-below.rkt" - (prefix-in c: scheme/contract) - syntax/parse scheme/match mzlib/trace scheme/list + (prefix-in c: racket/contract) + syntax/parse racket/match racket/list unstable/sequence unstable/debug ;; fixme - don't need to be bound in this phase - only to make syntax/parse happy - scheme/bool + racket/bool racket/unsafe/ops (only-in racket/private/class-internal make-object do-make-object) (only-in '#%kernel [apply k:apply]) ;; end fixme - (for-syntax syntax/parse scheme/base (utils tc-utils)) + (for-syntax syntax/parse racket/base (utils tc-utils)) (private type-annotation) (types utils abbrev union subtype resolve convenience type-table substitute) (utils tc-utils) @@ -25,7 +25,7 @@ (for-template racket/unsafe/ops (only-in '#%kernel [apply k:apply]) - "internal-forms.rkt" scheme/base scheme/bool '#%paramz + "internal-forms.rkt" racket/base racket/bool '#%paramz (only-in racket/private/class-internal make-object do-make-object))) (provide tc/funapp) @@ -97,10 +97,10 @@ (list (tc-result1: argtys-t) ...)) (handle-clauses (doms rngs rests arrs) f-stx args-stx ;; only try inference if the argument lengths are appropriate - (lambda (dom _ rest a) ((if rest <= =) (length dom) (length argtys))) + (λ (dom _ rest a) ((if rest <= =) (length dom) (length argtys))) ;; only try to infer the free vars of the rng (which includes the vars in filters/objects) ;; note that we have to use argtys-t here, since argtys is a list of tc-results - (lambda (dom rng rest a) (infer/vararg vars null argtys-t dom rest rng (and expected (tc-results->values expected)))) + (λ (dom rng rest a) (infer/vararg vars null argtys-t dom rest rng (and expected (tc-results->values expected)))) t argtys expected)] ;; procedural structs [((tc-result1: (and sty (Struct: _ _ _ (? Function? proc-ty) _ _ _ _))) _) @@ -128,7 +128,6 @@ [((tc-result1: (Error:)) _) (ret (make-Error))] ;; otherwise fail [((tc-result1: f-ty) _) - ;(printf "ft: ~a argt: ~a~n" ftype0 argtys) (tc-error/expr #:return (ret (Un)) "Cannot apply expression of type ~a, since it is not a function type" f-ty)]))