{[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.

  Simple cross referenced generator
  Release version: 2.0K  Level: 3  Date: 15-Jan-1982 11:23:15
  Processor: PDP11
}

{  Cross reference generator for Pascal
                                       N. Wirth   7 May 74
                                       J. Zaun    9 Nov 78
                                       M. Ball    9 Feb 81


   Originally written by N. Wirth for the CDC 6000 Implementation.

   Converted by J. Zaun to "paslist" to cater to the idiosyncracies
   of the Univac 1100 operating system and provide a way to get page
   ejects, etc into a listing.

   Further modified to cater to the idiosyncracies of the PDP-11
   operating systems and reduce space requirements.  This includes
   some blatant hacks to make things fit into a single word of a
   packed record.
}

label
  99;

const

  panic_space = 200; {bytes at which to quit}

  hash_max = 733; {size of hash table}

  blank12 = '            '; {12 blanks}
  id_length = 12; {12 char identifiers}
  ref_length = 6; {length of each reference}

  case_shift = - 32; {ASCII case shift offset}

  {[s=4] key word indexes, defined to allow binary search }
  and_key = 1;       arr_key = 2;       beg_key = 3;       cas_key = 4;
  con_key = 5;       div_key = 6;       do_key = 7;        dwn_key = 8;
  els_key = 9;       end_key = 10;      ext_key = 11;      fil_key = 12;
  for_key = 13;      fun_key = 14;      got_key = 15;      if_key = 16;
  in_key = 17;       lab_key = 18;      mod_key = 19;      nil_key = 20;
  non_key = 21;      not_key = 22;      of_key = 23;       or_key = 24;
  org_key = 25;      oth_key = 26;      pac_key = 27;      prc_key = 28;
  prg_key = 29;      rec_key = 30;      rep_key = 31;      set_key = 32;
  thn_key = 33;      to_key = 34;       typ_key = 35;      unt_key = 36;
  var_key = 37;      whl_key = 38;      wth_key = 39;

  {[s=1] end key definitions}

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

   %include OSCONF {Specifies operating system }

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


  cmdlinelength = 132; { length of a command line }

type

  quals = (blanks, listq, widthq, notfound);

  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);

  index = 0..hash_max; {hash table size}
  alpha = packed array [1..id_length] of char;

  kinds = (no_kind, decl_kind, asg_kind); {ref kinds}

  item_ptr = ^item;
  item =
    packed record
      line: 0..16383; {line no of ref, limits set to allow 2 word item}
      kind: kinds; {reference kind}
      next: item_ptr; {next reference for this entry}
    end;

  entries =
    packed record
      entri: alpha; {item name}
      last: item_ptr; {last reference to this item}
      next_indx: index; {next link in hash chain}
    end;

var

  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}

  {input variables}

  id: alpha; {Input identifier}
  id_nmbr, total: integer; {id counters}
  char_cnt, blank_cnt: integer; {character pos with id}
  line_nmbr: integer; {input line number}
  error_line: integer; {Line number of error}
  line_end: boolean; {TRUE at line_end}

  listing_wanted: boolean; {listing of input desired}

  {structured constants}

  r: array [and_key..wth_key] of alpha; {key word table}
  alpha_numerics, numerics, numbers, upper_cases: set of char;
  lower_cases: set of char;
  decls: set of and_key..wth_key; {start of decl}

  decl, def: boolean; {Tells when to mark refs as decl}

  {hash table variables}

  hash_table: array [index] of entries; {the hash table}
  indx, last_indx: index; {hash indexes}
  asg_ref: item_ptr; {line ref of last identitier}
  asg_ok: boolean; {determines which ref is asg ref}

  {output variables}

  done: boolean; {TRUE when done}
  error: boolean; {TRUE when table is full}
  flag_char: char; {char to print along left column}
  current_letter: char; {current xref letter}
  line_length: integer;


function space: integer;

{ Returns the amount of stack space remaining
}

  external;

 {*-----------------------*
  |   initialization      |
  *-----------------------*  }

{Command String Interpreter,  parses the command string and sets
 the initial state of the switches.
}


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.
}

  const
    qualifierlength = 6; {one > max qualifier accepted}

  type

    qualifier = packed array [1..qualifierlength] of char; {qual name}

    qualtable = array [quals] of qualifier; {look-up table}

  var

    qualindex: qualtable; {qualifier lookup table}
    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 initquals;

