depager 0.2.3 → 0.3.0.b20160729

data/examples/rie_pl0/pl0.rie.dr

@@ -0,0 +1,450 @@
+%class Pl0::Parser
+%extend Depager::Lexer ('plugins/lex.rb')
+%extend Depager::Rie ('plugins/rie.rb')
+#%decorate Depager::LALR::ShiftReducePrinter ('plugins/srp.rb')
+%decorate @Rie
+%inner{
+  KEYWORDS = {
+    "begin"     => :BEGINN,
+    "end"       => :END,
+    "call"      => :CALL,
+    "const"     => :CONST,
+    "do"        => :DO,
+    "if"        => :IF,
+    "then"      => :THEN,
+    "odd"       => :ODD,
+    "procedure" => :PROCEDURE,
+    "read"      => :READ,
+    "writeln"   => :WRITELN,
+    "write"     => :WRITE,
+    "var"       => :VAR,
+    "while"     => :WHILE,
+  }
+%}
+%%
+%LEX{
+  /\s+/, /\#.*/  { }
+  "<>"           { yield token( '<>' ) }
+  "<="           { yield token( '<=' ) }
+  ">="           { yield token( '>=' ) }
+  ":="           { yield token( ':=' ) }
+  /\d+/          { yield token( :NUMBER, $&.to_i ) }
+  /\w+/          { yield token( KEYWORDS[$&] || :IDENT, $& ) }
+  /./            { yield token( $& ) }
+%}
+
+#begin-rule
+  program [ code ] :
+      block '.'
+      {
+        block._env = newenv()
+        block._lab = genlab()
+        $.code     = block.code
+        exec_code(linearize_code($.code))
+      }
+  ;
+  block [ _env, _lab, code ] :
+      constdefpart vardeclpart procdeclpart statement
+      {
+        %thread env
+        %except constdefpart._env = newenv( $._env )
+        $.code = [
+          [ :O_JMP, 0, $._lab ],
+          procdeclpart.code,
+          [ :O_LAB, 0, $._lab ],
+          [ :O_INT, 0, procdeclpart.env.nvars ],
+          statement.code,
+          [ :O_OPR, 0, :P_RET ]
+        ]
+        debug_info "SYMS:\n" + procdeclpart.env.pretty_inspect
+        debug_info "CODE:\n" + $.code.pretty_inspect
+      }
+  ;
+  constdefpart [ _env:eq, env ] :
+      # empty
+      { %thread env }
+    | CONST constdeflist ';'
+      { %thread env }
+  ;
+  constdeflist [ _env:eq, env ] :
+        constdef
+      { %thread env }
+    | constdeflist ',' constdef
+      { %thread env }
+  ;
+  constdef [ _env:eq, env ] :
+      IDENT '=' NUMBER
+      {
+        $.env = $._env | [ entry(:CONSTANT, IDENT.value, NUMBER.value) ]
+        not $._env[ IDENT.value ] or
+        message "redeclaration of constant '%s'", IDENT.value
+      }
+  ;
+  vardeclpart [ _env:eq, env ] :
+      # empty
+      { %thread env }
+    | VAR vardecllist ';'
+      { %thread env }
+  ;
+  vardecllist [ _env:eq, env ] :
+      vardecl
+      { %thread env }
+    | vardecllist ',' vardecl
+      { %thread env }
+  ;
+  vardecl [ _env:eq, env ] :
+      IDENT
+      {
+        $.env = $._env | [ entry(:VARIABLE, IDENT.value, 0) ]
+        not $._env[ IDENT.value ] or
+        message "redeclaration of variable '%s'",IDENT.value
+      }
+  ;
+  procdeclpart [ _env:eq, env, code ] :
+      # empty
+      {
+        %thread env
+        $.code = [ ]
+      }
+    | procdeclpart procdecl
+      {
+        %thread env
+        $.code = procdeclpart.code + procdecl.code
+      }
+  ;
+  procdecl [ _env:eq, env, code ] :
+      prochead ';' block ';'
+      {
+        %thread env
+        %transfer code
+        block._lab = prochead.lab
+      }
+  ;
+  prochead [ _env:eq, env, lab ] :
+      PROCEDURE IDENT
+      {
+        lab   = genlab()
+        $.env = $._env | [ entry(:PROC, IDENT.value, lab) ]
+        $.lab = lab
+        not $._env[ IDENT.value ] or
+        message "redeclaration of procedure '%s'",IDENT.value
+      }
+  ;
+  statement [ _env:eq, code ] :
+      # empty
+      { $.code = []; }
+    | ident ':=' expression
+      {
+        %transfer _env
+        $.code = [
+          expression.code,
+          [ :O_STO, $._env.level - ident.entry.level, ident.entry.value ]
+        ]
+        ident.entry.kind == :VARIABLE or
+        message "assignment to constant/procedure is not allowed"
+      }
+    | CALL ident
+      {
+        %transfer _env
+        $.code = [
+          [ :O_CAL, $._env.level - ident.entry.level, ident.entry.value ]
+        ]
+        ident.entry.kind == :PROC or
+        message "call of a constant or a variable is meaningless"
+      }
+    | IF condition THEN statement
+      {
+        %transfer _env
+        lab = genlab();
+        $.code = [
+          condition.code,
+          [ :O_JPC, 0, lab ],
+          statement.code,
+          [ :O_LAB, 0, lab ]
+        ]
+      }
+    | WHILE condition DO statement
+      {
+        %transfer _env
+        lab1   = genlab()
+        lab2   = genlab()
+        $.code = [
+          [ :O_LAB, 0, lab1 ],
+          condition.code,
+          [ :O_JPC, 0, lab2 ],
+          statement.code,
+          [ :O_JMP, 0, lab1 ],
+          [ :O_LAB, 0, lab2 ]
+        ]
+      }
+    | WRITE '(' expression ')'
+      {
+        %transfer _env
+        $.code = [
+          expression.code,
+          [ :O_CSP, 0, :WRI ]
+        ]
+      }
+    | WRITELN '(' expression ')'
+      {
+        %transfer _env
+        $.code = [
+          expression.code,
+          [ :O_CSP, 0, :WRI ],
+          [ :O_CSP, 0, :WRL ]
+        ]
+      }
+    | WRITELN
+      { $.code = [ [ :O_CSP, 0, :WRL ] ] }
+    | READ '(' ident ')'
+      {
+        %transfer _env
+        $.code = [
+          [ :O_CSP, 0, :RDI ],
+          [ :O_STO, $._env.level - ident.entry.level, ident.entry.value ]
+        ]
+        ident.entry.kind == :VARIABLE or
+        message "read to constant/procedure is not allowed"
+      }
+    | BEGINN statementlist END
+      { %transfer _env, code }
+  ;
+
+  statementlist [ _env:eq, code ] :
+      statement
+      { %transfer _env, code }
+    | statementlist ';' statement
+      {
+        %transfer _env
+        $.code = statementlist.code + [ statement.code ]
+      }
+
+  ;
+  expression [ _env:eq, code ] :
+      term
+      { %transfer _env, code }
+    | '+' term
+      { %transfer _env, code }
+    | '-' term
+      {
+        %transfer _env
+        $.code = [
+          term.code,
+          [ :O_OPR, 0, :P_NEG ]
+        ]
+      }
+    | expression addsub term
+      {
+        %transfer _env;
+        $.code = [
+          expression.code,
+          term.code,
+          addsub.code
+        ]
+      }
+  ;
+  addsub [ code ] :
+      '+' { $.code = [ :O_OPR, 0, :P_ADD ] }
+    | '-' { $.code = [ :O_OPR, 0, :P_SUB ] }
+  ;
+  term [ _env:eq, code ] :
+      factor
+      { %transfer _env, code }
+    | term muldiv factor
+      {
+        %transfer _env
+        $.code = [
+          term.code,
+          factor.code,
+          muldiv.code
+        ]
+      }
+  ;
+  muldiv [ code ] :
+      '*' { $.code = [ :O_OPR, 0, :P_MUL ] }
+    | '/' { $.code = [ :O_OPR, 0, :P_DIV ] }
+  ;
+  factor [ _env:eq, code ] :
+      ident
+      {
+        %transfer _env
+        $.code = ident.entry.kind == :CONSTANT ?
+          [ :O_LIT, 0, ident.entry.value ] :
+          [ :O_LOD, $._env.level - ident.entry.level, ident.entry.value ]
+        ident.entry.kind != :PROC or
+        message "expression must not contain a procedure identifier"
+      }
+    | NUMBER
+      { $.code = [ :O_LIT, 0, NUMBER.value ] }
+    | '(' expression ')'
+      { %transfer _env, code }
+  ;
+
+  condition [ _env:eq, code ] :
+      ODD expression
+      {
+        %transfer _env
+        $.code = [
+          expression.code,
+          [ :O_OPR, 0, :P_ODD ]
+        ]
+      }
+    | expression-left relop expression-right
+      {
+        %transfer _env
+        $.code = [
+          left.code,
+          right.code,
+          relop.code
+        ]
+      }
+  ;
+  relop [ code ] :
+      '='  { $.code = [ :O_OPR, 0, :P_EQ ] }
+    | '<>' { $.code = [ :O_OPR, 0, :P_NE ] }
+    | '<'  { $.code = [ :O_OPR, 0, :P_LT ] }
+    | '>'  { $.code = [ :O_OPR, 0, :P_GT ] }
+    | '<=' { $.code = [ :O_OPR, 0, :P_LE ] }
+    | '>=' { $.code = [ :O_OPR, 0, :P_GE ] }
+  ;
+  ident [ _env:eq, entry ] :
+      IDENT
+      {
+        $.entry = $._env[ IDENT.value ]
+        $._env[ IDENT.value ] or
+        message "undeclared identifier %s", IDENT.value
+      }
+  ;
+#end-rule
+%%
+class Pl0::Rie
+  class Env
+    attr_reader :ary, :level
+    def initialize ary, level = 0
+      @ary, @level = ary, level
+      # warn self.inspect
+    end
+    def nvars
+      @ary.inject(0){|r, i| i.level == level and i.kind == :VARIABLE and r += 1 ; r }
+    end
+    def | ary
+      x = @ary.find_all{|i| i.level == level and i.kind == :VARIABLE }.size+3
+      arg = @ary.dup
+      ary.each do |i|
+        i.level = level
+        if i.kind == :VARIABLE
+          i.value = x
+          x += 1
+        end
+        arg.delete_if{|j| j.name == i.name}
+        arg << i
+      end
+      Env.new(arg, level)
+    end
+    def [] name
+      @ary.find{|i| i.name == name }
+    end
+    def inspect
+      "[#{@level}|#{@ary.inspect}]"
+    end
+  end
+  def newenv arg = nil
+    arg ? Env.new(arg.ary.dup, arg.level+1) : Env.new([])
+  end
+  def genlab
+    @label ||= 0
+    @label += 1
+  end
+  class Entry
+    attr_accessor :kind, :name, :value, :level
+    def initialize k, n, v
+      @kind, @name, @value = k, n, v
+      @level = nil
+    end
+    def inspect
+      "(#{@name}.#{@level}:#{@kind.to_s[0,1]}/#{@value})"
+    end
+  end
+  def entry k, n, v
+    #warn "ENTRY:#{n}:#{v.inspect}"
+    Entry.new(k, n, v)
+  end
+  def message *args
+    print("#{basis.file.lineno}:")
+    printf(*args); puts "\n"; exit
+  end
+
+  def debug_info *args
+    $DEBUG and warn(sprintf(*args))
+  end
+  def linearize_code code, res=[], labs={}
+    code.each do |i|
+      case i[0]
+      when :O_LAB
+        lab, addr = i[2], res.size
+        debug_info "PATCH: #{lab}->#{addr} @ #{labs[lab].inspect}"
+        labs[lab] and labs[lab].each{|i| res[i][2] = addr }
+        labs[lab] = res.size
+      when :O_JMP, :O_JPC, :O_CAL
+        lab, addr = i[2], labs[i[2]]
+        if addr.is_a? Integer
+          i[2] = addr
+        else
+          labs[lab] ||= []
+          labs[lab] << res.size
+        end
+        res << i
+      when Symbol
+        res << i
+      else
+        linearize_code i, res, labs
+      end
+    end ; res
+  end
+  # :-3(BP)       :-2          :-1  *STACK*
+  # [lexical base][caller base][PC]{...vars...}
+  def exec_code ils
+    warn "\n** CODE **"
+    ils.each_with_index{|i,x| warn "#{'% 4i'%x} #{i.inspect}"}
+    warn "\n** EXEC **"
+    pc, bp, s = 0, 1, [0, 0, 0, 0]
+    begin
+      op, l, a = ils[pc] ; pc += 1
+      debug_info "  #{s.inspect}\nPC:#{pc-1} BP:#{bp} CODE:[#{op}, #{l}, #{a}]"
+      case op
+      when :O_LIT ; s.push a
+      when :O_OPR ;
+        case a
+        when :P_RET; _, bp, pc, = s.slice!(bp, s.size-1)
+        when :P_NEG; s.push(-s.pop)
+        when :P_ODD; s.push s.pop % 2
+        when :P_ADD; r=s.pop; s.push s.pop + r
+        when :P_SUB; r=s.pop; s.push s.pop - r
+        when :P_MUL; r=s.pop; s.push s.pop * r
+        when :P_DIV; r=s.pop; s.push s.pop / r
+        when :P_EQ ; r=s.pop; s.push( s.pop == r ? 1 : 0 )
+        when :P_NE ; r=s.pop; s.push( s.pop != r ? 1 : 0 )
+        when :P_LT ; r=s.pop; s.push( s.pop <  r ? 1 : 0 )
+        when :P_GE ; r=s.pop; s.push( s.pop >= r ? 1 : 0 )
+        when :P_GT ; r=s.pop; s.push( s.pop >  r ? 1 : 0 )
+        when :P_LE ; r=s.pop; s.push( s.pop <= r ? 1 : 0 )
+        end
+      when :O_LOD; x=bp;l.times{x=s[x]}; s.push s[x+a];
+      when :O_STO; x=bp;l.times{x=s[x]}; s[x+a] = s.pop;
+      when :O_CAL; x=bp;l.times{x=s[x]}; s.push x, bp, pc; bp, pc = s.size-3, a;
+      when :O_INT; s.fill(0, s.size, a)
+      when :O_JMP; pc = a
+      when :O_JPC; pc = a if s.pop == 0
+      when :O_CSP;
+        case a
+        when :RDI; print "?"; s.push Integer(STDIN.gets)
+        when :WRI; printf( "\t%10d", s.pop )
+        when :WRL; puts ""
+        end
+      end
+    end while pc != 0
+  end
+end
+
+parser = Pl0.create_decorated_parser
+r, = parser.parse(ARGF)

data/examples/rie_pl0/test.pl0

@@ -0,0 +1,10 @@
+var x, y;
+  procedure multiply;
+    var a;
+    begin
+      a := x*y;
+      write(x) ; write(y) ; writeln(a)
+    end;
+begin
+  x := 5; y := 10; call multiply
+end.