vishapoberon/compiler
1
0
Fork 0
mirror of https://github.com/vishapoberon/compiler.git synced 2026-04-06 14:32:24 +00:00
Code Issues Projects Releases Packages Wiki Activity Actions

voc compiler first commit

Browse source 
Former-commit-id: 760d826948
This commit is contained in:
Norayr Chilingarian 2013-09-27 22:34:17 +04:00
parent 4a7dc4b549
commit 6a1eccd316
119 changed files with 30400 additions and 0 deletions
Download patch file Download diff file Expand all files Collapse all files

303
src/tools/browser/BrowserCmd.Mod Normal file
View file

@ -0,0 +1,303 @@
MODULE BrowserCmd; (* RC 29.10.93 *) (* object model 4.12.93, command line version jt 4.4.95 *)
IMPORT
OPM, OPS, OPT, OPV,
Texts := CmdlnTexts, Console, Args;
CONST
OptionChar = "-";
(* object modes *)
Var = 1; VarPar = 2; Con = 3; Fld = 4; Typ = 5; LProc = 6; XProc = 7;
SProc = 8; CProc = 9; IProc = 10; Mod = 11; Head = 12; TProc = 13;
(* structure forms *)
Undef = 0; Byte = 1; Bool = 2; Char = 3; SInt = 4; Int = 5; LInt = 6;
Real = 7; LReal = 8; Set = 9; String = 10; NilTyp = 11; NoTyp = 12;
Pointer = 13; ProcTyp = 14; Comp = 15;
(* composite structure forms *)
Basic = 1; Array = 2; DynArr = 3; Record = 4;
(* module visibility of objects *)
internal = 0; external = 1; externalR = 2;
(* symbol file items *)
Smname = 16; Send = 18; Stype = 19; Salias = 20; Svar = 21; Srvar = 22;
Svalpar = 23; Svarpar = 24; Sfld = 25; Srfld = 26; Shdptr = 27; Shdpro = 28; Stpro = 29; Shdtpro = 30;
Sxpro = 31; Sipro = 32; Scpro = 33; Sstruct = 34; Ssys = 35; Sptr = 36; Sarr = 37; Sdarr = 38; Srec = 39; Spro = 40;
VAR
W: Texts.Writer;
option: CHAR;
PROCEDURE Ws(s: ARRAY OF CHAR); BEGIN Texts.WriteString(W, s) END Ws;
PROCEDURE Wch(ch: CHAR); BEGIN Texts.Write(W, ch) END Wch;
PROCEDURE Wi(i: LONGINT); BEGIN Texts.WriteInt(W, i, 0) END Wi;
PROCEDURE Wln; BEGIN Texts.WriteLn(W) END Wln;
PROCEDURE Indent(i: INTEGER);
BEGIN WHILE i > 0 DO Wch(" "); Wch(" "); DEC(i) END
END Indent;
PROCEDURE ^Wtype(typ: OPT.Struct);
PROCEDURE ^Wstruct(typ: OPT.Struct);
PROCEDURE Wsign(result: OPT.Struct; par: OPT.Object);
VAR paren, res, first: BOOLEAN;
BEGIN first := TRUE;
res := (result # NIL) (* hidden mthd *) & (result # OPT.notyp);
paren := res OR (par # NIL);
IF paren THEN Wch("(") END ;
WHILE par # NIL DO
IF ~first THEN Ws("; ") ELSE first := FALSE END ;
IF option = "x" THEN Wi(par^.adr); Wch(" ") END ;
IF par^.mode = VarPar THEN Ws("VAR ") END ;
Ws(par^.name); Ws(": "); Wtype(par^.typ);
par := par^.link
END ;
IF paren THEN Wch(")") END ;
IF res THEN Ws(": "); Wtype(result) END
END Wsign;
PROCEDURE Objects(obj: OPT.Object; mode: SET);
VAR i: LONGINT; m: INTEGER; s: SET; ext: OPT.ConstExt;
BEGIN
IF obj # NIL THEN
Objects(obj^.left, mode);
IF obj^.mode IN mode THEN
CASE obj^.mode OF
| Con:
Indent(2); Ws(obj^.name); Ws(" = ");
CASE obj^.typ^.form OF
| Bool:
IF obj^.conval^.intval = 1 THEN Ws("TRUE") ELSE Ws("FALSE") END
| Char:
IF (obj^.conval^.intval >= 32) & (obj^.conval^.intval <= 126) THEN
Wch(22X); Wch(CHR(obj^.conval^.intval)); Wch(22X)
ELSE
i := obj^.conval^.intval DIV 16;
IF i > 9 THEN Wch(CHR(55 + i)) ELSE Wch(CHR(48 + i)) END ;
i := obj^.conval^.intval MOD 16;
IF i > 9 THEN Wch(CHR(55 + i)) ELSE Wch(CHR(48 + i)) END ;
Wch("X")
END
| SInt, Int, LInt:
Wi(obj^.conval^.intval)
| Set:
Wch("{"); i := 0; s := obj^.conval^.setval;
WHILE i <= MAX(SET) DO
IF i IN s THEN Wi(i); EXCL(s, i);
IF s # {} THEN Ws(", ") END
END ;
INC(i)
END ;
Wch("}")
| Real:
Texts.WriteReal(W, SHORT(obj^.conval^.realval), 16)
| LReal:
Texts.WriteLongReal(W, obj^.conval^.realval, 23)
| String:
Ws(obj^.conval^.ext^)
| NilTyp:
Ws("NIL")
END ;
Wch(";"); Wln
| Typ:
IF obj^.name # "" THEN Indent(2);
IF obj^.typ^.strobj = obj THEN (* canonical name *)
Wtype(obj^.typ); Ws(" = "); Wstruct(obj^.typ)
ELSE (* alias *)
Ws(obj^.name); Ws(" = "); Wtype(obj^.typ)
END ;
Wch(";"); Wln
END
| Var:
Indent(2); Ws(obj^.name);
IF obj^.vis = externalR THEN Ws("-: ") ELSE Ws(": ") END ;
Wtype(obj^.typ); Wch(";"); Wln
| XProc, CProc, IProc:
Indent(1); Ws("PROCEDURE ");
IF obj^.mode = IProc THEN Wch("+")
ELSIF obj^.mode = CProc THEN Wch("-")
END ;
Ws(obj^.name);
Wsign(obj^.typ, obj^.link);
IF obj^.mode = CProc THEN
ext := obj^.conval^.ext; m := ORD(ext^[0]); i := 1; Ws(' "');
WHILE i <= m DO Wch(ext^[i]); INC(i) END ;
Wch('"');
END ;
Wch(";"); Wln
END
END ;
Objects(obj^.right, mode)
END
END Objects;
PROCEDURE Wmthd(obj: OPT.Object);
VAR
BEGIN
IF obj # NIL THEN
Wmthd(obj^.left);
IF (obj^.mode = TProc) & ((obj^.name # OPM.HdTProcName) OR (option = "x")) THEN
Indent(3); Ws("PROCEDURE (");
IF obj^.name # OPM.HdTProcName THEN
IF obj^.link^.mode = VarPar THEN Ws("VAR ") END ;
Ws(obj^.link^.name); Ws(": "); Wtype(obj^.link^.typ)
END ;
Ws(") "); Ws(obj^.name);
Wsign(obj^.typ, obj^.link^.link);
Wch(";");
IF option = "x" THEN Indent(1);
Ws("(* methno: "); Wi(obj^.adr DIV 10000H); Ws(" *)")
END ;
Wln;
END ;
Wmthd(obj^.right)
END
END Wmthd;
PROCEDURE Wstruct(typ: OPT.Struct);
VAR fld: OPT.Object;
PROCEDURE SysFlag;
BEGIN
IF typ^.sysflag # 0 THEN
Wch("["); Wi(typ^.sysflag); Ws("] ")
END
END SysFlag;
BEGIN
CASE typ^.form OF
| Undef:
Ws("Undef")
| Pointer:
Ws("POINTER "); SysFlag; Ws("TO "); Wtype(typ^.BaseTyp)
| ProcTyp:
Ws("PROCEDURE "); SysFlag; Wsign(typ^.BaseTyp, typ^.link)
| Comp:
CASE typ^.comp OF
| Array:
Ws("ARRAY "); SysFlag; Wi(typ^.n); Ws(" OF "); Wtype(typ^.BaseTyp)
| DynArr:
Ws("ARRAY "); SysFlag; Ws("OF "); Wtype(typ^.BaseTyp)
| Record:
Ws("RECORD ");SysFlag;
IF typ^.BaseTyp # NIL THEN Wch("("); Wtype(typ^.BaseTyp); Wch(")") END ;
Wln; fld := typ^.link;
WHILE (fld # NIL) & (fld^.mode = Fld) DO
IF (option = "x") OR (fld^.name[0] # "@") THEN Indent(3);
IF option = "x" THEN Wi(fld^.adr); Wch(" ") END ;
Ws(fld^.name);
IF fld^.vis = externalR THEN Wch("-") END ;
Ws(": "); Wtype(fld^.typ); Wch(";");
Wln
END ;
fld := fld^.link
END ;
Wmthd(typ^.link);
Indent(2); Ws("END ");
IF option = "x" THEN Indent(1);
Ws("(* size: "); Wi(typ^.size); Ws(" align: "); Wi(typ^.align);
Ws(" nofm: "); Wi(typ^.n); Ws(" *)")
END
END
END
END Wstruct;
PROCEDURE Wtype(typ: OPT.Struct);
VAR obj: OPT.Object;
BEGIN
obj := typ^.strobj;
IF obj^.name # "" THEN
IF typ^.mno # 0 THEN Ws(OPT.GlbMod[typ^.mno].name); Wch(".")
ELSIF (typ = OPT.bytetyp) OR (typ = OPT.sysptrtyp) THEN Ws("SYSTEM.")
ELSIF obj^.vis = internal THEN Wch("#")
END ;
Ws(obj^.name)
ELSE
IF (option = "x") & (typ^.ref > OPM.MaxStruct) THEN Wch("#"); Wi(typ^.ref - OPM.MaxStruct); Wch(" ") END ;
Wstruct(typ)
END
END Wtype;
PROCEDURE WModule(name: OPS.Name; T: Texts.Text);
VAR i: INTEGER;
beg, end: LONGINT; first, done: BOOLEAN;
PROCEDURE Header(s: ARRAY OF CHAR);
BEGIN
beg := W.buf.len; Indent(1); Ws(s); Wln; end := W.buf.len
END Header;
PROCEDURE CheckHeader;
VAR len: LONGINT;
BEGIN
len := T.len;
IF end = W.buf.len THEN Texts.Append(T, W.buf); Texts.Delete(T, len+beg, len+end)
ELSE Wln
END
END CheckHeader;
BEGIN
OPT.Import("@notself", name, done);
IF done THEN
Ws("DEFINITION "); Ws(name); Wch(";"); Wln; Wln;
Header("IMPORT"); i := 1; first := TRUE;
WHILE i < OPT.nofGmod DO
IF first THEN first := FALSE; Indent(2) ELSE Ws(", ") END ;
Ws(OPT.GlbMod[i].name);
INC(i)
END ;
IF ~first THEN Wch(";"); Wln END ;
CheckHeader;
Header("CONST"); Objects(OPT.GlbMod[0].right, {Con}); CheckHeader;
Header("TYPE"); Objects(OPT.GlbMod[0].right, {Typ}); CheckHeader;
Header("VAR"); Objects(OPT.GlbMod[0].right, {Var}); CheckHeader;
Objects(OPT.GlbMod[0].right, {XProc, IProc, CProc});
Wln;
Ws("END "); Ws(name); Wch("."); Wln; Texts.Append(T, W.buf)
ELSE
Texts.WriteString(W, name); Texts.WriteString(W, " -- symbol file not found");
Texts.WriteLn(W); Texts.Append(T, W.buf)
END
END WModule;
PROCEDURE Ident(VAR name, first: ARRAY OF CHAR);
VAR i, j: INTEGER; ch: CHAR;
BEGIN i := 0;
WHILE name[i] # 0X DO INC(i) END ;
WHILE (i >= 0) & (name[i] # "/") DO DEC(i) END ;
INC(i); j := 0; ch := name[i];
WHILE (ch # ".") & (ch # 0X) DO first[j] := ch; INC(i); INC(j); ch := name[i] END ;
first[j] := 0X
END Ident;
PROCEDURE ShowDef*;
VAR T, dummyT: Texts.Text; S, vname, name: OPS.Name; R: Texts.Reader; ch: CHAR;
s: ARRAY 1024 OF CHAR; i: INTEGER;
BEGIN
option := 0X; Args.Get(1, S);
IF Args.argc > 2 THEN
IF S[0] = OptionChar THEN option := S[1]; Args.Get(2, S)
ELSE Args.Get(2, vname); option := vname[1]
END
END ;
IF Args.argc >= 2 THEN
Ident(S, name);
NEW(T); Texts.Open(T, "");
OPT.Init(name, {}); OPT.SelfName := "AvoidErr154"; WModule(name, T); OPT.Close;
Texts.OpenReader(R, T, 0); Texts.Read(R, ch); i := 0;
WHILE ~R.eot DO
IF ch = 0DX THEN s[i] := 0X; i := 0; Console.String(s); Console.Ln
ELSE s[i] := ch; INC(i)
END ;
Texts.Read(R, ch)
END ;
s[i] := 0X; Console.String(s)
END
END ShowDef;
BEGIN
OPT.typSize := OPV.TypSize; Texts.OpenWriter(W); ShowDef
END BrowserCmd.

376
src/tools/coco/CR.ATG Normal file
View file

@ -0,0 +1,376 @@
COMPILER CR (*H.Moessenboeck 17.11.93, Coco/R*)
(*---------------------- semantic declarations ----------------------------*)
IMPORT CRT, CRA, CRX, Sets, Texts := CmdlnTexts, Oberon;
CONST
ident = 0; string = 1; (*symbol kind*)
VAR
str: ARRAY 32 OF CHAR;
w: Texts.Writer;
genScanner: BOOLEAN;
PROCEDURE SemErr(nr: INTEGER);
BEGIN
CRS.Error(200+nr, CRS.pos);
END SemErr;
PROCEDURE MatchLiteral(sp: INTEGER); (*store string either as token or as literal*)
VAR sn, sn1: CRT.SymbolNode; matchedSp: INTEGER;
BEGIN
CRT.GetSym(sp, sn);
CRA.MatchDFA(sn.name, sp, matchedSp);
IF matchedSp # CRT.noSym THEN
CRT.GetSym(matchedSp, sn1); sn1.struct := CRT.classLitToken; CRT.PutSym(matchedSp, sn1);
sn.struct := CRT.litToken
ELSE sn.struct := CRT.classToken;
END;
CRT.PutSym(sp, sn)
END MatchLiteral;
PROCEDURE SetCtx(gp: INTEGER); (*set transition code to CRT.contextTrans*)
VAR gn: CRT.GraphNode;
BEGIN
WHILE gp > 0 DO
CRT.GetNode(gp, gn);
IF gn.typ IN {CRT.char, CRT.class} THEN
gn.p2 := CRT.contextTrans; CRT.PutNode(gp, gn)
ELSIF gn.typ IN {CRT.opt, CRT.iter} THEN SetCtx(gn.p1)
ELSIF gn.typ = CRT.alt THEN SetCtx(gn.p1); SetCtx(gn.p2)
END;
gp := gn.next
END
END SetCtx;
PROCEDURE SetDDT(s: ARRAY OF CHAR);
VAR name: ARRAY 64 OF CHAR; i: INTEGER; ch: CHAR;
BEGIN
i := 1;
WHILE s[i] # 0X DO
ch := s[i]; INC(i);
IF (ch >= "0") & (ch <= "9") THEN CRT.ddt[ORD(ch)-ORD("0")] := TRUE END
END
END SetDDT;
PROCEDURE FixString (VAR s: ARRAY OF CHAR; len: INTEGER);
VAR double: BOOLEAN; i: INTEGER;
BEGIN
double := FALSE;
FOR i := 0 TO len-2 DO
IF s[i] = '"' THEN double := TRUE END
END;
IF ~ double THEN s[0] := '"'; s[len-1] := '"' END
END FixString;
(*-------------------------------------------------------------------------*)
CHARACTERS
letter = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz".
digit = "0123456789".
eol = CHR(13).
tab = CHR(9).
noQuote1 = ANY - '"' - eol.
noQuote2 = ANY - "'" - eol.
IGNORE eol + tab + CHR(28)
TOKENS
ident = letter {letter | digit}.
string = '"' {noQuote1} '"' | "'" {noQuote2} "'".
number = digit {digit}.
PRAGMAS
ddtSym = "$" {digit}. (. CRS.GetName(CRS.nextPos, CRS.nextLen, str); SetDDT(str) .)
COMMENTS FROM "(*" TO "*)" NESTED
(*-------------------------------------------------------------------------*)
PRODUCTIONS
CR (. VAR undef, hasAttrs, ok, ok1: BOOLEAN; eofSy, gR: INTEGER;
gramLine, sp: INTEGER;
gn: CRT.GraphNode; sn: CRT.SymbolNode;
name, gramName: CRT.Name; .)
=
"COMPILER" (. Texts.OpenWriter(w);
CRT.Init; CRX.Init; CRA.Init;
gramLine := CRS.line;
eofSy := CRT.NewSym(CRT.t, "EOF", 0);
genScanner := TRUE;
CRT.ignoreCase := FALSE;
ok := TRUE;
Sets.Clear(CRT.ignored) .)
ident (. CRS.GetName(CRS.pos, CRS.len, gramName);
CRT.semDeclPos.beg := CRS.nextPos; CRT.importPos.beg := -1; .)
{ "IMPORT" (. CRT.importPos.beg := CRS.nextPos .)
{ANY} ";" (. CRT.importPos.len := SHORT(CRS.pos - CRT.importPos.beg);
CRT.importPos.col := 0;
CRT.semDeclPos.beg := CRS.nextPos .)
| ANY
} (. CRT.semDeclPos.len := SHORT(CRS.nextPos - CRT.semDeclPos.beg);
CRT.semDeclPos.col := 0 .)
{ Declaration }
SYNC
"PRODUCTIONS" (. IF genScanner THEN CRA.MakeDeterministic(ok) END;
CRT.nNodes := 0 .)
{ ident (. CRS.GetName(CRS.pos, CRS.len, name);
sp := CRT.FindSym(name); undef := sp = CRT.noSym;
IF undef THEN
sp := CRT.NewSym(CRT.nt, name, CRS.line);
CRT.GetSym(sp, sn);
ELSE
CRT.GetSym(sp, sn);
IF sn.typ = CRT.nt THEN
IF sn.struct > 0 THEN SemErr(7) END
ELSE SemErr(8)
END;
sn.line := CRS.line
END;
hasAttrs := sn.attrPos.beg >= 0 .)
( Attribs <sn.attrPos> (. IF ~undef & ~hasAttrs THEN SemErr(9) END;
CRT.PutSym(sp, sn) .)
| (. IF ~undef & hasAttrs THEN SemErr(10) END .)
)
[ SemText <sn.semPos>]
WEAK "="
Expression <sn.struct, gR> (. CRT.CompleteGraph(gR); CRT.PutSym(sp, sn);
IF CRT.ddt[2] THEN CRT.PrintGraph END .)
WEAK "."
} (. sp := CRT.FindSym(gramName);
IF sp = CRT.noSym THEN SemErr(11);
ELSE
CRT.GetSym(sp, sn);
IF sn.attrPos.beg >= 0 THEN SemErr(12) END;
CRT.root := CRT.NewNode(CRT.nt, sp, gramLine);
END .)
"END" ident (. CRS.GetName(CRS.pos, CRS.len, name);
IF name # gramName THEN SemErr(17) END;
IF CRS.errors = 0 THEN
Texts.WriteString(w, " checking"); Texts.Append(Oberon.Log, w.buf);
CRT.CompSymbolSets;
IF ok THEN CRT.TestCompleteness(ok) END;
IF ok THEN
CRT.TestIfAllNtReached(ok1); CRT.FindCircularProductions(ok)
END;
IF ok THEN CRT.TestIfNtToTerm(ok) END;
IF ok THEN CRT.LL1Test(ok1) END;
IF CRT.ddt[0] THEN CRA.PrintStates END;
IF CRT.ddt[7] THEN CRT.XRef END;
IF ok THEN
Texts.WriteString(w, " +parser");
Texts.Append(Oberon.Log, w.buf);
CRX.GenCompiler;
IF genScanner THEN
Texts.WriteString(w, " +scanner");
Texts.Append(Oberon.Log, w.buf);
CRA.WriteScanner
END;
IF CRT.ddt[8] THEN CRX.WriteStatistics END
END
ELSE ok := FALSE
END;
IF CRT.ddt[6] THEN CRT.PrintSymbolTable END;
IF ok THEN Texts.WriteString(w, " done") END;
Texts.WriteLn(w); Texts.Append(Oberon.Log, w.buf) .)
".".
(*------------------------------------------------------------------------------------*)
Declaration (. VAR gL1, gR1, gL2, gR2: INTEGER; nested: BOOLEAN; .)
=
"CHARACTERS" { SetDecl }
| "TOKENS" { TokenDecl <CRT.t> }
| "PRAGMAS" { TokenDecl <CRT.pr> }
| "COMMENTS"
"FROM" TokenExpr <gL1, gR1>
"TO" TokenExpr <gL2, gR2>
( "NESTED" (. nested := TRUE .)
| (. nested := FALSE .)
) (. CRA.NewComment(gL1, gL2, nested) .)
| "IGNORE"
( "CASE" (. CRT.ignoreCase := TRUE .)
| Set <CRT.ignored>
)
.
(*------------------------------------------------------------------------------------*)
SetDecl (. VAR c: INTEGER; set: CRT.Set; name: CRT.Name; .)
=
ident (. CRS.GetName(CRS.pos, CRS.len, name);
c := CRT.ClassWithName(name); IF c >= 0 THEN SemErr(7) END .)
"=" Set <set> (. c := CRT.NewClass(name, set) .)
".".
(*------------------------------------------------------------------------------------*)
Set <VAR set: CRT.Set> (. VAR set2: CRT.Set; .)
=
SimSet <set>
{ "+" SimSet <set2> (. Sets.Unite(set, set2) .)
| "-" SimSet <set2> (. Sets.Differ(set, set2) .)
}.
(*------------------------------------------------------------------------------------*)
SimSet <VAR set: CRT.Set> (. VAR c, n, i: INTEGER; name: CRT.Name; s: ARRAY 128 OF CHAR; .)
=
ident (. CRS.GetName(CRS.pos, CRS.len, name);
c := CRT.ClassWithName(name);
IF c < 0 THEN SemErr(15); Sets.Clear(set)
ELSE CRT.GetClass(c, set)
END .)
| string (. CRS.GetName(CRS.pos, CRS.len, s);
Sets.Clear(set); i := 1;
WHILE s[i] # s[0] DO
Sets.Incl(set, ORD(s[i])); INC(i)
END .)
| "CHR" "(" number (. CRS.GetName(CRS.pos, CRS.len, name);
n := 0; i := 0;
WHILE name[i] # 0X DO
n := 10 * n + (ORD(name[i]) - ORD("0"));
INC(i)
END;
Sets.Clear(set); Sets.Incl(set, n) .)
")"
| "ANY" (. Sets.Fill(set) .)
.
(*------------------------------------------------------------------------------------*)
TokenDecl <typ: INTEGER> (. VAR sp, kind, gL, gR: INTEGER; sn: CRT.SymbolNode;
pos: CRT.Position; name: CRT.Name; .)
=
Symbol <name, kind> (. IF CRT.FindSym(name) # CRT.noSym THEN SemErr(7)
ELSE
sp := CRT.NewSym(typ, name, CRS.line);
CRT.GetSym(sp, sn); sn.struct := CRT.classToken;
CRT.PutSym(sp, sn)
END .)
SYNC
( "=" TokenExpr <gL, gR> "." (. IF kind # ident THEN SemErr(13) END;
CRT.CompleteGraph(gR);
CRA.ConvertToStates(gL, sp) .)
| (. IF kind = ident THEN genScanner := FALSE
ELSE MatchLiteral(sp)
END .)
)
[ SemText <pos> (. IF typ = CRT.t THEN SemErr(14) END;
CRT.GetSym(sp, sn); sn.semPos := pos; CRT.PutSym(sp, sn) .)
].
(*------------------------------------------------------------------------------------*)
Expression <VAR gL, gR: INTEGER> (. VAR gL2, gR2: INTEGER; first: BOOLEAN; .)
=
Term <gL, gR> (. first := TRUE .)
{ WEAK "|"
Term <gL2, gR2> (. IF first THEN
CRT.MakeFirstAlt(gL, gR); first := FALSE
END;
CRT.ConcatAlt(gL, gR, gL2, gR2) .)
}.
(*------------------------------------------------------------------------------------*)
Term<VAR gL, gR: INTEGER> (. VAR gL2, gR2: INTEGER; .)
= (. gL := 0; gR := 0 .)
( Factor <gL, gR>
{ Factor <gL2, gR2> (. CRT.ConcatSeq(gL, gR, gL2, gR2) .)
}
| (. gL := CRT.NewNode(CRT.eps, 0, 0); gR := gL .)
).
(*------------------------------------------------------------------------------------*)
Factor <VAR gL, gR: INTEGER> (. VAR sp, kind, c: INTEGER; name: CRT.Name;
gn: CRT.GraphNode; sn: CRT.SymbolNode;
set: CRT.Set;
undef, weak: BOOLEAN;
pos: CRT.Position; .)
=
(. gL :=0; gR := 0; weak := FALSE .)
( [ "WEAK" (. weak := TRUE .)
]
Symbol <name, kind> (. sp := CRT.FindSym(name); undef := sp = CRT.noSym;
IF undef THEN
IF kind = ident THEN (*forward nt*)
sp := CRT.NewSym(CRT.nt, name, 0)
ELSE (*undefined string in production*)
sp := CRT.NewSym(CRT.t, name, CRS.line);
MatchLiteral(sp)
END
END;
CRT.GetSym(sp, sn);
IF ~(sn.typ IN {CRT.t,CRT.nt}) THEN SemErr(4) END;
IF weak THEN
IF sn.typ = CRT.t THEN sn.typ := CRT.wt ELSE SemErr(23) END
END;
gL := CRT.NewNode(sn.typ, sp, CRS.line); gR := gL .)
( Attribs <pos> (. CRT.GetNode(gL, gn); gn.pos := pos; CRT.PutNode(gL, gn);
CRT.GetSym(sp, sn);
IF undef THEN
sn.attrPos := pos; CRT.PutSym(sp, sn)
ELSIF sn.attrPos.beg < 0 THEN SemErr(5)
END;
IF kind # ident THEN SemErr(3) END .)
| (. CRT.GetSym(sp, sn);
IF sn.attrPos.beg >= 0 THEN SemErr(6) END .)
)
| "(" Expression <gL, gR> ")"
| "[" Expression <gL, gR> "]" (. CRT.MakeOption(gL, gR) .)
| "{" Expression <gL, gR> "}" (. CRT.MakeIteration(gL, gR) .)
| SemText <pos> (. gL := CRT.NewNode(CRT.sem, 0, 0);
gR := gL;
CRT.GetNode(gL, gn); gn.pos := pos; CRT.PutNode(gL, gn) .)
| "ANY" (. Sets.Fill(set); Sets.Excl(set, CRT.eofSy);
gL := CRT.NewNode(CRT.any, CRT.NewSet(set), 0); gR := gL .)
| "SYNC" (. gL := CRT.NewNode(CRT.sync, 0, 0); gR := gL .)
).
(*------------------------------------------------------------------------------------*)
TokenExpr <VAR gL, gR: INTEGER> (. VAR gL2, gR2: INTEGER; first: BOOLEAN; .)
=
TokenTerm <gL, gR> (. first := TRUE .)
{ WEAK "|"
TokenTerm <gL2, gR2> (. IF first THEN
CRT.MakeFirstAlt(gL, gR); first := FALSE
END;
CRT.ConcatAlt(gL, gR, gL2, gR2) .)
}.
(*------------------------------------------------------------------------------------*)
TokenTerm <VAR gL, gR: INTEGER> (. VAR gL2, gR2: INTEGER; .)
=
TokenFactor <gL, gR>
{ TokenFactor <gL2, gR2> (. CRT.ConcatSeq(gL, gR, gL2, gR2) .)
}
[ "CONTEXT"
"(" TokenExpr <gL2, gR2> (. SetCtx(gL2); CRT.ConcatSeq(gL, gR, gL2, gR2) .)
")"
].
(*------------------------------------------------------------------------------------*)
TokenFactor <VAR gL, gR: INTEGER> (. VAR kind, c: INTEGER; set: CRT.Set; name: CRT.Name; .)
=
(. gL :=0; gR := 0 .)
( Symbol <name, kind> (. IF kind = ident THEN
c := CRT.ClassWithName(name);
IF c < 0 THEN
SemErr(15);
Sets.Clear(set); c := CRT.NewClass(name, set)
END;
gL := CRT.NewNode(CRT.class, c, 0); gR := gL
ELSE (*string*)
CRT.StrToGraph(name, gL, gR)
END .)
| "(" TokenExpr <gL, gR> ")"
| "[" TokenExpr <gL, gR> "]" (. CRT.MakeOption(gL, gR) .)
| "{" TokenExpr <gL, gR> "}" (. CRT.MakeIteration(gL, gR) .)
).
(*------------------------------------------------------------------------------------*)
Symbol <VAR name: CRT.Name; VAR kind: INTEGER> =
( ident (. kind := ident .)
| string (. kind := string .)
) (. CRS.GetName(CRS.pos, CRS.len, name);
IF kind = string THEN FixString(name, CRS.len) END .) .
(*------------------------------------------------------------------------------------*)
Attribs <VAR attrPos: CRT.Position> =
"<" (. attrPos.beg := CRS.nextPos; attrPos.col := CRS.nextCol .)
{ ANY }
">" (. attrPos.len := SHORT(CRS.pos - attrPos.beg) .).
(*------------------------------------------------------------------------------------*)
SemText <VAR semPos: CRT.Position> =
"(." (. semPos.beg := CRS.nextPos; semPos.col := CRS.nextCol .)
{ ANY }
".)" (. semPos.len := SHORT(CRS.pos - semPos.beg) .).
END CR.

930
src/tools/coco/CRA.Mod Normal file
View file

@ -0,0 +1,930 @@
MODULE CRA; (* handles the DFA *)
IMPORT Oberon, Texts := CmdlnTexts, Sets, CRS, CRT;
CONST
maxStates = 300;
EOL = 0DX;
TYPE
State = POINTER TO StateNode;
Action = POINTER TO ActionNode;
Target = POINTER TO TargetNode;
StateNode = RECORD (*state of finite automaton*)
nr: INTEGER; (*state number*)
firstAction: Action; (*to first action of this state*)
endOf: INTEGER; (*nr. of recognized token if state is final*)
ctx: BOOLEAN; (*TRUE: state reached by contextTrans*)
next: State
END;
ActionNode = RECORD (*action of finite automaton*)
typ: INTEGER; (*type of action symbol: char, class*)
sym: INTEGER; (*action symbol*)
tc: INTEGER; (*transition code: normTrans, contextTrans*)
target: Target; (*states after transition with input symbol*)
next: Action;
END;
TargetNode = RECORD (*state after transition with input symbol*)
state: State; (*target state*)
next: Target;
END;
Comment = POINTER TO CommentNode;
CommentNode = RECORD (* info about a comment syntax *)
start,stop: ARRAY 2 OF CHAR;
nested: BOOLEAN;
next: Comment;
END;
Melted = POINTER TO MeltedNode;
MeltedNode = RECORD (* info about melted states *)
set: CRT.Set; (* set of old states *)
state: State; (* new state *)
next: Melted;
END;
VAR
firstState: State;
lastState: State; (* last allocated state *)
rootState: State; (* start state of DFA *)
lastSimState: INTEGER; (* last non melted state *)
stateNr: INTEGER; (*number of last allocated state*)
firstMelted: Melted; (* list of melted states *)
firstComment: Comment; (* list of comments *)
out: Texts.Writer; (* current output *)
fram: Texts.Reader; (* scanner frame input *)
PROCEDURE SemErr(nr: INTEGER);
BEGIN CRS.Error(200+nr, CRS.pos)
END SemErr;
PROCEDURE Put(ch: CHAR);
BEGIN Texts.Write(out, ch) END Put;
PROCEDURE PutS(s: ARRAY OF CHAR);
VAR i: INTEGER;
BEGIN i := 0;
WHILE (i < LEN(s)) & (s[i] # 0X) DO
IF s[i] = "$" THEN Texts.WriteLn(out) ELSE Texts.Write(out, s[i]) END;
INC(i)
END
END PutS;
PROCEDURE PutI(i: INTEGER);
BEGIN Texts.WriteInt(out, i, 0) END PutI;
PROCEDURE PutI2(i, n: INTEGER);
BEGIN Texts.WriteInt(out, i, n) END PutI2;
PROCEDURE PutC(ch: CHAR);
BEGIN
IF (ch < " ") OR (ORD(ch) = 34) THEN PutS("CHR("); PutI(ORD(ch)); Put(")")
ELSE Put(CHR(34)); Put(ch); Put(CHR(34))
END
END PutC;
PROCEDURE PutRange(s: CRT.Set);
VAR lo, hi: ARRAY 32 OF CHAR; top, i: INTEGER; s1: CRT.Set;
BEGIN
(*----- fill lo and hi *)
top := -1; i := 0;
WHILE i < 128 DO
IF Sets.In(s, i) THEN
INC(top); lo[top] := CHR(i); INC(i);
WHILE (i < 128) & Sets.In(s, i) DO INC(i) END;
hi[top] := CHR(i - 1)
ELSE INC(i)
END
END;
(*----- print ranges *)
IF (top = 1) & (lo[0] = 0X) & (hi[1] = 7FX) & (CHR(ORD(hi[0]) + 2) = lo[1]) THEN
Sets.Fill(s1); Sets.Differ(s1, s); PutS("~ ("); PutRange(s1); Put(")")
ELSE
i := 0;
WHILE i <= top DO
IF hi[i] = lo[i] THEN PutS("(ch="); PutC(lo[i])
ELSIF lo[i] = 0X THEN PutS("(ch<="); PutC(hi[i])
ELSIF hi[i] = 7FX THEN PutS("(ch>="); PutC(lo[i])
ELSE PutS("(ch>="); PutC(lo[i]); PutS(") & (ch<="); PutC(hi[i])
END;
Put(")");
IF i < top THEN PutS(" OR ") END;
INC(i)
END
END
END PutRange;
PROCEDURE PutChCond(ch: CHAR);
BEGIN
PutS("(ch ="); PutC(ch); Put(")")
END PutChCond;
PROCEDURE Length*(s: ARRAY OF CHAR): INTEGER;
VAR i: INTEGER;
BEGIN
i:=0; WHILE (i < LEN(s)) & (s[i] # 0X) DO INC(i) END;
RETURN i
END Length;
PROCEDURE AddAction(act:Action; VAR head:Action);
VAR a,lasta: Action;
BEGIN
a := head; lasta := NIL;
LOOP
IF (a = NIL) (*collecting classes at the front gives better*)
OR (act^.typ < a^.typ) THEN (*performance*)
act^.next := a;
IF lasta = NIL THEN head := act ELSE lasta^.next := act END;
EXIT;
END;
lasta := a; a := a^.next;
END;
END AddAction;
PROCEDURE DetachAction(a:Action; VAR L:Action);
BEGIN
IF L = a THEN L := a^.next ELSIF L # NIL THEN DetachAction(a, L^.next) END
END DetachAction;
PROCEDURE TheAction (state: State; ch: CHAR): Action;
VAR a: Action; set: CRT.Set;
BEGIN
a := state.firstAction;
WHILE a # NIL DO
IF a.typ = CRT.char THEN
IF ORD(ch) = a.sym THEN RETURN a END
ELSIF a.typ = CRT.class THEN
CRT.GetClass(a^.sym, set);
IF Sets.In(set, ORD(ch)) THEN RETURN a END
END;
a := a.next
END;
RETURN NIL
END TheAction;
PROCEDURE AddTargetList(VAR lista, listb: Target);
VAR p,t: Target;
PROCEDURE AddTarget(t: Target; VAR list:Target);
VAR p,lastp: Target;
BEGIN
p:=list; lastp:=NIL;
LOOP
IF (p = NIL) OR (t^.state.nr < p^.state.nr) THEN EXIT END;
IF p^.state = t^.state THEN RETURN END;
lastp := p; p := p^.next
END;
t^.next:=p;
IF lastp=NIL THEN list:=t ELSE lastp^.next:=t END
END AddTarget;
BEGIN
p := lista;
WHILE p # NIL DO
NEW(t); t^.state:=p^.state; AddTarget(t, listb);
p := p^.next
END
END AddTargetList;
PROCEDURE NewMelted(set: CRT.Set; state: State): Melted;
VAR melt: Melted;
BEGIN
NEW(melt); melt^.set := set; melt^.state := state;
melt^.next := firstMelted; firstMelted := melt;
RETURN melt
END NewMelted;
PROCEDURE NewState(): State;
VAR state: State;
BEGIN
NEW(state); INC(stateNr); state.nr := stateNr;
state.firstAction := NIL; state.endOf := CRT.noSym; state.ctx := FALSE; state.next := NIL;
IF firstState = NIL THEN firstState := state ELSE lastState.next := state END;
lastState := state;
RETURN state
END NewState;
PROCEDURE NewTransition(from, to: State; typ, sym, tc: INTEGER);
VAR a: Action; t: Target;
BEGIN
NEW(t); t^.state := to; t^.next := NIL;
NEW(a); a^.typ := typ; a^.sym := sym; a^.tc := tc; a^.target := t;
AddAction(a, from.firstAction)
END NewTransition;
PROCEDURE NewComment*(from, to: INTEGER; nested: BOOLEAN);
VAR com: Comment;
PROCEDURE MakeStr(gp: INTEGER; VAR s: ARRAY OF CHAR);
VAR i, n: INTEGER; gn: CRT.GraphNode; set: CRT.Set;
BEGIN
i := 0;
WHILE gp # 0 DO
CRT.GetNode(gp, gn);
IF gn.typ = CRT.char THEN
IF i < 2 THEN s[i] := CHR(gn.p1) END; INC(i)
ELSIF gn.typ = CRT.class THEN
CRT.GetClass(gn.p1, set);
IF Sets.Elements(set, n) # 1 THEN SemErr(26) END;
IF i < 2 THEN s[i] := CHR(n) END; INC(i)
ELSE SemErr(22)
END;
gp := gn.next
END;
IF i > 2 THEN SemErr(25) ELSIF i < 2 THEN s[i] := 0X END
END MakeStr;
BEGIN
NEW(com);
MakeStr(from, com^.start); MakeStr(to, com^.stop);
com^.nested := nested;
com^.next := firstComment; firstComment := com
END NewComment;
PROCEDURE MakeSet(p: Action; VAR set: CRT.Set);
BEGIN
IF p^.typ = CRT.class THEN CRT.GetClass(p^.sym, set)
ELSE Sets.Clear(set); Sets.Incl(set, p^.sym)
END
END MakeSet;
PROCEDURE ChangeAction(a: Action; set: CRT.Set);
VAR nr: INTEGER;
BEGIN
IF Sets.Elements(set, nr) = 1 THEN a^.typ := CRT.char; a^.sym := nr
ELSE
nr := CRT.ClassWithSet(set);
IF nr < 0 THEN nr := CRT.NewClass("#0", set) END; (*class with dummy name*)
a^.typ := CRT.class; a^.sym := nr
END
END ChangeAction;
PROCEDURE CombineShifts;
VAR state: State; n: INTEGER; a, b, c: Action; seta, setb: CRT.Set;
BEGIN
state := firstState;
WHILE state # NIL DO
a := state.firstAction;
WHILE a # NIL DO
b := a^.next;
WHILE b # NIL DO
IF (a^.target^.state = b^.target^.state) & (a^.tc = b^.tc) THEN
MakeSet(a, seta); MakeSet(b, setb); Sets.Unite(seta, setb);
ChangeAction(a, seta);
c := b; b := b^.next; DetachAction(c, a)
ELSE b := b^.next
END
END;
a := a^.next
END;
state := state.next
END
END CombineShifts;
PROCEDURE DeleteRedundantStates;
VAR
action: Action;
state, s1, s2: State;
used: CRT.Set;
newState: ARRAY maxStates OF State;
PROCEDURE FindUsedStates(state: State);
VAR action: Action;
BEGIN
IF Sets.In(used, state.nr) THEN RETURN END;
Sets.Incl(used, state.nr);
action := state.firstAction;
WHILE action # NIL DO
FindUsedStates(action^.target^.state);
action:=action^.next
END
END FindUsedStates;
PROCEDURE DelUnused;
VAR state: State;
BEGIN
state := firstState.next; lastState := firstState; stateNr := 0; (*firstState has number 0*)
WHILE state # NIL DO
IF Sets.In(used, state.nr) THEN INC(stateNr); state.nr := stateNr; lastState := state
ELSE lastState.next := state.next
END;
state := state.next
END
END DelUnused;
BEGIN
Sets.Clear(used); FindUsedStates(firstState);
(*---------- combine equal final states ------------*)
s1 := firstState.next; (*first state cannot be final*)
WHILE s1 # NIL DO
IF Sets.In(used, s1.nr) & (s1.endOf # CRT.noSym) & (s1.firstAction = NIL) & ~ s1.ctx THEN
s2 := s1.next;
WHILE s2 # NIL DO
IF Sets.In(used, s2.nr) & (s1.endOf = s2.endOf) & (s2.firstAction = NIL) & ~ s2.ctx THEN
Sets.Excl(used, s2.nr); newState[s2.nr] := s1
END;
s2 := s2.next
END
END;
s1 := s1.next
END;
state := firstState; (*> state := firstState.next*)
WHILE state # NIL DO
IF Sets.In(used, state.nr) THEN
action := state.firstAction;
WHILE action # NIL DO
IF ~ Sets.In(used, action.target.state.nr) THEN
action^.target^.state := newState[action.target.state.nr]
END;
action := action^.next
END
END;
state := state.next
END;
DelUnused
END DeleteRedundantStates;
PROCEDURE ConvertToStates*(gp0, sp: INTEGER);
(*note: gn.line is abused as a state number!*)
VAR n: INTEGER; S: ARRAY maxStates OF State; gn: CRT.GraphNode;
PROCEDURE TheState(gp: INTEGER): State;
VAR state: State; gn: CRT.GraphNode;
BEGIN
IF gp = 0 THEN state := NewState(); state.endOf := sp; RETURN state
ELSE CRT.GetNode(gp, gn); RETURN S[gn.line]
END
END TheState;
PROCEDURE Step(from: State; gp: INTEGER);
VAR gn: CRT.GraphNode;
BEGIN
IF gp = 0 THEN RETURN END;
CRT.GetNode(gp, gn);
CASE gn.typ OF
CRT.class, CRT.char: NewTransition(from, TheState(ABS(gn.next)), gn.typ, gn.p1, gn.p2)
| CRT.alt: Step(from, gn.p1); Step(from, gn.p2)
| CRT.opt, CRT.iter: Step(from, ABS(gn.next)); Step(from, gn.p1)
END
END Step;
PROCEDURE FindTrans(gp: INTEGER; state: State);
VAR gn: CRT.GraphNode; new: BOOLEAN;
BEGIN
IF gp = 0 THEN RETURN END; (*end of graph*)
CRT.GetNode(gp, gn);
IF gn.line # 0 THEN RETURN END; (*already visited*)
new := state = NIL;
IF new THEN state := NewState() END;
INC(n); S[n] := state; gn.line := n; CRT.PutNode(gp, gn);
IF CRT.DelGraph(gp) THEN state.endOf := sp END; (*state is end state*)
CASE gn.typ OF
CRT.class, CRT.char: FindTrans(ABS(gn.next), NIL);
| CRT.opt: FindTrans(ABS(gn.next), NIL); FindTrans(gn.p1, state)
| CRT.iter: FindTrans(ABS(gn.next), state); FindTrans(gn.p1, state)
| CRT.alt: FindTrans(gn.p1, state); FindTrans(gn.p2, state)
END;
IF new OR (state = firstState) & (gp = gp0) THEN (*start of a group of equally numbered nodes*)
Step(state, gp)
END
END FindTrans;
BEGIN
IF CRT.DelGraph(gp0) THEN SemErr(20) END;
CRT.GetNode(gp0, gn);
IF gn.typ = CRT.iter THEN SemErr(21) END;
n := 0; FindTrans(gp0, firstState)
END ConvertToStates;
PROCEDURE MatchDFA* (s: ARRAY OF CHAR; sp: INTEGER; VAR matchedSp: INTEGER);
VAR state, to: State; a: Action; i, len: INTEGER;
BEGIN (*s with quotes*)
state := firstState; i := 1; len := Length(s) - 1;
LOOP (*try to match s against existing DFA*)
IF i = len THEN EXIT END;
a := TheAction(state, s[i]);
IF a = NIL THEN EXIT END;
state := a.target.state; INC(i)
END;
WHILE i < len DO (*make new DFA for s[i..len-1]*)
to := NewState();
NewTransition(state, to, CRT.char, ORD(s[i]), CRT.normTrans);
state := to; INC(i)
END;
matchedSp := state.endOf;
IF state.endOf = CRT.noSym THEN state.endOf := sp END
END MatchDFA;
PROCEDURE SplitActions(a, b: Action);
VAR c: Action; seta, setb, setc: CRT.Set;
PROCEDURE CombineTransCodes(t1, t2: INTEGER; VAR result:INTEGER);
BEGIN
IF t1 = CRT.contextTrans THEN result := t1 ELSE result := t2 END
END CombineTransCodes;
BEGIN
MakeSet(a, seta); MakeSet(b, setb);
IF Sets.Equal(seta, setb) THEN
AddTargetList(b^.target, a^.target);
CombineTransCodes(a^.tc, b^.tc, a^.tc);
DetachAction(b, a)
ELSIF Sets.Includes(seta, setb) THEN
setc := seta; Sets.Differ(setc, setb);
AddTargetList(a^.target, b^.target);
CombineTransCodes(a^.tc, b^.tc, b^.tc);
ChangeAction(a, setc)
ELSIF Sets.Includes(setb, seta) THEN
setc := setb; Sets.Differ(setc, seta);
AddTargetList(b^.target, a^.target);
CombineTransCodes(a^.tc, b^.tc, a^.tc);
ChangeAction(b, setc)
ELSE
Sets.Intersect(seta, setb, setc);
Sets.Differ(seta, setc);
Sets.Differ(setb, setc);
ChangeAction(a, seta);
ChangeAction(b, setb);
NEW(c); c^.target:=NIL;
CombineTransCodes(a^.tc, b^.tc, c^.tc);
AddTargetList(a^.target, c^.target);
AddTargetList(b^.target, c^.target);
ChangeAction(c, setc);
AddAction(c, a)
END
END SplitActions;
PROCEDURE MakeUnique(state: State; VAR changed:BOOLEAN);
VAR a, b: Action;
PROCEDURE Overlap(a, b: Action): BOOLEAN;
VAR seta, setb: CRT.Set;
BEGIN
IF a^.typ = CRT.char THEN
IF b^.typ = CRT.char THEN RETURN a^.sym = b^.sym
ELSE CRT.GetClass(b^.sym, setb); RETURN Sets.In(setb, a^.sym)
END
ELSE
CRT.GetClass(a^.sym, seta);
IF b^.typ = CRT.char THEN RETURN Sets.In(seta, b^.sym)
ELSE CRT.GetClass(b^.sym, setb); RETURN ~ Sets.Different(seta, setb)
END
END
END Overlap;
BEGIN
a := state.firstAction; changed := FALSE;
WHILE a # NIL DO
b := a^.next;
WHILE b # NIL DO
IF Overlap(a, b) THEN SplitActions(a, b); changed:=TRUE END;
b := b^.next;
END;
a:=a^.next
END
END MakeUnique;
PROCEDURE MeltStates(state: State; VAR correct:BOOLEAN);
VAR
action: Action;
ctx: BOOLEAN;
endOf: INTEGER;
melt: Melted;
set: CRT.Set;
s: State;
changed: BOOLEAN;
PROCEDURE AddMeltedSet(nr: INTEGER; VAR set: CRT.Set);
VAR m: Melted;
BEGIN
m := firstMelted;
WHILE (m # NIL) & (m^.state.nr # nr) DO m := m^.next END;
IF m = NIL THEN HALT(98) END;
Sets.Unite(set, m^.set);
END AddMeltedSet;
PROCEDURE GetStateSet(t: Target; VAR set: CRT.Set; VAR endOf: INTEGER; VAR ctx:BOOLEAN);
VAR statenr: INTEGER; (*lastS: State;*)
BEGIN
Sets.Clear(set); endOf := CRT.noSym; ctx := FALSE; (*lastS := NIL;*)
WHILE t # NIL DO
statenr := t.state.nr;
IF statenr <= lastSimState THEN Sets.Incl(set, statenr)
ELSE AddMeltedSet(statenr, set)
END;
IF t^.state^.endOf # CRT.noSym THEN
IF (endOf = CRT.noSym) OR (endOf = t^.state^.endOf)
(*OR (lastS^.firstAction # NIL) & (t^.state^.firstAction = NIL)*) THEN
endOf := t^.state.endOf; (*lastS := t^.state*)
ELSE
PutS("$Tokens "); PutI(endOf); PutS(" and "); PutI(t^.state.endOf);
PutS(" cannot be distinguished.$");
correct:=FALSE
END
END;
IF t^.state.ctx THEN ctx := TRUE;
IF t.state.endOf # CRT.noSym THEN
PutS("$Ambiguous CONTEXT clause.$"); correct := FALSE
END
END;
t := t^.next
END
END GetStateSet;
PROCEDURE FillWithActions(state: State; targ: Target);
VAR action,a: Action;
BEGIN
WHILE targ # NIL DO
action := targ^.state.firstAction;
WHILE action # NIL DO
NEW(a); a^ := action^; a^.target := NIL;
AddTargetList(action^.target, a^.target);
AddAction(a, state.firstAction);
action:=action^.next
END;
targ:=targ^.next
END;
END FillWithActions;
PROCEDURE KnownMelted(set:CRT.Set; VAR melt: Melted): BOOLEAN;
BEGIN
melt := firstMelted;
WHILE melt # NIL DO
IF Sets.Equal(set, melt^.set) THEN RETURN TRUE END;
melt := melt^.next
END;
RETURN FALSE
END KnownMelted;
BEGIN
action := state.firstAction;
WHILE action # NIL DO
IF action^.target^.next # NIL THEN (*more than one target state*)
GetStateSet(action^.target, set, endOf, ctx);
IF ~ KnownMelted(set, melt) THEN
s := NewState(); s.endOf := endOf; s.ctx := ctx;
FillWithActions(s, action^.target);
REPEAT MakeUnique(s, changed) UNTIL ~ changed;
melt := NewMelted(set, s);
END;
action^.target^.next:=NIL;
action^.target^.state := melt^.state
END;
action := action^.next
END;
Texts.Append(Oberon.Log, out.buf)
END MeltStates;
PROCEDURE MakeDeterministic*(VAR correct: BOOLEAN);
VAR state: State; changed: BOOLEAN;
PROCEDURE FindCtxStates; (*find states reached by a context transition*)
VAR a: Action; state: State;
BEGIN
state := firstState;
WHILE state # NIL DO
a := state.firstAction;
WHILE a # NIL DO
IF a^.tc = CRT.contextTrans THEN a^.target^.state.ctx := TRUE END;
a := a^.next
END;
state := state.next
END;
END FindCtxStates;
BEGIN
IF lastState = NIL THEN lastSimState := 0 ELSE lastSimState := lastState.nr END;
FindCtxStates;
state := firstState;
WHILE state # NIL DO
REPEAT MakeUnique(state, changed) UNTIL ~ changed;
state := state.next
END;
correct := TRUE;
state := firstState;
WHILE state # NIL DO MeltStates(state, correct); state := state.next END;
DeleteRedundantStates;
CombineShifts
END MakeDeterministic;
PROCEDURE PrintSymbol(typ, val, width: INTEGER);
VAR name: CRT.Name; len: INTEGER;
BEGIN
IF typ = CRT.class THEN
CRT.GetClassName(val, name); PutS(name); len := Length(name)
ELSIF (val >= ORD(" ")) & (val < 127) & (val # 34) THEN
Put(CHR(34)); Put(CHR(val)); Put(CHR(34)); len:=3
ELSE
PutS("CHR("); PutI2(val, 2); Put(")"); len:=7
END;
WHILE len < width DO Put(" "); INC(len) END
END PrintSymbol;
PROCEDURE PrintStates*;
VAR action: Action; first: BOOLEAN; state: State; i: INTEGER; targ: Target; set: CRT.Set; name: CRT.Name;
BEGIN
PutS("$-------- states ---------$");
state := firstState;
WHILE state # NIL DO
action := state.firstAction; first:=TRUE;
IF state.endOf = CRT.noSym THEN PutS(" ")
ELSE PutS("E("); PutI2(state.endOf, 2); Put(")")
END;
PutI2(state.nr, 3); Put(":"); IF action = NIL THEN PutS(" $") END;
WHILE action # NIL DO
IF first THEN Put(" "); first:=FALSE ELSE PutS(" ") END;
PrintSymbol(action^.typ, action^.sym, 0); Put(" ");
targ := action^.target;
WHILE targ # NIL DO
PutI(targ^.state.nr); Put(" "); targ := targ^.next;
END;
IF action^.tc = CRT.contextTrans THEN PutS(" context$") ELSE PutS(" $") END;
action := action^.next
END;
state := state.next
END;
PutS("$-------- character classes ---------$");
i := 0;
WHILE i <= CRT.maxC DO
CRT.GetClass(i, set); CRT.GetClassName(i, name); PutS(name); PutS(": ");
Sets.Print(out, set, 80, 13); Texts.WriteLn(out);
INC(i)
END;
Texts.Append(Oberon.Log, out.buf)
END PrintStates;
PROCEDURE GenComment(com:Comment);
PROCEDURE GenBody;
BEGIN
PutS(" LOOP$");
PutS(" IF "); PutChCond(com^.stop[0]); PutS(" THEN$");
IF Length(com^.stop) = 1 THEN
PutS(" DEC(level); oldEols := chLine - startLine; NextCh;$");
PutS(" IF level = 0 THEN RETURN TRUE END;$");
ELSE
PutS(" NextCh;$");
PutS(" IF "); PutChCond(com^.stop[1]); PutS(" THEN$");
PutS(" DEC(level); oldEols := chLine - startLine; NextCh;$");
PutS(" IF level=0 THEN RETURN TRUE END$");
PutS(" END;$");
END;
IF com^.nested THEN
PutS(" ELSIF "); PutChCond(com^.start[0]); PutS(" THEN$");
IF Length(com^.start) = 1 THEN
PutS(" INC(level); NextCh;$");
ELSE
PutS(" NextCh;$");
PutS(" IF "); PutChCond(com^.start[1]); PutS(" THEN$");
PutS(" INC(level); NextCh;$");
PutS(" END;$");
END;
END;
PutS(" ELSIF ch = EOF THEN RETURN FALSE$");
PutS(" ELSE NextCh END;$");
PutS(" END;$");
END GenBody;
BEGIN
PutS(" IF "); PutChCond(com^.start[0]); PutS(" THEN$");
IF Length(com^.start) = 1 THEN
PutS(" NextCh;$");
GenBody;
PutS(" END;");
ELSE
PutS(" NextCh;$");
PutS(" IF "); PutChCond(com^.start[1]); PutS(" THEN$");
PutS(" NextCh;$");
GenBody;
PutS(" ELSE$");
PutS(" IF ch = EOL THEN DEC(chLine); lineStart := oldLineStart END;$");
PutS(" DEC(chPos, 2); Texts.OpenReader(r, src, chPos+1); NextCh; RETURN FALSE$");
PutS(" END$");
PutS(" END;");
END;
END GenComment;
PROCEDURE CopyFramePart (stopStr: ARRAY OF CHAR); (*Copy from file <fram> to file <out> until <stopStr>*)
VAR ch, startCh: CHAR; i, j, high: INTEGER;
BEGIN
startCh := stopStr[0]; high := Length(stopStr) - 1; Texts.Read (fram, ch);
WHILE ch # 0X DO
IF ch = startCh THEN (* check if stopString occurs *)
i := 0;
REPEAT
IF i = high THEN RETURN END; (*stopStr[0..i] found; no unrecognized character*)
Texts.Read (fram, ch); INC(i);
UNTIL ch # stopStr[i];
(*stopStr[0..i-1] found; 1 unrecognized character*)
j := 0; WHILE j < i DO Texts.Write(out, stopStr[j]); INC(j) END
ELSE Texts.Write (out, ch); Texts.Read(fram, ch)
END
END
END CopyFramePart;
PROCEDURE GenLiterals;
VAR
i, j, k, l: INTEGER;
key: ARRAY 128 OF CRT.Name;
knr: ARRAY 128 OF INTEGER;
ch: CHAR;
sn: CRT.SymbolNode;
BEGIN
(*-- sort literal list*)
i := 0; k := 0;
WHILE i <= CRT.maxT DO
CRT.GetSym(i, sn);
IF sn.struct = CRT.litToken THEN
j := k-1; WHILE (j >= 0) & (sn.name < key[j]) DO key[j+1] := key[j]; knr[j+1] := knr[j]; DEC(j) END;
key[j+1] := sn.name; knr[j+1] := i; INC(k)
END;
INC(i)
END;
(*-- print case statement*)
IF k > 0 THEN
PutS(" IF (lexeme[0] >= "); PutC(key[0, 1]); PutS(") & (lexeme[0] <= "); PutC(key[k-1, 1]); PutS(") THEN$");
PutS(" CASE lexeme[0] OF$");
i := 0;
WHILE i < k DO
ch := key[i, 1]; (*key[i, 0] = quote*)
PutS(" | "); PutC(ch); j := i;
REPEAT
IF i = j THEN PutS(": IF lexeme = ") ELSE PutS(" ELSIF lexeme = ") END;
PutS(key[i]); PutS(" THEN sym := "); PutI(knr[i]); Put(CHR(13));
INC(i)
UNTIL (i = k) OR (key[i, 1] # ch);
PutS(" END$");
END;
PutS(" ELSE$ END$ END;$")
END
END GenLiterals;
PROCEDURE WriteState(state: State);
VAR action: Action; first, ctxEnd: BOOLEAN; sn: CRT.SymbolNode; endOf: INTEGER;
set: CRT.Set;
BEGIN
endOf := state.endOf;
IF (endOf > CRT.maxT) & (endOf # CRT.noSym) THEN (*pragmas have been moved*)
endOf := CRT.maxT + CRT.maxSymbols - endOf
END;
PutS(" | "); PutI2(state.nr, 2); PutS(": ");
first:=TRUE; ctxEnd := state.ctx;
action := state.firstAction;
WHILE action # NIL DO
IF first THEN PutS("IF "); first:=FALSE ELSE PutS(" ELSIF ") END;
IF action^.typ = CRT.char THEN PutChCond(CHR(action^.sym))
ELSE CRT.GetClass(action^.sym, set); PutRange(set)
END;
PutS(" THEN");
IF action.target.state.nr # state.nr THEN
PutS(" state := "); PutI(action.target.state.nr); Put(";")
END;
IF action^.tc = CRT.contextTrans THEN PutS(" INC(apx)"); ctxEnd := FALSE
ELSIF state.ctx THEN PutS(" apx := 0")
END;
PutS(" $");
action := action^.next
END;
IF state.firstAction # NIL THEN PutS(" ELSE ") END;
IF endOf = CRT.noSym THEN PutS("sym := noSym; ")
ELSE (*final state*)
CRT.GetSym(endOf, sn);
IF ctxEnd THEN (*final context state: cut appendix*)
PutS("chPos := chPos - apx - 1; Texts.OpenReader(r, src, chPos+1); NextCh; ")
END;
PutS("sym := "); PutI(endOf); PutS("; ");
IF sn.struct = CRT.classLitToken THEN PutS("CheckLiteral; ") END
END;
PutS("RETURN$");
IF state.firstAction # NIL THEN PutS(" END;$") END
END WriteState;
PROCEDURE *Show (t: Texts.Text; op: INTEGER; beg, end: LONGINT);
END Show;
PROCEDURE WriteScanner*;
VAR
scanner: ARRAY 32 OF CHAR;
name: ARRAY 64 OF CHAR;
startTab: ARRAY 128 OF INTEGER;
com: Comment;
i, j, l: INTEGER;
gn: CRT.GraphNode;
sn: CRT.SymbolNode;
state: State;
t: Texts.Text;
PROCEDURE FillStartTab;
VAR action: Action; i, targetState: INTEGER; class: CRT.Set;
BEGIN
startTab[0] := stateNr + 1; (*eof*)
i := 1; WHILE i < 128 DO startTab[i] := 0; INC(i) END;
action := firstState.firstAction;
WHILE action # NIL DO
targetState := action.target.state.nr;
IF action^.typ = CRT.char THEN
startTab[action^.sym] := targetState
ELSE
CRT.GetClass(action^.sym, class); i := 0;
WHILE i < 128 DO
IF Sets.In(class, i) THEN startTab[i] := targetState END;
INC(i)
END
END;
action := action^.next
END
END FillStartTab;
BEGIN
FillStartTab;
CRT.GetNode(CRT.root, gn); CRT.GetSym(gn.p1, sn);
COPY(sn.name, scanner); l := Length(scanner); scanner[l] := "S"; scanner[l+1] := 0X;
NEW(t); Texts.Open(t, "Scanner.FRM"); Texts.OpenReader(fram, t, 0);
IF t.len = 0 THEN
Texts.WriteString(out, "Scanner.FRM not found"); Texts.WriteLn(out);
Texts.Append(Oberon.Log, out.buf); HALT(99)
END;
Texts.Append(Oberon.Log, out.buf);
(*------- *S.MOD -------*)
CopyFramePart("-->modulename"); PutS(scanner);
CopyFramePart("-->declarations"); PutS(" noSym = "); PutI(CRT.maxT); Put(";");
CopyFramePart("-->comment");
com := firstComment;
WHILE com # NIL DO GenComment(com); com := com^.next END;
CopyFramePart("-->literals"); GenLiterals;
CopyFramePart("-->GetSy1");
IF ~ Sets.In(CRT.ignored, ORD(EOL)) THEN PutS(" IF oldEols > 0 THEN DEC(oldEols); ch := EOL END;$") END;
PutS(" WHILE (ch=20X)"); IF ~ Sets.Empty(CRT.ignored) THEN PutS(" OR ") END;
PutRange(CRT.ignored); PutS(" DO NextCh END;");
IF firstComment # NIL THEN
PutS("$ IF ("); com := firstComment;
WHILE com # NIL DO
PutChCond(com^.start[0]);
IF com^.next # NIL THEN PutS(" OR ") END;
com := com^.next
END;
PutS(") & Comment() THEN Get(sym); RETURN END;")
END;
CopyFramePart("-->GetSy2");
state := firstState.next;
WHILE state # NIL DO WriteState(state); state := state.next END;
PutS(" | "); PutI2(stateNr + 1, 2); PutS(": sym := 0; ch := 0X; RETURN$");
CopyFramePart("-->initialization");
i := 0;
WHILE i < 32 DO
j := 0; PutS(" ");
WHILE j < 4 DO
PutS("start["); PutI(4*i+j); PutS("]:="); PutI(startTab[4*i+j]); PutS("; ");
INC(j)
END;
Texts.WriteLn(out);
INC(i)
END;
CopyFramePart("-->modulename"); PutS(scanner); Put(".");
NEW(t); (*t.notify := Show;*) Texts.Open(t, ""); Texts.Append(t, out.buf);
l := Length(scanner); scanner[l] := "."; scanner[l+1] := "M"; scanner[l+2] := "o"; scanner[l+3] := "d"; scanner[l+4] := 0X;
Texts.Close(t, scanner)
END WriteScanner;
PROCEDURE Init*;
BEGIN
firstState := NIL; lastState := NIL; stateNr := -1;
rootState := NewState();
firstMelted := NIL; firstComment := NIL
END Init;
BEGIN
Texts.OpenWriter(out)
END CRA.

703
src/tools/coco/CRP.Mod Normal file
View file

@ -0,0 +1,703 @@
(* parser module generated by Coco-R *)
MODULE CRP;
IMPORT CRS, CRT, CRA, CRX, Sets, Texts := CmdlnTexts, Oberon;
CONST
maxP = 39;
maxT = 38;
nrSets = 18;
setSize = 32; nSets = (maxT DIV setSize) + 1;
TYPE
SymbolSet = ARRAY nSets OF SET;
VAR
sym: INTEGER; (* current input symbol *)
symSet: ARRAY nrSets OF SymbolSet;
CONST
ident = 0; string = 1; (*symbol kind*)
VAR
str: ARRAY 32 OF CHAR;
w: Texts.Writer;
genScanner: BOOLEAN;
PROCEDURE SemErr(nr: INTEGER);
BEGIN
CRS.Error(200+nr, CRS.pos);
END SemErr;
PROCEDURE MatchLiteral(sp: INTEGER); (*store string either as token or as literal*)
VAR sn, sn1: CRT.SymbolNode; matchedSp: INTEGER;
BEGIN
CRT.GetSym(sp, sn);
CRA.MatchDFA(sn.name, sp, matchedSp);
IF matchedSp # CRT.noSym THEN
CRT.GetSym(matchedSp, sn1); sn1.struct := CRT.classLitToken; CRT.PutSym(matchedSp, sn1);
sn.struct := CRT.litToken
ELSE sn.struct := CRT.classToken;
END;
CRT.PutSym(sp, sn)
END MatchLiteral;
PROCEDURE SetCtx(gp: INTEGER); (*set transition code to CRT.contextTrans*)
VAR gn: CRT.GraphNode;
BEGIN
WHILE gp > 0 DO
CRT.GetNode(gp, gn);
IF gn.typ IN {CRT.char, CRT.class} THEN
gn.p2 := CRT.contextTrans; CRT.PutNode(gp, gn)
ELSIF gn.typ IN {CRT.opt, CRT.iter} THEN SetCtx(gn.p1)
ELSIF gn.typ = CRT.alt THEN SetCtx(gn.p1); SetCtx(gn.p2)
END;
gp := gn.next
END
END SetCtx;
PROCEDURE SetDDT(s: ARRAY OF CHAR);
VAR name: ARRAY 64 OF CHAR; i: INTEGER; ch: CHAR;
BEGIN
i := 1;
WHILE s[i] # 0X DO
ch := s[i]; INC(i);
IF (ch >= "0") & (ch <= "9") THEN CRT.ddt[ORD(ch)-ORD("0")] := TRUE END
END
END SetDDT;
PROCEDURE FixString (VAR s: ARRAY OF CHAR; len: INTEGER);
VAR double: BOOLEAN; i: INTEGER;
BEGIN
double := FALSE;
FOR i := 0 TO len-2 DO
IF s[i] = '"' THEN double := TRUE END
END;
IF ~ double THEN s[0] := '"'; s[len-1] := '"' END
END FixString;
(*-------------------------------------------------------------------------*)
PROCEDURE Error (n: INTEGER);
BEGIN CRS.Error(n, CRS.nextPos)
END Error;
PROCEDURE Get;
BEGIN
LOOP CRS.Get(sym);
IF sym > maxT THEN
IF sym = 39 THEN
CRS.GetName(CRS.nextPos, CRS.nextLen, str); SetDDT(str)
END;
CRS.nextPos := CRS.pos;
CRS.nextCol := CRS.col;
CRS.nextLine := CRS.line;
CRS.nextLen := CRS.len;
ELSE EXIT
END
END
END Get;
PROCEDURE Expect(n: INTEGER);
BEGIN IF sym = n THEN Get ELSE Error(n) END
END Expect;
PROCEDURE StartOf(s: INTEGER): BOOLEAN;
BEGIN RETURN (sym MOD setSize) IN symSet[s, sym DIV setSize]
END StartOf;
PROCEDURE ExpectWeak(n, follow: INTEGER);
BEGIN
IF sym = n THEN Get
ELSE Error(n); WHILE ~ StartOf(follow) DO Get END
END
END ExpectWeak;
PROCEDURE WeakSeparator(n, syFol, repFol: INTEGER): BOOLEAN;
VAR s: SymbolSet; i: INTEGER;
BEGIN
IF sym = n THEN Get; RETURN TRUE
ELSIF StartOf(repFol) THEN RETURN FALSE
ELSE
i := 0; WHILE i < nSets DO s[i] := symSet[syFol, i] + symSet[repFol, i] + symSet[0, i]; INC(i) END;
Error(n); WHILE ~ ((sym MOD setSize) IN s[sym DIV setSize]) DO Get END;
RETURN StartOf(syFol)
END
END WeakSeparator;
PROCEDURE ^TokenFactor(VAR gL, gR: INTEGER);
PROCEDURE ^TokenTerm(VAR gL, gR: INTEGER);
PROCEDURE ^Factor(VAR gL, gR: INTEGER);
PROCEDURE ^Term(VAR gL, gR: INTEGER);
PROCEDURE ^Symbol(VAR name: CRT.Name; VAR kind: INTEGER);
PROCEDURE ^SimSet(VAR set: CRT.Set);
PROCEDURE ^Set(VAR set: CRT.Set);
PROCEDURE ^TokenExpr(VAR gL, gR: INTEGER);
PROCEDURE ^TokenDecl(typ: INTEGER);
PROCEDURE ^SetDecl;
PROCEDURE ^Expression(VAR gL, gR: INTEGER);
PROCEDURE ^SemText(VAR semPos: CRT.Position);
PROCEDURE ^Attribs(VAR attrPos: CRT.Position);
PROCEDURE ^Declaration;
PROCEDURE ^CR;
PROCEDURE TokenFactor(VAR gL, gR: INTEGER);
VAR kind, c: INTEGER; set: CRT.Set; name: CRT.Name;
BEGIN
gL :=0; gR := 0 ;
IF (sym = 1) OR (sym = 2) THEN
Symbol(name, kind);
IF kind = ident THEN
c := CRT.ClassWithName(name);
IF c < 0 THEN
SemErr(15);
Sets.Clear(set); c := CRT.NewClass(name, set)
END;
gL := CRT.NewNode(CRT.class, c, 0); gR := gL
ELSE (*string*)
CRT.StrToGraph(name, gL, gR)
END ;
ELSIF (sym = 23) THEN
Get;
TokenExpr(gL, gR);
Expect(24);
ELSIF (sym = 28) THEN
Get;
TokenExpr(gL, gR);
Expect(29);
CRT.MakeOption(gL, gR) ;
ELSIF (sym = 30) THEN
Get;
TokenExpr(gL, gR);
Expect(31);
CRT.MakeIteration(gL, gR) ;
ELSE Error(39)
END;
END TokenFactor;
PROCEDURE TokenTerm(VAR gL, gR: INTEGER);
VAR gL2, gR2: INTEGER;
BEGIN
TokenFactor(gL, gR);
WHILE StartOf(1) DO
TokenFactor(gL2, gR2);
CRT.ConcatSeq(gL, gR, gL2, gR2) ;
END;
IF (sym = 33) THEN
Get;
Expect(23);
TokenExpr(gL2, gR2);
SetCtx(gL2); CRT.ConcatSeq(gL, gR, gL2, gR2) ;
Expect(24);
END;
END TokenTerm;
PROCEDURE Factor(VAR gL, gR: INTEGER);
VAR sp, kind, c: INTEGER; name: CRT.Name;
gn: CRT.GraphNode; sn: CRT.SymbolNode;
set: CRT.Set;
undef, weak: BOOLEAN;
pos: CRT.Position;
BEGIN
gL :=0; gR := 0; weak := FALSE ;
CASE sym OF
| 1,2,27: IF (sym = 27) THEN
Get;
weak := TRUE ;
END;
Symbol(name, kind);
sp := CRT.FindSym(name); undef := sp = CRT.noSym;
IF undef THEN
IF kind = ident THEN (*forward nt*)
sp := CRT.NewSym(CRT.nt, name, 0)
ELSE (*undefined string in production*)
sp := CRT.NewSym(CRT.t, name, CRS.line);
MatchLiteral(sp)
END
END;
CRT.GetSym(sp, sn);
IF ~(sn.typ IN {CRT.t,CRT.nt}) THEN SemErr(4) END;
IF weak THEN
IF sn.typ = CRT.t THEN sn.typ := CRT.wt ELSE SemErr(23) END
END;
gL := CRT.NewNode(sn.typ, sp, CRS.line); gR := gL ;
IF (sym = 34) THEN
Attribs(pos);
CRT.GetNode(gL, gn); gn.pos := pos; CRT.PutNode(gL, gn);
CRT.GetSym(sp, sn);
IF undef THEN
sn.attrPos := pos; CRT.PutSym(sp, sn)
ELSIF sn.attrPos.beg < 0 THEN SemErr(5)
END;
IF kind # ident THEN SemErr(3) END ;
ELSIF StartOf(2) THEN
CRT.GetSym(sp, sn);
IF sn.attrPos.beg >= 0 THEN SemErr(6) END ;
ELSE Error(40)
END;
| 23: Get;
Expression(gL, gR);
Expect(24);
| 28: Get;
Expression(gL, gR);
Expect(29);
CRT.MakeOption(gL, gR) ;
| 30: Get;
Expression(gL, gR);
Expect(31);
CRT.MakeIteration(gL, gR) ;
| 36: SemText(pos);
gL := CRT.NewNode(CRT.sem, 0, 0);
gR := gL;
CRT.GetNode(gL, gn); gn.pos := pos; CRT.PutNode(gL, gn) ;
| 25: Get;
Sets.Fill(set); Sets.Excl(set, CRT.eofSy);
gL := CRT.NewNode(CRT.any, CRT.NewSet(set), 0); gR := gL ;
| 32: Get;
gL := CRT.NewNode(CRT.sync, 0, 0); gR := gL ;
ELSE Error(41)
END;
END Factor;
PROCEDURE Term(VAR gL, gR: INTEGER);
VAR gL2, gR2: INTEGER;
BEGIN
gL := 0; gR := 0 ;
IF StartOf(3) THEN
Factor(gL, gR);
WHILE StartOf(3) DO
Factor(gL2, gR2);
CRT.ConcatSeq(gL, gR, gL2, gR2) ;
END;
ELSIF StartOf(4) THEN
gL := CRT.NewNode(CRT.eps, 0, 0); gR := gL ;
ELSE Error(42)
END;
END Term;
PROCEDURE Symbol(VAR name: CRT.Name; VAR kind: INTEGER);
BEGIN
IF (sym = 1) THEN
Get;
kind := ident ;
ELSIF (sym = 2) THEN
Get;
kind := string ;
ELSE Error(43)
END;
CRS.GetName(CRS.pos, CRS.len, name);
IF kind = string THEN FixString(name, CRS.len) END ;
END Symbol;
PROCEDURE SimSet(VAR set: CRT.Set);
VAR c, n, i: INTEGER; name: CRT.Name; s: ARRAY 128 OF CHAR;
BEGIN
IF (sym = 1) THEN
Get;
CRS.GetName(CRS.pos, CRS.len, name);
c := CRT.ClassWithName(name);
IF c < 0 THEN SemErr(15); Sets.Clear(set)
ELSE CRT.GetClass(c, set)
END ;
ELSIF (sym = 2) THEN
Get;
CRS.GetName(CRS.pos, CRS.len, s);
Sets.Clear(set); i := 1;
WHILE s[i] # s[0] DO
Sets.Incl(set, ORD(s[i])); INC(i)
END ;
ELSIF (sym = 22) THEN
Get;
Expect(23);
Expect(3);
CRS.GetName(CRS.pos, CRS.len, name);
n := 0; i := 0;
WHILE name[i] # 0X DO
n := 10 * n + (ORD(name[i]) - ORD("0"));
INC(i)
END;
Sets.Clear(set); Sets.Incl(set, n) ;
Expect(24);
ELSIF (sym = 25) THEN
Get;
Sets.Fill(set) ;
ELSE Error(44)
END;
END SimSet;
PROCEDURE Set(VAR set: CRT.Set);
VAR set2: CRT.Set;
BEGIN
SimSet(set);
WHILE (sym = 20) OR (sym = 21) DO
IF (sym = 20) THEN
Get;
SimSet(set2);
Sets.Unite(set, set2) ;
ELSE
Get;
SimSet(set2);
Sets.Differ(set, set2) ;
END;
END;
END Set;
PROCEDURE TokenExpr(VAR gL, gR: INTEGER);
VAR gL2, gR2: INTEGER; first: BOOLEAN;
BEGIN
TokenTerm(gL, gR);
first := TRUE ;
WHILE WeakSeparator(26, 1, 5) DO
TokenTerm(gL2, gR2);
IF first THEN
CRT.MakeFirstAlt(gL, gR); first := FALSE
END;
CRT.ConcatAlt(gL, gR, gL2, gR2) ;
END;
END TokenExpr;
PROCEDURE TokenDecl(typ: INTEGER);
VAR sp, kind, gL, gR: INTEGER; sn: CRT.SymbolNode;
pos: CRT.Position; name: CRT.Name;
BEGIN
Symbol(name, kind);
IF CRT.FindSym(name) # CRT.noSym THEN SemErr(7)
ELSE
sp := CRT.NewSym(typ, name, CRS.line);
CRT.GetSym(sp, sn); sn.struct := CRT.classToken;
CRT.PutSym(sp, sn)
END ;
WHILE ~( StartOf(6) ) DO Error(45); Get END;
IF (sym = 8) THEN
Get;
TokenExpr(gL, gR);
Expect(9);
IF kind # ident THEN SemErr(13) END;
CRT.CompleteGraph(gR);
CRA.ConvertToStates(gL, sp) ;
ELSIF StartOf(7) THEN
IF kind = ident THEN genScanner := FALSE
ELSE MatchLiteral(sp)
END ;
ELSE Error(46)
END;
IF (sym = 36) THEN
SemText(pos);
IF typ = CRT.t THEN SemErr(14) END;
CRT.GetSym(sp, sn); sn.semPos := pos; CRT.PutSym(sp, sn) ;
END;
END TokenDecl;
PROCEDURE SetDecl;
VAR c: INTEGER; set: CRT.Set; name: CRT.Name;
BEGIN
Expect(1);
CRS.GetName(CRS.pos, CRS.len, name);
c := CRT.ClassWithName(name); IF c >= 0 THEN SemErr(7) END ;
Expect(8);
Set(set);
c := CRT.NewClass(name, set) ;
Expect(9);
END SetDecl;
PROCEDURE Expression(VAR gL, gR: INTEGER);
VAR gL2, gR2: INTEGER; first: BOOLEAN;
BEGIN
Term(gL, gR);
first := TRUE ;
WHILE WeakSeparator(26, 2, 8) DO
Term(gL2, gR2);
IF first THEN
CRT.MakeFirstAlt(gL, gR); first := FALSE
END;
CRT.ConcatAlt(gL, gR, gL2, gR2) ;
END;
END Expression;
PROCEDURE SemText(VAR semPos: CRT.Position);
BEGIN
Expect(36);
semPos.beg := CRS.nextPos; semPos.col := CRS.nextCol ;
WHILE StartOf(9) DO
Get;
END;
Expect(37);
semPos.len := SHORT(CRS.pos - semPos.beg) ;
END SemText;
PROCEDURE Attribs(VAR attrPos: CRT.Position);
BEGIN
Expect(34);
attrPos.beg := CRS.nextPos; attrPos.col := CRS.nextCol ;
WHILE StartOf(10) DO
Get;
END;
Expect(35);
attrPos.len := SHORT(CRS.pos - attrPos.beg) ;
END Attribs;
PROCEDURE Declaration;
VAR gL1, gR1, gL2, gR2: INTEGER; nested: BOOLEAN;
BEGIN
IF (sym = 11) THEN
Get;
WHILE (sym = 1) DO
SetDecl;
END;
ELSIF (sym = 12) THEN
Get;
WHILE (sym = 1) OR (sym = 2) DO
TokenDecl(CRT.t);
END;
ELSIF (sym = 13) THEN
Get;
WHILE (sym = 1) OR (sym = 2) DO
TokenDecl(CRT.pr);
END;
ELSIF (sym = 14) THEN
Get;
Expect(15);
TokenExpr(gL1, gR1);
Expect(16);
TokenExpr(gL2, gR2);
IF (sym = 17) THEN
Get;
nested := TRUE ;
ELSIF StartOf(11) THEN
nested := FALSE ;
ELSE Error(47)
END;
CRA.NewComment(gL1, gL2, nested) ;
ELSIF (sym = 18) THEN
Get;
IF (sym = 19) THEN
Get;
CRT.ignoreCase := TRUE ;
ELSIF StartOf(12) THEN
Set(CRT.ignored);
ELSE Error(48)
END;
ELSE Error(49)
END;
END Declaration;
PROCEDURE CR;
VAR undef, hasAttrs, ok, ok1: BOOLEAN; eofSy, gR: INTEGER;
gramLine, sp: INTEGER;
gn: CRT.GraphNode; sn: CRT.SymbolNode;
name, gramName: CRT.Name;
BEGIN
Expect(4);
Texts.OpenWriter(w);
CRT.Init; CRX.Init; CRA.Init;
gramLine := CRS.line;
eofSy := CRT.NewSym(CRT.t, "EOF", 0);
genScanner := TRUE;
CRT.ignoreCase := FALSE;
ok := TRUE;
Sets.Clear(CRT.ignored) ;
Expect(1);
CRS.GetName(CRS.pos, CRS.len, gramName);
CRT.semDeclPos.beg := CRS.nextPos; CRT.importPos.beg := -1; ;
WHILE StartOf(13) DO
IF (sym = 5) THEN
Get;
CRT.importPos.beg := CRS.nextPos ;
WHILE StartOf(14) DO
Get;
END;
Expect(6);
CRT.importPos.len := SHORT(CRS.pos - CRT.importPos.beg);
CRT.importPos.col := 0;
CRT.semDeclPos.beg := CRS.nextPos ;
ELSE
Get;
END;
END;
CRT.semDeclPos.len := SHORT(CRS.nextPos - CRT.semDeclPos.beg);
CRT.semDeclPos.col := 0 ;
WHILE StartOf(15) DO
Declaration;
END;
WHILE ~( (sym = 0) OR (sym = 7)) DO Error(50); Get END;
Expect(7);
IF genScanner THEN CRA.MakeDeterministic(ok) END;
CRT.nNodes := 0 ;
WHILE (sym = 1) DO
Get;
CRS.GetName(CRS.pos, CRS.len, name);
sp := CRT.FindSym(name); undef := sp = CRT.noSym;
IF undef THEN
sp := CRT.NewSym(CRT.nt, name, CRS.line);
CRT.GetSym(sp, sn);
ELSE
CRT.GetSym(sp, sn);
IF sn.typ = CRT.nt THEN
IF sn.struct > 0 THEN SemErr(7) END
ELSE SemErr(8)
END;
sn.line := CRS.line
END;
hasAttrs := sn.attrPos.beg >= 0 ;
IF (sym = 34) THEN
Attribs(sn.attrPos);
IF ~undef & ~hasAttrs THEN SemErr(9) END;
CRT.PutSym(sp, sn) ;
ELSIF (sym = 8) OR (sym = 36) THEN
IF ~undef & hasAttrs THEN SemErr(10) END ;
ELSE Error(51)
END;
IF (sym = 36) THEN
SemText(sn.semPos);
END;
ExpectWeak(8, 16);
Expression(sn.struct, gR);
CRT.CompleteGraph(gR); CRT.PutSym(sp, sn);
IF CRT.ddt[2] THEN CRT.PrintGraph END ;
ExpectWeak(9, 17);
END;
sp := CRT.FindSym(gramName);
IF sp = CRT.noSym THEN SemErr(11);
ELSE
CRT.GetSym(sp, sn);
IF sn.attrPos.beg >= 0 THEN SemErr(12) END;
CRT.root := CRT.NewNode(CRT.nt, sp, gramLine);
END ;
Expect(10);
Expect(1);
CRS.GetName(CRS.pos, CRS.len, name);
IF name # gramName THEN SemErr(17) END;
IF CRS.errors = 0 THEN
Texts.WriteString(w, " checking"); Texts.Append(Oberon.Log, w.buf);
CRT.CompSymbolSets;
IF ok THEN CRT.TestCompleteness(ok) END;
IF ok THEN
CRT.TestIfAllNtReached(ok1); CRT.FindCircularProductions(ok)
END;
IF ok THEN CRT.TestIfNtToTerm(ok) END;
IF ok THEN CRT.LL1Test(ok1) END;
IF CRT.ddt[0] THEN CRA.PrintStates END;
IF CRT.ddt[7] THEN CRT.XRef END;
IF ok THEN
Texts.WriteString(w, " +parser");
Texts.Append(Oberon.Log, w.buf);
CRX.GenCompiler;
IF genScanner THEN
Texts.WriteString(w, " +scanner");
Texts.Append(Oberon.Log, w.buf);
CRA.WriteScanner
END;
IF CRT.ddt[8] THEN CRX.WriteStatistics END
END
ELSE ok := FALSE
END;
IF CRT.ddt[6] THEN CRT.PrintSymbolTable END;
IF ok THEN Texts.WriteString(w, " done") END;
Texts.WriteLn(w); Texts.Append(Oberon.Log, w.buf) ;
Expect(9);
END CR;
PROCEDURE Parse*;
BEGIN
Get;
CR;
END Parse;
BEGIN
symSet[0, 0] := {0,1,2,7,8,11,12,13,14,18};
symSet[0, 1] := {4};
symSet[1, 0] := {1,2,23,28,30};
symSet[1, 1] := {};
symSet[2, 0] := {1,2,9,23,24,25,26,27,28,29,30,31};
symSet[2, 1] := {0,4};
symSet[3, 0] := {1,2,23,25,27,28,30};
symSet[3, 1] := {0,4};
symSet[4, 0] := {9,24,26,29,31};
symSet[4, 1] := {};
symSet[5, 0] := {7,9,11,12,13,14,16,17,18,24,29,31};
symSet[5, 1] := {};
symSet[6, 0] := {0,1,2,7,8,11,12,13,14,18};
symSet[6, 1] := {4};
symSet[7, 0] := {1,2,7,11,12,13,14,18};
symSet[7, 1] := {4};
symSet[8, 0] := {9,24,29,31};
symSet[8, 1] := {};
symSet[9, 0] := {1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,31};
symSet[9, 1] := {0,1,2,3,4,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,31};
symSet[10, 0] := {1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,31};
symSet[10, 1] := {0,1,2,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,31};
symSet[11, 0] := {7,11,12,13,14,18};
symSet[11, 1] := {};
symSet[12, 0] := {1,2,22,25};
symSet[12, 1] := {};
symSet[13, 0] := {1,2,3,4,5,6,8,9,10,15,16,17,19,20,21,22,23,24,25,26,27,28,29,30,31};
symSet[13, 1] := {0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,31};
symSet[14, 0] := {1,2,3,4,5,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,31};
symSet[14, 1] := {0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,31};
symSet[15, 0] := {11,12,13,14,18};
symSet[15, 1] := {};
symSet[16, 0] := {0,1,2,7,8,9,11,12,13,14,18,23,25,26,27,28,30};
symSet[16, 1] := {0,4};
symSet[17, 0] := {0,1,2,7,8,10,11,12,13,14,18};
symSet[17, 1] := {4};
END CRP.
| 0: Msg("EOF expected")
| 1: Msg("ident expected")
| 2: Msg("string expected")
| 3: Msg("number expected")
| 4: Msg("'COMPILER' expected")
| 5: Msg("'IMPORT' expected")
| 6: Msg("';' expected")
| 7: Msg("'PRODUCTIONS' expected")
| 8: Msg("'=' expected")
| 9: Msg("'.' expected")
| 10: Msg("'END' expected")
| 11: Msg("'CHARACTERS' expected")
| 12: Msg("'TOKENS' expected")
| 13: Msg("'PRAGMAS' expected")
| 14: Msg("'COMMENTS' expected")
| 15: Msg("'FROM' expected")
| 16: Msg("'TO' expected")
| 17: Msg("'NESTED' expected")
| 18: Msg("'IGNORE' expected")
| 19: Msg("'CASE' expected")
| 20: Msg("'+' expected")
| 21: Msg("'-' expected")
| 22: Msg("'CHR' expected")
| 23: Msg("'(' expected")
| 24: Msg("')' expected")
| 25: Msg("'ANY' expected")
| 26: Msg("'|' expected")
| 27: Msg("'WEAK' expected")
| 28: Msg("'[' expected")
| 29: Msg("']' expected")
| 30: Msg("'{' expected")
| 31: Msg("'}' expected")
| 32: Msg("'SYNC' expected")
| 33: Msg("'CONTEXT' expected")
| 34: Msg("'<' expected")
| 35: Msg("'>' expected")
| 36: Msg("'(.' expected")
| 37: Msg("'.)' expected")
| 38: Msg("??? expected")
| 39: Msg("invalid TokenFactor")
| 40: Msg("invalid Factor")
| 41: Msg("invalid Factor")
| 42: Msg("invalid Term")
| 43: Msg("invalid Symbol")
| 44: Msg("invalid SimSet")
| 45: Msg("this symbol not expected in TokenDecl")
| 46: Msg("invalid TokenDecl")
| 47: Msg("invalid Declaration")
| 48: Msg("invalid Declaration")
| 49: Msg("invalid Declaration")
| 50: Msg("this symbol not expected in CR")
| 51: Msg("invalid CR")

230
src/tools/coco/CRS.Mod Normal file
View file

@ -0,0 +1,230 @@
(* scanner module generated by Coco-R *)
MODULE CRS;
IMPORT Texts := CmdlnTexts, SYSTEM;
CONST
EOL = 0DX;
EOF = 0X;
maxLexLen = 127;
noSym = 38;
TYPE
ErrorProc* = PROCEDURE (n: INTEGER; pos: LONGINT);
StartTable = ARRAY 128 OF INTEGER;
VAR
src*: Texts.Text; (*source text. To be set by the main pgm*)
pos*: LONGINT; (*position of current symbol*)
line*, col*, len*: INTEGER; (*line, column, length of current symbol*)
nextPos*: LONGINT; (*position of lookahead symbol*)
nextLine*, nextCol*, nextLen*: INTEGER; (*line, column, length of lookahead symbol*)
errors*: INTEGER; (*number of errors detected*)
Error*: ErrorProc;
ch: CHAR; (*current input character*)
r: Texts.Reader; (*global reader*)
chPos: LONGINT; (*position of current character*)
chLine: INTEGER; (*current line number*)
lineStart: LONGINT; (*start position of current line*)
apx: INTEGER; (*length of appendix*)
oldEols: INTEGER; (*nr. of EOLs in a comment*)
start: StartTable; (*start state for every character*)
PROCEDURE NextCh; (*return global variable ch*)
BEGIN
Texts.Read(r, ch); INC(chPos);
IF ch = EOL THEN INC(chLine); lineStart := chPos + 1 END
END NextCh;
PROCEDURE Comment(): BOOLEAN;
VAR level, startLine: INTEGER; oldLineStart: LONGINT;
BEGIN (*Comment*)
level := 1; startLine := chLine; oldLineStart := lineStart;
IF (ch ="(") THEN
NextCh;
IF (ch ="*") THEN
NextCh;
LOOP
IF (ch ="*") THEN
NextCh;
IF (ch =")") THEN
DEC(level); oldEols := chLine - startLine; NextCh;
IF level=0 THEN RETURN TRUE END
END;
ELSIF (ch ="(") THEN
NextCh;
IF (ch ="*") THEN
INC(level); NextCh;
END;
ELSIF ch = EOF THEN RETURN FALSE
ELSE NextCh END;
END;
ELSE
IF ch = EOL THEN DEC(chLine); lineStart := oldLineStart END;
DEC(chPos, 2); Texts.OpenReader(r, src, chPos+1); NextCh; RETURN FALSE
END
END;
END Comment;
PROCEDURE Get*(VAR sym: INTEGER);
VAR state: INTEGER; lexeme: ARRAY maxLexLen+1 OF CHAR;
PROCEDURE CheckLiteral;
BEGIN
IF nextLen < maxLexLen THEN lexeme[nextLen] := 0X END;
IF (lexeme[0] >= "A") & (lexeme[0] <= "W") THEN
CASE lexeme[0] OF
| "A": IF lexeme = "ANY" THEN sym := 25
END
| "C": IF lexeme = "CASE" THEN sym := 19
ELSIF lexeme = "CHARACTERS" THEN sym := 11
ELSIF lexeme = "CHR" THEN sym := 22
ELSIF lexeme = "COMMENTS" THEN sym := 14
ELSIF lexeme = "COMPILER" THEN sym := 4
ELSIF lexeme = "CONTEXT" THEN sym := 33
END
| "E": IF lexeme = "END" THEN sym := 10
END
| "F": IF lexeme = "FROM" THEN sym := 15
END
| "I": IF lexeme = "IGNORE" THEN sym := 18
ELSIF lexeme = "IMPORT" THEN sym := 5
END
| "N": IF lexeme = "NESTED" THEN sym := 17
END
| "P": IF lexeme = "PRAGMAS" THEN sym := 13
ELSIF lexeme = "PRODUCTIONS" THEN sym := 7
END
| "S": IF lexeme = "SYNC" THEN sym := 32
END
| "T": IF lexeme = "TO" THEN sym := 16
ELSIF lexeme = "TOKENS" THEN sym := 12
END
| "W": IF lexeme = "WEAK" THEN sym := 27
END
ELSE
END
END;
END CheckLiteral;
BEGIN
WHILE (ch=20X) OR (ch=CHR(9)) OR (ch=CHR(13)) OR (ch=CHR(28)) DO NextCh END;
IF ((ch ="(")) & Comment() THEN Get(sym); RETURN END;
IF ch > 7FX THEN ch := " " END;
pos := nextPos; col := nextCol; line := nextLine; len := nextLen;
nextPos := chPos; nextCol := SHORT(chPos - lineStart); nextLine := chLine; nextLen := 0;
state := start[ORD(ch)]; apx := 0;
LOOP
IF nextLen < maxLexLen THEN lexeme[nextLen] := ch END;
INC(nextLen);
NextCh;
IF state > 0 THEN
CASE state OF
| 1: IF (ch>="0") & (ch<="9") OR (ch>="A") & (ch<="Z") OR (ch>="a") & (ch<="z") THEN
ELSE sym := 1; CheckLiteral; RETURN
END;
| 2: IF (ch<=CHR(12)) OR (ch>=CHR(14)) & (ch<="!") OR (ch>="#") THEN
ELSIF (ch =CHR(34)) THEN state := 3;
ELSE sym := noSym; RETURN
END;
| 3: sym := 2; RETURN
| 4: IF (ch<=CHR(12)) OR (ch>=CHR(14)) & (ch<="&") OR (ch>="(") THEN
ELSIF (ch ="'") THEN state := 3;
ELSE sym := noSym; RETURN
END;
| 5: IF (ch>="0") & (ch<="9") THEN
ELSE sym := 3; RETURN
END;
| 6: IF (ch>="0") & (ch<="9") THEN
ELSE sym := 39; RETURN
END;
| 7: sym := 6; RETURN
| 8: sym := 8; RETURN
| 9: IF (ch =")") THEN state := 22;
ELSE sym := 9; RETURN
END;
| 10: sym := 20; RETURN
| 11: sym := 21; RETURN
| 12: IF (ch =".") THEN state := 21;
ELSE sym := 23; RETURN
END;
| 13: sym := 24; RETURN
| 14: sym := 26; RETURN
| 15: sym := 28; RETURN
| 16: sym := 29; RETURN
| 17: sym := 30; RETURN
| 18: sym := 31; RETURN
| 19: sym := 34; RETURN
| 20: sym := 35; RETURN
| 21: sym := 36; RETURN
| 22: sym := 37; RETURN
| 23: sym := 0; ch := 0X; RETURN
END (*CASE*)
ELSE sym := noSym; RETURN (*NextCh already done*)
END (*IF*)
END (*LOOP*)
END Get;
PROCEDURE GetName*(pos: LONGINT; len: INTEGER; VAR s: ARRAY OF CHAR);
VAR i: INTEGER; r: Texts.Reader;
BEGIN
Texts.OpenReader(r, src, pos);
IF len >= LEN(s) THEN len := SHORT(LEN(s)) - 1 END;
i := 0; WHILE i < len DO Texts.Read(r, s[i]); INC(i) END;
s[i] := 0X
END GetName;
PROCEDURE StdErrorProc* (n: INTEGER; pos: LONGINT);
BEGIN INC(errors) END StdErrorProc;
PROCEDURE Reset* (t: Texts.Text; pos: LONGINT; errProc: ErrorProc);
BEGIN
src := t; Error := errProc;
Texts.OpenReader(r, src, pos);
chPos := pos - 1; chLine := 1; lineStart := 0;
oldEols := 0; apx := 0; errors := 0;
NextCh
END Reset;
BEGIN
start[0]:=23; start[1]:=0; start[2]:=0; start[3]:=0;
start[4]:=0; start[5]:=0; start[6]:=0; start[7]:=0;
start[8]:=0; start[9]:=0; start[10]:=0; start[11]:=0;
start[12]:=0; start[13]:=0; start[14]:=0; start[15]:=0;
start[16]:=0; start[17]:=0; start[18]:=0; start[19]:=0;
start[20]:=0; start[21]:=0; start[22]:=0; start[23]:=0;
start[24]:=0; start[25]:=0; start[26]:=0; start[27]:=0;
start[28]:=0; start[29]:=0; start[30]:=0; start[31]:=0;
start[32]:=0; start[33]:=0; start[34]:=2; start[35]:=0;
start[36]:=6; start[37]:=0; start[38]:=0; start[39]:=4;
start[40]:=12; start[41]:=13; start[42]:=0; start[43]:=10;
start[44]:=0; start[45]:=11; start[46]:=9; start[47]:=0;
start[48]:=5; start[49]:=5; start[50]:=5; start[51]:=5;
start[52]:=5; start[53]:=5; start[54]:=5; start[55]:=5;
start[56]:=5; start[57]:=5; start[58]:=0; start[59]:=7;
start[60]:=19; start[61]:=8; start[62]:=20; start[63]:=0;
start[64]:=0; start[65]:=1; start[66]:=1; start[67]:=1;
start[68]:=1; start[69]:=1; start[70]:=1; start[71]:=1;
start[72]:=1; start[73]:=1; start[74]:=1; start[75]:=1;
start[76]:=1; start[77]:=1; start[78]:=1; start[79]:=1;
start[80]:=1; start[81]:=1; start[82]:=1; start[83]:=1;
start[84]:=1; start[85]:=1; start[86]:=1; start[87]:=1;
start[88]:=1; start[89]:=1; start[90]:=1; start[91]:=15;
start[92]:=0; start[93]:=16; start[94]:=0; start[95]:=0;
start[96]:=0; start[97]:=1; start[98]:=1; start[99]:=1;
start[100]:=1; start[101]:=1; start[102]:=1; start[103]:=1;
start[104]:=1; start[105]:=1; start[106]:=1; start[107]:=1;
start[108]:=1; start[109]:=1; start[110]:=1; start[111]:=1;
start[112]:=1; start[113]:=1; start[114]:=1; start[115]:=1;
start[116]:=1; start[117]:=1; start[118]:=1; start[119]:=1;
start[120]:=1; start[121]:=1; start[122]:=1; start[123]:=17;
start[124]:=14; start[125]:=18; start[126]:=0; start[127]:=0;
END CRS.

994
src/tools/coco/CRT.Mod Normal file
View file

@ -0,0 +1,994 @@
MODULE CRT; (* H.Moessenboeck 17.11.93, Cocol-R Tables *)
IMPORT Texts := CmdlnTexts, Oberon, Sets;
CONST
maxSymbols* = 300; (*max nr of t, nt, and pragmas*)
maxTerminals* = 256; (*max nr of terminals*)
maxNt* = 128; (*max nr of nonterminals*)
maxNodes* = 1500; (*max nr of graph nodes*)
normTrans* = 0; contextTrans* = 1; (*transition codes*)
maxSetNr = 128; (* max. number of symbol sets *)
maxClasses = 50; (* max. number of character classes *)
(* node types *)
t* = 1; pr* = 2; nt* = 3; class* = 4; char* = 5; wt* = 6; any* = 7; eps* = 8; sync* = 9; sem* = 10;
alt* = 11; iter* = 12; opt* = 13;
noSym* = -1;
eofSy* = 0;
(* token kinds *)
classToken* = 0; (*token class*)
litToken* = 1; (*literal (e.g. keyword) not recognized by DFA*)
classLitToken* = 2; (*token class that can also match a literal*)
TYPE
Name* = ARRAY 16 OF CHAR; (*symbol name*)
Position* = RECORD (*position of stretch of source text*)
beg*: LONGINT; (*start relative to beginning of file*)
len*: INTEGER; (*length*)
col*: INTEGER; (*column number of start position*)
END;
SymbolNode* = RECORD
typ*: INTEGER; (*nt, t, pr, unknown*)
name*: Name; (*symbol name*)
struct*: INTEGER; (*typ = nt: index of 1st node of syntax graph*)
(*typ = t: token kind: literal, class, ...*)
deletable*: BOOLEAN; (*typ = nt: TRUE, if nonterminal is deletable*)
attrPos*: Position; (*position of attributes in source text*)
semPos*: Position; (*typ = pr: pos of sem action in source text*)
(*typ = nt: pos of local decls in source text *)
line*: INTEGER; (*source text line number of item in this node*)
END;
Set* = ARRAY maxTerminals DIV Sets.size OF SET;
GraphNode* = RECORD
typ* : INTEGER; (* nt,sts,wts,char,class,any,eps,sem,sync,alt,iter,opt*)
next*: INTEGER; (* index of successor node *)
(* next < 0: to successor in enclosing structure *)
p1*: INTEGER; (* typ IN {nt, t, wt}: index to symbol list *)
(* typ = any: index to anyset *)
(* typ = sync: index to syncset *)
(* typ = alt: index of 1st node of 1st alternative*)
(* typ IN {iter, opt}: 1st node in subexpression *)
(* typ = char: ordinal character value *)
(* typ = class: index of character class *)
p2*: INTEGER; (* typ = alt: index of 1st node of 2nd alternative*)
(* typ IN {char, class}: transition code *)
pos*: Position; (* typ IN {nt, t, wt}: pos of actual attribs *)
(* typ = sem: pos of sem action in source text. *)
line*: INTEGER; (* source text line number of item in this node *)
END;
MarkList* = ARRAY maxNodes DIV Sets.size OF SET;
FirstSets = ARRAY maxNt OF RECORD
ts: Set; (*terminal symbols*)
ready: BOOLEAN; (*TRUE = ts is complete*)
END;
FollowSets = ARRAY maxNt OF RECORD
ts: Set; (*terminal symbols*)
nts: Set; (*nts whose start set is to be included*)
END;
CharClass = RECORD
name: Name; (*class name*)
set: INTEGER (* ptr to set representing the class*)
END;
SymbolTable = ARRAY maxSymbols OF SymbolNode;
ClassTable = ARRAY maxClasses OF CharClass;
GraphList = ARRAY maxNodes OF GraphNode;
VAR
maxSet*: INTEGER; (* index of last set *)
maxT*: INTEGER; (* terminals stored from 0 .. maxT *)
maxP*: INTEGER; (* pragmas stored from maxT+1 .. maxP *)
firstNt*: INTEGER; (* index of first nt: available after CompSymbolSets *)
lastNt*: INTEGER; (* index of last nt: available after CompSymbolSets *)
maxC*: INTEGER; (* index of last character class *)
semDeclPos*: Position; (*position of global semantic declarations*)
importPos*: Position; (*position of imported identifiers*)
ignored*: Set; (* characters ignored by the scanner *)
ignoreCase*: BOOLEAN; (* TRUE: scanner treats lower case as upper case*)
ddt*: ARRAY 10 OF BOOLEAN; (* debug and test switches *)
nNodes*: INTEGER; (* index of last graph node *)
root*: INTEGER; (* index of root node, filled by ATG *)
w: Texts.Writer;
st: SymbolTable;
gn: GraphList;
first: FirstSets; (*first[i] = first symbols of st[i+firstNt]*)
follow: FollowSets; (*follow[i] = followers of st[i+firstNt]*)
chClass: ClassTable; (*character classes*)
set: ARRAY 128 OF Set; (*set[0] reserved for union of all synchronisation sets*)
dummyName: INTEGER; (*for unnamed character classes*)
PROCEDURE ^MovePragmas;
PROCEDURE ^DelNode*(gn: GraphNode): BOOLEAN;
PROCEDURE Str(s: ARRAY OF CHAR);
BEGIN Texts.WriteString(w, s)
END Str;
PROCEDURE NL;
BEGIN Texts.WriteLn(w)
END NL;
PROCEDURE Length(s: ARRAY OF CHAR): INTEGER;
VAR i: INTEGER;
BEGIN
i:=0; WHILE (i < LEN(s)) & (s[i] # 0X) DO INC(i) END;
RETURN i
END Length;
PROCEDURE Restriction(n: INTEGER);
BEGIN
NL; Str("Restriction "); Texts.WriteInt(w, n, 0); NL; Texts.Append(Oberon.Log, w.buf);
HALT(99)
END Restriction;
PROCEDURE ClearMarkList(VAR m: MarkList);
VAR i: INTEGER;
BEGIN
i := 0; WHILE i < maxNodes DIV Sets.size DO m[i] := {}; INC(i) END;
END ClearMarkList;
PROCEDURE GetNode*(gp: INTEGER; VAR n: GraphNode);
BEGIN
n := gn[gp]
END GetNode;
PROCEDURE PutNode*(gp: INTEGER; n: GraphNode);
BEGIN gn[gp] := n
END PutNode;
PROCEDURE DelGraph*(gp: INTEGER): BOOLEAN;
VAR gn: GraphNode;
BEGIN
IF gp = 0 THEN RETURN TRUE END; (*end of graph found*)
GetNode(gp, gn);
RETURN DelNode(gn) & DelGraph(ABS(gn.next));
END DelGraph;
PROCEDURE NewSym*(typ: INTEGER; name: Name; line: INTEGER): INTEGER;
VAR i: INTEGER;
BEGIN
IF maxT + 1 = firstNt THEN Restriction(6)
ELSE
CASE typ OF
| t: INC(maxT); i := maxT
| pr: DEC(maxP); DEC(firstNt); DEC(lastNt); i := maxP
| nt: DEC(firstNt); i := firstNt
END;
IF maxT >= maxTerminals THEN Restriction(6) END;
st[i].typ := typ; st[i].name := name;
st[i].struct := 0; st[i].deletable := FALSE;
st[i].attrPos.beg := -1;
st[i].semPos.beg := -1;
st[i].line := line
END;
RETURN i
END NewSym;
PROCEDURE GetSym*(sp: INTEGER; VAR sn: SymbolNode);
BEGIN sn := st[sp]
END GetSym;
PROCEDURE PutSym*(sp: INTEGER; sn: SymbolNode);
BEGIN st[sp] := sn
END PutSym;
PROCEDURE FindSym*(name: Name): INTEGER;
VAR i: INTEGER;
BEGIN
i := 0; (*search in terminal list*)
WHILE (i <= maxT) & (st[i].name # name) DO INC(i) END;
IF i <= maxT THEN RETURN i END;
i := firstNt; (*search in nonterminal/pragma list*)
WHILE (i < maxSymbols) & (st[i].name # name) DO INC(i) END;
IF i < maxSymbols THEN RETURN i ELSE RETURN noSym END
END FindSym;
PROCEDURE NewSet*(s: Set): INTEGER;
BEGIN
INC(maxSet); IF maxSet > maxSetNr THEN Restriction(4) END;
set[maxSet] := s;
RETURN maxSet
END NewSet;
PROCEDURE PrintSet(s: ARRAY OF SET; indent: INTEGER);
CONST maxLineLen = 80;
VAR col, i, len: INTEGER; empty: BOOLEAN; sn: SymbolNode;
BEGIN
i := 0; col := indent; empty := TRUE;
WHILE i <= maxT DO
IF Sets.In(s, i) THEN
empty := FALSE; GetSym(i, sn); len := Length(sn.name);
IF col + len + 2 > maxLineLen THEN
NL; col := 1;
WHILE col < indent DO Texts.Write(w, " "); INC(col) END
END;
Str(sn.name); Str(" ");
INC(col, len + 2)
END;
INC(i)
END;
IF empty THEN Str("-- empty set --") END;
NL; Texts.Append(Oberon.Log, w.buf)
END PrintSet;
PROCEDURE CompFirstSet*(gp: INTEGER; VAR fs: Set);
VAR visited: MarkList;
PROCEDURE CompFirst(gp: INTEGER; VAR fs: Set);
VAR s: Set; gn: GraphNode; sn: SymbolNode;
BEGIN
Sets.Clear(fs);
WHILE (gp # 0) & ~ Sets.In(visited, gp) DO
GetNode(gp, gn); Sets.Incl(visited, gp);
CASE gn.typ OF
| nt:
IF first[gn.p1 - firstNt].ready THEN
Sets.Unite(fs, first[gn.p1 - firstNt].ts);
ELSE
GetSym(gn.p1, sn); CompFirst(sn.struct, s); Sets.Unite(fs, s);
END;
| t, wt: Sets.Incl(fs, gn.p1);
| any: Sets.Unite(fs, set[gn.p1])
| alt, iter, opt:
CompFirst(gn.p1, s); Sets.Unite(fs, s);
IF gn.typ = alt THEN CompFirst(gn.p2, s); Sets.Unite(fs, s) END
ELSE (* eps, sem, sync: nothing *)
END;
IF ~ DelNode(gn) THEN RETURN END;
gp := ABS(gn.next)
END
END CompFirst;
BEGIN (* ComputeFirstSet *)
ClearMarkList(visited);
CompFirst(gp, fs);
IF ddt[3] THEN
NL; Str("ComputeFirstSet: gp = "); Texts.WriteInt(w, gp, 0); NL;
PrintSet(fs, 0);
END;
END CompFirstSet;
PROCEDURE CompFirstSets;
VAR i: INTEGER; sn: SymbolNode;
BEGIN
i := firstNt; WHILE i <= lastNt DO first[i-firstNt].ready := FALSE; INC(i) END;
i := firstNt;
WHILE i <= lastNt DO (* for all nonterminals *)
GetSym(i, sn); CompFirstSet(sn.struct, first[i - firstNt].ts);
first[i - firstNt].ready := TRUE;
INC(i)
END;
END CompFirstSets;
PROCEDURE CompExpected*(gp, sp: INTEGER; VAR exp: Set);
BEGIN
CompFirstSet(gp, exp);
IF DelGraph(gp) THEN Sets.Unite(exp, follow[sp - firstNt].ts) END
END CompExpected;
PROCEDURE CompFollowSets;
VAR sn: SymbolNode; gn: GraphNode; curSy, i, size: INTEGER; visited: MarkList;
PROCEDURE CompFol(gp: INTEGER);
VAR s: Set; gn: GraphNode;
BEGIN
WHILE (gp > 0) & ~ Sets.In(visited, gp) DO
GetNode(gp, gn); Sets.Incl(visited, gp);
IF gn.typ = nt THEN
CompFirstSet(ABS(gn.next), s); Sets.Unite(follow[gn.p1 - firstNt].ts, s);
IF DelGraph(ABS(gn.next)) THEN
Sets.Incl(follow[gn.p1 - firstNt].nts, curSy - firstNt)
END
ELSIF gn.typ IN {opt, iter} THEN CompFol(gn.p1)
ELSIF gn.typ = alt THEN CompFol(gn.p1); CompFol(gn.p2)
END;
gp := gn.next
END
END CompFol;
PROCEDURE Complete(i: INTEGER);
VAR j: INTEGER;
BEGIN
IF Sets.In(visited, i) THEN RETURN END;
Sets.Incl(visited, i);
j := 0;
WHILE j <= lastNt - firstNt DO (* for all nonterminals *)
IF Sets.In(follow[i].nts, j) THEN
Complete(j); Sets.Unite(follow[i].ts, follow[j].ts);
Sets.Excl(follow[i].nts, j)
END;
INC(j)
END;
END Complete;
BEGIN (* CompFollowSets *)
curSy := firstNt; size := (lastNt - firstNt + 2) DIV Sets.size;
WHILE curSy <= lastNt + 1 DO (* also for dummy root nt*)
Sets.Clear(follow[curSy - firstNt].ts);
i := 0; WHILE i <= size DO follow[curSy - firstNt].nts[i] := {}; INC(i) END;
INC(curSy)
END;
curSy := firstNt; (*get direct successors of nonterminals*)
WHILE curSy <= lastNt DO
GetSym(curSy, sn); ClearMarkList(visited); CompFol(sn.struct);
INC(curSy)
END;
CompFol(root); (*curSy=lastNt+1*)
curSy := 0; (*add indirect successors to follow.ts*)
WHILE curSy <= lastNt - firstNt DO
ClearMarkList(visited); Complete(curSy);
INC(curSy);
END;
END CompFollowSets;
PROCEDURE CompAnySets;
VAR curSy, i: INTEGER; sn: SymbolNode;
PROCEDURE LeadingAny(gp: INTEGER; VAR a: GraphNode): BOOLEAN;
VAR gn: GraphNode;
BEGIN
IF gp <= 0 THEN RETURN FALSE END;
GetNode(gp, gn);
IF (gn.typ = any) THEN a := gn; RETURN TRUE
ELSE RETURN (gn.typ = alt) & (LeadingAny(gn.p1, a) OR LeadingAny(gn.p2, a))
OR (gn.typ IN {opt, iter}) & LeadingAny(gn.p1, a)
OR DelNode(gn) & LeadingAny(gn.next, a)
END
END LeadingAny;
PROCEDURE FindAS(gp: INTEGER);
VAR gn, gn2, a: GraphNode; s1, s2: Set; p: INTEGER;
BEGIN
WHILE gp > 0 DO
GetNode(gp, gn);
IF gn.typ IN {opt, iter} THEN
FindAS(gn.p1);
IF LeadingAny(gn.p1, a) THEN
CompFirstSet(ABS(gn.next), s1); Sets.Differ(set[a.p1], s1)
END
ELSIF gn.typ = alt THEN
p := gp; Sets.Clear(s1);
WHILE p # 0 DO
GetNode(p, gn2); FindAS(gn2.p1);
IF LeadingAny(gn2.p1, a) THEN
CompFirstSet(gn2.p2, s2); Sets.Unite(s2, s1); Sets.Differ(set[a.p1], s2)
ELSE
CompFirstSet(gn2.p1, s2); Sets.Unite(s1, s2)
END;
p := gn2.p2
END
END;
gp := gn.next
END
END FindAS;
BEGIN
curSy := firstNt;
WHILE curSy <= lastNt DO (* for all nonterminals *)
GetSym(curSy, sn); FindAS(sn.struct);
INC(curSy)
END
END CompAnySets;
PROCEDURE CompSyncSets;
VAR curSy, i: INTEGER; sn: SymbolNode; visited: MarkList;
PROCEDURE CompSync(gp: INTEGER);
VAR s: Set; gn: GraphNode;
BEGIN
WHILE (gp > 0) & ~ Sets.In(visited, gp) DO
GetNode(gp, gn); Sets.Incl(visited, gp);
IF gn.typ = sync THEN
CompExpected(ABS(gn.next), curSy, s);
Sets.Incl(s, eofSy); Sets.Unite(set[0], s);
gn.p1 := NewSet(s); PutNode(gp, gn)
ELSIF gn.typ = alt THEN CompSync(gn.p1); CompSync(gn.p2)
ELSIF gn.typ IN {iter, opt} THEN CompSync(gn.p1)
END;
gp := gn.next
END
END CompSync;
BEGIN
curSy := firstNt; ClearMarkList(visited);
WHILE curSy <= lastNt DO
GetSym(curSy, sn); CompSync(sn.struct);
INC(curSy);
END
END CompSyncSets;
PROCEDURE CompDeletableSymbols*;
VAR changed, del: BOOLEAN; i: INTEGER; sn: SymbolNode;
BEGIN
del := FALSE;
REPEAT
changed := FALSE;
i := firstNt;
WHILE i <= lastNt DO (*for all nonterminals*)
GetSym(i, sn);
IF ~sn.deletable & DelGraph(sn.struct) THEN
sn.deletable := TRUE; PutSym(i, sn); changed := TRUE; del := TRUE
END;
INC(i)
END;
UNTIL ~changed;
i := firstNt; IF del THEN NL END;
WHILE i <= lastNt DO
GetSym(i, sn);
IF sn.deletable THEN Str(" "); Str(sn.name); Str(" deletable"); NL END;
INC(i);
END;
Texts.Append(Oberon.Log, w.buf)
END CompDeletableSymbols;
PROCEDURE CompSymbolSets*;
VAR i: INTEGER; sn: SymbolNode;
BEGIN
i := NewSym(t, "???", 0); (*unknown symbols get code maxT*)
MovePragmas;
CompDeletableSymbols;
CompFirstSets;
CompFollowSets;
CompAnySets;
CompSyncSets;
IF ddt[1] THEN
i := firstNt; Str("First & follow symbols:"); NL;
WHILE i <= lastNt DO (* for all nonterminals *)
GetSym(i, sn); Str(sn.name); NL;
Str("first: "); PrintSet(first[i - firstNt].ts, 10);
Str("follow: "); PrintSet(follow[i - firstNt].ts, 10);
NL;
INC(i);
END;
IF maxSet >= 0 THEN NL; NL; Str("List of sets (ANY, SYNC): "); NL END;
i := 0;
WHILE i <= maxSet DO
Str(" set["); Texts.WriteInt (w, i, 2); Str("] = "); PrintSet(set[i], 16);
INC (i)
END;
NL; NL; Texts.Append(Oberon.Log, w.buf)
END;
END CompSymbolSets;
PROCEDURE GetFirstSet(sp: INTEGER; VAR s: Set);
BEGIN s := first[sp - firstNt].ts
END GetFirstSet;
PROCEDURE GetFollowSet(sp: INTEGER; VAR s: Set);
BEGIN s := follow[sp - firstNt].ts
END GetFollowSet;
PROCEDURE GetSet*(nr: INTEGER; VAR s: Set);
BEGIN s := set[nr]
END GetSet;
PROCEDURE MovePragmas;
VAR i: INTEGER;
BEGIN
IF maxP > firstNt THEN
i := maxSymbols - 1; maxP := maxT;
WHILE i > lastNt DO
INC(maxP); IF maxP >= firstNt THEN Restriction(6) END;
st[maxP] := st[i]; DEC(i)
END;
END
END MovePragmas;
PROCEDURE PrintSymbolTable*;
VAR i, j: INTEGER;
PROCEDURE WriteTyp(typ: INTEGER);
BEGIN
CASE typ OF
| t : Str(" t ");
| pr : Str(" pr ");
| nt : Str(" nt ");
END;
END WriteTyp;
BEGIN (* PrintSymbolTable *)
Str("Symbol Table:"); NL; NL;
Str("nr name typ hasAttribs struct del line"); NL; NL;
i := 0;
WHILE i < maxSymbols DO
Texts.WriteInt(w, i, 3); Str(" ");
j := 0; WHILE (j < 8) & (st[i].name[j] # 0X) DO Texts.Write(w, st[i].name[j]); INC(j) END;
WHILE j < 8 DO Texts.Write(w, " "); INC(j) END;
WriteTyp(st[i].typ);
IF st[i].attrPos.beg >= 0 THEN Str(" TRUE ") ELSE Str(" FALSE") END;
Texts.WriteInt(w, st[i].struct, 10);
IF st[i].deletable THEN Str(" TRUE ") ELSE Str(" FALSE") END;
Texts.WriteInt(w, st[i].line, 6); NL;
IF i = maxT THEN i := firstNt ELSE INC(i) END
END;
NL; NL; Texts.Append(Oberon.Log, w.buf)
END PrintSymbolTable;
PROCEDURE NewClass*(name: Name; set: Set): INTEGER;
BEGIN
INC(maxC); IF maxC >= maxClasses THEN Restriction(7) END;
IF name[0] = "#" THEN name[1] := CHR(ORD("A") + dummyName); INC(dummyName) END;
chClass[maxC].name := name; chClass[maxC].set := NewSet(set);
RETURN maxC
END NewClass;
PROCEDURE ClassWithName*(name: Name): INTEGER;
VAR i: INTEGER;
BEGIN
i := maxC; WHILE (i >= 0) & (chClass[i].name # name) DO DEC(i) END;
RETURN i
END ClassWithName;
PROCEDURE ClassWithSet*(s: Set): INTEGER;
VAR i: INTEGER;
BEGIN
i := maxC; WHILE (i >= 0) & ~ Sets.Equal(set[chClass[i].set], s) DO DEC(i) END;
RETURN i
END ClassWithSet;
PROCEDURE GetClass*(n: INTEGER; VAR s: Set);
BEGIN
GetSet(chClass[n].set, s)
END GetClass;
PROCEDURE GetClassName*(n: INTEGER; VAR name: Name);
BEGIN
name := chClass[n].name
END GetClassName;
PROCEDURE XRef*;
CONST maxLineLen = 80;
TYPE ListPtr = POINTER TO ListNode;
ListNode = RECORD
next: ListPtr;
line: INTEGER;
END;
ListHdr = RECORD
name: Name;
lptr: ListPtr;
END;
VAR gn: GraphNode; col, i, j: INTEGER; l, p, q: ListPtr;
sn: SymbolNode;
xList: ARRAY maxSymbols OF ListHdr;
BEGIN (* XRef *)
IF maxT <= 0 THEN RETURN END;
MovePragmas;
(* initialise cross reference list *)
i := 0;
WHILE i <= lastNt DO (* for all symbols *)
GetSym(i, sn); xList[i].name := sn.name; xList[i].lptr := NIL;
IF i = maxP THEN i := firstNt ELSE INC(i) END
END;
(* search lines where symbol has been referenced *)
i := 1;
WHILE i <= nNodes DO (* for all graph nodes *)
GetNode(i, gn);
IF gn.typ IN {t, wt, nt} THEN
NEW(l); l^.next := xList[gn.p1].lptr; l^.line := gn.line;
xList[gn.p1].lptr := l
END;
INC(i);
END;
(* search lines where symbol has been defined and insert in order *)
i := 1;
WHILE i <= lastNt DO (*for all symbols*)
GetSym(i, sn); p := xList[i].lptr; q := NIL;
WHILE (p # NIL) & (p^.line > sn.line) DO q := p; p := p^.next END;
NEW(l); l^.next := p;
l^.line := -sn.line;
IF q # NIL THEN q^.next := l ELSE xList[i].lptr := l END;
IF i = maxP THEN i := firstNt ELSE INC(i) END
END;
(* print cross reference listing *)
NL; Str("Cross reference list:"); NL; NL; Str("Terminals:"); NL; Str(" 0 EOF"); NL;
i := 1;
WHILE i <= lastNt DO (*for all symbols*)
Texts.WriteInt(w, i, 3); Str(" ");
j := 0; WHILE (j < 15) & (xList[i].name[j] # 0X) DO Texts.Write(w, xList[i].name[j]); INC(j) END;
l := xList[i].lptr; col := 25;
WHILE l # NIL DO
IF col + 5 > maxLineLen THEN
NL; col := 0; WHILE col < 25 DO Texts.Write(w, " "); INC(col) END
END;
IF l^.line = 0 THEN Str("undef") ELSE Texts.WriteInt(w, l^.line, 5) END;
INC(col, 5);
l := l^.next
END;
NL;
IF i = maxT THEN NL; Str("Pragmas:"); NL END;
IF i = maxP THEN NL; Str("Nonterminals:"); NL; i := firstNt ELSE INC(i) END
END;
NL; NL; Texts.Append(Oberon.Log, w.buf)
END XRef;
PROCEDURE NewNode*(typ, p1, line: INTEGER): INTEGER;
BEGIN
INC(nNodes); IF nNodes > maxNodes THEN Restriction(3) END;
gn[nNodes].typ := typ; gn[nNodes].next := 0;
gn[nNodes].p1 := p1; gn[nNodes].p2 := 0;
gn[nNodes].pos.beg := -1; gn[nNodes].line := line;
RETURN nNodes;
END NewNode;
PROCEDURE CompleteGraph*(gp: INTEGER);
VAR p: INTEGER;
BEGIN
WHILE gp # 0 DO
p := gn[gp].next; gn[gp].next := 0; gp := p
END
END CompleteGraph;
PROCEDURE ConcatAlt*(VAR gL1, gR1: INTEGER; gL2, gR2: INTEGER);
VAR p: INTEGER;
BEGIN
gL2 := NewNode(alt, gL2, 0);
p := gL1; WHILE gn[p].p2 # 0 DO p := gn[p].p2 END; gn[p].p2 := gL2;
p := gR1; WHILE gn[p].next # 0 DO p := gn[p].next END; gn[p].next := gR2
END ConcatAlt;
PROCEDURE ConcatSeq*(VAR gL1, gR1: INTEGER; gL2, gR2: INTEGER);
VAR p, q: INTEGER;
BEGIN
p := gn[gR1].next; gn[gR1].next := gL2; (*head node*)
WHILE p # 0 DO (*substructure*)
q := gn[p].next; gn[p].next := -gL2; p := q
END;
gR1 := gR2
END ConcatSeq;
PROCEDURE MakeFirstAlt*(VAR gL, gR: INTEGER);
BEGIN
gL := NewNode(alt, gL, 0); gn[gL].next := gR; gR := gL
END MakeFirstAlt;
PROCEDURE MakeIteration*(VAR gL, gR: INTEGER);
VAR p, q: INTEGER;
BEGIN
gL := NewNode(iter, gL, 0); p := gR; gR := gL;
WHILE p # 0 DO
q := gn[p].next; gn[p].next := - gL; p := q
END
END MakeIteration;
PROCEDURE MakeOption*(VAR gL, gR: INTEGER);
BEGIN
gL := NewNode(opt, gL, 0); gn[gL].next := gR; gR := gL
END MakeOption;
PROCEDURE StrToGraph*(str: ARRAY OF CHAR; VAR gL, gR: INTEGER);
VAR len, i: INTEGER;
BEGIN
gR := 0; i := 1; len := Length(str) - 1;
WHILE i < len DO
gn[gR].next := NewNode(char, ORD(str[i]), 0); gR := gn[gR].next;
INC(i)
END;
gL := gn[0].next; gn[0].next := 0
END StrToGraph;
PROCEDURE DelNode*(gn: GraphNode): BOOLEAN;
VAR sn: SymbolNode;
PROCEDURE DelAlt(gp: INTEGER): BOOLEAN;
VAR gn: GraphNode;
BEGIN
IF gp <= 0 THEN RETURN TRUE END; (*end of graph found*)
GetNode(gp, gn);
RETURN DelNode(gn) & DelAlt(gn.next);
END DelAlt;
BEGIN
IF gn.typ = nt THEN GetSym(gn.p1, sn); RETURN sn.deletable
ELSIF gn.typ = alt THEN RETURN DelAlt(gn.p1) OR (gn.p2 # 0) & DelAlt(gn.p2)
ELSE RETURN gn.typ IN {eps, iter, opt, sem, sync}
END
END DelNode;
PROCEDURE PrintGraph*;
VAR i: INTEGER;
PROCEDURE WriteTyp(typ: INTEGER);
BEGIN
CASE typ OF
| nt : Str("nt ")
| t : Str("t ")
| wt : Str("wt ")
| any : Str("any ")
| eps : Str("eps ")
| sem : Str("sem ")
| sync: Str("sync")
| alt : Str("alt ")
| iter: Str("iter")
| opt : Str("opt ")
ELSE Str("--- ")
END;
END WriteTyp;
BEGIN (* PrintGraph *)
Str("GraphList:"); NL; NL;
Str(" nr typ next p1 p2 line"); NL; NL;
i := 0;
WHILE i <= nNodes DO
Texts.WriteInt(w, i, 3); Str(" ");
WriteTyp(gn[i].typ); Texts.WriteInt(w, gn[i].next, 7);
Texts.WriteInt(w, gn[i].p1, 7);
Texts.WriteInt(w, gn[i].p2, 7);
Texts.WriteInt(w, gn[i].line, 7);
NL;
INC(i);
END;
NL; NL; Texts.Append(Oberon.Log, w.buf)
END PrintGraph;
PROCEDURE FindCircularProductions* (VAR ok: BOOLEAN);
CONST maxList = 150;
TYPE ListEntry = RECORD
left : INTEGER;
right : INTEGER;
deleted: BOOLEAN;
END;
VAR changed, onLeftSide, onRightSide: BOOLEAN; i, j, listLength: INTEGER;
list: ARRAY maxList OF ListEntry;
singles: MarkList;
sn: SymbolNode;
PROCEDURE GetSingles (gp: INTEGER; VAR singles: MarkList);
VAR gn: GraphNode;
BEGIN
IF gp <= 0 THEN RETURN END; (* end of graph found *)
GetNode (gp, gn);
IF gn.typ = nt THEN
IF DelGraph(ABS(gn.next)) THEN Sets.Incl(singles, gn.p1) END
ELSIF gn.typ IN {alt, iter, opt} THEN
IF DelGraph(ABS(gn.next)) THEN
GetSingles(gn.p1, singles);
IF gn.typ = alt THEN GetSingles(gn.p2, singles) END
END
END;
IF DelNode(gn) THEN GetSingles(gn.next, singles) END
END GetSingles;
BEGIN (* FindCircularProductions *)
i := firstNt; listLength := 0;
WHILE i <= lastNt DO (* for all nonterminals i *)
ClearMarkList (singles); GetSym (i, sn);
GetSingles (sn.struct, singles); (* get nt's j such that i-->j *)
j := firstNt;
WHILE j <= lastNt DO (* for all nonterminals j *)
IF Sets.In(singles, j) THEN
list[listLength].left := i; list[listLength].right := j;
list[listLength].deleted := FALSE;
INC (listLength)
END;
INC(j)
END;
INC(i)
END;
REPEAT
i := 0; changed := FALSE;
WHILE i < listLength DO
IF ~ list[i].deleted THEN
j := 0; onLeftSide := FALSE; onRightSide := FALSE;
WHILE j < listLength DO
IF ~ list[j].deleted THEN
IF list[i].left = list[j].right THEN onRightSide := TRUE END;
IF list[j].left = list[i].right THEN onLeftSide := TRUE END
END;
INC(j)
END;
IF ~ onRightSide OR ~ onLeftSide THEN
list[i].deleted := TRUE; changed := TRUE
END
END;
INC(i)
END
UNTIL ~ changed;
i := 0; ok := TRUE;
WHILE i < listLength DO
IF ~ list[i].deleted THEN
ok := FALSE;
GetSym(list[i].left, sn); NL; Str(" "); Str(sn.name); Str(" --> ");
GetSym(list[i].right, sn); Str(sn.name)
END;
INC(i)
END;
Texts.Append(Oberon.Log, w.buf)
END FindCircularProductions;
PROCEDURE LL1Test* (VAR ll1: BOOLEAN);
VAR sn: SymbolNode; curSy: INTEGER;
PROCEDURE LL1Error (cond, ts: INTEGER);
VAR sn: SymbolNode;
BEGIN
ll1 := FALSE;
GetSym (curSy, sn); Str(" LL1 error in "); Str(sn.name); Str(": ");
IF ts > 0 THEN GetSym (ts, sn); Str(sn.name); Str(" is ") END;
CASE cond OF
1: Str(" start of several alternatives.")
| 2: Str(" start & successor of deletable structure")
| 3: Str(" an ANY node that matchs no symbol")
END;
NL; Texts.Append(Oberon.Log, w.buf)
END LL1Error;
PROCEDURE Check (cond: INTEGER; VAR s1, s2: Set);
VAR i: INTEGER;
BEGIN
i := 0;
WHILE i <= maxT DO
IF Sets.In(s1, i) & Sets.In(s2, i) THEN LL1Error(cond, i) END;
INC(i)
END
END Check;
PROCEDURE CheckAlternatives (gp: INTEGER);
VAR gn, gn1: GraphNode; s1, s2: Set; p: INTEGER;
BEGIN
WHILE gp > 0 DO
GetNode(gp, gn);
IF gn.typ = alt THEN
p := gp; Sets.Clear(s1);
WHILE p # 0 DO (*for all alternatives*)
GetNode(p, gn1); CompExpected(gn1.p1, curSy, s2);
Check(1, s1, s2); Sets.Unite(s1, s2);
CheckAlternatives(gn1.p1);
p := gn1.p2
END
ELSIF gn.typ IN {opt, iter} THEN
CompExpected(gn.p1, curSy, s1);
CompExpected(ABS(gn.next), curSy, s2);
Check(2, s1, s2);
CheckAlternatives(gn.p1)
ELSIF gn.typ = any THEN
GetSet(gn.p1, s1);
IF Sets.Empty(s1) THEN LL1Error(3, 0) END (*e.g. {ANY} ANY or [ANY] ANY*)
END;
gp := gn.next
END
END CheckAlternatives;
BEGIN (* LL1Test *)
curSy := firstNt; ll1 := TRUE;
WHILE curSy <= lastNt DO (*for all nonterminals*)
GetSym(curSy, sn); CheckAlternatives (sn.struct);
INC (curSy)
END;
END LL1Test;
PROCEDURE TestCompleteness* (VAR ok: BOOLEAN);
VAR sp: INTEGER; sn: SymbolNode;
BEGIN
sp := firstNt; ok := TRUE;
WHILE sp <= lastNt DO (*for all nonterminals*)
GetSym (sp, sn);
IF sn.struct = 0 THEN
ok := FALSE; NL; Str(" No production for "); Str(sn.name); Texts.Append(Oberon.Log, w.buf)
END;
INC(sp)
END
END TestCompleteness;
PROCEDURE TestIfAllNtReached* (VAR ok: BOOLEAN);
VAR gn: GraphNode; sp: INTEGER; reached: MarkList; sn: SymbolNode;
PROCEDURE MarkReachedNts (gp: INTEGER);
VAR gn: GraphNode; sn: SymbolNode;
BEGIN
WHILE gp > 0 DO
GetNode(gp, gn);
IF gn.typ = nt THEN
IF ~ Sets.In(reached, gn.p1) THEN (*new nt reached*)
Sets.Incl(reached, gn.p1);
GetSym(gn.p1, sn); MarkReachedNts(sn.struct)
END
ELSIF gn.typ IN {alt, iter, opt} THEN
MarkReachedNts(gn.p1);
IF gn.typ = alt THEN MarkReachedNts(gn.p2) END
END;
gp := gn.next
END
END MarkReachedNts;
BEGIN (* TestIfAllNtReached *)
ClearMarkList(reached);
GetNode(root, gn); Sets.Incl(reached, gn.p1);
GetSym(gn.p1, sn); MarkReachedNts(sn.struct);
sp := firstNt; ok := TRUE;
WHILE sp <= lastNt DO (*for all nonterminals*)
IF ~ Sets.In(reached, sp) THEN
ok := FALSE; GetSym(sp, sn); NL; Str(" "); Str(sn.name); Str(" cannot be reached")
END;
INC(sp)
END;
Texts.Append(Oberon.Log, w.buf)
END TestIfAllNtReached;
PROCEDURE TestIfNtToTerm* (VAR ok: BOOLEAN);
VAR changed: BOOLEAN; gn: GraphNode; sp: INTEGER;
sn: SymbolNode;
termList: MarkList;
PROCEDURE IsTerm (gp: INTEGER): BOOLEAN;
VAR gn: GraphNode;
BEGIN
WHILE gp > 0 DO
GetNode(gp, gn);
IF (gn.typ = nt) & ~ Sets.In(termList, gn.p1)
OR (gn.typ = alt) & ~ IsTerm(gn.p1) & ~ IsTerm(gn.p2) THEN RETURN FALSE
END;
gp := gn.next
END;
RETURN TRUE
END IsTerm;
BEGIN (* TestIfNtToTerm *)
ClearMarkList(termList);
REPEAT
sp := firstNt; changed := FALSE;
WHILE sp <= lastNt DO
IF ~ Sets.In(termList, sp) THEN
GetSym(sp, sn);
IF IsTerm(sn.struct) THEN Sets.Incl(termList, sp); changed := TRUE END
END;
INC(sp)
END
UNTIL ~changed;
sp := firstNt; ok := TRUE;
WHILE sp <= lastNt DO
IF ~ Sets.In(termList, sp) THEN
ok := FALSE; GetSym(sp, sn); NL; Str(" "); Str(sn.name); Str(" cannot be derived to terminals")
END;
INC(sp)
END;
Texts.Append(Oberon.Log, w.buf)
END TestIfNtToTerm;
PROCEDURE Init*;
BEGIN
maxSet := 0; Sets.Clear(set[0]); Sets.Incl(set[0], eofSy);
firstNt := maxSymbols; maxP := maxSymbols; maxT := -1; maxC := -1;
lastNt := maxP - 1;
dummyName := 0;
nNodes := 0
END Init;
BEGIN (* CRT *)
(* The dummy node gn[0] ensures that none of the procedures
above have to check for 0 indices. *)
nNodes := 0;
gn[0].typ := -1; gn[0].p1 := 0; gn[0].p2 := 0; gn[0].next := 0; gn[0].line := 0;
Texts.OpenWriter(w)
END CRT.

474
src/tools/coco/CRX.Mod Normal file
View file

@ -0,0 +1,474 @@
MODULE CRX; (* H.Moessenboeck 17.11.93 *)
IMPORT Oberon, Texts := CmdlnTexts, Sets, CRS, CRT, SYSTEM;
CONST
symSetSize = 100;
maxTerm = 3; (* sets of size < maxTerm are enumerated *)
tErr = 0; altErr = 1; syncErr = 2;
EOL = 0DX;
VAR
maxSS: INTEGER; (* number of symbol sets *)
errorNr: INTEGER; (* highest parser error number *)
curSy: INTEGER; (* symbol whose production is currently generated *)
err, w: Texts.Writer;
fram: Texts.Reader;
src: Texts.Reader;
syn: Texts.Writer;
scanner: ARRAY 32 OF CHAR;
symSet: ARRAY symSetSize OF CRT.Set;
PROCEDURE Restriction(n: INTEGER);
BEGIN
Texts.WriteLn(w); Texts.WriteString(w, "Restriction ");
Texts.WriteInt(w, n, 0); Texts.WriteLn(w); Texts.Append(Oberon.Log, w.buf);
HALT(99)
END Restriction;
PROCEDURE PutS(s: ARRAY OF CHAR);
VAR i: INTEGER;
BEGIN i := 0;
WHILE (i < LEN(s)) & (s[i] # 0X) DO
IF s[i] = "$" THEN Texts.WriteLn(syn) ELSE Texts.Write(syn, s[i]) END;
INC(i)
END
END PutS;
PROCEDURE PutI(i: INTEGER);
BEGIN Texts.WriteInt(syn, i, 0)
END PutI;
PROCEDURE Indent(n: INTEGER);
VAR i: INTEGER;
BEGIN i := 0; WHILE i < n DO Texts.Write(syn, " "); INC(i) END
END Indent;
PROCEDURE PutSet(s: SET);
VAR i: INTEGER; first: BOOLEAN;
BEGIN
i := 0; first := TRUE;
WHILE i < Sets.size DO
IF i IN s THEN
IF first THEN first := FALSE ELSE Texts.Write(syn, ",") END;
PutI(i)
END;
INC(i)
END
END PutSet;
PROCEDURE PutSet1(s: CRT.Set);
VAR i: INTEGER; first: BOOLEAN;
BEGIN
i := 0; first := TRUE;
WHILE i <= CRT.maxT DO
IF Sets.In(s, i) THEN
IF first THEN first := FALSE ELSE Texts.Write(syn, ",") END;
PutI(i)
END;
INC(i)
END
END PutSet1;
PROCEDURE Length*(s: ARRAY OF CHAR): INTEGER;
VAR i: INTEGER;
BEGIN
i:=0; WHILE (i < LEN(s)) & (s[i] # 0X) DO INC(i) END;
RETURN i
END Length;
PROCEDURE Alternatives(gp: INTEGER): INTEGER;
VAR gn: CRT.GraphNode; n: INTEGER;
BEGIN
n := 0;
WHILE gp > 0 DO
CRT.GetNode(gp, gn); gp := gn.p2; INC(n)
END;
RETURN n
END Alternatives;
PROCEDURE CopyFramePart (stopStr: ARRAY OF CHAR); (*Copy from file <fram> to file <syn> until <stopStr>*)
VAR ch, startCh: CHAR; i, j, high: INTEGER;
BEGIN
startCh := stopStr[0]; high := Length(stopStr) - 1; Texts.Read (fram, ch);
WHILE ch # 0X DO
IF ch = startCh THEN (* check if stopString occurs *)
i := 0;
REPEAT
IF i = high THEN RETURN END; (*stopStr[0..i] found; no unrecognized character*)
Texts.Read (fram, ch); INC(i);
UNTIL ch # stopStr[i];
(*stopStr[0..i-1] found; 1 unrecognized character*)
j := 0; WHILE j < i DO Texts.Write(syn, stopStr[j]); INC(j) END
ELSE Texts.Write (syn, ch); Texts.Read(fram, ch)
END
END
END CopyFramePart;
PROCEDURE CopySourcePart (pos: CRT.Position; indent: INTEGER);
(*Copy sequence <position> from <src> to <syn>*)
VAR ch: CHAR; i: INTEGER; nChars: LONGINT; r: Texts.Reader;
BEGIN
IF (pos.beg >= 0) & (pos.len > 0) THEN
Texts.OpenReader(r, CRS.src, pos.beg); Texts.Read(r, ch);
nChars := pos.len - 1;
Indent(indent);
LOOP
WHILE ch = EOL DO
Texts.WriteLn(syn); Indent(indent);
IF nChars > 0 THEN Texts.Read(r, ch); DEC(nChars) ELSE EXIT END;
i := pos.col;
WHILE (ch = " ") & (i > 0) DO (* skip blanks at beginning of line *)
IF nChars > 0 THEN Texts.Read(r, ch); DEC (nChars) ELSE EXIT END;
DEC(i)
END
END;
Texts.Write (syn, ch);
IF nChars > 0 THEN Texts.Read(r, ch); DEC (nChars) ELSE EXIT END
END
END
(* IF pos.beg >= 0 THEN
Texts.OpenReader(r, CRS.src, pos.beg);
nChars := pos.len; col := pos.col - 1; ch := " ";
WHILE (nChars > 0) & (ch = " ") DO (*skip leading blanks*)
Texts.Read(r, ch); DEC(nChars); INC(col)
END;
Indent(indent);
LOOP
WHILE ch = EOL DO
Texts.WriteLn(syn); Indent(indent);
IF nChars > 0 THEN Texts.Read(r, ch); DEC(nChars) ELSE EXIT END;
i := col - 1;
WHILE (ch = " ") & (i > 0) DO (* skip blanks at beginning of line *)
IF nChars > 0 THEN Texts.Read(r, ch); DEC (nChars) ELSE EXIT END;
DEC(i)
END
END;
Texts.Write (syn, ch);
IF nChars > 0 THEN Texts.Read(r, ch); DEC (nChars) ELSE EXIT END
END (* LOOP *)
END *)
END CopySourcePart;
PROCEDURE GenErrorMsg (errTyp, errSym: INTEGER; VAR errNr: INTEGER);
VAR i: INTEGER; name: ARRAY 32 OF CHAR; sn: CRT.SymbolNode;
BEGIN
INC (errorNr); errNr := errorNr;
CRT.GetSym (errSym, sn); COPY(sn.name, name);
i := 0; WHILE name[i] # 0X DO IF name[i] = CHR(34) THEN name[i] := "'" END; INC(i) END;
Texts.WriteString(err, " |");
Texts.WriteInt (err, errNr, 3); Texts.WriteString (err, ": Msg("); Texts.Write(err, CHR(34));
CASE errTyp OF
| tErr : Texts.WriteString (err, name); Texts.WriteString (err, " expected")
| altErr : Texts.WriteString (err, "invalid "); Texts.WriteString (err, name)
| syncErr: Texts.WriteString (err, "this symbol not expected in "); Texts.WriteString (err, name)
END;
Texts.Write(err, CHR(34)); Texts.Write(err, ")"); Texts.WriteLn(err)
END GenErrorMsg;
PROCEDURE NewCondSet (set: CRT.Set): INTEGER;
VAR i: INTEGER;
BEGIN
i := 1; (*skip symSet[0]*)
WHILE i <= maxSS DO
IF Sets.Equal(set, symSet[i]) THEN RETURN i END;
INC(i)
END;
INC(maxSS); IF maxSS > symSetSize THEN Restriction (9) END;
symSet[maxSS] := set;
RETURN maxSS
END NewCondSet;
PROCEDURE GenCond (set: CRT.Set);
VAR sx, i, n: INTEGER;
PROCEDURE Small(s: CRT.Set): BOOLEAN;
BEGIN
i := Sets.size;
WHILE i <= CRT.maxT DO
IF Sets.In(set, i) THEN RETURN FALSE END;
INC(i)
END;
RETURN TRUE
END Small;
BEGIN
n := Sets.Elements(set, i);
(*IF n = 0 THEN PutS(" FALSE") (*this branch should never be taken*)
ELSIF (n > 1) & Small(set) THEN
PutS(" sym IN {"); PutSet(set[0]); PutS("} ")
ELSIF n <= maxTerm THEN
i := 0;
WHILE i <= CRT.maxT DO
IF Sets.In (set, i) THEN
PutS(" (sym = "); PutI(i); Texts.Write(syn, ")");
DEC(n); IF n > 0 THEN PutS(" OR") END
END;
INC(i)
END
ELSE PutS(" sym IN symSet["); PutI(NewCondSet(set)); PutS(",0]")
END;*)
IF n = 0 THEN PutS(" FALSE") (*this branch should never be taken*)
ELSIF n <= maxTerm THEN
i := 0;
WHILE i <= CRT.maxT DO
IF Sets.In (set, i) THEN
PutS(" (sym = "); PutI(i); Texts.Write(syn, ")");
DEC(n); IF n > 0 THEN PutS(" OR") END
END;
INC(i)
END
ELSE PutS(" StartOf("); PutI(NewCondSet(set)); PutS(") ")
END;
END GenCond;
PROCEDURE GenCode (gp, indent: INTEGER; checked: CRT.Set);
VAR gn, gn2: CRT.GraphNode; sn: CRT.SymbolNode; gp2: INTEGER;
s1, s2: CRT.Set; errNr, alts: INTEGER; equal: BOOLEAN;
BEGIN
WHILE gp > 0 DO
CRT.GetNode (gp, gn);
CASE gn.typ OF
| CRT.nt:
Indent(indent);
CRT.GetSym(gn.p1, sn); PutS(sn.name);
IF gn.pos.beg >= 0 THEN
Texts.Write(syn, "("); CopySourcePart(gn.pos, 0); Texts.Write(syn, ")")
END;
PutS(";$")
| CRT.t:
CRT.GetSym(gn.p1, sn); Indent(indent);
IF Sets.In(checked, gn.p1) THEN
PutS("Get;$")
ELSE
PutS("Expect("); PutI(gn.p1); PutS(");$")
END
| CRT.wt:
CRT.CompExpected(ABS(gn.next), curSy, s1);
CRT.GetSet(0, s2); Sets.Unite(s1, s2);
CRT.GetSym(gn.p1, sn); Indent(indent);
PutS("ExpectWeak("); PutI(gn.p1); PutS(", "); PutI(NewCondSet(s1)); PutS(");$")
| CRT.any:
Indent(indent); PutS("Get;$")
| CRT.eps: (* nothing *)
| CRT.sem:
CopySourcePart(gn.pos, indent); PutS(";$");
| CRT.sync:
CRT.GetSet(gn.p1, s1);
GenErrorMsg (syncErr, curSy, errNr);
Indent(indent);
PutS("WHILE ~("); GenCond(s1); PutS(") DO Error(");
PutI(errNr); PutS("); Get END;$")
| CRT.alt:
CRT.CompFirstSet(gp, s1); equal := Sets.Equal(s1, checked);
alts := Alternatives(gp);
IF alts > 5 THEN Indent(indent); PutS("CASE sym OF$") END;
gp2 := gp;
WHILE gp2 # 0 DO
CRT.GetNode(gp2, gn2);
CRT.CompExpected(gn2.p1, curSy, s1);
Indent(indent);
IF alts > 5 THEN PutS("| "); PutSet1(s1); PutS(": ") (*case labels*)
ELSIF gp2 = gp THEN PutS("IF"); GenCond(s1); PutS(" THEN$")
ELSIF (gn2.p2 = 0) & equal THEN PutS("ELSE$")
ELSE PutS("ELSIF"); GenCond(s1); PutS(" THEN$")
END;
Sets.Unite(s1, checked);
GenCode(gn2.p1, indent + 2, s1);
gp2 := gn2.p2
END;
IF ~ equal THEN
GenErrorMsg(altErr, curSy, errNr);
Indent(indent); PutS("ELSE Error("); PutI(errNr); PutS(")$")
END;
Indent(indent); PutS("END;$")
| CRT.iter:
CRT.GetNode(gn.p1, gn2);
Indent(indent); PutS("WHILE");
IF gn2.typ = CRT.wt THEN
CRT.CompExpected(ABS(gn2.next), curSy, s1);
CRT.CompExpected(ABS(gn.next), curSy, s2);
CRT.GetSym(gn2.p1, sn);
PutS(" WeakSeparator("); PutI(gn2.p1); PutS(", "); PutI(NewCondSet(s1));
PutS(", "); PutI(NewCondSet(s2)); PutS(") ");
Sets.Clear(s1); (*for inner structure*)
IF gn2.next > 0 THEN gp2 := gn2.next ELSE gp2 := 0 END
ELSE
gp2 := gn.p1; CRT.CompFirstSet(gp2, s1); GenCond(s1)
END;
PutS(" DO$");
GenCode(gp2, indent + 2, s1);
Indent(indent); PutS("END;$")
| CRT.opt:
CRT.CompFirstSet(gn.p1, s1);
IF ~ Sets.Equal(checked, s1) THEN
Indent(indent); PutS("IF"); GenCond(s1); PutS(" THEN$");
GenCode(gn.p1, indent + 2, s1);
Indent(indent); PutS("END;$")
ELSE GenCode(gn.p1, indent, checked)
END
END; (*CASE*)
IF ~ (gn.typ IN {CRT.eps, CRT.sem, CRT.sync}) THEN Sets.Clear(checked) END;
gp := gn.next
END
END GenCode;
PROCEDURE GenCodePragmas;
VAR i, p: INTEGER; sn: CRT.SymbolNode;
PROCEDURE P(s1, s2: ARRAY OF CHAR);
BEGIN
PutS(" "); PutS(scanner); PutS(s1); PutS(" := "); PutS(scanner); PutS(s2); PutS(";$")
END P;
BEGIN
i := CRT.maxT + 1;
WHILE i <= CRT.maxP DO
CRT.GetSym(i, sn);
PutS(" IF sym = "); PutI(i); PutS(" THEN$"); CopySourcePart(sn.semPos, 9); PutS("$ END;$");
INC(i)
END;
P(".nextPos", ".pos"); P(".nextCol", ".col"); P(".nextLine", ".line"); P(".nextLen", ".len")
END GenCodePragmas;
PROCEDURE GenProcedureHeading (sn: CRT.SymbolNode; forward: BOOLEAN);
BEGIN
PutS("PROCEDURE ");
IF forward THEN Texts.Write(syn, "^") END;
PutS(sn.name);
IF sn.attrPos.beg >= 0 THEN
Texts.Write(syn, "("); CopySourcePart(sn.attrPos, 0); Texts.Write(syn, ")")
END;
PutS(";$")
END GenProcedureHeading;
PROCEDURE GenForwardRefs;
VAR sp: INTEGER; sn: CRT.SymbolNode;
BEGIN
IF ~ CRT.ddt[5] THEN
sp := CRT.firstNt;
WHILE sp <= CRT.lastNt DO (* for all nonterminals *)
CRT.GetSym (sp, sn); GenProcedureHeading(sn, TRUE);
INC(sp)
END;
Texts.WriteLn(syn)
END
END GenForwardRefs;
PROCEDURE GenProductions;
VAR sn: CRT.SymbolNode; checked: CRT.Set;
BEGIN
curSy := CRT.firstNt;
WHILE curSy <= CRT.lastNt DO (* for all nonterminals *)
CRT.GetSym (curSy, sn); GenProcedureHeading (sn, FALSE);
IF sn.semPos.beg >= 0 THEN CopySourcePart(sn.semPos, 2); PutS(" $") END;
PutS("BEGIN$"); Sets.Clear(checked);
GenCode (sn.struct, 2, checked);
PutS("END "); PutS(sn.name); PutS(";$$");
INC (curSy);
END;
END GenProductions;
PROCEDURE InitSets;
VAR i, j: INTEGER;
BEGIN
i := 0; CRT.GetSet(0, symSet[0]);
WHILE i <= maxSS DO
j := 0;
WHILE j <= CRT.maxT DIV Sets.size DO
PutS(" symSet["); PutI(i); PutS(", ");PutI(j);
PutS("] := {"); PutSet(symSet[i, j]); PutS("};$");
INC(j)
END;
INC(i)
END
END InitSets;
PROCEDURE *Show(t: Texts.Text; op: INTEGER; beg, end: LONGINT);
BEGIN END Show;
PROCEDURE GenCompiler*;
VAR errNr, i: INTEGER; checked: CRT.Set;
gn: CRT.GraphNode; sn: CRT.SymbolNode;
parser: ARRAY 32 OF CHAR;
t: Texts.Text; pos: LONGINT;
ch1, ch2: CHAR;
BEGIN
CRT.GetNode(CRT.root, gn); CRT.GetSym(gn.p1, sn);
COPY(sn.name, parser); i := Length(parser); parser[i] := "P"; parser[i+1] := 0X;
COPY(parser, scanner); scanner[i] := "S";
NEW(t); Texts.Open(t, "Parser.FRM"); Texts.OpenReader(fram, t, 0);
IF t.len = 0 THEN
Texts.WriteString(w, "Parser.FRM not found"); Texts.WriteLn(w);
Texts.Append(Oberon.Log, w.buf); HALT(99)
END;
Texts.OpenWriter(err); Texts.WriteLn(err);
i := 0;
WHILE i <= CRT.maxT DO GenErrorMsg(tErr, i, errNr); INC(i) END;
(*----- write *P.Mod -----*)
Texts.OpenWriter(syn);
NEW(t); (*t.notify := Show;*) Texts.Open(t, "");
CopyFramePart("-->modulename"); PutS(parser);
CopyFramePart("-->scanner"); PutS(scanner);
IF CRT.importPos.beg >= 0 THEN PutS(", "); CopySourcePart(CRT.importPos, 0) END;
CopyFramePart("-->constants");
PutS("maxP = "); PutI(CRT.maxP); PutS(";$");
PutS(" maxT = "); PutI(CRT.maxT); PutS(";$");
PutS(" nrSets = ;$"); Texts.Append(t, syn.buf); pos := t.len - 2;
CopyFramePart("-->declarations"); CopySourcePart(CRT.semDeclPos, 0);
CopyFramePart("-->errors"); PutS(scanner); PutS(".Error(n, "); PutS(scanner); PutS(".nextPos)");
CopyFramePart("-->scanProc");
IF CRT.maxT = CRT.maxP THEN PutS(scanner); PutS(".Get(sym)")
ELSE
PutS("LOOP "); PutS(scanner); PutS(".Get(sym);$");
PutS(" IF sym > maxT THEN$");
GenCodePragmas;
PutS(" ELSE EXIT$");
PutS(" END$");
PutS("END$")
END;
CopyFramePart("-->productions"); GenForwardRefs; GenProductions;
CopyFramePart("-->parseRoot"); Sets.Clear(checked); GenCode (CRT.root, 2, checked);
CopyFramePart("-->initialization"); InitSets;
CopyFramePart("-->modulename"); PutS(parser); Texts.Write(syn, ".");
Texts.Append(t, syn.buf); Texts.Append(t, err.buf);
PutI(maxSS+1); (*if no set, maxSS = -1*) Texts.Insert(t, pos, syn.buf);
i := Length(parser); parser[i] := "."; parser[i+1] := "M"; parser[i+2] := "o"; parser[i+3] := "d"; parser[i+4] := 0X;
Texts.Close(t, parser)
END GenCompiler;
PROCEDURE WriteStatistics*;
BEGIN
Texts.WriteInt (w, CRT.maxT + 1, 0); Texts.WriteString(w, " t, ");
Texts.WriteInt (w, CRT.maxSymbols - CRT.firstNt + CRT.maxT + 1, 0); Texts.WriteString(w, " syms, ");
Texts.WriteInt (w, CRT.nNodes, 0); Texts.WriteString(w, " nodes, ");
Texts.WriteInt (w, maxSS, 0); Texts.WriteString(w, "sets");
Texts.WriteLn(w); Texts.Append(Oberon.Log, w.buf)
END WriteStatistics;
PROCEDURE Init*;
BEGIN
errorNr := -1; maxSS := 0 (*symSet[0] reserved for all SYNC sets*)
END Init;
BEGIN
Texts.OpenWriter(w)
END CRX.

180
src/tools/coco/Coco.Mod Normal file
View file

@ -0,0 +1,180 @@
(* Implementation restrictions
3 too many nodes in graph (>1500) CRG.NewNode
4 too many sets (ANY-symbols or SYNC symbols) CRT.NewAnySet,
CRT.ComputeSyncSet
6 too many symbols (>300) CRT.NewSym
7 too many character classes (>50) CRT.NewClass
9 too many conditions in generated code (>100) CRX.NewCondSet
Trace output (ddt settings: ${digit})
0 Prints states of automaton
1 Prints start symbols and followers of nonterminals (also option /s)
2 Prints the internal graph
3 Trace of start symbol set computation
4 Trace of follow set computation
5 suppresses FORWARD declarations in parser (for multipass compilers)
6 Prints the symbol list
7 Prints a cross reference list (also option /x)
8 Write statistics
==========================================================================*)
MODULE Coco;
IMPORT Oberon, (*TextFrames,*) Texts := CmdlnTexts,(* Viewers,*) CRS, CRP, CRT;
CONST minErrDist = 8;
VAR w: Texts.Writer; lastErrPos: LONGINT;
PROCEDURE Error (n: INTEGER; pos: LONGINT);
PROCEDURE Msg (s: ARRAY OF CHAR);
BEGIN Texts.WriteString(w, s)
END Msg;
BEGIN
INC(CRS.errors);
IF pos < lastErrPos + minErrDist THEN lastErrPos := pos; RETURN END;
lastErrPos := pos;
Texts.WriteInt(w, pos, 3); Texts.WriteString(w, ": ");
IF n < 200 THEN
CASE n OF
| 0: Msg("EOF expected")
| 1: Msg("ident expected")
| 2: Msg("string expected")
| 3: Msg("number expected")
| 4: Msg("'COMPILER' expected")
| 5: Msg("'IMPORT' expected")
| 6: Msg("';' expected")
| 7: Msg("'PRODUCTIONS' expected")
| 8: Msg("'=' expected")
| 9: Msg("'.' expected")
| 10: Msg("'END' expected")
| 11: Msg("'CHARACTERS' expected")
| 12: Msg("'TOKENS' expected")
| 13: Msg("'PRAGMAS' expected")
| 14: Msg("'COMMENTS' expected")
| 15: Msg("'FROM' expected")
| 16: Msg("'TO' expected")
| 17: Msg("'NESTED' expected")
| 18: Msg("'IGNORE' expected")
| 19: Msg("'CASE' expected")
| 20: Msg("'+' expected")
| 21: Msg("'-' expected")
| 22: Msg("'CHR' expected")
| 23: Msg("'(' expected")
| 24: Msg("')' expected")
| 25: Msg("'ANY' expected")
| 26: Msg("'|' expected")
| 27: Msg("'WEAK' expected")
| 28: Msg("'[' expected")
| 29: Msg("']' expected")
| 30: Msg("'{' expected")
| 31: Msg("'}' expected")
| 32: Msg("'SYNC' expected")
| 33: Msg("'CONTEXT' expected")
| 34: Msg("'<' expected")
| 35: Msg("'>' expected")
| 36: Msg("'(.' expected")
| 37: Msg("'.)' expected")
| 38: Msg("??? expected")
| 39: Msg("invalid TokenFactor")
| 40: Msg("invalid Factor")
| 41: Msg("invalid Factor")
| 42: Msg("invalid Term")
| 43: Msg("invalid Symbol")
| 44: Msg("invalid SimSet")
| 45: Msg("this symbol not expected in TokenDecl")
| 46: Msg("invalid TokenDecl")
| 47: Msg("invalid Declaration")
| 48: Msg("invalid Declaration")
| 49: Msg("invalid Declaration")
| 50: Msg("this symbol not expected in Coco")
| 51: Msg("invalid start of the program")
ELSE Texts.WriteString(w, "error "); Texts.WriteInt(w, n, 0)
END
ELSE
CASE n OF
| 201: Msg("unexpected end of file");
| 202: Msg("string terminator not on this line");
| 203: Msg("a literal must not have attributes");
| 204: Msg("this symbol kind not allowed in production");
| 205: Msg("symbol declared without attributes");
| 206: Msg("symbol declared with attributes");
| 207: Msg("name declared twice");
| 208: Msg("this type not allowed on left side of production");
| 209: Msg("symbol earlier referenced without attributes");
| 210: Msg("symbol earlier referenced with attributes");
| 211: Msg("missing production for grammar name");
| 212: Msg("grammar symbol must not have attributes");
| 213: Msg("a literal must not be declared with a structure")
| 214: Msg("semantic action not allowed here")
| 215: Msg("undefined name")
| 216: Msg("attributes not allowed in token declaration")
| 217: Msg("name does not match name in heading")
| 220: Msg("token may be empty")
| 221: Msg("token must not start with an iteration")
| 222: Msg("only characters allowed in comment declaration")
| 223: Msg("only terminals may be weak")
| 224:
| 225: Msg("comment delimiter must not exceed 2 characters")
| 226: Msg("character set contains more than one character")
ELSE Texts.WriteString(w, "error "); Texts.WriteInt(w, n, 0)
END
END;
Texts.WriteLn(w); Texts.Append(Oberon.Log, w.buf)
END Error;
PROCEDURE Options(VAR s: Texts.Scanner);
VAR i: INTEGER;
BEGIN
IF s.nextCh = "/" THEN Texts.Scan(s); Texts.Scan(s);
IF s.class = Texts.Name THEN i := 0;
WHILE s.s[i] # 0X DO
IF CAP(s.s[i]) = "X" THEN CRT.ddt[7] := TRUE
ELSIF CAP(s.s[i]) = "S" THEN CRT.ddt[1] := TRUE
END;
INC(i)
END
END
END;
END Options;
PROCEDURE Compile*;
VAR (*v: Viewers.Viewer;*)(* f: TextFrames.Frame; *) s: Texts.Scanner; src, t: Texts.Text;
pos, beg, end, time: LONGINT; i: INTEGER;
BEGIN
(* Texts.OpenScanner(s, Oberon.Par.text, Oberon.Par.pos); Texts.Scan(s);
f := Oberon.Par.frame(TextFrames.Frame);
src := NIL; pos := 0;
IF (s.class = Texts.Char) & (s.c = "^") THEN
Oberon.GetSelection(t, beg, end, time);
IF time >= 0 THEN Texts.OpenScanner(s, t, beg); Texts.Scan(s) END
END;*)
IF s.class = Texts.Name THEN
NEW(src); Texts.Open(src, s.s);
(*ELSIF (s.class = Texts.Char) & (s.c = "*") THEN
v := Oberon.MarkedViewer();
IF (v # NIL) & (v.dsc.next IS TextFrames.Frame) THEN
src := v.dsc.next(TextFrames.Frame).text;
Texts.OpenScanner(s, v.dsc(TextFrames.Frame).text, 0); Texts.Scan(s)
END
ELSIF (s.class = Texts.Char) & (s.c = "@") THEN
Oberon.GetSelection(t, beg, end, time);
IF time >= 0 THEN src := t; pos := beg; s.s := " " END*)
END;
IF src # NIL THEN
Texts.WriteString (w, "Coco/R - Compiler-Compiler V2.2"); Texts.Append(Oberon.Log, w.buf);
i := 0; WHILE i < 10 DO CRT.ddt[i] := FALSE; INC(i) END;
Options(s);
Texts.WriteLn(w); Texts.WriteString(w, s.s); Texts.Append(Oberon.Log, w.buf);
CRS.Reset(src, pos, Error); lastErrPos := -10;
CRP.Parse
END
END Compile;
BEGIN
Texts.OpenWriter(w);
Compile;
END Coco.

5
src/tools/coco/Coco.Report.ps.1 Normal file
View file

File diff suppressed because one or more lines are too long

83
src/tools/coco/Coco.Tool Normal file
View file

@ -0,0 +1,83 @@
Coco/R - the Oberon scanner and parser generator
For a complete documentation see the postscript file Coco.Report.ps.
Compiler.Compile
Sets.Mod CRS.Mod CRT.Mod CRA.Mod CRX.Mod CRP.Mod Coco.Mod ~
NOTE: the option character should be changed to "\" in Coco.Mod for Unix implementations.
Coco.Compile *
Coco.Compile ~
Coco.Compile ^
Coco.Compile @
(*________________________ usage ________________________*)
Coco.Compile <filename> [options]
The file CR.ATG is an example of an input file to Coco. If the grammar in the input file has the name X
the generated scanner has the name XS.Mod and the generated parser has the name XP.Mod.
Options:
/X generates a cross reference list of all syntax symbols
/S generates a list of all terminal start symbols and successors of nonterminal symbols.
Interface of the generated scanner:
DEFINITION XS;
IMPORT Texts;
TYPE
ErrorProc = PROCEDURE (n: INTEGER; pos: LONGINT);
VAR
Error: ErrorProc;
col, errors, len, line, nextCol, nextLen, nextLine: INTEGER;
nextPos, pos: LONGINT;
src: Texts.Text;
PROCEDURE Reset (t: Texts.Text; pos: LONGINT; errProc: ErrorProc);
PROCEDURE Get(VAR sym: INTEGER);
PROCEDURE GetName(pos: LONGINT; len: INTEGER; VAR name: ARRAY OF CHAR);
PROCEDURE StdErrorProc (n: INTEGER; pos: LONGINT);
END XS.
Interface of the generated parser:
DEFINITION XP;
PROCEDURE Parse;
END XP.
Example how to use the generated parts;
Texts.OpenScanner(s, Oberon.Par.Text, Oberon.Par.Pos); Texts.Scan(s);
IF s.class = Texts.Name THEN
NEW(text); Texts.Open(text, s.s);
XS.Reset(text, 0, MyErrorHandler);
XP.Parse;
END
Error handling in the generated parser:
The grammar has to contain hints, from which Coco can generate appropriate error handling.
The hints can be placed arbitrarily on the right-hand side of a production:
SYNC Denotes a synchronisation point. At such points symbols are skipped until a symbol
is found which is a legal continuation symbol at that point (or eof). SYNC is usually
placed at points where particularly "safe" symbols are expected, i.e., symbols that
are rarely missing or misspelled.
WEAK s s is an arbitrary terminal symbol (e.g., ";") which is considered "weak", because it is
frequently missing or misspelled (e.g., a semicolon between statements).
Example:
Statement =
SYNC
( ident WEAK ":=" Expression
| "IF" Expression "THEN" StatSeq ["ELSE" StatSeq] "END"
| "WHILE" Expression "DO" StatSeq "END"
).
StatSeq =
Statement { WEAK ";" Statement}.þ

8
src/tools/coco/Oberon.Mod Normal file
View file

@ -0,0 +1,8 @@
MODULE Oberon;
IMPORT Texts := CmdlnTexts;
VAR Log* : Texts.Text;
END Oberon.

65
src/tools/coco/Parser.FRM Normal file
View file

@ -0,0 +1,65 @@
(* parser module generated by Coco-R *)
MODULE -->modulename;
IMPORT -->scanner;
CONST
-->constants
setSize = 32; nSets = (maxT DIV setSize) + 1;
TYPE
SymbolSet = ARRAY nSets OF SET;
VAR
sym: INTEGER; (* current input symbol *)
symSet: ARRAY nrSets OF SymbolSet;
-->declarations
PROCEDURE Error (n: INTEGER);
BEGIN -->errors
END Error;
PROCEDURE Get;
BEGIN
-->scanProc
END Get;
PROCEDURE Expect(n: INTEGER);
BEGIN IF sym = n THEN Get ELSE Error(n) END
END Expect;
PROCEDURE StartOf(s: INTEGER): BOOLEAN;
BEGIN RETURN (sym MOD setSize) IN symSet[s, sym DIV setSize]
END StartOf;
PROCEDURE ExpectWeak(n, follow: INTEGER);
BEGIN
IF sym = n THEN Get
ELSE Error(n); WHILE ~ StartOf(follow) DO Get END
END
END ExpectWeak;
PROCEDURE WeakSeparator(n, syFol, repFol: INTEGER): BOOLEAN;
VAR s: SymbolSet; i: INTEGER;
BEGIN
IF sym = n THEN Get; RETURN TRUE
ELSIF StartOf(repFol) THEN RETURN FALSE
ELSE
i := 0; WHILE i < nSets DO s[i] := symSet[syFol, i] + symSet[repFol, i] + symSet[0, i]; INC(i) END;
Error(n); WHILE ~ ((sym MOD setSize) IN s[sym DIV setSize]) DO Get END;
RETURN StartOf(syFol)
END
END WeakSeparator;
-->productions
PROCEDURE Parse*;
BEGIN
Get;
-->parseRoot
END Parse;
BEGIN
-->initialization
END -->modulename.

103
src/tools/coco/Scanner.FRM Normal file
View file

@ -0,0 +1,103 @@
(* scanner module generated by Coco-R *)
MODULE -->modulename;
IMPORT Texts := CmdlnTexts, SYSTEM;
CONST
EOL = 0DX;
EOF = 0X;
maxLexLen = 127;
-->declarations
TYPE
ErrorProc* = PROCEDURE (n: INTEGER; pos: LONGINT);
StartTable = ARRAY 128 OF INTEGER;
VAR
src*: Texts.Text; (*source text. To be set by the main pgm*)
pos*: LONGINT; (*position of current symbol*)
line*, col*, len*: INTEGER; (*line, column, length of current symbol*)
nextPos*: LONGINT; (*position of lookahead symbol*)
nextLine*, nextCol*, nextLen*: INTEGER; (*line, column, length of lookahead symbol*)
errors*: INTEGER; (*number of errors detected*)
Error*: ErrorProc;
ch: CHAR; (*current input character*)
r: Texts.Reader; (*global reader*)
chPos: LONGINT; (*position of current character*)
chLine: INTEGER; (*current line number*)
lineStart: LONGINT; (*start position of current line*)
apx: INTEGER; (*length of appendix*)
oldEols: INTEGER; (*nr. of EOLs in a comment*)
start: StartTable; (*start state for every character*)
PROCEDURE NextCh; (*return global variable ch*)
BEGIN
Texts.Read(r, ch); INC(chPos);
IF ch = EOL THEN INC(chLine); lineStart := chPos + 1 END
END NextCh;
PROCEDURE Comment(): BOOLEAN;
VAR level, startLine: INTEGER; oldLineStart: LONGINT;
BEGIN (*Comment*)
level := 1; startLine := chLine; oldLineStart := lineStart;
-->comment
END Comment;
PROCEDURE Get*(VAR sym: INTEGER);
VAR state: INTEGER; lexeme: ARRAY maxLexLen+1 OF CHAR;
PROCEDURE CheckLiteral;
BEGIN
IF nextLen < maxLexLen THEN lexeme[nextLen] := 0X END;
-->literals
END CheckLiteral;
BEGIN
-->GetSy1
IF ch > 7FX THEN ch := " " END;
pos := nextPos; col := nextCol; line := nextLine; len := nextLen;
nextPos := chPos; nextCol := SHORT(chPos - lineStart); nextLine := chLine; nextLen := 0;
state := start[ORD(ch)]; apx := 0;
LOOP
IF nextLen < maxLexLen THEN lexeme[nextLen] := ch END;
INC(nextLen);
NextCh;
IF state > 0 THEN
CASE state OF
-->GetSy2
END (*CASE*)
ELSE sym := noSym; RETURN (*NextCh already done*)
END (*IF*)
END (*LOOP*)
END Get;
PROCEDURE GetName*(pos: LONGINT; len: INTEGER; VAR s: ARRAY OF CHAR);
VAR i: INTEGER; r: Texts.Reader;
BEGIN
Texts.OpenReader(r, src, pos);
IF len >= LEN(s) THEN len := SHORT(LEN(s)) - 1 END;
i := 0; WHILE i < len DO Texts.Read(r, s[i]); INC(i) END;
s[i] := 0X
END GetName;
PROCEDURE StdErrorProc* (n: INTEGER; pos: LONGINT);
BEGIN INC(errors) END StdErrorProc;
PROCEDURE Reset* (t: Texts.Text; pos: LONGINT; errProc: ErrorProc);
BEGIN
src := t; Error := errProc;
Texts.OpenReader(r, src, pos);
chPos := pos - 1; chLine := 1; lineStart := 0;
oldEols := 0; apx := 0; errors := 0;
NextCh
END Reset;
BEGIN
-->initialization
END -->modulename.

138
src/tools/coco/Sets.Mod Normal file
View file

@ -0,0 +1,138 @@
MODULE Sets;
IMPORT Texts := CmdlnTexts;
CONST size* = 32;
PROCEDURE Clear*(VAR s: ARRAY OF SET);
VAR i: INTEGER;
BEGIN
i := 0; WHILE i < LEN(s) DO s[i] := {}; INC(i) END
END Clear;
PROCEDURE Fill*(VAR s: ARRAY OF SET);
VAR i: INTEGER;
BEGIN
i := 0; WHILE i < LEN(s) DO s[i] := {0 .. size-1}; INC(i) END
END Fill;
PROCEDURE Incl*(VAR s: ARRAY OF SET; x: INTEGER);
BEGIN INCL(s[x DIV size], x MOD size)
END Incl;
PROCEDURE Excl*(VAR s: ARRAY OF SET; x: INTEGER);
BEGIN EXCL(s[x DIV size], x MOD size)
END Excl;
PROCEDURE In*(VAR s: ARRAY OF SET; x: INTEGER): BOOLEAN;
BEGIN RETURN x MOD size IN s[x DIV size]
END In;
PROCEDURE Includes*(VAR s1, s2: ARRAY OF SET): BOOLEAN;
VAR i: INTEGER;
BEGIN
i := 0;
WHILE i < LEN(s1) DO
IF s1[i] + s2[i] # s1[i] THEN RETURN FALSE END;
INC(i)
END;
RETURN TRUE;
END Includes;
PROCEDURE Elements*(VAR s: ARRAY OF SET; VAR lastElem: INTEGER): INTEGER;
VAR i, n, max: INTEGER;
BEGIN
i := 0; n := 0; max := SHORT(LEN(s)) * size;
WHILE i < max DO
IF (i MOD size) IN s[i DIV size] THEN INC(n); lastElem := i END;
INC(i)
END;
RETURN n
END Elements;
PROCEDURE Empty*(VAR s: ARRAY OF SET): BOOLEAN;
VAR i: INTEGER;
BEGIN
i := 0;
WHILE i < LEN(s) DO
IF s[i] # {} THEN RETURN FALSE END;
INC(i)
END;
RETURN TRUE
END Empty;
PROCEDURE Equal*(VAR s1, s2: ARRAY OF SET): BOOLEAN;
VAR i: INTEGER;
BEGIN
i := 0;
WHILE i < LEN(s1) DO
IF s1[i] # s2[i] THEN RETURN FALSE END;
INC(i)
END;
RETURN TRUE
END Equal;
PROCEDURE Different*(VAR s1, s2: ARRAY OF SET): BOOLEAN;
VAR i: INTEGER;
BEGIN
i := 0;
WHILE i < LEN(s1) DO
IF s1[i] * s2[i] # {} THEN RETURN FALSE END;
INC(i)
END;
RETURN TRUE
END Different;
PROCEDURE Unite*(VAR s1, s2: ARRAY OF SET);
VAR i: INTEGER;
BEGIN
i := 0; WHILE i < LEN(s1) DO s1[i] := s1[i] + s2[i]; INC(i) END
END Unite;
PROCEDURE Differ*(VAR s1, s2: ARRAY OF SET);
VAR i: INTEGER;
BEGIN
i := 0; WHILE i < LEN(s1) DO s1[i] := s1[i] - s2[i]; INC(i) END
END Differ;
PROCEDURE Intersect*(VAR s1, s2, s3: ARRAY OF SET);
VAR i: INTEGER;
BEGIN
i := 0; WHILE i < LEN(s1) DO s3[i] := s1[i] * s2[i]; INC(i) END
END Intersect;
PROCEDURE Print*(VAR f: Texts.Writer; s: ARRAY OF SET; w, indent: INTEGER);
VAR col, i, max: INTEGER;
BEGIN
i := 0; col := indent; max := SHORT(LEN(s)) * size;
Texts.Write(f, "{");
WHILE i < max DO
IF In(s, i) THEN
IF col + 4 > w THEN
Texts.WriteLn(f);
col := 0; WHILE col < indent DO Texts.Write(f, " "); INC(col) END
END;
Texts.WriteInt(f, i, 3); Texts.Write(f, ",");
INC(col, 4)
END;
INC(i)
END;
Texts.Write(f, "}")
END Print;
END Sets.

471
src/tools/coco/v4_compat/Oberon.Mod Executable file
View file

@ -0,0 +1,471 @@
MODULE Oberon; (*JG 6.9.90 / 23.9.93*)
IMPORT SYSTEM, Unix, Kernel, Modules, Input, Display, Fonts, Viewers, Texts, X11; (* << *)
CONST
(*message ids*)
consume* = 0; track* = 1;
defocus* = 0; neutralize* = 1; mark* = 2;
BasicCycle = 20;
ESC = 1BX; SETUP = 0A4X;
TYPE
Painter* = PROCEDURE (x, y: INTEGER);
Marker* = RECORD Fade*, Draw*: Painter END;
Cursor* = RECORD
marker*: Marker; on*: BOOLEAN; X*, Y*: INTEGER
END;
ParList* = POINTER TO ParRec;
ParRec* = RECORD
vwr*: Viewers.Viewer;
frame*: Display.Frame;
text*: Texts.Text;
pos*: LONGINT
END;
InputMsg* = RECORD (Display.FrameMsg)
id*: INTEGER;
keys*: SET;
X*, Y*: INTEGER;
ch*: CHAR;
fnt*: Fonts.Font;
col*, voff*: SHORTINT
END;
SelectionMsg* = RECORD (Display.FrameMsg)
time*: LONGINT;
text*: Texts.Text;
beg*, end*: LONGINT
END;
ControlMsg* = RECORD (Display.FrameMsg)
id*, X*, Y*: INTEGER
END;
CopyOverMsg* = RECORD (Display.FrameMsg)
text*: Texts.Text;
beg*, end*: LONGINT
END;
CopyMsg* = RECORD (Display.FrameMsg)
F*: Display.Frame
END;
Task* = POINTER TO TaskDesc;
Handler* = PROCEDURE;
TaskDesc* = RECORD
next: Task;
safe*: BOOLEAN;
time*: LONGINT;
handle*: Handler
END;
VAR
User*: ARRAY 12 OF CHAR; (* << *)
Arrow*, Star*: Marker;
Mouse*, Pointer*: Cursor;
FocusViewer*: Viewers.Viewer;
Log*: Texts.Text;
Par*: ParList; (*actual parameters*)
CurTask*, PrevTask: Task;
CurFnt*: Fonts.Font; CurCol*, CurOff*: SHORTINT;
Password*: LONGINT;
DW, DH, CL, H0, H1, H2, H3: INTEGER;
unitW: INTEGER;
ActCnt: INTEGER; (*action count for GC*)
Mod: Modules.Module;
ArrowFade: Painter; (* << *)
(*user identification*)
PROCEDURE Code(VAR s: ARRAY OF CHAR): LONGINT;
VAR i: INTEGER; a, b, c: LONGINT;
BEGIN
a := 0; b := 0; i := 0;
WHILE s[i] # 0X DO
c := b; b := a; a := (c MOD 509 + 1) * 127 + ORD(s[i]);
INC(i)
END;
IF b >= 32768 THEN b := b - 65536 END;
RETURN b * 65536 + a
END Code;
PROCEDURE SetUser* (VAR user, password: ARRAY OF CHAR);
BEGIN COPY(user, User); Password := Code(password)
END SetUser;
(*clocks*)
PROCEDURE GetClock* (VAR t, d: LONGINT);
BEGIN Kernel.GetClock(t, d)
END GetClock;
PROCEDURE SetClock* (t, d: LONGINT);
BEGIN Kernel.SetClock(t, d)
END SetClock;
PROCEDURE Time* (): LONGINT;
BEGIN RETURN Input.Time()
END Time;
(*cursor handling*)
PROCEDURE FlipArrow (X, Y: INTEGER); (* << *)
END FlipArrow;
PROCEDURE FlipStar (X, Y: INTEGER);
BEGIN
IF X < CL THEN
IF X < 7 THEN X := 7 ELSIF X > DW - 8 THEN X := DW - 8 END
ELSE
IF X < CL + 7 THEN X := CL + 7 ELSIF X > CL + DW - 8 THEN X := CL + DW - 8 END
END ;
IF Y < 7 THEN Y := 7 ELSIF Y > DH - 8 THEN Y := DH - 8 END;
Display.CopyPattern(Display.white, Display.star, X - 7, Y - 7, 2)
END FlipStar;
PROCEDURE OpenCursor* (VAR c: Cursor);
BEGIN c.on := FALSE; c.X := 0; c.Y := 0
END OpenCursor;
PROCEDURE FadeCursor* (VAR c: Cursor);
BEGIN IF c.on THEN c.marker.Fade(c.X, c.Y); c.on := FALSE END
END FadeCursor;
PROCEDURE DrawCursor* (VAR c: Cursor; VAR m: Marker; X, Y: INTEGER); (* << RC *)
BEGIN
IF c.on & ((X # c.X) OR (Y # c.Y) OR (m.Draw # c.marker.Draw)) THEN
c.marker.Fade(c.X, c.Y); c.on := FALSE
END;
IF c.marker.Fade = ArrowFade THEN
IF m.Fade # ArrowFade THEN X11.DefineCursor(X11.display, X11.primary, X11.noCursor) END
ELSE
IF m.Fade = ArrowFade THEN X11.DefineCursor(X11.display, X11.primary, X11.arrow) END
END ;
IF ~c.on THEN
m.Draw(X, Y); c.marker := m; c.X := X; c.Y := Y; c.on := TRUE
END
END DrawCursor;
(*display management*)
PROCEDURE RemoveMarks* (X, Y, W, H: INTEGER);
BEGIN
IF (Mouse.X > X - 16) & (Mouse.X < X + W + 16) & (Mouse.Y > Y - 16) & (Mouse.Y < Y + H + 16) THEN
FadeCursor(Mouse)
END;
IF (Pointer.X > X - 8) & (Pointer.X < X + W + 8) & (Pointer.Y > Y - 8) & (Pointer.Y < Y + H + 8) THEN
FadeCursor(Pointer)
END
END RemoveMarks;
PROCEDURE HandleFiller (V: Display.Frame; VAR M: Display.FrameMsg);
BEGIN
WITH V: Viewers.Viewer DO
IF M IS InputMsg THEN
WITH M: InputMsg DO
IF M.id = track THEN DrawCursor(Mouse, Arrow, M.X, M.Y) END
END;
ELSIF M IS ControlMsg THEN
WITH M: ControlMsg DO
IF M.id = mark THEN DrawCursor(Pointer, Star, M.X, M.Y) END
END
ELSIF M IS Viewers.ViewerMsg THEN
WITH M: Viewers.ViewerMsg DO
IF (M.id = Viewers.restore) & (V.W > 0) & (V.H > 0) THEN
RemoveMarks(V.X, V.Y, V.W, V.H);
Display.ReplConst(Display.black, V.X, V.Y, V.W, V.H, 0)
ELSIF (M.id = Viewers.modify) & (M.Y < V.Y) THEN
RemoveMarks(V.X, M.Y, V.W, V.Y - M.Y);
Display.ReplConst(Display.black, V.X, M.Y, V.W, V.Y - M.Y, 0)
END
END
END
END
END HandleFiller;
PROCEDURE OpenDisplay* (UW, SW, H: INTEGER);
VAR Filler: Viewers.Viewer;
BEGIN
Input.SetMouseLimits(Viewers.curW + UW + SW, H);
Display.ReplConst(Display.black, Viewers.curW, 0, UW + SW, H, 0);
NEW(Filler); Filler.handle := HandleFiller;
Viewers.InitTrack(UW, H, Filler); (*init user track*)
NEW(Filler); Filler.handle := HandleFiller;
Viewers.InitTrack(SW, H, Filler) (*init system track*)
END OpenDisplay;
PROCEDURE DisplayWidth* (X: INTEGER): INTEGER;
BEGIN RETURN DW
END DisplayWidth;
PROCEDURE DisplayHeight* (X: INTEGER): INTEGER;
BEGIN RETURN DH
END DisplayHeight;
PROCEDURE OpenTrack* (X, W: INTEGER);
VAR Filler: Viewers.Viewer;
BEGIN
NEW(Filler); Filler.handle := HandleFiller;
Viewers.OpenTrack(X, W, Filler)
END OpenTrack;
PROCEDURE UserTrack* (X: INTEGER): INTEGER;
BEGIN RETURN X DIV DW * DW
END UserTrack;
PROCEDURE SystemTrack* (X: INTEGER): INTEGER;
BEGIN RETURN X DIV DW * DW + DW DIV 8 * 5
END SystemTrack;
PROCEDURE UY (X: INTEGER): INTEGER;
VAR fil, bot, alt, max: Display.Frame;
BEGIN
Viewers.Locate(X, 0, fil, bot, alt, max);
IF fil.H >= DH DIV 8 THEN RETURN DH END;
RETURN max.Y + max.H DIV 2
END UY;
PROCEDURE AllocateUserViewer* (DX: INTEGER; VAR X, Y: INTEGER);
BEGIN
IF Pointer.on THEN X := Pointer.X; Y := Pointer.Y
ELSE X := DX DIV DW * DW; Y := UY(X)
END
END AllocateUserViewer;
PROCEDURE SY (X: INTEGER): INTEGER;
VAR fil, bot, alt, max: Display.Frame;
BEGIN
Viewers.Locate(X, DH, fil, bot, alt, max);
IF fil.H >= DH DIV 8 THEN RETURN DH END;
IF max.H >= DH - H0 THEN RETURN max.Y + H3 END;
IF max.H >= H3 - H0 THEN RETURN max.Y + H2 END;
IF max.H >= H2 - H0 THEN RETURN max.Y + H1 END;
IF max # bot THEN RETURN max.Y + max.H DIV 2 END;
IF bot.H >= H1 THEN RETURN bot.H DIV 2 END;
RETURN alt.Y + alt.H DIV 2
END SY;
PROCEDURE AllocateSystemViewer* (DX: INTEGER; VAR X, Y: INTEGER);
BEGIN
IF Pointer.on THEN X := Pointer.X; Y := Pointer.Y
ELSE X := DX DIV DW * DW + DW DIV 8 * 5; Y := SY(X)
END
END AllocateSystemViewer;
PROCEDURE MarkedViewer* (): Viewers.Viewer;
BEGIN RETURN Viewers.This(Pointer.X, Pointer.Y)
END MarkedViewer;
PROCEDURE PassFocus* (V: Viewers.Viewer);
VAR M: ControlMsg;
BEGIN M.id := defocus; FocusViewer.handle(FocusViewer, M); FocusViewer := V
END PassFocus;
(*command interpretation*)
PROCEDURE Call* (name: ARRAY OF CHAR; par: ParList; new: BOOLEAN; VAR res: INTEGER);
VAR Mod: Modules.Module; P: Modules.Command; i, j: INTEGER;
BEGIN res := 1;
i := 0; j := 0;
WHILE name[j] # 0X DO
IF name[j] = "." THEN i := j END;
INC(j)
END;
IF i > 0 THEN
name[i] := 0X;
Mod := Modules.ThisMod(name);
IF Modules.res = 0 THEN
INC(i); j := i;
WHILE name[j] # 0X DO name[j - i] := name[j]; INC(j) END;
name[j - i] := 0X;
P := Modules.ThisCommand(Mod, name);
IF Modules.res = 0 THEN
Par := par; Par.vwr := Viewers.This(par.frame.X, par.frame.Y); P; res := 0
ELSE res := -1
END
ELSE res := Modules.res
END
ELSE res := -1
END
END Call;
PROCEDURE GetSelection* (VAR text: Texts.Text; VAR beg, end, time: LONGINT);
VAR M: SelectionMsg;
BEGIN
M.time := -1; Viewers.Broadcast(M); time := M.time;
IF time >= 0 THEN text := M.text; beg := M.beg; end := M.end END
END GetSelection;
PROCEDURE GC;
BEGIN IF ActCnt <= 0 THEN Kernel.GC(FALSE); ActCnt := BasicCycle END
END GC;
PROCEDURE Install* (T: Task);
VAR t: Task;
BEGIN t := PrevTask;
WHILE (t.next # PrevTask) & (t.next # T) DO t := t.next END;
IF (t.next # T) & (CurTask # T) THEN
IF CurTask # NIL THEN (* called from a task *)
T.next := CurTask.next; CurTask.next := T
ELSE (* no task is currently running *)
T.next := PrevTask.next; PrevTask.next := T
END
END
END Install;
PROCEDURE Remove* (T: Task);
VAR t: Task;
BEGIN t := PrevTask;
WHILE (t.next # T) & (t.next # PrevTask) DO t := t.next END;
IF t.next = T THEN t.next := t.next.next; PrevTask := t.next END;
IF CurTask = T THEN CurTask := PrevTask.next END
END Remove;
PROCEDURE Collect* (count: INTEGER);
BEGIN ActCnt := count
END Collect;
PROCEDURE SetFont* (fnt: Fonts.Font);
BEGIN CurFnt := fnt
END SetFont;
PROCEDURE SetColor* (col: SHORTINT);
BEGIN CurCol := col
END SetColor;
PROCEDURE SetOffset* (voff: SHORTINT);
BEGIN CurOff := voff
END SetOffset;
PROCEDURE MinTime(): LONGINT; (* << *)
VAR minTime: LONGINT; t: Task;
BEGIN
minTime := MAX(LONGINT); t := PrevTask;
REPEAT
IF (t.time # -1) & (t.time < minTime) THEN minTime := t.time END ;
t := t.next;
UNTIL t = PrevTask ;
RETURN minTime
END MinTime;
PROCEDURE NotifyTasks; (* << *)
VAR t0, p: Task;
BEGIN t0 := PrevTask;
REPEAT
CurTask := PrevTask.next;
IF CurTask.time = -1 THEN
IF ~CurTask.safe THEN PrevTask.next := CurTask.next END;
p := CurTask; CurTask.handle; PrevTask.next := CurTask;
IF CurTask # p THEN RETURN END (*detect Remove(CurTask)*)
END;
PrevTask := CurTask
UNTIL CurTask = t0
END NotifyTasks;
PROCEDURE Loop*;
VAR V: Viewers.Viewer; M: InputMsg; N: ControlMsg;
prevX, prevY, X, Y: INTEGER; keys: SET; ch: CHAR;
VM: Viewers.ViewerMsg; i: INTEGER; res: LONGINT; (* << *)
BEGIN
res := Kernel.sigsetjmp(Kernel.trapEnv, 1); (* << *)
LOOP
CurTask := NIL;
Input.Mouse(keys, X, Y);
IF Input.Available() > 0 THEN Input.Read(ch);
IF ch < 0F0X THEN
IF ch = ESC THEN
N.id := neutralize; Viewers.Broadcast(N); FadeCursor(Pointer)
ELSIF ch = SETUP THEN
N.id := mark; N.X := X; N.Y := Y; V := Viewers.This(X, Y); V.handle(V, N)
ELSIF ch = 0CX THEN (* << *)
N.id := neutralize; Viewers.Broadcast(N); FadeCursor(Pointer);
VM.id := Viewers.suspend; Viewers.Broadcast(VM);
VM.id := Viewers.restore; Viewers.Broadcast(VM)
ELSE
M.id := consume; M.ch := ch; M.fnt := CurFnt; M.col := CurCol; M.voff := CurOff;
FocusViewer.handle(FocusViewer, M);
DEC(ActCnt); NotifyTasks
END
ELSIF ch = 0F1X THEN Display.SetMode(0, {})
ELSIF ch = 0F2X THEN Display.SetMode(0, {0})
ELSIF ch = 0F3X THEN Display.SetMode(0, {2})
ELSIF ch = 0F4X THEN X11.InitColors
ELSIF Kernel.FKey[ORD(ch) - 0F0H] # NIL THEN Kernel.FKey[ORD(ch) - 0F0H]
END
ELSIF keys # {} THEN
M.id := track; M.X := X; M.Y := Y; M.keys := keys;
REPEAT
V := Viewers.This(M.X, M.Y); V.handle(V, M);
Input.Mouse(M.keys, M.X, M.Y)
UNTIL M.keys = {};
DEC(ActCnt); NotifyTasks
ELSE
IF (X # prevX) OR (Y # prevY) OR ~Mouse.on THEN
M.id := track; M.X := X; M.Y := Y; M.keys := keys; V := Viewers.This(X, Y); V.handle(V, M);
prevX := X; prevY := Y
END;
X11.DoSync; (* << *)
IF X11.EventsQueued(X11.display, X11.QueuedAfterReading) = 0 THEN (* << *)
Kernel.Select(MinTime() - Input.Time()); NotifyTasks;
FOR i := 0 TO 7 DO Kernel.readySet[i] := {} END
END ;
CurTask := PrevTask.next;
IF (CurTask.time <= Input.Time()) & (CurTask.time # -1) THEN
IF ~CurTask.safe THEN PrevTask.next := CurTask.next END;
CurTask.handle; PrevTask.next := CurTask
END;
PrevTask := CurTask
END
END
END Loop;
BEGIN User[0] := 0X;
Arrow.Fade := FlipArrow; Arrow.Draw := FlipArrow;
ArrowFade := FlipArrow; (* << *)
Star.Fade := FlipStar; Star.Draw := FlipStar;
OpenCursor(Mouse); OpenCursor(Pointer);
DW := Display.Width; DH := Display.Height; CL := Display.ColLeft;
H3 := DH - DH DIV 3;
H2 := H3 - H3 DIV 2;
H1 := DH DIV 5;
H0 := DH DIV 10;
(* moved into Configuration.Mod
unitW := DW DIV 8;
OpenDisplay(unitW * 5, unitW * 3, DH);
FocusViewer := Viewers.This(0, 0);
*)
CurFnt := Fonts.Default;
CurCol := Display.white;
CurOff := 0;
Collect(BasicCycle);
NEW(PrevTask);
PrevTask.handle := GC;
PrevTask.safe := TRUE;
PrevTask.time := -1; (* << *)
PrevTask.next := PrevTask;
CurTask := NIL;
Display.SetMode(0, {});
END Oberon.

471
src/tools/coco/v4_compat/Oberon.Mod_orig Normal file
View file

@ -0,0 +1,471 @@
MODULE Oberon; (*JG 6.9.90 / 23.9.93*)
IMPORT SYSTEM, Unix, Kernel, Modules, Input, Display, Fonts, Viewers, Texts, X11; (* << *)
CONST
(*message ids*)
consume* = 0; track* = 1;
defocus* = 0; neutralize* = 1; mark* = 2;
BasicCycle = 20;
ESC = 1BX; SETUP = 0A4X;
TYPE
Painter* = PROCEDURE (x, y: INTEGER);
Marker* = RECORD Fade*, Draw*: Painter END;
Cursor* = RECORD
marker*: Marker; on*: BOOLEAN; X*, Y*: INTEGER
END;
ParList* = POINTER TO ParRec;
ParRec* = RECORD
vwr*: Viewers.Viewer;
frame*: Display.Frame;
text*: Texts.Text;
pos*: LONGINT
END;
InputMsg* = RECORD (Display.FrameMsg)
id*: INTEGER;
keys*: SET;
X*, Y*: INTEGER;
ch*: CHAR;
fnt*: Fonts.Font;
col*, voff*: SHORTINT
END;
SelectionMsg* = RECORD (Display.FrameMsg)
time*: LONGINT;
text*: Texts.Text;
beg*, end*: LONGINT
END;
ControlMsg* = RECORD (Display.FrameMsg)
id*, X*, Y*: INTEGER
END;
CopyOverMsg* = RECORD (Display.FrameMsg)
text*: Texts.Text;
beg*, end*: LONGINT
END;
CopyMsg* = RECORD (Display.FrameMsg)
F*: Display.Frame
END;
Task* = POINTER TO TaskDesc;
Handler* = PROCEDURE;
TaskDesc* = RECORD
next: Task;
safe*: BOOLEAN;
time*: LONGINT;
handle*: Handler
END;
VAR
User*: ARRAY 12 OF CHAR; (* << *)
Arrow*, Star*: Marker;
Mouse*, Pointer*: Cursor;
FocusViewer*: Viewers.Viewer;
Log*: Texts.Text;
Par*: ParList; (*actual parameters*)
CurTask*, PrevTask: Task;
CurFnt*: Fonts.Font; CurCol*, CurOff*: SHORTINT;
Password*: LONGINT;
DW, DH, CL, H0, H1, H2, H3: INTEGER;
unitW: INTEGER;
ActCnt: INTEGER; (*action count for GC*)
Mod: Modules.Module;
ArrowFade: Painter; (* << *)
(*user identification*)
PROCEDURE Code(VAR s: ARRAY OF CHAR): LONGINT;
VAR i: INTEGER; a, b, c: LONGINT;
BEGIN
a := 0; b := 0; i := 0;
WHILE s[i] # 0X DO
c := b; b := a; a := (c MOD 509 + 1) * 127 + ORD(s[i]);
INC(i)
END;
IF b >= 32768 THEN b := b - 65536 END;
RETURN b * 65536 + a
END Code;
PROCEDURE SetUser* (VAR user, password: ARRAY OF CHAR);
BEGIN COPY(user, User); Password := Code(password)
END SetUser;
(*clocks*)
PROCEDURE GetClock* (VAR t, d: LONGINT);
BEGIN Kernel.GetClock(t, d)
END GetClock;
PROCEDURE SetClock* (t, d: LONGINT);
BEGIN Kernel.SetClock(t, d)
END SetClock;
PROCEDURE Time* (): LONGINT;
BEGIN RETURN Input.Time()
END Time;
(*cursor handling*)
PROCEDURE FlipArrow (X, Y: INTEGER); (* << *)
END FlipArrow;
PROCEDURE FlipStar (X, Y: INTEGER);
BEGIN
IF X < CL THEN
IF X < 7 THEN X := 7 ELSIF X > DW - 8 THEN X := DW - 8 END
ELSE
IF X < CL + 7 THEN X := CL + 7 ELSIF X > CL + DW - 8 THEN X := CL + DW - 8 END
END ;
IF Y < 7 THEN Y := 7 ELSIF Y > DH - 8 THEN Y := DH - 8 END;
Display.CopyPattern(Display.white, Display.star, X - 7, Y - 7, 2)
END FlipStar;
PROCEDURE OpenCursor* (VAR c: Cursor);
BEGIN c.on := FALSE; c.X := 0; c.Y := 0
END OpenCursor;
PROCEDURE FadeCursor* (VAR c: Cursor);
BEGIN IF c.on THEN c.marker.Fade(c.X, c.Y); c.on := FALSE END
END FadeCursor;
PROCEDURE DrawCursor* (VAR c: Cursor; VAR m: Marker; X, Y: INTEGER); (* << RC *)
BEGIN
IF c.on & ((X # c.X) OR (Y # c.Y) OR (m.Draw # c.marker.Draw)) THEN
c.marker.Fade(c.X, c.Y); c.on := FALSE
END;
IF c.marker.Fade = ArrowFade THEN
IF m.Fade # ArrowFade THEN X11.DefineCursor(X11.display, X11.primary, X11.noCursor) END
ELSE
IF m.Fade = ArrowFade THEN X11.DefineCursor(X11.display, X11.primary, X11.arrow) END
END ;
IF ~c.on THEN
m.Draw(X, Y); c.marker := m; c.X := X; c.Y := Y; c.on := TRUE
END
END DrawCursor;
(*display management*)
PROCEDURE RemoveMarks* (X, Y, W, H: INTEGER);
BEGIN
IF (Mouse.X > X - 16) & (Mouse.X < X + W + 16) & (Mouse.Y > Y - 16) & (Mouse.Y < Y + H + 16) THEN
FadeCursor(Mouse)
END;
IF (Pointer.X > X - 8) & (Pointer.X < X + W + 8) & (Pointer.Y > Y - 8) & (Pointer.Y < Y + H + 8) THEN
FadeCursor(Pointer)
END
END RemoveMarks;
PROCEDURE HandleFiller (V: Display.Frame; VAR M: Display.FrameMsg);
BEGIN
WITH V: Viewers.Viewer DO
IF M IS InputMsg THEN
WITH M: InputMsg DO
IF M.id = track THEN DrawCursor(Mouse, Arrow, M.X, M.Y) END
END;
ELSIF M IS ControlMsg THEN
WITH M: ControlMsg DO
IF M.id = mark THEN DrawCursor(Pointer, Star, M.X, M.Y) END
END
ELSIF M IS Viewers.ViewerMsg THEN
WITH M: Viewers.ViewerMsg DO
IF (M.id = Viewers.restore) & (V.W > 0) & (V.H > 0) THEN
RemoveMarks(V.X, V.Y, V.W, V.H);
Display.ReplConst(Display.black, V.X, V.Y, V.W, V.H, 0)
ELSIF (M.id = Viewers.modify) & (M.Y < V.Y) THEN
RemoveMarks(V.X, M.Y, V.W, V.Y - M.Y);
Display.ReplConst(Display.black, V.X, M.Y, V.W, V.Y - M.Y, 0)
END
END
END
END
END HandleFiller;
PROCEDURE OpenDisplay* (UW, SW, H: INTEGER);
VAR Filler: Viewers.Viewer;
BEGIN
Input.SetMouseLimits(Viewers.curW + UW + SW, H);
Display.ReplConst(Display.black, Viewers.curW, 0, UW + SW, H, 0);
NEW(Filler); Filler.handle := HandleFiller;
Viewers.InitTrack(UW, H, Filler); (*init user track*)
NEW(Filler); Filler.handle := HandleFiller;
Viewers.InitTrack(SW, H, Filler) (*init system track*)
END OpenDisplay;
PROCEDURE DisplayWidth* (X: INTEGER): INTEGER;
BEGIN RETURN DW
END DisplayWidth;
PROCEDURE DisplayHeight* (X: INTEGER): INTEGER;
BEGIN RETURN DH
END DisplayHeight;
PROCEDURE OpenTrack* (X, W: INTEGER);
VAR Filler: Viewers.Viewer;
BEGIN
NEW(Filler); Filler.handle := HandleFiller;
Viewers.OpenTrack(X, W, Filler)
END OpenTrack;
PROCEDURE UserTrack* (X: INTEGER): INTEGER;
BEGIN RETURN X DIV DW * DW
END UserTrack;
PROCEDURE SystemTrack* (X: INTEGER): INTEGER;
BEGIN RETURN X DIV DW * DW + DW DIV 8 * 5
END SystemTrack;
PROCEDURE UY (X: INTEGER): INTEGER;
VAR fil, bot, alt, max: Display.Frame;
BEGIN
Viewers.Locate(X, 0, fil, bot, alt, max);
IF fil.H >= DH DIV 8 THEN RETURN DH END;
RETURN max.Y + max.H DIV 2
END UY;
PROCEDURE AllocateUserViewer* (DX: INTEGER; VAR X, Y: INTEGER);
BEGIN
IF Pointer.on THEN X := Pointer.X; Y := Pointer.Y
ELSE X := DX DIV DW * DW; Y := UY(X)
END
END AllocateUserViewer;
PROCEDURE SY (X: INTEGER): INTEGER;
VAR fil, bot, alt, max: Display.Frame;
BEGIN
Viewers.Locate(X, DH, fil, bot, alt, max);
IF fil.H >= DH DIV 8 THEN RETURN DH END;
IF max.H >= DH - H0 THEN RETURN max.Y + H3 END;
IF max.H >= H3 - H0 THEN RETURN max.Y + H2 END;
IF max.H >= H2 - H0 THEN RETURN max.Y + H1 END;
IF max # bot THEN RETURN max.Y + max.H DIV 2 END;
IF bot.H >= H1 THEN RETURN bot.H DIV 2 END;
RETURN alt.Y + alt.H DIV 2
END SY;
PROCEDURE AllocateSystemViewer* (DX: INTEGER; VAR X, Y: INTEGER);
BEGIN
IF Pointer.on THEN X := Pointer.X; Y := Pointer.Y
ELSE X := DX DIV DW * DW + DW DIV 8 * 5; Y := SY(X)
END
END AllocateSystemViewer;
PROCEDURE MarkedViewer* (): Viewers.Viewer;
BEGIN RETURN Viewers.This(Pointer.X, Pointer.Y)
END MarkedViewer;
PROCEDURE PassFocus* (V: Viewers.Viewer);
VAR M: ControlMsg;
BEGIN M.id := defocus; FocusViewer.handle(FocusViewer, M); FocusViewer := V
END PassFocus;
(*command interpretation*)
PROCEDURE Call* (name: ARRAY OF CHAR; par: ParList; new: BOOLEAN; VAR res: INTEGER);
VAR Mod: Modules.Module; P: Modules.Command; i, j: INTEGER;
BEGIN res := 1;
i := 0; j := 0;
WHILE name[j] # 0X DO
IF name[j] = "." THEN i := j END;
INC(j)
END;
IF i > 0 THEN
name[i] := 0X;
Mod := Modules.ThisMod(name);
IF Modules.res = 0 THEN
INC(i); j := i;
WHILE name[j] # 0X DO name[j - i] := name[j]; INC(j) END;
name[j - i] := 0X;
P := Modules.ThisCommand(Mod, name);
IF Modules.res = 0 THEN
Par := par; Par.vwr := Viewers.This(par.frame.X, par.frame.Y); P; res := 0
ELSE res := -1
END
ELSE res := Modules.res
END
ELSE res := -1
END
END Call;
PROCEDURE GetSelection* (VAR text: Texts.Text; VAR beg, end, time: LONGINT);
VAR M: SelectionMsg;
BEGIN
M.time := -1; Viewers.Broadcast(M); time := M.time;
IF time >= 0 THEN text := M.text; beg := M.beg; end := M.end END
END GetSelection;
PROCEDURE GC;
BEGIN IF ActCnt <= 0 THEN Kernel.GC(FALSE); ActCnt := BasicCycle END
END GC;
PROCEDURE Install* (T: Task);
VAR t: Task;
BEGIN t := PrevTask;
WHILE (t.next # PrevTask) & (t.next # T) DO t := t.next END;
IF (t.next # T) & (CurTask # T) THEN
IF CurTask # NIL THEN (* called from a task *)
T.next := CurTask.next; CurTask.next := T
ELSE (* no task is currently running *)
T.next := PrevTask.next; PrevTask.next := T
END
END
END Install;
PROCEDURE Remove* (T: Task);
VAR t: Task;
BEGIN t := PrevTask;
WHILE (t.next # T) & (t.next # PrevTask) DO t := t.next END;
IF t.next = T THEN t.next := t.next.next; PrevTask := t.next END;
IF CurTask = T THEN CurTask := PrevTask.next END
END Remove;
PROCEDURE Collect* (count: INTEGER);
BEGIN ActCnt := count
END Collect;
PROCEDURE SetFont* (fnt: Fonts.Font);
BEGIN CurFnt := fnt
END SetFont;
PROCEDURE SetColor* (col: SHORTINT);
BEGIN CurCol := col
END SetColor;
PROCEDURE SetOffset* (voff: SHORTINT);
BEGIN CurOff := voff
END SetOffset;
PROCEDURE MinTime(): LONGINT; (* << *)
VAR minTime: LONGINT; t: Task;
BEGIN
minTime := MAX(LONGINT); t := PrevTask;
REPEAT
IF (t.time # -1) & (t.time < minTime) THEN minTime := t.time END ;
t := t.next;
UNTIL t = PrevTask ;
RETURN minTime
END MinTime;
PROCEDURE NotifyTasks; (* << *)
VAR t0, p: Task;
BEGIN t0 := PrevTask;
REPEAT
CurTask := PrevTask.next;
IF CurTask.time = -1 THEN
IF ~CurTask.safe THEN PrevTask.next := CurTask.next END;
p := CurTask; CurTask.handle; PrevTask.next := CurTask;
IF CurTask # p THEN RETURN END (*detect Remove(CurTask)*)
END;
PrevTask := CurTask
UNTIL CurTask = t0
END NotifyTasks;
PROCEDURE Loop*;
VAR V: Viewers.Viewer; M: InputMsg; N: ControlMsg;
prevX, prevY, X, Y: INTEGER; keys: SET; ch: CHAR;
VM: Viewers.ViewerMsg; i: INTEGER; res: LONGINT; (* << *)
BEGIN
res := Kernel.sigsetjmp(Kernel.trapEnv, 1); (* << *)
LOOP
CurTask := NIL;
Input.Mouse(keys, X, Y);
IF Input.Available() > 0 THEN Input.Read(ch);
IF ch < 0F0X THEN
IF ch = ESC THEN
N.id := neutralize; Viewers.Broadcast(N); FadeCursor(Pointer)
ELSIF ch = SETUP THEN
N.id := mark; N.X := X; N.Y := Y; V := Viewers.This(X, Y); V.handle(V, N)
ELSIF ch = 0CX THEN (* << *)
N.id := neutralize; Viewers.Broadcast(N); FadeCursor(Pointer);
VM.id := Viewers.suspend; Viewers.Broadcast(VM);
VM.id := Viewers.restore; Viewers.Broadcast(VM)
ELSE
M.id := consume; M.ch := ch; M.fnt := CurFnt; M.col := CurCol; M.voff := CurOff;
FocusViewer.handle(FocusViewer, M);
DEC(ActCnt); NotifyTasks
END
ELSIF ch = 0F1X THEN Display.SetMode(0, {})
ELSIF ch = 0F2X THEN Display.SetMode(0, {0})
ELSIF ch = 0F3X THEN Display.SetMode(0, {2})
ELSIF ch = 0F4X THEN X11.InitColors
ELSIF Kernel.FKey[ORD(ch) - 0F0H] # NIL THEN Kernel.FKey[ORD(ch) - 0F0H]
END
ELSIF keys # {} THEN
M.id := track; M.X := X; M.Y := Y; M.keys := keys;
REPEAT
V := Viewers.This(M.X, M.Y); V.handle(V, M);
Input.Mouse(M.keys, M.X, M.Y)
UNTIL M.keys = {};
DEC(ActCnt); NotifyTasks
ELSE
IF (X # prevX) OR (Y # prevY) OR ~Mouse.on THEN
M.id := track; M.X := X; M.Y := Y; M.keys := keys; V := Viewers.This(X, Y); V.handle(V, M);
prevX := X; prevY := Y
END;
X11.DoSync; (* << *)
IF X11.EventsQueued(X11.display, X11.QueuedAfterReading) = 0 THEN (* << *)
Kernel.Select(MinTime() - Input.Time()); NotifyTasks;
FOR i := 0 TO 7 DO Kernel.readySet[i] := {} END
END ;
CurTask := PrevTask.next;
IF (CurTask.time <= Input.Time()) & (CurTask.time # -1) THEN
IF ~CurTask.safe THEN PrevTask.next := CurTask.next END;
CurTask.handle; PrevTask.next := CurTask
END;
PrevTask := CurTask
END
END
END Loop;
BEGIN User[0] := 0X;
Arrow.Fade := FlipArrow; Arrow.Draw := FlipArrow;
ArrowFade := FlipArrow; (* << *)
Star.Fade := FlipStar; Star.Draw := FlipStar;
OpenCursor(Mouse); OpenCursor(Pointer);
DW := Display.Width; DH := Display.Height; CL := Display.ColLeft;
H3 := DH - DH DIV 3;
H2 := H3 - H3 DIV 2;
H1 := DH DIV 5;
H0 := DH DIV 10;
(* moved into Configuration.Mod
unitW := DW DIV 8;
OpenDisplay(unitW * 5, unitW * 3, DH);
FocusViewer := Viewers.This(0, 0);
*)
CurFnt := Fonts.Default;
CurCol := Display.white;
CurOff := 0;
Collect(BasicCycle);
NEW(PrevTask);
PrevTask.handle := GC;
PrevTask.safe := TRUE;
PrevTask.time := -1; (* << *)
PrevTask.next := PrevTask;
CurTask := NIL;
Display.SetMode(0, {});
END Oberon.

1363
src/tools/coco/v4_compat/TextFrames.Mod Executable file
View file

File diff suppressed because it is too large Load diff

1362
src/tools/coco/v4_compat/TextFrames.Mod_orig Normal file
View file

File diff suppressed because it is too large Load diff

50
src/tools/ocat/OCatCmd.Mod Normal file
View file

@ -0,0 +1,50 @@
MODULE OCatCmd; (* J. Templ, 13-Jan-96 *)
(* looks at the OBERON search path and writes one or more Oberon or ascii texts to standard out *)
IMPORT Args, Console, Files, Texts := CmdlnTexts;
PROCEDURE Cat*;
VAR path: ARRAY 128 OF CHAR; i: INTEGER; T: Texts.Text; R: Texts.Reader; ch: CHAR; tab: BOOLEAN;
buf: ARRAY 1024 OF CHAR; bufpos: INTEGER;
PROCEDURE ConsoleChar(ch: CHAR); (* buffered write *)
BEGIN buf[bufpos] := ch; INC(bufpos);
IF bufpos = LEN(buf) - 1 THEN buf[bufpos] := 0X; Console.String(buf); bufpos := 0 END
END ConsoleChar;
BEGIN
path := ""; NEW(T);
Args.Get(1, path);
IF path = "-t" THEN tab := TRUE; i := 2; Args.Get(2, path)
ELSE tab := FALSE; i := 1
END ;
WHILE path # "" DO
IF Files.Old(path) # NIL THEN
Texts.Open(T, path);
Texts.OpenReader(R, T, 0); Texts.Read(R, ch); bufpos := 0;
WHILE ~R.eot DO
IF ch >= " " THEN ConsoleChar(ch)
ELSIF ch = 09X THEN
IF tab THEN ConsoleChar(ch) ELSE ConsoleChar(" "); ConsoleChar(" ") END
ELSIF ch = 0DX THEN ConsoleChar(0AX)
END ;
Texts.Read(R, ch)
END ;
buf[bufpos] := 0X; Console.String(buf) (* flush *)
ELSE
Console.String("ocat: cannot open "); Console.String(path); Console.Ln
END ;
INC(i); path := "";
Args.Get(i, path)
END
END Cat;
BEGIN Cat
END OCatCmd.
ocat [-t] files...
-t no tab conversion

69
src/tools/vocparam/vocparam.c Normal file
View file

@ -0,0 +1,69 @@
/* J. Templ 23.6.95
this program tests and outputs important characteristics of
the C compiler and SYSTEM.h file used to compile it.
The output of this program is accepted by voc as file voc.par.
% cc vocparam.c; a.out > voc.par
*/
#include "SYSTEM.h"
#include "stdio.h"
struct {CHAR ch; CHAR x;} c;
struct {CHAR ch; BOOLEAN x;} b;
struct {CHAR ch; SHORTINT x;} si;
struct {CHAR ch; INTEGER x;} i;
struct {CHAR ch; LONGINT x;} li;
struct {CHAR ch; SET x;} s;
struct {CHAR ch; REAL x;} r;
struct {CHAR ch; LONGREAL x;} lr;
struct {CHAR ch; void *x;} p;
struct {CHAR ch; void (*x)();} f;
struct {CHAR ch;} rec0;
struct {CHAR ch; LONGREAL x;} rec1;
struct {char x[65];} rec2;
void main()
{
long x, y;
/* get size and alignment of standard types */
printf("CHAR %d %d\n", sizeof(CHAR), (char*)&c.x - (char*)&c);
printf("BOOLEAN %d %d\n", sizeof(BOOLEAN), (char*)&b.x - (char*)&b);
printf("SHORTINT %d %d\n", sizeof(SHORTINT), (char*)&si.x - (char*)&si);
printf("INTEGER %d %d\n", sizeof(INTEGER), (char*)&i.x - (char*)&i);
printf("LONGINT %d %d\n", sizeof(LONGINT), (char*)&li.x - (char*)&li);
printf("SET %d %d\n", sizeof(SET), (char*)&s.x - (char*)&s);
printf("REAL %d %d\n", sizeof(REAL), (char*)&r.x - (char*)&r);
printf("LONGREAL %d %d\n", sizeof(LONGREAL), (char*)&lr.x - (char*)&lr);
printf("PTR %d %d\n", sizeof p.x, (char*)&p.x - (char*)&p);
printf("PROC %d %d\n", sizeof f.x, (char*)&f.x - (char*)&f);
printf("RECORD %d %d\n", (sizeof rec2 == 65) == (sizeof rec0 == 1), sizeof rec2 - 64);
x = 1;
printf("ENDIAN %d %d\n", *(char*)&x, 0);
if (sizeof(CHAR)!=1) printf("error: CHAR should have size 1\n");
if (sizeof(BOOLEAN)!=1) printf("error: BOOLEAN should have size 1\n");
if (sizeof(SHORTINT)!=1) printf("error: SHORTINT should have size 1\n");
if (sizeof(long)!=sizeof p.x) printf("error: LONGINT should have the same size as pointers\n");
if (sizeof(long)!=sizeof f.x) printf("error: LONGINT should have the same size as function pointers\n");
if (((sizeof rec2 == 65) == (sizeof rec0 == 1)) && ((sizeof rec2 - 64) != sizeof rec0))
printf("error: unsupported record layout sizeof rec0 = %d sizeof rec2 = %d\n", sizeof rec0, sizeof rec2);
/* test the __ASHR macro */
if (__ASHR(-1, 1) != -1) printf("error: ASH(-1, -1) # -1\n");
if (__ASHR(-2, 1) != -1) printf("error: ASH(-2, -1) # -1\n");
if (__ASHR(0, 1) != 0) printf("error: ASH(0, 1) # 0\n");
if (__ASHR(1, 1) != 0) printf("error: ASH(1, 1) # 0\n");
if (__ASHR(2, 1) != 1) printf("error: ASH(2, 1) # 1\n");
/* test the __SETRNG macro */
x = 0; y = sizeof(SET)*8 - 1;
if (__SETRNG(x, y) != -1) printf("error: SETRNG(0, MAX(SET)) != -1\n");
/* test string comparison for extended ascii */
{char a[10], b[10];
a[0] = (CHAR)128; a[1] = 0;
b[0] = 0;
if (__STRCMP(a, b) < 0) printf("error: __STRCMP(a, b) with extended ascii charcters; should be unsigned\n");
}
}