SICP 読み (375) 5.5 翻訳系

自分が残した足跡ながら見返してみるととても微妙。がしかし負けずに匍匐前進です。

問題 5.50

こっちでどこまでイケてたのか忘れている。で、試験してみると

;;; M-Eval input:
1

;;; M-Eval value:
*** ERROR: Unbound variable pair?
Stack Trace:

ありゃ。このあたりッスか。で、エントリを確認してみたらこのあたりの問題処理の記録が全然残っていません。しまった。
ええと現時点では以下を ch5-eceval-support.scm の primitive-procedures に追加しております。

• pair?
• string?
• symbol?

これで quote とか数値とか文字列はスルーな模様。define はどうかって確認してみたら

;;; M-Eval input:
(defie x 1)
*** ERROR: Unbound variable error
Stack Trace:

うーん。error も追加したらパス。変数の lookup もできている模様。

;;; M-Eval input:
(define x 1)

;;; M-Eval value:
ok

;;; M-Eval input:
x

;;; M-Eval value:
1

;;; M-Eval input:

set! も OK な模様

;;; M-Eval input:
(set! x 2)

;;; M-Eval value:
#<undef>

;;; M-Eval input:
x

;;; M-Eval value:
2

;;; M-Eval input:

あるいは論理積

;;; M-Eval input:
(and true true)

;;; M-Eval value:
#t

;;; M-Eval input:
(and true false)

;;; M-Eval value:
#f

;;; M-Eval input:
(and false true)

;;; M-Eval value:
#f

;;; M-Eval input:
(and false false)

;;; M-Eval value:
#f

;;; M-Eval input:

論理和

;;; M-Eval input:
(or true true)
*** ERROR: Unbound variable not
Stack Trace:

あ、オチた。なんじゃこりゃ。確かに primitive-procedures には not は無いのですが、どこをどうしたら not が出てくるんだろうか。trace-on したところ

((after-call1077 3) test (op false?) (reg val))
((after-call1077 4) branch (label false-branch1070))
((true-branch1069 1) assign proc (op lookup-variable-value) (const car) (reg env))
((true-branch1069 2) assign val (op lookup-variable-value) (const vals) (reg env))
((true-branch1069 3) assign argl (op list) (reg val))
((true-branch1069 4) test (op primitive-procedure?) (reg proc))
((true-branch1069 5) branch (label primitive-branch1078))
((primitive-branch1078 1) assign val (op apply-primitive-procedure) (reg proc) (reg argl))
((primitive-branch1078 2) goto (reg continue))
((after-call422 1) assign argl (op list) (reg val))
((after-call422 2) restore proc)
((after-call422 3) restore continue)
((after-call422 4) test (op primitive-procedure?) (reg proc))
((after-call422 5) branch (label primitive-branch423))
((compiled-branch424 1) assign val (op compiled-procedure-entry) (reg proc))
((compiled-branch424 2) goto (reg val))
((entry394 1) assign env (op compiled-procedure-env) (reg proc))
((entry394 2) assign env (op extend-environment) (const (ret)) (reg argl) (reg env))
((entry394 3) save continue)
((entry394 4) save env)
((entry394 5) assign proc (op lookup-variable-value) (const true?) (reg env))
((entry394 6) assign val (op lookup-variable-value) (const ret) (reg env))
((entry394 7) assign argl (op list) (reg val))
((entry394 8) test (op primitive-procedure?) (reg proc))
((entry394 9) branch (label primitive-branch399))
((compiled-branch400 1) assign continue (label after-call401))
((compiled-branch400 2) assign val (op compiled-procedure-entry) (reg proc))
((compiled-branch400 3) goto (reg val))
((entry930 1) assign env (op compiled-procedure-env) (reg proc))
((entry930 2) assign env (op extend-environment) (const (x)) (reg argl) (reg env))
((entry930 3) assign proc (op lookup-variable-value) (const not) (reg env))

で not が確かに出てきとりますがこれは一体どこだ。あ、成程。とりあえず、or とか and の eval な処理は以下。

(define (eval-and exp env)
  (define (eval-and-iter predicates env)
    (let ((ret (eval (car predicates) env)))
      (if (false? ret)
          false
          (if (null? (cdr predicates))
              ret
              (eval-and-iter (cdr predicates) env)))))
  (if (null? (cdr exp))
      true
      (eval-and-iter (cdr exp) env)))

(define (eval-or exp env)
  (define (eval-or-iter predicates env)
    (let ((ret (eval (car predicates) env)))
      (if (true? ret)
          ret
          (if (null? (cdr predicates))
              false
              (eval-or-iter (cdr predicates) env)))))
  (if (null? (cdr exp))
      false
      (eval-or-iter (cdr exp) env)))

上記の手続き定義で出てきている true? とか false? の定義が以下

(define (true? x)
  (not (eq? x false)))
(define (false? x)
  (eq? x false))

確かに not 使っておりますな。primitive-procedure に追加。

;;; M-Eval input:
(or true true)

;;; M-Eval value:
#t

;;; M-Eval input:
(or true false)

;;; M-Eval value:
#t

