home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / INFO / TURBOPAS / ID_REF.ZIP / ID-REF.PAS next >
Encoding:
Pascal/Delphi Source File  |  1985-12-28  |  31.1 KB  |  1,075 lines

  1. { Identifier Cross-referencer - Copyright 1985 Lodestar Computing, Inc. }
  2. {$R-,V-}
  3. PROGRAM ident_cross_ref;
  4.  
  5.   { MODIFICATIONS:
  6.  
  7.     28 Jun 85 - Dap - Corrected for Pointers verses Control Chars
  8.     05 Jun 85 - Dap - Corrected for hexidecimal numers
  9.     22 Apr 85 - Dap - Find Match corrected for length
  10.     21 Apr 85 - Dap - Corrected for Turbos use of '#' & '$' for numbers
  11.     20 Oct 84 - Dap - Modified to run under Turbo Pascal
  12.     12 Oct 84 - Dap - Rewrite of original Xiu_Ref
  13.       Which was a Cross-referencer that handled UCSD Include files & Units
  14.     1976      - Nw  - Pascal Cross-reference program
  15.       "Algorithms + Data Structures = Programs" by Niklaus Wirth
  16.         Copyright 1976 by Prentice-Hall, Inc.
  17.       See pages 206 - 8 program crossref
  18.   }
  19.  
  20.   CONST
  21.                               { Version Control }
  22.     icr_name    = 'Identifier Cross Referencer';
  23.     icr_version = '[2.2e] 28 Jun 85';
  24.  
  25.     forever     = False; { How long this thing would go }
  26.  
  27.     sys_slop    = 200; { Leave a little space for the system     }
  28.  
  29.     bs  = #08; { Back space                           }
  30.     cr  = #13; { Carriage return                      }
  31.     ff  = #12; { Form feed                            }
  32.     nul = #00; { Null char - used to zero in fillchar }
  33.     tab = #09; { Tab horizontal                       }
  34.  
  35.     big_len     =  255; { Maximum string length                 }
  36.     name_len    =   12; { Maximum file name with volume info    }
  37.     digit_width =    5; { DIGITS PER NUMBER                     }
  38.     max_ln_num  = 9999; { MAX LINE NUMBER                       }
  39.     max_nst_lev =    1; { Maximum nesting level                 }
  40.     scrn_width  =   80; { Screen line width                     }
  41.     out_width   =  132; { Out device line width                 }
  42.     out_height  =   66; { Out device page height                }
  43.     out_border  =    4; { White space on top and bottom of page }
  44.     dot_max     =   70; { dot max per line                      }
  45.  
  46.   TYPE
  47.     char_set      = SET OF Char;
  48.     big_string    = String[big_len];
  49.     file_name     = String[name_len];
  50.     alpha         = String[1];
  51.  
  52.     nest_info     = ARRAY [0 .. max_nst_lev] OF { 0 is main file }
  53.       RECORD
  54.         cur_file  : file_name;
  55.         cur_block : Integer;
  56.         cur_byte  : Integer;
  57.         cur_line  : big_string;
  58.         in_file   : Text[2024]     { Specify 2K buffer size }
  59.       END;
  60.  
  61.                          { Pointers to Reference Data }
  62.  
  63.     item_ref      = ^item;
  64.     rsrv_ref      = ^rsrv;
  65.     word_ref      = ^word;
  66.  
  67.                          { Reference Data Structures }
  68.  
  69.     item          =
  70.       RECORD
  71.         ln_num : 0 .. max_ln_num;
  72.         next   : item_ref;
  73.       END;
  74.     rsrv          =
  75.       RECORD
  76.         bal   : -1 .. 1;
  77.         left  : rsrv_ref;
  78.         right : rsrv_ref;
  79.         key   : alpha;
  80.       END;
  81.     word          =
  82.       RECORD
  83.         first : item_ref;
  84.         last  : item_ref;
  85.         left  : word_ref;
  86.         right : word_ref;
  87.         key   : alpha;
  88.       END;
  89.  
  90.   VAR
  91.     done       : Boolean;
  92.     first_time : Boolean; { First time through program }
  93.  
  94.     comment_chars : char_set; { All the valid comment options   }
  95.     com_delimit   : char_set; { Delimiting chars for comments   }
  96.     com_opt_chars : char_set; { What options used for cross ref }
  97.     delimiters    : char_set;
  98.     ident_chars   : char_set;
  99.     lower_letters : char_set;
  100.     numbers       : char_set;
  101.     hexdigits     : char_set;
  102.     parse_chars   : char_set;
  103.     start_ident   : char_set;
  104.     upper_letters : char_set;
  105.  
  106.     ord_lwr_a : Integer;
  107.     
  108.     dit_cnt   : Integer;
  109.     dot_cnt   : Integer;
  110.     line_cnt  : Integer;
  111.     page_cnt  : Integer;
  112.     
  113.     heap      : ^Integer; { Pointer for memory management }
  114.  
  115.     item_bytes : Integer; { Number of 16 bit words for an item    }
  116.     rsrv_bytes : Integer; { Number of 16 bit words for a reserved }
  117.     word_bytes : Integer; { Number of 16 bit words for a word     }
  118.  
  119.     word_max  : Integer; { Longest word length   }
  120.  
  121.     nest_lev  : Integer;   { Current nesting level }
  122.     nesting   : nest_info; { Where at in what file }
  123.  
  124.     title    : big_string; { Heading of each page of listing }
  125.     out_name : big_string; { Output file name                }
  126.  
  127.     out_file : Text[2024]; { Specify 2K buffer size }
  128.  
  129.     rsrv_root : rsrv_ref; { Reserved rsrv identifier root }
  130.     rwrd_root : word_ref; { Reserved word identifier root }
  131.     word_root : word_ref; { Word     word identifier root }
  132.  
  133.   FUNCTION lower_ch ( ch : Char ) : Char;
  134.  
  135.     BEGIN { lower_ch }
  136.       IF ch IN upper_letters THEN
  137.         ch := Chr (Ord (ch) + ord_lwr_a);
  138.       lower_ch := ch
  139.     END;  { lower_ch }
  140.  
  141.   PROCEDURE lower_str (     in_str  : big_string;
  142.                         VAR out_str : big_string );
  143.  
  144.     VAR
  145.       i : Integer;
  146.  
  147.     BEGIN { lower_str }
  148.       out_str := in_str;
  149.       FOR i := 1 TO Length (in_str) DO
  150.         out_str[i] := lower_ch (in_str[i] );
  151.     END;  { lower_str }
  152.  
  153.   PROCEDURE upper_str (     in_str  : big_string;
  154.                         VAR out_str : big_string );
  155.  
  156.     VAR
  157.       i : Integer;
  158.  
  159.     BEGIN { upper_str }
  160.       out_str := in_str;
  161.       FOR i := 1 TO Length (in_str) DO
  162.         out_str[i] := upcase (in_str[i] );
  163.     END;  { upper_str }
  164.  
  165.   FUNCTION min ( a, b : Integer ) : Integer;
  166.  
  167.     BEGIN { min }
  168.       IF a < b THEN
  169.         min := a
  170.       ELSE
  171.         min := b
  172.     END;  { min }
  173.  
  174.   FUNCTION max ( a, b : Integer ) : Integer;
  175.  
  176.     BEGIN { max }
  177.       IF a > b THEN
  178.         max := a
  179.       ELSE
  180.         max := b
  181.     END;  { max }
  182.  
  183.   PROCEDURE init_dot ( message : big_string );
  184.  
  185.  
  186.     BEGIN { init_dot }
  187.       WriteLn;
  188.       Write (message:(scrn_width + Length (message) ) DIV 2);
  189.       dit_cnt  := out_height;
  190.       dot_cnt  := dot_max;
  191.       line_cnt := 0;
  192.       page_cnt := 0;
  193.     END;  { init_dot }
  194.  
  195.   PROCEDURE term_dot;
  196.  
  197.     BEGIN { term_dot }
  198.       WriteLn;
  199.       WriteLn ('<', line_cnt:digit_width, '>');
  200.     END;  { term_dot }
  201.  
  202.   PROCEDURE dot;
  203.  
  204.     BEGIN { dot }
  205.       IF dot_cnt < dot_max THEN
  206.         dot_cnt := dot_cnt + 1
  207.       ELSE
  208.         BEGIN
  209.           dot_cnt := 1;
  210.           WriteLn;
  211.           Write ('<', line_cnt:digit_width, '>')
  212.         END;
  213.       line_cnt := line_cnt + 1;
  214.       Write ('.')
  215.     END;  { dot }
  216.  
  217.   PROCEDURE dit;
  218.  
  219.     BEGIN { dit }
  220.       IF dit_cnt < out_height - out_border THEN
  221.         dit_cnt := dit_cnt + 1
  222.       ELSE
  223.         BEGIN
  224.           page_cnt := page_cnt + 1;
  225.           Write (out_file, ff);
  226.           WriteLn (out_file);
  227.           WriteLn (out_file);
  228.           WriteLn (out_file, title, 'Page':15, page_cnt:3);
  229.           WriteLn (out_file);
  230.           dit_cnt := out_border
  231.         END
  232.     END;  { dit }
  233.  
  234.   PROCEDURE show_avail;
  235.  
  236.     BEGIN { show_avail }
  237.       WriteLn;
  238.       WriteLn ('Memory Available   :', MemAvail:7);
  239.     END;  { show_avail }
  240.  
  241.   PROCEDURE init_sys;
  242.  
  243.     PROCEDURE process_reserved_file;
  244.  
  245.       VAR
  246.         s       : big_string;
  247.         rebal   : Boolean;
  248.         in_file : Text;
  249.  
  250.       PROCEDURE add_reserved (     id    : big_string;
  251.                                VAR r     : rsrv_ref;
  252.                                VAR rebal : Boolean );
  253.  
  254.         VAR
  255.           r1 : rsrv_ref;
  256.           r2 : rsrv_ref;
  257.  
  258.         PROCEDURE new_reserved ( VAR r : rsrv_ref );
  259.  
  260.                      { Allocate memory for reserved word }
  261.  
  262.           VAR
  263.             valid : Integer;
  264.  
  265.           BEGIN { new_reserved }
  266.             valid := rsrv_bytes + Length (id) + 1;
  267.             GetMem (r, valid);
  268.             IF (valid = 0) OR (MemAvail <= sys_slop) THEN
  269.               BEGIN
  270.                 WriteLn;
  271.                 Write ('I''ve run out of internal memory. Program terminated.');
  272.                 done := True
  273.               END;
  274.           END;  { new_reserved }
  275.           
  276.         BEGIN { add_reserved }
  277.           IF r = Nil THEN
  278.             BEGIN
  279.               new_reserved (r);
  280.               IF NOT done THEN
  281.                 BEGIN
  282.                   rebal := True; { Check for rebalancing }
  283.                   WITH r^ DO
  284.                     BEGIN
  285.                       Move (id, key, Length (id) + 1);
  286.                       left  := Nil;
  287.                       right := Nil;
  288.                       bal   := 0
  289.                     END
  290.                 END
  291.             END
  292.           ELSE IF id = r^.key THEN
  293.             rebal := False
  294.           ELSE IF id < r^.key THEN
  295.             BEGIN
  296.               add_reserved (id, r^.left, rebal);
  297.               IF rebal THEN
  298.                 CASE r^.bal OF
  299.                   + 0 : r^.bal := - 1;
  300.                   + 1 :
  301.                     BEGIN
  302.                       r^.bal := 0;
  303.                       rebal  := False
  304.                     END;
  305.                   - 1 :
  306.                     BEGIN
  307.                       r1 := r^.left;
  308.                       IF r1^.bal = - 1 THEN
  309.                         BEGIN
  310.                           r^.left   := r1^.right;
  311.                           r1^.right := r;
  312.                           r^.bal    := 0;
  313.                           r         := r1
  314.                         END
  315.                       ELSE
  316.                         BEGIN
  317.                           r2        := r1^.right;
  318.                           r1^.right := r2^.left;
  319.                           r2^.left  := r1;
  320.                           r^.left   := r2^.right;
  321.                           r2^.right := r;
  322.                           IF r2^.bal = - 1 THEN
  323.                             r^.bal := + 1
  324.                           ELSE
  325.                             r^.bal := + 0;
  326.                           IF r2^.bal = + 1 THEN
  327.                             r1^.bal := - 1
  328.                           ELSE
  329.                             r1^.bal := + 0;
  330.                           r := r2
  331.                         END;
  332.                       r^.bal := 0;
  333.                       rebal  := False
  334.                     END
  335.                 END
  336.             END
  337.           ELSE { id > r^.key }
  338.             BEGIN
  339.               add_reserved (id, r^.right, rebal);
  340.               IF rebal THEN
  341.                 CASE r^.bal OF
  342.                   + 0 : r^.bal := + 1;
  343.                   - 1 :
  344.                     BEGIN
  345.                       r^.bal := 0;
  346.                       rebal  := False
  347.                     END;
  348.                   + 1 :
  349.                     BEGIN
  350.                       r1 := r^.right;
  351.                       IF r1^.bal = + 1 THEN
  352.                         BEGIN
  353.                           r^.right := r1^.left;
  354.                           r1^.left := r;
  355.                           r^.bal   := 0;
  356.                           r        := r1
  357.                         END
  358.                       ELSE
  359.                         BEGIN
  360.                           r2        := r1^.left;
  361.                           r1^.left  := r2^.right;
  362.                           r2^.right := r1;
  363.                           r^.right  := r2^.left;
  364.                           r2^.left  := r;
  365.                           IF r2^.bal = + 1 THEN
  366.                             r^.bal := - 1
  367.                           ELSE
  368.                             r^.bal := + 0;
  369.                           IF r2^.bal = - 1 THEN
  370.                             r1^.bal := + 1
  371.                           ELSE
  372.                             r2^.bal := + 0;
  373.                           r := r2
  374.                         END;
  375.                       r^.bal := 0;
  376.                       rebal  := False
  377.                     END
  378.                 END
  379.             END
  380.         END;  { add_reserved }
  381.  
  382.       BEGIN { process_reserved_file }
  383.         init_dot ('Processing Reserved Word File');
  384.         Assign (in_file, 'C:Resrv.Txt');
  385.         {$I-}
  386.         Reset (in_file);
  387.         {$I+}
  388.         IF IoResult <> 0 THEN
  389.           BEGIN
  390.             WriteLn;
  391.             WriteLn ('Reserved Word File not found.');
  392.             Halt
  393.           END
  394.         ELSE
  395.           BEGIN
  396.             WHILE NOT (Eof (in_file) OR done) DO
  397.               BEGIN
  398.                 ReadLn (in_file, s);
  399.                 upper_str (s, s);
  400.                 dot;
  401.                 add_reserved (s, rsrv_root, rebal)
  402.               END;
  403.             term_dot
  404.           END;
  405.         Close (in_file)
  406.       END;  { process_reserved_file }
  407.  
  408.     BEGIN { init_sys }
  409.       done       := False;
  410.       first_time := True;
  411.  
  412.       comment_chars :=
  413.         ['A', 'B', 'C', 'I', 'K', 'P', 'R', 'T', 'U', 'V', 'W', 'X',
  414.          'a', 'b', 'c', 'i', 'k', 'p', 'r', 't', 'u', 'v', 'w', 'x'];
  415.       com_delimit   := ['+', '-', ',', ' '];
  416.       com_opt_chars := ['I', 'P', 'T', 'i', 'p', 't'];
  417.       delimiters    :=
  418.         ['{', '}', '(', ')', '[', ']',
  419.          '+', '-', '*', '/', '<', '>', '=',
  420.          '.', ',', ':', ';', '^', ' ', '''', '#', '$'];  { 21 Apr 85 }
  421.       lower_letters := ['a' .. 'z'];
  422.       upper_letters := ['A' .. 'Z'];
  423.       numbers       := ['0' .. '9'];
  424.       hexdigits     := numbers + ['A' .. 'F', 'a' .. 'f'];
  425.       start_ident   := lower_letters + upper_letters ;
  426.       ident_chars   := start_ident + numbers + ['_'];
  427.       parse_chars   := ident_chars + delimiters;
  428.  
  429.       ord_lwr_a := Ord ('a') - Ord ('A');
  430.  
  431.       item_bytes := SizeOf (item);
  432.       rsrv_bytes := SizeOf (rsrv);
  433.       word_bytes := SizeOf (word);
  434.  
  435.       rsrv_root := Nil;
  436.       
  437.       ClrScr;
  438.       WriteLn (icr_name:(scrn_width + Length (icr_name) ) DIV 2,
  439.         icr_version:scrn_width - (scrn_width + Length (icr_name) ) DIV 2);
  440.       show_avail;
  441.       process_reserved_file;
  442.     END;  { init_sys }
  443.  
  444.   PROCEDURE init;
  445.  
  446.     PROCEDURE open_files;
  447.  
  448.       LABEL
  449.         exit;
  450.  
  451.       VAR
  452.         io_error : Integer;
  453.         f_name   : big_string;
  454.  
  455.       BEGIN { open_files }
  456.         WriteLn;
  457.         Write ('Process what file ? ');
  458.         ReadLn (f_name);
  459.         IF Length (f_name) = 0 THEN
  460.           BEGIN
  461.             done := True;
  462.             Goto exit
  463.           END;
  464.         upper_str (f_name, f_name);
  465.         IF (Pos ('.PAS', f_name) = 0) AND (Pos ('.', f_name) = 0) THEN
  466.           f_name := Concat (f_name, '.PAS');
  467.         WITH nesting[nest_lev] DO
  468.           BEGIN
  469.             Close (in_file);
  470.             {$I-}
  471.             Assign (in_file, f_name);
  472.             Reset (in_file);
  473.             {$I+}
  474.           END;
  475.         io_error := IoResult;
  476.         IF io_error = 0 THEN
  477.           nesting[nest_lev].cur_file := f_name
  478.         ELSE
  479.           BEGIN
  480.             WriteLn;
  481.             Write ('Unable to open ', f_name, ' due to I/O error #', io_error);
  482.             done := True;
  483.             Goto exit
  484.           END;
  485.         WriteLn;
  486.         Write ('To      what file ? ');
  487.         ReadLn (f_name);
  488.         IF Length (f_name) = 0 THEN
  489.           BEGIN
  490.             done := True;
  491.             Goto exit
  492.           END;
  493.         upper_str (f_name, f_name);
  494.         IF (Pos ('.LST', f_name) = 0) AND (Pos ('.', f_name) = 0) THEN
  495.           f_name := Concat (f_name, '.LST');
  496.         out_name := Concat (Copy (f_name, 1, Pos ('.', f_name) ), 'REF');
  497.         {$I-}
  498.         Assign (out_file, f_name);
  499.         Rewrite (out_file);
  500.         {$I+}
  501.         io_error := IoResult;
  502.         IF io_error <> 0 THEN
  503.           BEGIN
  504.             WriteLn;
  505.             Write ('Unable to open ', f_name, ' due to I/O error #', io_error);
  506.             done := True
  507.           END;
  508.         exit:
  509.       END;  { open_files }
  510.  
  511.     BEGIN { init }
  512.       word_max  := 0;
  513.  
  514.       rwrd_root := Nil;
  515.       word_root := Nil;
  516.  
  517.       nest_lev := 0;
  518.       FillChar (nesting, SizeOf (nesting), nul);
  519.       
  520.       IF first_time THEN
  521.         first_time := NOT first_time
  522.       ELSE
  523.         BEGIN
  524.           WriteLn;
  525.           WriteLn;
  526.           WriteLn (icr_name:(scrn_width + Length (icr_name) ) DIV 2,
  527.             icr_version:scrn_width - (scrn_width + Length (icr_name) ) DIV 2)
  528.         END;
  529.       open_files;
  530.       IF NOT done THEN
  531.         BEGIN
  532.           WriteLn;
  533.           Write ('Title : ');
  534.           ReadLn (title);
  535.           show_avail
  536.         END;
  537.     END;  { init }
  538.  
  539.   PROCEDURE cross_reference;
  540.  
  541.     VAR
  542.       end_file : Boolean;
  543.       end_line : Boolean;
  544.       
  545.       was_proc   : Boolean;
  546.       
  547.       i : Integer;
  548.       
  549.       in_line  : big_string;
  550.  
  551.     FUNCTION is_reserved ( id : big_string;
  552.                            r  : rsrv_ref ) : Boolean;
  553.  
  554.       VAR
  555.         found : Boolean;
  556.  
  557.       BEGIN { is_reserved }
  558.         upper_str (id, id);
  559.         found := False;
  560.         WHILE NOT found AND (r <> Nil) DO
  561.           IF      id < r^.key THEN
  562.             r := r^.left
  563.           ELSE IF id > r^.key THEN
  564.             r := r^.right
  565.           ELSE
  566.             found := True;
  567.         IF found THEN
  568.           IF (id = 'FUNCTION') OR (id = 'PROCEDURE') OR (id = 'PROGRAM') THEN
  569.             was_proc := True;
  570.         is_reserved := found
  571.       END;  { is_reserved }
  572.  
  573.     PROCEDURE fix_nest;
  574.  
  575.       BEGIN { fix_nest }
  576.         i := 1;
  577.         WITH nesting[nest_lev] DO
  578.           BEGIN
  579.             in_line  := in_line + ' ' + cur_line;
  580.             end_line := i >= Length (in_line)
  581.           END
  582.       END;  { fix_nest }
  583.  
  584.     PROCEDURE set_nest;
  585.  
  586.       BEGIN { set_nest }
  587.         WITH nesting[nest_lev] DO
  588.           cur_line := Copy (in_line, i, Length (in_line) - i + 1)
  589.       END;  { set_nest }
  590.  
  591.     PROCEDURE get_line;
  592.  
  593.       PROCEDURE put_line;
  594.  
  595.         PROCEDURE fix_tabs;
  596.  
  597.           CONST
  598.             tab_spaces : String[8] = '        ';
  599.  
  600.           VAR
  601.             x : Integer;
  602.             l : big_string;
  603.  
  604.           BEGIN { fix_tabs }
  605.             l       := in_line;
  606.             in_line := '';
  607.             FOR x := 1 TO Length (l) DO
  608.               IF l[x] = tab THEN
  609.                 in_line := in_line + Copy (tab_spaces, 1, 8 - (x - 1) MOD 8)
  610.               ELSE
  611.                 in_line := in_line + l[x]
  612.           END;  { fix_tabs }
  613.  
  614.         BEGIN { put_line }
  615.           IF Pos (tab, in_line) > 0 THEN
  616.             fix_tabs;
  617.           dit;
  618.           Write (out_file, line_cnt:digit_width, ':');
  619.           IF Length (in_line) > 0 THEN
  620.             Write (out_file, ' ', in_line);
  621.           WriteLn (out_file)
  622.         END;  { put_line }
  623.  
  624.       BEGIN { get_line }
  625.         i := 1;
  626.         WITH nesting[nest_lev] DO
  627.           BEGIN
  628.             REPEAT
  629.               ReadLn (in_file, in_line);
  630.               dot;
  631.               put_line;
  632.               end_line := Length (in_line) = 0;
  633.             UNTIL NOT end_line OR Eof (in_file);
  634.             IF Eof (in_file) THEN
  635.               IF nest_lev = 0 THEN
  636.                 end_file := True
  637.               ELSE
  638.                 BEGIN
  639.                   IF Length (in_line) > 0 THEN
  640.                     BEGIN
  641.                       WriteLn (out_file);
  642.                       dit
  643.                     END;
  644.                   WriteLn (out_file, '*** End of include file ', cur_file:name_len);
  645.                   dit;
  646.                   WriteLn;
  647.                   Write ('*** End of include file ', cur_file:name_len);
  648.                   dot_cnt := dot_max;
  649.                   Close (in_file);
  650.                   nest_lev := nest_lev - 1;
  651.                   fix_nest
  652.                 END
  653.           END
  654.       END;  { get_line }
  655.  
  656.     FUNCTION cur_ch : Char;
  657.  
  658.       BEGIN { cur_ch }
  659.         cur_ch := in_line[i]
  660.       END;  { cur_ch }
  661.       
  662.     FUNCTION next_ch : Char;
  663.       
  664.       BEGIN { next_ch }
  665.         IF i + 1 > Length (in_line) THEN
  666.           next_ch := cr
  667.         ELSE
  668.           next_ch := in_line[i + 1]
  669.       END;  { next_ch }
  670.  
  671.     FUNCTION next2_ch : Char; { 22 Apr 85 }
  672.  
  673.       BEGIN { next2_ch }
  674.         IF i + 2 > Length (in_line) THEN
  675.           next2_ch := cr
  676.         ELSE
  677.           next2_ch := in_line[i + 2]
  678.       END;  { next2_ch }
  679.  
  680.     PROCEDURE get_ch;
  681.  
  682.       BEGIN { get_ch }
  683.         IF i < Length (in_line) THEN
  684.           i := i + 1
  685.         ELSE
  686.           end_line := True
  687.       END;  { get_ch }
  688.  
  689.     PROCEDURE get_identifier;
  690.  
  691.       VAR
  692.         loc : Integer;
  693.         id  : big_string;
  694.  
  695.       PROCEDURE bomb;
  696.  
  697.         BEGIN { bomb }
  698.           term_dot;
  699.           WriteLn;
  700.           WriteLn ('I''ve run out of internal memory.',
  701.             ' Identifier Cross Referencing prematurely terminated.');
  702.           show_avail;
  703.           done := True
  704.         END;  { bomb }
  705.  
  706.       PROCEDURE add_identifier (     id : big_string;
  707.                                  VAR wd : word_ref );
  708.  
  709.         VAR
  710.           ir : item_ref;
  711.           wr : word_ref;
  712.  
  713.         PROCEDURE new_identifier ( VAR w : word_ref );
  714.  
  715.                           { Allocate memory for word }
  716.  
  717.           VAR
  718.             valid : Integer;
  719.  
  720.           BEGIN { new_identifier }
  721.             valid := word_bytes + Length (id) + 1;
  722.             GetMem (w, valid);
  723.             IF (valid = 0) OR (MemAvail <= sys_slop) THEN
  724.               bomb;
  725.           END;  { new_identifier }
  726.  
  727.         BEGIN { add_identifier }
  728.           wr := wd;
  729.           IF wd <> Nil THEN
  730.             IF      id < wd^.key THEN
  731.               add_identifier (id, wd^.left)
  732.             ELSE IF id > wd^.key THEN
  733.               add_identifier (id, wd^.right)
  734.             ELSE { id = wd^.key }
  735.               BEGIN
  736.                 New (ir);
  737.                 ir^.ln_num       := line_cnt;
  738.                 ir^.next         := Nil;
  739.                 wr^.last^.next   := ir;
  740.                 wr^.last         := ir
  741.               END
  742.           ELSE { wd = Nil }
  743.             BEGIN
  744.               new_identifier (wr);
  745.               New (ir);
  746.               WITH wr^ DO
  747.                 BEGIN
  748.                   word_max := max (Length (id), word_max);
  749.                   Move (id, key, Length (id) + 1);
  750.                   left  := Nil;
  751.                   right := Nil;
  752.                   first := ir;
  753.                   last  := ir
  754.                 END;
  755.               ir^.ln_num := line_cnt;
  756.               ir^.next   := Nil;
  757.               wd         := wr
  758.             END
  759.         END;  { add_identifier }
  760.  
  761.       BEGIN { get_identifier }
  762.         loc := i;
  763.         WHILE next_ch IN ident_chars DO
  764.           get_ch;
  765.         id := Copy (in_line, loc, i - loc + 1);
  766.         IF NOT is_reserved (id, rsrv_root) THEN
  767.           BEGIN
  768.             add_identifier (id, word_root);
  769.             IF was_proc THEN
  770.               BEGIN
  771.                 was_proc := False;
  772.                 WriteLn;
  773.                 Write (id);
  774.                 dot_cnt := dot_max
  775.               END
  776.           END
  777.       END;  { get_identifier }
  778.  
  779.     PROCEDURE find_match ( pattern : big_string );
  780.  
  781.       BEGIN { find_match }
  782.         get_ch;
  783.         IF end_line THEN
  784.           get_line
  785.         ELSE
  786.           BEGIN
  787.             Delete (in_line, 1, i - 1);
  788.             i := 1
  789.           END;
  790.         WHILE NOT end_file AND (Pos (pattern, in_line) < i) DO
  791.           get_line;
  792.         i := Pos (pattern, in_line) + Length (pattern) - 1
  793.       END;  { find_match }
  794.  
  795.     PROCEDURE parse_comment ( pattern : big_string );
  796.  
  797.       VAR
  798.         done : Boolean;
  799.         j    : Integer;
  800.  
  801.       PROCEDURE get_com_str ( VAR s       : big_string;
  802.                                   max_len : Integer );
  803.  
  804.         VAR
  805.           k : Integer;
  806.  
  807.         BEGIN { get_com_str }
  808.           k := 0;
  809.           WHILE (cur_ch <> ' ') AND (next_ch <> pattern[1] ) DO
  810.             get_ch;
  811.           WHILE cur_ch = ' ' DO
  812.             get_ch;
  813.           WHILE NOT end_line AND (cur_ch <> pattern[1] ) AND (k < max_len) DO
  814.             BEGIN
  815.               k    := k + 1;
  816.               s[k] := cur_ch;
  817.               get_ch
  818.             END;
  819.           s[0] := Chr (k);
  820.         END;  { get_com_str }
  821.  
  822.       PROCEDURE do_page;
  823.  
  824.         BEGIN { do_page }
  825.           Write (out_file, ff);
  826.           dit_cnt := out_height
  827.         END;  { do_page }
  828.  
  829.       PROCEDURE do_find;
  830.  
  831.         BEGIN { do_find }
  832.           i := i - 1;
  833.           find_match (pattern);
  834.           done := True
  835.         END;  { do_find }
  836.  
  837.       PROCEDURE get_include_file;
  838.  
  839.         LABEL
  840.           leave_include;
  841.  
  842.         VAR
  843.           io_error : Integer;
  844.           f_name   : big_string;
  845.           t_file   : Text;
  846.  
  847.         BEGIN { get_include_file }
  848.           get_com_str (f_name, name_len);
  849.           IF Length (f_name) > 0 THEN
  850.             BEGIN
  851.               set_nest;
  852.               dit;
  853.               WriteLn (out_file);
  854.               dit;
  855.               WriteLn (out_file, '*** Including text from ', f_name);
  856.               WriteLn;
  857.               Write ('*** Including text from ', f_name);
  858.               dot_cnt := dot_max;
  859.               IF nest_lev >= max_nst_lev THEN
  860.                 BEGIN
  861.                   WriteLn (out_file, '*** Unable to include files beyond ',
  862.                     max_nst_lev, ' levels.');
  863.                   dit;
  864.                   WriteLn;
  865.                   Write ('*** Unable to nest include files beyond ',
  866.                     max_nst_lev, ' levels.');
  867.                   Goto leave_include
  868.                 END
  869.               ELSE
  870.                 BEGIN
  871.                   {$I-}
  872.                   Assign (t_file, f_name);
  873.                   Reset (t_file);
  874.                   {$I+}
  875.                   io_error := IoResult;
  876.                   Close (t_file);
  877.                   IF io_error <> 0 THEN
  878.                     BEGIN
  879.                       WriteLn (out_file, '*** Unable to open include file due to I/O error #', io_error);
  880.                       dit;
  881.                       WriteLn;
  882.                       Write ('*** Unable to open include file ', f_name:name_len,
  883.                         ' due to I/O error #', io_error)
  884.                     END
  885.                   ELSE
  886.                     BEGIN
  887.                       nest_lev := nest_lev + 1;
  888.                       WITH nesting[nest_lev] DO
  889.                         BEGIN
  890.                           cur_file := f_name;
  891.                           {$I-}
  892.                           Assign (in_file, cur_file);
  893.                           Reset (in_file);
  894.                           {$I+}
  895.                         END
  896.                     END
  897.                 END
  898.             END;
  899.           leave_include:
  900.         END;  { get_include_file }
  901.  
  902.       BEGIN { parse_comment }
  903.         done := False;
  904.         FOR j := 1 TO Length (pattern) + 1 DO
  905.           get_ch;
  906.         REPEAT
  907.           IF end_line THEN
  908.             get_line;
  909.           IF NOT (cur_ch IN comment_chars + com_delimit) THEN
  910.             do_find
  911.           ELSE IF NOT (cur_ch IN com_opt_chars) THEN { cur_ch IN comment_chars + com_delimit }
  912.             IF next_ch IN com_delimit THEN
  913.               WHILE next_ch IN com_delimit DO
  914.                 get_ch
  915.             ELSE
  916.               do_find
  917.           ELSE IF NOT (next_ch IN ['-', '+'] ) THEN { cur_ch IN com_opt_chars }
  918.             BEGIN
  919.               CASE upcase (cur_ch) OF
  920.                 'I' : get_include_file;
  921.                 'P' : do_page;
  922.                 'T' : get_com_str (title, scrn_width);
  923.               END;
  924.               IF UpCase (cur_ch) <> 'P' THEN
  925.                 do_find
  926.             END
  927.           ELSE { Switch option: next_ch IN ['-', '+'] }
  928.             get_ch
  929.         UNTIL done
  930.       END;  { parse_comment }
  931.  
  932.     BEGIN { cross_reference }
  933.       end_file := False;
  934.       end_line := False;
  935.  
  936.       was_proc   := False;
  937.       
  938.       init_dot ('Cross Referencing File');
  939.       WHILE NOT (end_file OR done) DO
  940.         BEGIN
  941.           get_line;
  942.           WHILE NOT (end_line OR done) DO
  943.             BEGIN
  944.               IF      NOT (cur_ch IN parse_chars) THEN
  945.                 BEGIN
  946.                   term_dot;
  947.                   WriteLn;
  948.                   Write ('Invalid character in text ');
  949.                   IF cur_ch IN [' ' .. '~'] + [#128 .. #254] THEN
  950.                     WriteLn ('"', cur_ch, '"')
  951.                   ELSE
  952.                     WriteLn ('(', Ord (cur_ch), ')');
  953.                   done := True
  954.                 END
  955.               ELSE IF cur_ch IN start_ident THEN
  956.                 get_identifier
  957.               ELSE IF cur_ch = '{' THEN
  958.                 IF next_ch IN ['#', '$'] THEN
  959.                   parse_comment ('}')
  960.                 ELSE
  961.                   find_match ('}')
  962.               ELSE IF (cur_ch = '(') AND (next_ch = '*') THEN
  963.                 IF next2_ch IN ['#', '$'] THEN
  964.                   parse_comment ('*)')
  965.                 ELSE
  966.                   find_match ('*)')
  967.               ELSE IF cur_ch = '''' THEN
  968.                 find_match ('''')
  969.               ELSE IF cur_ch IN numbers + ['$', '#'] THEN { Numbers, Hexidecimal, Chars ASCII value }
  970.                 WHILE next_ch IN hexdigits + ['$'] DO
  971.                   get_ch
  972.               ELSE IF (cur_ch = '^') AND (next_ch IN start_ident) AND
  973.                       NOT (next2_ch IN ident_chars) { 28 Jun 85 } THEN { Control Chars }
  974.                 get_ch;
  975.               get_ch
  976.             END
  977.         END;
  978.       term_dot
  979.     END;  { cross_reference }
  980.  
  981.   PROCEDURE term;
  982.  
  983.     VAR
  984.       cnt      : Integer;
  985.       digit_ln : Integer;
  986.       num_ir   : Integer;
  987.       num_wd   : Integer;
  988.       io_error : Integer;
  989.  
  990.     PROCEDURE print_tree ( w : word_ref );
  991.  
  992.       PROCEDURE print_word ( VAR w : word ); { MUST be a variable parameter! }
  993.  
  994.         VAR
  995.           ir : item_ref;
  996.  
  997.         BEGIN { print_word }
  998.           num_wd := num_wd + 1;
  999.           Write (out_file, w.key, '':word_max - Length (w.key) );
  1000.           dot;
  1001.           cnt := 0;
  1002.           ir  := w.first;
  1003.           REPEAT
  1004.             IF cnt < digit_ln THEN
  1005.               cnt := cnt + 1
  1006.             ELSE
  1007.               BEGIN
  1008.                 cnt := 1;
  1009.                 dit;
  1010.                 IF (dit_cnt = out_border) AND (page_cnt > 1) THEN { New page }
  1011.                   BEGIN
  1012.                     Write (out_file, w.key, '':word_max - Length (w.key),
  1013.                       ' (Continued from previous page)');
  1014.                     dit
  1015.                   END;
  1016.                 WriteLn (out_file);
  1017.                 Write (out_file, '':word_max)
  1018.               END;
  1019.             num_ir := num_ir + 1;
  1020.             Write (out_file, ir^.ln_num:digit_width);
  1021.             ir := ir^.next
  1022.           UNTIL ir = Nil;
  1023.           WriteLn (out_file);
  1024.           dit
  1025.         END;  { print_word }
  1026.         
  1027.       BEGIN { print_tree }
  1028.         IF w <> Nil THEN
  1029.           BEGIN
  1030.             print_tree (w^.left);
  1031.             print_word (w^);
  1032.             print_tree (w^.right)
  1033.           END
  1034.       END;  { print_tree }
  1035.  
  1036.     BEGIN { term }
  1037.       Close (out_file);
  1038.       {$I-}
  1039.       Assign (out_file, out_name);
  1040.       Rewrite (out_file);
  1041.       {$I+}
  1042.       io_error := IoResult;
  1043.       IF io_error <> 0 THEN
  1044.         BEGIN
  1045.           WriteLn;
  1046.           Write ('Unable to open ', out_name, ' due to I/O error #', io_error);
  1047.           Halt
  1048.         END;
  1049.       digit_ln := (out_width - word_max) DIV digit_width;
  1050.       init_dot ('Printing Cross Reference List');
  1051.       dit;
  1052.       WriteLn;
  1053.       num_ir := 0;
  1054.       num_wd := 0;
  1055.       print_tree (word_root);
  1056.       WriteLn (out_file);
  1057.       WriteLn (out_file, 'There were ', num_wd, ' identifiers',
  1058.         ' with ', num_ir, ' occurences.');
  1059.       Close (out_file);
  1060.       term_dot;
  1061.     END;  { term }
  1062.  
  1063.   BEGIN { ident_cross_ref }
  1064.     init_sys;
  1065.     WHILE NOT done DO
  1066.       BEGIN
  1067.         init;
  1068.         IF NOT done THEN
  1069.           BEGIN
  1070.             Mark (heap);
  1071.             cross_reference;
  1072.             term;
  1073.             Release (heap)
  1074.           END
  1075.       END
  1076.   END   { ident_cross_ref }.