SICP 読み (259) 5.2 レジスタ計算機での計算
問題 5.11 の c.
昨晩のハマりどころはレジスタのアクセスに get-register でなく、その中の手続きを使って試験を書いている箇所が多すぎたため、と思われます。抽象化してるんだから一回試験にパスしたんだったら、その手続きを使えよ、と。(とほほほ
面倒臭すぎて死にそうだった。
最初は試験の前面書き直しも考えていたのですが、ヤメ。以下に解とおぼしき手続きとその試験をサラしておきます。まず本体から。
(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))
;;**original (unmonitored) version from section 5.2.1
(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))
;;**monitored version from section 5.2.4
(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 (make-new-machine)
(let ((pc (make-register 'pc))
(flag (make-register 'flag))
(the-instruction-sequence '()))
(let ((the-ops
(list (list 'initialize-stack
(lambda () (stack 'initialize)))
;;**next for monitored stack (as in section 5.2.4)
;; -- comment out if not wanted
(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) (make-stack))
register-table)))
'register-allocated)
(define (lookup-register sw name)
(let ((val (assoc name register-table)))
(if val
(if (eq? sw 'reg)
(cadr val)
(caddr 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)
(else (error "Unknown request -- MACHINE" message))))
dispatch)))
(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 reg-name))
(define (get-stack machine reg-name)
((machine 'get-register) 'stack reg-name))
(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 "Dup label entry -- ASSEMBLE" 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))
(ops (machine 'operations)))
(for-each
(lambda (inst)
(set-instruction-execution-proc!
inst
(make-execution-procedure
(instruction-text inst) labels machine
pc flag 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 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 pc))
((eq? (car inst) 'restore)
(make-restore inst machine pc))
((eq? (car inst) 'perform)
(make-perform inst machine labels ops 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 pc)
(let ((reg (get-register machine
(stack-inst-reg-name inst)))
(stack (get-stack machine
(stack-inst-reg-name inst))))
(lambda ()
(push stack (get-contents reg))
(advance-pc pc))))
(define (make-restore inst machine pc)
(let ((reg (get-register machine
(stack-inst-reg-name inst)))
(stack (get-stack 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-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 (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 place label element -- ASSEMBLE" 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))))
;; from 4.1
(define (tagged-list? exp tag)
(if (pair? exp)
(eq? (car exp) tag)
#f))以降、三点ほど試験を。
(use gauche.test)
(add-load-path ".")
(load "ch5-regsim")
(test-start "ch5-regsim")
(test-section "register (make & set)")
(let ((reg (make-register 'a)))
(test* "nonexistent reg" *test-error* (reg 'xxx))
(test* "unassigned" '*unassigned* (reg 'get))
(test* "unassigned" '*unassigned* (get-contents reg)))
(test-section "register (get & set)")
(let ((reg (make-register 'a)))
((reg 'set) 1)
(test* "return 1" 1 (reg 'get))
(test* "return 1" 1 (get-contents reg))
(set-contents! reg 2)
(test* "return 2" 2 (reg 'get))
(test* "return 2" 2 (get-contents reg)))
(test-section "stack (make & pop)")
(let ((s (make-stack)))
(test* "stack is null" *test-error* (s 'pop)))
(test-section "stack (posh & pop)")
(let ((s (make-stack)))
((s 'push) 1)
(test* "return 1" 1 (s 'pop))
(test* "stack is null" *test-error* (s 'pop))
((s 'push) 2)
((s 'push) 1)
(test* "return 1" 1 (s 'pop))
(test* "return 2" 2 (s 'pop))
(test* "stack is null" *test-error* (s 'pop)))
(test-section "stack (initialize)")
(let ((s (make-stack)))
((s 'push) 1)
(s 'initialize)
(test* "stack is null" *test-error* (s 'pop)))
(test-section "stack (push & pop (2))")
(let ((s (make-stack)))
(push s 1)
(push s 2)
(test* "return 2" 2 (s 'pop))
(test* "return 1" 1 (s 'pop))
(test* "stack is null" *test-error* (s 'pop)))
(test-section "make-instruction")
(test* "return (1 ())" '(1) (make-instruction 1))
(test-section "instruction-text")
(test* "return car" 1 (instruction-text '(1 2)))
(test-section "instruction-execution-proc")
(test* "return cdr" 2 (instruction-execution-proc '(1 . 2)))
(test-section "set-instruction-execution-proc!")
(let ((l '(cons 1 '())))
(set-instruction-execution-proc! l 1)
(test* "set-cdr!" 1 (cdr l)))
(test-section "make-label-entry")
(test* "(label . inst)" '(1 . 2) (make-label-entry 1 2))
(test-section "lookup-label")
(let ((labels (cons (make-label-entry 1 2)
'())))
(test* "lookup failure" *test-error* (lookup-label labels 3))
(test* "return cdr" 2 (lookup-label labels 1)))
(test-section "assign-reg-name")
(let ((l1 '(assign n (op -) (reg n) (const 1)))
(l2 '(assign continue (label afterfib-n-1))))
(test* "register name is n" 'n (assign-reg-name l1))
(test* "register name is continue" 'continue (assign-reg-name l2)))
(test-section "assign-value-exp")
(let ((l1 '(assign n (op -) (reg n) (const 1)))
(l2 '(assign continue (label afterfib-n-1))))
(test* "return exp" '((op -) (reg n) (const 1)) (assign-value-exp l1))
(test* "return exp" '((label afterfib-n-1)) (assign-value-exp l2)))
(test-section "operation-exp?")
(let ((l1 '(assign n (op -) (reg n) (const 1)))
(l2 '(assign continue (label afterfib-n-1))))
(test* "operation exp" #t (operation-exp? (assign-value-exp l1)))
(test* "not operation exp" #f (operation-exp? (assign-value-exp l2))))
(test-section "operation-exp-op")
(let ((l1 '(assign n (op -) (reg n) (const 1))))
(test* "operation is -" '- (operation-exp-op (assign-value-exp l1))))
(test-section "operation-exp-operands")
(let ((l1 '(assign n (op -) (reg n) (const 1))))
(test* "operation input"
'((reg n) (const 1))
(operation-exp-operands (assign-value-exp l1))))
(test-section "test-condition")
(let ((l '(test (op <) (reg n) (const 2))))
(test* "condition exp" '((op <) (reg n) (const 2)) (test-condition l))
(test* "operation exp" #t (operation-exp? (test-condition l))))
(test-section "register-exp?")
(test* "register exp" #t (register-exp? '(reg n)))
(test* "not register exp" #f (register-exp? '(const 1)))
(test* "not register exp" #f (register-exp? '(label afterfib-n-1)))
(test-section "register-exp-reg")
(test* "get register's name" 'n (register-exp-reg '(reg n)))
(test-section "constant-exp?")
(test* "constant exp" #t (constant-exp? '(const 1)))
(test* "not constant exp" #f (constant-exp? '(reg n)))
(test* "not constant exp" #f (constant-exp? '(label afterfib-n-1)))
(test-section "constant-exp-value")
(test* "constant exp value" 1 (constant-exp-value '(const 1)))
(test-section "label-exp?")
(test* "label exp" #t (label-exp? '(label afterfib-n-1)))
(test* "not label exp" #f (label-exp? '(reg n)))
(test* "not label exp" #f (label-exp? '(const 1)))
(test-section "label-exp-label")
(test* "label value" 'afterfib-n-1 (label-exp-label '(label afterfib-n-1)))
(test-section "branch-dest")
(let ((l '(branch (label immediate-answer))))
(test* "branch destination" '(label immediate-answer) (branch-dest l))
(test* "label" #t (label-exp? (branch-dest l))))
(test-section "goto-dest")
(let ((l '(goto (reg continue))))
(test* "goto destination" '(reg continue) (goto-dest l)))
(test-section "stack-inst-reg-name")
(let ((l1 '(save val))
(l2 '(restore val)))
(test* "save register name" 'val (stack-inst-reg-name l1))
(test* "restore register name" 'val (stack-inst-reg-name l2)))
(test-section "perform-action")
(let ((l1 '(perform (op print) (reg a))))
(test* "perform action exp" '((op print) (reg a)) (perform-action l1)))
(test-section "make-new-machine")
(let ((m (make-new-machine)))
(test* "pc register is null"
'*unassigned*
(((m 'get-register) 'reg 'pc) 'get))
(test* "pc register is null"
'*unassigned*
(get-contents ((m 'get-register) 'reg 'pc)))
(test* "flag register is null"
'*unassigned*
(((m 'get-register) 'reg 'flag) 'get))
(test* "flag register is null"
'*unassigned*
(get-contents ((m 'get-register) 'reg 'flag))))
(test-section "hand make-machine")
(let ((m (make-new-machine)))
(for-each (lambda (register-name)
((m 'allocate-register) register-name))
'(a b t))
(test* "register a is null"
'*unassigned*
(get-contents ((m 'get-register) 'reg 'a)))
(test* "register b is null"
'*unassigned*
(get-contents ((m 'get-register) 'reg 'b)))
(test* "register t is null"
'*unassigned*
(get-contents ((m 'get-register) 'reg 't)))
(test* "stack is null" *test-error* ((get-stack m 'a) 'pop))
(test* "1st operation" 'initialize-stack (car (car (m 'operations))))
(test* "2nd operation" 'print-stack-statistics (car (cadr (m 'operations))))
((m 'install-operations) (list (list 'rem remainder) (list '= =)))
(test* "3rd operation" 'rem (car (caddr (m 'operations))))
(test* "4th operation" '= (car (cadddr (m 'operations)))))
(test-section "label")
(let ((m (make-new-machine))
(l '(test-b
(test (op =) (reg b) (const 0))
(branch (label gcd-done))
(assign t (op rem) (reg a) (reg b))
(assign a (reg b))
(assign b (reg t))
(goto (label test-b))
gcd-done)))
(for-each (lambda (register-name)
((m 'allocate-register) register-name))
'(a b t))
((m 'install-operations) (list (list 'rem remainder) (list '= =)))
(extract-labels
l
(lambda (insts labels)
(test* "1st labels name" 'test-b (car (car labels)))
(test* "1st labels value"
'(((test (op =) (reg b) (const 0)))
((branch (label gcd-done)))
((assign t (op rem) (reg a) (reg b)))
((assign a (reg b)))
((assign b (reg t)))
((goto (label test-b))))
(cdr (car labels)))
(test* "2nd labels name" 'gcd-done (car (cadr labels)))
(test* "2nd labels value" '() (cdr (cadr labels))))))
(test-section "(assign <register-name> (reg <register-name>))")
(let ((m (make-new-machine)))
(for-each (lambda (register-name)
((m 'allocate-register) register-name))
'(a b t))
((m 'install-operations) (list (list 'rem remainder) (list '= =)))
(set-contents! ((m 'get-register) 'reg 'a) 1)
(test* "value of register a" 1 (get-contents ((m 'get-register) 'reg 'a)))
(let ((ope (make-assign '(assign b (reg a)) m '() (m 'operations)
((m 'get-register) 'reg 'pc))))
(set-contents! ((m 'get-register) 'reg 'pc) '(() (gcd-done ())))
(ope)
(test* "value of register b" 1 (get-contents ((m 'get-register) 'reg 'b))))
(test* "undefined register"
*test-error*
(make-assign '(assign c (reg a))
m
'()
(m 'operations)
((m 'get-register) 'reg 'pc)))
(test* "undefined register"
*test-error*
(make-assign '(assign b (reg c))
m
'()
(m 'operations)
((m 'get-register) 'reg 'pc))))
(test-section "(assign <register-name> (const <constant-value>))")
(let ((m (make-new-machine)))
(for-each (lambda (register-name)
((m 'allocate-register) register-name))
'(a b t))
((m 'install-operations) (list (list 'rem remainder) (list '= =)))
(test* "undefined register"
*test-error*
(make-assign '(assign c (const 1))
m
'()
(m 'operations)
((m 'get-register) 'reg 'pc)))
(let ((ope (make-assign '(assign b (const 1))
m
'()
(m 'operations)
((m 'get-register) 'reg 'pc))))
(set-contents! ((m 'get-register) 'reg 'pc) '(() (gcd-done ())))
(ope)
(test* "value of register b" 1 (get-contents ((m 'get-register) 'reg 'b)))))
(test-section "(assign <register-name> (label <label-name>))")
(let ((m (make-new-machine)))
(for-each (lambda (register-name)
((m 'allocate-register) register-name))
'(a b t))
((m 'install-operations) (list (list 'rem remainder) (list '= =)))
(let ((ope (make-assign '(assign b (label gcd-done))
m
'((gcd-done . ()))
(m 'operations)
((m 'get-register) 'reg 'pc))))
(set-contents! ((m 'get-register) 'reg 'pc) '(() (gcd-done ())))
(ope)
(test* "value of register b" '() (get-contents ((m 'get-register) 'reg 'b)))
(test* "undefined register"
*test-error*
(make-assign '(assign d (label gcd-done))
m
'((gcd-done . ()))
(m 'operations)
((m 'get-register) 'reg 'pc))))
(test* "undefined label"
*test-error*
(make-assign '(assign b (label x))
m
'()
(m 'operations)
((m 'get-register) 'reg 'pc))))
(test-section "(assign <register-name> (op <operation-name>) <input1> ... <inputn>)")
(let ((m (make-new-machine)))
(for-each (lambda (register-name)
((m 'allocate-register) register-name))
'(a b t))
((m 'install-operations) (list (list 'rem remainder) (list '+ +)))
;; (assign b (op rem) (reg a) (label gcd-done)) ??
(let ((ope (make-assign '(assign a (op +) (reg t) (reg b))
m
'()
(m 'operations)
((m 'get-register) 'reg 'pc))))
(set-contents! ((m 'get-register) 'reg 'pc) '(() (gcd-done ())))
(set-contents! ((m 'get-register) 'reg 't) 3)
(set-contents! ((m 'get-register) 'reg 'b) 2)
(test* "value of register t" 3 (get-contents ((m 'get-register) 'reg 't)))
(test* "value of register b" 2 (get-contents ((m 'get-register) 'reg 'b)))
(test* "register a is null" '*unassigned* (get-contents ((m 'get-register) 'reg 'a)))
(ope)
(test* "value of register a" 5 (get-contents ((m 'get-register) 'reg 'a))))
(let ((ope (make-assign '(assign a (op rem) (reg a) (const 2))
m
'()
(m 'operations)
((m 'get-register) 'reg 'pc))))
(set-contents! ((m 'get-register) 'reg 'pc) '(() (gcd-done ())))
(set-contents! ((m 'get-register) 'reg 'a) 3)
(ope)
(test* "value of register a" 1 (get-contents ((m 'get-register) 'reg 'a))))
(let ((ope (make-assign '(assign a (op +) (const 1) (const 2) (const 3))
m
'()
(m 'operations)
((m 'get-register) 'reg 'pc))))
(set-contents! ((m 'get-register) 'reg 'pc) '(() (gcd-done ())))
(ope)
(test* "value of register a" 6 (get-contents ((m 'get-register) 'reg 'a))))
(test* "undefined register"
*test-error*
(make-assign '(assign d (op =) (reg a) (reg b))
m
'()
(m 'operations)
((m 'get-register) 'reg 'pc)))
(test* "undefined operation"
*test-error*
(make-assign '(assign b (op *) (reg a) (reg b))
m
'()
(m 'operations)
((m 'get-register) 'reg 'pc)))
(test* "undefined register"
*test-error*
(make-assign '(assign b (op rem) (reg d) (reg b))
m
'()
(m 'operations)
((m 'get-register) 'reg 'pc)))
(test* "undefined register"
*test-error*
(make-assign '(assign b (op rem) (reg a) (reg d))
m
'()
(m 'operations)
((m 'get-register) 'reg 'pc))))
(test-section "make-primitive (constant)")
(let ((m (make-new-machine)))
(let ((ope (make-primitive-exp '(const 2) m '())))
(test* "return constant value" 2 (ope))))
(test-section "make-primitive (labal)")
(let ((m (make-new-machine)))
(let ((ope (make-primitive-exp '(label gcd-done) m '((gcd-done . ())))))
(test* "return label value" '() (ope))
(test* "undefined label"
*test-error*
(make-primitive-exp '(label test)
m
'()))))
(test-section "make-primitive (register)")
(let ((m (make-new-machine)))
(for-each (lambda (register-name)
((m 'allocate-register) register-name))
'(a b t))
(set-contents! ((m 'get-register) 'reg 'a) 1)
(let ((ope (make-primitive-exp '(reg a) m '())))
(test* "return register value" 1 (ope))
(test* "undefined register"
*test-error*
(make-primitive-exp '(reg c)
m
'()))))
(test-section "make-operation-exp (+)")
(let ((m (make-new-machine)))
(for-each (lambda (register-name)
((m 'allocate-register) register-name))
'(a b t))
((m 'install-operations) (list (list 'rem remainder) (list '+ +)))
(set-contents! ((m 'get-register) 'reg 'a) 3)
(set-contents! ((m 'get-register) 'reg 'b) 2)
(let ((ope1 (make-operation-exp '((ope +) (const 1) (const 2))
m
'()
(m 'operations)))
(ope2 (make-operation-exp '((ope +) (const 1)
(const 2)
(const 3)
(const 4)
(const 5))
m
'()
(m 'operations)))
(ope3 (make-operation-exp '((ope +) (reg a) (reg b))
m
'()
(m 'operations))))
(test* "(+ 1 2)" 3 (ope1))
(test* "(+ 1 2 3 4 5)" 15 (ope2))
(test* "(+ a b)" 5 (ope3))
(test* "undefined operation"
*test-error*
(make-operation-exp '((ope *)
(const 2)
(const 3))
m
'()))
(test* "undefined register"
*test-error*
(make-operation-exp '((ope +)
(reg c)
(reg d))
m
'()))))
(test-section "lookup-prim")
(let ((m (make-new-machine)))
(for-each (lambda (register-name)
((m 'allocate-register) register-name))
'(a b t))
((m 'install-operations) (list (list 'rem remainder) (list '+ +)))
(test* "undefined ope" *test-error* (lookup-prim '* (m 'operations)))
(test* "apply +" 2 (apply (lookup-prim '+ (m 'operations)) '(1 1))))
(test-section "make-branch (error)")
(test* "invalid branch"
*test-error*
(make-branch '(branch (reg a)) '() '() '()))
(test-section "make-branch (flag is #t)")
(let ((m (make-new-machine))
(l '(test-b
(test (op =) (reg b) (const 0))
(branch (label gcd-done))
(assign t (op rem) (reg a) (reg b))
(assign a (reg b))
(assign b (reg t))
(goto (label test-b))
gcd-done)))
(extract-labels
l
(lambda (insts labels)
(set-contents! ((m 'get-register) 'reg 'flag) #t)
(let ((thunk (make-branch '(branch (label test-b))
m
labels
((m 'get-register) 'reg 'flag)
((m 'get-register) 'reg 'pc))))
(thunk)
(test* "branch"
'(test (op =) (reg b) (const 0))
(car (car (get-contents ((m 'get-register) 'reg 'pc)))))))))
(test-section "make-branch (flag is #f)")
(let ((m (make-new-machine))
(l '(test-b
(test (op =) (reg b) (const 0))
(branch (label gcd-done))
(assign t (op rem) (reg a) (reg b))
(assign a (reg b))
(assign b (reg t))
(goto (label test-b))
gcd-done)))
(extract-labels
l
(lambda (insts labels)
(set-contents! ((m 'get-register) 'reg 'flag) #f)
(set-contents! ((m 'get-register) 'reg 'pc) '(() (gcd-done ())))
(let ((thunk (make-branch '(branch (label test-b))
m
labels
((m 'get-register) 'reg 'flag)
((m 'get-register) 'reg 'pc))))
(thunk)
(test* "branch"
'gcd-done
(car (car (get-contents ((m 'get-register) 'reg 'pc)))))))))
(test-section "make-goto (error)")
(test* "cannot jmp"
*test-error*
(make-goto '(goto (op =))
'()
'()
'()))
(test* "cannot jmp"
*test-error*
(make-goto '(goto (const 2))
'()
'()
'()))
(test-section "make-goto (label)")
(let ((m (make-new-machine))
(l '(test-b
(test (op =) (reg b) (const 0))
(branch (label gcd-done))
(assign t (op rem) (reg a) (reg b))
(assign a (reg b))
(assign b (reg t))
(goto (label test-b))
gcd-done)))
(extract-labels
l
(lambda (insts labels)
(let ((thunk (make-goto '(goto (label test-b))
m
labels
((m 'get-register) 'reg 'pc))))
(thunk)
(test* "goto label"
'(test (op =) (reg b) (const 0))
(car (car (get-contents ((m 'get-register) 'reg 'pc)))))))))
(test-section "make-goto (register)")
(let ((m (make-new-machine))
(l '(test-b
(test (op =) (reg b) (const 0))
(branch (label gcd-done))
(assign t (op rem) (reg a) (reg b))
(assign a (reg b))
(assign b (reg t))
(goto (label test-b))
gcd-done)))
(for-each (lambda (register-name)
((m 'allocate-register) register-name))
'(a b t))
(extract-labels
l
(lambda (insts labels)
(let ((thunk (make-goto '(goto (reg a)) m labels ((m 'get-register) 'reg 'pc)))
(ope (make-assign '(assign a (label test-b))
m
labels
(m 'operations)
((m 'get-register) 'reg 'pc))))
(set-contents! ((m 'get-register) 'reg 'pc) '(() (gcd-done ())))
(ope)
(thunk)
(test* "goto register"
'(test (op =) (reg b) (const 0))
(car (car (get-contents ((m 'get-register) 'reg 'pc)))))))))
(test-section "make-save")
(let ((m (make-new-machine)))
(for-each (lambda (register-name)
((m 'allocate-register) register-name))
'(a b t))
(set-contents! ((m 'get-register) 'reg 'a) 1)
(let ((thunk (make-save '(save a)
m
((m 'get-register) 'reg 'pc))))
(test* "stack is null" *test-error* ((get-stack m 'a) 'pop))
(set-contents! ((m 'get-register) 'reg 'pc) '(() (gcd-done ())))
(thunk)
(test* "pc is gcd-done"
'()
(cadr (car (get-contents ((m 'get-register) 'reg 'pc)))))
(test* "pop from stack" 1 ((get-stack m 'a) 'pop))
(test* "stack is null" *test-error* ((get-stack m 'a) 'pop))
))
(test-section "make-restore")
(let ((m (make-new-machine)))
(for-each (lambda (register-name)
((m 'allocate-register) register-name))
'(a b t))
(set-contents! ((m 'get-register) 'reg 'a) 1)
(let ((push-thunk (make-save '(save a)
m
((m 'get-register) 'reg 'pc)))
(pop-thunk (make-restore '(restore b)
m
((m 'get-register) 'reg 'pc))))
(test* "stack is null"
*test-error*
((get-stack m 'a) 'pop))
(set-contents! ((m 'get-register) 'reg 'pc) '(() (gcd-done ())))
(push-thunk)
(test* "pc advanced"
'()
(cadr (car (get-contents ((m 'get-register) 'reg 'pc)))))
(set-contents! ((m 'get-register) 'reg 'pc) '(() (gcd-done ())))
(test* "stack b is null" *test-error* (pop-thunk))))
(test-section "make-machine")
(let ((m (make-machine '(a b t)
(list (list 'rem remainder) (list '= =))
'(test-b
(test (op =) (reg b) (const 0))
(branch (label gcd-done))
(assign t (op rem) (reg a) (reg b))
(assign a (reg b))
(assign b (reg t))
(goto (label test-b))
gcd-done))))
(test* "a" '*unassigned* (get-contents ((m 'get-register) 'reg 'a)))
(test* "b" '*unassigned* (get-contents ((m 'get-register) 'reg 'b)))
(test* "t" '*unassigned* (get-contents ((m 'get-register) 'reg 't)))
(test* "a" '*unassigned* (get-register-contents m 'a))
(test* "b" '*unassigned* (get-register-contents m 'b))
(test* "t" '*unassigned* (get-register-contents m 't))
(set-register-contents! m 'a 206)
(set-register-contents! m 'b 40)
(test* "a" 206 (get-register-contents m 'a))
(test* "b" 40 (get-register-contents m 'b))
(start m)
(test* "a" 2 (get-register-contents m 'a)))
(test-section "extract-labels (5.8)")
(let ((m (make-new-machine))
(l '(start
(goto (label here))
here
(assign a (const 3))
(goto (label there))
here
(assign a (const 4))
(goto (label there))
there)))
(for-each (lambda (register-name)
((m 'allocate-register) register-name))
'(a))
(test* "assemble error" *test-error* (assemble l m)))
(test-section "make-operation-exp (5.9)")
(let ((m (make-new-machine)))
((m 'install-operations) (list (list 'rem remainder) (list '+ +)))
(test* "use only reg & const" *test-error*
(make-operation-exp '((ope +) (label gcd-done) (const 2))
m
'((gcd-done . ()))
(m 'operations))))
(test-end)次は make-* な試験。
(use gauche.test)
(add-load-path ".")
(load "ch5-regsim")
(test-start "make-execution-procedure test")
(test-section "assign")
(let ((m (make-new-machine)))
(for-each (lambda (register-name)
((m 'allocate-register) register-name))
'(a b t))
((m 'install-operations) (list (list 'rem remainder) (list '= =)))
(set-contents! ((m 'get-register) 'reg 'a) 1)
(test* "a is 1" 1 (get-contents ((m 'get-register) 'reg 'a)))
(let ((thunk (make-execution-procedure
'(assign b (reg a))
'()
m
((m 'get-register) 'reg 'pc)
((m 'get-register) 'reg 'flag)
(m 'operations))))
(set-contents! ((m 'get-register) 'reg 'pc) '(() (gcd-done ())))
(thunk)
(test* "b is 1" 1 (get-contents ((m 'get-register) 'reg 'b)))))
(test-section "test (1)")
(let ((m (make-new-machine)))
(for-each (lambda (register-name)
((m 'allocate-register) register-name))
'(a b t))
((m 'install-operations) (list (list 'rem remainder) (list '= =)))
(let ((thunk (make-test '(test (op =) (const 1) (const 1))
m
'()
(m 'operations)
((m 'get-register) 'reg 'flag)
((m 'get-register) 'reg 'pc))))
(set-contents! ((m 'get-register) 'reg 'pc) '(() (gcd-done ())))
(thunk)
(test* "true" #t (get-contents ((m 'get-register) 'reg 'flag)))))
(test-section "test (2)")
(let ((m (make-new-machine)))
(for-each (lambda (register-name)
((m 'allocate-register) register-name))
'(a b t))
((m 'install-operations) (list (list 'rem remainder) (list '= =)))
(let ((thunk (make-execution-procedure
'(test (op =) (const 1) (const 1))
'()
m
((m 'get-register) 'reg 'pc)
((m 'get-register) 'reg 'flag)
(m 'operations))))
(set-contents! ((m 'get-register) 'reg 'pc) '(() (gcd-done ())))
(thunk)
(test* "true" #t (get-contents ((m 'get-register) 'reg 'flag)))))
(test-section "goto label")
(let ((m (make-new-machine))
(l '(test-b
(test (op =) (reg b) (const 0))
(branch (label gcd-done))
(assign t (op rem) (reg a) (reg b))
(assign a (reg b))
(assign b (reg t))
(goto (label test-b))
gcd-done)))
(extract-labels
l
(lambda (insts labels)
(let ((thunk (make-execution-procedure
'(goto (label test-b))
labels
m
((m 'get-register) 'reg 'pc)
((m 'get-register) 'reg 'flag)
(m 'operations))))
(thunk)
(test* "goto test-b" '(test (op =) (reg b) (const 0))
(car (car (get-contents ((m 'get-register) 'reg 'pc)))))))))
(test-section "save")
(let ((m (make-new-machine)))
(for-each (lambda (register-name)
((m 'allocate-register) register-name))
'(a b t))
(set-contents! ((m 'get-register) 'reg 'a) 1)
(let ((thunk (make-execution-procedure
'(save a)
'()
m
((m 'get-register) 'reg 'pc)
((m 'get-register) 'reg 'flag)
(m 'operations))))
(test* "stack is empty" *test-error* ((m 'stack) 'pop))
(set-contents! ((m 'get-register) 'reg 'pc) '(() (gcd-done ())))
(thunk)
(test* "pc is null"
'()
(cadr (car (get-contents ((m 'get-register) 'reg 'pc)))))
(test* "pop" 1 ((get-stack m 'a) 'pop))
(test* "stack is null" *test-error* ((get-stack m 'a) 'pop))))
(test-section "restore")
(let ((m (make-new-machine)))
(for-each (lambda (register-name)
((m 'allocate-register) register-name))
'(a b t))
(set-contents! ((m 'get-register) 'reg 'a) 1)
(let ((push-thunk (make-save '(save a)
m
; (m 'stack)
((m 'get-register) 'reg 'pc)))
(pop-thunk (make-execution-procedure
'(restore b)
'()
m
((m 'get-register) 'reg 'pc)
((m 'get-register) 'reg 'flag)
(m 'operations))))
(test* "stack is empty" *test-error* ((get-stack m 'b) 'pop))
(set-contents! ((m 'get-register) 'reg 'pc) '(() (gcd-done ())))
(push-thunk)
(test* "pc is ()" '() (cadr (car (get-contents ((m 'get-register) 'reg 'pc)))))
(set-contents! ((m 'get-register) 'reg 'pc) '(() (gcd-done ())))
(test* "stack is empty" *test-error* ((get-stack m 'b) 'pop))))
(test-end)次が 5.11-c な試験
(use gauche.test)
(add-load-path ".")
(load "ch5-regsim")
(test-start "5.11-c")
(test-section "make-new-machine")
(let ((m (make-new-machine)))
(for-each (lambda (register-name)
((m 'allocate-register) register-name))
'(a b))
(test* "register a allocated"
'*unassigned*
(get-contents (get-register m 'a)))
(test* "register b allocated"
'*unassigned*
(get-contents (get-register m 'b)))
(test* "stack a allocated" #t (not (null? (get-stack m 'a))))
(test* "stack b allocated" #t (not (null? (get-stack m 'b))))
(test* "stack a is null" *test-error* ((get-stack m 'a) 'pop))
(test* "stack b is null" *test-error* ((get-stack m 'b) 'pop))
(let ((push-a-thunk (make-save '(save a)
m
((m 'get-register) 'reg 'pc)))
(pop-a-thunk (make-restore '(restore a)
m
((m 'get-register) 'reg 'pc)))
(push-b-thunk (make-save '(save b)
m
((m 'get-register) 'reg 'pc)))
(pop-b-thunk (make-restore '(restore b)
m
((m 'get-register) 'reg 'pc))))
(define (test-init)
(set-contents! (get-register m 'a) 1)
(set-contents! (get-register m 'b) 2)
(set-contents! (get-register m 'pc) '(() (gcd-done ())))
(push-a-thunk)
(set-contents! (get-register m 'pc) '(() (gcd-done ())))
(push-b-thunk)
(set-contents! (get-register m 'a) 9)
(set-contents! (get-register m 'b) 8)
(test* "a" 9 (get-contents (get-register m 'a)))
(test* "b" 8 (get-contents (get-register m 'b))))
(test-init)
(set-contents! (get-register m 'pc) '(() (gcd-done ())))
(pop-b-thunk)
(test* "pop b" 2 (get-contents (get-register m 'b)))
(set-contents! (get-register m 'pc) '(() (gcd-done ())))
(pop-a-thunk)
(test* "pop a" 1 (get-contents (get-register m 'a)))
(test* "stack a is null" *test-error* (pop-a-thunk))
(test* "stack b is null" *test-error* (pop-b-thunk))
(test-init)
(set-contents! (get-register m 'pc) '(() (gcd-done ())))
(pop-a-thunk)
(test* "pop a" 1 (get-contents (get-register m 'a)))
(set-contents! (get-register m 'pc) '(() (gcd-done ())))
(pop-b-thunk)
(test* "pop b" 2 (get-contents (get-register m 'b)))
(test* "stack a is null" *test-error* (pop-a-thunk))
(test* "stack b is null" *test-error* (pop-b-thunk))
)
)
(test-end)次の 5.12 の設問の意味が理解できてません。書いてある通りにヤッてみれば良いのかなぁ。データパスというのは 294p とか 296p とかのソレなのでしょうか。
