{$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}
      nl = chr(10); ff = chr(12);
 
type alfa = array [1..charsperword] 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);
 
const
     blanks = alfa(' ',' ',' ',' ',' ',' ',' ',' ',
                   ' ',' ',' ',' ');
 
var
     root: wordref;
     k: integer;
     ncl, nsave: integer;      {current line number}
     idx: alfa;
     lst, infile: text;
     filename: array [1..32] of char;
     endofline, done, printsource, getnextchar: boolean;
     ch: char;
 
 
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;
        write(lst,nl,' ':13)
      end;
      l := l+1;
      lineno := x@.lno;
      write(lst,lineno:digitspernum); 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;
{initialize files}
var i: integer; ch: char;
begin
  write(output,nl,'SOURCE FILE NAME: '); break(output);
  i := 0;
  repeat
    read(input,ch);
    i := i+1; filename[i] := ch
  until ch = nl;
  filename[i] := chr(0);
  reset(infile, filename);
  rewrite(lst, "PASXRF.LST", 2);
  write(lst,nl);
  write(output,nl,'PRINT INPUT FILE [Y/N]: '); break(output);
  read(input,ch); printsource := (ch = 'Y') or (ch = 'y');
  write(output,nl); break(output)
end; {INITFILES}
 
procedure nextline;
{start printing next line}
begin
  ncl := ncl +1;
  if printsource then write(lst, nl, ncl:digitspernum, ' ')
end; {NEXTLINE}
 
procedure nextchar;
{get next input character}
begin
  ch := infile@; get(infile);
  if eof(infile) then begin done := true; ch := nl end;
  endofline := ch = nl;
  if endofline then nextline
  else begin
    if printsource then write(lst,ch);
    if (ch >= 'a') and (ch <= 'z')
      then ch := chr(ord(ch)-32)  {convert to upper case}
  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}
 
function reservedword (length: integer): boolean;
{determine if word is a PASCAL reserved word}
const
  rwrange = 157;
type
  rword = array [0..rwrange] of char;
  rwindex = array [0..10] of 0..rwrange;
  lntable = array [0..charsperword] 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');
             {length = 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[length];
  if n = 0 then reservedword := false
  else begin
    k := startrsw[length];  m := 0;
    repeat
      equl := true; m := m+1; i := 1;
      {for I := 1 to LENGTH do}
      while i <= length do
      begin
        if idx[i] <> rswords[k] then equl := false;
        k := k+1; i := i+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; 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 := blanks;
      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 write(lst,nl,ff,nl);
  printtree(root);
  write(lst,nl); break(lst);
  write(output,'end PASREF',nl); break(output)
end.