crtable.pas

一个Pascal语言分析器

            list[listLength].deleted := FALSE;
            INC(listLength);
            IF listLength > maxList THEN Restriction(9, listLength)
          END;
        INC(j)
      END;
      INC(i)
    END;
    REPEAT
      i := 0;
      changed := FALSE;
      WHILE i < listLength DO BEGIN
        IF NOT list[i].deleted THEN
          BEGIN
            j := 0;
            onLeftSide := FALSE;
            onRightSide := FALSE;
            WHILE j < listLength DO BEGIN
              IF NOT list[j].deleted THEN
                BEGIN
                  IF list[i].left = list[j].right THEN onRightSide := TRUE;
                  IF list[j].left = list[i].right THEN onLeftSide := TRUE
                END;
              INC(j)
            END;
            IF NOT onRightSide OR NOT onLeftSide THEN
              BEGIN list[i].deleted := TRUE; changed := TRUE END
          END;
        INC(i)
      END
    UNTIL NOT changed;
    Write(CRS.lst, 'Circular derivations:    ');
    i := 0;
    ok := TRUE;
    WHILE i < listLength DO BEGIN
      IF NOT list[i].deleted THEN
        BEGIN
          ok := FALSE;
          WriteLn(CRS.lst);
          Write(CRS.lst, '     ');
          GetSym(list[i].left, sn);
          Write(CRS.lst, sn.name:20, ' --> ');
          GetSym(list[i].right, sn);
          Write(CRS.lst, sn.name:20);
        END;
      INC(i)
    END;
    IF ok THEN Write(CRS.lst, ' -- none --');
    WriteLn(CRS.lst);
  END;

(* LL1Test              Collect terminal sets and checks LL(1) conditions
----------------------------------------------------------------------*) 

PROCEDURE LL1Test (VAR ll1 : BOOLEAN);
  VAR
    sn : SymbolNode;
    curSy : INTEGER;

  PROCEDURE LL1Error (cond, ts : INTEGER);
    VAR
      sn : SymbolNode;
    BEGIN
      ll1 := FALSE;
      WriteLn(CRS.lst);
      Write(CRS.lst, ' LL(1) error in ');
      GetSym(curSy, sn);
      Write(CRS.lst, sn.name, ': ');
      IF ts > 0 THEN
        BEGIN
          GetSym(ts, sn);
          Write(CRS.lst, sn.name, ' is ');
        END;
      CASE cond OF
        1 : Write(CRS.lst, 'the start of several alternatives.');
        2 : Write(CRS.lst, 'the start & successor of a deletable structure');
        3 : Write(CRS.lst, 'an ANY node that matches no symbol');
      END;
    END;

  PROCEDURE Check (cond : INTEGER; VAR s1, s2 : CRTSet);
    VAR
      i : INTEGER;
    BEGIN
      i := 0;
      WHILE i <= maxT DO BEGIN
        IF Sets.IsIn(s1, i) AND Sets.IsIn(s2, i) THEN LL1Error(cond, i);
        INC(i)
      END
    END;

  PROCEDURE CheckAlternatives (gp : INTEGER);
    VAR
      gn, gn1 : GraphNode;
      s1, s2 : CRTSet;
      p : INTEGER;
    BEGIN
      WHILE gp > 0 DO BEGIN
        GetNode(gp, gn);
        IF gn.typ = alt
          THEN
            BEGIN
              p := gp;
              Sets.Clear(s1);
              WHILE p <> 0 DO BEGIN (*for all alternatives*)
                GetNode(p, gn1);
                CompExpected(gn1.p1, curSy, s2);
                Check(1, s1, s2);
                Sets.Unite(s1, s2);
                CheckAlternatives(gn1.p1);
                p := gn1.p2
              END
            END
          ELSE IF (gn.typ = opt) OR (gn.typ = iter) THEN
            BEGIN
              CompExpected(gn.p1, curSy, s1);
              CompExpected(ABS(gn.next), curSy, s2);
              Check(2, s1, s2);
              CheckAlternatives(gn.p1)
            END
          ELSE IF gn.typ = any THEN
            BEGIN
              GetSet(gn.p1, s1);
              IF Sets.Empty(s1) THEN LL1Error(3, 0)
            END
            (*e.g. {ANY} ANY or [ANY] ANY*) ;
        gp := gn.next
      END
    END;

  BEGIN (* LL1Test *)
    Write(CRS.lst, 'LL(1) conditions:');
    curSy := firstNt;
    ll1 := TRUE;
    WHILE curSy <= lastNt DO BEGIN (*for all nonterminals*)
      GetSym(curSy, sn);
      CheckAlternatives(sn.struct);
      INC(curSy)
    END;
    IF ll1 THEN Write(CRS.lst, '         --  ok  --');
    WriteLn(CRS.lst);
  END;

