kyacc/derived/yaccformBundle.m3


MODULE yaccformBundle;
Generated by m3bundle; see its manpage.

IMPORT Bundle, BundleRep, Text;
IMPORT Thread, Wr, TextWr;

TYPE T = Bundle.T OBJECT OVERRIDES
           get      := LookUp;
           getNames := GetNames;
         END;

TYPE Texts = REF ARRAY OF TEXT;

VAR
  bundle: T     := NIL;
  names : Texts := NIL;

PROCEDURE Get(): Bundle.T =
  BEGIN
    IF (bundle = NIL) THEN bundle := NEW (T) END;
    RETURN bundle;
  END Get;

PROCEDURE GetNames (<*UNUSED*> self: T): Texts =
  BEGIN
    IF names = NIL THEN
      names := NEW (Texts, NUMBER (Names));
      names^ := Names;
    END;
    RETURN names;
  END GetNames;

PROCEDURE LookUp (<*UNUSED*> self: T;  element: TEXT): TEXT =
  BEGIN
    FOR i := 0 TO LAST (Names)-1 DO
      IF Text.Equal (Names[i], element) THEN
        IF Elements[i] = NIL THEN Elements[i] := GetElt (i) END;
        RETURN Elements[i];
      END;
    END;
    RETURN NIL;
  END LookUp;

CONST Names = ARRAY [0..8] OF TEXT {
  "yaccform.i3",
  "yaccform.type.m3",
  "yaccform.proc.m3",
  "yaccform.typecase.m3",
  "yaccform.rule.m3",
  "yaccform.m3",
  "yaccform.orig.m3",
  "yaccform.reduce.m3",
  NIL
};

VAR Elements := ARRAY [0..8] OF TEXT {
  E0,
  E1,
  E2,
  E3,
  E4,
  NIL (* E5 .. E5_2 *),
  E6,
  E7,
  NIL
};

PROCEDURE GetElt (n: INTEGER): TEXT =
  <*FATAL Thread.Alerted, Wr.Failure *>
  VAR wr := TextWr.New ();
  BEGIN
    CASE n OF
    | 5 =>
        Wr.PutText (wr, E5);
        Wr.PutText (wr, E5_0);
        Wr.PutText (wr, E5_1);
        Wr.PutText (wr, E5_2);
    ELSE (*skip*)
    END;
    RETURN TextWr.ToText (wr);
  END GetElt;

CONST E0 =
   "INTERFACE %yacc;\n%gen\n(* original parser definition *)\nIMPORT %tok;\n"
 & "TYPE\n  (* additional parse types *)\n  StartType = %tok.ParseType BRAN"
 & "DED \"%yacc.StartType\" OBJECT END;\n  OtherType = %tok.ParseType;\n%ty"
 & "pe\\\n\n  (* import tokens *)\n  ConstToken = %tok.ConstToken;\n%gettok"
 & "\\\n\n  (* the parser *)\n  T <: Public;\n  Public = OBJECT\n  METHODS\n"
 & "    setLex(lex: %tok.Lexer): T;\n    parse(exhaustInput: BOOLEAN := TRU"
 & "E): StartType;\n\n    (* rules *)\n%prot\\\n\n    purge(): INTEGER;\n  "
 & "  (* Allow any internally allocated ParseTypes to be garbage collected,"
 & "\n       even if the parser itself remains in scope. Return number of P"
 & "arseType\n       objects allocated but not discarded (not the number of"
 & " purged objects).\n       Can be called at any time by the thread calli"
 & "ng get. *)\n  END;\n\n  (* And now, for a hack to allow compatible meth"
 & "ods *)\n  (* ... without importing the original parser *)\n  Original_P"
 & "arser = T;\n%orig\\\n  (* ... and without importing the original token "
 & "*)\n%tokOrig\\\n\nEND %yacc.\n";

CONST E1 =
   "  %name = %sup BRANDED \"%yacc.%name\" OBJECT END;\n";

CONST E2 =
   "PROCEDURE %name(self: T;\n VAR result: %return%uparams) = BEGIN\n IF re"
 & "sult=NIL THEN\n   result:=NewPT(self.allocate_%return,TYPECODE(%return)"
 & ");\n END;END %name;\n\n";

