(define (double val) (+ val val))
(define (quadruple val) (double (double val)))
(define (1+ x) (+ x 1)) (define (1- x) (- x 1))
(define (filter fn lst) (if (null? lst) '()
(let ((first (car lst)) (rest (filter fn (cdr lst))))
(if (fn first) (cons first rest) rest))))
(define (char->string char) (let ((buf (make-string 1))) (string-set! buf 0 char) buf))
(define (string-idx-2 string char idx)
(cond ((= idx (string-length string)) #f)
((char=? (string-ref string idx) char) idx)
(else (string-idx-2 string char (1+ idx)))))
(define (string-idx string char) (string-idx-2 string char 0))
(define (emit . stuff) (emit-inline stuff) (newline))
(define (emit-inline stuff)
(cond ((null? stuff) #t)
((pair? stuff) (emit-inline (car stuff)) (emit-inline (cdr stuff)))
((string? stuff) (display stuff))
(else (error (list "emitting" stuff)))))
(define (insn . insn) (emit (cons " " insn)))
(define (comment . comment) (insn "# " comment))
(define (twoarg mnemonic) (lambda (src dest) (insn mnemonic " " src ", " dest)))
(define mov (twoarg "movl")) (define movb (twoarg "movb"))
(define movzbl (twoarg "movzbl"))
(define test (twoarg "test")) (define cmp (twoarg "cmpl"))
(define lea (twoarg "lea"))
(define add (twoarg "add")) (define sub (twoarg "sub"))
(define xchg (twoarg "xchg"))
(define asm-and (twoarg "and"))
(define (onearg mnemonic) (lambda (rand) (insn mnemonic " " rand)))
(define asm-push (onearg "push")) (define asm-pop (onearg "pop"))
(define jmp (onearg "jmp")) (define jnz (onearg "jnz"))
(define je (onearg "je")) (define jz je)
(define jnb (onearg "jnb")) (define jg (onearg "jg"))
(define js (onearg "js"))
(define call (onearg "call")) (define int (onearg "int"))
(define inc (onearg "inc")) (define dec (onearg "dec"))
(define idiv (onearg "idiv"))
(define sal (onearg "sal")) (define sar (onearg "sar"))
(define (ret) (insn "ret"))
(define (rep-stosb) (insn "rep stosb"))
(define (repe-cmpsb) (insn "repe cmpsb"))
(define eax "%eax") (define ebx "%ebx")
(define ecx "%ecx") (define edx "%edx")
(define ebp "%ebp") (define esp "%esp")
(define esi "%esi") (define edi "%edi")
(define al "%al")
(define (const x) (list "$" x))
(define (indirect x) (list "(" x ")"))
(define (offset x offset) (list (number->string offset) (indirect x)))
(define (absolute x) (list "*" x))
(define (index-register base index size)
(list base "," index "," (number->string size)))
(define (syscall) (int (const "0x80")))
(define (section name) (insn ".section " name))
(define (rodata) (section ".rodata"))
(define (text) (insn ".text"))
(define (label label) (emit label ":"))
(define (global-label lbl) (insn ".globl " lbl) (label lbl))
(define constcounters '())
(define constcounter 0)
(define label-prefix "k")
(define label-prefix-symbol 'k)
(define (stringlist->string stringlist)
(list->string (stringlist->string-2 stringlist 0)))
(define (stringlist->string-2 stringlist idx)
(if (null? stringlist) '()
(if (= idx (string-length (car stringlist)))
(stringlist->string-2 (cdr stringlist) 0)
(cons (string-ref (car stringlist) idx)
(stringlist->string-2 stringlist (1+ idx))))))
(define (set-label-prefix new-prefix)
(set! constcounters (cons (cons label-prefix-symbol constcounter)
constcounters))
(set! label-prefix (stringlist->string (cons "_"
(escape (symbol->string new-prefix) 0
'("+" "-" "=" "?" ">" "<" "!" "*")
'("Plus" "_" "Eq" "P" "Gt" "Lt" "Bang" "star")))))
(set! label-prefix-symbol (string->symbol label-prefix))
(set! constcounter
(let ((counterthing (assq label-prefix-symbol constcounters)))
(if counterthing (cdr counterthing)
0)))
)
(define (new-label)
(set! constcounter (1+ constcounter))
(list label-prefix "_" (number->string constcounter)))
(define (escape-char char dangerous escapes) (cond ((null? dangerous) (char->string char))
((char=? char (string-ref (car dangerous) 0))
(car escapes))
(else (escape-char char (cdr dangerous) (cdr escapes)))))
(define (escape string idx dangerous escapes) (if (= idx (string-length string)) '()
(cons (escape-char (string-ref string idx) dangerous escapes)
(escape string (1+ idx) dangerous escapes))))
(define (backslash string) (escape string 0 '("\\" "\n" "\"")
'("\\\\" "\\n" "\\\"")))
(define (asm-represent-string string) (list "\"" (backslash string) "\""))
(define (ascii string) (insn ".ascii " (asm-represent-string string)))
(define (rodatum labelname)
(rodata)
(comment "align pointers so they end in binary 00")
(insn ".align 4")
(label labelname))
(define (compile-word contents) (insn ".int " contents))
(define tos eax) (define nos (indirect esp))
(define (push-const val) (asm-push tos) (mov (const val) tos))
(define (pop) (asm-pop tos))
(define (dup) (asm-push tos))
(define (swap) (xchg tos nos))
(define stuff-to-put-in-the-header (lambda () #f))
(define (concatenate-thunks a b) (lambda () (a) (b)))
(define (add-to-header proc)
(set! stuff-to-put-in-the-header
(concatenate-thunks stuff-to-put-in-the-header proc)))
(define (define-error-routine labelname message)
(add-to-header (lambda ()
(let ((errlabel
(constant-string (string-append "error: "
(string-append message "\n")))))
(label labelname)
(mov (const errlabel) tos)
(jmp "report_error")))))
(add-to-header (lambda ()
(label "report_error")
(extract-string)
(comment "fd 2: stderr")
(mov (const "2") ebx)
(write_2)
(mov (const "1") ebx) (mov (const "1") eax) (syscall)))
(define (compile-tag-check-procedure desired-tag)
(get-procedure-arg 0)
(asm-and (const "3") tos)
(cmp (const desired-tag) tos)
(je "return_true")
(jmp "return_false"))
(define procedure-magic "0xca11ab1e")
(add-to-header (lambda ()
(label "ensure_procedure")
(if-not-right-magic-jump procedure-magic "not_procedure")
(ret)))
(define (ensure-procedure) (call "ensure_procedure"))
(define (compile-apply nargs)
(ensure-procedure)
(mov (offset tos 4) ebx) (mov (const (number->string nargs)) edx)
(call (absolute ebx)))
(define (compile-tail-apply nargs)
(comment "Tail call; nargs = " (number->string nargs))
(comment "Note %esp points at the last thing pushed,")
(comment "not the next thing to push. So for 1 arg, we want %ebx=%esp")
(lea (offset esp (quadruple (1- nargs))) ebx)
(pop-stack-frame edx)
(copy-args ebx nargs 0)
(asm-push edx)
(ensure-procedure)
(mov (offset tos 4) ebx)
(mov (const (number->string nargs)) edx)
(jmp (absolute ebx)))
(define (copy-args basereg nargs i)
(if (= nargs i) '()
(begin (asm-push (offset basereg (- 0 (quadruple i))))
(copy-args basereg nargs (1+ i)))))
(add-to-header
(lambda ()
(label "package_up_variadic_args")
(comment "we have %ebp pointing at args, %edx with count")
(comment "saved %ebp in %eax. zero-iterations case: return nil")
(push-const nil-value)
(label "variadic_loop")
(dec edx)
(comment "fucking dec doesn't update carry flag, so jump if negative")
(js "variadic_loop_end")
(comment "calling cons clobbers registers, so push %edx")
(asm-push edx)
(comment "now push args for cons")
(asm-push eax)
(asm-push (offset (index-register ebp edx 4) 4))
(comment "give cons its argument count")
(mov (const "2") edx)
(call "cons")
(comment "now the args are popped and we have new list in %eax")
(asm-pop edx)
(jmp "variadic_loop")
(label "variadic_loop_end")
(comment "now we pretend procedure was called with the list as first arg")
(mov eax (indirect ebp))
(comment "restore %eax to value on entry to package_up_variadic_args")
(pop)
(ret)))
(define (compile-variadic-prologue)
(comment "make space for variadic argument list")
(asm-pop ebx)
(asm-push ebx)
(asm-push ebx)
(comment "push desired %esp on return")
(lea (offset (index-register esp edx 4) 8) ebx)
(asm-push ebx)
(asm-push ebp) (lea (offset esp 12) ebp)
(call "package_up_variadic_args"))
(define (compile-procedure-prologue nargs)
(if (null? nargs) (compile-variadic-prologue)
(begin
(comment "compute desired %esp on return in %ebx and push it")
(lea (offset (index-register esp edx 4) 4) ebx)
(asm-push ebx)
(asm-push ebp) (lea (offset esp 12) ebp)
(cmp (const (number->string nargs)) edx)
(jnz "argument_count_wrong"))))
(define (compile-procedure-epilogue)
(comment "procedure epilogue")
(comment "get return address")
(pop-stack-frame edx)
(jmp (absolute edx)))
(define (pop-stack-frame return-address-register)
(mov (offset ebp -4) return-address-register)
(mov (offset ebp -8) esp)
(mov (offset ebp -12) ebp))
(define-error-routine "not_procedure" "not a procedure")
(define-error-routine "argument_count_wrong" "wrong number of arguments")
(define (compile-procedure bodylabel nargs body)
(text)
(label bodylabel)
(compile-procedure-prologue nargs)
(body)
(compile-procedure-epilogue))
(define (compile-procedure-labeled labelname nargs body)
(let ((bodylabel (new-label)))
(rodatum labelname)
(compile-word procedure-magic)
(compile-word bodylabel)
(compile-word "0") (compile-procedure bodylabel nargs body)))
(define (define-global-procedure symbolname nargs body)
(add-to-header
(lambda ()
(set-label-prefix symbolname)
(let ((procedure-value-label (new-label)))
(define-global-variable symbolname procedure-value-label)
(compile-procedure-labeled procedure-value-label nargs body)))))
(define (get-procedure-arg n)
(asm-push tos)
(mov (offset ebp (quadruple n)) tos))
(define (set-procedure-arg n)
(mov tos (offset ebp (quadruple n))))
(define-global-procedure 'procedure? 1
(lambda ()
(get-procedure-arg 0)
(if-not-right-magic-jump procedure-magic "return_false")
(jmp "return_true")))
(define (set-subtract a b) (filter (lambda (x) (not (memq x b))) a))
(define (set-equal a b) (eq? (set-subtract a b) (set-subtract b a)))
(define (add-if-not-present obj set) (if (memq obj set) set (cons obj set)))
(define (set-union a b) (if (null? b) a
(add-if-not-present (car b) (set-union (cdr b) a))))
(define (set-intersect a b) (filter (lambda (x) (memq x b)) a))
(define (assert x why) (if (not x) (error "surprise! error" why) '()))
(assert (set-equal '() '()) "empty set equality")
(assert (set-equal '(a) '(a)) "set equality with one item")
(assert (not (set-equal '(a) '(b))) "set inequality with one item")
(assert (not (set-equal '() '(a))) "set inequality () (a)")
(assert (not (set-equal '(a) '())) "set inequality (a) ()")
(assert (set-equal '(a a) '(a)) "set equality (a a) (a)")
(assert (set-equal '(a b) '(b a)) "set equality sequence varies")
(assert (= (length (add-if-not-present 'a '())) 1) "add to empty set")
(assert (= (length (add-if-not-present 'a '(a))) 1) "redundant add")
(assert (= (length (add-if-not-present 'a '(b))) 2) "nonredundant add")
(define sample-abcd (set-union '(a b c) '(b c d)))
(assert (= (length sample-abcd) 4) "set union")
(assert (memq 'a sample-abcd) "member from set 1")
(assert (memq 'd sample-abcd) "member from set 2")
(assert (not (memq '() sample-abcd)) "nil not in set")
(define (assert-set-equal a b) (assert (set-equal a b) (list 'set-equal a b)))
(assert-set-equal (set-intersect '(a b c) '(b c d)) '(b c))
(define (captured-vars expr)
(if (not (pair? expr)) '()
(case (car expr)
((lambda) (free-vars-lambda (cadr expr) (cddr expr)))
((if %begin) (all-captured-vars (cdr expr)))
((quote) '())
((set!) (captured-vars (caddr expr))) (else (all-captured-vars expr)))))
(define (all-captured-vars exprs)
(if (null? exprs) '()
(set-union (captured-vars (car exprs))
(all-captured-vars (cdr exprs)))))
(define (vars-bound args) (if (symbol? args) (list args) args))
(define (free-vars-lambda args body)
(set-subtract (all-free-vars body) (vars-bound args)))
(define (free-vars expr)
(cond ((symbol? expr) (list expr))
((not (pair? expr)) '())
(else (case (car expr)
((lambda) (free-vars-lambda (cadr expr) (cddr expr)))
((if %begin) (all-free-vars (cdr expr)))
((quote) '())
((set!) (add-if-not-present (cadr expr)
(free-vars (caddr expr))))
(else (all-free-vars expr))))))
(define (all-free-vars exprs) (if (null? exprs) '()
(set-union (free-vars (car exprs))
(all-free-vars (cdr exprs)))))
(define (artifacts vars body env) (filter (lambda (x) (assq x env))
(free-vars-lambda vars body)))
(define (compile-heap-args heap-args heap-slots-used env)
(comment "discarding useless value in %eax")
(pop)
(compile-heap-args-2 heap-args heap-slots-used env))
(define (compile-heap-args-2 heap-args heap-slots-used env)
(if (null? heap-args) env
(let ((var (car heap-args)))
(begin
(comment "move arg from stack to heap: " (symbol->string var))
(compile-var var env)
(move-var-to-heap-arg)
(compile-heap-args-2 (cdr heap-args) (1+ heap-slots-used)
(cons (list var 'heap-pointer
heap-slots-used) env))))))
(define (push-artifacts artifacts) (push-artifacts-2 artifacts 0))
(define (push-artifacts-2 artifacts slotnum)
(if (null? artifacts) '()
(let ((var (car artifacts)))
(comment "fetch artifact from closure: " (number->string slotnum)
" " (symbol->string var))
(asm-push (offset eax (+ 12 (quadruple slotnum))))
(cons (list var 'heap-pointer slotnum)
(push-artifacts-2 (cdr artifacts) (1+ slotnum))))))
(define (push-closure label artifacts env)
(push-const (tagged-integer (+ 12 (quadruple (length artifacts)))))
(emit-malloc)
(mov tos ebx)
(mov (const procedure-magic) (indirect ebx))
(mov (const label) (offset ebx 4))
(mov (const (number->string (length artifacts))) (offset ebx 8))
(store-closure-artifacts ebx 12 artifacts env))
(define (store-closure-artifacts reg off artifacts env)
(if (null? artifacts) '()
(begin (get-heap-var (assq (car artifacts) env))
(mov tos (offset reg off))
(pop)
(store-closure-artifacts reg (+ off 4) (cdr artifacts) env))))
(define heap-var-magic "0x1ce11ed")
(define (move-var-to-heap-arg)
(comment "moving top of stack to newly allocated heap var")
(push-const (tagged-integer 8))
(emit-malloc)
(mov (const heap-var-magic) (indirect tos))
(asm-pop (offset tos 4)))
(define sample-closure-expression
'(lambda (a b)
(lambda (c d)
(lambda (e f) (+ e f c a)))))
(assert-set-equal (free-vars sample-closure-expression) '(+))
(assert-set-equal (captured-vars sample-closure-expression) '(+))
(define sample-inner-lambda-1 (caddr sample-closure-expression))
(assert-set-equal (free-vars sample-inner-lambda-1) '(a +))
(assert-set-equal (captured-vars sample-inner-lambda-1) '(a +))
(define sample-inner-lambda-2 (caddr sample-inner-lambda-1))
(assert-set-equal (free-vars sample-inner-lambda-2) '(a c +))
(assert-set-equal (captured-vars sample-inner-lambda-2) '(a c +))
(assert-set-equal (artifacts '(e f) (caddr sample-inner-lambda-2)
'((c whatever) (d whatever)
(a whatever) (b whatever)))
'(a c))
(define sample-quoted-expr '(foo bar '(a b c)))
(assert-set-equal (free-vars sample-quoted-expr) '(foo bar))
(assert-set-equal (captured-vars sample-quoted-expr) '())
(define sample-if-expr '(if a b c))
(assert-set-equal (free-vars sample-if-expr) '(a b c))
(assert-set-equal (captured-vars sample-if-expr) '())
(define sample-begin-expr '(if a b c))
(assert-set-equal (free-vars sample-begin-expr) '(a b c))
(assert-set-equal (captured-vars sample-begin-expr) '())
(assert-set-equal (captured-vars '(begin (if x (lambda (y) (z a) (y c)) d) e))
'(z a c))
(assert-set-equal (captured-vars '(lambda x (x y z))) '(y z))
(define (heap-args varlist body)
(set-intersect varlist (all-captured-vars body)))
(assert-set-equal '(a) (heap-args (cadr sample-closure-expression)
(cddr sample-closure-expression)))
(assert-set-equal '(c) (heap-args (cadr sample-inner-lambda-1)
(cddr sample-inner-lambda-1)))
(assert-set-equal '() (heap-args (cadr sample-inner-lambda-2)
(cddr sample-inner-lambda-2)))
(assert-set-equal '(message)
(heap-args '(message)
'((lambda (message2)
(display message)
(display message2)
(newline)))))
(assert-set-equal '(a b) (free-vars '(set! a b)))
(assert-set-equal '() (captured-vars '(set! a b)))
(add-to-header
(lambda ()
(insn ".bss")
(label "the_arena")
(insn ".space 128*1048576") (compile-global-variable "arena_pointer" "the_arena")))
(define (align4 reg)
(add (const "3") reg)
(asm-and (const "~3") reg))
(define (emit-malloc)
(comment "code to allocate memory; tagged number of bytes in %eax")
(ensure-integer)
(scheme-to-native-integer eax)
(align4 eax)
(mov (indirect "arena_pointer") ebx)
(add ebx eax)
(mov eax (indirect "arena_pointer"))
(mov ebx eax)
(comment "now %eax points to newly allocated memory"))
(define string-magic "0xbabb1e")
(define (constant-string-2 contents labelname)
(rodatum labelname)
(compile-word string-magic)
(compile-word (number->string (string-length contents)))
(ascii contents)
(text)
labelname)
(define (constant-string contents) (constant-string-2 contents (new-label)))
(define (if-not-right-magic-jump magic destlabel)
(comment "test whether %eax has magic: " magic)
(comment "first, ensure that it's a pointer, not something unboxed")
(test (const "3") tos) (jnz destlabel)
(comment "now, test its magic number")
(cmp (const magic) (indirect tos))
(jnz destlabel))
(define-error-routine "notstring" "not a string")
(add-to-header (lambda ()
(label "ensure_string")
(if-not-right-magic-jump string-magic "notstring")
(ret)))
(define (ensure-string) (call "ensure_string"))
(define-global-procedure 'string? 1
(lambda ()
(get-procedure-arg 0)
(if-not-right-magic-jump string-magic "return_false")
(jmp "return_true")))
(define (extract-string)
(ensure-string)
(lea (offset tos 8) ebx) (asm-push ebx)
(mov (offset tos 4) tos))
(define-global-procedure 'make-string 1
(lambda () (get-procedure-arg 0)
(ensure-integer)
(comment "we need 8 bytes more than the string length")
(push-const (tagged-integer 8))
(emit-integer-addition)
(emit-malloc)
(mov (const string-magic) (indirect tos))
(mov tos ebx)
(comment "push address to return, get string length and store it")
(get-procedure-arg 0)
(scheme-to-native-integer tos)
(mov tos (offset ebx 4))
(comment "fill string with Xes")
(lea (offset ebx 8) edi)
(mov tos ecx)
(mov (const "'X") eax)
(rep-stosb)
(comment "now pop and return the address")
(pop)))
(define (check-array-bounds )
(comment "verify that tagged %eax is in [0, untagged NOS)")
(ensure-integer)
(scheme-to-native-integer eax)
(comment "set flags by (unsigned array index - array max)")
(cmp nos tos)
(comment "now we expect unsigned overflow, i.e. borrow/carry.")
(jnb "index_out_of_bounds")
(comment "now discard both the index and the bound")
(pop) (pop))
(define-error-routine "index_out_of_bounds" "array index out of bounds")
(define-global-procedure 'string-set! 3
(lambda ()
(comment "string-set! primitive procedure")
(get-procedure-arg 0)
(extract-string)
(get-procedure-arg 1)
(check-array-bounds)
(get-procedure-arg 1)
(scheme-to-native-integer tos)
(mov tos edi)
(comment "now retrieve the address of string bytes from the stack")
(pop)
(mov tos ebx)
(get-procedure-arg 2)
(ensure-character)
(scheme-to-native-character tos)
(movb al (indirect (index-register ebx edi 1)))
(comment "discard the character and base address")
(pop) (pop)
(comment "but we need a return value...")
(get-procedure-arg 0)))
(define-global-procedure 'string-ref 2
(lambda ()
(comment "string-ref primitive procedure")
(get-procedure-arg 0)
(extract-string)
(get-procedure-arg 1)
(check-array-bounds)
(get-procedure-arg 1)
(scheme-to-native-character tos)
(comment "get base address of string data from stack")
(asm-pop ebx)
(movzbl (indirect (index-register tos ebx 1)) tos)
(native-to-scheme-character tos)))
(define-global-procedure 'string-length 1
(lambda ()
(comment "string-length primitive procedure")
(get-procedure-arg 0)
(extract-string)
(asm-pop ebx)
(native-to-scheme-integer tos)))
(define cons-magic "0x2ce11ed")
(define (ensure-cons) (call "ensure_cons"))
(add-to-header (lambda () (label "ensure_cons")
(if-not-right-magic-jump cons-magic "not_cons")
(ret)))
(define-error-routine "not_cons" "not a cons")
(define-global-procedure 'car 1
(lambda ()
(get-procedure-arg 0)
(ensure-cons)
(mov (offset tos 4) tos)))
(define-global-procedure 'cdr 1
(lambda ()
(get-procedure-arg 0)
(ensure-cons)
(mov (offset tos 8) tos)))
(add-to-header (lambda () (text) (label "cons")))
(define-global-procedure 'cons 2
(lambda ()
(push-const (tagged-integer 12))
(emit-malloc)
(mov (const cons-magic) (indirect tos))
(mov tos ebx)
(get-procedure-arg 0)
(mov tos (offset ebx 4))
(pop)
(get-procedure-arg 1)
(mov tos (offset ebx 8))
(pop)))
(define (compile-cons car-contents cdr-contents labelname)
(rodatum labelname)
(compile-word cons-magic)
(compile-word car-contents)
(compile-word cdr-contents)
(text))
(define-global-procedure 'pair? 1
(lambda ()
(get-procedure-arg 0)
(if-not-right-magic-jump cons-magic "return_false")
(jmp "return_true")))
(add-to-header
(lambda ()
(label "return_true")
(mov (const true-value) tos)
(compile-procedure-epilogue)
(label "return_false")
(mov (const false-value) tos)
(compile-procedure-epilogue)))
(define symbol-magic "0x1abe1")
(define-global-procedure 'symbol? 1
(lambda ()
(get-procedure-arg 0)
(if-not-right-magic-jump symbol-magic "return_false")
(jmp "return_true")))
(define interned-symbol-list '())
(define (intern symbol)
(interning symbol interned-symbol-list))
(define (interning symbol symlist)
(cond ((null? symlist)
(set! interned-symbol-list
(cons (list symbol (new-label)) interned-symbol-list))
(car interned-symbol-list))
((eq? symbol (caar symlist)) (car symlist))
(else (interning symbol (cdr symlist)))))
(define (symbol-value symbol) (cadr (intern symbol)))
(define (emit-symbols)
(comment "symbols")
(emit-symbols-from "0" interned-symbol-list))
(define (emit-symbols-from last-pointer remaining)
(if (null? remaining) (emit-symbol-list-header last-pointer)
(let ((symlabel (car remaining)))
(comment "symbol: " (symbol->string (car symlabel)))
(let ((stringlabel (compile-constant (symbol->string (car symlabel)))))
(rodatum (cdr symlabel))
(compile-word symbol-magic)
(compile-word stringlabel)
(compile-word last-pointer)
(emit-symbols-from (cdr symlabel) (cdr remaining))))))
(define (emit-symbol-list-header last-pointer)
(section ".data")
(label "symbol_table")
(compile-word last-pointer))
(add-to-header (lambda () (label "ensure_symbol")
(if-not-right-magic-jump symbol-magic "not_symbol")
(ret)))
(define-error-routine "not_symbol" "not a symbol")
(define (ensure-symbol) (call "ensure_symbol"))
(define-global-procedure 'symbol->string 1
(lambda () (get-procedure-arg 0)
(ensure-symbol)
(mov (offset tos 4) tos)))
(define-global-procedure 'string->symbol 1
(lambda ()
(get-procedure-arg 0)
(extract-string)
(comment "now string length is in %eax and string data pointer at (%esp)")
(mov (indirect "symbol_table") ebx)
(label "string_to_symbol_loop")
(test ebx ebx)
(jz "intern_new_symbol")
(comment "fetch pointer to string value")
(mov (offset ebx 4) edx)
(comment "fetch string length")
(mov (offset edx 4) ecx)
(cmp ecx eax)
(jnz "wrong_symbol_thanks_for_playing")
(comment "fetch string pointer")
(lea (offset edx 8) esi)
(mov nos edi)
(repe-cmpsb)
(jnz "wrong_symbol_thanks_for_playing")
(comment "found the right symbol")
(pop)
(mov ebx tos)
(jmp "string_symbol_return")
(label "wrong_symbol_thanks_for_playing")
(comment "get address of next symbol")
(mov (offset ebx 8) ebx)
(jmp "string_to_symbol_loop")
(label "intern_new_symbol")
(comment "get string pointer")
(get-procedure-arg 0)
(comment "symbols are 12 bytes")
(push-const (tagged-integer 12))
(emit-malloc)
(mov (const symbol-magic) (indirect tos))
(comment "store string pointer for new symbol")
(mov nos ebx)
(mov ebx (offset tos 4))
(mov (indirect "symbol_table") ebx)
(mov ebx (offset tos 8))
(mov tos (indirect "symbol_table"))
(label "string_symbol_return")))
(define (write_2)
(mov tos edx) (asm-pop ecx) (mov (const "4") eax) (syscall))
(define (target-display)
(extract-string)
(comment "fd 1: stdout")
(mov (const "1") ebx)
(write_2))
(define (target-newline)
(push-const "newline_string")
(target-display))
(add-to-header (lambda () (constant-string-2 "\n" "newline_string")))
(define-global-procedure 'display 1
(lambda () (get-procedure-arg 0)
(target-display)))
(define-global-procedure 'newline 0 target-newline)
(define-global-procedure 'eq? 2
(lambda () (get-procedure-arg 0)
(get-procedure-arg 1)
(target-eq?)))
(define-global-procedure 'current-input-port 0
(lambda () (comment "We don't have ports right now, so return nil")
(push-const nil-value)))
(define-global-procedure 'read-char '()
(lambda () (comment "We don't care about our args.")
(comment "(maybe somebody passed us (current-input-port))")
(section ".data")
(label "read_char_buffer")
(compile-word "0")
(text)
(comment "__NR_read; see asm-i486/unistd.h")
(mov (const "3") eax)
(comment "stdin")
(mov (const "0") ebx)
(mov (const "read_char_buffer") ecx)
(mov (const "1") edx)
(syscall)
(test eax eax)
(je "return_eof")
(movzbl (indirect "read_char_buffer") tos)
(native-to-scheme-character tos)
(jmp "read_char_return")
(label "return_eof")
(mov (const eof-value) tos)
(label "read_char_return")))
(define-global-procedure 'display-stderr 1
(lambda () (get-procedure-arg 0)
(extract-string)
(comment "fd 2: stderr")
(mov (const "2") ebx)
(write_2)))
(define-global-procedure 'exit 1
(lambda () (get-procedure-arg 0)
(ensure-integer)
(scheme-to-native-integer tos)
(mov tos ebx)
(mov (const "1") eax) (syscall)))
(define (tagshift str) (list (number->string str) "<<2"))
(define integer-tag "1")
(define-global-procedure 'integer? 1
(lambda () (compile-tag-check-procedure integer-tag)))
(define (tagged-integer int) (list integer-tag " + " (tagshift int)))
(add-to-header (lambda ()
(label "ensure_integer")
(test (const "1") tos)
(jz "not_an_integer")
(test (const "2") tos)
(jnz "not_an_integer")
(ret)))
(define-error-routine "not_an_integer" "not an integer")
(define (ensure-integer) (call "ensure_integer"))
(define (assert-equal a b) (if (equal? a b) #t (error "not equal" (list a b))))
(define (emit-integer-addition) (asm-pop ebx)
(add ebx tos)
(dec tos))
(define (integer-add rands env tail?)
(comment "integer add operands")
(assert-equal 2 (compile-args rands env))
(comment "now execute integer add")
(ensure-integer)
(swap)
(ensure-integer)
(emit-integer-addition))
(define (integer-sub rands env tail?)
(comment "integer subtract operands")
(assert-equal 2 (compile-args rands env))
(comment "now execute integer subtract")
(ensure-integer)
(swap)
(ensure-integer)
(sub tos nos)
(pop)
(inc tos))
(define (native-to-scheme-integer reg) (sal reg) (sal reg) (inc reg))
(define (scheme-to-native-integer reg) (sar reg) (sar reg))
(define (emit-division-code)
(get-procedure-arg 1)
(ensure-integer)
(comment "fetch dividend second; idiv wants it in %eax")
(get-procedure-arg 0)
(ensure-integer)
(comment "zero out the tag")
(dec tos)
(asm-pop ebx)
(dec ebx)
(comment "zero the top half of the dividend")
(sub edx edx)
(idiv ebx))
(define-global-procedure 'remainder 2
(lambda () (emit-division-code)
(comment "remainder (<<2) is in %edx")
(mov edx tos)
(comment "put the tag back")
(inc tos)))
(define-global-procedure 'quotient 2
(lambda () (emit-division-code)
(native-to-scheme-integer tos)))
(define-global-procedure '< 2
(lambda ()
(comment "procedure <: (< x y) returns true if x < y")
(get-procedure-arg 0)
(ensure-integer)
(get-procedure-arg 1)
(ensure-integer)
(cmp tos nos)
(pop)
(jg "return_false")
(jmp "return_true")))
(define enum-tag "2")
(define (enum-value offset) (list enum-tag " + " (tagshift offset)))
(define nil-value (enum-value 256))
(define true-value (enum-value 257))
(define false-value (enum-value 258))
(define eof-value (enum-value 259))
(define-global-procedure 'eof-object? 1
(lambda ()
(get-procedure-arg 0)
(cmp (const eof-value) tos)
(je "return_true")
(jmp "return_false")))
(define (jump-if-false label)
(cmp (const false-value) tos)
(pop)
(je label))
(define (target-eq?)
(let ((label1 (new-label)))
(let ((label2 (new-label)))
(asm-pop ebx)
(cmp ebx tos)
(je label1)
(mov (const false-value) tos)
(jmp label2)
(label label1)
(mov (const true-value) tos)
(label label2))))
(define (jump-if-not-char label)
(test (const "1") tos)
(jnz label)
(test (const "2") tos)
(jz label)
(cmp (const (enum-value 256)) tos)
(jnb label))
(define (ensure-character) (jump-if-not-char "not_a_character"))
(define-error-routine "not_a_character" "not a character")
(define-global-procedure 'char? 1
(lambda ()
(get-procedure-arg 0)
(jump-if-not-char "return_false")
(jmp "return_true")))
(define scheme-to-native-character scheme-to-native-integer)
(define (native-to-scheme-character reg) (sal reg) (inc reg) (sal reg))
(define (tagged-character char)
(list enum-tag " + " (number->string (char->integer char)) "<<2"))
(define-global-procedure 'integer->char 1
(lambda () (get-procedure-arg 0)
(inc tos)
(ensure-character)))
(define-global-procedure 'char->integer 1
(lambda () (get-procedure-arg 0)
(ensure-character)
(dec tos)))
(define global-variable-labels '())
(define global-variables-defined '())
(define (allocate-new-global-variable-label! name)
(let ((label (new-label)))
(set! global-variable-labels
(cons (cons name label) global-variable-labels))
label))
(define (global-variable-label name)
(let ((binding (assq name global-variable-labels)))
(if binding (cdr binding) (allocate-new-global-variable-label! name))))
(define (compile-global-variable varlabel initial)
(section ".data")
(label varlabel)
(compile-word initial)
(text))
(define (define-global-variable name initial)
(if (assq name global-variables-defined)
(begin (push-const initial) (set-global-variable name))
(begin (compile-global-variable (global-variable-label name) initial)
(set! global-variables-defined
(cons (list name) global-variables-defined)))))
(define (fetch-global-variable varname)
(asm-push tos)
(mov (indirect (global-variable-label varname)) tos))
(define (set-global-variable varname)
(mov tos (indirect (global-variable-label varname))))
(define (undefined-global-variables)
(filter (lambda (pair) (not (assq (car pair) global-variables-defined)))
global-variable-labels))
(define (assert-no-undefined-global-variables)
(if (not (null? (undefined-global-variables)))
(error "error: undefined global" (undefined-global-variables))
#t))
(define (compile-quote-3 expr labelname)
(cond ((string? expr) (constant-string-2 expr labelname))
((pair? expr) (let ((compiled-car (compile-constant (car expr))))
(compile-cons compiled-car (compile-constant (cdr expr))
labelname)))
(else (error "unquotable" expr)))
labelname)
(define (compile-constant expr)
(cond ((null? expr) nil-value)
((symbol? expr) (symbol-value expr))
((integer? expr) (tagged-integer expr))
((boolean? expr) (if expr true-value false-value))
((char? expr) (tagged-character expr))
(else (compile-quote-3 expr (new-label)))))
(define (compile-quotable obj env) (push-const (compile-constant obj)))
(define (fetch-heap-var-pointer slotnum)
(comment "fetching heap var pointer " (number->string slotnum))
(dup)
(mov (offset ebp (- -16 (quadruple slotnum))) tos))
(define-error-routine "not_heap_var" "heap-var indirection to non-heap-var")
(add-to-header (lambda ()
(label "ensure_heap_var")
(if-not-right-magic-jump heap-var-magic "not_heap_var")
(ret)))
(define (ensure-heap-var) (call "ensure_heap_var"))
(define (fetch-heap-var slotnum)
(fetch-heap-var-pointer slotnum)
(comment "now fetching current value from the heap")
(ensure-heap-var)
(mov (offset tos 4) tos))
(define (set-heap-var slotnum)
(fetch-heap-var-pointer slotnum)
(ensure-heap-var)
(mov nos ebx)
(mov ebx (offset tos 4))
(pop))
(define (get-variable vardefn)
(case (car vardefn)
((stack) (get-procedure-arg (cadr vardefn)))
((heap-pointer) (fetch-heap-var (cadr vardefn)))
(else (error "unexpected var type" (car vardefn)))))
(define (set-variable vardefn)
(case (car vardefn)
((stack) (set-procedure-arg (cadr vardefn)))
((heap-pointer) (set-heap-var (cadr vardefn)))
(else (error "unexpected var type" vardefn))))
(define (get-heap-var vardefn)
(if (eq? (cadr vardefn) 'heap-pointer)
(fetch-heap-var-pointer (caddr vardefn))
(error "trying to fetch the heap var pointer for " vardefn)))
(define (compile-var var env)
(let ((binding (assq var env)))
(if binding (get-variable (cdr binding))
(fetch-global-variable var))))
(define (compile-set var defn env)
(compile-expr defn env #f)
(let ((binding (assq var env)))
(if binding (set-variable (cdr binding))
(set-global-variable var))))
(define (compile-discarding expr env) (compile-expr expr env #f) (pop))
(define (lambda-environment env vars idx)
(if (null? vars) '()
(cons (list (car vars) 'stack idx)
(lambda-environment env (cdr vars) (1+ idx)))))
(define (compile-lambda rands env tail?)
(let ((vars (car rands)) (body (cdr rands)))
(let ((varlist (if (symbol? vars) (list vars) vars))
(nargs (if (symbol? vars) '() (length vars))))
(let ((artifacts (artifacts varlist body env))
(jumplabel (new-label))
(stack-env (lambda-environment env varlist 0))
(heap-arg-list (heap-args varlist body)))
(let ((proclabel (new-label)))
(comment "jump past the body of the lambda")
(jmp jumplabel)
(if (null? artifacts)
(begin
(compile-procedure-labeled proclabel nargs
(lambda ()
(let ((inner-env (compile-heap-args heap-arg-list 0
stack-env)))
(compile-begin body inner-env #t))))
(label jumplabel)
(push-const proclabel))
(begin
(compile-procedure proclabel nargs
(lambda ()
(let ((artifacts-env (push-artifacts artifacts)))
(let ((inner-env (compile-heap-args
heap-arg-list
(length artifacts) (append artifacts-env stack-env))))
(compile-begin body inner-env #t)))))
(label jumplabel)
(push-closure proclabel artifacts env))))))))
(define (compile-begin rands env tail?)
(cond ((null? rands) (push-const "31")) ((null? (cdr rands)) (compile-expr (car rands) env tail?))
(else
(begin (if tail? (compile-expr (car rands) env #f)
(compile-discarding (car rands) env))
(compile-begin (cdr rands) env tail?)))))
(define (compile-if rands env tail?)
(if (not (= (length rands) 3))
(error "if arguments length " (length rands) " != 3")
(let ((cond (car rands)) (then (cadr rands)) (else (caddr rands))
(falselabel (new-label)))
(let ((endlabel (new-label)))
(compile-expr cond env #f)
(jump-if-false falselabel)
(compile-expr then env tail?)
(jmp endlabel)
(label falselabel)
(compile-expr else env tail?)
(label endlabel)))))
(define (compile-combination rator rands env tail?)
(case rator
((%begin) (compile-begin rands env tail?))
((if) (compile-if rands env tail?))
((lambda) (compile-lambda rands env tail?))
((quote) (assert-equal 1 (length rands))
(compile-quotable (car rands) env))
((set!) (assert-equal 2 (length rands))
(compile-set (car rands) (cadr rands) env))
((+) (integer-add rands env tail?))
((-) (integer-sub rands env tail?))
(else (let ((nargs (compile-args rands env)))
(comment "get the procedure")
(compile-expr rator env #f)
(comment "now apply the procedure")
(if tail? (compile-tail-apply nargs)
(compile-apply nargs))))))
(define (compile-expr expr env tail?)
(cond ((pair? expr) (compile-combination (car expr) (cdr expr) env tail?))
((symbol? expr) (compile-var expr env))
((or (string? expr) (boolean? expr) (integer? expr) (char? expr))
(compile-quotable expr env))
(else (error "don't know how to compile" expr))))
(define (compile-args-2 args env n)
(compile-expr (car args) env #f) (1+ n))
(define (compile-args args env)
(if (null? args) 0
(compile-args-2 args env (compile-args (cdr args) env))))
(define (compile-toplevel-define name body env)
(define-global-variable name nil-value)
(comment "compute initial value for global variable")
(compile-expr body env #f)
(comment "initialize global variable with value")
(mov tos (indirect (global-variable-label name)))
(pop))
(define global-env '())
(define macros '())
(define (define-ur-macro name fun)
(set! macros (cons (list name fun) macros)))
(define (relevant-macro-definition expr)
(if (pair? expr) (assq (car expr) macros) #f))
(define (macroexpand-1 expr)
(if (relevant-macro-definition expr)
((cadr (relevant-macro-definition expr)) (cdr expr))
expr))
(define-ur-macro 'begin (lambda (args) (cons '%begin args)))
(define-ur-macro 'cond
(lambda (args)
(cond ((null? args) #f)
((eq? (caar args) 'else) (cons 'begin (cdar args)))
(else (list 'if (caar args) (cons 'begin (cdar args))
(cons 'cond (cdr args)))))))
(define-ur-macro 'define
(lambda (args)
(if (pair? (car args)) (list '%define (caar args)
(cons 'lambda (cons (cdar args) (cdr args))))
(cons '%define args))))
(define-ur-macro 'let
(lambda (args)
(cons (cons 'lambda (cons (map car (car args)) (cdr args)))
(map cadr (car args)))))
(define-ur-macro 'case
(lambda (args)
(cond ((pair? (car args))
(list 'let (list (list 'case-atom-key (car args)))
(cons 'case (cons 'case-atom-key (cdr args)))))
((null? (cdr args)) (list 'begin)) ((eq? (caadr args) 'else) (cons 'begin (cdadr args)))
(else (list 'if (list 'memv (car args) (list 'quote (caadr args)))
(cons 'begin (cdadr args))
(cons 'case (cons (car args) (cddr args))))))))
(define-ur-macro 'or
(lambda (args)
(cond ((null? args) #f)
((= 1 (length args)) (car args))
(else (list 'let (list (list 'or-internal-argument (car args)))
(list 'if 'or-internal-argument 'or-internal-argument
(cons 'or (cdr args))))))))
(define-ur-macro 'and
(lambda (args)
(cond ((null? args) #t)
((= 1 (length args)) (car args))
(else (list 'if (car args) (cons 'and (cdr args)) #f)))))
(define (totally-macroexpand expr)
(cond ((relevant-macro-definition expr)
(totally-macroexpand (macroexpand-1 expr)))
((not (pair? expr)) expr)
(else (case (car expr)
((quote) expr)
((lambda) (cons 'lambda (cons (cadr expr)
(map totally-macroexpand
(cddr expr)))))
(else (map totally-macroexpand expr))))))
(assert-equal (totally-macroexpand 'foo) 'foo)
(assert-equal (totally-macroexpand '(if a b c)) '(if a b c))
(assert (relevant-macro-definition '(begin a b c)) "no begin defn")
(assert-equal (totally-macroexpand '(begin a b c)) '(%begin a b c))
(assert-equal (totally-macroexpand '(cond ((eq? x 3) 4 '(cond 3))
((eq? x 4) 8)
(else 6 7)))
'(if (eq? x 3) (%begin 4 '(cond 3))
(if (eq? x 4) (%begin 8)
(%begin 6 7))))
(assert-equal (totally-macroexpand '(let () a b c)) '((lambda () a b c)))
(assert-equal (totally-macroexpand '(let ((a 1) (b 2)) a b c))
'((lambda (a b) a b c) 1 2))
(assert-equal (totally-macroexpand '(and a b c)) '(if a (if b c #f) #f))
(assert-equal (totally-macroexpand '(or a b c))
(totally-macroexpand
'(let ((or-internal-argument a))
(if or-internal-argument or-internal-argument
(let ((or-internal-argument b))
(if or-internal-argument or-internal-argument
c))))))
(assert-equal (totally-macroexpand
'(let ((cond (car rands)) (then (cadr rands))
(else (caddr rands)) (falselabel (new-label))
(endlabel (new-label)))
(compile-expr cond env #f)
(jump-if-false falselabel)))
'((lambda (cond then else falselabel endlabel)
(compile-expr cond env #f)
(jump-if-false falselabel)
) (car rands) (cadr rands) (caddr rands)
(new-label) (new-label)))
(define (compile-toplevel expr)
(compile-toplevel-expanded (totally-macroexpand expr)))
(define (compile-toplevel-expanded expr)
(if (eq? (car expr) '%define)
(begin
(set-label-prefix (cadr expr))
(compile-toplevel-define (cadr expr) (caddr expr) global-env))
(compile-discarding expr global-env)))
(define (ungettable thunk)
(let ((ungot #f) (last #f))
(lambda cmd (cond ((not (null? cmd)) (set! ungot last))
(ungot (let ((result ungot)) (set! ungot #f) result))
(else (set! last (thunk)) last)))))
(define (read-from-string string)
(let ((pos 0))
(lambda () (if (= pos (string-length string)) 'eof-indicator
(begin (set! pos (1+ pos)) (string-ref string (1- pos)))))))
(define sample-sr (read-from-string "foo"))
(assert-equal (sample-sr) #\f)
(assert-equal (sample-sr) #\o)
(assert-equal (sample-sr) #\o)
(assert-equal (sample-sr) 'eof-indicator)
(assert-equal (sample-sr) 'eof-indicator)
(define sample-unget (ungettable (read-from-string "foo")))
(assert-equal (sample-unget) #\f)
(sample-unget 'unget)
(assert-equal (sample-unget) #\f)
(assert-equal (sample-unget) #\o)
(assert-equal (sample-unget) #\o)
(assert-equal (sample-unget) 'eof-indicator)
(define (parse s)
(let ((c (after-wsp s)))
(if (parse-eof? c) c
(case c
(( #\( ) (parse-list s))
(( #\' ) (list 'quote (parse s)))
(( #\" ) (parse-string-literal s))
(( #\# ) (parse-hashy-thing s))
(else (s 'unget) (parse-atom s))))))
(define (parse-list s)
(let ((c (after-wsp s)))
(if (parse-eof? c) (error "missing right paren")
(case c
(( #\) ) '())
(( #\. ) (read-dotted-tail s))
(else (let ((hd (begin (s 'unget) (parse s))))
(cons hd (parse-list s))))))))
(define (read-dotted-tail s)
(let ((rv (parse s)))
(if (eqv? #\) (after-wsp s)) rv (error "funky dotted list"))))
(define whitespace-chars "\n ")
(define (after-wsp s)
(let ((c (s))) (case c
((#\space #\newline #\tab) (after-wsp s))
(( #\; ) (discard-comment s) (after-wsp s))
(else c))))
(define (discard-comment s) (if (eqv? (s) #\newline) #f (discard-comment s)))
(define (parse-atom s)
(let ((atom (parse-atom-2 s)))
(if (parsed-number? atom) (string->number (list->string atom))
(string->symbol (list->string atom)))))
(define (char-numeric? char) (if (string-idx "0123456789" char) #t #f))
(define (parsed-number? lst)
(cond ((null? lst) #f)
((char-numeric? (car lst)) (all-numeric? (cdr lst)))
((string-idx "+-" (car lst)) (and (not (null? (cdr lst)))
(all-numeric? (cdr lst))))
(else #f)))
(define (all-numeric? lst)
(or (null? lst) (and (char-numeric? (car lst)) (all-numeric? (cdr lst)))))
(define (parse-atom-2 s)
(let ((c (s)))
(if (parse-eof? c) '()
(case c
(( #\space #\newline #\tab #\; #\( #\) #\' #\" ) (s 'unget) '())
(else (cons c (parse-atom-2 s)))))))
(define (parse-string-literal s) (list->string (parse-string-literal-2 s)))
(define (parse-string-literal-2 s)
(let ((c (s)))
(case c (( #\\ )
(let ((next (s)))
(let ((decoded
(case next ((#\n) #\newline) ((#\t) #\tab) (else next))))
(cons decoded (parse-string-literal-2 s)))))
(( #\" )
'())
(else
(cons c (parse-string-literal-2 s))))))
(define (parse-hashy-thing s)
(let ((c (s)))
(if (parse-eof? c) (error "eof after #")
(case c
(( #\t ) #t)
(( #\f ) #f)
(( #\\ ) (parse-char-literal s))
(else (error "Unimplemented #" c))))))
(define (parse-char-literal s)
(let ((c (s))) (cond ((parse-eof? c) (error "eof in char literal"))
((char-alphabetic? c) (s 'unget) (parse-named-char s))
(else c))))
(define (parse-named-char s)
(let ((name (parse-atom-2 s)))
(if (= 1 (length name)) (car name)
(case (string->symbol (list->string name))
((space) #\space)
((newline) #\newline)
((tab) #\tab)
(else (error "Unrecognized character name"
(string->symbol (list->string name))))))))
(define (parse-string string) (parse (ungettable (read-from-string string))))
(define (read-expr file) (parse (ungettable (lambda () (read-char file)))))
(define (parse-eof? x) (or (eof-object? x) (eq? x 'eof-indicator)))
(assert-equal (parse-string "()") '())
(assert-equal (parse-string " ()") '())
(assert-equal (parse-string "\n()") '())
(assert-equal (parse-string " ( )") '())
(assert-equal (parse-string ";hi\n(;hi\n)") '())
(assert-equal (parse-string "x ") 'x)
(assert-equal (parse-string "x") 'x) (assert-equal (parse-string "xyz") 'xyz)
(assert-equal (parse-string "(xyz)") '(xyz))
(assert-equal (parse-string "(x y z)") '(x y z))
(assert-equal (parse-string "(x y . z)") '(x y . z))
(assert-equal (parse-string "(define (1+ x) (+ x 1))")
'(define (1+ x) (+ x 1)))
(assert-equal
(parse-string "(define (filter fn lst) ; foo\n (if (null? lst) '()))")
'(define (filter fn lst) (if (null? lst) (quote ()))))
(parse-string "(char->string (string-ref \"0123456789\"))") (assert-equal (parse-string "(char->string (string-ref \"0123456789\" digit)))")
'(char->string (string-ref "0123456789" digit)))
(assert-equal (parse-string "(foo\"3\"()\"5\")") '(foo "3" () "5"))
(assert-equal (parse-string "(b a #t #f)") '(b a #t #f))
(assert-equal (parse-string "(mov (offset ebp -8) esp)")
'(mov (offset ebp -8) esp))
(assert (parse-eof? (parse-string "")) "parsing at end of file")
(assert-equal
(parse-string "(#\\a #\\newline #\\tab #\\space #\\( #\\) #\\# #\\\\)")
'(#\a #\newline #\tab #\space #\( #\) #\# #\\))
(assert-equal (parse-string "\"hello\\n\\tthere\"") "hello\n\tthere")
(define standard-library
'(
(define (1+ x) (+ x 1))
(define (1- x) (- x 1))
(define (list . args) args) (define (length list) (if (null? list) 0 (1+ (length (cdr list)))))
(define (assq obj alist) (cond ((null? alist) #f)
((eq? obj (caar alist)) (car alist))
(else (assq obj (cdr alist)))))
(define (memq obj list) (cond ((null? list) #f)
((eq? obj (car list)) list)
(else (memq obj (cdr list)))))
(define memv memq) (define (append a b) (if (null? a) b (cons (car a) (append (cdr a) b))))
(define (caar val) (car (car val)))
(define (cdar val) (cdr (car val)))
(define (cadr val) (car (cdr val)))
(define (cddr val) (cdr (cdr val)))
(define (caddr val) (car (cddr val)))
(define (caadr val) (car (cadr val)))
(define (cdadr val) (cdr (cadr val)))
(define (cadar val) (car (cdar val)))
(define (not x) (if x #f #t))
(define (string-append-3 length s2 buf idx)
(if (= idx (string-length buf)) buf
(begin
(string-set! buf idx (string-ref s2 (- idx length)))
(string-append-3 length s2 buf (1+ idx)))))
(define (string-append-2 s1 s2 buf idx)
(if (= idx (string-length s1))
(string-append-3 (string-length s1) s2 buf idx)
(begin
(string-set! buf idx (string-ref s1 idx))
(string-append-2 s1 s2 buf (1+ idx)))))
(define (string-append s1 s2) (string-append-2 s1 s2 (make-string (+ (string-length s1)
(string-length s2)))
0))
(define (char-whitespace? c)
(case c ((#\space #\newline #\tab) #t) (else #f)))
(define (char<? a b) (< (char->integer a) (char->integer b)))
(define (char<=? a b) (or (eqv? a b) (char<? a b)))
(define (char-between? a b c) (and (char<=? a b) (char<=? b c)))
(define (char-alphabetic? x) (or (char-between? #\A x #\Z)
(char-between? #\a x #\z)))
(define = eq?)
(define char=? eq?)
(define eqv? eq?)
(define (equal? a b)
(cond ((eq? a b) #t)
((string? a) (and (string? b) (string=? a b)))
((pair? a) (and (pair? b) (equal? (car a) (car b))
(equal? (cdr a) (cdr b))))
(else #f)))
(define (string=? a b)
(and (= (string-length a) (string-length b)) (string=?-2 a b 0)))
(define (string=?-2 a b idx)
(or (= idx (string-length a))
(and (char=? (string-ref a idx) (string-ref b idx))
(string=?-2 a b (1+ idx)))))
(define (null? x) (eq? x '()))
(define (boolean? x) (if (eq? x #t) #t (eq? x #f)))
(define number? integer?)
(define (for-each proc list) (if (null? list) #f
(begin
(proc (car list))
(for-each proc (cdr list)))))
(define (map proc list) (if (null? list) '() (cons (proc (car list)) (map proc (cdr list)))))
(define (reverse lst) (reverse-plus '() lst))
(define (reverse-plus tail lst)
(if (null? lst) tail (reverse-plus (cons (car lst) tail) (cdr lst))))
(define (string->list string) (string->list-2 string (string-length string) '()))
(define (string->list-2 string n rest)
(if (= n 0) rest
(string->list-2 string (- n 1)
(cons (string-ref string (- n 1)) rest))))
(define (list->string lst)
(list->string-2 (make-string (length lst)) lst 0))
(define (list->string-2 buf lst idx)
(if (null? lst) buf
(begin (string-set! buf idx (car lst))
(list->string-2 buf (cdr lst) (1+ idx)))))
(define (char->string char)
(let ((buf (make-string 1))) (string-set! buf 0 char) buf))
(define (string-digit digit)
(char->string (string-ref "0123456789" digit)))
(define (number->string-2 num tail)
(if (= num 0) tail
(number->string-2 (quotient num 10)
(string-append (string-digit (remainder num 10))
tail))))
(define (number->string num) (cond ((= num 0) "0")
((< num 0) (string-append "-" (number->string-2 (- 0 num) "")))
(else (number->string-2 num ""))))
(define (string->number str)
(if (string=? str "") (error "string->number of empty string")
(case (string-ref str 0)
(( #\+ ) (string->number-2 str 1 0))
(( #\- ) (- 0 (string->number-2 str 1 0)))
(else (string->number-2 str 0 0)))))
(define (string->number-2 str idx sofar)
(if (= idx (string-length str)) sofar
(let ((c (string-ref str idx)))
(if (not (char-between? #\0 c #\9))
(error "non-numeric char" c str)
(string->number-2
str
(1+ idx)
(+ (10* sofar) (- (char->integer c) (char->integer #\0))))))))
(define (10* x) (+ (8* x) (2* x)))
(define (2* x) (+ x x))
(define (8* x) (2* (2* (2* x))))
(define (error . args)
(display-stderr "error: ")
(for-each display-stderr args)
(display-stderr "\n")
(exit 1))
(define (escape-char char dangerous escapes) (cond ((null? dangerous) (char->string char))
((char=? char (string-ref (car dangerous) 0))
(car escapes))
(else (escape-char char (cdr dangerous) (cdr escapes)))))
(define (escape string idx dangerous escapes) (if (= idx (string-length string)) '()
(cons (escape-char (string-ref string idx) dangerous escapes)
(escape string (1+ idx) dangerous escapes))))
(define (backslash string) (escape string 0 '("\\" "\n" "\"")
'("\\\\" "\\n" "\\\"")))
(define (write x) (wthunk x display))
(define (wthunk x display)
(cond ((string? x) (wstring x display))
((or (pair? x) (null? x)) (display "(") (wlist x display))
((symbol? x) (display (symbol->string x)))
((eq? x #t) (display "#t"))
((eq? x #f) (display "#f"))
((eq? x #\newline) (display "#\\newline"))
((eq? x #\space) (display "#\\space"))
((eq? x #\tab) (display "#\\tab"))
((char? x) (display "#\\") (display (char->string x)))
(else (error "don't know how to write" x))))
(define (wstring x pr) (pr "\"") (for-each pr (backslash x)) (pr "\""))
(define (wlist x pr)
(cond ((null? x)
(pr ")"))
((pair? x)
(wthunk (car x) pr)
(if (null? (cdr x)) #f (pr " "))
(wlist (cdr x) pr))
(else
(pr ". ")
(wthunk x pr)
(pr ")"))))
))
(define (compile-program body)
(stuff-to-put-in-the-header)
(global-label "_start") (insn ".weak _start") (global-label "main") (mov (const "0x610ba1") ebp)
(for-each compile-toplevel standard-library)
(comment "(end of standard library prologue)")
(body)
(mov (const "1") eax) (mov (const "0") ebx) (syscall)
(emit-symbols)
(assert-no-undefined-global-variables))
(define (read-compile-loop)
(let ((expr (read-expr (current-input-port))))
(if (eof-object? expr) #t
(begin (compile-toplevel expr)
(read-compile-loop)))))
(compile-program read-compile-loop)