(* TestCompleteness     Test if all nonterminals have productions
----------------------------------------------------------------------*) 

PROCEDURE TestCompleteness (VAR ok : BOOLEAN);
  VAR
    sp : INTEGER;
    sn : SymbolNode;
  BEGIN
    Write(CRS.lst, 'Undefined nonterminals:  ');
    sp := firstNt; ok := TRUE;
    WHILE sp <= lastNt DO BEGIN (*for all nonterminals*)
      GetSym(sp, sn);
      IF sn.struct = 0 THEN
        BEGIN
          ok := FALSE;
          WriteLn(CRS.lst); Write(CRS.lst, '     ', sn.name);
        END;
      INC(sp)
    END;
    IF ok THEN Write(CRS.lst, ' -- none --');
    WriteLn(CRS.lst);
  END;

(* TestIfAllNtReached   Test if all nonterminals can be reached
----------------------------------------------------------------------*) 

PROCEDURE TestIfAllNtReached (VAR ok : BOOLEAN);
  VAR
    gn : GraphNode;
    sp : INTEGER;
    reached : MarkList;
    sn : SymbolNode;

  PROCEDURE MarkReachedNts (gp : INTEGER);
    VAR
      gn : GraphNode;
      sn : SymbolNode;
    BEGIN
      WHILE gp > 0 DO BEGIN
        GetNode(gp, gn);
        IF gn.typ = nt
          THEN
            BEGIN
              IF NOT IsInMarkList(reached, gn.p1) THEN (*new nt reached*)
                BEGIN
                  InclMarkList(reached, gn.p1);
                  GetSym(gn.p1, sn);
                  MarkReachedNts(sn.struct)
                END
            END
          ELSE IF (gn.typ = alt) OR (gn.typ = iter) OR (gn.typ = opt) THEN
            BEGIN
              MarkReachedNts(gn.p1);
              IF gn.typ = alt THEN MarkReachedNts(gn.p2)
            END;
        gp := gn.next
      END
    END;

  BEGIN (* TestIfAllNtReached *)
    ClearMarkList(reached);
    GetNode(root, gn); InclMarkList(reached, gn.p1);
    GetSym(gn.p1, sn); MarkReachedNts(sn.struct);
    Write(CRS.lst, 'Unreachable nonterminals:');
    sp := firstNt; ok := TRUE;
    WHILE sp <= lastNt DO BEGIN (*for all nonterminals*)
      IF NOT IsInMarkList(reached, sp) THEN
        BEGIN
          ok := FALSE; GetSym(sp, sn);
          WriteLn(CRS.lst); Write(CRS.lst, '     ', sn.name)
        END;
      INC(sp)
    END;
    IF ok THEN Write(CRS.lst, ' -- none --');
    WriteLn(CRS.lst);
  END;

(* TestIfNtToTerm   Test if all nonterminals can be derived to terminals
----------------------------------------------------------------------*) 

