home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / PASCAL / MADTRB33.ZIP / BLIST.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1986-02-10  |  7.7 KB  |  227 lines
  1. {$C-}
  2.  
  3. PROGRAM BList;
  4.  
  5. { TURBO PASCAL SOURCE CODE LISTER AND BEGIN-END COUNTER PROGRAM }
  6.  
  7. { Prints a listing to console or printer of a TURBO PASCAL source code with
  8.   optional display of comment counter and begin/end counter, and also optional
  9.   display skip of paper perforations.  Accepts file name passed by CP/M or
  10.   from operator input of file to list. }
  11.  
  12. { This version of the code is specific to CP/M-80 because the GET_IN_FILE
  13.   procedure looks for a parameter passed by CP/M at absolute location $80. The
  14.   procedure could be modified for other operating systems, or not to accept
  15.   passed parameters at all. }
  16.  
  17. { I declare that this code is released to the PUBLIC DOMAIN as of July 1, 1984
  18.                                        Phillip M. Nickell                     }
  19.  
  20. { Modified Sept. 1, 1984 by Marvin Landis
  21.   Record/end combination is now handled correctly. }
  22.  
  23. { Modified 2/10/86 by Doug Stevens.
  24.   Changed single key input statements to be generic.
  25.   Added code (commented out) to get parameter under MS-DOS.
  26.   See Get_In_File. }
  27.  
  28. VAR Buff1: STRING[135];                       { Input line buffer }
  29.     ListFil: TEXT;                            { Fib for LST: or CON: output }
  30.     InFile: TEXT;                             { Fib for input file }
  31.     BCount,KCount,LineCt: INTEGER;            { Counters }
  32.     Count_Be,PerfSkip: BOOLEAN;               { Count begin/end and skip }
  33.  
  34. CONST First: BOOLEAN = TRUE;                  { True when program is run }
  35.  
  36. { To customize code for your printer and desires - adjust the next two items }
  37.  
  38.       MaxLine = 60;      { max # of lines on page when in PERFSKIP mode }
  39.       SkipLine = 2;      { # of lines to skip at top of form }
  40.  
  41.       CR = #13;
  42.       LF = #10;
  43.       FF = #12;
  44.  
  45. Procedure Clean;      { Clears screen and positions cursor }
  46. BEGIN
  47.   ClrScr;
  48.   GoToXY(1,10);
  49. END;
  50.  
  51. Procedure Lines(X: Integer);   { Puts X amount of blank lines to output file }
  52. Var N: Integer;
  53. BEGIN
  54.   For N:= 1 To X Do
  55.     Writeln(ListFil);
  56. END;
  57.  
  58. { GET_IN_FILE PROCEDURE : When program is first run, it will check for a file
  59.   name passed by CP/M and will try to open that file.  If no name is passed,
  60.   it will ask operator for a file name to open.  Proc will tell operator if
  61.   file doesn't exist and will allow multiple retrys.  On second and later
  62.   executions, proc will not check for CP/M passed file name.  In all cases
  63.   proc will assume a file type of .PAS if file type is not specified.  Exit
  64.   from the program occurs when a null string is entered in response to a file
  65.   name request. }
  66.  
  67. Procedure Get_In_File;                 { Gets input file name }
  68. Var FNam: String[14];                  { Input file name }
  69.     Parm: String[14] Absolute $81;     { Passed file name if any }
  70.     ParmLth: Byte Absolute $80;        { CP/M passed length of Parm }
  71.     Existing: Boolean;
  72.  
  73. (*  Parm: String[14] Absolute Cseg:$80; {Replace Parm and ParmLth declarations}
  74.     ParmLth: Byte Absolute Cseg:$80;    {with these for MS-DOS systems.} *)
  75.  
  76. BEGIN
  77.   Repeat                               { Until file exists }
  78.     If (ParmLth In [1..14]) And First Then
  79.       FNam:= Copy(Parm,1,ParmLth - 1)
  80.     Else Begin
  81.       Clean;
  82.       Write('Enter file name to list or <CR> to exit: ');
  83.       Readln(FNam);
  84.     End;
  85.     If FNam = '' Then Halt;
  86.     If Pos('.',FNam) = 0 Then
  87.       FNam:= Concat(FNam,'.PAS');      { File default to .PAS type }
  88.     First:= False;
  89.     Assign(InFile,FNam);
  90.     {$I-}
  91.     Reset(InFile);
  92.     {$I+}
  93.     Existing:= (IOResult = 0);
  94.     If Not Existing Then Begin
  95.       Clean;
  96.       Writeln('File does not exist.');
  97.       Delay(700);
  98.     End;
  99.   Until Existing;
  100. END;   { Get_In_File }
  101.  
  102. { GET_OUT_FILE procedure : Asks operator to select output to console device
  103.   or list device, and then assigns and resets a file control block to the
  104.   appropriate device.  'C' or 'P' are the only correct responses, and
  105.   multiple retrys are allowed. }
  106.  
  107. Procedure Get_Out_File;
  108. Var C: Char;
  109. BEGIN
  110.   Repeat                            { Until good selection }
  111.     Clean;
  112.     Write('Output listing to (C)onsole or (P)rinter? ');
  113.     Read(Kbd,C); C := UpCase(C);
  114.   Until C In ['C','P'];
  115.   Writeln;
  116.   If C = 'C' Then
  117.     Assign(ListFil,'CON:')
  118.   Else
  119.     Assign(ListFil,'LST:');
  120.   Reset(ListFil);
  121. END;  { Get_Out_File }
  122.  
  123. { GET_OPTIONS procedure : Asks operator if count of begin/end pairs is desired,
  124.   and also if skip over paper perforations is desired.  Proc will set or clear
  125.   the Count_Be flag and the PerfSkip flag. }
  126.  
  127. Procedure Get_Options;
  128. Var C: Char;
  129. BEGIN
  130.   Repeat
  131.     Clean;
  132.     Write('Count of BEGIN/END pairs (Y/N)? ');
  133.     Read(Kbd,C); C := UpCase(C);
  134.   Until C In ['Y','N'];
  135.   If C = 'Y' Then Count_Be:= True
  136.   Else Count_Be:= False;
  137.   Repeat
  138.     Clean;
  139.     Write('Skip printer perforations (Y/N)? ');
  140.     Read(Kbd,C); C := UpCase(C);
  141.   Until C In ['Y','N'];
  142.   If C = 'Y' Then PerfSkip:= True
  143.   Else PerfSkip:= False;
  144. END;  { Get_Options }
  145.  
  146. { SCAN_LINE procedure : Scans one line of Turbo Pascal source code looking
  147.   for begin/end pairs, case/end pairs, literal fields and comment fields.
  148.   BCount is begin/end and case/end counter.  KCount is comment counter.
  149.   Begin/case/ends are only valid outside of comment fields and literal
  150.   constant fields (KCount = 0 and NOT LITERAL).  Some of the code in this
  151.   procedure appears at first glance to be repetitive and/or redundant, but
  152.   was added to speed up the process of scanning each line of source code.
  153.   The program now spits out listings much faster than a 160 cps printer. }
  154.  
  155. Procedure Scan_Line;
  156. Var Literal: Boolean;               { True if in literal field }
  157.     Tmp: String[8];                 { Temp work area }
  158.     Buff2: String[135];             { Working line buffer }
  159.     I: Integer;
  160. BEGIN
  161.   Literal:= False;
  162.   Buff2[0]:= Buff1[0];      { Copy input buffer into working buffer }
  163.   For I:= 1 to Length(Buff1) Do
  164.     Buff2[I]:= UpCase(Buff1[I]);
  165.   Buff2:= Concat(' ',Buff2,'       ');   { Add on some working space }
  166.   For I:= 1 to Length(Buff2) - 7 Do Begin
  167.     Tmp:= Copy(Buff2,I,8);
  168.     If Not Literal Then Begin
  169.       If Tmp[1] In ['{','}','(','*'] Then Begin
  170.         If (Tmp[1] = '{') Or (Copy(Tmp,1,2) = '(*') Then
  171.           KCount:= Succ(KCount);
  172.         If (Tmp[1] = '}') Or (Copy(Tmp,1,2) = '*)') then
  173.           KCount:= Pred(KCount);
  174.       End;
  175.     End;
  176.     If KCount = 0 Then Begin
  177.       If Tmp[1] = Chr(39) Then Literal:= Not Literal;
  178.       If Not Literal And (Tmp[2] In ['B','C','E','R']) Then Begin
  179.         If (Copy(Tmp,1,7) = ' BEGIN ') Or (Copy(Tmp,1,6) = ' CASE ') Or
  180.         (Tmp = ' RECORD ') Then Begin
  181.           BCount:= Succ(BCount);
  182.           I:= I + 5;
  183.         End;
  184.         If (Copy(Tmp,1,4) = ' END') And (Tmp[5] In ['.',' ',';']) Then Begin
  185.           BCount:= Pred(BCount);
  186.           I:= I + 4;
  187.         End;
  188.       End;
  189.     End;
  190.   End;
  191. END;  { Scan_Line }
  192.  
  193. BEGIN
  194.   Repeat                     { Forever }
  195.     Get_In_File;
  196.     Get_Out_File;
  197.     Get_Options;
  198.     Lines(1);
  199.     Linect:= 1;
  200.     If Count_Be Then Begin
  201.       KCount:= 0;
  202.       BCount:= 0;
  203.       Writeln(ListFil,' C  B');
  204.     End;
  205.     While Not EOF(InFile) Do Begin
  206.       Readln(InFile,Buff1);
  207.       If Count_Be Then Begin
  208.         Scan_Line;
  209.         Writeln(ListFil,KCount:2,BCount:3,'  ',Buff1);
  210.       End Else
  211.         Writeln(ListFil,Buff1);
  212.       If PerfSkip Then Begin
  213.         LineCt:= Succ(LineCt);
  214.         If LineCt > MaxLine Then Begin
  215.           Write(ListFil,FF);
  216.           Lines(SkipLine);
  217.           LineCt:= 1;
  218.           If Count_Be Then Writeln(ListFil,' C  B');
  219.         End;
  220.       End;
  221.     End;
  222.     Write(CR,LF,'Hit any key to continue...');
  223.     Repeat Until KeyPressed;
  224.   Until False;     { Exit is in Get_In_File procedure }
  225. END.
  226.  
  227.