#
# $Id: lisp.rb,v 1.14 2003/03/25 16:25:42 fukumoto Exp $
#
# module Lisp
#   def cons(a, b)
#   def consp(a)
#   def atom(a)
#   def car(a)
#   def cdr(a)
#   def cadr(a)
#   def cddr(a)
#   def nth(n, l)
#   def list(*args)
#   def append(*args)
#   def prin1_to_string(x)
#   class Cons
#     def inspect
#     def to_s
#     def ==(y)
#   class ConsCons < Cons
#     def initialize(a, b)
#     def nth(n)
#   class List < Cons
#     def initialize(a, from = 0, to = -1)
#     def car
#     def cdr
#     def nth(n)
#   class Input
#     class InputError < Exception; end
#     def initialize(inp = STDIN)
#     def ungettoken(t)
#     def readlist
#     def readlist_rest
#     def gettoken
#   class Interpreter
#     class ExitLisp < Exception; end
#     class LispError < Exception; end
#     def interp
#     def def_env
#     def new_env(old_env, vars, args)
#     class Stack
#       class Chunk < Array
# 	def initialize(cont, offset)
# 	def share
#       def initialize(stack = [], cont = nil)
#       def share
#       def push(x)
#       def pop
#       def concat(a)
#       def empty?
#       def length
#     def setup
#     def _eval(expr, env)
#     def eval_list(lst, env, ret)
#     def eval_body(l, env, ret)
#     def quote(x, e, r)
#     def cond(l, e, r)
#     def setq(l, e, ret)
#     class Closure
#       def initialize(vars, body, env, interpreter)
#       def inspect
#       def call(ret, *args)
#     def defun(x, env, ret)
#     def function(x, env, ret)
#     def multiple_value_list(l, e, r)
#     def multiple_value_setq(l, e, r)
# 

