{[b+]}
{ NOTICE OF COPYRIGHT AND OWNERSHIP OF SOFTWARE:

  Copyright 1980, 1981, 1982   by Oregon Software, Inc.
  All Rights Reserved.

  Whether this program is copied in whole or in part and whether this
  program is copied in original or in modified form, ALL COPIES OF THIS
  PROGRAM MUST DISPLAY THIS NOTICE OF COPYRIGHT AND OWNERSHIP IN FULL.

  Procedural Cross Referencer, Based on one by Arthur Sale.
  Release version: 2.0K  Level: 3  Date: 15-Jan-1982 10:38:00
  Processor: PDP11
}

program procref(input, output, inputfile, outputfile);

{-----------------------------------------------------------------------|
|                                                                       |
|                 PASCAL PROCEDURAL CROSS-REFERENCER                    |
|                                                                       |
|          (c) Copyright 1979 A.H.J.Sale, Southampton, England.         |
|                                                                       |
|   DEVELOPMENT                                                         |
|   This program is a software tool developed  from  a  prototype  by   |
|   A.J.Currie at the University of Southampton, England.  The proto-   |
|   type of 231 lines of source text was used firstly as a basis  for   |
|   extensions,   and   then   rewritten  to  assure  correctness  by   |
|   A.H.J.Sale, on leave from the University  of  Tasmania  and  then   |
|   stabilized at 1979 December 4; the  development  time  being  es-   |
|   timated at 4 man-days from prototype to production.                 |
|                                                                       |
|   PURPOSE                                                             |
|   The program reads Pascal source programs and produces two  tables   |
|   as  output.  One documents all procedure or function headings  in   |
|   a  format  that  illustrates  lexical  nesting.  The other tables   |
|   gives the locations of heading, block, and  body  for  each  pro-   |
|   cedure and function, and what procedures and functions it immedi-   |
|   ately calls.                                                        |
|                                                                       |
|   There is a User Manual for this program; if it has not been  pro-   |
|   vided with your installation write to:                              |
|             Department of Information Science                         |
|             University of Tasmania                                    |
|             P.O.Box 252C, G.P.O Hobart                                |
|             Tasmania  7001                                            |
|   and ask for the Technical Report on referencer, if  it  is  still   |
|   available.  The program is written to be portable and is believed   |
|   to be in Standard Pascal.                                           |
|                                                                       |
|   Permission is granted to copy this program, store it in a comput-   |
|   er  system,  and distribute it, provided that this header comment   |
|   is retained in all copies.                                          |
|                                                                       |
|-----------------------------------------------------------------------}

