$TITLE('ISIS PRT UTILITY PROGRAM  V1.6')
PRT:
/*    V1.6  11 FEB 82

    This utility will print an ISIS file to :LP:.
    Tab characters (^I) are expanded into spaces.
    PRT is invoked by the command:

       PRT <filename> W D P S K R<cnt> L<cnt> H"title" O/<list of words>/

    where W, D, P, S, K, R, L, H and O are optional switches:

    W   will print wide left margins (7 spaces) so that holes
        may be punched.

    D   will double-space text lines to ease in editing.

    P   will issue a page eject following the file listing.

    S   will skip 5 lines following the file listing.

    K   will suppress (kill) form feeds at the beginning of the file listing.
        Note:  This switch will also suppress the header at the beginning of
        the listing if the H switch is used.

    R<cnt>  will print the file 'cnt' times, where 'cnt' is an integer
        between 0 and 65535.  If 'cnt' is omitted, the file will be printed
        0 times.

        Ex:  to print the file FOO.SRC 5 times, use the command
                    PRT FOO.SRC R5

    L<cnt>  will output a skip to top of page after 'cnt' lines have been
        printed.  If 'cnt' is omitted, a 60-line page format is assumed.
        If tne 'L' switch is omitted, no page formatting (other than that
        explicitly determined by the location of form feeds in the file) is
        produced.  Any form feeds in the file will cause a skip to the top
        of the next page and the output of a header (if the H switch is used).
        Consecutive form feeds are suppressed so that only one page will be
        ejected.  If it is desired to output multiple blank pages, a single
        line consisting of at least one space must separate the form feeds.

        Ex:  to list a file at 30 lines to the page, use the command
                    PRT FILE.EXT L30

             to list a file at 60 lines to the page (default), use the command
                    PRT FILE.EXT L

    H"title"  prints a header at the top of each page.  "title" may be from
        0 to 45 characters long, and is included in the header.  If no title
        is desired, the form 'H' may be used to generate a header.  The "
        character may be replaced by any other character except ';' or a
        space, allowing the text string to contain quotes.

        Ex:  to output a title to the listing of PROG1.SRC, use the command
                    PRT PROG1.SRC L H"Nebutron Integrator, Ver 32.7"

             (note that paging is also specified, handy for source files)

    O   will overstrike <list of words> on the printer output.  Primarily used
        to increase legibility of program listings, the words to be overstruck
        are intended to be identifier-numeric constant-reserved word type
        character strings.  A "word"  is defined by any combination of 'A'-'Z',
        'a'-'z', '0'-'9', and '$'.  Any other character acts as a word
        delimiter.  Words located between comment brackets will be ignored.

        Ex: to overstrike the words 'IDEN$TIFIER', '65476', 'YOURNAME',
            the following construct is used: O/IDEN$TIFIER 65476 YOURNAME/

        Note that constructs such as O/MULTI-PART-WORD/ will be treated as
        three separate words since the '-' character acts to delimit "MULTI",
        "PART" and "WORD".

        To include a subset of reserved words from a programming language
        such as PLM/80, FORTRAN, etc., a '*' preceding a valid reserved word
        list name will add that list of reserved words to the list of words
        to be overstruck.

        Ex: overstrike a PLM/80 program: O/*PLM80/

        Note:  As of version 1.4, 'PLM80' is the only reserved word list
        implemented.

        Multiple occurrances of the "O" switch is permitted.  Each will add
        to the list of words to be overstruck.

    If <filename> is not a legal ISIS file name, PRT will return to ISIS
    with a non-fatal error.
*/
$EJECT
DO;
   DECLARE CR       LITERALLY '0DH',
           FF       LITERALLY '0CH',
           LF       LITERALLY '0AH',
           TAB      LITERALLY '09H',
           TRUE     LITERALLY '0FFH',
           FALSE    LITERALLY '0',
           MAXLEN   LITERALLY 'LENGTH(RESLIST)-1',
           DEFAULTS LITERALLY '1'; /* CURRENT NUMBER OF DEFAULT LISTS */

   DECLARE (COMMENT,     /* TRUE IF SEARCH IS PRESENTLY IN A COMMENT */
            WIDE,        /* TRUE IF WIDE MARGINS ARE SELECTED */
            DOUBLE,      /* = 2 IF DOUBLE SPACING IS REQUESTED */
            PAGE,        /* TRUE IF PAGE EJECT AFTER LISTING IS REQUESTED */
            HEADER,      /* TRUE IF HEADER IS TO BE OUTPUT AFTER PAGE EJECT */
            SPACE,       /* TRUE IF 5 LINE SPACE AFTER LISTING IS REQUESTED */
            OVERSTRIKE,  /* TRUE IF OVERSTRIKING IS REQUESTED */
            CCFLAG,      /* CARRIAGE CONTROL FLAG RETURNED BY 'READREC' */
            NEWPAGE,     /* TRUE IF NOTHING HAS BEEN PRINTED ON CURRENT PAGE */
            SUPPRESS,    /* TRUE IF FORM FEEDS ARE TO BE SUPPRESSED AT START */
            PCNT         /* COUNTER USED IN "Printed..." OUTPUT */
           ) BYTE;

   DECLARE (AFN1,         /* AFTN OF FILE TO BE PRINTED */
            AFNLP,        /* AFTN OF :LP: */
            LOOPCNT,      /* COUNTER FOR PRINT LOOPS */
            LINECNT,      /* NUMBER OF LINES PER PAGE */
            LINE$NUM,     /* LINE COUNTER FOR CURRENT PAGE */
            PAGENUM,      /* PAGE COUNTER */
            REPCNT,       /* NUMBER OF TIMES TO PRINT FILE */
            DISCBUF$INDX, /* INDEX INTO DISC BUFFER */
            RESLIST$INDX, /* POINTER INTO RESLIST */
            BUFLEN,       /* CHAR COUNT RETURNED BY 'READ' */
            TXTINDX,      /* TEXT BUFFER INDEX */
            FLEN,         /* LENGTH OF FILE NAME STRING */
            ERRS          /* ISIS ERROR RETURN LOCATION */
           ) ADDRESS;

   DECLARE TXTBUF(150) BYTE,      /* BUFFER FOR TEXT */
           HEADBUF(80) BYTE,      /* BUFFER FOR HEADER OUTPUT */
           FNAM(20) BYTE,         /* BUFFER FOR FILE NAME TO OPEN */
           DISCBUF(8000H) BYTE,   /* DISC BUFFER */
           RESLIST(500) BYTE;     /* LIST OF RESERVED WORDS */

   DECLARE ERR1(*) BYTE DATA ('Missing text delimiter');
   DECLARE ERR2(*) BYTE DATA ('Undefined reserved word list');
   DECLARE ERR3(*) BYTE DATA ('Reserved word buffer is full');
   DECLARE ERR4(*) BYTE DATA ('Unrecognized switch');
   DECLARE OPEN$ERR4(*) BYTE DATA ('Illegal filename');
   DECLARE OPEN$ERR5(*) BYTE DATA ('Illegal device name');
   DECLARE OPEN$ERR13(*) BYTE DATA ('No such file');
   DECLARE OPEN$ERR22(*) BYTE DATA ('Illegal file/device for input');
   DECLARE OPEN$ERR23(*) BYTE DATA ('No filename given for disk file');

   DECLARE COPY(*) BYTE INITIAL ('Printed: XXXXX copy  ',CR);
   DECLARE PLURAL(*) BYTE DATA ('ies');
   DECLARE MARGIN(*) BYTE DATA ('       '); /* 7 SPACE MARGIN FOR WIDE PRT */
   DECLARE SIGNON(*) BYTE DATA (CR,LF,
           'ISIS-II File Print Utility   V1.6',CR,LF,
           '(c) 1981 Lockheed PARL, Palo Alto, CA    By Greg Kremer',CR,LF,LF);

   DECLARE DEFAULT$LIST(DEFAULTS) STRUCTURE /* LIST OF DEFAULT LIST NAMES */
                                  (NAME(5) BYTE,     /* LIST'S NAME */
                                   LIST$LOC ADDRESS) /* ADDRESS OF LIST */
                                  DATA ('PLM80', .PLM80$RESLIST);

   DECLARE PLM80$RESLIST(*) BYTE DATA ('DO!', /* PLM-80 RESERVED WORDS */
                                 'IF!',       /* WORD IS TERMINATED BY '!' */
                                 'THEN!',
                                 'ELSE!',
                                 'END!',
                                 'WHILE!',
                                 'TO!',
                                 'BY!',
                                 'CASE!',
                                 'CALL!',
                                 'RETURN!',
                                 'OR!',
                                 'AND!',
                                 'XOR!',
                                 'NOT!',
                                 'MOD!',
                                 'DECLARE!',
                                 'BYTE!',
                                 'ADDRESS!',
                                 'LITERALLY!',
                                 'INITIAL!',
                                 'DATA!',
                                 'BASED!', 
                                 'PROCEDURE!',
                                 'EXTERNAL!',
                                 'STRUCTURE!',
                                 'REENTRANT!',
                                 'PUBLIC!',
                                 'AT!', 
                                 'INTERRUPT!',
                                 'ENABLE!',
                                 'DISABLE!',
                           /*    'HALT!',
                                 'GOTO!',
                                 'GO!',
                                 'PLUS!',
                                 'MINUS!',
                                 'EOF!', */
                                  '*');   /* LIST IS TERMINATED BY '*' */
