CRX.Mod

(* OBERON System 3, Release 2.3.

Copyright 1999 ETH Zürich Institute for Computer Systems, 
ETH Center, CH-8092 Zürich. e-mail: oberon@inf.ethz.ch.

This module may be used under the conditions of the general Oberon 
System 3 license contract. The full text can be downloaded from

	"ftp://ftp.inf.ethz.ch/pub/software/Oberon/System3/license.txt;A"

Under the license terms stated it is in particular (a) prohibited to modify
the interface of this module in any way that disagrees with the style
or content of the system and (b) requested to provide all conversions
of the source code to another platform with the name OBERON. *)

MODULE CRX;	(** portable *)

IMPORT Oberon, Texts, Sets, CRS, CRT, CRA, Files;

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;
	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);  name := sn.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 i, n: INTEGER;

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: 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 GenCompiler*;
	VAR errNr, i: INTEGER; checked: CRT.Set;
			gn: CRT.GraphNode; sn: CRT.SymbolNode;
			parser: ARRAY 32 OF CHAR;
			t: Texts.Text; pos: LONGINT;	f: Files.File;
BEGIN
	CRT.GetNode(CRT.root, gn); CRT.GetSym(gn.p1, sn);
	 parser := sn.name; i := Length(parser); parser[i] := "P"; parser[i+1] := 0X;
	 scanner := parser; 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)  *)
	CRA.Backup(parser);
	f := Files.New(parser);
	Texts.Store(t, f, 0, pos);
	Files.Register(f)
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.