PROCEDURE TestIfNtToTerm (VAR ok : BOOLEAN);
  VAR
    changed : BOOLEAN;
    sp : INTEGER;
    sn : SymbolNode;
    termList : MarkList;

  FUNCTION IsTerm (gp : INTEGER) : BOOLEAN;
    VAR
      gn : GraphNode;
    BEGIN
      WHILE gp > 0 DO BEGIN
        GetNode(gp, gn);
        IF (gn.typ = nt) AND NOT IsInMarkList(termList, gn.p1)
          OR (gn.typ = alt) AND NOT IsTerm(gn.p1)
             AND ((gn.p2 = 0) OR NOT IsTerm(gn.p2))
          THEN BEGIN IsTerm := FALSE; EXIT END;
        gp := gn.next
      END;
      IsTerm := TRUE
    END;

  BEGIN (* TestIfNtToTerm *)
    ClearMarkList(termList);
    REPEAT
      sp := firstNt;
      changed := FALSE;
      WHILE sp <= lastNt DO BEGIN
        IF NOT IsInMarkList(termList, sp) THEN
          BEGIN
            GetSym(sp, sn);
            IF IsTerm(sn.struct) THEN
              BEGIN InclMarkList(termList, sp); changed := TRUE END
          END;
        INC(sp)
      END
    UNTIL NOT changed;
    Write(CRS.lst, 'Underivable nonterminals:');
    sp := firstNt; ok := TRUE;
    WHILE sp <= lastNt DO BEGIN
      IF NOT IsInMarkList(termList, sp) THEN
        BEGIN
          ok := FALSE; GetSym(sp, sn);
          WriteLn(CRS.lst); Write(CRS.lst, '     ', sn.name);
        END;
      INC(sp)
    END;
    IF ok THEN Write(CRS.lst, ' -- none --');
    WriteLn(CRS.lst);
  END;

(* ASCIIName            Assigns the wellknown ASCII-Name in lowercase
----------------------------------------------------------------------*) 

PROCEDURE ASCIIName (ascii : CHAR; VAR asciiname : Name);
  VAR
    N : INTEGER;
  BEGIN
    CASE ascii OF
      #00 : asciiname := '_nul';
      #01 : asciiname := '_soh';
      #02 : asciiname := '_stx';
      #03 : asciiname := '_etx';
      #04 : asciiname := '_eot';
      #05 : asciiname := '_enq';
      #06 : asciiname := '_ack';
      #07 : asciiname := '_bel';
      #08 : asciiname := '_bs';
      #09 : asciiname := '_ht';
      #10 : asciiname := '_lf';
      #11 : asciiname := '_vt';
      #12 : asciiname := '_ff';
      #13 : asciiname := '_cr';
      #14 : asciiname := '_so';
      #15 : asciiname := '_si';
      #16 : asciiname := '_dle';
      #17 : asciiname := '_dc1';
      #18 : asciiname := '_dc2';
      #19 : asciiname := '_dc3';
      #20 : asciiname := '_dc4';
      #21 : asciiname := '_nak';
      #22 : asciiname := '_syn';
      #23 : asciiname := '_etb';
      #24 : asciiname := '_can';
      #25 : asciiname := '_em';
      #26 : asciiname := '_sub';
      #27 : asciiname := '_esc';
      #28 : asciiname := '_fs';
      #29 : asciiname := '_gs';
      #30 : asciiname := '_rs';
      #31 : asciiname := '_us';
      ' ' : asciiname := '_sp';
      '!' : asciiname := '_bang';
      '"' : asciiname := '_dquote';
      '#' : asciiname := '_hash';
      '$' : asciiname := '_dollar';
      '%' : asciiname := '_percent';
      '&' : asciiname := '_and';
      '''' : asciiname := '_squote';
      '(' : asciiname := '_lparen';
      ')' : asciiname := '_rparen';
      '*' : asciiname := '_star';
      '+' : asciiname := '_plus';
      ',' : asciiname := '_comma';
      '-' : asciiname := '_minus';
      '.' : asciiname := '_point';
      '/' : asciiname := '_slash';
      '0' : asciiname := '_zero';
      '1' : asciiname := '_one';
      '2' : asciiname := '_two';
      '3' : asciiname := '_three';
      '4' : asciiname := '_four';
      '5' : asciiname := '_five';
      '6' : asciiname := '_six';
      '7' : asciiname := '_seven';
      '8' : asciiname := '_eight';
      '9' : asciiname := '_nine';
      ':' : asciiname := '_colon';
      ';' : asciiname := '_semicolon';
      '<' : asciiname := '_less';
      '=' : asciiname := '_equal';
      '>' : asciiname := '_greater';
      '?' : asciiname := '_query';
      '@' : asciiname := '_at';
      'A' .. 'Z', 'a' .. 'z' : BEGIN asciiname := '_ '; asciiname[2] := ascii END;
      '[' : asciiname := '_lbrack';
      '\' : asciiname := '_backslash';
      ']' : asciiname := '_rbrack';
      '^' : asciiname := '_uparrow';
      '_' : asciiname := '_underscore';
      '`' : asciiname := '_accent';
      '{' : asciiname := '_lbrace';
      '|' : asciiname := '_bar';
      '}' : asciiname := '_rbrace';
      '~' : asciiname := '_tilde';
      #127 : asciiname := '_delete';
      ELSE BEGIN
             N := ORD(ascii);
             asciiname := 'ascii  ';
             asciiname[7] := CHR(N MOD 10 + ORD('0'));
             N := N DIV 10;
             asciiname[6] := CHR(N MOD 10 + ORD('0'));
             asciiname[5] := CHR(N DIV 10 + ORD('0'));
           END
    END;
  END;

(* BuildName            Build new Name to represent old string
----------------------------------------------------------------------*) 

PROCEDURE BuildName (VAR old, new : Name);
  VAR
    ForLoop, I : INTEGER;
    TargetIndex : INTEGER;
    ascName : Name;
  BEGIN
    TargetIndex := 1;
    FOR ForLoop := 2 TO Length(old) -1 DO BEGIN
      CASE old[ForLoop] OF
        'A' .. 'Z', 'a' .. 'z' : 
          BEGIN
            IF TargetIndex <= 255 THEN
              BEGIN new[TargetIndex] := old[ForLoop]; INC(TargetIndex); END;
          END;
        ELSE
          BEGIN
            ASCIIName(old[ForLoop], ascName);
            FOR I := 1 TO Length(ascName) DO
              IF TargetIndex <= MaxNameLength - 3 THEN
                BEGIN new[TargetIndex] := ascName[I]; INC(TargetIndex) END;
          END;
      END;
    END;
    new[0] := CHR(TargetIndex-1);
  END;

(* SymName              Generates a new name for a symbol constant
----------------------------------------------------------------------*) 

PROCEDURE SymName (symn : Name; VAR conn : Name);
  BEGIN
    IF (symn[1] = '''') OR (symn[1] = '"')
      THEN IF Length(symn) = 3 THEN ASCIIName(symn[2], conn) ELSE BuildName(symn, conn)
      ELSE conn := symn;
    conn := Concat(conn, 'Sym');
  END;