;;; M-Eval input:
(or false true)

;;; M-Eval value:
#t

;;; M-Eval input:
(or false false)

;;; M-Eval value:
#f

;;; M-Eval input:

論理和も OK なので次は否定

;;; M-Eval input:
(not true)

;;; M-Eval value:
#f

;;; M-Eval input:
(not false)

;;; M-Eval value:
#t

;;; M-Eval input:

ではそろそろ元に戻って application なソレの問題解決に着手。続きは別途投入ってコトで。

続き

ええと (+ 1 2) を評価させたら以下

;;; M-Eval input:
(+ 1 2)
*** ERROR: invalid application: ((primitive #<subr +>) 1 2)
Stack Trace:
_______________________________________
  0  args

  1  (map (lambda (p) (p)) aprocs)
        At line 499 of "./ch5-regsim.scm"
  2  value-proc

  3  (set-contents! target (value-proc))
        At line 371 of "./ch5-regsim.scm"
  4  (instruction-execution-proc (car insts))
        At line 192 of "./ch5-regsim.scm"

これは直前エントリのいっちゃん最後の状態。そのエントリによると

((primitive-branch1376 1) assign val (op apply-primitive-procedure) (reg proc) (reg argl))

で終了されているご様子。レジスタの中身を見てみると

gosh> (get-register-contents eceval 'proc)
(primitive #<subr apply>)
gosh> (get-register-contents eceval 'argl)
((primitive #<subr +>) (1 2))
gosh> 

まぁそうだろうな、という感じ。でもちょっと (かなり) アタマ方面の整理ができてない。仕方が無いので順を追って確認してみようとして以下を試してみた。

;;; M-Eval input:
+

;;; M-Eval value:
(primitive (primitive #<subr +>))

;;; M-Eval input:

むむ。ナンダコレハ。ええと primitive-procedures は二つあります。一つはコンパイルされる scheme な評価器の中。もう一つは ch5-eceval-support.scm の中。こっちはコンパイルされた手続きが使う、とソースにもコメントがある。という事はコンパイルされる評価器においては primitive-procedure の定義を以下のようにしないとダメ、という事なのかなぁ。

(define primitive-procedures
  (list (list 'car (cadr car))
	(list 'cdr (cadr cdr))
	(list 'cons (cadr cons))
	(list 'null? (cadr null?))
	(list 'list (cadr list))
	(list 'eqv? (cadr eqv?))
	(list 'eq? (cadr eq?))
	(list 'equal? (cadr equal?))
	(list 'number? (cadr number?))
	(list 'complex? (cadr complex?))
	(list 'real? (cadr real?))
	(list 'rational? (cadr rational?))
	(list 'integer? (cadr integer?))
	(list '= (cadr =))
	(list '< (cadr <))
	(list '> (cadr >))
	(list '<= (cadr <=))
	(list '>= (cadr >=))
	(list 'zero? (cadr zero?))
	(list 'positive? (cadr positive?))
	(list 'negative? (cadr negative?))
	(list 'odd? (cadr odd?))
	(list 'even? (cadr even?))
	(list 'max (cadr max))
	(list 'min (cadr min))
	(list '+ (cadr +))
	(list '* (cadr *))
	(list '- (cadr -))
	(list '/ (cadr /))
	(list 'assoc (cadr assoc))
	(list 'cadr (cadr cadr))
	(list 'cddr (cadr cddr))
	(list 'caddr (cadr caddr))
	(list 'cdddr (cadr cdddr))
;        <more primitives>
	))

うーん。動いたんですが、なんか違うような気もするなぁ。てーか何故にこれで動くのか、が今一つイメージできておりません。とほほほ。
と言いつつ factorial の定義を試してみたら

;;; M-Eval input:
(define (factorial n) (if (= n 1) 1 (* n (factorial (- n 1)))))
*** ERROR: Unbound variable cdadr

とほほほ。これは ch5-eceval-support の中の primitive-procedure に定義、で良いんだよな。で試験してみたら

;;; M-Eval input:
(define (factorial n) (if (= n 1) 1 (* n (factorial (- n 1)))))
*** ERROR: Unbound variable caadr
Stack Trace:

よく確認して試験すりゃいいのにね、と自分を叱咤しつつリトライ。

;;; M-Eval input:
(define (factorial n) (if (= n 1) 1 (* n (factorial (- n 1)))))

;;; M-Eval value:
ok

;;; M-Eval input:

でけた。がしかし

;;; M-Eval input:
(factorial 1)
*** ERROR: Unbound variable cadddr
Stack Trace:

うーん。これはそろそろ手を抜く方法を考えた方が良さげ。リストの car を全部出力、とかかなぁ。とりあえず cadddr のみ盛り込み。
一応動くようにはなったのか。でもこれってまだ全部の分岐を通過してないはずだから、まだオチる可能性はあるな。やれやれ。でもこの時点で通ってないのは

• begin
• cond
• let

くらいなのか。let* とかも使えるみたいですが試験するかどうかは微妙。
対処がこれで妥当なのかどうかはもう少し検証してみたいと思います。