CONST E3 =
   "          | %name => symCode := %code;\n";

CONST E4 =
   "    R{%length, %codeReturn, %debug}\\,\n";

CONST E5 =
   "MODULE %yacc;\n%gen\nIMPORT %tok;\nIMPORT IntIntTbl, IntTextTbl;\nIMPOR"
 & "T RTType;\nIMPORT Env, Thread, Wr, Fmt, Rd;\nFROM Stdio IMPORT stdout;\n"
 & "FROM %tok IMPORT NewPT;\n<* FATAL Wr.Failure, Thread.Alerted *>\n\nTYPE"
 & "\n  TypedSymbol = RECORD\n    code: INTEGER;\n    value: %tok.ParseType"
 & ";\n  END;\nCONST\n  EOFSymbol = TypedSymbol{code := 0, value := NIL};\n"
 & "  NoToken = TypedSymbol{code := -1, value := NIL};\n  NotASymbol = Type"
 & "dSymbol{code := -1000, value := NIL};\n\nTYPE\n  StackElem = RECORD\n  "
 & "  state: INTEGER;\n    value: TypedSymbol;\n  END;\n  StackElemArray = "
 & "REF ARRAY OF StackElem;\n\n  Stack = RECORD\n    a: StackElemArray;\n  "
 & "  ptr: INTEGER;\n  END;\n\nREVEAL\n  T = Public BRANDED \"%yacc\" OBJEC"
 & "T\n    lex: %tok.Lexer;\n    tokenLookup: IntIntTbl.T := NIL; (* M3 typ"
 & "e code -> SymCode *)\n    symbols: IntTextTbl.T;           (* SymCode -"
 & "> name *)\n%alloc\\\n  OVERRIDES\n    setLex := SetLex;\n    parse := P"
 & "arse;\n    purge := Purge;\n%ovr\\\n  END;\n\nTYPE\n  SymCode = BITS %s"
 & "ymCodeBits FOR [0..%symCodeLast];\n  (* symbol code:  0 .. %symCodePenu"
 & "lt\n     set default:  %symCodeLast *)\n\n  Action = BITS %actionBits F"
 & "OR [0..%actionLast];\n  (* error:        -1   (not stored in table)\n  "
 & "   shift:        1 .. %lastShift0\n     accept:       %lastShift1\n    "
 & " reduce:       %lastShift2 .. %lastReduce0\n     shift&accept: %lastRed"
 & "uce1\n     shift&reduce: %lastReduce2 .. %actionLast  *)\n\n  StateRef "
 & "= BITS %stateBits FOR [0..%stateLast];\n  (* no more:      0\n     next"
 & " state:   1..%stateLast *)\n\n  S = RECORD\n    key: SymCode;\n    acti"
 & "on: Action;\n    next: StateRef;\n  END;\n\n  R = RECORD\n    length: I"
 & "NTEGER;\n    returnCode: INTEGER;\n    name: TEXT;\n  END;\n\n  Y = REC"
 & "ORD\n    code: INTEGER;\n    name: TEXT;\n  END;\n\nCONST\n  States = A"
 & "RRAY [1..%stateLast] OF S {\n%States};\n\n  Rules = ARRAY [%lastShift2."
 & ".%lastReduce0] OF R {\n%Rules};\n\n  Symbols = ARRAY [1..%numSym] OF Y "
 & "{\n%Symbols};\n\nVAR\n  Debug := Env.Get(\"%yaccDEBUG\") # NIL;\n\nPROC"
 & "EDURE SetLex(self: T; lex: %tok.Lexer): T =\n  BEGIN self.lex := lex; R"
 & "ETURN self; END SetLex;\n\nPROCEDURE Init";

