diff --git a/collects/typed-scheme/test.ss b/collects/typed-scheme/test.ss index 90be8df4..bf99f487 100644 --- a/collects/typed-scheme/test.ss +++ b/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) diff --git a/collects/typed-scheme/typecheck/tc-lambda-unit.ss b/collects/typed-scheme/typecheck/tc-lambda-unit.ss index 8309340c..969c7fc8 100644 --- a/collects/typed-scheme/typecheck/tc-lambda-unit.ss +++ b/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)]) - (check-below t expected))])) - (let loop ([formals (syntax->list formals)] - [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))])))) + ;; FIXME - is this right? + [_ (go (syntax->list formals) (syntax->list bodies) null null null)])) + (go (syntax->list formals) (syntax->list bodies) null null null))) (define (tc/mono-lambda/type formals bodies expected) (make-Function (map lam-result->type (tc/mono-lambda formals bodies expected)))) diff --git a/collects/typed-scheme/typecheck/tc-let-unit.ss b/collects/typed-scheme/typecheck/tc-let-unit.ss index 81ae2668..06083a25 100644 --- a/collects/typed-scheme/typecheck/tc-let-unit.ss +++ b/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) diff --git a/collects/typed-scheme/utils/utils.ss b/collects/typed-scheme/utils/utils.ss index a2503c86..a321e257 100644 --- a/collects/typed-scheme/utils/utils.ss +++ b/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