(* AssignSymNames     Assigns the user defined or generated token names
----------------------------------------------------------------------*) 

PROCEDURE AssignSymNames (default : BOOLEAN; VAR thereExists : BOOLEAN);

  PROCEDURE AssignDef (VAR n (*is not modified*), constant : Name);
    VAR
      ForLoop : INTEGER;
    BEGIN
      FOR ForLoop := 1 TO lastName DO
        IF n = tt[ForLoop].definition THEN
          BEGIN
            constant := tt[ForLoop].name; thereExists := TRUE; EXIT;
          END;
      IF default THEN SymName(n, constant) ELSE constant := ''
    END;

  VAR
    ForLoop : INTEGER;
  BEGIN
    thereExists := default;
    st^[0].constant := 'EOFSYMB';
    FOR ForLoop := 1 TO maxP DO
      AssignDef(st^[ForLoop].name, st^[ForLoop].constant);
    st^[maxT].constant := 'NOSYMB';
  END;

BEGIN (* CRTable *)
  ch := 'A'; WHILE ch <= 'Z' DO BEGIN ddt[ch] := FALSE; INC(ch) END;
  maxSet := 0; Sets.Clear(cset[0]); Sets.Incl(cset[0], eofSy);
  firstNt := maxSymbols; maxP := maxSymbols; maxT :=  -1; maxC :=  -1;
  lastNt := maxP - 1;
  dummyName := 0; lastName := 0; symNames := FALSE; hasUses := FALSE;
  (* The dummy node gn^[0] ensures that none of the procedures
     above have to check for 0 indices. *) 
  NEW(gn);
  NEW(st);
  nNodes := 0;
  gn^[0].typ := -1; gn^[0].p1 := 0;    gn^[0].p2 := 0;
  gn^[0].next := 0; gn^[0].line := 0;
  gn^[0].pos.beg := -1; gn^[0].pos.len := 0; gn^[0].pos.col := 0;
END.