$EJECT
/**********************************************************/
/*                                                        */
/*                 EXTERNAL SUBRS                         */
/*                                                        */
/**********************************************************/

OPEN: /* OPEN A FILE */
   PROCEDURE(AFTNPTR,FILENAM,ACCESS,ECHOAFTN,STATS) EXTERNAL;
   DECLARE (AFTNPTR,FILENAM,ACCESS,ECHOAFTN,STATS) ADDRESS;
END OPEN;

READ: /* GET 'CNT' BYTES FROM A FILE THAT HAS BEEN OPENED */
   PROCEDURE(AFTN,BUFR,CNT,ACT,STATS) EXTERNAL;
   DECLARE (AFTN,BUFR,CNT,ACT,STATS) ADDRESS;
END READ;

WRITE: /* OUTPUT 'CNT' BYTES TO FILE */
   PROCEDURE(AFTN,BUFR,CNT,STATS) EXTERNAL;
   DECLARE (AFTN,BUFR,CNT,STATS) ADDRESS;
END WRITE;

CLOSE: /* CLOSE A FILE THAT IS OPEN */
   PROCEDURE(AFTN,STATS) EXTERNAL;
   DECLARE (AFTN,STATS) ADDRESS;
END CLOSE;

ERROR: /* REPORT NON-FATAL ERRORS TO CONSOLE DEVICE */
   PROCEDURE(ERRNUM) EXTERNAL;
   DECLARE ERRNUM ADDRESS;
