Retro1.org codex

*DECK LFGGFN
      PROC LFGGFN(TABLE,FILECNT); 
      BEGIN                  # GET FILE NAMES                          #
*IF,DEF,IMS 
# 
**    LFGGFN - GET FILE NAMES.
* 
*     D.K. ENDO    81/12/15 
* 
*     LFGGFN ATTEMPTS TO BUILD THE FILE NAME TABLE FROM THE INPUT 
*     DIRECTIVES GIVEN. 
* 
*     PROC LFNGFN(TABLE,FILECNT)
* 
*     ENTRY        NONE.
* 
*     EXIT         TABLE = TABLE CONTAINING FILE NAMES. 
*                  FILECNT = NUMBER OF ENTRIES IN TABLE.
* 
*     MESSAGES     DIRECTIVE FILE EMPTY.
*                  DIRECTIVE ERRORS DETECTED. 
* 
*     METHOD
* 
*     WRITE HEADER FOR LISTING. 
*     READ FIRST CARD.
*     IF FILE IS NOT EMPTY
*     THEN
*       FOR EACH CARD WHILE NOT END OF RECORD,
*         GET FIRST TOKEN.
*         IF TOKEN IS AN ASTERISK,
*           GET NEXT TOKEN. 
*           IF TOKEN IS NOT THE KEYWORD -FILE-, 
*             FLAG ERROR -- NO DIRECTIVE. 
*           GET NEXT TOKEN. 
*         FOR EACH TOKEN UNTIL END OF CARD, 
*           SELECT CASE THAT APPLIES, 
*             CASE 1(NAME): 
*               IF LENGTH OF NAME IS NOT GREATER THAN MAXIMUM,
*               THEN, 
*                 PUT NAME IN TABLE 
*                 INCREMENT FILE NAME COUNT.
*               OTHERWISE,
*                 FLAG ERROR -- FILE NAME TOO LONG. 
*             CASE 2(DELIMITER):  
*               IF TOKEN IS A COMMA 
*               THEN, 
*                 IF COMMA WAS ALREADY SPECIFIED, 
*                   FLAG ERROR -- CONSECUTIVE COMMAS. 
*               OTHERWISE,
*                 FLAG ERROR -- ASTERISK IS INVALID DELIMITER.
*             CASE 3(UNKNOWN CHARACTER):  
*               FLAG ERROR -- INVALID DELIMITER.
*             CASE 4(EOC):  
*               SET END OF CARD FLAG. 
*         IF NO FILE NAMES WERE SPECIFIED 
*           FLAG ERROR -- NO FILE NAMES 
*         IF LISTING FLAG SET OR ERROR DETECTED ON LINE,
*           WRITE DIRECTIVE CARD TO OUTPUT FILE.
*         READ NEXT CARD. 
*     OTHERWISE,
*       SEND DAYFILE MESSAGE -- EMPTY DIRECTIVE FILE. 
*       ABORT.
*     IF ERRORS DETECTED IN DIRECTIVE FILE
*       SEND DAYFILE MESSAGE -- DIRECTIVE ERRORS DETECTED.
*       ABORT.
* 
# 
*ENDIF
      ARRAY TABLE [0:0] S(1);          # TABLE TO PUT FILE NAMES       #
        BEGIN 
        ITEM TBL$ENT    C(00,00,10);   # FILE NAME ENTRY               #
        ITEM TBL$NUM    I(00,00,60);   # NUMBER ENTRY                  #
        END 
      ITEM FILECNT;                    # FILE COUNT                    #
# 
****  PROC LFGGFN - XREF LIST BEGINS. 
# 
      XREF
        BEGIN 
        PROC ABORT;          # ABORTS JOB ON REQUEST                   #
        ITEM INPUT;          # DIRECTIVE FILE FET                      #
        PROC LFGGNT;         # GET NEXT TOKEN                          #
        PROC LFGLHDR;        # WRITES LISTING HEADER                   #
        PROC LFGWL;          # WRITES LINE TO OUTPUT FILE              #
        PROC MESSAGE;        # SENDS MESSAGE TO DAYFILE                #
        ITEM OUTPUT;         # OUTPUT FET                              #
        PROC READH;          # READ INPUT DIRECTIVE IN -H- FORMAT      #
        PROC WRITER;         # FLUSH CIO BUFFER AND WRITE EOR          #
        END 
