SICP 5.4 The Explicit-Control Evaluator

ノート

第４章のMetacircular evaluatorをレジスタマシンで実現する。

Registers and operations

第４章で実装した各シンタックスに対応する手続きをそのままレジスタマシンに移植する事も出来るが、ポイントがズレてしまうので各シンタックスに対応する処理を直接レジスタマシンに書き下す。

5.4.1 The Core of the Explicit-Control Evaluator

まずディスパッチャ。シンタックスの解釈は全てプリミティブとして実装されている。

Evaluating simple expressions

シンプルな式の評価。レジスタvalに結果を保存して、レジスタcontinueに保存されたラベルにジャンプする。ここでもかなりのプリミティブが用いられている。

ev-self-evalはリテラルの処理。expは数値か文字列なので、それをそのままvalに保存してcontinueに飛ぶ。
ev-variableはexpが示す変数の値を環境から探して来てvalに保存する。変数の値を探すのはプリミティブのlookup-variable-value。
ev-quotedはシンボルの処理。プリミティブtext-of-quotationでシンボル名をvalに保存。
ev-lambdaはラムダ式の処理。unevに引数のリスト、expに本体を入れてプリミティブmake-procedureで手続きを作ってvalに保存。

Evaluating procedure applications

Metacircular evaluaterでは式の各要素を再帰的に評価して、その結果をapplyに渡していたが、explicit-control evaluatorでも同様に実装する。

ev-applicationは関数呼び出し。オペレータ部分をexpに入れてeval-dispatchを呼び出し、帰って来たらev-appl-did-operatorに進む。
ev-appl-did-opertorでは実引数の評価。procに評価が終わったオペレータを設定して、引数が無ければ直ぐにapply-dispatchに進む。引数がある場合には一旦procをスタックに保存して、ev-appl-operand-loopに進む。

ev-appl-operand-loopは順番に引数を評価する。expに最初の引数を保存してeval-dispatchに飛ぶ。戻り先はev-appl-accumulate-arg。最後の引数の場合にはev-appl-last-argに進む。

ここの実装方法により引数の評価順序が決まる。ここではfirst-operandがcarで、rest-operandsがcdrなので左側の引数から評価される事になる。

ev-appl-accumulate-argでは、arglに評価が終わった引数を追加し、unevから評価が終わった引数を取り除き、ev-appl-operand-loopに戻る。

ev-appl-last-argは最後の引数の評価。最後なのでレジスタはスタックに保存しておく必要が無い。eval-dispatchに飛んで、ev-appl-accum-last-argに戻る。

ev-appl-accum-last-argでは最後の引数をarglに追加。スタックにセーブしてあったオペレータをprocに戻してapply-dispatchに飛ぶ。

Procedure application

apply-dispatchに飛んで来た時点で、procには手続きが、arglには評価が終わった実引数が入っている。continueに入っていた戻り場所はスタックにセーブされている。手続きの適用が終わった段階ではvalに評価が終わった値を入れて、スタックにセーブされていたcontinueの場所に飛ぶ。

procの手続きがプリミティブであればprimitive-applyに、そうでない手続きであればcompound-applyに、それ以外はunknown-procedure-typeに飛ぶ。

primitive-applyではレジスタマシンのプリミティブapply-primitive-procedureにprocとarglを渡して、結果をvalに保存して、continueをリストアして、そのラベルにジャンプする。

compound-applyでは、プリミティブprocedure-parametersでフレームを作りunevに保存、プリミティブprocedure-environmentで環境を救ってenvに保存、unev、argl、envから環境を拡張。unevには手続きの本体を保存して、ev-sequenceにジャンプ。

5.4.2 Sequence Evaluation and Tail Recursion

ev-beginは明示的にbeginで始まるシーケンスを評価する。これから評価するシーケンスexpをunevに保存して、戻る場所continueをスタックに保存してからシーケンスを評価するev-sequenceにジャンプする。

