開発環境
- macOS Sierra - Apple (OS)
- Emacs (Text Editor)
- C, Scheme (プログラミング言語)
- Clang/LLVM (コンパイラ, Xcode - Apple)
- 参考書籍等
Cを高級アセンブラーとした、Scheme の コンパイラー(ksc)、インタプリター(ksi)を作成。インタプリターで正確な整数の読み込み、手続き(cons 、car 、cdr)といくつかの構文を使えるところまで。
コード
ksc.scm
(begin
(define (newline port)
(display #\newline port))
(define (print-elements list port)
(if (not (null? list))
(begin
(display (car list) port)
(print-elements (cdr list) port))))
(define (print-code code port)
(display '|/** \x5c;file */| port)
(newline port)
(display '|#include <kscm.h>| port)
(newline port)
(display
'|int main (int argc,char *argv[]){init();get_command_line(argc, argv);| port)
(print-elements (c-caddr code) port)
(display '|printf("=> ");object_write_stdout(val);puts("");}| port))
(define undef (if #f 0))
(define (pair->c obj)
(c-append '(|(|)
(obj->c (car obj))
'(| . |)
(obj->c (cdr obj))
'(|)|)))
(define (obj->c obj)
(if (number? obj)
(list obj)
(if (string? obj)
(c-string->c obj)
(if (symbol? obj)
(c-symbol->c obj)
(if (pair? obj)
(pair->c obj)
(if (null? obj)
'(|()|)
(if (boolean? obj)
(list obj)
(if (char? obj)
(c-char->c obj)))))))))
(define (const obj)
(if (eq? obj undef)
'(undef)
(if (eof-object? obj)
'(eof_obj)
(c-append '(|c_str_to_datum("|)
(obj->c obj)
'(|")|)))))
(define (definition-value exp)
(if (symbol? (c-cadr exp))
(c-caddr exp)
(c-make-lambda (c-cdadr exp)
(c-cddr exp))))
(define (and->if exp)
(if (null? exp)
#t
(begin
(define (iter o)
(if (null? (cdr o))
(car o)
(list 'if
(car o)
(iter (cdr o))
'#f)))
(iter exp))))
(define (or->if exp)
(if (null? exp)
'#f
(list 'if (car exp) (car exp) (cons 'or (cdr exp)))))
(define log-port (open-output-file "compiler.log"))
(define (compile exp target linkage)
(display exp log-port)
(newline log-port)
(if (c-self-evaluating? exp)
(compile-self-evaluating exp target linkage)
(if (symbol? exp)
(compile-variable exp target linkage)
(if (pair? exp)
((lambda (o)
(if (symbol? o)
(if (eq? o 'quote)
(compile-quoted exp target linkage)
(if (eq? o 'lambda)
(compile-lambda exp target linkage)
(if (eq? o 'set!)
(compile-assignment exp
target linkage)
(if (eq? o 'define)
(compile-definition exp
target linkage)
(if (eq? o 'if)
(compile-if exp
target linkage)
(if (eq? o 'begin)
(compile-sequence
(cdr exp)
target
linkage)
(if (eq? o 'and)
(compile
(and->if (cdr exp))
target
linkage)
(if (eq? o 'or)
(compile
(or->if (cdr exp))
target
linkage)
(compile-application
exp target linkage
)))))))))
(compile-application exp target linkage)))
(car exp))
(error '|unknown expression type -- compile| exp)))))
(define (compile-linkage linkage)
(if (eq? linkage 'return)
(c-make-instruction-sequence '(cont) '()
'(|goto *cont.cont;|))
(if (eq? linkage 'next)
(c-empty-instruction-sequence)
(c-make-instruction-sequence
'() '()
(list '|goto | linkage '|;|)))))
(define (end-with-linkage linkage instruction-sequence)
(preserving '(cont)
instruction-sequence
(compile-linkage linkage)))
(define (compile-self-evaluating exp target linkage)
(end-with-linkage
linkage
(c-make-instruction-sequence
'() (list target)
(c-append (list '|object_free(&| target '|);|
target '| = |)
(const exp)
'(|;|)))))
(define (compile-variable exp target linkage)
(end-with-linkage
linkage
(c-make-instruction-sequence
'(env) (list target)
(c-append (list '|object_free(&| target '|);|
target '| = lookup_var_val(c_str_to_datum("|)
(c-symbol->c exp)
'(|"));|)))))
(define (compile-quoted exp target linkage)
(end-with-linkage
linkage
(c-make-instruction-sequence
'() (list target)
(c-append (list '|object_free(&| target '|);|
target '| = |)
(const (c-cadr exp))
'(|;|)))))
(define (compile-assignment exp target linkage)
((lambda (var get-value-code)
(end-with-linkage
linkage
(preserving '(env)
get-value-code
(c-make-instruction-sequence
'(env val) (list target)
(c-append '(|{Object t = set_var_val(c_str_to_datum("|)
(c-symbol->c var)
(list '|"));
object_free(&| target '|);|
target '| = t;}|))))))
(c-cadr exp)
(compile (c-caddr exp) 'val 'next)))
(define (compile-definition exp target linkage)
((lambda (var get-value-code)
(end-with-linkage
linkage
(preserving '(env)
get-value-code
(c-make-instruction-sequence
'(env val) (list target)
(c-append '(|{Object t = def_var_val(c_str_to_datum("|)
(c-symbol->c var)
(list '|"));
object_free(&| target '|);|
target '| = t;}|))))))
(c-definition-variable exp)
(compile (definition-value exp) 'val 'next)))
(define (compile-if exp target linkage)
((lambda (f-branch after-if)
((lambda (consequent-linkage)
((lambda (p-code c-code a-code)
(preserving
'(env cont)
p-code
(append-instruction-sequences
(c-make-instruction-sequence
'(val) '()
(list '|if(val.type==BOOLEAN && !val.boolean){
goto | f-branch '|;}|))
(parallel-instruction-sequences
c-code
(append-instruction-sequences
(c-make-instruction-sequence
'() '()
(list f-branch '|:;|))
a-code))
(if (eq? linkage 'next)
(c-make-instruction-sequence
'() '()
(list after-if '|:;|))
(c-empty-instruction-sequence))
)))
(compile (c-cadr exp) 'val 'next)
(compile (c-caddr exp) target consequent-linkage)
(compile (c-if-alternative exp) target linkage)))
(if (eq? linkage 'next) after-if linkage)))
(make-label 'false_branch)
(make-label 'after_if)))
(define (compile-sequence seq target linkage)
(if (null? (cdr seq))
(compile (car seq) target linkage)
(preserving '(env cont)
(compile (car seq) target 'next)
(compile-sequence (cdr seq) target linkage))))
(define (compile-lambda exp target linkage)
((lambda (proc-entry after-lambda)
((lambda (lambda-linkage)
(append-instruction-sequences
(tack-on-instruction-sequence
(end-with-linkage
lambda-linkage
(c-make-instruction-sequence
'(env) (list target)
(list '|object_free(&| target '|);|
target '| = make_compiled_procedure(&&| proc-entry '|);|)
))
(compile-lambda-body exp proc-entry))
(if (eq? lambda-linkage after-lambda)
(c-make-instruction-sequence
'() '() (list after-lambda '|:;|))
(c-empty-instruction-sequence))))
(if (eq? linkage 'next) after-lambda linkage)))
(make-label 'entry)
(make-label 'after_lambda)))
(define (compile-lambda-body exp proc-entry)
((lambda (formals)
(append-instruction-sequences
(c-make-instruction-sequence
'(env proc argl) '(env)
(c-append (list proc-entry
'|:env = compiled_procedure_env();
env = extend_environment(|)
(const formals)
'(|);|)))
(compile-sequence (c-cddr exp) 'val 'return)))
(c-cadr exp)))
(define (compile-application exp target linkage)
(define (iter proc lst)
(if (null? lst)
'()
(cons (proc (car lst))
(iter proc (cdr lst)))))
((lambda (proc-code operand-codes)
(preserving
'(env cont)
proc-code
(preserving
'(proc cont)
(construct-arglist operand-codes)
(compile-procedure-call target linkage))))
(compile (car exp) 'proc 'next)
(iter (lambda (operand) (compile operand 'val 'next)) (cdr exp))))
(define (construct-arglist operand-codes)
((lambda (operand-codes)
(if (null? operand-codes)
(c-make-instruction-sequence
'() '(argl)
'(|argl = empty;|))
((lambda (code-to-get-last-arg)
(if (null? (cdr operand-codes))
code-to-get-last-arg
(preserving '(env)
code-to-get-last-arg
(code-to-get-rest-args
(cdr operand-codes)))))
(append-instruction-sequences
(car operand-codes)
(c-make-instruction-sequence
'(val) '(argl)
'(|argl = cons(object_copy(val),empty);|))))))
(c-reverse operand-codes)))
(define (code-to-get-rest-args operand-codes)
((lambda (code-for-next-arg)
(if (null? (cdr operand-codes))
code-for-next-arg
(preserving '(env)
code-for-next-arg
(code-to-get-rest-args
(cdr operand-codes)))))
(preserving
'(argl)
(car operand-codes)
(c-make-instruction-sequence
'(val argl) '(argl)
'(|argl = cons(object_copy(val), argl);|)))))
(define (compile-procedure-call target linkage)
((lambda (primitive-branch after-call)
((lambda (compiled-linkage)
(append-instruction-sequences
(c-make-instruction-sequence
'(proc) '()
(list '|if (proc.type == PROC_APPLY) {
proc = apply_proc();
argl = apply_argl();
}
if (proc.type == PROC) { goto |
primitive-branch '|;}|))
(parallel-instruction-sequences
(compile-proc-appl target compiled-linkage)
(append-instruction-sequences
(c-make-instruction-sequence
'() '()
(list primitive-branch '|:;|))
(end-with-linkage
linkage
(c-make-instruction-sequence
'(proc argl)
(list target)
(list '|object_free(&| target '|);|
target '| = proc.proc(argl); |)
))))
(if (eq? linkage 'next)
(c-make-instruction-sequence
'() '() (list after-call '|:;|))
(c-empty-instruction-sequence))
))
(if (eq? linkage 'next) after-call linkage)))
(make-label 'primitive_branch)
(make-label 'after_call)))
(define (compile-proc-appl target linkage)
(if (and (eq? target 'val) (not (eq? linkage 'return)))
(c-make-instruction-sequence
'(proc) all-regs
(list '|cont.cont = &&| linkage '|;
object_free(&val);
val = compiled_procedure_entry(proc);
goto *val.cont;|))
(if (and (not (eq? target 'val))
(not (eq? linkage 'return)))
((lambda (proc-return)
(c-make-instruction-sequence
'(proc) all-regs
(list '|cont.cont = &&| proc-return '|;
object_free(&val);
val = compiled_procedure_entry(proc);
goto *val.cont;|
proc-return '|:
object_free(&| target '|);|
target '| = val; val.type = NONE;
goto | linkage '|;|)))
(make-label 'proc_return))
(if (and (eq? target 'val) (eq? linkage 'return))
(c-make-instruction-sequence
'(proc cont) all-regs
'(|object_free(&val);
val = compiled_procedure_entry(proc);
goto *val.cont;|)
)
(if (and (not (eq? target 'val))
(eq? linkage 'return))
(error
'|return linkage, target not val -- compile|
target))))))
(define all-regs '(env proc val argl cont))
(define (append-instruction-sequences . seqs)
(define (append-2-sequences seq1 seq2)
(c-make-instruction-sequence
(c-list-union (c-registers-needed seq1)
(c-list-difference (c-registers-needed seq2)
(c-registers-modified seq1)))
(c-list-union (c-registers-modified seq1)
(c-registers-modified seq2))
(c-append (c-statements seq1) (c-statements seq2))))
(define (append-seq-list seqs)
(if (null? seqs)
(c-empty-instruction-sequence)
(append-2-sequences (car seqs)
(append-seq-list (cdr seqs)))))
(append-seq-list seqs))
(define (preserving regs seq1 seq2)
(if (null? regs)
(append-instruction-sequences seq1 seq2)
((lambda (first-reg)
(if (and (c-needs-register? seq2 first-reg)
(c-modifies-register? seq1 first-reg))
(preserving (cdr regs)
(c-make-instruction-sequence
(c-list-union (list first-reg)
(c-registers-needed seq1))
(c-list-difference
(c-registers-modified seq1)
(list first-reg))
(c-append
(list '|save(| first-reg '|);|)
(c-statements seq1)
(list '|object_free(&| first-reg '|);|
first-reg '| =restore();|)))
seq2)
(preserving (cdr regs) seq1 seq2)))
(car regs))))
(define (tack-on-instruction-sequence seq body-seq)
(c-make-instruction-sequence
(c-registers-needed seq)
(c-registers-modified seq)
(c-append (c-statements seq) (c-statements body-seq))))
(define (parallel-instruction-sequences seq1 seq2)
(c-make-instruction-sequence
(c-list-union (c-registers-needed seq1)
(c-registers-needed seq2))
(c-list-union (c-registers-modified seq1)
(c-registers-modified seq2))
(c-append (c-statements seq1) (c-statements seq2))))
(define input-file (open-input-file "input.scm"))
(define output-file (open-output-file "output.c"))
(define data (read input-file))
(define code (compile data 'val 'next))
(print-code code output-file)
'compiled
)
ksi.scm
((lambda ()
(define (eval exp env) ((analyze exp) env))
(define (analyze exp)
(if (eof-object? exp)
(exit)
(if (self-evaluating? exp)
(analyze-self-evaluating exp)
(if (variable? exp)
(analyze-variable exp)
(if (quoted? exp)
(analyze-quoted exp)
(if (lambda? exp)
(analyze-lambda exp)
(if (definition? exp)
(analyze-definition exp)
(if (assignment? exp)
(analyze-assignment exp)
(if (if? exp)
(analyze-if exp)
(if (begin? exp)
(analyze-sequence (begin-actions exp))
(if (application? exp)
(analyze-application exp)
(error
"unknown expression type -- analyze"
exp))))))))))))
(define (analyze-self-evaluating exp) (lambda (env) exp))
(define (analyze-variable exp) (lambda (env) (lookup-variable-value exp env)))
(define (analyze-quoted exp)
((lambda (qval)
(lambda (env) qval))
(text-of-quotation exp)))
(define (analyze-lambda exp)
((lambda (vars bproc)
(lambda (env) (make-procedure vars bproc env)))
(lambda-parameters exp)
(analyze-sequence (lambda-body exp))))
(define (analyze-definition exp)
((lambda (var vproc)
(lambda (env)
(define-variable! var (vproc env) env)))
(definition-variable exp)
(analyze (definition-value exp))))
(define (analyze-assignment exp)
((lambda (var vproc)
(lambda (env)
(set-variable-value! var (vproc env) env)))
(assignment-variable exp)
(analyze (assignment-value exp))))
(define (analyze-if exp)
((lambda (pproc cproc aproc)
(lambda (env)
(if (pproc env)
(cproc env)
(aproc env))))
(analyze (if-predicate exp))
(analyze (if-consequent exp))
(analyze (if-alternative exp))))
(define (map proc list)
(if (null? list)
'()
(cons (proc (car list))
(map proc (cdr list)))))
(define (analyze-sequence exps)
(define (sequentially proc1 proc2)
(lambda (env) (proc1 env) (proc2 env)))
(define (loop first-proc rest-procs)
(if (null? rest-procs)
first-proc
(loop (sequentially first-proc (car rest-procs))
(cdr rest-procs))))
((lambda (procs)
(if (null? procs)
(error "empty sequence -- analyze"))
(loop (car procs) (cdr procs)))
(map analyze exps)))
(define (analyze-application exp)
((lambda (pproc aprocs)
(lambda (env)
(execute-application (pproc env)
(map (lambda (aproc) (aproc env))
aprocs))))
(analyze (operator exp))
(map analyze (operands exp))))
(define (execute-application proc args)
(if (primitive-procedure? proc)
(c-apply (primitive-implementation proc) args)
(if (compound-procedure? proc)
((procedure-body proc)
(extend-environment (procedure-parameters proc)
args
(procedure-environment proc)))
(error "unknown procedure type -- execute-application" proc))))
(define (self-evaluating? exp)
(or (boolean? exp)
(number? exp)
(vector? exp)
(char? exp)
(string? exp)
(bytevector? exp)
(procedure? exp)
(eq? exp (if #f '()))))
(define (variable? exp) (symbol? exp))
(define (quoted? exp) (tagged-list? exp 'quote))
(define (text-of-quotation exp) (car (cdr exp)))
(define (tagged-list? exp tag)
(if (pair? exp)
(eq? (car exp) tag)
#f))
(define (lambda? exp) (tagged-list? exp 'lambda))
(define (lambda-parameters exp) (car (cdr exp)))
(define (lambda-body exp) (cdr (cdr exp)))
(define (make-lambda parameters body) (cons 'lambda (cons parameters body)))
(define (if? exp) (tagged-list? exp 'if))
(define (if-predicate exp) (car (cdr exp)))
(define (if-consequent exp) (car (cdr (cdr exp))))
(define (if-alternative exp)
(if (not (null? (cdr (cdr (cdr exp)))))
(car (cdr (cdr (cdr exp))))))
(define (begin? exp) (tagged-list? exp 'begin))
(define (begin-actions exp) (cdr exp))
(define (application? exp) (pair? exp))
(define (operator exp) (car exp))
(define (operands exp) (cdr exp))
(define (definition? exp) (tagged-list? exp 'define))
(define (definition-variable exp)
(if (symbol? (car (cdr exp)))
(car (cdr exp))
(car (car (cdr exp)))))
(define (definition-value exp)
(if (symbol? (car (cdr exp)))
(car (cdr (cdr exp)))
(make-lambda (cdr (car (cdr exp)))
(cdr (cdr exp)))))
(define (assignment? exp) (tagged-list? exp 'set!))
(define (assignment-variable exp) (car (cdr exp)))
(define (assignment-value exp) (car (cdr (cdr exp))))
(define (first-frame env) (car env))
(define the-empty-environment '())
(define (make-frame variables values) (cons variables values))
(define (frame-variables frame) (car frame))
(define (frame-values frame) (cdr frame))
(define (add-binding-to-frame! var val frame)
(set-car! frame (cons var (car frame)))
(set-cdr! frame (cons val (cdr frame))))
(define (define-variable! var val env)
((lambda (frame)
(define (scan vars vals)
(if (null? vars)
(add-binding-to-frame! var val frame)
(if (eq? var (car vars))
(set-car! vals val)
(scan (cdr vars) (cdr vals)))))
(scan (frame-variables frame)
(frame-values frame)))
(first-frame env)))
(define (set-variable-value! var val env)
(define (env-loop env)
(define (scan vars vals)
(if (null? vars)
(env-loop (enclosing-environment env))
(if (eq? var (car vars))
(set-car! vals val)
(scan (cdr vars) (cdr vals)))))
(if (eq? env the-empty-environment)
(error "(set!) unbound variable --" var)
((lambda (frame)
(scan (frame-variables frame)
(frame-values frame)))
(first-frame env))))
(env-loop env))
(define (make-procedure parameters body env)
(list 'procedure parameters body env))
(define (compound-procedure? p) (tagged-list? p 'procedure))
(define (procedure-parameters p) (car (cdr p)))
(define (procedure-body p) (car (cdr (cdr p))))
(define (procedure-environment p) (car (cdr (cdr (cdr p)))))
(define (enclosing-environment env) (cdr env))
(define (extend-environment vars vals base-env)
(define (iter vars-0 vals-0 vars-1 vals-1)
(if (symbol? vars-0)
(cons (make-frame (cons vars-0 vars-1)
(cons vals-0 vals-1))
base-env)
(if (null? vars-0)
(if (null? vals-0)
(cons (make-frame vars-1 vals-1) base-env)
(error "Too many arguments supplied" vars vals))
(if (null? vals-0)
(error "Too few arguments supplied" vars vals)
(iter (cdr vars-0)
(cdr vals-0)
(cons (car vars-0) vars-1)
(cons (car vals-0) vals-1))))))
(iter vars vals '() '()))
(define (lookup-variable-value var env)
(define (env-loop env)
(define (scan vars vals)
(if (null? vars)
(env-loop (enclosing-environment env))
(if (eq? var (car vars))
(car vals)
(scan (cdr vars) (cdr vals)))))
(if (eq? env the-empty-environment)
(error "unbound variable" var)
((lambda (frame)
(scan (frame-variables frame)
(frame-values frame)))
(first-frame env))))
(env-loop env))
(define (primitive-procedure? proc) (tagged-list? proc 'primitive))
(define (primitive-implementation proc) (car (cdr proc)))
(define primitive-procedures
(list (list 'car car)
(list 'cdr cdr)
(list 'cons cons)
))
(define (primitive-procedure-names) (map car primitive-procedures))
(define (primitive-procedure-objects)
(map (lambda (proc)
(list 'primitive (car (cdr proc))))
primitive-procedures))
(define (setup-environment)
((lambda (initial-env)
(define-variable! 'quote quote initial-env)
(define-variable! 'lambda lambda initial-env)
(define-variable! 'define define initial-env)
(define-variable! 'set! set! initial-env)
(define-variable! 'if if initial-env)
(define-variable! 'begin begin initial-env)
initial-env)
(extend-environment
(primitive-procedure-names)
(primitive-procedure-objects)
the-empty-environment)))
(define the-global-environment (setup-environment))
(define input-prompt "> ")
(define output-prompt "=> ")
(define input-port (current-input-port))
(define output-port (current-output-port))
(define (driver-loop)
(prompt-for-input input-prompt)
((lambda (input)
((lambda (output)
(announce-output output-prompt)
(user-print output))
(eval input the-global-environment)))
(read input-port))
(driver-loop))
(define (prompt-for-input string)
(display string output-port))
(define (announce-output string)
(display string output-port))
(define (user-print object)
(if (compound-procedure? object)
(begin (display '|#<compound-procedure | output-port)
(write (procedure-parameters object) output-port)
(write '> output-port))
(write object output-port))
(newline output-port))
(driver-loop)
))
入出力結果(Terminal)
$ ./ksi > '|Hello, World!| => |Hello,\x20;World!| > "Hello, World!" => "Hello, World!" > exit: 0 $
0 コメント:
コメントを投稿