今回は micro Scheme に「継続 (continuation)」を導入します。micro Scheme は Scheme 上で動作しているので、cons や eq? のように call/cc を呼び出せば、簡単に継続を実装することができます。ですが、それでは面白くないですね。そこで、インタプリタを「継続渡しスタイル (Continuation Passing Style : CPS)」で書き直して、継続を取り扱うことにします。
継続渡しスタイルについては拙作のページ 継続と継続渡しスタイル で詳しく説明しています。よろしければ参考にしてください。
まずは S 式を評価する関数 m-eval から修正します。次のリストを見てください。
リスト : S 式の評価
(define (m-eval expr env cont)
(cond ((self-evaluation? expr) (cont expr))
((symbol? expr)
(cont (cdr (lookup expr env))))
((pair? expr)
(m-eval (car expr) env
(lambda (procedure)
(case (car procedure)
((syntax) ((cadr procedure) expr env cont))
((macro)
(m-apply (cdr procedure) (cdr expr)
(lambda (new-expr)
(m-eval new-expr env cont))))
(else
(map-eval (cdr expr) env
(lambda (actuals)
(m-apply procedure actuals cont))))))))
(else
(error "unknown expression type -- m-eval" exp))))
m-eval の引数 cont が継続を表すクロージャです。たとえば、値 value を返す場合は cont に value を渡して評価します。expr が自己評価フォームの場合は expr を、変数の場合は lookup で値を求めて返します。
expr がリストの場合はちょっと複雑です。まず、先頭要素を m-eval で評価して、その値を継続の引数 procedure に渡して処理します。このように、m-eval を呼び出すときは、必ず継続渡しスタイルでプログラムを記述してください。
procedure が syntax ならば、引数と環境と継続を渡して関数を呼び出します。macro の場合は、m-apply でクロージャを評価して新しい S 式 new-expr を生成します。m-apply も継続渡しスタイルで記述し、最後の引数が継続を表すクロージャになります。このラムダ式の中で new-expr を m-eval で評価します。
関数呼び出しの場合は、関数 map-eval で引数を評価します。map-eval も継続渡しスタイルです。map-eval は引数の評価結果をリストに格納してラムダ式の引数 actuals に渡します。この中で m-apply を呼び出して関数 procedure を評価します。関数の評価結果は cont で返します。
map-eval は次のようになります。
リスト : 引数を評価する
(define (map-eval args env cont)
(if (null? args)
(cont '())
(m-eval (car args) env
(lambda (x)
(map-eval (cdr args) env
(lambda (y) (cont (cons x y))))))))
引数 args が空リストの場合は cont で空リストを返します。そうでなければ、m-eval で先頭要素を評価し、その結果を継続 (ラムダ式) の引数 x に渡します。この中で map-eval を再帰呼び出しし、残りのリストを処理します。その結果は継続の引数 y に渡されます。ここで、x と y の値を cons でつないで cont で返します。これで引数を評価した結果をリストに格納して返すことができます。
継続渡しスタイルのプログラムはちょっと難しいと思います。よく理解できない方は拙作のページ 継続と継続渡しスタイル をお読みください。
次はシンタックス形式を処理する関数を修正します。次のリストを見てください。
リスト : シンタックス形式
;;; (quote x)
(define (m-quote expr env cont) (cont (cadr expr)))
;;; (if test then else)
(define (m-if expr env cont)
(m-eval (cadr expr) env
(lambda (pred)
(if pred
(m-eval (caddr expr) env cont)
(if (null? (cdddr expr))
(cont '*undef*)
(m-eval (cadddr expr) env cont))))))
;;; (lambda (args ...) body ...)
(define (m-lambda expr env cont)
(cont (list 'closure expr env)))
;;; (define name s-expr)
(define (m-define expr env cont)
;; 内部 define は考慮しない
(m-eval (caddr expr) env
(lambda (value)
(set! *global-environment*
(cons (cons (cadr expr) value)
*global-environment*))
;; シンボルを返す
(cont (cadr expr)))))
;;; (set! name value)
(define (m-set! expr env cont)
(m-eval (caddr expr) env
(lambda (value)
(set-cdr! (lookup (cadr expr) env) value)
(cont value))))
m-quote は簡単です。expr の第 2 要素を cont に渡して評価するだけです。m-if は条件部を m-eval で評価して、その結果を継続の引数 pred に渡します。pred が真の場合、m-eval で then 節を評価します。偽の場合、else 節があればそれを m-eval で評価します。なければ、cont で *undef* を返します。m-lambda は簡単です。クロージャを生成して cont で返すだけです。
m-define は m-eval で expr の第 3 要素を評価して、その値を継続の引数 value に渡します。この中で、変数 (cadr expr) と値 value を組にして *global-environment* にセットします。そして、cont で変数を返します。m-set! は m-eval で expr の第 3 要素を評価して、継続の引数 value に渡します。この中で変数と値を格納したセルを lookup で求め、その CDR 部を value に書き換えます。最後に cont で値 value を返します。
次はマクロの処理を修正します。
リスト : マクロの定義
(define (m-define-macro expr env cont)
;; とりあえず大域変数のみ
(m-eval (caddr expr) env
(lambda (value)
(set! *global-environment*
(cons (cons (cadr expr)
(cons 'macro value))
*global-environment*))
;; symbol を返す
(cont (cadr expr)))))
m-define-macro は m-eval で expr の第 3 要素を評価して、その値を継続の引数 value に渡します。この中で、変数 (cadr expr) と (cons 'macro value) を組にして *global-environment* にセットします。そして、cont でマクロ名を表すシンボルを返します。
次はバッククオートの処理を修正します。
リスト : quasiquote
(define (m-quasiquote exp env cont)
(define (transfer ls cont)
(cond ((pair? ls)
(cond ((pair? (car ls))
(cond ((eq? (caar ls) 'unquote)
(transfer (cdr ls)
(lambda (xs)
(m-eval (cadar ls) env
(lambda (ys) (cont (cons ys xs)))))))
((eq? (caar ls) 'unquote-splicing)
(transfer (cdr ls)
(lambda (xs)
(m-eval (cadar ls) env
(lambda (ys) (cont (append ys xs)))))))
(else (transfer (car ls)
(lambda (xs)
(transfer (cdr ls)
(lambda (ys) (cont (cons xs ys)))))))))
(else (transfer (cdr ls)
(lambda (xs) (cont (cons (car ls) xs)))))))
(else (cont ls))))
(transfer (cadr exp) cont))
内部関数 transfer を継続渡しスタイルで書き直します。引数 cont が継続です。ls の先頭要素で (unquote ...) を見つけた場合、残りのリスト (cdr ls) を transfer で処理し、その結果を継続の引数 xs に渡します。この中で m-eval を呼び出して、unquote の引数を評価します。その結果を継続の引数 ys に渡し、cons で ys と xs を結合して cont で返します。unquote-splicing を見つけた場合は append で結合します。
そうでなければ transfer で (car ls) を処理し、その結果を継続の引数 xs に渡します。この中で残りのリスト (cdr ls) を処理して、その結果を継続の引数 ys に渡します。あとは cons で xs と ys を結合して cont で返します。
ls の先頭要素がリストでなければ、transfer で (cdr ls) を処理して、その結果と先頭要素を cons で結合して返します。ls がリストでなければ、それをそのまま cont で返すだけです。
次は関数適用の処理を修正します。ここで継続を取り出す関数 call/cc と高階関数 apply を追加します。apply は継続のテストで使うため実装します。継続は引数を一つ受け取る関数として定義します。これらの関数を表すため、primitive の構造を修正します。第 2 要素がシンボルの場合、それに対応する処理を行うようにします。
primitive apply : apply の処理 primitive call/cc : call/cc の処理 primitive continuation cont : 継続 cont の評価 primitive #<func> : 関数 func の評価
継続は (primitive continuation cont) で表します。cont は継続渡しスタイルで引数として渡している継続です。この継続を micro Scheme の関数値として取り出すことで、micro Scheme で継続を実装することができます。この処理を関数 p-call/cc で行います。
リスト : micro Scheme 用 call/cc
(define (p-call/cc procedure cont)
(m-apply procedure
(list (list 'primitive 'continuation cont)) cont))
p-call/cc は m-apply を呼び出して procedure を評価します。このとき、継続を表す関数 (primitive continuation cont) を生成します。ここで継続 cont が取り出されて、関数値を表すリストに保存されます。それをリストに格納して m-apply に渡します。これで procedure に継続を渡して評価することができます。
m-apply のプログラムは次のようになります。
リスト : 関数適用
(define (m-apply procedure actuals cont)
(case (car procedure)
((primitive)
(case (cadr procedure)
((apply)
(p-apply (car actuals) (cdr actuals) cont))
((call/cc)
(p-call/cc (car actuals) cont))
((continuation)
((caddr procedure) (car actuals)))
(else
(cont (apply (cadr procedure) actuals)))))
((closure)
(let ((expr (cadr procedure)))
;; body の評価
(eval-body (cddr expr)
(add-binding (cadr expr) actuals (caddr procedure))
cont)))
(else
(error "unknown procedure type -- m-apply" procedure))))
m-apply も継続渡しスタイルで記述します。procedure が primitive の場合、第 2 要素によって処理を振り分けます。apply であれば、p-apply を呼び出して関数 apply の処理を行います。call/cc の場合は p-call/cc を呼び出します。
continuation の場合、第 3 要素の継続に引数を一つ渡して評価します。このとき、m-apply の引数 cont を評価して値を返すのではなく、procedure に格納されている継続を評価することで値を返すことに注意してください。他の関数は apply で評価して、その結果を cont に渡して返します。
procedure が closure の場合は、add-binding で変数束縛を行い、eval-body で本体を評価します。eval-body も継続渡しスタイルでプログラムします。次のリストを見てください。
リスト : body の評価
(define (eval-body body env cont)
(if (null? (cdr body))
(m-eval (car body) env cont)
(m-eval (car body) env
(lambda (value)
(eval-body (cdr body) env cont)))))
body の要素が残り一つの場合、それを m-eval で評価します。要素が複数有る場合、m-eval で先頭要素を評価し、その結果を継続の引数 value に渡します。そして、eval-body を再帰呼び出しします。この場合、value は使用されずに捨てられることになります。結局、最後の S 式の評価結果を cont で返すことになります。
次は apply を処理する関数 p-apply を作ります。
リスト : micro Scheme 用 apply
(define (p-apply procedure actuals cont)
;; 複数の引数を最後のリストに集める
(define (collect-actuals ls)
(if (null? (cdr ls))
(car ls)
(cons (car ls) (collect-actuals (cdr ls)))))
(m-apply procedure (collect-actuals actuals) cont))
apply に与えられる最後の引数はリストです。内部関数 collect-actuals は最後の引数の先頭に、今までの引数を追加して返します。つまり、次のような動作を行います。
(collect-actuals '(a b (c d e))) => '(a b c d e)
そして、m-apply で procedure を評価します。これでリストの引数を展開して procedure に渡すことができます。
最後に REPL (read-eval-print-loop) を修正します。次のリストを見てください。
リスト : REPL
; 初期化
(define *global-environment*
(list
(list 'car 'primitive car)
(list 'cdr 'primitive cdr)
(list 'cons 'primitive cons)
(list 'eq? 'primitive eq?)
(list 'eqv? 'primitive eqv?)
(list 'pair? 'primitive pair?)
(list 'call/cc 'primitive 'call/cc)
(list 'apply 'primitive 'apply)
(list 'display 'primitive (lambda (x) (display x) '*undef*))
(list 'newline 'primitive (lambda () (newline) '*undef*))
(list 'if 'syntax m-if)
(list 'quote 'syntax m-quote)
(list 'lambda 'syntax m-lambda)
(list 'define 'syntax m-define)
(list 'set! 'syntax m-set!)
(list 'define-macro 'syntax m-define-macro)
(list 'quasiquote 'syntax m-quasiquote)
))
;;; read-eval-print-loop
(define (repl)
(let loop ()
(display "\n>>> ")
(display (m-eval (read) '() (lambda (x) x)))
(newline)
(loop)))
*global-environment* には apply と call/cc のほかに、テストで使うため display と newline を追加します。関数 repl は m-eval に (lambda (x) x) を渡すだけです。これで、m-eval の評価結果を求めて、display で表示することができます。
それでは実際に継続を使ってみましょう。
>>> (define list (lambda x x)) list >>> (define a #f) a >>> (list 'a 'b (call/cc (lambda (k) (set! a k) 'c)) 'd) (a b c d) >>> a (primitive continuation #<closure (map-eval #f)>) >>> (a 'e) (a b e d) >>> (a 'f) (a b f d)
変数 a に取り出した継続をセットします。この場合、継続は (list a b [ ] 'd) になります。list の処理だけではなく、'd を評価する処理も残っています。継続 a に引数を渡して評価すると、[ ] の部分に継続の引数がセットされ、'd を評価して list に渡されます。したがって、(a 'e) を評価すると (a b e d) になり、(a 'f) を評価すると (a b f d) になります。正常に動作していますね。
次は大域脱出を試してみましょう。
リスト : 大域脱出 (define bar1 (lambda (cont) (display "call bar1\n"))) (define bar2 (lambda (cont) (display "call bar2\n") (cont #f))) (define bar3 (lambda (cont) (display "call bar3\n"))) (define test (lambda (cont) (bar1 cont) (bar2 cont) (bar3 cont)))
>>> (call/cc (lambda (cont) (test cont))) call bar1 call bar2 #f
bar2 からトップレベルへ脱出するので、bar3 は呼び出されていません。これも正常に動作していますね。
もちろん、繰り返しから脱出することもできます。次の例を見てください。
リスト : do から脱出する場合
(define find-do
(lambda (fn ls)
(call/cc
(lambda (k)
(do ((xs ls (cdr xs)))
((null? xs) #f)
(if (fn (car xs)) (k (car xs))))))))
リスト ls から関数 fn が真を返す要素を探します。継続のテストということで、あえて do を使って実装しています。fn が真を返す場合、継続 k でその要素を返します。それでは実行してみましょう。
>>> (find-do (lambda (x) (eq? 'c x)) '(a b c d e)) c >>> (find-do (lambda (x) (eq? 'c x)) '(a b d e f)) #f
もちろん高階関数からも脱出することができます。
リスト : map から脱出する場合
(define map-check (lambda (fn chk ls)
(call/cc
(lambda (k)
(map (lambda (x) (if (chk x) (k '()) (fn x))) ls)))))
>>> (map-check (lambda (x) (cons x x)) (lambda (x) (eq? x 'e)) '(a b c d e f)) () >>> (map-check (lambda (x) (cons x x)) (lambda (x) (eq? x 'e)) '(a b c d f)) ((a . a) (b . b) (c . c) (d . d) (f . f))
関数 chk が真となる要素がある場合、処理を中断して空リストを返します。これも正常に動いていますね。
再帰呼び出しから脱出することも簡単です。
リスト : flatten の再帰呼び出しから脱出する場合
(define flatten (lambda (ls)
(call/cc
(lambda (cont)
(letrec ((flatten-sub
(lambda (ls)
(cond ((null? ls) '())
((not (pair? ls)) (list ls))
((null? (car ls)) (cont '()))
(else (append (flatten-sub (car ls))
(flatten-sub (cdr ls))))))))
(flatten-sub ls))))))
拙作のページ 継続と継続渡しスタイル で作成したプログラムと同じです。リストを平坦化する関数 flatten で、要素に空リストが含まれている場合は空リストを返します。
>>> (flatten '(a (b (c (d . e) f) g) h)) (a b c d e f g h) >>> (flatten '(a (b (c (d () . e) f) g) h)) ()
これも正常に動作しています。
最後に、イテレータを生成する関数 make-iter を試してみます。
リスト : イテレータを生成する関数
(define make-iter
(lambda (proc . args)
(letrec ((iter
(lambda (return)
(apply
proc
(lambda (x) ; 高階関数に渡す関数の本体
(set! return ; 脱出先継続の書き換え
(call/cc
(lambda (cont)
(set! iter cont) ; 継続の書き換え
(return x)))))
args)
;; 終了後は継続 return で脱出
(return #f))))
(lambda ()
(call/cc
(lambda (cont) (iter cont)))))))
リスト : 木の高階関数
(define for-each-tree
(lambda (fn ls)
(let loop ((ls ls))
(cond ((null? ls) '())
((pair? ls)
(loop (car ls))
(loop (cdr ls)))
(else (fn ls))))))
拙作のページ 継続と継続渡しスタイル で作成したプログラムと同じです。それでは実行してみましょう。
>>> (define a (make-iter for-each-tree '(a (b (c (d . e) f) g) h))) a >>> (a) a >>> (a) b >>> (a) c >>> (a) d >>> (a) e >>> (a) f >>> (a) g >>> (a) h >>> (a) #f
正常に動作していますね。なお、(a) を評価する前に変数 a の値を表示すると無限ループになります。ご注意ください。
最後に末尾再帰最適化について考えてみましょう。Scheme は末尾再帰最適化を行うので、ある条件で m-eval が末尾再帰していれば、micro Scheme も末尾再帰最適化が行われます。実をいうと micro Scheme は最初から末尾再帰最適化が行われているのです。なお、ここでいう末尾再帰最適化は処理速度のことではなく、次に示すような関数呼び出しにおいて、スタックを消費せずに実行できることです。
>>> (define foo (lambda () (foo))) foo >>> (foo) => 無限ループになる
末尾再帰最適化が行われる場合、foo を評価すると無限ループになります。実際、micro Scheme で foo を評価すると無限ループになります。
末尾再帰の末尾とは最後に行われる処理のことで、一般に末尾で関数を呼び出すことを「末尾呼び出し」といいます。関数を呼び出す場合、返ってきた後に行う処理のために、必要な情報を保存しておかなければいけません。ところが、末尾呼び出しはそのあと実行する処理がないので、情報を保存しておく必要がありません。このため、末尾再帰は繰り返しに変換することができるのです。
簡単な例として、Common Lisp で階乗を計算する関数 fact を作りましょう。
リスト : 末尾再帰を繰り返しに変換する
(defun fact (x a)
(if (= x 0)
a
(fact (- x 1) (* a x))))
(defun facti (x a)
(tagbody
loop
(if (= x 0)
(return-from facti a))
(setf a (* a x)
x (- x 1))
(go loop)))
fact は末尾再帰になっています。これを繰り返しに変換すると facti のようになります。引数 x と a の値を保存する必要が無いので、値を書き換えてから先頭の処理へジャンプします。tagbody はジャンプ命令 go を使うための特殊形式 (シンタックス形式) です。Scheme に tagbody と go はありませんが、末尾再帰は最適化が行われるため効率的に処理することができます。
micro Scheme で S 式を評価するとき、末尾呼び出しが行われる場所は m-if と eval-body の 2 か所しかありません。次のリストを見てください。
リスト : 末尾呼び出しの処理
;;; (if test then else)
(define (m-if expr env)
(if (m-eval (cadr expr) env)
(m-eval (caddr expr) env)
(if (null? (cdddr expr))
'*undef*
(m-eval (cadddr expr) env))))
;;; body の評価
(define (eval-body body env)
(cond ((null? (cdr body))
(m-eval (car body) env)) ; 最後の S 式の評価結果を返す
(else
(m-eval (car body) env)
(eval-body (cdr body) env))))
m-if は条件部を評価したあと、then 節か else 節を評価しますが、そのあと評価する S 式はありません。どちらの節を評価するにしても末尾で m-eval を呼び出しているので、m-eval は m-if を経由していますが末尾再帰になっています。このような場合でも Scheme は最適化してくれます。
eval-body の場合も同様です。最後の S 式を評価するときの m-eval は末尾呼び出しになっているので、m-apply と eval-body を経由して m-eval は末尾再帰になります。このように m-eval を末尾再帰でプログラムすると、micro Scheme で S 式を評価するときに末尾再帰最適化が行われます。
継続渡しスタイルの場合も同じです。m-if と eval-body の末尾呼び出しで、m-eval を末尾再帰でプログラムすれば、micro Scheme でも末尾再帰最適化が行われます。ちなみに、eval-body を次のようにプログラムすると、末尾再帰最適化は行われません。
リスト : body の評価 (間違い)
(define (eval-body body env cont)
(m-eval (car body) env
(lambda (value)
(if (null? (cdr body))
(cont value)
(eval-body (cdr body) env cont)))))
これでも継続は正常に動作しますが、if の then 節で m-eval を呼び出していないので、m-eval の呼び出しは末尾再帰になりません。ご注意くださいませ。
;;;
;;; micro.scm : Micro Scheme (R7RS-small 対応版)
;;;
;;; (1) 基本機能の実装
;;; (2) 伝統的なマクロを追加
;;; (3) 継続を CPS で実装
;;;
;;; Copyright (C) 2009-2021 Makoto Hiroi
;;;
(import (scheme base) (scheme cxr) (scheme write) (scheme read)
(scheme file) (scheme process-context))
;;; 変数束縛
(define (add-binding vars vals env)
(cond ((null? vars) env) ; 実引数が多い場合は無視する
((symbol? vars)
;; 実引数をリストにまとめて変数に束縛
(cons (cons vars vals) env))
(else
(cons (cons (car vars) (car vals))
(add-binding (cdr vars) (cdr vals) env)))))
;;; 変数を環境から探す
(define (lookup var env)
;; 局所変数から探す
(let ((value (assoc var env)))
(if value
value
;; 大域変数から探す
(assoc var *global-environment*))))
;;;
;;; syntax
;;;
;;; (quote x)
(define (m-quote expr env cont) (cont (cadr expr)))
;;; (if test then else)
(define (m-if expr env cont)
(m-eval (cadr expr) env
(lambda (pred)
(if pred
(m-eval (caddr expr) env cont)
(if (null? (cdddr expr))
(cont '*undef*)
(m-eval (cadddr expr) env cont))))))
;;; (lambda (args ...) body ...)
(define (m-lambda expr env cont)
(cont (list 'closure expr env)))
;;; (define name s-expr)
(define (m-define expr env cont)
;; 内部 define は考慮しない
(m-eval (caddr expr) env
(lambda (value)
(set! *global-environment*
(cons (cons (cadr expr) value)
*global-environment*))
;; シンボルを返す
(cont (cadr expr)))))
;;; (set! name value)
(define (m-set! expr env cont)
(m-eval (caddr expr) env
(lambda (value)
(set-cdr! (lookup (cadr expr) env) value)
(cont value))))
;;;
;;; マクロ
;;;
;;; (define-macro name s-expr)
(define (m-define-macro expr env cont)
;; とりあえず大域変数のみ
(m-eval (caddr expr) env
(lambda (value)
(set! *global-environment*
(cons (cons (cadr expr)
(cons 'macro value))
*global-environment*))
;; symbol を返す
(cont (cadr expr)))))
;;; quasiquote
(define (m-quasiquote exp env cont)
(define (transfer ls cont)
(cond ((pair? ls)
(cond ((pair? (car ls))
(cond ((eq? (caar ls) 'unquote)
(transfer (cdr ls)
(lambda (xs)
(m-eval (cadar ls) env
(lambda (ys) (cont (cons ys xs)))))))
((eq? (caar ls) 'unquote-splicing)
(transfer (cdr ls)
(lambda (xs)
(m-eval (cadar ls) env
(lambda (ys) (cont (append ys xs)))))))
(else (transfer (car ls)
(lambda (xs)
(transfer (cdr ls)
(lambda (ys) (cont (cons xs ys)))))))))
(else (transfer (cdr ls)
(lambda (xs) (cont (cons (car ls) xs)))))))
(else (cont ls))))
(transfer (cadr exp) cont))
;;;
;;; 関数適用
;;;
;;; 関数値 : (tag ...)
;;; tag
;;; syntax : シンタックス形式 (syntax m-xxx)
;;; primitive : プリミティブ (primitive #<subr ...>)
;;; closure : クロージャ (closure (lambda (args ...) body ...) env)
;;; macro : マクロ (macro (lambda (args ...) body ...))
;;; 継続
(define (p-call/cc procedure cont)
(m-apply procedure
(list (list 'primitive 'continuation cont)) cont))
;;; apply
(define (p-apply procedure actuals cont)
;; 複数の引数を最後のリストに集める
(define (collect-actuals ls)
(if (null? (cdr ls))
(car ls)
(cons (car ls) (collect-actuals (cdr ls)))))
(m-apply procedure (collect-actuals actuals) cont))
;;; apply
;;; procedure := 関数値
(define (m-apply procedure actuals cont)
(case (car procedure)
((primitive)
(case (cadr procedure)
((apply)
(p-apply (car actuals) (cdr actuals) cont))
((call/cc)
(p-call/cc (car actuals) cont))
((continuation)
((caddr procedure) (car actuals)))
(else
(cont (apply (cadr procedure) actuals)))))
((closure)
(let ((expr (cadr procedure)))
;; body の評価
(eval-body (cddr expr)
(add-binding (cadr expr) actuals (caddr procedure))
cont)))
(else
(error "unknown procedure type -- m-apply" procedure))))
;;;
;;; S 式の評価
;;;
;;; body の評価
(define (eval-body body env cont)
(if (null? (cdr body))
(m-eval (car body) env cont)
(m-eval (car body) env
(lambda (value)
(eval-body (cdr body) env cont)))))
;;; 自己評価フォームか
(define (self-evaluation? expr)
(and (not (pair? expr)) (not (symbol? expr))))
;;; 引数を評価する
(define (map-eval args env cont)
(if (null? args)
(cont '())
(m-eval (car args) env
(lambda (x)
(map-eval (cdr args) env
(lambda (y) (cont (cons x y))))))))
;;; eval
(define (m-eval expr env cont)
(cond ((self-evaluation? expr) (cont expr))
((symbol? expr)
(cont (cdr (lookup expr env))))
((pair? expr)
(m-eval (car expr) env
(lambda (procedure)
(case (car procedure)
((syntax) ((cadr procedure) expr env cont))
((macro)
(m-apply (cdr procedure) (cdr expr)
(lambda (new-expr)
(m-eval new-expr env cont))))
(else
(map-eval (cdr expr) env
(lambda (actuals)
(m-apply procedure actuals cont))))))))
(else
(error "unknown expression type -- m-eval" exp))))
;;; 初期化
(define *global-environment*
(list
(list 'car 'primitive car)
(list 'cdr 'primitive cdr)
(list 'cons 'primitive cons)
(list 'eq? 'primitive eq?)
(list 'eqv? 'primitive eqv?)
(list 'pair? 'primitive pair?)
(list 'call/cc 'primitive 'call/cc)
(list 'apply 'primitive 'apply)
(list 'display 'primitive (lambda (x) (display x) '*undef*))
(list 'newline 'primitive (lambda () (newline) '*undef*))
(list 'if 'syntax m-if)
(list 'quote 'syntax m-quote)
(list 'lambda 'syntax m-lambda)
(list 'define 'syntax m-define)
(list 'set! 'syntax m-set!)
(list 'define-macro 'syntax m-define-macro)
(list 'quasiquote 'syntax m-quasiquote)
))
;;; read-eval-print-loop
(define (repl)
(let loop ()
(display "\n>>> ")
(display (m-eval (read) '() (lambda (x) x)))
(newline)
(loop)))
;;; ファイルの読み込み
(for-each
(lambda (name)
(with-input-from-file name
(lambda ()
(let loop ()
(let ((output (m-eval (read) '() (lambda (x) x))))
(if (not (eof-object? output))
(loop)))))))
(cdr (command-line)))
;;; 実行
(repl)