test/derived/CalcParse.m3


MODULE CalcParse;
Generated by kyacc
IMPORT CalcTok;
IMPORT IntIntTbl, IntTextTbl;
IMPORT RTType;
IMPORT Env, Thread, Wr, Fmt, Rd;
FROM Stdio IMPORT stdout;
FROM CalcTok IMPORT NewPT;
<* FATAL Wr.Failure, Thread.Alerted *>

TYPE
  TypedSymbol = RECORD
    code: INTEGER;
    value: CalcTok.ParseType;
  END;
CONST
  EOFSymbol = TypedSymbol{code := 0, value := NIL};
  NoToken = TypedSymbol{code := -1, value := NIL};
  NotASymbol = TypedSymbol{code := -1000, value := NIL};

TYPE
  StackElem = RECORD
    state: INTEGER;
    value: TypedSymbol;
  END;
  StackElemArray = REF ARRAY OF StackElem;

  Stack = RECORD
    a: StackElemArray;
    ptr: INTEGER;
  END;

REVEAL
  T = Public BRANDED "CalcParse" OBJECT
    lex: CalcTok.Lexer;
    tokenLookup: IntIntTbl.T := NIL; (* M3 type code -> SymCode *)
    symbols: IntTextTbl.T;           (* SymCode -> name *)
    allocate_expr: CalcTok.Allocator;
    allocate_list: CalcTok.Allocator;
    allocate_number: CalcTok.Allocator;
    allocate_stat: CalcTok.Allocator;
  OVERRIDES
    setLex := SetLex;
    parse := Parse;
    purge := Purge;
    empty_list := empty_list;
    cons_list := cons_list;
    eval_stat := eval_stat;
    assign_stat := assign_stat;
    paren_expr := paren_expr;
    add_expr := add_expr;
    sub_expr := sub_expr;
    mul_expr := mul_expr;
    div_expr := div_expr;
    uminus_expr := uminus_expr;
    ident_expr := ident_expr;
    num_expr := num_expr;
    digit_number := digit_number;
    cons_number := cons_number;
  END;

TYPE
  SymCode = BITS 9 FOR [0..264];
  (* symbol code:  0 .. 263
     set default:  264 *)

  Action = BITS 6 FOR [0..54];
  (* error:        -1   (not stored in table)
     shift:        1 .. 24
     accept:       25
     reduce:       26 .. 39
     shift&accept: 40
     shift&reduce: 41 .. 54  *)

  StateRef = BITS 6 FOR [0..45];
  (* no more:      0
     next state:   1..45 *)

  S = RECORD
    key: SymCode;
    action: Action;
    next: StateRef;
  END;

  R = RECORD
    length: INTEGER;
    returnCode: INTEGER;
    name: TEXT;
  END;

  Y = RECORD
    code: INTEGER;
    name: TEXT;
  END;

CONST
  States = ARRAY [1..45] OF S {
    S{264,26,25}, S{264,25,26}, S{260,12,27}, S{260,50,28}, S{10,42,0},
    S{264,28,29}, S{264,36,30}, S{264,37,31}, S{260,49,27}, S{264,29,29},
    S{260,50,27}, S{41,45,32}, S{260,17,27}, S{264,32,33}, S{260,18,27},
    S{260,48,27}, S{264,32,34}, S{264,31,34}, S{260,48,28}, S{260,24,28},
    S{260,14,28}, S{260,49,28}, S{260,10,28}, S{264,31,33}, S{258,2,0},
    S{259,5,35}, S{45,11,36}, S{45,4,36}, S{43,20,37}, S{256,23,0},
    S{263,54,0}, S{43,15,38}, S{42,19,39}, S{42,16,40}, S{260,6,41},
    S{261,51,42}, S{45,21,33}, S{45,13,34}, S{47,22,0}, S{47,9,0},
    S{261,7,43}, S{40,3,44}, S{45,4,42}, S{262,8,45}, S{263,53,0}};

  Rules = ARRAY [26..39] OF R {
    R{0, 258, "empty_list :"},
    R{3, 258, "cons_list : list stat '\\n'"},
    R{1, 259, "eval_stat : expr"},
    R{3, 259, "assign_stat : LETTER ASSIGN expr"},
    R{3, 260, "paren_expr : '(' expr ')'"},
    R{3, 260, "add_expr : expr '+' expr"},
    R{3, 260, "sub_expr : expr '-' expr"},
    R{3, 260, "mul_expr : expr '*' expr"},
    R{3, 260, "div_expr : expr '/' expr"},
    R{2, 260, "uminus_expr : '-' expr"},
    R{1, 260, "ident_expr : LETTER"},
    R{1, 260, "num_expr : number"},
    R{1, 262, "digit_number : DIGIT"},
    R{2, 262, "cons_number : number DIGIT"}
};

  Symbols = ARRAY [1..16] OF Y {
    Y{0,"EOF"}, Y{10,"'\\n'"}, Y{40,"'('"}, Y{41,"')'"}, Y{42,"'*'"},
    Y{43,"'+'"}, Y{45,"'-'"}, Y{47,"'/'"}, Y{256,"ASSIGN"}, Y{257,"ERROR"},
    Y{258,"list"}, Y{259,"stat"}, Y{260,"expr"}, Y{261,"LETTER"},
    Y{262,"number"}, Y{263,"DIGIT"}};

