ktok/derived/tokformBundle.m3


MODULE tokformBundle;
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..4] OF TEXT {
  "tokform.type",
  "tokform.m3",
  "tokform.case",
  "tokform.i3",
  NIL
};

VAR Elements := ARRAY [0..4] OF TEXT {
  E0,
  NIL (* E1 .. E1_0 *),
  E2,
  NIL (* E3 .. E3_0 *),
  NIL
};

PROCEDURE GetElt (n: INTEGER): TEXT =
  <*FATAL Thread.Alerted, Wr.Failure *>
  VAR wr := TextWr.New ();
  BEGIN
    CASE n OF
    | 1 =>
        Wr.PutText (wr, E1);
        Wr.PutText (wr, E1_0);
    | 3 =>
        Wr.PutText (wr, E3);
        Wr.PutText (wr, E3_0);
    ELSE (*skip*)
    END;
    RETURN TextWr.ToText (wr);
  END GetElt;

CONST E0 =
   "  %type = Token BRANDED \"%tok.%type\" OBJECT END;\n";

CONST E1 =
   "MODULE %tok;\n%gen\nIMPORT Rd, Thread;\nIMPORT Wr;\nIMPORT Fmt;\nIMPORT"
 & " RTAllocator;\nFROM Stdio IMPORT stdout;\n<* FATAL Wr.Failure, Thread.A"
 & "lerted *>\n\nREVEAL\n  ParseType = ParseTypePublic BRANDED \"%tok.Parse"
 & "Type\" OBJECT\n    x: REFANY := NIL;\n    (* if allocated, a is an allo"
 & "cator.\n       if freed into an allocator, a is \"tail\".\n       else,"
 & " a is NIL *)\n  OVERRIDES\n    discard := Discard;\n    detach := Detac"
 & "h;\n  END;\n  Allocator = BRANDED \"%tok.PrivAlloc\" OBJECT\n    m3type"
 & ": INTEGER;\n    free: ParseType := NIL;\n    numAlloc: INTEGER := 0;\n "
 & "   valid: BOOLEAN := TRUE;\n  END;\n\nPROCEDURE NewPT(VAR a: Allocator;"
 & " m3type: INTEGER): ParseType =\n  VAR\n    result: ParseType;\n  BEGIN\n"
 & "    IF a = NIL THEN\n      a := NEW(Allocator, m3type := m3type);\n    "
 & "END;\n    <* ASSERT a.m3type = m3type *>\n    IF a.free = NIL THEN\n   "
 & "   result := RTAllocator.NewTraced(m3type);\n    ELSE\n      result := "
 & "a.free;\n      a.free := NARROW(a.free.x, ParseType); (* free := free.t"
 & "ail *)\n    END;\n    INC(a.numAlloc);\n    result.x := a;\n    RETURN "
 & "result;\n  END NewPT;\n\nPROCEDURE Discard(self: ParseType) =\n  VAR\n "
 & "   a: Allocator;\n  BEGIN\n    IF self.x # NIL THEN\n      a := self.x;"
 & "  (* this fails if self not allocated using New *)\n      IF a.valid TH"
 & "EN\n        self.x := a.free; (* self.tail = a.free *)\n        a.free "
 & ":= self;\n        DEC(a.numAlloc);\n      END;\n    END;\n  END Discard"
 & ";\n\nPROCEDURE Detach(self: ParseType): ParseType = BEGIN\n  self.x := "
 & "NIL; RETURN self; END Detach;\n\nPROCEDURE Purge(VAR a: Allocator): INT"
 & "EGER =\n  VAR\n    result: INTEGER;\n  BEGIN\n    IF a = NIL THEN RETUR"
 & "N 0;END;\n    a.valid := FALSE;\n    result := a.numAlloc;\n    a := NI"
 & "L;\n    RETURN result;\n  END Purge;\n\nVAR\n  ConstTokens: ARRAY Const"
 & "TokenCode OF ConstToken;\nPROCEDURE NewConstToken(val: ConstTokenCode):"
 & " ConstToken =\n  BEGIN\n    <* ASSERT val IN LegalConstTokenCodes *>\n "
 & "   RETURN ConstTokens[val];\n  END NewConstToken; \n\nPROCEDURE Test(le"
 & "x: Lexer) =\n  VAR\n    typeName: TEXT;\n  BEGIN\n    TRY\n      LOOP\n"
 & "        TYPECASE lex.get() OF\n   ";

