{$T-}
program pasref;
{PASCAL cross reference generator using a binary tree.
 Adapted from  "Algorithms + Data Structures = Programs",
 by Niklaus Wirth  (pp. 206-210).
 
 
 PASREF produces a cross reference listing of
 PASCAL source programs on the file 'PASXRF.LST'.
 Before generating the references, lower case
 letters are mapped into upper case.  A listing of
 the source file with line numbers is optional.
 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.
 
      V2A  -  15 Apr 78
      Bill Heidebrecht
      TRW Systems
      One Space Park
      Redondo Beach, CA 90278 *)
 
const CHARSPERWORD = 12;    (* length of words *)
      NUMBSPERLINE = 12;    (* numbers per line *)
      DIGITSPERNUM =  6;    (* digits per number *)
      RWRANGE = 192;        (* reserved word table size *)
 
type TEXT = file of CHAR;
     ALFA = array [1..CHARSPERWORD] of CHAR;
     SHORTALFA = array [1..10] 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: INTEGER;
     NCL, NSAVE: INTEGER;      (* current line number *)
     IDX: ALFA;
     LST, INFILE: TEXT;
     FILENAME: array [1..20] of CHAR;
     ENDOFLINE, DONE, PRINTSOURCE, GETNEXTCHAR: BOOLEAN;
     CH: CHAR;
     RSWORDS: array [1..RWRANGE] of CHAR;
     NUMBERRSW, STARTRSW: array [0..CHARSPERWORD] of INTEGER;
     RWTABSIZE: INTEGER;
 
 
function MATCH (W: WORDREF): COMPARE;
(* compare two character strings *)
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 or (I>=CHARSPERWORD)
end; (* MATCH *)
 
procedure SEARCH (var W1: WORDREF);
(* tree search and insertion *)
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 := NSAVE; 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 := NSAVE; X^.NEXT := NIL;
            W^.LAST^.NEXT := X; W^.LAST := X
          end
    end (* case *)
  end
end; (* SEARCH *)
 
procedure PRINTTREE (W2: WORDREF);
(* print a tree or subtree *)
var W: WORDREF;
 
  procedure PRINTWORD (W1: WORDREF);
  (* print a word and its references *)
  var L, LINENO: INTEGER; X: ITEMREF;
      WA: WORD;
  begin
    WA := W1^;
    WRITE(LST,' ',WA.KEY);
    X := WA.FIRST; L := 0;
    repeat
      if L = NUMBSPERLINE then
      begin (* start new line *)
        L := 0;
        WRITELN(LST); WRITE(LST,' ':13)
      end;
      L := L+1;
      LINENO := X^.LNO;
      WRITE(LST,LINENO:DIGITSPERNUM); X := X^.NEXT
    until X = NIL;
    WRITELN(LST)
  end; (* PRINTWORD *)
 
begin (* PRINTTREE *)
  W := W2;
  if W <> NIL then
  begin
    PRINTTREE(W^.LEFT);
    PRINTWORD(W);
    PRINTTREE(W^.RIGHT)
  end
end; (* PRINTTREE *)
 
procedure INITFILES;
(* initialize files *)
var I: INTEGER; CH: CHAR;
begin
  WRITE(TTY,'SOURCE FILE NAME: '); BREAK; READLN(TTY);
  FILENAME := '                    '; I := 0;
  while not EOLN(TTYIN) do
  begin
    I := I+1; READ(TTY,FILENAME[I])
  end;
  RESET(INFILE, FILENAME);
  REWRITE(LST, 'PASXRF.LST ');
  WRITELN(LST);
  WRITE(TTY,'PRINT INPUT FILE [Y/N]: '); BREAK; READLN(TTY);
  READ(TTY,CH); PRINTSOURCE := (CH = 'Y') or (CH = 'y')
end; (* INITFILES *)
 
procedure NEXTLINE;
(* start printing next line *)
begin
  NCL := SUCC(NCL);
  if PRINTSOURCE then
  begin
    WRITELN(LST);
    WRITE(LST, NCL:DIGITSPERNUM, ' ')
  end
end; (* NEXTLINE *)
 
procedure NEXTCHAR;
(* get next input character *)
begin
  ENDOFLINE := FALSE;
  if EOF(INFILE) then DONE := TRUE else
  begin
    if EOLN(INFILE) then
    begin
      ENDOFLINE := TRUE;
      READLN(INFILE);
      NEXTLINE
    end else
    begin
      READ(INFILE,CH);
      if PRINTSOURCE then WRITE(LST,CH);
      if (CH >= 'a') and (CH <= 'z')
        then CH := CHR(ORD(CH)-32)  (* convert to upper case *)
    end
  end
end; (* NEXTCHAR *)
 
function SPECIALCHAR: BOOLEAN;
(* determine if character is a separator *)
begin
  SPECIALCHAR := FALSE;
  if (CH<'0') or (CH>'Z') then SPECIALCHAR := TRUE
  else if (CH>'9') and (CH<'A') then SPECIALCHAR := TRUE;
  if CH='_' then SPECIALCHAR := FALSE
end; (* SPECIALCHAR *)
 
procedure RESERVE (RWORD: SHORTALFA);
(* reserve a PASCAL keyword *)
var I, N: INTEGER;
    CH: CHAR;