VAR
  Debug := Env.Get("CalcParseDEBUG") # NIL;

PROCEDURE SetLex(self: T; lex: CalcTok.Lexer): T =
  BEGIN self.lex := lex; RETURN self; END SetLex;

PROCEDURE Init(self: T) =
  BEGIN (* called on first parse *)
    self.tokenLookup := NEW(IntIntTbl.Default).init(16);
    IF Debug THEN
      self.symbols := NEW(IntTextTbl.Default).init(16);
      FOR i := 1 TO 16 DO
        EVAL self.symbols.put(Symbols[i].code, Symbols[i].name);
      END;
    END;
  END Init;

PROCEDURE NextToken(self: T): TypedSymbol =
  VAR
    symCode, m3code: INTEGER;
    token: CalcTok.Token;
    found := FALSE;
  BEGIN
    TRY
      token := self.lex.get();
    EXCEPT
      Rd.EndOfFile => RETURN EOFSymbol;
    END;
    m3code := TYPECODE(token);
    IF NOT self.tokenLookup.get(m3code, symCode) THEN
      REPEAT
        m3code := RTType.Supertype(m3code);
        IF m3code = RTType.NoSuchType THEN
          TYPECASE token OF
          | ConstToken => symCode := -1;
          | DIGIT => symCode := 263;
          | LETTER => symCode := 261;
          ELSE
            <* ASSERT FALSE *>
          END;
          found := TRUE;
        ELSE
          found := self.tokenLookup.get(m3code, symCode);
        END;
      UNTIL found;
      EVAL self.tokenLookup.put(TYPECODE(token), symCode);
    END;
    IF symCode = -1 THEN
      symCode := NARROW(token, ConstToken).val;
    END;
    RETURN TypedSymbol{code := symCode, value := token};
  END NextToken;

PROCEDURE AllocStack(): Stack =
  VAR
    a :=NEW(StackElemArray, 16);
  BEGIN
    a[0] := StackElem{state := 1, value := EOFSymbol};
    RETURN Stack{a := a, ptr := 0};
  END AllocStack;

PROCEDURE Push(VAR stack: Stack; elem: StackElem) =
  VAR
    new: StackElemArray;
  BEGIN
    INC(stack.ptr);
    IF stack.ptr > LAST(stack.a^) THEN
      new := NEW(StackElemArray, NUMBER(stack.a^) * 2);
      SUBARRAY(new^, 0, NUMBER(stack.a^)) := stack.a^;
      stack.a := new;
    END;
    stack.a[stack.ptr] := elem;
  END Push;

PROCEDURE ActionLookup(curState: INTEGER; symbol: TypedSymbol): INTEGER =
  VAR
    cur := curState;
    state: S;
    default := -1;
  BEGIN
    REPEAT
      state := States[cur];
      IF state.key = 264 THEN
        default := state.action;
      ELSIF state.key = symbol.code THEN
        RETURN state.action;
      END;
      cur := state.next;
    UNTIL cur = 0;
    RETURN default;
  END ActionLookup;

