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

Fix polymorphic structure predicates.

Browse Source 
svn: r14483
This commit is contained in:
Sam Tobin-Hochstadt 2009-04-10 00:07:11 +00:00
parent 69a3b7a70f
commit 929dc1d5b2
3 changed files with 16 additions and 3 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

11
collects/tests/typed-scheme/succeed/list-struct-sum.ss
View File

@ -13,4 +13,13 @@
[else (+ (Cons-first alon) [else (+ (Cons-first alon)
(sum (Cons-rest alon)))])) (sum (Cons-rest alon)))]))
(sum (make-Cons 5 (make-Cons 3 (make-Cons 1 (make-Empty)))))
(: 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)))))

2
collects/typed-scheme/typecheck/tc-if-unit.ss
View File

@ -31,7 +31,7 @@
;; type-op : (Type Type -> Type) Type -> _ Type -> Type ;; type-op : (Type Type -> Type) Type -> _ Type -> Type
(define ((type-op f t) _ old) (define ((type-op f t) _ old)
(let ([new-t (f old t)]) (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 ;; if this operation produces an uninhabitable type, then this expression can't be executed
(when (type-equal? new-t (Un)) (when (type-equal? new-t (Un))
;(printf "setting flag!~n") ;(printf "setting flag!~n")

6
collects/typed-scheme/typecheck/tc-structs.ss
View File

@ -87,6 +87,7 @@
(define (mk/register-sty nm flds parent parent-field-types types (define (mk/register-sty nm flds parent parent-field-types types
#:wrapper [wrapper values] #:wrapper [wrapper values]
#:type-wrapper [type-wrapper values] #:type-wrapper [type-wrapper values]
#:pred-wrapper [pred-wrapper values]
#:mutable [setters? #f] #:mutable [setters? #f]
#:proc-ty [proc-ty #f] #:proc-ty [proc-ty #f]
#:maker [maker* #f] #:maker [maker* #f]
@ -105,6 +106,7 @@
(register-struct-types nm sty flds external-fld-types external-fld-types/no-parent setters? (register-struct-types nm sty flds external-fld-types external-fld-types/no-parent setters?
#:wrapper wrapper #:wrapper wrapper
#:type-wrapper type-wrapper #:type-wrapper type-wrapper
#:pred-wrapper pred-wrapper
#:maker (or maker* maker) #:maker (or maker* maker)
#:constructor-return cret)))) #:constructor-return cret))))
@ -114,6 +116,7 @@
(define (register-struct-types nm sty flds external-fld-types external-fld-types/no-parent setters? (define (register-struct-types nm sty flds external-fld-types external-fld-types/no-parent setters?
#:wrapper [wrapper values] #:wrapper [wrapper values]
#:type-wrapper [type-wrapper values] #:type-wrapper [type-wrapper values]
#:pred-wrapper [pred-wrapper values]
#:maker [maker* #f] #:maker [maker* #f]
#:constructor-return [cret #f]) #:constructor-return [cret #f])
;; create the approriate names that define-struct will bind ;; create the approriate names that define-struct will bind
@ -126,7 +129,7 @@
(list (cons (or maker* maker) (list (cons (or maker* maker)
(wrapper (->* external-fld-types (if cret cret name)))) (wrapper (->* external-fld-types (if cret cret name))))
(cons pred (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) (map (lambda (g t) (cons g (wrapper (->* (list name) t)))) getters external-fld-types/no-parent)
(if setters? (if setters?
(map (lambda (g t) (cons g (wrapper (->* (list name t) -Void)))) setters external-fld-types/no-parent) (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 ;; wrap everything in the approriate forall
#:wrapper (lambda (t) (make-Poly tvars t)) #:wrapper (lambda (t) (make-Poly tvars t))
#:type-wrapper (lambda (t) (make-App t new-tvars #f)) #: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)) #:poly? #t))