{ Initialize the qualifier table.
}


    begin {[s=2]}
      qualindex[blanks] := '      ';      qualindex[listq] := 'LIST  ';
      qualindex[widthq] := 'WIDTH ';
      {[s=1]}
    end;



  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
            cmdline[cmdlength] := input^;
            cmdlength := cmdlength + 1;
            end;
          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}
      quali: 0..qualifierlength; {current character in qual being built}
      name: qualifier; {qualifier name}
      thisqual: quals; {qualifier just found}


    procedure findqual(target: qualifier; {candidate Qual name}
                       var result: quals {result of lookup} );

      var
        partialmatch: boolean; {partially matches the Qual so far}
        partialresult: quals; {where the match was}
        partials: 0..maxint; {counter of partial matches}
        effectivelength: 0..qualifierlength; {significant chars in target}
        i: 1..qualifierlength; {induction var}


      begin {Look up "target" in the Qualindex and set "result" to the
             appropriate Qual. if there is a full match, this is always
             taken. Otherwise, a single partial match will be accepted.
             multiple partial matches cause "ambiguous" to be set.}

        partials := 0;
        effectivelength := 0;
        for i := 1 to qualifierlength do
          if target[i] <> ' ' then effectivelength := i;
        result := blanks;
        qualindex[notfound] := target; {to terminate search}

        while target <> qualindex[result] do
          begin
          result := succ(result);
          partialmatch := target <> qualindex[result];
          for i := 1 to effectivelength do
            partialmatch := partialmatch and
                            (target[i] = qualindex[result, i]);
          if partialmatch then
            begin
            partialresult := result;
            partials := partials + 1;
            end;
          end;
        if (result = notfound) and (partials = 1) then
          result := partialresult;
      end; {findQual}


    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;
      quali := 0;
      while cmdline[next] in alpha_numerics do
        begin
        if quali < qualifierlength then
          begin
          quali := quali + 1;
          name[quali] := cmdline[next];
          if name[quali] in lower_cases then
            name[quali] := chr(ord(name[quali]) + case_shift);
          end;
        next := next + 1;
        end;
      while quali < qualifierlength do
        begin
        quali := quali + 1;
        name[quali] := ' ';
        end;
      findqual(name, thisqual);
      if thisqual = notfound then csierror(unknown, startingindex, next - 1)
      else if thisqual = listq then listing_wanted := true
      else if thisqual = widthq then numeric_value(line_length, 20, maxint);
    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}
    initquals;
    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 initialize;

  var
    indx: index;
    thisfile: filename;
    exists: boolean; {dummy to getfilename}


  begin
    {hash table variables}
    for indx := 0 to hash_max - 1 do hash_table[indx].entri := blank12;
    total := 0;
    id_nmbr := 0;
    line_nmbr := 0;
    last_indx := hash_max;

    {I/O related variables}
    done := false;
    error := false;
    current_letter := ' ';
    blank_cnt := id_length;

    {character sets}
    numbers := ['0'..'9'];
    upper_cases := ['A'..'Z', '$'];
    lower_cases := ['a'..'z'];
    alpha_numerics := lower_cases + ['_'] + upper_cases + numbers;
    numerics := ['b', 'B', 'E', 'e'] + numbers;

    {syntax variables}
    decl := true;
    def := false;
    asg_ok := true;
    flag_char := ' ';
    decls := [con_key, typ_key, var_key, prc_key, prg_key, fun_key];

    {[s=2] key word table -- these entries MUST be in alphabetical order}

    r[and_key] := 'AND         ';        r[arr_key] := 'ARRAY       ';
    r[beg_key] := 'BEGIN       ';        r[cas_key] := 'CASE        ';
    r[con_key] := 'CONST       ';        r[div_key] := 'DIV         ';
    r[do_key] := 'DO          ';         r[dwn_key] := 'DOWNTO      ';
    r[els_key] := 'ELSE        ';        r[end_key] := 'END         ';
    r[ext_key] := 'EXTERNAL    ';        r[fil_key] := 'FILE        ';
    r[for_key] := 'FOR         ';        r[fun_key] := 'FUNCTION    ';
    r[got_key] := 'GOTO        ';        r[if_key] := 'IF          ';
    r[in_key] := 'IN          ';         r[lab_key] := 'LABEL       ';
    r[mod_key] := 'MOD         ';        r[nil_key] := 'NIL         ';
    r[non_key] := 'NONPASCAL   ';        r[not_key] := 'NOT         ';
    r[of_key] := 'OF          ';         r[or_key] := 'OR          ';
    r[org_key] := 'ORIGIN      ';        r[oth_key] := 'OTHERWISE   ';
    r[pac_key] := 'PACKED      ';        r[prc_key] := 'PROCEDURE   ';
    r[prg_key] := 'PROGRAM     ';        r[rec_key] := 'RECORD      ';
    r[rep_key] := 'REPEAT      ';        r[set_key] := 'SET         ';
    r[thn_key] := 'THEN        ';        r[to_key] := 'TO          ';
    r[typ_key] := 'TYPE        ';        r[unt_key] := 'UNTIL       ';
    r[var_key] := 'VAR         ';        r[whl_key] := 'WHILE       ';
    r[wth_key] := 'WITH        ';

    {[s=1]}

    listing_wanted := false;
    line_length := 80;
    csi;
    getfilename(2, thisfile, exists);
    if rsx then reset(input, thisfile, 'sy:.pas')
    else reset(input, thisfile, '.pas');
    getfilename(1, thisfile, exists);
    if rsx then rewrite(output, thisfile, 'sy:.crf')
    else rewrite(output, thisfile, '.crf');

  end {initialize} ;

