diff options
| -rw-r--r-- | Makefile | 7 | ||||
| -rw-r--r-- | compiler.scm | 162 |
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")) |