導入
今回はScheme上にレジスタマシンを実装して、入力したSchemeのコードをレジスタマシンが解釈するアセンブリ言語に翻訳・実行し、結果を表示するというプログラムを紹介します。レジスタマシンについては、「計算器プログラムの構造と解釈」第5章を参照してください。
https://sicp.iijlab.net/fulltext/x500.html
コード
common.scm
共通の基本的な手続き群です。
(define nil '())
(define true #t)
(define false #f)
(define (true? x) (not (eq? x false)))
(define (false? x) (eq? x false))
(define (for-each proc items)
(if (null? items)
true
(begin
(proc (car items))
(for-each proc (cdr items)))))
(define (filter predicate sequence)
(cond ((null? sequence) nil)
((predicate (car sequence))
(cons (car sequence) (filter predicate (cdr sequence))))
(else (filter predicate (cdr sequence)))))
comp.scm
コンパイラです。Schemeのプログラムをレジスタマシンが解釈できるアセンブリ言語へ翻訳するための手続き群です。
(load "./common.scm")
(load "./debug.scm")
(define output-comment false)
(define (comment-on) (set! output-comment true) true)
(define (comment-off) (set! output-comment false) false)
(define (comment s)
(if (true? output-comment)
(list (string-append "; " s))
nil))
(define label-counter 0)
(define (new-label-number)
(set! label-counter (+ 1 label-counter))
label-counter)
(define (make-label name)
(string->symbol
(string-append (symbol->string name)
(number->string (new-label-number)))))
(define (compile-and-go expression)
(let ((instructions
(assemble (statements
(formatted-compile expression 'val 'return nil))
eceval)))
(set! the-global-environment (setup-environment))
(set-register-contents! eceval 'val instructions)
(set-register-contents! eceval 'flag true)
;; (trace-on eceval)
(start eceval)))
(define (formatted-compile-orig exp target linkage ctenv)
(define (output-iter s)
(if (null? s)
(newline)
(begin
(cond ((pair? (car s))
(display " ")
(display (car s))
(newline))
(else
(display (car s))
(newline)))
(output-iter (cdr s)))))
(let ((compiled-code (compile exp target linkage ctenv)))
(display ";; needed : ")
(display (registers-needed compiled-code))
(newline)
(display ";; modified : ")
(display (registers-modified compiled-code))
(newline)
(output-iter (statements compiled-code))))
(define (formatted-compile-with-source-code exp target linkage ctenv)
(define (make-inst-line s)
(display " ")
(display (car s))
(newline))
(define (make-label-line s)
(display (car s))
(newline))
(define (make-nop-line)
(display " (perform (op nop))")
(newline))
(define (output-iter s ns label-flag)
(cond ((null? s) ns)
((pair? (car s))
(make-inst-line s)
(output-iter (cdr s) (append ns (list (car s))) false))
((true? label-flag)
(make-nop-line)
(make-label-line s)
(output-iter (cdr s) (append ns (cons (car s) '((perform (op nop))))) true))
(else
(make-label-line s)
(output-iter (cdr s) (append ns (list (car s))) true))))
(let ((compiled-code (compile exp target linkage ctenv)))
(display ";; needed : ")
(display (registers-needed compiled-code))
(newline)
(display ";; modified : ")
(display (registers-modified compiled-code))
(newline)
(list
(registers-needed compiled-code)
(registers-modified compiled-code)
(output-iter (statements compiled-code) nil false))))
(define (formatted-compile exp target linkage ctenv)
(define (output-iter s ns label-flag)
(cond ((null? s) ns)
((pair? (car s))
(output-iter (cdr s) (append ns (list (car s))) false))
((true? label-flag)
(output-iter (cdr s) (append ns (cons (car s) '((perform (op nop))))) true))
(else
(output-iter (cdr s) (append ns (list (car s))) true))))
(let ((compiled-code (compile exp target linkage ctenv)))
(list
(registers-needed compiled-code)
(registers-modified compiled-code)
(output-iter (statements compiled-code) nil false))))
(define (compile exp target linkage ctenv)
;; (debug-print "COMPILE exp=" exp)
(cond ((self-evaluating? exp)
(compile-self-evaluating exp target linkage ctenv))
((quoted? exp)
(compile-quoted exp target linkage ctenv))
((variable? exp)
(compile-variable exp target linkage ctenv))
((assignment? exp)
(compile-assignment exp target linkage ctenv))
((definition? exp)
(compile-definition exp target linkage ctenv))
((if? exp)
(compile-if exp target linkage ctenv))
((cond? exp)
(compile-if (cond->if exp) target linkage ctenv))
((let? exp)
(compile-let exp target linkage ctenv))
((lambda? exp)
(compile-lambda exp target linkage ctenv))
((begin? exp)
(compile-sequence (begin-actions exp) target linkage ctenv))
((open-code? exp)
(compile-open-code exp target linkage ctenv))
((application? exp)
(compile-application exp target linkage ctenv))
(else
(error "Unknown expression type -- COMPILE" exp))))
(define (make-instruction-sequence needs modifies statements)
(list needs modifies statements))
(define (empty-instruction-sequence)
(make-instruction-sequence nil nil nil))
(define (compile-linkage linkage)
(cond ((eq? linkage 'return)
(make-instruction-sequence
'(continue)
nil
'((goto (reg continue)))))
((eq? linkage 'next)
(empty-instruction-sequence))
(else
(make-instruction-sequence
nil
nil
`((goto (label ,linkage)))))))
(define (end-with-linkage linkage instruction-sequence)
(preserving 'end-with-linkage
'(continue)
instruction-sequence
(compile-linkage linkage)))
(define (compile-self-evaluating exp target linkage ctenv)
(end-with-linkage
linkage
(make-instruction-sequence
nil
(list target)
(append
(comment "compile-self-evaluating")
`((assign ,target (const ,exp)))))))
(define (compile-quoted exp target linkage ctenv)
(end-with-linkage
linkage
(make-instruction-sequence
nil
(list target)
(append
(comment "compile-quoted")
`((assign ,target (const ,(text-of-quotation exp))))))))
(define (compile-variable exp target linkage ctenv)
(end-with-linkage
linkage
(make-instruction-sequence
'(env)
(list target)
(append
(comment "compile-variable")
(let ((laddr (find-variable exp ctenv)))
(if (not-found? laddr)
`((assign ,target
(op lookup-variable-value)
(const ,exp)
(reg env)))
`((assign ,target
(op lexical-address-lookup)
(const ,laddr)
(reg env)))
))))))
(define (compile-assignment exp target linkage ctenv)
(let ((var (assignment-variable exp))
(get-value-code
(compile (assignment-value exp) 'val 'next ctenv)))
(end-with-linkage
linkage
(preserving
'compile-assignment
'(env)
get-value-code
(make-instruction-sequence
'(env val)
(list target)
(append
(comment "compile-assignment")
(let ((laddr (find-variable var ctenv)))
(if (not-found? laddr)
`((perform (op set-variable-value!)
(const ,var)
(reg val)
(reg env))
(assign ,target (const ok)))
`((perform (op lexical-address-set!)
(const ,laddr)
(reg val)
(reg env))
(assign ,target (const ok)))
))))))))
(define (compile-definition exp target linkage ctenv)
(let ((var (definition-variable exp))
(get-value-code
(compile (definition-value exp) 'val 'next ctenv)))
(end-with-linkage
linkage
(preserving
'compile-definition
'(env)
get-value-code
(make-instruction-sequence
'(env val)
(list target)
(append
(comment "compile-definition")
`((perform (op define-variable!)
(const ,var)
(reg val)
(reg env))
(assign ,target (const ok)))))))))
(define (compile-if exp target linkage ctenv)
(let ((t-branch (make-label 'true-branch))
(f-branch (make-label 'false-branch))
(after-if (make-label 'after-if)))
(let ((consequent-linkage
(if (eq? linkage 'next) after-if linkage)))
(let ((p-code (compile (if-predicate exp) 'val 'next ctenv))
(c-code (compile (if-consequent exp) target consequent-linkage ctenv))
(a-code (compile (if-alternative exp) target linkage ctenv)))
(preserving
'compile-if
'(env continue)
p-code
(append-instruction-sequences
(make-instruction-sequence
'(val)
nil
(append
(comment "compile-if")
`((test (op false?) (reg val))
(branch (label ,f-branch)))))
(parallel-instruction-sequences
(append-instruction-sequences t-branch c-code)
(append-instruction-sequences f-branch a-code))
after-if))))))
(define (compile-sequence seq target linkage ctenv)
(if (last-exp? seq)
(compile (first-exp seq) target linkage ctenv)
(preserving
'compile-sequence
'(env continue)
(compile (first-exp seq) target 'next ctenv)
(compile-sequence (rest-exps seq) target linkage ctenv))))
(define (compile-lambda exp target linkage ctenv)
(let ((proc-entry (make-label 'entry))
(after-lambda (make-label 'after-lambda)))
(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)
(append
(comment "compile-lambda")
`((assign ,target
(op make-compiled-procedure)
(label ,proc-entry)
(reg env))))))
(compile-lambda-body exp proc-entry ctenv))
after-lambda))))
(define (compile-lambda-body exp proc-entry ctenv)
(let ((formals (lambda-parameters exp)))
(append-instruction-sequences
(make-instruction-sequence
'(env proc argl)
'(env)
(append
(comment "compile-lambda-body")
`(,proc-entry
(assign env (op compiled-procedure-env) (reg proc))
(assign env
(op extend-environment)
(const ,formals)
(reg argl)
(reg env)))))
(compile-sequence
(scan-out-defines (lambda-body exp))
'val
'return
(cons formals ctenv)))))
(define (compile-let exp target linkage ctenv)
(compile
(cons (make-lambda
(let-parameter-variables (let-parameters exp))
(let-body exp))
(let-parameter-exps (let-parameters exp)))
target
linkage
ctenv))
(define (make-compiled-procedure entry env)
(list 'compiled-procedure entry env))
(define (compiled-procedure? proc)
(tagged-list? proc 'compiled-procedure))
(define (compiled-procedure-entry c-proc) (cadr c-proc))
(define (compiled-procedure-env c-proc) (caddr c-proc))
(define (compile-application exp target linkage ctenv)
(let ((proc-code (compile (operator exp) 'proc 'next ctenv))
(operand-codes (list-of-operands (operands exp) target ctenv)))
(preserving
'compile-application
'(env continue)
proc-code
(preserving
'compile-application-arglist
'(proc continue)
(construct-arglist operand-codes)
(compile-procedure-call target linkage)))))
(define (list-of-operands exps target ctenv)
(list-of-operands-left exps target ctenv))
(define (list-of-operands-left exps target ctenv)
(if (no-operands? exps)
nil
(let ((code (compile (first-operand exps) target 'next ctenv)))
(cons code
(list-of-operands-left (rest-operands exps) target ctenv)))))
(define (list-of-operands-right exps target ctenv)
(reverse (list-of-operands-left (reverse exps) target ctenv)))
(define (construct-arglist operand-codes)
(let ((operand-codes (reverse operand-codes)))
(if (null? operand-codes)
(make-instruction-sequence
nil
'(argl)
(append
(comment "construct-arglist : null arg")
'((assign argl (const ())))))
(let ((code-to-get-last-arg
(append-instruction-sequences
(car operand-codes)
(make-instruction-sequence
'(val)
'(argl)
(append
(comment "construct-arglist")
'((assign argl (op list) (reg val))))))))
(if (null? (cdr operand-codes))
code-to-get-last-arg
(preserving
'construct-arglist
'(env)
code-to-get-last-arg
(code-to-get-rest-args (cdr operand-codes))))))))
(define (code-to-get-rest-args operand-codes)
(let ((code-for-next-arg
(preserving
'code-to-get-rest-args
'(argl)
(car operand-codes)
(make-instruction-sequence
'(val argl)
'(argl)
(append
(comment "code-to-get-rest-args")
'((assign argl
(op cons) (reg val) (reg argl))))))))
(if (null? (cdr operand-codes))
code-for-next-arg
(preserving
'code-to-get-last-args
'(env)
code-for-next-arg
(code-to-get-rest-args (cdr operand-codes))))))
(define (compile-procedure-call-orig target linkage)
(let ((primitive-branch (make-label 'primitive-branch))
(compiled-branch (make-label 'compiled-branch))
(after-call (make-label 'after-call)))
(let ((compiled-linkage
(if (eq? linkage 'next) after-call linkage)))
(append-instruction-sequences
(make-instruction-sequence
'(proc)
nil
(append
(comment "compile-procedure-call: testing")
`((test (op primitive-procedure?) (reg proc))
(branch (label ,primitive-branch)))))
(parallel-instruction-sequences
(append-instruction-sequences
compiled-branch
(compile-proc-appl target compiled-linkage))
(append-instruction-sequences
primitive-branch
(end-with-linkage
linkage
(make-instruction-sequence
'(proc argl)
(list target)
(append
(comment "compile-procedure-call: primitive")
`((assign ,target
(op apply-primitive-procedure)
(reg proc)
(reg argl))))))))
after-call))))
(define (compile-procedure-call target linkage)
(let ((primitive-branch (make-label 'primitive-branch))
(compiled-branch (make-label 'compiled-branch))
(interpret-branch (make-label 'interpret-branch))
(after-call (make-label 'after-call)))
(let ((compiled-linkage
(if (eq? linkage 'next) after-call linkage)))
(append-instruction-sequences
(make-instruction-sequence
'(proc)
nil
(append
(comment "compile-procedure-call: primitive testing")
`((test (op primitive-procedure?) (reg proc))
(branch (label ,primitive-branch)))))
(parallel-instruction-sequences
(append-instruction-sequences
(make-instruction-sequence
'(proc)
nil
(append
(comment "compile-procedure-call: compiled-procedure testing")
`((test (op compiled-procedure?) (reg proc))
(branch (label ,compiled-branch)))))
(parallel-instruction-sequences
(append-instruction-sequences
interpret-branch
(interpret-proc-appl target compiled-linkage))
(append-instruction-sequences
compiled-branch
(compile-proc-appl target compiled-linkage))))
(append-instruction-sequences
primitive-branch
(end-with-linkage
linkage
(make-instruction-sequence
'(proc argl)
(list target)
(append
(comment "compile-procedure-call: primitive")
`((assign ,target
(op apply-primitive-procedure)
(reg proc)
(reg argl))))))))
after-call))))
(define (compile-proc-appl target linkage)
(define target-is-val? (eq? target 'val))
(define target-is-not-val? (not target-is-val?))
(define linkage-is-return? (eq? linkage 'return))
(define linkage-is-not-return? (not linkage-is-return?))
(cond ((and (eq? target 'val) (not (eq? linkage 'return)))
(make-instruction-sequence
'(proc)
all-regs
(append
(comment "compile-proc-appl : target=val, linkage!=return")
`((assign continue (label ,linkage))
(assign val (op compiled-procedure-entry) (reg proc))
(goto (reg val))))))
((and (not (eq? target 'val)) (not (eq? linkage 'return)))
(let ((proc-return (make-label 'proc-return)))
(make-instruction-sequence
'(proc)
all-regs
(append
(comment "compile-proc-appl : target!=val, linkage!=return")
`((assign continue (label ,proc-return))
(assign val (op compiled-procedure-entry) (reg proc))
(goto (reg val))
,proc-return
(assign ,target (reg val))
(goto (label ,linkage)))))))
((and (eq? target 'val) (eq? linkage 'return))
(make-instruction-sequence
'(proc continue)
all-regs
(append
(comment "compile-proc-appl : target=val, linkage=return")
'((assign val (op compiled-procedure-entry) (reg proc))
(goto (reg val))))))
((and (not (eq? target 'val)) (eq? linkage 'return))
(error "return linkage, target not val -- COMPILE"
target))))
(define (interpret-proc-appl target linkage)
(define target-is-val? (eq? target 'val))
(define target-is-not-val? (not target-is-val?))
(define linkage-is-return? (eq? linkage 'return))
(define linkage-is-not-return? (not linkage-is-return?))
(cond ((and (eq? target 'val) (not (eq? linkage 'return)))
(make-instruction-sequence
'(proc)
all-regs
(append
(comment "interpret-proc-appl : target=val, linkage!=return")
`((assign continue (label ,linkage))
(save continue)
(goto (reg compapp))))))
((and (not (eq? target 'val)) (not (eq? linkage 'return)))
(let ((proc-return (make-label 'proc-return)))
(make-instruction-sequence
'(proc)
all-regs
(append
(comment "interpret-proc-appl : target!=val, linkage!=return")
`((assign continue (label ,proc-return))
(save continue)
(goto (reg compapp))
,proc-return
(assign ,target (reg val))
(goto (label ,linkage)))))))
((and (eq? target 'val) (eq? linkage 'return))
(make-instruction-sequence
'(proc continue)
all-regs
(append
(comment "interpret-proc-appl : target=val, linkage=return")
'((save continue)
(goto (reg compapp))))))
((and (not (eq? target 'val)) (eq? linkage 'return))
(error "return linkage, target not val -- COMPILE"
target))))
(define (compile-open-code exp target linkage ctenv)
(let ((ope (operator exp))
(operand-codes (list-of-operands (operands exp) 'val ctenv)))
(preserving
'compile-open-code
'(env proc continue)
(spread-arguments operand-codes)
(let ((laddr (find-variable ope ctenv)))
(if (not-found? laddr)
(open-code-primitive ope target linkage)
(open-code-lexical laddr target linkage))))))
(define (open-code-primitive ope target linkage)
(end-with-linkage
linkage
(make-instruction-sequence
'(argl)
(list target)
(append
(comment "open-code-primitive")
`((assign ,target (op ,ope) (reg argl)))))))
(define (open-code-lexical laddr target linkage)
(append-instruction-sequences
(make-instruction-sequence
'(argl)
'(proc)
(append
(comment "open-code-lexical")
`((assign proc (op lexical-address-lookup) (const ,laddr) (reg env)))))
(compile-procedure-call target linkage)))
(define (spread-arguments args)
(let ((operands (reverse args)))
(if (null? operands)
(error "arguments not found -- SPREAD-ARGUMENTS")
(let ((spread-arguments-get-last-arg
(append-instruction-sequences
(car operands)
(make-instruction-sequence
'(val)
'(argl)
(append
(comment "spread-arguments")
'((assign argl (op list) (reg val))))))))
(if (null? (cdr operands))
spread-arguments-get-last-arg
(preserving
'spread-arguments
'(env)
spread-arguments-get-last-arg
(code-to-get-rest-args (cdr operands))))))))
(define all-regs '(env proc val argl continue))
(define (registers-needed s)
(if (symbol? s) nil (car s)))
(define (registers-modified s)
(if (symbol? s) nil (cadr s)))
(define (statements s)
(if (symbol? s) (list s) (caddr s)))
(define (needs-register? seq reg)
(memq reg (registers-needed seq)))
(define (modifies-register? seq reg)
(memq reg (registers-modified seq)))
(define (append-instruction-sequences . seqs)
(define (append-2-sequences seq1 seq2)
(make-instruction-sequence
(list-union (registers-needed seq1)
(list-difference (registers-needed seq2)
(registers-modified seq1)))
(list-union (registers-modified seq1)
(registers-modified seq2))
(append (statements seq1) (statements seq2))))
(define (append-seq-list seqs)
(if (null? seqs)
(empty-instruction-sequence)
(append-2-sequences (car seqs)
(append-seq-list (cdr seqs)))))
(append-seq-list seqs))
(define (list-union s1 s2)
(cond ((null? s1) s2)
((memq (car s1) s2) (list-union (cdr s1) s2))
(else (cons (car s1) (list-union (cdr s1) s2)))))
(define (list-difference s1 s2)
(cond ((null? s1) nil)
((memq (car s1) s2) (list-difference (cdr s1) s2))
(else (cons (car s1) (list-difference (cdr s1) s2)))))
(define (preserving proc regs seq1 seq2)
(if (null? regs)
(append-instruction-sequences seq1 seq2)
(let ((first-reg (car regs)))
(if (and (needs-register? seq2 first-reg)
(modifies-register? seq1 first-reg))
(preserving
proc
(cdr regs)
(make-instruction-sequence
(list-union (list first-reg)
(registers-needed seq1))
(list-difference (registers-modified seq1)
(list first-reg))
(append
(comment (string-append "preserving begin : "
(symbol->string proc)))
`((save ,first-reg))
(statements seq1)
`((restore ,first-reg))
(comment (string-append "preserving end : "
(symbol->string proc)))))
seq2)
(preserving proc (cdr regs) seq1 seq2)))))
(define (tack-on-instruction-sequence seq body-seq)
(make-instruction-sequence
(registers-needed seq)
(registers-modified seq)
(append
(comment "tack-on-instruction seq start")
(statements seq)
(comment "tack-on-instruction seq end")
(comment "tack-on-instruction body-seq start")
(statements body-seq)
(comment "tack-on-instruction body-seq end"))))
(define (parallel-instruction-sequences seq1 seq2)
(make-instruction-sequence
(list-union (registers-needed seq1)
(registers-needed seq2))
(list-union (registers-modified seq1)
(registers-modified seq2))
(append
(comment "parallel-instruction-sequence seq1 start")
(statements seq1)
(comment "parallel-instruction-sequence seq1 end")
(comment "parallel-instruction-sequence seq2 start")
(statements seq2)
(comment "parallel-instruction-sequence seq2 end"))))
例としてcompile-and-go手続きを使うと、レジスタマシン用のアセンブリ言語に翻訳して実行します。
(compile-and-go
'(begin
(define nil '())
(define (rev lis)
(define (iter l r)
(if (null? l)
r
(iter (cdr l) (cons (car l) r))))
(iter lis nil))
(rev '(a b c d e f))
))
例として、リストを反転するサンプルプログラムを翻訳・実行してみます。
comp-eval-sample.scm として保存し、reg-driver.scm をScheme処理系にロードした後、さらにサンプルプログラムをロードします。(Emacs ではプログラムを表示しているバッファで C-c C-l するとロードできます。)
gosh> (load "./reg-driver.scm")
gosh> (load "./comp-eval-sample.scm")
; (total-pushes = 50 maximum-depth = 5)
;;; EC-Eval value:
(f e d c b a)
debug.scm
デバッグ用の手続き群です。レジスタマシンでは「継続」を多用しているのでデバッグはとても大変です。
(define debugging true)
(define (debug-on) (set! debugging true) true)
(define (debug-off) (set! debugging false) false)
(define (debug-print . msg)
(define (debug-print-iter m)
(cond ((null? m) (newline))
(else
(user-print (car m))
(display " ")
(debug-print-iter (cdr m)))))
(if debugging
(begin
(display ";*** DEBUG *** ")
(debug-print-iter msg))))
eceval.scm
レジスタマシン用アセンブリ言語で記述したインタプリタ(REPL)です。
(load "./common.scm")
(load "./debug.scm")
(define eceval-operations
(list
(list 'self-evaluating? self-evaluating?)
(list 'variable? variable?)
(list 'quoted? quoted?)
(list 'assignment? assignment?)
(list 'definition? definition?)
(list 'if? if?)
(list 'cond? cond?)
(list 'lambda? lambda?)
(list 'let? let?)
(list 'begin? begin?)
(list 'compile-and-run? compile-and-run?)
(list 'application? application?)
(list 'lookup-variable-value lookup-variable-value)
(list 'lexical-address-lookup lexical-address-lookup)
(list 'text-of-quotation text-of-quotation)
(list 'lambda-parameters lambda-parameters)
(list 'lambda-body lambda-body)
(list 'let-parameters let-parameters)
(list 'let-body let-body)
(list 'let->combination let->combination)
(list 'make-procedure make-procedure)
(list 'make-compiled-procedure make-compiled-procedure)
(list 'operands operands)
(list 'operator operator)
(list 'no-operands? no-operands?)
(list 'first-operand first-operand)
(list 'rest-operands rest-operands)
(list 'primitive-procedure? primitive-procedure?)
(list 'compound-procedure? compound-procedure?)
(list 'compiled-procedure? compiled-procedure?)
(list 'apply-primitive-procedure apply-primitive-procedure)
(list 'procedure-parameters procedure-parameters)
(list 'procedure-environment procedure-environment)
(list 'extend-environment extend-environment)
(list 'procedure-body procedure-body)
(list 'compiled-procedure-env compiled-procedure-env)
(list 'compiled-procedure-entry compiled-procedure-entry)
(list 'begin-actions begin-actions)
(list 'first-exp first-exp)
(list 'last-exp? last-exp?)
(list 'rest-exps rest-exps)
(list 'true? true?)
(list 'false? false?)
(list 'null? null?)
(list 'symbol? symbol?)
(list 'if-predicate if-predicate)
(list 'if-consequent if-consequent)
(list 'if-alternative if-alternative)
(list 'cond->if cond->if)
(list 'cond-clauses cond-clauses)
(list 'cond-else-clause? cond-else-clause?)
(list 'cond-predicate cond-predicate)
(list 'cond-actions cond-actions)
(list 'assignment-variable assignment-variable)
(list 'assignment-value assignment-value)
(list 'set-variable-value! set-variable-value!)
(list 'lexical-address-set! lexical-address-set!)
(list 'definition-variable definition-variable)
(list 'definition-value definition-value)
(list 'define-variable! define-variable!)
(list 'prompt-for-input prompt-for-input)
(list 'get-global-environment get-global-environment)
(list 'announce-output announce-output)
(list 'user-print user-print)
(list 'empty-arglist empty-arglist)
(list 'adjoin-arg adjoin-arg)
(list 'last-operand? last-operand?)
(list 'quotient quotient)
(list 'operator? operator?)
(list 'car car)
(list 'cdr cdr)
(list 'cons cons)
(list 'list list)
(list 'read read)
(list 'display display)
(list 'newline newline)
(list 'exit exit)
(list 'apply-in-underlying-scheme apply-in-underlying-scheme)
(list 'debug-print debug-print)
(list 'nop nop)
(list 'add add)
(list 'sub sub)
(list 'mul mul)
(list 'div div)
))
(define eceval
(make-machine
eceval-operations
'(
(assign compapp (label compound-apply))
(branch (label external-entry))
read-eval-print-loop
(perform (op initialize-stack))
(perform (op prompt-for-input) (const ";;; EC-Eval input:"))
(assign exp (op read))
(assign env (op get-global-environment))
(assign continue (label print-result))
(goto (label eval-dispatch))
print-result
;; (perform (op print-instruction-counting))
(perform (op print-stack-statistics))
(perform (op announce-output) (const ";;; EC-Eval value:"))
(perform (op user-print) (reg val))
(goto (label read-eval-print-loop))
external-entry
(perform (op initialize-stack))
(assign env (op get-global-environment))
(assign continue (label print-result))
(goto (reg val))
eval-dispatch
(test (op self-evaluating?) (reg exp))
(branch (label ev-self-eval))
(test (op variable?) (reg exp))
(branch (label ev-variable))
(test (op quoted?) (reg exp))
(branch (label ev-quoted))
(test (op assignment?) (reg exp))
(branch (label ev-assignment))
(test (op definition?) (reg exp))
(branch (label ev-definition))
(test (op if?) (reg exp))
(branch (label ev-if))
(test (op cond?) (reg exp))
(branch (label ev-cond))
(test (op lambda?) (reg exp))
(branch (label ev-lambda))
(test (op let?) (reg exp))
(branch (label ev-let))
(test (op begin?) (reg exp))
(branch (label ev-begin))
(test (op compile-and-run?) (reg exp))
(branch (label ev-compile-and-run))
(test (op application?) (reg exp))
(branch (label ev-application))
(goto (label unknown-expression-type))
ev-self-eval
(assign val (reg exp))
(goto (reg continue))
ev-variable
(assign val (op lookup-variable-value) (reg exp) (reg env))
(goto (reg continue))
ev-quoted
(assign val (op text-of-quotation) (reg exp))
(goto (reg continue))
ev-assignment
(assign unev (op assignment-variable) (reg exp))
(save unev)
(assign exp (op assignment-value) (reg exp))
(save env)
(save continue)
(assign continue (label ev-assignment-1))
(goto (label eval-dispatch))
ev-assignment-1
(restore continue)
(restore env)
(restore unev)
(perform (op set-variable-value!) (reg unev) (reg val) (reg env))
(assign val (const ok))
(goto (reg continue))
ev-definition
(assign unev (op definition-variable) (reg exp))
(save unev)
(assign exp (op definition-value) (reg exp))
(save env)
(save continue)
(assign continue (label ev-definition-1))
(goto (label eval-dispatch))
ev-definition-1
(restore continue)
(restore env)
(restore unev)
(perform (op define-variable!) (reg unev) (reg val) (reg env))
(assign val (const ok))
(goto (reg continue))
ev-if
(save exp)
(save env)
(save continue)
(assign continue (label ev-if-decide))
(assign exp (op if-predicate) (reg exp))
(goto (label eval-dispatch))
ev-if-decide
(restore continue)
(restore env)
(restore exp)
(test (op true?) (reg val))
(branch (label ev-if-consequent))
ev-if-alternative
(assign exp (op if-alternative) (reg exp))
(goto (label eval-dispatch))
ev-if-consequent
(assign exp (op if-consequent) (reg exp))
(goto (label eval-dispatch))
ev-cond
(assign exp (op cond->if) (reg exp))
(goto (label ev-if))
ev-cond-new
(assign exp (op cond-clauses) (reg exp))
ev-cond-clauses
(test (op null?) (reg exp))
(branch (label ev-cond-null))
(goto (label ev-cond-not-null))
ev-cond-null
(assign val (const #f))
(goto (reg continue))
ev-cond-not-null
(assign unev (op car) (reg exp))
(test (op cond-else-clause?) (reg unev))
(branch (label ev-cond-eval-actions))
(save exp)
(save unev)
(save continue)
(assign continue (label ev-cond-1))
(assign exp (op cond-predicate) (reg unev))
(goto (label eval-dispatch))
ev-cond-1
(restore continue)
(restore unev)
(restore exp)
(test (op true?) (reg val))
(branch (label ev-cond-eval-actions))
(assign exp (op cdr) (reg exp))
(goto (label ev-cond-clauses))
ev-cond-eval-actions
(assign unev (op cond-actions) (reg unev))
(save continue)
(goto (label ev-sequence))
ev-lambda
(assign unev (op lambda-parameters) (reg exp))
(assign exp (op lambda-body) (reg exp))
(assign val (op make-procedure) (reg unev) (reg exp) (reg env))
(goto (reg continue))
ev-let
(assign unev (op let-parameters) (reg exp))
(assign exp (op let-body) (reg exp))
(assign val (op let->combination) (reg unev) (reg exp) (reg env))
(goto (reg continue))
ev-begin
(assign unev (op begin-actions) (reg exp))
(save continue)
(goto (label ev-sequence))
ev-compile-and-run
(assign exp (op operands) (reg exp))
(assign exp (op first-operand) (reg exp))
(assign exp (op text-of-quotation) (reg exp))
(goto (label eval-dispatch))
ev-application
(save continue)
(assign unev (op operands) (reg exp))
(assign exp (op operator) (reg exp))
(test (op operator?) (reg exp))
(branch (label ev-application-1))
(goto (label ev-application-2))
ev-application-1
(assign continue (label ev-appl-did-operator-2))
(goto (label eval-dispatch))
ev-application-2
(save env)
(save unev)
(assign continue (label ev-appl-did-operator))
(goto (label eval-dispatch))
ev-appl-did-operator
(restore unev)
(restore env)
ev-appl-did-operator-2
(assign argl (op empty-arglist))
(assign proc (reg val))
(test (op no-operands?) (reg unev))
(branch (label apply-dispatch))
(save proc)
ev-appl-operand-loop
(save argl)
(assign exp (op first-operand) (reg unev))
(test (op last-operand?) (reg unev))
(branch (label ev-appl-last-arg))
(save env)
(save unev)
(assign continue (label ev-appl-accumulate-arg))
(goto (label eval-dispatch))
ev-appl-accumulate-arg
(restore unev)
(restore env)
(restore argl)
(assign argl (op adjoin-arg) (reg val) (reg argl))
(assign unev (op rest-operands) (reg unev))
(goto (label ev-appl-operand-loop))
ev-appl-last-arg
(assign continue (label ev-appl-accum-last-arg))
(goto (label eval-dispatch))
ev-appl-accum-last-arg
(restore argl)
(assign argl (op adjoin-arg) (reg val) (reg argl))
(restore proc)
(goto (label apply-dispatch))
apply-dispatch
(test (op primitive-procedure?) (reg proc))
(branch (label primitive-apply))
(test (op compound-procedure?) (reg proc))
(branch (label compound-apply))
(test (op compiled-procedure?) (reg proc))
(branch (label compiled-apply))
(goto (label unknown-procedure-type))
primitive-apply
(assign val (op apply-primitive-procedure)
(reg proc)
(reg argl))
(restore continue)
(goto (reg continue))
compound-apply
(assign unev (op procedure-parameters) (reg proc))
(assign env (op procedure-environment) (reg proc))
(assign env (op extend-environment)
(reg unev) (reg argl) (reg env))
(assign unev (op procedure-body) (reg proc))
(goto (label ev-sequence))
compiled-apply
(restore continue)
(assign val (op compiled-procedure-entry) (reg proc))
(goto (reg val))
ev-sequence
(assign exp (op first-exp) (reg unev))
(test (op last-exp?) (reg unev))
(branch (label ev-sequence-last-exp))
(save unev)
(save env)
(assign continue (label ev-sequence-continue))
(goto (label eval-dispatch))
ev-sequence-continue
(restore env)
(restore unev)
(assign unev (op rest-exps) (reg unev))
(goto (label ev-sequence))
ev-sequence-last-exp
(restore continue)
(goto (label eval-dispatch))
unknown-expression-type
(assign val (const unknown-expression-type-error))
(goto (label signal-error))
unknown-procedure-type
(restore continue)
(assign val (const unknown-procedure-type-error))
(goto (label signal-error))
signal-error
(perform (op user-print) (reg val))
(goto (label read-eval-print-loop))
)))
(define (start-eceval)
(set! the-global-environment (setup-environment))
(set-register-contents! eceval 'flag false)
(start eceval))
eval.scm
Scheme 言語で記述したインタプリタ(REPL)です.
(load "./common.scm")
(load "./debug.scm")
(define (apply proc args)
; dummy
)
(define apply-in-underlying-scheme (with-module scheme apply))
(define (eval exp env)
(cond ((self-evaluating? exp) exp)
((variable? exp) (lookup-variable-value exp env))
((quoted? exp) (text-of-quotation exp))
((assignment? exp) (eval-assignment exp env))
((definition? exp) (eval-definition exp env))
((if? exp) (eval-if exp env))
((lambda? exp)
(make-procedure (lambda-parameters exp)
(lambda-body exp)
env))
((let? exp)
(let->combination (let-parameters exp)
(let-body exp)
env))
((begin? exp)
(eval-sequence (begin-actions exp) env))
((cond? exp) (eval (cond->if exp) env))
((application? exp)
(apply (eval (operator exp) env)
(list-of-values (operands exp) env)))
(else
(error "unknown expression type -- EVAL" exp))))
(define (apply procedure arguments)
(cond ((primitive-procedure? procedure)
(apply-primitive-procedure procedure arguments))
((compound-procedure? procedure)
(eval-sequence
(scan-out-defines (procedure-body procedure))
(extend-environment
(procedure-parameters procedure)
arguments
(procedure-environment procedure))))
(else
(error "unknown prodecure type -- APPLY"))))
(define (list-of-values exps env)
(if (no-operands? exps)
'()
(let ((e (eval (first-operand exps) env)))
(cons e
(list-of-values (rest-operands exps) env)))))
(define (eval-if exp env)
(if (true? (eval (if-predicate exp) env))
(eval (if-consequent exp) env)
(eval (if-alternative exp) env)))
(define (eval-sequence exps env)
(cond ((last-exp? exps) (eval (first-exp exps) env))
(else (eval (first-exp exps) env)
(eval-sequence (rest-exps exps) env))))
(define (eval-assignment exp env)
(set-variable-value! (assignment-variable exp)
(eval (assignment-value exp) env)
env)
'ok)
(define (eval-definition exp env)
(define-variable! (definition-variable exp)
(eval (definition-value exp) env)
env)
'ok)
(define (self-evaluating? exp)
(cond ((number? exp) true)
((string? exp) true)
(else false)))
(define (variable? exp) (symbol? exp))
(define (quoted? exp)
(tagged-list? exp 'quote))
(define (text-of-quotation exp) (cadr exp))
(define (tagged-list? exp tag)
(if (pair? exp)
(eq? (car exp) tag)
false))
(define (make-assignment variable value)
(list 'set! variable value))
(define (assignment? exp)
(tagged-list? exp 'set!))
(define (assignment-variable exp) (cadr exp))
(define (assignment-value exp) (caddr exp))
(define (definition? exp)
(tagged-list? exp 'define))
(define (definition-variable exp)
(if (symbol? (cadr exp))
(cadr exp)
(caadr exp)))
(define (definition-value exp)
(if (symbol? (cadr exp))
(caddr exp)
(make-lambda (cdadr exp) ; formal parameters
(cddr exp)))) ; body
(define (lambda? exp) (tagged-list? exp 'lambda))
(define (lambda-parameters exp) (cadr exp))
(define (lambda-body exp) (cddr exp))
(define (make-lambda parameters body)
(cons 'lambda (cons parameters body)))
(define (make-let parameters body)
(list 'let parameters body))
(define (let? exp) (tagged-list? exp 'let))
(define (let-parameters exp) (cadr exp))
(define (let-body exp) (cddr exp))
(define (let-parameter-variables exp) (map car exp))
(define (let-parameter-exps exp) (map cadr exp))
(define (let->combination parameters body env)
(apply (make-procedure
(let-parameter-variables parameters) body env)
(list-of-values (let-parameter-exps parameters) env)))
(define (if? exp) (tagged-list? exp 'if))
(define (if-predicate exp) (cadr exp))
(define (if-consequent exp) (caddr exp))
(define (if-alternative exp)
(if (not (null? (cdddr exp)))
(cadddr exp)
'false))
(define (make-if predicate consequent alternative)
(list 'if predicate consequent alternative))
(define (begin? exp) (tagged-list? exp 'begin))
(define (begin-actions exp) (cdr exp))
(define (last-exp? seq) (null? (cdr seq)))
(define (first-exp seq) (car seq))
(define (rest-exps seq) (cdr seq))
(define (sequence->exp seq)
(cond ((null? seq) seq)
((last-exp? seq) (first-exp seq))
(else (make-begin seq))))
(define (make-begin seq) (cons 'begin seq))
(define (compile-and-run? exp) (tagged-list? exp 'compile-and-run))
(define (application? exp) (pair? exp))
(define (open-code? exp)
(if (application? exp)
(not (false? (memq (car exp) '(add sub mul div))))
false))
(define (operator? exp) (not (false? (memq exp '(+ - * /)))))
(define (operator exp) (car exp))
(define (operands exp) (cdr exp))
(define (no-operands? ops) (null? ops))
(define (first-operand ops) (car ops))
(define (rest-operands ops) (cdr ops))
(define (last-operand? ops) (null? (cdr ops)))
(define (empty-arglist) '())
(define (adjoin-arg arg arglist)
(append arglist (list arg)))
(define (cond? exp) (tagged-list? exp 'cond))
(define (cond-clauses exp) (cdr exp))
(define (cond-else-clause? clause)
(eq? (cond-predicate clause) 'else))
(define (cond-predicate clause) (car clause))
(define (cond-actions clause) (cdr clause))
(define (cond->if exp)
(expand-clauses (cond-clauses exp)))
(define (expand-clauses clauses)
(if (null? clauses)
'false ; no else clause
(let ((first (car clauses))
(rest (cdr clauses)))
(if (cond-else-clause? first)
(if (null? rest)
(sequence->exp (cond-actions first))
(error "else clause is not last --EXPAND-CLAUSES" clauses))
(make-if (cond-predicate first)
(sequence->exp (cond-actions first))
(expand-clauses rest))))))
(define (make-procedure parameters body env)
(list 'procedure parameters body env))
(define (compound-procedure? p)
(tagged-list? p 'procedure))
(define (procedure-parameters p) (cadr p))
(define (procedure-body p) (caddr p))
(define (procedure-environment p) (cadddr p))
(define (enclosing-environment env) (cdr env))
(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 (extend-environment vars vals base-env)
(if (= (length vars) (length vals))
(cons (make-frame vars vals) base-env)
(if (< (length vars) (length vals))
(error "too many arguments supplied -- EXPAND-ENVIRONMENT")
(error "few arguments supplied -- EXPAND-ENVIRONMENT"))))
(define (lookup-variable-value var env)
(define (env-loop env)
(define (scan vars vals)
(cond ((null? vars)
(env-loop (enclosing-environment env)))
((eq? var (car vars))
(car vals))
(else (scan (cdr vars) (cdr vals)))))
(if (eq? env the-empty-environment)
(if (unassigned? var)
var
(error "unbound variable -- LOOKUP-VARIABLE-VALUE" var))
(let ((frame (first-frame env)))
(scan (frame-variables frame)
(frame-values frame)))))
(env-loop env))
(define (set-variable-value! var val env)
(define (env-loop env)
(define (scan vars vals)
(cond ((null? vars)
(env-loop (enclosing-environment env)))
((eq? var (car vars))
(set-car! vals val))
(else (scan (cdr vars) (cdr vals)))))
(if (eq? env the-empty-environment)
(error "unbound variable -- SET-VARIABLE-VALUE!" var)
(let ((frame (first-frame env)))
(scan (frame-variables frame)
(frame-values frame)))))
(env-loop env))
(define (unassigned? exp) (eq? exp '*unassigned*))
(define (frame-number laddr) (car laddr))
(define (displacement-number laddr) (cadr laddr))
(define (get-lexical-frame laddr env)
(define (iter fn e)
(if (= fn 0)
(first-frame e)
(iter (- fn 1) (cdr e))))
(iter (frame-number laddr) (reverse (cdr (reverse env)))))
(define (lexical-variable-value laddr env)
(define (iter d vals)
(if (= d 0)
vals
(iter (- d 1) (cdr vals))))
(let ((frame (get-lexical-frame laddr env)))
(iter (displacement-number laddr)
(frame-values frame))))
(define (lexical-address-lookup laddr env)
(let ((val (car (lexical-variable-value laddr env))))
(if (unassigned? val)
(error "unassigned variable -- LEXICAL-ADDRESS-LOOKUP" laddr)
val)))
(define (lexical-address-set! laddr val env)
(set-car! (lexical-variable-value laddr env) val)
'ok)
(define (not-found? x) (eq? x 'not-found))
(define (find-variable variable ctenv)
(define (scan-frame var dn frm)
(if (null? frm)
'not-found
(if (eq? var (car frm))
dn
(scan-frame var (+ dn 1) (cdr frm)))))
(define (scan-ctenv fn env)
(if (null? env)
'not-found
(let ((dn (scan-frame variable 0 (car env))))
(if (not-found? dn)
(scan-ctenv (+ fn 1) (cdr env))
(list fn dn)))))
(scan-ctenv 0 ctenv))
(define (define-variable! var val env)
(let ((frame (first-frame env)))
(define (scan vars vals)
(cond ((null? vars)
(add-binding-to-frame! var val frame))
((eq? var (car vars))
(set-car! vals val))
(else (scan (cdr vars) (cdr vals)))))
(scan (frame-variables frame)
(frame-values frame))))
(define (scan-out-defines exps)
(define (first-exp exp) (car exp))
(define (rest-exps exp) (cdr exp))
(define (scan-out-defines-iter exp params body)
(if (or (null? exp) (not (definition? (first-exp exp))))
(list (make-let params (append body exp)))
(scan-out-defines-iter
(rest-exps exp)
(append params (list (list (definition-variable
(first-exp exp))
'*unassigned*)))
(append body
(list (make-assignment
(definition-variable (first-exp exp))
(definition-value (first-exp exp))))))
))
(if (definition? (first-exp exps))
(scan-out-defines-iter exps '() (list 'begin))
exps))
(define (setup-environment)
(let ((initial-env
(extend-environment (primitive-procedure-names)
(primitive-procedure-objects)
the-empty-environment)))
(define-variable! 'true true initial-env)
(define-variable! 'false false initial-env)
initial-env))
(define (primitive-procedure? proc)
(tagged-list? proc 'primitive))
(define (primitive-implementation proc) (cadr proc))
(define primitive-procedures
(list (list '+ +)
(list '- -)
(list '* *)
(list '/ /)
(list 'quotient quotient)
(list '= =)
(list '> >)
(list '< <)
(list '<= <=)
(list '>= >=)
(list 'not not)
(list 'and and)
(list 'or or)
(list 'car car)
(list 'cdr cdr)
(list 'cadr cadr)
(list 'cddr cddr)
(list 'caadr caadr)
(list 'caddr caddr)
(list 'cdadr cdadr)
(list 'cdddr cdddr)
(list 'cadddr cadddr)
(list 'set-car! set-car!)
(list 'set-cdr! set-cdr!)
(list 'list list)
(list 'length length)
(list 'string-length string-length)
(list 'cons cons)
(list 'symbol->string symbol->string)
(list 'symbol? symbol?)
(list 'number? number?)
(list 'string? string?)
(list 'pair? pair?)
(list 'eq? eq?)
(list 'null? null?)
(list 'odd? odd?)
(list 'even? even?)
(list 'compiled-procedure? compiled-procedure?)
(list 'exit exit)
(list 'display display)
(list 'newline newline)
(list 'read read)
(list 'true? true?)
(list 'false? false?)
(list 'lapply apply)
))
(define (primitive-procedure-names)
(map car
primitive-procedures))
(define (primitive-procedure-objects)
(map (lambda (proc) (list 'primitive (cadr proc)))
primitive-procedures))
(define (apply-primitive-procedure proc args)
(apply-in-underlying-scheme (primitive-implementation proc) args))
(define input-prompt ";;; M-Eval input:")
(define output-prompt ";;; M-Eval value:")
(define (driver-loop)
(prompt-for-input input-prompt)
(let ((input (read)))
(let ((output (eval input the-global-environment)))
(announce-output output-prompt)
(user-print output)))
(driver-loop))
(define (prompt-for-input string)
(newline) (newline) (display string) (newline))
(define (announce-output string)
(newline) (display string) (newline))
(define (user-print object)
(define (user-print-iter obj)
(cond ((compound-procedure? obj)
(list 'compound-procedure
(procedure-parameters obj)
(procedure-body obj)
'<procedure-env>))
((compiled-procedure? obj)
(list '<compiled-procedure>))
((pair? obj)
(cons
(user-print-iter (car obj))
(user-print-iter (cdr obj))))
(else obj)))
(display (user-print-iter object)))
(define (nop) 'nop)
(define the-global-environment (setup-environment))
(define (get-global-environment) the-global-environment)
open-code.scm
基本機械手続き群です。翻訳のときに Scheme のプリミティブ手続きを使うことで生成コード量を減らすのが目的です。
(define (add args) (apply-in-underlying-scheme + args))
(define (sub args) (apply-in-underlying-scheme - args))
(define (mul args) (apply-in-underlying-scheme * args))
(define (div args) (apply-in-underlying-scheme / args))
reg-driver.scm
Scheme のプログラムを翻訳してレジスタマシン上で実行し、結果を返すインタプリタ(REPL)です。
(load "./comp.scm")
(load "./eval.scm")
(load "./regmcn.scm")
(load "./open-code.scm")
(load "./eceval.scm")
(define rm-input-prompt ";;; RM-Eval input:")
(define rm-output-prompt ";;; RM-Eval value:")
(define rm-machine
(make-machine
eceval-operations
'(
(assign env (op get-global-environment))
(perform (op initialize-stack))
(assign continue (label rm-done))
(goto (reg val))
rm-done
(perform (op print-stack-statistics))
)))
(define (rm-driver-loop)
(prompt-for-input rm-input-prompt)
(let ((input (read)))
(let ((inst (assemble
(statements (compile input 'val 'return nil))
rm-machine)))
(set-register-contents! rm-machine 'val inst)
(start rm-machine)
(announce-output rm-output-prompt)
(user-print (get-register-contents rm-machine 'val))))
(rm-driver-loop))
regmcn.scm
レジスタマシンの実装です。
(load "./common.scm")
(load "./debug.scm")
(define (make-machine ops controller-text)
(let ((machine (make-new-machine)))
(machine 'initialize-registers)
((machine 'install-operations) ops)
((machine 'install-instruction-sequence)
(assemble controller-text machine))
machine))
(define (make-register name)
(let ((reg-name name)
(contents '*unassigned*)
(tracing false))
(define (display-tracing value)
(display "TRACE REGISTER name=")
(display reg-name)
(display " old-value=")
(display contents)
(display " new-value=")
(display value)
(newline))
(define (dispatch message)
(cond ((eq? message 'get) contents)
((eq? message 'set)
(lambda (value)
(if tracing (display-tracing value))
(set! contents value)))
((eq? message 'trace-on) (set! tracing true) 'trace-on)
((eq? message 'trace-off) (set! tracing false) 'trace-off)
(else
(error "Unknown request -- REGISTER" message))))
dispatch))
(define (get-contents register)
(register 'get))
(define (set-contents! register value)
((register 'set) value))
(define (make-stack)
(let ((s nil)
(number-pushes 0)
(max-depth 0)
(current-depth 0))
(define (push x)
(set! s (cons x s))
(set! number-pushes (+ number-pushes 1))
(set! current-depth (+ current-depth 1))
(set! max-depth (max current-depth max-depth)))
(define (pop)
(if (null? s)
(error "Empty stack -- POP")
(let ((top (car s)))
(set! s (cdr s))
(set! current-depth (- current-depth 1))
top)))
(define (initialize)
(set! s nil)
(set! number-pushes 0)
(set! current-depth 0)
(set! max-depth 0)
'done)
(define (print-statistics)
(newline)
(display "; ")
(display (list 'total-pushes '= number-pushes
'maximum-depth '= max-depth)))
(define (dispatch message)
(cond ((eq? message 'push) push)
((eq? message 'pop) (pop))
((eq? message 'initialize) (initialize))
((eq? message 'print-statistics) (print-statistics))
(else (error "Unknown request -- STACK" message))))
dispatch))
(define (push stack value)
((stack 'push) value))
(define (pop stack)
(stack 'pop))
(define (make-new-machine)
(let ((pc (make-register 'pc))
(flag (make-register 'flag))
(stack (make-stack))
(the-instruction-sequence nil)
(instructions (make-register 'instructions))
(entry-points (make-register 'entry-points))
(saved-regs (make-register 'saved-regs))
(restored-regs (make-register 'restored-regs))
(source-of-regs (make-register 'source-of-regs))
(instruction-counting (make-register 'instruction-counting))
(instruction-tracing false)
(lbl (make-register 'lbl))
(inst-or-label (make-register 'inst-or-label))
(breakpoints (make-register 'breakpoints))
(step (make-register 'step))
(proceed-flag (make-register 'proceed-flag))
(proceed-inst (make-register 'proceed-inst)))
(let ((the-ops
(list (list 'initialize-stack
(lambda () (stack 'initialize)))
(list 'print-instruction-counting
(lambda ()
(newline)
(display "; ")
(display (get-contents instruction-counting))))
(list 'print-stack-statistics
(lambda () (stack 'print-statistics)))))
(register-table
(list (list 'pc pc)
(list 'flag flag)
(list 'instructions instructions)
(list 'entry-points entry-points)
(list 'saved-regs saved-regs)
(list 'restored-regs restored-regs)
(list 'source-of-regs source-of-regs)
(list 'instruction-counting instruction-counting)
(list 'lbl lbl)
(list 'inst-or-label inst-or-label)
(list 'breakpoints breakpoints)
(list 'step step)
(list 'proceed-flag proceed-flag)
(list 'proceed-inst proceed-inst)
)))
(define (initialize-registers)
(set-contents! instructions nil)
(set-contents! entry-points nil)
(set-contents! saved-regs nil)
(set-contents! restored-regs nil)
(set-contents! source-of-regs nil)
(initialize-instruction-counting)
(initialize-breakpoints)
(set-contents! lbl nil)
(set-contents! inst-or-label nil)
(set-contents! step (cons nil 0))
(set-contents! proceed-flag false)
(set-contents! proceed-inst nil))
(define (initialize-instruction-counting)
(set-contents! instruction-counting nil))
(define (initialize-breakpoints)
(set-contents! breakpoints nil))
(define (allocate-register name)
(if (assoc name register-table)
(error "Multiply defined register: " name)
(set! register-table
(cons (list name (make-register name))
register-table)))
(lookup-register name))
(define (lookup-register name)
(let ((val (assoc name register-table)))
(if val
(cadr val)
(allocate-register name))))
(define (execute)
(let ((insts (get-contents pc)))
(if (null? insts)
(begin
(if (and instruction-tracing
(eq? (get-contents inst-or-label) 'label))
(begin
(display "TRACE:")
(display (car (reverse (get-contents lbl))))
(newline)))
'done)
(if (breakpoint?)
(begin
(set-contents! proceed-inst (car insts))
'broken)
(begin
((instruction-execution-proc (car insts)))
(execute))))))
(define (set-breakpoint label n)
(cond ((>= n 0)
(set-contents! breakpoints (cons
(cons label n)
(get-contents breakpoints)))
'done)
(else (error "offset is minus value -- SET-BREAKPOINT"))))
(define (proceed-machine)
((instruction-execution-proc (get-contents proceed-inst)))
(set-contents! proceed-inst nil)
(set-contents! proceed-flag true)
(execute))
(define (cancel-breakpoint label n)
(set-contents! breakpoints
(filter (lambda (bp)
(not (and (eq? label (car bp))
(eq? n (cdr bp)))))
(get-contents breakpoints)))
'done)
(define (cancel-all-breakpoints) (initialize-breakpoints) 'done)
(define (breakpoint?)
(if (get-contents proceed-flag)
(begin
(set-contents! proceed-flag false)
false)
(let ((s (get-contents step)))
(let ((bps (assoc (car s) (get-contents breakpoints))))
(if bps
(= (cdr s) (cdr bps))
false)))))
(define (dispatch message)
(cond ((eq? message 'start)
(set-contents! pc the-instruction-sequence)
(execute))
((eq? message 'install-instruction-sequence)
(lambda (seq) (set! the-instruction-sequence seq)))
((eq? message 'allocate-register) allocate-register)
((eq? message 'get-register) lookup-register)
((eq? message 'install-operations)
(lambda (ops) (set! the-ops (append the-ops ops))))
((eq? message 'stack) stack)
((eq? message 'operations) the-ops)
((eq? message 'initialize-registers) (initialize-registers))
((eq? message 'initialize-instruction-counting) (initialize-instruction-counting))
((eq? message 'instruction-counting) instruction-counting)
((eq? message 'instruction-tracing) instruction-tracing)
((eq? message 'trace-on) (set! instruction-tracing true) 'trace-on)
((eq? message 'trace-off) (set! instruction-tracing false) 'trace-off)
((eq? message 'set-breakpoint) set-breakpoint)
((eq? message 'proceed-machine) (proceed-machine))
((eq? message 'cancel-breakpoint) cancel-breakpoint)
((eq? message 'cancel-all-breakpoints) (cancel-all-breakpoints))
(else (error "Unknown request -- MACHINE" message))))
dispatch)))
(define (start machine)
(machine 'start))
(define (trace-on machine)
(machine 'trace-on))
(define (trace-off machine)
(machine 'trace-off))
(define (get-register-contents machine register-name)
(get-contents (get-register machine register-name)))
(define (set-register-contents! machine register-name value)
(set-contents! (get-register machine register-name) value)
'done)
(define (adjoin-register-contents! machine register-name value)
(define (adjoin-set element set)
(define (last s) (list-ref s (- (length s) 1)))
(define (iter x s ns)
(cond ((null? s)
(if (null? ns)
(cons x nil)
ns))
((string>? x (last s)) (append s (cons x nil)))
((string>? x (car s))
(iter x (cdr s) (append ns (cons (car s) nil))))
((string=? x (car s))
(iter x (cdr s) ns))
(else (iter x nil (append ns (cons x s))))))
(map string->symbol
(iter (symbol->string element) (map symbol->string set) nil)))
(set-register-contents!
machine
register-name
(adjoin-set value (get-register-contents machine register-name))))
(define (get-register machine reg-name)
((machine 'get-register) reg-name))
(define (trace-register-on machine reg-name)
((get-register machine reg-name) 'trace-on))
(define (trace-register-off machine reg-name)
((get-register machine reg-name) 'trace-off))
(define (set-breakpoint machine label n)
((machine 'set-breakpoint) label n))
(define (proceed-machine machine)
(machine 'proceed-machine))
(define (cancel-breakpoint machine label n)
((machine 'cancel-breakpoint) label n))
(define (cancel-all-breakpoints machine)
(machine 'cancel-all-breakpoints))
(define (assemble controller-text machine)
(extract-labels
machine
controller-text
(lambda (insts labels lbl)
(set-register-contents! machine 'lbl lbl)
(update-insts! insts labels machine)
insts)))
(define (extract-labels machine text receive)
(if (null? text)
(receive nil nil nil)
(extract-labels
machine
(cdr text)
(lambda (insts labels lbl)
(let ((next-inst (car text)))
(if (symbol? next-inst)
(if (assoc next-inst labels)
(error "Multiply defined label: " next-inst)
(begin
(if (null? (get-register-contents machine 'inst-or-label))
(set-register-contents! machine 'inst-or-label 'label))
(receive insts
(cons (make-label-entry next-inst
insts)
labels)
(if (null? lbl)
(cons next-inst lbl)
(cons next-inst (cdr lbl))))))
(begin
(if (null? (get-register-contents machine 'inst-or-label))
(set-register-contents! machine 'inst-or-label 'inst))
(receive (cons (make-instruction next-inst)
insts)
labels
(cons nil lbl)))))))))
(define (update-insts! insts labels machine)
(let ((pc (get-register machine 'pc))
(flag (get-register machine 'flag))
(stack (machine 'stack))
(ops (machine 'operations)))
(for-each
(lambda (inst)
(set-instruction-execution-proc!
inst
(make-execution-procedure
(instruction-text inst) labels machine pc flag stack ops)))
insts)))
(define (make-instruction text)
(cons text nil))
(define (instruction-text inst)
(car inst))
(define (instruction-execution-proc inst)
(cdr inst))
(define (set-instruction-execution-proc! inst proc)
(set-cdr! inst proc))
(define (make-label-entry label-name insts)
(cons label-name insts))
(define (lookup-label labels label-name)
(let ((val (assoc label-name labels)))
(if val
(cdr val)
(error "Undefined label -- ASSEMBLE" label-name))))
(define (make-execution-procedure inst labels machine pc flag stack ops)
(adjoin-register-contents! machine 'instructions (car inst))
(cond ((eq? (car inst) 'assign)
(make-assign inst machine labels ops pc))
((eq? (car inst) 'test)
(make-test inst machine labels ops flag pc))
((eq? (car inst) 'branch)
(make-branch inst machine labels flag pc))
((eq? (car inst) 'goto)
(make-goto inst machine labels pc))
((eq? (car inst) 'save)
(make-save inst machine stack pc))
((eq? (car inst) 'restore)
(make-restore inst machine stack pc))
((eq? (car inst) 'perform)
(make-perform inst machine labels ops pc))
((eq? (car inst) 'halt)
(make-halt inst machine pc))
(else
(error "Unknown instruction type -- ASSEMBLE" inst))))
(define (advance-pc machine pc)
(set-contents! pc (cdr (get-contents pc)))
(next-step (get-register machine 'step)
pc
(get-register machine 'lbl)
(get-register machine 'inst-or-label)))
(define (next-step step pc lbl inst-or-label)
(let ((s (get-contents step))
(label (lookup-lbl pc lbl inst-or-label)))
(if (not (null? label))
(set-contents! step (cons label 0))
(set-contents! step (cons (car s) (+ 1 (cdr s)))))))
(define (lookup-lbl pc lbl inst-or-label)
(let ((p (get-contents pc))
(l (get-contents lbl))
(i-or-l (get-contents inst-or-label)))
(if (null? p)
nil
(let ((idx
(if (eq? i-or-l 'inst)
(- (length l) (length p))
(- (- (length l) 1) (length p)))))
(if (>= idx 0)
(list-ref l idx)
nil)))))
(define (count-instruction machine inst pc)
(if (machine 'instruction-tracing)
(let ((lbl-name (lookup-lbl pc
(get-register machine 'lbl)
(get-register machine 'inst-or-label))))
(if (not (null? lbl-name))
(begin
(display "TRACE:")
(display lbl-name)
(newline)))
(display "TRACE: ")
(display inst)
(newline))
(count-register-contents machine 'instruction-counting (car inst))))
(define (count-register-contents machine reg-name var)
(let ((a (assoc var (get-register-contents machine reg-name))))
(if a
(set-cdr! a (+ 1 (cdr a)))
(set-register-contents! machine reg-name
(cons (cons var 1)
(get-register-contents machine reg-name))))))
(define (add-register-contents machine reg-name var val)
(let ((s (assoc var (get-register-contents machine reg-name))))
(if s
(set-cdr! s (list val (cdr s)))
(set-register-contents! machine reg-name
(cons (cons var val)
(get-register-contents machine reg-name))))))
;;
(define (make-assign inst machine labels operations pc)
(let ((reg-name (assign-reg-name inst)))
(let ((target (get-register machine reg-name))
(value-exp (assign-value-exp inst)))
(add-register-contents machine 'source-of-regs reg-name value-exp)
(let ((value-proc
(if (operation-exp? value-exp)
(make-operation-exp value-exp machine labels operations)
(make-primitive-exp (car value-exp) machine labels))))
(lambda ()
(count-instruction machine inst pc)
(set-contents! target (value-proc))
(advance-pc machine pc))))))
(define (assign-reg-name assign-instruction)
(cadr assign-instruction))
(define (assign-value-exp assign-instruction)
(cddr assign-instruction))
(define (make-test inst machine labels operations flag pc)
(let ((condition (test-condition inst)))
(if (operation-exp? condition)
(let ((condition-proc
(make-operation-exp condition machine labels operations)))
(lambda ()
(count-instruction machine inst pc)
(set-contents! flag (condition-proc))
(advance-pc machine pc)))
(error "Bad TEST instruction -- ASSEMBLE" inst))))
(define (test-condition test-instruction)
(cdr test-instruction))
(define (make-branch inst machine labels flag pc)
(let ((dest (branch-dest inst)))
(if (label-exp? dest)
(let ((insts (lookup-label labels (label-exp-label dest))))
(lambda ()
(count-instruction machine inst pc)
(if (get-contents flag)
(begin
(set-contents! pc insts)
(set-register-contents! machine 'step (cons (label-exp-label dest) 0)))
(advance-pc machine pc))))
(error "Bad BRANCH instruction -- ASSEMBLE" inst))))
(define (branch-dest branch-instruction)
(cadr branch-instruction))
(define (make-goto inst machine labels pc)
(let ((dest (goto-dest inst)))
(cond ((label-exp? dest)
(let ((insts (lookup-label labels (label-exp-label dest))))
(lambda ()
(count-instruction machine inst pc)
(set-contents! pc insts)
(set-register-contents! machine 'step (cons (label-exp-label dest) 0)))))
((register-exp? dest)
(let ((reg-name (register-exp-reg dest)))
(adjoin-register-contents! machine 'entry-points reg-name)
(let ((reg (get-register machine reg-name)))
(lambda ()
(count-instruction machine inst pc)
(set-contents! pc (get-contents reg))
(set-register-contents! machine 'step (cons reg-name 0))))))
(else (error "Bad GOTO instruction -- ASSEMBLE" inst)))))
(define (goto-dest goto-instruction)
(cadr goto-instruction))
(define (make-save inst machine stack pc)
(let ((reg-name (stack-inst-reg-name inst)))
(adjoin-register-contents! machine 'saved-regs reg-name)
(let ((reg (get-register machine reg-name)))
(lambda ()
(count-instruction machine inst pc)
(push stack (get-contents reg))
(advance-pc machine pc)))))
(define (make-restore inst machine stack pc)
(let ((reg-name (stack-inst-reg-name inst)))
(adjoin-register-contents! machine 'restored-regs reg-name)
(let ((reg (get-register machine reg-name)))
(lambda ()
(count-instruction machine inst pc)
(set-contents! reg (pop stack))
(advance-pc machine pc)))))
(define (stack-inst-reg-name stack-instruction)
(cadr stack-instruction))
(define (make-perform inst machine labels operations pc)
(let ((action (perform-action inst)))
(if (operation-exp? action)
(let ((action-proc
(make-operation-exp action machine labels operations)))
(lambda ()
(count-instruction machine inst pc)
(action-proc)
(advance-pc machine pc)))
(error "Bad PERFORM instruction -- ASSEMBLE" inst))))
(define (perform-action inst) (cdr inst))
(define (make-halt inst machine pc)
(lambda ()
(count-instruction machine inst pc)
(set-contents! pc nil)))
(define (make-primitive-exp exp machine labels)
(cond ((constant-exp? exp)
(let ((c (constant-exp-value exp)))
(lambda () c)))
((label-exp? exp)
(let ((insts (lookup-label labels (label-exp-label exp))))
(lambda () insts)))
((register-exp? exp)
(let ((r (get-register machine (register-exp-reg exp))))
(lambda () (get-contents r))))
(else
(error "Unknown expression type -- ASSEMBLE" exp))))
(define (tagged-list? proc tag)
(if (pair? proc)
(eq? (car proc) tag)
false))
(define (constant-exp? exp) (tagged-list? exp 'const))
(define (constant-exp-value exp) (cadr exp))
(define (label-exp? exp) (tagged-list? exp 'label))
(define (label-exp-label exp) (cadr exp))
(define (register-exp? exp) (tagged-list? exp 'reg))
(define (register-exp-reg exp) (cadr exp))
(define (check op arg)
(define checks
(list
(list 'car (list pair?))
(list 'cdr (list pair?))
(list 'quotient (list integer?
(lambda (x) (and (integer? x) (not (= x 0))))))
))
(define (chk-iter cop carg)
(if (null? carg)
true
(if ((car cop) (car carg))
(chk-iter (cdr cop) (cdr carg))
false)))
(let ((chk (assoc op checks)))
(if chk
(chk-iter (cadr chk) arg)
true)))
(define (make-operation-exp exp machine labels operations)
(let ((operator (operation-exp-op exp)))
(let ((op (lookup-prim operator operations))
(aprocs
(map (lambda (e) (make-primitive-exp e machine labels))
(operation-exp-operands exp))))
(lambda ()
(let ((ap (map (lambda (p) (p)) aprocs)))
(if (check operator ap)
(apply-in-underlying-scheme op ap)
(error "Illegal arguments -- ASSEMBLE" exp)))))))
(define (operation-exp? exp)
(and (pair? exp) (tagged-list? (car exp) 'op)))
(define (operation-exp-op operation-exp)
(cadr (car operation-exp)))
(define (operation-exp-operands operation-exp)
(cdr operation-exp))
(define (lookup-prim symbol operations)
(let ((val (assoc symbol operations)))
(if val
(cadr val)
(error "Unknown operation -- ASSEMBLE" symbol))))
実行
Schemeインタプリタ
reg-driver.scm をロードすると、一式全部ロードするのでおすすめです。
gosh> (driver-loop)
;;; M-Eval input:
(define (sum lis)
(if (null? lis)
0
(+ (car lis) (sum (cdr lis)))))
;;; M-Eval value:
ok
;;; M-Eval input:
(sum '(1 2 3 4 5))
;;; M-Eval value:
15
アセンブリ言語版インタプリタ
gosh> (start-eceval)
;;; EC-Eval input:
(define (sum-iter lis)
(define (iter l sum)
(if (null? l)
sum
(iter (cdr l) (+ sum (car l)))))
(iter lis 0))
; (total-pushes = 3 maximum-depth = 3)
;;; EC-Eval value:
ok
;;; EC-Eval input:
(sum-iter '(1 2 3 4 5))
; (total-pushes = 186 maximum-depth = 9)
;;; EC-Eval value:
15
レジスタマシン版インタプリタ
gosh> (rm-driver-loop)
;;; RM-Eval input:
(define (fact-tail n x)
(if (= n 0)
x
(fact-tail (- n 1) (* n x))))
; (total-pushes = 0 maximum-depth = 0)
;;; RM-Eval value:
ok
;;; RM-Eval input:
(define (fact n)
(fact-tail n 1))
; (total-pushes = 0 maximum-depth = 0)
;;; RM-Eval value:
ok
;;; RM-Eval input:
(fact 10)
; (total-pushes = 62 maximum-depth = 3)
;;; RM-Eval value:
3628800