オレ言語

ore.rb

class OreSymbol
  attr_reader :sym
  def initialize(name)
    @sym = name[1..-1].to_sym
  end

  def to_sym
    @sym
  end

  def ==(s)
    @sym == s.to_sym
  end
end

class Parser
  def parse(token)
    @i = 0
    @token = token
    self.parse_quotation
  end

  def parse_quotation
    ast = []
    while @i < @token.size
      t = @token[@i]

      if t == "("
        begin
          @i += 1
        end while @token[@i] != ")"
        @i += 1
        t = @token[@i]
      end

      if t =~ /^\d+$/
        ast << t.to_i
      elsif t =~ /^".*"$/
        ast << t[1..-2]
      elsif t == "["
        @i += 1
        ast << self.parse_quotation
      elsif t == "]"
        break
      elsif t == ":"
        @i += 1
        ast << @token[@i]
        @i += 1
        ast << self.parse_quotation
        ast << :"define-word"
      elsif t == ";"
        break
      elsif t == "true"
        ast << true
      elsif t == "false"
        ast << false
      elsif t == "nil"
        ast << nil
      elsif t[0] == ":"
        ast << OreSymbol.new(t)
      else
        ast << t.to_sym
      end
      @i += 1
    end
    ast
  end
end

token = []
DATA.readlines.each do |t|
  token.concat t.split
end
ast = Parser.new.parse(token)

class VM
  def initialize
    @stack = []
    @retain_stack = []
    @break_flg = false
    @words = {
      :call => ->{self.run(@stack.pop)},
      :print => ->{puts @stack.pop},
      :drop => ->{@stack.pop},
      :dup => ->{@stack << @stack[-1]},
      :over => ->{@stack << @stack[-2]},
      :swap => ->{@stack[-2], @stack[-1] = @stack[-1], @stack[-2]},
      :"unit-test" => ->{self.run(@stack.pop);r=@stack.shift;raise "#{@stack} is not #{r}" unless r == @stack;@stack=[]},
      :"define-word" => ->{quot=@stack.pop;name=@stack.pop.to_sym;@words[name]=->{self.run(quot)}},
      :if => ->{e=@stack.pop;t=@stack.pop;b=@stack.pop;self.run(b ? t : e)},
      :loop => ->{quot=@stack.pop;loop{self.run(quot);if @break_flg then @break_flg=false;break;end}},
      :break => ->{@break_flg=true},
      :">r" => ->{@retain_stack << @stack.pop},
      :"r>" => ->{@stack << @retain_stack.pop},
      :send => ->{r=@stack.pop;m=@stack.pop;a=@stack.pop;@stack << r.__send__(m, *a)},
      :sendb => ->{r=@stack.pop;m=@stack.pop;tmp=@stack.pop;b=->*x{@stack.concat(x);self.run(tmp);@stack.pop};a=@stack.pop;@stack << r.__send__(m, *a, &b)},
      :"get-const" => ->{c=@stack.pop;@stack << Object.const_get(c)},
      :curry => ->{@stack.last << @stack.delete_at(-2)},
    }
    [:==, :<, :>, :<=, :>=, :!=, :+, :-, :*, :/, :%].each do |c|
      @words[c] = ->{a=@stack.pop;b=@stack.pop;@stack << (b.__send__(c, a))}
    end
  end

  def run(ast)
    ast.each do |d|
      case d
      when Symbol
        @words[d].call
      when OreSymbol
        @stack << d.sym
      else
        @stack << d
      end
      break if @break_flg
    end
  end
end

VM.new.run(ast)

__END__
: nip ( x1 x2 -- x2 ) swap drop ;
: tuck ( x1 x2 -- x2 x1 x2 ) swap over ;
: 2dup ( x1 x2 -- x1 x2 x1 x2 ) over over ;
: 2drop ( x1 x2 -- ) drop drop ;
: rot ( x1 x2 x3 -- x2 x3 x1 ) >r swap r> swap ;
: -rot ( x1 x2 x3 -- x3 x1 x2 ) swap >r swap r> ;
: 2swap ( x1 x2 x3 x4 -- x3 x4 x1 x2 ) >r -rot r> -rot ;
: 2over ( x1 x2 x3 x4 -- x1 x2 x3 x4 x1 x2 ) >r >r 2dup r> -rot r> -rot ;
: dip swap >r call r> ;
: new-quot [ ] :new :Array get-const send ;
: 0send [ ] -rot send ;
: 1send >r >r new-quot curry r> r> send ;
: map ( block receiver -- array ) new-quot -rot :map swap sendb ;