# 
****
# 
      DEF ECODE1 # 1 #;      # INDEX FOR MESSAGE ONE.                  #
      DEF ECODE2 # 2 #;      # INDEX FOR MESSAGE TWO.                  #
      DEF ECODE3 # 3 #;      # INDEX FOR MESSAGE THREE                 #
      DEF ECODE4 # 4 #;      # INDEX FOR MESSAGE FOUR                  #
      DEF ECODE5 # 5 #;      # INDEX FOR MESSAGE FIVE                  #
      DEF LFN$MXL # 7 #;     # MAXIMUM LENGTH FOR FILE NAME            #
      DEF TRNS$OK # 0 #;     # STATUS RETURN AFTER SUCCESSFUL READ     #
      CONTROL NOLIST;        # LFGSTAN COMMON DECK                     #
*CALL LFGSTAN 
      CONTROL LIST; 
      ITEM ABRTFLG B;        # ABORT FLAG                              #
      ITEM CARDCNT I;        # DIRECTIVE CARD COUNT                    #
      ITEM COL I;            # POINTER TO CURRENT CHARACTER            #
      ITEM COMMA$FLG B;      # COMMA FLAG                              #
      ITEM DIR$FLG B;        # DIRECTIVE FLAG                          #
      ITEM EOC B;            # END OF CARD FLAG                        #
      ITEM ERRLINE B;        # DIRECTIVE ERROR INDICATOR               #
      ITEM I I;              # SCRATCH ITEM                            #
      ITEM J I;              # SCRATCH ITEM                            #
      ITEM LENGTH;           # LENGTH OF TOKEN                         #
      ITEM LFN$FLG B;        # LOCAL FILE NAME FLAG                    #
      ITEM LSTNG$ID;         # LISTING I.D.                            #
      ITEM STATIS I;         # STATUS RETURNED ON READ                 #
      ITEM TOKEN C(10);      # TOKEN RETURNED FOR DIRECTIVE LINE       #
      ITEM TYPE I;           # TOKEN TYPE                              #
      ARRAY DIR$BUFF [0:9] S(1);
        BEGIN                # DIRECTIVE LINE BUFFER                   #
        ITEM DB$LINE    C(00,00,90) = [" "];
        ITEM DB$ZBYT    I(09,00,60) = [0];
        END 
      ARRAY DIR$ERROR [0:0] S(3); 
        BEGIN                # DIRECTIVE ERROR MESSAGE                 #
        ITEM DE$MSG     C(00,00,27) = [" DIRECTIVE ERRORS DETECTED."];
        ITEM DE$ZBYT    I(02,42,18) = [0];
        END 
      ARRAY EMPTY$FILE [0:0] S(3);
        BEGIN 
        ITEM EF$MSG     C(00,00,22) = [" EMPTY DIRECTIVE FILE."]; 
        ITEM EF$ZBYT    I(02,12,48) = [0];
        END 
      DEF MXET # 5 #; 
      ARRAY ERRMSG$TABLE [00:MXET] S(6);
        BEGIN 
        ITEM ERRMSG     C(00,00,50) = 
                   [" ",
                    " ****   DIRECTIVE INDICATOR -FILE- NOT FOUND.    ",
                    " ****   FILE NAME MUST BE 1 TO 7 CHARACTERS.     ",
                    " ****   FILE NAME MUST BE DELIMITED BY ONE COMMA.",
                    " ****   COMMA AND/OR BLANKS ARE ONLY LEGAL DELIM.",
                    " ****   AT LEAST ONE FILE NAME MUST BE SPECIFIED.",
                   ]; 
        ITEM ERMS$ZBYT  I(05,00,60) = [,
                                       0, 
                                       0, 
                                       0, 
                                       0, 
                                       0, 
                                      ];
        END 
      SWITCH GFNSWTCH        UNKNOWN, 
                             NAME,
                             DELIM, 
                             EO$CARD; 
      CONTROL EJECT;
      FUNC ZFILL(NAME) C(10); 
      BEGIN 
      ITEM NAME C(10);
      ITEM CTEMP1 C(1); 
      ITEM CTEMP2 C(10);
      ITEM I I; 
