{$T-,W-}
program Pasref;
{*************************************************
*						 *
*		   PASREF:			 *
*  A  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 a destination file. *
*  Before generating the references, lower case	 *
*  letters are mapped into upper case. A source	 *
*  file listing 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.	 *
*  						 *
*         Version 2e  -  16 Feb 80		 *
*         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); nul = chr(0);
 
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);
 
 
var
  root: wordref;
  k: integer;
  ncl, nsave: integer;      {current line number}
  idx: alfa;
  endofline, done, printsource,
  getnextchar, ok: boolean;
  ch: char;
  lst, infile: text;
 
 
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 nextline;
{start printing next line}
begin
  ncl := ncl +1;
  if printsource then
  begin
    write(lst,ncl:digitspernum, '  ');
  end
end {nextline};
 
procedure nextchar;
{get next input character}
begin
  endofline:=false;
  if eof(infile) then begin done:=true; ch:=nul; end
  else begin
    if eoln(infile) then begin
      readln(infile);
      endofline:=true;
      if printsource then begin writeln(lst); nextline; end;
    end; {if eoln}
    read(infile,ch);
    if ch:=ff then begin
      endofline:=true;
      if printsource then begin page(lst); nextline; end;
    end {if ff}
    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; {else}
  end; {else}
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;
      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};
 
procedure initfiles;
{initialize files}
var i: integer; ch: char;
begin {initfiles}
  ok := true;
  printsource := false; { X default }
  writeln('PASREF - Pascal cross reference program.');
  writeln('Do you wish to have the source program listed?');
  readln(ch);
  if (ch='Y') or (ch='y') then printsource := true;
  writeln('Enter name of source file:');
  reset(infile," ",2);
  writeln('Enter name of listing file:');
  rewrite(lst," ");
end {initfiles};
 
 
 
begin {Pasref}
  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 := '            ';
      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);
end.
                                                                                                                      