home *** CD-ROM | disk | FTP | other *** search
/ Oakland CPM Archive / oakcpm.iso / cpm / pascal-p / xrefc26.lbr / XREFC.PZS / XREFC.PAS
Encoding:
Pascal/Delphi Source File  |  1987-01-15  |  35.4 KB  |  960 lines
  1. PROGRAM xrefc(textfile, listfile, input, output);
  2. (* non-standard Pascal features used, see {} or $s- in col. 1 *)
  3. (* Created from "xref 2.3"                                    *)
  4. (* ---------------------------------------------------------- *)
  5. (*        CROSS-REFERENCE GENERATOR FOR C PROGRAMS            *)
  6. (* Versions exist for Pascal, C, 8080/z80/8086 Assy languages *)
  7. (* Execution time, (XREF) operating on own source code:       *)
  8. (* (30 Oct. 80)       with run-time checks  on        off     *)
  9. (*                                        ========  ========  *)
  10. (*   HP3000 - CPU time -                    39 sec.   33 sec. *)
  11. (*   RUNPCD 8080 interp, 518 ns. clock 16.4 min. 13.8 min.    *)
  12. (*   8080 Native, 518 ns clk, 17 Oct. 81   3.5 min.           *)
  13. (*                                                            *)
  14. (*  by C.B.Falconer, 680 Hartford Tpk,                        *)
  15. (*                   Hamden, Conn. 06517      (203) 281-1438  *)
  16. (*                                                            *)
  17. (* 30 Dec. 1986. Allowed for "" or <> include delimiters.     *)
  18. (*   2.6         Input via readstring facility PascalP 3.1.8  *)
  19. (*               No heap size report. Graceful heap o'flow.   *)
  20. (* 18 Mar. 1986. Expanded table to full C reserved set.       *)
  21. (*               Upper/lower case input distinguished.        *)
  22. (*               Copyright message emitted.                   *)
  23. (* 14 Jan. 1984. Using "c" flavor include commands. Follow is *)
  24. (*               controlled by parm 100 digit.                *)
  25. (* 31 Oct. 1983. Parm=100 (hundreds digit odd) causes all     *)
  26. (*               includes ($i'fname') to be tracked.          *)
  27. (* 17 Nov. 1982. "Full" xref ability. 1st crack at making     *)
  28. (*               useful with non-std WordStar text files.     *)
  29. (* 11 Nov. 1982. Added ability to cross-ref integer values.   *)
  30. (*               First provisions for heap overflow made.     *)
  31. (* 24 Oct. 1982. Segmented for maximum isolation.             *)
  32. (* 17 Oct. 1982. Overflow on 95% hash table use.  Final sort  *)
  33. (*               changed to quicksort.  Using std procs for   *)
  34. (*               dater, getparm, filename, lsri (intrinsics)  *)
  35. (*               Textfile close after reading complete.       *)
  36. (* 12 Jun. 1982. Added ability to restrict identifiers used   *)
  37. (*               to break up runs where heap space is         *)
  38. (*               insufficient for a single pass.              *)
  39. (* 12 Mar. 1982. Corrected table overflow detection.          *)
  40. (* 2 Nov., 1980. Revised to further reduce hashtable size.    *)
  41. (*               Only 2 include levels are now available.     *)
  42. (*               "magic" is optimized at 6 for systems where  *)
  43. (*               a heap assignment requires 2 words of over-  *)
  44. (*               head.  If no overhead, then 4 is optimum.    *)
  45. (*               This is based on cross-referancing the com-  *)
  46. (*               piler source code.  The overhead will be     *)
  47. (*               required when both systems handle dispose    *)
  48. (*               and mark/release simultaneously.             *)
  49. (* 30 Oct. 1980. Revised to use only text files and to        *)
  50. (*               suppress multiple listings of line-nos.      *)
  51. (*               Added output of heap usage, and changed      *)
  52. (*               const "magic" from 5 to 4 to minimize        *)
  53. (*               heap usage on the compiler source. Hash      *)
  54. (*                table size was reduced from 1499 to 1201    *)
  55. (* 30 Jul. 1980. Revised to use "getparm" and nest includes   *)
  56. (* 15 Feb. 1980. For genesis, see credits below.              *)
  57. (*                                                            *)
  58. (*  This program has been constructed to minimize heap use    *)
  59. (* and thus to allow large programs to be cross-referanced    *)
  60. (* In addition, provisions have been made for input from      *)
  61. (* variable record length ascii files, with leading line-     *)
  62. (* numbers (8 digit field on the HP3000) and use of the "DLE" *)
  63. (* indentation code at the start of lines.  The program will  *)
  64. (* follow a sequence of "INCLUDE" files.  If input data is    *)
  65. (* unnumbered, a numbered output listing is generated.        *)
  66. (*                                                            *)
  67. (* For comparison, on a large test source file,               *)
  68. (*  lines processed versus maxdata parameter are:             *)
  69. (*                                     (15 Feb. 80)           *)
  70. (*    maxdata       original       this version vs "magic"    *)
  71. (*    (hp3000)      version             3      4       5      *)
  72. (*    =======       =======         =====  =====   =====      *)
  73. (*       8000             0                          437      *)
  74. (*      10000           441          1277            898      *)
  75. (*      12000           910          1927           1738      *)
  76. (*      14000          1367          2295           2139      *)
  77. (*      16000          1867          3089           3059      *)
  78. (*      20000                                       4709      *)
  79. (*      30000          5675         >7000          >7000      *)
  80. (* The "maxdata" parameter, on the HP3000, specifies the max- *)
  81. (* imum data space, in 16 bit words, available. This includes *)
  82. (* any space used for system buffers, etc (about 4000 words)  *)
  83. (* The final result is capable of processing a file with in   *)
  84. (* excess of 11000 occurences of identifier refs.  The limit  *)
  85. (* has not been found, but is believed to be about 16000 to   *)
  86. (* 18000 references, with 12 char. identifiers.               *)
  87. (*                                                            *)
  88. (* The program is organized to facilitate changes of input    *)
  89. (* languages, basically by altering the input character set   *)
  90. (* and reserved words (in initialize), and the structure of   *)
  91. (* comments (in scaninput).  The "magic" parameter is usually *)
  92. (* 2 for assembly language (i.e. definition and reference is  *)
  93. (* most common), and 5 for Pascal. This heuristic appears to  *)
  94. (* minimize memory requirements.                              *)
  95. (*                                                            *)
  96. (* The program assumes the ASCII char. set in several places  *)
  97. (*                 W A R N I N G                              *)
  98. (* UPPER and lower case characters occur in the source.  On   *)
  99. (* an uppercase only printer the lower case characters will   *)
  100. (* be mapped into upper case.                                 *)
  101. (* ---------------------------------------------------------- *)
  102.  
  103. (* ---------------------------------------------------------- *)
  104. (*                                                            *)
  105. (* From "XREF"   -  Robert A Fraley, HP Labs  -   4 Oct 1978  *)
  106. (*                                                            *)
  107. (*   modified from a program by Bary Pollack, UBC, based on a *)
  108. (*   program by N. Wirth  7.5.74                              *)
  109. (*                                                            *)
  110. (*  constant p determines max number of identifiers.          *)
  111. (* ---------------------------------------------------------- *)
  112.  
  113.   (*  prime numbers for reference.  p must be prime.   *)
  114.   (* 53 211 307 401 503 601 701 809 907 1009 1103 1201 *)
  115.   (* 1301 1409 1499 1597 1699 1789 1889 1999 2099 2203 *)
  116.   (* 2309 2411 2609 2797 2999 3203 3413 3607 3803 4001 *)
  117.  
  118.   CONST
  119.     head        = 'XREFC (textfile, listfile, input, output) [parm]';
  120.     ver         = ' Ver. 2.6, 30 Dec. 86';
  121.     copyrite    = 'Copyright (c) 1980, 1986 by C.B. Falconer';
  122.     p           = 1699;    (* prime =  size of hashtable  *)
  123.     (* compiler contains approx. 1100 identifiers, so that *)
  124.     (* this should keep table utilization below 95%        *)
  125.     phash       = 13841;   (* constant FOR rehashing  *)
  126.     phash2      = 14153;   (* second rehashing constant *)
  127.     nkmax       = 38;      (* maximum  no. of keywords  *)
  128.  
  129.     debuga      = false;   (* for hashing debuggery *)
  130.     debugb      = false;   (* include mechanism *)
  131.     debugc      = false;
  132.     debugd      = false;   (* pack *)
  133.     debuge      = false;   (* unpack *)
  134.  
  135.     fnsize      = 28;      (* size of a filename, max *)
  136.  
  137.     alfalen     = 12;      (* max identifier length *)
  138.     pklen       = 9;       (* 8 bit words for packed alfa *)
  139.                            (* := 3*((alfalen+3) div 4) *)
  140.     pkmax       = 64;      (* # char (64 max) in packed char set *)
  141.     pkcharmax   = 63;      (* := pkmax -1 *)
  142.  
  143. (*$s-*)                     (* define limits of chars *)
  144.     nul         = (:0:);
  145.     tab         = (:9:);
  146.     cr          = (:13:);
  147.     rub         = (:127:);
  148. (*$s+*)
  149.  
  150.     magic       = 5;       (* control heap use, maximize space *)
  151.     (* optimum value depends on statistics of input file. 2 to 10 *)
  152.     (* for assembly, most common case is a label and 1 referance, *)
  153.     (* i.e. use 2; for Pascal the optimum appears to be about 5   *)
  154.  
  155.     (* numfield * perline + alfalen = output width required *)
  156.     perline     = 11;      (* occurences per line of listing *)
  157.     numfield    = 6;       (* size of line number list field *)
  158.  
  159.     (* for input system *)
  160.     linemax     = 100;     (* MAX CHARACTERS PER INPUT LINE *)
  161.     linmaxm2    = 98;      (* linemax-2 *)
  162.     numlgh      = 8;       (* length of line number field *)
  163.     indflag     = 16;      (* text indentation signal=dle *)
  164.     indbase     = ' ';     (* base for blank count *)
  165.     linetrunc   = 100;     (* truncate input lines here *)
  166.     maxinclude  = 2;       (* see also incl1txt etc below *)
  167.     heapmargin  = 256;     (* for graceful overflow *)
  168.  
  169.   TYPE
  170.     alfa        = PACKED ARRAY[1..alfalen] OF char;
  171.     pkalfa      = ARRAY[1..pklen] OF char;
  172.     ascii       = nul..rub;  (* the char. set used *)
  173.     index       = 0..p;
  174.     line        = PACKED ARRAY[1..linemax] OF char;
  175.  
  176.     keyptr      = ^listhdr;
  177.     listptr     = ^list;
  178.  
  179.     listhdr     = RECORD
  180.       id          : pkalfa;
  181.       last        : listptr;
  182.       END; (* listhdr *)
  183.  
  184.     list        = RECORD
  185.       linums      : ARRAY[1..magic] OF integer;
  186.       next        : listptr;
  187.       END; (* list *)
  188.  
  189.     pkval       = 0..pkcharmax;
  190.  
  191.     dltype      = PACKED ARRAY[1..15] OF char;     (* for dateline *)
  192.     fntyp       = PACKED ARRAY[1..fnsize] OF char; (* for filename *)
  193.  
  194.   VAR
  195.     n           : integer;      (* current line number  *)
  196.     i           : integer;      (* handy *)
  197.     totlines    : integer;      (* count of lines input *)
  198.  
  199.     idcount,
  200.     refcount    : integer;      (* frequency counters  *)
  201.     nc, nco     : integer;      (* number of collisions  *)
  202.  
  203.     a, blank    : alfa;         (* identifier buffer  *)
  204.     apk         : pkalfa;       (* packed id buffer *)
  205.  
  206.     hashtbl     : ARRAY[index] OF keyptr;     (* hash table  *)
  207.  
  208.     nk          : integer;      (* reserved words in table *)
  209.     rsdwd       : ARRAY[1..nkmax] OF pkalfa; (* reserved words *)
  210.  
  211.     letters,
  212.     digits,
  213.     alfamerics  : SET OF char;
  214.     chscale     : ARRAY[ascii] OF pkval;
  215.     chexpand    : ARRAY[pkval] OF char;
  216.  
  217.     (* for input buffering scheme *)
  218.     textfile,
  219.     incl1txt,
  220.     incl2txt    : text;
  221.     (* WARNING - number of files must agree with maxinclude *)
  222.     (*           and with code in "getline"                 *)
  223.     inclevel    : 0..maxinclude; (* 0 for master file *)
  224.     listfile    : text;
  225.     filebuff,
  226.     inbuff      : line;
  227.     chcnt       : integer;     (* character counter *)
  228.     ch          : char;        (* last character *)
  229.     numbered    : boolean;     (* front numbered source file*)
  230.     linelen,                   (* current source length *)
  231.     linewidth   : integer;     (* source line width *)
  232.     moretext,
  233.     eol         : boolean;     (* end of line/input flag *)
  234.     mustlist,                  (* to force source list *)
  235.     allowlist   : boolean;     (* to suppress listings *)
  236.     firstchars  : SET OF char; (* if ids restricted *)
  237.     follow,                    (* all include files *)
  238.     full,                      (* xref all identifiers *)
  239.     numerics,                  (* xref numeric constants *)
  240.     restricted  : boolean;     (* to reduce identifiers *)
  241.                                (* accepted, when heap space *)
  242.                                (* is insufficient for full  *)
  243.                                (* xref.  Allows multiple    *)
  244.                                (* partial runs to complete  *)
  245.  
  246.   (* 1---------------1 *)
  247.  
  248. (*$s'outerblk'*)
  249.   PROCEDURE packword(a : alfa; VAR apk : pkalfa);
  250.   (* pack four chars into 3 bytes, preserve lex. order *)
  251.  
  252.     VAR
  253.       i, j, k, l : integer;
  254.  
  255.     BEGIN (* packword *)
  256.     k := 0; i := 0; l := 0;
  257.     IF debugd THEN writeln(a);
  258.     FOR j := 1 TO alfalen DO BEGIN
  259.       k := lsl(k, 6) + chscale[a[j]];         (* insert 6 bits *)
  260.       IF l <> 0 THEN BEGIN
  261.         i := succ(i);               (* pick off the top 8 bits *)
  262.         apk[i] := chr(mask(lsr(k, 6 - l), 255)); END;
  263.       l := succ(succ(l));
  264.       IF l = 8 THEN l := 0; END;
  265.     IF debugd THEN BEGIN
  266.       FOR j := 1 TO pklen DO write(ord(apk[j]) : 4);
  267.       writeln; END;
  268.     END; (* packword *)
  269.  
  270.   (* 1---------------1 *)
  271.  
  272. (*$s'nonbusyseg'*)
  273.   PROCEDURE initialize;
  274.  
  275.     VAR
  276.       c   : char;
  277.       i   : integer;
  278.      dl   : dltype;    (* for dateline *)
  279.      fn   : fntyp;     (* for filename *)
  280.  
  281.     (* 2---------------2 *)
  282.  
  283.     PROCEDURE enterword(wd : alfa); (* into rsdwd table *)
  284.  
  285.       BEGIN (* enterword *)
  286.       packword(wd, apk);
  287.       nk := succ(nk); (* keep track of number entered *)
  288.       rsdwd[nk] := apk;
  289.       END; (* enterword *)
  290.  
  291.     (* 2---------------2 *)
  292.  
  293.     PROCEDURE setfirstchars;
  294.  
  295.       VAR
  296.         ch, ch1  : char;
  297.         i        : integer;
  298.         accept   : boolean;
  299.         theset   : SET OF char;
  300.  
  301.       (* 3---------------3 *)
  302.  
  303.       PROCEDURE readupshift(VAR c : char);
  304.  
  305.         BEGIN (* readupshift *)
  306.         readln(c);
  307.         IF c IN ['a'..'z'] THEN
  308.           c := chr(ord(c) - ord('a') + ord('A'));
  309.         END; (* readupshift *)
  310.  
  311.       (* 3---------------3 *)
  312.  
  313.       PROCEDURE downshift(VAR c : char);
  314.  
  315.         BEGIN (* downshift *)
  316.         c := chr(ord(c) + ord('a') - ord('A'));
  317.         END; (* downshift *)
  318.  
  319.       (* 3---------------3 *)
  320.  
  321.       BEGIN (* setfirstchars *)
  322.       REPEAT
  323.         prompt('Accept or reject ids with first chars (a/r)?');
  324.         readupshift(ch);
  325.       UNTIL ch in ['A', 'R'];
  326.       accept := ch = 'A';
  327.       REPEAT
  328.         write('First char. to ');
  329.         IF accept THEN prompt('accept ?')
  330.         ELSE prompt('reject ?');
  331.         readupshift(ch);
  332.       UNTIL ch IN ['A'..'Z'];
  333.       REPEAT
  334.         write('Last char. to ');
  335.         IF accept THEN prompt('accept ?')
  336.         ELSE prompt('reject ?');
  337.         readupshift(ch1);
  338.       UNTIL (ch1 IN [ch..'Z']);
  339.       theset := [ch..ch1];
  340.       downshift(ch); downshift(ch1);
  341.       theset := theset + [ch..ch1];
  342.       IF accept THEN firstchars := theset
  343.       ELSE firstchars := firstchars - theset;
  344.       END; (* setfirstchars *)
  345.  
  346.     (* 2---------------2 *)
  347.  
  348.     BEGIN (* initialize *)
  349.     writeln(head, ver);
  350.     writeln(copyrite);
  351.     IF getparm = 0 THEN BEGIN
  352.       write('Parm=2/4 to suppress/force source list, ');
  353.       writeln('else only un-numbered source listed');
  354.       writeln('Add 10 to restrict identifiers, 20 for numeric values');
  355.       writeln('Add 40 to include C reserved words');
  356.       writeln('Add 100 to follow all #include files'); END;
  357.     IF NOT exists(textfile) THEN BEGIN
  358.       writeln('no source file'); terminate; END;
  359.     rewrite(listfile); (* after opening textfile, protection *)
  360. {}  i := getparm MOD 10;
  361.     allowlist := NOT odd(i DIV 2); (* parm=2 to suppress *)
  362.     mustlist := allowlist AND odd(i DIV 4); (* 4 forces *)
  363. {}  i := (getparm DIV 10) MOD 10; firstchars := [nul..rub];
  364.     restricted := odd(i);
  365.     numerics   := odd(i DIV 2);
  366.     full       := odd(i DIV 4);
  367.     follow     := odd(getparm DIV 100);
  368.     (* hundreds digit up available for further expansion *)
  369.     IF restricted THEN setfirstchars;
  370.     eol := true; inclevel := 0;
  371.     ch := ' '; chcnt := 0; linelen := linemax;
  372.     linewidth := linetrunc; (* ignore input past this column *)
  373. {}  dater(dl); filename(textfile, fn);
  374.     writeln(listfile);
  375.     writeln(listfile, fn, '** CROSS-REFERENCE **', dl : 20);
  376.     writeln(listfile);
  377.     moretext := NOT eof(textfile);
  378.     n := 0; idcount := 0; refcount := 0; nc := 0; nco := 0;
  379.     totlines := 0;
  380.  
  381.     FOR i := 0 TO p DO hashtbl[i] := NIL;
  382.  
  383.     FOR i := 1 TO alfalen DO blank[i] := ' ';
  384.  
  385.     (* this controls the character set in identifiers *)
  386.     (* W A R N I N G  depends on contiguous alpha character set *)
  387.     digits := ['0'..'9']; letters := ['A'..'Z', 'a'..'z', '_'];
  388.     alfamerics := letters + digits;
  389.  
  390.     (* this controls the apparent character ordering *)
  391.     (* W A R N I N G  depends on contiguous alpha character set *)
  392.     FOR c := nul TO rub DO chscale[c] := 0;
  393.     chexpand[0] := ' ';
  394.     FOR c := '0' TO '9' DO BEGIN
  395.       chscale[c] := ord(c) - ord('0') + 1;
  396.       chexpand[chscale[c]] := c; END;
  397. {}  FOR c := 'A' TO 'Z' DO BEGIN
  398.       chscale[c] := 2*(ord(c) - ord('A')) + 11;
  399.       chexpand[chscale[c]] := c; END;
  400. {}  FOR c := 'a' TO 'z' DO BEGIN (* lower case *)
  401.       chscale[c] := 2*(ord(c) - ord('a')) + 12;
  402.       chexpand[chscale[c]] := c; END;
  403.     chscale['_'] := 63; chexpand[63] := '_';
  404.  
  405.     (* must modify length if alfalen changed *)
  406.     nk := 0; (* allows easy reserved word list modification *)
  407.     enterword('auto        ');  (* alphabetical order *)
  408.     enterword('break       ');
  409.     enterword('case        ');
  410.     enterword('char        ');
  411.     enterword('continue    ');
  412.     enterword('default     ');
  413.     enterword('do          ');
  414.     enterword('double      ');
  415.     enterword('else        ');
  416.     enterword('entry       ');
  417.     enterword('extern      ');
  418.     enterword('float       ');
  419.     enterword('for         ');
  420.     enterword('goto        ');
  421.     enterword('if          ');
  422.     enterword('int         ');
  423.     enterword('long        ');
  424.     enterword('register    ');
  425.     enterword('return      ');
  426.     enterword('short       ');
  427.     enterword('sizeof      ');
  428.     enterword('static      ');
  429.     enterword('struct      ');
  430.     enterword('switch      ');
  431.     enterword('typedef     ');
  432.     enterword('union       ');
  433.     enterword('unsigned    ');
  434.     enterword('while       ');
  435.     END; (* initialize *)
  436.  
  437.   (* 1---------------1 *)
  438.  
  439. (*$s'phase2'*)
  440.   PROCEDURE printbl;
  441.  
  442.     VAR
  443.       i, j, m : index;
  444.       x,w     : keyptr;
  445.       junk    : boolean; (* unused *)
  446.       depth   : integer;
  447.  
  448.     (* 2---------------2 *)
  449.  
  450.     PROCEDURE printword(k : keyptr);
  451.  
  452.       VAR
  453.         i   : 0..magic;
  454.         l   : 0..perline;
  455.         x   : listptr;
  456.         a   : alfa;
  457.  
  458.       (* 3---------------3 *)
  459. {}
  460.       PROCEDURE unpackword(apk : pkalfa; VAR a : alfa);
  461.       (* unpack four characters from 3 bytes *)
  462.  
  463.         VAR
  464.           i, j, k, l :  integer;
  465.  
  466.         BEGIN (* unpackword *)
  467.         IF debuge THEN BEGIN
  468.           FOR i := 1 TO pklen DO write(ord(apk[i]) : 4);
  469.           writeln; END;
  470.         j := 0; k := 0; l := 0;
  471.         FOR i := 1 TO pklen DO BEGIN
  472.           k := k + ord(apk[i]);
  473.           j := succ(j); l := succ(succ(l));
  474.           a[j] := chexpand[mask(lsr(k, l), 63)];
  475.           IF l = 6 THEN BEGIN
  476.             j := succ(j); a[j] := chexpand[mask(k, 63)];
  477.             l := 0; k := 0; END;
  478.           k := lsl(k, 8); END;
  479.         IF debuge THEN writeln(a);
  480.         END; (* unpackword *)
  481.  
  482.       (* 3---------------3 *)
  483.  
  484.       BEGIN (* printword *)
  485.       unpackword(k^.id, a);
  486.       write(listfile, a);
  487.       x := k^.last; l := 0; i := magic;
  488.       REPEAT
  489.         IF i = magic THEN BEGIN
  490.           i := 1; x := x^.next; END
  491.         ELSE i := succ(i);
  492.         IF x^.linums[i] <> 0 THEN BEGIN
  493.           IF l = perline THEN BEGIN
  494.             l := 0; writeln(listfile);
  495.             write(listfile, ' ' : alfalen); END;
  496.           write(listfile, x^.linums[i] : numfield);
  497.           l := succ(l); END;
  498.       UNTIL (x = k^.last) AND (i = magic);
  499.       writeln(listfile)
  500.       END; (* printword *)
  501.  
  502.     (* 2---------------2 *)
  503.  
  504.     PROCEDURE sort(l, r : index);
  505.     (* Quicksort, almost directly from Wirth *)
  506.  
  507.       VAR
  508.         i, j     : integer; (* needs minindex-1..maxindex+1 *)
  509.  
  510.       BEGIN (* sort *)
  511.       IF debugc THEN BEGIN
  512.         depth := succ(depth);
  513.         writeln(' ' : depth, 'sort(', l : 1,', ', r : 1, ')'); END;
  514.       x := hashtbl[l]; i := l; j := r;
  515.       REPEAT
  516.         WHILE (x^.id > hashtbl[i]^.id) DO i := succ(i);
  517.         WHILE (hashtbl[j]^.id > x^.id) DO j := pred(j);
  518.         IF i <= j THEN BEGIN
  519.           w := hashtbl[i]; hashtbl[i] := hashtbl[j];
  520.           hashtbl[j] := w; i := succ(i); j := pred(j); END;
  521.       UNTIL i > j;
  522.       IF j - l < r - i THEN BEGIN
  523.         IF l < j THEN sort(l, j);
  524.         IF i < r THEN sort(i, r); END
  525.       ELSE BEGIN
  526.         IF i < r THEN sort(i, r);
  527.         IF l < j THEN sort(l, j); END;
  528.       IF debugc THEN depth := pred(depth);
  529.       END; (* sort *)
  530.  
  531.     (* 2---------------2 *)
  532.  
  533.     BEGIN (* printbl *)
  534.     m := pred(p); i := 0;
  535.     WHILE i <= m DO BEGIN (* coalesce table *)
  536.       IF hashtbl[i] = NIL THEN BEGIN
  537.         WHILE (hashtbl[m] = NIL) AND (m > i) DO m := pred(m);
  538.         hashtbl[i] := hashtbl[m];
  539.         IF m > 0 THEN m := pred(m); END;
  540.       i := succ(i); END;
  541.     (* now only indices 0..m are in use *)
  542.     depth := 0; sort(0, m);
  543.     FOR i := 0 TO m DO printword(hashtbl[i]);
  544.     END; (* printbl *)
  545.  
  546.   (* 1---------------1 *)
  547.  
  548. (*$s'phase1'*)
  549.   PROCEDURE scaninput;
  550.  
  551.     (* 2---------------2 *)
  552.  
  553.     PROCEDURE nextch;
  554.     (* Apart from dependence on the ASCII char set, this   *)
  555.     (* should be the only area requiring alteration for    *)
  556.     (* installation on other systems.  The following       *)
  557.     (* constructs may create problems:                     *)
  558.     (*     string[variable FOR constant] is a substring    *)
  559.     (*     reset(f,name) opens external file "name"        *)
  560.     (* Other constructs (i.e. $INCLUDE) are dependant on   *)
  561.     (* on system conventions, and must be customized.      *)
  562.     (*                                                     *)
  563.     (* returns the next character of source text in "ch".  *)
  564.     (* returns a blank for eol, and handles "INCLUDE" file *)
  565.     (* access.  Indentation codes (i.e. DLE n) are ignored *)
  566.     (* since they may only occur at the start of a line.   *)
  567.     (* If the file is un-numbered, each line is listed     *)
  568.     (* with the appropriate indentation.  "INCLUDE" files, *)
  569.     (* if un-numbered, cause the line number to advance to *)
  570.     (* the next multiple of 1000.  In addition, numbered   *)
  571.     (* input lines will ignore the fractional portion      *)
  572.     (* (to the HP3000 editor) of the line-number.  Thus    *)
  573.     (* line number 1234.5 will be cross referanced as line *)
  574.     (* 1234, etc.                                          *)
  575.  
  576.       LABEL 11;
  577.  
  578.       VAR
  579.         tabfound : boolean; (* readaline/writeline interface *)
  580.  
  581.       (* 3---------------3 *)
  582.  
  583.       PROCEDURE writeline;
  584.  
  585.         VAR
  586.           column, i : integer;
  587.           ch        : char;
  588.  
  589.         BEGIN (* writeline *)
  590.         IF mustlist OR (NOT numbered AND allowlist) THEN BEGIN
  591.           write(listfile, n : 5, ' ');
  592.           IF tabfound THEN BEGIN (* allow for source with tabs *)
  593.             i := 1; column := 0; (* current column *)
  594.             IF (linelen > 1) AND (inbuff[1] = chr(indflag)) THEN BEGIN
  595.               column := ord(inbuff[2]) - ord(indbase);
  596.               IF column > 0 THEN write(listfile, ' ' : column);
  597.               i := 3; END;
  598.             FOR i := i TO linelen DO BEGIN (* expanding tabs *)
  599.               ch := inbuff[i];
  600.               IF ch = tab THEN
  601.                 REPEAT (* ensure at least one space *)
  602.                   write(listfile, ' '); column := succ(column);
  603.                 UNTIL column MOD 8 = 0
  604.               ELSE BEGIN
  605.                 write(listfile, ch); column := succ(column); END;
  606.               END;
  607.             END
  608.           ELSE IF (linelen < 2) OR (inbuff[1] <> chr(indflag)) THEN
  609.             write(listfile, inbuff : linelen)
  610.           ELSE BEGIN (* indent *)
  611.             write(listfile, ' ' : (ord(inbuff[2]) - ord(indbase)));
  612.   (*$s-*)   write(listfile, inbuff[3 FOR linmaxm2] : linelen-2); END;
  613.   (*$s+*) writeln(listfile); END;
  614.         END; (* writeline *)
  615.  
  616.       (* 3---------------3 *)
  617.  
  618.       PROCEDURE getline;
  619.  
  620.         LABEL 1, 3;
  621.  
  622.         VAR
  623.           llen, i, j : integer;
  624.           eofincl    : boolean;
  625.  
  626.         (* 4---------------4 *)
  627.  
  628. (*$x+,d-,n- no runtime checks here *)
  629.         PROCEDURE numcheck;
  630.  
  631.           VAR
  632.             j : integer;
  633.  
  634.           BEGIN (* numcheck *)
  635.           j := 0;
  636.           IF llen < numlgh THEN numbered := false
  637.           ELSE
  638.             REPEAT
  639.               j := succ(j);
  640.               numbered := filebuff[j] IN digits;
  641.             UNTIL NOT numbered OR (j = numlgh);
  642.           IF numbered THEN BEGIN
  643.             n := 0; (* use input line number *)
  644.             FOR j := 1 to 5 DO
  645.               n := 10 * n + ord(filebuff[j]) - ord('0'); END
  646.           ELSE n := succ(n);
  647.           END; (* numcheck *)
  648.  
  649.         (* 4---------------4 *)
  650.  
  651.         PROCEDURE readaline(VAR f : text);
  652.  
  653.           VAR
  654.             ch     : char;
  655.  
  656.           BEGIN (* readaline *)
  657.           tabfound := false; (* so writeline knows about it *)
  658.           IF eof(f) THEN BEGIN
  659.             close(f); eofincl := true; END
  660.           ELSE BEGIN
  661.             eofincl := false;
  662.             readln(f, filebuff); llen := length(filebuff);
  663.             tabfound := scanfor(tab, filebuff, llen) > 0; END;
  664.           END; (* readaline *)
  665. (*$x- restore options *)
  666.  
  667.         (* 4---------------4 *)
  668.  
  669.         BEGIN (* getline *)
  670.    1:   llen := 0;
  671.         IF inclevel > 0 THEN BEGIN
  672.           IF inclevel = 1 THEN readaline(incl1txt)
  673.           ELSE readaline(incl2txt);
  674.           IF eofincl THEN BEGIN
  675.             IF debugb THEN BEGIN
  676.               writeln('exit include at line ', n : 0); END;
  677.             inclevel := pred(inclevel); GOTO 1; END;
  678.           END
  679.         ELSE IF eof(textfile) THEN GOTO 3
  680.         ELSE readaline(textfile);
  681.         numcheck; (* check FOR numbered FILE *)
  682.         totlines := succ(totlines); eol := false;
  683.         chcnt := 0; linelen := linewidth;
  684.         IF numbered THEN BEGIN
  685.           (* adjust parameters AND eol conditions *)
  686.           llen := llen - numlgh;
  687.           FOR i := 1 TO succ(llen) (* include eos mark *) DO
  688.             inbuff[i] := filebuff[i + numlgh]; END
  689.         ELSE inbuff := filebuff;
  690.         IF llen < linewidth THEN linelen := llen;
  691.         IF (inbuff[1] = '#') AND (linelen > 9) AND follow THEN BEGIN
  692.           IF inbuff[9] = tab THEN inbuff[9] := ' ';
  693. (*$s-*)   IF inbuff[1 FOR 9] = '#include ' THEN BEGIN
  694. (*$s+*)     writeline;
  695.             i := scanwhile(' ', inbuff[9], length(inbuff)-9) + 8;
  696.             IF debugb THEN writeln('"', inbuff[i], '"@', i : 1);
  697.             IF inbuff[i] IN ['"', '<'] THEN BEGIN (* strip delims *)
  698.               IF inbuff[i] = '"' THEN
  699.                 j := scanfor('"', inbuff[succ(i)], length(inbuff) - i)
  700.               ELSE
  701.                 j := scanfor('>', inbuff[succ(i)], length(inbuff) - i);
  702.               IF debugb THEN writeln('"', inbuff[i+j], '"@', i+j : 1);
  703.               IF j > 0 THEN inbuff[i+j] := nul; (* remark end of string *) 
  704.               i := succ(i); END;
  705.             IF inclevel = maxinclude THEN BEGIN
  706.               writeln('too many nested includes, line ', n : 1);
  707.               GOTO 1; END;
  708.             inclevel := succ(inclevel);
  709.             IF inclevel = 1 THEN BEGIN
  710. (*$s-*)       reset(incl1txt, inbuff[i FOR 30]);
  711. (*$s+*)       eofincl := eof(incl1txt); END
  712.             ELSE BEGIN
  713. (*$s-*)       reset(incl2txt, inbuff[i FOR 30]);
  714. (*$s+*)       eofincl := eof(incl2txt); END;
  715.             IF eofincl THEN BEGIN
  716.               inclevel := pred(inclevel); GOTO 1; END;
  717.             IF debugb THEN BEGIN
  718.               writeln('enter include at line ', n : 1); END;
  719.             GOTO 1; END;
  720.           END;
  721.         IF inbuff[1] = chr(indflag) THEN (* dle *)
  722.           chcnt := 2; (* bypass indentation *)
  723.    3:   END; (* getline *)
  724.  
  725.       (* 3---------------3 *)
  726.  
  727. (*$x+,d-,n- no run-time checks *)
  728.       BEGIN  (* nextch *)
  729.       IF eol THEN BEGIN
  730.         IF inclevel = 0 THEN (* avoid eof causing get *)
  731.           IF eof(textfile) THEN BEGIN
  732.             moretext := false; GOTO 11; END;
  733.         getline; writeline; END;
  734. 11:   ch := ' ';
  735.       IF moretext THEN
  736.         IF chcnt >= linelen THEN eol := true
  737.         ELSE BEGIN
  738.           chcnt := succ(chcnt);
  739.           ch := chr(mask(ord(inbuff[chcnt]), 127)); END;
  740.       END; (* nextch *)
  741.  
  742.     (* 2---------------2 *)
  743.  
  744.     FUNCTION notrsdwd(VAR x : pkalfa):  boolean;
  745.  
  746.       LABEL 1;
  747.  
  748.       VAR
  749.         i, j, k   : integer;
  750.  
  751.       BEGIN (* notrsdwd *)
  752.       IF NOT full THEN BEGIN
  753.         notrsdwd := false;
  754.         i := 1; j := nk;
  755.         REPEAT
  756.           k := (i+j) DIV 2;              (*  binary search  *)
  757.           IF (rsdwd[k] > x) THEN j := pred(k)
  758.           ELSE IF rsdwd[k] = x THEN GOTO 1
  759.           ELSE i := succ(k);
  760.         UNTIL i > j; END;
  761.       notrsdwd := true;
  762.   1:  END (* notrsdwd *) ;
  763. (*$x- restore options *)
  764.  
  765.     (* 2---------------2 *)
  766.  
  767.     PROCEDURE insert;              (*  linear quotient hash search  *)
  768.  
  769.       LABEL 1;
  770.  
  771.       VAR
  772.         d      : index;
  773.         i      : 0..magic;
  774.         found  : boolean;
  775.         h      : integer;
  776.         ct     : integer;
  777.         x      : listptr;
  778.         marg   : ARRAY[1..heapmargin] OF char;
  779.         (* allows remainder of system to execute *)
  780.  
  781.       (* 3---------------3 *)
  782.  
  783.       FUNCTION alloc(VAR x : listptr) : boolean;
  784.       (* returns true if successful new(x) executed *)
  785.  
  786.         BEGIN (* alloc *)
  787.         allocate(x); alloc := x <> NIL;
  788.         END; (* alloc *)
  789.  
  790.       (* 3---------------3 *)
  791.  
  792.       FUNCTION newrecord : boolean;
  793.  
  794.         VAR
  795.           i   : integer;
  796.  
  797.         BEGIN (* newrecord *)
  798.         IF alloc(x) THEN BEGIN
  799.           newrecord := true; hashtbl[h]^.last := x; x^.linums[1] := n;
  800.           x^.next := hashtbl[h]^.last;
  801.           FOR i := 2 TO magic DO
  802.             x^.linums[i] := 0; (* i.e. empty *) END
  803.         ELSE newrecord := false;
  804.         END; (* newrecord *)
  805.  
  806.       (* 3---------------3 *)
  807.  
  808. (*$s'outerblk'*)
  809.       PROCEDURE fullup(VAR f : text);
  810.  
  811.         BEGIN (* fullup *)
  812.         writeln(f);
  813.         writeln(f, '*** TABLE 95% FULL ***');
  814.         END; (* fullup *)
  815.  
  816.       (* 3---------------3 *)
  817.  
  818. (*$s'phase1'*)
  819.       BEGIN  (* insert *)
  820.       d := 0; (* flags not rehashing *)
  821. {}    h := abs(mergebytes(ord(apk[1]), ord(apk[2])) MOD phash +
  822.                mergebytes(ord(apk[3]), ord(apk[4])) MOD phash) MOD p;
  823.       found := false; refcount := succ(refcount); ct := nc;
  824.       REPEAT
  825.         IF hashtbl[h] = NIL THEN BEGIN (* new entry *)
  826.           new(hashtbl[h]); hashtbl[h]^.id := apk;
  827.           IF NOT newrecord THEN BEGIN (* quit on overflow *)
  828.             moretext := false; GOTO 1; END;
  829.           found := true; idcount := succ(idcount);
  830.           IF idcount >= p - p DIV 20 THEN BEGIN
  831.             (* > trunc(0.95 * p); avoids use of real pkg *)
  832.             (* hash algorithm very inefficient when full *)
  833.             fullup(output); fullup(listfile); moretext := false; END;
  834.           nco := nco + (nc-ct); END
  835.         ELSE IF hashtbl[h]^.id = apk THEN BEGIN (* found *)
  836.           WITH hashtbl[h]^ DO BEGIN
  837.             i := 0;
  838.             REPEAT  (* find an empty slot *)
  839.               i := succ(i);
  840.               IF last^.linums[i] = n THEN GOTO 1; (* already stored *)
  841.             UNTIL (i = magic) OR (last^.linums[i] = 0);
  842.             IF last^.linums[i] = 0 THEN (* room in this record *)
  843.               last^.linums[i] := n
  844.             ELSE (* a new record needed *)
  845.               IF alloc(x) THEN BEGIN
  846.                 x^.next := last^.next;
  847.                 last^.next := x; last := x;
  848.                 x^.linums[1] := n;
  849.                 FOR i := 2 TO magic DO
  850.                   x^.linums[i] := 0; (* i.e. empty *) END
  851.               ELSE BEGIN (* quit on overflow *)
  852.                 moretext := false; GOTO 1; END;
  853.             END; (* WITH hashtbl[h] *)
  854.           found := true; END (* idisequal *)
  855.         ELSE BEGIN (* collision *)
  856.           nc := succ(nc);
  857.           IF d = 0 THEN BEGIN (* first rehash *)
  858.             IF debuga THEN BEGIN
  859.               FOR i := 1 TO 6 DO write(ord(apk[i]) : 3);
  860.               writeln(a : succ(alfalen)); END;
  861.             d := (abs(mergebytes(ord(apk[1]), ord(apk[2])) MOD phash2 +
  862.                       mergebytes(ord(apk[5]), ord(apk[6])) MOD phash2))
  863.                  MOD p;
  864.             IF d = 0 THEN d := 1; END;
  865.           h := h + d;
  866.           IF h >= p THEN h := h - p; END;
  867.       UNTIL found;
  868. 1:    END; (* insert *)
  869.  
  870.     (* 2---------------2 *)
  871.  
  872.     PROCEDURE formid;
  873.  
  874.       VAR
  875.         k : integer;
  876.  
  877.       BEGIN (* formid *)
  878.       k := 0; a := blank;
  879.       REPEAT
  880.         IF k < alfalen THEN BEGIN
  881.           k := succ(k); a[k] := ch; END;
  882.         nextch;
  883.       UNTIL NOT (ch IN alfamerics);
  884.       packword(a, apk);
  885.       END; (* formid *)
  886.  
  887.     (* 2---------------2 *)
  888.  
  889.     BEGIN (* scaninput *)
  890.     (* alter definition of a comment here *)
  891.     WHILE moretext DO BEGIN
  892.       IF ch = ' ' THEN nextch
  893.       ELSE IF ch IN letters THEN
  894.         IF restricted THEN BEGIN
  895.           IF ch IN firstchars THEN BEGIN
  896.             formid;
  897.             IF notrsdwd(apk) THEN insert; END
  898.           ELSE
  899.             REPEAT (* skip over id *)
  900.               nextch;
  901.             UNTIL NOT (ch IN digits); END
  902.         ELSE BEGIN
  903.           formid;
  904.           IF notrsdwd(apk) THEN insert; END
  905.       ELSE IF ch IN digits THEN BEGIN
  906.         formid;
  907.         IF numerics THEN insert; END
  908.       ELSE IF ch = '''' THEN BEGIN  (* string constant *)
  909.         REPEAT
  910.           nextch;
  911.         UNTIL (ch = '''') OR NOT moretext;
  912.         IF moretext THEN nextch; END
  913.       ELSE IF ch = '"' THEN BEGIN (* string constant *)
  914.         REPEAT
  915.           nextch;
  916.         UNTIL (ch = '"') OR NOT moretext;
  917.         IF moretext THEN nextch; END
  918.       ELSE IF ch = '/' THEN BEGIN
  919.         nextch;
  920.         IF (ch = '*') AND NOT eol THEN BEGIN (* comment *)
  921.           nextch;
  922.           REPEAT
  923.             WHILE (ch <> '*') AND moretext DO nextch;
  924.             IF moretext THEN nextch;
  925.           UNTIL (ch = '/') OR NOT moretext;
  926.           IF moretext THEN nextch; END;
  927.         END
  928.       ELSE nextch; END; (* of main loop *)
  929.     END; (* scaninput *)
  930.  
  931.   (* 1---------------1 *)
  932.  
  933. (*$s'phase2'*)
  934.   PROCEDURE showstats(VAR f : text);
  935.  
  936.     BEGIN (* showstats *)
  937.     writeln(f);
  938.     writeln(f, idcount : 6,' Identifiers', refcount : 6,' Occurences');
  939.     writeln(f, nco : 6, ' Collisions ', nc : 6, ' Misses');
  940.     END; (* showstats *)
  941.  
  942.   (* 1---------------1 *)
  943.  
  944. (*$s'outerblk'*)
  945.   BEGIN  (* xrefc *)
  946.   initialize;
  947.   IF NOT moretext THEN writeln('NO INPUT!!');
  948.   scaninput; (* FILE FOR identifiers  *)
  949.   close(textfile); (* allow others access *)
  950.   writeln(totlines, ' lines read');
  951.   writeln(listfile);
  952.   IF alfalen > 7 THEN i := alfalen + 4
  953.   ELSE i := 12;
  954.   IF idcount > 0 THEN BEGIN
  955.     writeln(listfile, 'IDENTIFIER', 'OCCURRENCES' : i);
  956.     writeln(listfile, '==========', '===========' : i);
  957.     printbl; END;
  958.   showstats(listfile); showstats(output);
  959.   END. (* xrefc *)
  960. «&