RubyでSchemeを作ってみたよ今度こそ。

ちゃんとREPLでインタープリット！末尾再帰最適化！継続なし！(でも原理的にはすぐ実装できるはず……！）中間言語方式！

class Cons
  def initialize(a,d)
    @car=a
    @cdr=d
  end
  attr_accessor :car
  attr_accessor :cdr
  def cadr
    cdr.car
  end
  def caddr
    cdr.cadr
  end
  def cadddr
    cdr.caddr
  end
  def cddr
    cdr.cdr
  end
  def to_a
    return [car] if cdr.nil?
    return [car] + cdr.to_a if cons? cdr
    raise 'not proper list'
  end
  def length
    return 1 if cdr.nil?
    return 1 + cdr.length
    raise 'not proper list'
  end
  def to_s
    str="("
    cur=self
    while cons? cur.cdr
      str+=cur.car.to_s + " "
      cur=cur.cdr
    end
    str+=cur.car.to_s
    str+=" . " +cur.cdr.to_s unless cur.cdr.nil?
    str+=")"
    return str
  end
end

def nil.to_s
  "()"
end

def list(*ss)
  return nil if ss.length==0
  return cons(ss.first,list(*ss[1...ss.length]))
end

def cons?(s)
  s.kind_of?(Cons)
end

def cons(car,cdr)
  return Cons.new(car,cdr)
end

class Environment
  def initialize(parent)
    @parent=parent
    @hash=Hash.new
  end
  attr_reader :parent
  def key?(name)
    return current_key?(name) || (@parent && @parent.key?(name))
  end
  def current_key?(name)
    return @hash.key?(name)
  end
  def define(name,value)
    @hash.store(name,value)
  end
  def get(name)
    return @hash[name] if current_key? name
    return @parent.get(name) unless @parent.nil?
    raise "not defined: #{name}"
  end
  def set(name,value)
    return @hash.store(name,value) if current_key?(name)
    return @parent.set(name,value) unless @parent.nil?
    raise "not defined: #{name}"
  end
end


def parse_s(src)
  src=src.gsub(/\s+/,",").gsub(/[a-zA-Z+\-*\/][a-zA-Z0-9?!]*/,":\\0").gsub("(","list(")
  eval(src)
end


Frame=Struct.new(:parent,:env,:nxt,:rib)
Closure=Struct.new(:env,:params,:body)

def compile(sexpr,nxt)
  #p "compile #{sexpr.to_s},#{nxt.to_s}"
  return compile_list(sexpr,nxt) if cons? sexpr
  return [:refer, sexpr, nxt] if sexpr.kind_of? Symbol
  return [:const, sexpr, nxt]
end

def compile_list(sexpr,nxt)
  case sexpr.car
  when :if
    th=compile(sexpr.caddr,nxt)
    el=compile(sexpr.cadddr,nxt)
    return compile(sexpr.cadr,[:test,th,el])
  when :lambda
    body=sexpr.cddr.to_a.reverse.inject([:return]){|r,i|compile(i,r)}
    params=sexpr.cadr.to_a
    return [:close,params,body,nxt]
  when :define
    return compile(sexpr.caddr,[:define,sexpr.cadr,nxt])
  when :set!
    return compile(sexpr.caddr,[:set,sexpr.cadr,nxt])
  else
    call=sexpr.cdr.to_a.reverse.inject(compile(sexpr.car,[:apply])){|r,i|compile(i,[:param,r])}
    call=[:frame,nxt,call] unless nxt[0]==:return
    return call
  end
end



class VM
  attr_reader :env
  def initialize env
    @global=env
    @env=Environment.new(env)
    @next=[:halt]
    @ax=nil
    @rib=[]
    @frame=nil
  end
  def run_string(src)
    run(compile(parse_s(src),[:halt]))
  end
  def run(instruction)
    @next=instruction
    while true
      case @next[0]
      when :halt
        return @ax
      when :refer
        @ax=@env.get(@next[1])
        @next=@next[2]
      when :const
        @ax=@next[1]
        @next=@next[2]
      when :test
        if @ax.nil?
          @next=@next[2]
        else
          @next=@next[1]
        end
      when :close
        @ax=Closure.new(@env,@next[1],@next[2])
        @next=@next[3]
      when :apply
        if @ax.instance_of? Closure
          @env=Environment.new(@ax.env)
          @rib.each_index{|i|
            @env.define(@ax.params[i],@rib[i])
          }
          @rib=[]
          @next=@ax.body
        elsif @ax.instance_of? Proc
          @ax=@ax.call *@rib
          @next=[:return]
        end
      when :frame
        @frame=Frame.new(@frame,@env,@next[1],@rib)
        @rib=[]
        @next=@next[2]
      when :param
        @rib.push @ax
        @next=@next[1]
      when :return
        @env=@frame.env
        @next=@frame.nxt
        @rib=@frame.rib
        @frame=@frame.parent
      when :define
        @global.define(@next[1],@ax)
        @next=@next[2]
      when :set
        @env.set(@next[1],@ax)
        @next=@next[2]
      else
        raise 'unknown instruction'
      end
    end
  end
end


def repl
  global=Environment.new(nil)
  global.define(:nil,nil)
  global.define(:list,lambda{|*s|list *s})
  global.define(:+,lambda{|*s| s.inject(0){|r,i|r+i}})
  global.define(:read,lambda{parse_s gets.chop})
  global.define(:eval,lambda{|s|VM.new(global).run(compile(s,[:halt]))})
  global.define(:print,lambda{|s|puts s.to_s})
  global.define(:repl,Closure.new(Environment.new(global),[],compile(parse_s('((lambda () (print (eval (read))) (repl)))'),[:halt])))
  vm=VM.new global
  vm.run_string '(repl)'
end

(define incr nil)

;定番のアレ
((lambda (counter) (set! incr (lambda () (set! counter (+ counter 1))))) 0) 

(incr)
1
(incr)
2
(incr)
3


(define inf (lambda () (inf))) ;無限に実行できるよ……！なぜなら末尾再帰だから……！
(define inf2(lambda () (inf) 1)) ;末尾再帰じゃないとメモリをモリモリ食べた挙句落ちるよ……！