Programmer 7500/MAX_PROGRAMMERS.iso/INFO/TURBOPAS/ID_REF.ZIP/ID-REF.PAS

Pascal/Delphi Source File | 1985-12-28 | 31.1 KB | 1,075 lines

{ Identifier Cross-referencer - Copyright 1985 Lodestar Computing, Inc. }
{$R-,V-}
PROGRAM ident_cross_ref;

  { MODIFICATIONS:

    28 Jun 85 - Dap - Corrected for Pointers verses Control Chars
    05 Jun 85 - Dap - Corrected for hexidecimal numers
    22 Apr 85 - Dap - Find Match corrected for length
    21 Apr 85 - Dap - Corrected for Turbos use of '#' & '$' for numbers
    20 Oct 84 - Dap - Modified to run under Turbo Pascal
    12 Oct 84 - Dap - Rewrite of original Xiu_Ref
      Which was a Cross-referencer that handled UCSD Include files & Units
    1976      - Nw  - Pascal Cross-reference program
      "Algorithms + Data Structures = Programs" by Niklaus Wirth
        Copyright 1976 by Prentice-Hall, Inc.
      See pages 206 - 8 program crossref
  }

  CONST
                              { Version Control }
    icr_name    = 'Identifier Cross Referencer';
    icr_version = '[2.2e] 28 Jun 85';

    forever     = False; { How long this thing would go }

    sys_slop    = 200; { Leave a little space for the system     }

    bs  = #08; { Back space                           }
    cr  = #13; { Carriage return                      }
    ff  = #12; { Form feed                            }
    nul = #00; { Null char - used to zero in fillchar }
    tab = #09; { Tab horizontal                       }

    big_len     =  255; { Maximum string length                 }
    name_len    =   12; { Maximum file name with volume info    }
    digit_width =    5; { DIGITS PER NUMBER                     }
    max_ln_num  = 9999; { MAX LINE NUMBER                       }
    max_nst_lev =    1; { Maximum nesting level                 }
    scrn_width  =   80; { Screen line width                     }
    out_width   =  132; { Out device line width                 }
    out_height  =   66; { Out device page height                }
    out_border  =    4; { White space on top and bottom of page }
    dot_max     =   70; { dot max per line                      }

  TYPE
    char_set      = SET OF Char;
    big_string    = String[big_len];
    file_name     = String[name_len];
    alpha         = String[1];

    nest_info     = ARRAY [0 .. max_nst_lev] OF { 0 is main file }
      RECORD
        cur_file  : file_name;
        cur_block : Integer;
        cur_byte  : Integer;
        cur_line  : big_string;
        in_file   : Text[2024]     { Specify 2K buffer size }
      END;

                         { Pointers to Reference Data }

    item_ref      = ^item;
    rsrv_ref      = ^rsrv;
    word_ref      = ^word;

                         { Reference Data Structures }

    item          =
      RECORD
        ln_num : 0 .. max_ln_num;
        next   : item_ref;
      END;
    rsrv          =
      RECORD
        bal   : -1 .. 1;
        left  : rsrv_ref;
        right : rsrv_ref;
        key   : alpha;
      END;
    word          =
      RECORD
        first : item_ref;
        last  : item_ref;
        left  : word_ref;
        right : word_ref;
        key   : alpha;
      END;

  VAR
    done       : Boolean;
    first_time : Boolean; { First time through program }

    comment_chars : char_set; { All the valid comment options   }
    com_delimit   : char_set; { Delimiting chars for comments   }
    com_opt_chars : char_set; { What options used for cross ref }
    delimiters    : char_set;
    ident_chars   : char_set;
    lower_letters : char_set;
    numbers       : char_set;
    hexdigits     : char_set;
    parse_chars   : char_set;
    start_ident   : char_set;
    upper_letters : char_set;

    ord_lwr_a : Integer;

    dit_cnt   : Integer;
    dot_cnt   : Integer;
    line_cnt  : Integer;
    page_cnt  : Integer;

    heap      : ^Integer; { Pointer for memory management }

    item_bytes : Integer; { Number of 16 bit words for an item    }
    rsrv_bytes : Integer; { Number of 16 bit words for a reserved }
    word_bytes : Integer; { Number of 16 bit words for a word     }

    word_max  : Integer; { Longest word length   }

    nest_lev  : Integer;   { Current nesting level }
    nesting   : nest_info; { Where at in what file }

    title    : big_string; { Heading of each page of listing }
    out_name : big_string; { Output file name                }

    out_file : Text[2024]; { Specify 2K buffer size }

    rsrv_root : rsrv_ref; { Reserved rsrv identifier root }
    rwrd_root : word_ref; { Reserved word identifier root }
    word_root : word_ref; { Word     word identifier root }

  FUNCTION lower_ch ( ch : Char ) : Char;

    BEGIN { lower_ch }
      IF ch IN upper_letters THEN
        ch := Chr (Ord (ch) + ord_lwr_a);
      lower_ch := ch
    END;  { lower_ch }

  PROCEDURE lower_str (     in_str  : big_string;
                        VAR out_str : big_string );

    VAR
      i : Integer;

    BEGIN { lower_str }
      out_str := in_str;
      FOR i := 1 TO Length (in_str) DO
        out_str[i] := lower_ch (in_str[i] );
    END;  { lower_str }

  PROCEDURE upper_str (     in_str  : big_string;
                        VAR out_str : big_string );

    VAR
      i : Integer;

    BEGIN { upper_str }
      out_str := in_str;
      FOR i := 1 TO Length (in_str) DO
        out_str[i] := upcase (in_str[i] );
    END;  { upper_str }

  FUNCTION min ( a, b : Integer ) : Integer;

    BEGIN { min }
      IF a < b THEN
        min := a
      ELSE
        min := b
    END;  { min }

  FUNCTION max ( a, b : Integer ) : Integer;

    BEGIN { max }
      IF a > b THEN
        max := a
      ELSE
        max := b
    END;  { max }

  PROCEDURE init_dot ( message : big_string );

    BEGIN { init_dot }
      WriteLn;
      Write (message:(scrn_width + Length (message) ) DIV 2);
      dit_cnt  := out_height;
      dot_cnt  := dot_max;
      line_cnt := 0;
      page_cnt := 0;
    END;  { init_dot }

  PROCEDURE term_dot;

    BEGIN { term_dot }
      WriteLn;
      WriteLn ('<', line_cnt:digit_width, '>');
    END;  { term_dot }

  PROCEDURE dot;

    BEGIN { dot }
      IF dot_cnt < dot_max THEN
        dot_cnt := dot_cnt + 1
      ELSE
        BEGIN
          dot_cnt := 1;
          WriteLn;
          Write ('<', line_cnt:digit_width, '>')
        END;
      line_cnt := line_cnt + 1;
      Write ('.')
    END;  { dot }

  PROCEDURE dit;

    BEGIN { dit }
      IF dit_cnt < out_height - out_border THEN
        dit_cnt := dit_cnt + 1
      ELSE
        BEGIN
          page_cnt := page_cnt + 1;
          Write (out_file, ff);
          WriteLn (out_file);
          WriteLn (out_file);
          WriteLn (out_file, title, 'Page':15, page_cnt:3);
          WriteLn (out_file);
          dit_cnt := out_border
        END
    END;  { dit }

  PROCEDURE show_avail;

    BEGIN { show_avail }
      WriteLn;
      WriteLn ('Memory Available   :', MemAvail:7);
    END;  { show_avail }

  PROCEDURE init_sys;

    PROCEDURE process_reserved_file;

      VAR
        s       : big_string;
        rebal   : Boolean;
        in_file : Text;

      PROCEDURE add_reserved (     id    : big_string;
                               VAR r     : rsrv_ref;
                               VAR rebal : Boolean );

        VAR
          r1 : rsrv_ref;
          r2 : rsrv_ref;

        PROCEDURE new_reserved ( VAR r : rsrv_ref );

                     { Allocate memory for reserved word }

          VAR
            valid : Integer;

          BEGIN { new_reserved }
            valid := rsrv_bytes + Length (id) + 1;
            GetMem (r, valid);
            IF (valid = 0) OR (MemAvail <= sys_slop) THEN
              BEGIN
                WriteLn;
                Write ('I''ve run out of internal memory. Program terminated.');
                done := True
              END;
          END;  { new_reserved }

        BEGIN { add_reserved }
          IF r = Nil THEN
            BEGIN
              new_reserved (r);
              IF NOT done THEN
                BEGIN
                  rebal := True; { Check for rebalancing }
                  WITH r^ DO
                    BEGIN
                      Move (id, key, Length (id) + 1);
                      left  := Nil;
                      right := Nil;
                      bal   := 0
                    END
                END
            END
          ELSE IF id = r^.key THEN
            rebal := False
          ELSE IF id < r^.key THEN
            BEGIN
              add_reserved (id, r^.left, rebal);
              IF rebal THEN
                CASE r^.bal OF
                  + 0 : r^.bal := - 1;
                  + 1 :
                    BEGIN
                      r^.bal := 0;
                      rebal  := False
                    END;
                  - 1 :
                    BEGIN
                      r1 := r^.left;
                      IF r1^.bal = - 1 THEN
                        BEGIN
                          r^.left   := r1^.right;
                          r1^.right := r;
                          r^.bal    := 0;
                          r         := r1
                        END
                      ELSE
                        BEGIN
                          r2        := r1^.right;
                          r1^.right := r2^.left;
                          r2^.left  := r1;
                          r^.left   := r2^.right;
                          r2^.right := r;
                          IF r2^.bal = - 1 THEN
                            r^.bal := + 1
                          ELSE
                            r^.bal := + 0;
                          IF r2^.bal = + 1 THEN
                            r1^.bal := - 1
                          ELSE
                            r1^.bal := + 0;
                          r := r2
                        END;
                      r^.bal := 0;
                      rebal  := False
                    END
                END
            END
          ELSE { id > r^.key }
            BEGIN
              add_reserved (id, r^.right, rebal);
              IF rebal THEN
                CASE r^.bal OF
                  + 0 : r^.bal := + 1;
                  - 1 :
                    BEGIN
                      r^.bal := 0;
                      rebal  := False
                    END;
                  + 1 :
                    BEGIN
                      r1 := r^.right;
                      IF r1^.bal = + 1 THEN
                        BEGIN
                          r^.right := r1^.left;
                          r1^.left := r;
                          r^.bal   := 0;
                          r        := r1
                        END
                      ELSE
                        BEGIN
                          r2        := r1^.left;
                          r1^.left  := r2^.right;
                          r2^.right := r1;
                          r^.right  := r2^.left;
                          r2^.left  := r;
                          IF r2^.bal = + 1 THEN
                            r^.bal := - 1
                          ELSE
                            r^.bal := + 0;
                          IF r2^.bal = - 1 THEN
                            r1^.bal := + 1
                          ELSE
                            r2^.bal := + 0;
                          r := r2
                        END;
                      r^.bal := 0;
                      rebal  := False
                    END
                END
            END
        END;  { add_reserved }

      BEGIN { process_reserved_file }
        init_dot ('Processing Reserved Word File');
        Assign (in_file, 'C:Resrv.Txt');
        {$I-}
        Reset (in_file);
        {$I+}
        IF IoResult <> 0 THEN
          BEGIN
            WriteLn;
            WriteLn ('Reserved Word File not found.');
            Halt
          END
        ELSE
          BEGIN
            WHILE NOT (Eof (in_file) OR done) DO
              BEGIN
                ReadLn (in_file, s);
                upper_str (s, s);
                dot;
                add_reserved (s, rsrv_root, rebal)
              END;
            term_dot
          END;
        Close (in_file)
      END;  { process_reserved_file }

    BEGIN { init_sys }
      done       := False;
      first_time := True;

      comment_chars :=
        ['A', 'B', 'C', 'I', 'K', 'P', 'R', 'T', 'U', 'V', 'W', 'X',
         'a', 'b', 'c', 'i', 'k', 'p', 'r', 't', 'u', 'v', 'w', 'x'];
      com_delimit   := ['+', '-', ',', ' '];
      com_opt_chars := ['I', 'P', 'T', 'i', 'p', 't'];
      delimiters    :=
        ['{', '}', '(', ')', '[', ']',
         '+', '-', '*', '/', '<', '>', '=',
         '.', ',', ':', ';', '^', ' ', '''', '#', '$'];  { 21 Apr 85 }
      lower_letters := ['a' .. 'z'];
      upper_letters := ['A' .. 'Z'];
      numbers       := ['0' .. '9'];
      hexdigits     := numbers + ['A' .. 'F', 'a' .. 'f'];
      start_ident   := lower_letters + upper_letters ;
      ident_chars   := start_ident + numbers + ['_'];
      parse_chars   := ident_chars + delimiters;

      ord_lwr_a := Ord ('a') - Ord ('A');

      item_bytes := SizeOf (item);
      rsrv_bytes := SizeOf (rsrv);
      word_bytes := SizeOf (word);

      rsrv_root := Nil;

      ClrScr;
      WriteLn (icr_name:(scrn_width + Length (icr_name) ) DIV 2,
        icr_version:scrn_width - (scrn_width + Length (icr_name) ) DIV 2);
      show_avail;
      process_reserved_file;
    END;  { init_sys }

  PROCEDURE init;

    PROCEDURE open_files;

      LABEL
        exit;

      VAR
        io_error : Integer;
        f_name   : big_string;

      BEGIN { open_files }
        WriteLn;
        Write ('Process what file ? ');
        ReadLn (f_name);
        IF Length (f_name) = 0 THEN
          BEGIN
            done := True;
            Goto exit
          END;
        upper_str (f_name, f_name);
        IF (Pos ('.PAS', f_name) = 0) AND (Pos ('.', f_name) = 0) THEN
          f_name := Concat (f_name, '.PAS');
        WITH nesting[nest_lev] DO
          BEGIN
            Close (in_file);
            {$I-}
            Assign (in_file, f_name);
            Reset (in_file);
            {$I+}
          END;
        io_error := IoResult;
        IF io_error = 0 THEN
          nesting[nest_lev].cur_file := f_name
        ELSE
          BEGIN
            WriteLn;
            Write ('Unable to open ', f_name, ' due to I/O error #', io_error);
            done := True;
            Goto exit
          END;
        WriteLn;
        Write ('To      what file ? ');
        ReadLn (f_name);
        IF Length (f_name) = 0 THEN
          BEGIN
            done := True;
            Goto exit
          END;
        upper_str (f_name, f_name);
        IF (Pos ('.LST', f_name) = 0) AND (Pos ('.', f_name) = 0) THEN
          f_name := Concat (f_name, '.LST');
        out_name := Concat (Copy (f_name, 1, Pos ('.', f_name) ), 'REF');
        {$I-}
        Assign (out_file, f_name);
        Rewrite (out_file);
        {$I+}
        io_error := IoResult;
        IF io_error <> 0 THEN
          BEGIN
            WriteLn;
            Write ('Unable to open ', f_name, ' due to I/O error #', io_error);
            done := True
          END;
        exit:
      END;  { open_files }

    BEGIN { init }
      word_max  := 0;

      rwrd_root := Nil;
      word_root := Nil;

      nest_lev := 0;
      FillChar (nesting, SizeOf (nesting), nul);

      IF first_time THEN
        first_time := NOT first_time
      ELSE
        BEGIN
          WriteLn;
          WriteLn;
          WriteLn (icr_name:(scrn_width + Length (icr_name) ) DIV 2,
            icr_version:scrn_width - (scrn_width + Length (icr_name) ) DIV 2)
        END;
      open_files;
      IF NOT done THEN
        BEGIN
          WriteLn;
          Write ('Title : ');
          ReadLn (title);
          show_avail
        END;
    END;  { init }

  PROCEDURE cross_reference;

    VAR
      end_file : Boolean;
      end_line : Boolean;

      was_proc   : Boolean;

      i : Integer;

      in_line  : big_string;

    FUNCTION is_reserved ( id : big_string;
                           r  : rsrv_ref ) : Boolean;

      VAR
        found : Boolean;

      BEGIN { is_reserved }
        upper_str (id, id);
        found := False;
        WHILE NOT found AND (r <> Nil) DO
          IF      id < r^.key THEN
            r := r^.left
          ELSE IF id > r^.key THEN
            r := r^.right
          ELSE
            found := True;
        IF found THEN
          IF (id = 'FUNCTION') OR (id = 'PROCEDURE') OR (id = 'PROGRAM') THEN
            was_proc := True;
        is_reserved := found
      END;  { is_reserved }

    PROCEDURE fix_nest;

      BEGIN { fix_nest }
        i := 1;
        WITH nesting[nest_lev] DO
          BEGIN
            in_line  := in_line + ' ' + cur_line;
            end_line := i >= Length (in_line)
          END
      END;  { fix_nest }

    PROCEDURE set_nest;

      BEGIN { set_nest }
        WITH nesting[nest_lev] DO
          cur_line := Copy (in_line, i, Length (in_line) - i + 1)
      END;  { set_nest }

    PROCEDURE get_line;

      PROCEDURE put_line;

        PROCEDURE fix_tabs;

          CONST
            tab_spaces : String[8] = '        ';

          VAR
            x : Integer;
            l : big_string;

          BEGIN { fix_tabs }
            l       := in_line;
            in_line := '';
            FOR x := 1 TO Length (l) DO
              IF l[x] = tab THEN
                in_line := in_line + Copy (tab_spaces, 1, 8 - (x - 1) MOD 8)
              ELSE
                in_line := in_line + l[x]
          END;  { fix_tabs }

        BEGIN { put_line }
          IF Pos (tab, in_line) > 0 THEN
            fix_tabs;
          dit;
          Write (out_file, line_cnt:digit_width, ':');
          IF Length (in_line) > 0 THEN
            Write (out_file, ' ', in_line);
          WriteLn (out_file)
        END;  { put_line }

      BEGIN { get_line }
        i := 1;
        WITH nesting[nest_lev] DO
          BEGIN
            REPEAT
              ReadLn (in_file, in_line);
              dot;
              put_line;
              end_line := Length (in_line) = 0;
            UNTIL NOT end_line OR Eof (in_file);
            IF Eof (in_file) THEN
              IF nest_lev = 0 THEN
                end_file := True
              ELSE
                BEGIN
                  IF Length (in_line) > 0 THEN
                    BEGIN
                      WriteLn (out_file);
                      dit
                    END;
                  WriteLn (out_file, '*** End of include file ', cur_file:name_len);
                  dit;
                  WriteLn;
                  Write ('*** End of include file ', cur_file:name_len);
                  dot_cnt := dot_max;
                  Close (in_file);
                  nest_lev := nest_lev - 1;
                  fix_nest
                END
          END
      END;  { get_line }

    FUNCTION cur_ch : Char;

      BEGIN { cur_ch }
        cur_ch := in_line[i]
      END;  { cur_ch }

    FUNCTION next_ch : Char;

      BEGIN { next_ch }
        IF i + 1 > Length (in_line) THEN
          next_ch := cr
        ELSE
          next_ch := in_line[i + 1]
      END;  { next_ch }

    FUNCTION next2_ch : Char; { 22 Apr 85 }

      BEGIN { next2_ch }
        IF i + 2 > Length (in_line) THEN
          next2_ch := cr
        ELSE
          next2_ch := in_line[i + 2]
      END;  { next2_ch }

    PROCEDURE get_ch;

      BEGIN { get_ch }
        IF i < Length (in_line) THEN
          i := i + 1
        ELSE
          end_line := True
      END;  { get_ch }

    PROCEDURE get_identifier;

      VAR
        loc : Integer;
        id  : big_string;

      PROCEDURE bomb;

        BEGIN { bomb }
          term_dot;
          WriteLn;
          WriteLn ('I''ve run out of internal memory.',
            ' Identifier Cross Referencing prematurely terminated.');
          show_avail;
          done := True
        END;  { bomb }

      PROCEDURE add_identifier (     id : big_string;
                                 VAR wd : word_ref );

        VAR
          ir : item_ref;
          wr : word_ref;

        PROCEDURE new_identifier ( VAR w : word_ref );

                          { Allocate memory for word }

          VAR
            valid : Integer;

          BEGIN { new_identifier }
            valid := word_bytes + Length (id) + 1;
            GetMem (w, valid);
            IF (valid = 0) OR (MemAvail <= sys_slop) THEN
              bomb;
          END;  { new_identifier }

        BEGIN { add_identifier }
          wr := wd;
          IF wd <> Nil THEN
            IF      id < wd^.key THEN
              add_identifier (id, wd^.left)
            ELSE IF id > wd^.key THEN
              add_identifier (id, wd^.right)
            ELSE { id = wd^.key }
              BEGIN
                New (ir);
                ir^.ln_num       := line_cnt;
                ir^.next         := Nil;
                wr^.last^.next   := ir;
                wr^.last         := ir
              END
          ELSE { wd = Nil }
            BEGIN
              new_identifier (wr);
              New (ir);
              WITH wr^ DO
                BEGIN
                  word_max := max (Length (id), word_max);
                  Move (id, key, Length (id) + 1);
                  left  := Nil;
                  right := Nil;
                  first := ir;
                  last  := ir
                END;
              ir^.ln_num := line_cnt;
              ir^.next   := Nil;
              wd         := wr
            END
        END;  { add_identifier }

      BEGIN { get_identifier }
        loc := i;
        WHILE next_ch IN ident_chars DO
          get_ch;
        id := Copy (in_line, loc, i - loc + 1);
        IF NOT is_reserved (id, rsrv_root) THEN
          BEGIN
            add_identifier (id, word_root);
            IF was_proc THEN
              BEGIN
                was_proc := False;
                WriteLn;
                Write (id);
                dot_cnt := dot_max
              END
          END
      END;  { get_identifier }

    PROCEDURE find_match ( pattern : big_string );

      BEGIN { find_match }
        get_ch;
        IF end_line THEN
          get_line
        ELSE
          BEGIN
            Delete (in_line, 1, i - 1);
            i := 1
          END;
        WHILE NOT end_file AND (Pos (pattern, in_line) < i) DO
          get_line;
        i := Pos (pattern, in_line) + Length (pattern) - 1
      END;  { find_match }

    PROCEDURE parse_comment ( pattern : big_string );

      VAR
        done : Boolean;
        j    : Integer;

      PROCEDURE get_com_str ( VAR s       : big_string;
                                  max_len : Integer );

        VAR
          k : Integer;

        BEGIN { get_com_str }
          k := 0;
          WHILE (cur_ch <> ' ') AND (next_ch <> pattern[1] ) DO
            get_ch;
          WHILE cur_ch = ' ' DO
            get_ch;
          WHILE NOT end_line AND (cur_ch <> pattern[1] ) AND (k < max_len) DO
            BEGIN
              k    := k + 1;
              s[k] := cur_ch;
              get_ch
            END;
          s[0] := Chr (k);
        END;  { get_com_str }

      PROCEDURE do_page;

        BEGIN { do_page }
          Write (out_file, ff);
          dit_cnt := out_height
        END;  { do_page }

      PROCEDURE do_find;

        BEGIN { do_find }
          i := i - 1;
          find_match (pattern);
          done := True
        END;  { do_find }

      PROCEDURE get_include_file;

        LABEL
          leave_include;

        VAR
          io_error : Integer;
          f_name   : big_string;
          t_file   : Text;

        BEGIN { get_include_file }
          get_com_str (f_name, name_len);
          IF Length (f_name) > 0 THEN
            BEGIN
              set_nest;
              dit;
              WriteLn (out_file);
              dit;
              WriteLn (out_file, '*** Including text from ', f_name);
              WriteLn;
              Write ('*** Including text from ', f_name);
              dot_cnt := dot_max;
              IF nest_lev >= max_nst_lev THEN
                BEGIN
                  WriteLn (out_file, '*** Unable to include files beyond ',
                    max_nst_lev, ' levels.');
                  dit;
                  WriteLn;
                  Write ('*** Unable to nest include files beyond ',
                    max_nst_lev, ' levels.');
                  Goto leave_include
                END
              ELSE
                BEGIN
                  {$I-}
                  Assign (t_file, f_name);
                  Reset (t_file);
                  {$I+}
                  io_error := IoResult;
                  Close (t_file);
                  IF io_error <> 0 THEN
                    BEGIN
                      WriteLn (out_file, '*** Unable to open include file due to I/O error #', io_error);
                      dit;
                      WriteLn;
                      Write ('*** Unable to open include file ', f_name:name_len,
                        ' due to I/O error #', io_error)
                    END
                  ELSE
                    BEGIN
                      nest_lev := nest_lev + 1;
                      WITH nesting[nest_lev] DO
                        BEGIN
                          cur_file := f_name;
                          {$I-}
                          Assign (in_file, cur_file);
                          Reset (in_file);
                          {$I+}
                        END
                    END
                END
            END;
          leave_include:
        END;  { get_include_file }

      BEGIN { parse_comment }
        done := False;
        FOR j := 1 TO Length (pattern) + 1 DO
          get_ch;
        REPEAT
          IF end_line THEN
            get_line;
          IF NOT (cur_ch IN comment_chars + com_delimit) THEN
            do_find
          ELSE IF NOT (cur_ch IN com_opt_chars) THEN { cur_ch IN comment_chars + com_delimit }
            IF next_ch IN com_delimit THEN
              WHILE next_ch IN com_delimit DO
                get_ch
            ELSE
              do_find
          ELSE IF NOT (next_ch IN ['-', '+'] ) THEN { cur_ch IN com_opt_chars }
            BEGIN
              CASE upcase (cur_ch) OF
                'I' : get_include_file;
                'P' : do_page;
                'T' : get_com_str (title, scrn_width);
              END;
              IF UpCase (cur_ch) <> 'P' THEN
                do_find
            END
          ELSE { Switch option: next_ch IN ['-', '+'] }
            get_ch
        UNTIL done
      END;  { parse_comment }

    BEGIN { cross_reference }
      end_file := False;
      end_line := False;

      was_proc   := False;

      init_dot ('Cross Referencing File');
      WHILE NOT (end_file OR done) DO
        BEGIN
          get_line;
          WHILE NOT (end_line OR done) DO
            BEGIN
              IF      NOT (cur_ch IN parse_chars) THEN
                BEGIN
                  term_dot;
                  WriteLn;
                  Write ('Invalid character in text ');
                  IF cur_ch IN [' ' .. '~'] + [#128 .. #254] THEN
                    WriteLn ('"', cur_ch, '"')
                  ELSE
                    WriteLn ('(', Ord (cur_ch), ')');
                  done := True
                END
              ELSE IF cur_ch IN start_ident THEN
                get_identifier
              ELSE IF cur_ch = '{' THEN
                IF next_ch IN ['#', '$'] THEN
                  parse_comment ('}')
                ELSE
                  find_match ('}')
              ELSE IF (cur_ch = '(') AND (next_ch = '*') THEN
                IF next2_ch IN ['#', '$'] THEN
                  parse_comment ('*)')
                ELSE
                  find_match ('*)')
              ELSE IF cur_ch = '''' THEN
                find_match ('''')
              ELSE IF cur_ch IN numbers + ['$', '#'] THEN { Numbers, Hexidecimal, Chars ASCII value }
                WHILE next_ch IN hexdigits + ['$'] DO
                  get_ch
              ELSE IF (cur_ch = '^') AND (next_ch IN start_ident) AND
                      NOT (next2_ch IN ident_chars) { 28 Jun 85 } THEN { Control Chars }
                get_ch;
              get_ch
            END
        END;
      term_dot
    END;  { cross_reference }

  PROCEDURE term;

    VAR
      cnt      : Integer;
      digit_ln : Integer;
      num_ir   : Integer;
      num_wd   : Integer;
      io_error : Integer;

    PROCEDURE print_tree ( w : word_ref );

      PROCEDURE print_word ( VAR w : word ); { MUST be a variable parameter! }

        VAR
          ir : item_ref;

        BEGIN { print_word }
          num_wd := num_wd + 1;
          Write (out_file, w.key, '':word_max - Length (w.key) );
          dot;
          cnt := 0;
          ir  := w.first;
          REPEAT
            IF cnt < digit_ln THEN
              cnt := cnt + 1
            ELSE
              BEGIN
                cnt := 1;
                dit;
                IF (dit_cnt = out_border) AND (page_cnt > 1) THEN { New page }
                  BEGIN
                    Write (out_file, w.key, '':word_max - Length (w.key),
                      ' (Continued from previous page)');
                    dit
                  END;
                WriteLn (out_file);
                Write (out_file, '':word_max)
              END;
            num_ir := num_ir + 1;
            Write (out_file, ir^.ln_num:digit_width);
            ir := ir^.next
          UNTIL ir = Nil;
          WriteLn (out_file);
          dit
        END;  { print_word }

      BEGIN { print_tree }
        IF w <> Nil THEN
          BEGIN
            print_tree (w^.left);
            print_word (w^);
            print_tree (w^.right)
          END
      END;  { print_tree }

    BEGIN { term }
      Close (out_file);
      {$I-}
      Assign (out_file, out_name);
      Rewrite (out_file);
      {$I+}
      io_error := IoResult;
      IF io_error <> 0 THEN
        BEGIN
          WriteLn;
          Write ('Unable to open ', out_name, ' due to I/O error #', io_error);
          Halt
        END;
      digit_ln := (out_width - word_max) DIV digit_width;
      init_dot ('Printing Cross Reference List');
      dit;
      WriteLn;
      num_ir := 0;
      num_wd := 0;
      print_tree (word_root);
      WriteLn (out_file);
      WriteLn (out_file, 'There were ', num_wd, ' identifiers',
        ' with ', num_ir, ' occurences.');
      Close (out_file);
      term_dot;
    END;  { term }

  BEGIN { ident_cross_ref }
    init_sys;
    WHILE NOT done DO
      BEGIN
        init;
        IF NOT done THEN
          BEGIN
            Mark (heap);
            cross_reference;
            term;
            Release (heap)
          END
      END
  END   { ident_cross_ref }.