{$Y-,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.	 *
*  						 *
*    Reworked by C. E. Chew.                     *
*                                                *
*                                                *
*************************************************}

 
const
  stringlength = 15;    {length of words}
  numbsperline = 10;    {numbers per line}
  digitspernum =  6;    {digits per number}
  nl = chr(10);
  ff = chr(12);
  nul = chr(0);
  lines_per_page=56;
  header1='Pascal NBS ';
  header2=' Page:';
 
type
  versionstring = array [1..80] of char;
  balancing = (unleft, balanced, unright);
  wordref = @word;
  itemref = @item;
  string = array [1..stringlength+1] of char;
  keystate = (user, builtin, reserved);
  relation = (lt,le,eq,ge,gt,ne);
  word = record
  	   bal: balancing;
	   status : keystate;
           first, last: itemref;
           left, right: wordref;
	   key : string
         end;
  item = record
           lno:  integer;
           next: itemref
         end;
 
var
  nbsversion : @versionstring;
  root: wordref;
  i,k: integer;
  ncl, nsave: integer;      {current line number}
  idx: string;
  endofline, done, printsource, getnextchar: boolean;
  ch, lch, hch: char;
  lst, infile: text;
  pagecount,linecount: integer;
  pass: array[0..26] of char;
  passcount,passes: integer;
  date_string,time_string:string;
  crefdesire: set of keystate;

procedure rerun; external;

function length(src:string):integer; external;

procedure date(var da:string); external;

procedure time(var ti:string); external;

procedure lowercase(var c:char); external;

procedure padright(var s:string; l,m:integer); external;

function match(s1,s2:string):relation; external;

function stoi(s:string; b,st:integer; var so:integer):integer; external;

function version:@versionstring; external;

procedure newline;
begin
  linecount:=linecount+1;
  if (linecount=lines_per_page) then begin
      linecount:=0;
      if (pagecount>0) then page(lst);
      pagecount:=pagecount+1;
      write(lst,header1,nbsversion@,' - ',argv[2]@,' - ');
      writeln(lst,date_string:9,time_string:9,header2,pagecount:3);
      writeln(lst)
   end
end;

procedure search (var t: wordref; id: string; len: integer;
		  state: keystate; nsave:integer);

var
  h : boolean;

procedure inserting(var t : wordref; var h : boolean);

var
  x : itemref;
  tl, tr : wordref;
  r : relation;
  i : integer;

begin
  if t = nil then begin
    new(t, len+1);
    if state in crefdesire then begin
      new(x);
      with x@ do begin
	lno := nsave;
	next := nil
      end
    end;
    h := true;
    with t@ do begin
      for i := 1 to len+1 do
	key[i] := id[i];
      bal := balanced;
      status := state;
      left := nil;
      right := nil;
      first := x;
      last := x
    end
  end
  else begin
    r := match(id, t@.key);
    if r = lt then begin
      inserting(t@.left, h);
      if h then begin
        case t@.bal of
          unright : begin
            t@.bal := balanced;
            h := false
          end;
          balanced : begin
            t@.bal := unleft
          end;
          unleft : begin
            tl := t@.left;
            if tl@.bal = unleft then begin
              t@.left := tl@.right;
              tl@.right := t;
              t@.bal := balanced;
              t := tl
            end
            else begin
              tr := tl@.right;
              tl@.right := tr@.left;
              tr@.left := tl;
              t@.left := tr@.right;
              tr@.right := t;
              if tr@.bal = unleft then
                t@.bal := unright
              else
                t@.bal := balanced;
              if tr@.bal = unright then
                tl@.bal := unleft
              else
                tl@.bal := balanced;
              t := tr
            end;
            t@.bal := balanced;
            h := false
          end
        end
      end
    end
    else if r = gt then begin
      inserting(t@.right, h);
      if h then begin
        case t@.bal of
          unleft : begin
            t@.bal := balanced;
            h := false
          end;
          balanced : begin
            t@.bal := unright
          end;
          unright : begin
            tr := t@.right;
            if tr@.bal = unright then begin
              t@.right := tr@.left;
              tr@.left := t;
              t@.bal := balanced;
              t := tr
            end
            else begin
              tl := tr@.left;
              tr@.left := tl@.right;
              tl@.right := tr;
              t@.right := tl@.left;
              tl@.left := t;
              if tl@.bal = unright then
                t@.bal := unleft
              else
                t@.bal := balanced;
              if tl@.bal = unleft then
                tr@.bal := unright
              else
                tr@.bal := balanced;
              t := tl
            end;
            t@.bal := balanced;
            h := false
          end
        end
      end
    end
    else begin
      if t@.status in crefdesire then begin
	new(x);
	with x@ do begin
	  lno := nsave;
	  next := nil
	end;
	t@.last@.next := x;
	t@.last := x
      end;
      h := false
    end
  end
end;

begin
  inserting(t, h)
end; {SEARCH}