END ERROR;

EXIT: /* RETURN TO ISIS */
   PROCEDURE EXTERNAL;
END EXIT;
$EJECT
/************************************************************/
/*                                                          */
/*                 LOCAL SUBRS                              */
/*                                                          */
/************************************************************/

FORMAT$ERROR: /* INDICATE ERROR AND RETURN TO ISIS */
   PROCEDURE(ERRMSG,LEN);
   DECLARE (ERRMSG,LEN) ADDRESS;

   CALL WRITE(0,.('***ERROR:  '),11,.ERRS);
   CALL WRITE(0,ERRMSG,LEN,.ERRS);
   CALL WRITE(0,.(CR,LF,LF),3,.ERRS);
   CALL EXIT; /* RETURN TO ISIS */
END FORMAT$ERROR;

/**********************************/

CNVRT: /* CONVERT 16 BIT INTEGER TO 5 CHAR ASCII */
   PROCEDURE (NUM,BUFLOC);
   DECLARE (NUM,BUFLOC) ADDRESS;
   DECLARE (ASCII$NUM BASED BUFLOC)(1) BYTE; /* CHAR BUFFER */
   DECLARE DIGCNT BYTE; /* COUNTER FOR DIGITS */

   DO DIGCNT= 0 TO 3; /* BLANK BUFFER IN CASE NUM IS ZERO */
      ASCII$NUM(DIGCNT)= ' ';
   END;
   /* DIGCNT IS NOW EQUAL TO 4 */
   ASCII$NUM(DIGCNT)= '0';  /* PUT '0' IN ONE'S DIGIT */
   DO WHILE NUM <> 0;  /* NOW CONVERT NUMBER IN NUM */
      ASCII$NUM(DIGCNT)= (NUM MOD 10) + '0'; /* START WITH ONES DIGIT */
      DIGCNT= DIGCNT-1;
      NUM= NUM/10;
   END;
END CNVRT;

/***********************************/

IN$ALPHA: /* DETERMINE IF A CHAR IS ALPHA-NUMERIC OR '$' */
   PROCEDURE(CHAR) BYTE;
   DECLARE CHAR BYTE; /* CHAR TO TEST */

   RETURN (CHAR <= 'Z' AND CHAR >= 'A') OR
          (CHAR <= 'z' AND CHAR >= 'a') OR
          (CHAR <= '9' AND CHAR >= '0') OR
          CHAR = '$';
END IN$ALPHA;

/***********************************/

IN$DIGITS: /* SIMPLE PROCEDURE TO TEST IF CHAR IS A DIGIT */
   PROCEDURE(CHAR) BYTE;
   DECLARE CHAR BYTE;

   RETURN CHAR <= '9' AND CHAR >= '0';
END IN$DIGITS;

/************************************/

STRING$COMP: /* COMPARE TWO STRINGS */
   PROCEDURE(STRLOC1,STRLOC2,LEN) BYTE;
   DECLARE (STRLOC1,STRLOC2,LEN) ADDRESS;
   DECLARE (STRING1 BASED STRLOC1)(1) BYTE; /* FIRST STRING */
   DECLARE (STRING2 BASED STRLOC2)(1) BYTE; /* SECOND STRING */
   DECLARE INDX ADDRESS; /* STRING LENGTH COUNTER */

   DO INDX= 0 TO LEN-1;
      IF STRING1(INDX) <> STRING2(INDX) THEN RETURN FALSE;
   END;
   RETURN TRUE;
END STRING$COMP;

/***********************************/

LOAD$RESWORD: /* STORE A RESERVED WORD INTO RESLIST */
   PROCEDURE;

   DO WHILE IN$ALPHA(TXTBUF(TXT$INDX));
      RESLIST(RESLIST$INDX)= TXTBUF(TXT$INDX);
      TXT$INDX= TXT$INDX+1;
      IF RESLIST$INDX < MAXLEN-1
         THEN RESLIST$INDX= RESLIST$INDX+1;
         ELSE CALL FORMAT$ERROR(.ERR3,LENGTH(ERR3));
   END;
   RESLIST(RESLIST$INDX)= '!'; /* WORD TERMINATOR */
   RESLIST$INDX= RESLIST$INDX+1;
END LOAD$RESWORD;