module Lisp

  def cons(a, b)
    ConsCons.new(a, b)
  end
  def consp(a)
    a.kind_of?(Cons) ? :t : nil
  end
  def atom(a)
    a.kind_of?(Cons) ? nil : :t
  end
  def car(a)
    a.car
  end
  def cdr(a)
    a.cdr
  end
  def cadr(a)
    a.cdr.car
  end
  def cddr(a)
    a.cdr.cdr
  end
  def nth(n, l)
    l.nth(n)
  end
  def list(*args)
    List.new(args)
  end
  def append(*args)
    if args.length == 0
      nil
    else
      first = args.shift
      if args.length == 0
	first
      elsif first == nil
	append(*args)
      else
	cons(first.car, append(first.cdr, *args))
      end
    end
  end
  def prin1_to_string(x)
    if x.eql? nil
      "nil"
    else
      x.to_s
    end
  end

  class Cons
    include Lisp
    def inspect
      to_s
    end
    def to_s
      s = "("
      s << prin1_to_string(self.car)
      p = self.cdr
      while p.kind_of? Cons
	s << " " << prin1_to_string(p.car)
	p = p.cdr
      end
      if p == nil
	s << ")"
      else
	s << " . " << prin1_to_string(p) << ")"
      end
    end
    def ==(y)
      if y.kind_of? Cons
	(self.car == y.car) and (self.cdr == y.cdr)
      else
	false
      end
    end
  end

  class ConsCons < Cons
    attr_reader :car, :cdr
    def initialize(a, b)
      @car = a
      @cdr = b
    end
    def nth(n)
      if n == 0
	self.car
      else
	self.cdr.nth(n-1)
      end
    end
  end

  class List < Cons
    def initialize(a, from = 0, to = -1)
      # assert a.kind_of? Array
      @list = a
      @from = from
      @to = (to < 0 ? to + a.length : to)
      @tail = nil
    end
    def car
      @list[@from]
    end
    def cdr
      if @from == @to
	@tail
      else
	List.new(@list, @from+1, @to)
      end
    end
    def nth(n)
      raise if @from + n > @to
      @list[@from + n]
    end
  end

  class Input
    include Lisp
    class InputError < Exception; end
    def initialize(inp = STDIN)
      @in = inp
      @tokenbuf = nil
      @ungettoken = false
    end
    def readlist
      t = gettoken
      if t == '('
	t = gettoken
	if t == ')'
	  nil
	else
	  ungettoken(t)
	  a = readlist
	  cons(a, readlist_rest)
	end
      elsif t == "'"
	a = readlist
	list(:quote, a)
      else
	t
      end
    end
    def readlist_rest
      t = gettoken
      if t == ')'
	nil
      elsif t == '.'
	b = readlist
	t = gettoken
	raise InputError unless t == ')'
	b
      else
	ungettoken(t)
	cons(readlist, readlist_rest)
      end
    end
    def getch
      @in.getc.chr
    end
    def ungetch(c)
      @in.ungetc(c[0])
    end
    def ungettoken(t)
      @tokenbuf = t
      @ungettoken = true
    end
    def gettoken
      if @ungettoken
	@ungettoken = false
	return @tokenbuf
      end

      begin
	c = getch
      end while /\s/ =~ c

      case c
      when /[\(\)\[\]\.\']/
	c
      when /\w|\+|\-|\*/
	w = ''
	begin
	  w << c
	end until /\w|\+|\-|\*/ !~ (c = getch)
	ungetch(c)
	if /^(\-|\+)?\d+$/ =~ w
	  w.to_i
	elsif w == 'nil'
	  nil
	else
	  w.intern
	end
      end
    end
  end # end of Input

  class Interpreter
    include Lisp
    class ExitLisp < Exception; end
    class LispError < Exception; end

    def interp
      inp = Input.new
      setup
      env = def_env()
      @prompt = "> "
      loop {
	begin
	  print @prompt
	  values = _eval(inp.readlist, env)
	  print(values.map{|i| prin1_to_string(i)}.join("\n")); print "\n"
	  print "max: ", @max, "\n" if $VERBOSE
	rescue LispError
	  p $!
	rescue Interrupt, StandardError
	  p $!, $@
	end
      }
    rescue ExitLisp
    end

    def def_env
      initial_values = {
	:t => :t,
	:print => lambda { |r, x| print "\n", prin1_to_string(x), " "; r and r.replace([x]) },
	:prin1 => lambda { |r, x| print prin1_to_string(x); r and r.replace([x]) },
	:car => lambda { |r, x| r and r.replace([x.car]) },
	:cdr => lambda { |r, x| r and r.replace([x.cdr]) },
	:cons => lambda { |r, x, y| r and r.replace([cons(x, y)]) },
	:consp => lambda { |r, x| r and r.replace([consp(x)]) },
	:atom => lambda { |r, x| r and r.replace([atom(x)]) },
	:list => lambda { |r, *x| r and r.replace([List.new(x)]) },
	:listp => lambda { |r, x| r and r.replace([x == nil ? :t : consp(x)]) },
	:append => lambda { |r, *l| r and r.replace([append(*l)]) },
	:eq => lambda { |r, x, y| r and r.replace([x.equal?(y) ? :t : nil]) },
	:equal => lambda { |r, x, y| r and r.replace([x==y ? :t : nil]) },
	:null => lambda { |r, x| r and r.replace([x == nil ? :t : nil]) },
	:not => lambda { |r, x| r and r.replace([x == nil ? :t : nil]) },
	:nth => lambda { |r, n, x| r and r.replace([nth(n, x)]) },
	:numberp => lambda { |r, x| r and r.replace([x.kind_of?(Numeric) ? :t : nil]) },
	:zerop => lambda { |r, x| r and r.replace([x.zero? ? :t : nil]) },
	:+ => lambda { |r, *l| r and r.replace([l.inject(0) { |x,y| x+y }]) },
	:- => lambda { |r, *l|
	  r and r.replace([l.length == 1 ? -l[0] : l[1..-1].inject(l[0]) { |x,y| x-y }])
	},
	:* => lambda { |r, *l| r and r.replace([l.inject(1) { |x,y| x*y }]) },
	"1+".intern => lambda { |r, x| r and r.replace([x + 1]) },
	"1-".intern => lambda { |r, x| r and r.replace([x - 1]) },
	:values => lambda { |r, *l| r and r.replace(l) },
	:quit => lambda { |r,| raise ExitLisp },
	:debug => lambda { |r, x| $DEBUG=x },
      }
      env = Hash.new { |h,k| raise LispError, "unknown name \"#{k}\"" }
      initial_values.each_pair { |k,v| env[k] = v }
      if $DEBUG
	old_env = env 
	env = new_env(env, nil, [])
      end
      env
    end

    def new_env(old_env, vars, args)
      env = Hash.new { |h,k| old_env[k] }
      while vars.kind_of? Cons
	raise LispError, "too few arguments" if args.length == 0
	env[vars.car] = args.shift
	vars = vars.cdr
      end
      if vars.kind_of? Symbol
	env[vars] = List.new(args)
      else
	raise LispError, "too many arguments" if args.length > 0
      end
      env
    end

    class Stack
      class Chunk < Array
	attr_reader :continue
	attr_reader :offset
	attr_reader :shared
	def initialize(cont, offset)
	  super()
	  @continue = cont
	  @offset = offset
	  @shared = false
	end
	def share
	  @shared = true
	end
      end
      def initialize(stack = [], cont = nil)
	@chunk = nil
	@ptr = 0
	@offset = @ptr
      end
      def share
	@chunk.share
	return self.dup
      end
      def push(x)
	if @chunk.eql?(nil) or @chunk.shared
	  @chunk = Chunk.new(@chunk, @ptr)
	  @offset = @ptr
	end
	@chunk[@ptr - @offset] = x
	@ptr += 1
      end
      def pop
	raise if @ptr <= 0
	while @ptr - @offset == 0
	  @chunk = @chunk.continue
	  raise if @chunk.equal? nil
	  @offset = @chunk.offset
	end
	@ptr -= 1
	@chunk[@ptr - @offset]
      end
      def concat(a)
	a.each do |i| push(i) end
      end
      def empty?
	@ptr == 0
      end
      def length
	@ptr
      end
    end

    def setup
      @special = {
	:quote => method(:quote),
	:cond => method(:cond),
	:setq => method(:setq),
	:defun => method(:defun),
	:function => method(:function),
	:"multiple-value-list" => method(:multiple_value_list),
	:"multiple-value-setq" => method(:multiple_value_setq),
	:"call-with-current-continuation" => method(:call_with_current_continuation),
	:callcc => method(:call_with_current_continuation),
      }

      @eval = lambda{ |x, e, r|
	if x == nil or x.kind_of? Numeric
	  r and r.replace([x])
	elsif x.kind_of? Symbol
	  r and r.replace([e[x]])
	elsif x.kind_of? Cons
	  if (s = @special[x.car]) != nil
	    s.call(x.cdr, e, r)
	  else
	    values = []
	    @evalstack.push([@apply, values, e, r])
	    eval_list(x, e, values)
	  end
	else
	  raise LispError, "unknown eval input"
	end
      }

      @apply = lambda{ |a, e, r|
	fn = a.shift
	if fn.respond_to? :call
	  fn.call(r, *a)
	elsif fn.kind_of? Cons and fn.car == :lambda
	  body = fn.cdr.cdr
	  vars = fn.cdr.car
	  env = new_env(e, vars, a)
	  eval_body(body, env, r)
	else
	  p fn if $DEBUG
	  raise LispError, "unknown function form"
	end
      }
    end
      
    def _eval(expr, env)
      (print "enter eval: "; p expr) if $DEBUG
      @evalstack = Stack.new
      values = []
      @max = 0 if $VERBOSE
      @evalstack.push([@eval, expr, env, values])
      while not @evalstack.empty?
	@max = @evalstack.length if @max < @evalstack.length if $VERBOSE
	job = @evalstack.pop
	(print @evalstack.length, ": "; p job) if $DEBUG
	op = job[0]
	op.call(*job[1..-1])
      end # end of while 
      values
    end # end of def

    def eval_list(lst, env, ret)
      @eval_list_continue ||= lambda { |v, l, e, r|
	r and r.push(v[0])
	if l != nil
	  eval_list(l, e, r)
	end
      }
      retval = []
      @evalstack.push([@eval_list_continue, retval, lst.cdr, env, ret])
      @evalstack.push([@eval, lst.car, env, retval])
    end

    def eval_body(l, env, ret)
      if l != nil
	a = []
	while l.cdr != nil
	  a.unshift([@eval, l.car, env, nil])
	  l = l.cdr
	end
	a.unshift([@eval, l.car, env, ret])
	@evalstack.concat(a)
      end
    end

    def quote(x, e, r)
      r and r.replace([x.car])
    end

    def cond(l, e, r)
      @cond_continue ||= lambda{ |clauses, env, evalresult, ret|
	if evalresult[0] != nil
	  eval_body(clauses.car.cdr, env, ret)
	else
	  cond(clauses.cdr, env, ret)
	end
      }
      retval = []
      @evalstack.push([@cond_continue, l, e, retval, r])
      @evalstack.push([@eval, l.car.car, e, retval])
    end

    def setq(l, e, ret)
      @setq_continue ||= lambda{ |list, env, value, retval|
	env[list.car] = value[0]
	list = list.cdr.cdr
	if list == nil
	  retval and retval.replace([value[0]])
	else
	  setq(list, env, retval)
	end
      }
      r = []
      @evalstack.push([@setq_continue, l, e, r, ret])
      @evalstack.push([@eval, l.cdr.car, e, r])
    end

    class Closure
      def initialize(vars, body, env, interpreter)
	@vars = vars
	@body = body
	@env = env
	@interpreter = interpreter
      end
      def inspect
	sprintf("#<%s:%x>", self.class, self.__id__)
      end
      def call(ret, *args)
	env = @interpreter.new_env(@env, @vars, args)
	@interpreter.eval_body(@body, env, ret)
      end
    end

    def defun(x, env, ret)
      f = x.car
      fname = f.car
      vars = f.cdr
      body = x.cdr
      env[fname] = Closure.new(vars, body, env, self)
      ## env[fname] = cons(:lambda, cons(vars, body))
      ret and ret.replace([fname])
    end

    def function(x, env, ret)
      raise LispError, "function argument not lambda expression" if x.car.car != :lambda
      # warn if x.cdr != nil
      vars = x.car.cdr.car
      body = x.car.cdr.cdr
      ret and ret.replace([Closure.new(vars, body, env, self)])
    end

    def multiple_value_list(l, e, r)
      @multiple_value_list_cont ||= lambda { |val, env, ret|
	ret and ret.replace([List.new(val)])
      }
      values = []
      @evalstack.push([@multiple_value_list_cont, values, e, r])
      @evalstack.push([@eval, l.car, e, values])
    end

    def multiple_value_setq(l, e, r)
      @multiple_value_setq_cont ||= lambda { |val, vars, env, ret|
	retval = val[0]
	while vars != nil
	  env[vars.car] = val.shift
	  vars = vars.cdr
	end
	ret and ret.replace([retval])
      }
      values = []
      @evalstack.push([@multiple_value_setq_cont, values, l.car, e, r])
      @evalstack.push([@eval, l.cdr.car, e, values])
    end

    def call_with_current_continuation(l, e, r)
      stack = @evalstack.share
      cont = lambda { |ret, *args|
	@evalstack = stack
	r and r.replace(args)
      }
      callcc_cont = lambda { |val, env, ret|
	@evalstack.push([@apply, [val[0], cont], env, ret])
      }
      values = []
      @evalstack.push([callcc_cont, values, e, r])
      @evalstack.push([@eval, l.car, e, values])
    end
  end # end of class Interpreter

end # end of module Lisp