続・EOPLの再帰関数の実装

http://d.hatena.ne.jp/sumii/20071105/p1

の反応がちょっと良かったので、調子に乗って相互再帰に対応したコードを書いてみる。相互再帰関数がクロージャを共有し、「何番目の関数か」を表す整数と、共有クロージャとの組を関数の値とするところがポイント（のつもり）です。バグってたら教えてください。(_ _) Schemeに慣れていないので、わかりにくい／美しくない等はお許しを。（Schemeではよく環境を「変数名と値の組のリスト」ではなく「変数名のリストと値のリストの組」で表すようですが何故なんでしょうか…）

(define eval-expression
  (lambda (exp env)
    (cases expression exp
      ; 中略
      (proc-exp (ids body) (cons 0 (closure (list '_) (list ids) (list body) env)))
      (app-exp (rator rands)
        (let ((proc (eval-expression rator env))
              (args (eval-rands rands env)))
          (if (and (pair? proc) (number? (car proc)) (procval? (cdr proc)))
            (apply-procval proc args)
            (eopl:error 'eval-expression
              "Attempt to apply non-procedure ~s" proc))))
      (letrec-exp (proc-names idss bodies letrec-body)
        (eval-expression letrec-body
          (extend-env-recursively (closure proc-names idss bodies env)))))))

(define-datatype procval procval?
  (closure
    (proc-names (list-of symbol?))
    (idss (list-of (list-of symbol?)))
    (bodies (list-of expression?))
    (env environment?)))

(define apply-procval
  (lambda (proc args)
    (cases procval (cdr proc)
      (closure (proc-names idss bodies env)
        (eval-expression
         (list-ref bodies (car proc))
         (extend-env
          (list-ref idss (car proc))
          args
          (extend-env-recursively (cdr proc))))))))

(define extend-env-recursively
  (lambda (proc)
    (cases procval proc
      (closure (proc-names idss bodies old-env)
        (lambda (sym)
          (let ((pos (rib-find-position sym proc-names)))
            (if (number? pos)
                (cons pos proc)
                (apply-env old-env sym))))))))

追記：（クロージャではなく）consセルが毎回生成されていたので、「整数とクロージャの組」をあらかじめ作っておくバージョンも掲載。

(define extend-env-recursively
  (lambda (proc)
    (cases procval proc
      (closure (proc-names idss bodies old-env)
        (define (make-recfun-table pos proc-names)
          (if (null? proc-names)
              '()
              (cons
               (cons (car proc-names) (cons pos proc))
               (make-recfun-table (+ 1 pos) (cdr proc-names)))))
        (define (lookup-recfun-table proc-name recfun-table)
          (if (null? recfun-table)
              #f
              (if (eq? proc-name (caar recfun-table))
                  (cdar recfun-table)
                  (lookup-recfun-table proc-name (cdr recfun-table)))))
        (let ((recfun-table (make-recfun-table 0 proc-names)))
          (lambda (sym)
            (let ((val (lookup-recfun-table sym recfun-table)))
              (if val
                  val
                  (apply-env old-env sym)))))))))

追記：http://blog.so-net.ne.jp/rainyday/2007-11-13 がフォローしてくださっています。感謝。

iotaとかassocとか使わずに（というか存在を失念していた）、make-recfun-tableやらlookup-recfun-tableやら再発明した○×△な私。letrec f(f) = ...についてはまったくその通りで、私がサボりました。:-)

「整数とクロージャの組」の整数をクロージャに含めるかどうかは、整数以外の部分が相互再帰関数の個数だけ重複すると思ってやめたのですが、ちょっと迷いました。確かにpair?とかcarとかcdrとかうっとうしいので、datatypeだけでなく組に対しても使える、ネストしたパターンマッチングがあれば…（ぼそ）。私がコンパイラ演習でSchemeコンパイラについて習ったときはAndrew Wrightのmatch.scmを使ったのですが、最近はどうするものなんでしょうか。

あと、Iさんに聞かれて気づいたのですが、インタプリタではなくコンパイラではどうなっているか考えると意外と(?)微妙で面白いです（クロージャの表現や最適化等）。