PROCEDURE Parse(self: T; exhaustInput: BOOLEAN := TRUE): StartType =
  VAR
    curState: INTEGER := 1;
    stack := AllocStack();
    action: INTEGER;
    symbol, preservedToken: TypedSymbol;
    skipTokenGets: INTEGER := 0;

  PROCEDURE DebugPrint(message: TEXT) = BEGIN
    IF Debug THEN Wr.PutText(stdout,"CalcParseDEBUG: "&message&"\n");
     Wr.Flush(stdout);END;END DebugPrint;
  PROCEDURE DebugSymbol(message: TEXT) = VAR name: TEXT; BEGIN
   IF Debug THEN EVAL self.symbols.get(symbol.code, name);
    DebugPrint(message & " " & name & "(" &
      Fmt.Int(symbol.code) & ")"); END; END DebugSymbol;
  PROCEDURE DebugState(message: TEXT) = BEGIN IF Debug THEN
    DebugPrint(message & " " & Fmt.Int(curState));END;END DebugState;
  PROCEDURE DebugRule(message: TEXT) = BEGIN IF Debug THEN
    DebugPrint(message&" "&Rules[action].name);END;END DebugRule;

  BEGIN
    IF self.tokenLookup = NIL THEN Init(self); END;
    stack.a[0] := StackElem{state := curState, value := NotASymbol};
    DebugState("starting in state");
    LOOP
      IF skipTokenGets = 2 THEN
        skipTokenGets := 1;
        DebugSymbol("scanning reduced symbol");
      ELSIF skipTokenGets = 1 AND preservedToken # NoToken THEN
        skipTokenGets := 0;
        symbol := preservedToken;
        DebugSymbol("re-scanning input token");
      ELSE
        skipTokenGets := 0;
        symbol := NextToken(self);
        preservedToken := symbol;
        DebugSymbol("input token");
      END;
      action := ActionLookup(curState, symbol);
      IF action >= 40 THEN
        DebugPrint("shifting anonymously");
        Push(stack, StackElem{state := 0, value := symbol});
        DEC(action, 15);
        IF skipTokenGets = 0 THEN
          preservedToken := NoToken;
        END;
      END;
      IF action = -1 THEN
        DebugPrint("syntax error");
        self.lex.error("CalcParse: syntax error");RETURN NIL;
      ELSIF action <= 24 THEN
        curState := action;
        DebugState("shifting to state");
        Push(stack, StackElem{state := curState, value := symbol});
      ELSIF action = 25 THEN
        DebugPrint("parsing stopped with singleton start symbol on stack");
        <* ASSERT stack.ptr = 1 *>
        IF exhaustInput AND preservedToken = NoToken THEN
          symbol := NextToken(self);
          DebugPrint("getting token to check that it's an EOF");
        END;
        IF symbol.code # 0 THEN
          IF exhaustInput THEN
            DebugPrint("Error: last token was not EOF");
            self.lex.unget();
            self.lex.error("CalcParse: syntax error (parsing stopped before EOF)");
            RETURN NIL;
          END;
          IF preservedToken # NoToken THEN
            self.lex.unget();
            DebugPrint("ungetting last token");
          END;
        END;
        symbol := stack.a[1].value;
        DebugSymbol("returning symbol");
        RETURN symbol.value;
      ELSE
        DebugRule("reducing by rule");
        WITH p=stack.ptr, a=stack.a, v=symbol.value, l=Rules[action].length DO
          CASE action OF
          | 26 => VAR w: list := NIL;
            BEGIN self.empty_list(w); v:=w; END;
          | 27 => VAR w: list := NIL;
            p1:list:=a[p-2].value.value;p2:stat:=a[p-1].value.value;
            BEGIN self.cons_list(w, p1, p2); v:=w; END;
          | 28 => VAR w: stat := NIL;
            p1:expr:=a[p].value.value;
            BEGIN self.eval_stat(w, p1); v:=w; END;
          | 29 => VAR w: stat := NIL;
            p1:LETTER:=a[p-2].value.value;p2:expr:=a[p].value.value;
            BEGIN self.assign_stat(w, p1, p2); v:=w; END;
          | 30 => VAR w: expr := NIL;
            p1:expr:=a[p-1].value.value;
            BEGIN self.paren_expr(w, p1); v:=w; END;
          | 31 => VAR w: expr := NIL;
            p1:expr:=a[p-2].value.value;p2:expr:=a[p].value.value;
            BEGIN self.add_expr(w, p1, p2); v:=w; END;
          | 32 => VAR w: expr := NIL;
            p1:expr:=a[p-2].value.value;p2:expr:=a[p].value.value;
            BEGIN self.sub_expr(w, p1, p2); v:=w; END;
          | 33 => VAR w: expr := NIL;
            p1:expr:=a[p-2].value.value;p2:expr:=a[p].value.value;
            BEGIN self.mul_expr(w, p1, p2); v:=w; END;
          | 34 => VAR w: expr := NIL;
            p1:expr:=a[p-2].value.value;p2:expr:=a[p].value.value;
            BEGIN self.div_expr(w, p1, p2); v:=w; END;
          | 35 => VAR w: expr := NIL;
            p1:expr:=a[p].value.value;
            BEGIN self.uminus_expr(w, p1); v:=w; END;
          | 36 => VAR w: expr := NIL;
            p1:LETTER:=a[p].value.value;
            BEGIN self.ident_expr(w, p1); v:=w; END;
          | 37 => VAR w: expr := NIL;
            p1:number:=a[p].value.value;
            BEGIN self.num_expr(w, p1); v:=w; END;
          | 38 => VAR w: number := NIL;
            p1:DIGIT:=a[p].value.value;
            BEGIN self.digit_number(w, p1); v:=w; END;
          | 39 => VAR w: number := NIL;
            p1:number:=a[p-1].value.value;p2:DIGIT:=a[p].value.value;
            BEGIN self.cons_number(w, p1, p2); v:=w; END;
          ELSE
            <* ASSERT FALSE *>
          END;
          FOR i := p - l + 1 TO p DO a[i].value.value.discard(); END;
          DEC(p, l);
          curState := a[p].state;
        END;
        DebugState("popping to state");
        symbol.code := Rules[action].returnCode;
        skipTokenGets := 2;
      END;
    END;
  END Parse;

