{$T-}
program PASRF2;
{PASCAL cross reference generator using a binary tree.
 Adapted from  Algorithms + Data Structures = Programs,
 by Niklaus Wirth  (pp. 206-210).
 
 There are two versions of this program:
   - PASREF is intended for use with source
       programs with Pascal reserved words
       typed in lower case.  References are
       printed for all identifiers typed
       in upper case.
   - PASRF2 is intended for use with source
       programs with Pascal reserved words
       typed in upper case.  References are
       printed for identifiers typed in
       upper case which are not Pascal reserved
       words.  PASRF2 can be used with both
       types of programs.
 
 For very large programs, it may be necessary
 to increase the heap size.  A heap size of
 70000 (octal) bytes should be sufficient for
 programs of about 2000 lines or more.
 
 V1C - Bill Heidebrecht - 10 Nov 77
       TRW Systems
       One Space Park
       Redondo Beach, CA 90278}
 
const C1 = 12;    {length of words}
      C2 = 12;    {numbers per line}
      C3 =  6;    {digits per number}
      NL = CHR(10); FF = CHR(12);
 
type ALFA = array [1..C1] of CHAR;
     WORDREF = @WORD;
     ITEMREF = @ITEM;
     WORD = record KEY: ALFA;
                   FIRST, LAST: ITEMREF;
                   LEFT, RIGHT: WORDREF
            end;
     ITEM = record
                   LNO:  INTEGER;
                   NEXT: ITEMREF
            end;
     COMPARE = (LT, EQ, GT);
 
var
     ROOT: WORDREF;
     K, K1: INTEGER;
     NCL: INTEGER;      {current line number}
     IDX: ALFA;
     LST, INFILE: TEXT;
     FILENAME: array [1..32] of CHAR;
     DONE, PRINTSOURCE: BOOLEAN;
     CH: CHAR;
 
 
function MATCH (W: WORDREF): COMPARE;
var I: INTEGER; DIFFERENT: BOOLEAN;
    B: ALFA;
begin
  MATCH:= EQ;
  DIFFERENT:= FALSE;
  B:= W@.KEY; I:= 0;
  repeat
    I:= I+1;
    if IDX[I] # B[I] then
    begin
      DIFFERENT:= TRUE;
      if IDX[I] > B[I] then MATCH:= GT
                       else MATCH:= LT
    end;
  until DIFFERENT ! (I>=C1);
end;
 
procedure SEARCH (var W1: WORDREF);
var W: WORDREF; X: ITEMREF;
begin
  W:= W1;
  if W = NIL then
  begin  {insert new identifier into tree}
    NEW(W); NEW(X);
    with W@ do begin
      KEY:= IDX; LEFT:= NIL; RIGHT:= NIL;
      FIRST:= X; LAST:= X;
    end;
    X@.LNO:= NCL; X@.NEXT:= NIL; W1:= W
  end
  else begin
    case MATCH(W) of
      LT: SEARCH(W@.LEFT);
      GT: SEARCH(W@.RIGHT);
      EQ: begin  {add reference to existing list}
            NEW(X); X@.LNO:= NCL; X@.NEXT:= NIL;
            W@.LAST@.NEXT:= X; W@.LAST:= X
          end
    end {case}
  end
end; {SEARCH}
 
procedure PRINTTREE (W2: WORDREF);
var W: WORDREF;
 
  procedure PRINTWORD (W1: WORDREF);
  var L, LINENO: INTEGER; X: ITEMREF;
      WA: WORD;
  begin
    WA:= W1@;
    WRITE(LST,' ',WA.KEY);
    X:= WA.FIRST; L:= 0;
    repeat if L = C2 then
           begin
             L:= 0;
             WRITE(LST,NL,' ':13)
           end;
      L:= L+1;
      LINENO:= X@.LNO;
      WRITE(LST,LINENO:C3); X:= X@.NEXT
    until X = NIL;
    WRITE(LST,NL)
  end; {PRINTWORD}
 
begin {PRINTTREE}
  W:= W2;
  if W # NIL then
  begin PRINTTREE(W@.LEFT);
        PRINTWORD(W); PRINTTREE(W@.RIGHT)
  end
end; {PRINTTREE}
 
procedure INITFILES;
var I: INTEGER; CH: CHAR;
begin
  WRITE(OUT,NL,'SOURCE FILE NAME: '); BREAK(OUT);
  I:= 0;
  repeat
    READ(INP,CH);
    I:= I+1; FILENAME[I]:= CH
  until CH = NL;
  FILENAME[I]:= ' ';
  RESET(INFILE, FILENAME);
  REWRITE(LST, 'PASREF.OUT ');
  WRITE(LST,NL);
  WRITE(OUT,NL,'PRINT INPUT FILE [Y/N]: '); BREAK(OUT);
  READ(INP,CH); PRINTSOURCE:= CH = 'Y';
  WRITE(OUT,NL); BREAK(OUT);
