開発環境
- OS X Mavericks - Apple(OS)
- Emacs (CUI)、BBEdit - Bare Bones Software, Inc. (GUI) (Text Editor)
- Scheme (プログラミング言語)
- MIT/GNU Scheme (処理系)
計算機プログラムの構造と解釈(Gerald Jay Sussman(原著)、Julie Sussman(原著)、Harold Abelson(原著)、和田 英一(翻訳)、ピアソンエデュケーション、原書: Structure and Interpretation of Computer Programs (MIT Electrical Engineering and Computer Science)(SICP))の5(レジスタ計算機での計算)、5.5(翻訳系)、翻訳系の概観、5.5.6(文面アドレス)、問題 5.42.を解いてみる。
その他参考書籍
問題 5.42.
コード(BBEdit)
compiler5.42.scm
(define (compile exp target linkage compile-time-env)
(cond ((self-evaluating? exp)
(compile-self-evaluating exp target linkage))
((quoted? exp) (compile-quoted exp target linkage))
((variable? exp)
(compile-variable exp target linkage compile-time-env))
((assignment? exp)
(compile-assignment exp target linkage compile-time-env))
((definition? exp)
(compile-definition exp target linkage compile-time-env))
((if? exp) (compile-if exp target linkage compile-time-env))
((lambda? exp) (compile-lambda exp target linkage compile-time-env))
((begin? exp)
(compile-sequence (begin-actions exp)
target
linkage
compile-time-env))
((cond? exp) (compile (cond->if exp) target linkage compile-time-env))
((open-code? exp)
(compile-open-code exp target linkage compile-time-env))
((application? exp)
(compile-application exp target linkage compile-time-env))
(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 '() '() '()))
(define (compile-linkage linkage)
(cond ((eq? linkage 'return)
(make-instruction-sequence '(continue) '()
'((goto (reg continue)))))
((eq? linkage 'next)
(empty-instruction-sequence))
(else
(make-instruction-sequence '() '()
`((goto (label ,linkage)))))))
(define (end-with-linkage linkage instruction-sequence)
(preserving '(continue)
instruction-sequence
(compile-linkage linkage)))
(define (compile-self-evaluating exp target linkage)
(end-with-linkage linkage
(make-instruction-sequence '() (list target)
`((assign ,target (const ,exp))))))
(define (compile-quoted exp target linkage)
(end-with-linkage linkage
(make-instruction-sequence '() (list target)
`((assign ,target (const ,(text-of-quotation exp)))))))
(define (compile-variable exp target linkage compile-time-env)
(let ((lexical-address (find-variable exp compile-time-env)))
(if (eq? lexical-address 'not-found)
(end-with-linkage linkage
(make-instruction-sequence '(env) (list target)
`((assign ,target
(op lookup-variable-value)
(const ,exp)
(reg env)))))
(end-with-linkage linkage
(make-instruction-sequence '(env) (list target)
`((assign ,target
(op lexical-address-lookup)
(const ,lexical-address)
(reg env))))))))
(define (compile-assignment exp target linkage compile-time-env)
(let ((var (assignment-variable exp))
(get-value-code
(compile (assignment-value exp) 'val 'next compile-time-env)))
(let ((lexical-address (find-variable var compile-time-env)))
(if (eq? lexical-address 'not-found)
(end-with-linkage linkage
(preserving '(env)
get-value-code
(make-instruction-sequence '(env val) (list target)
`((perform (op set-variable-value!)
(const ,var)
(reg val)
(reg env))
(assign ,target (const ok))))))
(end-with-linkage linkage
(preserving '(env)
get-value-code
(make-instruction-sequence '(env val) (list target)
`((perform (op lexical-address-set!)
(const ,lexical-address)
(reg val)
(reg env))
(assign ,target (const ok))))))))))
(define (compile-definition exp target linkage compile-time-env)
(let ((var (definition-variable exp))
(get-value-code
(compile (definition-value exp) 'val 'next compile-time-env)))
(end-with-linkage linkage
(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))))))))
(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-if exp target linkage compile-time-env)
(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 compile-time-env))
(c-code
(compile
(if-consequent exp) target consequent-linkage))
(a-code
(compile (if-alternative exp) target linkage compile-time-env)))
(preserving '(env continue)
p-code
(append-instruction-sequences
(make-instruction-sequence '(val) '()
`((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 compile-time-env)
(if (last-exp? seq)
(compile (first-exp seq) target linkage compile-time-env)
(preserving '(env continue)
(compile (first-exp seq) target 'next compile-time-env)
(compile-sequence (rest-exps seq) target linkage compile-time-env))))
(define (compile-lambda exp target linkage compile-time-env)
(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)
`((assign ,target
(op make-compiled-procedure)
(label ,proc-entry)
(reg env)))))
(compile-lambda-body exp proc-entry compile-time-env))
after-lambda))))
(define (compile-lambda-body exp proc-entry compile-time-env)
(let ((formals (lambda-parameters exp)))
(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))))
(compile-sequence (lambda-body exp)
'val
'return
(cons formals compile-time-env)))))
;; 5.38
(define (spread-arguments operand-codes compile-time-env)
(if (null? operand-codes)
(make-instruction-sequence
'((assign arg1 (const ()))
(assign arg2 (const ()))))
(let ((op1 (compile (car operand-codes) 'arg1 'next compile-time-env))
(op2 (compile (cadr operand-codes) 'arg2 'next compile-time-env)))
(append-instruction-sequences
op1
(append-instruction-sequences
(make-instruction-sequence '(arg1) '() '((save arg1)))
(append-instruction-sequences
op2
(make-instruction-sequence '() '(arg1) '((restore arg1)))))))))
(define (open-code? exp) (memq (car exp) '(= * - +)))
(define (compile-open-code exp target linkage compile-time-env)
(define (inner exp target linkage)
(end-with-linkage linkage
(preserving '(env continue)
(spread-arguments (operands exp) compile-time-env)
(make-instruction-sequence '(arg1 arg2) (list target)
`((assign ,target (op ,(operator exp)) (reg arg1) (reg arg2)))))))
(define (fold op operand-codes)
(if (null? (cdr operand-codes))
(car operand-codes)
(list op (car operand-codes) (fold op (cdr operand-codes)))))
(let ((op (operator exp)))
(if (or (eq? op '+) (eq? op '*))
(inner (fold op (operands exp)) target linkage)
(inner exp target linkage))))
(define (compile-application exp target linkage compile-time-env)
(let ((proc-code (compile (operator exp) 'proc 'next compile-time-env))
(operand-codes
(map (lambda (operand) (compile operand 'val 'next compile-time-env))
(operands exp))))
(preserving '(env continue)
proc-code
(preserving '(proc continue)
(construct-arglist operand-codes)
(compile-procedure-call target linkage)))))
(define (construct-arglist operand-codes)
(let ((operand-codes (reverse operand-codes)))
(if (null? operand-codes)
(make-instruction-sequence '() '(argl)
'((assign argl (const ()))))
(let ((code-to-get-last-arg
(append-instruction-sequences
(car operand-codes)
(make-instruction-sequence '(val) '(argl)
'((assign argl (op list) (reg val)))))))
(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))))))))
(define (code-to-get-rest-args operand-codes)
(let ((code-for-next-arg
(preserving '(argl)
(car operand-codes)
(make-instruction-sequence '(val argl) '(argl)
'((assign argl
(op cons) (reg val) (reg argl)))))))
(if (null? (cdr operand-codes))
code-for-next-arg
(preserving '(env)
code-for-next-arg
(code-to-get-rest-args (cdr operand-codes))))))
(define (compile-procedure-call 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) '()
`((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)
`((assign ,target
(op apply-primitive-procedure)
(reg proc)
(reg argl)))))))
after-call))))
(define (compile-proc-appl target linkage)
(cond ((and (eq? target 'val) (not (eq? linkage 'return)))
(make-instruction-sequence '(proc) all-regs
`((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
`((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
'((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 all-regs '(env proc val argl continue))
(define (registers-needed s)
(if (symbol? s) '() (car s)))
(define (registers-modified s)
(if (symbol? s) '() (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) '())
((memq (car s1) s2) (list-difference (cdr s1) s2))
(else (cons (car s1)
(list-difference (cdr s1) s2)))))
(define (preserving 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 (cdr regs)
(make-instruction-sequence
(list-union (list first-reg)
(registers-needed seq1))
(list-difference (registers-modified seq1)
(list first-reg))
(append `((save ,first-reg))
(statements seq1)
`((restore ,first-reg))))
seq2)
(preserving (cdr regs) seq1 seq2)))))
(define (tack-on-instruction-sequence seq body-seq)
(make-instruction-sequence
(registers-needed seq)
(registers-modified seq)
(append (statements seq) (statements body-seq))))
(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 (statements seq1) (statements seq2))))
;;
(define (lexical-address-lookup lexical-address compile-time-env)
(let ((val (list-ref (list-ref compile-time-env
(car lexical-address))
(cadr lexical-address))))
(if (eq? val '*unassigned*)
(error
"Unassigned variable -- LEXICAL-ADDRESS-LOOKUP" lexical-address)
val)))
(define (lexical-address-set! exical-address val lcompile-time-env)
(define (iter-frame frame-n var-n env)
(cond ((null? env)
(error
"Unbound compile-time-env -- LEXICAL-ADDRESS-SET!"
val lexical-address compile-time-env))
((= frame-n 0)
(iter-variable var-n (car env)))
(else (iter-frame (- frame-n 1) var-n (cdr env)))))
(define (iter-variable var-n frame)
(cond ((null? frame)
(error
"Unbound variable - LEXICAL-ADDRESS-SET!"
val lexical-address compile-time-env))
((= var-n 0)
(set-car! frame val))
((iter-variable val (- var-n (cdr frame))))))
(iter-frame (car lexical-address)
(cadr lexical-address)
compile-time-env))
;; 5.41
(define (find-variable var compile-time-env)
(define (iter frame-n disp-n frame frames)
(if (null? frame)
(if (null? frames)
'not-found
(iter (+ frame-n 1)
0
(car frames)
(cdr frames)))
(if (eq? (car frame) var)
(list frame-n disp-n)
(iter frame-n
(+ disp-n 1)
(cdr frame)
frames))))
(if (null? compile-time-env)
'not-found
(iter 0 0 (car compile-time-env) (cdr compile-time-env))))
;; 見やすく表示する為に追加
(define (print-compiled compiled)
(define (iter result)
(newline)
(if (and (not (null? result)) (pair? result))
(let ((first (car result))
(rest (cdr result)))
(if (symbol? first)
(begin (display first)
(iter rest))
(begin (display " ")
(display first)
(iter rest))))
'done))
(newline)
(display (car compiled))
(newline)
(display (cadr compiled))
(iter (caddr compiled)))
入出力結果(Terminal, REPL(Read, Eval, Print, Loop))
$ scheme
MIT/GNU Scheme running under MacOSX
Type `^C' (control-C) followed by `H' to obtain information about interrupts.
Copyright (C) 2011 Massachusetts Institute of Technology
This is free software; see the source for copying conditions. There is NO
warranty; not even for MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
Image saved on Saturday October 26, 2013 at 11:02:50 PM
Release 9.1.1 || Microcode 15.3 || Runtime 15.7 || SF 4.41 || LIAR/C 4.118
Edwin 3.116
1 ]=> (load "./eval.scm")
;Loading "./eval.scm"... done
;Value: the-global-environment
1 ]=> (load "./compiler5.42.scm")
;Loading "./compiler5.42.scm"... done
;Value: print-compiled
1 ]=> (print-compiled
(compile
'((lambda (x y)
(lambda (a b c d e)
((lambda (y z) (* x y z))
(* a b x)
(+ c d x))))
3
4)
'val
'next
'())
)
(env)
(env proc argl continue val)
(assign proc (op make-compiled-procedure) (label entry2) (reg env))
(goto (label after-lambda1))
entry2
(assign env (op compiled-procedure-env) (reg proc))
(assign env (op extend-environment) (const (x y)) (reg argl) (reg env))
(assign val (op make-compiled-procedure) (label entry4) (reg env))
(goto (reg continue))
entry4
(assign env (op compiled-procedure-env) (reg proc))
(assign env (op extend-environment) (const (a b c d e)) (reg argl) (reg env))
(assign proc (op make-compiled-procedure) (label entry6) (reg env))
(goto (label after-lambda5))
entry6
(assign env (op compiled-procedure-env) (reg proc))
(assign env (op extend-environment) (const (y z)) (reg argl) (reg env))
(assign arg1 (op lexical-address-lookup) (const (2 0)) (reg env))
(save arg1)
(assign arg1 (op lexical-address-lookup) (const (0 0)) (reg env))
(save arg1)
(assign arg2 (op lexical-address-lookup) (const (0 1)) (reg env))
(restore arg1)
(assign arg2 (op *) (reg arg1) (reg arg2))
(restore arg1)
(assign val (op *) (reg arg1) (reg arg2))
(goto (reg continue))
after-lambda5
(assign arg1 (op lexical-address-lookup) (const (0 2)) (reg env))
(save arg1)
(assign arg1 (op lexical-address-lookup) (const (0 3)) (reg env))
(save arg1)
(assign arg2 (op lexical-address-lookup) (const (1 0)) (reg env))
(restore arg1)
(assign arg2 (op +) (reg arg1) (reg arg2))
(restore arg1)
(assign val (op +) (reg arg1) (reg arg2))
(assign argl (op list) (reg val))
(assign arg1 (op lexical-address-lookup) (const (0 0)) (reg env))
(save arg1)
(assign arg1 (op lexical-address-lookup) (const (0 1)) (reg env))
(save arg1)
(assign arg2 (op lexical-address-lookup) (const (1 0)) (reg env))
(restore arg1)
(assign arg2 (op *) (reg arg1) (reg arg2))
(restore arg1)
(assign val (op *) (reg arg1) (reg arg2))
(assign argl (op cons) (reg val) (reg argl))
(test (op primitive-procedure?) (reg proc))
(branch (label primitive-branch9))
compiled-branch8
(assign val (op compiled-procedure-entry) (reg proc))
(goto (reg val))
primitive-branch9
(assign val (op apply-primitive-procedure) (reg proc) (reg argl))
(goto (reg continue))
after-call7
after-lambda3
after-lambda1
(assign val (const 4))
(assign argl (op list) (reg val))
(assign val (const 3))
(assign argl (op cons) (reg val) (reg argl))
(test (op primitive-procedure?) (reg proc))
(branch (label primitive-branch12))
compiled-branch11
(assign continue (label after-call10))
(assign val (op compiled-procedure-entry) (reg proc))
(goto (reg val))
primitive-branch12
(assign val (op apply-primitive-procedure) (reg proc) (reg argl))
after-call10
;Value: done
1 ]=> ^D
End of input stream reached.
Moriturus te saluto.
$
上から順に、(2 0), (0 0) (0 1)は(* x y z)のx、y、zのアドレス、次の(0 2)、(0 3)、(1 0)は(+ c d x)のc、d、xのアドレス、(0 0)、(0 1)、(1 0)は(* a b x)のa、b、xのアドレスとなっているので、テストが正しいのは確認できた。
テストしたのは上手くいった。
0 コメント:
コメントを投稿