{ The above comment is included as requested.  The source for this program
  was obtained from Pascal News, and modified at Oregon Software to add the
  following capabilities:

        1.  DEC PDP 11 command line scanning.
        2.  multiple source and %include files.
        3.  Remove requirement for "program" header
        4.  Allow external procedure (no main body)
        5.  Reverse (called by) references
        6.  Tabs in input lines.

  In addition, the program as distributed contained a major bug in the
  handling of field names, and any field name in a record with the
  same name as a procedure would mask any use of the procedure within
  that scope.  Removing the problem completely requires a large increase
  in the complexity of the analysis, and was judged infeasable.  The
  current limitation is that an unqualified reference to a field with
  the same name as a procedure will be treated as a reference to that
  procedure.  This can only occur within a "with" statement.  This
  restriction may be removed in a later release.

  version 2.0K-3, created on 15-Jan-1982 at 10:38:00
}

  label
    99; {exit for error or eof}

  const

    sigcharlimit = 16; {This constant is the number of significant characters
                        kept in the identifier entries. It can readily be
                        changed. It is not advised that it be reduced below
                        10 (reserved words get to 9). }

    uclcdisplacement = 32; {This constant is used to convert upper-case
                            letters to lower-case and vice-versa. It should
                            be equal to ord('a') - ord('A').}

    linelimit = 161; {This constant determines the size of the input line
                      buffer. The maximum acceptable input line is one
                      smaller because a sentinel space is appended to every
                      line.}

    linewidth = 80; {This constant determines the default maximum width of the
                     printing of the second cross-reference table. The
                     program deduces how many names will fit on a line.}

    indentation = 4; {This determines the indentation of the lex-levels.}

    prefix = 9; {width of crossref prefix data}

    { These constants are used for the sketchy syntax analysis. }
    { They are collected here so that their lengths may be altered}
    { if sigcharlimit is altered. }
    sprogram = 'program         ';
    sprocedure = 'procedure       ';
    sfunction = 'function        ';
    slabel = 'label           ';
    sconst = 'const           ';
    stype = 'type            ';
    svar = 'var             ';
    sbegin = 'begin           ';
    scase = 'case            ';
    send = 'end             ';
    sforward = 'forward         ';
    srecord = 'record          ';
    sinclude = 'include         ';
    spaces = '                ';

    labelsize = 13; {max size used for labeling files}

    blanklabel = '             '; {blank file label}

    fakeprog = '.MAIN.          '; {fake program name if none}

    {ASCII special character handline}

    ff = 14B; {ascii form feed}
    ht = 11B; {ascii tab character}

    tabinterval = 8; {DEC standard tab interval}

    {pdp11 file system interface}

    filenamelength = 60; {max length of a file name for your system}

    %include OSCONF { Specifies operating system }

    rsxprompt = 'PRF>'; {prompt to use if on RSX system}

    cmdlinelength = 132; { length of a command line }

    sourcedepth = 8; {max source nesting depth for includes}

  type
    natural = 0..maxint;
    positive = 1..maxint;

    prefixname = packed array [1..prefix] of char;

    sigcharrange = 1..sigcharlimit;

    pseudostring = packed array [sigcharrange] of char;
    stringcases = packed array [sigcharrange] of boolean;

    linesize = 1..linelimit;
    lineindex = 0..linelimit;

    setofchar = set of char;

    prockind = (fwdhalf, allfwd, shortform, formal, outside, outsidedef,
                notproc);

    ptrtoentry = ^entry;

    listofusages = ^usagecell;

    ptrtostackcell = ^stackcell;

    tokentype = (othersy, namesy, lparensy, rparensy, colonsy, semicolsy,
                 periodsy, assignsy, subrangesy);

    filelabel = packed array [1..labelsize] of char;

    lineref =
      record
        line: natural; {line number of reference}
        fileref: filelabel; {file of reference}
      end;

    entry =
      record
        procname: pseudostring;
        procuppers: stringcases;
        linenumber: lineref; {line where header found}
        startofbody: lineref; {line where body is found}
        left, right: ptrtoentry;
        before, after: ptrtoentry;
        calls: listofusages;
        called: listofusages;
        localtree: ptrtoentry;
        case status: prockind of
          fwdhalf, shortform, formal, outside, notproc: ();
          allfwd, outsidedef:
            (forwardblock: lineref {line where forward label found} );
      end;

    usagecell =
      record
        what: ptrtoentry;
        next: listofusages;
      end;

    stackcell =
      record
        current: ptrtoentry;
        scopetree: ptrtoentry;
        substack: ptrtostackcell;
      end;

    {source include control}

    sourceindex = 1..sourcedepth; {current source nexting level}

    sourcedescriptor =
      record
        inputfile: text; {current input file}
        line: array [linesize] of char; {current input line}
        chno, total: lineindex; {char pointers in line}
        lineno: natural; {line number of this line}
        currentlabel: filelabel; {current file label}
      end;

    sourcestack = array [sourceindex] of sourcedescriptor;

    {pdp11 interface types}

    filename = packed array [1..filenamelength] of char;

    cmdindex = 1..cmdlinelength; {pointer to chars in command line}

    cmdbuffer = packed array [cmdindex] of char; {command line buffer}

    errorname = (unknown, twofilenames, badfile, nofile, nooutputfile,
                 noinput, manyouts, numrange);


  var

    lowers: stringcases;
    i: sigcharrange; {induction var}

    depth: natural;
    level: - 1..maxint;
    pretty: natural;

    adjustment: (first, other);
    movement: integer;
    printflag: boolean;
    errorflag: boolean;

    ch: char;

    token: tokentype;
    symbol: pseudostring;
    symbolcase: stringcases;

    savesymbol: pseudostring;

    superroot: ptrtoentry;
    stack: ptrtostackcell;

    alphabet: setofchar;

    alphanums: setofchar;
    uppercase: setofchar;
    lowercase: setofchar;
    digits: setofchar;
    usefulchars: setofchar;

    namesperline: positive;
    outwidth: integer;

    lastlabel: filelabel; {last label printed}
    currentlabel: filelabel; {label for current lines}

    {PDP 11 file system interface}

    cmdline: cmdbuffer; {actual command line read}
    cmdlength: cmdindex; {length of line being read in}
    fieldsfound: 0..cmdlinelength; {number of fields found by csi}
    outspeced: boolean; { true if an output file specified with "=" }
    firstfound: boolean; {true if the first field was found}

    curfileno: natural; {file number of current input file}
    currentfile: filename; {file name for current input file}
    fileexists: boolean; {current file exists}

    outputfile: text; {result file for reference table}
    source: sourcestack; {source files}
    sourcelevel: sourceindex; {current include depth}

{Command String Interpreter,  parses the command string and sets
 the initial state of the switches.  This is almost as complicated
 as the whole rest of the program put together.  Let's hear it
 for csi format!!!!!
}


  procedure getline(var line: cmdbuffer; {resulting command line}
                    var length: cmdindex {resulting command length} );

{ RT 11 procedure to get a command line no matter what its source.
}

    external;


  procedure exitst(status: integer {status for error on exit} );

{ Entrance to the library to exit with a status set to "status".
}
    external;


  procedure csierror(which: errorname; {which error}
                     startind: cmdindex; {start of command to print}
                     endind: cmdindex {end of command to print} );

{ Print an error message and exit from the program with a fatal
  error status.  The offending portion of the command line is printed
  before the error message.
}

    var
      i: integer; {induction var}


    begin
      for i := startind to endind do write(cmdline[i]);
      if startind <= endind then writeln;
      case which of
        unknown: writeln('Unknown qualifier.');
        twofilenames: writeln('Two file names in one field.');
        badfile: writeln('Bad file name syntax.');
        nofile: writeln('No file in field.');
        nooutputfile: writeln('Output requested but no file provided.');
        noinput: writeln('No input file provided.');
        manyouts: writeln('More than one output file specification.');
        numrange: writeln('Value for qualifier out of range.');
        end;
      exitst(4); {magic number for fatal error}
    end; {error}


  procedure skipbalancedstring(startindex: cmdindex;
                               var next: cmdindex);

    var
      endchar: char; {bracket which terminates string}


    begin {Skip a string balanced with respect to parentheses and quoted
           strings}
      if cmdline[next] in ['(', '[', '<'] then
        begin
        if cmdline[next] = '(' then endchar := ')'
        else if cmdline[next] = '<' then endchar := '>'
        else endchar := ']';
        next := next + 1;
        while (cmdline[next] <> endchar) and (next <> cmdlength) do
          skipbalancedstring(startindex, next);
        end
      else if cmdline[next] = '"' then
        repeat
          next := next + 1
        until (cmdline[next] = '"') or (next = cmdlength);
      if next < cmdlength then next := next + 1
      else csierror(badfile, startindex, cmdlength);
    end; {skipbalancedstring}


  procedure csi;

