Add some documentation to the abi

[scheme.git] / typecheck.scm

diff --git a/typecheck.scm b/typecheck.scm
index 21b874c2fdc043b41297575d84bdd12132d559a5..7eb4fa96606d786b5e58d17f2d2601f4f52c85a3 100644 (file)
--- 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,25 +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))
-       (cons (normalize (car prog)) (normalize (cdr prog))) ; (f a)
-       (list (list (normalize (car prog)) (normalize (cadr prog))) (normalize (caddr prog))))) ; (f a b)
-   ((let? prog)
+        `(,(normalize (car prog)) ,(normalize (cadr prog))) ; (f a)
+        `(,(list (normalize (car prog)) (normalize (cadr prog)))
+          ,(normalize (caddr prog))))) ; (f a b)
+    ('let
        (append (list 'let
-                 (map (lambda (x) (cons (car x) (normalize (cdr x))))
+                     (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
@@ -72,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)
@@ -85,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
@@ -101,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))
@@ -120,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)))