More restrictive handling of contracts for the `Any' type.

svn: r18043

original commit: 8bf908d1061510198bb6a155fee7a25312bea714

collects/tests/typed-scheme/fail/bad-any.ss

@@ -0,0 +1,14 @@
+#;
+(exn-pred exn:fail:contract?)
+#lang scheme/load
+
+(module m typed-scheme  
+  (: f Any)
+  (define f (lambda: ([x : Number]) (add1 x)))
+  (provide f))
+
+(module n scheme
+  (require 'm)
+  (f "foo"))
+
+(require 'n)

collects/typed-scheme/private/type-contract.ss

@@ -13,7 +13,7 @@
  (private parse-type)
  scheme/match syntax/struct syntax/stx mzlib/trace unstable/syntax scheme/list
  (only-in scheme/contract -> ->* case-> cons/c flat-rec-contract provide/contract any/c)
- (for-template scheme/base scheme/contract unstable/poly-c (only-in scheme/class object% is-a?/c subclass?/c)))
+ (for-template scheme/base scheme/contract unstable/poly-c (utils any-wrap) (only-in scheme/class object% is-a?/c subclass?/c)))
 
 (define (define/fixup-contract? stx)
   (or (syntax-property stx 'typechecker:contract-def)
@@ -29,7 +29,11 @@
      (let ([typ (if maker?
                     ((Struct-flds (lookup-type-name (Name-id typ))) #f . t:->* . typ)
                     typ)])
-       (with-syntax ([cnt (type->contract typ (lambda () (tc-error/stx prop "Type ~a could not be converted to a contract." typ)))])
+       (with-syntax ([cnt (type->contract 
+                           typ 
+                           ;; this is for a `require/typed', so the value is not from the typed side
+                           #:typed-side #f 
+                           (lambda () (tc-error/stx prop "Type ~a could not be converted to a contract." typ)))])
          (syntax/loc stx (define-values (n) cnt))))]
     [_ (int-err "should never happen - not a define-values: ~a" (syntax->datum stx))]))
 
@@ -44,15 +48,18 @@
   (= (length l) (length (remove-duplicates l))))
 
 
-(define (type->contract ty fail #:out [out? #f])
+(define (type->contract ty fail #:out [out? #f] #:typed-side [from-typed? #t])
   (define vars (make-parameter '()))
   (let/ec exit
-    (let loop ([ty ty] [pos? #t])
-      (define (t->c t) (loop t pos?))
-      (define (t->c/neg t) (loop t (not pos?)))
+    (let loop ([ty ty] [pos? #t] [from-typed? from-typed?])
+      (define (t->c t) (loop t pos? from-typed?))
+      (define (t->c/neg t) (loop t (not pos?) (not from-typed?)))
       (match ty
         [(or (App: _ _ _) (Name: _)) (t->c (resolve-once ty))]
-        [(Univ:) #'any/c]
+        ;; any/c doesn't provide protection in positive position
+        [(Univ:) (if from-typed? 
+                     #'any-wrap/c
+                     #'any/c)]
         ;; we special-case lists:
         [(Mu: var (Union: (list (Value: '()) (Pair: elem-ty (F: var)))))
          #`(listof #,(t->c elem-ty))]
@@ -143,3 +150,4 @@
         [else          
          (exit (fail))]))))
 
+

collects/typed-scheme/typecheck/provide-handling.ss

@@ -5,7 +5,8 @@
          syntax/kerncase syntax/boundmap
          (env type-name-env type-alias-env)
          mzlib/trace
-         (private type-contract typed-renaming)
+         (only-in (private type-contract) type->contract)
+         (private typed-renaming)
          (rep type-rep)
 	 (utils tc-utils)
          scheme/contract/private/provide

collects/typed-scheme/utils/any-wrap.ss

@@ -0,0 +1,38 @@
+#lang scheme/base
+
+(require scheme/match scheme/vector scheme/contract)
+
+(define-struct any-wrap (val)
+  #:property prop:custom-write
+  (lambda (v p write?)
+    (fprintf p "#<Typed Value>")))
+
+(define (traverse wrap?)
+  (define (t v)
+    (match v
+      [(? (lambda (e) (and (any-wrap? e) (not wrap?)))) (any-wrap-val v)]
+      [(? (lambda (e) 
+            (or (number? e) (string? e) (char? e) (symbol? e) (keyword? e) (bytes? e) (void? e)))) v]
+      [(cons x y) (cons (t x) (t y))]
+      [(and (? immutable?) (? vector?)) (vector-map t v)]
+      [(and (? immutable?) (box v)) (box (t v))]
+      [(and (? immutable?) (? hash? v))
+       ((cond [(hash-eq? v) make-immutable-hasheq]
+              [(hash-eqv? v) make-immutable-hasheqv]
+              [else make-immutable-hash])
+        (for/list ([(k v) (in-hash v)])
+          (cons (t k) (t v))))]
+      #; ;; need to check immutablity
+      [(? prefab-struct-key)
+       (let* ([k (prefab-struct-key v)]
+              [vals (struct->vector v)])
+         (apply make-prefab-struct k (for/list ([i (in-vector vals 1)]) i)))]
+      [_ (if wrap? (make-any-wrap v) v)]))
+  t)
+  
+(define any-wrap/c
+  (simple-contract 
+   #:name 'Any
+   #:projection (compose traverse blame-original?)))
+
+(provide any-wrap/c)

collects/typed-scheme/utils/tc-utils.ss

@@ -8,7 +8,7 @@ don't depend on any other portion of the system
 (provide (all-defined-out))
 (require "syntax-traversal.ss"
 	 "utils.ss"
-	 syntax/parse (for-syntax scheme/base syntax/parse) scheme/match
+	 syntax/parse (for-syntax scheme/base syntax/parse) scheme/match unstable/debug
          (for-syntax unstable/syntax))
 
 ;; a parameter representing the original location of the syntax being currently checked
@@ -42,11 +42,13 @@ don't depend on any other portion of the system
 (define warn-unreachable? (make-parameter #t))
 
 (define (warn-unreachable e)
-  (let ([l (current-logger)])
+  (let ([l (current-logger)]
+        [stx (locate-stx e)])
     (when (and (warn-unreachable?)
                (log-level? l 'warning)
-               (and (orig-module-stx) (eq? (syntax-source-module e) (syntax-source-module (orig-module-stx))))
-	       (syntax-source-module e))
+               (syntax-original? (syntax-local-introduce e))
+               #;(and (orig-module-stx) (eq? (debug syntax-source-module e) (debug syntax-source-module (orig-module-stx))))
+	       #;(syntax-source-module stx))
       (log-message l 'warning (format "Typed Scheme has detected unreachable code: ~e" (syntax->datum (locate-stx e)))
                    e))))