Programmer 7500/MAX_PROGRAMMERS.iso/PASCAL/TURBO5.ZIP/PASLIST.PAS

Pascal/Delphi Source File | 1986-12-26 | 15.9 KB | 533 lines

PROGRAM PASLIST (INPUT,OUTPUT,LISTFILE,INCFILE);
{  ***************************************************************************
   Read Turbo PASCAL source and list with date and time,
   index by page no. at end.
   Includes, Procedures, and Functions may be indented but must be the
   first non-blank on the line they occupy.  Includes are automatic but may
   not be nested.     Overlay procedures and functions are also identified.
   Written by Todd Merriman - Future Communications, Atlanta, GA - 1984.
   (c) 1984 - Future Communications, published in the Public Domain for
   non-commercial use.  This source is probably too large to compile without
   breaking down into includes;  all the modules have been assembled into
   one file for distribution.
   ***************************************************************************
}
{--!--!--!--!--!--!--!--!--!--!--!--!--!--!--!--!--!--!--!--!--!--!--!--!--!---
}
CONST
   VER                      = '1.4';
   PAGELEN                  = 66;
   TOPMARG                  = 2;
   BOTMARG                  = 2;
   HEADMARG                 = 2;
   LEFTMARG                 = 0;
   RIGHTMARG                = 0;
   PAPERWIDTH               = 80;
   MAX                      = 255;
   MATCH0                   = 'PROCEDURE';
   MATCH1                   = 'FUNCTION';
   MATCH2                   = 'OVERLAY';
   LINELEN                  = 255;
   OFF                      = 45;
   HEADING                  = 'PASLIST by Future Communications';

LABEL
   EXIT;

TYPE
   STRING255                = STRING [LINELEN];
   STRING14                 = STRING [14];
   STRING8                  = STRING [8];

VAR
   I,J                      : INTEGER;
   LISTFILE,INCFILE         : TEXT;
   LISTNAME,INCNAME,HEADNAME: STRING14;
   PAGENO,POINT             : INTEGER;
   PROCPAGE                 : ARRAY [0..MAX] OF INTEGER;
   PROCNAME                 : ARRAY [0..MAX] OF STRING [35];
   LINENO                   : INTEGER;
   TESTLINE                 : STRING [LINELEN];
   TOP,INCLUDE              : BOOLEAN;
   DRIVE                    : STRING [2];
   FILL                     : STRING [40];
   ABORT                    : BOOLEAN;
   OK                       : BOOLEAN;


FUNCTION DATE : STRING8;
{  **************************************************************************
   Read date from reserved memory location (CP/M-80)
   **************************************************************************
}
VAR
   TEMP     : ARRAY [0..2] OF BYTE ABSOLUTE $0010;
   I        : BYTE;
   STR      : STRING8;

BEGIN { DATE }

   STR      := '';
   FOR I := 0 TO 2 DO
   BEGIN
      STR := STR + CHR (((TEMP [I] AND $F0) SHR 4) + $30);
      STR := STR + CHR ((TEMP [I] AND $0F)+ $30);
      IF I < 2 THEN STR := STR + '/';
   END; { FOR }
   DATE := STR;

END; { DATE }


FUNCTION TIME : STRING8;
{  **************************************************************************
   Read time from reserved memory location (CP/M-80)
   **************************************************************************
}
VAR
   TEMP     : ARRAY [0..2] OF BYTE ABSOLUTE $0013;
   I        : BYTE;
   STR      : STRING8;

BEGIN { TIME }

   STR      := '';
   FOR I := 0 TO 2 DO
   BEGIN
      STR := STR + CHR (((TEMP [I] AND $F0) SHR 4) + $30);
      STR := STR + CHR ((TEMP [I] AND $0F) + $30);
      IF I < 2 THEN STR := STR + ':';
   END; { FOR }
   TIME := STR;

END; { TIME }


PROCEDURE CHECKDATIME (VAR GOOD : BOOLEAN);
{  ***************************************************************************
   See if valid date and time in memory
   ***************************************************************************
}
VAR
   CHECK,CODE    : INTEGER;

BEGIN { CHECKDATIME }
   GOOD := TRUE;
   VAL (COPY (DATE, 1, 2), CHECK, CODE);
   IF (CHECK > 12) OR
      (CHECK < 1) OR
      (CODE > 0) THEN
         GOOD := FALSE;
   VAL (COPY (TIME, 1, 2), CHECK, CODE);
   IF (CHECK > 23) OR
      (CODE > 0) THEN
         GOOD := FALSE;
END; { CHECKDATIME }


