Schemeのメタ循環インタプリタに, shift/reset(限定継続)の機能を付け加えよう. という話です.
最初からすべてを実装するのは大変なので, 3つのversionを作ります.Schemeの処理系はGaucheを想定しています.
interp1 : 普通のSchemeで作成した（Schemeのsubsetを解釈する）メタ循環インタプリタ
interp2 : カリー化されたSchemeのメタ循環インタプリタ
interp3 : Abstrcting Control(論文)のSemanticsに基づいたインタプリタ
shift/resetの評価器 次の一連の式は, shift/resetを実行可能な評価関数の定義です. 論文(
Abstracting Control )のセクション1, Extended Continuation-Passing Styleの後半部分に登場する評価器(evaluator)です.
一番先頭の行は, 評価器(インタプリタ)の型で, 式と環境, 継続とメタ継続(限定継続)を引数にとり, 計算結果を返すものです. 上から順に変数, 組み込み関数(オペレータ)の適用, 関数適用, ラムダ抽象, if(条件分岐), call/cc, shift, resetを表します.
基本的に, ラムダ計算にcall/cc, shift/reset, ifと定数/プリミティブ関数を拡張したプログラムになります.
Eval :: Exp -> Env -> Cont -> MCont -> Ans
Eval [ x ] ρκγ = κ ( ρ [ x ]) γ
Eval [ π E ] ρκγ = Eval [ E ] ρ ( λ νγ' . κ ( π ν ) γ' ) γ
Eval [ E 1 E 2 ] ρκγ = Eval [ E 1 ] ρ ( λ fγ' . Eval [ E 2 ] ρ ( λ aγ" . f a κ γ" ) γ' ) γ
Eval [ λ x . E ] ρκγ = κ ( λ νκ'γ' . Eval [ E ] ρ [ x := ν ] κ' γ' ) γ
Eval [ E 1 → E 2 | E 3 ] ρκγ
= Eval [ E 1 ] ρ ( λ bγ' . b → Eval [ E 2 ] ρκγ' | Eval [ E 3 ] ρκγ' ) γ
Eval [ ε k . E ] ρκγ = Eval [ E ] ρ [ k := ( λ νκ'γ' . κ ν γ' )] κ γ
Eval [ ξ k . E ] ρκγ = Eval [ E ] ρ [ k := ( λ νκ'γ' . κ ν ( λ w . κ' w γ' ))] ( λ xγ" . γ" x ) γ
Eval [{ E }] ρκγ = Eval [ E ] ρ ( λ xγ' . γ' x ) ( λ ν . κνγ ) ρ[x] は, 環境ρから変数xに相当する値を返す処理を意味しています.
E
1 →E
2 |E
3 は, Schemeにおける (if E
1 E
2 E
3 )を表します.
ρ[x:=ν]は, 環境ρ中のxをνに置き換えることの表現です.
Eval[x]ρκγ = ...は例えば, 評価関数が式x(変数)と, 環境ρ, 継続κ, メタ継続γを引数として受け取った時, 右側の式を返すという風に読みます.
全体的に限定継続付きの継続渡しスタイルになっていて, ある評価ステップで計算しきれなかった計算(=残りの計算)は, 次以降のステップで継続として記述されます. 定数/変数項やラムダ抽象のステップでは, これ以上計算できないので, 継続にその式(定数やラムダ抽象など)を関数適用します. それ以外のステップは, 基本的に残りの計算を継続で表現して, 式(プログラム)の解釈を進めます.
最終的な目標 次のような実装を実現することです.
gosh > ( interp3 ' ( reset ( + 1 ( shift ( c ) ( c 10 )))))
11
gosh > ( interp3 ' ( reset ( + 1 ( shift ( c ) ( c ( c 10 ))))))
12
gosh > ( interp3 ' ( reset ( + 1 ( shift ( c ) 10 ))))
10 一番目の実行では, 限定継続が1回実行されて11を返しますが, 二回目は, 2回実行されて12を返します. 最後の実行では, 残りの計算が切り捨てられて10を返しています.
interp1(メタ循環インタプリタの実装) interp1では, 簡単なラムダ抽象とその関数適用, ifによる分岐, プリミティブの演算の実行が可能な処理系を作成します.
文法は以下のようなものを受け付けます.
exp := const | var | (exp exp ...) | (lambda (var ...) exp) | (if exp exp exp)
interp1の実装は次のようになります.
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
;; a simple meta-circular interpreter
(use util.match)
(define lookup
(lambda (var env exception)
(cond
((null? env)
(exception (string-append
"# error :: could not find the variable > "
(symbol->string var))))
((eq? var (caar env))
(cdar env))
(else
(lookup var (cdr env) exception)))))
(define extend*
(lambda (vars vals env)
(append
(map (lambda (var val) `(,var . ,val)) vars vals)
env)))
(define initial-env
(extend* '(+ - * / mod < > <= >= = eq? equal? number?)
(list + - * / mod < > <= >= = eq? equal? number?)
'()))
(define eval1
(lambda (s-exp env exception)
(match s-exp
((and ('lambda args body) lambda-exp)
`(,lambda-exp . ,env))
(('if cond-exp then-exp else-exp)
(if (eval1 cond-exp env exception)
(eval1 then-exp env exception)
(eval1 else-exp env exception)))
((func-exp . args-exps)
(let ((args (map (lambda (exp) (eval1 exp env exception)) args-exps))
(function (eval1 func-exp env exception)))
(if (procedure? function)
(apply function args)
(match function
((('lambda vars body) . env)
(eval1 body (extend* vars args env) exception))
(a
(display a)
(exception "# error :: malformed lambda"))))))
(a
(cond
((or (string? a) (boolean? a) (number? a))
a)
((symbol? a)
(lookup a env exception))
(else
(exception "# error :: malformed object")))))))
(define interp1
(lambda (s-exp)
(call/cc
(lambda (exit-point)
(eval1 s-exp initial-env exit-point)))))
;; sample programs
(define factorial-p
'(((lambda (f) ((lambda (p) (f (lambda (a) ((p p) a))))
(lambda (p) (f (lambda (a) ((p p) a))))))
(lambda (y) (lambda (n) (if (< n 1) 1 (* n (y (- n 1))))))) 100))
(define fib-p
'(((lambda (f) ((lambda (p) (f (lambda (a) ((p p) a))))
(lambda (p) (f (lambda (a) ((p p) a))))))
(lambda (fib)
(lambda (n) (if (< n 1) 1 (+ (fib (- n 1)) (fib (- n 2))))))) 10))
環境(変数を表すシンボルとその値のペアからなるリスト)から変数名を探し, それに該当する値を返すのがlookup関数, extend*は, 環境を拡張する関数でインタプリタでは共に定番の補助関数となっています. initial-envは, プリミティブの演算(関数)が含まれている環境. eval1がインタプリタ. interp1は例外の機構を付け加えたインタプリタです(interp2以降では, もう少し複雑な使われ方をします).
サンプルプログラムとして, 階乗を計算するプログラムとフィボナッチ数を計算するプログラムを作成しました. ループは不動点コンビネータで記述します.
評価関数は, schemeのmatchマクロの都合上, 最初に(lambda, ifなどの)スペシャルフォームを持ってきて, 次に関数適用, 定数/変数といった順に並べる必要がありました.
ラムダ抽象を評価した結果の値は, レキシカルクロージャ(ラムダ抽象と環境のペア)です.
エラーが発生するポイントとしては, 探している変数が見つからないlookup関数(8行目), 間違った関数適用の形式(46行目), 想定されていないプログラムのフォーマット(54行目)などがあります. このようなケースでは, continuationを使って, 脱出します.
実行結果は, こんな感じです.
gosh > ( interp1 factorial - p )
93326215443944152681699238856266700490715968264381621468592963895217599993229915608941463976156518286253697920827223758251185210916864000000000000000000000000
gosh > ( interp1 fib - p )
144
gosh > ( interp1 '( ( lambda ( x y ) (+ x (* y y ))) 7 12 ))
151 interp2(カリー化) 基本的に動作(計算結果, 機能など)については, interp1とほぼ同じですが, 内部的に式をカリー化したインタプリタを作成します. interp2では, プログラムとなる式を受け取ると, 内部的にカリー化して, カリー化された式を受け付けるインタプリタによりプログラムを計算します.
また, これに伴い, プリミティブの関数もカリー化します.
interp2の動作とinterp1の動作の違いは, 例えば, 次のプログラムを解釈できるか否かだと言えます.
gosh > ( interp2 ' (( lambda ( x ) ( x 2 )) ( + 4 )))
6
gosh > ( interp1 ' (( lambda ( x ) ( x 2 )) ( + 4 )))
4 "# error :: malformed lambda" interp1では, +関数のカリー化に失敗しています(ラムダ抽象で包み込む必要があります)が, interp2では, その必要がありません (Haskell likeなスタイルになっているようにも見えます).
interp2の実装は以下のとおり.
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
;; a simple meta-circular interpreter
;; curried version
(use util.match)
(define lookup
(lambda (var env exception)
(cond
((null? env)
(exception (string-append
"# error :: could not find the variable > "
(symbol->string var))))
((eq? var (caar env))
(cdar env))
(else
(lookup var (cdr env) exception)))))
(define extend
(lambda (var val env)
`((,var . ,val) . ,env)))
(define extend*
(lambda (vars vals env)
(append
(map (lambda (var val) `(,var . ,val)) vars vals)
env)))
(define-syntax curry
(syntax-rules ()
((_ (a) body)
(lambda (a) body))
((_ (a b ...) body)
(lambda (a)
(curry (b ...) body)))))
(define-syntax curry*
(syntax-rules ()
((_ (f args ...))
(curry (args ...) (f args ...)))))
(define-syntax curry-primitives-2
(syntax-rules ()
((_ f)
(list (curry* (f x y))))
((_ f fs ...)
(cons (curry* (f x y)) (curry-primitives-2 fs ...)))))
(define initial-env2
(extend* '(+ - * / mod < > <= >= = eq? equal?)
(curry-primitives-2
+ - * / mod < > <= >= = eq? equal?) '()))
(define eval2
(lambda (s-exp env exception)
(match s-exp
((and ('lambda (a) body) lambda-exp)
`(,lambda-exp . ,env))
(('if cond-exp then-exp else-exp)
(if (eval2 cond-exp env exception)
(eval2 then-exp env exception)
(eval2 else-exp env exception)))
((func-exp arg-exp)
(let ((arg (eval2 arg-exp env exception))
(function (eval2 func-exp env exception)))
(if (procedure? function)
(function arg)
(match function
((('lambda (var) body) . env)
(eval2 body (extend var arg env) exception))
(a
(exception "# error :: malformed lambda"))))))
(a
(cond
((or (string? a) (boolean? a) (number? a))
a)
((symbol? a)
(lookup a env exception))
(else
(exception "# error :: malformed object")))))))
(define curry-s-exp
(lambda (s-exp exception)
(match s-exp
(('lambda (a) body)
`(lambda (,a) ,(curry-s-exp body exception)))
(('lambda args body)
`(lambda (,(car args))
,(curry-s-exp `(lambda ,(cdr args) ,body) exception)))
(('if cond-exp then-exp else-exp)
`(if ,(curry-s-exp cond-exp exception)
,(curry-s-exp then-exp exception)
,(curry-s-exp else-exp exception)))
((fun-exp . args-exp)
(let ((fun (curry-s-exp fun-exp exception))
(args (map (lambda (exp) (curry-s-exp exp exception)) args-exp)))
(fold (lambda (a f) `(,f ,a)) fun args)))
(a
(if (or (boolean? a) (symbol? a) (number? a) (string? a))
a
(exception "# error :: malformed target program"))))))
(define interp2
(lambda (s-exp)
(call/cc
(lambda (exit-point)
(eval2 (curry-s-exp s-exp exit-point) initial-env2 exit-point)))))
実行結果は,前述のケース以外では, interp1と同じです.
プリミティブ関数をカリー化するcurryマクロとそれに関連するcurry*, curry-primitives-2などのマクロが登場しています. これは, プリミティブの関数fを, (lambda (x) (lambda (y) (f x y)))と書き直すことで, カリー化するマクロです. カリー化されたことで, eval2インタプリタでは, 関数適用が必ず関数と引数のペアになりました(今までは, 関数と引数の割合は一対多でした).
curry-s-expは, 普通のS式を引数にとって, カリー化されたS式を返します.
interp3(素朴なshift/resetの実装) interp2まで完成すると, いよいよ, shift/resetが実装できるようになります. shift/resetの評価器は, 継続渡しスタイルで記述されます.
interp3の実装はこのようになります.
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
;; a simple meta-circular interpreter
;; shift/reset (delimited continuation) implemented
(use util.match)
(define lookup
(lambda (var env exception)
(cond
((null? env)
(exception (string-append
"# error :: could not find the variable > "
(symbol->string var))))
((eq? var (caar env))
(cdar env))
(else
(lookup var (cdr env) exception)))))
(define extend
(lambda (var val env)
`((,var . ,val) . ,env)))
(define extend*
(lambda (vars vals env)
(append
(map (lambda (var val) `(,var . ,val)) vars vals)
env)))
;; (\vky. (k (\v'k'y'. (k' (f v v') y'))))
(define-syntax normal2->cps2
(syntax-rules ()
((_ f)
(lambda (v k y)
(k (lambda (vv kk yy) (kk (f v vv) yy)) y)))))
(define-syntax add-transform-cps-2
(syntax-rules ()
((_ () () env)
env)
((_ (var vars ...) (val vals ...) env)
(extend 'var (normal2->cps2 val)
(add-transform-cps-2 (vars ...) (vals ...) env)))))
(define initial-env3
(add-transform-cps-2
(+ - * / mod < > <= >= = eq? equal?)
(+ - * / mod < > <= >= = eq? equal?)
'()))
;; Eval : Exp -> Env -> Cont -> MCont -> Ans
;; Eval[\x. E]rky = k (\vk'y'.Eval[E]r[x:= v] k' y') y
;; Eval[E1 -> E2|E3]rky = Eval[E1] r (\by'. b -> Eval[E2]rky' | Eval[E3]rky') y
;; Eval[call/cc c. E]rky= Eval[E] r [c:= (\vk'y'. k v y')] k y
;; Eval[shift c. E]rky = Eval[E] r [c:= (\vk'y'. k v (\w. k'wy'))] (\xy''.y''x) y
;; Eval[{E}]rky = Eval[E] r (\xy'. y' x) (\v.kvy)
;; Eval[p E]rky = Eval[E] r (\vy'. k (p v) y') y
;; Eval[E1 E2]rky = Eval[E1] r (\fy'. Eval[E2] r (\ay''. f a k y'') y') y
;; Eval[c]rky = k c y
;; Eval[x]rky = k (r[x]) y
;; continuation : Value -> MCont -> Ans
;; meta-continuation : Value -> Ans
(define eval3-gen
(lambda (exception)
(define eval3
(lambda (exp env k y)
(match exp
(('lambda (a) body)
(k (lambda (v kk yy) (eval3 body (extend a v env) kk yy)) y))
(('if cond-exp then-exp else-exp)
(eval3 cond-exp env
(lambda (b yy) (if b (eval3 then-exp env k yy)
(eval3 else-exp env k yy)))
y))
(('call/cc (c) body)
(eval3 body (extend c (lambda (v kk yy) (k v yy)) env) k y))
(('shift (c) body)
(eval3 body (extend c (lambda (v kk yy) (k v (lambda (w) (kk w yy)))) env)
(lambda (x yyy) (yyy x)) y))
(('reset body)
(eval3 body env (lambda (x yy) (yy x)) (lambda (v) (k v y))))
((e1 e2)
(eval3 e1 env
(lambda (f yy)
(eval3 e2 env (lambda (a yyy) (f a k yyy)) yy))
y))
(a
(cond
((or (boolean? a) (number? a) (string? a))
(k a y))
((symbol? a)
(k (lookup a env exception) y))
(else
(exception "# error :: malformed object")))))))
eval3))
(define curry-s-exp-with-cont
(lambda (s-exp exception)
(match s-exp
(('lambda (a) body)
`(lambda (,a) ,(curry-s-exp-with-cont body exception)))
(('lambda args body)
`(lambda (,(car args))
,(curry-s-exp-with-cont `(lambda ,(cdr args) ,body) exception)))
(('call/cc (c) body)
`(call/cc (,c) ,(curry-s-exp-with-cont body exception)))
(('shift (c) body)
`(shift (,c) ,(curry-s-exp-with-cont body exception)))
(('reset body)
`(reset ,(curry-s-exp-with-cont body exception)))
(('if cond-exp then-exp else-exp)
`(if ,(curry-s-exp-with-cont cond-exp exception)
,(curry-s-exp-with-cont then-exp exception)
,(curry-s-exp-with-cont else-exp exception)))
((fun-exp . args-exp)
(let ((fun (curry-s-exp-with-cont fun-exp exception))
(args (map (lambda (exp) (curry-s-exp-with-cont exp exception)) args-exp)))
(fold (lambda (a f) `(,f ,a)) fun args)))
(a
(if (or (boolean? a) (symbol? a) (number? a) (string? a) (list? a))
a
(exception "# error :: malformed target language"))))))
(define interp3
(lambda (s-exp)
(call/cc
(lambda (exit-point)
((eval3-gen exit-point)
(curry-s-exp-with-cont s-exp exit-point)
initial-env3 (lambda (v mk) v) (lambda (v) v))))))
(define generate-factorial-sr/p
(lambda (n)
`(call/cc (c)
(+ 1 (reset
(((lambda (f) ((lambda (p) (f (lambda (a) ((p p) a))))
(lambda (p) (f (lambda (a) ((p p) a))))))
(lambda (y) (lambda (n)
(if (= n 1)
1
(if (< n 0)
(c "call/cc exception")
(if (< 50 n)
(shift (c) n)
(* n (y (- n 1))))))))) ,n))))))
(define normal-p
(generate-factorial-sr/p 10))
(define shift-exception-p
(generate-factorial-sr/p 100))
(define call/cc-exception-p
(generate-factorial-sr/p -10))
normal2->cps2は, 2引数をとるプリミティブの関数を限定継続付きの継続渡しスタイルへ変換するマクロです. add-transform-cps-2で, その処理をすべてのプリミティブ関数に実行します.
eval3では, インタプリタ上の例外処理をきれいに扱うため, factory関数を作り, eval3をその関数が生成するクロージャとすることで, 評価器の定義をそのまま記述できるようにしました. 基本的に書き方は, 冒頭で書いた定義と(順番が違う以外は, )ほぼ同じです.
カリー化するプログラム(curry-s-exp)も, 文法の拡張部分について, 修正をほどこします.
eval3へ最初に渡す継続は, (λx m. x)で, xに式全体の計算結果が渡されるので, それを返すようにします.
サンプルプログラムとして, factorial-pでcall/ccとshift/resetを使ったものを作成しました.
interp3の実行結果は次のようになるはずです.
gosh > ( interp3 normal - p )
3628801
gosh > ( interp3 shift - exception - p )
101
gosh > ( interp3 call / cc - exception - p )
"call/cc exception" normal-pでは, 例外を返さない範囲内の引数が与えられたので, 普通にfactorialを計算します. shift-exception-pでは, factorial関数に50より上の値が渡されたので限定継続を使って, resetの外側へ脱出しています. 負の値を渡した場合は, 継続によってcall/ccの外へジャンプします.
紛らわしいのですが, call/ccは, 継続を束縛した変数cを呼び出すことで例外のように式の外側へジャンプしますが, shift/resetは, 限定継続を束縛した変数cを呼び出さないことで式(reset)の外側へ脱出します.
以上で, メタ循環インタプリタに限定継続(と継続)の機能を実装することができるようになりました.
この投稿では, 素朴な(お試しの)実装について書きましたが, 本格的な言語に実用的な実装するには, Stackなどによる実装にする必要があります(遅いです).