summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--Makefile7
-rw-r--r--compiler.scm162
2 files changed, 150 insertions, 19 deletions
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"))