From: Luke Lau <luke_lau@icloud.com>
Date: Sun, 21 Jul 2019 00:40:02 +0000 (+0100)
Subject: Add more binary ops
X-Git-Url: http://git.lukelau.me/?p=scheme.git;a=commitdiff_plain;h=da18430cebcb7b813c9b29841f78d65580c91684

Add more binary ops
---

diff --git a/codegen.scm b/codegen.scm
index 76fa671..3a01dff 100644
--- a/codegen.scm
+++ b/codegen.scm
@@ -9,19 +9,35 @@
 (define (codegen-add xs si env)
   (define (go ys)
     (if (null? ys)
-      (emit "movq %rbx, %rax")
+      (emit "movq ~a(%rsp), %rax" si)
       (begin
 	(let ((y (car ys)))
 	     (if (integer? y)
-		 (emit "addq $~a, %rbx" y)
+		 (emit "addq $~a, ~a(%rsp)" y si)
 		 (begin
-		   (codegen-expr y si env)
-		   (emit "addq %rax, %rbx"))))
+		   (codegen-expr y (- si wordsize) env)
+		   (emit "addq %rax, ~a(%rsp)" si))))
 	(go (cdr ys)))))
   (begin
-    (emit "movq $0, %rbx")
+					; use si(%rsp) as the accumulator
+    (emit "movq $0, ~a(%rsp)" si)
     (go xs)))
 
+(define (codegen-binop opcode)
+  (lambda (a b si env)
+    (codegen-expr b si env)
+    (emit "movq %rax, ~a(%rsp)" si)
+    (codegen-expr a (- si wordsize) env)
+    (emit "~a ~a(%rsp), %rax" opcode si)))
+
+(define codegen-sub (codegen-binop "sub"))
+(define codegen-mul (codegen-binop "imul"))
+
+(define (codegen-not x si env)
+  (codegen-expr x si env)
+  (emit "xorq $-1, %rax")
+  (emit "andq $1, %rax"))
+
 (define (range s n)
   (if (= 0 n) '()
       (append (range s (- n 1))
@@ -47,14 +63,21 @@
     (emit "movq ~a(%rsp), %rax" offset)))
 
 (define (codegen-expr e si env)
-  (cond ((and (list? e) (eq? (car e) '+))
-	 (codegen-add (cdr e) si env))
+  (cond ((app? e)
+	 (case (car e)
+	   ('+ (codegen-add (cdr e) si env))
+	   ('- (codegen-sub (cadr e) (caddr e) si env))
+	   ('* (codegen-mul (cadr e) (caddr e) si env))
+	   ('! (codegen-not (cadr e) si env))
+	   ('bool->int (codegen-expr (cadr e) si env))
+	   (else (error #f "can't handle anything else yet"))))
 	((let? e) (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))))
 
 (define (codegen program)
diff --git a/main.scm b/main.scm
index 29c03e5..289840b 100644
--- a/main.scm
+++ b/main.scm
@@ -1,6 +1,6 @@
 (load "codegen.scm")
 
 (compile-to-binary
- (if (>= (length (command-line)) 1)
+ (if (> (length (command-line)) 1)
      (call-with-input-file (cadr (command-line)) read)
      (read)))
diff --git a/typecheck.scm b/typecheck.scm
index eaff75e..59e652a 100644
--- a/typecheck.scm
+++ b/typecheck.scm
@@ -43,6 +43,14 @@
 	    (map normalize (let-body prog))))
    (else prog)))
 
+(define (builtin-type x)
+  (case x
+    ('+ '(abs int (abs int int)))
+    ('- '(abs int (abs int int)))
+    ('* '(abs int (abs int int)))
+    ('! '(abs bool bool))
+    ('bool->int '(abs bool int))
+    (else #f)))
 
 ; we typecheck the lambda calculus only (only single arg lambdas)
 (define (typecheck prog)
@@ -57,10 +65,8 @@
 	  (cond
 	   ((integer? x) (list '() 'int))
 	   ((boolean? x) (list '() 'bool))
-	   ((eq? x 'inc) (list '() '(abs int int)))
-	   ((eq? x '+)   (list '() '(abs int (abs int int))))
+	   ((builtin-type x) (list '() (builtin-type x)))
 	   ((symbol? x)  (list '() (env-lookup env x)))
-
 	   ((let? x)
 	    (let ((new-env (fold-left
 			    (lambda (acc bind)