/**************************************/

LOAD$RESLIST: /* LOAD DEFAULT RESERVED WORD LIST INTO RESLIST */
   PROCEDURE;
   DECLARE I BYTE;
   DECLARE LIST$PTR ADDRESS;
   DECLARE (LIST BASED LIST$PTR)(1) BYTE;
   DECLARE INDX ADDRESS;

   TXT$INDX= TXT$INDX+1; /* UPDATE GLOBAL POINTER TO COMMAND BUFFER */
   I= 0; /* START LOOKING THRU POSSIBLE RESERVED WORD LISTS */
   DO WHILE I < DEFAULTS AND NOT STRING$COMP(.TXTBUF(TXT$INDX),.DEFAULT$LIST(I).NAME,5);
      I= I+1;
   END;
   IF I = DEFAULTS /* THEN STRING DIDN'T MATCH */
      THEN CALL FORMAT$ERROR(.ERR2,LENGTH(ERR2));
   LIST$PTR= DEFAULT$LIST(I).LIST$LOC; /* COPY RESERVED WORD LIST */
   INDX= 0;
   DO WHILE LIST(INDX) <> '*';  /* '*' IS LIST TERMINATOR */
      RESLIST(RESLIST$INDX)= LIST(INDX);
      INDX= INDX+1;
      IF RESLIST$INDX < MAXLEN
         THEN RESLIST$INDX= RESLIST$INDX+1;
         ELSE CALL FORMAT$ERROR(.ERR3,LENGTH(ERR3));
   END;
   TXT$INDX= TXT$INDX+5; /* POINT TO NEXT SET OF CHARS */
END LOAD$RESLIST;

/******************************************/

OVSTR: /* SET UP RESLIST FOR OVERSTRUCK CHARACTERS */
   PROCEDURE;
   DECLARE DELIM BYTE;   /* HOLDS DELIMITER FOR MATCHING */

   OVERSTRIKE= TRUE; /* SET OVERSTRIKE FLAG */
   TXT$INDX= TXT$INDX+1; /* POINT TO DELIMITER */
   DELIM= TXTBUF(TXT$INDX);
   TXT$INDX= TXT$INDX+1;  /* NOW PICK OUT LIST OF RESERVED WORDS */
   DO WHILE TXTBUF(TXT$INDX) <> DELIM; /* TERMINATED WITH DELIMITER */
      IF IN$ALPHA(TXTBUF(TXT$INDX))
         THEN CALL LOAD$RESWORD; /* ADD RESERVED WORD TO RESLIST */
      ELSE IF TXTBUF(TXT$INDX) = '*'
         THEN CALL LOAD$RESLIST; /* ADD A DEFAULT LIST TO RESLIST */
      ELSE IF TXTBUF(TXT$INDX) = CR
         THEN CALL FORMAT$ERROR(.ERR1,LENGTH(ERR1)); /* SCREW-UP */
      ELSE TXT$INDX= TXT$INDX+1; /* ASSUME ANYTHING ELSE IS A SPACE */
   END;
   RESLIST(RESLIST$INDX)= '*';
END OVSTR;

/****************************************/

LISTCNT: /* GET # OF LINES PER PAGE (DEFAULT = 60) */
   PROCEDURE;

   LINECNT= 0; /* INITIALIZE LINECNT FOR CONVERSION */
   DO WHILE IN$DIGITS(TXTBUF(TXT$INDX+1)); /* GET DIGITS FROM CMD LINE */
      LINECNT= LINECNT*10 + (TXTBUF(TXT$INDX+1) - '0'); /* DIGIT TO NUMBER */
      TXT$INDX= TXT$INDX + 1;
   END;
   IF LINECNT = 0  /* SET DEFAULT IF NO NUMBER WAS INPUT */
      THEN LINECNT= 60;
END LISTCNT;

/************************************************/

REPT: /* SET UP REPEAT COUNT AND FLAG */
   PROCEDURE;

   REPCNT=0; /* DEFAULT CASE */
   DO WHILE IN$DIGITS(TXTBUF(TXT$INDX+1));
      REPCNT= REPCNT*10 + (TXTBUF(TXT$INDX+1) - '0');
      TXT$INDX= TXT$INDX+1;
   END;
END REPT;

/******************************************/