procedure printtree (w: wordref);
{print a tree or subtree}

procedure printword (w: wordref);
{print a word and its references}
var
  l: integer;
  x: itemref;
  wa: word;

begin
  wa := w@;
  x := wa.first;
  if (x@.lno <> 0) or (x@.next <> nil) then begin
    newline;
    padright(wa.key, stringlength, stringlength);
    write(lst,' ',wa.key);
    l := 0;
    repeat
      if l = numbsperline then begin {start new line}
        l := 0;
        writeln(lst);
        newline;
        write(lst,' ':stringlength+1)
      end;
      with x@ do begin
	if lno <> 0 then begin
	  l := l+1;
	  write(lst,lno:digitspernum)
	end;
	x := next
      end
    until x = nil;
    writeln(lst) 
  end
end {PRINTWORD};
 
begin {PRINTTREE}
  if w <> nil then begin
    printtree(w@.left);
    if w@.status in crefdesire then
      printword(w);
    printtree(w@.right)
  end
end {PRINTTREE};
 
procedure nextline;
{start printing next line}
begin
  if printsource then
    newline;
  ncl := ncl +1;
  if printsource then
    write(lst, ncl:digitspernum, '  ')
end {NEXTLINE};
 
procedure nextchar;
{get next input character}
begin
  if endofline and ((infile@ = ' ') or (infile@ = chr(9))) then begin
    nextline;
    endofline := false;
    repeat
      if printsource then
	write(lst, infile@);
      get(infile)
    until (infile@ <> ' ') and (infile@ <> chr(9))
  end;
  if not eof(infile) then begin
    if not eoln(infile) then begin
      read(infile, ch);
      if ch <> ff then begin
	if endofline then
	  nextline;
	if printsource then
	  write(lst, ch);
	lowercase(ch);
	endofline := false
      end
      else begin
	if printsource and not endofline then
	  writeln(lst);
	endofline := true;
	linecount := lines_per_page - 1
      end
    end
    else begin
      ch := nl;
      readln(infile);
      if endofline then
	nextline;
      if printsource then
	writeln(lst);
      endofline := true
    end
  end
  else begin
    ch := nl;
    if printsource and not endofline then
      writeln(lst);
    done := true
  end
end {NEXTCHAR};
 
function specialchar: boolean;
{determine if character is a separator}

begin
  specialchar := not (((ch >= 'a') and (ch <= 'z')) or
		      ((ch >= '0') and (ch <= '9')) or
		      (ch = '_'))
end {SPECIALCHAR};
 
procedure reservedword (var root: wordref);
{determine if word is a PASCAL reserved word}
const
  rwrange = 443;

type
  rswords = array [1..rwrange] of char;

var
  i, j, l : integer;
  ch : char;
  stnd : keystate;
  id : string;

const
  rsword = rswords(
chr(3),'e','n','d',            
chr(5),'b','e','g','i','n',          
chr(2),'i','f',             
chr(4),'t','h','e','n',           
chr(4),'e','l','s','e',           
chr(3),'d','i','v',            
chr(3),'m','o','d',            
chr(2),'d','o',             
chr(5),'w','h','i','l','e',          
chr(6),'r','e','p','e','a','t',         
chr(5),'u','n','t','i','l',          
chr(4),'w','i','t','h',           
chr(4),'c','a','s','e',           
chr(4),'l','o','o','p',           
chr(4),'e','x','i','t',           
chr(3),'n','o','t',            
chr(2),'o','r',             
chr(3),'a','n','d',            
chr(2),'t','o',             
chr(2),'i','n',             
chr(3),'n','i','l',            
chr(3),'f','o','r',            
chr(2),'o','f',             
chr(5),'a','r','r','a','y',          
chr(5),'c','o','n','s','t',          
chr(4),'f','i','l','e',           
chr(6),'p','a','c','k','e','d',         
chr(6),'r','e','c','o','r','d',         
chr(3),'s','e','t',            
chr(4),'t','y','p','e',           
chr(3),'v','a','r',            
chr(6),'d','o','w','n','t','o',         
chr(9),'p','r','o','c','e','d','u','r','e',      
chr(8),'f','u','n','c','t','i','o','n',       
chr(7),'p','r','o','g','r','a','m',        
chr(4),'g','o','t','o',           
chr(5),'l','a','b','e','l',          
chr(7),'i','n','t','e','g','e','r',
chr(4),'r','e','a','l',
chr(4),'c','h','a','r',
chr(7),'b','o','o','l','e','a','n',
chr(4),'t','e','x','t',
chr(6),'m','a','x','i','n','t',
chr(5),'f','a','l','s','e',
chr(4),'t','r','u','e',
chr(13),'g','e','t',
chr(13),'p','u','t',
chr(15),'b','r','e','a','k',
chr(14),'s','e','e','k',
chr(15),'r','e','s','e','t',
chr(17),'r','e','w','r','i','t','e',
chr(16),'u','p','d','a','t','e',
chr(14),'r','e','a','d',
chr(16),'r','e','a','d','l','n',
chr(15),'w','r','i','t','e',
chr(17),'w','r','i','t','e','l','n',
chr(13),'e','o','f',
chr(14),'e','o','l','n',
chr(13),'n','e','w',
chr(14),'f','r','e','e',
chr(14),'m','a','r','k',
chr(17),'r','e','l','e','a','s','e',
chr(14),'p','r','e','d',
chr(14),'s','u','c','c',
chr(13),'a','n','y',
chr(13),'a','l','l',
chr(13),'o','d','d',
chr(13),'o','r','d',
chr(13),'c','h','r',
chr(15),'f','l','o','a','t',
chr(15),'t','r','u','n','c',
chr(15),'r','o','u','n','d',
chr(13),'m','a','x',
chr(13),'m','i','n',
chr(14),'c','e','i','l',
chr(15),'f','l','o','o','r',
chr(13),'a','b','s',
chr(13),'s','q','r',
chr(14),'s','q','r','t',
chr(12),'l','n',
chr(13),'e','x','p',
chr(13),'s','i','n',
chr(13),'c','o','s',
chr(16),'a','r','c','t','a','n',
chr(14),'p','a','g','e');


