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

Fix a number of bugs reported by eli

Browse Source 
svn: r18017
This commit is contained in:
Sam Tobin-Hochstadt 2010-02-08 18:17:15 +00:00
parent 13b5f7e095
commit 55a48ca594
7 changed files with 48 additions and 28 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
collects/tests/typed-scheme/fail/bad-first.ss Normal file
View File

@ -0,0 +1,3 @@
#lang typed-scheme
(require scheme/list)
(first (cons 1 2))

4
collects/typed-scheme/private/base-env-numeric.ss
View File

@ -105,8 +105,8 @@
[imag-part (N . -> . -Real)]
[magnitude (N . -> . -Real)]
[angle (N . -> . -Real)]
[numerator (-Real . -> . -Integer)]
[denominator (-Real . -> . -Integer)]
[numerator (-Real . -> . -Real)]
[denominator (-Real . -> . -Real)]
[rationalize (-Real -Real . -> . N)]
[expt (cl->* (-Integer -Integer . -> . -Integer) (N N . -> . N))]
[sqrt (cl->*

44
collects/typed-scheme/private/base-env.ss
View File

@ -26,34 +26,44 @@
(->* (list (-lst a)) (-lst a))))]
[cadr (-poly (a b c)
(cl-> [((-pair a (-pair b c))) b]
[((-lst a)) a]))]
[caddr (-poly (a) (-> (-lst a) a))]
(cl->* [->acc (list (-pair a (-pair b c))) b (list -car -cdr)]
[-> (-lst a) a]))]
[cddr (-poly (a b c)
(cl->* [->acc (list (-pair a (-pair b c))) c (list -cdr -cdr)]
[-> (-lst a) (-lst a)]))]
[caddr (-poly (a b c d)
(cl->* [->acc (list (-pair a (-pair b (-pair c d)))) c (list -car -cdr -cdr)]
[-> (-lst a) a]))]
[cdddr (-poly (a b c d)
(cl->* [->acc (list (-pair a (-pair b (-pair c d)))) d (list -cdr -cdr -cdr)]
[-> (-lst a) a]))]
[cadddr (-poly (a) (-> (-lst a) a))]
[cddr (-poly (a) (-> (-lst a) (-lst a)))]
[cdddr (-poly (a) (-> (-lst a) (-lst a)))]
[cddddr (-poly (a) (-> (-lst a) (-lst a)))]
[first (-poly (a b)
(cl->*
(->acc (list (-pair a b)) a (list -car))
(->acc (list (-pair a (-lst b))) a (list -car))
(->* (list (-lst a)) a)))]
[second (-poly (a b c)
(cl-> [((-pair a (-pair b c))) b]
[((-lst a)) a]))]
(cl->* [->acc (list (-pair a (-pair b (-lst c)))) b (list -car -cdr)]
[->* (list (-lst a)) a]))]
[third (-poly (a b c d)
(cl-> [((-pair a (-pair b (-pair c d)))) c]
[((-lst a)) a]))]
(cl->* [->acc (list (-pair a (-pair b (-pair c (-lst d))))) c (list -car -cdr -cdr)]
[->* (list (-lst a)) a]))]
[fourth (-poly (a) ((-lst a) . -> . a))]
[fifth (-poly (a) ((-lst a) . -> . a))]
[sixth (-poly (a) ((-lst a) . -> . a))]
[rest (-poly (a b)
(cl->*
(->acc (list (-pair a b)) b (list -cdr))
(->acc (list (-pair a (-lst b))) (-lst b) (list -cdr))
(->* (list (-lst a)) (-lst a))))]
[cons (-poly (a b)
(cl-> [(a (-lst a)) (-lst a)]
[(a b) (-pair a b)]))]
(cl->* [->* (list a (-lst a)) (-lst a)]
[->* (list a b) (-pair a b)]))]
[*cons (-poly (a b) (cl->
[(a b) (-pair a b)]
[(a (-lst a)) (-lst a)]))]
@ -137,14 +147,14 @@
. -> .
(-lst b))
((a . -> . Univ) (-lst a) . -> . (-lst a))))]
[filter-not (-poly (a b) (cl->*
((a . -> . Univ) (-lst a) . -> . (-lst a))))]
[filter-not (-poly (a) (cl->*
((a . -> . Univ) (-lst a) . -> . (-lst a))))]
[remove (-poly (a) (a (-lst a) . -> . (-lst a)))]
[remq (-poly (a) (a (-lst a) . -> . (-lst a)))]
[remv (-poly (a) (a (-lst a) . -> . (-lst a)))]
[remove* (-poly (a b) ((-lst a) (-lst a) [(a b . -> . B)] . ->opt . (-lst b)))]
[remq* (-poly (a b) (cl-> [((-lst a) (-lst a)) (-lst a)]))]
[remv* (-poly (a b) (cl-> [((-lst a) (-lst a)) (-lst a)]))]
[remq* (-poly (a) (cl-> [((-lst a) (-lst a)) (-lst a)]))]
[remv* (-poly (a) (cl-> [((-lst a) (-lst a)) (-lst a)]))]
(error
(make-Function (list

9
collects/typed-scheme/private/base-types-extra.ss
View File

@ -12,12 +12,13 @@
;; special type names that are not bound to particular types
(define-other-types
-> U mu All Opaque
Parameter Tuple Class Values Instance Refinement
-> U Rec All Opaque
Parameterof List Class Values Instance Refinement
pred)
(provide (rename-out [All ∀]
[U Un]
[Tuple List]
[mu Rec]))
[List Tuple]
[Rec mu]
[Parameterof Parameter]))

4
collects/typed-scheme/private/base-types-new.ss
View File

@ -41,9 +41,11 @@
[HashTable (-poly (a b) (-HT a b))]
[Promise (-poly (a) (-Promise a))]
[Pair (-poly (a b) (-pair a b))]
[MPair (-poly (a b) (-mpair a b))]
[Boxof (-poly (a) (make-Box a))]
[Continuation-Mark-Set -Cont-Mark-Set]
[False (-val #f)]
[True (-val #t)]
[Null (-val null)]
[Nothing (Un)]
[Pairof (-poly (a b) (-pair a b))]
[MPairof (-poly (a b) (-mpair a b))]

4
collects/typed-scheme/private/base-types.ss
View File

@ -46,3 +46,7 @@
[False (-val #f)]
[True (-val #t)]
[Null (-val null)]
[Nothing (Un)]
[Pairof (-poly (a b) (-pair a b))]
[MPairof (-poly (a b) (-mpair a b))]

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

@ -185,9 +185,9 @@
(fp ")")]))]
[(arr: _ _ _ _ _) (print-arr c)]
[(Vector: e) (fp "(Vectorof ~a)" e)]
[(Box: e) (fp "(Box ~a)" e)]
[(Box: e) (fp "(Boxof ~a)" e)]
[(Union: elems) (fp "~a" (cons 'U elems))]
[(Pair: l r) (fp "(Pair ~a ~a)" l r)]
[(Pair: l r) (fp "(Pairof ~a ~a)" l r)]
[(F: nm) (fp "~a" nm)]
;; FIXME
[(Values: (list v)) (fp "~a" v)]
@ -195,8 +195,8 @@
[(ValuesDots: v dty dbound) (fp "~a" (cons 'values (append v (list dty '... dbound))))]
[(Param: in out)
(if (equal? in out)
(fp "(Parameter ~a)" in)
(fp "(Parameter ~a ~a)" in out))]
(fp "(Parameterof ~a)" in)
(fp "(Parameterof ~a ~a)" in out))]
[(Hashtable: k v) (fp "(HashTable ~a ~a)" k v)]
#;[(Poly-unsafe: n b) (fp "(unsafe-poly ~a ~a ~a)" (Type-seq c) n b)]