PROCEDURE CONVERT (VAR BIG : STRING8; VAR LITTLE : BYTE);
{  ***************************************************************************
   Convert a character string to BCD numbers
   ***************************************************************************
}
BEGIN { CONVERT }
   LITTLE := ((ORD (BIG [1]) - $30) SHL 4) OR (ORD (BIG [2]) - $30);
   DELETE (BIG,1,2);
   IF LENGTH (BIG) > 0 THEN DELETE (BIG,1,1);      { get the separator }
END; { CONVERT }


PROCEDURE SETDATE;
{  ***************************************************************************
   Prompt for date and set in memory
   ***************************************************************************
}
CONST
   DIGITS   : SET OF CHAR = ['0'..'9'];

VAR
   TEMP     : ARRAY [0..2] OF BYTE ABSOLUTE $0010;
   I        : BYTE;
   STR      : STRING8;

BEGIN { SETDATE }
   WRITE ('Enter date [MM/DD/YY] ');
   READLN (STR);
   IF LENGTH (STR) > 0 THEN
   BEGIN
      FOR I := 0 TO 2 DO
      BEGIN
         IF (STR [1] IN DIGITS) AND (NOT (STR [2] IN DIGITS)) THEN
            STR := '0' + STR;          { insure leading zeros }
         CONVERT (STR,TEMP [I]);
      END; { FOR }
   END; { IF }
END; { SETDATE }


PROCEDURE SETIME;
{  ***************************************************************************
   Prompt for time and set in memory
   ***************************************************************************
}
CONST
   DIGITS   : SET OF CHAR = ['0'..'9'];

VAR
   TEMP     : ARRAY [0..2] OF BYTE ABSOLUTE $0013;
   I        : BYTE;
   STR      : STRING8;

BEGIN { SETIME }
   WRITE ('Enter time [HH:MM] ');
   READLN (STR);
   IF LENGTH (STR) > 0 THEN
   BEGIN
      INSERT (':00',STR,LENGTH (STR)+1);             { add seconds }
      FOR I := 0 TO 2 DO
      BEGIN
         IF (STR [1] IN DIGITS) AND (NOT (STR [2] IN DIGITS)) THEN
            STR := '0' + STR;          { insure leading zeros }
         CONVERT (STR,TEMP [I]);
      END; { FOR }
   END; { IF }
END; { SETIME }


FUNCTION CMDLINE: STRING14;
{  ***************************************************************************
   Get command from command line
   ***************************************************************************
}
CONST
   BUF     = $80;

VAR
   I       : INTEGER;
   ST      : STRING14;

BEGIN { CMDLINE }

   ST      := '';
   FOR I:= BUF+2 TO BUF + ORD (MEM [BUF]) DO
   BEGIN
      ST [0] := SUCC (ST [0]);
      ST [ORD (ST [0])] := CHR (MEM [I]);
   END;

   CMDLINE:=ST;

END; { CMDLINE }


FUNCTION UPSTRING (ST : STRING255) : STRING255;
{  ***************************************************************************
   Convert a line to upper case
   ***************************************************************************
}
VAR
   I    : INTEGER;
   TEMP : STRING255;

BEGIN
   TEMP := '';
   IF LENGTH(ST) <> 0
      THEN FOR I:=1 TO LENGTH (ST) DO
         TEMP := TEMP + UPCASE (ST [I]);
   UPSTRING := TEMP;
END; { UPSTRING }


PROCEDURE FIXNAME (VAR FNAME : STRING14);
{  ***************************************************************************
   Insert extension if none supplied
   ***************************************************************************
}
BEGIN
   FNAME := UPSTRING (FNAME);
   IF POS ('.',FNAME) = 0 THEN
   BEGIN
      INSERT ('.PAS',FNAME,LENGTH(FNAME)+1);
   END; { IF }
END; { FIXNAME }


PROCEDURE EMPTYLINE;
{  ***************************************************************************
   Print a line with something in it to show margins
   ***************************************************************************
}
VAR
   I                        : INTEGER;

BEGIN { EMPTYLINE }
   WRITE (LST,'.');
   FOR I := 1 TO 78 - RIGHTMARG - LEFTMARG DO WRITE (LST,' ');
   WRITELN (LST,'.');
END; { EMPTYLINE }


PROCEDURE PAGEHEAD;
{  ***************************************************************************
   Print heading for each page of listing
   ***************************************************************************
}
VAR
   I,J                      : BYTE;

