Add missing file.

Fix bug in struct type creation.
Add ability to disable printing dynamically.
Fix recursion into objects & paths.

svn: r14747

collects/typed-scheme/infer/infer-unit.ss

@@ -452,6 +452,7 @@
 (define (infer X S T R must-vars [expected #f])
   (with-handlers ([exn:infer? (lambda _ #f)])  
     (let ([cs (cgen/list null X S T)])
+      (printf "finished step 1~n")
       (if (not expected)
           (subst-gen cs R must-vars)
           (subst-gen (cset-meet cs (cgen null X R expected)) R must-vars)))))
@@ -459,7 +460,10 @@
 ;; like infer, but T-var is the vararg type:
 (define (infer/vararg X S T T-var R must-vars [expected #f])
   (define new-T (if T-var (extend S T T-var) T))
+  (printf "infer/vararg: ~a~n" (list X S T))
+  (printf "new-T: ~a~n" new-T)
   (and ((length S) . >= . (length T))
+       (printf "finished step 0~n")
        (infer X S new-T R must-vars expected)))
 
 ;; like infer, but dotted-var is the bound on the ...
@@ -486,4 +490,4 @@
 (define (i s t r)
   (infer/simple (list s) (list t) r))
 
-;(trace cgen)
+(trace cgen subst-gen)

collects/typed-scheme/rep/type-rep.ss

@@ -341,6 +341,17 @@
                       #:LatentFilter (sub-lf st))
                      e))
 
+(define ((sub-lo st) e)
+  (latentobject-case (#:Type st
+                      #:LatentObject (sub-lo st)
+                      #:PathElem (sub-pe st))
+                     e))
+
+(define ((sub-pe st) e)
+  (pathelem-case (#:Type st
+                  #:PathElem (sub-pe st))
+                 e))
+
 ;; abstract-many : Names Type -> Scope^n 
 ;; where n is the length of names  
 (define (abstract-many names ty)
@@ -349,7 +360,7 @@
       (define (sb t) (loop outer t))
       (define slf (sub-lf sb))
       (type-case 
-       (#:Type sb #:LatentFilter (sub-lf sb))
+       (#:Type sb #:LatentFilter (sub-lf sb) #:LatentObject (sub-lo sb))
        ty
        [#:F name* (if (eq? name name*) (*B (+ count outer)) ty)]
        ;; necessary to avoid infinite loops
@@ -392,7 +403,7 @@
       (define (sb t) (loop outer t))    
       (define slf (sub-lf sb))  
       (type-case 
-       (#:Type sb #:LatentFilter slf)
+       (#:Type sb #:LatentFilter slf #:LatentObject (sub-lo sb))
        ty
        [#:B idx (if (= (+ count outer) idx)
                     image
@@ -580,7 +591,7 @@
  free-vars*
  type-equal? type-compare type<?
  remove-dups
- sub-lf
+ sub-lf sub-lo sub-pe
  Values: Values? Values-rs
  (rename-out [Mu:* Mu:]               
              [Poly:* Poly:]

collects/typed-scheme/test.ss

@@ -86,7 +86,7 @@ xxx6-y
 (lambda () (values 1 1))
 (lambda () 1)
 #{(lambda (x) x) :: (Number -> Number)}
-;; BUG - this should work
+
 {ann (values (lambda (x) x) (lambda (x) x)) (values (Number -> Number) (String -> String))}
 
 (list 1 2 3)

collects/typed-scheme/test2.ss

@@ -1,5 +1,5 @@
 #lang typed-scheme
-
+#|
 (: f (Number String -> Number))
 (define (f x z) #;(f x z) 7)
 (lambda: ([x : Any] [y : Any]) (values (number? y) (number? x)))
@@ -19,14 +19,16 @@
 (+)
 (+ 1 2 3)
 (+ 1 2 3.5)
-
+|#
 (define-struct: (Z) X ([y : Z]))
 (define:  my-x : (X Number) (make-X 1))
+(X-y my-x)
+
 #| ; FIXME - doesn't work yet
 (number? (X-y my-x))
 (if (number? (X-y my-x)) (+ 1 (X-y my-x)) 7)
 |#
-
+#|
 (define: (f2) : (U) (error 'foo))
 (lambda: ([x : Number]) #{((f2)) :: (U)})
 
@@ -47,3 +49,4 @@
 ;(map + (list 1 2 3) (list 1 2 "foo"))
 
 ((lambda (a b . c) (+ a b (car c))) 1 2 3 4)
+|#

collects/typed-scheme/typecheck/find-annotation.ss

@@ -0,0 +1,65 @@
+#lang scheme/base
+
+(require "../utils/utils.ss" stxclass
+         scheme/contract
+         (rep type-rep)
+         (private type-annotation))
+
+(p/c [find-annotation (syntax? identifier? . -> . (or/c #f Type/c))])
+
+(define-syntax-class lv-clause
+  #:transparent
+  (pattern [(v:id ...) e:expr]))
+
+(define-syntax-class lv-clauses
+  #:transparent
+  (pattern (cl:lv-clause ...)
+           #:with (e ...) #'(cl.e ...)
+           #:with (vs ...) #'((cl.v ...) ...)))
+
+(define-syntax-class core-expr
+  #:literals (reverse letrec-syntaxes+values let-values #%plain-app
+                      if letrec-values begin #%plain-lambda set! case-lambda
+                      begin0 with-continuation-mark)
+  #:transparent
+  (pattern (let-values cls:lv-clauses body)
+           #:with (expr ...) #'(cls.e ... body))
+  (pattern (letrec-values cls:lv-clauses body)
+           #:with (expr ...) #'(cls.e ... body))
+  (pattern (letrec-syntaxes+values _ cls:lv-clauses body)
+           #:with (expr ...) #'(cls.e ... body))
+  (pattern (#%plain-app expr ...))
+  (pattern (if expr ...))
+  (pattern (with-continuation-mark expr ...))
+  (pattern (begin expr ...))
+  (pattern (begin0 expr ...))
+  (pattern (#%plain-lambda _ e)
+           #:with (expr ...) #'(e))
+  (pattern (case-lambda [_ expr] ...))
+  (pattern (set! _ e)
+           #:with (expr ...) #'(e))
+  (pattern _ 
+           #:with (expr ...) #'()))
+
+;; expr id -> type or #f
+;; if there is a binding in stx of the form:
+;; (let ([x (reverse name)]) e)
+;; where x has a type annotation, return that annotation, otherwise #f
+(define (find-annotation stx name)
+  (define (find s) (find-annotation s name))
+  (define (match? b)
+    (syntax-parse b
+      #:literals (#%plain-app reverse)
+      [c:lv-clause
+       #:with (#%plain-app reverse n:id) #'c.e
+       #:with (v) #'(c.v ...) 
+       #:when (free-identifier=? name #'n)
+       (type-annotation #'v)]
+      [_ #f]))
+  (syntax-parse stx
+    #:literals (let-values)
+    [(let-values cls:lv-clauses body)
+     (or (ormap match? (syntax->list #'cls))
+	 (find #'body))]
+    [e:core-expr
+     (ormap find (syntax->list #'(e.expr ...)))]))

collects/typed-scheme/typecheck/tc-structs.ss

@@ -126,14 +126,14 @@
   (define bindings
     (append 
      (list (cons (or maker* maker) 
-                 (wrapper (->* external-fld-types (if cret cret name))))
+                 (debug (wrapper (->* external-fld-types (if cret cret name)))))
            (cons pred
                  (make-pred-ty (pred-wrapper name))))
      (for/list ([g (in-list getters)] [t (in-list external-fld-types/no-parent)] [i (in-naturals)])
        (let ([func (if setters? 
                        (->* (list name) t)
                        (make-Function 
-                        (list (make-arr* (list sty) t 
+                        (list (make-arr* (list name) t 
                                          #:object (make-LPath (list (make-StructPE name i)) 0)))))])
          (cons g (wrapper func))))
      (if setters?

collects/typed-scheme/typed-scheme.ss

@@ -48,7 +48,9 @@
            [with-handlers
                ([(lambda (e) (and catch-errors? (exn:fail? e) (not (exn:fail:syntax? e))))
                  (lambda (e) (tc-error "Internal error: ~a" e))])]
-           [parameterize (;; a cheat to avoid units
+           [parameterize (;; disable fancy printing
+                          [custom-printer #t]
+                          ;; a cheat to avoid units
                           [infer-param infer]
                           ;; do we report multiple errors
                           [delay-errors? #t]

collects/typed-scheme/types/printer.ss

@@ -116,7 +116,7 @@
     ;; names are just the printed as the original syntax
     [(Name: stx) (fp "~a" (syntax-e stx))]
     [(App: rator rands stx) 
-     (fp "~a" (cons rator rands))]
+     (fp "~a" (list* '@ rator rands))]
     ;; special cases for lists
     [(Mu: var (Union: (list (Value: '()) (Pair: elem-ty (F: var)))))
      (fp "(Listof ~a)" elem-ty)]

collects/typed-scheme/types/utils.ss

@@ -38,7 +38,7 @@
 (define (substitute image name target #:Un [Un (get-union-maker)])
   (define (sb t) (substitute image name t))
   (if (hash-ref (free-vars* target) name #f)
-      (type-case (#:Type sb #:LatentFilter (sub-lf sb))
+      (type-case (#:Type sb #:LatentFilter (sub-lf sb) #:LatentObject (sub-lo sb))
                  target
                  [#:Union tys (Un (map sb tys))]
                  [#:F name* (if (eq? name* name) image target)]

collects/typed-scheme/utils/utils.ss

@@ -22,6 +22,7 @@ at least theoretically.
          debug
          in-syntax
 	 symbol-append
+         custom-printer
 	 rep utils typecheck infer env private)
 
 (define-syntax (define-requirer stx)
@@ -201,6 +202,18 @@ at least theoretically.
   print-type* print-filter* print-latentfilter* print-object* print-latentobject*
   print-pathelem*)
 
+(define pseudo-printer
+  (lambda (s port mode)
+    (parameterize ([current-output-port port]
+                   [show-sharing #f]
+                   [booleans-as-true/false #f]
+                   [constructor-style-printing #t])
+      (newline)
+      (pretty-print (print-convert s))
+      (newline))))
+
+(define custom-printer (make-parameter #t))
+  
 (require scheme/pretty mzlib/pconvert)
 
 (define-syntax (define-struct/printer stx)
@@ -208,15 +221,8 @@ at least theoretically.
     [(form name (flds ...) printer)
      #`(define-struct/properties name (flds ...) 
          #,(if printing?
-               #'([prop:custom-write printer]) 
+               #'([prop:custom-write (lambda (a b c) (if (custom-printer) (printer a b c) (pseudo-printer a b c)))]) 
-               #'([prop:custom-write (lambda (s port mode)
+               #'([prop:custom-write pseudo-printer]))
-                                       (parameterize ([current-output-port port]
-                                                      [show-sharing #f]
-                                                      [booleans-as-true/false #f]
-                                                      [constructor-style-printing #t])
-                                         (newline)
-                                         (pretty-print (print-convert s))
-                                         (newline)))]))
          #f)]))
 
 (define (id kw . args)