{*---------------------*
 |  I/O procedures     |
 *---------------------*   }


procedure new_line(ch: char);


  begin { Process a new input line, generating a line number if a listing is
         being generated. NOTE: The linenumber, etc is calculated to take
         exactly 8 characters, so tabs look right }
    line_nmbr := line_nmbr + 1;
    if listing_wanted then write(output, ch, line_nmbr: 6, ' ');
  end;


procedure sget;


  begin
    if eof(input) then goto 99
    else if eoln(input) then
      begin
      if listing_wanted then writeln;
      get(input);
      if not eof(input) then new_line(flag_char);
      line_end := true;
      end
    else
      begin
      line_end := false;
      get(input)
      end;
    if eof(input) then goto 99;
  end;


procedure copy_char;


  begin
    if listing_wanted then write(input^);
    sget;
  end;

 {*-----------------------------*
  | Lexical and Syntax Analysis |
  *-----------------------------* }


function reserved_wrd(word: alpha): boolean;

  var
    low, high, key: integer;
    key_ok: boolean;


  begin
    low := and_key;
    high := wth_key;
    repeat { binary search }
      key := (low + high) div 2;
      if r[key] <= word then low := key + 1;
      if r[key] >= word then high := key - 1;
    until low > high;
    key_ok := (r[key] = word);
    if key_ok then
      begin
      if key in decls then decl := true
      else if key = beg_key then decl := false
      else if (key = rec_key) or (key = cas_key) then def := false;
      end;
    reserved_wrd := key_ok;
  end { function } ;


procedure cross_ref;

  var
    indx, dst, i: index;
    ref: item_ptr;
    found: boolean;


  begin
    indx := 1;
    found := false;
    dst := 1;
    for i := 1 to 8 do indx := abs((indx * ord(id[i])) mod hash_max);
    total := total + 1;
    if space >= panic_space then
      begin
      new(ref);
      if asg_ok then asg_ref := ref;
      with ref^ do
        begin
        line := line_nmbr;
        next := nil;
        if decl and not def then kind := decl_kind
        else kind := no_kind;
        end;
      repeat
        with hash_table[indx] do
          begin
          if entri = id then
            begin {found}
            found := true;
            ref^.next := last;
            last := ref;
            end
          else if entri = blank12 then
            begin {new entri}
            found := true;
            id_nmbr := id_nmbr + 1;
            entri := id;
            last := ref;
            next_indx := last_indx;
            last_indx := indx;
            end
          else
            begin {collision}
            indx := (indx + dst) mod hash_max;
            dst := dst + 2;
            if dst >= hash_max then
              begin
              writeln;
              writeln('**** Too many unique identifiers.');
              error := true;
              error_line := line_nmbr;
              found := true
              end
            end
          end {with}
      until found;
      end
    else
      begin
      writeln;
      writeln('**** Too many references.');
      error := true;
      error_line := line_nmbr;
      end;
  end {cross_ref} ;


procedure identifier;


  begin
    if not error then
      begin
      char_cnt := 0;
      repeat
        if (char_cnt < id_length) then
          begin
          char_cnt := char_cnt + 1;
          if input^ in lower_cases then
            id[char_cnt] := chr(ord(input^) + case_shift)
          else id[char_cnt] := input^;
          end;
        copy_char
      until not (input^ in alpha_numerics);
      if char_cnt >= blank_cnt then blank_cnt := char_cnt
      else
        repeat
          id[blank_cnt] := ' ';
          blank_cnt := blank_cnt - 1
        until blank_cnt = char_cnt;
      if not reserved_wrd(id) then cross_ref;
      end
    else
      repeat
        copy_char
      until not (input^ in alpha_numerics);
  end {identifier} ;