GETHEAD: /* CONSTRUCT HEADER BUFFER AND SET FLAG 'HEADER' TO TRUE. */
   PROCEDURE;
   DECLARE TPTR ADDRESS,  /* POINTS TO WHERE TEXT TO FILL HEADER COMES FROM */
           HINDX BYTE,    /* INDEX INTO HEADER BUFFER */
           INDX BYTE,     /* COUNTER */
           DELIM BYTE;    /* DELIMITER FOR TEXT STRING */
   DECLARE TCHAR BASED TPTR BYTE;  /* CHARACTER TO GO INTO HEADER BUFFER */

   TPTR= .('File ');   /* PUT THIS INTO HEADER FIRST */
   DO HINDX= 0 TO 4;
      HEADBUF(HINDX)= TCHAR;
      TPTR= TPTR+1;
   END;
   TPTR= .FNAM;     /* NOW LOAD IN FILE NAME STRING */
   DO INDX= 1 TO FLEN;
      HEADBUF(HINDX)= TCHAR;
      HINDX= HINDX+1;
      TPTR= TPTR+1;
   END;
   DO HINDX= HINDX TO 25;   /* PAD OUT TO TITLE FIELD */
      HEADBUF(HINDX)= ' ';
   END;
   /* NOW LOOK TO SEE IF THERE IS A TITLE STRING */
   IF TXTBUF(TXT$INDX+1) <> ' ' AND TXTBUF(TXT$INDX+1) <> CR AND TXTBUF(TXT$INDX+1) <> ';'
      THEN DO;  /* COPY TEXT INTO HEADBUF */
         TXT$INDX= TXT$INDX+1;  /* POINT TO DELIMITER */
         DELIM= TXTBUF(TXT$INDX);
         TXT$INDX=TXT$INDX+1;
         DO WHILE TXTBUF(TXT$INDX) <> DELIM;
            IF TXTBUF(TXT$INDX) = CR  /* NO MATCHING RIGHT DELIMITER */
               THEN CALL FORMAT$ERROR(.ERR1,LENGTH(ERR1));
            HEADBUF(HINDX)= TXTBUF(TXT$INDX);
            IF HINDX <= 69  /* LIMIT AMOUNT OF TEXT WE CAN COPY */
               THEN HINDX= HINDX+1;
            TXT$INDX= TXT$INDX+1;
         END;
         /* EXIT WITH TXT$INDX POINTING AT RIGHT DELIMITER */
      END;
   DO HINDX= HINDX TO 69;  /* PAD REST OF TITLE FIELD */
      HEADBUF(HINDX)= ' ';
   END;
   TPTR= .(' Page');  /* LOAD LAST ITEM INTO HEADBUF */
   DO HINDX= HINDX TO 75;
      HEADBUF(HINDX)= TCHAR;
      TPTR= TPTR+1;
   END;
   HEADER= TRUE;
   RETURN;
END GETHEAD;

/***********************************************/

GETCHAR: /* GET 1 CHAR FROM DISC BUFFER & READ IN NEW BUF IF NECESSARY */
   PROCEDURE(CHAR$ADD) BYTE;
   DECLARE CHAR$ADD ADDRESS;
   DECLARE CHAR BASED CHAR$ADD BYTE;

   IF DISCBUF$INDX = BUFLEN /* END OF CURRENT BUFFER */
      THEN DO; /* GET NEW BUFFER FROM AFN1 (ASSUMES FILE IS OPEN) */
         CALL READ(AFN1,.DISCBUF,LENGTH(DISCBUF),.BUFLEN,.ERRS);
         IF BUFLEN = 0 /* THIS MEANS END OF FILE */
            THEN RETURN FALSE;
            ELSE DISCBUF$INDX= 0; /* RESET BUFFER INDEX */
      END; /* OF BUFFER UPDATE */
   CHAR= DISCBUF(DISCBUF$INDX); /* GET CHAR */
   DISCBUF$INDX= DISCBUF$INDX+1;
   RETURN TRUE;
END GETCHAR;

/***********************************************/

READREC: /* THIS ROUTINE FORMATS DATA OFF THE DISK INTO RECORDS.  A RECORD
            IS DEFINED AS <optional text><CR>, CC.  TEXT IS READ FROM THE
            DISK BUFFER UNTIL A TERMINATOR (CR, LF, OR FF) IS READ.  ONCE
            THE TERMINATOR HAS BEEN READ, A CR IS APPENDED TO THE TEXT STRING
            AND CC IS SET TO WHAT CARRIAGE CONTROL IS IMPLIED BY THE TERMINATOR.
            FOR LF, THIS IS 1 (SINGLE SPACE) OR 2 (DOUBLE SPACE).
            FOR FF, THIS IS -1
            FOR CR, CC = 0

            THIS INSURES THAT CARRIAGE CONTROL CHARACTERS IN THE FILE WILL BE
            CORRECTLY HANDLED AS NULL RECORDS.
         */
   PROCEDURE(BUFLOC,CCLOC) BYTE; /* READREC = FALSE IF EOF OCCURS */
   DECLARE (BUFLOC,CCLOC) ADDRESS;
   DECLARE (CHAR,I,FILL) BYTE;
   DECLARE (BUFFER BASED BUFLOC)(1) BYTE; /* RECORD RETURNED HERE */
   DECLARE CC BASED CCLOC BYTE;           /* CARRIAGE CONTROL RETURNED HERE */

   CHAR= 0;
   I= -1;    /* INITIALIZE BUFFER POINTER */
   DO WHILE CHAR <> LF AND CHAR <> CR AND CHAR <> FF; /* SCAN FILE UNTIL TERMINATOR IS FOUND */
      IF NOT GETCHAR(.CHAR) /* WE HAVE EOF (NO BYTES SENT) */
         THEN RETURN FALSE;
      I= I+1;    /* POINT TO NEXT AVAILABLE SPACE IN BUFFER */
      IF CHAR = TAB /* EXPAND CHAR IF IT IS A TAB */
         THEN DO;
            FILL= (I AND 0F8H) + 7; /* SET FILL TO NEXT TAB STOP */
            DO I= I TO FILL; /* STORE BLANKS */
               BUFFER(I)= ' ';
            END;
            I= FILL;   /* POINTS TO LAST FILLED LOCATION */
         END;
         ELSE BUFFER(I)= CHAR;  /* IF NOT A TAB, JUST STORE IN BUFFER */
   END; /* AT THIS POINT A TERMINATOR HAS BEEN RECEIVED */
   IF BUFFER(I) = FF   /* SET CARRIAGE CONTROL IMPLIED BY TERMINATOR */
      THEN CC= -1;
   ELSE IF BUFFER(I)= LF
      THEN CC= DOUBLE; /* FOR LF, SET ACCORDING TO DOUBLE SPACE FLAG */
   ELSE CC= 0;         /* CR MEANS NO CARRIAGE CONTROL */
   BUFFER(I)= CR;      /* TERMINATE RECORD WITH CR */
   RETURN TRUE;
