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.m3",
"tokform.case",
"tokform.i3",
"tokform.type",
NIL
};
VAR Elements := ARRAY [0..4] OF TEXT {
NIL (* E0 .. E0_0 *),
E1,
NIL (* E2 .. E2_0 *),
E3,
NIL
};
PROCEDURE GetElt (n: INTEGER): TEXT =
<*FATAL Thread.Alerted, Wr.Failure *>
VAR wr := TextWr.New ();
BEGIN
CASE n OF
| 0 =>
Wr.PutText (wr, E0);
Wr.PutText (wr, E0_0);
| 2 =>
Wr.PutText (wr, E2);
Wr.PutText (wr, E2_0);
ELSE (*skip*)
END;
RETURN TextWr.ToText (wr);
END GetElt;
CONST E0 =
"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 E0_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 E1 =
" | %type => typeName := \"%type\";\n";
CONST E2 =
"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 E2_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";
CONST E3 =
" %type = Token BRANDED \"%tok.%type\" OBJECT END;\n";
BEGIN
END tokformBundle.