#!/usr/bin/env ruby
require 'stringio'
module L2Lisp
  SUMMARY = '
Little Lambda Lisp 4.3 in Ruby                           H19.7/19 (鈴)

Ruby 1.8.2 以降 (JRuby 1.0 を含む) による小さな Lisp インタープリタ

これはラムダ算法を Scheme と同程度に近似する Emacs Lisp もどきである。
版数４は Little Lambda Lisp 3 in Standard Pascal の移植・改訂版である
ことを意味する。cf. http://www.okisoft.co.jp/esc/llsp/v3.html

実行例: ruby L2Lisp.rb

上記のように無引数で起動すると対話セッションに入る。引数として 
Lisp スクリプトのファイル名を１個以上与えると，それらを順に実行する。
ただし，ハイフン１文字の引数は標準入力と解釈し，対話セッションに入る。
セッション中，本記述は (progn (princ summary) "") で読むことができる。
著作権表示は (progn (princ copyright) "") で読むことができる。

他の Ruby プログラムからライブラリとして利用することもできる。例えば:

  require "L2Lisp"
  LL = L2Lisp
  i = LL::Interp.new                # インタープリタ・オブジェクト構築
  i.symbol[:str] = proc {|a| a.to_s}             # 組込み関数 str 追加
  r = i.run(File.new("lisp_script"))             # Lisp スクリプト実行
  e = LL::Cell.new(:str, LL::Cell.new(123, nil)) # (str 123) 構築
  r = i.eval(e)                                  # (str 123) 評価

