M.Hiroi's Home Page

Common Lisp Programming

お気楽 Common Lisp プログラミング入門

[ PrevPage | Common Lisp | NextPage ]

Common Lisp で作る micro Scheme (3)

今回は micro Scheme に「継続 (continuation)」を導入します。Scheme の継続は実装するのが難しいように思えますが、インタプリタを「継続渡しスタイル (Continuation Passing Style : CPS)」で書き直すことで実現することができます。継続渡しスタイルについては拙作のページ 継続渡しスタイル で詳しく説明しています。よろしければ参考にしてください。

●継続とは?

ここで簡単に Scheme の継続について説明します。Scheme は関数 call-with-current-continuation を使って「継続」を取り出すことができます。多くの Scheme 処理系では call/cc という省略形を使うことができます。今回の micro Scheme では call/cc を使うことにします。

call/cc は高階関数です。call/cc に渡される関数は引数がひとつで、その引数に call/cc が取り出した継続が渡されます。call/cc はその関数を評価し、その結果が call/cc の返り値になります。

Scheme の仕様書 (R5RS) によると、継続は引数を一つ取る関数で表されます。引数を渡して継続を評価すると、今までの処理を破棄して、call/cc で取り出された残りの計算 (継続) を実行します。このとき、継続に渡した引数が call/cc の返り値になります。

簡単な例を示しましょう。Gauche (Scheme) での実行例です。

gosh> (call/cc (lambda (cont) cont))
#<subr continuation>
gosh> (+ 1 (* 2 (call/cc (lambda (cont) 3))))
7
gosh> (+ 1 (* 2 (call/cc (lambda (cont) (cont 4) 3))))
9

最初の例では、ラムダ式の引数 cont に継続が渡されます。ラムダ式は cont をそのまま返しているので、call/cc の返り値は取り出された継続になります。Gauche の場合、継続は #<subr continuation> と表記され、継続は関数であることがわかります。

次の例を見てください。call/cc によって取り出される継続は、call/cc の返り値を 2 倍して、その結果に 1 を加えるという処理になります。call/cc の返り値を X とすると、継続は (+ 1 (* 2 X)) という S 式で表すことができます。ラムダ式では継続を評価せずに 3 をそのまま返しているので、(+ 1 (* 2 3)) をそのまま計算して値は 7 になります。

最後の例では、ラムダ式の中で (cont 4) を評価しています。継続を評価しているので、現在の処理を破棄して、取り出した継続 (+ 1 (* 2 X)) を評価します。したがって、ラムダ式で (cont 4) の後ろにある 3 を返す処理は実行されません。X の値は継続の引数 4 になるので、(+ 1 (* 2 4)) を評価して値は 9 になります。

継続を変数に保存しておいて、あとから実行することもできます。次の例を見てくください。

