X-Git-Url: http://git.lukelau.me/?p=scheme.git;a=blobdiff_plain;f=typecheck.scm;h=7eb4fa96606d786b5e58d17f2d2601f4f52c85a3;hp=55c2fd8201f2467ff3e136189412b6dc351780fd;hb=91145e54f41ee88f1e279a80430b3f5ed4e7a8c6;hpb=e51b9e423665428c41cddac0642d1e34b18ca1da

diff --git a/typecheck.scm b/typecheck.scm
index 55c2fd8..7eb4fa9 100644
--- a/typecheck.scm
+++ b/typecheck.scm
@@ -10,6 +10,7 @@
   (case t
     ('int #t)
     ('bool #t)
+    ('void #t)
     (else #f)))
 
 (define (pretty-type t)
@@ -46,28 +47,25 @@
       (car xs)
       (last (cdr xs))))
 				
-					
 (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))))
-   (else prog)))
+    (else (ast-traverse normalize prog))))
 
 (define (builtin-type x)
   (case x
@@ -75,7 +73,9 @@
     ('- '(abs int (abs int int)))
     ('* '(abs int (abs int int)))
     ('! '(abs bool bool))
+    ('= '(abs int (abs int bool)))
     ('bool->int '(abs bool int))
+    ('print '(abs string void))
     (else #f)))
 
 ; we typecheck the lambda calculus only (only single arg lambdas)
@@ -88,12 +88,29 @@
     ;; (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))
+	   ('string-literal (list '() 'string))
+	   ('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 +121,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 +140,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)))