Lisp 値は次のように表現される:
 数, 文字列 ⇒ 数, 文字列
 シンボル   ⇒ Symbol インスタンス (大域変数値は Interp#symbol に格納)
 nil        ⇒ nil
 cons セル  ⇒ Cell インスタンス

特徴:
* 静的スコープ
* 末尾呼出しの最適化
* 関数と変数の名前空間は同一
* シンボルの初期値は (未束縛ではなく) 自分自身
* 関数 / と - は１個以上の引数をとる。
* (eval e) は e を大域的な環境で評価する。
* (eq x y) の結果は Ruby の x == y に従う。
* (delay x) は Scheme と同じく x の約束を作る。
  ~x と略記できる。組込み関数と条件式は implicit forcing を行う。
* (read) は EOF に対して *eof* の大域変数値を返す。
* 評価時例外 EvalError は (catch *error* …) で捕捉できる。
* (lambda …) を評価すると再帰的に内部形式のラムダ式になる。
* (macro …) は大域的な環境でだけ評価できる。結果はマクロ式である。
  マクロ式はラムダ式と同様だが，適用時，引数を評価せず，適用結果を評価する。
* マクロ式で，自由なシンボルは捕捉されないが，マクロ引数は捕捉される。
* (macro …) 内の $ で始まるシンボルは (quote 内も含め) dummy symbol となる。
  そのマクロ式の中でだけ eq が成り立つ。(マクロ引数の捕捉防止用)
* (lambda …) を評価する時，最大 MAX_MACRO_EXPS 重だけ再帰的にマクロ展開する
  (非大域的に束縛されたマクロを除く)。残りは適用時に処理される。
* 印字する時，高々 MAX_EXPANSIONS 重だけ再帰的に印字済みリストを印字する。
* (dump) は内部状態である symbol キーのリストと字句的環境のペアを返す。
* その他の点では Emacs Lisp のサブセット
'

  COPYRIGHT = '
Copyright (c) 2007 Oki Software Co., Ltd.

Permission is hereby granted, free of charge, to any person
obtaining a copy of this software and associated documentation
files (the "Software"), to deal in the Software without 
restriction, including without limitation the rights to use,
copy, modify, merge, publish, distribute, sublicense, and/or
sell copies of the Software, and to permit persons to whom the
Software is furnished to do so, subject to the following
conditions:

The above copyright notice and this permission notice shall be
included in all copies or substantial portions of the Software.

THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES
OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND  
NONINFRINGEMENT.  IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR
OTHER DEALINGS IN THE SOFTWARE.
'

  LL = L2Lisp                   # 便宜上の短縮名

  MAX_EXPANSIONS = 5            # 再帰的に印字する深さ
  MAX_MACRO_EXPS = 20           # 静的にマクロ展開する深さ
  MAX_EXC_TRACES = 10           # 例外発生時の評価トレースの記録段数

  # 以下の定数定義は Emacs の ruby-mode の字下げバグを回避するため
  LPAREN = :"("; RPAREN = :")"; DOT = :"."; QUOTE = :"'"; TILDE = :"~"
  EOF = :"#<eof>"; NONE = :"#<none>"
  CLOSURE = :"#<closure>"; LAMBDA = :"#<lambda>"; MACRO = :"#<macro>"
  REST = :"&rest"; UNWIND_PROTECT = :"unwind-protect"


  class SyntaxError < RuntimeError
  end


  class EvalError < RuntimeError
    attr :trace

    def initialize(message, exp=NONE)
      super((exp == NONE) ? message : message + ': ' + LL.str(exp))
      @trace = []
    end

    def to_s
      s = "*** %s\n" % super
      @trace.each_with_index {|t, index| s += "%3d: %s\n" % [index, t]}
      return s
    end
  end


  class Thrown < EvalError
    attr :tag
    attr :value

    def initialize(tag, value)
      super('no catcher for (%s %s)' % [LL.str(tag), LL.str(value)])
      @tag = tag
      @value = value
    end
  end


  class VariableExpected < EvalError
    def initialize(exp)
      super('variable expected', exp)
    end
  end


  class ProperListExpected < EvalError
    def initialize(exp)
      super('proper list expected', exp)
    end
  end


  # cons セル
  class Cell
    include Enumerable
    attr :car, true
    attr :cdr, true

    def initialize(car, cdr)
      @car = car
      @cdr = cdr
    end

    def inspect
      return LL.str(self)
    end

    def each                    # Lisp の mapc に相当
      j = self
      begin
        yield j.car
        j = j.cdr
      end while Cell === j
      j.nil? or raise ProperListExpected, j
    end

    def mapcar                  # Lisp の mapcar に相当
      c = yield @car
      x = y = Cell.new(c, nil)
      j = @cdr
      while Cell === j
        c = yield j.car
        y = y.cdr = Cell.new(c, nil)
        j = j.cdr
      end
      j.nil? or raise ProperListExpected, j
      return x
    end

    def length
      return inject(0) {|x, y| x + 1}
    end

    def _repr(print_quote, reclevel, printed)
      if printed.has_key?(self)
        reclevel -= 1
        return ['...'] if reclevel == 0
      else
        printed[self] = true
      end
      case @cdr
      when nil
        s = LL.str(@car, print_quote, reclevel, printed)
        return [s]
      when Cell
        s = LL.str(@car, print_quote, reclevel, printed)
        t = @cdr._repr(print_quote, reclevel, printed)
        return t.unshift(s)
      else
        s = LL.str(@car, print_quote, reclevel, printed)
        t = LL.str(@cdr, print_quote, reclevel, printed)
        return [s, '.', t]
      end
    end
  end # Cell


  # 引数の文字列表現を得る
  def str(x, print_quote=true, reclevel=MAX_EXPANSIONS, printed={})
    case x
    when Cell
      return '(' + x._repr(print_quote, reclevel, printed).join(' ') + ')'
    when Symbol then return x.to_s
    when String, Exception then return (print_quote) ? x.inspect : x
    else return x.inspect
    end
  end
  module_function :str


  def mapc(x, &block)
    case x
    when Cell then x.each(&block)
    when nil then ;
    else raise ProperListExpected, x
    end
  end
  module_function :mapc


  class Arg                 # コンパイル後のラムダ式やマクロ式の仮引数
    attr :level
    attr :offset
    attr :symbol

    def initialize(level, offset, symbol)
      @level = level
      @offset = offset
      @symbol = symbol
    end

    def inspect
      return "#%p:%p%p" % [@level, @offset, @symbol]
    end

    def set_value(x, link)
      @level.times {link = link.cdr}
      link.car[@offset] = x
    end

    def get_value(link)
      @level.times {link = link.cdr}
      return link.car[@offset]
    end
  end # Arg


  class Dummy                  # コンパイル後のマクロ式の dummy symbol
    attr :symbol

    def initialize(symbol)
      @symbol = symbol
    end

    def inspect
      return "%p:%x" % [@symbol, object_id]
    end
  end # Dummy


  class Promise                 # 約束: (delay exp) の評価結果
    attr :exp, true
    attr :link, true            # 字句的環境 (評価済みならば NONE)

    def initialize(exp, link)
      @exp = exp
      @link = link
    end

    def inspect
      if @link == NONE
        return "#delivered:%p" % @exp
      else
        return "#promised:%p:%p" % [@link, @exp]
      end
    end
  end # Promise


  class EagerList < Cell  # リストの各要素の約束をかなえるためのラッパ
    def initialize(list, interp)
      super(list.car, list.cdr)
      @interp = interp
    end

    def each
      j = self
      begin
        yield j.car
        j = j.cdr
        j = @interp.deliver(j) if Promise === j
      end while Cell === j
      j.nil? or raise ProperListExpected, j
    end

    def mapcar
      c = yield @car
      x = y = Cell.new(c, nil)
      j = @cdr
      j = @interp.deliver(j) if Promise === j
      while Cell === j
        c = yield j.car
        y = y.cdr = Cell.new(c, nil)
        j = j.cdr
        j = @interp.deliver(j) if Promise === j
      end
      j.nil? or raise ProperListExpected, j
      return x
    end
  end # EagerList


  # 式を読む
  class Reader
    def initialize(rf)
      @rf = rf                  # 入力ファイル: IO
      @buf = []                 # 入力行から得たトークンの並び
      @line = nil               # 入力行: String または nil
    end

    def read
      begin
        _read_token
        return _parse_expression
      rescue SyntaxError => ex
        @buf.clear    # その行の残りのトークンを捨てて次回の回復を図る
        raise EvalError, 'SyntaxError: %s -- %d: %p' % [ex, @rf.lineno, @line]
      end
    end

    def _parse_expression
      case @token
      when DOT, RPAREN
        raise SyntaxError, 'unexpected: %s' % @token
      when LPAREN
        _read_token
        return _parse_list_body
      when QUOTE
        _read_token
        return Cell.new(:quote, Cell.new(_parse_expression, nil))
      when TILDE
        _read_token
        return Cell.new(:delay, Cell.new(_parse_expression, nil))
      else
        return @token
      end
    end

    def _parse_list_body
      case @token
      when EOF then raise SyntaxError, 'unexpected EOF'
      when RPAREN then return nil
      else
        e1 = _parse_expression
        _read_token
        if @token == DOT
          _read_token
          (@token != EOF) or raise SyntaxError, 'unexpected EOF'
          e2 = _parse_expression
          _read_token
          (@token == RPAREN) or raise SyntaxError, '")" expected: %s' % @token
        else
          e2 = _parse_list_body
        end
        return Cell.new(e1, e2)
      end
    end

    def _read_token
      while @buf.empty?
        @line = @rf.gets
        if @line.nil?
          @token = EOF
          @rf.close
          return
        end
        @buf = @line.chomp.scan(TOKEN_PAT).flatten.compact
      end
      case t = @buf.shift
      when '(', ')', '.', '\'', '~' then @token = t.to_sym
      when 'nil' then @token = nil
      when /\A\".*\"\z/ then @token = t[1..-2]
      else
        begin @token = Integer(t)
        rescue ArgumentError
          begin @token = Float(t)
          rescue ArgumentError
            if /\A([A-Za-z0-9]|_|&|\$|\*|\/|\+|-|<|>|=|!|\?)+\z/ === t
              @token = t.to_sym
            else raise SyntaxError, 'bad token: %p' % t
            end
          end
        end
      end
    end
    TOKEN_PAT = /\s+|;.*$|(".*?"|[^()'~ ]+|.)/
  end # Reader


  # 式を解釈する
  class Interp
    attr :symbol                  # シンボルからその大域値への写像

    def initialize
      @reader = Reader.new(STDIN)
      @environ = nil
      @symbol = {}
      def @symbol.inspect
        LL.str(keys.inject(nil) {|a, b| Cell.new(b, a)})
      end
      @symbol[:car] = proc {|x| (x.nil?) ? nil : x.car}
      @symbol[:cdr] = proc {|x| (x.nil?) ? nil : x.cdr}
      @symbol[:cons] = @cons = proc {|x, y| Cell.new(x, y)}
      @symbol[:atom] = proc {|x| (Cell === x) ? nil : :t}
      @symbol[:eq] = proc {|x, y| (x == y) ? :t : nil}
      @symbol[:prin1] = proc {|x| print(LL.str(x, true)); x}
      @symbol[:princ] = proc {|x| print(LL.str(x, false)); x}
      @symbol[:terpri] = proc {print("\n"); :t}
      @symbol[:read] = proc {@reader.read}
      @symbol[:dump] = proc {   # 値を定義したシンボルと現在の環境
        x = @symbol.keys.inject(nil) {|a, b| Cell.new(b, a)}
        Cell.new(x, Cell.new(@environ, nil))
      }
      @symbol[:assq] = proc {|key, list|
        (list.nil?) ? nil :
        EagerList.new(list, self).detect {|x|
          x = deliver(x) if Promise === x
          Cell === x and ((Promise === x.car) ? deliver(x.car) : x.car) == key
        }
      }
      @symbol[:'+'] = proc {|*x| x.inject(0) {|a, b| a + b}}
      @symbol[:'*'] = proc {|*x| x.inject(1) {|a, b| a * b}}
      @symbol[:'/'] = proc {|x, *y| y.inject(x) {|a, b| a / b}}
      @symbol[:'-'] = proc {|x, *y|
        (y.length == 0) ? -x : y.inject(x) {|a, b| a - b}
      }
      @symbol[:'<'] = proc {|x, y| (x < y) ? :t : nil}
      @symbol[:eval] = proc {|x|
        old_env = @environ
        @environ = nil          # 大域的な環境にする
        begin eval(x, true)     # 末尾呼出しと同じく環境復元は不要
        ensure @environ = old_env
        end
      }
      @symbol[:rplaca] = proc {|x, y| x.car = y}
      @symbol[:rplacd] = proc {|x, y| x.cdr = y}
      @symbol[:throw] = proc {|x, y| raise Thrown.new(x, y)}
      @symbol[:stringp] = proc {|x| (String === x) ? :t : nil}
      @symbol[:length] = proc {|x|
        (x.nil?) ? 0 : ((Cell === x) ? EagerList.new(x, self) : x).length
      }
      @symbol[:force] = proc {|x| x}
      @symbol[:"*eof*"] = EOF
      @symbol[:summary] = SUMMARY
      @symbol[:copyright] = COPYRIGHT
      run(PRELUDE)
    end

    def eval(x, can_lose_current_env=false)
      begin
        loop {
          case x
          when Symbol then return @symbol.fetch(x, x)
          when Arg then return x.get_value(@environ)
          when Cell
            case x.car
            when :quote then return x.cdr.car
            when :cond
              x, cont = eval_cond_body(x.cdr)
              return x unless cont
            when :setq then return eval_setq_body(x.cdr)
            when :lambda then return compile_lambda(x.cdr, true)
            when :macro then return compile_lambda(x.cdr, false)
            when LAMBDA then return make_closure(CLOSURE, x.cdr)
            when CLOSURE, MACRO then return x
            when :catch then return eval_catch_body(x.cdr)
            when UNWIND_PROTECT then return eval_unwind_protect_body(x.cdr)
            when :delay
              kdr = x.cdr
              (Cell === kdr and kdr.cdr.nil?) or raise EvalError, "bad delay"
              return Promise.new(kdr.car, @environ)
            else
              case kar = x.car
              when Symbol then kar = @symbol.fetch(kar, kar)
              when Arg then kar = kar.get_value(@environ)
              when Cell
                case kar.car
                when CLOSURE, MACRO then ;
                else kar = eval(kar, false)
                end
              end
              case kar
              when Cell
                case kar.car
                when CLOSURE
                  args = get_args(x.cdr, true)
                  x, cont = apply_lambda(kar.cdr, args, can_lose_current_env)
                  return x unless cont
                when MACRO
                  args = get_args(x.cdr, false)
                  x, cont = apply_lambda(kar.cdr, args, false)
                else raise EvalError.new('not applicable list', kar)
                end
              when Proc
                args = ((kar == @cons) ? get_args(x.cdr, true) :
                        get_delivered_args(x.cdr))
                begin
                  return kar.call(*args)
                rescue EvalError
                  raise
                rescue => e
                  raise EvalError, '%s: %s -- %p %p' % [e.class, e, kar, args]
                end
              when :apply
                args = get_delivered_args(x.cdr)
                (args.length >= 2) or raise EvalError, "2 args required"
                f, *a = args
                a = a.reverse.inject {|rest, first| Cell.new(first, rest)}
                if Cell === a
                  a = EagerList.new(a, self).mapcar {|element|
                    Cell.new(:quote, Cell.new(element, nil))
                  }
                end
                x = Cell.new(f, a)
              else raise EvalError.new('not applicable atom', kar)
              end
            end
          else return x
          end
        }
      rescue EvalError => ex
        ex.trace << LL.str(x) if ex.trace.length < MAX_EXC_TRACES
        raise
      end
    end

    def deliver(promise)        # 約束をかなえる
      unless promise.link == NONE
        old_env = @environ
        @environ = promise.link
        begin
          x = eval(promise.exp, true)
          x = deliver(x) if Promise === x
        ensure
          @environ = old_env
        end
        unless promise.link == NONE # eval の中でかなえられていなければ…
          promise.exp = x
          promise.link = NONE
        end
      end
      return promise.exp
    end

    def eval_cond_body(body)
      while Cell === body      # while ループを LL.mapc(body) にすると
        case clause = body.car # (tak 18 12 6) が 9 秒から 14 秒に低速化する
        when nil then ;
        when Cell
          result = eval(clause.car, false)
          result = deliver(result) if Promise === result
          if result != nil      # テスト結果が真ならば
            clause = clause.cdr
            return result, false unless Cell === clause
            while Cell === (d = clause.cdr)
              eval(clause.car, false)
              clause = d
            end
            d.nil? or raise ProperListExpected, d
            return clause.car, true # 末尾呼出し ⇒ 戻った先で評価する
          end
        else raise EvalError.new('cond test expected', clause)
        end
        body = body.cdr
      end
      body.nil? or raise ProperListExpected, body
      return nil, false         # すべて失敗ならば nil
    end

    def eval_setq_body(body)    # (LVAL RVAL LVAL RVAL...)
      result = nil
      while Cell === body
        lval = body.car
        body = body.cdr
        (Cell === body) or raise EvalError, 'right value expected'
        result = eval(body.car, false)
        case lval
        when Symbol then @symbol[lval] = result
        when Arg then lval.set_value(result, @environ)
        else raise VariableExpected, lval
        end
        body = body.cdr
      end
      body.nil? or raise ProperListExpected, body
      return result
    end

    # リストで与えられた引数並びを (flag が真なら評価して) Array にする
    def get_args(list, flag)
      args = []        # ここは高頻度で呼ばれるからベタな while を使う
      while Cell === list
        x = list.car
        args << (flag ? eval(x, false) : x)
        list = list.cdr
      end
      list.nil? or raise ProperListExpected, list
      return args
    end

    def get_delivered_args(list)
      args = []
      while Cell === list
        x = eval(list.car, false)
        args << ((Promise === x) ? deliver(x) : x)
        list = list.cdr
      end
      list.nil? or raise ProperListExpected, list
      return args
    end

    # j = ((arity . link) . body)
    def apply_lambda(j, args, can_lose_original_env)
      body = j.cdr
      (Cell === body) or raise EvalError, 'body expected'
      j = j.car
      arity = j.car
      link = j.cdr
      if arity < 0
        arity = -arity -1       # &rest より前の引数の個数
        if arity <= args.length # rest 引数を１個のリストに構成する
          x = nil
          rests = args.slice!(arity .. -1)
          rests.reverse_each {|e| x = Cell.new(e, x)}
          args << x
          arity += 1
        end
      end
      (args.length == arity) or raise EvalError, 'arity not matched'
      old_env = @environ              # 元の環境を退避する
      @environ = Cell.new(args, link) # 新環境に変更する
      begin
        while Cell === (d = body.cdr)
          eval(body.car, false)
          body = d
        end
        if can_lose_original_env then # ⇒ (典型的には) 末尾呼出し
          old_env = @environ          # 新環境のまま
          return body.car, true       # 戻った先で評価する
        else
          return eval(body.car, true), false
        end
      ensure
        @environ = old_env
      end
    end

    def compile_lambda(kdr, is_lambda)
      if is_lambda then x = compile1(LAMBDA, kdr)
      else
        x = replace_dummy_variables1(kdr, {})
        x = compile1(MACRO, x)
      end
      if is_lambda then return make_closure(CLOSURE, x.cdr)
      else
        @environ.nil? or raise EvalError.new('nested macro', x)
        return make_closure(MACRO, x.cdr)
      end
    end

    # $ ではじまるシンボル s を (#<dummy> . s) に置き換える
    def replace_dummy_variables1(j, names)
      case j
      when Symbol
        if j.to_s[0] == ?$
          k = names[j]
          if k.nil? then names[j] = k = Dummy.new(j) end
          return k
        else return j
        end
      when Cell
        case j.car
        when CLOSURE, LAMBDA, MACRO then return j
        else return j.mapcar {|x| replace_dummy_variables1(x, names)}
        end
      else return j
      end
    end

    def compile1(newkar, j)
      (Cell === j) or raise EvalError, 'arglist and body expected'
      rest, table = make_arg_table2(j.car)
      arity = table.length
      arity = -arity if rest
      (Cell === j.cdr) or raise EvalError, 'body expected'
      body = scan2(j.cdr, table)
      body = expand_macros2(body, MAX_MACRO_EXPS)
      body = compile_inners2(body)
      return Cell.new(newkar, Cell.new(arity, body))
    end

    def compile_inners2(j)
      if Cell === j
        case j.car
        when :quote, CLOSURE, LAMBDA, MACRO then return j
        when :lambda then return compile1(LAMBDA, j.cdr)
        when :macro then raise EvalError.new('nested macro', j)
        else return j.mapcar {|x| compile_inners2(x)}
        end
      else return j
      end
    end

    def make_arg_table2(i)      # 仮引数並び -> rest?, table
      offset = 0
      rest = false
      table = {}
      while Cell === i
        j = i.car
        (not rest) or raise EvalError.new('2nd rest', j)
        if j == REST            # &rest rest_arg
          i = i.cdr
          (Cell === i) or raise VariableExpected, i
          j = i.car
          (j != REST) or raise VariableExpected, j
          rest = true
        end
        case j
        when Symbol then sym = j
        when Arg then sym = j = j.symbol
        when Dummy then sym = j.symbol
        else raise VariableExpected, j
        end
        table[j] = Arg.new(0, offset, sym)
        offset += 1
        i = i.cdr
      end
      i.nil? or raise ProperListExpected, i
      return rest, table
    end

    def scan2(j, table)
      case j
      when Symbol, Dummy
        k = table[j]
        return (k.nil?) ? j : k
      when Arg
        k = table[j.symbol]
        return (k.nil?) ? Arg.new(j.level + 1, j.offset, j.symbol) : k
      when Cell
        case j.car
        when :quote, CLOSURE, LAMBDA, MACRO then return j
        else return j.mapcar {|x| scan2(x, table)}
        end
      else return j
      end
    end

    def expand_macros2(j, count)
      if count > 0 and Cell === j
        case k = j.car
        when :quote, :lambda, :macro, CLOSURE, LAMBDA, MACRO then return j
        else
          if Symbol === k then k = @symbol.fetch(k, k) end
          if Cell === k and k.car == MACRO
            args = get_args(j.cdr, false)
            z, cont = apply_lambda(k.cdr, args, false)
            return expand_macros2(z, count - 1)
          else
            return j.mapcar {|x| expand_macros2(x, count)}
          end
        end
      else return j
      end
    end

    def make_closure(newkar, j) # j = (arity . body)
      # (newkar (arity . environ) . body)
      return Cell.new(newkar, Cell.new(Cell.new(j.car, @environ), j.cdr))
    end

    def eval_catch_body(j)      # j = (tag body...)
      (Cell === j) or raise EvalError.new('tag and body expected', j)
      tag = eval(j.car, false)
      begin
        result = nil
        LL.mapc(j.cdr) {|x| result = eval(x, false)}
        return result
      rescue Thrown => th
        if tag == th.tag then return th.value else raise end
      rescue EvalError => ex   # 一般の評価例外は *error* で捕捉される
        if tag == :"*error*" then return ex else raise end
      end
    end

    def eval_unwind_protect_body(j) # j = (body cleanup...)
      (Cell === j) or raise EvalError.new('body (and cleanup) expected', j)
      begin
        return eval(j.car, false)
      ensure LL.mapc(j.cdr) {|x| eval(x, false)}
      end
    end

    # IO または String から式を読んで評価(し，結果を印字)するループ
    def run(rf, interactive=(rf==STDIN))
      rf = StringIO.new(rf) if String === rf
      rr = Reader.new(rf)
      result = nil
      loop {
        print '> ' if interactive
        begin
          x = rr.read
          if x == EOF
            printf "Goodbye\n" if interactive
            return result
          end
          result = eval(x, false)
          puts LL.str(result) if interactive
        rescue EvalError => ex
          if interactive then print ex else raise end
        end
      }
    end
  end # Interp


  PRELUDE = %q{
;; 初期化 Lisp スクリプト

(setq list (lambda (&rest x) x))
(setq progn (macro (&rest x) (list cond (cons t x))))

(setq defmacro
      (macro (name args &rest body)
             (list progn
                   (list setq name (cons macro (cons args body)))
                   (list quote name))))

(defmacro defun (name args &rest body)
  (list progn
        (list setq name (cons lambda (cons args body)))
        (list quote name)))

(defun caar (x) (car (car x)))
(defun cadr (x) (car (cdr x)))
(defun cdar (x) (cdr (car x)))
(defun cddr (x) (cdr (cdr x)))
(defun null (x) (eq x nil))
(defun not (x) (eq x nil))
(defun identity (x) x)
(defun print (x) (prin1 x) (terpri) x)

(defun > (x y) (< y x))
(defun >= (x y) (not (< x y)))
(defun <= (x y) (not (< y x)))
(defun = (x y) (eq x y))
(defun /= (x y) (not (= x y)))

(defmacro if (test then &rest else)
  (cons cond (cons (list test then)
                   (cond (else (list (cons t else)))))))

(defmacro let (args &rest body)
  ((lambda (vars vals)
     (defun vars (x)
       (if (null x) nil
         (cons (if (atom (car x)) (car x) (caar x))
               (vars (cdr x)))))
     (defun vals (x)
       (if (null x) nil
         (cons (if (atom (car x)) nil (cadr (car x)))
               (vals (cdr x)))))
     (cons (cons lambda (cons (vars args) body))
           (vals args)))
   nil nil))

(defun equal (x y)
  (cond ((atom x)
         (eq x y))
        ((equal (car x) (car y))
         (equal (cdr x) (cdr y)))))

(defun mapcar (f x)
  (if (null x) nil
    (cons (f (car x))
          (mapcar f (cdr x)))))

(defun _append (x y)
  (if (null x) y
    (cons (car x) (_append (cdr x) y))))
(defmacro append (x &rest y)
  (if (null y) x
    (list '_append x (cons 'append y))))

(defmacro and (x &rest y)
  (if (null y) x
    (list cond
          (list x (cons 'and y)))))
(defmacro or (x &rest y)
  (if (null y) x
    (list cond
          (list x)
          (list (cons 'or y)))))

(defmacro while (test &rest body)
  (list let (quote ($a))
        (list setq $a
              (list lambda () (list cond (cons test (append body '(($a)))))))
        '($a)))

(defun reduce (f x)
  (if (null x)
      (f)
    (let ((r (car x)))
      (setq x (cdr x))
      (while x
        (setq r (f r (car x))
              x (cdr x)))
      r)))

(defun range (m n)                      ; from Python 3000
  (cond ((< m n)
         (cons m ~(range (+ m 1) n)))))
}
end # L2Lisp


if __FILE__ == $0               # 主ルーチン
  lisp = L2Lisp::Interp.new
  if ARGV.empty? then lisp.run(STDIN)
  else
    ARGV.each {|file_name|
      if file_name == '-' then lisp.run(STDIN)
      else lisp.run(File.new(file_name))
      end
    }
  end
end