BEGIN { PAGEHEAD }

   WHILE (LINENO >= PAGELEN - BOTMARG) OR (TOP) DO
   BEGIN
      IF NOT TOP THEN WRITE(LST,^L);
      TOP                      := FALSE;
      LINENO                   := 1;
      FOR I := 1 TO TOPMARG DO
      BEGIN
         EMPTYLINE;
         LINENO              := SUCC (LINENO);
      END; { FOR }
      WRITELN (LST,HEADNAME,FILL,TIME,'  ',DATE,FILL,'Page ',PAGENO);
      LINENO                 := SUCC (LINENO);
      FOR I := 1 TO HEADMARG DO
      BEGIN
         IF (INCLUDE) AND (I=1) THEN
         BEGIN
            FOR J := 1 TO 30 DO WRITE (LST,' ');
            WRITELN (LST,'[INCLUDED: ',INCNAME,']');
         END { IF }
         ELSE EMPTYLINE;
         LINENO              := SUCC (LINENO);
      END; { FOR }

      IF EOF (LISTFILE) THEN
      BEGIN
         FOR I := 1 TO 35 DO WRITE (LST,' ');
         WRITELN (LST,'I N D E X');
         WRITELN (LST);
         WRITELN (LST);
         LINENO              := LINENO + 3;
      END; { IF EOF }

      PAGENO                 := SUCC (PAGENO);

   END; { WHILE }

END; { PAGEHEAD }


PROCEDURE TESTREF;
{  ***************************************************************************
   Test for key words at beginning of line
   ***************************************************************************
}
VAR
   K                        : BYTE;            { points to position in line }
   L                        : BYTE;            { points to first non-blank }
   TESTCHAR                 : SET OF CHAR;

BEGIN { TESTREF }

   IF LENGTH (TESTLINE) > 0 THEN
   BEGIN
      TESTLINE := UPSTRING (TESTLINE);
      L := 0;
      REPEAT
         L := L+1;
      UNTIL TESTLINE [L] > ' ';                { may be indented }
                                               { test for keywords }
      TESTCHAR                 := [' ','0'..'9','A'..'Z'];

      IF  (COPY (TESTLINE,L,4) = '{$I ') THEN INCLUDE := TRUE
      ELSE
      IF COPY (TESTLINE,L,LENGTH(MATCH0)) = MATCH0 THEN
      BEGIN
         K                   := LENGTH (MATCH0) + 1;
         PROCNAME [POINT]    := COPY (TESTLINE,L,K);
         REPEAT
            PROCNAME [POINT] := CONCAT (PROCNAME [POINT],
                                COPY (TESTLINE,K+L,1));
            K                := SUCC (K);
         UNTIL NOT (COPY (TESTLINE,K+L,1) IN TESTCHAR);
         PROCPAGE [POINT]    := PAGENO - 1;
         POINT               := SUCC (POINT);
      END { IF }
      ELSE IF COPY (TESTLINE,L,LENGTH(MATCH1)) = MATCH1 THEN
      BEGIN
         K                   := LENGTH (MATCH1) + 1;
         PROCNAME [POINT]    := COPY (TESTLINE,L,K);
         REPEAT
            PROCNAME [POINT] := CONCAT (PROCNAME [POINT],
                                COPY (TESTLINE,K+L,1));
            K                := SUCC (K);
         UNTIL NOT (COPY (TESTLINE,K+L,1) IN TESTCHAR);
         PROCPAGE [POINT]    := PAGENO - 1;
         POINT               := SUCC (POINT);
      END { IF }
      ELSE IF COPY (TESTLINE,L,LENGTH(MATCH2)) = MATCH2 THEN
      BEGIN
         K                   := LENGTH (MATCH2) + 1;
         PROCNAME [POINT]    := COPY (TESTLINE,L,K);
         REPEAT
            PROCNAME [POINT] := CONCAT (PROCNAME [POINT],
                                COPY (TESTLINE,K+L,1));
            K                := SUCC (K);
         UNTIL NOT (COPY (TESTLINE,K+L,1) IN TESTCHAR);
         PROCPAGE [POINT]    := PAGENO - 1;
         POINT               := SUCC (POINT);
     END; { IF }
  END; { IF LENGTH }

END; { TESTREF }


PROCEDURE LISTINC;
{  ***************************************************************************
   List routine for included files
   ***************************************************************************
}
VAR
   K                        : INTEGER;