ev-sequenceとev-sequence-continueでループを形成。compound-applyから呼ばれる時は手続きの本体の評価、ev-beginから呼ばれる時はbeginで始まるシーケンスの評価。評価する前のシーケンスはunevに保存される。

ev-sequenceではexpにシーケンスの最初の式を取り出し、それが最後の式でなければunevとenvを保存、戻り場所としてcontinueにev-sequence-continueを保存して、eval-dispatchにジャンプして式を評価する。最後の式の場合にはev-sequence-last-expにジャンプ。

ev-sequence-continueではeval-dispatchから戻って来た所なので、envとunevを戻して、unevを更新、ev-sequenceに戻る。

ev-sequence-last-expではcontinueを戻して、最後の式をev-sequenceで評価する。

Tail recursion

ev-sequence-last-expでは最後の式を評価する時にunevもenvもスタックに保存せずにev-sequenceに飛ぶので、末尾再帰で余計なスタックは使わない様になっている。

5.4.3 Conditionals, Assignments, and Definitions

スペシャルフォームの評価。

ev-ifはifを評価。exp（if節全体）、env、continueをセーブ。continueに分岐部分のラベルを代入して、条件部分をexpに入れてeval-dispatchにジャンプ。

ev-if-decideはレジスタを戻してレジスタvalの値がtrueであればev-if-consequentにジャンプ。そうでなければev-if-alternativeに抜ける。

ev-if-consequentとev-if-altanativeはそれぞれ真の場合、偽の場合の手続きをexpに入れてeval-dispatchにジャンプ。

Assignments and definitions

ev-assignment変数への代入。unevに変数を、expに値部分の式を保存してeval-dispatchを呼ぶ。戻って来る所はev-assignment-1。マシンのオペレーションset-variable-value!を使ってenvの変数に値を設定する。

ev-definitionも同様。

Exercise 5.23

ちょっと先まで読んで、まずはマシンが動く状態にしないと動作確認が出来ない。
5.4.4に書いてあるREPLの部分、4.1.2節、4.1.3節、4.1.4節、Exercise 4.11での実装、脚注に書いてある定義を取り込んで、eceval-operationsにopで使用している手続きを登録する。