END READREC;

/****************************************/

NXTPG: /* OUTPUT A TOP OF FORM AND HEADER, IF REQUIRED */
   PROCEDURE;

   IF NOT NEWPAGE
      THEN DO;  /* START A NEW PAGE */
         NEWPAGE= TRUE;
         CALL WRITE(AFNLP,.(FF),1,.ERRS);
         PAGENUM= PAGENUM+1;
         IF HEADER   /* THEN OUTPUT THE HEADER */
            THEN DO;
               CALL CNVRT(PAGENUM,.HEADBUF(75));  /* STICK PAGE NUMBER INTO HEADER */
               CALL WRITE(AFNLP,.HEADBUF,80,.ERRS);
               CALL WRITE(AFNLP,.(CR,LF,LF),3,.ERRS);
               LINE$NUM= 3;
            END;
            ELSE LINE$NUM= 1;
      END;
END NXTPG;

/*********************************************/

LPOUT: /* OUTPUT A TEXT RECORD TO :LP:.  RECORD IS TERMINATED WITH CR */
       /* TRAILING BLANKS ARE SUPPRESSED. */
   PROCEDURE(BUFLOC,CC);
   DECLARE BUFLOC ADDRESS; /* LOCATION OF TEXT */
   DECLARE CC BYTE; /* CARRIAGE CONTROL, # OF LFS TO OUTPUT (CC => 0) */
   DECLARE (CNT,I) BYTE;
   DECLARE (BUFFER BASED BUFLOC)(1) BYTE;
   DECLARE OUTBUF(132) BYTE; /* OUTPUT BUFFER FOR TEXT */

   CNT= 0; /* INITIALIZE CHAR COUNT */
   DO WHILE BUFFER(CNT) <> CR;  /* LOCATE END OF LINE */
      OUTBUF(CNT)= BUFFER(CNT); /* COPY TEXT INTO OUTPUT BUFFER */
      CNT= CNT + 1;
   END;
   DO WHILE OUTBUF(CNT-1) <= ' ' AND CNT > 0; /* NOW BACK UP TILL TEXT STARTS */
      CNT= CNT - 1;
   END;
   OUTBUF(CNT)= CR; /* PUT IN NEW CR */
   IF CNT > 0 /* PRINT OUT TEXT IF ANY */
      THEN DO;
         NEWPAGE= FALSE;
         IF WIDE /* STICK A MARGIN ON THE OUTPUT */
            THEN CALL WRITE(AFNLP,.MARGIN,LENGTH(MARGIN),.ERRS);
         CALL WRITE(AFNLP,.OUTBUF,CNT+1,.ERRS); /* OUTPUT TEXT BUFFER */
      END;
   IF CC = -1  /* NOW DO CARRIAGE CONTROL */
      THEN CALL NXTPG;    /* OUTPUT A TOP OF FORM */
      ELSE DO I= 1 TO CC; /* IF CC >= 0, OUTPUT APPROPRIATE NUMBER OF LF's */
         LINE$NUM= LINE$NUM+1;
         IF LINENUM > LINECNT AND LINECNT > 0 /* THEN PAGING IS REQUIRED. */
            THEN CALL NXTPG;
            ELSE DO;
               NEWPAGE= FALSE;
               CALL WRITE(AFNLP,.(LF),1,.ERRS);
            END;
   END;
END LPOUT;

/*****************************************************/