#                                                                      #
#                            ZFILL CODE BEGINS HERE                    #
#                                                                      #
      FOR I=0 STEP 1 UNTIL 9           # FOR EACH CHARACTER IN NAME    #
      DO
        BEGIN 
        CTEMP1 = C<I,1>NAME;
        IF CTEMP1 EQ " "               # CHARACTER IS BLANK            #
        THEN
          BEGIN 
          C<I,1>CTEMP2 = 0;            # REPLACE BLANK WITH ZERO       #
          END 
        ELSE                           # CHARACTER IS NON-BLANK        #
          BEGIN 
          C<I,1>CTEMP2 = CTEMP1;       # SAVE CHARACTER                #
          END 
        END 
      ZFILL = CTEMP2;        # RETURN ZERO FILLED NAME                 #
      RETURN;                # **** RETURN ****                        #
      END 
      CONTROL EJECT;
#                                                                      #
#                            LFGGFN CODE BEGINS HERE                   #
#                                                                      #
      ABRTFLG = FALSE;                 # CLEAR ABORT FLAG              #
      FILECNT = 0;                     # INITIALIZE FILE NAME COUNT    #
      PAGEN = 1;                       # INITIALIZE PAGE COUNT         #
      LSTNG$ID = DIR$LST;              # SET LISTING ID                #
      LFGLHDR(LSTNG$ID);               # WRITE LISTING HEADER          #
      READH(INPUT,DIR$BUFF[1],8,STATIS);  # READ FIRST INPUT CARD      #
      IF STATIS EQ TRNS$OK             # IF READ WAS O.K.              #
      THEN
        BEGIN                # KEEP READING CARDS TILL NO MORE         #
        FOR CARDCNT=0 STEP 1 WHILE STATIS EQ TRNS$OK
        DO
          BEGIN 
          COL = 0;                     # SET COLUMN POINTER            #
          EOC = FALSE;                 # CLEAR END OF CARD INDICATOR   #
          ERRLINE = FALSE;             # CLEAR ERROR LINE FLAG         #
          COMMA$FLG = FALSE;           # CLEAR COMMA FLAG              #
          LFGGNT(TOKEN,COL,LENGTH,TYPE,DIR$BUFF[1]); # GET NEXT TOKEN  #
          IF TOKEN EQ "*"              # IF TOKEN IS -*-, THIS MUST    #
          THEN                         #  BE A DIRECTIVE INDICATOR     #
            BEGIN 
            LFGGNT(TOKEN,COL,LENGTH,TYPE,DIR$BUFF[1]); #GET NEXT TOKEN #
            IF TOKEN NQ "FILE"         # IF TOKEN IS NOT -FILE-        #
            THEN
              BEGIN          # FLAG ERROR -- INVALID DIRECTIVE IND.    #
              LFGWL(ERRMSG$TABLE[ECODE1],LSTNG$ID); 
              ERRLINE = TRUE;          # SET ERROR LINE FLAG           #
              ABRTFLG = TRUE;          # SET ABORT FLAG                #
              END 
            LFGGNT(TOKEN,COL,LENGTH,TYPE,DIR$BUFF[1]); # GET NEXT TOKEN#
            DIR$FLG = TRUE;            # SET DIRECTIVE FOUND FLAG      #
            END 
          LFN$FLG = FALSE;             # CLEAR FILE NAME FLAG          #
          FOR J=0 WHILE NOT EOC 
          DO                 # FOR EACH TOKEN TILL END OF CARD         #
            BEGIN 
            GOTO GFNSWTCH[TYPE];       # GOTO APPROPRIATE PARAGRAPH    #