CONST E5_0 =
   "(self: T) =\n  BEGIN (* called on first parse *)\n    self.tokenLookup "
 & ":= NEW(IntIntTbl.Default).init(%numSym);\n    IF Debug THEN\n      self"
 & ".symbols := NEW(IntTextTbl.Default).init(%numSym);\n      FOR i := 1 TO"
 & " %numSym DO\n        EVAL self.symbols.put(Symbols[i].code, Symbols[i]."
 & "name);\n      END;\n    END;\n  END Init;\n\nPROCEDURE NextToken(self: "
 & "T): TypedSymbol =\n  VAR\n    symCode, m3code: INTEGER;\n    token: %to"
 & "k.Token;\n    found := FALSE;\n  BEGIN\n    TRY\n      token := self.le"
 & "x.get();\n    EXCEPT\n      Rd.EndOfFile => RETURN EOFSymbol;\n    END;"
 & "\n    m3code := TYPECODE(token);\n    IF NOT self.tokenLookup.get(m3cod"
 & "e, symCode) THEN\n      REPEAT\n        m3code := RTType.Supertype(m3co"
 & "de);\n        IF m3code = RTType.NoSuchType THEN\n          TYPECASE to"
 & "ken OF\n          | ConstToken => symCode := -1;\n%case\\\n          EL"
 & "SE\n            <* ASSERT FALSE *>\n          END;\n          found := "
 & "TRUE;\n        ELSE\n          found := self.tokenLookup.get(m3code, sy"
 & "mCode);\n        END;\n      UNTIL found;\n      EVAL self.tokenLookup."
 & "put(TYPECODE(token), symCode);\n    END;\n    IF symCode = -1 THEN\n   "
 & "   symCode := NARROW(token, ConstToken).val;\n    END;\n    RETURN Type"
 & "dSymbol{code := symCode, value := token};\n  END NextToken;\n\nPROCEDUR"
 & "E AllocStack(): Stack =\n  VAR\n    a :=NEW(StackElemArray, 16);\n  BEG"
 & "IN\n    a[0] := StackElem{state := 1, value := EOFSymbol};\n    RETURN "
 & "Stack{a := a, ptr := 0};\n  END AllocStack;\n\nPROCEDURE Push(VAR stack"
 & ": Stack; elem: StackElem) =\n  VAR\n    new: StackElemArray;\n  BEGIN\n"
 & "    INC(stack.ptr);\n    IF stack.ptr > LAST(stack.a^) THEN\n      new "
 & ":= NEW(StackElemArray, NUMBER(stack.a^) * 2);\n      SUBARRAY(new^, 0, "
 & "NUMBER(stack.a^)) := stack.a^;\n      stack.a := new;\n    END;\n    st"
 & "ack.a[stack.ptr] := elem;\n  END Push;\n\nPROCEDURE ActionLookup(curSta"
 & "te: INTEGER; symbol: TypedSymbol): INTEGER =\n  VAR\n    cur := curStat"
 & "e;\n    state: S;\n    default := -1;\n  BEGIN\n    REPEAT\n      state"
 & " := States[cur];\n      IF state.key = %symCodeLast THEN\n        defau"
 & "lt := state.action";

CONST E5_1 =
   ";\n      ELSIF state.key = symbol.code THEN\n        RETURN state.actio"
 & "n;\n      END;\n      cur := state.next;\n    UNTIL cur = 0;\n    RETUR"
 & "N default;\n  END ActionLookup;\n\nPROCEDURE Parse(self: T; exhaustInpu"
 & "t: BOOLEAN := TRUE): StartType =\n  VAR\n    curState: INTEGER := 1;\n "
 & "   stack := AllocStack();\n    action: INTEGER;\n    symbol, preservedT"
 & "oken: TypedSymbol;\n    skipTokenGets: INTEGER := 0;\n\n  PROCEDURE Deb"
 & "ugPrint(message: TEXT) = BEGIN\n    IF Debug THEN Wr.PutText(stdout,\"%"
 & "yaccDEBUG: \"&message&\"\\n\");\n     Wr.Flush(stdout);END;END DebugPri"
 & "nt;\n  PROCEDURE DebugSymbol(message: TEXT) = VAR name: TEXT; BEGIN\n  "
 & " IF Debug THEN EVAL self.symbols.get(symbol.code, name);\n    DebugPrin"
 & "t(message & \" \" & name & \"(\" &\n      Fmt.Int(symbol.code) & \")\")"
 & "; END; END DebugSymbol;\n  PROCEDURE DebugState(message: TEXT) = BEGIN "
 & "IF Debug THEN\n    DebugPrint(message & \" \" & Fmt.Int(curState));END;"
 & "END DebugState;\n  PROCEDURE DebugRule(message: TEXT) = BEGIN IF Debug "
 & "THEN\n    DebugPrint(message&\" \"&Rules[action].name);END;END DebugRul"
 & "e;\n\n  BEGIN\n    IF self.tokenLookup = NIL THEN Init(self); END;\n   "
 & " stack.a[0] := StackElem{state := curState, value := NotASymbol};\n    "
 & "DebugState(\"starting in state\");\n    LOOP\n      IF skipTokenGets = "
 & "2 THEN\n        skipTokenGets := 1;\n        DebugSymbol(\"scanning red"
 & "uced symbol\");\n      ELSIF skipTokenGets = 1 AND preservedToken # NoT"
 & "oken THEN\n        skipTokenGets := 0;\n        symbol := preservedToke"
 & "n;\n        DebugSymbol(\"re-scanning input token\");\n      ELSE\n    "
 & "    skipTokenGets := 0;\n        symbol := NextToken(self);\n        pr"
 & "eservedToken := symbol;\n        DebugSymbol(\"input token\");\n      E"
 & "ND;\n      action := ActionLookup(curState, symbol);\n      IF action >"
 & "= %lastReduce1 THEN\n        DebugPrint(\"shifting anonymously\");\n   "
 & "     Push(stack, StackElem{state := 0, value := symbol});\n        DEC("
 & "action, %DECaction);\n        IF skipTokenGets = 0 THEN\n          pres"
 & "ervedToken := NoToken;\n        END;\n      END;\n      IF action = -1 "
 & "THEN\n        DebugPrin";