begin
  i := 1;
  repeat
    ch := rsword[i];
    if ch < chr(20) then begin
      i := i + 1;
      l := ord(ch) mod 10;
      if ch < chr(10) then
	stnd := reserved
      else
	stnd := builtin
    end
    else begin
      for j := 1 to l do
	id[j] := rsword[i + j - 1];
      id[l + 1] := nul;
      if (ch >= lch) and (ch < hch) then
	search(root, id, l, stnd, 0);
      i := i + l
    end
  until i > rwrange
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};
 
function initfiles:boolean;
{initialize files}
var i: integer; ch: char;
 
begin {initfiles}
  initfiles := true;
  if (argc<4) or (argc>5) then begin
    initfiles := false
  end
  else begin
    crefdesire := [user];
    printsource := true; { L default }
    if argv[1]@[0] = '-' then begin
    { get option from command line: }
      i := 1;
      loop
        ch := argv[1]@[i];
      exit if ch = nul;
        if ch='X' then printsource := false
	else if ch = 'P' then crefdesire := crefdesire + [reserved]
	else if ch = 'S' then crefdesire := crefdesire + [builtin]
	else if ch = 'N' then crefdesire := crefdesire - [user];
        i := i + 1
      end {loop}
    end;
    i := 0;
    if argc=5 then
      passes:=stoi(argv[4]@, 10, 1, i)
    else
      passes:=1;
    if (passes<1) or (passes>26) or (i<>0) then
      initfiles := false
    else begin
      pass[0]:='a';
      i:=26 div passes;
      passcount:=0;
      repeat
        ch:=chr(ord(pass[passcount])+i);
        passcount:=passcount+1;
        pass[passcount]:=ch
      until passcount=passes;
      pass[passes] := '{'
    end;
    reset(infile, argv[2]@, "PAS");
    rewrite(lst,  argv[3]@, "CRF")
  end
end {INITFILES};
 
 
 
begin {main program}
  date(date_string);
  time(time_string);
  nbsversion := version;
  if not initfiles then begin
    writeln('PASREF        ', header1,nbsversion@);
    writeln;
    writeln('Command line format :');
    writeln('           $-[options]  source  dest  [passes]');
    writeln;
    writeln('Default input extension     .PAS');
    writeln('Default output extension    .CRF');
    writeln;
    writeln('Option X     No source listing - cross reference only');
    writeln('Option P     Cross reference Pascal symbols');
    writeln('Option S     Cross reference standard functions and procedures');
    writeln('Option N     Don''t cross reference user identifiers');
    writeln;
    rerun
  end
  else begin
    endofline:=true;
    linecount:=lines_per_page-1;
    pagecount:=0;
    for passcount:=1 to passes do begin
      mark;
      lch:=pass[passcount-1];
      hch:=pass[passcount];
      reset(infile,"");
      done := false;
      root := nil;
      ncl := 0;
      getnextchar := true;
      reservedword(root);
      repeat
        if getnextchar then nextchar;
        getnextchar := true;
        if ((ch>='a') and (ch<='z')) then begin
	  if  ((ch>=lch) and (ch<hch)) then begin
	    k := 1; nsave := ncl;
	    repeat
	      if k <= stringlength then {save character} begin
		idx[k] := ch;
		k := k + 1
	      end;
	      nextchar
	    until endofline or done or specialchar;
	    idx[k] := nul;
	    search(root, idx, k-1, user, nsave)
	  end
	  else
	    repeat
	      nextchar
	    until endofline or done or specialchar
	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 linecount:=lines_per_page-1;
      printtree(root);
      printsource:=false;
      release
    end
  end;
  page(lst)
end.