begin
  I := 0; N := RWTABSIZE+1;
  repeat
    I := I+1; CH := RWORD[I];
    RWTABSIZE := RWTABSIZE+1;
    RSWORDS[RWTABSIZE] := CH
  until CH = '.';
  RWTABSIZE := RWTABSIZE-1; I := I-1;
  if NUMBERRSW[I] = 0 then STARTRSW[I] := N;
  NUMBERRSW[I] := NUMBERRSW[I] + 1
end; (* RESERVE *)
 
procedure INITTABLE;
(* initialize table of PASCAL reserved words *)
var I: INTEGER;
begin
  for I := 1 to CHARSPERWORD do
  begin
    NUMBERRSW[I] := 0;
    STARTRSW[I] := 0
  end;
  RWTABSIZE := 0;
(* 2 char words *)
  RESERVE('IF.       ');
  RESERVE('DO.       ');
  RESERVE('IN.       ');
  RESERVE('OF.       ');
  RESERVE('TO.       ');
  RESERVE('OR.       ');
(* 3 char words *)
  RESERVE('END.      ');
  RESERVE('VAR.      ');
  RESERVE('FOR.      ');
  RESERVE('SET.      ');
  RESERVE('MOD.      ');
  RESERVE('DIV.      ');
  RESERVE('AND.      ');
  RESERVE('NOT.      ');
  RESERVE('NIL.      ');
(* 4 char words *)
  RESERVE('THEN.     ');
  RESERVE('ELSE.     ');
  RESERVE('WITH.     ');
  RESERVE('CASE.     ');
  RESERVE('TYPE.     ');
  RESERVE('CHAR.     ');
  RESERVE('REAL.     ');
  RESERVE('TRUE.     ');
  RESERVE('FILE.     ');
  RESERVE('GOTO.     ');
  RESERVE('LOOP.     ');
  RESERVE('EXIT.     ');
(* 5 char words *)
  RESERVE('BEGIN.    ');
  RESERVE('WHILE.    ');
  RESERVE('UNTIL.    ');
  RESERVE('ARRAY.    ');
  RESERVE('CONST.    ');
  RESERVE('FALSE.    ');
  RESERVE('LABEL.    ');
(* 6 char words *)
  RESERVE('REPEAT.   ');
  RESERVE('RECORD.   ');
  RESERVE('DOWNTO.   ');
  RESERVE('PACKED.   ');
(* 7 char words *)
  RESERVE('INTEGER.  ');
  RESERVE('BOOLEAN.  ');
  RESERVE('FORWARD.  ');
  RESERVE('PROGRAM.  ');
(* 8 char words *)
  RESERVE('FUNCTION. ');
(* 9 char words *)
  RESERVE('PROCEDURE.')
end; (* INITTABLE *)
 
function RESERVEDWORD (LENGTH: INTEGER): BOOLEAN;
(* determine if word is a PASCAL reserved word *)
var
  I, K, M, N: INTEGER;
  EQUL: BOOLEAN;
begin
  N := NUMBERRSW[LENGTH];
  if N = 0 then RESERVEDWORD := FALSE
  else begin
    K := STARTRSW[LENGTH];  M := 0;
    repeat
      EQUL := TRUE; M := M+1;
      for I := 1 to LENGTH do
      begin
        if IDX[I] <> RSWORDS[K] then EQUL := FALSE;
        K := K+1
      end;
    until EQUL or (M = N);
    RESERVEDWORD := EQUL
  end
end; (* RESERVEDWORD *)
 
procedure SKIP1 (ENDCHAR: CHAR);
(* scan to end of string or comment *)
begin
  repeat
    NEXTCHAR
  until (CH = ENDCHAR) or DONE
end; (* SKIP1 *)
 
procedure SKIP2;
(* scan to end of ( *-* ) comment *)
begin
  NEXTCHAR;
  repeat
    while (CH <> '*') and not DONE do NEXTCHAR;
    if not DONE then NEXTCHAR;
  until (CH = ')') or DONE
end; (* SKIP2 *)
 
begin (* main program *)
  INITFILES; INITTABLE;
  DONE := FALSE;
  ROOT := NIL;
  NCL := 0; NEXTLINE;
  GETNEXTCHAR := TRUE;
  repeat
    if GETNEXTCHAR then NEXTCHAR;
    GETNEXTCHAR := TRUE;
    if (CH>='A') and (CH<='Z') then
    begin
      K := 0; NSAVE := NCL;
      IDX := '            ';
      repeat
        if K < CHARSPERWORD then (* save character *)
          begin K := K+1; IDX[K] := CH end;
        NEXTCHAR
      until  ENDOFLINE or DONE or SPECIALCHAR;
      if not RESERVEDWORD(K) then SEARCH(ROOT)
    end;
    (* check for quote or comment *)
    if CH = '''' then SKIP1('''')
    else if CH = '{' then SKIP1('}')
    else if CH = '"' then SKIP1('"')
    else if CH = '(' then
    begin
      NEXTCHAR;
      if CH = '*' then SKIP2
      else GETNEXTCHAR := FALSE
    end
  until DONE;
  if PRINTSOURCE then
  begin
    WRITELN(LST); PAGE(LST)
  end;
  PRINTTREE(ROOT);
  WRITELN(LST); PAGE(LST);
  WRITELN(TTY,'end PASREF'); BREAK
end.