開発環境
- 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.2(レジスタ計算機シミュレータ)、5.2.3(命令の実行手続きの生成)、assign命令、test、branchおよびgoto命令、その他の命令、部分式の実行手続き、問題 5.12を解いてみる。
その他参考書籍
問題 5.12.
修正箇所。
コード(BBEdit)
(define (make-analyze-info) (let ((orders '((assign) (test) (branch) (goto) (save) (restore) (perform) (branch-not)))) (define (add-analyze-info inst label) (let ((order (assoc label orders))) (if order (if (not (member inst order)) (set-cdr! order (cons inst (cdr order)))) (error "Not exists -- MAKE-ANALYZE-INFO" label)))) (define (get-analyze-info) orders) (define (dispatch message) (cond ((eq? message 'add-analyze-info) add-analyze-info) ((eq? message 'get-analyze-info) get-analyze-info) (else (error "Unknown request -- MAKE-ANALYZE-INFO" message)))) dispatch)) (define (add-analyze-info inst machine label) (((machine 'analyze-info) 'add-analyze-info) inst label)) (define (get-analyze-info machine) (((machine 'analyze-info) 'get-analyze-info))) (define (make-new-machine) (let ((pc (make-register 'pc)) (flag (make-register 'flag)) (stack (make-stack)) (the-instruction-sequence '()) (analyze-info (make-analyze-info))) (let ((the-ops (list (list 'initialize-stack (lambda () (stack 'initialize))))) (register-table (list (list 'pc pc) (list 'flag flag)))) (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))) 'register-allocated) (define (lookup-register name) (let ((val (assoc name register-table))) (if val (cadr val) (error "Unknown register:" name)))) (define (execute) (let ((insts (get-contents pc))) (if (null? insts) 'done (begin ((instruction-execution-proc (car insts))) (execute))))) (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 'analyze-info) analyze-info) (else (error "Unknown request -- MACHINE" message)))) dispatch))) (define (make-execution-procedure inst labels machine pc flag stack ops) (cond ((eq? (car inst) 'assign) (add-analyze-info inst machine 'assign) (make-assign inst machine labels ops pc)) ((eq? (car inst) 'test) (add-analyze-info inst machine 'test) (make-test inst machine labels ops flag pc)) ((eq? (car inst) 'branch) (add-analyze-info inst machine 'branch) (make-branch inst machine labels flag pc)) ((eq? (car inst) 'goto) (add-analyze-info inst machine 'goto) (make-goto inst machine labels pc)) ((eq? (car inst) 'save) (add-analyze-info inst machine 'save) (make-save inst machine stack pc)) ((eq? (car inst) 'restore) (add-analyze-info inst machine 'restore) (make-restore inst machine stack pc)) ((eq? (car inst) 'perform) (add-analyze-info inst machine 'perform) (make-perform inst machine labels ops pc)) ;; 新しい構文を追加(branchと枝分かれの仕方が逆) ((eq? (car inst) 'branch-not) (add-analyze-info inst machine 'branch-not) (make-branch-not inst machine labels flag pc)) (else (error "Unknown instruction type -- ASSEMBLE" inst))))
全体。
コード(BBEdit)
register_c.scm
(define (make-machine register-names ops controller-text) (let ((machine (make-new-machine))) (for-each (lambda (register-name) ((machine 'allocate-register) register-name)) register-names) ((machine 'install-operations) ops) ((machine 'install-instruction-sequence) (assemble controller-text machine)) machine)) (define (make-register name) (let ((contents '*unassigned*)) (define (dispatch message) (cond ((eq? message 'get) contents) ((eq? message 'set) (lambda (value) (set! contents value))) (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 '())) (define (push x) (set! s (cons x s))) (define (pop) (if (null? s) (error "Empty stack -- POP") (let ((top (car s))) (set! s (cdr s)) top))) (define (initialize) (set! s '()) 'done) (define (dispatch message) (cond ((eq? message 'push) push) ((eq? message 'pop) (pop)) ((eq? message 'initialize) (initialize)) (else (error "Unknown request -- STACK" message)))) dispatch)) (define (pop stack) (stack 'pop)) (define (push stack value) ((stack 'push) value)) (define (make-analyze-info) (let ((orders '((assign) (test) (branch) (goto) (save) (restore) (perform) (branch-not)))) (define (add-analyze-info inst label) (let ((order (assoc label orders))) (if order (if (not (member inst order)) (set-cdr! order (cons inst (cdr order)))) (error "Not exists -- MAKE-ANALYZE-INFO" label)))) (define (get-analyze-info) orders) (define (dispatch message) (cond ((eq? message 'add-analyze-info) add-analyze-info) ((eq? message 'get-analyze-info) get-analyze-info) (else (error "Unknown request -- MAKE-ANALYZE-INFO" message)))) dispatch)) (define (add-analyze-info inst machine label) (((machine 'analyze-info) 'add-analyze-info) inst label)) (define (get-analyze-info machine) (((machine 'analyze-info) 'get-analyze-info))) (define (start machine) (machine 'start)) (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 (get-register machine reg-name) ((machine 'get-register) reg-name)) (define (make-new-machine) (let ((pc (make-register 'pc)) (flag (make-register 'flag)) (stack (make-stack)) (the-instruction-sequence '()) (analyze-info (make-analyze-info))) (let ((the-ops (list (list 'initialize-stack (lambda () (stack 'initialize))))) (register-table (list (list 'pc pc) (list 'flag flag)))) (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))) 'register-allocated) (define (lookup-register name) (let ((val (assoc name register-table))) (if val (cadr val) (error "Unknown register:" name)))) (define (execute) (let ((insts (get-contents pc))) (if (null? insts) 'done (begin ((instruction-execution-proc (car insts))) (execute))))) (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 'analyze-info) analyze-info) (else (error "Unknown request -- MACHINE" message)))) dispatch))) (define (assemble controller-text machine) (extract-labels controller-text (lambda (insts labels) (update-insts! insts labels machine) insts))) (define (extract-labels text receive) (if (null? text) (receive '() '()) (extract-labels (cdr text) (lambda (insts labels) (let ((next-inst (car text))) (if (symbol? next-inst) (if (assoc next-inst labels) (error "Multiply defined label: " next-inst) (receive insts (cons (make-label-entry next-inst insts) labels))) (receive (cons (make-instruction next-inst) insts) labels))))))) (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 '())) (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) (cond ((eq? (car inst) 'assign) (add-analyze-info inst machine 'assign) (make-assign inst machine labels ops pc)) ((eq? (car inst) 'test) (add-analyze-info inst machine 'test) (make-test inst machine labels ops flag pc)) ((eq? (car inst) 'branch) (add-analyze-info inst machine 'branch) (make-branch inst machine labels flag pc)) ((eq? (car inst) 'goto) (add-analyze-info inst machine 'goto) (make-goto inst machine labels pc)) ((eq? (car inst) 'save) (add-analyze-info inst machine 'save) (make-save inst machine stack pc)) ((eq? (car inst) 'restore) (add-analyze-info inst machine 'restore) (make-restore inst machine stack pc)) ((eq? (car inst) 'perform) (add-analyze-info inst machine 'perform) (make-perform inst machine labels ops pc)) ;; 新しい構文を追加(branchと枝分かれの仕方が逆) ((eq? (car inst) 'branch-not) (add-analyze-info inst machine 'branch-not) (make-branch-not inst machine labels flag pc)) (else (error "Unknown instruction type -- ASSEMBLE" inst)))) (define (make-assign inst machine labels operations pc) (let ((target (get-register machine (assign-reg-name inst))) (value-exp (assign-value-exp inst))) (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 () ; execution procedure for assign (set-contents! target (value-proc)) (advance-pc pc))))) (define (assign-reg-name assign-instruction) (cadr assign-instruction)) (define (assign-value-exp assign-instruction) (cddr assign-instruction)) (define (advance-pc pc) (set-contents! pc (cdr (get-contents pc)))) (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 () (set-contents! flag (condition-proc)) (advance-pc 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 () (if (get-contents flag) (set-contents! pc insts) (advance-pc 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 () (set-contents! pc insts)))) ((register-exp? dest) (let ((reg (get-register machine (register-exp-reg dest)))) (lambda () (set-contents! pc (get-contents reg))))) (else (error "Bad GOTO instruction -- ASSEMBLE" inst))))) (define (goto-dest goto-instruction) (cadr goto-instruction)) (define (make-save inst machine stack pc) (let ((reg (get-register machine (stack-inst-reg-name inst)))) (lambda () (push stack (get-contents reg)) (advance-pc pc)))) (define (make-restore inst machine stack pc) (let ((reg (get-register machine (stack-inst-reg-name inst)))) (lambda () (set-contents! reg (pop stack)) (advance-pc 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 () (action-proc) (advance-pc pc))) (error "Bad PERFORM instruction -- ASSEMBLE" inst)))) (define (perform-action inst) (cdr inst)) (define (make-branch-not inst machine labels flag pc) (let ((dest (branch-not-dest inst))) (if (label-exp? dest) (let ((insts (lookup-label labels (label-exp-label dest)))) (lambda () (if (get-contents flag) (advance-pc pc) (set-contents! pc insts)))) (error "Bad BRANCH-NOT instruction -- ASSEMBLE" inst)))) (define (branch-not-dest branch-not-instruction) (cadr branch-not-instruction)) (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? exp tag) (if (pair? exp) (eq? (car exp) tag) false)) (define (register-exp? exp) (tagged-list? exp 'reg)) (define (register-exp-reg exp) (cadr exp)) (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 (make-operation-exp exp machine labels operations) (let ((op (lookup-prim (operation-exp-op exp) operations)) (aprocs (map (lambda (e) (if (label-exp? e) (error "Cannot apply op to lbael -- MAKE-OPERATION-EXP" e) (make-primitive-exp e machine labels))) (operation-exp-operands exp)))) (lambda () (apply op (map (lambda (p) (p)) aprocs))))) (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))))
元のrestoreとの違いを確認。
入出力結果(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 "register_extends") ;Loading "register_extends.scm"... done ;Value: lookup-prim 1 ]=> (define fib-machine (make-machine '(continue n val) (list (list '< <) (list '- -) (list '+ +)) '( (assign continue (label fib-done)) fib-loop (test (op <) (reg n) (const 2)) (branch (label immediate-answer)) (save continue) (assign continue (label afterfib-n-2)) (save n) (assign n (op -) (reg n) (const 1)) (goto (label fib-loop)) afterfib-n-1 (restore n) (assign n (op -) (reg n) (const 2)) (assign continue (label afterfib-n-2)) (save val) (goto (label fib-loop)) afterfib-n-2 (assign n (reg val)) (restore val) (restore continue) (assign val (op +) (reg val) (reg n)) (goto (reg continue)) immediate-answer (assign val (reg n)) (goto (reg continue)) fib-done))) ;Value: fib-machine 1 ]=> (set-register-contents! fib-machine 'n 10) ;Value: done 1 ]=> (start fib-machine) ;Value: done 1 ]=> (get-register-contents fib-machine 'n) ;Value: 45 1 ]=> (get-analyze-info fib-machine) ;Value 2: ((assign (assign val (reg n)) (assign val (op +) (reg val) (reg n)) (assign n (reg val)) (assign n (op -) (reg n) (const 2)) (assign n (op -) (reg n) (const 1)) (assign continue (label afterfib-n-2)) (assign continue (label fib-done))) (test (test (op <) (reg n) (const 2))) (branch (branch (label immediate-answer))) (goto (goto (reg continue)) (goto (label fib-loop))) (save (save val) (save n) (save continue)) (restore (restore continue) (restore val) (restore n)) (perform) (branch-not)) 1 ]=> ^D End of input stream reached. Moriturus te saluto. $
0 コメント:
コメントを投稿