Add let bindings

Also split out some helpers into a separate ast file
Need to split compiler out into codegen and main

diff --git a/ast.scm b/ast.scm
new file mode 100644 (file)
index 0000000..19dc7a0
--- /dev/null
+++ b/ast.scm
@@ -0,0 +1,20 @@
+(define (app? x)
+  (and (list? x)
+       (>= (length x) 2)
+       (not (eq? (car x) 'let))
+       (not (eq? (car x) 'lambda))))
+
+(define (let? x)
+  (and (list? x) (eq? (car x) 'let)))
+
+(define let-bindings cadr)
+(define let-body cddr)
+
+(define (lambda? x)
+  (and (list? x) (eq? (car x) 'lambda)))
+
+(define lambda-arg cadr)
+(define lambda-body cddr)
+
+(define (var? x)
+  (and (not (list? x)) (symbol? x)))

diff --git a/compiler.scm b/compiler.scm
index 351e11b7695f927121d574baef27924ed2d31f67..d79a37a26f77babdd28040991efa8003ca25ecc1 100644 (file)
--- a/compiler.scm
+++ b/compiler.scm
@@ -1,11 +1,12 @@
 (load "typecheck.scm")
+(load "ast.scm")
 
 (define (emit . s)
   (begin
     (apply printf s)
     (display "\n")))
 
-(define (compile-add xs)
+(define (codegen-add xs)
   (define (go ys)
     (if (null? ys)
       (emit "movq %rbx, %rax")
@@ -16,12 +17,42 @@
     (emit "movq $0, %rbx")
     (go xs)))
 
-(define (compile-expr e)
-  (if (and (list? e) (eq? (car e) '+))
-      (compile-add (cdr e))
-      (emit "movq $~a, %rax" e)))
+(define (range s n)
+  (if (= 0 n) '()
+      (append (range s (- n 1))
+             (list (+ s (- n 1))))))
 
-(define (compile-program program)
+(define wordsize 8)
+
+(define (codegen-let bindings body si env)
+  (let* ((stack-offsets (map (lambda (x) (- si (* x wordsize)))
+                            (range 0 (length bindings))))
+        (inner-si (- si (* (length bindings) wordsize)))
+        (names (map car bindings))
+        (exprs (map cadr bindings))
+        (inner-env (append (map cons names stack-offsets) env)))
+  (for-each (lambda (expr offset)
+             (codegen-expr expr inner-si env)
+             (emit "movq %rax, ~a(%rsp)" offset))
+           exprs stack-offsets)
+  (for-each (lambda (form) (codegen-expr form inner-si inner-env)) body)))
+
+(define (codegen-var name si env)
+  (let ((offset (cdr (assoc name env))))
+    (emit "movq ~a(%rsp), %rax" offset)))
+
+(define (codegen-expr e si env)
+  (cond ((and (list? e) (eq? (car e) '+))
+        (codegen-add (cdr e)))
+       ((let? e) (codegen-let
+                  (let-bindings e)
+                  (let-body e)
+                  si
+                  env))
+       ((var? e) (codegen-var e si env))
+       (else (emit "movq $~a, %rax" e))))
+
+(define (codegen program)
   (emit ".text")
   (emit ".p2align 4,,15")
   (emit ".globl _scheme_entry")
@@ -37,7 +68,7 @@
            '(12 13 14 15))
 
   ; our code goes here
-  (compile-expr program)
+  (codegen-expr program 0 '())
 
   ; restore preserved registers
   (for-each (lambda (i)
@@ -55,5 +86,5 @@
   (let ([tmp-path "/tmp/a.s"])
     (when (file-exists? tmp-path) (delete-file tmp-path))
     (with-output-to-file tmp-path
-      (lambda () (compile-program program)))
+      (lambda () (codegen program)))
     (system "clang -fomit-frame-pointer /tmp/a.s rts.c")))

diff --git a/typecheck.scm b/typecheck.scm
index 0e4e265f2d2a47f81b8a13ea4ade24914c3b33a1..a7384294ac0e5ad2e4d7225a53cca150b93ba2ea 100644 (file)
--- a/typecheck.scm
+++ b/typecheck.scm
@@ -1,18 +1,13 @@
-(define (app? x)
-  (and (list? x) (>= (length x) 2) (not (eq? (car x) 'lambda))))
-
-(define (lambda? x)
-  (and (list? x) (eq? (car x) 'lambda)))
-
-(define lambda-arg caadr)
-(define lambda-body caddr)
-
+(load "ast.scm")
                                        ; ('a, ('b, 'a))
-(define (env-lookup env x)
+(define (env-lookup env n)
   (if (null? env) (error #f "empty env")                       ; it's a type equality
-      (if (eq? (caar env) x)
+      (if (eq? (caar env) n)
          (cdar env)
-         (env-lookup (cdr env) x))))
+         (env-lookup (cdr env) n))))
+
+(define (env-insert env n t)
+  (cons (cons n t) env))
 
 (define abs-arg cadr)
 
@@ -23,19 +18,32 @@
     (string->symbol
      (string-append "t" (number->string (- cur-tvar 1))))))
 
+(define (last xs)
+  (if (null? (cdr xs))
+      (car xs)
+      (last (cdr xs))))
+
                                        
 (define (normalize prog) ; (+ a b) -> ((+ a) b)
   (cond
-   ((lambda? prog) '(lambda (lambda-arg prog) (normalize (lambda-body prog))))
+   ((lambda? prog) (list 'lambda (lambda-arg prog) (normalize (lambda-body prog))))
    ((app? prog)
     (if (null? (cddr prog))
        (cons (normalize (car prog)) (normalize (cdr prog))) ; (f a)
        (normalize (cons (cons (car prog) (list (cadr prog))) (cddr prog))))) ; (f a b)
+   ((let? prog)
+    (append (list 'let
+                 (map (lambda (x) (cons (car x) (normalize (cdr x))))
+                      (let-bindings prog)))
+           (map normalize (let-body prog))))
    (else prog)))
 
 
 (define (typecheck prog)
   (define (check env x)
+    ;; (display "check: ")
+    ;; (display x)
+    ;; (display "\n")
     (let
        ((res
          (cond
@@ -45,6 +53,17 @@
           ((eq? x '+)   (list '() '(abs int (abs int int))))
           ((symbol? x) (list '() (env-lookup env x)))
 
+          ((let? x)
+           (let ((new-env (fold-left
+                           (lambda (acc bind)
+                             (let ((t (check
+                                       (env-insert acc (car bind) (fresh-tvar))
+                                       (cadr bind))))
+                               (env-insert acc (car bind) (cadr t))))
+                           env (let-bindings x))))
+             (check new-env (last (let-body x)))))
+                 
+
           ((lambda? x)
            (let* ((new-env (cons (cons (lambda-arg x) (fresh-tvar)) env))
                   (body-type-res (check new-env (lambda-body x)))
@@ -86,7 +105,7 @@
              (if (abs? resolved-func-type)
                  (let ((return-type (substitute cs (caddr resolved-func-type))))
                    (list cs return-type))
-                 (error #f "wah")))))))
+                 (error #f "not a function")))))))
       ;; (display "result of ")
       ;; (display x)
       ;; (display ":\n\t")
@@ -123,16 +142,18 @@
                                        ; TODO: what's the most appropriate substitution?
                                        ; should all constraints just be limited to a pair?
 (define (substitute cs t)
-  (define (blah c)
+                                       ; gets the first concrete type
+                                       ; otherwise returns the last type variable
+  (define (get-concrete c)
     (if (null? (cdr c))
        (car c)
        (if (not (tvar? (car c)))
            (car c)
-           (blah (cdr c)))))
+           (get-concrete (cdr c)))))
   (fold-left
    (lambda (t c)
      (if (member t c)
-        (blah c)
+        (get-concrete c)
         t))
    t cs))