{$T-}
program PASREF;
{PASCAL cross reference generator using a binary tree.
 Adapted from  Algorithms + Data Structures = Programs,
 by Niklaus Wirth  (pp. 206-210).
 
 V1A - Bill Heidebrecht - 16 Sep 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;
    Q: COMPARE;
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,'IN FILE: '); 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;
 
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;
        SEARCH(ROOT);
        CHECKEOL
      end else
      begin {check for quote or comment}
        if CH = '''' then
          repeat NEXTCHAR; CHECKEOL
          until (CH = '''') ! DONE
        else if CH = '{' then
          repeat NEXTCHAR; CHECKEOL
          until (CH = '}') ! DONE
      end
  until DONE;
  WRITE(LST,FF,NL);
  PRINTTREE(ROOT);
  WRITE(LST,NL); BREAK(LST);
  WRITE(OUT,'END PASREF',NL); BREAK(OUT)
end.