end; {INITFILES}
 
procedure NEXTCHAR;
begin
  READ(INFILE,CH);
  if EOF(INFILE) then begin DONE:= TRUE; CH:= NL end;
  if PRINTSOURCE then WRITE(LST,CH)
end;
 
procedure CHECKEOL;
begin
  if CH = NL then {new line}
  begin
    NCL:= NCL+1;
    if PRINTSOURCE then WRITE(LST, NCL:C3, ' ')
  end;
end;
 
function SPECIALCHAR: BOOLEAN;
begin
  SPECIALCHAR:= FALSE;
  if (CH<'0') ! (CH>'Z') then SPECIALCHAR:= TRUE
  else if (CH>'9') & (CH<'A') then SPECIALCHAR:= TRUE;
  if CH='_' then SPECIALCHAR:= FALSE;
end;
 
function RESERVEDWORD (LEN: INTEGER): BOOLEAN;
const
  RWRANGE = 157;
type
  RWORD = array [0..RWRANGE] of CHAR;
  RWINDEX = array [0..10] of 0..RWRANGE;
  LNTABLE = array [0..C1] of INTEGER;
const
  RSWORDS = RWORD (
      'I','F','D','O','I','N','T','O','O','F','O','R',
      'E','N','D','F','O','R','S','E','T','V','A','R','D','I','V',
      'M','O','D','A','N','D','N','O','T',
      'T','H','E','N','E','L','S','E','C','A','S','E',
      'L','O','O','P','E','X','I','T','W','I','T','H',
      'T','Y','P','E','F','I','L','E','G','O','T','O',
      'B','E','G','I','N','W','H','I','L','E','U','N','T','I','L',
      'A','R','R','A','Y','C','O','N','S','T','L','A','B','E','L',
      'R','E','P','E','A','T','R','E','C','O','R','D',
      'D','O','W','N','T','O','P','A','C','K','E','D',
      'F','O','R','W','A','R','D','P','R','O','G','R','A','M',
      'F','U','N','C','T','I','O','N',
      'P','R','O','C','E','D','U','R','E');
                      {0,1,2, 3, 4, 5,  6,  7,  8,  9, 10,11,12}
  STARTRSW  = RWINDEX (0,0,0,12,36,72,102,126,140,148,157);
  NUMBERRSW = LNTABLE (0,0,6, 8, 9, 6,  4,  2,  1,  1,  0,0,0);
var
  I, K, M, N: INTEGER;
  EQUL: BOOLEAN;
begin
  N:= NUMBERRSW[LEN];
  if N = 0 then RESERVEDWORD:= FALSE
  else begin
    K:= STARTRSW[LEN];  M:= 0;
    repeat
      EQUL:= TRUE; M:= M+1; I:= 1;
      {for I:= 1 to LEN do}
      while I <= LEN do
      begin
        if IDX[I] # RSWORDS[K] then EQUL:= FALSE;
        K:= K+1; I:= I+1
      end;
    until EQUL ! (M = N);
    RESERVEDWORD:= EQUL;
  end;
end;
 
begin {main program}
  INITFILES; DONE:= FALSE;
  ROOT:= NIL; K1:= C1;
  CH:= NL; NCL:= 0; CHECKEOL;
  repeat
    NEXTCHAR; CHECKEOL;
      if (CH>='A') & (CH<='Z') then
      begin K:= 0;
        repeat
          if K < C1 then
            begin K:= K+1; IDX[K]:= CH end;
          NEXTCHAR
        until SPECIALCHAR ! DONE;
        if K >= K1 then K1:= K else
          repeat
            IDX[K1]:= ' '; K1:= K1-1
          until K1 = K;
        if ~ RESERVEDWORD(K) then SEARCH(ROOT);
        CHECKEOL
      end ;
      {check for quote or comment}
        if CH = '''' then
          repeat NEXTCHAR; CHECKEOL
          until (CH = '''') ! DONE
        else if CH = '{' then
          repeat NEXTCHAR; CHECKEOL
          until (CH = '}') ! DONE
  until DONE;
  WRITE(LST,NL,FF,NL);
  PRINTTREE(ROOT);
  WRITE(LST,NL); BREAK(LST);
  WRITE(OUT,'end PASRF2',NL); BREAK(OUT)
end.