home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / PASCAL / PLISTER.ZIP / PLISTER.PAS
Encoding:
Pascal/Delphi Source File  |  1986-11-08  |  31.3 KB  |  908 lines
  1. program PLIST;
  2. (* Written by: Rick Schaeffer
  3.               E. 13611 26th Av.
  4.               Spokane, Wa.  99216
  5.  
  6.   modifications (7/8/84  by Len Whitten, CIS: [73545,1006])
  7.      1) added error handling if file not found
  8.      2) added default extension of .PAS to main & include files
  9.      3) added "WhenCreated" procedure to extract file
  10.         creation date & time from TURBO FIB
  11.      4) added demarcation of where include file ends
  12.      5) added upper char. conversion to include file
  13.      6) increased left margin to 5 spaces (80 char. line just fits @ 10cpi)
  14.      7) added listing control: {.L-} turns it off, {.L+} turns it back on,
  15.         must be in column 1
  16.      
  17.   further modifications (7/12/84 by Rick Schaeffer)
  18.      1) cleaned up the command line parsing routines and put them in
  19.         separate procedures.  Now permits any number of command line
  20.         arguments, each argument separated with at least one space.
  21.      2) added support for an optional second command line parameter
  22.         which specifies whether include files will be listed or not.
  23.         The command is invoked by placing "/i" on the command line
  24.         at least one space after the file name to be listed.  For
  25.         instance, to list MYPROG.PAS as well as any "included" files,
  26.         the command line would be: PLIST MYPROG /I
  27.  
  28.    further modification (8/28/84) by Jay Kadashaw)
  29.       1) Restored filedate and filetime after listing an included
  30.          file.
  31.       2) Added comment counter and begin/end counter.
  32.       3) Output can be routed to either the printer or console.
  33.       4) After listing first file the user is prompted for next
  34.          file if any.
  35.  
  36.    Still more modifications! (10/30/84) by Michael Roberts
  37.          1) Cleaned Up various problems I encountered
  38.          2) Removed Comment counter in order to add line numbers
  39.          3) Added Cross-Referencing facility
  40.             a) IMPORTANT!! Make sure when you create COM file you assign
  41.                The minimum segment sizes given in a MEM compile
  42.                (Particularly allow a minimum Stack Size Of 1300)
  43.             b) The file 'TURBOPAS.RES' contains the reserved words for
  44.                the TURBO Pascal compiler release 2.0.  If new reserved
  45.                words are implemented in future releases, add the new
  46.                words to this file.
  47.  
  48.             Please let me know if you run into any problems!
  49.                    Michael Roberts  [CIS 74226,3045]
  50.                    3103 Glenview
  51.                    Royal Oak, MI 48073
  52.  
  53.  
  54.  
  55.  
  56.  
  57.     Further Updates and modifications -- 03/04/85, Gene Czarcinski ..
  58.         1) Eliminate requirement for the TURBOPAS.RES file.
  59.         2) Do FormFeed at end of output, not the beginning.
  60.         3) Add code to check for and eliminate xref of reserved words
  61.         4) Redo/correct build of xref table .. rewrite BuildXref
  62.            (fixes bug causing incorrect line numbers in xref)
  63.         5) If command line parms specified, do not prompt and
  64.            process only that file.
  65.         6) Add code to support command line parms --
  66.              /X - supports compressed print on Gemini 10X printer
  67.              /R - XREF reserved words also
  68.              /C - output to console (default is printer)
  69.  
  70.    ** NOTE **
  71.       The routine BuildXref now contains a copmplex if-then-else-elseif
  72.       structure.  If the if-elseif structure is too long, it appears that
  73.       TURBO will barf (hang in compile).
  74.  
  75.  
  76.    Supported pseudo operations:
  77.     1) Listing control: {.L-} turns it off, {.L+} turns it back on,
  78.        must be in column 1
  79.     2. Page ejection: {.PAGE} or {.PA}, must be in column 1.
  80. *)
  81.  
  82.  { When program is first run will check for a file
  83.    name passed by DOS, and will try to open that file.  If no name is
  84.    passed, will ask operator for a file name to open.  Proc will tell
  85.    operator if file doesn't exist and will allow multiple retrys.
  86.  
  87.    Included files will be expanded only if the program is invoked as
  88.    follows:
  89.      pretty filename /i
  90.    The default is not to expand included files.
  91.  
  92.    On 2nd and later executions, proc will not check for DOS passed file
  93.    name.  In all cases, proc will assume a file type of .PAS if file
  94.    type is not specified.
  95.    PROGRAM EXIT from this proc when a null string is encountered in
  96.    response to a file name request. }
  97.  
  98.  
  99.  
  100. const monthmask = $000F;
  101.   daymask = $001F;
  102.   minutemask = $003F;
  103.   secondmask = $001F;
  104.  
  105. { to customize code for your printer - adjust the next item }
  106.  
  107.   maxline = 58;
  108.  
  109.   ff = #12;
  110.   PreFix  = #27#66#03#27#77#14;
  111.   PostFix = #27#77#0#18;
  112.  
  113.  
  114. type
  115.    XrefWordptr = ^XrefwordRec;
  116.    XrefNumPtr  = ^XrefNumRec;
  117.    XrefWordRec = RECORD
  118.                  XrefWord    : string[20];
  119.                  FirstNum    : XrefNumPtr;
  120.                  LastNum     : XrefNumPtr;
  121.                  NextWord    : XrefwordPtr;
  122.                  END;
  123.    XrefNumRec  = RECORD
  124.                  XrefNum     : Integer;
  125.                  NextNum     : XrefNumPtr;
  126.                  END;
  127.    alfa = string[15];
  128.    two_letters = string[2];
  129.    dtstr = string[8];
  130.    fnmtype = string[14];
  131.    instring = string[135];
  132.    regpack = record
  133.       ax,bx,cx,dx,bp,si,di,ds,es,flags : integer;
  134.    end;
  135.  
  136. Var
  137.   ParmX,
  138.   ParmR,
  139.   ParmC,
  140.   CmdParm,
  141.   DoneFlag,
  142.   First,
  143.   initprt   : boolean;
  144.   answer    : char;
  145.   Buff1     : instring;          {input line buffer}
  146.   FirstWord : ARRAY[0..26] of XrefWordPtr;
  147.   PrevWord,
  148.   NewWord,
  149.   CurrWord  : XRefWordPtr;
  150.   CurrNum   : XRefNumPtr;
  151.   XrefWord  : string[20];
  152.   XrefNum   : Integer;
  153.   wordchk   : alfa;
  154.   heaptop   : ^Integer;
  155.   listfil   : text;              {FIB for LST: or CON: output}
  156.   infile    : text;              {FIB for input file}
  157.   fnam      : fnmtype;           {in file name}
  158.   FirstNdx,
  159.   bcount,                        {begin/end counter}
  160.   kcount,                        {comment counter}
  161.   linect,                        {output file line counter}
  162.   linecnt,
  163.   pageno,
  164.   offset    : integer;
  165.   print     : boolean;           (* {.L-} don't print *)
  166.                                  (* {.L+} print       *)
  167.   print_head : boolean;
  168.   Print_Xref : boolean;
  169.   Word_switch: Boolean;
  170.   c         : char;
  171.   month, day, year,
  172.   hour, minute, second : two_letters;
  173.   sysdate, systime,
  174.   filedate, filetime : dtstr;
  175.   expand_includes    : boolean;
  176.   holdarg            : instring;
  177.   allregs : regpack;
  178.  
  179. {.page}
  180. Procedure ListIt(filename : fnmtype); forward;
  181.  
  182. Function Find_in_Reserve(var kword: alfa) : boolean;
  183. var flg : boolean;
  184.     cnt : integer;
  185. Begin
  186.    cnt := length(kword);
  187.         if cnt=2 then begin
  188.            if kword='IF' then flg:=TRUE
  189.       else if kword='DO' then flg:=TRUE
  190.       else if kword='TO' then flg:=TRUE
  191.       else if kword='IN' then flg:=TRUE
  192.       else if kword='OF' then flg:=TRUE
  193.       else if kword='OR' then flg:=TRUE
  194.       else if kword='LN' then flg:=TRUE
  195.       else if kword='HI' then flg:=TRUE
  196.       else if kword='LO' then flg:=TRUE
  197.       else flg:=FALSE;
  198.    end
  199.    else if cnt=3 then begin
  200.            if kword='END'       then flg:=TRUE
  201.       else if kword='FOR'       then flg:=TRUE
  202.       else if kword='VAR'       then flg:=TRUE
  203.       else if kword='SET'       then flg:=TRUE
  204.       else if kword='CHR'       then flg:=TRUE
  205.       else if kword='ORD'       then flg:=TRUE
  206.       else if kword='VAL'       then flg:=TRUE
  207.       else if kword='STR'       then flg:=TRUE
  208.       else if kword='MOD'       then flg:=TRUE
  209.       else if kword='DIV'       then flg:=TRUE
  210.       else if kword='AND'       then flg:=TRUE
  211.       else if kword='NOT'       then flg:=TRUE
  212.       else if kword='XOR'       then flg:=TRUE
  213.       else if kword='SHL'       then flg:=TRUE
  214.       else if kword='SHR'       then flg:=TRUE
  215.       else if kword='SIN'       then flg:=TRUE
  216.       else if kword='COS'       then flg:=TRUE
  217.       else if kword='INT'       then flg:=TRUE
  218.       else if kword='POS'       then flg:=TRUE
  219.       else if kword='EXP'       then flg:=TRUE
  220.       else if kword='NIL'       then flg:=TRUE
  221.       else if kword='ABS'       then flg:=TRUE
  222.       else if kword='SQR'       then flg:=TRUE
  223.       else if kword='ODD'       then flg:=TRUE
  224.       else if kword='EOF'       then flg:=TRUE
  225.       else if kword='PTR'       then flg:=TRUE
  226.       else if kword='NEW'       then flg:=TRUE
  227.       else flg:= FALSE;
  228.    end
  229.    else if cnt=4 then begin
  230.            if kword='ELSE'      then flg:=TRUE
  231.       else if kword='THEN'      then flg:=TRUE
  232.       else if kword='TYPE'      then flg:=TRUE
  233.       else if kword='TRUE'      then flg:=TRUE
  234.       else if kword='CHAR'      then flg:=TRUE
  235.       else if kword='BYTE'      then flg:=TRUE
  236.       else if kword='REAL'      then flg:=TRUE
  237.       else if kword='FRAC'      then flg:=TRUE
  238.       else if kword='SQRT'      then flg:=TRUE
  239.       else if kword='PRED'      then flg:=TRUE
  240.       else if kword='SUCC'      then flg:=TRUE
  241.       else if kword='WITH'      then flg:=TRUE
  242.       else if kword='COPY'      then flg:=TRUE
  243.       else if kword='MOVE'      then flg:=TRUE
  244.       else if kword='FILE'      then flg:=TRUE
  245.       else if kword='TEXT'      then flg:=TRUE
  246.       else if kword='READ'      then flg:=TRUE
  247.       else if kword='SEEK'      then flg:=TRUE
  248.       else if kword='EOLN'      then flg:=TRUE
  249.       else if kword='MARK'      then flg:=TRUE
  250.       else if kword='ADDR'      then flg:=TRUE
  251.       else if kword='SWAP'      then flg:=TRUE
  252.       else if kword='GOTO'      then flg:=TRUE
  253.       else if kword='EXIT'      then flg:=TRUE
  254.       else if kword='HALT'      then flg:=TRUE
  255.       else if kword='DRAW'      then flg:=TRUE
  256.       else if kword='PLOT'      then flg:=TRUE
  257.       else flg:=FALSE;
  258.    end
  259.    else if cnt=5 then begin
  260.            if kword='WHILE'     then flg:=TRUE
  261.       else if kword='SOUND'     then flg:=TRUE
  262.       else if kword='UNTIL'     then flg:=TRUE
  263.       else if kword='CONST'     then flg:=TRUE
  264.       else if kword='FALSE'     then flg:=TRUE
  265.       else if kword='ARRAY'     then flg:=TRUE
  266.       else if kword='LABEL'     then flg:=TRUE
  267.       else if kword='ROUND'     then flg:=TRUE
  268.       else if kword='TRUNC'     then flg:=TRUE
  269.       else if kword='CLOSE'     then flg:=TRUE
  270.       else if kword='WRITE'     then flg:=TRUE
  271.       else if kword='RESET'     then flg:=TRUE
  272.       else if kword='ERASE'     then flg:=TRUE
  273.       else if kword='FLUSH'     then flg:=TRUE
  274.       else if kword='CHAIN'     then flg:=TRUE
  275.       else if kword='DELAY'     then flg:=TRUE
  276.       else if kword='HIRES'     then flg:=TRUE
  277.       else if kword='MSDOS'     then flg:=TRUE
  278.       else flg:=FALSE;
  279.    end
  280.    else if cnt=6 then begin
  281.            if kword='SIZEOF'    then flg:=TRUE
  282.       else if kword='DOWNTO'    then flg:=TRUE
  283.       else if kword='REPEAT'    then flg:=TRUE
  284.       else if kword='RECORD'    then flg:=TRUE
  285.       else if kword='STRING'    then flg:=TRUE
  286.       else if kword='ARCTAN'    then flg:=TRUE
  287.       else if kword='UPCASE'    then flg:=TRUE
  288.       else if kword='CONCAT'    then flg:=TRUE
  289.       else if kword='LENGTH'    then flg:=TRUE
  290.       else if kword='INSERT'    then flg:=TRUE
  291.       else if kword='DELETE'    then flg:=TRUE
  292.       else if kword='ASSIGN'    then flg:=TRUE
  293.       else if kword='READLN'    then flg:=TRUE
  294.       else if kword='RENAME'    then flg:=TRUE
  295.       else if kword='GETMEM'    then flg:=TRUE
  296.       else if kword='WINDOW'    then flg:=TRUE
  297.       else if kword='WHEREX'    then flg:=TRUE
  298.       else if kword='WHEREY'    then flg:=TRUE
  299.       else if kword='CLREOL'    then flg:=TRUE
  300.       else if kword='CLRSCR'    then flg:=TRUE
  301.       else if kword='GOTOXY'    then flg:=TRUE
  302.       else if kword='RANDOM'    then flg:=TRUE
  303.       else flg:=FALSE;
  304.    end
  305.    else if cnt=7 then begin
  306.            if kword='OVERLAY'   then flg:=TRUE
  307.       else if kword='FORWARD'   then flg:=TRUE
  308.       else if kword='BOOLEAN'   then flg:=TRUE
  309.       else if kword='INTEGER'   then flg:=TRUE
  310.       else if kword='WRITELN'   then flg:=TRUE
  311.       else if kword='REWRITE'   then flg:=TRUE
  312.       else if kword='FILEPOS'   then flg:=TRUE
  313.       else if kword='EXECUTE'   then flg:=TRUE
  314.       else if kword='DISPOSE'   then flg:=TRUE
  315.       else if kword='FREEMEM'   then flg:=TRUE
  316.       else if kword='NOSOUND'   then flg:=TRUE
  317.       else if kword='DISPOSE'   then flg:=TRUE
  318.       else if kword='CRTEXIT'   then flg:=TRUE
  319.       else if kword='PALETTE'   then flg:=TRUE
  320.       else if kword='CRTINIT'   then flg:=TRUE
  321.       else if kword='INSLINE'   then flg:=TRUE
  322.       else if kword='DELLINE'   then flg:=TRUE
  323.       else if kword='PROGRAM'   then flg:=TRUE
  324.       else flg:=FALSE;
  325.    end
  326.    else begin
  327.            if kword='PROCEDURE' then flg:=TRUE
  328.       else if kword='FUNCTION'  then flg:=TRUE
  329.       else if kword='EXTERNAL'  then flg:=TRUE
  330.       else if kword='FILLCHAR'  then flg:=TRUE
  331.       else if kword='FILESIZE'  then flg:=TRUE
  332.       else if kword='MEMAVAIL'  then flg:=TRUE
  333.       else if kword='MAXAVAIL'  then flg:=TRUE
  334.       else if kword='TEXTMODE'  then flg:=TRUE
  335.       else if kword='TEXTCOLOR' then flg:=TRUE
  336.       else if kword='IORESULT'  then flg:=TRUE
  337.       else if kword='LOWVIDEO'  then flg:=TRUE
  338.       else if kword='NORMVIDEO' then flg:=TRUE
  339.       else if kword='KEYPRESSED'      then flg:=TRUE
  340.       else if kword='BLOCKREAD'       then flg:=TRUE
  341.       else if kword='BLOCKWRITE'      then flg:=TRUE
  342.       else if kword='TEXTBACKROUND'   then flg:=TRUE
  343.       else if kword='HIRESCOLOR'      then flg:=TRUE
  344.       else if kword='GRAPHWINDOW'     then flg:=TRUE
  345.       else if kword='GRAPHMODE'       then flg:=TRUE
  346.       else if kword='GRAPHCOLORMODE'  then flg:=TRUE
  347.       else if kword='GRAPHBACKGROUND' then flg:=TRUE
  348.       else flg:=FALSE;
  349.    end;
  350.    Find_in_Reserve := flg;
  351. End;
  352.  
  353.  
  354. procedure getchar(var char_value : char);
  355. begin
  356.    allregs.ax := $0000;
  357.    intr($16, allregs);
  358.    char_value := chr(ord(lo(allregs.ax)));
  359. end;
  360.  
  361. procedure fill_blanks (var line: dtstr);
  362. var i : integer;
  363. begin
  364.   for i:= 1 to 8 do if line[i] = ' ' then line[i]:= '0';
  365. end;
  366.  
  367. procedure getdate(var date : dtstr);
  368. begin
  369.    allregs.ax := $2A * 256;
  370.    MsDos(allregs);
  371.    str((allregs.dx div 256):2,month);
  372.    str((allregs.dx mod 256):2,day);
  373.    str((allregs.cx - 1900):2,year);
  374.    date := month + '/' + day + '/' + year;
  375.    fill_blanks (date);
  376. end;
  377.  
  378. procedure gettime(var time : dtstr);
  379. begin
  380.    allregs.ax := $2C * 256;
  381.    MsDos(allregs);
  382.    str((allregs.cx div 256):2,hour);
  383.    str((allregs.cx mod 256):2,minute);
  384.    str((allregs.dx div 256):2,second);
  385.    time := hour + ':' + minute + ':' + second;
  386.    fill_blanks (time);
  387. end;
  388.  
  389. procedure WhenCreated (var date, time: dtstr; var infile: text);
  390. var fulltime,fulldate: integer;
  391. begin
  392.  
  393.         { fulldate gets the area of the FIB which corresponds to bytes 20-21
  394.           of the FCB. Format is: bits 0 - 4: day of month
  395.                                       5 - 8: month of year
  396.                                       9 -15: year - 1980
  397.         }
  398.     fulldate:= memw [seg(infile):ofs(infile)+31];
  399.     str(((fulldate shr 9) + 80):2,year);
  400.     str(((fulldate shr 5) and monthmask):2,month);
  401.     str((fulldate and daymask):2,day);
  402.     date:= month + '/' + day + '/' + year;
  403.     fill_blanks(date);
  404.  
  405.         { fulltime gets the area of the FIB which corresponds to bytes 22-23
  406.           of the FCB. Format is: bits 0 - 4: seconds/2
  407.                                       5 -10: minutes
  408.                                       11-15: hours
  409.         }
  410.     fulltime:= memw [seg(infile):ofs(infile)+33];
  411.     str((fulltime shr 11):2,hour);
  412.     str(((fulltime shr 5) and minutemask):2,minute);
  413.     str(((fulltime and secondmask) * 2):2,second);
  414.     time:= hour + ':' + minute + ':' + second;
  415.     fill_blanks (time);
  416. end;  {WhenCreated}
  417.  
  418. Procedure BuildXref;
  419. var done:boolean;
  420. Begin
  421.    FirstNdx := ord(wordchk[1]) - ord('A');
  422.    if (FirstNdx<1) or (FirstNdx>26) or (length(wordchk)=0) then
  423.       FirstNdx := 0;
  424.    done := FALSE;
  425.    CurrWord := FirstWord[FIrstNdx];
  426.    PrevWord := nil;
  427.    REPEAT
  428.       if CurrWord=nil then begin
  429.          new(CurrWord);
  430.          CurrWord^.XrefWord  := wordchk;
  431.          CurrWord^.FirstNum  := nil;
  432.          CurrWord^.LastNum   := nil;
  433.          CurrWord^.NextWord  := nil;
  434.          done := TRUE;
  435.       end
  436.       else if CurrWord^.XrefWord = wordchk then begin
  437.          done := TRUE;
  438.       end
  439.       else if CurrWord^.XrefWord > wordchk then Begin
  440.          new(NewWord);
  441.          NewWord^.XrefWord  := wordchk;
  442.          NewWord^.FirstNum  := nil;
  443.          NewWord^.LastNum   := nil;
  444.          NewWord^.NextWord  := CurrWord;
  445.          if FirstWord[FirstNdx]=CurrWord then
  446.             FirstWord[FirstNdx] := NewWord;
  447.          CurrWord := NewWord;
  448.          done := TRUE;
  449.       end
  450.       else begin
  451.          PrevWord := CurrWord;
  452.          CurrWord := CurrWord^.NextWord;
  453.       end;
  454.    UNTIL done;
  455.    if FirstWord[FirstNdx]=nil then begin
  456.       FirstWord[FirstNdx] := CurrWord;
  457.    end;
  458.    if PrevWord <> Nil then begin
  459.       PrevWord^.NextWord := CurrWord;
  460.    end;
  461.    new(CurrNum);
  462.    CurrNum^.NextNum := nil;
  463.    CurrNum^.XrefNum := linecnt;
  464.    if CurrWord^.FirstNum=nil then
  465.       CurrWord^.FirstNum := CurrNum;
  466.    if CurrWord^.LastNum=nil  then
  467.       CurrWord^.LastNum := CurrNum
  468.    else begin
  469.       CurrWord^.LastNum^.NextNum := CurrNum;
  470.       CurrWord^.LastNum := CurrNum;
  471.    end;
  472. end;
  473.  
  474. procedure print_heading(filename : fnmtype);
  475. var offset_inc: integer;
  476. begin
  477.    if print then begin
  478.        pageno := pageno + 1;
  479.        {top of form}
  480.        if initprt then begin
  481.           if not ParmC then
  482.              write(listfil,ff);
  483.        end
  484.        else begin
  485.           initprt := TRUE;
  486.           if not ParmC then begin
  487.              if ParmX then
  488.                 write(listfil,PreFix);
  489.           end;
  490.        end;
  491.        writeln(listfil);
  492.        writeln(listfil,'TURBO Pascal Program Lister - 03/04/85  ',
  493.                        'Printed: ',sysdate,'  ',systime,
  494.                        '   Page ',pageno:4);
  495.        if filename <> fnam then begin
  496.           offset_inc:= 14 - length (filename);
  497.           write(listfil,'      Include File:',filename,' ':offset_inc,
  498.              'Created: ',filedate,'  ',filetime);
  499.        end
  500.        else write(listfil,'      Main File: ',fnam,' ':offset,
  501.              'Created: ',filedate,'  ',filetime);
  502.        writeln(listfil); writeln(listfil);
  503.        If Print_Xref then
  504.           Writeln(Listfil,' ':32,'CROSS-REFERENCE')
  505.        else
  506.            writeln(listfil, '       ');
  507.        writeln(listfil);
  508.        linect := 6;
  509.      end; {check for print}
  510. end;  {print_heading}
  511.  
  512. procedure printline(iptline : instring; filename : fnmtype);
  513. begin
  514.    if print then begin
  515.        if linect < 56 then begin
  516.           writeln(listfil,'     ',iptline);
  517.           linect := linect + 1
  518.        end
  519.        else begin
  520.           print_heading(filename);
  521.        end;
  522.    end; {check for print}
  523. end;  {printline}
  524.  
  525. function chkinc(var iptline : instring; var incflname : fnmtype) : boolean;
  526. var
  527.    done : boolean;
  528.    i, j : integer;
  529. begin
  530.    i := 4; j := 1; incflname := '';
  531.    if copy(iptline,1,3)='{$I' then begin
  532.       i := 4; j := 1; incflname := '';
  533.       while (iptline[i]=' ') and (i<=length(iptline)) do
  534.           i := i + 1;
  535.       done := false;
  536.       while not done do begin
  537.          if i<=length(iptline) then begin
  538.             if not (iptline[i] in [' ','}','+','-']) then begin
  539.                incflname := incflname + iptline[i];
  540.                i := i+1; j := j+1;
  541.             end
  542.             else
  543.                done := true;
  544.          end
  545.          else
  546.             done := true;
  547.          if j>14 then
  548.             done := true;
  549.       end;
  550.    end;
  551.    if incflname <> '' then begin
  552.       chkinc := true;
  553.       for i := 1 to length(Incflname) do
  554.           incflname[i] := upcase(incflname[i]);
  555.    end
  556.    else
  557.       chkinc := false;
  558. end;  {chkinc}
  559.  
  560. function parse_cmd(argno : integer) : instring;
  561. var
  562.    i,j : integer;
  563.    wkstr : instring;
  564.    done : boolean;
  565.    cmdline : ^instring;
  566. begin
  567.    cmdline := ptr(CSEG,$0080);
  568.    wkstr := '';
  569.    done := false; i := 1; j := 0;
  570.    if length(cmdline^) < i then done := true;
  571.    repeat
  572.       while ((cmdline^[i] = ' ') and (not done)) do begin
  573.          i := i + 1;
  574.          if i > length(cmdline^) then done := true;
  575.       end;
  576.       if not done then j := j + 1;
  577.       while ((cmdline^[i] <> ' ') and (not done)) do begin
  578.          wkstr := wkstr + cmdline^[i];
  579.          i := i + 1;
  580.          if i > length(cmdline^) then done := true;
  581.       end;
  582.       if (j <> argno) then wkstr := '';
  583.    until (done or (j = argno));
  584.    for i := 1 to length(wkstr) do
  585.       wkstr[i] := upcase(wkstr[i]); {all arguments forced to upper case}
  586.    parse_cmd := wkstr;
  587. end;
  588.  
  589. PROCEDURE GET_IN_FILE;     {GETS INPUT FILE NAME }
  590. var
  591.   existing : boolean;
  592.   i        : integer;
  593. begin
  594.     REPEAT             {until file exists}
  595.       holdarg := parse_cmd(1); {get command line argument # 1}
  596.       if (length(holdarg) in [1..14]) and first then begin
  597.          fnam := holdarg;       {move possible file name to fnam}
  598.          CmdParm := TRUE;
  599.       end
  600.       else begin
  601.           writeln;
  602.           write(' ENTER FILE NAME TO LIST or <cr> to EXIT  ');
  603.           readln(fnam);
  604.           if length(fnam)=0 then
  605.              HALT
  606.           else begin
  607.                   writeln;write(' EXPAND INCLUDES? (Y/N) ');
  608.                   readln(answer);
  609.                   if upcase(answer) = 'Y' then
  610.                      expand_includes := true
  611.                   else
  612.                      expand_includes := false;
  613.           end;
  614.       end;
  615.  
  616.      for i := 1 to length(fnam) do
  617.          fnam[i] := upcase(fnam[i]);
  618.      if pos('.',fnam) = 0 then       {file type given?}
  619.        fnam := concat(fnam,'.PAS');  {file default to .PAS type}
  620.  
  621.  {get optional command line argument # 2}
  622.      if CmdParm and first then begin
  623.          holdarg := parse_cmd(2);
  624.          if (length(holdarg)>1) and (holdarg[1]='/') then begin
  625.             for i := 1 to length(holdarg) do
  626.                holdarg[i] := upcase(holdarg[i]);
  627.             while length(holdarg)>0 do begin
  628.                     if holdarg[1]='R' then ParmR := TRUE
  629.                else if holdarg[1]='I' then expand_includes := TRUE
  630.                else if holdarg[1]='C' then ParmC := TRUE
  631.                else if holdarg[1]='X' then ParmX := TRUE;
  632.                Delete(holdarg,1,1);
  633.             end;
  634.          end;
  635.      end;
  636.  
  637.      first := false;                 {get passed file name only once}
  638.      assign(infile,fnam);
  639.        {$I-}
  640.      reset(infile);                {check for existence of file}
  641.        {$I+}
  642.      existing := (ioresult = 0);     {true if file found}
  643.      if not existing then begin
  644.         writeln;
  645.         writeln(' FILE DOESN''T EXIST'); {tell operator the sad news}
  646.      end;
  647.    UNTIL existing;                     {until file exists}
  648. end; {GET_IN_FILE}
  649.  
  650. { GET_OUT_FILE procedure asks operator to select output to console
  651.   device or list device, and then assigns and resets a file control
  652.   block to the appropriate device.  'C' or 'P' is only correct
  653.   response, and multiple retrys are allowed. }
  654.  
  655. Procedure Get_Out_File;
  656. var  c : char;
  657. begin
  658.    if CmdParm then begin
  659.       if ParmC then c := 'C'
  660.                else c := 'P';
  661.    end
  662.    else begin
  663.        REPEAT    {until good selection}
  664.          writeln; write(' OUTPUT LISTING TO (C)ONSOLE OR (P)RINTER ?  ');
  665.          getchar(c);
  666.          c := upcase(c); write(c);
  667.        UNTIL c in ['C', 'P'];
  668.        writeln;
  669.    end;
  670.    if c = 'C' then
  671.       assign (listfil, 'CON:')
  672.    else
  673.       assign (listfil, 'LST:');
  674.    reset(listfil);
  675. end;  {GET_OUT_FILE}
  676.  
  677.  
  678. {.page}
  679. { SCAN_LINE procedure scans one line of Turbo Pascal source code
  680.   looking for BEGIN/END pairs, CASE/END pairs, LITERAL fields
  681.   and COMMENT fields.  BCOUNT is begin/end and case/end counter.
  682.   KCOUNT is comment counter.  Begin/case/ends are only valid
  683.   outside of comment fields and literal constant fields (KCOUNT = 0
  684.   and NOT LITERAL).
  685.   Some of the code in the SCAN_LINE procedure appears at first glance
  686.   to be repitive and/or redundant, but was added to speed up the
  687.   process of scanning each line of source code.}
  688.  
  689. Procedure SCAN_LINE;
  690.   var
  691.     literal : boolean;          { true if in literal field}
  692.     tmp     : string[7];        { tmp work area }
  693.     i       : integer;          {loop variable index}
  694.     buff2   : instring;         {working line buffer}
  695.     incflname : fnmtype;        {in file name}
  696.     filedate_save : dtstr;
  697.     filetime_save : dtstr;
  698.   begin
  699.     literal := false;
  700.  
  701.     buff2[0] := buff1[0];  {copy input buffer to working buffer}
  702.     for i := 1 to length(buff1) do
  703.         buff2[i] := upcase(buff1[i]);  {and translate to upper case}
  704.  
  705.     if chkinc(buff2, incflname) and expand_includes then begin
  706.        if pos('.',incflname) = 0 then
  707.           incflname := incflname + '.PAS';
  708.        printline('+++++++++++++++++++++++++++++++++++++',incflname);
  709.        printline('    Including "'+incflname+'"', incflname);
  710.        printline('+++++++++++++++++++++++++++++++++++++',incflname);
  711.        filedate_save := filedate;  {save filedate & filetime for}
  712.        filetime_save := filetime;  {main file                   }
  713.        listit(incflname);
  714.        filedate := filedate_save;  {restore}
  715.        filetime := filetime_save;
  716.        printline('-------------------------------------',incflname);
  717.        printline('    End of    "'+incflname+'"', incflname);
  718.        printline('-------------------------------------',incflname);
  719.        linecnt := linecnt - 1;
  720.     end;  {include file check}
  721.  
  722.     if copy(buff2,1,5) = '{.L-}' then begin
  723.        print := false;
  724.        if length(buff2) = 5 then
  725.           linecnt := linecnt - 1;
  726.     end;
  727.  
  728.     if copy(buff2,1,5) = '{.L+}' then begin
  729.        print := true;
  730.        if length(buff2) = 5 then
  731.           linecnt := linecnt - 1;
  732.     end;
  733.  
  734.     if (copy(buff2,1,7)='{.PAGE}') or (Copy(buff2,1,5)='{.PA}') then begin
  735.        print_head := true;
  736.        if length(buff2) = 7 then
  737.           linecnt := linecnt - 1;
  738.     end;
  739.  
  740.     if length(buff2) > 0 then
  741.        linecnt := linecnt + 1;
  742.  
  743.     buff2 := concat('  ', buff2, '      ');  {add on some working space}
  744.     for i := 1 to length(buff2) - 6 do begin
  745.         tmp := copy(buff2, i, 7);
  746.         if not literal then begin     {possible to find comment delim}
  747.            {determine if comment area delim}
  748.            if tmp[1] in ['{', '}', '(', '*'] then begin
  749.                if (tmp[1] = '{') or (copy(tmp,1,2)='(*') then
  750.                  kcount := succ(kcount);  {count comment opens}
  751.                if (tmp[1] = '}') or (copy(tmp,1,2)='*)') then
  752.                  kcount := pred(kcount);  {un-count comment closes}
  753.            end;
  754.         end;
  755.  
  756.         if kcount = 0 then begin  {we aren't in a comment area}
  757.             if tmp[1] = chr(39) then
  758.               literal := not literal;   {toggle literal flag}
  759.             if not literal then begin
  760.               if ((not Word_switch) and
  761.                        (buff2[i] in ['A'..'Z','a'..'z'])) then begin
  762.                  Word_switch := true;
  763.                  wordchk := '';
  764.               end;
  765.               if word_switch then
  766.                  if (buff2[i] in ['A'..'Z','a'..'z','0'..'9','_']) then
  767.                     wordchk := concat(wordchk,upcase(Buff2[i]))
  768.                  else begin
  769.                     word_switch := false;
  770.                     if ParmR then
  771.                        BuildXref
  772.                     else begin
  773.                        if not find_in_reserve(wordchk) then BuildXref;
  774.                     end;
  775.                  end;
  776.             end;
  777.             if not literal and (tmp[2] in ['B','C','E']) then begin
  778.                if (tmp=' BEGIN ') or (copy(tmp,1,6)=' CASE ') then begin
  779.                  bcount := succ(bcount);  {count BEGIN}
  780.                  i := i + 5;              {skip rest of begin}
  781.                end;
  782.                if (copy(tmp,1,4) = ' END') and
  783.                   (tmp[5] in ['.', ' ', ';']) and
  784.                    (bcount > 0) then begin
  785.                     bcount := pred(bcount);   {un-count for END}
  786.                     i := i + 4;
  787.                end;
  788.             end;  {if not literal}
  789.         end;  { if kcount = 0 }
  790.     end;  { for i := }
  791. end;  {SCAN_LINE}
  792.  
  793. {.page}
  794. Procedure ListIt;
  795. var infile : text;
  796. begin
  797.    assign(infile, filename);
  798.    {$I-} reset(infile) {$I+} ;
  799.    if IOresult <> 0 then begin
  800.       writeln ('File ',filename,' not found.');
  801.       halt;
  802.    end;
  803.    WhenCreated(filedate,filetime,infile);
  804.       print_heading(filename);
  805.       while not eof(infile) do begin
  806.          readln(infile, buff1);
  807.          scan_line;
  808.          if print_head then
  809.             print_heading(filename);
  810.          if print and (not print_head) then begin
  811.             if length(buff1) > 0 then
  812.                writeln(listfil,linecnt : 4, bcount : 3, ' ', buff1)
  813.             else
  814.                writeln(listfil,'        ',buff1);
  815.             linect := succ(linect);
  816.             if linect > maxline then begin
  817.                print_heading(filename);
  818.             end;
  819.          end;
  820.          print_head := false;
  821.       end;     {while not eof}
  822. end; {ListIt}
  823.  
  824. {.page}
  825. Procedure ListXref;
  826. Var   x, y: Integer;
  827. Begin
  828.      Print_Xref := True;
  829.      Print_heading(fnam);
  830.      FOR FirstNdx := 0 to 26 do begin
  831.         CurrWord := FirstWord[FirstNdx];
  832.         while CurrWord <> Nil Do Begin
  833.            Write(listfil,CurrWord^.XrefWord:20);
  834.            x := 0;
  835.            CurrNum := CurrWord^.FirstNum;
  836.            while CurrNum <> Nil do begin
  837.               if X < 10 then begin
  838.                  Write(listfil,CurrNum^.XrefNum:5);
  839.                  x := x + 1;
  840.               end
  841.               else begin
  842.                  Writeln(listfil);
  843.                  Linect := linect + 1;
  844.                  if linect>maxline then Print_heading(fnam);
  845.                  Write(listfil,' ':20,CurrNum^.XrefNum:5);
  846.                  x := 0;
  847.               end;
  848.               CurrNum := CurrNum^.NextNum;
  849.            end;
  850.            writeln(listfil);
  851.            Linect := linect+1;
  852.            if linect > Maxline then Print_heading(fnam);
  853.            CurrWord := CurrWord^.NextWord;
  854.         end;
  855.      end;
  856. end;
  857. {.page}
  858.  
  859. begin {main procedure}
  860.      Mark(heaptop);
  861.      DoneFlag := FALSE;
  862.      getdate(sysdate);
  863.      gettime(systime);
  864.      First := TRUE;
  865.      expand_includes := false;       {default settings}
  866.      print := true;  initprt := FALSE;
  867.      ParmC := FALSE; ParmR := FALSE; ParmX := FALSE; CmdParm := FALSE;
  868.      expand_includes := FALSE;
  869.      pageno := 0;
  870.  
  871.   repeat {forever}
  872.      Release(heaptop);
  873.      for FirstNdx := 0 to 26 do
  874.          FirstWord[FirstNdx] := nil;
  875.      ClrScr;
  876.      GotoXY(2, 2);
  877.      writeln('TURBO Pascal Formatted Listing');
  878.      GotoXY(2, 4);
  879.      get_in_file;      {file to list}
  880.      offset := 23 - length(fnam);
  881.      get_out_file;     {where to list it}
  882.      pageno := 0;
  883.      linect := 1;      {output line counter}
  884.      kcount := 0;
  885.      linecnt := 0;
  886.      bcount := 0;
  887.      print_head := false;
  888.      Print_xref := False;
  889.      word_switch:= False;
  890.      listit(fnam);
  891.      Listxref;
  892.      if CmdParm then
  893.         DoneFlag := TRUE
  894.      else begin
  895.         writeln;
  896.         write('HIT ANY KEY TO CONTINUE ');  {allow op to see end
  897.                                                   of listing}
  898.         getchar(c);
  899.      end;
  900.   until DoneFlag;
  901.   if not ParmC then begin
  902.      write(listfil,ff);
  903.      if ParmX then write(listfil,PostFix);
  904.   end;
  905.   Close(listfil);
  906.   HALT;
  907. end.  {main procedure}
  908.