SEARCH: /* THIS ROUTINE BLANKS OUT ALL TEXT IN A BUFFER EXCEPT FOR
           THOSE RESERVED WORDS LISTED IN 'RESLIST'. */
   PROCEDURE(BUFLOC);
   DECLARE BUFLOC ADDRESS; /* TEXT TO BE MODIFIED */
   DECLARE (P1,P2,P3) ADDRESS; /* POINTERS TO TEXT STRINGS */
   DECLARE (BUFFER BASED BUFLOC)(1) BYTE;

   P1= 0;
   DO WHILE BUFFER(P1) <> CR;  /* OPERATE ON BUFFER UNTIL TERMINATOR (CR) */
      IF COMMENT  /* SEE IF END OF COMMENT IS IN THIS BUFFER */
         THEN DO;
            DO WHILE (BUFFER(P1) <> '*' OR BUFFER(P1+1) <> '/')
                     AND BUFFER(P1) <> CR;
               BUFFER(P1)= ' '; /* BLANK COMMENT */
               P1= P1 + 1;
            END;
            IF BUFFER(P1)= CR
               THEN RETURN;  /* WHOLE BUFFER IS A COMMENT */
               ELSE COMMENT= FALSE; /* END OF COMMENT--TURN FLAG OFF & CONT */
         END;
      IF BUFFER(P1) = '/' AND BUFFER(P1+1) = '*' /* BEGINNING OF COMMENT */
         THEN COMMENT= TRUE;
         ELSE IF IN$ALPHA(BUFFER(P1))
            THEN DO; /* FOUND SOME TEXT */
               P3= 0; /* POINTER INTO RESERVED WORD LIST */
               /* LOOK THRU RESERVED WORDS TO MATCH TEXT AT P1 */
               DO WHILE RESLIST(P3) <> '*' AND RESLIST(P3) <> '!';
                  /* A '*' IS THE END OF THE LIST. (NO MATCH) */
                  /* A '!' SIGNIFIES A MATCH */
                  P2= P1; /* USE P1 TO HOLD STARTING POINT */
                  /* TEST FOR '!' SINCE THIS IS USED TO TERMINATE WORD */
                  DO WHILE BUFFER(P2) = RESLIST(P3) AND BUFFER(P2) <> '!';
                     /* COMPARE BYTE BY BYTE */
                     P2= P2 + 1;
                     P3= P3 + 1;
                  END;
                  /* IF WE HAD NO MATCH P3 WON'T POINT TO '!' */
                  IF RESLIST(P3) <> '!' OR IN$ALPHA(BUFFER(P2))
                     THEN DO;
                        DO WHILE RESLIST(P3) <> '!';
                           /* LOOK FOR NEXT RESERVED WORD */
                           P3= P3 + 1;
                        END;
                        P3= P3 + 1; /* START AT NEXT WORD */
                     END;
               END;
               IF RESLIST(P3) = '*' /* THEN NO MATCH */
                  THEN DO WHILE IN$ALPHA(BUFFER(P1));
                     /* BLANK OUT WORD */
                     BUFFER(P1)= ' ';
                     P1= P1 + 1;
                  END;
                  ELSE P1= P2; /* SKIP OVER RESERVED WORD */
            END;
            ELSE DO;
               BUFFER(P1)= ' ';
               P1= P1 + 1;
            END;
   END;
