SICP 読み (366) 5.5 翻訳系

ついに回数が 1 年分の日数を超えてしまった。全然先は見えん。

問題 5.50

ええと、問題 5.19 なディレクトリで ut 動かしてみたら試験失敗って (を
なんか微妙だなぁ。

つづき

稼動空きが微妙に減っています。ばたばた状態。昨晩のダメージがまだ残っていたりなんかするんですが一応試験が失敗する理由は判明。
問題 5.19 では単体試験を実施していない模様。何故だ。(272) なエントリが問題 5.19 な取り組みなはずなんですが、動作の確認が試験ベースになってない。とりあえず今日は早めに帰宅予定なので試験を作ってリハビリ予定。しかも以前のエントリを検索してて、問題 5.26 でも 5.19 なデバッガ(??)使って動作を見ている模様。

帰宅後

ch5-regsim.scm の試験をこつこつ作成中。パスしてない部分を順に直していく事に。
まず、

<make-instruction>-------------------------------------------------------------
test return (1 ()), expects (1) ==> ERROR: GOT ((() . 1))

から。試験は以下

(test-section "make-instruction")
(test* "return (1 ())" '(1) (make-instruction 1))

実装はこうなっております

(define (make-instruction text)
  (cons (cons '() text) '()))

breakpoint をラベルと行番号でナニするとゆー事でラベル + 行番号なリストと命令を cons してるとゆー事は試験としてはこうか

(test-section "make-instruction")
(test* "return (1 ())" '((() 1)) (make-instruction 1))

あ、違った。こうだ。

(test-section "make-instruction")
(test* "return (1 ())" '((() . 1)) (make-instruction 1))

パス。次は

<instruction-text>-------------------------------------------------------------
test return car, expects 1 ==> ERROR: GOT #<error "pair required, but got 1">

なんですが以下が試験。

(test-section "instruction-text")
(test* "return car" 1 (instruction-text '(1 2)))

instruction-text の定義は以下

(define (instruction-text inst)
  (cdr (car inst)))

うん。確かにこうなってないとマズいな。てーコトは試験は以下か

(test-section "instruction-text")
(test* "return car" 1 (instruction-text '((() . 1) 2)))

パス。次は以下

<label>------------------------------------------------------------------------
test 1st labels name, expects test-b ==> ok
test 1st labels value, expects (((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)))) 
==> ERROR: GOT ((((test-b 1) test (op =) (reg b) (const 0))) 
		(((test-b 2) branch (label gcd-done))) 
		(((test-b 3) assign t (op rem) (reg a) (reg b))) 
		(((test-b 4) assign a (reg b))) 
		(((test-b 5) assign b (reg t))) 
		(((test-b 6) goto (label test-b))))
test 2nd labels name, expects gcd-done ==> ok
test 2nd labels value, expects () ==> ok

まぁそりゃそうだわな。既存な試験は以下

(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))))))

ちょい長い。これは何をしてるのか。extract-labels って懐しいな。上記の試験はラベル限定なんでそっち限定で確認しておくと、extract-labels に渡す手続き (receive) は命令のリストとラベルのリストを受け取るのですが、receive が受け取る labels な引数に設定されるのは

(define (make-label-entry label-name insts)
  (cons label-name insts))

なリストになる。insts はラベル以降に存在する命令になる。確かこれで jmp を実現していたはず。で、上記の insts な引数で渡されるリストは

((label counter) . (instruction-text inst))

みたいなリストが要素になっている、という事か。なので上記のダウトな試験は

     (test* "1st labels value" 
	    '((((test-b 1) test (op =) (reg b) (const 0)))
	      (((test-b 2) branch (label gcd-done)))
	      (((test-b 3) assign t (op rem) (reg a) (reg b)))
	      (((test-b 4) assign a (reg b)))
	      (((test-b 5) assign b (reg t)))
	      (((test-b 6) goto (label test-b))))
	    (cdr (car labels)))

となっているべき、なのかな。試験はこれでパス。一つめのソレは残り三つ。次は

<make-branch (flag is #t)>-----------------------------------------------------
test branch, expects (test (op =) (reg b) (const 0)) 
==> ERROR: GOT ((test-b 1) test (op =) (reg b) (const 0))

これはどんな試験を書いとるか、とゆーと

(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) 'flag) #t)
     (let ((thunk (make-branch '(branch (label test-b))
			       m
			       labels
			       ((m 'get-register) 'flag)
			       ((m 'get-register) 'pc))))
       (thunk)
       (test* "branch" 
	      '(test (op =) (reg b) (const 0))
	      (car (car (get-contents ((m 'get-register) 'pc)))))))))

これはまたえらい手間かかっとりますが要は branch がきちんと動いてるかどうかを確認している訳ですか。make-branch が戻す手続きは flag が #t だったら pc に branch で指定されたラベルな命令をセットするのか。
で、labels に設定されているリストは上記の通り、ラベルとそのラベル内の順番なソレが追加されておりますので pc にセットされておるのは

((test-b 1) test (op =) (reg b) (const 0))

になるんかな。試験はパス。次の NG は

<make-goto (label)>------------------------------------------------------------
test goto label, expects (test (op =) (reg b) (const 0)) 
==> ERROR: GOT ((test-b 1) test (op =) (reg b) (const 0))

試験は以下。

(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) 'pc))))
       (thunk)
       (test* "goto label"
	      '(test (op =) (reg b) (const 0))
	      (car (car (get-contents ((m 'get-register) 'pc)))))))))

