SICP 読み (152) 4.1.4 評価器をプログラムとして走らせる

Exercise をスルーして 4.1.3 と 4.1.4 の手続きを一通りなぞってみる。述語の試験はとりあえずパス。ヤッツケにならないように進めたい。

procedure

procedure のコンストラクタとセレクタの試験が以下。

 ("procedure"
  ("make-procedure"
   (assert-equal '(procedure (a b) ((+ a b)) ())
                 (make-procedure '(a b) '((+ a b)) '()))
   )

  ("tagged-list?"
   (assert-true (compound-procedure? '(procedure)))
   (assert-true (not (compound-procedure? '(a))))
   )

  ("selector"
   (let ((l (make-procedure '(a b) '((+ a b)) '())))
     (assert-equal '(a b) (procedure-parameters l))
     (assert-equal '((+ a b)) (procedure-body l))
     (assert-equal '() (procedure-environment l))
     )
   )
  )

environment

新しい環境はリストの先頭に追加されていくのだろうか。

 ("environment"
  ("selector"
   (let ((l '(1 2 3 4)))
     (assert-equal 1 (first-frame l))
     (assert-equal '(2 3 4) (enclosing-environment l))
     (assert-equal '() the-empty-environment)
     )
   )
  )

frame

フレームの構成はなんか微妙。どうやって束縛を解決するのか。

 ("frame"
  ("constructor"
   (let ((l '((a b c) 1 2 3)))
     (assert-equal l (make-frame '(a b c) '(1 2 3)))
     )
   )

  ("selector"
   (let ((l (make-frame '(a b c) '(1 2 3))))
     (assert-equal '(a b c) (frame-variables l))
     (assert-equal '(1 2 3) (frame-values l))
     )
   )

  ("add-bind"
   (let ((before (make-frame '(a b c) '(1 2 3)))
         (after (make-frame '(d a b c) '(4 1 2 3))))
     (assert-equal '((a b c) 1 2 3) before)
     (add-binding-to-frame! 'd '4 before)
     (assert-equal after before)
     )
   )
  )

環境の拡張

手続きを見るに、拡張な手続きは変数のリストと値のリストを受け取って作ったフレームをリストの先頭に据えるらしい。

 ("extend-environment"
  ("normal"
   (let ((init-env '())
         (f1 (make-frame '(a b c) '(1 2 3)))
         (f2 (make-frame '(d e f) '(4 5 6))))
     (assert-equal the-empty-environment init-env)
     (assert-equal '(((a b c) 1 2 3))
                   (extend-environment (frame-variables f1)
                                       (frame-values f1)
                                       init-env))
     (let ((e1 (extend-environment (frame-variables f1)
                                   (frame-values f1)
                                   init-env)))
       (let ((e2 (extend-environment (frame-variables f2)
                                     (frame-values f2)
                                     e1)))
         (assert-equal '(((d e f) 4 5 6) ((a b c) 1 2 3)) e2)
         (assert-equal f2 (first-frame e2))
         (assert-equal f1 (first-frame (enclosing-environment e2)))
         )
       )
     )
   )

  ("error"
   (assert-error (lambda () (extend-environment '(a b) '(1 2 3) '())))
   (assert-error (lambda () (extend-environment '(a b c) '(1 2) '())))
   )
  )

lookup

束縛の解決。これは環境を遡っているはず。

 ("lookup"
  ("unbound (1)"
   (assert-error (lambda () (lookup-variable-value 'a '())))
   )

  ("unbound (2)"
   (let ((e (extend-environment '(a b) '(1 2) '())))
     (assert-error (lambda () (lookup-variable-value 'c e)))
     )
   )

  ("unbound (3)"
   (let ((e (extend-environment '(d e f) '(4 5 6)
                                (extend-environment '(a b c)
                                                    '(1 2 3)
                                                    '()))))
     (assert-error (lambda () (lookup-variable-value 'g e)))
     )
   )

  ("normal (1)"
   (let ((e (extend-environment '(a b c) '(1 2 3) '())))
     (assert-equal 1 (lookup-variable-value 'a e))
     (assert-equal 2 (lookup-variable-value 'b e))
     (assert-equal 3 (lookup-variable-value 'c e))
     )
   )

  ("normal (2)"
   (let ((e (extend-environment '(d e f) '(4 5 6)
                                (extend-environment '(a b c)
                                                    '(1 2 3)
                                                    '()))))
     (assert-equal 1 (lookup-variable-value 'a e))
     (assert-equal 2 (lookup-variable-value 'b e))
     (assert-equal 3 (lookup-variable-value 'c e))
     (assert-equal 4 (lookup-variable-value 'd e))
     (assert-equal 5 (lookup-variable-value 'e e))
     (assert-equal 6 (lookup-variable-value 'f e))
     )
   )
  )

束縛の変更

手続きとしては lookup と変わらない。束縛が見つかったら値を変更。もう少し品良くできそうではありますが。

 ("set"
  ("unbound (1)"
   (assert-error (lambda () (set-variable-value 'a '())))
   )

  ("unbound (2)"
   (let ((e (extend-environment '(a b) '(1 2) '())))
     (assert-error (lambda () (set-variable-value 'c e)))
     )
   )

  ("unbound (3)"
   (let ((e (extend-environment '(d e f) '(4 5 6)
                                (extend-environment '(a b c)
                                                    '(1 2 3)
                                                    '()))))
     (assert-error (lambda () (set-variable-value 'g e)))
     )
   )
  ("normal (1)"
   (let ((e (extend-environment '(a b c) '(1 2 3) '())))
     (assert-equal 1 (lookup-variable-value 'a e))
     (assert-equal 2 (lookup-variable-value 'b e))
     (assert-equal 3 (lookup-variable-value 'c e))
     (set-variable-value! 'a 4 e)
     (assert-equal 4 (lookup-variable-value 'a e))
     (assert-equal 2 (lookup-variable-value 'b e))
     (assert-equal 3 (lookup-variable-value 'c e))
     (set-variable-value! 'b 5 e)
     (assert-equal 4 (lookup-variable-value 'a e))
     (assert-equal 5 (lookup-variable-value 'b e))
     (assert-equal 3 (lookup-variable-value 'c e))
     (set-variable-value! 'c 6 e)
     (assert-equal 4 (lookup-variable-value 'a e))
     (assert-equal 5 (lookup-variable-value 'b e))
     (assert-equal 6 (lookup-variable-value 'c e))
     )
   )

  ("normal (2)"
   (let ((e (extend-environment '(d e f) '(4 5 6)
                                (extend-environment '(a b c)
                                                    '(1 2 3)
                                                    '()))))
     (assert-equal 1 (lookup-variable-value 'a e))
     (assert-equal 2 (lookup-variable-value 'b e))
     (assert-equal 3 (lookup-variable-value 'c e))
     (assert-equal 4 (lookup-variable-value 'd e))
     (assert-equal 5 (lookup-variable-value 'e e))
     (assert-equal 6 (lookup-variable-value 'f e))
     (set-variable-value! 'a 7 e)
     (assert-equal 7 (lookup-variable-value 'a e))
     (assert-equal 2 (lookup-variable-value 'b e))
     (assert-equal 3 (lookup-variable-value 'c e))
     (assert-equal 4 (lookup-variable-value 'd e))
     (assert-equal 5 (lookup-variable-value 'e e))
     (assert-equal 6 (lookup-variable-value 'f e))
     (set-variable-value! 'b 8 e)
     (assert-equal 7 (lookup-variable-value 'a e))
     (assert-equal 8 (lookup-variable-value 'b e))
     (assert-equal 3 (lookup-variable-value 'c e))
     (assert-equal 4 (lookup-variable-value 'd e))
     (assert-equal 5 (lookup-variable-value 'e e))
     (assert-equal 6 (lookup-variable-value 'f e))
     (set-variable-value! 'c 9 e)
     (assert-equal 7 (lookup-variable-value 'a e))
     (assert-equal 8 (lookup-variable-value 'b e))
     (assert-equal 9 (lookup-variable-value 'c e))
     (assert-equal 4 (lookup-variable-value 'd e))
     (assert-equal 5 (lookup-variable-value 'e e))
     (assert-equal 6 (lookup-variable-value 'f e))
     (set-variable-value! 'd 1 e)
     (assert-equal 7 (lookup-variable-value 'a e))
     (assert-equal 8 (lookup-variable-value 'b e))
     (assert-equal 9 (lookup-variable-value 'c e))
     (assert-equal 1 (lookup-variable-value 'd e))
     (assert-equal 5 (lookup-variable-value 'e e))
     (assert-equal 6 (lookup-variable-value 'f e))
     (set-variable-value! 'e 2 e)
     (assert-equal 7 (lookup-variable-value 'a e))
     (assert-equal 8 (lookup-variable-value 'b e))
     (assert-equal 9 (lookup-variable-value 'c e))
     (assert-equal 1 (lookup-variable-value 'd e))
     (assert-equal 2 (lookup-variable-value 'e e))
     (assert-equal 6 (lookup-variable-value 'f e))
     (set-variable-value! 'f 3 e)
     (assert-equal 7 (lookup-variable-value 'a e))
     (assert-equal 8 (lookup-variable-value 'b e))
     (assert-equal 9 (lookup-variable-value 'c e))
     (assert-equal 1 (lookup-variable-value 'd e))
     (assert-equal 2 (lookup-variable-value 'e e))
     (assert-equal 3 (lookup-variable-value 'f e))
     )
   )
  )

って試験が凄い微妙だ。ヤッツケ感満点。

変数の定義 (束縛の追加)

これ、数値でしか試験してないけど、手続きとかリストとかも試験すべきだな。

 ("define"
  ("add"
   (let ((e (extend-environment '(a b) '(1 2) '())))
     (define-variable! 'c 3 e)
     (assert-equal 3 (lookup-variable-value 'c e))
     (assert-equal 'c (car (car (car e))))
     (assert-equal 3 (car (cdr (car e))))
     )
   )

  ("set"
   (let ((e (extend-environment '(a b c) '(1 2 3) '())))
     (define-variable! 'c 4 e)
     (assert-equal 4 (lookup-variable-value 'c e))
     )
   )

  ("add"
   (let ((e (extend-environment '(d e f) '(4 5 6)
                                (extend-environment '(a b c)
                                                    '(1 2 3)
                                                    '()))))
     (define-variable! 'c 7 e)
     (assert-equal 7 (lookup-variable-value 'c e))
     (assert-equal '(c d e f)
                   (car (car e)))
     (assert-equal '(a b c)
                   (car (car (cdr e))))
     )
   )
  )

定義は今いるフレームのみが対象。しかも既存だったら値を変更。ここまでで 4.1.3 なソレは終了ですが、練習問題は一旦スルー。後で戻ります。

the-global-environment

以下の定義は一番最後じゃないと駄目なの??

(define (setup-environment)
 (let ((initial-env
        (extend-environment (primitive-procedure-names)
                            (primitive-procedure-objects)
                            the-empty-environment)))
   (define-variable! 'true #t initial-env)
   (define-variable! 'false #f initial-env)
   initial-env))
(define the-global-environment (setup-environment))

微妙な試験も書いている。

 ("the-global-environment"
  ("true & false"
   (assert-equal 'true (cadr (car (car the-global-environment))))
   (assert-equal 'false (car (car (car the-global-environment))))
   (assert-true (lookup-variable-value 'true the-global-environment))
   (assert-false (lookup-variable-value 'false the-global-environment))
   )
  )

primitive

微妙なバグがたくさんありそげ。早く eval なソレ達の試験を書きたいんですが、primitive なナニの試験を。

  ("primitive"
   ("the-global-environment"
    (assert-false (primitive-procedure?
		   (lookup-variable-value 'true the-global-environment)))
    (assert-true (primitive-procedure?
		  (lookup-variable-value 'cons the-global-environment)))
    (assert-equal '(1 . 2)
		  (apply-in-underlying-scheme cons '(1 2)))
    (assert-equal '(1 . 2)
		  (apply-primitive-procedure
		   (lookup-variable-value 'cons the-global-environment)
		   '(1 2)))
    (assert-equal 1 (apply-in-underlying-scheme
		     (primitive-implementation
		      (lookup-variable-value 'car the-global-environment))
		     '((1 2))))
    (assert-equal 2 (primitive-implementation '(1 2)))
    )
   )

色々な意味で微妙。てか、こっからが面白い。とりあえず試験を今から検討。

eval が動く

わははは。動く動く。どんどん試験を書いてるんですが、if でひっカカる。

   ("if"
    (let ((new-env (extend-environment '(x y) 
				       '(1 ()) 
				       the-global-environment)))
      (assert-true (eval '(null? y) new-env))
      )
    )

この試験に失敗。出力は以下 (一部)。

Error occurred in if
*** ERROR: invalid application: ((primitive #<subr null?>) ())

うーん。何が悪いのか分からん、とゆー事で eval に null? を評価させてみる。

   ("app"
    (assert-true (eval '(null? ()) the-global-environment))
    )

と、

*** ERROR: Unknown expression type -- EVEL ()

知らぬ、との事。なんでかね。しかも EVEL だし (とほほ
ってナチュラルか。quote しないと駄目。でも動かん。

*** ERROR: invalid application: ((primitive #<subr null?>) ())

メセジとしては同じか。ええと、

(eval '(null? '()) the-global-environment)

はどう評価されて何を戻すか、というと??

ハマリ

こんなハマり方は久々。しかもまだ解決してないし。(を

   ("app"
    (let ((l '(null? '())))
      (assert-true (application? l))

      (assert-equal 'primitive (car (eval (operator l) 
					  the-global-environment)))
      (assert-true (primitive-procedure? (eval (operator l)
					       the-global-environment)))

      (assert-true (apply (eval (operator l) the-global-environment)
			  (list-of-values (operands l) 
					  the-global-environment)))
      (assert-true (apply-primitive-procedure
		    (eval (operator l) the-global-environment)
		    (list-of-values (operands l) the-global-environment)))

;      (assert-true (eval l the-global-environment))
      )
    )

いっちゃんケツの assert だけ NG。何故なんだ、と頭をカキむしってる間に板橋のソレが身柄確保、と言うのを聞きつつ apply-in-underlying-scheme でハマりかけたのを思いだした。もしかして定義の位置ですか? と言いつつ apply の定義を eval とソレとの間に移動したら通ったよ。SICP 恐るべし。

if

primitive なソレがようやく動いたので if も試験。

   ("if"
    (let ((new-env (extend-environment '(x y) 
				       '(1 ()) 
				       the-global-environment)))
      (let ((l '(null? y)))
	(assert-true (eval l new-env))
	)
      (let ((l '(if (null? y) x y)))
	(assert-equal 1 (eval l new-env))
	)
      (let ((l '(if (null? x) x y)))
	(assert-equal '() (eval l new-env))
	)
      )
    )
   )

そろそろ基本手続きをなんとかせんといけないらしい。ってか次が lambda なんで止めたくないんですが。