END SEARCH;
$EJECT
/*******************************************************/
/*                                                     */
/*             MAIN PROG                               */
/*                                                     */
/*******************************************************/

   CALL WRITE(0,.SIGNON,LENGTH(SIGNON),.ERRS);  /* IDENTIFY PROGRAM */

   /* GET FILENAME FROM COMMAND BUFFER */
   CALL READ(1,.TXTBUF,LENGTH(TXTBUF),.BUFLEN,.ERRS);
   TXT$INDX= 0; /* THIS WILL GO ALONG THE COMMAND STRING */
   DO WHILE TXTBUF(TXT$INDX) = ' '; /* SKIP BLANKS */
      TXT$INDX= TXT$INDX + 1;
   END;
   FLEN= 0; /* THIS WILL GO ALONG FILE NAME STRING */
   DO WHILE TXTBUF(TXT$INDX) <> ' ' AND TXTBUF(TXT$INDX) <> CR AND TXTBUF(TXT$INDX) <> ';';
      FNAM(FLEN)= TXTBUF(TXT$INDX); /* COPY UNTIL SPACE OR END OF COMMAND BUFFER */
      TXT$INDX= TXT$INDX + 1;
      FLEN= FLEN + 1;
   END;
   FNAM(FLEN)= ' '; /* TERMINATE NAME WITH BLANK */

   /* SET DEFAULT SWITCH SETTINGS */
   RESLIST$INDX= 0; /* RESET POINTER TO RESERVED WORDS */
   WIDE= FALSE;     /* NO MARGIN */
   REPCNT= 1;       /* PRINT ONCE */
   LINECNT= 0;      /* NO PAGING REQUESTED */
   DOUBLE= 1;       /* SINGLE SPACE */
   HEADER= FALSE;   /* NO HEADER */
   PAGE= FALSE;     /* NO PAGE EJECT */
   SPACE= FALSE;    /* NO SPACING */
   SUPPRESS= FALSE; /* ISSUE FF AT START OF LISTING */
   OVERSTRIKE= FALSE;  /* NO OVERSTRIKING */

   /* LOOK FOR LEGAL SWITCHES IN REST OF COMMAND BUFFER */
   DO WHILE TXTBUF(TXT$INDX) <> CR AND TXTBUF(TXT$INDX) <> ';';
      IF TXTBUF(TXT$INDX) <> ' '
         THEN /* CHECK POSSIBLE VALUES */
            IF TXTBUF(TXT$INDX) = 'W'        /* WIDE MARGINS */
               THEN WIDE= TRUE;
            ELSE IF TXTBUF(TXT$INDX) = 'D'   /* DOUBLE SPACING */
               THEN DOUBLE= 2;
            ELSE IF TXTBUF(TXT$INDX) = 'P'   /* PAGE EJECT */
               THEN PAGE= TRUE;
            ELSE IF TXTBUF(TXT$INDX) = 'S'   /* SPACE EJECT */
               THEN SPACE= TRUE;
            ELSE IF TXTBUF(TXT$INDX) = 'H'   /* PRINT HEADER */
               THEN CALL GETHEAD;
            ELSE IF TXTBUF(TXT$INDX) = 'O'   /* OVERSTRIKING */
               THEN CALL OVSTR;
            ELSE IF TXTBUF(TXT$INDX) = 'R'   /* REPEAT PRINT */
               THEN CALL REPT;
            ELSE IF TXTBUF(TXT$INDX) = 'L'   /* PAGELENGTH */
               THEN CALL LISTCNT;
            ELSE IF TXTBUF(TXT$INDX) = 'K'   /* SUPPRESS FORM FEEDS */
               THEN SUPPRESS= TRUE;
            ELSE CALL FORMAT$ERROR(.ERR4,LENGTH(ERR4));
      TXT$INDX= TXT$INDX + 1;
   END;

   CALL OPEN(.AFNLP,.(':LP: '),2,0,.ERRS); /* OPEN :LP: FOR PRINT */

   /* GO THROUGH PRINT LOOP FOR EACH PRINTING OF FILE */
   DO LOOPCNT= 1 TO REPCNT; /* OPEN FILE AND PRINT */
      CALL OPEN(.AFN1,.FNAM,1,0,.ERRS);
      /* IDENTIFY COMMON OPEN ERRORS */
      IF ERRS = 4
         THEN CALL FORMAT$ERROR(.OPEN$ERR4,LENGTH(OPEN$ERR4));
      ELSE IF ERRS = 5
         THEN CALL FORMAT$ERROR(.OPEN$ERR5,LENGTH(OPEN$ERR5));
      ELSE IF ERRS = 13
         THEN CALL FORMAT$ERROR(.OPEN$ERR13,LENGTH(OPEN$ERR13));
      ELSE IF ERRS = 22
         THEN CALL FORMAT$ERROR(.OPEN$ERR22,LENGTH(OPEN$ERR22));
      ELSE IF ERRS = 23
         THEN CALL FORMAT$ERROR(.OPEN$ERR23,LENGTH(OPEN$ERR23));
      ELSE IF ERRS <> 0
         THEN DO;
            CALL ERROR(ERRS);
            CALL EXIT;
         END;

      /* INITIALIZE COUNTERS AND SUCH */
      DISCBUF$INDX= 0; /* INITIALIZE POINTERS TO FILE BUFFER */
      BUFLEN= 0;       /* TO FORCE THE FIRST READ */
      PAGENUM= 0;
      NEWPAGE= SUPPRESS; /* FORCE A FORM FEED AT START OF LISTING */
      CALL NXTPG;
      COMMENT= FALSE;  /* START OFF WITH NO COMMENT */

      DO WHILE READREC(.TXTBUF,.CCFLAG); /* KEEP READING BUFFERS TILL EOF */
         IF OVERSTRIKE /* PRINT BUFFER THEN OVERSTRIKE RESERVED WORDS */
            THEN DO;
               CALL LPOUT(.TXTBUF,0); /* PRINT FIRST LINE BY ITSELF FOR NOW */
               CALL SEARCH(.TXTBUF);  /* SCREEN OUT NON-RESERVED WORDS */
            END;
         CALL LPOUT(.TXTBUF,CCFLAG);  /* PRINT BUFFER (SECOND TIME IF OVERSTRUCK) */
      END;
      IF PAGE
         THEN CALL WRITE(AFNLP,.(FF),1,.ERRS); /* PUT PAGE BETWEEN FILES */
      IF SPACE
         THEN CALL WRITE(AFNLP,.(CR,LF,LF,LF,LF,LF),6,.ERRS); /* PUT 5 LINES BETWEEN FILES */
      CALL CLOSE(AFN1,.ERRS); /* CLOSE TEXT FILE (TO BE RE-OPENED IF REPEAT) */
      CALL CNVRT(LOOPCNT,.COPY(9)); /* LOAD # OF COPIES FOR OUTPUT */
      IF LOOPCNT = 2   /* GET A LITTLE FANCY WITH THE OUTPUT HERE... */
         THEN DO PCNT= 0 TO 2;
            COPY(18+PCNT)= PLURAL(PCNT); /* CHANGE "copy" TO "copies" */
         END;
      CALL WRITE(0,.COPY,LENGTH(COPY),.ERRS);
   END;
   CALL WRITE(0,.(LF),1,.ERRS); /* FINAL LINE FEED TO CONSOLE */
   CALL EXIT;
END PRT;