test いっこしかないのにやたらに長い。これも同じですね。

((test-b 1) test (op =) (reg b) (const 0))

かどうかを確認すれば良いはず。次は以下

<make-goto (register)>---------------------------------------------------------
test goto register, expects (test (op =) (reg b) (const 0)) 
==> ERROR: GOT ((test-b 1) test (op =) (reg b) (const 0))

これも同様。これで全部パス。次は他の試験ですが、これは残り一つです。

<goto label>-------------------------------------------------------------------
test goto test-b, expects (test (op =) (reg b) (const 0)) 
==> ERROR: GOT ((test-b 1) test (op =) (reg b) (const 0))

試験は以下

(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) 'pc)
		((m 'get-register) 'flag)
		(m 'stack)
		(m 'operations))))
    (set-contents! ((m 'get-register) 'pc) '(() (gcd-done ())))
    (thunk)
    (test* "true" #t (get-contents ((m 'get-register) 'flag)))))

これは何を確認しているのか、というと何だろ。条件式 (= 1 1) を評価して flag に #t が入ってれば OK ってコト??
し、しまった。見てる試験が違うぞ。(を
正しくは以下か。

(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) 'pc)
		   ((m 'get-register) 'flag)
		   (m 'stack)
		   (m 'operations))))
       (thunk)
       (test* "goto test-b" '(test (op =) (reg b) (const 0))
	      (car (car (get-contents ((m 'get-register) 'pc)))))))))

ええと (goto (label test-b)) して pc に正しい値が入っているか、か。これも同じと言えば同じです。

       (test* "goto test-b" 
	      '((test-b 1) test (op =) (reg b) (const 0))
	      (car (car (get-contents ((m 'get-register) 'pc)))))))))

で良いか。これで既存な試験は全部パス。

$ make
Testing 5.2.1 ...                                                passed.
Testing ch5-syntax ...                                           passed.
Testing make-execution-procedure test ...                        passed.
$

おそらく全部カバーできていないと見ています。ツール作れりゃ良いのでしょうが、

$ grep '^(define' ch5-regsim.scm

をなんとか整形して手続きの名前が取り出せてもねぇ。カバー具合は目視で見るか。とりあえず問題 5.19 な ch5-regsim.scm な試験は現時点で以下。

test-make-execution-procedure.scm

(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) 'a) 1)
  (test* "a is 1" 1 (get-contents ((m 'get-register) 'a)))
  (let ((thunk (make-execution-procedure
		'(assign b (reg a))
		'()
		m
		((m 'get-register) 'pc)
		((m 'get-register) 'flag)
		(m 'stack)
		(m 'operations))))
    (set-contents! ((m 'get-register) 'pc) '(() (gcd-done ())))
    (thunk)
    (test* "b is 1" 1 (get-contents ((m 'get-register) '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) 'flag)
			  ((m 'get-register) 'pc))))
    (set-contents! ((m 'get-register) 'pc) '(() (gcd-done ())))
    (thunk)
    (test* "true" #t (get-contents ((m 'get-register) '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) 'pc)
		((m 'get-register) 'flag)
		(m 'stack)
		(m 'operations))))
    (set-contents! ((m 'get-register) 'pc) '(() (gcd-done ())))
    (thunk)
    (test* "true" #t (get-contents ((m 'get-register) '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) 'pc)
		   ((m 'get-register) 'flag)
		   (m 'stack)
		   (m 'operations))))
       (thunk)
       (test* "goto test-b" 
	      '((test-b 1) test (op =) (reg b) (const 0))
	      (car (car (get-contents ((m 'get-register) '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) 'a) 1)
     (let ((thunk (make-execution-procedure
		   '(save a)
		   '()
		   m
		   ((m 'get-register) 'pc)
		   ((m 'get-register) 'flag)
		   (m 'stack)
		   (m 'operations))))
       (test* "stack is empty" *test-error* ((m 'stack) 'pop))
       (set-contents! ((m 'get-register) 'pc) '(() (gcd-done ())))
       (thunk)
       (test* "pc is null" 
	      '() 
	      (cadr (car (get-contents ((m 'get-register) 'pc)))))
       (test* "pop" 1 ((m 'stack) 'pop))
       (test* "stack is null" *test-error* ((m 'stack) '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) 'a) 1)
  (let ((push-thunk (make-save '(save a)
			       m
			       (m 'stack)
			       ((m 'get-register) 'pc)))
	(pop-thunk (make-execution-procedure
		   '(restore b)
		   '()
		   m
		   ((m 'get-register) 'pc)
		   ((m 'get-register) 'flag)
		   (m 'stack)
		   (m 'operations))))
    (test* "stack is empty" *test-error* ((m 'stack) 'pop))
    (set-contents! ((m 'get-register) 'pc) '(() (gcd-done ())))
    (push-thunk)
    (test* "pc is ()" '() (cadr (car (get-contents ((m 'get-register) 'pc)))))
    (set-contents! ((m 'get-register) 'pc) '(() (gcd-done ())))
    (pop-thunk)
    (test* "b is 1" 1 (get-contents ((m 'get-register) 'b)))
    (test* "stack is empty" *test-error* ((m 'stack) 'pop))))

(test-end)

test-ch5-regsim.scm

(use gauche.test)

(add-load-path ".")
(load "ch5-regsim")

(test-start "5.2.1")

(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) 'pc) 'get))
  (test* "pc register is null" 
	 '*unassigned* 
	 (get-contents ((m 'get-register) 'pc)))
  (test* "flag register is null" 
	 '*unassigned* 
	 (((m 'get-register) 'flag) 'get))
  (test* "flag register is null" 
	 '*unassigned* 
	 (get-contents ((m 'get-register) '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) 'a)))
  (test* "register b is null"
	 '*unassigned* 
	 (get-contents ((m 'get-register) 'b)))
  (test* "register t is null"
	 '*unassigned* 
	 (get-contents ((m 'get-register) 't)))

  (test* "stack is null" *test-error* ((m 'stack) 'pop))
  (test* "stack is null" *test-error* (pop (m 'stack)))

  (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-b 1) test (op =) (reg b) (const 0)))
	      (((test-b 2) branch (label gcd-done)))
	      (((test-b 3) assign t (op rem) (reg a) (reg b)))
	      (((test-b 4) assign a (reg b)))
	      (((test-b 5) assign b (reg t)))
	      (((test-b 6) 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) 'a) 1)
  (test* "value of register a" 1 (get-contents ((m 'get-register) 'a)))
  (let ((ope (make-assign '(assign b (reg a)) m '() (m 'operations)
			  ((m 'get-register) 'pc))))
    (set-contents! ((m 'get-register) 'pc) '(() (gcd-done ())))
    (ope)
    (test* "value of register b" 1 (get-contents ((m 'get-register) 'b))))

  (test* "undefined register" 
	 *test-error* 
	 (make-assign '(assign c (reg a))
		      m
		      '()
		      (m 'operations)
		      ((m 'get-register) 'pc)))
  (test* "undefined register" 
	 *test-error*
	 (make-assign '(assign b (reg c))
		      m
		      '()
		      (m 'operations)
		      ((m 'get-register) '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) 'pc)))
  (let ((ope (make-assign '(assign b (const 1))
			  m
			  '()
			  (m 'operations)
			  ((m 'get-register) 'pc))))
    (set-contents! ((m 'get-register) 'pc) '(() (gcd-done ())))
    (ope)
    (test* "value of register b" 1 (get-contents ((m 'get-register) '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) 'pc))))
    (set-contents! ((m 'get-register) 'pc) '(() (gcd-done ())))
    (ope)
    (test* "value of register b" '() (get-contents ((m 'get-register) 'b)))
    (test* "undefined register"
	   *test-error*
	   (make-assign '(assign d (label gcd-done))
			m
			'((gcd-done . ()))
			(m 'operations)
			((m 'get-register) 'pc))))

  (test* "undefined label"
	 *test-error*
	 (make-assign '(assign b (label x))
		      m
		      '()
		      (m 'operations)
		      ((m 'get-register) '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) 'pc))))
    (set-contents! ((m 'get-register) 'pc) '(() (gcd-done ())))
    (set-contents! ((m 'get-register) 't) 3)
    (set-contents! ((m 'get-register) 'b) 2)
    (test* "value of register t" 3 (get-contents ((m 'get-register) 't)))
    (test* "value of register b" 2 (get-contents ((m 'get-register) 'b)))
    (test* "register a is null" '*unassigned* (get-contents ((m 'get-register) 'a)))
    (ope)
    (test* "value of register a" 5 (get-contents ((m 'get-register) 'a))))

  (let ((ope (make-assign '(assign a (op rem) (reg a) (const 2))
			  m
			  '()
			  (m 'operations)
			  ((m 'get-register) 'pc))))
    (set-contents! ((m 'get-register) 'pc) '(() (gcd-done ())))
    (set-contents! ((m 'get-register) 'a) 3)
    (ope)
    (test* "value of register a" 1 (get-contents ((m 'get-register) 'a))))

  (let ((ope (make-assign '(assign a (op +) (const 1) (const 2) (const 3))
			  m
			  '()
			  (m 'operations)
			  ((m 'get-register) 'pc))))
    (set-contents! ((m 'get-register) 'pc) '(() (gcd-done ())))
    (ope)
    (test* "value of register a" 6 (get-contents ((m 'get-register) 'a))))

  (test* "undefined register"
	 *test-error*
	 (make-assign '(assign d (op =) (reg a) (reg b))
		      m
		      '()
		      (m 'operations)
		      ((m 'get-register) 'pc)))
  (test* "undefined operation"
	 *test-error*
	 (make-assign '(assign b (op *) (reg a) (reg b))
		      m
		      '()
		      (m 'operations)
		      ((m 'get-register) 'pc)))
  (test* "undefined register"
	 *test-error*
	 (make-assign '(assign b (op rem) (reg d) (reg b))
		      m
		      '()
		      (m 'operations)
		      ((m 'get-register) 'pc)))
  (test* "undefined register"
	 *test-error*
	 (make-assign '(assign b (op rem) (reg a) (reg d))
		      m
		      '()
		      (m 'operations)
		      ((m 'get-register) '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) '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) 'a) 3)
  (set-contents! ((m 'get-register) '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) 'flag) #t)
     (let ((thunk (make-branch '(branch (label test-b))
			       m
			       labels
			       ((m 'get-register) 'flag)
			       ((m 'get-register) 'pc))))
       (thunk)
       (test* "branch" 
	      '((test-b 1) test (op =) (reg b) (const 0))
	      (car (car (get-contents ((m 'get-register) '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) 'flag) #f)
     (set-contents! ((m 'get-register) 'pc) '(() (gcd-done ())))
     (let ((thunk (make-branch '(branch (label test-b))
			       m
			       labels
			       ((m 'get-register) 'flag)
			       ((m 'get-register) 'pc))))
       (thunk)
       (test* "branch"
	      'gcd-done
	      (car (car (get-contents ((m 'get-register) '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) 'pc))))
       (thunk)
       (test* "goto label"
	      '((test-b 1) test (op =) (reg b) (const 0))
	      (car (car (get-contents ((m 'get-register) '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) 'pc)))
	   (ope (make-assign '(assign a (label test-b))
			     m
			     labels
			     (m 'operations)
			     ((m 'get-register) 'pc))))
       (set-contents! ((m 'get-register) 'pc) '(() (gcd-done ())))
       (ope)
       (thunk)
       (test* "goto register"
	      '((test-b 1) test (op =) (reg b) (const 0))
	      (car (car (get-contents ((m 'get-register) '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) 'a) 1)
  (let ((thunk (make-save '(save a)
			  m
			  (m 'stack)
			  ((m 'get-register) 'pc))))
    (test* "stack is null" *test-error* ((m 'stack) 'pop))
    (set-contents! ((m 'get-register) 'pc) '(() (gcd-done ())))
    (thunk)
    (test* "pc is gcd-done" 
	   '() 
	   (cadr (car (get-contents ((m 'get-register) 'pc)))))
    (test* "pop from stack" 1 ((m 'stack) 'pop))
    (test* "stack is null" *test-error* ((m 'stack) '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) 'a) 1)
  (let ((push-thunk (make-save '(save a)
			       m
			       (m 'stack)
			       ((m 'get-register) 'pc)))
	(pop-thunk (make-restore '(restore b)
				 m
				 (m 'stack)
				 ((m 'get-register) 'pc))))
    (test* "stack is null"
	   *test-error*
	   ((m 'stack) 'pop))
    (set-contents! ((m 'get-register) 'pc) '(() (gcd-done ())))
    (push-thunk)
    (test* "pc advanced" 
	   '() 
	   (cadr (car (get-contents ((m 'get-register) 'pc)))))
    (set-contents! ((m 'get-register) 'pc) '(() (gcd-done ())))
    (pop-thunk)
    (test* "value of register b" 1 (get-contents ((m 'get-register) 'b)))
    (test* "stack is null" *test-error* ((m 'stack) 'pop))))

(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) 'a)))
  (test* "b" '*unassigned* (get-contents ((m 'get-register) 'b)))
  (test* "t" '*unassigned* (get-contents ((m 'get-register) '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-end)

test-ch5-syntax.scm

(use gauche.test)

(add-load-path ".")
(load "load-eceval-compiler.scm")
(load "ch5-compiler.scm")
(define true #t)
(define false #f)

(test-start "ch5-syntax")

(test-section "self-evaluating?")
(test* "(self-evaluating? number) returns true" 
       true (self-evaluating? 1))
(test* "(self-evaluating? string) returns true" 
       true (self-evaluating? "a"))
(test* "(self-evaluating? symbol) returns false" 
       false (self-evaluating? 'a))

(test-section "tagged-list?")
(test* "exp isn't list" 
       false (tagged-list? 'a 'b))
(test* "match"
       true (tagged-list? '(a b) 'a))
(test* "unmatch"
       false (tagged-list? '(a b) 'b))

(test-section "quoted?")
(test* "(quote a) is quoted"
       true (quoted? '(quote a)))
(test* "'a is not quoted"
       false (quoted? '('a)))
(test* "(a b) is not quoted"
       false (quoted? '(a b)))

(test-section "text-of-quotation")
(test* "text-of-quotation returns cadr"
       'b (text-of-quotation '(a b)))

(test-section "variable?")
(test* "x is variable"
       true (variable? 'x))
(test* "1 is not variable"
       false (variable? 1))

(test-section "assignment?")
(test* "(assignment? '(set!) returns true"
       true (assignment? '(set!)))
(test* "(assignment? '(lambda (x) x) returns false"
       false (assignment? '(lambda (x) x)))

(test-section "assignment-variable")
(test* "assignment-variable returns cadr value"
       'x (assignment-variable '(set! x y)))

(test-section "assignment-value")
(test* "assignment-value returns caddr value"
       '(+ 1 2) (assignment-value '(set! x (+ 1 2))))

(test-section "definition?")
(test* "(define) is definition exp"
       true (definition? '(define)))
(test* "(set!) is not definition exp"
       false (definition? '(set!)))

(test-section "definition-variable")
(test* "definition-variable returns cadr value if exp is symbol"
       'x (definition-variable '(define x 1)))
(test* "definition-variable returns caadr value if exp is not symbol"
       'x (definition-variable '(define (x y) y)))

(test-section "definition-value")
(test* "definition-value returns caddr value if exp is symbol"
       1 (definition-value '(define x 1)))
(test* "definition-value returns lambda-exp if exp is not symbol"
       '(lambda (y) y) (definition-value '(define (x y) y)))

(test-section "lambda?")
(test* "(lambda) is lambda exp"
       true (lambda? '(lambda)))
(test* "(define) is not lambda exp"
       false (lambda? '(define)))

(test-section "lambda-parameters")
(test* "lambda-parameters returns cadr value"
       '(y) (lambda-parameters '(lambda (y) y)))

(test-section "lambda-body")
(test* "lambda-body returns cddr value"
       '(y) (lambda-body '(lambda (y) y)))

(test-section "make-lambda")
(let ((lambda-exp '(lambda (y) y)))
  (test* "make-lambda returns '(lambda (parameters . body))"
	 lambda-exp (make-lambda (lambda-parameters lambda-exp)
				 (lambda-body lambda-exp))))

(test-section "if?")
(test* "(if) is if exp"
       true (if? '(if)))
(test* "(lambda) is not if exp"
       false (if? '(lambda)))

(test-section "if-predicate")
(test* "if-predicate returns cadr value"
       '(= x 1) (if-predicate '(if (= x 1) x)))

(test-section "if-consequent")
(test* "if-consequent returns cadr value"
       'x (if-consequent '(if (= x 1) x)))

(test-section "if-alternative")
(test* "if-alternative returns caddr value"
       'y (if-alternative '(if (= x 1) x y)))

(test-section "begin?")
(test* "(begin) is begin exp"
       true (begin? '(begin)))
(test* "(if) is not begin exp"
       false (begin? '(if)))

(test-section "begin-actions")
(test* "begin-actions returns cdr value"
       '(b c) (begin-actions '(a b c)))

(test-section "last-exp?")
(test* "'(a) is last-exp"
       true (last-exp? '(a)))
(test* "'(a b) is not last-exp"
       false (last-exp? '(a b)))

(test-section "first-exp")
(test* "first-exp returns car value"
       'a (first-exp '(a b c)))

(test-section "rest-exps")
(test* "rest-exps returns cdr value"
       '(b c) (rest-exps '(a b c)))

(test-section "application?")
(test* "(a b) is application exp"
       true (application? '(a b)))
(test* "(a) is application exp"
       true (application? '(a)))
(test* "1 is not application exp"
       false (application? 1))

(test-section "operator")
(test* "operator returns car value"
       'a (operator '(a b c)))

(test-section "operands")
(test* "operands returns cdr value"
       '(b c) (operands '(a b c)))

(test-section "no-operands?")
(test* "'() is no-operands exp"
       true (no-operands? '()))
(test* "'(a) is not no-operands exp"
       false (no-operands? '(a)))

(test-section "first-operand")
(test* "first-operand returns car value"
       'a (first-operand '(a b c)))

(test-section "rest-operands")
(test* "rest-operands returns cdr value"
       '(b c) (rest-operands '(a b c)))

(test-section "make-if")
(test* "make-if returns (if predicate consequent alternative)"
       '(if pred conseq alter) (make-if 'pred 'conseq 'alter))

(test-section "sequence->exp")
(test* "sequence->exp returns '() if seq is null"
       '() (sequence->exp '()))
(test* "sequence->exp returns a if seq is (a)"
       'a (sequence->exp '(a)))
(test* "sequence->exp returns (begin a b) if seq is (a b)"
       '(begin a b) (sequence->exp '(a b)))

(test-section "make-begin")
(test* "make-begin returns (begin . seq)"
       '(begin a b) (make-begin '(a b)))

(test-section "cond?")
(test* "(cond) is cond exp"
       true (cond? '(cond)))
(test* "(a) is not cond exp"
       false (cond? '(a)))

(test-section "cond-clauses")
(test* "cond-clauses returns cdr value"
       '(b) (cond-clauses '(a b)))
(test* "cond-clauses returns cdr value"
       '(((null? l) '()) (else (cdr l))) (cond-clauses '(cond ((null? l) '())
							      (else (cdr l)))))

(test-section "cond-else-clause?")
(let ((l '(cond ((null? l) '())
		(else (cdr l)))))
  (test* "((null? l) '()) is not cond-else-clause"
	 false (cond-else-clause? (car (cond-clauses l))))
  (test* "(else (cdr l)) is cond-else-clause"
	 true (cond-else-clause? (cadr (cond-clauses l)))))

(test-section "cond-predicate")
(let ((l '(cond ((null? l) '())
		(else (cdr l)))))
  (test* "cond-predicate returns car value"
	 '(null? l) (cond-predicate (car (cond-clauses l)))))

(test-section "cond-actions")
(let ((l '(cond ((null? l) '())
		(else (cdr l)))))
  (test* "cond-actions returns cdr value"
	 '((cdr l)) (cond-actions (cadr (cond-clauses l)))))

(test-section "expand-clauses")
(let ((l '(cond ((null? seq) seq)
		((last-exp? seq) (first-exp seq))
		(else (make-begin seq))))
      (err-cond '(cond ((null? seq) seq)
		       (else (make-begin seq))
		       ((last-exp? seq) (first-exp seq))))
      (no-else-l '(cond ((null? seq) seq)
			((last-exp? seq) (first-exp seq)))))
  (test* "else has to be last"
	 *test-error* (expand-clauses (cond-clauses error-cond)))
  (test* "expand-clauses returns false if clauses is '()"
	 'false (expand-clauses '()))
  (test* "expand-clauses returns if exp"
	 '(if (null? seq)
	      seq
	      (if (last-exp? seq)
		  (first-exp seq)
		  (make-begin seq)))
	 (expand-clauses (cond-clauses l)))
  (test* "expand-clauses returns if exp (no else)"
	 '(if (null? seq)
	      seq
	      (if (last-exp? seq)
		  (first-exp seq)
		  false))
	 (expand-clauses (cond-clauses no-else-l)))
  )

(test-section "cond->if")
(let ((l '(cond ((null? seq) seq)
		((last-exp? seq) (first-exp seq))
		(else (make-begin seq))))
      (err-cond '(cond ((null? seq) seq)
		       (else (make-begin seq))
		       ((last-exp? seq) (first-exp seq))))
      (no-else-l '(cond ((null? seq) seq)
			((last-exp? seq) (first-exp seq)))))
  (test* "else has to be last"
	 *test-error* (cond->if error-cond))
  (test* "expand-clauses returns if exp"
	 '(if (null? seq)
	      seq
	      (if (last-exp? seq)
		  (first-exp seq)
		  (make-begin seq)))
	 (cond->if l))
  (test* "expand-clauses returns if exp (no else)"
	 '(if (null? seq)
	      seq
	      (if (last-exp? seq)
		  (first-exp seq)
		  false))	
 (cond->if no-else-l))
  )

(test-end)

元気があればカバー率を見てみます。