gpm.rb

gpm.rb

require 'strscan'

=begin

http://parametron.blogspot.jp/search/label/Christopher%20Strachey%E3%81%AEGPM

program = token*
token = argexpansion | macrocall | literal | constant
literal = [^$;<>,]+
argexpansion = ~ \d+
macrocall = $ macroname macroargs ;
macroname = token+
macroargs = macroarg*
macroarg = , token*
constant = < token* >

=end
class GPM
  def self.parse(str)
    Parser.new(str).parse
  end

  def self.eval(tree)
    Interpreter.new.eval(tree)
  end

  class Interpreter
    def initialize
      @env = [[]]
    end

    def eval(tree)
      op, *rest = tree
      case op
      when :concat, :arg
        rest.map {|x| eval x }.join
      when :argexpand
        raise "malformed form of #{op} (#{rest.inspect})" if rest.size != 1 || !rest[0].is_a?(Fixnum)
        elem = lookup(rest[0])
        raise "argument index error: #{rest[0]}" unless elem.is_a?(String)
        elem
      when :call
        raise "empty call" if rest.empty?
        pp({ :call_args => rest, :with_env => @env }) if $DEBUG
        macroname, *args = rest.map {|x| eval x }
        if macroname =~ /\Adef\z/
          raise "malformed def: (#{evaluated.inspect})" if args.size != 2
          @env.last.unshift [args[0], GPM.parse(args[1])]
          ""
        else
          body = lookup(macroname)
          @env.push [[0, macroname]].concat args.each_with_index.map {|x,i| [i + 1, x] }
          pp({:call_body => body, :call_env => @env}) if $DEBUG
          result = eval body
          @env.pop
          result
        end
      when :const, :lit
        raise "malformed form of #{op} (#{rest.inspect})" if rest.size != 1 || !rest[0].is_a?(String)
        rest[0]
      else
        raise "unexpected operator: #{op.inspect}"
      end
    end

    private

    def lookup(macroname)
      @env.reverse_each do |frame|
        if pair = frame.assoc(macroname)
          return pair[1]
        end
      end
      raise "undefined macro: #{macroname.inspect}"
    end
  end

  class Parser
    def initialize(str)
      @s = StringScanner.new(str)
      @stack = []
    end

    def parse
      @stack.push [:concat]
      while parse_token(false)
        # p @stack
      end
      @stack.last
    end

    protected

    def parse_list
      @stack.push [], [:arg]
      while parse_token(true)
        # p @stack
      end
      @stack.last
    end

    private

    def parse_token(is_list)
      skip_whitespace
      case
      when @s.skip(/\$/)
        @stack.last.push [:call, *parse_call]
      when @s.skip(/</)
        @stack.last.push [:const, parse_const]
      when argno = @s.scan(/~\d+/)
        @stack.last.push [:argexpand, argno[1..-1].to_i]
      when is_list && @s.skip(/,/)
        top = @stack.pop
        @stack.last.push top
        @stack.push [:arg]
      when lit = @s.scan(is_list ? /[^<>$;~,\s]+/ : /[^<>~$;\s]+/) || @s.scan(/~/)
        @stack.last.push [:lit, lit]
      when @s.eos?
        if is_list
          top = @stack.pop
          @stack.last.push top
        end

        case @stack.size
        when 1
          false
        when 0
          raise "unexpected state"
        else
          raise "unclosed #{@stack.last[0]}"
        end
      else
        raise "unexpected char: #{@s.peek(1)}"
      end
    end

    def parse_call
      start = @s.pos
      skip_call
      Parser.new(@s.string[start..@s.pos - 2]).parse_list
    end

    def parse_const
      start = @s.pos
      skip_const
      @s.string[start..@s.pos - 2]
    end

    def skip_call
      nest = 1

      while nest > 0
        @s.skip(/[^<$;>]*/)
        case
        when @s.skip(/;/)
          nest -= 1
        when @s.skip(/\$/)
          nest += 1
        when @s.skip(/</)
          skip_const
        else
          raise "got unexpected char parsing $; (#{@s.peek(1)})"
        end
      end
    end

    def skip_const
      nest = 1
      while nest > 0
        @s.skip(/[^<>]*/)
        case
        when @s.skip(/>/)
          nest -= 1
        when @s.skip(/</)
          nest += 1
        else
          raise "got unexpected char parsing <> (#{@s.peek(1)})"
        end
      end
    end

    def skip_whitespace
      @s.skip(/\s+/)
    end
  end
end

require 'pp'

str = DATA.read
pp parsed = GPM.parse(str)
pp GPM.eval parsed

__END__
$def,1+,<$1,2,3,4,5,6,7,8,9,10,$def,1,<~>~1;;>;

$def,1-,<$-1,0,1,2,3,4,5,6,7,8,$def,-1,<~>~1;;>;

$def,+,<$~1,
 $def,~1,<$1+,$+,$1-,>~1<;,>~2<;;>;,
 $def,0,~2;;>;

$def,-,<$~2,
 $def,~2,<$-,$1-,>~1<;,$1-,>~2<;;>;,
 $def,0,~1;;>;

$def,lt,<$~1,
  $def,~1,<$p,>~1<,>~2<,$def,p,$lt,$1-,>~1<;,>~2<;;;>;
  $def,-1,t;$def,~2,f;;>;

$def,gcd,<$~2,
 $def,~2,
  <$$lt,>~1<,>~2<;,
  $def,f,
   <$gcd,$-,>>~1<<,>>~2<<;,>>~2<<;>;,
  $def,t,
   <$gcd,>>~1<<,$-,>>~2<<,>>~1<<;;>;;>;,
 $def,~1,~1;;>;

$def, hanoi, <
  $def, n-1,
    $1-,~4;
  ;
  $~4,
    $def, ~4, <
      $hanoi, >~1<, >~3<, >~2<, >$n-1;<;
      +
      >~1< - >~3<
      +
      $hanoi, >~2<, >~1<, >~3<, >$n-1;<;
    >;
    $def, 0, <
      >~1< - >~3<
    >;
  ;
>;
$hanoi,a,b,c,2;

$gcd,2,4;,$gcd,5,3;,$gcd,6,3;