Fix a number of bugs reported by eli

svn: r18017 original commit: 55a48ca594bc7e3834bfbebea7fc5a1967c278d1
2010-02-08 18:17:15 +00:00 · 2010-02-08 18:17:15 +00:00 · 0db7c6d821
commit 0db7c6d821
parent 40b9514197 e9503a6993 8d5eb1decf 4c1cf6b520
9 changed files with 59 additions and 34 deletions
--- a/collects/tests/typed-scheme/fail/bad-first.ss
+++ b/collects/tests/typed-scheme/fail/bad-first.ss
@ -0,0 +1,3 @@
+#lang typed-scheme
+(require scheme/list)
+(first (cons 1 2))
--- a/collects/typed-scheme/private/base-env-numeric.ss
+++ b/collects/typed-scheme/private/base-env-numeric.ss
@ -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->*
--- a/collects/typed-scheme/private/base-env.ss
+++ b/collects/typed-scheme/private/base-env.ss
@ -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 
--- a/collects/typed-scheme/private/base-types-extra.ss
+++ b/collects/typed-scheme/private/base-types-extra.ss
@ -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]))

--- a/collects/typed-scheme/private/base-types-new.ss
+++ b/collects/typed-scheme/private/base-types-new.ss
@ -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))]
--- a/collects/typed-scheme/private/base-types.ss
+++ b/collects/typed-scheme/private/base-types.ss
@ -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))]
+
--- a/collects/typed-scheme/typecheck/tc-toplevel.ss
+++ b/collects/typed-scheme/typecheck/tc-toplevel.ss
@ -20,6 +20,7 @@
         "def-binding.ss"
         (for-template
          "internal-forms.ss"
+          unstable/location
          mzlib/contract
          scheme/base))

@ -268,7 +269,7 @@
        ([the-variable-reference (generate-temporary #'blame)]
         [((new-provs ...) ...) (map (generate-prov stx-defs val-defs #'the-variable-reference) provs)])
      #`(begin
-          (define the-variable-reference (#%variable-reference))
+          (define the-variable-reference (quote-module-path))
           #,(env-init-code)
           #,(tname-env-init-code)
           #,(talias-env-init-code)
--- a/collects/typed-scheme/types/printer.ss
+++ b/collects/typed-scheme/types/printer.ss
@ -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)]
--- a/collects/typed-scheme/utils/require-contract.ss
+++ b/collects/typed-scheme/utils/require-contract.ss
@ -1,9 +1,11 @@
 #lang scheme/base

-(require scheme/contract (for-syntax scheme/base syntax/kerncase 
-                                     syntax/parse
-                                     "../utils/tc-utils.ss"
-                                     (prefix-in tr: "../private/typed-renaming.ss")))
+(require scheme/contract
+         (for-syntax scheme/base
+                     syntax/kerncase 
+                     syntax/parse
+                     "../utils/tc-utils.ss"
+                     (prefix-in tr: "../private/typed-renaming.ss")))

 (provide require/contract define-ignored)

@ -19,7 +21,7 @@
                 (define name #,(syntax-property #'e*
                                                 'inferred-name
                                                 (syntax-e #'name))))]
-       [(begin (begin e))
+       [(begin e)
        #`(define name #,(syntax-property #'e
                                          'inferred-name
                                          (syntax-e #'name)))])]))
@ -42,6 +44,7 @@
                          (get-alternate nm.r)
                          '(interface for #,(syntax->datum #'nm))
                          'never-happen
+                          (quote nm)
                          (quote-syntax nm))))]
    [(require/contract (orig-nm:renameable nm:id) cnt lib)
     #`(begin (require (only-in lib [orig-nm orig-nm.r]))
@ -50,4 +53,5 @@
                          (get-alternate orig-nm.r) 
                          '#,(syntax->datum #'nm)
                          'never-happen
+                          (quote nm)
                          (quote-syntax nm))))]))