{Edit 0.4 } program F4REFb(		{$X+}
{NS}		    source: 'dsk:source.ft',
{NS}		    listing:'IO: listing.ls',
{NS}		    output);
{$L-}

{ Simple cross reference generator for FORTRAN IV programs, using
  a binary tree algorithm.

  Copyright (C) 1981   John T. Easton and
		       Social Science Research Facilities Center and
		       University of Minnesota.
  Notes:

    -- Amount of memory available limits the size of the program processable.
    -- References are listed for all identifiers used and then some: data
       statements such as 6HARRGHH and 'AIEEEE' will show up as though they
       are identifiers	HARRGHH and AIEEEE; on the other hand, no
       identifiers are lost.
    -- FORTRAN keywords and identifiers must not be run together for this
       program to be able to distinguish them.
    -- We try ignore FORTRAN keywords, especially 'GOTO', 'GO' and 'TO'.
       See the full list in InitScan, below.
    -- Lower case input is mapped to upper case characters.
    -- Column one of the output is always blank.
    -- Width of the source echoed is not limited, but only sourcewidth (72)
       characters are significant.
    -- Width of cross-reference report is limited by tablewidth (72).


  Adapted from Niklaus Wirth's program 4.5 in 'Algorithms + Data Structures =
  Programs', Prentice Hall 1976, section 4.4, pp 206-208.

  Please retain the above names in all uses of this program.
}

  const
    digitspernumber = 5;
    idstrlength =     6 {length of identifiers};
    sourcewidth =    72 {higher columns not cross-referenced};
    tablewidth =     72 {cross-reference table};


  type
    idstring =	packed array [1..idstrlength] of char;
    natural =	0..maxint;
    entryptr =	^ entry;
    refptr =	^ reference;

    entry =
      record
	name:	     idstring;
	left, right: entryptr;
	last:	     refptr {last reference points to first}
      end		    {reference in a circular list};

    reference =
      packed record
	lno:  natural;
	next: refptr
      end;

  var
    source, listing {,output} : text;
    root:	     entryptr;
    refsperline:     natural;
    programname:     packed array[1..14] of char;
    today:	     packed array[1..10] of char;


  procedure Title;
  begin {Title}
    page(listing);
    writeln(listing);
    writeln(listing,' FORTRAN Cross Reference Listing of ',programname,
		    ' ':6,today);
    writeln(listing)
  end {Title};


  procedure ScanProgram;
    const
      maxkeywords =  47 {number of FORTRAN keywords};
    var
      lastidlength:  0..idstrlength;
      id:	     idstring;
      linenumber:    natural  {current source line number};
      columncount:   natural;
      doingformat:   boolean;
      keywords:      array[1..maxkeywords] of idstring {FORTRAN keywords};
      keywordcount:  0..maxkeywords;


    procedure InitScan;


      procedure A{dd keyword} (id: idstring);
      begin {A}
	if keywordcount = maxkeywords then
	  begin
	    writeln(output,'** key word table overflow');
{NS}	    halt
	  end
	else
	  begin
	    keywordcount := keywordcount + 1;
	    keywords [ keywordcount ] := id
	  end
      end {A};


    begin {InitScan}
      root := nil;
      Title;
      keywordcount := 0;
      A('AND   '); A('ASSIGN'); A('BACKSP'); A('BLOCK '); A('CALL  ');
      A('COMMON'); A('COMPLE'); A('CONTIN'); A('DATA  '); A('DEFINE');
      A('DIMENS'); A('DO    '); A('DOUBLE'); A('END   '); A('EQ    ');
      A('EQUIVA'); A('EQV   '); A('EXPLIC'); A('EXTERN'); A('FALSE ');
      A('FILE  '); A('FORMAT'); A('FUNCTI'); A('GE    '); A('GO    ');
      A('GOTO  '); A('GT    '); A('IF	 '); A('INTEGE'); A('LE    ');
      A('LOGICA'); A('LT    '); A('NE	 '); A('NOT   '); A('OR    ');
      A('PAUSE '); A('PRECIS'); A('READ  '); A('REAL  '); A('RETURN');
      A('REWIND'); A('STOP  '); A('SUBROU'); A('TO    '); A('TRUE  ');
      A('WRITE '); A('XOR   ');
      if keywordcount < maxkeywords then
	begin
	  writeln(listing,'** keyword array under-used');
{NS}	 {halt}
	end;
      linenumber := 0;
      lastidlength := idstrlength;
      doingformat := false;
    end {InitScan};


    function NotKey(id: idstring) : boolean;
      var
	i, j, k: natural;
    begin {NotKey}
      i := 1;
      j := keywordcount;
      repeat k := (i + j) div 2;
	if keywords[k] <= id
	  then i := k + 1
	  else j := k - 1
      until i > j;
      if j = 0 then NotKey := true
      else NotKey := keywords[j] <> id
    end {NotKey};


    procedure EnterID(id: idstring;var w1: entryptr);


      procedure Enter(var w1: entryptr);
	var
	  w: entryptr;
	  x: refptr;
      begin {Enter}
	w := w1;
	if w = nil then
	  begin
	    new(w);   new(x);
	    with w^ do
	      begin
		name := id;
		left := nil;   right := nil;
		last := x
	      end;
	    x^.lno := linenumber;
	    x^.next := x {circular list};
	    w1 :=w
	  end
	else if id < w^.name then Enter(w^.left)
	else if id > w^.name then Enter(w^.right)
	else
	  begin
	    new(x);
	    x^.lno := linenumber;   x^.next := w^.last^.next;
	    w^.last^.next := x;     w^.last := x
	  end
      end {Enter};


    begin {EnterID}
      Enter(w1)
    end {EnterID};


    procedure OpenLine;
    begin {OpenLine}
      linenumber := linenumber + 1;
      write(listing,linenumber:digitspernumber,' ');
      columncount := 0
    end {OpenLine};


    procedure CloseLine;
    begin {CloseLine}
      writeln(listing);
      readln(source)
    end {CloseLine};


    procedure Advance;
    begin {Advance}
      write(listing,source^);
      get(source);
      columncount := columncount + 1;
      if columncount = sourcewidth then
	while not eoln(source) do
	  begin write(listing,source^); get(source) end
    end {Advance};


    procedure ScanIdent;
      var idlen: 0..idstrlength;
    begin {ScanIdent}
      idlen := 0;
      repeat
	if idlen < idstrlength then
	  begin
	    idlen := idlen + 1;
	    if source^ in
		     ['a','b','c','d','e','f','g','h','i','j','k','l','m',
		      'n','o','p','q','r','s','t','u','v','w','x','y','z']
	      then id[idlen] := chr(ord(source^)-ord('a')+ord('A'))
	      else id[idlen] := source^
	  end;
	Advance
      until not (source^ in
		   ['A','B','C','D','E','F','G','H','I','J','K','L','M',
		    'N','O','P','Q','R','S','T','U','V','W','X','Y','Z',
		    'a','b','c','d','e','f','g','h','i','j','k','l','m',
		    'n','o','p','q','r','s','t','u','v','w','x','y','z',
		    '0'..'9']);
      if idlen >= lastidlength then lastidlength := idlen
      else
	repeat
	  id[lastidlength] := ' ';
	  lastidlength := lastidlength - 1
	until lastidlength = idlen;
      if NotKey(id) then EnterID(id,root)
      else if id = 'FORMAT' then
	begin
	  doingformat := true;
	  while not eoln(source) do Advance
	end
    end {ScanIdent};


    procedure ScanALine;
    begin {ScanALine}
      while not eoln(source) do
	begin
	  if source^ = ' ' then Advance
	  else if source^ in
		 ['A','B','C','D','E','F','G','H','I','J','K','L','M',
		  'N','O','P','Q','R','S','T','U','V','W','X','Y','Z',
		  'a','b','c','d','e','f','g','h','i','j','k','l','m',
		  'n','o','p','q','r','s','t','u','v','w','x','y','z'
		 ] then ScanIdent
	  else if source^ in ['0'..'9','.','+','-'] then
	    repeat Advance {skipping through a number}
	    until not (source^ in ['0'..'9','.'])
	  else Advance {miscellaneous}
	end
    end {ScanALine};


  begin {ScanProgram}
    InitScan;
    while not eof(source) do
      begin
	OpenLine;
	if source^ in ['C','c','*','$'] then
	  begin {FORTRAN comment}
	    while not eoln(source) do Advance
	  end {comment}
	else
	  begin {statement}
	    while (source^ = ' ') and not(eoln(source)) do Advance;
	    if (columncount = 6) and doingformat then
	       while not eoln(source) do Advance
	    else doingformat := false {switch off};
	    ScanALine
	  end {statement};
	CloseLine
      end {while not eof(source)}
  end {ScanProgram};


  procedure ReportReferences;


    procedure PrintTree(w: entryptr);


      procedure PrintEntry(w:entry);
	var
	  c: natural;
	  x: refptr;
      begin {PrintEntry}
	write(listing,' ',w.name);
	x := w.last^.next;
	w.last^.next := nil {break the ring};
	c := 0;
	repeat
	  if c = refsperline then
	    begin
	      writeln(listing);
	      c := 0;
	      write(listing,' ':idstrlength+1)
	    end;
	  c := c + 1;
	  write(listing,' ',x^.lno:digitspernumber);
	  x := x^.next
	until x = nil;
	writeln(listing)
      end {PrintEntry};


    begin {PrintTree}{in-order recursive traversal of binary tree}
      if w <> nil then
	begin
	  PrintTree(w^.left);
	  PrintEntry(w^);
	  PrintTree(w^.right)
	end
    end {PrintTree};


  begin {ReportReferences}
    refsperline := (tablewidth - idstrlength - 1) div
		   (digitspernumber + 1);
    Title;
    PrintTree(root);
    writeln(listing)
  end {ReportReferences};


begin {F4REFb}
  reset(source);
{NS} GetFN(source,programname);   {non-standard}
  if eof(source) then
    writeln(output,'file ''',programname,''' is missing or empty.')
  else {non-empty source}
    begin
{NS}  Date(today);   {non-standard}
      rewrite(listing);
      ScanProgram;
      ReportReferences
    end
end {F4REFb}.