home *** CD-ROM | disk | FTP | other *** search
/ ftp.barnyard.co.uk / 2015.02.ftp.barnyard.co.uk.tar / ftp.barnyard.co.uk / cpm / walnut-creek-CDROM / CPM / TURBOPAS / TYPEX.PZS / TYPEX.PAS
Pascal/Delphi Source File  |  2000-06-30  |  27KB  |  845 lines
  1. {$U-}
  2. {$C-}
  3. {
  4.   TYPEX.PAS  Jim Mischel, June 1, 1986
  5.  
  6.   Program listing and variable cross-reference generator for
  7.   Turbo Pascal programs.
  8.  
  9.   Usage is TYPEX <source> [<destination>] [;<options>]
  10.      Options are: I - INCLUDE files also
  11.                   X - Create program Cross-reference
  12.      Defaults:
  13.         Output   - LST:
  14.         Includes - NO
  15.         Xref     - NO
  16.  
  17.   If memory size is a consideration, INITIALIZE, PROCESS_FILE, and PRINT_XREF
  18.   can be made overlay procedures, with a savings of approximately 2.5K bytes.
  19.  
  20.   This program evolved from LISTER.PAS that was included on the Turbo Pascal
  21.   distribution disk.  Some of the original code still exists.
  22.  
  23.   The procedure GETDATE may have to be changed for use with MS-DOS.
  24.   It will NOT work with CP/M 2.2 without modification.  It will work
  25.   with MP/M, CP/M 3.x, and TurboDOS 1.3 or higher.
  26.  
  27.   This program was written using Turbo Pascal version 3.0 for CP/M.  I have
  28.   not tested it on any other operating system, though it should work except
  29.   as noted above.
  30.  
  31.   MODIFICATIONS:
  32.  
  33.   06/01/86 - jim - Initial coding.
  34.  
  35.   10/21/86 - jim - Use a pointer-reversal in PRINT_REFS in place of the
  36.                    recurrsive list traversal.
  37.  
  38.   11/30/86 - jim - Make the tree a right in-threaded tree.  This speeds
  39.                    printing of the cross-reference.
  40.                    Add the FSTPTR field to the node record.  References are
  41.                    now added in order of occurance.  FSTPTR points to the
  42.                    first reference record, and NXTPTR points to the last.
  43.                    Also added NUMREFS to the record to prevent having
  44.                    to scan the list twice.  PRINT_REFS is now a simple linked
  45.                    list traversal procedure.
  46. }
  47. program typex;
  48. const
  49.   version_no    = '2.5';
  50.   printwidth    = 70;                   { print width for each line }
  51.   printlength   = 55;                   { # of lines to print on each page }
  52.   pathlength    = 14;                   { maximum length of file name }
  53.   default_output = 'LST:';              { default destination }
  54.   include_default = false;              { default to no include files }
  55.   xref_default  = false;                { default to no cross-reference }
  56.   refs_per_line = 10;                   { max. number of references per line }
  57.   max_id_len    = 15;                   { max. id length for references on same line }
  58.   optchr        = ';';                  { option seperator character }
  59.  
  60. type
  61.   filename      = string[pathlength];
  62.   string8       = string[8];
  63.   string255     = string[255];
  64.   strptr        = ^string255;
  65.   refptr        = ^reference;
  66.   reference     = record                { item reference record }
  67.                     line,               { source line of reference }
  68.                     incl     : integer; { line in include file (if any) }
  69.                     nxtptr   : refptr;  { pointer to next reference }
  70.                   end;
  71.  
  72.   itmptr        = ^item;
  73.   item          = record
  74.                     idname : strptr;    { pointer to id name }
  75.                     left,               { left node of binary tree }
  76.                     right  : itmptr;    { right node of binary tree }
  77.                     rthrd  : boolean;   { TRUE if right is thread pointer }
  78.                     fstptr,             { pointer to first reference }
  79.                     nxtptr : refptr;    { pointer to last reference }
  80.                     numrefs : integer;  { Reference counter.  This is NOT a
  81.                                           count of references to this ID.  It
  82.                                           is used by PRINT_REFS to figure out
  83.                                           how many lines it will take to print
  84.                                           all the references for this item. }
  85.                   end;
  86. var
  87.   page_no,                              { current page number }
  88.   currow        : integer;              { current row in output file }
  89.   outfile,                              { listing file }
  90.   mainfile      : text;                 { source file }
  91.   mainfilename  : filename;             { input file name }
  92.   search        : array[1..4] of string[4]; { search strings for includes }
  93.   date,                                 { date returned from get_date }
  94.   time          : string8;              { time returned from get_date }
  95.   dots          : string[70];           { line of dots for page header }
  96.   xref,                                 { TRUE = generate cross-reference }
  97.   includes      : boolean;              { TRUE = process include files }
  98.   xref_head     : itmptr;               { root of cross-reference tree }
  99.  
  100. { PAGE - move output to new page }
  101. procedure page(var outfile : text);
  102. const
  103.   ff            = ^L;
  104. begin
  105.   write(outfile,ff);
  106. end;
  107.  
  108. { HEADINGS - move to new page and print headings. }
  109. procedure headings;
  110. begin
  111.   page(outfile);
  112.   page_no := page_no + 1;
  113.   write(outfile,date:8);
  114.   write(outfile,mainfilename:39);
  115.   writeln(outfile,time:33);
  116.   writeln(outfile,dots,'Page ',page_no:5);
  117.   writeln(outfile);
  118.   currow := 0;
  119. end; { headings }
  120.  
  121. { OPEN - open file FP with name NAME. Return TRUE if operation successful. }
  122. function open(var fp : text; name : filename) : boolean;
  123. begin
  124.   assign(fp,name);
  125.   {$i- turn off I/O error checking}
  126.   reset(fp);
  127.   {$i+ error checking back on}
  128.   if ioresult <> 0 then
  129.     begin
  130.       open := false;
  131.       close(fp);
  132.     end
  133.   else
  134.     open := true;
  135. end { open };
  136.  
  137. { INITIALIZE - set parameters and open files }
  138. procedure initialize;
  139.  
  140. { GET_DATE - get date and time from system and convert to two strings.
  141.              Date is stored as MM/DD/YY.  Time is stored as HH:MM:SS,
  142.              with seconds set to 00.
  143.              This routine will not work for dates prior to 01/01/78
  144. }
  145.  
  146. procedure get_date(var date_ptr,time_ptr);
  147. type
  148.   month_array   = array[1..2,1..12] of integer;
  149.   string8       = string[8];
  150. var
  151.   date          : string8 absolute date_ptr;
  152.   time          : string8 absolute time_ptr;
  153.   date_time     : packed array [1..4] of char;
  154.   jdate         : integer absolute date_time; { #days since 12/31/77 }
  155.   x,
  156.   month         : byte;
  157.   year          : integer;
  158. const
  159.   day_table     : month_array =
  160.                   ((31,59,90,120,151,181,212,243,273,304,334,365),
  161.                    (31,60,91,121,152,182,213,244,274,305,335,366));
  162.  
  163. { LEAP - return TRUE if YEAR is a leap year }
  164. function leap(year : integer) : boolean;
  165. begin
  166.   leap := (year mod 4 = 0) and (year <> 100);
  167. end; {leap}
  168.  
  169. { DAYS_IN - return number of days in YEAR }
  170. function days_in(year : integer) : integer;
  171. begin
  172.   if (leap(year)) then days_in := 366
  173.   else days_in := 365;
  174. end; {days_in}
  175.  
  176. begin
  177.   bdos(105,addr(date_time));            { get system date/time }
  178.   time := '00:00:00';                   { initialize time }
  179.   time[1] := chr((ord(date_time[3]) div 16) + 48); { hours first digit }
  180.   time[2] := chr((ord(date_time[3]) mod 16) + 48); {       second digit }
  181.   time[4] := chr((ord(date_time[4]) div 16) + 48); { minutes first digit }
  182.   time[5] := chr((ord(date_time[4]) mod 16) + 48); {         second digit }
  183.  
  184.   year := 78;
  185.   while (jdate > days_in(year)) do
  186.     begin
  187.       jdate := jdate-days_in(year);
  188.       year := year + 1;
  189.     end;
  190.  
  191.   if (leap(year)) then x := 2           { set proper date table }
  192.   else x := 1;
  193.  
  194.   month := 1;
  195.   while (jdate > day_table[x,month]) do { move us to the proper month }
  196.     month := month + 1;
  197.   if (month > 1) then
  198.     jdate := jdate - day_table[x,month-1]; { and set the date }
  199.  
  200.   date := '00/00/00';
  201.   date[1] := chr(month div 10 + 48);    { month first digit }
  202.   date[2] := chr(month mod 10 + 48);    {       second digit }
  203.   date[4] := chr(jdate div 10 + 48);    { day first digit }
  204.   date[5] := chr(jdate mod 10 + 48);    { day second digit }
  205.   date[7] := chr(year div 10 + 48);     { year first digit }
  206.   date[8] := chr(year mod 10 + 48);     {      second digit }
  207. end; { get_date }
  208.  
  209. { PRINTUSE - print usage information and exit }
  210. procedure printuse;
  211. begin
  212.   writeln;
  213.   writeln('Turbo Pascal program listing and variable Cross-reference generator');
  214.   writeln;
  215.   writeln('Usage is TYPEX <source> [<destination>] [',optchr:1,'<options>]');
  216.   writeln('   Options are: I - INCLUDE files also');
  217.   writeln('                X - Create program Cross-reference');
  218.   write  ('   DEFAULTS:  Output   - ');
  219.   writeln(default_output);
  220.   write  ('              Includes - ');
  221.   if include_default then
  222.     writeln('YES')
  223.   else
  224.     writeln('NO');
  225.   write  ('              Xref     - ');
  226.   if xref_default then
  227.     writeln('YES')
  228.   else
  229.     writeln('NO');
  230.   halt;
  231. end; { printuse }
  232.  
  233. { OPENMAIN - Open main input and output files.  Set XREF and INCLUDE options. }
  234. procedure openmain;
  235. var
  236.   tmpstr,
  237.   option_string : string[32];
  238.   param         : byte;
  239.   outfilename   : filename;             { output file name }
  240.  
  241. function get_param(var param : byte) : string255;
  242. var
  243.   x             : byte;
  244. begin
  245.   if (length(tmpstr) > 0) then
  246.     begin                               { there's an option string here }
  247.       get_param := tmpstr;
  248.       tmpstr := '';
  249.     end
  250.   else
  251.   if (param > paramcount) then
  252.     get_param := ''                     { no more parameters }
  253.   else
  254.     begin
  255.       tmpstr := paramstr(param);        { get next parameter }
  256.       param := param+1;                 { bump parameter count }
  257.       x := pos(optchr,tmpstr);
  258.       if (x > 1) then                   { see if it's an option string }
  259.         begin
  260.           get_param := copy(tmpstr,1,x-1);    { this is the returned parameter }
  261.           tmpstr := copy(tmpstr,x,length(tmpstr)-x+1); { save this for next time }
  262.         end
  263.       else
  264.         begin
  265.           get_param := tmpstr;          { return this }
  266.           tmpstr := '';                 { nothing saved }
  267.         end;
  268.     end;
  269. end; { get_param }
  270.  
  271. begin { openmain }
  272.   if (paramcount = 0) then
  273.     printuse;
  274.   includes := include_default;          { set default parameters }
  275.   xref := xref_default;
  276.   tmpstr := '';
  277.   option_string := '';
  278.   param := 1;
  279.   mainfilename := get_param(param);     { get input file name }
  280.   if not (open(mainfile,mainfilename)) then
  281.     begin
  282.       writeln('ERROR - cannot open input file ',mainfilename);
  283.       halt;
  284.     end;
  285.   outfilename := get_param(param);      { get output file name and options }
  286.   if (length(outfilename) > 0) then
  287.     if (outfilename[1] = optchr) then
  288.       begin
  289.         option_string := outfilename;   { options }
  290.         outfilename := default_output;  { but no defined file name }
  291.       end
  292.     else
  293.       option_string := get_param(param) { get options (if any) }
  294.   else
  295.     begin
  296.       option_string := '';              { no options }
  297.       outfilename := default_output;    { no defined file name }
  298.     end;
  299.   assign(outfile,outfilename);
  300.   {$I-}
  301.   rewrite(outfile);
  302.   {$I+}
  303.   if (ioresult <> 0) then
  304.     begin
  305.       writeln('ERROR - cannot open output file ',outfilename);
  306.       halt;
  307.     end;
  308.   if (pos(optchr,option_string) = 1) then
  309.     begin                               { set options }
  310.       includes := (include_default xor (pos('I',option_string) > 0));
  311.       xref := (xref_default xor (pos('X',option_string) > 0));
  312.     end;
  313. end {openmain};
  314.  
  315. begin {initialize}
  316.   openmain;                             { open files and get options }
  317.   get_date(date,time);                  { get date and time for headings }
  318.   fillchar(dots,sizeof(dots),'.');
  319.   dots[0] := chr(70);                   { set length of dot line }
  320.   search[1] := '{$'+'i';
  321.   search[2] := '{$'+'I';
  322.   search[3] := '(*$'+'i';               { setup search strings for includes }
  323.   search[4] := '(*$'+'I';
  324.   page_no := 0;
  325.   headings;
  326.   xref_head := nil;
  327. end; {initialize}
  328. {
  329.   PROCESS_FILE - print each line of the input file and INCLUDED files,
  330.   if requested.  Create cross-reference records for each variable
  331.   if requested.
  332. }
  333. procedure process_file;
  334. var
  335.   linebuffer    : strptr;
  336.   line_no,                              { current line number in input file }
  337.   include_line  : integer;              { line number in include file }
  338.  
  339.   including,                            { TRUE = processing include file }
  340.   quote         : boolean;              { quote flag }
  341.   comment_type  : byte;                 { type of comment being processed:
  342.                                            0 = no comment
  343.                                            1 = '{'-type comment
  344.                                            2 = '(*'-type comment }
  345.  
  346. { INCLUDEIN - return TRUE if there is an INCLUDE statement in the current line }
  347. function includein(curstr : strptr) : boolean;
  348. var
  349.   x,
  350.   column        : byte;
  351. begin
  352.   x := 0;
  353.   column := 0;
  354.   repeat
  355.     x := x+1;
  356.     column := pos(search[x],curstr^);
  357.   until (x = 4) or (column > 0);
  358.   if (column = 0) then
  359.     includein := false
  360.   else
  361.     includein := not (curstr^[column+length(search[x])] in ['-','+']);
  362. end; {includein}
  363.  
  364. { PROCESS_LINE - write PRINTSTR to the output file, updating work_line.
  365.                  If cross-referencing, generate XREF records for each
  366.                  item found in PRINTSTR }
  367. procedure process_line(printstr : strptr; var work_line : integer);
  368. var
  369.   x             : byte;
  370.  
  371. { XREF_LINE - create reference records for each item found in PRINTSTR }
  372. procedure xref_line;
  373. var
  374.   x             : byte;
  375.   wkstr         : string255;
  376.   ch            : char;
  377.  
  378. {
  379.   ADD_TREE - add a reference to the tree.  If WKSTR is not in the tree,
  380.   create a new node for it.
  381. }
  382. procedure add_tree(var tree : itmptr);
  383. var
  384.   q,p           : itmptr;
  385.   less,
  386.   found         : boolean;
  387.  
  388. { MAKETREE - create a new tree node. }
  389. function maketree : itmptr;
  390. var
  391.   p             : itmptr;
  392. begin {maketree}
  393.   new(p);
  394.   with p^ do
  395.     begin
  396.       getmem(idname,length(wkstr)+1);   { allocate just enough for IDNAME }
  397.       idname^ := wkstr;
  398.       if (length(idname^) < max_id_len) then
  399.         numrefs := 0
  400.       else
  401.         numrefs := refs_per_line;
  402.       left := nil;
  403.       right := nil;
  404.       rthrd := false;
  405.       nxtptr := nil;                    { set reference pointer }
  406.       fstptr := nil;
  407.     end;
  408.   maketree := p;
  409. end; {maketree}
  410.  
  411. procedure setleft(p : itmptr);
  412. var
  413.   q             : itmptr;
  414. begin {setleft}
  415.   q := maketree;
  416.   p^.left := q;
  417.   q^.right := p;                        { inorder successor of q is p }
  418.   q^.rthrd := true;
  419. end; {setleft}
  420.  
  421. procedure setright(p : itmptr);
  422. var
  423.   q             : itmptr;
  424. begin {setright}
  425.   q := maketree;
  426.   q^.right := p^.right;                 { inorder successor of q is successor of p }
  427.   q^.rthrd := p^.rthrd;                 { may or may not be thread pointer }
  428.   p^.right := q;
  429.   p^.rthrd := false;
  430. end; {setright}
  431.  
  432. procedure add_ref(p : itmptr; line_no,include_line : integer);
  433. var
  434.   r             : refptr;
  435. begin {add_ref}
  436.   new(r);                               { create a new reference record }
  437.   with r^ do
  438.     begin
  439.       line := line_no;
  440.       incl := include_line;
  441.       nxtptr := nil;
  442.     end;
  443.   with p^ do
  444.     begin
  445.       if (fstptr = nil) then            { if first reference for this record }
  446.         fstptr := r                     { setup list head pointer }
  447.       else
  448.         nxtptr^.nxtptr := r;            { link previous last ref to new }
  449.       nxtptr := r;                      { point to last }
  450.       if (include_line > 0) then        { update reference counter }
  451.         numrefs := numrefs+2            { INCLUDEs take 2 spaces }
  452.       else
  453.         numrefs := numrefs+1;
  454.     end;
  455. end; {add_ref}
  456.  
  457. begin {add_tree}
  458.   if tree = nil then
  459.     begin                               { nothing in the tree }
  460.       tree := maketree;                 { so we'll make it }
  461.       p := tree;
  462.     end
  463.   else
  464.     begin
  465.       q := tree;
  466.       p := tree;
  467.       found := false;
  468.       while (q <> nil) and not found do     { search the tree }
  469.         begin
  470.           p := q;
  471.           if (p^.idname^ = wkstr) then
  472.             found := true                   { found it }
  473.           else
  474.             begin
  475.               less := (wkstr < p^.idname^);
  476.               if (less) then
  477.                 q := p^.left
  478.               else
  479.               if (p^.rthrd) then
  480.                 q := nil
  481.               else
  482.                 q := p^.right;
  483.             end;
  484.         end;
  485.       if (not found) then               { not found, create a new node }
  486.         if (less) then
  487.           begin
  488.             setleft(p);
  489.             p := p^.left;
  490.           end
  491.         else
  492.           begin
  493.             setright(p);
  494.             p := p^.right;
  495.           end;
  496.     end;
  497.   add_ref(p,line_no,include_line);      { create a new reference record }
  498. end; {add_tree}
  499.  
  500. { GETCHR - get the next character in the line.  Return 0 at end of line }
  501. procedure getchr;
  502. begin
  503.   if (x = 0) or (x > length(printstr^)) then
  504.     x := 0                              { end of line }
  505.   else
  506.     begin
  507.       ch := upcase(printstr^[x]);       { convert to uppercase for xref }
  508.       x := x+1;
  509.     end;
  510. end;
  511.  
  512. { KEYWORD - return TRUE if WKSTR is in the key word table.
  513.             This is a simple binary search }
  514. function keyword : boolean;
  515. const
  516.   nkwords       = 44;                   { number of key words in table }
  517. type
  518.   key_word_table= array[1..nkwords] of string[9];
  519. const
  520.   key_words     : key_word_table =
  521.                   ('ABSOLUTE' ,'AND'      ,'ARRAY'    ,'BEGIN',
  522.                    'CASE'     ,'CONST'    ,'DIV'      ,'DO',
  523.                    'DOWNTO'   ,'ELSE'     ,'END'      ,'EXTERNAL',
  524.                    'FILE'     ,'FOR'      ,'FORWARD'  ,'FUNCTION',
  525.                    'GOTO'     ,'IF'       ,'IN'       ,'INLINE',
  526.                    'LABEL'    ,'MOD'      ,'NIL'      ,'NOT',
  527.                    'OF'       ,'OR'       ,'OVERLAY'  ,'PACKED',
  528.                    'PROCEDURE','PROGRAM'  ,'RECORD'   ,'REPEAT',
  529.                    'SET'      ,'SHL'      ,'SHR'      ,'STRING',
  530.                    'THEN'     ,'TO'       ,'TYPE'     ,'UNTIL',
  531.                    'VAR'      ,'WHILE'    ,'WITH'     ,'XOR');
  532. var
  533.   high,
  534.   low,
  535.   mid           : byte;
  536. begin
  537.   high := nkwords;
  538.   low := 1;
  539.   while (low <= high) do
  540.     begin
  541.       mid := (high+low) div 2;
  542.       if (key_words[mid] = wkstr) then
  543.         begin
  544.           keyword := true;
  545.           exit;
  546.         end
  547.       else
  548.       if (key_words[mid] > wkstr) then
  549.         high := mid-1
  550.       else
  551.         low := mid+1;
  552.     end;
  553.   keyword := false;
  554. end;
  555.  
  556. begin {xref_line}
  557.   x := 1;                               { start at beginning }
  558.   wkstr := '';
  559.   getchr;
  560.   while (x > 0) do                      { while not end of line }
  561.     begin
  562.       if (ch = '''') and (comment_type = 0) then { set quote flag }
  563.         quote := not(quote)
  564.       else
  565.       if not quote then                 { if not in quote then go }
  566.         case comment_type of
  567.           0 : if ch = '{' then
  568.                 comment_type := 1       { start a comment }
  569.               else
  570.               if ch = '(' then
  571.                 begin
  572.                   getchr;
  573.                   if (x > 0) then
  574.                     if (ch = '*') then
  575.                       comment_type := 2 { start a comment }
  576.                     else
  577.                       x := x-1;
  578.                 end
  579.               else
  580.               if ch in ['A'..'Z'] then  { start a word }
  581.                 begin
  582.                   repeat
  583.                     wkstr := wkstr+ch;
  584.                     getchr;
  585.                   until (not (ch in ['0'..'9','A'..'Z','_'])) or (x = 0);
  586.                   if not keyword then   { check for keyword }
  587.                     add_tree(xref_head);{ not keyword, add to xref tree }
  588.                   wkstr := '';
  589.                   if x > 0 then         { if not end of line }
  590.                     x := x-1;           { go back to previous character }
  591.                 end;
  592.           1 : if ch = '}' then          { end comment }
  593.                 comment_type := 0;
  594.           2 : if ch = '*' then
  595.                 begin
  596.                   getchr;
  597.                   if (x > 0) then
  598.                     if (ch = ')') then
  599.                       comment_type := 0 { end comment }
  600.                     else
  601.                       x := x-1;
  602.                 end;
  603.         end; { case }
  604.       getchr;
  605.     end; { while }
  606. end; {xref_line}
  607.  
  608. { FINDSPACE - find end of last full word that will fit on the line }
  609. function findspace(printstr : strptr; var x : byte) : byte;
  610. var
  611.   y             : byte;
  612. begin
  613.   y := x;
  614.   x := x+printwidth;
  615.   if (x > length(printstr^)) then       { the whole line will fit }
  616.     x := length(printstr^)+1
  617.   else
  618.     begin
  619.       while (printstr^[x] <> ' ') and (x > y) do { look back for first space }
  620.         x := x-1;
  621.       if (x > y) then                   { found it }
  622.         x := x+1
  623.       else
  624.         x := y+printwidth+1;            { no space, break in middle of word }
  625.     end;
  626.   findspace := x-1;
  627. end; {findspace}
  628.  
  629. { DETAB - replace all tabs in the line with appropriate number of spaces }
  630. procedure detab(var printstr : string255);
  631. type
  632.   string8       = string[8];
  633. const
  634.   tab           = ^I;
  635.   tab_string    : string8 = '        ';
  636. var
  637.   x             : byte;
  638. begin
  639.   x := pos(tab,printstr);
  640.   while (x > 0) do
  641.     begin
  642.       delete(printstr,x,1);            { remove the tab }
  643.       insert(copy(tab_string,1,8-((x-1) mod 8)),printstr,x); { insert spaces }
  644.       x := pos(tab,printstr);
  645.     end;
  646. end; {detab}
  647.  
  648. begin {process_line}
  649.   detab(printstr^);
  650.   currow := currow + ((length(printstr^)-1) div printwidth) + 1;
  651.   if currow > printlength then
  652.     begin
  653.       headings;
  654.       currow := currow + ((length(printstr^)-1) div printwidth) + 1;
  655.     end;
  656.   work_line := work_line + 1;
  657.   if including then
  658.     write(outfile,'<',work_line:5,'> : ')
  659.   else
  660.     write(outfile,' ',work_line:5,'  : ');
  661.   x := 1;
  662.   writeln(outfile,copy(printstr^,1,findspace(printstr,x)));
  663.   while x <= length(printstr^) do
  664.     writeln(outfile,' ':10,copy(printstr^,x,findspace(printstr,x)));
  665.   if xref then
  666.     xref_line;
  667. end; {process_line}
  668.  
  669. procedure process_include_file(incstr : strptr);
  670. var
  671.   namestart,
  672.   nameend       : integer;
  673.   includefile   : text;
  674.   includefilename : filename;
  675.  
  676. function parse(incstr : strptr) : filename;
  677. begin
  678.   namestart := pos('$I',incstr^)+2;
  679.   if namestart = 2 then
  680.     namestart := pos('$i',incstr^)+2;
  681.   while (incstr^[namestart] = ' ') do
  682.     namestart := namestart + 1;
  683.   nameend := namestart;
  684.   while (not (incstr^[nameend] in [' ','}','*']))
  685.          and ((nameend - namestart) <= pathlength) do
  686.     nameend := nameend + 1;
  687.   nameend := nameend - 1;
  688.   parse := copy(incstr^,namestart,(nameend-namestart+1));
  689. end; {parse}
  690.  
  691. begin  {process_include_file}
  692.   includefilename := parse(incstr);
  693.   if (pos('.',includefilename) = 0) then
  694.     includefilename := includefilename + '.PAS';
  695.   including := true;
  696.   include_line := 0;
  697.   if not open(includefile,includefilename) then
  698.     begin
  699.       linebuffer^ := 'ERROR -- Include file not found:  ' + includefilename;
  700.       process_line(linebuffer,include_line);
  701.     end
  702.   else
  703.     begin
  704.       while not eof(includefile) do
  705.         begin
  706.           readln(includefile,linebuffer^);
  707.           process_line(linebuffer,include_line);
  708.         end;
  709.       close(includefile);
  710.     end;
  711.   including := false;
  712.   include_line := 0;
  713. end; {process_include_file}
  714.  
  715. begin  {process_file}
  716.   new(linebuffer);
  717.   quote := false;
  718.   comment_type := 0;
  719.   line_no := 0;
  720.   include_line := 0;
  721.   including := false;                   { not including a file now }
  722.   while not eof(mainfile) do
  723.     begin
  724.       readln(mainfile,linebuffer^);
  725.       process_line(linebuffer,line_no);
  726.       if includes and includein(linebuffer) then
  727.         process_include_file(linebuffer);
  728.     end;
  729.   dispose(linebuffer);
  730. end; {process_file}
  731.  
  732. { PRINT_XREF - print the cross-reference listing }
  733. procedure print_xref(xref_head : itmptr);
  734. var
  735.   ref_count     : integer;
  736.   p,q           : itmptr;
  737.  
  738. { LPWRITELN - write a newline on output file.  Check for page break. }
  739. procedure lpwriteln;
  740. begin
  741.   if (currow > printlength) then
  742.     headings;                           { new page }
  743.   writeln(outfile);
  744.   currow := currow + 1;
  745. end;
  746.  
  747. { NEWLINE - need another line for references.  Start at position (MAX_ID_LEN+1) }
  748. procedure newline;
  749. begin
  750.   lpwriteln;
  751.   write(outfile,' ':(max_id_len + 1));
  752.   ref_count := 1;
  753. end;
  754.  
  755. { PRINT_REFS - Print the list of references for the current node. }
  756. procedure print_refs(node : itmptr);
  757. var
  758.   list          : refptr;
  759.  
  760. { WRITE_REF - output one reference to the print file }
  761. procedure write_ref(ref : refptr);
  762. var
  763.   inclstr       : string8;
  764.   inclen        : byte absolute inclstr; {easier than length(inclstr)}
  765. begin
  766.   with ref^ do
  767.     begin
  768.       if (ref_count > refs_per_line) then
  769.         newline;
  770.       write(outfile,line:1);
  771.       if (incl = 0) then
  772.         begin                           { no include in this reference }
  773.           str(line:1,inclstr);
  774.           if (inclen < 6) then
  775.             write(outfile,' ':(6-inclen));
  776.           ref_count := ref_count + 1;
  777.         end
  778.       else
  779.         begin                           { process INCLUDEd reference }
  780.           write(outfile,'<',incl:1,'>');
  781.           str(line:1,inclstr);
  782.           if (inclen < 6) then
  783.             write(outfile,' ':(6-inclen));
  784.           str(incl:1,inclstr);
  785.           if (inclen < 4) then
  786.             write(outfile,' ':(4-inclen));
  787.           ref_count := ref_count + 2;
  788.         end;
  789.     end; {with}
  790. end; {write_ref}
  791.  
  792. begin {print_refs}
  793.   if ((node^.numrefs div refs_per_line) > (printlength - currow)) then
  794.     headings;
  795.   write(outfile,node^.idname^);         { output idname }
  796.   if (length(node^.idname^) >= max_id_len) then
  797.     newline
  798.   else
  799.     write(outfile,' ':(max_id_len-length(node^.idname^)+1));
  800.  
  801.   ref_count := 1;
  802.   list := node^.fstptr;
  803.   repeat
  804.     write_ref(list);
  805.     list := list^.nxtptr;
  806.   until (list = nil);
  807.   lpwriteln;
  808. end; {print_refs}
  809.  
  810. { in-order traversal of a right in-threaded binary tree. }
  811. begin {print_xref}
  812.   headings;
  813.   p := xref_head;
  814.   repeat
  815.     q := nil;
  816.     while (p <> nil) do
  817.       begin                             { traverse left branch }
  818.         q := p;
  819.         p := p^.left;
  820.       end;
  821.     if (q <> nil) then
  822.       begin
  823.         print_refs(q);
  824.         p := q^.right;
  825.         while (q^.rthrd) do
  826.           begin                         { back up }
  827.             print_refs(p);
  828.             q := p;
  829.             p := p^.right;
  830.           end;
  831.       end;
  832.   until (q = nil);
  833. end; {print_xref}
  834.  
  835. begin { typex }
  836.   writeln('[TYPEX Version ',version_no,']');
  837.   initialize;
  838.   process_file;
  839.   if xref then
  840.     print_xref(xref_head);
  841.   page(outfile);
  842.   close(mainfile);
  843.   close(outfile);
  844. end. { typex }
  845.