home *** CD-ROM | disk | FTP | other *** search
/ Shareware Overload / ShartewareOverload.cdr / database / xrefprg2.zip / XREFPRG2.PAS < prev   
Pascal/Delphi Source File  |  1986-03-10  |  34KB  |  1,088 lines
  1.   {$C-}  {* essential for programmed pause-abort facility;
  2.                                   see procedure dealwithuser *}
  3. program xrefprg;
  4. (*
  5. ==========================================================================
  6. 1/6/86
  7. Modified to produce cross reference listings of DB3 Ver 1.1 files
  8.  
  9. Existing programs like SL.COM and DTUN31 seem to work very well
  10. except in the area of producing a cross reference.  This quick
  11. conversion of a pascal lister seems to work pretty well.  
  12.  
  13. I have stripped out most of the Pascal specific code and changed
  14. the Reserved word list to work with DB3.  There are many other
  15. enhancements I would like to include but want to get this into
  16. use quickly.  
  17. ----------------------------------------------------------------------
  18. 3/2/86
  19. Added new keywords for dBASE + and ability to recognize end-of-line
  20. comments (&& comment).
  21.  
  22. See document file for other changes/additions.
  23.  
  24. If (when?) you discover problems with this program, please let me
  25. know at:
  26.                         Robert F. Hicks
  27.                         6508 Harwood Place
  28.                         Springfield, VA 22152
  29.  
  30. Many thanks to the original author(s) for code that could be easily
  31. modified.
  32. ==========================================================================
  33.  Cross reference generator Version 1.10, 5/8/85
  34.  
  35.           ------> REQUIRES TURBO PASCAL 3.0 <------
  36.                                         --- (explained below)
  37.  
  38.   This program, in its original form, was downloaded off of some bulletin
  39.   board somewhere.  At that point, it only listed a Pascal program to the
  40.   LST device and generated a cross reference of whatever reserved words
  41.   were in the list in function rsvdword, with those reserved boldfaced in
  42.   the printout.  I have made numerous improvements.
  43.  
  44.  
  45.   You should note that many of the new functions of XREF use TURBO features
  46.   which are specific to the IBM-PC version, such as the reverse video and
  47.   use of wherex and wherey.
  48.  
  49.   I can't think of anything else one would need in a source listing program.
  50.   If someone else can, or has any questions about the program, please contact
  51.   me at this address:
  52.  
  53.             Larry Jay Seltzer
  54.             657 Seventh Street
  55.             Lakewood, NJ  08701
  56.  
  57.   The compressed and default mode options work for the Epson FX-100 and
  58.   any compatable printer.  The codes are stored in CONSTants, so as to
  59.   be easily changeable for any printer with this capacity.  There are three
  60.   basic ways to invoke the program:
  61.  
  62.              1) XREF from command line.  You will be prompted for everything.
  63.              2) XREF [pathname][filename].[ext]
  64.                        You will be prompted for all applicable parameters.
  65.              3) XREF [pathname][filename].[ext] [/ { C, D, F, I, N, S } ]
  66.                         C means print out in compressed mode (EPSON)
  67.                         D means print out in default mode
  68.                         F means print out to disk file
  69.                         I means list include files within the main
  70.                         N means exclude the cross refernce
  71.                         S means send output to the screen instead of printer.
  72.  
  73.  
  74.   The program requires TURBO 3.0 because it uses TURBO FIBs, which have been
  75.   altered for version 3.0.  The FIB no longer contains the file's date of
  76.   creation, so the file handle is passed to DOS function call $57, which
  77.   returns the date.
  78.  
  79.  >>>> This should be compiled into a COM file
  80.                        by Turbo Pascal(tm) 3.0 or later before running.
  81.                                               What Borland hath wrought!!! <<<<
  82. *)
  83.  
  84. const
  85.    ch_per_word = 22; { characters per word }
  86.    linenums = 11; { line numbers per printed reference line }
  87.    linenum_size =  5; { size of displayed line numbers }
  88.    reserved_count = 303; { number of reserved words }
  89.  
  90.    {*** printer control sequences ***}
  91.    compressed_on : array[1..1] of char = (#15);
  92.    default_on : array[1..2] of char = (#27,#64);
  93.    boldface_on : array[1..2] of char = (#27,#71);
  94.    boldface_off : array[1..2] of char = (#27,#72);
  95.  
  96. type
  97.    datestr = string[10];
  98.    option_type = string[1];
  99.    switchsettype = set of char;
  100.    wordref = ^word;
  101.    itemref = ^item;
  102.    word = record key: string[ch_per_word];
  103.                 first, last: itemref;
  104.                 left, right: wordref;
  105.          end ;
  106.    item = record lno: integer;
  107.                 next: itemref;
  108.          end ;
  109.    state = (none,symbol,quote1,quote2,com1,com2);
  110.    filstring = string[64];
  111.    titletype = string[10];
  112. var
  113.    answer : option_type;
  114.    filename, outname : filstring;
  115.    root:  wordref;
  116.    xx,temp_adjust,ind_cnt,
  117.    next_case,next_do,next_if,
  118.    curr_case,curr_do,curr_if,
  119.    m,n,indent_amt,cutoff,pageno,
  120.       st_err_page,st_err_tot,
  121.     blk_err_page,blk_err_tot               : integer;
  122.    upid,id:    string[255];
  123.    blanks, ind_string                     : string[60];
  124.    fv,iv,
  125.    outf   :    text;
  126.    f      :    char;
  127.    switches : switchsettype;
  128.    scan  :  state;
  129.    title : titletype;
  130.    lead,test_sec_key,in_quotes,
  131.     auto_ind,taken_careof        : boolean;
  132.  
  133. function get_answer(opt1,opt2 : option_type) : option_type; forward;
  134.  
  135. function file_exists(var thefile : filstring) : boolean;
  136.    type
  137.       Registertype = record
  138.                      AX,BX,CX,DX,
  139.                      BP,SI,DI,DS,ES,flags: integer;
  140.       end;
  141.  
  142.    var
  143.       registers:registertype;
  144.  
  145.    begin
  146.       thefile := thefile + #0;
  147.       with registers do
  148.       begin
  149.          ds := seg(thefile);
  150.          dx := ofs(thefile)+1;
  151.          ax := $4E00;
  152.          cx := $0000
  153.       end;
  154.       intr($21,registers);
  155.       file_exists := not ((registers.flags and $0001) = $0001)
  156. end;
  157.  
  158.  
  159. function currdate: DateStr;
  160.    type
  161.       regpack = record
  162.                 ax,bx,cx,dx,bp,si,ds,es,flags: integer;
  163.       end;
  164.  
  165.    var
  166.       recpack:       regpack;                {record for MsDos call}
  167.       month,day:     string[2];
  168.       year:          string[4];
  169.       tempdate:      datestr;
  170.       i,dx,cx:       integer;
  171.  
  172.    begin
  173.       with recpack do
  174.       begin
  175.          ax := $2a shl 8;
  176.       end;
  177.       MsDos(recpack);                        { call function }
  178.       with recpack do
  179.       begin
  180.          str(cx,year);                        {convert to string}
  181.          str(dx mod 256,day);                     { " }
  182.          str(dx shr 8,month);                     { " }
  183.       end;
  184.       tempdate := month+'/'+day+'/'+year;
  185.       for i:= 1 to 10 do if tempdate[i] = ' ' then tempdate[i]:= '0';
  186.       currdate := tempdate
  187. end;
  188.  
  189. function filedate(var thefile : text) : datestr;
  190.    type
  191.       regpack = record
  192.                 al, ah : byte;
  193.                 bx,cx,dx,bp,si,ds,es,flags: integer;
  194.       end;
  195.    var
  196.       sortofdate,
  197.       i, handle : integer;
  198.       month,day : string[2];
  199.       year : string[4];
  200.       date : datestr;
  201.       recpack : regpack;
  202.  
  203.    begin
  204.       handle := memw [seg(thefile):ofs(thefile)];
  205.       recpack.al := 0;
  206.       recpack.AH := $57;
  207.       recpack.bx := handle;
  208.       msdos(recpack);
  209.       sortofdate := recpack.dx;
  210.       str(((sortofdate shr 9) + 1980):4,year);
  211.       str(((sortofdate shr 5) and $000F):2,month);
  212.       str((sortofdate and $001F):2,day);
  213.       date:= month + '/' + day + '/' + year;
  214.       for i:= 1 to 10 do if date[i] = ' ' then date[i]:= '0';
  215.       filedate := date
  216. end;  {WhenCreated}
  217.  
  218. procedure newpage(var fname : filstring;title:titletype);
  219.    var date : datestr;
  220.       date_stuff : string[40];
  221.    begin
  222.       pageno := pageno+1;
  223.       date_stuff := 'Created '+filedate(fv)+'  '+'Listed '+currdate;
  224.      If (not ('S' in switches)) and (not ('F' in switches))
  225.         then write(outf,#12) else writeln(outf);
  226.      write(outf,title,': ',fname,' ':6,date_stuff,' ':6,'Page ',pageno:3);
  227.      writeln(outf);
  228.      writeln(outf);
  229. end {newpage};
  230.  
  231. procedure writeid;
  232.    type
  233.       rsrv_key = (endcase,enddo,endif,aif,ado,acase,aelse,none);
  234.    var
  235.       chek_indent                    : rsrv_key;
  236.  
  237.    function rsvdword: boolean;
  238.  
  239.    const
  240.       wordlist: array[1..reserved_count] of string[14] =
  241. ('.AND.','.F.','.NOT.','.OR.','.T.','ABS','ACCE','ACCEPT','ADDI','ADDITIVE',
  242. 'ALL','ALTE','ALTERNATE','AMERICAN','ANSI','APPE','APPEND','ASC','AT','AVER',
  243. 'AVERAGE','BELL','BLAN','BLANK','BOF','BRITISH','BROW','BROWSE','CALL','CANC',
  244. 'CANCEL','CARR','CARRY','CASE','CATALOG','CDOW','CENTURY','CHR','CLEA',
  245. 'CLEAR','CLOS','CLOSE','CMON','CMONTH','COL','COLO','COLOR','CONF','CONFIRM',
  246. 'CONS','CONSOLE','CONT','CONTINUE','COPY','COUN','COUNT','CREA','CREATE',
  247. 'CTOD','DATA','DATABASES','DATE','DAY','DEBU','DEBUG','DECI','DECIMALS',
  248. 'DEFA','DEFAULT','DELE','DELETE','DELETED','DELI','DELIMITER','DELIMITERS',
  249. 'DEVI','DEVICE','DIR','DIR','DISK','DISKSPACE','DISP','DISPLAY','DO',
  250. 'DOHISTORY','DOW','DTOC','ECHO','EDIT','EJEC','EJECT','ELSE','ENDC','ENDCASE',
  251. 'ENDD','ENDDO','ENDI','ENDIF','ENDTEXT','EOF','ERAS','ERASE','ERROR','ESCA',
  252. 'ESCAPE','EXAC','EXACT','EXIT','EXP','EXPORT','EXTE','EXTENDED','FIELD',
  253. 'FIELDS','FILE','FILT','FILTER','FIND','FIXE','FIXED','FKLABEL','FKMAX','FORM',
  254. 'FORMAT','FOUND','FRENCH','FROM','FUNC','FUNCTION','GERMAN','GET','GETENV',
  255. 'GETS','GO','GOTO','HEAD','HEADING','HISTORY','IF','IIF','IMPORT','INDE',
  256. 'INDEX','INKEY','INPU','INPUT','INSE','INSERT','INT','INTE','INTENSITY',
  257. 'ISALPHA','ISCOLOR','ISLOWER','ISUPPER','ITALIAN','KEY','LABE','LABEL','LEFT',
  258. 'LEN','LIST','LOAD','LOCA','LOCATE','LOG','LOOP','LOWE','LOWER','LTRIM',
  259. 'LUPDATE','MARG','MARGIN','MASTER','MAX','MEMO','MEMORY','MEMOWIDTH','MENU',
  260. 'MENUS','MESSAGE','MIN','MOD','MODU','MODULE','MONT','MONTH','NDX','NOEJECT',
  261. 'OFF','ON','ORDER','OS','PACK','PARA','PARAMETER','PATH','PCOL','PICT',
  262. 'PICTURE','PLAIN','PRIN','PRINT','PRINTER','PRIV','PRIVATE','PROC','PROCEDURE',
  263. 'PROW','PUBL','PUBLIC','QUERY','QUIT','RANDOM','READ','READKEY','RECA',
  264. 'RECALL','RECCOUNT','RECN','RECNO','RECSIZE','REIN','REINDEX','RELA',
  265. 'RELATION','RELE','RELEASE','RENAME','REPL','REPLACE','REPLICATE','REPO',
  266. 'REPORT','REST','RESTORE','RESUME','RETRY','RETU','RETURN','RIGHT','ROUN',
  267. 'ROUND','ROW','RTRIM','RUN','SAFE','SAFETY','SAVE','SAY','SCOR','SCOREBOARD',
  268. 'SCREEN','SEEK','SELE','SELECT','SET','SKIP','SORT','SPAC','SPACE','SQRT',
  269. 'STAT','STATUS','STEP','STOR','STORE','STR','STRU','STRUCTURE','STUFF','SUBS',
  270. 'SUBSTR','SUM','SUMMARY','TALK','TEXT','TIME','TITLE','TO','TOTA','TOTAL',
  271. 'TRAN','TRANSFORM','TRIM','TYPE','TYPEAHEAD','UNIQ','UNIQUE','UPDA','UPDATE',
  272. 'UPPE','UPPER','USE','VAL','VERSION','VIEW','WAIT','WHIL','WHILE','WITH',
  273. 'YEAR','ZAP');
  274.    var
  275.       i, j, k: integer;
  276.  
  277.    begin
  278.       upid := '';
  279.       for i := 1 to length(id) do
  280.          upid := upid + upcase(copy(id,i,1));
  281.       i := 1;
  282.       j := reserved_count - 1;
  283.       repeat
  284.          k := (i+j) div 2;
  285.          if upid > wordlist[k] then
  286.             i := k+1
  287.          else
  288.             j := k
  289.       until i = j;
  290.       rsvdword := (upid = wordlist[i])
  291.     end {rsvdword};
  292.  
  293.    procedure search (var w1: wordref);
  294.       var
  295.          w: wordref;
  296.          x: itemref;
  297.       begin
  298.          w := w1;
  299.          if w = nil then
  300.          begin
  301.             new(w);
  302.             new(x);
  303.             with w^ do
  304.             begin
  305.                key := id;
  306.                left := nil;
  307.                right := nil;
  308.                first := x;
  309.                last := x
  310.             end ;
  311.             x^.lno := n;
  312.             x^.next := nil;
  313.             w1 := w
  314.          end
  315.          else
  316.             if id < w^.key then
  317.                search(w^.left)
  318.               else
  319.             if id > w^.key then
  320.                search(w^.right)
  321.              else
  322.             begin
  323.                  new(x);
  324.                 x^.lno := n;
  325.                 x^.next := nil;
  326.                 w^.last^.next := x;
  327.                 w^.last := x
  328.               end
  329.     end {search} ;
  330.  
  331.  
  332.     Procedure Regular_video;
  333.     begin
  334.         TextBackground(black);
  335.         TextColor(white);
  336.     end;
  337.  
  338.     Procedure Reverse_video;
  339.     begin
  340.         TextBackground(white);
  341.         TextColor(black);
  342.     end;
  343.  
  344.    function locase(ch:char) : char;
  345.    begin
  346.       If ch  in ['A'..'Z'] then
  347.          locase := chr(ord(ch) or $20)
  348.        else
  349.          locase := ch
  350.    end;
  351.  
  352.    procedure rsvd_write;
  353.    begin
  354.       if lead then
  355.       begin
  356.          write(outf,ind_string);
  357.          lead := FALSE
  358.       end;
  359.       if 'F' in switches then
  360.          write(outf,upid)
  361.       else
  362.          if 'S' in switches then
  363.          begin
  364.             reverse_video;
  365.             write(outf,upid);
  366.             regular_video
  367.          end
  368.          else
  369.             {put in a page break when a procedure starts}
  370.             if ((upid='PROCEDURE') and (n>10)) then
  371.             begin    { report at end of procedure same as end of file }
  372.             if (curr_if > 0) or (next_if > 0) then
  373.             begin
  374.                    blk_err_page := blk_err_page + 1;
  375.                  if not ('S' in switches) then
  376.                     writeln('*** MISSING ENDIF STATEMENT IN PROCEDURE ***');
  377.                     writeln(outf,'*** MISSING ENDIF STATEMENT IN PROCEDURE ***')
  378.              end;
  379.             if (curr_do > 0) or (next_do > 0) then
  380.             begin
  381.                    blk_err_page := blk_err_page + 1;
  382.                  if not ('S' in switches) then
  383.                     writeln('*** MISSING ENDDO STATEMENT IN PROCEDURE ***');
  384.                     writeln(outf,'*** MISSING ENDDO STATEMENT IN PROCEDURE ***')
  385.              end;
  386.             if (curr_case > 0) or (next_case > 0) then
  387.             begin
  388.                    blk_err_page := blk_err_page + 1;
  389.                  if not ('S' in switches) then
  390.                     writeln('*** MISSING ENDCASE STATEMENT IN PROCEDURE ***');
  391.                     writeln(outf,'*** MISSING ENDCASE STATEMENT IN PROCEDURE ***')
  392.              end;
  393.                 { reset counters for next proc }
  394.                curr_case := 0;
  395.                curr_do := 0;
  396.                curr_if := 0;
  397.                next_case := 0;
  398.                next_do := 0;
  399.                next_if := 0;
  400.                ind_string := '';
  401.                     st_err_tot := st_err_tot + st_err_page;
  402.                     blk_err_tot := blk_err_tot + blk_err_page;
  403.                     st_err_page := 0;
  404.                     blk_err_page := 0;
  405.                newpage(filename,title);
  406.                cutoff := n;
  407.                write(outf,boldface_on,upid,boldface_off)
  408.             end
  409.             else
  410.                write(outf,boldface_on,upid,boldface_off)
  411.    end {rsvd_write};
  412.  
  413.    procedure indentset;
  414.       begin
  415.       chek_indent := none;  {reset it for next pass}
  416.       if lead then
  417.          begin
  418.            if upid ='IF' then chek_indent := aif;
  419.            if upid ='DO' then chek_indent := ado;
  420.            if upid = 'CASE' then chek_indent := acase;
  421.            if upid = 'ELSE' then chek_indent := aelse;
  422.            if upid = 'ENDCASE' then chek_indent :=endcase;
  423.            if upid = 'ENDDO' then chek_indent := enddo;
  424.            if upid = 'ENDIF' then chek_indent := endif;
  425.  
  426.            case chek_indent of
  427.               endcase:     begin
  428.                            if curr_case >0 then
  429.                               curr_case := curr_case - 2
  430.                            else
  431.                                     begin
  432.                                        blk_err_page := blk_err_page + 1;
  433.                               writeln(outf,'*** ENDCASE WITHOUT CASE ***');
  434.                                         if not ('S' in switches) then
  435.                               writeln('*** ENDCASE WITHOUT CASE ***')
  436.                                     end
  437.                            end;
  438.               enddo:       begin
  439.                            if curr_do>0 then
  440.                               curr_do := curr_do - 1
  441.                            else
  442.                                     begin
  443.                                        blk_err_page := blk_err_page + 1;
  444.                               writeln(outf,'*** ENDDO WITHOUT DO ***');
  445.                                         if not ('S' in switches) then
  446.                               writeln('*** ENDDO WITHOUT DO ***')
  447.                                     end
  448.                            end;
  449.               endif:       if curr_if>0 then
  450.                               curr_if := curr_if - 1
  451.                            else
  452.                                     begin
  453.                                        blk_err_page := blk_err_page + 1;
  454.                               writeln(outf,'*** ENDIF WITHOUT IF ***');
  455.                                         if not ('S' in switches) then
  456.                               writeln('*** ENDIF WITHOUT IF ***')
  457.                                     end;
  458.               aif:          begin
  459.                                next_if := next_if + 1
  460.                             end;
  461.               ado:          begin
  462.                                test_sec_key := TRUE;
  463.                             end;
  464.               acase:        begin
  465.                                temp_adjust := 1
  466.                             end;
  467.               aelse:        begin
  468.                                    if curr_if > 0 then 
  469.                                   temp_adjust := 1
  470.                                          else
  471.                                          begin
  472.                                   blk_err_page := blk_err_page + 1;
  473.                                             writeln(outf,'*** ELSE WITHOUT IF ***');
  474.                                   if not ('S' in switches) then
  475.                                              writeln('*** ELSE WITHOUT IF ***')
  476.                                          end
  477.                             end;
  478.             end { endcase};
  479.              end
  480. else
  481.             begin
  482.                if upid = 'CASE' then
  483.                   next_case := next_case + 2;
  484.                if (upid ='WHIL') or (upid='WHILE') then
  485.                   next_do := next_do + 1;
  486.                test_sec_key := FALSE
  487.       end; {lead or test_sec_key }
  488.       { this is one of two places that changes in indent level occur
  489.          but the only place that temp changes occur }
  490.       ind_cnt :=(curr_case + curr_do + curr_if - temp_adjust) * indent_amt;
  491.       ind_string := copy(blanks,1,ind_cnt);
  492.       rsvd_write;
  493.       temp_adjust := 0
  494.    end; {indentset}
  495.  
  496.  
  497.    begin {writeid}
  498.       if rsvdword then
  499.            if lead or test_sec_key then
  500.             indentset
  501.          else
  502.             rsvd_write
  503.       else
  504.       begin
  505.          {upid :='';}
  506.          if test_sec_key then
  507.             test_sec_key := FALSE;
  508.          for xx := 1 to length(id) do
  509.             id[xx] := locase(id[xx]);
  510.          if lead then
  511.          begin
  512.             write(outf,ind_string);
  513.             lead := FALSE
  514.          end;
  515.          write(outf,id);
  516.          If not ('N' in switches) then
  517.          begin
  518.          search(root)
  519.          end
  520.       end
  521.  end;{writeid}
  522.  procedure scrn_update(indent : boolean);
  523.   const
  524.    mainx = 18;
  525.    incx = 20;
  526.  
  527.   begin
  528.    if indent
  529.     then
  530.      gotoxy(incx,wherey)
  531.     else
  532.      gotoxy(mainx,wherey);
  533.    write(n:1)
  534.   end;
  535.  
  536. procedure printtree (w:wordref);
  537.  
  538.   procedure printword (w:word);
  539.     var l: integer;
  540.         x: itemref;
  541.     begin
  542.       if (n mod 58) = 0 then
  543.         newpage(filename,'xref');
  544.       write(outf,' ',w.key:ch_per_word);
  545.       x := w.first;
  546.       l:= 0;
  547.       repeat
  548.         if l = linenums then
  549.         begin
  550.           writeln(outf);
  551.           n := n+1;
  552.           scrn_update(false);
  553.           if (n mod 58) = 0 then
  554.             newpage(filename,'xref');
  555.           write(outf,' ':ch_per_word+1);
  556.           l := 0
  557.         end ;
  558.         l := l+1;
  559.         write(outf,x^.lno:linenum_size);
  560.         x := x^.next
  561.       until x = nil;
  562.      writeln(outf);
  563.      n := n+1;
  564.      scrn_update(false)
  565.     end {printword} ;
  566.   begin
  567.    if w <> nil then
  568.     begin
  569.       printtree(w^.left);
  570.       printword(w^);
  571.       printtree(w^.right)
  572.     end ;
  573.   end {printtree} ;
  574.  
  575.  
  576.  function get_answer;
  577.   var ch : char;
  578.    begin
  579.     repeat
  580.      read(kbd,ch)
  581.     until ch in [opt1,opt2,upcase(opt1),upcase(opt2)];
  582.     writeln(ch);
  583.     get_answer := upcase(ch)
  584.    end;
  585.  
  586.  function get_choices(opt1,opt2,opt3 : option_type) : option_type;
  587.   var ch : char;
  588.    begin
  589.     repeat
  590.      read(kbd,ch)
  591.     until ch in [opt1,opt2,opt3,upcase(opt1),upcase(opt2),upcase(opt3)];
  592.     writeln(ch);
  593.     get_choices := upcase(ch)
  594.    end;
  595.  
  596.  procedure empty_keyboard;
  597.   var
  598.    c : char;
  599.   begin
  600.    while keypressed do
  601.     read(kbd,c)
  602.   end;
  603.  
  604.    Procedure do_listing(var fv : text;title:titletype ;
  605.                                      fn : filstring ; mode : state);
  606.  
  607.       var
  608.          lead_white                     : Boolean;
  609.  
  610.       procedure dealwithuser;
  611.          var
  612.              oldx,oldy : integer;
  613.              c : char;
  614.          begin
  615.              empty_keyboard;
  616.              oldx:=wherex; oldy:=wherey;
  617.              writeln;
  618.              write('Press space to continue, Esc to abort ...');
  619.              answer := get_answer( #32,#27);
  620.              if answer=#27 then
  621.                halt
  622.               else
  623.             begin
  624.                 gotoxy(wherex,wherey-1);
  625.                 delline;
  626.                 if (oldy=25) or (oldy=23) then
  627.                   oldy := 23;
  628.                 gotoxy(oldx,oldy)
  629.             end
  630.          end;
  631.  
  632.    begin
  633.        st_err_page := 0;
  634.         st_err_tot := 0;
  635.         blk_err_page := 0;
  636.         blk_err_tot := 0;
  637.       curr_case := 0;
  638.       curr_do := 0;
  639.       curr_if := 0;
  640.         temp_adjust := 0;
  641.         next_case := 0;
  642.         next_do := 0;
  643.         next_if := 0;
  644.         ind_string := '';
  645.         cutoff := n;
  646.         scan := mode;
  647.         lead := TRUE;
  648.         in_quotes := FALSE;
  649.         reset(fv);
  650.         if ((title='Filename') and(('C' in switches) or ( 'D' in switches) or ('L' in switches))) then
  651.          newpage(fn,title);
  652.         while not eof(fv) do
  653.         begin
  654.             if auto_ind then
  655.              lead_white := TRUE
  656.             else
  657.                 lead_white := FALSE;
  658.           lead := TRUE;
  659.           { update the indent counters with next line info }
  660.           curr_case := curr_case + next_case;
  661.           curr_do := curr_do + next_do;
  662.           curr_if := curr_if + next_if;
  663.           { adjust the length of the indent string   }
  664.           ind_cnt :=(curr_case + curr_do + curr_if - temp_adjust) * indent_amt;
  665.           ind_string := copy(blanks,1,ind_cnt);
  666.           { reset the next-line counters }
  667.           next_case := 0;
  668.           next_do := 0;
  669.           next_if := 0;
  670.           if ((((n + st_err_page + blk_err_page)-(58+cutoff)) = 0)
  671.                 and (('C' in switches) or ('D' in switches) or ('L' in switches)))
  672.              then
  673.          begin
  674.                 st_err_tot := st_err_tot + st_err_page;
  675.                 blk_err_tot := blk_err_tot + blk_err_page;
  676.                 st_err_page := 0;
  677.                 blk_err_page := 0;
  678.             cutoff := cutoff+58;
  679.              if not taken_careof then
  680.                  newpage(fn,title)
  681.          end;
  682.           taken_careof := false;
  683.           n := n+1;
  684.           if not ('S' in switches) then
  685.             scrn_update(title='Include');
  686.           if ((not ('F' in switches)) or ( 'L' in switches)) then
  687.             write(outf,n:linenum_size,' ');
  688.           while not eoln(fv) do
  689.           begin
  690.          if keypressed then
  691.             dealwithuser;
  692.          read(fv,f);
  693.          if lead_white then  
  694.          begin
  695.             while ((ord(f)<33) and not eoln(fv)) do read(fv,f); {drop leading white space}
  696.             lead_white := False
  697.          end;
  698.          case scan of
  699.               none: begin
  700.                      if f in['.','a'..'z','A'..'Z','_'] then
  701.                      begin
  702.                         id := f;
  703.                           scan := symbol
  704.                      end
  705.                        else
  706.                      begin
  707.                           if lead then
  708.                         begin
  709.                            write(outf,ind_string);
  710.                            lead := FALSE
  711.                         end;
  712.                         write(outf,f);
  713.                         if f ='''' then
  714.                         begin
  715.                                    scan := quote1;
  716.                                     in_quotes := TRUE {starting a quoted string }
  717.                                 end
  718.                         else
  719.                            if f = '*' then
  720.                               scan := com1
  721.                         else
  722.                            if f = '"' then
  723.                            begin
  724.                                        scan := quote2;
  725.                                         in_quotes := TRUE
  726.                                     end
  727.                         else
  728.                            if f = '&' then { possible beginning of dB+ }
  729.                               scan := com2 { end-of-line comment }
  730.                        end
  731.                    end;
  732.  
  733.         symbol:   begin
  734.                      if f in['.','a'..'z','A'..'Z','0'..'9','_'] then
  735.                      begin
  736.                         id := id + f;
  737.                      end
  738.                      else
  739.                      begin
  740.                         writeid;
  741.                         write(outf,f);
  742.                         if f = '''' then
  743.                            begin
  744.                               scan := quote1;
  745.                               in_quotes := TRUE { starting a quoted string }
  746.                            end
  747.                         else
  748.                            if f = '"' then
  749.                            begin
  750.                               scan := quote2;
  751.                               in_quotes := TRUE
  752.                            end
  753.                            else
  754.                              scan := none
  755.                      end
  756.                   end;
  757.  
  758.         quote1:   begin
  759.                      write(outf,f);
  760.                      if f = '''' then
  761.                      begin
  762.                         scan := none;
  763.                         in_quotes := FALSE {the quote is properly terminated}
  764.                      end
  765.                   end;
  766.  
  767.         quote2:   begin
  768.                      write(outf,f);
  769.                      if f = '"' then
  770.                      begin
  771.                         scan := none;
  772.                         in_quotes := FALSE
  773.                      end
  774.                    end;
  775.  
  776.         com1:     begin
  777.                      write(outf,f)
  778.                   end;
  779.  
  780.         com2:     begin
  781.                      if f = '&' then { two ampersands start e-o-l comment so }
  782.                         scan := com1 { treat successive char as regular com }
  783.                      else            { it's probably a macro so treat it like }
  784.                         scan := none;
  785.                         { an unknown for further testing }
  786.                      write(outf,f)
  787.                   end;
  788.        end;
  789.     end;
  790.     if scan = symbol then
  791.     begin
  792.        writeid;
  793.        scan := none
  794.     end;
  795.     scan := none;
  796.     writeln(outf);
  797.     if in_quotes then { a quoted string is NOT properly terminated }
  798.     begin
  799.        if not ('S' in switches) then
  800.        writeln('***  STRING ABOVE NOT TERMINATED  ***');
  801.        writeln(outf,'***  STRING ABOVE NOT TERMINATED  ***');
  802.          st_err_page := st_err_page + 1;
  803.        in_quotes := FALSE { reset the error-flag }
  804.     end;
  805.     readln(fv);
  806.    end;
  807.    if (curr_if > 0) or (next_if > 0) then
  808.    begin
  809.                                   blk_err_page := blk_err_page + 1;
  810.         if not ('S' in switches) then
  811.         writeln('*** MISSING ENDIF STATEMENT IN FILE ***');
  812.         writeln(outf,'*** MISSING ENDIF STATEMENT IN FILE ***')
  813.     end;
  814.    if (curr_do > 0) or (next_do > 0) then
  815.    begin
  816.                                   blk_err_page := blk_err_page + 1;
  817.         if not ('S' in switches) then
  818.         writeln('*** MISSING ENDDO STATEMENT IN FILE ***');
  819.         writeln(outf,'*** MISSING ENDDO STATEMENT IN FILE ***')
  820.     end;
  821.    if (curr_case > 0) or (next_case > 0) then
  822.    begin
  823.                                   blk_err_page := blk_err_page + 1;
  824.         if not ('S' in switches) then
  825.         writeln('*** MISSING ENDCASE STATEMENT IN FILE ***');
  826.         writeln(outf,'*** MISSING ENDCASE STATEMENT IN FILE ***')
  827.     end;
  828.     writeln(outf)
  829.  end;
  830.  
  831. procedure get_info;
  832.  var
  833.   i : integer;
  834.   parameters : string[127] absolute cseg:$0080;
  835.   workparams : string[127];
  836.  
  837.  procedure get_filename;
  838.  begin
  839.   M := 0;
  840.   repeat
  841.     M := M+1
  842.   until (M > length(workparams)) or (workparams[M] <> ' ');
  843.   N:=M;
  844.   REPEAT
  845.     N:=N+1
  846.   UNTIL (N>length(workparams)) OR (workparams[N]='/');
  847.   filename := copy(workparams,m,(n-m));
  848.   if pos('.',filename)=0                  { the extension was left out }
  849.    then filename := filename + '.PRG' { so add a default extension }
  850.  end;
  851.  
  852.  procedure waytogo_user;  {* filename and switches on command line *}
  853.  begin
  854.   n := pos('/',workparams) + 1;
  855.   While n<=length(workparams) do
  856.    begin
  857.     if upcase(workparams[n]) in ['A','C','D','F','L','N','S']
  858.      then switches := switches + [upcase(workparams[n])];
  859.     if workparams[n] in ['0'..'9'] then
  860.         indent_amt := (ord(workparams[n]) - ord('0'));    {convert to integer}
  861.     n:=n+1
  862.    end;
  863.     if 'A' in switches then
  864.        auto_ind := TRUE
  865.     else
  866.        auto_ind := FALSE;
  867.     if 'F' in switches then 
  868.        outname := copy(filename,1,pos('.',filename)-1)+'.'+'LST'
  869.  end;
  870.  
  871.  procedure query_filename;
  872.  begin
  873.   write('C/R to quit or enter name of file to be listed [.PRG] : ');
  874.   readln(filename);
  875.   if pos('.',filename)=0
  876.    then filename := filename + '.PRG';
  877.   if pos('.',filename) < 2 then
  878.       halt  
  879.  end;
  880.  
  881.  procedure switch_menu;
  882.  var
  883.    ok : boolean;
  884.    indanswer, answer : char;
  885.  begin
  886.   write('Output to file, screen, or printer (F,S,P) ? ');
  887.   answer := get_choices('f','s','p');
  888.   If answer = 'P'
  889.    then
  890.     begin
  891.      write('Printer output in compressed or default mode (C,D) ? ');
  892.      if get_answer('c','d') = 'C'
  893.       then switches := switches + ['C']
  894.       else switches := switches + ['D']
  895.     end
  896.    else
  897.     if answer='S'
  898.      then switches := switches + ['S']
  899.      else
  900.       begin
  901.        switches := switches + ['F'];
  902.        write('Enter name of output file [',copy(filename,1,
  903.                                       pos('.',filename)-1),'.','LST]');
  904.        readln(outname);
  905.        if outname=''
  906.         then outname := copy(filename,1,pos('.',filename)-1)+'.'+'LST';
  907.          write('Include line numbers in output file (Y,N) ? ');
  908.        if get_answer('y','n') = 'Y'
  909.           then switches := switches + ['L']
  910.       end;
  911.         write('Generate auto-indentation of output (Y,N) ? ');
  912.       if get_answer('y','n') = 'Y' then
  913.         begin
  914.             write('C/R for indent = 3 or enter value to indent ');
  915. {$I-} {turn off i/i chek until good answer}
  916.            ok := FALSE;
  917.            repeat
  918.             begin
  919.                read(indent_amt);
  920.                  ok := (IoResult = 0);
  921.                  if not ok then
  922.                  begin
  923.                     gotoxy(wherex-1,wherey);
  924.                     write(' ')
  925.                  end;
  926.                 auto_ind := TRUE;
  927.             end
  928.            until ok;
  929.                 writeln
  930.     end
  931.         else {indenting not wanted }
  932.         begin
  933.            indent_amt := 0;
  934.             auto_ind := FALSE
  935.          end;
  936. {$I+}
  937.   write('Produce cross reference of user-defined identifiers (Y,N) ? ');
  938.   if get_answer('y','n') = 'N'
  939.    then switches := switches + ['N'];
  940.  end;
  941.  
  942. begin
  943.  workparams := parameters;
  944. { while workparams[LENGTH(workparams)]=#0 DO
  945.    delete(workparams,length(workparams),1);}
  946.  If pos('/',workparams)>0 then
  947.   If pos('/',workparams)<=length(workparams) then
  948.    begin
  949.     get_filename;
  950.     if not file_exists(filename)
  951.      then
  952.       begin
  953.        writeln('File ',filename,' not found.');
  954.        repeat
  955.         query_filename;
  956.         if not file_exists(filename)
  957.          then writeln('File ',filename,' not found.');
  958.        until file_exists(filename);
  959.        switch_menu
  960.       end
  961.      else
  962.       waytogo_user
  963.    end
  964.   else
  965.    begin
  966.     get_filename;
  967.     if not file_exists(filename)
  968.      then
  969.       begin
  970.        writeln('File ',filename,' not found.');
  971.        repeat
  972.         query_filename
  973.        until file_exists(filename);
  974.       end;
  975.     switch_menu
  976.    end
  977.  else
  978.   begin
  979.    if length(workparams)=0
  980.     then query_filename
  981.     else get_filename;
  982.     if not file_exists(filename)
  983.      then
  984.       begin
  985.        writeln('File ',filename,' not found.');
  986.        repeat
  987.         query_filename;
  988.         if not file_exists(filename)
  989.          then writeln('File ',filename,' not found.')
  990.        until file_exists(filename);
  991.       end;
  992.    switch_menu
  993.   end;
  994.  while filename[LENGTH(filename)]=#0 DO
  995.   delete(filename,length(filename),1)
  996. end;
  997.  
  998. begin  {*** main ***}
  999.  
  1000.   indent_amt := 3;
  1001.   switches := [];
  1002.   blanks :='                                                       ';
  1003.   test_sec_key := FALSE;
  1004.   clrscr;
  1005.   gotoxy(0,10);
  1006.   get_info;
  1007.   empty_keyboard;
  1008.   if (not ('F' in switches)) and (not ('S' in switches))
  1009.    then
  1010.     begin
  1011.      If 'C' in switches
  1012.       then writeln(lst,compressed_on);
  1013.      If 'D' in switches
  1014.       then writeln(lst,default_on)
  1015.     end;
  1016.   if 'S' in switches
  1017.    then
  1018.     begin
  1019.      assign(outf,'CON:');
  1020.      rewrite(outf)
  1021.     end
  1022.    else
  1023.     if 'F' in switches
  1024.      then
  1025.       begin
  1026.        assign(outf,outname);
  1027.        rewrite(outf)
  1028.       end
  1029.      else
  1030.       begin
  1031.        assign(outf,'LST:');
  1032.        rewrite(outf)
  1033.       end;
  1034.   root := nil;
  1035.   n := 0;
  1036.   cutoff := 0;
  1037.   scan := none;
  1038.   pageno := 0;
  1039.   title := 'Filename';
  1040.   if not ('S' in switches)
  1041.    then
  1042.     begin
  1043.      writeln;
  1044.      write('Listing main file ',filename);
  1045.      if 'F' in switches
  1046.       then writeln(' to file ',outname)
  1047.       else writeln;
  1048.      write('Processing line #')
  1049.     end;
  1050.   assign(fv,filename);
  1051.   do_listing(fv,title,filename,none);
  1052.   if not ('N' in switches)
  1053.    THEN
  1054.     BEGIN
  1055.      if not ('S' in switches)
  1056.       then
  1057.        begin
  1058.         writeln;
  1059.         write('Listing cross reference of ',filename);
  1060.         if 'F' in switches
  1061.          then writeln(' to file ',outname)
  1062.          else writeln;
  1063.         write('Processing line #')
  1064.        end;
  1065.      n := 0;
  1066.      pageno := 0;
  1067.      title := 'xref';
  1068.      printtree(root);
  1069.      If (not ('S' in switches)) and (not ('F' in switches))
  1070.       then write(outf,#12);
  1071.     END;
  1072.      if ('F' in switches) then
  1073.            close(outf);
  1074.     st_err_tot := st_err_tot + st_err_page;  {last update of total errors}
  1075.     blk_err_tot := blk_err_tot + blk_err_page;
  1076.      writeln(' ');
  1077.      writeln('File processing completed for ',filename);
  1078.      if not ((st_err_tot > 0) or (blk_err_tot > 0)) then
  1079.         writeln('No errors were detected.')
  1080.      else
  1081.      begin
  1082.         if blk_err_tot > 0 then
  1083.             writeln('There were ',blk_err_tot,' block errors found.');
  1084.         if st_err_tot > 0 then
  1085.             writeln('There were ',st_err_tot,' unterminated strings found.')
  1086.     end
  1087. end.
  1088.