UNIT CRA;
(* CRA     Automaton and Scanner Generation
   ===     ================================

  (1) ConvertToStates translates a top-down graph into a NFA.
      MatchDFA tries to match literal strings against the DFA
  (2) MakeDeterministic converts the NFA into a DFA
  (3) WriteScanner generates the scanner source file

  ----------------------------------------------------------------*)

INTERFACE

CONST
  MaxSourceLineLength = 78;

TYPE
  PutSProc = PROCEDURE (S : STRING);

PROCEDURE CopyFramePart (stopStr: STRING; VAR leftMarg: INTEGER;
                         VAR framIn, framOut : TEXT);
(* "stopStr" must not contain "FileIO.EOL".
   "leftMarg" is in/out-parameter  --  it has to be set once by the
   calling program.    *)

PROCEDURE ImportSymConsts (leader: STRING; putS: PutSProc);
(* Generates the USES references for the eventually existing named constants. *)

PROCEDURE ConvertToStates (gp0, sp: INTEGER);
(* Converts top-down graph with root gp into a subautomaton that
   recognizes token sp *)

PROCEDURE MatchDFA (str: STRING; sp : INTEGER; VAR matchedSp: INTEGER);
(* Returns TRUE, if string str can be recognized by the current DFA.
   matchedSp is the token as that s can be recognized. *)

PROCEDURE MakeDeterministic (VAR correct: BOOLEAN);
(* Converts the NFA into a DFA. correct indicates if an error occurred. *)

PROCEDURE NewComment (start, stop: INTEGER; nested: BOOLEAN);
(* Defines a new comment for the scanner. The comment brackets are
   represented by the mini top-down graphs with the roots from and to. *)

PROCEDURE WriteScanner;
(* Emits the source code of the generated scanner using the frame file
   scanner.frm *)

PROCEDURE PrintStates;
(* List the automaton for tracing *)

IMPLEMENTATION

USES CRS, CRTable, FileIO, Sets;

CONST
  maxStates = 500;
  cr = #13;
TYPE
  Action = ^ ActionNode;
  Target = ^ TargetNode;
  State = 
    RECORD                     (* state of finite automaton *)
      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 *)
    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 *)
      theState : INTEGER;      (* target state *)
      next : Target;
    END;
  Comment = ^ CommentNode;
  STRING2 = STRING[2];
  CommentNode = 
    RECORD                     (* info about a comment syntax *)
      start, stop : STRING2;
      nested : BOOLEAN;
      next : Comment;
    END;
  Melted = ^ MeltedNode;
  MeltedNode = 
    RECORD                     (* info about melted states *)
      sset : CRTable.CRTSet;   (* set of old states *)
      theState : INTEGER;      (* new state *)
      next : Melted;
    END;

VAR
  stateArray : ARRAY [0 .. maxStates] OF State;
  lastSimState : INTEGER;      (* last non melted state *)
  lastState : INTEGER;         (* last allocated state  *)
  rootState : INTEGER;         (* start state of DFA    *)
  firstMelted : Melted;        (* list of melted states *)
  firstComment : Comment;      (* list of comments      *)
  scanner,                     (* generated scanner     *)
  fram : TEXT;                 (* scanner frame         *)
  NewLine : BOOLEAN;

PROCEDURE SemErr (nr : INTEGER);
  BEGIN
    CRS.Error(nr + 100, CRS.line, CRS.col, CRS.pos)
  END;

PROCEDURE Put (ch : CHAR);
  BEGIN
    Write(scanner, ch)
  END;

PROCEDURE PutLn;
  BEGIN
    WriteLn(scanner)
  END;

PROCEDURE PutB (n : INTEGER);
  BEGIN
    Write(scanner, ' ':n);
  END;

PROCEDURE Indent (n : INTEGER);
  BEGIN
    IF NewLine THEN PutB(n) ELSE NewLine := TRUE
  END;

PROCEDURE PutS (s : STRING); FAR;
  VAR
    i : INTEGER;
  BEGIN
    FOR i := 1 TO Length(s) DO
      IF s[i] = '$' THEN WriteLn(scanner) ELSE Write(scanner, s[i]);
  END;

