From 929dc1d5b245e03d59eba55989c42c1a3e91954a Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Fri, 10 Apr 2009 00:07:11 +0000 Subject: [PATCH] Fix polymorphic structure predicates. svn: r14483 --- .../tests/typed-scheme/succeed/list-struct-sum.ss | 11 ++++++++++- collects/typed-scheme/typecheck/tc-if-unit.ss | 2 +- collects/typed-scheme/typecheck/tc-structs.ss | 6 +++++- 3 files changed, 16 insertions(+), 3 deletions(-) diff --git a/collects/tests/typed-scheme/succeed/list-struct-sum.ss b/collects/tests/typed-scheme/succeed/list-struct-sum.ss index 08e7d49fb5..d448eac8b7 100644 --- a/collects/tests/typed-scheme/succeed/list-struct-sum.ss +++ b/collects/tests/typed-scheme/succeed/list-struct-sum.ss @@ -13,4 +13,13 @@ [else (+ (Cons-first alon) (sum (Cons-rest alon)))])) -(sum (make-Cons 5 (make-Cons 3 (make-Cons 1 (make-Empty))))) \ No newline at end of file + +(: sum2 ((ListOf Number) -> Number)) +(define (sum2 alon) + (cond + [(Empty? alon) 0] + [(Cons? alon) (+ (Cons-first alon) + (sum2 (Cons-rest alon)))])) + +(sum (make-Cons 5 (make-Cons 3 (make-Cons 1 (make-Empty))))) +(sum2 (make-Cons 5 (make-Cons 3 (make-Cons 1 (make-Empty))))) \ No newline at end of file diff --git a/collects/typed-scheme/typecheck/tc-if-unit.ss b/collects/typed-scheme/typecheck/tc-if-unit.ss index cc87ca8b13..3c279453d8 100644 --- a/collects/typed-scheme/typecheck/tc-if-unit.ss +++ b/collects/typed-scheme/typecheck/tc-if-unit.ss @@ -31,7 +31,7 @@ ;; type-op : (Type Type -> Type) Type -> _ Type -> Type (define ((type-op f t) _ old) (let ([new-t (f old t)]) - ;(printf "new-t ~a~n" new-t) + ;(printf "f old t new: ~a\n" (list f old t new-t)) ;; if this operation produces an uninhabitable type, then this expression can't be executed (when (type-equal? new-t (Un)) ;(printf "setting flag!~n") diff --git a/collects/typed-scheme/typecheck/tc-structs.ss b/collects/typed-scheme/typecheck/tc-structs.ss index 207e34d7b1..e48ff90b77 100644 --- a/collects/typed-scheme/typecheck/tc-structs.ss +++ b/collects/typed-scheme/typecheck/tc-structs.ss @@ -87,6 +87,7 @@ (define (mk/register-sty nm flds parent parent-field-types types #:wrapper [wrapper values] #:type-wrapper [type-wrapper values] + #:pred-wrapper [pred-wrapper values] #:mutable [setters? #f] #:proc-ty [proc-ty #f] #:maker [maker* #f] @@ -105,6 +106,7 @@ (register-struct-types nm sty flds external-fld-types external-fld-types/no-parent setters? #:wrapper wrapper #:type-wrapper type-wrapper + #:pred-wrapper pred-wrapper #:maker (or maker* maker) #:constructor-return cret)))) @@ -114,6 +116,7 @@ (define (register-struct-types nm sty flds external-fld-types external-fld-types/no-parent setters? #:wrapper [wrapper values] #:type-wrapper [type-wrapper values] + #:pred-wrapper [pred-wrapper values] #:maker [maker* #f] #:constructor-return [cret #f]) ;; create the approriate names that define-struct will bind @@ -126,7 +129,7 @@ (list (cons (or maker* maker) (wrapper (->* external-fld-types (if cret cret name)))) (cons pred - (make-pred-ty (wrapper name)))) + (make-pred-ty (pred-wrapper name)))) (map (lambda (g t) (cons g (wrapper (->* (list name) t)))) getters external-fld-types/no-parent) (if setters? (map (lambda (g t) (cons g (wrapper (->* (list name t) -Void)))) setters external-fld-types/no-parent) @@ -168,6 +171,7 @@ ;; wrap everything in the approriate forall #:wrapper (lambda (t) (make-Poly tvars t)) #:type-wrapper (lambda (t) (make-App t new-tvars #f)) + #:pred-wrapper (lambda (t) (subst-all (for/list ([t tvars]) (list t Univ)) t)) #:poly? #t))