開発環境
- 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.21-a.を解いてみる。
その他参考書籍
問題 5.21-a.
コード(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 count-leaves-machine
(make-machine
(list (list 'null? null?) (list 'pair? pair?) (list '+ +) (list 'car car)
(list 'cdr cdr) (list 'read read) (list 'print print))
'(loop
(assign continue (label count-leaves-done))
(assign tree (op read))
count-leaves-Loop
(test (op null?) (reg tree))
(branch (label immediate-answer-null))
(test (op pair?) (reg tree))
(branch (label left))
(assign val (const 1))
(goto (reg continue))
left
(save tree)
(assign tree (op car) (reg tree))
(save continue)
(assign continue (label right))
(goto (label count-leaves-loop))
right
(restore continue)
(restore tree)
(save continue)
(assign tree (op cdr) (reg tree))
(assign continue (label after-tree))
(save val)
(goto (label count-leaves-loop))
after-tree
(assign t (reg val))
(restore val)
(assign val (op +) (reg val) (reg t))
(restore continue)
(goto (reg continue))
immediate-answer-null
(assign val (const 0))
(goto (reg continue))
count-leaves-done
(perform (op print) (reg val))
(goto (label loop)))))
;Value: count-leaves-machine
1 ]=> (start count-leaves-machine)
()
0
10
1
(1 2)
2
(1 2 3)
3
(1 2 3 4)
4
(1 2 3 4 5)
5
((1 2) (3 4) 5)
5
(1 (2 3) (4 5))
5
(1 (2 3) 4 5 (6 7) 8 9 10)
10
^C
Interrupt option (? for help): ;Quit!
1 ]=> ^D
End of input stream reached.
Moriturus te saluto.
$
0 コメント:
コメントを投稿