1 MODULE CRA
; (* handles the DFA *)
3 IMPORT Oberon
, Texts
, Sets
, CRS
, CRT
;
10 State
= POINTER TO StateNode
;
11 Action
= POINTER TO ActionNode
;
12 Target
= POINTER TO TargetNode
;
14 StateNode
= RECORD (*state of finite automaton*)
15 nr
: INTEGER; (*state number*)
16 firstAction
: Action
; (*to first action of this state*)
17 endOf
: INTEGER; (*nr. of recognized token if state is final*)
18 ctx
: BOOLEAN; (*TRUE: state reached by contextTrans*)
21 ActionNode
= RECORD (*action of finite automaton*)
22 typ
: INTEGER; (*type of action symbol: char, class*)
23 sym
: INTEGER; (*action symbol*)
24 tc
: INTEGER; (*transition code: normTrans, contextTrans*)
25 target
: Target
; (*states after transition with input symbol*)
28 TargetNode
= RECORD (*state after transition with input symbol*)
29 state
: State
; (*target state*)
33 Comment
= POINTER TO CommentNode
;
34 CommentNode
= RECORD (* info about a comment syntax *)
35 start
,stop
: ARRAY 2 OF CHAR;
40 Melted
= POINTER TO MeltedNode
;
41 MeltedNode
= RECORD (* info about melted states *)
42 set
: CRT
.Set
; (* set of old states *)
43 state
: State
; (* new state *)
50 lastState
: State
; (* last allocated state *)
51 rootState
: State
; (* start state of DFA *)
52 lastSimState
: INTEGER; (* last non melted state *)
53 stateNr
: INTEGER; (*number of last allocated state*)
54 firstMelted
: Melted
; (* list of melted states *)
55 firstComment
: Comment
; (* list of comments *)
56 out
: Texts
.Writer
; (* current output *)
57 fram
: Texts
.Reader
; (* scanner frame input *)
60 PROCEDURE SemErr(nr
: INTEGER);
61 BEGIN CRS
.Error(200+nr
, CRS
.pos
)
64 PROCEDURE Put(ch
: CHAR);
65 BEGIN Texts
.Write(out
, ch
) END Put
;
67 PROCEDURE PutS(s
: ARRAY OF CHAR);
70 WHILE (i
< LEN(s
)) & (s
[i
] # 0X
) DO
71 IF s
[i
] = "$" THEN Texts
.WriteLn(out
) ELSE Texts
.Write(out
, s
[i
]) END;
76 PROCEDURE PutI(i
: INTEGER);
77 BEGIN Texts
.WriteInt(out
, i
, 0) END PutI
;
79 PROCEDURE PutI2(i
, n
: INTEGER);
80 BEGIN Texts
.WriteInt(out
, i
, n
) END PutI2
;
82 PROCEDURE PutC(ch
: CHAR);
84 IF (ch
< " ") OR (ORD(ch
) = 34) THEN PutS("CHR("); PutI(ORD(ch
)); Put(")")
85 ELSE Put(CHR(34)); Put(ch
); Put(CHR(34))
89 PROCEDURE PutRange(s
: CRT
.Set
);
90 VAR lo
, hi
: ARRAY 32 OF CHAR; top
, i
: INTEGER; s1
: CRT
.Set
;
92 (*----- fill lo and hi *)
96 INC(top
); lo
[top
] := CHR(i
); INC(i
);
97 WHILE (i
< 128) & Sets
.In(s
, i
) DO INC(i
) END;
102 (*----- print ranges *)
103 IF (top
= 1) & (lo
[0] = 0X
) & (hi
[1] = 7FX
) & (CHR(ORD(hi
[0]) + 2) = lo
[1]) THEN
104 Sets
.Fill(s1
); Sets
.Differ(s1
, s
); PutS("~ ("); PutRange(s1
); Put(")")
108 IF hi
[i
] = lo
[i
] THEN PutS("(ch="); PutC(lo
[i
])
109 ELSIF lo
[i
] = 0X
THEN PutS("(ch<="); PutC(hi
[i
])
110 ELSIF hi
[i
] = 7FX
THEN PutS("(ch>="); PutC(lo
[i
])
111 ELSE PutS("(ch>="); PutC(lo
[i
]); PutS(") & (ch<="); PutC(hi
[i
])
114 IF i
< top
THEN PutS(" OR ") END;
120 PROCEDURE PutChCond(ch
: CHAR);
122 PutS("(ch ="); PutC(ch
); Put(")")
125 PROCEDURE Length
*(s
: ARRAY OF CHAR): INTEGER;
128 i
:=0; WHILE (i
< LEN(s
)) & (s
[i
] # 0X
) DO INC(i
) END;
133 PROCEDURE AddAction(act
:Action
; VAR head
:Action
);
136 a
:= head
; lasta
:= NIL;
138 IF (a
= NIL) (*collecting classes at the front gives better*)
139 OR (act^
.typ
< a^
.typ
) THEN (*performance*)
141 IF lasta
= NIL THEN head
:= act
ELSE lasta^
.next
:= act
END;
144 lasta
:= a
; a
:= a^
.next
;
149 PROCEDURE DetachAction(a
:Action
; VAR L
:Action
);
151 IF L
= a
THEN L
:= a^
.next
ELSIF L
# NIL THEN DetachAction(a
, L^
.next
) END
155 PROCEDURE TheAction (state
: State
; ch
: CHAR): Action
;
156 VAR a
: Action
; set
: CRT
.Set
;
158 a
:= state
.firstAction
;
160 IF a
.typ
= CRT
.char
THEN
161 IF ORD(ch
) = a
.sym
THEN RETURN a
END
162 ELSIF a
.typ
= CRT
.class
THEN
163 CRT
.GetClass(a^
.sym
, set
);
164 IF Sets
.In(set
, ORD(ch
)) THEN RETURN a
END
172 PROCEDURE AddTargetList(VAR lista
, listb
: Target
);
175 PROCEDURE AddTarget(t
: Target
; VAR list
:Target
);
180 IF (p
= NIL) OR (t^
.state
.nr
< p^
.state
.nr
) THEN EXIT END;
181 IF p^
.state
= t^
.state
THEN RETURN END;
182 lastp
:= p
; p
:= p^
.next
185 IF lastp
=NIL THEN list
:=t
ELSE lastp^
.next
:=t
END
191 NEW(t
); t^
.state
:=p^
.state
; AddTarget(t
, listb
);
197 PROCEDURE NewMelted(set
: CRT
.Set
; state
: State
): Melted
;
200 NEW(melt
); melt^
.set
:= set
; melt^
.state
:= state
;
201 melt^
.next
:= firstMelted
; firstMelted
:= melt
;
206 PROCEDURE NewState(): State
;
209 NEW(state
); INC(stateNr
); state
.nr
:= stateNr
;
210 state
.firstAction
:= NIL; state
.endOf
:= CRT
.noSym
; state
.ctx
:= FALSE
; state
.next
:= NIL;
211 IF firstState
= NIL THEN firstState
:= state
ELSE lastState
.next
:= state
END;
217 PROCEDURE NewTransition(from
, to
: State
; typ
, sym
, tc
: INTEGER);
218 VAR a
: Action
; t
: Target
;
220 NEW(t
); t^
.state
:= to
; t^
.next
:= NIL;
221 NEW(a
); a^
.typ
:= typ
; a^
.sym
:= sym
; a^
.tc
:= tc
; a^
.target
:= t
;
222 AddAction(a
, from
.firstAction
)
226 PROCEDURE NewComment
*(from
, to
: INTEGER; nested
: BOOLEAN);
229 PROCEDURE MakeStr(gp
: INTEGER; VAR s
: ARRAY OF CHAR);
230 VAR i
, n
: INTEGER; gn
: CRT
.GraphNode
; set
: CRT
.Set
;
235 IF gn
.typ
= CRT
.char
THEN
236 IF i
< 2 THEN s
[i
] := CHR(gn
.p1
) END; INC(i
)
237 ELSIF gn
.typ
= CRT
.class
THEN
238 CRT
.GetClass(gn
.p1
, set
);
239 IF Sets
.Elements(set
, n
) # 1 THEN SemErr(26) END;
240 IF i
< 2 THEN s
[i
] := CHR(n
) END; INC(i
)
245 IF i
> 2 THEN SemErr(25) ELSIF i
< 2 THEN s
[i
] := 0X
END
250 MakeStr(from
, com^
.start
); MakeStr(to
, com^
.stop
);
251 com^
.nested
:= nested
;
252 com^
.next
:= firstComment
; firstComment
:= com
256 PROCEDURE MakeSet(p
: Action
; VAR set
: CRT
.Set
);
258 IF p^
.typ
= CRT
.class
THEN CRT
.GetClass(p^
.sym
, set
)
259 ELSE Sets
.Clear(set
); Sets
.Incl(set
, p^
.sym
)
264 PROCEDURE ChangeAction(a
: Action
; set
: CRT
.Set
);
267 IF Sets
.Elements(set
, nr
) = 1 THEN a^
.typ
:= CRT
.char
; a^
.sym
:= nr
269 nr
:= CRT
.ClassWithSet(set
);
270 IF nr
< 0 THEN nr
:= CRT
.NewClass("#0", set
) END; (*class with dummy name*)
271 a^
.typ
:= CRT
.class
; a^
.sym
:= nr
276 PROCEDURE CombineShifts
;
277 VAR state
: State
; n
: INTEGER; a
, b
, c
: Action
; seta
, setb
: CRT
.Set
;
281 a
:= state
.firstAction
;
285 IF (a^
.target^
.state
= b^
.target^
.state
) & (a^
.tc
= b^
.tc
) THEN
286 MakeSet(a
, seta
); MakeSet(b
, setb
); Sets
.Unite(seta
, setb
);
287 ChangeAction(a
, seta
);
288 c
:= b
; b
:= b^
.next
; DetachAction(c
, a
)
299 PROCEDURE DeleteRedundantStates
;
302 state
, s1
, s2
: State
;
304 newState
: ARRAY maxStates
OF State
;
306 PROCEDURE FindUsedStates(state
: State
);
309 IF Sets
.In(used
, state
.nr
) THEN RETURN END;
310 Sets
.Incl(used
, state
.nr
);
311 action
:= state
.firstAction
;
312 WHILE action
# NIL DO
313 FindUsedStates(action^
.target^
.state
);
321 state
:= firstState
.next
; lastState
:= firstState
; stateNr
:= 0; (*firstState has number 0*)
323 IF Sets
.In(used
, state
.nr
) THEN INC(stateNr
); state
.nr
:= stateNr
; lastState
:= state
324 ELSE lastState
.next
:= state
.next
331 Sets
.Clear(used
); FindUsedStates(firstState
);
332 (*---------- combine equal final states ------------*)
333 s1
:= firstState
.next
; (*first state cannot be final*)
335 IF Sets
.In(used
, s1
.nr
) & (s1
.endOf
# CRT
.noSym
) & (s1
.firstAction
= NIL) & ~ s1
.ctx
THEN
338 IF Sets
.In(used
, s2
.nr
) & (s1
.endOf
= s2
.endOf
) & (s2
.firstAction
= NIL) & ~ s2
.ctx
THEN
339 Sets
.Excl(used
, s2
.nr
); newState
[s2
.nr
] := s1
346 state
:= firstState
; (*> state := firstState.next*)
348 IF Sets
.In(used
, state
.nr
) THEN
349 action
:= state
.firstAction
;
350 WHILE action
# NIL DO
351 IF ~ Sets
.In(used
, action
.target
.state
.nr
) THEN
352 action^
.target^
.state
:= newState
[action
.target
.state
.nr
]
354 action
:= action^
.next
360 END DeleteRedundantStates
;
363 PROCEDURE ConvertToStates
*(gp0
, sp
: INTEGER);
364 (*note: gn.line is abused as a state number!*)
365 VAR n
: INTEGER; S
: ARRAY maxStates
OF State
; gn
: CRT
.GraphNode
;
367 PROCEDURE TheState(gp
: INTEGER): State
;
368 VAR state
: State
; gn
: CRT
.GraphNode
;
370 IF gp
= 0 THEN state
:= NewState(); state
.endOf
:= sp
; RETURN state
371 ELSE CRT
.GetNode(gp
, gn
); RETURN S
[gn
.line
]
375 PROCEDURE Step(from
: State
; gp
: INTEGER);
376 VAR gn
: CRT
.GraphNode
;
378 IF gp
= 0 THEN RETURN END;
381 CRT
.class
, CRT
.char
: NewTransition(from
, TheState(ABS(gn
.next
)), gn
.typ
, gn
.p1
, gn
.p2
)
382 | CRT
.alt
: Step(from
, gn
.p1
); Step(from
, gn
.p2
)
383 | CRT
.opt
, CRT
.iter
: Step(from
, ABS(gn
.next
)); Step(from
, gn
.p1
)
387 PROCEDURE FindTrans(gp
: INTEGER; state
: State
);
388 VAR gn
: CRT
.GraphNode
; new
: BOOLEAN;
390 IF gp
= 0 THEN RETURN END; (*end of graph*)
392 IF gn
.line
# 0 THEN RETURN END; (*already visited*)
394 IF new
THEN state
:= NewState() END;
395 INC(n
); S
[n
] := state
; gn
.line
:= n
; CRT
.PutNode(gp
, gn
);
396 IF CRT
.DelGraph(gp
) THEN state
.endOf
:= sp
END; (*state is end state*)
398 CRT
.class
, CRT
.char
: FindTrans(ABS(gn
.next
), NIL);
399 | CRT
.opt
: FindTrans(ABS(gn
.next
), NIL); FindTrans(gn
.p1
, state
)
400 | CRT
.iter
: FindTrans(ABS(gn
.next
), state
); FindTrans(gn
.p1
, state
)
401 | CRT
.alt
: FindTrans(gn
.p1
, state
); FindTrans(gn
.p2
, state
)
403 IF new
OR (state
= firstState
) & (gp
= gp0
) THEN (*start of a group of equally numbered nodes*)
409 IF CRT
.DelGraph(gp0
) THEN SemErr(20) END;
410 CRT
.GetNode(gp0
, gn
);
411 IF gn
.typ
= CRT
.iter
THEN SemErr(21) END;
412 n
:= 0; FindTrans(gp0
, firstState
)
416 PROCEDURE MatchDFA
* (s
: ARRAY OF CHAR; sp
: INTEGER; VAR matchedSp
: INTEGER);
417 VAR state
, to
: State
; a
: Action
; i
, len
: INTEGER;
418 BEGIN (*s with quotes*)
419 state
:= firstState
; i
:= 1; len
:= Length(s
) - 1;
420 LOOP (*try to match s against existing DFA*)
421 IF i
= len
THEN EXIT END;
422 a
:= TheAction(state
, s
[i
]);
423 IF a
= NIL THEN EXIT END;
424 state
:= a
.target
.state
; INC(i
)
426 WHILE i
< len
DO (*make new DFA for s[i..len-1]*)
428 NewTransition(state
, to
, CRT
.char
, ORD(s
[i
]), CRT
.normTrans
);
431 matchedSp
:= state
.endOf
;
432 IF state
.endOf
= CRT
.noSym
THEN state
.endOf
:= sp
END
436 PROCEDURE SplitActions(a
, b
: Action
);
437 VAR c
: Action
; seta
, setb
, setc
: CRT
.Set
;
439 PROCEDURE CombineTransCodes(t1
, t2
: INTEGER; VAR result
:INTEGER);
441 IF t1
= CRT
.contextTrans
THEN result
:= t1
ELSE result
:= t2
END
442 END CombineTransCodes
;
445 MakeSet(a
, seta
); MakeSet(b
, setb
);
446 IF Sets
.Equal(seta
, setb
) THEN
447 AddTargetList(b^
.target
, a^
.target
);
448 CombineTransCodes(a^
.tc
, b^
.tc
, a^
.tc
);
450 ELSIF Sets
.Includes(seta
, setb
) THEN
451 setc
:= seta
; Sets
.Differ(setc
, setb
);
452 AddTargetList(a^
.target
, b^
.target
);
453 CombineTransCodes(a^
.tc
, b^
.tc
, b^
.tc
);
454 ChangeAction(a
, setc
)
455 ELSIF Sets
.Includes(setb
, seta
) THEN
456 setc
:= setb
; Sets
.Differ(setc
, seta
);
457 AddTargetList(b^
.target
, a^
.target
);
458 CombineTransCodes(a^
.tc
, b^
.tc
, a^
.tc
);
459 ChangeAction(b
, setc
)
461 Sets
.Intersect(seta
, setb
, setc
);
462 Sets
.Differ(seta
, setc
);
463 Sets
.Differ(setb
, setc
);
464 ChangeAction(a
, seta
);
465 ChangeAction(b
, setb
);
466 NEW(c
); c^
.target
:=NIL;
467 CombineTransCodes(a^
.tc
, b^
.tc
, c^
.tc
);
468 AddTargetList(a^
.target
, c^
.target
);
469 AddTargetList(b^
.target
, c^
.target
);
470 ChangeAction(c
, setc
);
476 PROCEDURE MakeUnique(state
: State
; VAR changed
:BOOLEAN);
479 PROCEDURE Overlap(a
, b
: Action
): BOOLEAN;
480 VAR seta
, setb
: CRT
.Set
;
482 IF a^
.typ
= CRT
.char
THEN
483 IF b^
.typ
= CRT
.char
THEN RETURN a^
.sym
= b^
.sym
484 ELSE CRT
.GetClass(b^
.sym
, setb
); RETURN Sets
.In(setb
, a^
.sym
)
487 CRT
.GetClass(a^
.sym
, seta
);
488 IF b^
.typ
= CRT
.char
THEN RETURN Sets
.In(seta
, b^
.sym
)
489 ELSE CRT
.GetClass(b^
.sym
, setb
); RETURN ~ Sets
.Different(seta
, setb
)
495 a
:= state
.firstAction
; changed
:= FALSE
;
499 IF Overlap(a
, b
) THEN SplitActions(a
, b
); changed
:=TRUE
END;
507 PROCEDURE MeltStates(state
: State
; VAR correct
:BOOLEAN);
517 PROCEDURE AddMeltedSet(nr
: INTEGER; VAR set
: CRT
.Set
);
521 WHILE (m
# NIL) & (m^
.state
.nr
# nr
) DO m
:= m^
.next
END;
522 IF m
= NIL THEN HALT(98) END;
523 Sets
.Unite(set
, m^
.set
);
526 PROCEDURE GetStateSet(t
: Target
; VAR set
: CRT
.Set
; VAR endOf
: INTEGER; VAR ctx
:BOOLEAN);
527 VAR statenr
: INTEGER; (*lastS: State;*)
529 Sets
.Clear(set
); endOf
:= CRT
.noSym
; ctx
:= FALSE
; (*lastS := NIL;*)
531 statenr
:= t
.state
.nr
;
532 IF statenr
<= lastSimState
THEN Sets
.Incl(set
, statenr
)
533 ELSE AddMeltedSet(statenr
, set
)
535 IF t^
.state^
.endOf
# CRT
.noSym
THEN
536 IF (endOf
= CRT
.noSym
) OR (endOf
= t^
.state^
.endOf
)
537 (*OR (lastS^.firstAction # NIL) & (t^.state^.firstAction = NIL)*) THEN
538 endOf
:= t^
.state
.endOf
; (*lastS := t^.state*)
540 PutS("$Tokens "); PutI(endOf
); PutS(" and "); PutI(t^
.state
.endOf
);
541 PutS(" cannot be distinguished.$");
545 IF t^
.state
.ctx
THEN ctx
:= TRUE
;
546 IF t
.state
.endOf
# CRT
.noSym
THEN
547 PutS("$Ambiguous CONTEXT clause.$"); correct
:= FALSE
554 PROCEDURE FillWithActions(state
: State
; targ
: Target
);
555 VAR action
,a
: Action
;
558 action
:= targ^
.state
.firstAction
;
559 WHILE action
# NIL DO
560 NEW(a
); a^
:= action^
; a^
.target
:= NIL;
561 AddTargetList(action^
.target
, a^
.target
);
562 AddAction(a
, state
.firstAction
);
569 PROCEDURE KnownMelted(set
:CRT
.Set
; VAR melt
: Melted
): BOOLEAN;
573 IF Sets
.Equal(set
, melt^
.set
) THEN RETURN TRUE
END;
580 action
:= state
.firstAction
;
581 WHILE action
# NIL DO
582 IF action^
.target^
.next
# NIL THEN (*more than one target state*)
583 GetStateSet(action^
.target
, set
, endOf
, ctx
);
584 IF ~
KnownMelted(set
, melt
) THEN
585 s
:= NewState(); s
.endOf
:= endOf
; s
.ctx
:= ctx
;
586 FillWithActions(s
, action^
.target
);
587 REPEAT MakeUnique(s
, changed
) UNTIL ~ changed
;
588 melt
:= NewMelted(set
, s
);
590 action^
.target^
.next
:=NIL;
591 action^
.target^
.state
:= melt^
.state
593 action
:= action^
.next
595 Texts
.Append(Oberon
.Log
, out
.buf
)
599 PROCEDURE MakeDeterministic
*(VAR correct
: BOOLEAN);
600 VAR state
: State
; changed
: BOOLEAN;
602 PROCEDURE FindCtxStates
; (*find states reached by a context transition*)
603 VAR a
: Action
; state
: State
;
607 a
:= state
.firstAction
;
609 IF a^
.tc
= CRT
.contextTrans
THEN a^
.target^
.state
.ctx
:= TRUE
END;
617 IF lastState
= NIL THEN lastSimState
:= 0 ELSE lastSimState
:= lastState
.nr
END;
621 REPEAT MakeUnique(state
, changed
) UNTIL ~ changed
;
626 WHILE state
# NIL DO MeltStates(state
, correct
); state
:= state
.next
END;
627 DeleteRedundantStates
;
629 END MakeDeterministic
;
632 PROCEDURE PrintSymbol(typ
, val
, width
: INTEGER);
633 VAR name
: CRT
.Name
; len
: INTEGER;
635 IF typ
= CRT
.class
THEN
636 CRT
.GetClassName(val
, name
); PutS(name
); len
:= Length(name
)
637 ELSIF (val
>= ORD(" ")) & (val
< 127) & (val
# 34) THEN
638 Put(CHR(34)); Put(CHR(val
)); Put(CHR(34)); len
:=3
640 PutS("CHR("); PutI2(val
, 2); Put(")"); len
:=7
642 WHILE len
< width
DO Put(" "); INC(len
) END
646 PROCEDURE PrintStates
*;
647 VAR action
: Action
; first
: BOOLEAN; state
: State
; i
: INTEGER; targ
: Target
; set
: CRT
.Set
; name
: CRT
.Name
;
649 PutS("$-------- states ---------$");
652 action
:= state
.firstAction
; first
:=TRUE
;
653 IF state
.endOf
= CRT
.noSym
THEN PutS(" ")
654 ELSE PutS("E("); PutI2(state
.endOf
, 2); Put(")")
656 PutI2(state
.nr
, 3); Put(":"); IF action
= NIL THEN PutS(" $") END;
657 WHILE action
# NIL DO
658 IF first
THEN Put(" "); first
:=FALSE
ELSE PutS(" ") END;
659 PrintSymbol(action^
.typ
, action^
.sym
, 0); Put(" ");
660 targ
:= action^
.target
;
662 PutI(targ^
.state
.nr
); Put(" "); targ
:= targ^
.next
;
664 IF action^
.tc
= CRT
.contextTrans
THEN PutS(" context$") ELSE PutS(" $") END;
665 action
:= action^
.next
669 PutS("$-------- character classes ---------$");
671 WHILE i
<= CRT
.maxC
DO
672 CRT
.GetClass(i
, set
); CRT
.GetClassName(i
, name
); PutS(name
); PutS(": ");
673 Sets
.Print(out
, set
, 80, 13); Texts
.WriteLn(out
);
676 Texts
.Append(Oberon
.Log
, out
.buf
)
680 PROCEDURE GenComment(com
:Comment
);
685 PutS(" IF "); PutChCond(com^
.stop
[0]); PutS(" THEN$");
686 IF Length(com^
.stop
) = 1 THEN
687 PutS(" DEC(level); oldEols := chLine - startLine; NextCh;$");
688 PutS(" IF level = 0 THEN RETURN TRUE END;$");
691 PutS(" IF "); PutChCond(com^
.stop
[1]); PutS(" THEN$");
692 PutS(" DEC(level); oldEols := chLine - startLine; NextCh;$");
693 PutS(" IF level=0 THEN RETURN TRUE END$");
697 PutS(" ELSIF "); PutChCond(com^
.start
[0]); PutS(" THEN$");
698 IF Length(com^
.start
) = 1 THEN
699 PutS(" INC(level); NextCh;$");
702 PutS(" IF "); PutChCond(com^
.start
[1]); PutS(" THEN$");
703 PutS(" INC(level); NextCh;$");
707 PutS(" ELSIF ch = EOF THEN RETURN FALSE$");
708 PutS(" ELSE NextCh END;$");
713 PutS(" IF "); PutChCond(com^
.start
[0]); PutS(" THEN$");
714 IF Length(com^
.start
) = 1 THEN
720 PutS(" IF "); PutChCond(com^
.start
[1]); PutS(" THEN$");
724 PutS(" IF ch = EOL THEN DEC(chLine); lineStart := oldLineStart END;$");
725 PutS(" DEC(chPos, 2); Texts.OpenReader(r, src, chPos+1); NextCh; RETURN FALSE$");
732 PROCEDURE CopyFramePart (stopStr
: ARRAY OF CHAR); (*Copy from file <fram> to file <out> until <stopStr>*)
733 VAR ch
, startCh
: CHAR; i
, j
, high
: INTEGER;
735 startCh
:= stopStr
[0]; high
:= Length(stopStr
) - 1; Texts
.Read (fram
, ch
);
737 IF ch
= startCh
THEN (* check if stopString occurs *)
740 IF i
= high
THEN RETURN END; (*stopStr[0..i] found; no unrecognized character*)
741 Texts
.Read (fram
, ch
); INC(i
);
742 UNTIL ch
# stopStr
[i
];
743 (*stopStr[0..i-1] found; 1 unrecognized character*)
744 j
:= 0; WHILE j
< i
DO Texts
.Write(out
, stopStr
[j
]); INC(j
) END
745 ELSE Texts
.Write (out
, ch
); Texts
.Read(fram
, ch
)
750 PROCEDURE GenLiterals
;
753 key
: ARRAY 128 OF CRT
.Name
;
754 knr
: ARRAY 128 OF INTEGER;
758 (*-- sort literal list*)
760 WHILE i
<= CRT
.maxT
DO
762 IF sn
.struct
= CRT
.litToken
THEN
763 j
:= k
-1; WHILE (j
>= 0) & (sn
.name
< key
[j
]) DO key
[j
+1] := key
[j
]; knr
[j
+1] := knr
[j
]; DEC(j
) END;
764 key
[j
+1] := sn
.name
; knr
[j
+1] := i
; INC(k
)
768 (*-- print case statement*)
770 PutS(" IF (lexeme[0] >= "); PutC(key
[0, 1]); PutS(") & (lexeme[0] <= "); PutC(key
[k
-1, 1]); PutS(") THEN$");
771 PutS(" CASE lexeme[0] OF$");
774 ch
:= key
[i
, 1]; (*key[i, 0] = quote*)
775 PutS(" | "); PutC(ch
); j
:= i
;
777 IF i
= j
THEN PutS(": IF lexeme = ") ELSE PutS(" ELSIF lexeme = ") END;
778 PutS(key
[i
]); PutS(" THEN sym := "); PutI(knr
[i
]); Put(CHR(13));
780 UNTIL (i
= k
) OR (key
[i
, 1] # ch
);
783 PutS(" ELSE$ END$ END;$")
788 PROCEDURE WriteState(state
: State
);
789 VAR action
: Action
; first
, ctxEnd
: BOOLEAN; sn
: CRT
.SymbolNode
; endOf
: INTEGER;
792 endOf
:= state
.endOf
;
793 IF (endOf
> CRT
.maxT
) & (endOf
# CRT
.noSym
) THEN (*pragmas have been moved*)
794 endOf
:= CRT
.maxT
+ CRT
.maxSymbols
- endOf
796 PutS(" | "); PutI2(state
.nr
, 2); PutS(": ");
797 first
:=TRUE
; ctxEnd
:= state
.ctx
;
798 action
:= state
.firstAction
;
799 WHILE action
# NIL DO
800 IF first
THEN PutS("IF "); first
:=FALSE
ELSE PutS(" ELSIF ") END;
801 IF action^
.typ
= CRT
.char
THEN PutChCond(CHR(action^
.sym
))
802 ELSE CRT
.GetClass(action^
.sym
, set
); PutRange(set
)
805 IF action
.target
.state
.nr
# state
.nr
THEN
806 PutS(" state := "); PutI(action
.target
.state
.nr
); Put(";")
808 IF action^
.tc
= CRT
.contextTrans
THEN PutS(" INC(apx)"); ctxEnd
:= FALSE
809 ELSIF state
.ctx
THEN PutS(" apx := 0")
812 action
:= action^
.next
814 IF state
.firstAction
# NIL THEN PutS(" ELSE ") END;
815 IF endOf
= CRT
.noSym
THEN PutS("sym := noSym; ")
817 CRT
.GetSym(endOf
, sn
);
818 IF ctxEnd
THEN (*final context state: cut appendix*)
819 PutS("chPos := chPos - apx - 1; Texts.OpenReader(r, src, chPos+1); NextCh; ")
821 PutS("sym := "); PutI(endOf
); PutS("; ");
822 IF sn
.struct
= CRT
.classLitToken
THEN PutS("CheckLiteral; ") END
825 IF state
.firstAction
# NIL THEN PutS(" END;$") END
828 PROCEDURE *Show (t
: Texts
.Text
; op
: INTEGER; beg
, end
: LONGINT);
832 PROCEDURE WriteScanner
*;
834 scanner
: ARRAY 32 OF CHAR;
835 name
: ARRAY 64 OF CHAR;
836 startTab
: ARRAY 128 OF INTEGER;
844 PROCEDURE FillStartTab
;
845 VAR action
: Action
; i
, targetState
: INTEGER; class
: CRT
.Set
;
847 startTab
[0] := stateNr
+ 1; (*eof*)
848 i
:= 1; WHILE i
< 128 DO startTab
[i
] := 0; INC(i
) END;
849 action
:= firstState
.firstAction
;
850 WHILE action
# NIL DO
851 targetState
:= action
.target
.state
.nr
;
852 IF action^
.typ
= CRT
.char
THEN
853 startTab
[action^
.sym
] := targetState
855 CRT
.GetClass(action^
.sym
, class
); i
:= 0;
857 IF Sets
.In(class
, i
) THEN startTab
[i
] := targetState
END;
861 action
:= action^
.next
867 CRT
.GetNode(CRT
.root
, gn
); CRT
.GetSym(gn
.p1
, sn
);
868 COPY(sn
.name
, scanner
); l
:= Length(scanner
); scanner
[l
] := "S"; scanner
[l
+1] := 0X
;
869 NEW(t
); Texts
.Open(t
, "Scanner.FRM"); Texts
.OpenReader(fram
, t
, 0);
871 Texts
.WriteString(out
, "Scanner.FRM not found"); Texts
.WriteLn(out
);
872 Texts
.Append(Oberon
.Log
, out
.buf
); HALT(99)
874 Texts
.Append(Oberon
.Log
, out
.buf
);
876 (*------- *S.MOD -------*)
877 CopyFramePart("-->modulename"); PutS(scanner
);
878 CopyFramePart("-->declarations"); PutS(" noSym = "); PutI(CRT
.maxT
); Put(";");
879 CopyFramePart("-->comment");
881 WHILE com
# NIL DO GenComment(com
); com
:= com^
.next
END;
882 CopyFramePart("-->literals"); GenLiterals
;
884 CopyFramePart("-->GetSy1");
885 IF ~ Sets
.In(CRT
.ignored
, ORD(EOL
)) THEN PutS(" IF oldEols > 0 THEN DEC(oldEols); ch := EOL END;$") END;
886 PutS(" WHILE (ch=20X)"); IF ~ Sets
.Empty(CRT
.ignored
) THEN PutS(" OR ") END;
887 PutRange(CRT
.ignored
); PutS(" DO NextCh END;");
888 IF firstComment
# NIL THEN
889 PutS("$ IF ("); com
:= firstComment
;
891 PutChCond(com^
.start
[0]);
892 IF com^
.next
# NIL THEN PutS(" OR ") END;
895 PutS(") & Comment() THEN Get(sym); RETURN END;")
897 CopyFramePart("-->GetSy2");
898 state
:= firstState
.next
;
899 WHILE state
# NIL DO WriteState(state
); state
:= state
.next
END;
900 PutS(" | "); PutI2(stateNr
+ 1, 2); PutS(": sym := 0; ch := 0X; RETURN$");
902 CopyFramePart("-->initialization");
907 PutS("start["); PutI(4*i
+j
); PutS("]:="); PutI(startTab
[4*i
+j
]); PutS("; ");
914 CopyFramePart("-->modulename"); PutS(scanner
); Put(".");
915 NEW(t
); t
.notify
:= Show
; Texts
.Open(t
, ""); Texts
.Append(t
, out
.buf
);
916 l
:= Length(scanner
); scanner
[l
] := "."; scanner
[l
+1] := "M"; scanner
[l
+2] := "o"; scanner
[l
+3] := "d"; scanner
[l
+4] := 0X
;
917 Texts
.Close(t
, scanner
)
923 firstState
:= NIL; lastState
:= NIL; stateNr
:= -1;
924 rootState
:= NewState();
925 firstMelted
:= NIL; firstComment
:= NIL
929 Texts
.OpenWriter(out
)