{ Gets a command line and parse it.
  The procedure "getfilename",
  below, is used to get file names after csi has been called.

  The input line is assumed to be of the form:

        [ [ output ] "=" ] input [* "," input *]

  Qualifiers can be attached to any file, and all qualifiers are
  assumed to have the same effect no matter which file it is
  attached to.
}

    var

      next: cmdindex; {next char in command string}

      filefound: boolean; {true if file found in this field}
      filestart: cmdindex; {start of last file name found}
      manyfound: boolean; {more than 1 field found}
      emptyfile: boolean; {empty file name found, possibly an error}
      emptystart: cmdindex; {start of empty file field}
      emptyend: cmdindex; {end of empty file field}
      lastfield: cmdindex; {end of last field scanned}


    procedure getcmdline;

{ Read the command line into core.
}

      var
        i: integer; {induction var}


      begin
        if rsx then
          begin
          if input^ <> ' ' then
            begin
            repeat
              get(input)
            until (input^ = ' ');
            while not eoln and (input^ = ' ') do get(input);
            end;
          if input^ = ' ' then write(rsxprompt);
          if eoln then readln;
          end
        else if rsts then write('*');
        if rt11 then
          begin
          getline(cmdline, cmdlength);
          cmdlength := cmdlength + 1;
          end
        else
          begin
          cmdlength := 1;
          while not eoln do
            begin
            if cmdlength < cmdlinelength - 2 then
              begin
              read(input, cmdline[cmdlength]);
              cmdlength := cmdlength + 1;
              end
            else get(input);
            end;
          end;
        for i := cmdlength to cmdlinelength do cmdline[i] := ' ';
      end; {getcmdline}


    procedure takequal(var next: cmdindex);

{ Parse and look up a qualifier, updating "next" to point to the next
  character in the command line.
}

      var
        startingindex: cmdindex; {start of qualifier, for error printout}
        thisqual: char; {qualifier just found}


      procedure numeric_value(var result: integer; {resulting value}
                              low_lim, hi_lim: integer {limits on value} );

        var
          tempres: integer;
          accumulating: boolean;


        begin
          accumulating := true;
          tempres := 0;
          repeat
            next := next + 1;
          until (cmdline[next] <> ' ') or (next = cmdlength);
          while cmdline[next] in ['0'..'9'] do
            begin
            if accumulating then
              if tempres <= maxint div 10 then tempres := tempres * 10
              else accumulating := false;
            if accumulating then
              if tempres <= maxint - (ord(cmdline[next]) - ord('0')) then
                tempres := tempres + (ord(cmdline[next]) - ord('0'))
              else accumulating := false;
            next := next + 1;
            end;
          if accumulating and (tempres <= hi_lim) and
             (tempres >= low_lim) then
            result := tempres
          else csierror(numrange, startingindex, next - 1);
        end; {numeric_value}


      begin
        repeat
          next := next + 1;
        until (cmdline[next] <> ' ') or (next = cmdlength);
        startingindex := next;
        if cmdline[next] in alphanums then thisqual := cmdline[next]
        else cmdline[next] := ' ';
        while cmdline[next] in alphanums do next := next + 1;
        if (thisqual = 'w') or (thisqual = 'W') then
          numeric_value(outwidth, 2 * sigcharlimit + 5, maxint)
        else csierror(unknown, startingindex, next - 1);
      end; {takequal}


    procedure takefilename(var next: cmdindex);

{ Parse a filename.  The only data which is taken here is the existance of the
  file.  This routine makes sure that there is only one file specified
  per field.
}

      var
        startindex: cmdindex; {start of this field}


      begin
        startindex := next;
        while (next < cmdlength) and
              not (cmdline[next] in [',', '/', '=', ' ']) do
          skipbalancedstring(startindex, next);
        if filefound then csierror(twofilenames, filestart, next)
        else
          begin
          filefound := true;
          filestart := startindex;
          end;
      end; {takefilename}


    procedure endfield(var next: cmdindex {next character} );

{ Terminate a field, making several checks.
}


      begin
        fieldsfound := fieldsfound + 1;
        if (fieldsfound = 1) and filefound then firstfound := true
        else if filefound then manyfound := true;
        if not filefound then
          if outspeced then csierror(nofile, lastfield, next)
          else if not emptyfile then
            begin
            emptyfile := true;
            emptystart := lastfield;
            emptyend := next;
            end;
        if cmdline[next] = '=' then
          if fieldsfound > 1 then csierror(manyouts, 1, next)
          else
            begin
            fieldsfound := 1;
            outspeced := true;
            end;
        lastfield := next;
        if next < cmdlength then next := next + 1;
        filefound := false;
      end;


    procedure checkconsistancy;