BEGIN { LISTINC }

   K                        := 5;
   INCNAME                  := '';
   REPEAT
      INCNAME               := CONCAT (INCNAME,COPY (TESTLINE,K,1));
      K                     := SUCC (K);
   UNTIL (COPY (TESTLINE,K,1) < '.') OR (COPY (TESTLINE,K,1) > 'Z');
   PROCNAME [POINT]         := INCNAME;
   PROCPAGE [POINT]         := 0;
   POINT                    := SUCC (POINT);
   INCNAME                  := CONCAT (DRIVE, INCNAME);
   FIXNAME (INCNAME);
   ASSIGN (INCFILE,INCNAME);
   {$I-}
   RESET (INCFILE);
   {$I+}
   IF IORESULT = 0 THEN
   BEGIN
      WRITELN ('> Reading Include File: ',INCNAME);
      WHILE (NOT (EOF (INCFILE) OR ABORT)) DO      { include file }
      BEGIN
         PAGEHEAD;
         READLN (INCFILE,TESTLINE);
         WRITELN (LST,TESTLINE);
         IF KEYPRESSED THEN ABORT := TRUE;
         LINENO              := SUCC (LINENO);
         TESTREF;
      END; { WHILE }
      CLOSE (INCFILE);
      INCLUDE := FALSE;
      WRITELN ('> Reading Main File:    ',LISTNAME);
      PROCNAME [POINT]         := LISTNAME;
      PROCPAGE [POINT]         := 0;
      POINT                    := SUCC (POINT);
   END { IF IORESULT }
   ELSE
   BEGIN
      ABORT := TRUE;
      WRITELN (#7,'? ',INCNAME,' not found');
   END; { ELSE }

END; { LISTINC }

{  ***************************************************************************
}

BEGIN { PASLIST }
   PAGENO   := 1;
   LINENO   := 1;
   POINT    := 0;
   TOP      := TRUE;
   INCLUDE  := FALSE;
   ABORT    := FALSE;
   LISTNAME := '';
   INCNAME  := '';
   HEADNAME := '';
   WRITELN ('---------- ',HEADING,' -----------');
   WRITELN ('             Ver. ',VER);
   WRITELN ('Turbo PASCAL source listing with index');

   LISTNAME := CMDLINE;
   IF LENGTH (LISTNAME) = 0 THEN
   BEGIN
      WRITELN (#7,'Error: No filename specified on command line');
      ABORT := TRUE;
      GOTO EXIT;
   END; { IF }
   FIXNAME (LISTNAME);
   CHECKDATIME (OK);
   IF NOT OK THEN
   BEGIN
     SETDATE;
     SETIME;
   END; { IF }
   ASSIGN (LISTFILE,LISTNAME);
   {$I-}
   RESET (LISTFILE);
   {$I+}
   IF IORESULT <> 0 THEN
   BEGIN
      WRITELN (#7,'Error: ',LISTNAME,' does not exist');
      ABORT := TRUE;
      GOTO EXIT;
   END;
   WRITELN (CON,'Source File:            ',LISTNAME);

   IF POS (':',LISTNAME) = 0 THEN
   BEGIN
      HEADNAME       := LISTNAME;
      DRIVE          := '';
   END { IF }
   ELSE
   BEGIN
      HEADNAME       := COPY (LISTNAME,3,LENGTH (LISTNAME)-2);
      DRIVE          := COPY(LISTNAME,1,2);
   END; { ELSE }
   FILL := ' ';
   FOR I := 1 TO (PAPERWIDTH - LEFTMARG - RIGHTMARG - 42 +
      12 - LENGTH (HEADNAME)) DIV 2 DO
      FILL := FILL + '-';              { 42 spaces and chars in heading }
   FILL := FILL + ' ';
   WRITELN ('> Reading Main File:    ',LISTNAME);

   WHILE (NOT (EOF (LISTFILE) OR ABORT)) DO     { main file }
   BEGIN
      PAGEHEAD;
      READLN (LISTFILE,TESTLINE);
      WRITELN (LST,TESTLINE);
      IF KEYPRESSED THEN ABORT := TRUE;
      LINENO              := SUCC (LINENO);
      TESTREF;
      IF INCLUDE THEN LISTINC;   END; { WHILE }

   IF ABORT THEN WRITELN (LST,'>> List aborted');
   WRITE (LST,#12);
   IF ABORT THEN GOTO EXIT;

   WRITELN ('> ',POINT,' Index references found');
   TOP                      := TRUE;
   FOR I := 0 TO POINT - 1 DO                   { index }
   BEGIN
      PAGEHEAD;
      WRITE (LST,'               ');
      IF PROCPAGE [I] > 0 THEN
      BEGIN
         WRITE (LST,PROCNAME [I],' ');
         FOR J := 1 TO OFF - LENGTH (PROCNAME [I]) DO WRITE (LST,'.');
         WRITELN (LST,' page ',PROCPAGE [I]);
      END { IF }
      ELSE WRITELN (LST,'               ',PROCNAME [I]);
      LINENO              := LINENO + 1;
   END; { FOR }

   WRITE (LST,#12);
   EXIT:;
   IF ABORT THEN WRITELN (#7,'> List Aborted');
   WRITELN ('> End <');
   CLOSE (LISTFILE);

END. { PASLIST }