From: Luke Lau <luke_lau@icloud.com>
Date: Mon, 22 Jul 2019 23:03:24 +0000 (+0100)
Subject: Refactor ast "pattern matching" to a single function
X-Git-Url: https://git.lukelau.me/?p=scheme.git;a=commitdiff_plain;h=31e29e5a1880862f7786abd7f1df911f5acf651d

Refactor ast "pattern matching" to a single function
---

diff --git a/ast.scm b/ast.scm
index 2ffad97..8dac3b6 100644
--- 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)
@@ -18,15 +35,3 @@
 ; 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 e1b51a6..70a8ca4 100644
--- a/codegen.scm
+++ b/codegen.scm
@@ -136,10 +136,10 @@
        ))))			; 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))
@@ -149,29 +149,34 @@
 	 ('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))
-	((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)
-    (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)))
 
-     ((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))))
@@ -181,9 +186,6 @@
       (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 '())
@@ -196,17 +198,19 @@
       (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))))
-     ((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)))
 
+;(define (extract-strings program))
+
 (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)))))
 
-		 
-
 (define (codegen program)
   (let* ((extract-result (extract-lambdas program))
 	 (lambdas (car extract-result))
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)))