gosh> (define *cont* #f)
*cont*
gosh> (+ 1 (* 2 (call/cc (lambda (cont) (set! *cont* cont) 3))))
7
gosh> (*cont* 10)
21
gosh> (*cont* 100)
201

ラムダ式の中で取り出した継続を大域変数 *cont* に保存します。継続で行う処理は (+ 1 (* 2 X)) なので、(*cont* 10) は (+ 1 (* 2 10)) を評価して値は 21 になります。同様に、(*cont* 100) は (+ 1 (* 2 100)) を評価して値は 201 になります。

●S 式の評価の修正

それでは micro Scheme を継続渡しスタイルで書き直しましょう。まずは S 式を評価する関数 m-eval から修正します。次のリストを見てください。

リスト : S 式の評価

(defun m-eval (expr env cont)
  (cond ((self-evaluationp expr) (funcall cont expr))
        ((symbolp expr)
         (let ((cell (lookup expr env)))
           (if cell
               (funcall cont (cdr cell))
             (error "unbound variable ~S" expr))))
        ((consp expr)
         (m-eval (car expr) env
                 (lambda (procedure)
                   (case (car procedure)
                     ((syntax) (funcall (cadr procedure) expr env cont))
                     ((macro)
                      (m-apply (cdr procedure) (cdr expr)
                               (lambda (new-expr)
                                 (m-eval new-expr env cont))))
                       (t
                        (map-eval (cdr expr) env
                                  (lambda (actuals)
                                    (m-apply procedure actuals cont))))))))
        (t
         (error "unknown expression type -- m-eval ~S" expr))))

m-eval の引数 cont が継続を表すクロージャです。たとえば、値 value を返す場合は cont に value を渡して評価します。cont を評価するときは funcall を使うことに注意してください。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 は次のようになります。

リスト : 引数を評価する

(defun map-eval (args env cont)
  (if (null args)
      (funcall cont '())
    (m-eval (car args) env
            (lambda (x)
              (map-eval (cdr args) env
                        (lambda (y) (funcall cont (cons x y))))))))

引数 args が空リストの場合は cont に空リストを渡します。そうでなければ、m-eval で先頭要素を評価し、その結果を継続 (ラムダ式) の引数 x に渡します。この中で map-eval を再帰呼び出しし、残りのリストを処理します。その結果は継続の引数 y に渡されます。ここで、x と y の値を cons でつないで cont に渡します。これで引数を評価した結果をリストに格納して返すことができます。

継続渡しスタイルのプログラムはちょっと難しいと思います。よく理解できない方は拙作のページ 継続渡しスタイル をお読みください。

●シンタックス形式の修正

次はシンタックス形式を処理する関数を修正します。次のリストを見てください。

リスト : シンタックス形式

;;; (quote x)
(defun m-quote (expr env cont)
  (declare (ignore env))
  (funcall cont (cadr expr)))

(defun true-p (x) (not (eq x 'false)))

;;; (if test then eles)
(defun m-if (expr env cont)
  (m-eval (cadr expr) env
          (lambda (pred)
            (if (true-p pred)
                (m-eval (caddr expr) env cont)
              (if (null (cdddr expr))
                  (funcall cont '*undef*)
                (m-eval (cadddr expr) env cont))))))

;;; (lambda (args ...) body ...)
(defun m-lambda (expr env cont)
  (funcall cont (list 'closure expr env)))

;;; (define name s-expr)
(defun m-define (expr env cont)
  (m-eval (caddr expr) env
          (lambda (value)
            (setf *global-environment*
                  (cons (cons (cadr expr) value)
                        *global-environment*))
            (funcall cont (cadr expr)))))

;;; (set! name value)
(defun m-set! (expr env cont)
  (m-eval (caddr expr) env
          (lambda (value)
            (let ((cell (lookup (cadr expr) env)))
              (setf (cdr cell) value)
              (funcall cont (cdr cell))))))

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 を渡します。

●マクロの修正

次はマクロの処理を修正します。

リスト : マクロの定義

(defun m-define-macro (expr env cont)
  (m-eval (caddr expr) env
          (lambda (value)
            (setq *global-environment*
                  (cons (cons (cadr expr)
                              (cons 'macro value))
                        *global-environment*))
            ;; symbol を返す
            (funcall cont (cadr expr)))))

m-define-macro は m-eval で expr の第 3 要素を評価して、その値を継続の引数 value に渡します。この中で、変数 (cadr expr) と (cons 'macro value) を組にして *global-environment* にセットします。そして、cont にマクロ名を表すシンボルを渡します。

次はバッククオートの処理を修正します。

リスト : バッククオート

(defun m-backquote (expr env cont)
  (labels ((transfer (ls cont)
    (cond
     ((consp ls)
      (cond
       ((consp (car ls))
        (cond
         ((eq (caar ls) 'unquote)
          (transfer (cdr ls)
                    (lambda (x)
                      (m-eval (cadar ls) env
                              (lambda (y)
                                (funcall cont (cons y x)))))))
         ((eq (caar ls) 'splice)
          (transfer (cdr ls)
                    (lambda (x)
                      (m-eval (cadar ls) env
                              (lambda (y)
                                (funcall cont (append y x)))))))
         (t (transfer (car ls)
                      (lambda (x)
                        (transfer (cdr ls)
                                  (lambda (y)
                                    (funcall cont (cons x y)))))))))
        (t (transfer (cdr ls)
                     (lambda (x) (funcall cont (cons (car ls) x)))))))
     (t (funcall cont ls)))))
    (transfer (cadr expr) cont)))

局所関数 transfer を継続渡しスタイルで書き直します。引数 cont が継続です。リスト ls の先頭要素で (unquote ...) を見つけた場合、残りのリスト (cdr ls) を transfer で処理し、その結果を継続の引数 x に渡します。この中で m-eval を呼び出して、unquote の引数を評価します。その結果を継続の引数 y に渡し、cons で y と x を結合して cont に渡します。splice を見つけた場合は append で結合します。

そうでなければ transfer で (car ls) を処理し、その結果を継続の引数 x に渡します。この中で残りのリスト (cdr ls) を処理して、その結果を継続の引数 y に渡します。あとは cons で x と y を結合して cont に渡します。ls の先頭要素がリストでなければ、transfer で (cdr ls) を処理して、その結果と先頭要素を cons で結合して cont に渡します。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

(defun 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 のプログラムは次のようになります。

リスト : 関数適用

(defun 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)
        (funcall (caddr procedure) (car actuals)))
       (t (funcall cont (apply (cadr procedure) actuals)))))
    ((closure)
     (let ((expr (cadr procedure)))
       (eval-body (cddr expr)
                  (add-binding (cadr expr) actuals (caddr procedure))
                  cont)))
    (t
     (error "unknown procedure type -- m-apply ~S" 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 の評価

(defun eval-body (body env cont)
  (if (null (cdr body))
      (m-eval (car body) env cont)
    (m-eval (car body) env
            (lambda (value)
              (declare (ignore value))
              (eval-body (cdr body) env cont)))))

body の要素が残り一つの場合、それを m-eval で評価します。要素が複数有る場合、m-eval で先頭要素を評価し、その結果を継続の引数 value に渡します。そして、eval-body を再帰呼び出しします。この場合、value は使用されずに捨てられることになります。結局、最後の S 式の評価結果を cont に渡して返すことになります。

次は apply を処理する関数 p-apply を作ります。

リスト : micro Scheme 用 apply

(defun p-apply (procedure actuals cont)
  (labels ((collect-actuals (ls)
             (if (null (cdr ls))
                 (if (listp (car ls))
                     (car ls)
                   (error "type error -- apply ~S" (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 の修正

最後に 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
(defun repl (&rest file-list)
  (unwind-protect
      (progn
        (change-readtable)
        (dolist (file file-list)
          (with-open-file (in file :direction :input)
            (do ((output t))
                ((eq output nil) (terpri))
              (setf output (m-eval (read in nil) '() #'identity))
              (print output))))
        (do ((output nil))
            ((eq output 'quit))
          (princ ">>> ")
          (force-output)
          (handler-case
              (progn
                (setf output (m-eval (read) '() #'identity))
                (princ output)
                (terpri))
            (simple-error (c) (format t "ERROR: ~a~%" c)))))
    (setq *readtable* (copy-readtable nil))))

*global-environment* には apply と call/cc のほかに、テストで使うため display と newline を追加します。関数 repl は m-eval に関数 identity を渡すだけです。これで、m-eval の評価結果を求めて、print や princ で表示することができます。

●簡単な実行例

それでは実際に継続を使ってみましょう。

>>> (define a false)
A
>>> (define list (lambda x x))
LIST
>>> (list 'a 'b (call/cc (lambda (k) (set! a k) 'c)) 'd)
(A B C D)
>>> (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") (newline)))
(define bar2 (lambda (cont) (display "call bar2") (newline) (cont false)))
(define bar3 (lambda (cont) (display "call bar3") (newline)))
(define test (lambda (cont) (bar1 cont) (bar2 cont) (bar3 cont)))
>>> (call/cc (lambda (cont) (test cont)))
call bar1
call bar2
FALSE

bar2 からトップレベルへ脱出するので、bar3 は呼び出されていません。これも正常に動作していますね。

●繰り返しからの脱出

当然ですが、繰り返しから脱出することもできます。次の例を見てください。

リスト : do から脱出する場合

(define find-do
  (lambda (fn ls)
    (call/cc
      (lambda (k)
        (do ((xs ls (cdr xs)))
            ((null? xs) false)
          (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))
FALSE

もちろん高階関数からも脱出することができます。

リスト : 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))
NIL
>>> (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 は継続 cont を取り出して局所関数 flatten-sub に渡します。flatten-sub は空リストを見つけたら継続 cont を評価します。そうすると、再帰呼び出しの処理は破棄されて flatten の処理に戻り、cont に渡した空リストが返り値となります。

>>> (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))
NIL

これも正常に動作しています。

●イテレータの生成

最後に、イテレータを生成する関数 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 false))))
    (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))))))

拙作のページ お気楽 Scheme プログラミング入門 継続と継続渡しスタイル で作成したプログラムと同じです。それでは実行してみましょう。

>>> (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)
FALSE

正常に動作していますね。なお、(a) を評価する前に変数 a の値を表示すると無限ループになります。ご注意ください。

●末尾再帰最適化

最後に、末尾再帰最適化について考えてみましょう。使用している Common Lisp 処理系が末尾再帰最適化を行っている場合、ある条件で m-eval が末尾再帰していれば、micro Scheme も末尾再帰最適化が行われます。たとえば、次に示すような関数呼び出しにおいて、スタックを消費せずに実行することができます。

>>> (define foo (lambda () (foo)))
foo

>>> (foo)
=> 無限ループになる

末尾再帰最適化が行われる場合、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 を使うための特殊形式です。

micro Scheme で S 式を評価するとき、末尾呼び出しが行われる場所は m-if と eval-body の 2 か所しかありません。次のリストを見てください。

リスト : 末尾呼び出しの処理

;;; if の処理
(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 を経由していますが末尾再帰になっています。

eval-body の場合も同様です。最後の S 式を評価するときの m-eval は末尾呼び出しになっているので、m-apply と eval-body を経由して m-eval は末尾再帰になります。このように m-eval を末尾再帰でプログラムすると、Lisp 処理系で末尾再帰最適化が行われれば、micro Scheme でも S 式を評価するときに末尾再帰最適化が行われます。

継続渡しスタイルの場合も同じです。m-if と eval-body の末尾呼び出しで、m-eval を末尾再帰でプログラムすれば、micro Scheme でも末尾再帰最適化が行われます。ちなみに、eval-body を次のようにプログラムすると、末尾再帰最適化は行われません。

リスト : body の評価 (間違い)

(defun 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 の呼び出しは末尾再帰になりません。ご注意ください。

ところで Common Lisp の場合、Scheme とは違って末尾再帰最適化は仕様 (ANSI Common Lisp) に規定されていないので、その動作は処理系に依存します。SBCL の場合、micro Scheme で次に示す関数 foo を評価すると無限ループになりますが、CLISP ではスタックオーバーフローになります。

>>> (define foo (lambda () (foo)))
FOO
>>> (foo)
=> SBCL では無限ループ, CLISP ではスタックオーバーフロー

CLISP で動かす場合、tagbody と go を使って末尾再帰最適化を行うことは可能です。この方法は 参考文献 6 に示されています。ただし、プログラムはかなり複雑になります。また、この方法で「継続」と「末尾再帰最適化」をいっしょに実装するのはちょっと難しいように思います。実際に試してみたところ、正常に動作しない場合がありました。これは今後の研究課題にしたいと思います。

●参考文献, URL

  1. 黒川利明, 『LISP 入門』, 培風館, 1982
  2. Patrick Henry Winston, Berthold Klaus Paul Horn, 『LISP 原書第 3 版 (1)』, 培風館, 1992
    18. Lisp で書く Lisp
  3. R. Kent Dybvig (著), 村上雅章 (訳), 『プログラミング言語 SCHEME』, 株式会社ピアソン・エデュケーション, 2000
    9.2 Scheme のメタ循環インタプリタ
  4. Ravi Sethi (著), 神林靖 (訳), 『プログラミング言語の概念と構造』, アジソンウェスレイ, 1995
    第 11 章 定義インタプリタ
  5. Harold Abelson, Gerald Jay Sussman, Julie Sussman, "Structure and Interpretation of Computer Programs",
    4.1 The Metacircular Evaluator
  6. 稲葉雅幸, ソフトウェア特論, Scheme インタプリタ

●プログラムリスト

;;;
;;; micro.lsp : micro Scheme with Common Lisp
;;;
;;;             (1) 基本機能の実装
;;;             (2) 伝統的なマクロの追加
;;;             (3) CPS で継続を実装する
;;;
;;;             Copyright (C) 2009-2021 Makoto Hiroi
;;;

;;; 関数宣言
(declaim (ftype (function (t list function) t) m-eval))
(declaim (ftype (function (list list function) t) m-apply))

;;; 大域変数
(defvar *global-environment*)

;;; 変数束縛
(defun add-binding (vars vals env)
  (cond ((null vars) env)
        ((symbolp vars)
         (cons (cons vars vals) env))
        (t
         (cons (cons (car vars) (car vals))
               (add-binding (cdr vars) (cdr vals) env)))))

;;; 変数の値を取得
(defun lookup (var env)
  (let ((value (assoc var env)))
    (if value
        value
      (assoc var *global-environment*))))

;;;
;;; syntax
;;;

;;; (quote x)
(defun m-quote (expr env cont)
  (declare (ignore env))
  (funcall cont (cadr expr)))

(defun true-p (x) (not (eq x 'false)))

;;; (if test then eles)
(defun m-if (expr env cont)
  (m-eval (cadr expr) env
          (lambda (pred)
            (if (true-p pred)
                (m-eval (caddr expr) env cont)
              (if (null (cdddr expr))
                  (funcall cont '*undef*)
                (m-eval (cadddr expr) env cont))))))

;;; (lambda (args ...) body ...)
(defun m-lambda (expr env cont)
  (funcall cont (list 'closure expr env)))

;;; (define name s-expr)
(defun m-define (expr env cont)
  (m-eval (caddr expr) env
          (lambda (value)
            (setf *global-environment*
                  (cons (cons (cadr expr) value)
                        *global-environment*))
            (funcall cont (cadr expr)))))

;;; (set! name value)
(defun m-set! (expr env cont)
  (m-eval (caddr expr) env
          (lambda (value)
            (let ((cell (lookup (cadr expr) env)))
              (setf (cdr cell) value)
              (funcall cont (cdr cell))))))

;;;
;;; マクロ
;;;

;;; (define-macro name s-expr)
(defun m-define-macro (expr env cont)
  (m-eval (caddr expr) env
          (lambda (value)
            (setq *global-environment*
                  (cons (cons (cadr expr)
                              (cons 'macro value))
                        *global-environment*))
            ;; symbol を返す
            (funcall cont (cadr expr)))))

;;; backquote
(defun m-backquote (expr env cont)
  (labels ((transfer (ls cont)
    (cond
     ((consp ls)
      (cond
       ((consp (car ls))
        (cond
         ((eq (caar ls) 'unquote)
          (transfer (cdr ls)
                    (lambda (x)
                      (m-eval (cadar ls) env
                              (lambda (y)
                                (funcall cont (cons y x)))))))
         ((eq (caar ls) 'splice)
          (transfer (cdr ls)
                    (lambda (x)
                      (m-eval (cadar ls) env
                              (lambda (y)
                                (funcall cont (append y x)))))))
         (t (transfer (car ls)
                      (lambda (x)
                        (transfer (cdr ls)
                                  (lambda (y)
                                    (funcall cont (cons x y)))))))))
        (t (transfer (cdr ls)
                     (lambda (x) (funcall cont (cons (car ls) x)))))))
     (t (funcall cont ls)))))
    (transfer (cadr expr) cont)))

;;;
;;; 関数適用
;;;

;;; 関数値 : (tag ...)
;;; tag
;;; syntax    : シンタックス形式 (syntax m-xxx)
;;; primitive : プリミティブ     (primitive #<subr ...>)
;;; closure   : クロージャ       (closure (lambda (args ...) body ...) env)
;;; macro     : マクロ           (macro (lambda (args ...) body ...))

;;; 継続
(defun p-call/cc (procedure cont)
  (m-apply procedure
           (list (list 'primitive 'continuation cont)) cont))

;;; micro Scheme 用 apply
(defun p-apply (procedure actuals cont)
  (labels ((collect-actuals (ls)
             (if (null (cdr ls))
                 (if (listp (car ls))
                     (car ls)
                   (error "type error -- apply ~S" (car ls)))
               (cons (car ls) (collect-actuals (cdr ls))))))
    (m-apply procedure (collect-actuals actuals) cont)))

;;; body の評価
(defun eval-body (body env cont)
  (if (null (cdr body))
      (m-eval (car body) env cont)
    (m-eval (car body) env
            (lambda (value)
              (declare (ignore value))
              (eval-body (cdr body) env cont)))))

;;; apply
(defun 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)
        (funcall (caddr procedure) (car actuals)))
       (t (funcall cont (apply (cadr procedure) actuals)))))
    ((closure)
     (let ((expr (cadr procedure)))
       (eval-body (cddr expr)
                  (add-binding (cadr expr) actuals (caddr procedure))
                  cont)))
    (t
     (error "unknown procedure type -- m-apply ~S" procedure))))

;;;
;;; S 式の評価
;;;

;;; 自己評価フォームか
(defun self-evaluationp (expr)
  (and (not (consp expr)) (not (symbolp expr))))

;;; 引数を評価する
(defun map-eval (args env cont)
  (if (null args)
      (funcall cont '())
    (m-eval (car args) env
            (lambda (x)
              (map-eval (cdr args) env
                        (lambda (y) (funcall cont (cons x y))))))))

;;; eval
(defun m-eval (expr env cont)
  (cond ((self-evaluationp expr) (funcall cont expr))
        ((symbolp expr)
         (let ((cell (lookup expr env)))
           (if cell
               (funcall cont (cdr cell))
             (error "unbound variable ~S" expr))))
        ((consp expr)
         (m-eval (car expr) env
                 (lambda (procedure)
                   (case (car procedure)
                     ((syntax) (funcall (cadr procedure) expr env cont))
                     ((macro)
                      (m-apply (cdr procedure) (cdr expr)
                               (lambda (new-expr)
                                 (m-eval new-expr env cont))))
                     (t
                      (map-eval (cdr expr) env
                                (lambda (actuals)
                                  (m-apply procedure actuals cont))))))))
        (t
         (error "unknown expression type -- m-eval ~S" expr))))

;;; 初期化
(setf *global-environment*
      (list
       (cons 'true  'true)
       (cons 'false 'false)
       (cons 'nil   'nil)
       (cons 'quit  'quit)
       (list 'car   'primitive (lambda (x)
                                 (if (null x)
                                     (error "type error -- car NIL")
                                   (car x))))
       (list 'cdr   'primitive (lambda (x)
                                 (if (null x)
                                     (error "type error -- cdr NIL")
                                   (cdr x))))
       (list 'cons  'primitive #'cons)
       (list 'eq?   'primitive (lambda (x y) (if (eq x y) 'true 'false)))
       (list 'eqv?  'primitive (lambda (x y) (if (eql x y) 'true 'false)))
       (list 'pair? 'primitive (lambda (x) (if (consp x) 'true 'false)))
       (list 'call/cc 'primitive 'call/cc)
       (list 'apply   'primitive 'apply)
       (list 'display 'primitive (lambda (x) (princ x) '*undef*))
       (list 'newline 'primitive (lambda () (terpri) '*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 'backquote   'syntax #'m-backquote)
       ))

;;;
;;; read-eval-print-loop
;;;

(defun change-readtable ()
  (set-macro-character
   #\`
   (lambda (stream char)
     (declare (ignore char))
     (list 'backquote (read stream t nil t))))
  (set-macro-character
   #\,
   (lambda (stream char)
     (declare (ignore char))
     (cond ((char= (peek-char nil stream) #\@)
            (read-char stream)
            (list 'splice (read stream t nil t)))
           (t (list 'unquote (read stream t nil t)))))))

(defun repl (&rest file-list)
  (unwind-protect
      (progn
        (change-readtable)
        (dolist (file file-list)
          (with-open-file (in file :direction :input)
            (do ((output t))
                ((eq output nil) (terpri))
              (setf output (m-eval (read in nil) '() #'identity))
              (print output))))
        (do ((output nil))
            ((eq output 'quit))
          (princ ">>> ")
          (force-output)
          (handler-case
              (progn
                (setf output (m-eval (read) '() #'identity))
                (princ output)
                (terpri))
            (simple-error (c) (format t "ERROR: ~a~%" c)))))
    (setq *readtable* (copy-readtable nil))))

初版 2009 年 8 月 22 日
改訂 2021 年 7 月 3 日

Copyright (C) 2009-2021 Makoto Hiroi
All rights reserved.

[ PrevPage | Common Lisp | NextPage ]