PROCEDURE PutS1 (s : STRING);
  BEGIN
    IF s[1] = '"' THEN BEGIN s[1] := ''''; s[Length(s)] := '''' END; PutS(s);
  END;

PROCEDURE PutI (i : INTEGER);
  BEGIN
    Write(scanner, i:1)
  END;

PROCEDURE PutI2 (i, n : INTEGER);
  BEGIN
    Write(scanner, i:n)
  END;

PROCEDURE PutC (ch : CHAR);
  BEGIN
    CASE ch OF
      #0 .. #31, #127 .. #255, '''' : BEGIN  PutS('CHR('); PutI(ORD(ch)); Put(')') END;
      ELSE BEGIN Put(''''); Put(ch); Put('''') END
    END
  END;

PROCEDURE PutSN (i : INTEGER);
  VAR
    sn : CRTable.SymbolNode;
  BEGIN
    CRTable.GetSym(i, sn);
    IF Length(sn.constant) > 0 THEN PutS(sn.constant) ELSE PutI(i);
  END;

PROCEDURE PutSE (i : INTEGER);
  BEGIN
    PutS('BEGIN sym := '); PutSN(i); PutS('; ');
  END;

PROCEDURE PutRange (s : CRTable.CRTSet; indent : INTEGER);
  VAR
    lo, hi : ARRAY [0 .. 31] OF CHAR;
    top, i : INTEGER;
    s1 : CRTable.CRTSet;

  BEGIN
  (*----- fill lo and hi *) 
    top :=  -1;
    i := 0;
    WHILE i < 256 (*PDT*)  DO BEGIN
      IF Sets.IsIn(s, i)
        THEN
          BEGIN
            INC(top); lo[top] := CHR(i); INC(i);
            WHILE (i < 256 (*PDT*) ) AND Sets.IsIn(s, i) DO INC(i);
            hi[top] := CHR(i - 1)
          END
        ELSE INC(i)
    END;
    (*----- print ranges *) 
    IF (top = 1) AND (lo[0] = #0) AND (hi[1] = #255
    (*PDT*) ) AND (CHR(ORD(hi[0]) + 2) = lo[1])
      THEN
        BEGIN
          Sets.Fill(s1); Sets.Differ(s1, s);
          PutS('NOT ('); PutRange(s1, indent); Put(')')
        END
      ELSE
        BEGIN
          i := 0;
          WHILE i <= top DO BEGIN
            IF hi[i] = lo[i]
              THEN BEGIN PutS('(ch = '); PutC(lo[i]) END
              ELSE IF lo[i] = #0 THEN
                BEGIN PutS('(ch <= '); PutC(hi[i]) END
              ELSE IF hi[i] = #255 (*PDT*)  THEN
                BEGIN PutS('(ch >= '); PutC(lo[i]) END
              ELSE
                BEGIN
                  PutS('(ch >= '); PutC(lo[i]); PutS(') AND (ch <= ');
                  PutC(hi[i])
                END;
            Put(')');
            IF i < top THEN BEGIN PutS(' OR$'); PutB(indent) END;
            INC(i)
          END
        END
  END;

PROCEDURE PutChCond (ch : CHAR);
  BEGIN
    PutS('(ch = '); PutC(ch); Put(')')
  END;

(* PrintStates          List the automaton for tracing
-------------------------------------------------------------------------*) 

PROCEDURE PrintStates;

  PROCEDURE PrintSymbol (typ, val, width : INTEGER);
    VAR
      name : CRTable.Name;
      len : INTEGER;
    BEGIN
      IF typ = CRTable.class
        THEN
          BEGIN
            CRTable.GetClassName(val, name);
            Write(CRS.lst, name); len := Length(name)
          END
        ELSE IF (val >= ORD(' ')) AND (val < 127) AND (val <> 34) THEN
          BEGIN Write(CRS.lst, '"', CHR(val), '"'); len := 3 END
        ELSE
          BEGIN Write(CRS.lst, 'CHR(', val:2, ')'); len := 7 END;
      WHILE len < width DO BEGIN Write(CRS.lst, ' '); INC(len) END
    END;

  VAR
    anAction : Action;
    first : BOOLEAN;
    s, i : INTEGER;
    targ : Target;
    sset : CRTable.CRTSet;
    name : CRTable.Name;
  BEGIN
    WriteLn(CRS.lst); WriteLn(CRS.lst, '-------- states ---------');
    s := rootState;
    WHILE s <= lastState DO BEGIN
      anAction := stateArray[s].firstAction;
      first := TRUE;
      IF stateArray[s].endOf = CRTable.noSym
        THEN Write(CRS.lst, '     ')
        ELSE Write(CRS.lst, 'E(', stateArray[s].endOf:2, ')');
      Write(CRS.lst, s:3, ':');
      IF anAction = NIL THEN WriteLn(CRS.lst);
      WHILE anAction <> NIL DO BEGIN
        IF first
          THEN BEGIN Write(CRS.lst, ' '); first := FALSE END
          ELSE BEGIN Write(CRS.lst, '          ') END;
        PrintSymbol(anAction^.typ, anAction^.sym, 0);
        Write(CRS.lst, ' ');
        targ := anAction^.target;
        WHILE targ <> NIL DO BEGIN
          Write(CRS.lst, targ^.theState:1, ' '); targ := targ^.next;
        END;
        IF anAction^.tc = CRTable.contextTrans
          THEN WriteLn(CRS.lst, ' context')
          ELSE WriteLn(CRS.lst);
        anAction := anAction^.next
      END;
      INC(s)
    END;
    WriteLn(CRS.lst); WriteLn(CRS.lst, '-------- character classes ---------');
    i := 0;
    WHILE i <= CRTable.maxC DO BEGIN
      CRTable.GetClass(i, sset); CRTable.GetClassName(i, name);
      Write(CRS.lst, name:10, ': ');
      Sets.Print(CRS.lst, sset, 80, 13);
      WriteLn(CRS.lst);
      INC(i)
    END
  END;

(* AddAction            Add a action to the action list of a state
------------------------------------------------------------------------*) 

PROCEDURE AddAction (act : Action; VAR head : Action);
  VAR
    a, lasta : Action;
  BEGIN
    a := head;
    lasta := NIL;
    WHILE TRUE DO BEGIN
      IF (a = NIL) OR (act^.typ < a^.typ) THEN
        (*collecting classes at the front improves performance*) 
        BEGIN
          act^.next := a;
          IF lasta = NIL THEN head := act ELSE lasta^.next := act;
          EXIT;
        END;
      lasta := a;
      a := a^.next;
    END;
  END;

(* DetachAction         Detach action a from list L
------------------------------------------------------------------------*) 

PROCEDURE DetachAction (a : Action; VAR L : Action);
  BEGIN
    IF L = a THEN L := a^.next ELSE IF L <> NIL THEN DetachAction(a, L^.next)
  END;

FUNCTION TheAction (theState : State; ch : CHAR) : Action;
  VAR
    a : Action;
    sset : CRTable.CRTSet;
  BEGIN
    a := theState.firstAction;
    WHILE a <> NIL DO BEGIN
      IF a^.typ = CRTable.chart
        THEN
          BEGIN
            IF ORD(ch) = a^.sym THEN BEGIN TheAction := a; EXIT END
          END
        ELSE IF a^.typ = CRTable.class THEN
          BEGIN
            CRTable.GetClass(a^.sym, sset);
            IF Sets.IsIn(sset, ORD(ch)) THEN BEGIN TheAction := a; EXIT END
          END;
      a := a^.next
    END;
    TheAction := NIL
  END;

PROCEDURE AddTargetList (VAR lista, listb : Target);
  VAR
    p, t : Target;

  PROCEDURE AddTarget (t : Target; VAR list : Target);
    LABEL
      999;
    VAR
      p, lastp : Target;
    BEGIN
      p := list;
      lastp := NIL;
      WHILE TRUE DO BEGIN
        IF (p = NIL) OR (t^.theState < p^.theState) THEN GOTO 999;
        IF p^.theState = t^.theState THEN BEGIN DISPOSE(t); EXIT END;
        lastp := p; p := p^.next
      END;
      999:
      t^.next := p;
      IF lastp = NIL THEN list := t ELSE lastp^.next := t
    END;

  BEGIN