[ "a" 3 ] [ "a" 1 2 + ] unit-test
[ "a" 2 ] [ "a" 1 2 * ] unit-test
[ "a" "abc" ] [ "a" "a" "b" "c" + + ] unit-test
[ "a" 2 ] [ "a" [ 1 [ 1 + ] ] call call ] unit-test
[ "a" 1 ] [ "a" 1 2 drop ] unit-test
[ "a" 1 1 ] [ "a" 1 dup ] unit-test
[ "a" 1 2 1 ] [ "a" 1 2 over ] unit-test
[ "a" 2 1 ] [ "a" 1 2 swap ] unit-test
[ true false nil ] [ true false nil ] unit-test
[ 1 ] [ true [ 1 ] [ 2 ] if ] unit-test
[ 2 ] [ false [ 1 ] [ 2 ] if ] unit-test
[ 2 ] [ nil [ 1 ] [ 2 ] if ] unit-test
[ 1 ] [ 5 [ 1 ] [ 2 ] if ] unit-test
[ 1 ] [ "a" [ 1 ] [ 2 ] if ] unit-test
[ true ] [ 1 1 == ] unit-test
[ false ] [ 1 2 == ] unit-test
[ true ] [ 1 2 != ] unit-test
[ false ] [ 1 1 != ] unit-test
[ true ] [ 2 1 > ] unit-test
[ false ] [ 2 2 > ] unit-test
[ false ] [ 1 2 > ] unit-test
[ true ] [ 1 2 < ] unit-test
[ false ] [ 2 2 < ] unit-test
[ false ] [ 2 1 < ] unit-test
[ true ] [ 2 1 >= ] unit-test
[ true ] [ 2 2 >= ] unit-test
[ false ] [ 1 2 >= ] unit-test
[ true ] [ 1 2 <= ] unit-test
[ true ] [ 2 2 <= ] unit-test
[ false ] [ 2 1 <= ] unit-test
[ 1 ] [ 1 2 >r ] unit-test
[ 1 2 ] [ 1 2 >r >r r> r> ] unit-test
[ 1 ] [ 2 1 - ] unit-test
[ 2 ] [ 1 1 + ] unit-test
[ 2 ] [ 1 2 * ] unit-test
[ 2 ] [ 4 2 / ] unit-test
[ 2 ] [ 5 3 % ] unit-test
[ 5 ] [ 0 [ dup 5 < [ 1 + ] [ break ] if ] loop ] unit-test
[ 2 3 1 ] [ 1 2 3 rot ] unit-test
[ 2 ] [ 1 2 nip ] unit-test
[ 2 1 2 ] [ 1 2 tuck ] unit-test
[ 1 2 1 2 ] [ 1 2 2dup ] unit-test
[ ] [ 1 2 2drop ] unit-test
[ 2 3 1 ] [ 1 2 3 rot ] unit-test
[ 3 1 2 ] [ 1 2 3 -rot ] unit-test
[ 3 4 1 2 ] [ 1 2 3 4 2swap ] unit-test
[ 1 2 3 4 1 2 ] [ 1 2 3 4 2over ] unit-test
[ 2 2 ] [ 1 2 [ 1 + ] dip ] unit-test
[ a ] [ :a ] unit-test
[ :a ] [ :a ] unit-test
[ "1" ] [ [ ] :to_s 1 send ] unit-test
[ [ ] ] [ new-quot ] unit-test
[ "1" ] [ :to_s 1 0send ] unit-test
[ [ 1 ] ] [ 1 new-quot curry ] unit-test
[ [ 1 2 ] ] [ 2 :push 1 new-quot curry 1send ] unit-test
[ [ 2 3 4 ] ] [ [ 1 + ] [ 1 2 3 ] map ] unit-test