CRA.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 CRA;	(** portable *) (* handles the DFA *)

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

CONST
	maxStates = 300;
	
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
	IF to = firstState THEN SemErr(21) END;
	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; 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;

	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;
	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);$");
			PutS("          IF level = 0 THEN oldEols := chLine - startLine; NextCh; RETURN TRUE END;$");
			PutS("          NextCh;$");
		ELSE
			PutS("          NextCh;$");
			PutS("          IF "); PutChCond(com^.stop[1]); PutS(" THEN$");
			PutS("            DEC(level);$");
			PutS("            IF level=0 THEN oldEols := chLine - startLine; NextCh; RETURN TRUE END;$");
			PutS("            NextCh;$");
			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: 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 Backup*(VAR name: ARRAY OF CHAR);
VAR res, i: INTEGER; bak: ARRAY 64 OF CHAR;
BEGIN
	i := 0;
	WHILE name[i] # 0X DO
		bak[i] := name[i];	INC(i) 
	END;
	bak[i] := '.';	bak[i+1] := 'B';	bak[i+2] := 'a';	bak[i+3] := 'k';	bak[i+4] := 0X;
	Files.Rename(name, bak, res)
END Backup;

PROCEDURE WriteScanner*;
VAR
	scanner: ARRAY 32 OF CHAR;
	startTab: ARRAY 128 OF INTEGER;
	com:      Comment;
	i, j, l:  INTEGER;
	gn:       CRT.GraphNode;
	sn:       CRT.SymbolNode;
	state: State;
	t: Texts.Text;
	f: Files.File;
	len: LONGINT;
	
	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);
	 scanner := sn.name; 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");
	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)  *)
	Backup(scanner);
	f := Files.New(scanner);
	Texts.Store(t, f, 0, len);
	Files.Register(f)
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.