Refactor ast "pattern matching" to a single function

diff --git a/ast.scm b/ast.scm
index 2ffad975f66f1ec4fbca3f32f095e484658ed726..8dac3b68833ca430d27015b8a97263a72c531f37 100644 (file)
--- a/ast.scm
+++ b/ast.scm
@@ -1,11 +1,28 @@
-(define (app? x)
-  (and (list? x)
-       (>= (length x) 2)
-       (not (eq? (car x) 'let))
-       (not (eq? (car x) 'lambda))))
+(define (ast-type x)
+  (define (builtin? x)
+    (case x
+      ('+ #t)
+      ('- #t)
+      ('* #t)
+      ('! #t)
+      ('= #t)
+      ('bool->int #t)
+      (else #f)))
+  (cond
+   ((list? x)
+    (case (car x)
+      ('if 'if)
+      ('let 'let)
+      ('lambda 'lambda)
+      ('closure 'closure) ; only available in codegen
+      (else 'app)))
+   ((builtin? x) 'builtin)
+   ((symbol? x) 'var)
+   ((integer? x) 'int-literal)
+   ((boolean? x) 'bool-literal)))

 
 

-(define (let? x)
-  (and (list? x) (eq? (car x) 'let)))
+;; (define (ast-recurse f x)
+;;   (cond (

 
 (define let-bindings cadr)
 (define let-body cddr)
 
 (define let-bindings cadr)
 (define let-body cddr)


@@ -18,15 +35,3 @@
 ; for use elsewhere
 (define lambda-args cadr)
 (define lambda-body caddr)
 ; for use elsewhere
 (define lambda-args cadr)
 (define lambda-body caddr)

-
-(define (var? x)
-  (and (not (list? x)) (symbol? x)))
-
-(define (builtin? x)
-  (case x
-    ('+ #t)
-    ('- #t)
-    ('* #t)
-    ('! #t)
-    ('bool->int #t)
-    (else #f)))

diff --git a/codegen.scm b/codegen.scm
index e1b51a60a5ac6c9fcde9f23dd4ca58e9c02f2274..70a8ca4aa0df75518989d386502765e90e535137 100644 (file)
--- a/codegen.scm
+++ b/codegen.scm
@@ -136,10 +136,10 @@
        ))))                    ; move args and capture vars to stack
 
 (define (codegen-expr e si env)
        ))))                    ; move args and capture vars to stack
 
 (define (codegen-expr e si env)

-  (cond ((builtin? e) e)
-       ((closure? e) e)
-       
-       ((app? e)
+  (case (ast-type e)
+    ('builtin e)
+    ('closure e)
+    ('app

      (let ((callee (codegen-expr (car e) si env)))
        (case callee
         ('+ (codegen-add (cdr e) si env))
      (let ((callee (codegen-expr (car e) si env)))
        (case callee
         ('+ (codegen-add (cdr e) si env))


@@ -149,29 +149,34 @@
         ('bool->int (codegen-expr (cadr e) si env))
         (else (codegen-call callee (cdr e) si env)))))
 
         ('bool->int (codegen-expr (cadr e) si env))
         (else (codegen-call callee (cdr e) si env)))))
 

-       ((let? e) (codegen-let
-                  (let-bindings e)
+    ('let (codegen-let (let-bindings e)

                       (let-body e)
                       si
                       env))
                       (let-body e)
                       si
                       env))

-       ((var? e) (codegen-var e si env))
-       ((boolean? e) (emit "movq $~a, %rax" (if e 1 0)))
-       (else (emit "movq $~a, %rax" e))))
+
+    ('var (codegen-var e si env))
+
+    ('string-literal (emit "movq ~a, %rax" label))
+    ('bool-literal (emit "movq $~a, %rax" (if e 1 0)))
+    ('int-literal (emit "movq $~a, %rax" e))
+
+    (else (error #f "don't know how to codegen this"))))
+

 
 (define (fold-map f x) (fold-left append '() (map f x)))
 
 (define (free-vars prog)
   (define bound '())
   (define (collect e)
 
 (define (fold-map f x) (fold-left append '() (map f x)))
 
 (define (free-vars prog)
   (define bound '())
   (define (collect e)

-    (cond
-     ((builtin? e) '()) ; do nothing
-     ((var? e) (if (memq e bound) '() (list e)))
-     ((lambda? e)
+    (case (ast-type e)
+      ('builtin '()) ; do nothing
+      ('var (if (memq e bound) '() (list e)))
+      ('lambda

          (set! bound (append (lambda-args e) bound))
        (collect (lambda-body e)))
 
          (set! bound (append (lambda-args e) bound))
        (collect (lambda-body e)))
 

-     ((app? e) (fold-map collect e))
-     ((let? e)
+      ('app (fold-map collect e))
+      ('let

          (let ((bind-fvs (fold-map (lambda (a)
                                      ((set! bound (cons (car a) bound))
                                       (collect (cdr a))))
          (let ((bind-fvs (fold-map (lambda (a)
                                      ((set! bound (cons (car a) bound))
                                       (collect (cdr a))))


@@ -181,9 +186,6 @@
       (else '())))
   (collect prog))
 
       (else '())))
   (collect prog))
 

-(define (closure? e)
-  (and (list? e) (eqv? (car e) 'closure)))
-

                                        ; ((lambda (x) (+ x 1)) 42) => {lambda0: (x) (+ x 1)}, (@lambda0 42)
 (define (extract-lambdas program)
   (define lambdas '())
                                        ; ((lambda (x) (+ x 1)) 42) => {lambda0: (x) (+ x 1)}, (@lambda0 42)
 (define (extract-lambdas program)
   (define lambdas '())


@@ -196,17 +198,19 @@
       (set! lambdas (cons new-lambda lambdas))
       `(closure ,label ,captured))) ; todo: should we string->symbol?
   (define (extract e)
       (set! lambdas (cons new-lambda lambdas))
       `(closure ,label ,captured))) ; todo: should we string->symbol?
   (define (extract e)

-    (cond
-     ((lambda? e) (add-lambda e))
-     ((let? e) `(let
+    (case (ast-type e)
+     ('lambda (add-lambda e))
+     ('let `(let

                    ,(map extract (let-bindings e))
                  ,@(map extract (let-body e))))
                    ,(map extract (let-bindings e))
                  ,@(map extract (let-body e))))

-     ((app? e) (append (list (extract (car e)))
+     ('app (append (list (extract (car e)))

                       (map extract (cdr e))))
      (else e)))
   (let ((transformed (extract program)))
     (cons lambdas transformed)))
 
                       (map extract (cdr e))))
      (else e)))
   (let ((transformed (extract program)))
     (cons lambdas transformed)))
 

+;(define (extract-strings program))
+

 (define (amd64-abi f)
                                        ; preserve registers
   (emit "push %rbp")
 (define (amd64-abi f)
                                        ; preserve registers
   (emit "push %rbp")


@@ -248,8 +252,6 @@
     (else (error #f "need to test out the below"))
     (else (format "~a(%rsp)" (- n 6)))))
 
     (else (error #f "need to test out the below"))
     (else (format "~a(%rsp)" (- n 6)))))
 

-                
-

 (define (codegen program)
   (let* ((extract-result (extract-lambdas program))
         (lambdas (car extract-result))
 (define (codegen program)
   (let* ((extract-result (extract-lambdas program))
         (lambdas (car extract-result))

diff --git a/typecheck.scm b/typecheck.scm
index 55c2fd8201f2467ff3e136189412b6dc351780fd..197798e104a7595f5637646cb102f2d9d99f44d5 100644 (file)
--- a/typecheck.scm
+++ b/typecheck.scm
@@ -48,25 +48,28 @@
 
                                        
 (define (normalize prog) ; (+ a b) -> ((+ a) b)
 
                                        
 (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 (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)))))
        (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)
      (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))))
        (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)
     (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 int)))
     ('* '(abs int (abs int int)))
     ('! '(abs bool bool))

+    ('= '(abs int (abs int bool)))

     ('bool->int '(abs bool int))
     (else #f)))
 
     ('bool->int '(abs bool int))
     (else #f)))
 


@@ -88,12 +92,28 @@
     ;; (newline)
     (let
        ((res
     ;; (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
            (let ((new-env (fold-left
                            (lambda (acc bind)
                              (let ((t (check


@@ -104,7 +124,7 @@
              (check new-env (last (let-body x)))))
                  
 
              (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))
            (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)))))
           
                          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)))
            (let* ((arg-type-res (check env (cadr x)))
                   (arg-type (cadr arg-type-res))
                   (func-type-res (check env (car x)))