開発環境
- 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.3(記憶の割当てとごみ集め)、5.3.1(ベクタとしてのメモリー)、Lispデータの表現、基本リスト演算の実装、スタックの実装、問題 5.22(append手続き).を解いてみる。
その他参考書籍
問題 5.22(append!手続き).
コード(BBEdit)
register.scm
(define (make-machine ops controller-text) (let ((machine (make-new-machine))) ((machine 'install-operations) ops) ((machine 'install-instruction-sequence) (assemble controller-text machine)) machine)) (define (make-register name) (let ((contents '*unassigned*) (trace false)) (define (set value) (if trace (begin (newline) (display "name=") (display name) (display ", old value=") (display contents) (display ", new value=") (display value))) (set! contents value)) (define (dispatch message) (cond ((eq? message 'get) contents) ((eq? message 'set) set) ((eq? message 'trace-on) (set! trace true) 'done) ((eq? message 'trace-off) (set! trace false) 'done) (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 '()) (number-pushes 0) (max-depth 0) (current-depth 0)) (define (push x) (set! s (cons x s)) (set! number-pushes (+ 1 number-pushes)) (set! current-depth (+ 1 current-depth)) (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 '()) (set! number-pushes 0) (set! max-depth 0) (set! current-depth 0) 'done) (define (print-statistics) (newline) (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 (pop stack) (stack 'pop)) (define (push stack value) ((stack 'push) value)) (define (initialize stack) (stack 'initialize)) (define (print-statistics stack) (stack 'print-statistics)) (define (start machine) (machine 'start)) (define (trace-on machine) (machine 'trace-on)) (define (trace-off machine) (machine 'trace-off)) (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 (initialize-inst-count machine) (machine 'initialize-inst-count)) (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)) ;; 5.81 (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 (make-new-machine) (let ((pc (make-register 'pc)) (flag (make-register 'flag)) (stack (make-stack)) (the-instruction-sequence '()) (the-instruction-counting 0) (trace false) (label '()) (line 0) (breakpoints '()) (break false)) (let ((the-ops (list (list 'initialize-stack (lambda () (stack 'initialize))) (list 'print-stack-statistics (lambda () (stack 'print-statistics))))) (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) (begin (allocate-register name) (lookup-register name))))) (define (execute) (let ((insts (get-contents pc))) (if (null? insts) 'done (begin (set! the-instruction-counting (+ the-instruction-counting 1)) (let ((p (car insts))) (let ((l (instruction-label p))) (if trace (begin (newline) (if (null? l) (display label) (begin (set! label l) (display label))) (display ": ") (display (instruction-text p)))) (if (null? l) (set! line (+ line 1)) (begin (set! line 0) (set! label l))) (if break (begin (set! break false) ((instruction-execution-proc p)) (execute)) (if (member (cons label line) breakpoints) (begin (newline) (display "label=") (display label) (display " distance=") (display line) (display " break") (set! break true) 'done) (begin ((instruction-execution-proc p)) (execute)))))))))) (define (initialize-inst-count) (display (list 'the-instruction-counting '= the-instruction-counting)) (set! the-instruction-counting 0) 'done) ;; 命令トレースを開始、停止出来るようにする (define (trace-on) (set! trace true) 'done) (define (trace-off) (set! trace false) 'done) (define (set-breakpoint label n) (set! breakpoints (cons (cons label n) breakpoints)) 'done) (define (proceed-machine) (execute)) (define (cancel-breakpoint label n) (set! breakpoints (filter (lambda (x) (not (equal? x (cons label n)))) breakpoints)) 'done) (define (cancel-all-breakpoints) (set! breakpoints '()) 'done) (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 'trace-on) (trace-on)) ((eq? message 'trace-off) (trace-off)) ((eq? message 'initialize-inst-count) (initialize-inst-count)) ((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 (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) (begin (set-instruction-label! (car insts) 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) (list text '() '())) (define (instruction-text inst) (car inst)) (define (instruction-execution-proc inst) (cadr inst)) (define (instruction-label inst) (caddr inst)) (define (set-instruction-execution-proc! inst proc) (set-car! (cdr inst) proc)) (define (set-instruction-label! inst label) (set-car! (cddr inst) label)) (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) (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)) ;; 新しい構文を追加(branchと枝分かれの仕方が逆) ((eq? (car inst) 'branch-not) (make-branch-not inst machine labels flag pc)) ((eq? (car inst) 'initialize) (make-initialize stack pc)) ((eq? (car inst) 'print-statistics) (make-print-statistics stack 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-initialize stack pc) (lambda () (initialize stack) (advance-pc pc))) (define (make-print-statistics stack pc) (lambda () (print-statistics stack) (advance-pc pc))) (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))))
入出力結果(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.scm") ;Loading "./register.scm"... done ;Value: lookup-prim 1 ]=> (define (print a) (display a) (newline)) ;Value: print 1 ]=> (define append!-machine (make-machine (list (list 'read read) (list 'cdr cdr) (list 'null? null?) (list 'set-cdr! set-cdr!) (list 'print print)) '(Loop (assign x (op read)) (assign y (op read)) (save x) append!-machine-loop (assign b (op cdr) (reg x)) (test (op null?) (reg b)) (branch (label append!-machine-done)) (assign x (op cdr) (reg x)) (goto (label append!-machine-loop)) append!-machine-done (perform (op set-cdr!) (reg x) (reg y)) (restore x) (perform (op print) (reg x)) (goto (label loop))))) ;Value: append!-machine 1 ]=> (start append!-machine) (1 2) (3 4 5) (1 2 3 4 5) (1) (2 3 4 5) (1 2 3 4 5) (1 2 3 4 5) () (1 2 3 4 5) (1) () (1) (1) (2) (1 2) () (1) ;The object (), passed as the first argument to cdr, is not the correct type. ;To continue, call RESTART with an option number: ; (RESTART 2) => Specify an argument to use in its place. ; (RESTART 1) => Return to read-eval-print level 1. 2 error> ^C Interrupt option (? for help): ;Quit! 1 ]=> ^D End of input stream reached. Moriturus te saluto. $
0 コメント:
コメントを投稿