MODULE CRA;  (* handles the DFA *)

IMPORT Oberon, Texts, 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.