Fixes for letrec.

svn: r14638

collects/typed-scheme/test.ss

@@ -19,4 +19,23 @@
 #{(let: ([x : Integer 1] [y : Integer 2]) x) :: Integer}
 
 #{(let*: ([x : Number 1] [x : Integer 2]) x) :: Integer}
+#{(let*: ([x : Number 1] [x : Integer 2]) #{x :: Integer}) :: Integer}
+
+#{(letrec: ([x : Integer 1] [y : Integer 2]) #{x :: Integer}) :: Integer}
+(letrec: ([x : Integer 1] [y : Integer 2]) #{x :: Integer})
+(let ()
+  (define x 1)
+  (define y 2)
+  x)
+(letrec: ([z : (-> Any) (lambda () z)]) 1)
+(letrec: ([z : (-> Any) (lambda () w)]
+          [w : (-> Any) (lambda () z)]) z)
+(let ()
+  (define: (z) : Any w)
+  (define: (w) : Any z)
+  z)
+(let ()
+  (define: (z [x : Number]) : Any w)
+  (define: (w) : Any z)
+  z)
 

collects/typed-scheme/typecheck/tc-lambda-unit.ss

@@ -175,6 +175,19 @@
                     [(pair? (syntax-e s))
                      (+ 1 (loop (cdr (syntax-e s))))]
                     [else 1]))]))
+  (define (go formals bodies formals* bodies* nums-seen)
+    (cond 
+      [(null? formals)
+       (map tc/lambda-clause (reverse formals*) (reverse bodies*))]
+      [(memv (syntax-len (car formals)) nums-seen)
+       ;; we check this clause, but it doesn't contribute to the overall type
+       (tc/lambda-clause (car formals) (car bodies))
+       (go (cdr formals) (cdr bodies) formals* bodies* nums-seen)]
+      [else
+       (go (cdr formals) (cdr bodies) 
+           (cons (car formals) formals*)
+           (cons (car bodies) bodies*)
+           (cons (syntax-len (car formals)) nums-seen))]))
   (if (and expected
            (= 1 (length (syntax->list formals))))
       ;; special case for not-case-lambda
@@ -184,25 +197,9 @@
           [(Function: (list (arr: argss rets rests drests '()) ...))
            (for/list ([args argss] [ret rets] [rest rests] [drest drests])
              (tc/lambda-clause/check (car (syntax->list formals)) (car (syntax->list bodies)) args ret rest drest))]
-          [t (let ([t (tc/mono-lambda formals bodies #f)])               
+          ;; FIXME - is this right?
-               (check-below t expected))]))
+          [_ (go (syntax->list formals) (syntax->list bodies) null null null)]))
-      (let loop ([formals (syntax->list formals)] 
+      (go (syntax->list formals) (syntax->list bodies) null null null)))
-                 [bodies (syntax->list bodies)]
-                 [formals* null]
-                 [bodies* null]
-                 [nums-seen null])
-        (cond 
-          [(null? formals)
-           (map tc/lambda-clause (reverse formals*) (reverse bodies*))]
-          [(memv (syntax-len (car formals)) nums-seen)
-           ;; we check this clause, but it doesn't contribute to the overall type
-           (tc/lambda-clause (car formals) (car bodies))
-           (loop (cdr formals) (cdr bodies) formals* bodies* nums-seen)]
-          [else
-           (loop (cdr formals) (cdr bodies) 
-                 (cons (car formals) formals*)
-                 (cons (car bodies) bodies*)
-                 (cons (syntax-len (car formals)) nums-seen))]))))
 
 (define (tc/mono-lambda/type formals bodies expected)
   (make-Function (map lam-result->type (tc/mono-lambda formals bodies expected))))

collects/typed-scheme/typecheck/tc-let-unit.ss

@@ -29,7 +29,7 @@
    (for-each expr->type
              clauses
              exprs 
-             (map -values types))
+             (map ret types))
    (if expected 
        (tc-exprs/check (syntax->list body) expected)
        (tc-exprs (syntax->list body)))))
@@ -73,7 +73,7 @@
      (tc-expr/check e (mk expecteds))
      (tc-expr e)))
   (match tcr
-    [(tc-result: t) t]))
+    [(tc-result1: t) t]))
 
 (define (tc/letrec-values/internal namess exprs body form expected)
   (let* ([names (map syntax->list (syntax->list namess))]
@@ -100,7 +100,8 @@
          ;; then check this expression separately
          (with-lexical-env/extend
           (list (car names))
-          (list (get-type/infer (car names) (car exprs) (lambda (e) (tc-expr/maybe-expected/t e (car names))) tc-expr/check/t))
+          (list (get-type/infer (car names) (car exprs) (lambda (e) (tc-expr/maybe-expected/t e (car names))) 
+                                (lambda (e t) (tc-expr/check/t e (ret t)))))
           (loop (cdr names) (cdr exprs) (apply append (cdr names)) (cdr clauses)))]
         [else
          ;(for-each (lambda (vs) (for-each (lambda (v) (printf/log "Letrec Var: ~a~n" (syntax-e v))) vs)) names)

collects/typed-scheme/utils/utils.ss

@@ -190,7 +190,7 @@ at least theoretically.
       [(_ val)
        #'(? (lambda (x) (equal? val x)))])))
 
-(define-for-syntax printing? #t)
+(define-for-syntax printing? #f)
 
 (define-syntax-rule (defprinter t ...)
   (begin