NAME: 
            IF LENGTH LQ LFN$MXL       # IF FILE NAME IS NOT TOO LONG  #
            THEN
              BEGIN 
              LFN$FLG = TRUE;          # SET FILE NAME FLAG            #
              FILECNT = FILECNT + 1;   # INCREMENT FILE COUNT          #
              TBL$ENT[FILECNT] = ZFILL(TOKEN);   # PUT NAME INTO TABLE #
              COMMA$FLG = FALSE;       # CLEAR COMMA FLAG              #
              END 
            ELSE                       # FILE NAME TOO LONG            #
              BEGIN          # FLAG ERROR -- FILE NAME TOO LONG        #
              LFGWL(ERRMSG$TABLE[ECODE2],LSTNG$ID); 
              ERRLINE = TRUE;          # SET ERROR LINE FLAG           #
              ABRTFLG = TRUE;          # SET ABORT FLAG                #
              END 
            GOTO NEXT;
DELIM:  
            IF TOKEN EQ ","            # IF TOKEN IS COMMA             #
            THEN
              BEGIN 
              IF NOT COMMA$FLG         # IF A COMMA WAS NOT PREVIOUSLY #
              THEN                     #  SPECIFIED                    #
                BEGIN 
                COMMA$FLG = TRUE;      # SET COMMA FOUND FLAG          #
                END 
              ELSE                     # NO FILE NAME BETWEEN COMMAS   #
                BEGIN        # FLAG ERROR -- CONSECUTIVE COMMAS        #
                LFGWL(ERRMSG$TABLE[ECODE3],LSTNG$ID); 
                ERRLINE = TRUE;        # SET ERROR LINE FLAG           #
                ABRTFLG = TRUE;        # SET ABORT FLAG                #
                END 
              END 
            ELSE                       # TOKEN MUST BE AN ASTERISK     #
              BEGIN          # FLAG ERROR -- INVALID DELIMITER         #
              LFGWL(ERRMSG$TABLE[ECODE4],LSTNG$ID); 
              ERRLINE = TRUE;          # SET ERROR LINE FLAG           #
              ABRTFLG = TRUE;          # SET ABORT FLAG                #
              END 
            GOTO NEXT;
UNKNOWN:                     # FLAG ERROR -- INVALID DELIMITER         #
            LFGWL(ERRMSG$TABLE[ECODE4],LSTNG$ID); 
            ERRLINE = TRUE;            # SET ERROR LINE FLAG           #
            ABRTFLG = TRUE;            # SET ABORT FLAG                #
            GOTO NEXT;
EO$CARD:  
            EOC = TRUE;                # SET END OF CARD FLAG          #
NEXT: 
            LFGGNT(TOKEN,COL,LENGTH,TYPE,DIR$BUFF[1]); # GET NEXT TOKEN#
            END 
          IF NOT LFN$FLG AND           # IF NO FILE NAME SPECIFIED     #
             DIR$FLG
          THEN
            BEGIN            # FLAG ERROR -- NO FILE NAME SPECIFIED    #
            LFGWL(ERRMSG$TABLE[ECODE5],LSTNG$ID); 
            ERRLINE = TRUE;            # SET ERROR LINE FLAG           #
            ABRTFLG = TRUE;            # SET ABORT FLAG                #
            END 
          IF LISTFLG OR      # IF LISTING WAS REQUESTED OR             #
             ERRLINE         #  ERROR WAS DETECTED                     #
          THEN
            BEGIN            # WRITE INPUT DIRECTIVE                   #
            LFGWL(DIR$BUFF,LSTNG$ID); 
            END                        # READ NEXT CARD                #
          READH(INPUT,DIR$BUFF[1],8,STATIS);
          END 
        END 
      ELSE                             # EMPTY DIRECTIVE FILE          #
        BEGIN 
        MESSAGE(EMPTY$FILE,0);         # SEND MESSAGE TO DAYFILE       #
        ABORT;               # **** ABORT ****                         #
        END 
      IF ABRTFLG                       # IF ERROR WAS DETECTED         #
      THEN
        BEGIN 
        MESSAGE(DIR$ERROR,0);          # SEND MESSAGE TO DAYFILE       #
        WRITER(OUTPUT);                # FLUSH CIO BUFFER              #
        ABORT;               # **** ABORT ****                         #
        END 
      RETURN;                # **** RETURN ****                        #
      END # LFGGFN #
      TERM