{ Check the command line and qualifiers for consistancy.
  This should also set any defaults.
}


      begin
        if not ((outspeced and manyfound) or firstfound) then
          csierror(noinput, 2, 1);
        if not outspeced and emptyfile then
          csierror(nofile, emptystart, emptyend);
      end;


    begin {csi}
      getcmdline;
      next := 1;
      fieldsfound := 0;
      lastfield := 1;
      filefound := false;
      outspeced := false;
      emptyfile := false;
      firstfound := false;
      manyfound := false;

      repeat
        while (next < cmdlength) and (cmdline[next] = ' ') do
          next := next + 1;
        case cmdline[next] of
          '=', ',': endfield(next);
          '/': takequal(next);
          ' ': ;
          otherwise takefilename(next);
          end;
      until next = cmdlength;
      endfield(next);
      if not outspeced then fieldsfound := fieldsfound + 1; {fake field}
      checkconsistancy;
    end; {csi}


  procedure getfilename(which: Integer; {file desired}
                        var Result: filename; {resulting file name}
                        var exists: Boolean {true if file exists} );

{ Procedure to get file names from the input command line.

  The desired file name is specified by an index with the following
  possible values.

  1     Output file
  2..n  Input files
}

    var
      Next: cmdindex; {search variable}
      fieldstart: 0..cmdlinelength; {start of the desired field}
      i: Integer; {induction var for transfer}
      delims: set of Char; {ending fields}
      stripdevice: boolean; {strip off device field}
      scanning: boolean; {used in stripping device field}


    begin
      if (which <= 0) or (which > fieldsfound) or outspeced and
         (((which = 0) or (which = 1)) and not firstfound) then
        exists := false
      else
        begin {we have a file to find}
        delims := [',', ' ', '/', '='];
        stripdevice := false;
        if (which = 1) and not outspeced then
          begin
          delims := delims + ['.'];
          which := fieldsfound;
          stripdevice := true;
          end;
        Next := 1;
        if which > 1 then
          begin
          if outspeced then
            begin
            repeat
              skipbalancedstring(Next, Next);
            until cmdline[Next] = '=';
            Next := Next + 1;
            end;
          which := which - 1;
          end;
        for i := 1 to which - 1 do
          begin
          while not (cmdline[Next] in [',', '=']) do
            skipbalancedstring(Next, Next);
          Next := Next + 1;
          end;
        while cmdline[Next] = ' ' do Next := Next + 1;
        fieldstart := Next;
        repeat
          skipbalancedstring(Next, Next);
        until cmdline[Next] in delims;
	if stripdevice then
	  begin
	  fieldstart := next - 1;
	  scanning := true;
	  repeat
	    scanning := cmdline[fieldstart] in ['A'..'Z', 'a'..'z', '$', '.',
			'0'..'9'];
	    if scanning then fieldstart := fieldstart - 1;
	  until (fieldstart = 0) or not scanning;
	  fieldstart := fieldstart + 1;
	  end;
        for i := fieldstart to Next - 1 do
          Result[i - fieldstart + 1] := cmdline[i];
        for i := Next - fieldstart + 1 to filenamelength do Result[i] := ' ';
        exists := true;
        end;
    end; {getfilename}


  procedure extractlabel(from: filename; {full file name}
                         var result: filelabel {resulting file label} );

    var
      i, j, k: natural; {misc induction vars}
      lowers: boolean; {any lowercase characters in file name?}
      extension: packed array [1..4] of char; {default extension}


    begin {Extract a shortened label from a full file name. This is just the
           file name portion of the full name. The file name in "from" is
           assumed to be terminated with a blank}
      result := blanklabel;
      i := 1;
      j := 0;
      while (from[i] <> ' ') and (from[i] <> '.') do
        begin
        if not (from[i] in alphanums) then j := i;
        i := i + 1;
        end;
      k := 0;
      lowers := false;
      for j := j + 1 to i - 1 do
        if k < labelsize - 4 then
          begin
          k := k + 1;
          if from[j] in lowercase then lowers := true;
          result[k] := from[j];
          end;
      if lowers then extension := '.pas'
      else extension := '.PAS';
      if from[i] = '.' then
        while from[i] <> ' ' do
          begin
          if k < labelsize then
            begin
            k := k + 1;
            result[k] := from[i];
            end;
          i := i + 1;
          end
      else for i := 1 to 4 do result[k + i] := extension[i];
    end; {extractlabel}


  procedure openinput(newfile: filename; {file name to attach}
                      var s: sourcedescriptor {source level} );


    begin
      with s do
        begin
        if rsx then reset(inputfile, newfile, 'SY:.PAS')
        else reset(inputfile, newfile, '.PAS');
        lineno := 0;
        chno := 0;
        total := 0;
        extractlabel(newfile, currentlabel);
        end;
    end; {openinput}


  procedure printlabel;

    var
      i: 1..labelsize; {induction var}


    begin
      with source[sourcelevel] do
        if currentlabel <> lastlabel then
          begin
          lastlabel := currentlabel;
          writeln(outputfile);
          for i := 1 to labelsize do
            if lastlabel[i] <> ' ' then write(outputfile, lastlabel[i]);
          writeln(outputfile, ':');
          writeln(outputfile);
          end;
    end; {printlabel}


  procedure printline;

    var
      i: linesize;


    begin
      with source[sourcelevel] do
        begin
        printlabel;
        write(outputfile, lineno: 5, '  ');
        i := 1;
        {is this the first time in a run or not?}
        if adjustment = first then
          begin
          {ignore any leading spaces there happen to be. }
          while (i < total) and (line[i] = ' ') do i := succ(i);
          {compute the adjustment needed for other lines. }
          movement := (level * indentation) - (i - 1);
          adjustment := other;
          {insert any necessary indentation.}
          if level > 0 then write(outputfile, ' ': (level * indentation));
          end
        else
          begin
          {it wasn't the first, so try to adjust to align with its mother}
          if movement > 0 then write(outputfile, ' ': movement)
          else if movement < 0 then
            while (i < total) and (line[i] = ' ') and (i <= - movement) do
              i := succ(i);
          end;
        {write out the line. }
        while i < total do
          begin
          write(outputfile, line[i]);
          i := succ(i);
          end;
        writeln(outputfile);
        end; {with}
    end {printline} ;


  procedure error(e: positive);
   {this procedure is the error message repository.}


    begin
      errorflag := true;
      write(outputfile, 'FATAL ERROR - ');
      case e of
        1: write(outputfile, '%INCLUDE''s nested to deeply');
        2: write(outputfile, 'No identifier after prog/proc/func');
        3: write(outputfile, 'Token after heading unexpected');
        4: write(outputfile, 'Lost "." check begin/case/end.');
        5: write(outputfile, 'Same name, but not forward-declared');
        end;
      {we shall print the offending line too.}
      writeln(outputfile, '  - at following line ');
      adjustment := first;
      printline;
      goto 99; {escape}
    end {error} ;


  procedure nextch;


    begin
      with source[sourcelevel] do
        if (chno = total) and eof(inputfile) then
          begin
          close(inputfile);
          if sourcelevel = 1 then
            begin
            curfileno := curfileno + 1;
            getfilename(curfileno, currentfile, fileexists);
            if fileexists then openinput(currentfile, source[1])
            else goto 99; {all done, bomb out}
            end
          else sourcelevel := sourcelevel - 1;
          end;
      with source[sourcelevel] do
        if chno = total then
          begin
          if printflag then printline;
          total := 0;
          while not eoln(inputfile) do
            begin
            total := succ(total);
            read(inputfile, line[total]);
            if line[total] = chr(ff) then total := pred(total)
            else if line[total] = chr(ht) then
              begin
              line[total] := ' ';
              while total mod tabinterval <> 0 do
                begin
                total := succ(total);
                line[total] := ' ';
                end;
              end;
            end;
          total := succ(total);
          line[total] := ' ';
          readln(inputfile);
          lineno := lineno + 1;
          chno := 1;
          ch := line[1];
          end
        else
          begin
          chno := succ(chno);
          ch := line[chno];
          end;
    end {nextch} ;


  procedure push(newscope: ptrtoentry);

    var
      newlevel: ptrtostackcell;


    begin
      new(newlevel);
      newlevel^.current := newscope;
      newlevel^.scopetree := nil;
      newlevel^.substack := stack;
      stack := newlevel;
      level := level + 1;
    end {push} ;


  procedure pop;

    var
      oldcell: ptrtostackcell;


    begin
      stack^.current^.localtree := stack^.scopetree;
      oldcell := stack;
      stack := oldcell^.substack;
      dispose(oldcell);
      level := level - 1;
    end {pop} ;


  procedure findnode(var match: boolean;
                     var follow: ptrtoentry;
                     thisnode: ptrtoentry);


    begin
      match := false;
      while (thisnode <> nil) and not match do
        begin
        follow := thisnode;
        if savesymbol < thisnode^.procname then thisnode := thisnode^.left
        else if savesymbol > thisnode^.procname then
          thisnode := thisnode^.right
        else match := true;
        end
    end {findnode} ;


  function makeentry(mainprog: boolean;
                     proc: boolean): ptrtoentry;
    { The first parameter is true if the name in symbol is the
     program indetifier, which has no scope. The second parameter
     is true if the name in symbol is that of a procedure of function.
     The result returned is the identification of the relevant record.}

    var
      newentry, node: ptrtoentry;
      located: boolean;


    procedure puttosupertree(newnode: ptrtoentry);
      {this procedure takes the entry that has been created by
       MakeEntry and inserted into the local tree, and also links
       it into the supertree.}

      var
        place: ptrtoentry;


      procedure findleaf;
        {findleaf searches the supertree to find where this
         node should be placed. It will be appended to a leaf
         of course, and placed after entries with the same
         name.}

        var
          subroot: ptrtoentry;


        begin
          subroot := superroot;
          while subroot <> nil do
            begin
            place := subroot;
            if savesymbol < subroot^.procname then subroot := subroot^.before
            else subroot := subroot^.after;
            end
        end {findleaf} ;


      begin {puttosupertree}
        if superroot = nil then
          begin
          {nothing in the supertree yet.}
          superroot := newnode
          end
        else
          begin
          {seek the right place}
          findleaf;
          with place^ do
            if savesymbol < procname then before := newnode
            else after := newnode
          end
      end {PutToSuperTree} ;


    begin {MakeEntry}
      located := false;
      savesymbol := symbol;
      if mainprog then new(newentry)
      else if stack^.scopetree = nil then
        begin
        {Nothing here yet.}
        new(newentry);
        stack^.scopetree := newentry
        end
      else
        begin
        { seek the identifier in the tree.}
        findnode(located, node, stack^.scopetree);
        if not located then
          begin
          {normal case, make an entry.}
          new(newentry);
          with node^ do
            if symbol < procname then left := newentry
            else right := newentry
          end
        end;
      if not located then
        begin
        {Here we initialize all the fields}
        with newentry^, source[sourcelevel] do
          begin
          procname := symbol;
          procuppers := symbolcase;
          linenumber.line := lineno;
          linenumber.fileref := currentlabel;
          startofbody.line := 0;
          startofbody.fileref := blanklabel;
          if proc then status := shortform
          else status := notproc;
          left := nil;
          right := nil;
          before := nil;
          after := nil;
          calls := nil;
          called := nil;
          localtree := nil;
          end;
        makeentry := newentry;
        if proc then
          begin
          puttosupertree(newentry);
          push(newentry);
          end
        end
      else
        begin
        {well, it'd better be forward or else.}
        makeentry := node;
        push(node);
        if (node^.status = fwdhalf) or (node^.status = outside) then
          with source[sourcelevel] do
            begin
            stack^.scopetree := node^.localtree;
            if node^.status = fwdhalf then node^.status := allfwd
            else node^.status := outsidedef;
            node^.forwardblock.line := lineno;
            node^.forwardblock.fileref := currentlabel;
            end
        else error(5)
        end
    end {makeentry} ;


  procedure printtree(root: ptrtoentry);

    var
      thiscell: listofusages;
      count: natural;


    procedure namewrite(p: ptrtoentry);

      var
        s: sigcharrange;


      begin
        for s := 1 to sigcharlimit do
          if p^.procuppers[s] then
            write(outputfile, chr(ord(p^.procname[s]) - uclcdisplacement))
          else write(outputfile, p^.procname[s])
      end {namewrite} ;


    procedure writelineref(thisline: lineref);

      var
        c: 1..labelsize; {induction var}


      begin {Print a line reference in the form "filelabel: line".}
        with thisline do
          begin
          for c := 1 to labelsize do
            if fileref[c] <> ' ' then write(outputfile, fileref[c]);
          write(outputfile, ', ', line: 1);
          end;
      end; {writelineref}


    procedure listrefs(firstline: prefixname; {header for first line}
                       thiscell: listofusages {usages to list} );


      begin {list a set of references}
        writeln(outputfile);
        write(outputfile, firstline: sigcharlimit - 1, '  ');
        count := 0;
        while thiscell <> nil do
          begin
          if ((count mod namesperline) = 0) and (count <> 0) then
            begin
            writeln(outputfile);
            write(outputfile, ' ': sigcharlimit + 1);
            end;
          write(outputfile, ' ');
          namewrite(thiscell^.what);
          thiscell := thiscell^.next;
          count := count + 1;
          end;
        writeln(outputfile);
      end; {listrefs}


    begin {printtree}
      if root <> nil then
        with root^ do
          begin
          printtree(before);
          if (root <> superroot) or (calls <> nil) then
            begin
            writeln(outputfile);
            writeln(outputfile);
            namewrite(root);
            write(outputfile, '  Head: ');
            writelineref(linenumber);
            if startofbody.line <> 0 then
              begin
              write(outputfile, '  Body: ');
              writelineref(startofbody);
              end;
            case status of
              fwdhalf, notproc: write(outputfile, '  Incomplete');
              formal: write(outputfile, '  formal');
              outside: write(outputfile, '  external');
              shortform: ;
              outsidedef:
                begin
                writeln(outputfile);
                write(outputfile, ' ': sigcharlimit + 2,
                      'External Def, header stub: ');
                writelineref(forwardblock);
                end;
              allfwd:
                begin
                writeln(outputfile);
                write(outputfile, ' ': sigcharlimit + 2,
                      'Forward, header stub: ');
                writelineref(forwardblock);
                end;
              end;
            writeln(outputfile);
            if calls <> nil then listrefs('Calls    ', calls);
            if called <> nil then listrefs('Called by', called);
            end;
          printtree(after);
          end;
    end {printtree} ;


  procedure nexttoken;
    {this procedure produces the next "token" in a small set of
     recognized tokens. Most of these serve an incidental purpose;
     the prime purpose is to recognize names (res'd words or identifiers).
     It serves also to skip dangerous characters in comments, strings,
     and numbers.}


    procedure ignorecomment;
      {This procedure ships over comments according to the definition
       in the Draft Pascal Standard.}


      begin
        nextch;
        repeat
          while (ch <> '*') and (ch <> '}') do nextch;
          if ch = '*' then nextch;
        until (ch = ')') or (ch = '}');
        nextch;
      end {Ignorecomment} ;


    procedure ignorenumbers;
      {This procedure skips numbers because the exponent part
       just might get recognized as a name! Care must be taken
       not to consume half of a ".." occurring in a construct like
       "1..name", or worse to consume it and treat the name as a
       possible exponent as in "1..E02". Ugh.}


      begin
        while ch in digits do nextch;
       { The construction of NextCh, chno & line ensure that
        the following tests are always defined. It is to get
        rid of tokens which begin with a period like .. & .) }
        if (ch = '.') then
          with source[sourcelevel] do
            if (line[chno + 1] in digits) then
              begin
              nextch;
              while ch in digits do nextch
              end;
        if (ch = 'E') or (ch = 'e') then
          begin
          nextch;
          if (ch = '+') or (ch = '-') then nextch;
          while ch in digits do nextch
          end
        else if (ch = 'B') or (ch = 'b') then nextch;
      end {ignorenumbers} ;


    procedure readident;
     {This procedure reads in an identifier }

      var
        j: positive;


      begin
        token := namesy;
        symbol := spaces;
        symbolcase := lowers;
        j := 1;
        while (j <= sigcharlimit) and (ch in alphanums) do
          begin
          if ch in uppercase then
            begin
            symbol[j] := chr(ord(ch) + uclcdisplacement);
            symbolcase[j] := true;
            end
          else symbol[j] := ch;
          j := j + 1;
          nextch;
          end;
        {In case there is a tail, skip it.}
        while (ch in alphanums) do nextch;
      end {readident} ;


    procedure lexicaldirective;

      var
        j: natural;


      begin
        nextch;
        if ch in alphabet then
          begin
          readident;
          if symbol = sinclude then
            begin
            while ch = ' ' do nextch;
            j := 0;
            while not (ch in [' ', ';']) do
              begin
              j := j + 1;
              currentfile[j] := ch;
              nextch;
              end;
            for j := j + 1 to filenamelength do currentfile[j] := ' ';
            sourcelevel := sourcelevel + 1;
            openinput(currentfile, source[sourcelevel]);
            nextch;
            end;
          end;
        token := othersy;
      end; {lexicaldirective}


    begin {nexttoken}
      token := othersy;
      repeat
        case ch of

          ')':
            begin
            nextch;
            token := rparensy;
            end;

          '(':
            begin
            nextch;
            if ch = '*' then ignorecomment
            else token := lparensy
            end;

          '{': ignorecomment;

          '''':
            begin
            nextch;
            while ch <> '''' do nextch;
            nextch;
            end;

          '0', '1', '2', '3', '4', '5', '6', '7', '8', '9': ignorenumbers;

          ':':
            begin
            nextch;
            if ch = '=' then
              begin
              token := assignsy;
              nextch;
              end
            else token := colonsy;
            end;

          '.':
            begin
            nextch;
            if ch <> '.' then token := periodsy
            else
              begin
              token := subrangesy;
              nextch;
              end;
            end;

          ';':
            begin
            nextch;
            token := semicolsy;
            end;

          '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',
          '$':
            readident;
          '%': lexicaldirective;
          otherwise {uninteresting character } nextch;
          end;
      until token <> othersy;
    end {nexttoken} ;


  procedure processunit(programid: boolean);
    {this procedure processes a program unit. it is called on
     recognition of its leading token = program/procedure/function.
     The parameter records whether we currently have the main program
     identifier in the token, or not. It doesn;t have scope.}

    var
      at: ptrtoentry;


    function nameisinscope: boolean;
      {This function is called during the declaration phase
       of a block, and has to find any procedure which gets
       renamed by the scope rules.}

      var
        llevel: ptrtostackcell;
        discovered: boolean;
        where: ptrtoentry;


      begin
        llevel := stack;
        discovered := false;
        savesymbol := symbol;
        while (llevel <> nil) and not discovered do
          begin
          findnode(discovered, where, llevel^.scopetree);
          if not discovered then llevel := llevel^.substack
          end;
        if discovered then nameisinscope := (where^.status <> notproc)
        else nameisinscope := false;
      end {nameisinscope} ;


    procedure processblock;
      {This procedure is called by ProcessUnit when it has recognized
       the start of a block. It handles the processing of the block.}

      var
        address: ptrtoentry;


      procedure crossreference;
        {Crossreference is called whenever we have a name which
         might be a call to a procedure or function. The only way
         we tell is by looking in the table to see. If it is, then
         the list of usages if the procedure we are in is scanned and
         possibly extended.}

        var
          home: ptrtoentry;
          slevel: ptrtostackcell;
          found: boolean;


        procedure makeref(var log: listofusages; {list to add ref to}
                          usage: ptrtoentry {entry being used} );

          var
            found: boolean; {usage already noted}
            ptr: listofusages; {place to put next usage note}
            nextptr: listofusages; {scans list of usages}
            newcell: listofusages; {new usage entry being created}


          begin
            found := false;
            nextptr := log;
            if nextptr <> nil then
              repeat
                ptr := nextptr;
                found := (ptr^.what = usage);
                nextptr := ptr^.next;
              until found or (nextptr = nil)
            else ptr := nil;
            if not found then
              begin
              new(newcell);
              if ptr <> nil then ptr^.next := newcell
              else log := newcell;
              newcell^.what := usage;
              newcell^.next := nil;
              end;
          end; {makeref}


        begin {crossreference}
          slevel := stack;
          found := false;
          while (slevel <> nil) and not found do
            begin
            findnode(found, home, slevel^.scopetree);
            if not found then slevel := slevel^.substack;
            end;
          if found then
            begin
            if home^.status <> notproc then
              begin
              makeref(home^.called, stack^.current);
              makeref(stack^.current^.calls, home);
              end;
            end;
        end {crossreference} ;


      procedure scanforname;
        {This procedure is required to go forward until the
         current token is a name (reserved word or identifier).}


        begin
          nexttoken;
          while token <> namesy do nexttoken;
        end {scanforname} ;


      begin {processBlock}
        depth := 0;
        while (symbol <> sbegin) do
          begin
          while (symbol <> sbegin) and (symbol <> sprocedure) and
                (symbol <> sfunction) do
            begin
            scanforname;
            if symbol = srecord then depth := depth + 1
            else if symbol = send then depth := depth - 1
            else if (depth = 0) and nameisinscope then
              begin
              address := makeentry(false, false);
              {makeentry made its status notproc}
              end;
            end;
          if symbol <> sbegin then
            begin
            processunit(false);
            scanforname;
            end;
          end;
        {We have now arrived at the body}
        depth := 1;
        with stack^.current^, source[sourcelevel] do
          begin
          startofbody.line := lineno;
          startofbody.fileref := currentlabel;
          end;
        nexttoken;
        while depth <> 0 do
          begin
          if token = periodsy then
            begin
            nexttoken;
            if token = namesy then nexttoken;
            end;
          if token <> namesy then nexttoken
          else
            begin
            if (symbol = sbegin) or (symbol = scase) then
              begin
              depth := depth + 1;
              nexttoken;
              end
            else if (symbol = send) then
              begin
              depth := depth - 1;
              nexttoken;
              end
            else
              begin
                   {This name is a candidate call. But first we
                    must eliminate assignments to function values.}
              savesymbol := symbol;
              nexttoken;
              if token <> assignsy then
                begin
                crossreference
                end
              else
                begin
                nexttoken;
                end;
              end
            end;
          end;
      end {processblock} ;


    procedure scanparameters;
      { This procedure scans the parameter list because at the outer
       level there may be a formal procedure we ought to know about.}

      var
        which: ptrtoentry;


      procedure scantillclose;
        {This procedure is called when a left paranthese is
         detected, and its task is to find the matching right
         parenthese. It does this recursively.}


        begin
          nexttoken;
          while token <> rparensy do
            begin
            if token = lparensy then scantillclose;
            nexttoken;
            end;
        end {scantillclose} ;


      begin {scanParameters}
        nexttoken;
        while token <> rparensy do
          begin
          if (token = namesy) then
            begin
            if (symbol = sprocedure) or (symbol = sfunction) then
              begin
              { A formal procedural/functional parameter.}
              nexttoken;
              if token = namesy then
                begin
                which := makeentry(false, true);
                which^.status := formal;
                pop;
                nexttoken;
                if token = lparensy then
                  begin
                  {skip interior lists.}
                  scantillclose;
                  end;
                end
              else
                begin
                error(2);
                nexttoken;
                end;
              end
            else
              begin
              if nameisinscope then which := makeentry(false, false);
              nexttoken;
              end;
            end
          else nexttoken;
          end;
        nexttoken;
      end {scanparameters} ;


    begin {processUnit}
      if programid and (symbol <> sprogram) then
        begin
        at := makeentry(true, true);
        at^.procname := fakeprog;
        at^.procuppers := lowers;
        processblock;
        pop;
        end
      else
        begin
        printflag := true;
        adjustment := first;
        nexttoken;
        if token <> namesy then error(2)
        else
          begin
          {We now have the name to store away.}
          at := makeentry(programid, true);
          while not (token in [lparensy, semicolsy, colonsy]) do nexttoken;
          if token = lparensy then scanparameters;
          while token <> semicolsy do nexttoken;
          printline;
          { We have now printed the procedure heading.}
          printflag := false;
          writeln(outputfile);
          {Our next task is to see if there is an attached block.}
          nexttoken;
          if token <> namesy then error(3)
          else
            begin
            if (symbol <> slabel) and (symbol <> sconst) and
               (symbol <> stype) and (symbol <> sprocedure) and
               (symbol <> sfunction) and (symbol <> svar) and
               (symbol <> sbegin) then
              begin
              {bloody directive, mate.}
              if symbol = sforward then at^.status := fwdhalf
              else at^.status := outside;
              pop;
              end
            else
              begin
              processblock;
              pop;
              end;
            end;
          end;
        end;
    end {processunit} ;


  procedure printheading;


    begin
      writeln(outputfile, 'Procedural Cross-Referencer - Version 2.0K-3');
      writeln(outputfile, cmdline: cmdlength);
      writeln(outputfile);
    end {printheading} ;


  begin {referencer}
    superroot := nil;

    {Here we construct an outer-scope stack entry. This is needed
     to hold any pre-defined names. The Distributed version does not
     include any of these, but they are easily provided. See the
     outlines in the code marked with *** if you want this feature.}

    new(stack);
    with stack^ do
      begin
      current := nil;
      scopetree := nil;
      substack := nil;
      end;

    printflag := false;

    uppercase := ['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'];

    lowercase := ['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'];

    alphabet := uppercase + lowercase;

    digits := ['0', '1', '2', '3', '4', '5', '6', '7', '8', '9'];

    alphanums := alphabet + digits + ['$', '_'];

    usefulchars := alphabet + digits + ['(', ')', '{', '.', ':', ';', ''''];

    for i := 1 to sigcharlimit do lowers[i] := false;

    outwidth := linewidth;

    level := - 1;
    errorflag := false;

    lastlabel := blanklabel;

    csi;
    getfilename(1, currentfile, fileexists);
    if rsx then rewrite(outputfile, currentfile, 'SY:.PRF')
    else rewrite(outputfile, currentfile, '.PRF');
    curfileno := 2;
    sourcelevel := 1;
    getfilename(curfileno, currentfile, fileexists);
    openinput(currentfile, source[sourcelevel]);

    namesperline := (outwidth - (sigcharlimit + 2)) div (sigcharlimit + 1);

    printheading;
    writeln(outputfile, ' Line Program/procedure/function heading');
    for pretty := 1 to 43 do write(outputfile, '-');
    writeln(outputfile);

    {now we need to get the first token, which should be program.}
    nexttoken;
    if token <> namesy then error(1)
    else processunit(true);

    {Complete phase one - now for the next.}
  99:
    if not errorflag then
      begin
      page(outputfile);
      printheading;
      writeln(outputfile, 'Cross Reference Listing');
      printtree(superroot);
      writeln(outputfile);
      end;
  end.