From: Luke Lau Date: Thu, 15 Aug 2019 09:47:27 +0000 (+0100) Subject: Fix up typechecking of case X-Git-Url: https://git.lukelau.me/?p=scheme.git;a=commitdiff_plain;h=adbf51b9013353037797f4cc830a6c55628ce038 Fix up typechecking of case --- diff --git a/typecheck.scm b/typecheck.scm index 6aca2c1..1b2f214 100644 --- a/typecheck.scm +++ b/typecheck.scm @@ -247,23 +247,23 @@ ('app (check-app env x)) ['case (let* ([expr-type-res (check env (case-expr x))] - [expr-type (cadr env)] + [expr-type (cadr expr-type-res)] [case-match-type-res (map (lambda (x) (check env x)) (map car (case-cases x)))] [case-match-types (map cadr case-match-type-res)] [case-expr-type-res (map (lambda (x) (check env x)) (map cadr (case-cases x)))] - [case-expr-types (map cadr case-expr-types-res)] + [case-expr-types (map cadr case-expr-type-res)] [case-match-equality-cs (fold-left constraint-merge '() (map (lambda (t) (~ t expr-type)) case-match-types))] [case-expr-equality-cs (fold-left constraint-merge '() - (map (lambda (t) (~ t (car case-expr-type-res))) - (cdr case-expr-type-res)))] + (map (lambda (t) (~ t (car case-expr-types))) + (cdr case-expr-types)))] - [resolved-type (substitute case-expr-eqaulity-cs (car case-expr-type-res))] + [resolved-type (substitute case-expr-equality-cs (car case-expr-types))] [annotated `((case (,(case-expr x) : ,expr-type) ,(map (lambda (c e et) @@ -275,7 +275,7 @@ [cs (fold-left constraint-merge '() (append case-match-equality-cs case-expr-equality-cs - (cadr expr-type-res)))]) + (car expr-type-res)))]) (list cs resolved-type annotated))]))) ;; (display "result of ")