procedure number;


  begin
    repeat
      copy_char;
    until not (input^ in numerics)
  end {number} ;


procedure string;


  begin
    flag_char := 's';
    repeat
      copy_char;
    until (input^ = '''') or (line_end);
    flag_char := ' ';
    copy_char;
  end {string} ;


procedure comment;


  begin
    flag_char := 'c';
    copy_char;
    while input^ <> '}' do copy_char;
    flag_char := ' ';
    copy_char;
  end {comment} ;


procedure comment1(termchar: char);


  begin
    copy_char;
    if input^ = '*' then
      begin
      flag_char := 'c';
      copy_char;
      repeat
        while input^ <> '*' do copy_char;
        copy_char;
      until input^ = termchar;
      flag_char := ' ';
      copy_char;
      end
  end {comment1} ;


procedure special_char;

  var
    got: boolean;


  begin
    got := false;
    if input^ = '[' then asg_ok := false
    else if input^ = ']' then asg_ok := true
    else if input^ = '=' then def := true
    else if input^ = ';' then def := false
    else if input^ = '%' then
      while not eoln do copy_char
    else if input^ = ':' then
      begin
      copy_char;
      got := true;
      if input^ = '=' then
        begin
        if not error then asg_ref^.kind := asg_kind;
        copy_char;
        end
      else def := true;
      end;
    if not got then
      begin
      copy_char
      end;
  end;


procedure scan_input;


  begin
    new_line(' ');
    while not (done or eof(input)) do
      begin
      if input^ in upper_cases + lower_cases then identifier
      else if input^ in numbers then number
      else if input^ = '''' then string
      else if input^ = '{' then comment
      else if input^ = '(' then comment1(')')
      else if input^ = '/' then comment1('/')
      else special_char;
      end;
  end {print_listing} ;

{*----------------------*
 | hash table printing  |
 *----------------------* }


procedure print_entri(hash: entries);

  var
    out_count: integer;
    ch: char;
    i: integer;
    ref, last_ref, next_ref: item_ptr; {used to track entry list}


  begin
    with hash do
      begin
      if entri[1] <> current_letter then
        begin
        current_letter := entri[1];
        writeln;
        writeln('-', current_letter, '-');
        end;
      write(entri, ' ');
      out_count := id_length + 1;
      end;
    last_ref := nil;
    ref := nil;
    next_ref := hash.last;

    while next_ref <> nil do
      begin
      ref := next_ref;
      next_ref := ref^.next;
      ref^.next := last_ref;
      last_ref := ref;
      end;

    repeat
      if out_count > line_length - ref_length - 1 then
        begin {continue on next line}
        writeln;
        write(' ': id_length + 1);
        out_count := id_length + 1;
        end;
      out_count := out_count + ref_length + 1;
      with ref^ do
        begin
        if kind = decl_kind then ch := '*'
        else if kind = asg_kind then ch := '='
        else ch := ' ';
        write(line: ref_length, ch);
        ref := next
        end;
    until ref = nil;
    writeln;
  end {print_entri} ;


procedure print_cross_ref;

  var
    i, j, min: index;


  begin
    if listing_wanted then page(output);
    writeln('Cross reference:  * indicates definition, = indicates assignment'
            );
    i := last_indx;
    while i <> hash_max do
      begin
      min := i;
      j := hash_table[i].next_indx;
      while j <> hash_max do
        begin
        if hash_table[j].entri < hash_table[min].entri then min := j;
        j := hash_table[j].next_indx;
        end;
      print_entri(hash_table[min]);
      if min <> i then
        begin
        hash_table[min].entri := hash_table[i].entri;
        hash_table[min].last := hash_table[i].last;
        end;
      i := hash_table[i].next_indx;
      end; {while loop}
    writeln;
    writeln;
    if error then
      begin
      writeln('Memory capacity exceeded at line:', error_line: 5);
      writeln('Program too large for xref.');
      end;
    writeln('end xref', id_nmbr: 4, ' identifiers', total: 6,
            ' total references')
  end {print_cross_ref} ;

{ *-------------------*
  |   main program    |
  *-------------------* }


begin
  initialize;
  scan_input;
99:
  print_cross_ref;
end.