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