CONST E1_0 =
   "     | ConstToken(t) => typeName := \"<CONST \" & Fmt.Int(t.val) & \">\""
 & ";\n        | NULL => typeName := \"<NULL>\";\n%case\\\n        ELSE\n  "
 & "        typeName := \"<UNKNOWN>\";\n        END;\n        TYPECASE lex "
 & "OF RdLexer(l) => \n          Wr.PutText(stdout, typeName & \": \\\"\" &"
 & " l.getText() & \"\\\"\\n\");\n        ELSE\n          Wr.PutText(stdout"
 & ", typeName & \"\\n\");\n        END;\n      END;\n    EXCEPT\n      Rd."
 & "EndOfFile =>\n    END;\n  END Test;\n\nBEGIN\n  FOR i := FIRST(ConstTok"
 & "ens) TO LAST(ConstTokens) DO\n    IF i IN LegalConstTokenCodes THEN\n  "
 & "    ConstTokens[i] := NEW(ConstToken, val := i);\n    END;      \n  END"
 & ";\nEND %tok.\n";

CONST E2 =
   "        | %type => typeName := \"%type\";\n";

CONST E3 =
   "INTERFACE %tok;\n%gen\n(* original token definition *)\nIMPORT Rd;\nTYP"
 & "E\n  ParseType <: ParseTypePublic;\n  Token = ParseType BRANDED \"%tok."
 & "Token\" OBJECT END;\n\n  Lexer = OBJECT METHODS\n    get(): Token RAISE"
 & "S {Rd.EndOfFile};\n    (* get next token, or raise Rd.EndOfFile if toke"
 & "n cannot be formed\n       from remaining input *)\n\n    unget();\n   "
 & " (* will be called at most once after get(), and only when lookahead is"
 & "\n       required after last token when parsing without exhausting inpu"
 & "t *)\n\n    error(message: TEXT);\n    (* might print file name, line n"
 & "umber, and message, and exit *)\n  END;\n\n  RdLexer = Lexer OBJECT MET"
 & "HODS\n    setRd(rd: Rd.T): RdLexer;\n    (* Prepare to read tokens star"
 & "ting at cur(rd).\n       After every token, rd is repositionned after t"
 & "hat token. *)\n\n    getRd(): Rd.T;\n    (* get reader  *)\n    \n    f"
 & "romText(t: TEXT): RdLexer;\n    (* Calls setRd with a textReader. *)\n\n"
 & "    rewind();\n    (* equivalent to Rd.Seek(rd, 0) followed by setRd *)"
 & " \n\n    getText(): TEXT;\n    (* get TEXT of last token *)\n\n    purg"
 & "e(): INTEGER;\n    (* Allow any internally allocated ParseTypes to be g"
 & "arbage collected,\n       even if the lexer itself remains in scope. Re"
 & "turn number of ParseType\n       objects allocated but not discarded (n"
 & "ot the number of purged objects).\n       Can be called at any time by "
 & "the thread calling get. *)\n  END;\n\n  (* token types *)\n  ConstToken"
 & "Code = [1..%lastConst]; (* < 256 means char code *)\n  ConstToken = Tok"
 & "en BRANDED \"%tok.ConstToken\" OBJECT\n    val: ConstTokenCode;\n  END;"
 & " (* neither extend this object nor reassign val *)\n%type\\\n\n  (* Par"
 & "seType allocation *)\n  Allocator <: ROOT;\n  ParseTypePublic = OBJECT "
 & "METHODS\n    discard();\n    detach(): ParseType;\n  END;\n\nCONST\n  L"
 & "egalConstTokenCodes = SET OF ConstTokenCode{\n%constSet};\n%constName\\"
 & "\n\nPROCEDURE NewPT(VAR a: Allocator; m3type: INTEGER): ParseType;\n(* "
 & "IF a = NIL, then let a = new allocator for m3type.\n   regardless, retu"
 & "rn a new ParseType specifically of type m3type *)\n\nPROCEDURE Purge(VA"
 & "R a: Allocator";

CONST E3_0 =
   "): INTEGER;\n(* set a=NIL. return number of objects allocated using\n  "
 & " New(a, ...) which were not discarded using discard(). *)\n\nPROCEDURE "
 & "NewConstToken(val: ConstTokenCode): ConstToken;\n(* return a constToken"
 & " with val=val (well it might not be so new) *)\n(* discard() will fail "
 & "for a constToken *)\n\nPROCEDURE Test(lex: Lexer);\n(* get tokens and p"
 & "rint their names to stdout until Rd.EndOfFile *)\n\nEND %tok.\n";

BEGIN
END tokformBundle.