PROCEDURE Purge(self: T): INTEGER =
  BEGIN
    RETURN 0
      + CalcTok.Purge(self.allocate_expr)
      + CalcTok.Purge(self.allocate_list)
      + CalcTok.Purge(self.allocate_number)
      + CalcTok.Purge(self.allocate_stat);
  END Purge;
default methods
PROCEDURE empty_list(self: T;
 VAR result: list) = BEGIN
 IF result=NIL THEN
   result:=NewPT(self.allocate_list,TYPECODE(list));
 END;END empty_list;

PROCEDURE cons_list(self: T;
 VAR result: list;<*UNUSED*>p1: list;<*UNUSED*>p2: stat) = BEGIN
 IF result=NIL THEN
   result:=NewPT(self.allocate_list,TYPECODE(list));
 END;END cons_list;

PROCEDURE eval_stat(self: T;
 VAR result: stat;<*UNUSED*>p1: expr) = BEGIN
 IF result=NIL THEN
   result:=NewPT(self.allocate_stat,TYPECODE(stat));
 END;END eval_stat;

PROCEDURE assign_stat(self: T;
 VAR result: stat;<*UNUSED*>p1: LETTER;<*UNUSED*>p2: expr) = BEGIN
 IF result=NIL THEN
   result:=NewPT(self.allocate_stat,TYPECODE(stat));
 END;END assign_stat;

PROCEDURE paren_expr(self: T;
 VAR result: expr;<*UNUSED*>p1: expr) = BEGIN
 IF result=NIL THEN
   result:=NewPT(self.allocate_expr,TYPECODE(expr));
 END;END paren_expr;

PROCEDURE add_expr(self: T;
 VAR result: expr;<*UNUSED*>p1: expr;<*UNUSED*>p2: expr) = BEGIN
 IF result=NIL THEN
   result:=NewPT(self.allocate_expr,TYPECODE(expr));
 END;END add_expr;

PROCEDURE sub_expr(self: T;
 VAR result: expr;<*UNUSED*>p1: expr;<*UNUSED*>p2: expr) = BEGIN
 IF result=NIL THEN
   result:=NewPT(self.allocate_expr,TYPECODE(expr));
 END;END sub_expr;

PROCEDURE mul_expr(self: T;
 VAR result: expr;<*UNUSED*>p1: expr;<*UNUSED*>p2: expr) = BEGIN
 IF result=NIL THEN
   result:=NewPT(self.allocate_expr,TYPECODE(expr));
 END;END mul_expr;

PROCEDURE div_expr(self: T;
 VAR result: expr;<*UNUSED*>p1: expr;<*UNUSED*>p2: expr) = BEGIN
 IF result=NIL THEN
   result:=NewPT(self.allocate_expr,TYPECODE(expr));
 END;END div_expr;

PROCEDURE uminus_expr(self: T;
 VAR result: expr;<*UNUSED*>p1: expr) = BEGIN
 IF result=NIL THEN
   result:=NewPT(self.allocate_expr,TYPECODE(expr));
 END;END uminus_expr;

PROCEDURE ident_expr(self: T;
 VAR result: expr;<*UNUSED*>p1: LETTER) = BEGIN
 IF result=NIL THEN
   result:=NewPT(self.allocate_expr,TYPECODE(expr));
 END;END ident_expr;

PROCEDURE num_expr(self: T;
 VAR result: expr;<*UNUSED*>p1: number) = BEGIN
 IF result=NIL THEN
   result:=NewPT(self.allocate_expr,TYPECODE(expr));
 END;END num_expr;

PROCEDURE digit_number(self: T;
 VAR result: number;<*UNUSED*>p1: DIGIT) = BEGIN
 IF result=NIL THEN
   result:=NewPT(self.allocate_number,TYPECODE(number));
 END;END digit_number;

PROCEDURE cons_number(self: T;
 VAR result: number;<*UNUSED*>p1: number;<*UNUSED*>p2: DIGIT) = BEGIN
 IF result=NIL THEN
   result:=NewPT(self.allocate_number,TYPECODE(number));
 END;END cons_number;

BEGIN
END CalcParse.