CONST E5_2 =
   "t(\"syntax error\");\n        self.lex.error(\"%yacc: syntax error\");R"
 & "ETURN NIL;\n      ELSIF action <= %lastShift0 THEN\n        curState :="
 & " action;\n        DebugState(\"shifting to state\");\n        Push(stac"
 & "k, StackElem{state := curState, value := symbol});\n      ELSIF action "
 & "= %lastShift1 THEN\n        DebugPrint(\"parsing stopped with singleton"
 & " start symbol on stack\");\n        <* ASSERT stack.ptr = 1 *>\n       "
 & " IF exhaustInput AND preservedToken = NoToken THEN\n          symbol :="
 & " NextToken(self);\n          DebugPrint(\"getting token to check that i"
 & "t\'s an EOF\");\n        END;\n        IF symbol.code # 0 THEN\n       "
 & "   IF exhaustInput THEN\n            DebugPrint(\"Error: last token was"
 & " not EOF\");\n            self.lex.unget();\n            self.lex.error"
 & "(\"%yacc: syntax error (parsing stopped before EOF)\");\n            RE"
 & "TURN NIL;\n          END;\n          IF preservedToken # NoToken THEN\n"
 & "            self.lex.unget();\n            DebugPrint(\"ungetting last "
 & "token\");\n          END;\n        END;\n        symbol := stack.a[1].v"
 & "alue;\n        DebugSymbol(\"returning symbol\");\n        RETURN symbo"
 & "l.value;\n      ELSE\n        DebugRule(\"reducing by rule\");\n       "
 & " WITH p=stack.ptr, a=stack.a, v=symbol.value, l=Rules[action].length DO"
 & "\n          CASE action OF\n%reduce\\\n          ELSE\n            <* A"
 & "SSERT FALSE *>\n          END;\n          FOR i := p - l + 1 TO p DO a["
 & "i].value.value.discard(); END;\n          DEC(p, l);\n          curStat"
 & "e := a[p].state;\n        END;\n        DebugState(\"popping to state\""
 & ");\n        symbol.code := Rules[action].returnCode;\n        skipToken"
 & "Gets := 2;\n      END;\n    END;\n  END Parse; \n\nPROCEDURE Purge(self"
 & ": T): INTEGER =\n  BEGIN\n    RETURN 0%purge;\n  END Purge;\n\n(* defau"
 & "lt methods *)\n%defimpl\\\nBEGIN\nEND %yacc.\n";

CONST E6 =
   "  Original_%name = %name;\n";

CONST E7 =
   "          | %number => VAR w: %return := NIL;\\\n%fromStack\n          "
 & "  BEGIN self.%name(w%cparams); v:=w; END;\n";

BEGIN
END yaccformBundle.