From 091169d9291b9232c9fcb2c7d0cbc8e53375fda2 Mon Sep 17 00:00:00 2001
From: David Thompson <dthompson@vistahigherlearning.com>
Date: Wed, 10 Aug 2022 21:45:14 -0400
Subject: Step 3: Unary Primitives

---
 Makefile     |   7 ---
 compiler.scm | 162 ++++++++++++++++++++++++++++++++++++++++++++++++++++++-----
 2 files changed, 150 insertions(+), 19 deletions(-)
 delete mode 100644 Makefile

diff --git a/Makefile b/Makefile
deleted file mode 100644
index 513a132..0000000
--- a/Makefile
+++ /dev/null
@@ -1,7 +0,0 @@
-test:
-	gcc -c scheme_entry.S
-	gcc -c test.c
-	gcc -o test scheme_entry.o test.o
-	./test
-
-.PHONY: test
diff --git a/compiler.scm b/compiler.scm
index 919be4c..12ab894 100644
--- a/compiler.scm
+++ b/compiler.scm
@@ -1,18 +1,24 @@
-(use-modules (ice-9 format))
+(use-modules (ice-9 format)
+             (ice-9 popen)
+             (ice-9 rdelim)
+             (srfi srfi-1))
 
 (define (emit template-string . args)
   (apply format #t template-string args)
   (newline))
 
-(define (compile-program x)
-  (define fixnum-shift 2)
-  (define fixnum-tag 0)
-  (define char-shift 8)
-  (define char-tag 15)
-  (define boolean-shift 7)
-  (define boolean-tag 31)
-  (define empty-list 47) ;; #b00101111
-  (define (immediate-rep x)
+(define fixnum-mask 3)
+(define fixnum-shift 2)
+(define fixnum-tag 0)
+(define char-mask 255)
+(define char-shift 8)
+(define char-tag 15)
+(define boolean-mask 127)
+(define boolean-shift 7)
+(define boolean-tag 31)
+(define empty-list 47) ;; #b00101111
+
+(define (immediate-rep x)
     (cond
      ((integer? x)
       (ash x fixnum-shift))
@@ -22,6 +28,93 @@
       (logior (ash (if x 1 0) boolean-shift) boolean-tag))
      ((null? x)
       empty-list)))
+
+(define (immediate? x)
+  (or (integer? x)
+      (char? x)
+      (boolean? x)
+      (null? x)))
+
+(define (primcall? x)
+  (and (pair? x)
+       (memq (first x)
+             '(add1
+               sub1
+               integer->char
+               char->integer
+               zero?
+               null?
+               integer?
+               char?
+               boolean?))))
+
+(define (primcall-op x)
+  (first x))
+
+(define (primcall-operand1 x)
+  (second x))
+
+(define (emit-tag-check x mask tag)
+  (emit-expr x)
+  (emit "andl $~a, %eax" mask)
+  (emit "cmpl $~a, %eax" tag)
+  (emit "movl $0, %eax")
+  (emit "sete %al")
+  (emit "sall $~a, %eax" boolean-shift)
+  (emit "orl $~a, %eax" boolean-tag))
+
+(define (emit-expr x)
+  (cond
+   ((immediate? x)
+    (emit "movl $~a, %eax" (immediate-rep x)))
+   ((primcall? x)
+    (case (primcall-op x)
+      ((add1)
+       (emit-expr (primcall-operand1 x))
+       (emit "addl $~a, %eax" (immediate-rep 1)))
+      ((sub1)
+       (emit-expr (primcall-operand1 x))
+       (emit "subl $~a, %eax" (immediate-rep 1)))
+      ((integer->char)
+       (emit-expr (primcall-operand1 x))
+       (emit "sall $~a, %eax" (- char-shift fixnum-shift))
+       (emit "orl $~a, %eax" char-tag))
+      ((char->integer)
+       (emit-expr (primcall-operand1 x))
+       (emit "shr $~a, %eax" (- char-shift fixnum-shift)))
+      ((zero?)
+       (emit-expr (primcall-operand1 x))
+       ;; Since the tag of fixnums is 0, we can skip an 'andl'
+       ;; instruction that would apply the mask to the immediate
+       ;; value.
+       (emit "cmpl $0, %eax")
+       (emit "movl $0, %eax")
+       (emit "sete %al")
+       (emit "sall $~a, %eax" boolean-shift)
+       (emit "orl $~a, %eax" boolean-tag))
+      ((null?)
+       (emit-expr (primcall-operand1 x))
+       (emit "cmpl $~a, %eax" empty-list)
+       (emit "movl $0, %eax")
+       (emit "sete %al")
+       (emit "sall $~a, %eax" boolean-shift)
+       (emit "orl $~a, %eax" boolean-tag))
+      ((integer?)
+       (emit-tag-check (primcall-operand1 x) fixnum-mask fixnum-tag))
+      ((char?)
+       (emit-tag-check (primcall-operand1 x) char-mask char-tag))
+      ((boolean?)
+       (emit-tag-check (primcall-operand1 x) boolean-mask boolean-tag))
+      (else
+       (error "unknown primcall op" (primcall-op x)))))
+   (else
+    (error "unknown expression" x))))
+
+(define (compile-program x)
+  (emit-expr x)
+  (emit "ret"))
+
+(define (compile-and-run x)
   (with-output-to-file "scheme_entry.S"
     (lambda ()
       (display ".text
@@ -30,5 +123,50 @@
 .type	scheme_entry, @function
 scheme_entry:
 ")
-      (emit "movl $~a, %eax" (immediate-rep x))
-      (emit "ret"))))
+      (compile-program x)))
+  (and (zero? (system* "gcc" "-c" "scheme_entry.S"))
+       (zero? (system* "gcc" "-c" "test.c"))
+       (zero? (system* "gcc" "-o" "test" "scheme_entry.o" "test.o"))
+       (let* ((pipe (open-pipe* OPEN_READ "./test"))
+              (output (read-line pipe)))
+         (close pipe)
+         output)))
+
+(define (test-case x expected-output)
+  (let ((result (compile-and-run x)))
+    (if (string=? result expected-output)
+        #t
+        (begin
+          (display "expected: ")
+          (display expected-output)
+          (display ", got: ")
+          (display result)
+          (newline)
+          #f))))
+
+(begin
+  (test-case 1 "1")
+  (test-case #\b "b")
+  (test-case #t "#t")
+  (test-case #f "#f")
+  (test-case '(add1 3) "4")
+  (test-case '(sub1 3) "2")
+  (test-case '(integer->char 98) "b")
+  (test-case '(char->integer #\b) "98")
+  (test-case '(zero? 1) "#f")
+  (test-case '(zero? 0) "#t")
+  (test-case '(null? 1) "#f")
+  (test-case '(null? #\b) "#f")
+  (test-case '(null? #t) "#f")
+  (test-case '(null? #f) "#f")
+  (test-case '(null? ()) "#t")
+  (test-case '(integer? #\b) "#f")
+  (test-case '(integer? #f) "#f")
+  (test-case '(integer? 1) "#t")
+  (test-case '(char? 1) "#f")
+  (test-case '(char? #f) "#f")
+  (test-case '(char? #\b) "#t")
+  (test-case '(boolean? 1) "#f")
+  (test-case '(boolean? #\b) "#f")
+  (test-case '(boolean? #f) "#t")
+  (test-case '(boolean? #t) "#t"))
-- 
cgit v1.2.3