Implement 5.52 translate Scheme to C
This commit is contained in:
@@ -57,16 +57,16 @@
|
||||
|
||||
(define (compile-linkage linkage)
|
||||
(cond ((eq? linkage 'return)
|
||||
(make-instruction-sequence '(continue) '()
|
||||
'((goto (reg continue)))))
|
||||
(make-instruction-sequence '(continu) '()
|
||||
'((" goto *continu;"))))
|
||||
((eq? linkage 'next)
|
||||
(empty-instruction-sequence))
|
||||
(else
|
||||
(make-instruction-sequence '() '()
|
||||
`((goto (label ,linkage)))))))
|
||||
`((" goto " ,linkage ";"))))))
|
||||
|
||||
(define (end-with-linkage linkage instruction-sequence)
|
||||
(preserving '(continue)
|
||||
(preserving '(continu)
|
||||
instruction-sequence
|
||||
(compile-linkage linkage)))
|
||||
|
||||
@@ -77,7 +77,7 @@
|
||||
(cond ((number? exp)
|
||||
(end-with-linkage linkage
|
||||
(make-instruction-sequence '() (list target)
|
||||
`((" " ,target " = const_int(" ,exp ");")))))
|
||||
`((" " ,target " = const_i32(" ,exp ");")))))
|
||||
(else (error "SELF-EVAL -- unsupported type" exp))))
|
||||
|
||||
(define (compile-quoted exp target linkage)
|
||||
@@ -114,11 +114,8 @@
|
||||
(preserving '(env)
|
||||
get-value-code
|
||||
(make-instruction-sequence '(env val) (list target)
|
||||
`((perform (op define-variable!)
|
||||
(const ,var)
|
||||
(reg val)
|
||||
(reg env))
|
||||
(assign ,target (const ok))))))))
|
||||
`((" " ,target " = define_variable(\"" ,var "\", val, env);")
|
||||
))))))
|
||||
|
||||
|
||||
;;;conditional expressions
|
||||
@@ -137,9 +134,9 @@
|
||||
;; end of footnote
|
||||
|
||||
(define (compile-if exp target linkage)
|
||||
(let ((t-branch (make-label 'true-branch))
|
||||
(f-branch (make-label 'false-branch))
|
||||
(after-if (make-label 'after-if)))
|
||||
(let ((t-branch (make-label 'truebranch))
|
||||
(f-branch (make-label 'falsebranch))
|
||||
(after-if (make-label 'afterif)))
|
||||
(let ((consequent-linkage
|
||||
(if (eq? linkage 'next) after-if linkage)))
|
||||
(let ((p-code (compile (if-predicate exp) 'val 'next))
|
||||
@@ -148,23 +145,30 @@
|
||||
(if-consequent exp) target consequent-linkage))
|
||||
(a-code
|
||||
(compile (if-alternative exp) target linkage)))
|
||||
(preserving '(env continue)
|
||||
(preserving '(env continu)
|
||||
p-code
|
||||
(append-instruction-sequences
|
||||
(make-instruction-sequence '(val) '()
|
||||
`((test (op false?) (reg val))
|
||||
(branch (label ,f-branch))))
|
||||
`((" if(is_false(val))")
|
||||
(" goto " ,f-branch ";")
|
||||
(" goto " ,t-branch ";")
|
||||
))
|
||||
(parallel-instruction-sequences
|
||||
(append-instruction-sequences t-branch c-code)
|
||||
(append-instruction-sequences f-branch a-code))
|
||||
after-if))))))
|
||||
(append-instruction-sequences
|
||||
(make-instruction-sequence '() '() `((,t-branch ":")))
|
||||
c-code)
|
||||
(append-instruction-sequences
|
||||
(make-instruction-sequence '() '() `((,f-branch ":")))
|
||||
a-code))
|
||||
(make-instruction-sequence '() '() `((,after-if ":")))
|
||||
))))))
|
||||
|
||||
;;; sequences
|
||||
|
||||
(define (compile-sequence seq target linkage)
|
||||
(if (last-exp? seq)
|
||||
(compile (first-exp seq) target linkage)
|
||||
(preserving '(env continue)
|
||||
(preserving '(env continu)
|
||||
(compile (first-exp seq) target 'next)
|
||||
(compile-sequence (rest-exps seq) target linkage))))
|
||||
|
||||
@@ -172,31 +176,39 @@
|
||||
|
||||
(define (compile-lambda exp target linkage)
|
||||
(let ((proc-entry (make-label 'entry))
|
||||
(after-lambda (make-label 'after-lambda)))
|
||||
(after-lambda (make-label 'afterlambda)))
|
||||
(let ((lambda-linkage
|
||||
(if (eq? linkage 'next) after-lambda linkage)))
|
||||
(append-instruction-sequences
|
||||
(tack-on-instruction-sequence
|
||||
(end-with-linkage lambda-linkage
|
||||
(make-instruction-sequence '(env) (list target)
|
||||
`((assign ,target
|
||||
(op make-compiled-procedure)
|
||||
(label ,proc-entry)
|
||||
(reg env)))))
|
||||
`((" " ,target " = make_compiled_proc(&&" ,proc-entry ", env);"))))
|
||||
(compile-lambda-body exp proc-entry))
|
||||
after-lambda))))
|
||||
(make-instruction-sequence '() '() `((,after-lambda ":")))))))
|
||||
|
||||
(define (compile-lambda-body exp proc-entry)
|
||||
(let ((formals (lambda-parameters exp)))
|
||||
(define (formals-to-string formals)
|
||||
(if (null? formals)
|
||||
""
|
||||
(string-append
|
||||
"\""
|
||||
(string-append
|
||||
(symbol->string (car formals))
|
||||
(string-append
|
||||
"\", "
|
||||
(formals-to-string (cdr formals)))))))
|
||||
(let ((formals (lambda-parameters exp))
|
||||
(argv (make-label 'argv)))
|
||||
(append-instruction-sequences
|
||||
(make-instruction-sequence '(env proc argl) '(env)
|
||||
`(,proc-entry
|
||||
(assign env (op compiled-procedure-env) (reg proc))
|
||||
(assign env
|
||||
(op extend-environment)
|
||||
(const ,formals)
|
||||
(reg argl)
|
||||
(reg env))))
|
||||
`(
|
||||
(,proc-entry ":")
|
||||
(" env = proc->env;")
|
||||
(" const char *" ,argv "[] = {" ,(formals-to-string formals) "};")
|
||||
(" env = extend_environment(" ,argv ", argl, env);")
|
||||
))
|
||||
;(" env = extend_environment(" (const ,formals) ", argl, env);")))
|
||||
(compile-sequence (lambda-body exp) 'val 'return))))
|
||||
|
||||
|
||||
@@ -209,9 +221,9 @@
|
||||
(operand-codes
|
||||
(map (lambda (operand) (compile operand 'val 'next))
|
||||
(operands exp))))
|
||||
(preserving '(env continue)
|
||||
(preserving '(env continu)
|
||||
proc-code
|
||||
(preserving '(proc continue)
|
||||
(preserving '(proc continu)
|
||||
(construct-arglist operand-codes)
|
||||
(compile-procedure-call target linkage)))))
|
||||
|
||||
@@ -219,34 +231,30 @@
|
||||
(let ((operand-codes (reverse operand-codes)))
|
||||
(if (null? operand-codes)
|
||||
(make-instruction-sequence '() '(argl)
|
||||
'((assign argl (const ()))))
|
||||
'((" argl = NULL;")))
|
||||
(let ((code-to-get-last-arg
|
||||
(append-instruction-sequences
|
||||
(car operand-codes)
|
||||
(make-instruction-sequence '(val) '(argl)
|
||||
'((" argl[0] = val;"))))))
|
||||
'((" argl = cons(val, NULL);"))))))
|
||||
(if (null? (cdr operand-codes))
|
||||
code-to-get-last-arg
|
||||
(preserving '(env)
|
||||
code-to-get-last-arg
|
||||
(code-to-get-rest-args
|
||||
1
|
||||
(cdr operand-codes))))))))
|
||||
|
||||
(define (code-to-get-rest-args index operand-codes)
|
||||
(define (code-to-get-rest-args operand-codes)
|
||||
(let ((code-for-next-arg
|
||||
(preserving '(argl)
|
||||
(car operand-codes)
|
||||
(make-instruction-sequence '(val argl) '(argl)
|
||||
`((" argl[" ,index "] = val;"))))))
|
||||
`((" argl = cons(val, argl);"))))))
|
||||
(if (null? (cdr operand-codes))
|
||||
(append-instruction-sequences
|
||||
code-for-next-arg
|
||||
(make-instruction-sequence
|
||||
'() '() `((" argl[" ,(+ index 1) "] = NULL;"))))
|
||||
code-for-next-arg
|
||||
(preserving '(env)
|
||||
code-for-next-arg
|
||||
(code-to-get-rest-args (+ index 1) (cdr operand-codes))))))
|
||||
(code-to-get-rest-args (cdr operand-codes))))))
|
||||
|
||||
;;;applying procedures
|
||||
|
||||
@@ -259,7 +267,8 @@
|
||||
(append-instruction-sequences
|
||||
(make-instruction-sequence '(proc) '()
|
||||
`((" if (" primitive_procedure "(proc) == 1)")
|
||||
(" goto " ,primitive-branch ";")))
|
||||
(" goto " ,primitive-branch ";")
|
||||
(" goto " ,compiled-branch ";")))
|
||||
(parallel-instruction-sequences
|
||||
(append-instruction-sequences
|
||||
(make-instruction-sequence '() '() `((,compiled-branch ":")))
|
||||
@@ -269,7 +278,7 @@
|
||||
(end-with-linkage linkage
|
||||
(make-instruction-sequence '(proc argl)
|
||||
(list target)
|
||||
`((" val = (*proc->primitive_procedure)((void**) argl);"))))))
|
||||
`((" val = (*proc->primitive_procedure)(argl);"))))))
|
||||
(make-instruction-sequence '() '() `((,after-call ":")))))))
|
||||
|
||||
;;;applying compiled procedures
|
||||
@@ -277,31 +286,31 @@
|
||||
(define (compile-proc-appl target linkage)
|
||||
(cond ((and (eq? target 'val) (not (eq? linkage 'return)))
|
||||
(make-instruction-sequence '(proc) all-regs
|
||||
`((" " cont " = &&" ,linkage ";")
|
||||
`((" continu = &&" ,linkage ";")
|
||||
(" " entry " = " compiled_procedure_entry "(proc);")
|
||||
(" goto *entry;"))))
|
||||
((and (not (eq? target 'val))
|
||||
(not (eq? linkage 'return)))
|
||||
(let ((proc-return (make-label 'proc-return)))
|
||||
(make-instruction-sequence '(proc) all-regs
|
||||
`((assign continue (label ,proc-return))
|
||||
`((assign continu (label ,proc-return))
|
||||
(assign val (op compiled_procedure_entry)
|
||||
(reg proc))
|
||||
(goto (reg val))
|
||||
(" goto " (reg val) "// FOO2")
|
||||
,proc-return
|
||||
(assign ,target (reg val))
|
||||
(goto (label ,linkage))))))
|
||||
(" goto " (label ,linkage) "; // FOO1")))))
|
||||
((and (eq? target 'val) (eq? linkage 'return))
|
||||
(make-instruction-sequence '(proc continue) all-regs
|
||||
'((assign val (op compiled-procedure-entry)
|
||||
(reg proc))
|
||||
(goto (reg val)))))
|
||||
(make-instruction-sequence '(proc continu) all-regs
|
||||
'((" entry = compiled_procedure_entry(proc);")
|
||||
(" goto *entry;")
|
||||
)))
|
||||
((and (not (eq? target 'val)) (eq? linkage 'return))
|
||||
(error "return linkage, target not val -- COMPILE"
|
||||
target))))
|
||||
|
||||
;; footnote
|
||||
(define all-regs '(env proc val argl continue))
|
||||
(define all-regs '(env proc val argl continu))
|
||||
|
||||
|
||||
;;;SECTION 5.5.4
|
||||
@@ -361,9 +370,9 @@
|
||||
(registers-needed seq1))
|
||||
(list-difference (registers-modified seq1)
|
||||
(list first-reg))
|
||||
(append `((save ,first-reg))
|
||||
(append `((" save(",first-reg ", " ,first-reg "_stack);"))
|
||||
(statements seq1)
|
||||
`((restore ,first-reg))))
|
||||
`((" " ,first-reg " = restore(" ,first-reg "_stack);"))))
|
||||
seq2)
|
||||
(preserving (cdr regs) seq1 seq2)))))
|
||||
|
||||
|
||||
Reference in New Issue
Block a user