*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