X-Git-Url: https://git.lukelau.me/?p=scheme.git;a=blobdiff_plain;f=typecheck.scm;h=197798e104a7595f5637646cb102f2d9d99f44d5;hp=55c2fd8201f2467ff3e136189412b6dc351780fd;hb=31e29e5a1880862f7786abd7f1df911f5acf651d;hpb=8aacba5976424791fb51d5d36118269d32c4096a

diff --git a/typecheck.scm b/typecheck.scm
index 55c2fd8..197798e 100644
--- a/typecheck.scm
+++ b/typecheck.scm
@@ -48,25 +48,28 @@
 
 					
 (define (normalize prog) ; (+ a b) -> ((+ a) b)
-  (cond
+  (case (ast-type prog)
+    ('lambda 
 					; (lambda (x y) (+ x y)) -> (lambda (x) (lambda (y) (+ x y)))
-   ((lambda? prog)
 	(if (> (length (lambda-args prog)) 1)
 	    (list 'lambda (list (car (lambda-args prog)))
 		  (normalize (list 'lambda (cdr (lambda-args prog)) (caddr prog))))
 	    (list 'lambda (lambda-args prog) (normalize (caddr prog)))))
-   ((app? prog)
+    ('app
      (if (null? (cddr prog))
 	 `(,(normalize (car prog)) ,(normalize (cadr prog))) ; (f a)
 	 `(,(list (normalize (car prog)) (normalize (cadr prog)))
 	   ,(normalize (caddr prog))))) ; (f a b)
     ;; (list (list (normalize (car prog))
     ;; 	    (normalize (cadr prog))) (normalize (caddr prog))))) ; (f a b)
-   ((let? prog)
+    ('let
 	(append (list 'let
 		      (map (lambda (x) `(,(car x) ,(normalize (cadr x))))
 			   (let-bindings prog)))
 		(map normalize (let-body prog))))
+    ('if `(if ,(normalize (cadr prog))
+	      ,(normalize (caddr prog))
+	      ,(normalize (cadddr prog))))
     (else prog)))
 
 (define (builtin-type x)
@@ -75,6 +78,7 @@
     ('- '(abs int (abs int int)))
     ('* '(abs int (abs int int)))
     ('! '(abs bool bool))
+    ('= '(abs int (abs int bool)))
     ('bool->int '(abs bool int))
     (else #f)))
 
@@ -88,12 +92,28 @@
     ;; (newline)
     (let
 	((res
-	  (cond
-	   ((integer? x) (list '() 'int))
-	   ((boolean? x) (list '() 'bool))
-	   ((builtin-type x) (list '() (builtin-type x)))
-	   ((symbol? x)  (list '() (env-lookup env x)))
-	   ((let? x)
+	  (case (ast-type x)
+	   ('int-literal (list '() 'int))
+	   ('bool-literal (list '() 'bool))
+	   ('builtin (list '() (builtin-type x)))
+
+	   ('if
+	    (let* ((cond-type-res (check env (cadr x)))
+		   (then-type-res (check env (caddr x)))
+		   (else-type-res (check env (cadddr x)))
+		   (then-eq-else-cs (unify (cadr then-type-res)
+					   (cadr else-type-res)))
+		   (cs (consolidate
+			(car then-type-res)
+			(consolidate (car else-type-res)
+				     then-eq-else-cs)))
+		   (return-type (substitute cs (cadr then-type-res))))
+	      (when (not (eqv? (cadr cond-type-res) 'bool))
+		(error #f "if condition isn't bool"))
+	      (list cs return-type)))
+	   
+	   ('var  (list '() (env-lookup env x)))
+	   ('let
 	    (let ((new-env (fold-left
 			    (lambda (acc bind)
 			      (let ((t (check
@@ -104,7 +124,7 @@
 	      (check new-env (last (let-body x)))))
 		  
 
-	   ((lambda? x)
+	   ('lambda
 	    (let* ((new-env (env-insert env (lambda-arg x) (fresh-tvar)))
 		   (body-type-res (check new-env (lambda-body x)))
 		   (cs (car body-type-res))
@@ -123,7 +143,7 @@
 			  resolved-arg-type
 			  (cadr body-type-res)))))
 	   
-	   ((app? x) ; (f a)
+	   ('app ; (f a)
 	    (let* ((arg-type-res (check env (cadr x)))
 		   (arg-type (cadr arg-type-res))
 		   (func-type-res (check env (car x)))