home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / PASCAL / MADTRB11.ZIP / BLIST.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1985-08-05  |  8.6 KB  |  243 lines
  1. PROGRAM BLIST;
  2. {
  3. Source code list program for Turbo Pascal programs.
  4.  
  5. Source: "BLIST: A Turbo Pascal Source Code Lister", TUG Lines Volume I, Issue 2
  6. Author: Phillip N. Nickell
  7. Application: CP/M-80  (Modified for PC-DOS,MS-DOS)
  8. }
  9.  
  10. VAR
  11.   BUFF1   : STRING[135];                   { INPUT LINE BUFFER }
  12.   LISTFIL : TEXT;                          { FIB FOR LST: OR CON: OUTPUT}
  13.   INFILE  : TEXT;                          { FIB FOR INPUT FILE }
  14.   BCOUNT  : INTEGER;                       { BEGIN/END COUNTER }
  15.   KCOUNT  : INTEGER;                       { COMMENT COUNTER }
  16.   LINECT  : INTEGER;                       { OUTPUT FILE LINE COUNTER }
  17.   COUNT_BE,                                { COUNT BEG/END PAIRS FLAG }
  18.   PERFSKIP: BOOLEAN;                       { SKIP PAPER PERFS FLAGS }
  19.  
  20. CONST
  21.   FIRST   : BOOLEAN = TRUE;                         { TRUE WHEN PROG IS RUN }
  22.  
  23. { to customize code for your printer and desires - adjust the next two items }
  24.  
  25.   MAXLINE = 54;              { max # of lines on page when in PERFSKIP mode }
  26.   SKIPLINE = 1;   { # of lines to skip at top of form when in PERFSKIP mode }
  27.  
  28.   CR = #13;
  29.   LF = #10;
  30.   FF = #12;
  31.  
  32. PROCEDURE CLEAN;                           { CLEARS SCRN & POSITIONS CURSOR }
  33.  BEGIN
  34.   CLRSCR;
  35.   GOTOXY(1,10);
  36.  END;
  37.  
  38. PROCEDURE LINES(X: INTEGER);    { PUTS X AMMOUNT OF BLANK LINES TO OUTPUT FILE }
  39.   VAR N: INTEGER;
  40.  BEGIN
  41.   FOR N := 1 TO X DO
  42.     WRITELN(LISTFIL);
  43.  END;
  44.  
  45.  
  46. (* GET-IN-FILE PROC : When program is first run will check for a file name
  47.    passed by DOS, and will try to open that file. If no name is passed, will
  48.    ask operator for a file name to open.  Proc will tell operator if file
  49.    doesn't exist and will allow multiple retrys.  On 2nd and later executions,
  50.    proc will not check for DOS passed file name. In all cases, proc will
  51.    assume a file type of .PAS if file type is not specified.
  52.    PROGRAM EXIT from this proc when a null string is entered in response to
  53.    a file name request.
  54. *)
  55. PROCEDURE GET_IN_FILE;                    { GETS INPUT FILE NAME }
  56.   VAR FNAM    : STRING[14];                    { IN FILE NAME }
  57.       PARM    : STRING[14] ABSOLUTE CSEG:$0081;  { PASSED FILE NAME IF ANY }
  58.       PARMLTH : BYTE ABSOLUTE CSEG:$0080;        { CPM PASSED LTH OF PARM  }
  59.       EXISTING: BOOLEAN;
  60. BEGIN
  61.  REPEAT
  62.    IF (PARMLTH IN [1..14]) AND FIRST THEN  { POSSIBLE FILE NAME WAS PASSED }
  63.     FNAM := COPY(PARM,1,PARMLTH-1)       { MOVE POSSIBLE FILE NAME TO FNAM }
  64.    ELSE
  65.     BEGIN                            { NOTHING WAS PASSED OR NOT FIRST TRY }
  66.      CLEAN;
  67.      WRITE('ENTER FILE NAME TO LIST or <cr> to EXIT  ');
  68.      READLN(FNAM);
  69.     END;
  70.  
  71.    IF FNAM = '' THEN HALT;                     (* ******* EXIT ******** *)
  72.    IF POS('.',FNAM) = 0 THEN                         { FILE TYPE GIVEN ? }
  73.      FNAM := CONCAT(FNAM,'.PAS');            { FILE DEFAULT TO .PAS TYPE }
  74.  
  75.    FIRST := FALSE;                       { GET PASSED FILENAME ONLY ONCE }
  76.    ASSIGN( INFILE, FNAM );          { SET UP FILE CTL BLK FOR INPUT FILE }
  77.     {$I-}
  78.    RESET(INFILE);                         {  CHECK FOR EXISTANCE OF FILE }
  79.     {$I+}
  80.    EXISTING := (IORESULT = 0);                      { TRUE IF FILE FOUND }
  81.    IF NOT EXISTING THEN
  82.     BEGIN
  83.      CLEAN;
  84.      WRITELN('FILE DOESN''T EXIST');        { TELL OPERATOR THE SAD NEWS }
  85.      DELAY(700);                                   { AND LET HIM READ IT }
  86.     END;
  87.   UNTIL EXISTING;                                     {UNTIL FILE EXISTS }
  88. END; { OF GET_IN_FILE PROCEDURE }
  89.  
  90.  
  91. (* GET-OUT-FILE procedure asks operator to select output to console device
  92.    or list device, and then assigns and resets a file control block to the
  93.    appropriate device.  'C' or 'P' is only correct response, and multiple
  94.    retrys are allowed.
  95. *)
  96. PROCEDURE GET_OUT_FILE;
  97.   VAR C: CHAR;
  98. BEGIN
  99.   REPEAT  {UNTIL GOOD SELECTION }
  100.    CLEAN;
  101.    WRITE('OUTPUT LISTING TO (C)ONSOLE OR (P)RINTER ?  ');
  102.    READ(KBD,C); C := UPCASE(C);
  103.   UNTIL C IN ['C','P'];
  104.  
  105.   WRITELN;
  106.   IF C = 'C' THEN
  107.     ASSIGN (LISTFIL,'CON:')
  108.    ELSE
  109.     ASSIGN (LISTFIL,'LST:');
  110.   RESET(LISTFIL);
  111. END;
  112.  
  113. (* GET-OPTIONS procedure asks operator if count of begin/end pairs is
  114.    desired, and also if skip over paper perforations is desired. Proc
  115.    will set or clear the COUNT_BE flag and the PERFSKIP flag.
  116. *)
  117. PROCEDURE GET_OPTIONS;
  118.    VAR C: CHAR;
  119.  BEGIN
  120.   REPEAT
  121.    CLEAN;
  122.    WRITE('COUNT OF BEGIN/END PAIRS  (Y/N) ?  ');
  123.    READ(KBD,C); C := UPCASE(C);
  124.   UNTIL C IN ['Y','N'];
  125.   IF C = 'Y' THEN COUNT_BE := TRUE ELSE COUNT_BE := FALSE;
  126.  
  127.   REPEAT
  128.    CLEAN;
  129.    WRITE('SKIP PRINTER PERFORATIONS (Y/N) ? ');
  130.    READ(KBD,C); C := UPCASE(C);
  131.   UNTIL C IN ['Y','N'];
  132.   IF C = 'Y' THEN PERFSKIP := TRUE ELSE PERFSKIP := FALSE;
  133.  END; { GET_OPTIONS }
  134.  
  135.  
  136. (* SCAN_LINE procedure scans one line of Turbo Pascal source code looking
  137.    for BEGIN/END pairs, CASE/END pairs, LITERAL fields and COMMENT fields.
  138.    BCOUNT is begin/end and case/end counter. KCOUNT is comment counter.
  139.    Begin/case/ends are only valid outside of comment fields and literal
  140.    constant fields (KCOUNT = 0 and NOT LITERAL).
  141.  
  142.    Some of the code in the SCAN_LINE procedure appears at first glance
  143.    to be repetitive and/or redundant, but was added to speed up the process
  144.    of scanning each line of source code. The program now spits out listings
  145.    much faster than my 160cps printer.
  146. *)
  147. PROCEDURE SCAN_LINE;
  148.    VAR LITERAL : BOOLEAN;                      { TRUE IF IN LITERAL FIELD }
  149.        TMP     : STRING[7];                              { TEMP WORK AREA }
  150.        I       : INTEGER;                           { LOOP VARIABLE INDEX }
  151.        BUFF2   : STRING[135];                       { WORKING LINE BUFFER }
  152.  
  153.   BEGIN
  154.    LITERAL := FALSE;
  155.  
  156.    BUFF2[0] := BUFF1[0];            { COPY INPUT BUFFER TO WORKING BUFFER }
  157.    FOR I := 1 TO LENGTH(BUFF1) DO               { AND TRANSLATE TO UPCASE }
  158.     BUFF2[I] := UPCASE(BUFF1[I]);
  159.  
  160.    BUFF2 := CONCAT(' ',BUFF2,'      ');       { ADD ON SOME WORKING SPACE }
  161.  
  162.    FOR I := 1 TO LENGTH(BUFF2)-6 DO
  163.     BEGIN
  164.      TMP := COPY(BUFF2,I,7);
  165.      IF NOT LITERAL THEN
  166.       BEGIN
  167.       IF TMP[1] IN ['{','}','(','*'] THEN {MAY BE COMMENT AREA DELIM}
  168.        BEGIN
  169.         IF (TMP[1] = '{') OR (COPY(TMP,1,2) = '(*') THEN
  170.            KCOUNT := SUCC(KCOUNT);                    { COUNT COMMENT OPENS }
  171.          IF (TMP[1] = '}') OR (COPY(TMP,1,2) = '*)') THEN
  172.            KCOUNT := PRED(KCOUNT);                { UN-COUNT COMMENT CLOSES }
  173.         END;
  174.       END;
  175.  
  176.      IF KCOUNT = 0 THEN                     { WE AREN'T IN A COMMENT AREA }
  177.       BEGIN
  178.        IF TMP[1] = CHR(39) THEN
  179.         LITERAL := NOT LITERAL;                     { TOGGLE LITERAL FLAG }
  180.  
  181.        IF NOT LITERAL AND (TMP[2] IN ['B','C','E']) THEN
  182.         BEGIN                                 { ITS A POSBLE BEGIN OR END }
  183.          IF (TMP =  ' BEGIN ') OR (COPY(TMP,1,6) = ' CASE ') THEN
  184.           BEGIN
  185.            BCOUNT := SUCC(BCOUNT);                          { COUNT BEGIN }
  186.            I := I+ 5;                                { SKIP REST OF BEGIN }
  187.           END;
  188.          IF (COPY(TMP,1,4) = ' END') AND (TMP[5] IN ['.',' ',';']) THEN
  189.           BEGIN
  190.            BCOUNT := PRED(BCOUNT);                     { UN-COUNT FOR END }
  191.            I := I + 4;
  192.           END;
  193.         END; {IF NOT LITERAL }
  194.       END; { IF KCOUNT = 0 }
  195.     END; { FOR I := }
  196.   END; {SCAN_LINE}
  197.  
  198.  
  199.  
  200. BEGIN  { MAIN PROCEDURE }
  201.  
  202.   REPEAT {FOREVER}
  203.    GET_IN_FILE;      { FILE TO LIST }
  204.    GET_OUT_FILE;     { WHERE TO LIST IT }
  205.    GET_OPTIONS;      { HOW TO LIST IT }
  206.    LINES(1);         { 1 BLANK LINES ON OUTPUT FILE 0}
  207.    LINECT := 1;      { OUTPUT LINE COUNTER }
  208.  
  209.    IF COUNT_BE THEN  { OPTION WAS TO COUNT THE BEGIN/END PAIRS }
  210.     BEGIN
  211.      KCOUNT := 0;
  212.      BCOUNT := 0;
  213.      WRITELN(LISTFIL,' C  B');              { counter headings }
  214.     END;
  215.  
  216.    WHILE NOT EOF(INFILE) DO
  217.     BEGIN
  218.      READLN(INFILE, BUFF1);
  219.      IF COUNT_BE THEN
  220.       BEGIN
  221.        SCAN_LINE;
  222.        WRITELN(LISTFIL,KCOUNT:2,BCOUNT:3,'  ',BUFF1);
  223.       END
  224.       ELSE
  225.        WRITELN(LISTFIL,BUFF1);
  226.  
  227.      IF PERFSKIP THEN
  228.       BEGIN
  229.        LINECT := SUCC(LINECT);
  230.        IF LINECT > MAXLINE  THEN
  231.         BEGIN
  232.          WRITE(LISTFIL,FF);   { TOP OF FORM }
  233.          LINES(SKIPLINE);
  234.          LINECT := 1;
  235.          WRITELN(LISTFIL,' C  B');
  236.         END;        { LINECT > MAXLINE }
  237.       END;       { IF PERFSKIP }
  238.     END;       { WHILE NOT EOF }
  239.  WRITE(CR,LF,'HIT ANY KEY TO CONTINUE ');  { allow op to see end of listing }
  240.  READ(KBD,BCOUNT);
  241.  UNTIL FALSE { REPEAT FOREVER - EXIT IS IN GET_IN_FILE PROCEDURE }
  242. END.       { MAIN PROC }
  243.