この記事はLisp Advent Calendar 2015（ http://qiita.com/advent-calendar/2015/lisp ）の記事です。
まずそこそこの分量がありますが、コード全体を示します。
タイミングが合えばShibuya.lispで発表しようかと思っていたのですが、色々あってそのままになっていたのでここで公開します。というわけで以下はトークのノリでだらだらと紹介します。
まず、これはどういうものか、ということについてですが、Common Lispで実装したSchemeです。Common Lispを使っていて不意にSchemeの構文で書きたくなった時などに有用かと思います（実際のところは、他の言語でSchemeを実装するためのプロトタイプとして作りました）。Three Implementation Models for Schemeの影響もなんとなく受けている感じの実装になっていると思います。
実装していない（できていない）ものとして、
- proper tail call
- 特殊形式多数
- ライブラリ的関数多数
- Scheme的（衛生的）マクロ
があります。
データ構造には、consでスタックを実装したものを使っています。変数をレジスタに見立てていて、最初のほうで定義してある push-r と pop-r というマクロで仮想機械の命令風に操作しています。
(defmacro set-r (reg-name v) `(setq ,reg-name ,v))
(defmacro push-r (reg-name v) `(setq ,reg-name (cons ,v ,reg-name)))
(defmacro pop-r (reg-name)
`(prog1 (car ,reg-name)
(setq ,reg-name (cdr ,reg-name))))また、クロージャ（関数オブジェクト）は car が 'closure となっているリスト、マクロは car が 'macro となっているリスト、で表しています。このへんも定番の手法という感じでしょう。マクロは伝統的なマクロにのみ対応しています。
my-eval が eval 本体です。そのままでは少し大きくて見通しが悪いので、以下に骨組を示します。
(defun my-eval (acc env)
(let ((stck '(ret))
(args ()))
(tagbody
eval-expr
(cond
((symbolp acc)
(set-r acc (get-var acc env))
(go handle-val))
((atom acc) ; other atoms
(go handle-val))
((consp acc)
(let ((a (car acc))
(d (cdr acc)))
(case a
(quote
(cond
((and (consp d) (null (cdr d)))
(set-r acc (car d))
(go handle-val)))
(error "my-eval: quote: syntax-error"))
...
(otherwise ; other application form
(push-r stck d)
(push-r stck 'pre-apply)
(set-r acc a)
(go eval-expr))))))
(error "ERROR 1")
handle-val
(case (pop-r stck)
(ret
(return-from my-eval acc))
(post-def
(let ((sym (pop-r stck)))
(rplaca env (cons (cons sym acc) (car env)))
(set-r acc sym))
(go handle-val))
(arg
(push-r args acc)
(set-r acc (pop-r stck))
(go eval-expr))
...
(post-get
(set-r acc (get-var acc env))
(go handle-val)))
(error "ERROR 2"))))envは環境のチェイン、stckには「accにある式が値になった後にすべきこと」が積まれます。argsは実引数のリストで (f a b c d) のような関数適用の式の、引数 a b c d を順番に評価している時に、すでに評価された引数の値が残されていって、全ての引数の評価が終わると f に適用されます。
accという変数には、「これから評価しようとしている式」あるいは「その式が評価された値」が入ります。巨大な tagbody になっていて、前半側には go eval-expr で、後半側には go handle-val で飛ぶようになっているわけですが、acc に式を入れたら go eval-expr して、その式の値が求まって acc に値が入っている状態なら go handle-val するわけです。次に、eval-expr と handle-val の、それぞれでの動作を見ていきます。
その前にまず (f a b c d) のようなフォームの評価順について説明しておきます。f が特殊形式やマクロ名だった場合は引数の評価を始めてはいけないわけですから、まず f についてそのチェックをする必要があります（設計によっては、そのまま f を評価してしまっても良いわけですが、この実装ではそのようにはしていません）。特殊形式でもマクロ名でもなかった場合は、普通の関数適用として引数を評価し（引数の評価順は左から右としました）最後に関数位置にある f を評価して（値は関数オブジェクトになるはず）、apply、というような感じになります。
eval-expr
(cond
((symbolp acc)
(set-r acc (get-var acc env))
(go handle-val))
((atom acc) ; other atoms
(go handle-val))
((consp acc)
(let ((a (car acc))
(d (cdr acc)))
(case a
(quote
...では、eval-expr の動作を細かく見ていきます。まず、acc の値がシンボルであれば名前解決を行い、それ以外の atom であれば自己評価型としてそのまま handle-val に移ります。どちらでもなければ（一応 consp でチェックして）特殊形式あるいはマクロであればその処理、それでなければ関数適用のための処理、という感じになります。
ここで、たとえば if の処理であれば (push-r stck 'post-ifthen) のようにスタックに何か積んでいるものが多いですが、これはどういうことかというと、if であればまず (if c a b) の c の部分の式を acc に設定し、それを評価するわけですが、その値が得られた後に handle-val でその得られた値を元にどうにかする、という感じになるわけで、それをコードに実装するとこういう感じになります。
acc の式を評価して値が得られた場合（たとえば変数名だったので名前解決がされた、など）には go handle-val となって、my-eval の下側半分にあるコードが実行されます。
具体的には、
handle-val
(case (pop-r stck)
(ret
(return-from my-eval acc))
(post-def
...のように、スタックから先頭を取り出して、その内容に応じてcaseで多分岐して、といったようになっているわけです。先ほどの if の続きを見てみます。
(post-ifthen
(let ((then-clause (pop-r stck)))
(cond
(acc
(set-r acc then-clause)
(go eval-expr))
(t
(set-r acc ())
(go handle-val)))))if が現れたフォームを調べた段階で、else 節があるかないかはチェックしてあり、それに合わせて振り分けられています。こちらは else 節が無い場合です。
(if 条件 expr) のようなフォームの「条件」の部分を評価した値が acc に入っていますから、それを実装言語の cond に掛けて振り分けています。被実装言語の(準)真偽値として実装言語のそれがそのまま使われるようなコードになっていますが、もし変えたい場合はこのあたりを適当に書き換えればいいわけです。真っぽい値の場合はスタックに積んであったthen節の式を acc に入れて、また式の評価に戻るので go eval-expr しています。一方、偽っぽい値の場合は acc に空リスト（nil）を入れて handle-val の操作を続けます。
スタックの底には、最初に ret というシンボルを入れているので、
(defun my-eval (acc env)
(let ((stck '(ret))
(args ()))
(tagbody
...「残りのすべきこと」が全て無くなるとこれが取り出されて、
handle-val
(case (pop-r stck)
(ret
(return-from my-eval acc))この先頭部分のパターンによって return-from で関数 my-eval を抜けます。
最後にcallccについてです。
SchemeでSchemeを実装する超循環評価器であれば、call/ccでcall/ccを実装するという飛び道具が使えるわけですが（『プログラミング言語SCHEME』にコード全体が載っている実例があります）、ここではそれは使えませんので（というのが非再帰型で実装している理由の一つです）Three Implementation Models for Schemeなどを参考にした感じでスタックを保存するようにした実装をしています。
まず call/cc は 'conti というシンボルに評価され、関数位置がそのようなシンボルだった場合は特別扱いするような仕掛けがあります。
(my-eval '(define call/cc (quote conti)) env) ; Q&D hack!
次の段階は handle-val の中で、関数適用などを振り分けている post-apply の中にあって、
(post-apply
(push-r args acc)
(set-r acc (pop-r stck))
(cond
...etc...
((eq acc 'conti) ; special case (top half of call/cc)
(set-r acc (car args)) ; (car args) に call/cc の引数が入っている
(push-r stck env) ; env は継続のために保存しておく必要がある（argsはこの外側で保存されているはず）
(push-r stck 'pop-env) ; 再開したらenvを復元するようスタックに積む
(set-r args (cons (cons 'nuate stck) ())) ; `(nuate stck) という継続オブジェクトが先頭に入った引数リストを作る。cdrにスタックを保存
(push-r stck 'apply) ; 以上の準備を元に apply を実行する
(go handle-val))関数位置の値が 'conti ということは call/cc ですから、この時点での継続をオブジェクトにして、引数の手続きオブジェクトにそれを渡す、ということをしています。
次は、このようにして作った継続オブジェクトが実行される場合です。コードとしてはこの続きに、
((and (consp acc) (eq (car acc) 'nuate)) ; ditto (bottom half of call/cc)
(set-r stck (cdr acc))
(set-r acc (car args))
(go handle-val)))とあります。やはり関数位置の値が '(nuate ...) の場合を特別扱いしているという感じになります。cdr にスタックが保存されてますからそれをスタックにセットし、引数の値をaccに入れて、継続が再開されます。