(define eceval-operations
  (list (list 'self-evaluating? self-evaluating?)
        (list 'variable? variable?)
        (list 'quoted? quoted?)
        (list ' assignment? assignment?)
        (list 'definition? definition?)
        (list 'if? if?)
        (list 'lambda? lambda?)
        (list 'begin? begin?)
        (list 'application? application?)
        (list 'lookup-variable-value lookup-variable-value)
        (list 'text-of-quotation text-of-quotation)
        (list 'lambda-parameters lambda-parameters)
        (list 'lambda-body lambda-body)
        (list 'make-procedure make-procedure)
        (list 'operands operands)
        (list 'operator operator)
        (list 'empty-arglist empty-arglist)
        (list 'no-operands? no-operands?)
        (list 'first-operand first-operand)
        (list 'last-operand? last-operand?)
        (list 'adjoin-arg adjoin-arg)
        (list 'rest-operands rest-operands)
        (list 'primitive-procedure? primitive-procedure?) ;
        (list 'compound-procedure? compound-procedure?)
        (list 'apply-primitive-procedure apply-primitive-procedure)
        (list 'procedure-parameters procedure-parameters)
        (list 'procedure-environment procedure-environment)
        (list 'extend-environment extend-environment)
        (list 'procedure-body procedure-body)
        (list 'begin-actions begin-actions)
        (list 'first-exp first-exp)
        (list 'last-exp? last-exp?)
        (list 'rest-exps rest-exps)
        (list 'no-more-exps? no-more-exps?)
        (list 'if-predicate if-predicate)
        (list 'true? true?)
        (list 'if-alternative if-alternative)
        (list 'if-consequent if-consequent)
        (list 'assignment-variable assignment-variable)
        (list 'assignment-value assignment-value)
        (list 'set-variable-value! set-variable-value!)
        (list 'definition-variable definition-variable)
        (list 'definition-value definition-value)
        (list 'define-variable! define-variable!)
        (list 'prompt-for-input prompt-for-input)
        (list 'read read)
        (list 'get-global-environment get-global-environment)
        (list 'announce-output announce-output)
        (list 'user-print user-print)
        ))

動作確認。

> (start eceval)


;;; EC-Eval input:
(define (append x y)
  (if (null? x)
      y
      (cons (car x)
            (append (cdr x) y))))

;;; EC-Eval value:
ok

;;; EC-Eval input:
(append '(a b c) '(d e f))

;;; EC-Eval value:
(a b c d e f)

;;; EC-Eval input:
.

4.1.2節とそこのExerciseで拡張した構文はcond、and、or、let、let*、named-let（Exercis 4.8）とdo（Exercise 4.9）。その時に実装した手続きを取り込む。

その際にself-evaluating?にbooleanを加えないと、valに帰って来た#t等が処理出来ずにunknown-expression-type-errorとなってしまう。

(define (self-evaluating? exp)
  (cond ((number? exp) true)
        ((string? exp) true)
        ((boolean? exp) true)
        (else false)))

プリミティブの追加。

(define eceval-operations
  (list (list 'self-evaluating? self-evaluating?)
…
        (list 'cond? cond?)
        (list 'cond->if cond->if)
        (list 'and? and?)
        (list 'and->if and->if)
        (list 'or? or?)
        (list 'or->if or->if)
        (list 'let? let?)
        (list 'let->combination let->combination)
        (list 'let*? let*?)
        (list 'let*->nested-lets let*->nested-lets)
        (list 'do? do?)
        (list 'do->named-let do->named-let)
        ))

マシンを拡張

…
     eval-dispatch
…
     (test (op cond?) (reg exp))
     (branch (label ev-cond))
     (test (op and?) (reg exp))
     (branch (label ev-and))
     (test (op or?) (reg exp))
     (branch (label ev-or))
     (test (op let?) (reg exp))
     (branch (label ev-let))
     (test (op let*?) (reg exp))
     (branch (label ev-nested-let))
     (test (op do?) (reg exp))
     (branch (label ev-do))
     (test (op application?) (reg exp))
     (branch (label ev-application))
     (goto (label unknown-expression-type))
…
     ev-cond
     (assign exp (op cond->if) (reg exp))
     (goto (label eval-dispatch))
     ev-and
     (assign exp (op and->if) (reg exp))
     (goto (label eval-dispatch))
     ev-or
     (assign exp (op or->if) (reg exp))
     (goto (label eval-dispatch))
     ev-let
     (assign exp (op let->combination) (reg exp))
     (goto (label eval-dispatch))
     ev-nested-let
     (assign exp (op let*->nested-lets) (reg exp))
     (goto (label eval-dispatch))
     ev-do
     (assign exp (op do->named-let) (reg exp))
     (goto (label eval-dispatch))
…

テストの為に少しオペレータを追加

(define primitive-procedures
  (list (list 'car car)
        (list 'cdr cdr)
        (list 'cons cons)
        (list 'null? null?)
        (list 'list list)
        (list 'map map)
        (list '> >)
        (list '= =)
        (list '+ +)
        (list '- -)
        (list 'display display)
        (list 'newline newline)
;       <more primitives>
        ))

condのテスト。

;;; EC-Eval input:
(define x 0)

;;; EC-Eval value:
ok

;;; EC-Eval input:
(cond ((> x 0) x)
      ((= x 0) (display 'zero) 0)
      (else (- x)))
zero
;;; EC-Eval value:
0

;;; EC-Eval input:
(define x 100)

;;; EC-Eval value:
ok

;;; EC-Eval input:
(cond ((> x 0) x)
      ((= x 0) (display 'zero) 0)
      (else (- x)))

;;; EC-Eval value:
100

;;; EC-Eval input:

andのテスト

;;; EC-Eval input:
(define a 1)

;;; EC-Eval value:
ok

;;; EC-Eval input:
(define b 2)

;;; EC-Eval value:
ok

;;; EC-Eval input:
(and (= a 1) (= b 2))

;;; EC-Eval value:
#t

;;; EC-Eval input:
(and (= a 1) (= b 1))

;;; EC-Eval value:
#f

;;; EC-Eval input:

orのテスト

;;; EC-Eval input:
(or (= a 1) (= b 1))

;;; EC-Eval value:
#t

;;; EC-Eval input:
(or (= a 2) (= b 2))

;;; EC-Eval value:
#t

;;; EC-Eval input:
(or (= a 2) (= b 1))

;;; EC-Eval value:
#f

;;; EC-Eval input:

letのテスト

;;; EC-Eval input:
(let ((a 2)) (+ a 3))

;;; EC-Eval value:
5

;;; EC-Eval input:

let*のテスト

;;; EC-Eval input:
(let ((a 2)) (+ a 3))

;;; EC-Eval value:
5

;;; EC-Eval input:
(let* ((a 2) (c (+ a 3))) (+ c 4))

;;; EC-Eval value:
9

;;; EC-Eval input:

nemed-letのテスト。Exercise 4.8から。

;;; EC-Eval input:
(define (fib n)
  (let fib-iter ((a 1)
                 (b 0)
                 (count n))
    (if (= count 0)
        b
        (fib-iter (+ a b) a (- count 1)))))

;;; EC-Eval value:
ok

;;; EC-Eval input:
(fib 6)

;;; EC-Eval value:
8

;;; EC-Eval input:

doのテスト

;;; EC-Eval input:
(do ((x 1 (+ x 1)) (y 2 (+ y 1))) ((> x 10) x) (display x)(display ":")(display y)(newline))
1:2
2:3
3:4
4:5
5:6
6:7
7:8
8:9
9:10
10:11

;;; EC-Eval value:
11

;;; EC-Eval input:

Exercise 5.24

condを直接評価する命令群を作成する。andとかorとか後で使えそうだからExercise 5.23の結果をベースにcondの部分を入れ替える事にする。
condの処理はifの評価をベースに、条件にマッチした時には問題文で提案されている通りsequenceの処理を利用する。

1. 必要な式はunevに全て保存するのでexpを退避する必要はなし
2. なので条件を評価するときにはunevは退避する必要がある
3. 条件部を評価するのにenvを退避する必要があるのか疑問。ここでは退避しない
4. continueは最初に退避してsequenceの処理のジャンプするときには復元せずにそのままジャンプ（sequenceの最後で復元される）
5. else部が無くてそのまま抜けてしまう場合にはcontinueを復元して、そこにジャンプする必
6. 条件があった場合にはsequenceの処理に合わせてunevに式を保存してev-sequenceにジャンプ
7. 条件が合わなかった場合には評価した条件とそれに対応するシーケンンスの部分を取り除いて条件評価部分に戻る

プリミティブとして以下を定義する。

(define (cond-clauses exp) (cdr exp))
(define (cond-predicate clause) (caar clause))
(define (cond-actions clause)
  (let ((actions (cdar clause)))
     (if (eq? (car actions) '=>)
         (cdr actions)
         actions)))
(define (cond-alternative exp) (cdr exp))

一応、cond-actionsの動作確認

> (cond-actions '(
                  ((eq? (car clause) '=) (display "a")(newline)) 
                  ((eq? (car clause '>) (display "b")(newline)))))
'((display "a") (newline))
> (cond-actions '(
                  ((eq? (car clause) '=) => (display "a")(newline)) 
                  ((eq? (car clause '>) => (display "b")(newline)))))
'((display "a") (newline))
> 

これらとリストの空判定のためにnull?を登録して

(define eceval-operations
  (list (list 'self-evaluating? self-evaluating?)
        …
        (list 'cond-clauses cond-clauses)
        (list 'cond-predicate cond-predicate)
        (list 'cond-actions cond-actions)
        (list 'cond-alternative cond-alternative)
        (list 'null? null?)
        …

で、実行部分。

     ev-cond
     (assign unev (op cond-clauses) (reg exp))
     (save continue)
     ev-conditions
     (test (op null?) (reg unev))
     (branch (label ev-cond-no-match))
     (assign continue (label ev-cond-decide))
     (assign exp (op cond-predicate) (reg unev))
     (save unev)
     (goto (label eval-dispatch))
     ev-cond-decide
     (restore unev)
     (test (op true?) (reg val))
     (branch (label ev-cond-actions))
     ev-cond-alternative
     (assign unev (op cond-alternative) (reg unev))
     (goto (label ev-conditions))
     ev-cond-actions
     (assign unev (op cond-actions) (reg unev))
     (goto (label ev-sequence))
     ev-cond-no-match
     (restore continue)
     (goto (reg continue))

動作確認

;;; EC-Eval input:
(define else #t)

;;; EC-Eval value:
ok

;;; EC-Eval input:
(define x 0)

;;; EC-Eval value:
ok

;;; EC-Eval input:
(cond ((> x 0) x)
      ((= x 0) (display 'zero) 0)
      (else (+ x x)))
zero
;;; EC-Eval value:
0

;;; EC-Eval input:
(define x 100)

;;; EC-Eval value:
ok

;;; EC-Eval input:
(cond ((> x 0) x)
      ((= x 0) (display 'zero) 0)
      (else (+ x x)))

;;; EC-Eval value:
100

;;; EC-Eval input:
(define x -100)

;;; EC-Eval value:
ok

;;; EC-Eval input:
(cond ((> x 0) x)
      ((= x 0) (display 'zero) 0)
      (else (+ x x)))

;;; EC-Eval value:
-200

;;; EC-Eval input:
(cond ((> x 0) => x)
      ((= x 0) => (display 'zero) 0)
      (else => (+ x x)))

;;; EC-Eval value:
-200

;;; EC-Eval input:

elseが無くて抜けてしまうパターン

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

;;; EC-Eval value:
ok

;;; EC-Eval input:
(cond ((= x 0) 'zero))

;;; EC-Eval value:
#f

;;; EC-Eval input:
(define x 0)

;;; EC-Eval value:
ok

;;; EC-Eval input:
(cond ((= x 0) 'zero))

;;; EC-Eval value:
zero

;;; EC-Eval input:

とりあえずは動いていそう。

Exercise 5.25

今の実装をざっくり書き下すと：

1. オペレータを評価する
2. オペランドを一つ一つ評価してarglに溜める
3. オペレータがプリミティブならば
   1. プリミティブ手続きの適用を呼び出す
4. 合成手続きならば
   1. 新しい環境を作る
   2. 手続きの内容をシーケンスとして評価する

4.2の実装を参考にすると、これを：

1. オペレータを評価する
2. オペレータがプリミティブならば
   1. オペランドを一つ一つactual-valueで評価してarglに溜める
   2. プリミティブ手続きの適用を呼び出す
3. 合成手続きらば
   1. オペランドを一つ一つdelay-itしてarglに溜める
   2. 新しい環境を作る
   3. 手続きの内容をシーケンスとして評価する

とするのかな。メモ化は実装しない。

まず「オペレータを評価する」については従来と同じ。

「オペランドを一つ一つ評価してarglに溜める」の部分が「オペレータがプリミティブならば、オペランドを一つ一つactual-valueで評価してarglに溜める」に変化する。オペランドを評価した後の部分を以下のように変更する。

     ev-appl-did-operator
     (restore unev)
     (restore env)
     (assign argl (op empty-arglist))
     (assign proc (reg val))
     (test (op no-operands?) (reg unev))
     (branch (label apply-dispatch))
     (test (op primitive-procedure?) (reg proc)) ; Ex 5.25
     (branch (label apply-primitive-procedure)) ; Ex 5.25
     apply-primitive-procedure ; Ex 5.25
     (save proc)
     ev-appl-operand-loop
    …

それから、引数の評価が終わった後、オペーレタを適用する部分に直接元のprimitive-applyの部分に接続する。

     ev-appl-accum-last-arg
     (restore argl)
     (assign argl (op adjoin-arg) (reg val) (reg argl))
     (restore proc)
     (assign val (op apply-primitive-procedure)
             (reg proc)
             (reg argl))
     (restore continue)
     (goto (reg continue))

これに伴って、元のapply-dispatchからprimitive-applyへのジャンプの部分は削除しておく。

     apply-dispatch
     (test (op compound-procedure?) (reg proc))  
     (branch (label compound-apply))
     (goto (label unknown-procedure-type))

ここまでのところを動作確認。プリミティブに*と/も追加しておく。

(define primitive-procedures
  (list (list 'car car)
        …
        (list '* *)
        (list '/ /)
        …
        ))

実行

;;; EC-Eval input:
(* (+ 1 2) (- 6 4))

;;; EC-Eval value:
6

この後、delay-itを実装するとなると、プリミティブの引数は単にeval-dispatchに飛んではダメで、actual-valueで評価する必要がある。元々のactual-valueはforce-itを使って以下のように定義されていた。

(define (actual-value exp env)
  (force-it (eval exp env)))
(define (force-it obj)
  (if (thunk? obj)
      (actual-value (thunk-exp obj) (thunk-env obj))
      obj))

この部分を翻訳すると。

     actual-value
     (save continue)
     (assign continue (label force-it))
     (goto (label eval-dispatch))
     force-it
     (restore continue)
     (test (op thunk?) (reg val))
     (branch (label eval-thunk))
     (goto (reg continue))
     eval-thunk
     (assign env (op thunk-env) (reg val))
     (assign exp (op thunk-exp) (reg val))
     (goto (label actual-value))

thnk?、thunk-exp、thunk-envをオペレーションとして定義。

(define (thunk? obj)
  (tagged-list? obj 'thunk))
(define (thunk-exp thunk) (cadr thunk))
(define (thunk-env thunk) (caddr thunk))
…
(define eceval-operations
  (list (list 'self-evaluating? self-evaluating?)
  …
        (list 'delay-it delay-it)
        (list 'thunk? thunk?)
        (list 'thunk-exp thunk-exp)
        (list 'thunk-env thunk-env)
        ))

ev-appl-operand-loopではeval-dispatchに飛ぶ代わりにactual-valueに飛ぶように変更。

     ev-appl-operand-loop
     (save argl)
     (assign exp (op first-operand) (reg unev))
     (test (op last-operand?) (reg unev))
     (branch (label ev-appl-last-arg))
     (save env)
     (save unev)
     (assign continue (label ev-appl-accumulate-arg))
     (goto (label actual-value)) ; Ex 5.25

ev-appl-last-argも同様。

     ev-appl-last-arg
     (assign continue (label ev-appl-accum-last-arg))
     (goto (label actual-value)) ; Ex 5.25

この時点ではdelay-itが無いので、thunkが来ることはなく、valの値はそのまま返る事になる。
操作確認

;;; EC-Eval input:
(* (+ 1 2) (- 6 4))

;;; EC-Eval value:
6

次にオペレータがプリミティブではなかった場合。それぞれの引数についてループする部分は同じだが、引数をeval-dispatchで評価するのではなくdelay-itでサンクにするだけで引数リストに追加する。

     ev-delay-operand-loop
     (assign exp (op first-operand) (reg unev))
     (assign val (op delay-it) (reg exp) (reg env))
     (assign argl (op adjoin-arg) (reg val) (reg argl))
     (assign unev (op rest-operands) (reg unev))
     (test (op no-operands?) (reg unev))
     (branch (label apply-dispatch))
     (goto (label ev-delay-operand-loop))

apply-dispatch部分は、プリミティブの手続きが来ることはないので、その処理を取り除いて元のまま。

     apply-dispatch
     (test (op compound-procedure?) (reg proc))  
     (branch (label compound-apply))
     (goto (label unknown-procedure-type))
     compound-apply
     (assign unev (op procedure-parameters) (reg proc))
     (assign env (op procedure-environment) (reg proc))
     (assign env (op extend-environment)
             (reg unev) (reg argl) (reg env))
     (assign unev (op procedure-body) (reg proc))
     (goto (label ev-sequence))

delay-itはオペレータとして登録。

(define (delay-it exp env)
  (list 'thunk exp env))
(define eceval-operations
  (list (list 'self-evaluating? self-evaluating?)
        …
        (list 'delay-it delay-it)
        ))

ここまでを動作確認。

;;; EC-Eval input:
(define (inc x) (+ x 1))

;;; EC-Eval value:
ok

;;; EC-Eval input:
(inc 2)

;;; EC-Eval value:
3

;;; EC-Eval input:
(define (try a b)
  (if (= a 0) 1 b))

;;; EC-Eval value:
ok

;;; EC-Eval input:
(try 0 (/ 1 0))

;;; EC-Eval value:
1

tryの引数の評価で割り算は実行されていない。

ただ、このままでは式の値としてサンクが返る場合にはサンクを表示してしまう。

;;; EC-Eval input:
(try 1 (/ 1 0))

;;; EC-Eval value:
(thunk (/ 1 0) #0=(#hash((map . (primitive #<procedure:map>)) (= . (primitive #<procedure:=>)) (try . (procedure (a b) ((if (= a 0) 1 b)) #0#)) (true . #t) (/ . (primitive #<procedure:/>)) (* . (primitive #<procedure:*>)) (- . (primitive #<procedure:->)) (+ . (primitive #<procedure:+>)) (null? . (primitive #<procedure:null?>)) (list . (primitive #<procedure:list>)) (cdr . (primitive #<procedure:cdr>)) (car . (primitive #<procedure:car>)) (cons . (primitive #<procedure:cons>)) (false . #f) (inc . (procedure (x) ((+ x 1)) #0#)) (newline . (primitive #<procedure:newline>)) (display . (primitive #<procedure:display>)) (> . (primitive #<procedure:>>)))))

;;; EC-Eval input:

なので、メインループでeval-dispatchを呼ぶ代わりにacual-valueを呼ぶ。actual-valueは取り敢えずeval-dispatchを呼び出すので、この呼び出しの間は必要に応じて遅延される。最後に返って来た値をforce-itする。

     (assign continue (label print-result))
     (goto (label actual-value)) ; Ex 5.25
     print-result
    …

動作確認

;;; EC-Eval input:
(define (try a b)
  (if (= a 0) 1 b))

;;; EC-Eval value:
ok

;;; EC-Eval input:
(try 0 (/ 1 0))

;;; EC-Eval value:
1

;;; EC-Eval input:
(try 1 (/ 1 0))
. . /: division by zero
> 

ちゃんと実行しようとした。

最後にifの条件式は遅延せずに評価しなければならないので以下のように変更する。

     ev-if
     (save exp)
     (save env)
     (save continue)
     (assign continue (label ev-if-decide))
     (assign exp (op if-predicate) (reg exp))
     (goto (label actual-value)) ; Ex 5.25

4.2.1のunlessを動作させてみる。

;;; EC-Eval input:
(define (unless condition usual-value exceptional-value)
  (if condition exceptional-value usual-value))

;;; EC-Eval value:
ok

;;; EC-Eval input:
(define a 6)

;;; EC-Eval value:
ok

;;; EC-Eval input:
(define b 3)

;;; EC-Eval value:
ok

;;; EC-Eval input:
(unless (= b 0)
        (/ a b)
        (begin (display "exception: returning 0")
               0))

;;; EC-Eval value:
2

;;; EC-Eval input:
(define b 0)

;;; EC-Eval value:
ok

;;; EC-Eval input:
(unless (= b 0)
        (/ a b)
        (begin (display "exception: returning 0")
               0))
exception: returning 0
;;; EC-Eval value:
0

;;; EC-Eval input:

取り敢えず、こんなところか。本当はcondとかも対応しなければならないけど省略。