+(load "typecheck.scm")
+
+(define (emit . s)
+ (begin
+ (apply printf s)
+ (display "\n")))
+
+(define (compile-add xs)
+ (define (go ys)
+ (if (null? ys)
+ (emit "movq %rbx, %rax")
+ (begin
+ (emit "addq $~a, %rbx" (car ys))
+ (go (cdr ys)))))
+ (begin
+ (emit "movq $0, %rbx")
+ (go xs)))
+
+(define (compile-expr e)
+ (if (and (list? e) (eq? (car e) '+))
+ (compile-add (cdr e))
+ (emit "movq $~a, %rax" e)))
+
+(define (compile-program program)
+ (emit ".text")
+ (emit ".p2align 4,,15")
+ (emit ".globl _scheme_entry")
+ (emit "_scheme_entry:")
+
+ ; handle incoming call from C
+ (emit "push %rbp")
+ (emit "push %rbx")
+ (for-each (lambda (i)
+ (emit (string-append
+ "push %r"
+ (number->string i))))
+ '(12 13 14 15))
+
+ ; our code goes here
+ (compile-expr program)
+
+ ; restore preserved registers
+ (for-each (lambda (i)
+ (emit (string-append
+ "pop %r"
+ (number->string i))))
+ '(15 14 13 12))
+ (emit "pop %rbx")
+ (emit "pop %rbp")
+
+ (emit "ret"))
+
+(define (compile-to-binary program)
+ (when (not (eq? (typecheck program) 'int)) (error #f "not an int"))
+ (let ([tmp-path "/tmp/a.s"])
+ (when (file-exists? tmp-path) (delete-file tmp-path))
+ (with-output-to-file tmp-path
+ (lambda () (compile-program program)))
+ (system "clang -fomit-frame-pointer /tmp/a.s rts.c")))