1960 年 Lisp の eval を CPS 変換して Ruby で実行

乗りかかった船。S 式の入出力を Ruby でやれるようにしたついでに、1960 年の Lisp の eval 関数を Ruby で動くようにしてみました。「簡略版 S 式の LL(1) 文法による構文」と「簡略版 S 式の出力」の入出力スクリプトにくっつけて動かします。

最初に S 式の入力スクリプトの論理値の扱いを古いスタイルに合わせます。この修正をおこなわなくても動作しますが、気分の問題ってやつです。

+T = SymbolicAtom['t']
 QUOTE = SymbolicAtom['quote']

+def eq(x, y) x.equal?(y) ? T : nil end
-def eq(x, y) x.equal?(y) end
+def atom(x) x.respond_to?(:car) ? nil : T end
-def atom(x) not x.respond_to?(:car) end

ところで、ストレートに再帰呼び出しを直訳しても、Ruby は末尾呼び出しの最適化をしてくれないので困ります。そこで、定石にしたがって CPS 変換し、継続をトランポリンで回すスタイルで書いてみました。読みやすさと速度優先で、継続のクロージャをさらにラベル付けしたレジスタマシン方式に書き直し、それらをArray オブジェクトへ push していきます。レジスタは 4 つで、c が継続リストでこれまた Array オブジェクト、x と y はクロージャの変数のスナップショット、v は継続の引数であると同時に結果の値を格納します。なお、継続の引数は 1 個です。しかし、コーディングでは、x や y が引数になっていると指摘されそうですが、この継続への見掛け上の引数はクロージャのスナップショットを簡便に実現するためのものです、そこは大目に見てください。

ATOM = SymbolicAtom['atom']
EQ = SymbolicAtom['eq']
COND = SymbolicAtom['cond']
CAR = SymbolicAtom['car']
CDR = SymbolicAtom['cdr']
CONS = SymbolicAtom['cons']
LIST = SymbolicAtom['list']
LABEL = SymbolicAtom['label']
LAMBDA = SymbolicAtom['lambda']

def eval_jmclisp(exp, env)
  v = SymbolicAtom['*undef*']
  c = [[:eval, exp, env]]
  while instruction = c.pop
    opcode, x, y = *instruction
    case opcode
    when :eq
      v = eq(x, v)
    when :cons
      v = cons(x, v)
    when :atom
      v = atom(v)
    when :car
      v = car(v)
    when :cdr
      v = cdr(v)

    when :eval
      if atom(x)
        c.push [:assoc, x, y]
      elsif atom(car(x))
        case car(x)
        when QUOTE
          v = cadr(x)
        when COND
          c.push [:evcon, cdr(x), y]
        when EQ
          c.push [:eval1, x, y], [:eval, cadr(x), y]
        when CONS
          c.push [:eval2, x, y], [:eval, cadr(x), y]
        when ATOM
          c.push [:atom], [:eval, cadr(x), y]
        when CAR
          c.push [:car], [:eval, cadr(x), y]
        when CDR
          c.push [:cdr], [:eval, cadr(x), y]
        when LIST
          c.push [:evlis, cdr(x), y]
        else
          c.push [:eval3, cdr(x), y], [:assoc, car(x), y]
        end
      elsif eq(caar(x), LABEL)
        v = caddar(x)
        c.push [:eval3, cdr(x), cons(list(cadar(x), car(x)), y)]
      elsif eq(caar(x), LAMBDA)
        c.push [:eval4, x, y], [:evlis, cdr(x), y]
      end
    when :eval1
      c.push [:eq, v], [:eval, caddr(x), y]
    when :eval2
      c.push [:cons, v], [:eval, caddr(x), y]
    when :eval3
      c.push [:eval, cons(v, x), y]
    when :eval4
      c.push [:eval5, x, y], [:pair, cadar(x), v]
    when :eval5
      c.push [:eval6, x], [:append, v, y]
    when :eval6
      c.push [:eval, caddar(x), v]

    when :evcon
      c.push [:evcon1, x, y], [:eval, caar(x), y]
    when :evcon1
      if v
        c.push [:eval, cadar(x), y]
      else
        c.push [:evcon, cdr(x), y]
      end

    when :evlis
      if atom(x)
        v = nil
      else
        c.push [:evlis1, x, y], [:eval, car(x), y]
      end
    when :evlis1
      c.push [:cons, v], [:evlis, cdr(x), y]

    when :assoc
      if eq(caar(y), x)
        v = cadar(y)
      else
        c.push [:assoc, x, cdr(y)]
      end

    when :append
      if atom(x)
        v = y
      else
        c.push [:cons, car(x)], [:append, cdr(x), y]
      end

    when :pair
      if atom(x) or atom(y)
        v = nil
      else
        c.push [:cons, list(car(x), car(y))], [:pair, cdr(x), cdr(y)]
      end
    end
  end
  v
end

def list(*a)
  z = y = Pair.new(nil, nil)
  a.each {|x| y.cdr = Pair.new(x, nil); y = y.cdr }
  z.cdr
end

def cadr(x) x.cdr.car end
def cddr(x) x.cdr.cdr end
def caddr(x) x.cdr.cdr.car end
def caar(x) x.car.car end
def caddar(x) x.car.cdr.cdr.car end
def cadar(x) x.car.cdr.car end

さらに、S 式の文字列を受け取り、eval で評価してプリントするようにします。2 つ目の引数に S 式を与えたときは、環境に渡します。

def read_eval_print(exp, env = nil)
  puts exp
  puts 'where ' + env if env
  puts '=> ' + print_string(
    eval_jmclisp(read_string(exp), read_string(env || '()')) )
end

read_eval_print("((lambda (x y) (car (cons x y))) 'x 'y)")
read_eval_print("((lambda (x y) (cdr (cons x y))) 'x 'y)")
read_eval_print("((lambda (x) (cons (car x) (cdr x))) '(a . b))")

read_eval_print(
  "((label append (lambda (x y)
      (cond
        ((null x) y)
        ('t (cons (car x) (append (cdr x) y))) ) ) )
    '(a b c) '(d e f) )",
    "((null (lambda (x) (eq x 'nil)) ))")