./ ADD SSI=04010311,NAME=IKJEFP00,SOURCE=0 P00 TITLE 'IKJEFP00 TSO PARSE PROGRAM VERSION SIX DATE 6/11/71' 00060021 * 00062021 * 00064021 *********************************************************************** 00070020 * 00080020 * TITLE -- IKJEFP00 (IKJPARS LOAD MODULE) 00090020 * 00100020 * STATUS - CHANGE LEVEL 002 00110000 * 00120020 * FUNCTION -- PARSE IS A TSO SERVICE ROUTINE WHICH PROVIDES A 00130020 * CENTRALIZED, AND THEREFORE GENERALIZED, PROGRAM TO SYNTAX CHECK TSO 00140020 * COMMAND PARAMETERS. 00150020 * 00160020 * ENTRY POINT -- IKJPARS --- REGISTER ONE POINTS TO A PARAMETER LIST 00170020 * WHICH IS AS FOLLOWS - 00180020 * 00190020 * ******************************* 00200020 * / POINTER TO UPT / 00210020 * / POINTER TO ECT / 00220020 * / POINTER TO ECB / 00230020 * / POINTER TO PCL / 00240020 * / POINTER TO ANSWER PLACE / 00250020 * / POINTER TO COMMAND BUFFER / 00260020 * / USER WORD / 00270020 * ******************************* 00280020 * 00290020 * THE UPT, ECT AND ECB ARE NOT USED BY PARSE, BUT ARE PASSED ASIS IN 00300020 * THE PARAMETER LIST TO THE I/O SERVICE ROUTINES. 00310020 * 00320020 * INPUT -- THE PARAMETER CONTROL LIST (PCL) IS CREATED BY THE CP 00330020 * USING THE PARSE MACROS IKJPARMD, IKJPOSIT, IKJIDENT, IKJKEYWD, 00340020 * IKJNAME, IKJSUBF AND IKJENDP MACROS. EACH MACRO GENERATES ONE 00350020 * ENTRY IN THE PCL CALLED AN PARAMETER CONTROL ENTRY (PCE). 00360020 * THE ANSWER PLACE IS A FOUR BYTE AREA PROVIDED BY THE CALLING CP 00370020 * AS A LOCATION WHERE THE PARAMETER DESCRIPTION LIST (PDL) ADDRESS 00380020 * IS PLACED. 00390020 * THE COMMAND BUFFER IS OF THE FORM - 00400020 * 00410020 * ******************************************* 00420020 * / LENGTH / OFFSET / TEXT / 00430020 * ******************************************* 00440020 * 0 2 4 00450020 * 00460020 * THE LENGTH INCLUDES THE LENGTH OF THE LENGTH AND OFFSET FIELDS WITH 00470020 * THE BUFFER OFFSET POINTING TO THE LOCATION IN THE BUFFER WHERE 00480020 * PARSE IS TO BEGIN SCANNING. THE COMMAND SCAN SERVICE 00490020 * ROUTINE PREVIOUSLY UPDATED THE OFFSET PAST THE COMMAND NAME. 00500020 * THE USER WORD IS PASSED TO THE VALIDITY CHECK ROUTINE AND WOULD 00510020 * NORMALLY CONTAIN THE ADDRESS OF A WORK AREA. 00520020 * 00530020 * OUTPUT -- PARAMETER DESCRIPTION LIST (PDL) POINTED TO BY THE 00540020 * ANSWER PLACE. THE PDL BEGINS WITH TWO WORDS OF STORAGE CHAINS WITH 00550020 * THE REMAINING FIELDS VARIABLE LENGTH DEPENDENT UPON THE TYPE OF 00560020 * MACROS SELECTED FOR THE PCL. ONLY THE IKJPOSIT, IKJIDENT AND 00570020 * IKJKEYWD MACROS RESERVE SPACE IN THE PDL. EACH ENTRY IN THE PDL IS 00580020 * CALLED A PARAMETER DESCRIPTION ENTRY (PDE). 00590020 * 00600020 * EXTERNAL REFERENCES -- IKJEFP10 (PARSE MESSAGE MODULE) 00610020 * IKJEFP20 (PARSE/COMMAND SCAN COMMON MODULE) 00620020 * IKJPUTL (PUTLINE I/O SERVICE ROUTINE) 00630020 * IKJPTGT (PUTGET I/O SERVICE ROUTINE) 00640020 * IKJPARS2 - SEPARATE LOAD MODULE TO 00642000 * COBOL SYMBOLIC DEBUG SCAN AND PROMPT. 00644000 * PCE TYPES HANDLED BY THE NEW LOAD 00646000 * MODULE ARE: 00648000 * 1) IKJOPER 00648400 * 2) IKJTERM 00648800 * 3) IKJRSVWD 00649200 * 00650020 * EXITS,NORMAL -- REGISTER 15 CONTAINS A 00 RETURN CODE. 00660020 * 00670020 * EXITS,ERROR -- REGISTER 15 CONTAINS A 00680020 * 04 RETURN CODE, UNABLE TO PROMPT 00690020 * 08 RETURN CODE, PROCESSING INTERRUPTED BY 00700020 * ATTENTION 00710020 * 12 RETURN CODE, INVALID PARAMETERS PASSED 00720020 * TO PARSE FROM CP 00730020 * 16 RETURN CODE, NO SPACE AVAILABLE 00740020 * 20 RETURN CODE, VALIDITY CHECK ROUTINE 00750020 * REQUESTED TERMINATION 00760020 * 24 - AN ERROR IN INPUT PARAMETERS 00764000 * WAS DETECTED IN THE IKJPARS2 00766000 * LOAD MODULE. 00768000 * IN ADDITION TO THE ERROR RETURN CODES, THE PDL ADDRESS IN THE 00770020 * ANSWER PLACE IS SET TO X'FF000000'. 00780020 * 00790020 * TABLES/WORK AREAS -- MACRO IKJEFPWA IS USED TO DEFINE THE WORK AREA 00800020 * OBTAINED DURING INITIALIZATION BY IKJEFP00. IKJEFP20 ALSO 00810020 * REFERENCES THIS AREA THROUGH THE USE OF THE IKJEFPWA MACRO. 00820020 * 00830020 * ATTRIBUTES -- REENTRANT 00840020 * REFRESHABLE 00850020 * 00860020 * CHARACTER CODE DEPENDENCY -- CLASS C. THE OPERATION OF THIS PROGRAM 00870020 * IS DEPENDENT UPON AN INTERNAL REPRESENTATION OF THE EXTERNAL 00880020 * CHARACTER SET WHICH IS EQUIVALENT TO THE ONE USED AT ASSEMBLY 00890020 * TIME. THE CODING HAS BEEN ARRANGED SO THAT REDEFINITION OF 00900020 * 'CHARACTER' CONSTANTS, BY REASSSEMBLY, WILL RESULT IN A CORRECT 00910020 * PROGRAM FOR THE NEW DEFINITION. 00920020 * 00930020 * RELEASE 20 SUPPORT CODE -- 20035 00940020 * 00950020 *********************************************************************** 01000021 IKJEFP00 CSECT 01050021 * TSO1389,M0882,M0903,M3318,M0911,M3098,M3333,M2379,M2574,M3337,M2479 01060021 * M2454,M4223,M4477,M1564,M4789,M1647,M5028,M5767,M6393,S21105,A45355 01062021 * A45352,A45306,A46773,A45368,F41448 01064021 EXTRN TRTAB,UPPERTAB,IKJEFP10 EXTERNAL REFERENCES 01066021 ENTRY IKJPARS ESTABLISH ENTRY POINT 01068021 IKJPARS DS 0H FOR PARSE 01068421 * 01068521 R0 EQU 0 SCRATCH/PARAMETER REGISTER -- 01068621 * MUST BE 0 01070020 R1 EQU 1 SCRATCH/PARAMETER REGISTER -- 01080020 * MUST BE 1 01090020 R2 EQU 2 GENERAL SCRATCH REGISTER 01100020 R3 EQU 3 GENERAL SCRATCH REGISTER 01110020 XINPUT EQU 4 NEXT CHARACTER TO SCAN 01120020 XINPUTB EQU 5 LAST CHARACTER SCANNED USED TO 01130020 * COMPUTE LENGTH OF SCANNED 01140020 * DATA 01150020 XPCE EQU 6 ALWAYS POINTS TO THE CURRENT PCE 01160020 BASE3 EQU 7 ADDITIONAL BASE REGISTER FOR 01170020 * FIRST CSECT 01180020 LINK2 EQU 8 SECOND LEVEL LINKAGE REGISTER 01190020 * FOR LINKAGE BETWEEN 01200020 * SUBROUTINES 01210020 LINK1 EQU 9 FIRST LEVEL LINKAGE REGISTER FOR 01220020 * LINKAGE BETWEEN MAINLINE AND 01230020 * SUBROUTINES 01240020 BASE2 EQU 10 BASE REGISTER FOR SECOND CSECT 01250020 BASE1 EQU 11 MAINLINE BASE REGISTER 01260020 RBASE EQU 12 BASE REGISTER FOR CURRENT 01270020 * RECURSIVE WORKSPACE 01280020 PBASE EQU 13 BASE REGISTER FOR PERMANENT 01290020 * WORKSPACE -- MUST BE 13 01300020 R14 EQU 14 SCRATCH/RETURN REGISTER -- MUST 01310020 * BE 14 01320020 R15 EQU 15 SCRATCH/CALL REGISTER -- MUST BE 01330020 * 15 01340020 EJECT 01350020 * 01360020 * BIT PATTERNS USED TO TEST THE OPTIONS SELECTED BY THE USER AND 01370020 * REFLECTED IN VARIOUS BYTES IN THE PCE. 01380020 * 01390020 PCEFIDNT EQU B'10000000' BITS 0-2 - IKJIDENT PCE 01400020 PCEFPOST EQU B'00100000' BITS 0-2 - IKJPOSIT PCE 01410020 PCEFKYWD EQU B'01000000' BITS 0-2 - IKJKEYWD PCE 01420020 PCEFNAME EQU B'01100000' BITS 0-2 - IKJNAME PCE 01430020 PCEFSUEN EQU B'00000000' BITS 0-2 - IKJSUBF OR IKJENDP 01440020 * PCE 01450020 PCEFPRPT EQU B'00010000' BIT 3 - PROMPT IS SPECIFIED 01460020 PCEFDFLT EQU B'00001000' BIT 4 - DEFAULT IS SPECIFIED 01470020 PCEFSUBF EQU B'00000100' BIT 5 - SUBFIELD IS SPECIFIED 01480020 PCEFHELP EQU B'00000010' BIT 6 - HELP IS SPECIFIED 01490020 PCEFVCHK EQU B'00000001' BIT 7 - VALIDITY CHECK EXIT IS 01500020 * SPECIFIED 01510020 PCEFLIST EQU B'10000000' BIT 8 - LIST IS SPECIFIED 01520020 PCEFASIS EQU B'01000000' BIT 9 - NO TRANSLATION REQUIRED 01530020 PCEFRNGE EQU B'00100000' BIT 10 - RANGE IS SPECIFIED 01540020 PCEFINST EQU B'00010000' BIT 11 - INSERT IS SPECIFIED 01550020 PCEFQSTR EQU B'00001000' BIT 12 - SPECIAL STRING HANDLING 01552020 * IKJIDENT OPTIONS. 01560020 PCEFASTK EQU B'10000000' BIT 0 - ASTERISK IS ALLOWED 01570020 PCEFMAXL EQU B'01000000' BIT 1 - MAXLNTH IS SPECIFIED 01580020 PCEFPTBY EQU B'00100000' BIT 2 - USE PRINT INHIBIT MODE 01590020 * WHEN PROMPTING 01600020 SPACE 01610020 * 01620020 * RECURSIVE WORKSPACE FLAGS. 01630020 * 01640020 RFKYPRSE EQU X'80' KEYWORDS HAVE BEEN PARSED ONCE 01650020 RFQDSNM EQU X'40' A QUOTED DSNAME IS BEING 01660020 * PROCESSED 01670020 RFERASE EQU X'20' AN ERASE IS BEING PERFORMED 01680020 RFPRES EQU X'10' USED TO INDICATE A KEYWORD PCE 01690020 * WAS ENCOUNTERED IN THE PCL, 01700020 * IF OFF, AN EXTRANEOUS 01710020 * INFORMATION MESSAGE IS 01720020 * PRINTED INSTEAD OF AN 01730020 * INVALID KEYWORD MESSAGE 01740020 RFKEYWDS EQU X'08' THE NEXT RECURSION LEVEL IS FOR 01750020 * A KEYWORD PARAMETER 01760020 RFMEMB EQU X'04' INDICATES A MEMBER NAME IS BEING 01770020 * PROCESSED 01780020 RFNOTQ1 EQU X'02' INDICATES THE FIRST QUALIFIER IS 01790020 * NOT BEING PROCESSED 01800020 RFNOSKIP EQU X'01' INDICATES BLANKS SHOULD NOT BE 01810020 * SKIPPED AFTER A PROMPT 01820020 EJECT 01830020 * 01840020 * PERMANENT WORKSPACE FLAGS. 01850020 * 01860020 * P F L A G S 01870020 PFLIST EQU X'80' CURRENTLY PROCESSING A LIST 01880020 PFDEFLT EQU X'40' INDICATES A DEFAULT TAKEN 01890020 PFENDF EQU X'20' END OF INPUT AREA HAS BEEN 01900020 * REACHED 01910020 ADREXP EQU X'10' INDICATE ADDR EXPRESSION M4789 01920020 HEXBIT EQU X'08' ADDRESS EXPRESSION CONTAINS 01930020 * A HEX CHARACTER 01940020 PFBYPAS EQU X'04' BYPASS MODE IS TO BE ESTABLISHED 01950020 PFNEW EQU X'02' USED BY ADDRESS ROUTINE TO 01960020 * DENOTE A NEW VALID ADDRESS 01970020 * ENTRYNAME (WITH OR WITHOUT 01980020 * LOADNAME QUALIFICATION) 01990020 DECBIT EQU X'01' ADDRESS EXPRESSION IS DECIMAL 02000020 * P F L A G S 2 02010020 PFSKPINV EQU X'80' VALIDITY CHECK ROUTINE REQUESTED 02020020 * A REENTER MESSAGE ONLY 02030020 RNGEVAL1 EQU X'40' ADDRESS ROUTINE PROCESSED FIRST 02040020 * VALUE OF RANGE PARAMETER 02050020 ONERBIT EQU X'20' CONTROL BIT USED DURING SCAN 02060020 * BY ADDRESS ROUTINE 02070020 TWORBIT EQU X'10' CONTROL BIT USED DURING SCAN 02080020 * BY ADDRESS ROUTINE 02090020 RNGEVAL2 EQU X'08' ADDRESS ROUTINE PROCESSED 02100020 * SECOND VALUE OF RANGE 02110020 * PARAMETER 02120020 REGBIT EQU X'04' CONTROL BIT USED DURING SCAN 02130020 * BY ADDRESS ROUTINE 02140020 FLTERBIT EQU X'02' CONTROL BIT USED DURING SCAN 02150020 * BY ADDRESS ROUTINE 02160020 BREAKBIT EQU X'01' USED BY ADDRESS ROUTINE TO 02170020 * DENOTE A BREAK CHARACTER IN 02180020 * PARAMETER 02190020 * P F L A G S 3 02200020 PFSTPRMT EQU X'80' PROMPT FOR STRING 02210020 PFONE EQU X'40' INDICATES AT LEAST ONE PDE 02220020 * PDE HAS BEEN BUILT 02230020 LOADBIT EQU X'20' CONTROL BIT USED BY ADDRESS RTN 02240020 * DENOTING LOADNAME DATA 02250020 ENTRYBIT EQU X'10' CONTROL BIT USED BY ADDRESS RTN 02260020 * DENOTING ENTRYNAME DATA 02270020 PFNULL EQU X'08' INDICATES A NULL LINE WAS 02280020 * ENTERED AFTER A PROMPT 02290020 LPRNFND EQU X'04' USED TO INDICATE A LEFT PAREN 02300020 * WAS FOUND BY THE ERROR RTN. 02310020 PFSPACE EQU X'02' USED TO INDICATE A POSITIONAL 02320020 * SPACE PARAMETER WAS 02330020 * ENCOUNTERED SO THAT THE 02340020 * POSITIONAL STRING ROUTINE 02350020 * KNOWS WHEN TO END THE STRING 02360020 PFMORE EQU X'01' USED TO INDICATE IF THE LEFT 02370020 * PAREN OF A SUBFIELD WAS 02380020 * ALSO USED AS THE LEFT PAREN 02390020 * OF THE LIST WITHIN THE 02400020 * SUBFIELD 02410020 * P F L A G S 4 02420020 PFENDLIM EQU X'80' INDICATES END DELIMITER 02430020 * FOR A SELF-DELIMITING STRING 02440020 * HAS BEEN FOUND 02450020 PFLSTEND EQU X'40' INDICATES LIST END DELIMITER 02460020 * HAS BEEN FOUND 02470020 PFVCMSG EQU X'20' INDICATES A VALIDITY CHECK 02480020 * ROUTINE HAS SUPPLIED A SECOND 02490020 * LEVEL MESSAGE 02500020 PFPDDATA EQU X'10' INDICATE PROCESSING PROMPT OR 02510020 * DEFAULT DATA 02520020 PFSLASH EQU X'08' INDICATE DSNAME/USERID ROUTINE 02530020 * IS SCANNING FOR PASSWORD 02540020 PFENDSET EQU X'04' INDICATES BACKUP POINTER FOR 02550020 * ENDINPUT HAS BEEN SET 02560020 PFNOPOP EQU X'02' INDICATES STACK IS NOT TO M0911 02562020 * BE POPPED IF ALL SEPARATORS 02564020 * IN PROMPT BUFFER 02566020 CKRANGE EQU X'01' ADDR ROUTINE SHOULD CHECK M4789 02568020 * FOR RANGE 02568420 * P F L A G S 5 02568821 PFSQSTR EQU X'80' SPECIAL QSTRING HANDLING 02569221 * DONE AT LEAST ONCE 02569621 INVPRMPT EQU X'40' CHECK FOR INVALID MESSAGE PROMPT 02569721 EJECT 02570020 * 02580020 * MESSAGE EQUATES. 02590020 * 02600020 MSG1 EQU 0 ENTER 'PROMPT DATA' 02610020 MSG2 EQU 4 MISSING 'PROMPT DATA' 02620020 MSG3 EQU 8 REENTER 02630020 MSG4 EQU 12 AMBIGUOUS 02640020 MSG5 EQU 16 MISSING PASSWORD 02650020 MSG6 EQU 20 INVALID 'PARAMETER TYPE' 02660020 MSG7 EQU 24 END QUOTE ASSUMED 02670020 MSG8 EQU 28 RIGHT PAREN ASSUMED 02680020 MSG9 EQU 32 INVALID PASSWORD 02690020 MSG10 EQU 36 INVALID DATA SET NAME 02700020 MSG11 EQU 40 INVALID USERID 02710020 MSG12 EQU 44 INVALID ADDRESS 02720020 MSG13 EQU 48 INVALID KEYWORD 02730020 MSG14 EQU 52 INVALID VALUE 02740020 MSG15 EQU 56 ENTER PASSWORD 02750020 MSG16 EQU 60 INVALID STRING 02760020 MSG17 EQU 64 EXTRANEOUS INFORMATION 02770020 MSG18 EQU 68 INVALID 02772020 SPACE 02780020 * 02790020 * MISCELLANEOUS EQUATES. 02800020 * 02810020 ZERO EQU 0 USED AS A ZERO 02820020 ONE EQU 1 USED AS A ONE 02830020 TWO EQU 2 USED AS A TWO 02840020 THREE EQU 3 USED AS A THREE 02850020 FOUR EQU 4 USED AS A FOUR 02860020 FIVE EQU 5 USED AS A FIVE 02870020 SIX EQU 6 USED AS A SIX 02880020 SEVEN EQU 7 USED AS A SEVEN 02890020 EIGHT EQU 8 USED AS A EIGHT 02900020 TWELVE EQU 12 USED AS A TWELVE 02910020 FIFTEEN EQU 15 USED AS A FIFTEEN 02920020 SIXTEEN EQU 16 USED AS A SIXTEEN 02930020 TWENTY EQU 20 USED AS A TWENTY 02940020 TWENTY3 EQU 23 USED AS A TWENTY-THREE 02950020 TWENTY4 EQU 24 USED AS A TWENTY-FOUR 02960020 TWENTY8 EQU 28 USED AS A TWENTY-EIGHT 02970020 THIRTY2 EQU 32 USED AS A THIRTY-TWO 02980020 THIRTY5 EQU 35 USED AS A THIRTY-FIVE 02990020 THIRTY6 EQU 36 USED AS A THRITY-SIX 03000020 NINETY2 EQU 92 USED AS 92 F41448 03002021 WRKLEN EQU X'9C' LENGTH OF COBOL F41448 03004021 * PORTION OF WORKSPACE F41448 03006021 H00 EQU X'00' USED TO MAINPULATE FLAG BITS 03010020 HFF EQU X'FF' USED TO MAINPULATE FLAG BITS 03020020 HA0 EQU X'A0' USED IN PCE CHECKING FOR F41448 03022021 * COBOL F41448 03024021 H80 EQU X'80' USED BY ADDRESS RTN TO 03030020 * MANIPULATE BITS 03040020 HE0 EQU X'E0' USED TO OBTAIN TYPE INDICATOR 03050020 * FROM PCE FLAG BYTE 03060020 H01 EQU X'01' USED TO TEST FOR VALID VALIDITY 03070020 * CHECK ROUTINE ADDRESS 03080020 H18 EQU X'18' TEST FOR RSVD OR SUBSCRPT F41448 03082021 PRESENT EQU X'80' USED TO SET FLAGS 03090020 QUOTED EQU X'40' USED TO SET FLAGS 03100020 LENMLLST EQU 16 LENGTH OF MULTI-LEVEL ELEMENT 03110020 * FOR HELP MESSAGES 03120020 SEMICOLN EQU C';' SEMICOLON 03130020 COLON EQU C':' COLON 03140020 BKCHAR EQU C'_' BREAK CHARACTER 03150020 RIGHTPRN EQU C')' RIGHT PARENTHESIS 03160020 LEFTPRN EQU C'(' LEFT PARENTHESIS 03170020 BLNK EQU C' ' BLANK 03180020 COMMA EQU C',' COMMA 03190020 TABCHAR EQU X'05' HORIZONTAL TAB CHARACTER 03200020 NLCHAR EQU X'15' NEW LINE CHARACTER 03210020 QUOTE EQU C'''' QUOTATION MARK 03220020 PERIOD EQU C'.' PERIOD 03230020 SLASH EQU C'/' SLASH 03240020 ASTERISK EQU C'*' ASTERISK 03250020 PLUS EQU C'+' PLUS SIGN 03260020 EBCDIC0 EQU C'0' CHARACTER 0 03270020 EBCDIC1 EQU C'1' CHARACTER 1 03280020 EBCDIC2 EQU C'2' CHARACTER 2 03290020 EBCDIC3 EQU C'3' CHARACAER 3 03300020 EBCDIC4 EQU C'4' CHARACTER 4 03310020 EBCDIC5 EQU C'5' CHARACTER 5 03320020 EBCDIC6 EQU C'6' CHARACTER 6 03330020 CC1 EQU 1 CONDITION CODE ONE (BO) 03340020 CC4 EQU 4 MIXED CONDITION CODE F41448 03342021 CC9 EQU 9 BRANCH ON NOT MIXED F41448 03344021 CC5 EQU 5 CONDITION CODE FIVE 03350020 CC7 EQU 7 CONDITION CODE SEVEN (NZ OR NE) 03360020 CC8 EQU 8 CONDITION CODE EIGHT (0 OR EQ) 03370020 IPDLMAXE EQU 10 MAXIMUM INPUT STACKING DEPTH FOR 03380020 * A INPUT PUSHDOWN STACK 03390020 DSNMAXLN EQU 44 MAXIMUM LENGTH OF A DSNAME 03400020 DATAPRES EQU X'80' PDE FLAG TO INDICATE DATA THERE 03410020 SPACE 03420020 * 03430020 * EQUATES FOR POSITIONAL ADDRESS ROUTINE. 03440020 * 03450020 COUNTER EQU 2 USED TO CONTROL MAXIMUM SIZE 03460020 LEVELS EQU 3 USED TO CONTROL MAXIMUM SIZE 03470020 RELATIVE EQU C'+' DENOTES AN ADDRESS EXPRESSION 03480020 MORE EQU RELATIVE 03490020 CHECK EQU 1 TO INTERFACE WITH TYPETEST RTN 03500020 PERCENT EQU C'%' DENOTES LEVELS OF INDIRECT 03510020 * ADDRESSES 03520020 LESS EQU C'-' DENOTES AN ADDRESS EXPRESSION 03530020 PL1BIT EQU X'80' PL1 REQUIREMENT 03540020 LOCATPDE EQU 8 USED TO LOCATE LAST EXPRESSION 03550020 * VALUE ON CHAIN 03560020 D EQU C'D' USED TO TEST FOR DOUBLE 03570020 * PRECISION 03580020 LOWD EQU X'84' LOWER CASE IS VALID 03590020 E EQU C'E' USED BY ADDRESS RTN TO CHECK 03600020 * FOR SINGLE PRECISION 03610020 LOWE EQU X'85' LOWER CASE IS VALID 03620020 R EQU C'R' USED BY ADDRESS RTN TO CHECK 03630020 * FOR GENERAL REGISTER 03640020 LOWR EQU X'99' LOWER CASE IS VALID 03650020 NNN EQU C'N' DENOTES DECIMAL AS OPPOSED TO 03660020 * HEXIDECIMAL EXPRESSION VALUE 03670020 LOWNNN EQU X'95' LOWER CASE IS VALID 03680020 * THE FOLLOWING SYMBOLIC LABELS 03690020 * ARE USED WHEN REFERENCING AN 03700020 * ADDRESS EXPRESSION PDE 03710020 ADDRDATA EQU 0 POINTER TO ADDRESS STRING 03720020 ADDRLNTH EQU 4 POINTER TO ADDRESS LENGTH 03730020 ADDRFLGS EQU 8 INDICATES TYPE OF EXPRESSION 03740020 * VALUE 03750020 ADDRSIGN EQU 9 ARITHMETIC SIGN CHARACTER USED 03760020 * BEFORE NEXT EXPRESSION VALUE 03770020 * ZERO IF LAST VALUE TO CHAIN 03780020 ADDRCNT EQU 10 NUMBER OF LEVELS OF INDIRECT 03790020 * ADDRESSING 03800020 ADDRPTR EQU 12 POINTER TO NEXT EXPRESSION 03810020 * VALUE 03820020 TINYPDE EQU 1 R1(TINYPDE)USED AS POINTER TO 03830020 * CORE GOTTEN FOR ADDRESS 03840020 * EXPRESSION 03850020 HEXVALUE EQU X'02' USED BY ADDRESS SUBROUTINE TO 03860020 * DENOTE A HEXADECIMAL 03870020 * EXPRESSION VALUE 03880020 DECVALUE EQU X'04' USED BY ADDRESS SUBROUTINE TO 03890020 * DENOTE A DECIMAL EXPRESSION 03900020 * VALUE 03910020 SYMADR EQU X'80' SYMBOLIC ADDRESS FLAG 03920020 RELADR EQU X'40' RELATIVE ADDRESS FLAG 03930020 ABSADR EQU X'00' ABSOLUTE ADDRESS FLAG M5957 03940021 REG EQU X'20' REGISTER NOTATION FLAG 03950020 DPFPR EQU X'10' USED TO DENOTE DOUBLE PRECISION 03960020 * FLOATING POINT REGISTER 03970020 SPFPR EQU X'08' USED TO DENOTE SINGLE PRECISION 03980020 * FLOATING POINT REGISTER 03990020 ENTRYNAM EQU X'04' USED BY ADDRESS RTN TO DENOTE 04000020 * A NON-QUALIFYING ENTRYNAME 04010020 * (PRECEDED BY AN OPTIONAL 04020020 * LOADNAME) 04030020 EMPTYFLG EQU X'02' INITIAL SETTING OF DATAFLG - 04032020 * NO ADDR TYPE YET IDENTIFIED 04034020 SPACE 04040020 * 04050020 * OFFSETS FOR REQUIRED FIELDS IN MACROS. 04060020 * 04070020 PCEPCLLN EQU 0 PCL LENGTH FIELD IN IKJPARM 04080020 PCEPDLLN EQU 2 PDL LENGTH FIELD IN IKJPARM 04090020 PCEKYEND EQU 4 IKJKEYWD OR END-OF-FIELD OFFSET 04100020 * IN IKJPARM 04110020 PCEFLGB1 EQU 0 FLAG BYTE 1 04120020 PCEFLGB2 EQU 1 FLAG BYTE 2 04130020 PCELEN EQU 2 - 3 PCE LENGTH 04140020 PCEPDEO EQU 4 - 5 PDE OFFSET INTO PDL 04150020 PCEPOST EQU 6 TYPE OF POSITIONAL PARAMETER 04160020 PCENAML EQU 4 LENGTH OF NAME FOR IKJNAME 04170020 PCENAMN EQU 5 - N NAME SPECIFIED 04180020 PCEOPT EQU 6 IKJIDENT OPTION BYTE 04190020 PCEFIRST EQU 7 IKJIDENT FIRST CHARACTER FLAGS 04200020 PCEOTHER EQU 8 IKJIDENT OTHER CHARACTER FLAGS 04210020 PCEPARMT EQU 9 IKJIDENT PARAMETER TYPE SEGMENT 04220020 SPACE 04230020 * 04240020 * MESSAGE OFFSETS TO BE INSERTED INTO CONSTRUCTED MESSAGE SEGMENTS. 04250020 * 04260020 OFFSET1 EQU 16 OFFSET FOR ENTER 04270020 OFFSET2 EQU 29 OFFSET FOR ENTER PASSWORD 04280020 OFFSET3 EQU 44 OFFSET FOR EXTRANEOUS INFOR. 04290020 OFFSET4 EQU 37 OFFSET FOR RIGHT PAREN ASSUMED 04300020 OFFSET5 EQU 32 OFFSET FOR END QUOTE ASSUMED 04310020 OFFSET6 EQU 10 OFFSET FOR AMBIGUOUS KEYWORD 04320020 SPACE 04330020 * 04340020 * BIT SETTINGS USED BY TYPETEST FOR SYNTAX CHECKING CHARACTERS. 04350020 * 04360020 HEX EQU X'80' HEX CHARACTER 04370020 OLETTER EQU X'40' LETTER NOT A HEX LETTER 04380020 NATL EQU X'20' NATIONAL CHARACTER 04390020 NUMBER EQU X'10' NUMBER 04400020 SEPAR EQU X'08' SEPARATOR 04410020 NSEPDLIM EQU X'04' DELIMITER, NOT A SEPARATOR 04420020 NDLIMSPC EQU X'02' SPECIAL CHAR NOT A DELIM OR SEP 04430020 CMDDLIM EQU X'01' COMMAND NAME DELIMITER 04440020 INVALID EQU X'00' INVALID CHAR 04450020 ALPHA EQU HEX+OLETTER+NATL ALPHABETIC CHARS 04460020 DLIMREQD EQU SEPAR+NSEPDLIM A END OF PARAMETER DELIMITER IS 04470020 * REQUIRED 04480020 SPACE 04490020 * 04500020 * PARSE RETURN CODES 04510020 * 04520020 RCSUCSFL EQU 0 SUCCESSFUL COMPLETION 04530020 RCNOPRMT EQU 4 COMMAND INCOMPLETE - UNABLE TO 04540020 * PROMPT 04550020 RCATTN EQU 8 PROCESSING INTERRUPTED BY ATTN 04560020 RCERROR EQU 12 INVALID PARAMETERS 04570020 RCNOCORE EQU 16 NO SPACE AVAILABLE 04580020 RCVCERR EQU 20 VALIDITY CHECK ROUTINE INDICATED 04590020 * IT COULD NOT CONTINUE (E.G., 04600020 * GETMAIN FAILURE) AND WANTS 04610020 * PARSE TO TERMINATE 04620020 EJECT 04630020 *********************************************************************** 04640020 * * 04650020 * MAIN CONTROL ROUTINE * 04660020 * * 04670020 * STORAGE IS OBTAINED FOR THE PERMANENT WORKSPACE, THE PDL AND THE * 04680020 * RECURSIVE WORKSPACE. AFTER INITIALIZING THE WORKSPACE AREAS AND THE * 04690020 * NECESSARY REGISTERS, THE NEXT PCE TYPE IS ANALYZED AND A BRANCH IS * 04700020 * TAKEN TO THE APPROPRIATE PROCESSOR. * 04710020 * * 04720020 *********************************************************************** 04730020 */*IKJEFP00: CHART */ 04730400 */* E START */ 04732021 SPACE 04740020 SAVE (14,12),,IKJPARS-11/11/72 SAVE CALLERS REGISTERS 04750021 SPACE 04760020 BALR BASE1,ZERO ESTABLISH ADDRESSABILITY 04770020 */* P ESTABLISH ADDRESSABILITY FOR THREE CSECTS */ 04772021 USING *,BASE1 TO FIRST CSECT 04780020 SPACE 04790020 L BASE2,ADRCST1 ESTABLISH ADDRESSABILITY 04800020 USING IKJEFP01,BASE2 TO SECOND CSECT 04810020 SPACE 2 04820020 L BASE3,ADRCST2 ESTABLISH ADDRESSABILITY 04830020 USING IKJEFP02,BASE3 TO THIRD CSECT 04840020 SPACE 04850020 LR R3,R1 SAVE INPUT PARAMETER LIST ADR. 04860020 SPACE 04870020 * 04880020 * OBTAIN AND INITIALIZE PERMANENT AND FIRST RECURSIVE WORKSPACES. 04890020 * 04900020 */* L ISSUE GETMAIN FOR PWORK AND RWORK */ 04902021 GETMAIN R,LV=WORKSZ+RWORKSZ OBTAIN WORKSPACES 04910020 SPACE 04920020 LR R2,PBASE SAVE CALLER SAVERAREA ADDRESS 04930020 LR PBASE,R1 ESTABLISH PARSES SAVEAREA AND 04940020 * INITIALIZE PERMANENT 04950020 * WORKSPACE BASE REGISTER 04960020 ST R2,FOUR(PBASE) BACK CHAIN TO CALLERS SAVEAREA 04970020 ST PBASE,EIGHT(R2) FORWARD CHAIN TO PARSES SAVEAREA 04980020 USING PWORK,PBASE ESTABLISH ADDRESSABILTIY TO 04990020 * PERMANENT WORKSPACE 05000020 SPACE 05010020 * 05020020 * INITIALIZE THE FIRST MESSAGE SEGMENT OF THE HELP MESSAGES IN CASE THE 05030020 * FIRST MESSAGE ISSUED IS AN 'ENTER' MESSAGE BYPASSING THIS FUNCTION 05040020 * IN THE INFORMATIONAL MESSAGE SUBROUTINE (WRITER1). NO HELP MESSAGES 05050020 * ARE USED WITH THE 'ENTER PASSWORD FOR' MESSAGE. 05060020 * 05070020 */* P INITIALIZE FIRST MESSAGE SEGMENT FOR 'ENTER' */ 05072021 L R15,ADRMSGC LOAD ADDRESS OF MESSAGE CSECT 05080020 L R15,MSG1(R15) LOAD ADDRESS OF MESSAGE 05090020 MVC PRIMSGID(TWENTY),ZERO(R15) INITIALIZE THE FIRST 05100020 MVI PRIMSGID+ONE,TWENTY SEGMENT OF HELP MESSAGES 05110020 SPACE 05120020 * 05130020 * OBTAIN INPUT PARAMETERS. 05140020 * 05150020 */* P SAVE INPUT PARAMETERS */ 05152021 L XPCE,TWELVE(R3) LOAD ADR OF PCL 05160020 LA XPCE,ZERO(XPCE) CLEAR HIGH ORDER BYTE OF PCL 05170020 * ADDRESS 05180020 ST XPCE,PTABLEAD SAVE PCL ADDRESS 05190020 L XINPUT,TWENTY(R3) LOAD ADR OF INPUT BUFFER TO SCAN 05200020 LA XINPUT,ZERO(XINPUT) CLEAR HIGH ORDR BYTE OF INPUT 05210020 * BUFFER ADDRESS 05220020 MVC USERWORD(L'USERWORD),TWENTY4(R3) MOVE USER WORD TO 05230020 * VALIDITY CHECK EXIT 05240020 * PARAMETER LIST 05250020 MVC SRPARAMS(TWELVE),ZERO(R3) MOVE UPT, ECT, ECB ADDRESSES 05260020 * TO SERVICE ROUTINE PARM. LIST 05270020 L R3,SIXTEEN(R3) LOAD ADR OF ANSWER PLACE 05280020 LA R3,ZERO(R3) CLEAR HIGH ORDER BYTE OF ANSWER 05290020 * PLACE ADDRESS 05300020 SPACE 05310020 * 05320020 * INITIALIZE WORK AREAS AND SWITCHES. 05330020 * 05340020 */* P INITIALIZE WORK AREAS AND SWITCHES */ 05342021 MVC PUTLINE(LPLEND-LPUTLINE),LPUTLINE INITIALIZE PUTLINE AND 05350020 MVC PUTGET(LPGEND-LPUTGET),LPUTGET PUTGET PARAMETERS 05360020 MVI PFLAGS,ZERO CLEAR FLAG BYTE AREA 05370020 MVI PFLAGS2,ZERO CLEAR FLAG BYTE AREA 05380020 MVI PFLAGS3,ZERO CLEAR FLAG BYTE AREA 05390020 MVI PFLAGS4,ZERO CLEAR FLAG BYTE AREA 05400020 MVI PFLAGS5,ZERO CLEAR FLAG BYTE AREA 05402021 LA R2,OPEREND GET ADDR OF START OF F41448 05404021 * COBOL PERMANENT WORKSPACE F41448 05406021 XC ZERO(WRKLEN,R2),ZERO(R2) CLEAR COBOL WORK AREA F41448 05408021 XC TEMPPDE(CBLTPDE),TEMPPDE CLEAR THE COBOL TEMPRARY F41448 05408421 * PDE F41448 05408821 MVI RETCODE,RCSUCSFL SET USERS RETURN CODE TO ZERO 05410020 XC PANCHOR(L'PANCHOR+L'PANCHORT),PANCHOR ZERO INTERNAL 05420020 * STORAGE CHAINS 05430020 XC PIPDLCHN,PIPDLCHN ZERO INPUT PUSHDOWN STACK 05440020 * STORAGE CHAIN 05450020 MVI PIPDLX,ZERO ZERO PUSHDOWN STACK INDEX 05460020 LA R0,PIPDLCHN INITIALIZE CURRENT INPUT 05470020 ST R0,PIPDLCUR PUSHDOWN STACK PTR 05480020 LR R2,XINPUT COPY INPUT BUFFER ADDRESS 05490020 MVC PDWORD(TWO),ZERO(R2) ALIGN LENGTH ON PROPER BOUNDARY 05500020 AH R2,PDWORD ADD TOTAL BUFFER LENGTH TO START 05510020 * ADDRESS TO GET END OF BUFFER 05520020 * ADDRESS FOR FUTURE COMPARES 05530020 */* P SAVE END OF BUFFER ADDRESS */ 05532021 ST R2,ENDINPUT SAVED TO FIND END OF BUFFER 05540020 MVC PDWORD(TWO),TWO(XINPUT) ALIGN OFFSET ON PROPER BOUNDARY 05550020 LH R1,PDWORD SAVE FOR LATER CALCULATION 05560020 LA XINPUT,THREE(R1,XINPUT) POSITION SCAN POINTER JUST 05570020 * BEFORE FIRST INPUT CHARACTER 05580020 MVC PDWORD(TWO),PCEPCLLN(XPCE) ALIGN PCL LENGTH ON PROPER 05590020 * BOUNDARY 05600020 LH R2,PDWORD LOAD THE PCL LENGTH 05610020 AR R2,XPCE ADD THE PCL START ADDRESS 05620020 ST R2,PTABLEND SAVE POINTER TO BYTE PAST END OF 05630020 * PCL 05640020 MVC PDWORD(TWO),PCEPDLLN(XPCE) ALIGN PDL LENGTH ON PROPER 05650020 * BOUNDARY 05660020 LH R1,PDWORD LOAD PDL LENGTH 05670020 */* P POSITION SCAN POINTER TO BEFORE FIRST CHARACTER */ 05672021 LA R2,PCEKYEND(XPCE) SET UP A POINTER TO THE FIRST 05680020 * KEYWORD PCE OFFSET OR THE 05690020 * END-OF-FIELD PCE OFFSET TO BE 05700020 * USED IN THE RECURSE ROUTINE 05710020 SPACE 05720020 * 05730020 * OBTAIN STORAGE FOR PDL. 05740020 * 05750020 */* S STALOC: GET STORAGE FOR PDL */ 05752021 XC ZERO(FOUR,R3),ZERO(R3) ZERO ANSWER PLACE IN CASE 05760020 * GETMAIN FAILS --- CLEANUP 05770020 * ROUTINE NEEDS TO KNOW IF PDL 05780020 * OBTAINED FOR FREEMAIN 05790020 BAL LINK2,STALOC BRANCH TO STORAGE ALLOCATE RTN. 05800020 SPACE 05810020 * CORE ADDRESS RETURNED IN R1 05820020 SH R1,H8 BACK UP OVER STORAGE CHAINS 05830020 ST R1,ZERO(R3) STORE ADDRESS OF PDL IN ANSWER 05840020 * PLACE 05850020 ST R1,XPDL SAVE ADDRESS OF PDL 05860020 SPACE 05870020 * 05880020 * LOAD PUTLINE/PUTGET SERVICE ROUTINES. 05890020 * 05900020 */* L LOAD PUTLINE/PUTGET ROUTINES */ 05902021 LOAD EP=IKJPUTL LOAD PUTLINE SERVICE ROUTINE 05910020 SPACE 05920020 ST R0,PUTLPTR SAVE ADDRESS OF PUTLINE 05930020 SPACE 05940020 LOAD EP=IKJPTGT LOAD PUTGET SERVICE ROUTINE 05950020 SPACE 05960020 ST R0,PUTGPTR SAVE ADDRESS OF PUTGET 05970020 LA R1,WORKSZ(PBASE) INITIALIZE BASE REGISTER FOR 05980020 * RECURSIVE WORKSPACE AS 05990020 * THROUGH FOLLOWING GETMAIN WAS 06000020 * ISSUED 06010020 XR RBASE,RBASE SET CONDITION CODE TO ZERO 06020020 B RECURSEA BRANCH TO INITIALIZE RECURSIVE 06030020 * WORKSPACE - EVERTHING IS 06040020 * SETUP AS RECURSIVE WORKSPACE 06050020 * GETMAIN WAS ISSUED - PURPOSE 06060020 * IS TO ELIMINATE ADDITIONAL 06070020 * SVC 06080020 SPACE 06090020 * 06100020 * BEGINNING NEW SUBFIELD, ALLOCATE AND INITIALIZE NEW RECURSIVE 06110020 * WORKSPACE. 06120020 * 06130020 */* D (YES,,NO,RECURSEA) BEGINNING NEW SUBFIELD */ 06132021 */*RECURSE: P NEW RWORK SPACE ALLOCATION */ 06134021 RECURSE DS 0H NEW SUBFIELD WORKSPACE 06140020 * ALLOCATION 06150020 USING RWORK,RBASE ESTABLISH BASE FOR WORKSPACE 06160020 SPACE 06170020 LA R1,RWORKSZ SET SIZE OF WORKAREA NEEDED AND 06180020 * SET SUBPOOL TO 0 06190020 LR R3,LINK1 SAVE LINKAGE REGISTER 06200020 */* S GETCORE: GET CORE FOR WORKSPACE */ 06202021 BAL LINK1,GETCORE LINK TO GETCORE TO DO 06210020 * CONDITIONAL GETMAIN FOR SPACE 06220020 SPACE 06230020 * CORE ADDRESS RETURNED IN R1 06240020 LR LINK1,R3 RESTORE LINKAGE REGISTER 06250020 TM RFLAGS,RFERASE SET CONDITION CODE FOR FLAG 06260020 * SETTING THAT FOLLOWS 06270020 SPACE 06280020 * 06290020 ******** 06300020 ******** N O T E - NO CONDITION CODE SETTING HERE UNTIL AFTER RFLAGS 06310020 ******** HAS BEEN SET UP. 06320020 ******** 06330020 * 06340020 SPACE 06350020 DROP RBASE PREPARE TO USE GETMAIN RETURNED 06360020 * ADDRESS 06370020 SPACE 06380020 RECURSEA DS 0H * * * * 06390020 */*RECURSEA: D (YES,,NO,RECURSEB) IN ERASE MODE */ 06392021 USING RWORK,R1 USE GETMAIN AREA 06400020 SPACE 06410020 MVI RFLAGS,ZERO CLEAR FLAG BYTE TO ZERO 06420020 BZ *+EIGHT TEST ABOVE CONDITION CODE --- 06430020 * SKIP FLAG SETTING IF ZERO 06440020 */* P SET INDICATOR FOR ERASE MODE */ 06442021 SPACE 06450020 OI RFLAGS,RFERASE CONTINUE IN ERASE MODE 06460020 */*RECURSEB: P SET UP RETURN LINKAGE */ 06462021 ST RBASE,RBASESV SAVE LAST RWORK AREA ADDRESS 06470020 ST XPCE,RXPCESV SAVE ADDRESS OF PCE TO RESUME AT 06480020 ST R2,RPCEAD FOR USE IN FINDING KEYWORD 06490020 * OFFSET 06500020 ST LINK1,RLINKSV SAVE RETURN LINKAGE REGISTER 06510020 DROP R1 DROP TEMPORARY BASE REGISTER 06520020 SPACE 06530020 LR RBASE,R1 UPDATE RWORK BASE REGISTER 06540020 USING RWORK,RBASE SWITCH ASSEMBLER BACK TO RBASE 06550020 */* P POINT TO FIRST PCE OR FIRST PCE IN SUBFIELD */ 06552021 SPACE 06560020 LA XPCE,TWO(R2) BUMP PCE ADDRESS TO FIRST PCE OR 06570020 * FIRST PCE IN SUBFIELD 06580020 SPACE 06590020 * 06600020 * SELECT THE APPROPRIATE PCE PROCESSOR ROUTINE. 06610020 * 06620020 */*NEXTPCE: D (YES,ENDFIELD,NO,) END-OF-FIELD PROCESSOR */ 06622021 */* D (YES,POSIT,NO,) POSITIONAL PROCESSOR */ 06624021 */* D (YES,KEYWD,NO,) KEYWD PROCESSOR */ 06626021 */* D (YES,NAMESKP,NO,) SKIP NAME PCE PROCESSOR */ 06628000 */* D (YES,PARS2CHK,NO,IDENT) IS THIS A DOBOL PCE? */ 06628400 NEXTPCE DS 0H SELECT MAIN PROCESSING ROUTINE 06630020 NI PFLAGS,HFF-PFDEFLT CLEAR POSSIBLE DEFAULT TAKEN 06640020 * FLAG 06650020 NI PFLAGS4,HFF-PFSLASH-PFLSTEND-PFPDDATA-PFENDSET TURN OFF 06660020 * POSSIBLE LIST END FLAG, SLASH 06670020 * SCAN FLAG,PROMPT/DEFAULT FLAG 06680020 * AND ENDBAKUP SET FLAG 06690020 NI PFLAGS5,HFF-INVPRMPT RESET INVALID PROMPT FLAG A45352 06692021 XR R2,R2 CLEAR WORK REGISTER TO ZERO 06700020 IC R2,PCEFLGB1(XPCE) PICK UP TYPE INDICATOR FROM PCE 06710020 N R2,TYPEMASK ISOLATE TYPE INDICATOR BITS 06720020 SRL R2,THREE POSITION BITS FOR INDEXED BRANCH 06730020 B *+FOUR(R2) BRANCH TO PCE PROCESSOR 06740020 * 06750020 MAINB DS 0H USED FOR FUTURE COMPARANDS 06760020 * 06770020 ENDB B ENDFIELD BRANCH TO END-OF-FIELD PROCESSOR 06780020 * 06790020 POSITBB B POSIT BRANCH TO POSITIONAL PROCESSOR 06800020 * 06810020 KEYWDB B KEYWDP BRANCH TO KEYWORD PROCESSOR 06820020 * 06830020 NAMEB B NAMESKP BRANCH TO SKIP NAME PCE PROCESS. 06840020 * 06850020 IDENTB B IDENT BRANCH TO IDENT PROCESSOR 06860020 RESERV B PARS2CHK RESERVED WORD PCE F41448 06862021 TERMB B PARS2CHK TERM PCE F41448 06864021 OPRTR EQU * OPER PCE F41448 06866021 */*PARS2CHK: D (YES,GOTOPRS2,NO,) HAS IKJPARS2 BEEN LOADED? */ 06866421 PARS2CHK TM CBFLAGS2,PARS2IN HAS IKJPARS2 BEEN LOADED F41448 06868021 BO GOTOPRS2 IF YES GO TO BRANCH TO F41448 06868421 * MACRO PROCESSOR F41448 06868821 LA R2,QSTRINGA IF FIRST TIME THROUGH, F41448 06869221 * INITIALIZE FOR IKJPARS2 F41448 06869621 ST R2,VCONAD STORE VCON TABLE ADDRESS F41448 06869721 * IN WORK AREA F41448 06869821 */* P LOAD IKJPARS2 */ 06869921 LOAD EP=IKJPARS2 LOAD IKJPARSW F41448 06870021 ST R0,PARS2ADR STORE ENTRY ADDRESS IN F41448 06873221 * WORK AREA F41448 06875221 OI CBFLAGS2,PARS2IN INDICATE IKJPARS2 HAS F41448 06875621 * BEEN LOADED F41448 06876021 */* P SAVE IKJPARS BASE REGISTERS */ 06876121 ST BASE3,BASE3SV SAVE IKJPARS BASE F41448 06876421 STM BASE2,RBASE,BASE2SV REGISTERS F41448 06876521 */*GOTOPRS2: P LOAD ENTRY POINT OF IKJPARS2 */ 06877321 GOTOPRS2 L R2,PARS2ADR LOAD ENTRY POINT OF F41448 06879221 * IKJPARS2 F41448 06880021 LR BASE1,PBASE SET UP REGISTER 11 FOR F41448 06881921 * USE BY IKJPARS2 IN F41448 06882321 * ADDRESSING WORK AREA F41448 06882721 */* S () IKJPARS2: BRANCH TO COBOL PCE PROCESSOR */ 06882821 BR R2 BRANCH TO IKJPARS2 F41448 06883121 *****************************************************************F41448 06883221 * THE FOLLOWING ROUTINE IS THE INTERFACR ROUTINE BETWEEN IKJPARS2 * 06886021 * AND IKJPARS. ALL IKJPARS ROUTINES ARE ENTERED THGOUGH THIS F41448 06888721 * CONTROLLER ROUTINE. F41448 06889121 *****************************************************************F41448 06890021 SPACE 06890421 */*PARS2ENT: E ENTRY INTO PARSE FROM IKJPARS2 */ 06890521 */* P PREPARE TO TRANSFER CONTROL TO SUBROUTINE */ 06890621 PARS2ENT LA LINK1,RTRNAD LOAD RETURN ADDRESS INTO F41448 06890821 * LINK1 F41448 06891221 LA LINK2,RTRNAD AND LINK2 AND STORE INTO F41448 06891321 ST LINK2,CBLNKSV2 CBLNKSV2 SO THAT ANY F41448 06891421 * SUBROUTINE CALLED WILL F41448 06891521 * RETURN TO PROPER PLACE IF F41448 06894521 * BEING CALLED BY THE COBOL F41448 06896521 * MACRO SUPPORT F41448 06896921 */* R BRANCH TO APPROPRIATE SUBROUTINE */ 06897021 BR R15 BRANCH TO SUBROUTINE. F41448 06897321 * ADDRESS PLACED IN R15 BY F41448 06897721 * THE COBOL MACRO PROCES- F41448 06897821 * SORS BEFORE COMING TO F41448 06897921 * IKJPARS F41448 06898621 */*RTRNAD: E RETURN FROM SUBROUTINE */ 06898721 */* P PRESERVE RET CODE +0, +4, +8, +12 */ 06898821 RTRNAD BAL R15,RET1 RETURN ADDRESS FROM SUB- F41448 06899021 * ROUTINES IN ON +0, +4, F41448 06899421 BAL R15,RET1 +8, OR +12. THE SERIES F41448 06899821 BAL R15,RET1 OF BAL'S AND THE SUBTRCT F41448 06899921 BAL R15,RET1 PRESERVE THE RETURN F41448 06902721 RET1 LA R14,RTRNAD+4 GET ADDRESS IN R14 IN F41448 06904721 * ORDER TO PRESERVE RETURN F41448 06905121 * CODE F41448 06905521 LA R15,ZERO(R15) ZERO HIGH ORDER BYTE FOR F41448 06905921 * SUBTRACT REGISTER F41448 06906221 SR R15,R14 PRESERVE RETURN CODE F41448 06906621 */* P RESTORE IKJPARS2 ENVIRONMENT */ 06906921 L R14,CBLRET LOAD ENTRY INTO IKJPARS2 F41448 06907921 * FOR RETURN F41448 06908221 L RBASE,AUTOBASE RESTORE AUTOMATIC DATA F41448 06908521 * BASE REGISTER F41448 06908821 LM R2,R3,TERMBASE RESTORE IKJPARS2 F41448 06909121 * ENVIRONMENT F41448 06909421 LR BASE1,PBASE WORK AREA BASE REG F41448 06909721 */* R () RETURN TO IKJPARS2 */ 06909821 BR R14 RETURN TO COBOL SUPPORT F41448 06910021 * MODULE F41448 06911821 EJECT 06914421 *********************************************************************** 06917021 * * 06919621 * END-OF-FIELD ROUTINE * 06922221 * * 06924821 * THIS ROUTINE IS ENTERED FROM THE MAIN CONTROL ROUTINE WHEN AN * 06927421 * IKJENDP OR AN IKJSUBF PCE IS ENCOUNTERED. IF A SUBFIELD IS BEING * 06930020 * PROCESSED THE END OF THE SUBFIELD, A RIGHT PARENTHESIS, IS SEARCHED * 06940020 * FOR. IF NOT FOUND THE REMAINING PARAMETERS ARE CONSIDERED EXTRANEOUS* 06950020 * IF AN IKJKEYWD PCE WAS NEVER FOUND IN THE PCL OR INVALID KEYWORDS * 06960020 * IF ONE WAS. IF THE END OF THE SUBFIELD WAS FOUND THE RECURSIVE * 06970020 * WORKSPACE IS FREED. * 06980020 * CONTROL IS THEN GIVEN TO THE EXIT ROUTINE IF NO MORE RECURSIVE * 06990020 * WORKSPACES REMAIN OR TO THE KEYWD ROUTINE IF MORE REMAIN. * 07000020 * * 07010020 *********************************************************************** 07020020 */*ENDFIELD: D (YES,ENDFINDL,NO,) IN ERASE MODE */ 07022021 SPACE 07030020 ENDFIELD DS 0H END-OF-FIELD PROCESSOR 07040020 TM RFLAGS,RFERASE ARE WE IN ERASE MODE 07050020 BO ENDFINDL IF BIT ON YES --- SKIP SCANNING 07060020 */*ENDFISCN: S SCANF: POP THE STACK IF POSSIBLE */ 07062021 SPACE 07070020 ENDFISCN DS 0H * * * * 07080020 BAL LINK1,SCANF IF POSSIBLE, POP THE STACK 07090020 * 07100020 NOP ZERO +0 RETURN -NO MORE DATA - OK 07110020 * 07120020 * +4 RETURN - MORE DATA 07130020 */* S SKIPB: SKIP SEPARATORS */ 07132021 BAL LINK2,SKIPB BRANCH TO SKIP BLANKS SUBROUTINE 07140020 * 07150020 */* D (YES,ENDFINDL,NO,) REACHED END OF INPUT */ 07152021 B ENDFINDL +0 RETURN - RIGHT PAREN 07160020 * 07170020 * +4 RETURN - PPOINTR SET 07180020 */* P INCREMENT SCAN POINTER */ 07182021 LA XINPUT,ONE(XINPUT) INCREMENT SCAN REGISTER 07190020 */* D (YES,ENDFISMI,NO,) LAST LEVEL COMPLETE OR NO SUBFIELD */ 07192021 NC RBASESV,RBASESV WAS LAST LEVEL COMPLETE OR NO 07200020 * SUBFIELD 07210020 BZ ENDFISMI IF ZERO YES --- BRANCH 07220020 */* D (YES,ENDFINDL,NO,ENDEXTRA) REACHED END OF INPUT */ 07222021 SPACE 07230020 CLI ZERO(XINPUT),RIGHTPRN WAS A CLOSE PAREN FOUND 07240020 BE ENDFINDL YES --- ALLOW IT TO BE SKIPPED 07250020 SPACE 07260020 B ENDEXTRA NO -- ERROR CONDITION -- BRANCH 07270020 */*ENDFISMI: D (YES,,NO,ENDEXTRA) FIRST STACK IN CHAIN */ 07272021 SPACE 07280020 ENDFISMI DS 0H * * * * 07290020 L R1,PIPDLCUR LOAD PTR TO CURRENT STACK 07300020 NC ONE(THREE,R1),ONE(R1) IS THIS FIRST STACK IN CHAIN 07310020 BNZ ENDEXTRA IF NO BRANCH 07320020 */* D (YES,,NO,ENDEXTRA) AT LAST LEVEL */ 07322021 SPACE 07330020 CLI PIPDLX,ZERO DON'T ALLOW SEMICOLON EXCEPT AT 07340020 * LAST LEVEL 07350020 BNZ ENDEXTRA IF NOT --- BRANCH 07360020 */* D (YES,,NO,ENDEXTRA) ENDING SEMICOLON */ 07362021 SPACE 07370020 CLI ZERO(XINPUT),SEMICOLN IS IT THE ENDING SEMICOLON 07380020 BNE ENDEXTRA NO -- ERROR CONDITION -- BRANCH 07390020 SPACE 07400020 * 07410020 * FREE RECURSIVE WORKSPACE. 07420020 * 07430020 */*ENDFINDL: L FREE RWORK AREA */ 07432021 ENDFINDL DS 0H * * * * 07440020 LR R1,RBASE INITIALIZE TEMPORARY BASE REG. 07450020 SPACE 07460020 DROP RBASE DROP NORMAL BASE 07470020 USING RWORK,R1 CREATE TEMPORARY BASE REGISTER 07480020 SPACE 07490020 L XPCE,RXPCESV RESTORE LAST PCE ADDRESS 07500020 L RBASE,RBASESV RESTORE PREVIOUS RWORK BASE REG. 07510020 L LINK1,RLINKSV RESTORE PREVIOUS LINKAGE REG. 07520020 SPACE 07530020 DROP R1 DROP TEMPORARY BASE REGISTER 07540020 USING RWORK,RBASE RE-ESTABLISH NORMAL BASE REG. 07550020 SPACE 07560020 FREEMAIN R,LV=RWORKSZ,A=(1) RELEASE RWORK AREA 07570020 */* D (YES,EXIT,NO,) LAST RECURSIVE WORKSPACE */ 07572021 SPACE 07580020 LTR RBASE,RBASE WAS THAT THE LAST RECURSIVE 07590020 * WORKSPACE 07600020 BZ EXIT YES IF ZERO --- BRANCH 07610020 SPACE 07620020 NI PFLAGS3,HFF-PFMORE CLEAR POSSIBLE 'WHAT TO DO WITH 07630020 * RIGHT PAREN' FLAG 07640020 NI RFLAGS,HFF-RFKEYWDS CLEAR CAUSE OF ENTRY FLAG 07650020 */* R RETURN TO CALLER */ 07652021 BR LINK1 RETURN TO CALLER 07660020 SPACE 07670020 * 07680020 * SOME DATA WAS LEFT IN THE INPUT BUFFER OR INSIDE OF A SUBFIELD BUT 07690020 * THE PCL WAS EXHAUSTED. SINCE RFLAGS IS ASSOCIATED WITH A SUBFIELD 07700020 * LEVEL THE MESSAGE TO BE ISSUED IS RELEVANT TO SUBFIELDS RATHER THAN 07710020 * TO THE ENTIRE BUFFER. IF NO SUBFIELDS WERE SPECIFIED IT CAN BE 07720020 * CONSIDERED AS SUBFIELD LEVEL ZERO. THE FLAG NEED NOT BE TURNED OFF 07730020 * SINCE WHEN THE END OF THE SUBFIELD IS FOUND THE RWORK AREA IS FREED. 07740020 * 07750020 * CHECK TO SEE IF AN 'INVALID KEYWORD' OR AN 'EXTRANEOUS 07760020 * INFORMATION' MESSAGE IS TO BE PRINTED. THE 'INVALID KEYWORD' MESSAGE 07770020 * IS WRITTEN INSTEAD OF THE 'EXTRANEOUS INFORMATION' MESSAGE IF AN 07780020 * IKJKEYWD PCE WAS ENCOUNTERED. 07790020 * 07800020 */*ENDEXTRA: D (YES,ILLKEYWD,NO,) IKJEYWD PCE FOUND */ 07802021 ENDEXTRA DS 0H * * * * 07810020 TM RFLAGS,RFPRES WAS A IKJKEYWD PCE FOUND 07820020 BO ILLKEYWD IF YES PRINT INVALID MESSAGE 07830020 */* P COMPLETE LENGTH OF EXTRANEOUS DATA */ 07832021 SPACE 07840020 LR XINPUTB,XINPUT SAVE BEGINNING OF EXTRA DATA 07850020 * ADDRESS 07860020 BCTR XINPUT,ZERO DECREMENT FOR NEXT INCREMENT 07870020 SPACE 07880020 ENDEX1 DS 0H * * * * 07890020 LA XINPUT,ONE(XINPUT) BUMP INPUT POINTER 07900020 LR R2,XINPUT SAVE PTR FOR LATER SUBTRACTION 07910020 C XINPUT,ENDINPUT END OF INPUT BUFFER 07920020 BE ENDEX2 IF YES BRANCH 07930020 SPACE 07940020 NC RBASESV,RBASESV IS A SUBFIELD BEING PROCESSED 07950020 BZ ENDEX1 IF NO REMAINDER OF BUFFER IS 07960020 * EXTRANEOUS DATA 07970020 SPACE 07980020 CLI ZERO(XINPUT),RIGHTPRN END OF SUBFIELD 07990020 BNE ENDEX1 IF NO BRANCH 08000020 SPACE 08010020 ENDEX2 DS 0H * * * * 08020020 SR R2,XINPUTB COMPUTE LENGTH OF EXTRA DATA 08030020 */* S GETCORE: GET CORE FOR MESSAGE SEGMENT */ 08032021 LA R1,FOUR(R2) GET SIZE OF CORE FOR MESSAGE SEG 08040020 * PLUS FOUR FOR HEADER 08050020 BAL LINK1,GETCORE GET CORE FOR MESSAGE SEGMENT 08060020 SPACE 08070020 * CORE ADDRESS RETURNED IN R1 08080020 ST R1,SEGLIST+TWELVE STORE ADDRESS IN LIST OF SEGMENT 08090020 LA R0,FOUR(R2) GET SEGMENT SIZE 08100020 STH R0,ZERO(R1) STORE SIZE IN SEGMENT 08110020 MVI TWO(R1),ZERO SET FIRST BYTE OF OFFSET TO ZERO 08120020 MVI THREE(R1),OFFSET3 SET OFFSET TO LENGTH OF 08130020 * 'EXTRANEOUS INFORMATION' MSG 08140020 LR R15,XINPUTB MOVE START OF DATA ADDRESS 08150020 BCTR R2,ZERO REDUCE LENGTH FOR 'EX' 08160020 EX R2,BUILDSEG MOVE TEXT TO NEW SEGMENT 08170020 */* P INDICATE 'EXTRANEOUS INFORMATION' MSG */ 08172021 MVI MSGCODE,MSG17 INDICATE MESSAGE TO WRITE 08180020 */* S WRITER1: WRITE THE MESSAGE */ 08182021 BAL LINK1,WRITER1 WRITE THE MESSAGE 08190020 */* D (YES,ENDFISCN) POP THE STACK UNTIL NO MORE DATA */ 08192021 SPACE 08200020 BCT XINPUT,ENDFISCN POP STACK, IF POSSIBLE, UNTIL 08210020 * ITS COMPLETELY FREE OF DATA 08220020 EJECT 08230020 *********************************************************************** 08240020 * * 08250020 * EXIT ROUTINE * 08260020 * * 08270020 * THIS ROUTINE IS ENTERED FROM THE END-OF-FIELD ROUTINE WHEN THE * 08280020 * ORIGINAL RECURSIVE WORKSPACE HAS BEEN FREED. ITS ALSO ENTERED FROM * 08290020 * THE CLEANUP ROUTINE IF AN ABNORMAL TERMINATION OCCURS. * 08300020 * IN THIS ROUTINE THE INPUT BUFFER OFFSET IS UPDATED, THE I/O * 08310020 * ROUTINES ARE DELETED, THE PERMANENT WORKSPACE IS FREED AND CONTROL * 08320020 * IS RETURNED TO PARSE'S CALLER WITH A RETURN CODE IN REGISTER 15. * 08330020 * * 08340020 *********************************************************************** 08350020 */*EXIT: P COMPUTE CURRENT OFFSET */ 08352021 SPACE 08360020 EXIT DS 0H PARSE EXIT ROUTINE 08370020 L R2,FOUR(PBASE) LOAD CALLERS SAVE AREA ADDRESS 08380020 L R2,TWENTY4(R2) LOAD ORIGINAL INPUT PARAMETER 08390020 * ADDRESS 08400020 L R3,TWENTY(R2) LOAD ORIGINAL INPUT BUFFER ADR. 08410020 LA R3,ZERO(R3) CLEAR HIGH ORDER BYTE 08420020 MVC PDWORD(TWO),ZERO(R3) ALIGN ORIGINAL BUFFER LENGTH ON 08430020 * PROPER BOUNDARY 08440020 SR XINPUT,R3 COMPUTE CURRENT OFFSET 08450020 SH XINPUT,H4 COMPUTE OFFSET TO SEMICOLON 08460020 BM EXITRST DOES NOT LIE WITHIN INPUT, RESET 08470020 * TO ALL 08480020 SPACE 08490020 TM PFLAGS,PFENDF HAD WE RUN OFF THE END 08500020 BO EXITRST YES USE THIS OFFSET 08510020 SPACE 08520020 CH XINPUT,PDWORD SEE IF NEW OFFSET LIES WITHIN 08530020 * INPUT BUFFER 08540020 BL EXITANS YES USE THIS OFFSET 08550020 */*EXITRST: P REDUCE ORIGINAL BUFFER LENGTH BY LENGTH,OFFSET FIELDS */ 08552021 SPACE 08560020 EXITRST DS 0H * * * * 08570020 LH XINPUT,PDWORD GET ORIGINAL BUFFER LENGTH 08580020 SH XINPUT,H5 REDUCE BY SIZE OF LENGTH AND 08590020 * OFFSET FIELDS 08600020 SPACE 08610020 * 08620020 * UPDATE THE INPUT BUFFER OFFSET FIELD. 08630020 * 08640020 */*EXITANS: P UPDATE OFFSET IN INPUT BUFFER */ 08642021 EXITANS DS 0H * * * * 08650020 LA XINPUT,ONE(XINPUT) INCREMENT SCAN REGISTER TO NEXT 08660020 * CHARACTER 08670020 STH XINPUT,PDWORD STORE NEW OFFSET FOR MVC 08680020 MVC TWO(TWO,R3),PDWORD UPDATE OFFSET IN INPUT BUFFER 08690020 SPACE 08700020 * 08710020 * DELETE PUTLINE/PUTGET SERVICE ROUTINES. 08720020 * 08730020 */*EXITNORM: L DELETE PUTLINE/PUTGET RTNS */ 08732021 EXITNORM DS 0H ENTRY FROM CLEANUP 08740020 DELETE EP=IKJPUTL DELETE PUTLINE SERVICE ROUTINE 08750020 SPACE 08760020 DELETE EP=IKJPTGT DELETE PUTGET SERVICE ROUTINE 08770020 SPACE 08780020 DELETE EP=IKJPARS2 DELETE PARS2 LOAD MODULE F41448 08782021 SPACE 08784000 XR LINK1,LINK1 ZERO WORK REGISTER 08790020 IC LINK1,RETCODE LOAD THE RETURN CODE 08800020 LR R1,PBASE LOAD CORE ADDRESS FOR FREEMAIN 08810020 L PBASE,FOUR(PBASE) RESTORE CALLERS SAVE AREA ADR. 08820020 SPACE 08830020 FREEMAIN R,LV=WORKSZ,A=(1) RELEASE PERMANENT WORK AREA 08840020 */* P LOAD THE RETURN CODE */ 08842021 SPACE 08850020 LR R15,LINK1 LOAD PROPER RETURN CODE REGISTER 08860020 * FOR RETURN MACRO 08870020 */* R EXIT FROM PARSE */ 08872021 SPACE 08880020 RETURN (14,12),RC=(15) EXIT FROM PARSE 08890020 EJECT 08900020 *********************************************************************** 08910020 * * 08920020 * KEYWORD ROUTINE * 08930020 * * 08940020 * CONTROL IS OBTAINED FROM THE MAIN CONTROL ROUTINE. IF A KEYWORD * 08950020 * PARAMETER IS CURRENTLY BEING PARSED CONTROL IS GIVEN TO THE KEYWORD * 08960020 * SCAN ROUTINE. OTHERWISE A DEFAULT IS PICKED UP, IF PROVIDED, AND * 08970020 * SCANNED AS A NORMAL INPUT PARAMETER. * 08980020 * CONTROL MAY BE PASSED TO THE MAIN CONTROL ROUTINE IF IN ERASE * 08990020 * MODE OR A DEFAULT WAS NOT SUPPLIED. * 09000020 * * 09010020 *********************************************************************** 09020020 */*KEYWDP: P SET INDICATOR FOR IKJKEYWD PCE FOUND */ 09022021 SPACE 09030020 KEYWDP DS 0H KEYWORD ROUTINE 09040020 OI RFLAGS,RFPRES INDICATE A IKJKEYWD PCE WAS 09050020 * FOUND FOR A POSSIBLE MESSAGE 09060020 * IN THE END-OF-FIELD ROUTINE 09070020 */* D (YES,KEYWD,NO,) KEYWORD CURRENTLY BEING PARSED */ 09072021 TM RFLAGS,RFKYPRSE+RFERASE IS KEYWORD PARSE REQUIRED 09080020 BZ KEYWD NO, GO TO PARSE THEN 09090020 SPACE 09100020 MVC PDWORD(TWO),PCEPDEO(XPCE) ALIGN PDE OFFSET ON PROPER 09110020 * BOUNDARY 09120020 LH R2,PDWORD LOAD THE PDE OFFSET 09130020 A R2,XPDL GET TRUE ADDRESS OF PDE 09140020 */* D (YES,KEYWDER1,NO,) PDE ALREADY FILLED IN */ 09142021 NC ZERO(TWO,R2),ZERO(R2) SEE IF PDE ALREADY FILLED 09150020 BNZ KEYWDER1 IF YES SEE IF ERASING 09160020 */* D (YES,KEYWDPNX,NO,) IN ERASE MODE */ 09162021 SPACE 09170020 TM RFLAGS,RFERASE NO DEFAULT IF ERASING 09180020 BO KEYWDPNX GO TO FIRST NAME 09190020 */* S PROMPTQ: CHECK FOR PROMPT/DEFAULT */ 09192021 SPACE 09200020 BAL LINK1,PROMPTQ BRANCH TO PROMPT/DEFAULT ROUTINE 09210020 * 09220020 */* D (YES,KEYWDPRC,NO,KEYWDPNX) NEW DATA RETURNED */ 09222021 B KEYWDPRC +0 RETURN - PROCESS NEW LINE 09230020 * 09240020 * +4 RETURN - NO PROMPT OR DEFAULT 09250020 B KEYWDPNX GET NEXT PCE 09260020 SPACE 09270020 * 09280020 * SET UP TO SCAN NEW DATA. 09290020 * 09300020 */*KEYWDPRC: P POINT TO NEW PCE FOR NEW INPUT BUFFER */ 09302021 KEYWDPRC DS 0H * * * * 09310020 L XPCE,RPCEAD REFETCH START OF SUBFIELD ADDR. 09320020 MVC PDWORD(TWO),ZERO(XPCE) ALIGN OFFSET TO IKJKEYWD PCE --- 09330020 * RTABLEAD POINTS TO THE 09340020 * IKJSUBF PCE+1 --- ON PROPER 09350020 * BOUNDARY 09360020 L XPCE,PTABLEAD LOAD START OF PCL ADDRESS 09370020 AH XPCE,PDWORD POINT TO NEW PCE FOR NEW INPUT 09380020 * BUFFER 09390020 */* D (,KEYWD) PARSE NEW KEYWORD */ 09392021 B KEYWD BRANCH TO PARSE THE KEYWORD 09400020 */*KEYWDER1: D (YES,,NO,KEYWDPNX) IN ERASE MODE */ 09402021 SPACE 09410020 KEYWDER1 DS 0H * * * * 09420020 LA R0,KEYWDER3 SET RETURN LINKAGE TO CONTINUE 09430020 ST R0,RLINKSV1 STORE IN CASE RECURSE 09440020 SPACE 09450020 TM RFLAGS,RFERASE IN ERASE MODE 09460020 BZ KEYWDPNX NO --- BRANCH - PROCESS NORMALLY 09470020 SPACE 09480020 * 09490020 * ENTRY POINT FROM THE KEYWORD SCAN SUBROUTINE WHEN A KEYWORD PDE 09500020 * WAS ALREADY FILLED IN AND MUST BE ERASED. 09510020 * 09520020 */*KEYWDER4: P CLEAR KEYWORD NUMBER TO ZERO */ 09522021 KEYWDER4 DS 0H * * * * 09530020 LH R3,ZERO(R2) PICK UP KEYWORD NUMBER TO ERASE 09540020 * R3 USED TO FIND CORRECT 09550020 * IKJNAME PCE --- NAMESKP RTN 09560020 * GETS CONTROL NEXT 09570020 XC ZERO(TWO,R2),ZERO(R2) CLEAR OLD KEYWORD NUMBER TO ZERO 09580020 */*KEYWDPNX: D (,NEXTPCE) GET NEXT PCE */ 09582021 SPACE 09590020 KEYWDPNX DS 0H * * * * 09600020 BAL LINK1,KEYWDX1 COMPUTE NEXT PCE ADDRESS 09610020 SPACE 09620020 B NEXTPCE GET NEXT PCE 09630020 EJECT 09640020 *********************************************************************** 09650020 * * 09660020 * SKIP KEYWORD PCE SUBROUTINE * 09670020 * * 09680020 * THE FUNCTION OF THIS ROUTINE IS TO SKIP OVER A KEYWORD PCE. * 09690020 * RETURN - LINK1 * 09700020 * * 09710020 *********************************************************************** 09720020 */*KEYWDX1: E SKIP KEYWORD PCE ROUTINE */ 09722021 */*KEYWDX2: P ADD PCE ADDRESS TO LENGTH OF PDE */ 09724021 SPACE 09730020 KEYWDX1 DS 0H SKIP IKJKEYWD PCE SUBROUTINE 09740020 ST XPCE,PKEYWDPC SAVE THE CURRENT PCE ADDRESS 09750020 MVC PDWORD(TWO),PCEPDEO(XPCE) ALIGN PDE OFFSET FIELD ON 09760020 * PROPER BOUNDARY 09770020 LH R1,PDWORD LOAD THE PDE LENGTH 09780020 A R1,XPDL GET TRUE ADDRESS OF PDE 09790020 ST R1,PKEYWDPS SAVE ADDRESS FOR FUTURE USE IN 09800020 * CASE OF A MATCH 09810020 MVC PDWORD(TWO),PCELEN(XPCE) ALIGN PCE LENGTH FIELD ON 09820020 * PROPER BOUNDARY 09830020 AH XPCE,PDWORD BUMP PTR TO NEXT PCE 09840020 */* R RETURN TO CALLER */ 09842021 BR LINK1 RETURN TO CALLER 09850020 EJECT 09860020 *********************************************************************** 09870020 * * 09880020 * SKIP IKJNAME PCE ROUTINE * 09890020 * * 09900020 * THIS ROUTINE IS ENTERED FROM THE MAIN CONTROL ROUTINE WHEN AN * 09910020 * IKJNAME PCE IS ENCOUNTERED IN THE PCL. IF NOT IN KEYWORD ERASE MODE * 09920020 * THE NEXT PCE ADDRESS IS OBTAINED AND THE MAIN CONTROL ROUTINE GETS * 09930020 * CONTROL. IF IN ERASE MODE, THE PCE OF THE CORRESPONDING IKJNAME * 09940020 * SUBFIELD IS OBTAINED, IF ONE WAS SPECIFIED, AND ANOTHER RECURSIVE * 09950020 * WORK AREA IS OBTAINED. SINCE A KEYWORD MAY HAVE A SUBFIELD WITH * 09960020 * POSITIONAL PARAMETERS OR KEYWORDS IN IT THE SUBFIELD PDE MUST * 09970020 * ALSO BE ERASED. * 09980020 * ENTRY - IF ERASE MODE R3 CONTAINS NUMBER OF IKJNAME PCE * 09990020 * LOOKING FOR * 10000020 * * 10010020 *********************************************************************** 10020020 */*NAMESKP: D (YES,,NO,NAMESKP3) IN ERASE MODE */ 10022021 SPACE 10030020 NAMESKP DS 0H SKIP IKJNAME PCE ROUTINE 10040020 TM RFLAGS,RFERASE IN ERASE MODE 10050020 BZ NAMESKP3 NO --- NORMAL OPERATION - BRANCH 10060020 */* D (YES,,NO,NAMESKP3) THIS THE IKJNAME PCE LOOKING FOR */ 10062021 SPACE 10070020 BCT R3,NAMESKP3 IF IN ERASE MODE - IS THIS THE 10080020 * IKJNAME PCE LOOKING FOR 10090020 SPACE 10100020 * WHEN FALL THROUGH ANSWER YES 10110020 SPACE 10120020 * 10130020 * SET UP TO ERASE ANY SUBFIELD INFORMATION THAT MAY BE IN THE PDL. 10140020 * 10150020 */* D (YES,,NO,KEYWDER2) SUBFIELD SPECIFIED */ 10152021 TM PCEFLGB1(XPCE),PCEFSUBF IS A SUBFIELD SPECIFIED 10160020 BZ KEYWDER2 NO LEAVE ERASE FOR THIS ONE 10170020 */* P GET TRUE ADDRESS OF SUBFIELD PCE */ 10172021 SPACE 10180020 XR R2,R2 CLEAR WORK REG TO ZERO 10190020 IC R2,PCENAML(XPCE) PICK UP LENGTH - 1 OF NAME 10200020 AR R2,XPCE ADD PCE ADDRESS TO POINT PAST 10210020 * NAME FIELD 10220020 MVC PDWORD(TWO),PCENAMN+ONE(R2) ALIGN SUBFIELD OFFSET ON 10230020 * PROPER BOUNDARY 10240020 LH R2,PDWORD LOAD SUBFIELD OFFSET 10250020 A R2,PTABLEAD GET TRUE ADDRESS OF SUBFIELD PCE 10260020 */* L GO TO RECURSE TO OBTAIN NEW RECURSIVE WORKSPACE */ 10262021 BAL LINK1,RECURSE OBTAIN NEW RECURSIVE WORKSPACE 10270020 */*KEYWDER2: D (YES,,NO,KEYWDFNO) SUBFIELD HAS KEYWDS IN IT */ 10272021 SPACE 10280020 KEYWDER2 DS 0H * * * * 10290020 L R15,RLINKSV1 ON RETURN FROM RECURSE LEAVE 10300020 BR R15 ERASE MODE FOR THIS KEYWORD 10310020 */*KEYWDER3: P SET INFINITE COUNT IF STILL HIGH */ 10312021 SPACE 10320020 KEYWDER3 DS 0H * * * * 10330020 SR R3,R3 SET INFINITE COUNT IF STILL HIGH 10340020 */*NAMESKP3: D (,NEXTPCE) GET NEXT PCE */ 10342021 SPACE 10350020 NAMESKP3 DS 0H * * * * 10360020 MVC PDWORD(TWO),PCELEN(XPCE) ALIGN PCE LENGTH ON PROPER 10370020 * BOUNDARY 10380020 AH XPCE,PDWORD POINT TO NEXT PCE IN LIST 10390020 B NEXTPCE OBTAIN NEXT PCE 10400020 EJECT 10410020 *********************************************************************** 10420020 * * 10430020 * SELECT POSITIONAL PARAMETER ROUTINE * 10440020 * * 10450020 * THE FOLLOWING ROUTINES PROCESS THE VARIOUS PARAMETERS DESCRIBED * 10460020 * BY AN IKJPOSIT PCE. THE POSITIONAL PARAMETER TYPE IS USED IN THE * 10470020 * SELECTION OF THE APPROPRIATE ROUTINE. * 10480020 * * 10490020 *********************************************************************** 10500020 */*POSIT: D (YES,,NO,POSIT1) IN ERASE MODE */ 10502021 SPACE 10510020 POSIT DS 0H SELECT POSITIONAL ROUTINE 10520020 TM RFLAGS,RFERASE SHOULD SCANNING BE DONE 10530020 BO POSIT1 NO IF IN ERASE MODE --- BRANCH 10540020 */* S SCANF: POP THE STACK IF POSSIBLE */ 10542021 SPACE 10550020 BAL LINK1,SCANF DROP LEVEL IN PUSH DOWN LIST IF 10560020 * POSSIBLE 10570020 * 10580020 NOP ZERO +0 RETURN - NO INPUT DATA LEFT 10590020 * 10600020 * +4 RETURN - DATA REMAINS IN 10610020 * CURRENT BUFFER OR POP OCCURED 10620020 SPACE 10630020 * 10640020 * SELECT THE POSITIONAL ROUTINE TO GET CONTROL. IF IN ERASE MODE R2 10650020 * SHOULD CONTAIN THE MASSAGED POSITIONAL TYPE BEFORE BRANCHING TO THE 10660020 * ERASE ROUTINE. 10670020 * 10680020 */*POSIT1: P GET POSITIONAL TYPE BYTE */ 10682021 POSIT1 DS 0H * * * * 10690020 XR R2,R2 CLEAR WORK REG TO ZERO 10700020 IC R2,PCEPOST(XPCE) PICK UP THE POSITIONAL TYPE BYTE 10710020 SLL R2,TWO MULTIPLY TYPE FLAG BY FOUR 10720020 */* D (YES,POSITERS,NO,) IN ERASE MODE */ 10722021 TM RFLAGS,RFERASE ARE WE IN ERASE MODE 10730020 BO POSITERS BRANCH TO POSITIONAL ERASE RTN. 10740020 SPACE 10750020 XC TEMPPDE(LTPDE),TEMPPDE ZERO TEMPORARY STORAGE AREA 10760020 * FOR PDE 10770020 B *+FOUR(R2) BRANCH INTO BRANCH TABLE 10780020 * 10790020 POSITB DS 0H LABEL USED TO DETERMINE AT A 10800020 * LATER TIME WHICH BRANCH 10810020 * WAS TAKEN 10820020 * 10830020 */* D (YES,INVPARMS,NO,) INVALID POSITIONAL TYPE */ 10832021 */* D (YES,DELIMITR,NO,) DELIMITER */ 10834021 */* D (YES,STRING,NO,) SELF-DELIMITING STRING */ 10836021 */* D (YES,VALUE,NO,) VALUE TYPE */ 10838021 */* D (YES,ADDRESS,NO,) ADDRESS */ 10838421 */* D (YES,PSTRING,NO,) PARENTHESIZED STRING */ 10838821 */* D (YES,USERID,NO,) USERID */ 10839221 */* D (YES,DSNAME,NO,) DSNAME */ 10839621 */* D (YES,DSNAME,NO,) ASTERISK FOR DSNAME */ 10839721 */* D (YES,QSTRING,NO,SPACE) QUOTED STRING - IF NOT, MUST BE SPACE */ 10839821 B INVPARMS TYPE 0 - NONEXISTENT TYPE 10840020 * 10850020 DELIMB B DELIMITR TYPE 1 - DELIMITER 10860020 * 10870020 STRINB B STRING TYPE 2 - SELF-DELIMITING STRING 10880020 * 10890020 VALUEB B VALUE TYPE 3 - VALUE 10900020 * 10910020 ADDRB B ADDRESS TYPE 4 - ADDRESS 10920020 * 10930020 PSTRIB B PSTRING TYPE 5 - PARENTHESIZED STRING 10940020 * 10950020 USIDB B USERID TYPE 6 - USERID 10960020 * 10970020 DSNAMB B DSNAME TYPE 7 - DSNAME 10980020 * 10990020 DSTHIB B DSNAME TYPE 8 - * FOR DSNAME 11000020 * 11010020 QSTRIB B QSTRING TYPE 9 - QUOTED STRING 11020020 * 11030020 SPACEB B SPACE TYPE 10 - SPACE 11040020 EJECT 11050020 *********************************************************************** 11060020 * * 11070020 * POSITIONAL DELIMITER ROUTINE * 11080020 * * 11090020 * THIS ROUTINE PROCESSES THE DELIMITER OF A SELF-DEFINED STRING. * 11100020 * THE FOLLOWING ARE THE CHARACTERS WHICH MAY DELIMIT A SELF-DEFINED * 11110020 * STRING - ANY ENTERABLE CHARACTER EXCEPT A DIGIT, LEFT PAREN, * 11120020 * RIGHT PAREN, SEMICOLON, BLANK, COMMA, TAB, ASTERISK, OR NEW LINE * 11130020 * CHARACTER. IF THE FIRST NON-BLANK CHARACTER IS NOT A SUITABLE * 11140020 * DELIMITER, THE STRING IS CONSIDERED MISSING. A NEW LINE CHARACTER * 11150020 * IS SAVED FOR POSSIBLE COMPARES FOR THE END OF THE STRING AND A * 11160020 * FLAG IS SET TO INDICATE THE STRING SHOULD BE PROMPTED FOR WHEN A * 11170020 * STRING PCE IS PROCESSED. IF THE FIRST NON-BLANK CHARACTER IS A * 11180020 * SUITABLE DELIMITER, IT IS SAVED FOR FUTURE COMPARES FOR THE END * 11190020 * OF THE STRING. * 11200020 * * 11210020 *********************************************************************** 11220020 */*DELIMITR: S SKIPB: SKIP SEPARATORS */ 11222021 SPACE 11230020 DELIMITR DS 0H DELIMITER ROUTINE 11240020 BAL LINK2,SKIPB SKIP SEPARATORS TO DELIMITER 11250020 * 11260020 */* D (YES,DELIMNL,NO,) REACHED END OF INPUT */ 11262021 B DELIMNL +0 RETURN, REACHED END OF INPUT, 11270020 * STRING IS MISSING 11280020 * 11290020 * +4 RETURN, FOUND NON-SEPARATOR 11300020 * 11310020 LA XINPUT,ONE(XINPUT) GET NEXT CHARACTER 11320020 */* S TYPETEST: CHECK FOR LETTER OR SPECIAL CHARACTER */ 11322021 LA R1,ALPHA+NDLIMSPC IS DELIM A LETTER OR SPECIAL 11330020 BAL LINK1,TYPETEST CHARACTER 11340020 * 11350020 */* D (YES,,NO,DELIMNL1) DELIMITER IS LETTER OR SPECIAL CHARACTER */ 11352021 B DELIMNL1 +0 RETURN - NO, INVALID DELIM, 11360020 * THEN STRING IS MISSING 11370020 * 11380020 * +4 RETURN - YES, BUT CHECK FOR 11390020 * ASTERISK AND LEFT PAREN 11400020 * 11410020 */* D (YES,DELIMNL1,NO,) DELIMITER IS AN ASTERISK */ 11412021 CLI ZERO(XINPUT),ASTERISK IS DELIM AN ASTERISK 11420020 BE DELIMNL1 YES, THEN DELIM IS INVALID AND 11430020 * STRING IS MISSING 11440020 */* D (YES,DELIMNL1,NO,) DELIMITER IS LEFT PAREN */ 11442021 SPACE 11450020 CLI ZERO(XINPUT),LEFTPRN IS DELIM A LEFT PAREN 11460020 BE DELIMNL1 YES, THEN DELIM IS INVALID AND 11470020 * STRING IS MISSING 11480020 */* P SAVE DELIMITER FOR FINDING END OF STRING */ 11482021 SPACE 11490020 MVC PDELIM,ZERO(XINPUT) SAVE THE DELIMITER FOR FUTURE 11500020 * COMPARES FOR END OF STRING 11510020 NI PFLAGS3,HFF-PFSTPRMT CLEAR POSSIBLE PROMPT-FOR-STRING 11520020 * INDICATOR 11530020 NI PFLAGS4,HFF-PFENDLIM CLEAR POSSIBLE END-DELIMITER 11540020 * FOUND INDICATOR 11550020 */* D (,POSITX3) EXIT */ 11552021 B POSITX3 EXIT 11560020 */*DELIMNL1: P BACK UP SCAN POINTER */ 11562021 SPACE 11570020 DELIMNL1 DS 0H * * * * 11580020 BCTR XINPUT,ZERO BACK UP INPUT POINTER 11590020 */*DELIMNL: P SAVE NEW LINE CHARACTER */ 11592021 SPACE 11600020 DELIMNL DS 0H * * * * 11610020 MVI PDELIM,NLCHAR STORE NEW LINE CHARACTER FOR 11620020 * COMPARES FOR END OF STRING 11630020 * AFTER PROMPT OR DEFAULT 11640020 */* P SET INDICATOR FOR PROMPT */ 11642021 OI PFLAGS3,PFSTPRMT SET PROMPT-FOR-STRING INDICATOR 11650020 */* D (,POSITX3) EXIT ROUTINE */ 11652021 B POSITX3 EXIT 11660020 EJECT 11670020 *********************************************************************** 11680020 * * 11690020 * POSITIONAL SELF-DELIMITING STRING ROUTINE * 11700020 * * 11710020 * THIS ROUTINE PROCESSES A STRING WHICH IS DELIMITED BY A SELF- * 11720020 * DEFINED DELIMITER. IT ASSUMES A DELIMITER PCE HAS ALREADY BEEN * 11730020 * PROCESSED. IF THE 'DELIMITER' WAS AN UNSUITABLE DELIMITER A FLAG * 11740020 * WAS SET BY THE DELIMITER ROUTINE INDICATING THE STRING SHOULD BE * 11750020 * PROMPTED FOR IF REQUIRED. THE DATA RECEIVED FROM A PROMPT OR * 11760020 * DEFAULT DOES NOT INCLUDE DELIMITERS. THE END OF THE STRING IS * 11770020 * FOUND WHEN THE SELF-DEFINED DELIMITER IS SCANNED OR THE END OF THE * 11780020 * INPUT IS REACHED. NULL STRINGS HAVE A POINTER SET AND A LENGTH * 11790020 * OF ZERO. IF THE STRING IS REQUIRED A NULL STRING MUST BE ENTERED * 11800020 * AS TWO CONTIGUOUS SELF-DEFINED DELIMITERS. IF A STRING IS NOT * 11810020 * REQUIRED A NULL STRING MAY BE DELIMITED BY THE SELF-DEFINED * 11820020 * DELIMITER OR BY THE END OF THE INPUT. * 11830020 * * 11840020 *********************************************************************** 11850020 */*STRING: P DO NOT SKIP BLANKS AFTER A PROMPT */ 11852021 */* D (YES,,NO,STRINGN) DELIMITER IS A QUOTE */ 11852421 */* D (YES,,NO,STRINGN) SPECIAL STRING HANDLING REQUESTED */ 11854021 */* D (YES,,NO,QSTRING) FIRST TIME THROUGH */ 11856021 */* P BACK UP SCAN POINTER ONE PLACE */ 11858021 */* D (,QSTRING) TREAT AS QUOTED STRING */ 11858421 */*STRINGN: P TURN OFF FIRST TIME SWITCH FOR QSTRING */ 11858821 SPACE 11860020 STRING DS 0H SELF-DELIMITING STRING ROUTINE 11870020 CLI PDELIM,QUOTE IS DELIMITER A QUOTE S21105 11872021 BNE STRINGN NO, CONTINUE S21105 11874021 TM PCEFLGB2(XPCE),PCEFQSTR IS SPECIAL STRING HANDLING 11876020 * REQUESTED S21105 11878021 BZ STRINGN NO, CONTINUE S21105 11878421 TM PFLAGS5,PFSQSTR IS THIS THE FIRST TIME THROUGH 11878521 * S21105 11878621 BZ STRINGT YES, SET FLAG S21105 11878721 B QSTRING NO, BRANCH TO PROCESS AS QSTRING 11878821 * S21105 11879221 STRINGT OI PFLAGS5,PFSQSTR INDICATE SPECIAL HANDLING DONE 11881521 * ONCE S21105 11883521 BCT XINPUT,QSTRING BRANCH TO PROCESS AS QSTRING 11884421 * S21105 11884821 STRINGN NI PFLAGS5,HFF-PFSQSTR TURN OFF SPECIAL HANDLING FLAG 11886421 * S21105 11886821 OI RFLAGS,RFNOSKIP INDICATE BLANKS SHOULD NOT BE 11887221 */* D (YES,,NO,STRINGST) PROMPT IS REQUIRED */ 11892021 */* S PROMPTQ: TEST FOR PROMPT/DEFAULT DATA */ 11912021 */* D (YES,STRBUMP,NO,POSITX2) DATA RETURNED */ 11942021 */*STRINGST: P INCREMENT SCAN POINTER */ 11982021 */* D (YES,,NO,STRPSET) REACHED END OF INPUT */ 12012021 */* S PROMPTQ: TEST FOR PROMPT/DEFAULT DATA */ 12032021 * SKIPPED AFTER A PROMPT 12041321 TM PFLAGS3,PFSTPRMT IS STRING MISSING 12042421 BZ STRINGST NO - GO SET POINTER 12043521 SPACE 12044621 BAL LINK1,PROMPTQ TEST FOR PROMPT OR DEFAULT 12045721 * 12046821 B STRBUMP +0 RETURN - RESCAN NEW DATA 12047921 * 12049021 B POSITX2 +4 RETURN - NO DATA, TAKE NULL 12050121 * PDE EXIT 12051221 SPACE 12052321 STRINGST DS 0H * * * * 12053421 LA R2,ONE(XINPUT) BUMP POINTER TO NEXT CHARACTER 12054521 C R2,ENDINPUT IS PTR AT END OF INPUT 12055621 BL STRPSET NO, GO SET PPOINTER 12056721 SPACE 12057821 BAL LINK1,PROMPTQ YES, CHECK FOR PROMPT OR DEFAULT 12058921 * 12060020 */* D (YES,STRBUMP,NO,) DATA RETURNED */ 12062021 B STRBUMP +0 RETURN - RESCAN NEW DATA 12070020 * 12080020 * +4 RETURN - NO DATA RETURNED, 12090020 * PROCESS NULL STRING 12100020 */* D (YES,,NO,POSITX2) END DELIMITER FOUND FOR PREVIOUS STRING */ 12102021 TM PFLAGS4,PFENDLIM WAS AN END DELIMITER FOUND 12110020 * FOR A PREVIOUS STRING 12120020 BZ POSITX2 NO, TAKE NO PDE EXIT 12130020 * YES, PROCESS NULL STRING 12140020 */*STRBUMP: P POINT TO NEXT CHARACTER */ 12142021 SPACE 12150020 STRBUMP DS 0H * * * * 12160020 LA R2,ONE(XINPUT) GET PTR TO NEXT CHARACTER 12170020 */*STRPSET: P SET POINTER TO CHAR. AFTER SELF-DEFINED DELIMITER */ 12172021 SPACE 12180020 STRPSET DS 0H * * * * 12190020 ST R2,PPOINTR SET PPOINTR TO CHARACTER AFTER 12200020 * SELF-DEFINED DELIMITER OR 12210020 * FIRST CHARACTER OF DATA 12220020 * RETURNED 12230020 SPACE 12240020 * 12250020 * LOOP THROUGH STRING LOOKING FOR DELIMITER OR END OF INPUT. 12260020 * 12270020 */*STRINRPT: P INCREMENT SCAN POINTER */ 12272021 STRINRPT DS 0H * * * * 12280020 LA XINPUT,ONE(XINPUT) BUMP SCAN PTR BY ONE 12290020 LR XINPUTB,XINPUT SAVE PTR IN BACKUP REGISTER 12300020 */* D (YES,STRINEND,NO,) REACHED END OF INPUT */ 12302021 C XINPUT,ENDINPUT END OF INPUT DATA 12310020 BNL STRINEND YES BRANCH 12320020 */* D (YES,STRINRPT,NO,) SPACE/STRING SEQUENCE */ 12322021 SPACE 12330020 TM PFLAGS3,PFSPACE IS THIS A SPACE/STRING PARAMETER 12340020 * SEQUENCE 12350020 BO STRINRPT IF YES CONTINUE TO END OF BUFFER 12360020 */* D (YES,,NO,STRINRPT) END OF SELF-DELIMITING STRING */ 12362021 SPACE 12370020 CLC PDELIM,ZERO(XINPUT) END OF SELF-DELIMITING STRING 12380020 BNE STRINRPT IF NO BRANCH 12390020 OI PFLAGS4,PFENDLIM IF YES, TURN ON DELIMITER FOUND 12400020 */* P SET INDICATOR FOR DELIMITER FOUND */ 12402021 * FLAG 12410020 */*STRINEND: P COMPUTE AND SAVE LENGTH OF STRING */ 12412021 SPACE 12420020 STRINEND DS 0H ENTERED WHEN END OF STRING 12430020 S XINPUTB,PPOINTR COMPUTE LENGTH OF STRING 12440020 STH XINPUTB,PLENGTH STORE LENGTH 12450020 NI PFLAGS3,HFF-PFSPACE TURN OFF POSSIBLE FLAG 12460020 */* D (,POSITX1) EXIT */ 12462021 B POSITX1 EXIT - GET NEXT PCE 12470020 EJECT 12480020 *********************************************************************** 12490020 * * 12500020 * POSITIONAL VALUE ROUTINE * 12510020 * * 12520020 * A VALUE CONSISTS OF A TYPE-CHARACTER FOLLOWED BY A STRING * 12530020 * ENCLOSED IN QUOTES - X'STRING'. THE TYPE-CHARACTER MUST BE AN * 12540020 * ALPHABETIC OR NATIONAL CHARACTER. THE STRING MAY CONSIST OF ANY * 12550020 * COMBINATION OF CHARACTERS OF ANY LENGTH. A LIST OF VALUES AND A * 12560020 * RANGE OF VALUES ARE ALLOWED. IF THE FIRST NON-BLANK CHARACTER IS * 12570020 * NOT ALPHABETIC, THE VALUE IS CONSIDERED MISSING. THE VALUE IS * 12580020 * ALSO CONSIDERED MISSING IF THE CHARACTER AFTER THE TYPE- * 12590020 * CHARACTER IS NOT A QUOTE. THE TYPE-CHARACTER IS RAISED TO * 12600020 * UPPER CASE. THE STRING PORTION IS PROCESSED BY THE QSTRING * 12610020 * ROUTINE. IF THE ENDING QUOTE IS LEFT OFF, THE END OF THE * 12620020 * BUFFER DELIMITS THE STRING. A MESSAGE IS ISSUED TO INDICATE THIS * 12630020 * SITUATION TO THE USER. * 12640020 * * 12650020 *********************************************************************** 12660020 */*VALUE: P SAVE PDE SIZE */ 12662021 SPACE 12670020 VALUE DS 0H VALUE ROUTINE 12680020 LA R1,SEVEN GET PDE SIZE-1 12690020 STC R1,PPCOUNT SAVE 12700020 */* D (YES,ILLVALU,NO,) INPUT ENDED AFTER LEFT PAREN WAS FOUND */ 12700421 */* S SKIPB: SKIP SEPARATORS */ 12702021 BAL LINK2,SKIPB BRANCH TO SKIP SEPARATORS 12710020 * 12720020 */* D (YES,VALUEPRQ,NO,) REACHED END OF INPUT */ 12722021 B VALUEPRQ +0 RETURN - END OF INPUT DATA 12730020 * 12740020 */* S LISTT: CHECK FOR A LIST */ 12742021 BAL LINK1,LISTT +4 RETURN - CHECK FOR A LIST 12750020 SPACE 12760020 B ILLVALU +0 RETURN, INPUT ENDED AFTER 12770020 * LEFT PAREN WAS FOUND, INVALID 12780020 * PARM 12790020 SPACE 12800020 * +4 RETURN, NO LIST OR SCAN 12810020 * POINTER ADJUSTED TO FIRST 12820020 * PARM IN LIST 12830020 SPACE 12840020 * 12850020 * ENTRY POINT TO RESCAN A VALUE AFTER PROMPTING. 12860020 * 12870020 */*VALUERSC: P RESCAN VALUE AFTER PROMPTING */ 12872021 VALUERSC DS 0H * * * * 12880020 MVC INVPSAVE,PPOINTR SAVE PTR FOR INVALID MSG 12890020 */*VAL2RSC: P SCAN POSSIBLE 2ND RANGE VALUE */ 12892021 VAL2RSC DS 0H ENTRY TO SCAN 2ND RANGE VALUE 12900020 LA XINPUT,ONE(XINPUT) POINT TO NEXT INPUT CHARACTER 12910020 */* S TYPETEST: TEST FOR VALID ALPHABETIC CHARACTER */ 12912021 LA R1,ALPHA TEST FOR ALPHABETIC 12920020 BAL LINK1,TYPETEST CHARACTER 12930020 */* D (YES,VALUPRQX,NO,) INVALID CHARACTER FOUND */ 12932021 SPACE 12940020 B VALUPRQX +0 RETURN - INVALID, VALUE IS 12950020 * MISSING 12960020 * 12970020 * +4 RETURN - VALID CHARACTER 12980020 */* P COPY TYPE FIELD TO TEMPORARY PDE */ 12982021 MVC DATAFLB1(ONE),ZERO(XINPUT) COPY TYPE FIELD TO TEMP. PDE 12990020 L R15,AUPTAB GET ADDRESS OF TRANSLATE TABLE 13000020 TR DATAFLB1(ONE),ZERO(R15) RAISE TO UPPERCASE 13010020 LA XINPUT,ONE(XINPUT) INCREMENT SCAN REGISTER 13020020 LR XINPUTB,XINPUT SET BACKUP REGISTER 13030020 */* D (YES,,NO,VALENTRY) REACHED END OF INPUT AFTER FIRST CHARACTER */ 13032021 C XINPUT,ENDINPUT END OF INPUT DATA 13040020 BL VALENTRY NO - CONTINUE PROCESSING USING 13050020 * QSTRING CODE 13060020 BCTR XINPUT,ZERO YES - BACKUP AND TRY TO PROMPT 13070020 SPACE 13080020 * 13090020 * BRANCH TO PROMPT/DEFAULT ROUTINE. 13100020 * 13110020 */* VALUPRQX: P PREPARE TO PROMPT */ 13112021 VALUPRQX DS 0H * * * * 13120020 BCTR XINPUT,ZERO REDUCE SCAN PTR BY ONE 13130020 SPACE 13140020 VALUEPRQ DS 0H * * * * 13150020 */*VALUEPRQ: D (YES,ILLVALU,NO,) FIRST VALUE OF A RANGE WAS FOUND */ 13152021 TM PFLAGS2,RNGEVAL1 WAS THE FIRST VALUE OF RANGE 13160020 * FOUND 13170020 BO ILLVALU YES - INVALID VALUE --- BRANCH 13180020 */* S PROMPTQ: TEST FOR PROMPT/DEFAULT DATA */ 13182021 SPACE 13190020 BAL LINK1,PROMPTQ TEST FOR PROMPT OR DEFAULT 13200020 * 13210020 */* D (YES,,NO,VALUERSC) NO PROMPT OR DEFAULT */ 13212021 B VALUERSC +0 RETURN - NEW DATA TO SCAN 13220020 * 13230020 * +4 RETURN - NO PROMPT OR DEFAULT 13240020 */* P CLEAR TYPE CODE FIELD */ 13242021 MVI DATAFLB1,ZERO CLEAR TYPE CODE FIELD 13250020 */* D (,POSITX2) BRANCH TO NULL DATA EXIT */ 13252021 B POSITX2 BRANCH TO NULL DATA EXIT 13260020 EJECT 13260100 *********************************************************************** 13260400 * * 13260800 * STORAGE ALLOCATION SUBROUTINE * 13261200 * * 13261600 * REGISTER RESTRICTIONS - * 13261700 * R2 OR R3 CANNOT BE USED BY THIS ROUTINE * 13261800 * * 13261900 *********************************************************************** 13262500 SPACE 13262900 */*STALOC: E STORAGE ALLOCATION SUBROUTINE */ 13263300 STALOC DS 0H STORAGE ALLOCATION SUBROUTINE 13263700 */* P ROUND AMOUNT OF STORAGE REQUESTED TO 8 */ 13263800 LA R1,SEVEN(R1) ROUND AMOUNT OF STORAGE 13263900 N R1,EIGHTMAK REQUESTED TO EIGHT 13264400 LR R0,R1 SET LENGTH REQUIRED 13264800 */* D (YES,STALOALX,NO,) MORE STORAGE REQUESTED THAN NORMAL */ 13265200 C R0,MAXBLKSZ MORE STORAGE REQUESTED THAN 13265300 * NORMAL ALLOCATION 13265400 BNL STALOALX YES GET NEW CORE 13265800 SPACE 13266100 */*STALOFST: P LOAD ADDR OF INTERNAL MAIN STORAGE SPACE ANCHOR */ 13266500 STALOFST DS 0H * * * * 13266900 LA R15,PANCHORT LOAD ADDRESS OF INTERNAL MAIN 13267300 * STORAGE SPACE ANCHOR 13267400 SPACE 13267800 */*STALONXT: P LOAD NEXT ELEMENT ADDRESS */ 13267900 STALONXT DS 0H * * * * 13268000 LR R1,R15 SAVE BACKUP 13268100 L R15,ZERO(R15) LOAD NEXT ELEMENT ADDRESS 13268200 */* D (YES,,NO,STALOALO) ANY STORAGE LEFT */ 13268300 LTR R15,R15 ANY STORAGE LEFT 13268400 BZ STALOALO IF NO ALLOCATE MORE 13268800 SPACE 13268900 */* D (YES,,NO,STALONXT) IS IT ENOUGH */ 13269200 C R0,FOUR(R15) IF YES IS IT ENOUGH 13271200 BH STALONXT NO TRY NEXT ELEMENT 13271300 SPACE 13271400 */* D (YES,STALOSPL,NO,) IS IT EQUAL */ 13271500 BE STALOSPL EQUAL --- SPECIAL CHAINING 13271700 SPACE 13272100 */* P COMPUTE LEFTOVER AMOUNT SINCE THERE'S MORE THAN ENOUGH */ 13272200 LR R14,R15 MORE THAN ENOUGH --- COMPUTE 13272300 AR R14,R0 LEFTOVER AMOUNT 13272400 MVC ZERO(FOUR,R14),ZERO(R15) RESET FORWARD CHAIN 13272500 ST R14,ZERO(R1) SET NEW FORWARD CHAIN 13272600 L R1,FOUR(R15) PICK UP LENGTH 13272800 SR R1,R0 GET REMAINDER 13273200 ST R1,FOUR(R14) STORE REMAINDER 13273300 SPACE 13273400 */*STALOXIT: P CLEAR OLD CHAINING INFO */ 13273500 STALOXIT DS 0H * * * * 13273600 LR R1,R15 GET RETURN ADDRESS 13273700 XC ZERO(EIGHT,R1),ZERO(R1) CLEAR OLD CHAINING INFO 13273800 */* R RETURN TO CALLER */ 13273900 BR LINK2 RETURN TO CALLER 13274000 SPACE 13274100 */*STALOSPL: P COPY FORWARD CHAIN */ 13274200 STALOSPL DS 0H * * * * 13274600 MVC ZERO(FOUR,R1),ZERO(R15) COPY FORWARD CHAIN 13274700 */* D (,STALOXIT) EXIT */ 13274800 B STALOXIT EXIT TO CALLER 13274900 SPACE 13275100 */*STALOALO: P INDICATE 248 BYTE CHUNK */ 13275500 STALOALO DS 0H * * * * 13275900 L R1,MAXBLKSZ INDICATE NEED 248 BYTE CHUNK 13276300 SPACE 13276400 */*STALOALX: S GETCORE: GET CORE REQUESTED */ 13276500 STALOALX DS 0H * * * * 13276600 AL R1,SPOVRHD ADD SUBPOOL AND EIGHT BYTE 13277000 * OVERHEAD FOR STORAGE CHAINS 13277400 STM R0,R1,PDWORD SAVE REQUEST AND REQUIRED SIZES 13277800 BAL LINK1,GETCORE LINK TO GETCORE TO DO 13277900 * CONDITIONAL GETMAIN FOR SPACE 13278000 SPACE 13278100 * STORAGE ADDRESS RETURNED IN R1 13279000 L R15,PANCHOR LOAD ADDRESS OF LAST AREA GOTTEN 13279400 */* D (YES,STALOFRT,NO,) FIRST TIME THROUGH */ 13279800 LTR R15,R15 IS THIS THE FIRST TIME 13279900 BZ STALOFRT IF YES BRANCH 13280000 SPACE 13280100 */* P FORWARD CHAIN GETMAIN AREAS */ 13280600 ST R1,ZERO(R15) FORWARD CHAIN GETMAIN AREAS 13281000 SPACE 13281400 */*STALOFRT: P INDICATE NEW AREA IS END OF CHAIN */ 13281800 STALOFRT DS 0H * * * * 13281900 MVC ZERO(FOUR,R1),ENDCHAIN INDICATE NEW AREA IS END OF 13282300 * CHAIN 13282700 MVC FOUR(FOUR,R1),PDWORD+FOUR ADD SIZE TO STORAGE CHAINS 13283100 NI PDWORD+FOUR,ZERO KILL SUBPOOL INDICATOR 13283500 ST R1,PANCHOR STORE STORAGE ADDRESS 13283600 LA R1,EIGHT(R1) BUMP PAST STORAGE CHAINS 13283700 MVC ZERO(FOUR,R1),PANCHORT OTHER ANCHORS 13283800 ST R1,PANCHORT ON OTHER CHAINS 13284000 L R15,PDWORD+FOUR GET SIZE OF STORAGE REQUESTED 13284400 SH R15,H8 REDUCE BY SIZE OF STORAGE CHAINS 13284500 ST R15,FOUR(R1) STORE LENGTH AVAILABLE 13284600 */* P COMPUTE AMOUNT OF CORE TO CLEAR */ 13284700 SH R15,H8 COMPUTE AMOUNT OF CORE TO CLEAR 13284800 LA R1,EIGHT(R1) SET UP STARTING ADDRESS 13284900 SPACE 13285000 */*STALOCLR: P CLEAR THE STORAGE */ 13285100 STALOCLR DS 0H * * * * 13285200 BCTR R15,ZERO DECREMENT SIZE FOR EXECUTE 13285600 EX R15,CLEARXC CLEAR THE STORAGE 13285700 LR R14,R15 COPY LENGTH USED 13285800 N R14,CLEARMK1 MASK OFF HIGH PART TO GET LENGTH 13286100 * USED 13286500 LA R1,ONE(R1,R14) GET NEW START CLEAR ADDRESS 13286900 N R15,CLEARMK2 CLEAR LOWER PART FOR NEXT TRY 13287000 BNZ STALOCLR CLEAR IT UNLESS DONE 13287100 SPACE 13287200 */* P GET LENGTH REQUESTED FOR GETMAIN */ 13287300 L R0,PDWORD GET LENGTH REQUESTED FOR GETMAIN 13287700 */* D (,STALOFST) TRY AGAIN */ 13287800 B STALOFST TRY IT AGAIN 13287900 EJECT 13288400 *********************************************************************** 13291700 * * 13293700 * POSITIONAL PARENTHESIZED STRING ROUTINE * 13295700 * * 13296100 * THIS ROUTINE IS USED TO SCAN A STRING OF DATA ENCLOSED BY A SET * 13296500 * OF PARENTHESIS - (STRING). THE STRING CAN CONSIST OF ANY * 13296900 * COMBINATION OF CHARACTERS, HOWEVER, IF IT INCLUDES PARENTHESIS THEY * 13297000 * MUST BE BALANCED. * 13297100 * A PSTRING CAN NEVER BE SYNTACTICALLY INVALID (VALIDITY CHECK EXIT * 13297200 * ROUTINE CAN REQUEST THAT IT BE CONSIDERED INVALID) BUT IF THE * 13299300 * NEXT ITEM IN THE BUFFER DOES NOT BEGIN WITH A LEFT PARENTHESIS THE * 13301300 * PSTRING IS CONSIDERED TO BE MISSING. A PROMPT OR A DEFAULT MAY BE * 13301400 * SPECIFIED FOR A PSTRING. * 13301500 * IF THE USER LEAVES THE RIGHT PARENTHESIS OFF, THE END OF THE * 13304100 * BUFFER DELIMITS THE STRING. A MESSAGE IS ISSUED TO INDICATE THIS * 13306100 * SITUATION TO THE USER. * 13306500 * * 13306900 *********************************************************************** 13307200 */*PSTRING: S SKIPB: SKIP SEPARATORS */ 13307600 SPACE 13307700 PSTRING DS 0H PSTRING ROUTINE 13307800 BAL LINK2,SKIPB SKIP SEPARATORS 13308300 * 13308700 */* D (YES,,NO,PSTRIPRQ) DATA IN BUFFER */ 13309100 B PSTRIPRQ +0 RETURN - NO DATA - PROMPT 13309200 * 13309300 * +4 RETURN - DATA TO SCAN - 13309400 * XINPUT POINTS TO NONSEPARATOR 13309500 SPACE 13312000 * 13314000 * ENTRY POINT TO RESCAN NEW DATA FROM PROMPT OR DEFAULT. 13314400 * 13314800 */*PSTRIRSC: P RESCAN NEW DATA FROM PROMPT/DEFAULT */ 13314900 PSTRIRSC DS 0H * * * * 13315700 MVC INVPSAVE,PPOINTR SAVE PTR FOR INVALID MSG 13316100 LA XINPUT,ONE(XINPUT) BUMP SCAN PTR BY ONE 13316500 */* D (YES,,NO,PSTRPRQX) NEXT CHARACTER IS LEFT PAREN */ 13316900 CLI ZERO(XINPUT),LEFTPRN IS NEXT CHARACTER LEFT PAREN. 13317300 BNE PSTRPRQX NO - ERROR - PROMPT 13319800 SPACE 13321800 LA R2,ONE(XINPUT) YES - SET PPOINTR TO FIRST 13322200 ST R2,PPOINTR CHARACTER IN PSTRING 13322300 */* P SET DEPTH METER FOR NUMBER OF PARENS FOUND */ 13322400 LA R2,ONE SET DEPTH METER TO ONE 13325100 */*PSTRISCN: P LOOK FOR END OF STRING */ 13327100 SPACE 13327500 PSTRISCN DS 0H LOOP LOOKING FOR END OF STRING 13327900 LA XINPUT,ONE(XINPUT) BUMP SCAN PTR BY ONE 13328300 LR XINPUTB,XINPUT LOAD BACKUP REGISTER 13328800 */* D (YES,PSTRIMSG,NO,) REACHED END OF INPUT */ 13329200 C XINPUT,ENDINPUT IS THIS END OF INPUT DATA 13329600 BNL PSTRIMSG IF YES BRANCH 13329700 */* D (YES,,NO,PSTRINLP) ANOTHER LEFT PAREN FOUND */ 13329800 SPACE 13329900 CLI ZERO(XINPUT),LEFTPRN IS IT ANOTHER LEFT PAREN 13330500 */*PSTRINLP: D (YES,,NO,PSTRISCN) RIGHT PAREN FOUND */ 13330900 BNE PSTRINLP IF NO SKIP LEVEL INCREMENT 13331300 */* P INCREMENT DEPTH METER */ 13331700 SPACE 13331800 LA R2,ONE(R2) BUMP DEPTH METER BY ONE 13332400 SPACE 13332800 PSTRINLP DS 0H * * * * 13333200 CLI ZERO(XINPUT),RIGHTPRN IS IT A RIGHT PAREN 13333600 BNE PSTRISCN NO - BRANCH 13333700 */* P DECREMENT DEPTH METER */ 13334300 */* D (YES,,NO,PSTRISCN) DEPTH METER IS ZERO */ 13334700 SPACE 13335100 BCT R2,PSTRISCN YES - DECREMENT LEVEL WHEN ZERO 13335500 * FALL THROUGH 13335600 SPACE 13335800 * 13336200 * END OF PSTRING FOUND. 13336700 * 13337100 */* P COMPUTE AND SAVE LENGTH OF PSTRING */ 13337500 S XINPUTB,PPOINTR COMPUTE LENGTH OF PSTRING 13337900 STH XINPUTB,PLENGTH STORE LENGTH 13338100 */* D (,POSITX1) EXIT */ 13338500 B POSITX1 BRANCH TO EXIT ROUTINE 13338600 SPACE 13338700 * 13340600 * SEE IF PSTRING REQUIRED OR DEFAULTED. 13342600 * 13342700 */*PSTRPRQX: P PREPARE FOR PROMPT/DEFAULT */ 13342800 PSTRPRQX DS 0H * * * * 13343400 BCTR XINPUT,ZERO REDUCE SCAN POINTER BY ONE 13343800 */*PSTRIPRQ: S PROMPTQ: TEST FOR PROMPT/DEFAULT DATA */ 13344200 SPACE 13344300 PSTRIPRQ DS 0H * * * * 13344400 BAL LINK1,PROMPTQ TEST FOR PROMPT OR DEFAULT 13344500 * 13345000 */* D (YES,PSTRIRSC,NO,POSITX2) NEW DATA RETURNED */ 13345400 B PSTRIRSC +0 RETURN - RESCAN NEW DATA 13345800 * 13346200 B POSITX2 +4 RETURN - NOT REQUIRED AND NO 13346300 * DEFAULT - EXIT 13346400 SPACE 13346500 * 13346600 * ISSUE 'RIGHT PAREN ASSUMED' MESSAGE AND TREAT AS IF RIGHT PAREN 13347100 * FOUND. 13347500 * 13347900 */*PSTRIMSG: P COMPUTE AND SAVE LENGTH OF PSTRING */ 13348300 PSTRIMSG DS 0H END OF BUFFER FOUND 13348400 S XINPUTB,PPOINTR COMPUTE LENGTH OF PSTRING 13348500 STH XINPUTB,PLENGTH SAVE LENGTH 13350200 LA R1,FIVE(XINPUTB) GET SIZE OF CORE FOR MESSAGE SEG 13352200 * PLUS HEADER AND LEFT PAREN 13352600 */* S GETCORE: GET CORE FOR MESSAGE SEGMENT */ 13352700 BAL LINK1,GETCORE GET CORE FOR MESSAGE SEGMENT 13352800 SPACE 13352900 * CORE ADDRESS RETURNED IN R1 13353300 ST R1,SEGLIST+TWELVE STORE ADDRESS IN LIST OF SEGMENT 13353700 LA R0,FIVE(XINPUTB) GET SIZE OF MESSAGE SEGMENT 13354100 STH R0,ZERO(R1) STORE INTO SEGMENT 13354200 MVI TWO(R1),ZERO SET FIRST BYTE OF OFFSET TO ZERO 13354700 MVI THREE(R1),OFFSET4 SET OFFSET TO LENGTH OF 'RIGHT 13355100 * PAREN ASSUMED' MESSAGE 13355500 L R15,PPOINTR LOAD START OF DATA ADDRESS 13355600 BCTR R15,ZERO INCLUDE LEFT PAREN IN MESSAGE 13356200 EX XINPUTB,BUILDSEG MOVE TEXT TO NEW SEGMENT 13356600 */* P INDICATE 'RIGHT PAREN ASSUMED' MESSAGE */ 13357000 MVI MSGCODE,MSG8 INDICATE MESSAGE TO WRITE 13357400 */* S WRITE1: WRITE THE MESSAGE */ 13357500 BAL LINK1,WRITER1 WRITE THE MESSAGE 13357700 */* D (YES,,NO,PSTRET) PROCESSING COBOL PCE'S? */ 13357821 TM CBFLAGS1,COBOLMOD DID WE WRITE THE MESSAGE F41448 13359121 * WHILE PROCESSING COBOL F41448 13359221 * PCE'S? F41448 13359321 BZ PSTRET IF NOT, CONTINUE NORMAL F41448 13359421 */* P LOAD IKJPARS2 RETURN ADDRESS */ 13360121 */* R () EXIT TO IKJPARS2 */ 13362121 L LINK2,CBLNKSV2 PARSE. IF IN COBOL MODE F41448 13362321 * LOAD RETURN ADDRESS F41448 13363021 BR LINK2 FROM CBLNKSV2 + RETURN F41448 13363721 */*PSTRET: D (,POSITX1) EXIT AS NORMAL */ 13364400 SPACE 13365100 PSTRET B POSITX1 EXIT AS NORMAL 13365800 EJECT 13366500 SPACE 3 13367200 * 13367900 * ADDRESS OF NEXT CSECT 13368600 * 13369300 SPACE 13370000 ADRCST1 DC V(IKJEFP01) ADDRESS OF SECOND CSECT 13370400 EJECT 13372000 *********************************************************************** 13373600 * * 13375200 * POSITIONAL ADDRESS ROUTINE * 13376800 * * 13378400 * THE PURPOSE OF THIS ROUTINE IS TO SYNTAX CHECK THE ADDRESS PARAMETER* 13380020 * USED BY SUB-COMMANDS OF TEST 13390020 * A VALID ADDRESS CAN BE SYMBOLIC, RELATIVE, ABSOLUTE OR A REGISTER 13400020 * NAME INCLUDING ANY SPECIFICATION OF ONE OR MORE LEVELS OF INDIRECT 13410020 * ADDRESSING OR AN EXPRESSION BUILT OF COMBINATIONS OF SYMBOLIC, 13420020 * RELATIVE OR ABSOLUTE ADDRESSES, OR GENERAL REGISTER NAMES FOR WHICH 13430020 * INDIRECT ADDRESSING IS SPECIFIED, AND PLUS OR MINUS DISPLACEMENT 13440020 * VALUES 13450020 * SYMBOLIC AND RELATIVE ADDRESSES MAY ADDITIONALLY BE QUALIFIED BY 13460020 * '.ENTRYNAME.' OR 'LOADNAME.ENTRYNAME.' IF NO QUALIFIERS ARE 13470020 * SPECIFIED, THE QUALIFICATION IS IMPLICIT 13480020 * '.ENTRYNAME'(OPTIONALLY PRECEDED BY LOADNAME)IS ALSO A VALID ADDRESS 13490020 * * 13500020 *********************************************************************** 13510020 SPACE 13520020 IKJEFP01 CSECT 13530020 SPACE 13540020 */*ADDRESS: P GET PDE SIZE */ 13542021 ADDRESS DS 0H ADDRESS ROUTINE 13550020 MVI DATAEXP,HFF INSURES THAT EXPRESSION VALUE 13560020 * PDE PTR IS X'FF000000' 13570020 MVI DATAFLG,EMPTYFLG INITIALIZE FLAGS TO 'EMPTY'M5957 13572020 LA R1,THIRTY5 GET PDE SIZE-1 13580020 STC R1,PPCOUNT SAVE 13590020 */* S SKIPB: SKIP SEPARATORS */ 13592021 BAL LINK2,SKIPB SKIP BLANKS 13600020 B ADDREPRQ PROMPT IF NECESSARY 13610020 * (NULL PARAMETER) 13620020 */* S LISTT: CHECK FOR LIST */ 13622021 BAL LINK1,LISTT PROCESS POSSIBLE LIST 13630020 */* D (YES,,NO,ILLADDR) LIST IS VALID */ 13632021 B ILLADDR +0 RETURN - INVALID LIST 13640020 LA R0,LRPAREN+ONE GET DUMMY LIST PTR A51300 13642021 CR R0,XINPUT PROCESSING DUMMY LIST A51300 13644021 BE ADDREPRQ YES-LIST IS NULL,PROMPT A51300 13646021 SPACE 13650020 */*ADDRERSC: P SAVE PTR FOR INVALID MSG */ 13652021 ADDRERSC DS 0H * * * * 13660020 MVC INVPSAVE,PPOINTR SAVE PTR FOR INVALID MSG 13670020 SPACE 13680020 */*RANGENTR: P ENTRY FOR SECOND VALUE OF RANGE SCAN */ 13682021 RANGENTR DS 0H SPECIAL ENTRY TO SCAN SECOND 13690020 * VALUE OF RANGE ADDRESS 13700020 MVI DATAEXP,HFF IF EXPRESSION FOUND, FIELD 13710020 * WILL BE SET AS POINTER TO 1ST 13720020 * EXPRESSION VALUE PDE 13730020 */*STARTAGN: P SAVE START OF PARAMETER */ 13732021 STARTAGN DS 0H * * * * 13740020 LA XINPUT,ONE(XINPUT) INCREMENT SCAN REGISTER 13750020 LR XINPUTB,XINPUT SET BACKUP REGISTER 13760020 ST XINPUT,PPOINTR SAVE START OF PARAMETER 13770020 */* P ZERO A COUNTER FOR SIZE OF PARAMETER */ 13772021 XR COUNTER,COUNTER A WORK REGISTER TO MAINTAIN 13780020 * A TALLY OF SIZE OF PARAMETER 13790020 */* P ZERO A COUNTER FOR NUMBER OF LEVELS IN ADDRESS */ 13792021 XR LEVELS,LEVELS A WORK REGISTER TO MAINTAIN 13800020 * A TALLY OF THE NUMBER OF LEVELS 13810020 * OF INDIRECT ADDRESSES 13820020 */* D (YES,ADDREPLS,NO,) ADDRESS IS RELATIVE TYPE */ 13822021 CLI ZERO(XINPUT),RELATIVE IS RELATIVE SPECIFIED 13830020 BE ADDREPLS YES, GO PROCESS 13840020 */* D (YES,,NO,NOENTRNM) ENTRYNAME IS SPECIFIED */ 13842021 CLI ZERO(XINPUT),PERIOD IS ENTRYNAME SPECIFIED 13850020 BNE NOENTRNM NO, BRANCH 13860020 SPACE 13870020 */*ENTRYNM: P INCREMENT SCAN PTR AND SET ENTRYBIT ON */ 13872021 ENTRYNM DS 0H * * * * 13880020 LA R1,ONE(XINPUT) BEGINNING OF ENTRYNAME IS ONE 13890020 ST R1,PPOINTR BYTE PAST PERIOD 13900020 OI PFLAGS2,ENTRYBIT WORK BIT INDICATING AN 13910020 * ENTRYNAME IS BEING PROCESSED 13920020 LA XINPUT,ONE(XINPUT) INCREMENT SCAN REGISTER 13930020 LR XINPUTB,XINPUT SET BACKUP REGISTER 13940020 */* S CHECKEND: CHECK FOR END OF INPUT */ 13940421 BAL LINK1,CHECKEND CHECK FOR END OF INPUT M4789 13942020 SPACE 13950020 */*NOENTRNM: D (YES,,NO,REGISTER) FIRST CHARACTER IS LETTER OR NATIONAL 13952021 */* CHAR */ 13954021 NOENTRNM DS 0H * * * * 13960020 LA CHECK,HEX+OLETTER+NATL IS FIRST CHARACTER A LETTER 13970020 * OR NATIONAL CHARACTER 13980020 BAL LINK1,TYPETEST * * * * 13990020 B REGISTER NO, BRANCH 14000020 */* D (YES,ALPHAMER,NO,) PROCESSING AN ENTRYNAME */ 14002021 TM PFLAGS2,ENTRYBIT PROCESSING AN ENTRYNAME 14010020 BO ALPHAMER YES, BRANCH 14020020 */* P TURN ON FLTERBIT */ 14020421 OI PFLAGS2,FLTERBIT TURN BIT ON 14022020 LA CHECK,HEX HEX CHARACTER 14030020 */* S TYPETEST: CHECK FOR HEX CHARACTER */ 14032021 BAL LINK1,TYPETEST * * * * 14040020 */* D (YES,REGLOOP,NO,) CHARACTER IS HEX */ 14042021 B ALPHAMER NO, BRANCH 14050020 B REGLOOP BRANCH 14070020 SPACE 14086020 */*ALPHAMER: S TYPETEST: CHECK FOR ALPHAMERIC OR NATIONAL CHARACTER */ 14088021 ALPHAMER DS 0H * * * * 14090020 LA CHECK,HEX+OLETTER+NATL+NUMBER ALPHAMERIC OR NATIONAL 14100020 * CHARACTER 14110020 BAL LINK1,TYPETEST * * * * 14120020 */* D (YES,,NO,BREAK) CHARACTER IS ALPHAMERIC OR NATIONAL */ 14122021 B BREAK NO, BRANCH 14130020 SPACE 14140020 */*TALLYCT: P INCREMENT NO. OF LEVELS AND INCREMENT SCAN PTR */ 14142021 TALLYCT DS 0H * * * * 14150020 LA COUNTER,ONE(COUNTER) YES, INCREMENT TALLY BY ONE 14160020 LA XINPUT,ONE(XINPUT) INCREMENT SCAN REGISTER 14170020 LR XINPUTB,XINPUT SET BACKUP REGISTER 14180020 */* S CHEKCEND: CHECK FOR END OF INPUT */ 14180421 BAL LINK1,CHECKEND CHECK FOR END OF INPUT M4789 14182020 */* D (YES,MAXTEST,NO,) PROCESSING A SYMBOLIC ADDRESS */ 14184021 TM DATAFLG,SYMADR DEFINITELY PROCESSING A 14190020 * SYMBOLIC ADDRESS 14200020 BO MAXTEST YES, IS IT VALID 14210020 */* D (YES,,NO,ALPHAMER) NO. OF LEVELS GREATER THAN 8 */ 14212021 CH COUNTER,DEC9 ADDRESS TALLY GREATER THAN 8 14220020 BL ALPHAMER NO, BRANCH 14230020 */* D (YES,TURNOFF,NO,) PROCESSING ENTRYNAME */ 14232021 TM PFLAGS2,ENTRYBIT IS ENTRYNAME BIT ON 14240020 BO TURNOFF YES, ERROR 14250020 */* P TURN ON SYMBOLIC BIT */ 14252021 OI DATAFLG,SYMADR MUST BE SYMBOLIC 14260020 SPACE 14270020 */*MAXTEST: D (YES,TURNOFF,NO,ALPHAMER) SIZE OF PARAMETER GREATER THAN 14272021 */* 31 */ 14274021 MAXTEST DS 0H * * * * 14280020 CH COUNTER,DEC32 TALLY GREATER THAN 31 14290020 BE TURNOFF YES, ERROR 14300020 B ALPHAMER NO, SCAN NEXT CHARACTER 14310020 SPACE 14320020 */*BREAK: D (YES,,NO,DILIMITR) CHARACTER IS BREAK CHARACTER */ 14322021 BREAK DS 0H * * * * 14330020 CLI ZERO(XINPUT),BKCHAR BREAK CHARACTER 14340020 BNE DILIMITR NO, BRANCH 14350020 */* D (YES,TALLYCT,NO,) PROCESSING SYMBOLIC ADDRESS */ 14352021 TM DATAFLG,SYMADR DEFINITELY PROCESSING A 14360020 * SYMBOLIC ADDRESS 14370020 BO TALLYCT YES, BRANCH 14380020 */* P TURN ON BREAKBIT */ 14382021 OI PFLAGS2,BREAKBIT TURN BIT ON 14390020 */* D (,TALLYCT) BRANCH */ 14392021 B TALLYCT AND BRANCH 14400020 SPACE 14410020 */*DILIMITR: D (YES,SPECIAL,NO,) PROCESSING SYMBOLIC ADDRESS */ 14412021 DILIMITR DS 0H * * * * 14420020 TM DATAFLG,SYMADR ALREADY PROCESSING A SYMBOLIC 14430020 * ADDRESS 14440020 BO SPECIAL YES, BRANCH 14450020 */* D (YES,FINDOUT,NO,) VALID DELIMITER FOR LOADNAME OR ENTRYNAME */ 14452021 CLI ZERO(XINPUT),PERIOD VALID DELIMITER FOR LOADNAME 14460020 * OR ENTRYNAME 14470020 BE FINDOUT YES, BRANCH 14480020 */* D (YES,,NO,ASBEFORE) PROCESSING ENTRYNAME */ 14482021 TM PFLAGS2,ENTRYBIT CURRENTLY PROCESSING AN 14490020 * ENTRYNAME 14500020 BZ ASBEFORE NO, BRANCH 14510020 */* P TURN ON BIT DENOTING ENTRYNAME ADDRESS */ 14512021 OI PFLAGS,PFNEW TURN ON BIT DENOTING AN 14520020 * ENTRYNAME ADDRESS 14530020 */* D (,CHARACBK) BRANCH */ 14532021 B CHARACBK AND BRANCH 14540020 */*ASBEFORE: P TURN FILTER BIT OFF */ 14542021 ASBEFORE DS 0H * * * * 14550020 NI PFLAGS2,HFF-FLTERBIT TURN FILTER BIT OFF 14560020 */* P TURN ON BIT FOR SYMBOLIC ADDRESS */ 14562021 MVI DATAFLG,SYMADR DENOTE AS SYMBOLIC ADDRESS 14570020 */* D (,SPECIAL) BRANCH */ 14572021 B SPECIAL AND BRANCH 14580020 SPACE 14590020 */*FINDOUT: D (YES,CHARACBK,NO,) PROCESSING ENTRYNAME */ 14592021 FINDOUT DS 0H * * * * 14600020 TM PFLAGS2,ENTRYBIT PROCESSING AN ENTRYNAME 14610020 BO CHARACBK YES, BRANCH 14620020 SPACE 14630020 */*LOADPARM: P TURN ON LOADNAME BIT */ 14632021 LOADPARM DS 0H * * * * 14640020 OI PFLAGS2,LOADBIT INDICATE LOADNAME DATA TO BE 14650020 * MOVED 14660020 */* S MOVEIN: PREPARE TO MOVE DATA INTO PDE */ 14662021 BAL LINK2,MOVEIN BRANCH TO SECTION TO PREPARE 14670020 * TO MOVE DATA INTO PDE 14680020 */* D (YES,TURNOFF,NO,) LOADNAME PREVIOUSLY SCANNED */ 14682021 TM DATAFLA1,PL1BIT WAS A LOADNAME PREVIOUSLY 14690020 * SCANNED 14700020 BO TURNOFF YES, BRANCH 14710020 */* P TURN OFF LOADNAME CONTROL BIT */ 14712021 NI PFLAGS2,HFF-LOADBIT TURN OFF LOADNAME CONTROL BIT 14720020 */* P MOVE DATA INTO PDE */ 14722021 MVC DATAPTR1+ONE(L'DATAPTR1-ONE),PPOINTR+ONE 14730020 * MOVE LOADNAME PTR INTO PDE 14740020 MVC DATALEN1,PLENGTH MOVE DATA LENGTH 14750020 OI DATAFLA1,PL1BIT TURN ON PL1 BIT 14760020 LA XINPUT,ONE(,XINPUT) INCREMENT SCAN REGISTER 14770020 LR XINPUTB,XINPUT SET BACKUP REGISTER 14780020 */* P ZERO SIZE OF PARAMETER */ 14782021 XR COUNTER,COUNTER CLEAR TALLY REGISTER 14790020 */* D (,ENTRYNM) PROCESS ENTRYNAME */ 14792021 B ENTRYNM GO PROCESS ENTRYNAME 14800020 SPACE 14810020 */*CHARACBK: D (YES,TURNOFF,NO,) BREAKBIT IS ON */ 14812021 CHARACBK DS 0H * * * * 14820020 TM PFLAGS2,BREAKBIT IS BREAK CHARACTER BIT ON 14830020 BO TURNOFF YES, ERROR 14840020 */* S MOVEIN: PREPARE TO MOVE DATA INTO PDE */ 14842021 BAL LINK2,MOVEIN MOVE SCANNED DATA INTO PDE 14850020 */* D (YES,TURNOFF,NO,) ENTRYNAME WAS PREVIOUSLY SCANNED */ 14852021 TM DATAFLA2,PL1BIT WAS AN ENTRYNAME PREVIOUSLY 14860020 * SCANNED 14870020 BO TURNOFF YES, ERROR, BRANCH 14880020 */* P TURN ENTRYNAME CONTROL BIT OFF */ 14882021 NI PFLAGS2,HFF-ENTRYBIT TURN CONTROL BIT OFF 14890020 */* P MOVE ENTRYNAME DATA INTO PDE */ 14892021 MVC DATAPTR2+ONE(L'DATAPTR2-ONE),PPOINTR+ONE 14900020 * MOVE ENTRYNAME DATA INTO PDE 14910020 MVC DATALEN2,PLENGTH MOVE DATA LENGTH 14920020 */* P TURN ON PL1 BIT */ 14922021 OI DATAFLA2,PL1BIT TURN ON PL1 BIT 14930020 LA XINPUT,ONE(XINPUT) INCREMENT SCAN REG 14940020 LR XINPUTB,XINPUT SET BACKUP REGISTER 14950020 */* D (YES,RANGECK,NO,) SCANNING ENTRYNAME ADDRESS */ 14952021 TM PFLAGS,PFNEW SCANNING AN ENTRYNAME ADDRESS 14960020 BO RANGECK YES, GO SCAN FOR VALID DELIMITER 14970020 LA XINPUT,ONE(XINPUT) TEMPORARILY INCREMENT SCAN 14980020 * REGISTER 14990020 * SINCE SYMBOLIC AND RELATIVE 15000020 * ARE THE ONLY ADDRESSES WHICH MAY 15010020 * BE QUALIFIED, THE PERIOD 15020020 * FOLLOWING ENTRYNAME MUST BE 15030020 * FOLLOWED BY EITHER A PLUS(+) 15040020 * SIGN FOR RELATIVE OR A LETTER 15050020 * FOR SYMBOLIC 15060020 */* D (YES,REGRESET,NO,) PERIOD FOLLOWED BY A PLUS (+) */ 15062021 CLI ZERO(XINPUT),RELATIVE PERIOD FOLLOWED BY A PLUS(+) 15070020 BE REGRESET YES, BRANCH 15080020 */* S TYPETEST: CHARACTER IS LETTER OR NATIONAL CHAR */ 15082021 LA CHECK,HEX+OLETTER+NATL FOLLOWED A LETTER OR NATIONAL 15090020 * CHARACTER 15100020 BAL LINK1,TYPETEST * * * * 15110020 */* D (YES,,NO,TURNOFF) VALID CHARACTER */ 15112021 B TURNOFF + 0 RETURN - NO, ERROR CONDITION 15120020 SPACE 15130020 */*REGRESET: D (,STARTAGN) BRANCH TO BEGIN SCAN */ 15132021 REGRESET DS 0H * * * * 15140020 BCT XINPUT,STARTAGN + 4 RETURN - YES, RESTORE SCAN 15150020 * REGISTER TO LAST CHARACTER 15160020 * SCANNED AND BRANCH 15170020 SPACE 15180020 */*ADDREPLS: P INDICATE RELATIVE ADDRESS */ 15182021 ADDREPLS DS 0H * * * * 15190020 MVI DATAFLG,RELADR INDICATE RELATIVE ADDRESS 15200020 LA R1,ONE(XINPUT) BEGINNING OF RELATIVE ADDRESS 15210020 ST R1,PPOINTR IS ONE BYTE PAST + SIGN 15220020 SPACE 15230020 */*BUMPCTR: P INCREMENT SCAN POINTER */ 15232021 BUMPCTR DS 0H * * * * 15240020 LA XINPUT,ONE(XINPUT) INCREMENT SCAN REGISTER 15250020 LR XINPUTB,XINPUT SET BACKUP REGISTER 15260020 */* S CHECKEND: CHECK FOR END OF INPUT */ 15260421 BAL LINK1,CHECKEND CHECK FOR END OF INPUT M4789 15262020 */* S TYPETEST: CHECK FOR HEXADECIMAL CHARACTER */ 15264021 LA CHECK,HEX+NUMBER HEXADECIMAL CHARACTER 15270020 BAL LINK1,TYPETEST * * * * 15280020 */* D (YES,,NO,SPECIAL) HEX CHARACTER */ 15282021 B SPECIAL NO, BRANCH 15290020 */* P INCREMENT COUNTER FOR SIZE OF PARAMETER */ 15292021 LA COUNTER,ONE(COUNTER) YES, INCREMENT TALLY BY ONE 15300020 */* D (YES,TURNOFF,NO,) SIZE IS GREATER THAN 6 */ 15302021 CH COUNTER,DEC7 DOES TALLY EQUAL SEVEN 15310020 BE TURNOFF YES, ERROR, MAXIMUM IS 6 15320020 */* D (YES,TURNOFF,NO,) HEX CHARACTER FOLLOWS PERCENT SIGN */ 15322021 LTR LEVELS,LEVELS IF R3(LEVELS)NOT ZERO, THEN 15330020 BNZ TURNOFF HEXADECIMAL CHARACTER FOLLOWS 15340020 * THE PERCENT SIGN 15350020 * AND CONSTITUTES AN ERROR 15360020 */* D (YES,TURNOFF,NO,BUMPCTR) PROCESSING ABSOLUTE ADDRESS */ 15362021 CLI DATAFLG,ABSADR PROCESSING AN ABSOLUTE ADDRESS 15370020 * M5957 15372020 BE TURNOFF YES, ERROR, HEXADECIMAL M5957 15380020 * CHARACTER FOLLOWS DELIMITER 15390020 B BUMPCTR NO, BRANCH 15400020 SPACE 15410020 */*SPECIAL: D (YES,TURNOFF,NO,) ENTRYBIT IS ON */ 15412021 SPECIAL DS 0H * * * * 15420020 TM PFLAGS2,ENTRYBIT IF 'ENTRYBIT' IS ON WHEN TESTING 15430020 BO TURNOFF FOR LEVELS OF INDIRECT 15440020 * ADDRESSING, THE ADDRESS IS NOT 15450020 * VALID 15460020 */* D (YES,,NO,GOMOVE) INDIRECT ADDRESSING */ 15462021 CLI ZERO(XINPUT),PERCENT TEST FOR INDIRECT ADDRESSING 15470020 BNE GOMOVE NO, BRANCH 15480020 SPACE 15490020 */*GENLOOP: P INCREMENT NO. OF LEVELS FOR INDIRECT ADDRESS */ 15492021 GENLOOP DS 0H * * * * 15500020 LA LEVELS,ONE(LEVELS) INCREMENT TALLY OF LEVELS OF 15510020 * INDIRECT ADDRESSES 15520020 */* D (YES,TURNOFF,NO,BUMPCTR) LEVELS EQUALS 256 */ 15522021 CH LEVELS,TWO56 DOES TALLY EQUAL 256 15530020 BL BUMPCTR NO, CONTINUE SCANNING 15540020 B TURNOFF YES, ERROR, MAXIMUM IS 255 15550020 SPACE 15560020 */*GOMOVE: D (YES,TURNOFF,NO,) LENGTH OF ADDRESS IS ZERO */ 15562021 GOMOVE DS 0H * * * * 15570020 LTR COUNTER,COUNTER IS LENGTH OF ADDRESS ZERO 15580020 BZ TURNOFF YES, BRANCH, ERROR CONDITION 15590020 */* S MOVEIN: PREPARE TO MOVE ADDRESS INTO TEMPORARY PDE */ 15592021 BAL LINK2,MOVEIN MOVE SCANNED PORTION OF ADDRESS 15600020 * INTO TEMPORARY PDE 15610020 */* D (YES,EXPRESS,NO,RANGECK) ADDRESS EXPRESSION SPECIFIED */ 15612021 CLI ZERO(XINPUT),MORE TEST FOR ADDRESS EXPRESSION 15620020 BE EXPRESS DENOTED BY A PLUS 15630020 CLI ZERO(XINPUT),LESS OR A MINUS 15640020 BNE RANGECK IF NOT, BRANCH 15650020 SPACE 15660020 */*EXPRESS: P MOVE SIGN OF EXPRESSION VALUE TO PDE */ 15662021 EXPRESS DS 0H * * * * 15670020 MVC DATASGN(L'DATASGN),ZERO(XINPUT) 15680020 * MOVE SIGN OF EXPRESSION VALUE 15690020 * TO PDE 15700020 */*RECYCLE: P ZERO SIZE OF PARAMETER AND NUMBER OF LEVELS COUNTERS */ 15702021 RECYCLE DS 0H * * * * 15710020 XR COUNTER,COUNTER A WORK REGISTER TO MAINTAIN A 15720020 * TALLY OF SIZE OF EXPRESSION 15730020 XR LEVELS,LEVELS A WORK REGISTER TO MAINTAIN A 15740020 * TALLY OF THE NUMBER OF LEVELS 15750020 * OF INDIRECT ADDRESSES 15760020 LA R1,ONE(XINPUT) START OF EXPRESSION IS ONE BYTE 15770020 ST R1,PPOINTR PAST PLUS(MINUS)SIGN 15780020 */* P INDICATE ADDRESS EXPRESSION */ 15780421 OI PFLAGS,ADREXP INDICATE ADDR EXPRESSION M4789 15782020 SPACE 15790020 */*UPDATE: P INCREMENT SCAN POINTER */ 15792021 UPDATE DS 0H * * * * 15800020 LA XINPUT,ONE(XINPUT) INCREMENT SCAN REGISTER 15810020 LR XINPUTB,XINPUT SET BACKUP REGISTER 15820020 */* S CHECKEND: CHECK FOR END OF INPUT */ 15820421 BAL LINK1,CHECKEND CHECK FOR END OF INPUT M4789 15822020 SPACE 15830020 LA CHECK,HEX HEX CHARACTER 15840020 */* S TYPETEST: CHECK FOR HEX CHARACTER */ 15842021 BAL LINK1,TYPETEST * * * * 15850020 */* D (YES,,NO,DECIMAL) CHARACTER IS HEX */ 15852021 B DECIMAL NO, BRANCH 15860020 */* P TURN ON HEX BIT */ 15862021 OI PFLAGS,HEXBIT INDICATE HEX CHARACTER 15870020 */* D (YES,TURNOFF,NO,RAISECTR) HEX CHARACTER IN DECIMAL EXPRESSION */ 15870421 TM PFLAGS,DECBIT HEX CHARACTER IN DECIMAL 15872020 * EXPRESSION 15874020 BO TURNOFF YES,BRANCH 15876020 B RAISECTR * * * * 15880020 SPACE 15890020 */*DECIMAL: S TYPETEST: CHECK FOR NUMERIC CHARACTER */ 15892021 DECIMAL DS 0H * * * * 15900020 LA CHECK,NUMBER A NUMERIC CHARACTER 15910020 BAL LINK1,TYPETEST * * * * 15920020 */* D (YES,,NO,NTEST) NUMERIC CHARACTER */ 15922021 B NTEST NO, BRANCH 15930020 SPACE 15940020 */*RAISECTR: P INCREMENT SIZE OF EXPRESSION */ 15942021 RAISECTR DS 0H * * * * 15950020 LA COUNTER,ONE(COUNTER) INCREMENT TALLY BY ONE 15960020 */* D (YES,TURNOFF,NO,UPDATE) EXPRESSION EXCEEDS SIX DIGITS */ 15962021 CH COUNTER,DEC7 DOES EXPRESSION EXCEED SIX 15970020 * DIGITS (MAXIMUM) 15980020 BE TURNOFF YES, BRANCH 15990020 B UPDATE OTHERWISE, SCAN NEXT CHARACTER 16000020 SPACE 16010020 */*NTEST: D (YES,TURNOFF,NO,) SIZE OF EXPRESSION IS ZERO */ 16012021 NTEST DS 0H * * * * 16020020 LTR COUNTER,COUNTER IF R2(COUNTER)IS ZERO, THEN 16030020 BZ TURNOFF ADDRESS EXPRESSION IS INVALID 16040020 */* D (YES,HEXBITT,NO,) DECIMAL EXPRESSION SPECIFIED */ 16042021 CLI ZERO(XINPUT),NNN IS THIS A DECIMAL EXPRESSION 16050020 BE HEXBITT YES, BRANCH 16060020 CLI ZERO(XINPUT),LOWNNN LOW 'N' IS VALID 16070020 BE HEXBITT * * * * 16080020 */* D (YES,PERCENTT,NO,) COMPLETED SCAN FOR DECIMAL EXPRESSION */ 16082021 TM PFLAGS,DECBIT COMPLETED SCAN FOR DECIMAL 16090020 * EXPRESSION 16100020 BO PERCENTT YES, BRANCH 16110020 */* P INDICATE HEXADECIMAL VALUE */ 16112021 OI PFLAGS,HEXBIT DENTOE AS HEXADECIMAL VALUE 16120020 */* D (,PERCENTT) CHECK FOR LEVELS OF INDIRECT ADDRESSING */ 16122021 B PERCENTT BRANCH AND CHECK FOR LEVELS OF 16130020 * INDIRECT ADDRESSING 16140020 SPACE 16150020 */*HEXBITT: D (YES,TURNOFF,NO,) DECIMAL EXPRESSION CONTAINS HEX CHAR */ 16152021 HEXBITT DS 0H * * * * 16160020 TM PFLAGS,HEXBIT DOES DECIMAL EXPRESSION CONTAIN 16170020 * A HEX CHARACTER 16180020 BO TURNOFF YES EXIT --- BRANCH 16190020 SPACE 16200020 */* D (YES,TURNOFF,NO,) DECIMAL EXPRESSION ALREADY SPECIFIED */ 16202021 TM PFLAGS,DECBIT DECIMAL ADDRESS EXPRESSION 16210020 * ALREADY SPECIFIED 16220020 BO TURNOFF YES, ERROR, BRANCH 16230020 */* P INDICATE DECIMAL EXPRESSION */ 16232021 OI PFLAGS,DECBIT DENOTE AS DECIMAL ADDRESS 16240020 * EXPRESSION 16250020 */* D (,UPDATE) SCAN NEXT CHARACTER */ 16252021 B UPDATE AND SCAN NEXT CHARACTER 16260020 SPACE 16270020 */*PERCENTT: D (YES,,NO,ENDPDE) EXPRESSION HAS LEVELS OF INDIRECT 16272021 */*ADDRESSING */ 16274021 PERCENTT DS 0H * * * * 16280020 CLI ZERO(XINPUT),PERCENT DOES EXPRESSION CONTAIN LEVELS 16290020 * OF INDIRECT ADDRESSING 16300020 BNE ENDPDE NO, BRANCH 16310020 */* P INCREMENT NO. OF LEVELS OF INDIRECT ADDRESSING */ 16312021 LA LEVELS,ONE(LEVELS) INCREMENT TALLY OF LEVELS OF 16320020 * INDIRECT ADDRESSES 16330020 */* D (YES,TURNOFF,NO,) LEVELS EQUALS 256 */ 16332021 CH LEVELS,TWO56 DOES TALLY EQUAL 256 16340020 BNL TURNOFF YES, ERROR, MAXIMUM IS 255 16350020 */* P INCREMENT SCAN POINTER */ 16352021 LA XINPUT,ONE(XINPUT) INCREMENT SCAN POINTER 16360020 LR XINPUTB,XINPUT SET BACKUP REGISTER 16370020 */* S CHECKEND: CHECK FOR END OF INPUT */ 16370421 BAL LINK1,CHECKEND CHECK FOR END OF INPUT M4789 16372020 */* D (,PERCENTT) LOOK FOR ANOTHER LEVEL */ 16374021 B PERCENTT CHECK FOR ANOTHER LEVEL 16380020 SPACE 16390020 */*ENDPDE: P INDICATE ADDR EXPRESSION COMPLETE */ 16392021 ENDPDE DS 0H * * * * 16400020 NI PFLAGS,HFF-ADREXP ADDR EXPRESSION COMPLETE M4789 16402020 L TINYPDE,SPLNGTH SPECIFY SUBPOOL AND AMOUNT OF 16410020 * CORE NEEDED FOR EXPRESSION VALUE 16420020 * PDE AND CLEAR IT 16430020 */* S STALOC: GET CORE NEEDED FOR EXPRESSION VALUE PDE */ 16432021 BAL LINK2,STALOC * * * * 16440020 */* P DENOTE AS LAST IN CHAIN */ 16442021 MVI ADDRPTR(TINYPDE),HFF DENOTE AS LAST IN CHAIN 16450020 */* D (YES,,NO,SEARCH) JUST SCANNED FIRST EXPRESSION */ 16452021 CLI DATAEXP,HFF JUST SCANNED FIRST EXPRESSION 16460020 BNE SEARCH NO, BRANCH 16470020 */* P SET PTR TO FIRST EXPRESSION VALUE PDE */ 16472021 ST TINYPDE,DATAEXP INITIALIZE POINTER TO 1ST 16480020 * EXPRESSION VALUE PDE 16490020 */* D (,TRANSLAT) BRANCH */ 16492021 B TRANSLAT AND BRANCH 16500020 SPACE 16510020 */*SEARCH: P GET PTR TO FIRST EXP VALUE PDE FROM ORIGINAL PDE */ 16512021 SEARCH DS 0H * * * * 16520020 L LOCATPDE,DATAEXP OBTAIN PTR TO FIRST EXPRESSION 16530020 * VALUE PDE FROM ORIGINAL PDE 16540020 */* D (YES,LASTPTR,NO,) LAST PDE IN CHAIN */ 16542021 CLI ADDRPTR(LOCATPDE),HFF LAST PDE IN CHAIN 16550020 BE LASTPTR YES, BRANCH 16560020 SPACE 16570020 */*CYCLE: P GET PTR TO NEXT PDE */ 16572021 CYCLE DS 0H * * * * 16580020 L LOCATPDE,ADDRPTR(LOCATPDE) 16590020 * LOCATE POINTER TO NEXT PDE 16600020 */* D (YES,,NO,CYCLE) LAST PDE IN CHAIN */ 16602021 CLI ADDRPTR(LOCATPDE),HFF LAST 16610020 BNE CYCLE NO, BRANCH 16620020 SPACE 16630020 */*LASTPTR: P STORE PTR TO NEWEST PDE */ 16632021 LASTPTR DS 0H * * * * 16640020 ST TINYPDE,ADDRPTR(LOCATPDE) 16650020 * STORE PTR TO NEWEST PDE 16660020 SPACE 16670020 */*TRANSLAT: P COMPUTE LENGTH OF ADDRESS */ 16672021 TRANSLAT DS 0H * * * * 16680020 BCTR XINPUT,ZERO BACKUP SCAN AGAIN 16690020 S XINPUTB,PPOINTR COMPUTE LENGTH OF ADDRESS 16700020 SR XINPUTB,LEVELS EXPRESSION(EXCLUDING LEVELS OF 16710020 * INDIRECT ADDRESSING, IF NONE 16720020 * R3(LEVELS)WILL CONTAIN ZEROS) 16730020 TM PFLAGS,DECBIT PROCESSING A DECIMAL EXPRESSION 16740020 * VALUE 16750020 BZ ASITWAS NO, BRANCH 16760020 BCTR XINPUTB,ZERO SUBTRACT ONE TO EXCLUDE THE 16770020 * CHARACTER 'N' FROM THE LENGTH 16780020 * OF THE DECIMAL EXPRESSION VALUE 16790020 SPACE 16800020 */*ASITWAS: P STORE DATA LENGTH */ 16802021 ASITWAS DS 0H * * * * 16810020 STH XINPUTB,PLENGTH STORE DATA LENGTH 16820020 ST TINYPDE,TEMPSAVE TO TEMPORARILY STORE R1(TINYPDE) 16830020 * BEFORE LINKING TO TRANSQ 16840020 L R15,ATRANSQ GET ADDRESS OF TRANSLATE 16850020 * ROUTINE 16860020 */* P TRANSLATE TO UPPER CASE */ 16862021 BALR LINK1,R15 TRANSLATE TO UPPER CASE 16870020 L TINYPDE,TEMPSAVE RELOAD R1(TINYPDE) 16880020 */* P STORE DATA IN PDE */ 16882021 MVC ADDRDATA+ONE(THREE,TINYPDE),PPOINTR+ONE 16890020 * MOVE PTR TO ADDRESS STRING 16900020 MVC ADDRLNTH(TWO,TINYPDE),PLENGTH 16910020 * MOVE LENGTH OF ADDRESS STRING 16920020 * TO PDE 16930020 STH LEVELS,ADDRCNT(TINYPDE) STORE NUMBER OF LEVELS OF 16940020 * INDIRECT ADDRESSING. IF NONE, 16950020 * THEN R3(LEVELS)WILL BE ZERO 16960020 * M4789 16962020 */* D (YES,,NO,NODESIM) HEX EXPRESSION VALUE */ 16964021 TM PFLAGS,DECBIT HEXIDECIMAL EXPRESSION VALUE 16970020 BZ NODESIM NO, BRANCH M4789 16980020 */* P TURN OFF DECBIT */ 16982021 NI PFLAGS,HFF-DECBIT TURN BIT OFF M4789 16990020 */* P INDICATE HEX EXPRESSION IN PDE */ 16992021 OI ADDRFLGS(TINYPDE),DECVALUE M4789 17000020 * DENOTES A HEXIDECIMAL EXPRESSION 17010020 */* D (,WHATNEXT) BRANCH */ 17012021 B WHATNEXT * * * * 17020020 SPACE 17030020 */*NODESIM: P TURN OFF HEX BIT */ 17032021 NODESIM DS 0H * * * * 17040020 NI PFLAGS,HFF-HEXBIT TURN BIT OFF M4789 17050020 */* P INDICATE DEC EXPRESSION IN PDE */ 17052021 OI ADDRFLGS(TINYPDE),HEXVALUE M4789 17060020 * DENOTES A DECIMAL EXPRESSION 17070020 SPACE 17080020 */*WHATNEXT: P INCREMENT SCAN POINTER */ 17082021 WHATNEXT DS 0H * * * * 17090020 LA XINPUT,ONE(,XINPUT) INCREMENT SCAN REGISTER 17100020 LR XINPUTB,XINPUT SET BACKUP REGISTER 17110020 */* P CHECK FOR RANGE ON ENDINPUT TEST */ 17110121 OI PFLAGS4,CKRANGE CHECK FOR RNGE ON ENDINPUT M4789 17110420 */* S CHECKEND: CHECK FOR END OF INPUT */ 17110821 BAL LINK1,CHECKEND CHECK FOR END OF INPUT M4789 17112020 */* P TURN OFF BIT FOR RANGE CHECK */ 17112421 NI PFLAGS4,HFF-CKRANGE ENDINPUT NOT FOUND M4789 17114020 */* D (YES,ADDEXP,NO,RANGECK) ANOTHER RELATIVE EXP */ 17116021 CLI ZERO(XINPUT),MORE TEST FOR ANOTHER EXPRESSION (+) 17120020 BE ADDEXP YES, BRANCH 17130020 CLI ZERO(XINPUT),LESS (-) 17140020 BNE RANGECK NO, BRANCH 17150020 SPACE 17160020 */*ADDEXP: P MOVE SIGN OF NEXT EXP VALUE INTO PDE OF PREVIOUS EXP */ 17162021 ADDEXP DS 0H * * * * 17170020 MVC ADDRSIGN(ONE,TINYPDE),ZERO(XINPUT) 17180020 * MOVE SIGN OF NEXT EXPRESSION 17190020 * VALUE INTO PDE OF PREVIOUS 17200020 * EXPRESSION 17210020 */* D (,RECYCLE) BRANCH */ 17212021 B RECYCLE * * * * 17220020 SPACE 17230020 */*RANGECK: P TURN OFF BIT FOR RANGE CHECK */ 17232021 RANGECK DS 0H * * * * 17240020 NI PFLAGS4,HFF-CKRANGE ENDINPUT HAS BEEN FOUND M4789 17242020 */* S RANGE: CHECK FOR POSSIBLE RANGE */ 17244021 BAL LINK1,RANGE PROCESS POSSIBLE RANGE 17250020 */* D (YES,EXITPREP,NO,) RANGE SPECIFIED */ 17252021 B ENDBUFFR NO, BRANCH 17260020 B EXITPREP YES, FIRST VALUE OF RANGE 17270020 * PARAMETER DETECTED 17280020 */*ENDBUFFR: D (YES,,NO,NOTEND) REACHED END OF INPUT */ 17282021 ENDBUFFR DS 0H * * * * 17290020 C XINPUT,ENDINPUT END OF BUFFER 17300020 * AN END OF BUFFER CONDITION IS 17310020 * CONSIDERED EQUIVALENT TO A 17320020 * VALID DELIMITER 17330020 BL NOTEND NO, CONTINUE 17340020 SPACE 17350020 */* P SET END OF FILE INDICATOR */ 17352021 OI PFLAGS,PFENDF YES, SET END-OF-FILE INDICATOR 17360020 * SO CURRENT STATUS OF SCAN 17370020 * WILL NOT BE SAVED BEFORE 17380020 * PROMPT 17390020 */* D (,EXITPREP) BRANCH TO ADDRESS EXIT */ 17392021 B EXITPREP BRANCH TO ADDRESS EXIT 17400020 SPACE 17410020 */*NOTEND: S TYPETEST: CHECK FOR DELIMITER CHARACTER */ 17412021 NOTEND DS 0H * * * * 17420020 SPACE 17430020 LA CHECK,DLIMREQD DELIMITER CHARACTER M3098 17440020 BAL LINK1,TYPETEST * * * * 17450020 SPACE 17460020 */* D (YES,EXITPREP,NO,PAREN) VALID DELIMITER */ 17462021 B PAREN +0 RETURN - NON-DELIMITER 17470020 SPACE 17480020 B EXITPREP +4 RETURN - DELIMITER 17490020 SPACE 17500020 */*PAREN: D (YES,,NO,TURNOFF) DELIMITER FOR LIST */ 17502021 PAREN DS 0H * * * * 17510020 CLI ZERO(XINPUT),RIGHTPRN LIST DELIMITER 17520020 BNE TURNOFF NO, BRANCH(NO REMAINING VALID 17530020 * DELIMITER) 17540020 */*EXITPREP: D (YES,,NO,NORANGE) COMPLETED SCAN FOR FIRST VALUE OF 17542021 */*RANGE */ 17544021 EXITPREP DS 0H * * * * 17550020 TM PFLAGS2,RNGEVAL1 JUST COMPLETED SCAN FOR FIRST 17560020 * VALUE OF RANGE PARAMETER 17570020 BZ NORANGE NO, BRANCH AND EXIT 17580020 */* P POINT TO BEGINNING OF SECOND VALUE OF RANGE */ 17582021 LA LINK2,RANGENTR INITILAIZE LINK2(R8) TO POINT 17590020 * TO BEGINNING OF SCAN OF SECOND 17600020 * VALUE OF RANGE ADDRESS 17610020 SPACE 17620020 */*NORANGE: D (YES,,NO,ADREXIT) ENTRYNAME ADDRESS BIT ON */ 17622021 NORANGE DS 0H * * * * 17630020 TM PFLAGS,PFNEW ENTRYNAME ADDRESS CONTROL BIT ON 17640020 BZ ADREXIT NO, BRANCH 17650020 */* P TURN BIT OFF */ 17652021 NI PFLAGS,HFF-PFNEW TURN BIT OFF 17660020 */* D (YES,,NO,ADREXIT) PROCESSING A NON-QUALIFYING ENTRYNAME */ 17662021 TM DATAFLA3,PL1BIT PROCESSING A NON-QUALIFYING 17670020 * ENTRYNAME 17680020 BO ADREXIT NO, BRANCH 17690020 */* P INDICATE AS NON-QUALIFYING ENTRYNAME */ 17692021 MVI DATAFLG,ENTRYNAM DENOTE AS NON-QUALIFYING 17700020 * ENTRYNAME(OPTIONALLY PRECEDED 17710020 * BY LOADNAME) 17720020 */*ADREXIT: P DECREMENT INPUT POINTER FOR EXIT */ 17722021 ADREXIT DS 0H * * * * 17730020 BCTR XINPUT,ZERO DECREMENT INPUT POINTER FOR 17740020 * NORMAL EXIT 17750020 SPACE 17760020 */*ADREXIT1: P MOVE 9 WORDS OF DATA TO PDE */ 17762021 ADREXIT1 DS 0H * * * * 17770020 LA R1,THIRTY5 HAVE EXIT ROUTINE MOVE 9 WORDS 17780020 * OF DATA TO PDE 17790020 */* D (,POSITX) EXIT */ 17792021 B POSITX EXIT 17800020 SPACE 17810020 */*REGISTER: D (YES,TURNOFF,NO,) REGISTER ADDRESS PRECEDED BY A 17812021 */*QUALIFIER */ 17814021 REGISTER DS 0H * * * * 17820020 TM PFLAGS2,ENTRYBIT A REGISTER ADDRESS PRECEDED 17830020 BO TURNOFF BY A QUALIFIER IS INVALID 17840020 TM DATAFLA2,PL1BIT THESE INSTRUCTIONS WILL DETECT 17850020 BO TURNOFF SUCH INVALID ADDRESSES 17860020 SPACE 17870020 */* D (YES,COMMON,NO,MAYBE1) CHARACTER IS 0,2,4,6 */ 17872021 CLI ZERO(XINPUT),EBCDIC0 IF FIRST CHARACTER IS 0,2,4,6 17880020 BE COMMON THEN ADDRESS MAY BE FLOATING 17890020 * POINT OR GENERAL REGISTER TYPE 17900020 * ADDRESS 17910020 CLI ZERO(XINPUT),EBCDIC2 * * * * 17920020 BE COMMON * * * * 17930020 CLI ZERO(XINPUT),EBCDIC4 * * * * 17940020 BE COMMON * * * * 17950020 CLI ZERO(XINPUT),EBCDIC6 * * * * 17960020 BNE MAYBE1 TEST IF FIRST CHARACTER IS A 17970020 * ONE, HENCE A GENERAL REGISTER 17980020 SPACE 17990020 */*COMMON: P INCREMENT SIZE COUNTER AND SCAN POINTER */ 17992021 COMMON DS 0H * * * * 18000020 * FIRST CHARACTER IS 0,2,4,OR 6 18010020 LA COUNTER,ONE(COUNTER) INCREMENT TALLY BY ONE 18020020 LA XINPUT,ONE(XINPUT) INCREMENT SCAN REGISTER 18030020 LR XINPUTB,XINPUT SET BACKUP REGISTER 18040020 */* S CHECKEND: CHECK FOR END OF INPUT */ 18040421 BAL LINK1,CHECKEND CHECK FOR END OF INPUT M4789 18042020 */* D (YES,DOUBLE,NO,SINGLE) DOUBLE PRECISION SPECIFIED */ 18044021 CLI ZERO(XINPUT),D DOUBLE PRECISION 18050020 BE DOUBLE YES, BRANCH 18060020 CLI ZERO(XINPUT),LOWD LOWER CASE 'D' IS VALID 18070020 BNE SINGLE * * * * 18080020 SPACE 18090020 */*DOUBLE: P INDICATE DOUBLE PRECISION FLOATING POINT ADDR */ 18092021 DOUBLE DS 0H * * * * 18100020 MVI DATAFLG,DPFPR DENOTE TYPE OF ADDRESS 18110020 * DOUBLE PRECISION FLOATING POINT 18120020 */*REPEAT: D (YES,MAYBE1,NO,) NEXT CHARACTER IS PERIOD (ABS. ADDR) */ 18122021 REPEAT DS 0H * * * * 18130020 CLI ONE(XINPUT),PERIOD IS THE NEXT CHARACTER A PERIOD 18140020 * DENOTING A ABSOLUTE ADDRESS 18150020 * OF THE TYPE -- 6D., 4E., ETC. 18160020 BE MAYBE1 IF YES BRANCH TO SAME LOCATION 18170020 * AS IF NOT FLOATING POINT REG 18180020 SPACE 18190020 */* P INCREMENT SCAN PTR PAST FLOATING POINT CHAR (D OR E) */ 18192021 LA XINPUT,ONE(XINPUT) INCREMENT POINTER PAST FLOATING 18200020 * POINT DESIGNATION --- D OR E 18210020 */* S CHECKEND: CHECK FOR END OF INPUT */ 18210421 BAL LINK1,CHECKEND CHECK FOR END OF INPUT M4789 18212020 */* S TYPETEST: CHECK FOR ZERO THROUGH F */ 18214021 LA CHECK,HEX+NUMBER HAVE ZERO THROUGH F DIGITS 18220020 * CHECKED FOR 18230020 BAL LINK1,TYPETEST TEST THE CHARACTER 18240020 * 18250020 */* D (YES,,NO,NOTABS) ABSOLUTE ADDRESS */ 18252021 B NOTABS NOT ABSOLUTE ADDRESS 18260020 * 18270020 */* P ZERO SIZE COUNTER */ 18272021 XR COUNTER,COUNTER RESET COUNTER 18280020 */* P BACK UP TO BEFORE D OR E */ 18282021 BCTR XINPUT,ZERO BACK UP XINPUT TO THE NUMBER 18290020 BCTR XINPUT,ZERO BEFORE THE D OR E 18300020 LR XINPUTB,XINPUT RESET BACKUP REGISTER 18310020 */* D (YES,TURNOFF,NO,MAYBE1) REGISTER FORM OF ADDRESS */ 18312021 TM DATAFLG,REG IF REG FORM OF ADDRESS FOUND AT 18320020 * THIS POINT AND IS OF THE FORM 18330020 * 2R13 OR 13R7 IT IS INVALID 18340020 * AND NOT ABSOLUTE 18350020 BNZ TURNOFF PROCESS INVALID ADDRESS 18360020 B MAYBE1 BRANCH TO PROCESS ABSOLUTE 18370020 * ADDRESS 18380020 SPACE 18390020 */*NOTABS: S MOVEIN: PREPARE TO MOVE DATA INTO PDE */ 18392021 NOTABS DS 0H * * * * 18400020 BCTR XINPUT,ZERO ADJUST FOR PREVIOUS INCREMENT 18410020 BAL LINK2,MOVEIN HAVE DATA MOVED INTO PDE 18420020 LA XINPUT,ONE(XINPUT) INCREMENT SCAN REGISTER 18430020 LR XINPUTB,XINPUT SET BACKUP REGISTER 18440020 */* D (,RANGECK) LOOK FOR RANGE PARAMETER */ 18442021 B RANGECK SCAN FOR RANGE PARAMETER 18450020 SPACE 18460020 */*SINGLE: D (YES,ONLYONE,NO,GENERAL) SINGLE PRECISION SPECIFIED */ 18462021 SINGLE DS 0H * * * * 18470020 CLI ZERO(XINPUT),E SINGLE PRECISION 18480020 BE ONLYONE YES, BRANCH 18490020 CLI ZERO(XINPUT),LOWE LOWER CASE 'E' IS VALID 18500020 BNE GENERAL * * * * 18510020 SPACE 18520020 */*ONLYONE: P INDICATE SINGLE PRECISION FLOATING POINT ADDR */ 18522021 ONLYONE DS 0H * * * * 18530020 MVI DATAFLG,SPFPR INDICATE TYPE OF ADDRESS 18540020 * SINGLE PRECISION FLOATING POINT 18550020 */* D (,REPEAT) BRANCH */ 18552021 B REPEAT AND BRANCH 18560020 SPACE 18570020 */*GENERAL: D (YES,GENREG,NO,NOREG) GENERAL REGISTER SPECIFIED */ 18572021 GENERAL DS 0H * * * * 18580020 CLI ZERO(XINPUT),R GENERAL REGISTER 18590020 BE GENREG YES, BRANCH 18600020 CLI ZERO(XINPUT),LOWR LOWER CASE 'R' IS VALID 18610020 BNE NOREG NOT A GENERAL REGISTER, BRANCH 18620020 */*GENREG: P INDICATE GENERAL REGISTER ADDRESS */ 18622021 GENREG DS 0H * * * * 18630020 MVI DATAFLG,REG INDICATE TYPE OF ADDRESS 18640020 * GENERAL REGISTER 18650020 * UNIQUE FOR ADDRESS '1R' 18660020 */* P TURN OFF TWORBIT */ 18662021 NI PFLAGS3,HFF-TWORBIT TWORBIT IS TURNED OFF 18670020 * BEFORE EXITING 18680020 LA XINPUT,ONE(XINPUT) INCREMENT SCAN REGISTER 18690020 */* S CHECKEND: CHECK FOR END OF INPUT */ 18690421 BAL LINK1,CHECKEND CHECK FOR END OF INPUT M4789 18692020 */* D (YES,GENLOOP,NO,) TEST FOR INDIRECT ADDRESSING */ 18694021 CLI ZERO(XINPUT),PERCENT TEST FOR INDIRECT ADDRESSING 18700020 BE GENLOOP YES, BRANCH 18710020 SPACE 18720020 BCTR XINPUT,ZERO BACKUP SCAN AGAIN 18730020 LR XINPUTB,XINPUT SET BACKUP REGISTER 18740020 */* D (,REPEAT) BRANCH */ 18742021 B REPEAT AND BRANCH 18750020 SPACE 18760020 */*MAYBE1: D (YES,,NO,DECIMALL) FIRST CHARACTER A ONE */ 18762021 MAYBE1 DS 0H * * * * 18770020 CLI ZERO(XINPUT),EBCDIC1 * * * * 18780020 BNE DECIMALL BRANCH, FIRST CHARACTER NOT 18790020 * A ONE 18800020 */* P TURN ON TWO CONTROL BITS USED FOR GEN. REGISTER SCAN */ 18802021 OI PFLAGS3,ONERBIT+TWORBIT TURN ON CONTROL BITS USED 18810020 * DURING SCANNING OF POSSIBLE 18820020 * GENERAL REGISTER ADDRESS 18830020 */*REGLOOP: P INCREMENT SIZE COUNTER BY ONE */ 18832021 REGLOOP DS 0H * * * * 18840020 LA COUNTER,ONE(COUNTER) INCREMENT TALLY BY ONE 18850020 LA XINPUT,ONE(XINPUT) INCREMENT SCAN REGISTER 18860020 LR XINPUTB,XINPUT SET BACKUP REGISTER 18870020 */* S CHECKEND: CHECK FOR END OF INPUT */ 18870421 BAL LINK1,CHECKEND CHECK FOR END OF INPUT M4789 18872020 SPACE 18880020 */* D (YES,,NO,REGBITT) CONTROL BIT FOR REGISTER SCAN IS ON */ 18882021 TM PFLAGS3,ONERBIT IS CONTROL BIT FOR REGISTER 18890020 * PROCESSING ON 18900020 BZ REGBITT NO, BRANCH 18910020 */* P TURN OFF CONTROL BIT */ 18912021 NI PFLAGS3,HFF-ONERBIT YES, CLEAR BIT 18920020 */* D (,EXCEED) BRANCH */ 18922021 B EXCEED AND BRANCH 18930020 SPACE 18940020 */*REGBITT: D (YES,,NO,VARYMAX) REGISTER CONTROL BIT ON */ 18942021 REGBITT DS 0H * * * * 18950020 TM PFLAGS2,REGBIT REGISTER CONTROL BIT ON 18960020 BZ VARYMAX NO, BRANCH 18970020 */* P TURN OFF CONTROL BIT */ 18972021 NI PFLAGS2,HFF-REGBIT CLEAR BIT 18980020 SPACE 18990020 */*EXCEED: D (YES,TURNOFF,NO,) PARAMETER SIZE GREATER THAN 2 (REG.) */ 18992021 EXCEED DS 0H * * * * 19000020 CH COUNTER,H3 IS TALLY FOR REGISTER SCAN 19010020 * GREATER THAN TWO 19020020 BNL TURNOFF REGISTER ADDRESS PARAMETER 19030020 * TOO LARGE 19040020 SPACE 19050020 */* D (YES,GENREG,NO,) GENERAL REGISTER ADDRESS */ 19052021 CLI ZERO(XINPUT),R GENERAL REGISTER ADDRESS 19060020 BE GENREG YES, BRANCH TO RTN PROCESSING 19070020 * A GENERAL REGISTER PARAMETER 19080020 CLI ZERO(XINPUT),LOWR LOWER CASE 'R' IS VALID 19090020 BE GENREG * * * * 19100020 SPACE 19110020 */*VARYMAX: D (YES,,NO,MAYBEREG) SIZE COUNTER IS EQUAL TO TWO */ 19112021 VARYMAX DS 0H * * * * 19120020 LA R15,TWO LOAD COMPRAND 19130020 CR COUNTER,R15 IF COUNTER IS EQUAL TO TWO 19140020 * PARAMETER CANNOT BE OF GEN- 19150020 * ERAL REG TYPE.FOR EX.--1AB30 19160020 * WOULD PASS AS A GENERAL REG 19170020 * TYPE IF NOT FOR THESE INSTRS 19180020 BNE MAYBEREG IF NOT TWO BRANCH 19190020 SPACE 19200020 */* P TURN OFF REGISTER CONTROL BIT */ 19202021 NI PFLAGS3,HFF-TWORBIT TURN OFF CONTROL FLAG SO LATER 19210020 * TEST IN 'NOREG' TAKES BZ 19220020 SPACE 19230020 */*MAYBEREG: D (YES,,NO,NOREG) SIZE GREATER THAN MAX FOR ABS. ADDR */ 19232021 MAYBEREG DS 0H * * * 19240020 CH COUNTER,DEC7 IS TALLY GREATER THAN MAXIMUM 19250020 * FOR AN ABSOLUTE ADDRESS 19260020 BL NOREG NO, BRANCH 19270020 */* D (YES,,NO,TURNOFF) SCANNING SYMBOLIC ADDRESS */ 19272021 TM PFLAGS2,FLTERBIT ARE WE POSSIBLY SCANNING A 19280020 * SYMBOLIC ADDRESS 19290020 BZ TURNOFF IF NOT SCANNING A SYMBOLIC 19300020 * ADDRESS PARAMETER, THEN 19310020 * PARAMETER TOO LONG 19320020 */* D (YES,,NO,NOREG) SIZE GREATER THAN MAX FOR LOADNAME */ 19322021 CH COUNTER,DEC9 IS TALLY GREATER THAN MAXIMUM 19330020 * FOR A LOADNAME PARAMETER 19340020 BL NOREG NO, BRANCH 19350020 */* P CLEAR BIT FOR SYMBOLIC ADDRESS */ 19352021 NI PFLAGS2,HFF-FLTERBIT CLEAR BIT 19360020 */* P INDICATE SYMBOLIC ADDRESS */ 19362021 MVI DATAFLG,SYMADR INDICATE AS SYMBOLIC ADDRESS 19370020 */* D (,ALPHAMER) BRANCH */ 19372021 B ALPHAMER AND BRANCH 19380020 SPACE 19390020 */*DECIMALL: P TURN ON REGISTER CONTROL BIT */ 19392021 DECIMALL DS 0H * * * * 19400020 OI PFLAGS2,REGBIT TURN ON REGISTER CONTROL BIT 19410020 SPACE 19420020 */*NOREG: S TYPETEST: CHECK IF CHARACTER IS A NUMBER */ 19422021 NOREG DS 0H * * * * 19430020 LA CHECK,NUMBER IS CHARACTER A NUMBER 19440020 BAL LINK1,TYPETEST * * * * 19450020 SPACE 19460020 */* D (YES,,NO,NODEC) CHARACTER IS NUMERIC */ 19462021 B NODEC +0 RETURN - NON-NUMERIC 19470020 SPACE 19480020 */* D (YES,,NO,REGLOOP) CONTROL BIT FOR REGISTER PROCESSING IS ON */ 19482021 TM PFLAGS3,TWORBIT +4 RETURN - NUMERIC 19490020 BZ REGLOOP BRANCH IF CONTROL BIT FOR 19500020 * REGISTER PROCESSING IS NOT ON 19510020 */* P TURN OFF CONTROL BIT */ 19512021 NI PFLAGS3,HFF-TWORBIT TURN OFF CONTROL BIT 19520020 * TEST IF SECOND NUMERIC CHARACTER 19530020 * IS BETWEEN 0-5 19540020 * THEREFORE, POSSIBLY A GENERAL 19550020 * REGISTER 19560020 */* D (YES,TURNON,NO,REGLOOP) SECOND NUMERIC CHAR IS BETWEEN 0-5 */ 19562021 CLI ZERO(XINPUT),EBCDIC0 * * * * 19570020 BE TURNON YES, BRANCH 19580020 SPACE 19590020 CLI ZERO(XINPUT),EBCDIC1 * * * * 19600020 BE TURNON YES, BRANCH 19610020 CLI ZERO(XINPUT),EBCDIC2 * * * * 19620020 BE TURNON YES, BRANCH 19630020 SPACE 19640020 CLI ZERO(XINPUT),EBCDIC3 * * * * 19650020 BE TURNON YES, BRANCH 19660020 SPACE 19670020 CLI ZERO(XINPUT),EBCDIC4 * * * * 19680020 BE TURNON YES, BRANCH 19690020 SPACE 19700020 CLI ZERO(XINPUT),EBCDIC5 * * * * 19710020 BNE REGLOOP * * * * 19720020 SPACE 19730020 */*TURNON: P TURN ON REGISTER CONTROL BIT */ 19732021 TURNON DS 0H * * * * 19740020 OI PFLAGS3,ONERBIT TURN REGISTER CONTROL BIT ON 19750020 */* D (,REGLOOP) SCAN NEXT CHARACTER */ 19752021 B REGLOOP BRANCH TO SCAN NEXT CHARACTER 19760020 SPACE 19770020 */*NODEC: P TURN REGISTER CONTROL BIT OFF */ 19772021 NODEC DS 0H * * * * 19780020 NI PFLAGS2,HFF-REGBIT TURN CONTROL BIT OFF 19790020 LA CHECK,HEX HEX CHARACTER 19800020 */* S TYPETEST: CHECK FOR HEX CHARACTER */ 19802021 BAL LINK1,TYPETEST * * * * 19810020 */* D (YES,REGLOOP,NO,WHATISIT) HEX CHARACTER */ 19812021 B WHATISIT NO, BRANCH 19820020 B REGLOOP YES, SCAN NEXT CHARACTER 19830020 SPACE 19840020 */*WHATISIT: D (YES,WHICHONE,NO,) DELIMITER FOR ABS. OR LOADNM ADDR */ 19842021 WHATISIT DS 0H * * * * 19850020 CLI ZERO(XINPUT),PERIOD VALID DELIMITER FOR ABSOLUTE 19860020 * OR LOADNAME PARAMETER 19870020 BE WHICHONE YES, BRANCH 19880020 */* D (YES,ALPHAMER,NO,CKCTRR) VALID SYMBOLIC PARAMETER */ 19882021 TM PFLAGS2,FLTERBIT IS FILTER BIT ON 19890020 BZ CKCTRR NO, FIRST CHARACTER NOT A 19900020 * LETTER, THEREFORE NOT A VALID 19910020 * SYMBOLIC PARAMETER 19920020 B ALPHAMER AND BRANCH 19940020 SPACE 19950020 */*CKCTRR: D (YES,ADDREPRQ,NO,TURNOFF) SIZE COUNTER ZERO */ 19952021 CKCTRR DS 0H * * * * 19960020 LTR COUNTER,COUNTER IS TALLY COUNT ZERO 19970020 BNZ TURNOFF NO, ERROR, BRANCH 19980020 BCT XINPUT,ADDREPRQ YES, THEN FIRST CHARACTER OF 19990020 * BUFFER NOT VALID - BACKUP BUFFER 20000020 SPACE 20010020 */*WHICHONE: P INCREMENT SCAN POINTER */ 20012021 WHICHONE DS 0H * * * * 20020020 LA XINPUT,ONE(XINPUT) TEMPORARILY INCREMENT SCAN REG 20030020 */* D (YES,ABSADDR,NO,) REACHED END OF INPUT */ 20030421 */* S TYPETEST: CHECK IF CHARACTER FOLLOWING DELIMITER IS A LETTER */ 20030821 C XINPUT,ENDINPUT ENDINPUT BEEN REACHED M4789 20032020 BNL ABSADDR YES, ABSOLUTE ADDRESS M4789 20034020 LA CHECK,HEX+OLETTER+NATL IS ALPHABETIC OR NATIONAL 20040020 * CHARACTER FOLLOWING 20050020 BAL LINK1,TYPETEST DELIMITER A LETTER 20060020 B ABSADDR NO, PARAMETER IS ABSOLUTE 20070020 * YES, PARAMETER IS LOADNAME 20080020 */* P RESTORE SCAN POINTER */ 20082021 BCTR XINPUT,ZERO RESTORE PTR TO LAST CHARACTER 20090020 * SCANNNED 20100020 */* P TURN OFF SYMBOLIC CONTORL BIT */ 20102021 NI PFLAGS2,HFF-FLTERBIT YES, TURN IT OFF 20110020 */* D (,LOADPARM) PROCESS LOADNAME */ 20112021 B LOADPARM * * * * 20120020 SPACE 20130020 */*ABSADDR: P RESTORE SCAN POINTER */ 20132021 ABSADDR DS 0H * * * * 20140020 BCTR XINPUT,ZERO RESTORE PTR TO LAST CHARACTER 20150020 * SCANNNED 20160020 */* P INDICATE ABSOLUTE ADDRESS */ 20162021 MVI DATAFLG,ABSADR INDICATE AS ABSOLUTE ADDRESS 20170020 */* D (YES,TURNOFF,NO,) ABSOLUTE ADDRESS HAS QUALIFICATION */ 20172021 TM DATAFLA2,PL1BIT IT IS NOT VALID FOR AN ABSOLUTE 20180020 BO TURNOFF ADDRESS TO HAVE QUALIFICATION 20190020 */* P TURN SYMBOLIC CONTROL BIT OFF */ 20192021 NI PFLAGS2,HFF-FLTERBIT TURN CONTROL BIT OFF 20200020 */* D (YES,BUMPCTR,NO,) ENDINPUT HAS BEEN REACHED */ 20200421 TM PFLAGS,PFENDF HAS ENDINPUT BEEN REACHED M4789 20202020 BNO BUMPCTR YES, MOVE DATA IN PDE M4789 20204020 CLI ZERO(XINPUT),PERIOD A46773 20204121 BNE TURNOFF A46773 20204221 */* D (,GOMOVE) INCREMENT SCAN PTR AND BRANCH */ 20204421 LA XINPUT,ONE(XINPUT) INCREMENT SCAN POINTER M4789 20206020 B SPECIAL * * * * M5767 20210020 SPACE 20220020 */*ADDREPRQ: S PROMPTQ: CHECK IF PROMPTING IS NECESSARY */ 20222021 ADDREPRQ DS 0H * * * * 20230020 BAL LINK1,PROMPTQ PROMPT IF NECESSARY 20240020 * 20250020 */* D (YES,ADDRERSC,NO,ADREXIT1) DATA RETURNED FROM PROMPT */ 20252021 B ADDRERSC +0 RETURN - DATA TO SCAN 20260020 * 20270020 B ADREXIT1 +4 RETURN - NO DATA PRESENT EXIT 20280020 SPACE 20290020 */*MOVEIN: E PREPARE DATA TO GO INTO PDE */ 20292021 MOVEIN DS 0H * * * * 20300020 BCTR XINPUT,ZERO BACK UP SCAN AGAIN 20310020 */* P COMPUTE LENGTH OF ADDRESS */ 20312021 S XINPUTB,PPOINTR COMPUTE LENGTH OF ADDRESS 20320020 SR XINPUTB,LEVELS EXCLUDING LEVELS OF INDIRECT 20330020 * ADDRESSING. IF NONE, R3(LEVELS) 20340020 * WILL CONTAIN ZERO 20350020 */* D (YES,ASITIS,NO,) PROCESSING LOADNAME OR ENTRYNAME QUALIFIER */ 20352021 TM PFLAGS2,LOADBIT+ENTRYBIT PROCESSING A LOADNAME QUALIFIER 20360020 * OR AN ENTRYNAME QUALIFIER 20370020 BM ASITIS YES, BRANCH 20380020 */* D (YES,LEVELTST,NO,) PROCESSING GENERAL REGISTER ADDRESS */ 20382021 TM DATAFLG,REG ARE WE PROCESSING A GENERAL 20390020 * REGISTER ADDRESS 20400020 BO LEVELTST YES, BRANCH 20410020 */* D (YES,SUBTRACT,NO,ASITIS) PROCESSING ABSOLUTE ADDRESS */ 20412021 CLI DATAFLG,ABSADR PROCESSING AN ABSOLUTE ADDRESS 20420020 * M5957 20422020 BNE ASITIS NO, BRANCH M5957 20430020 B SUBTRACT YES 20440020 SPACE 20450020 */*LEVELTST: D (YES,,NO,ASITIS) ANY LEVELS OF INDIRECT ADDRESSES */ 20452021 LEVELTST DS 0H 20460020 LTR LEVELS,LEVELS ANY LEVELS OF INDIRECT 20470020 * ADDRESSES SPECIFIED 20480020 BZ ASITIS NO, BRANCH ADDRESS LENGTH OK 20490020 SPACE 20500020 */*SUBTRACT: P EXCLUDE 'R' FROM LENGTH IF REG OR DELIM IF ABS ADDR */ 20502021 SUBTRACT DS 0H 20510020 BCTR XINPUTB,ZERO SUBTRACT ONE TO EXCLUDE THE 20520020 * CHARACTER 'R' FROM THE LENGTH 20530020 * IF REGISTER ADDRESS OR DELIMITER 20540020 * IF ABSOLUTE ADDRESS 20550020 */*ASITIS: P STORE DATA LENGTH */ 20552021 ASITIS EQU * 20560020 STH XINPUTB,PLENGTH STORE DATA LENGTH 20570020 L R15,ATRANSQ GET ADDRESS OF TRANSLATE 20580020 * ROUTINE 20590020 */* P TRANSLATE TO UPPER CASE */ 20592021 BALR LINK1,R15 TRANSLATE TO UPPER CASE 20600020 */* D (YES,,NO,ABC) PREPARING LOADNAME DATA FOR PDE */ 20602021 TM PFLAGS2,LOADBIT ARE WE PREPARING TO MOVE 20610020 * LOADNAME DATA INTO PDE 20620020 */* R RETURN */ 20622021 BCR CC7,LINK2 IF YES RETURN 20630020 SPACE 20640020 */*ABC: D (YES,,NO,ABCD) PREPARING ENTRYNAME DATA FOR PDE */ 20642021 TM PFLAGS2,ENTRYBIT ARE WE PREPARING TO MOVE 20650020 * ENTRYNAME DATA INTO PDE 20660020 */* R RETURN */ 20662021 BCR CC7,LINK2 IF YES RETURN 20670020 SPACE 20680020 */*ABCD: P MOVE DATA PTR TO TEMPORARY PDE */ 20682021 MVC DATAPTR3+ONE(L'DATAPTR3-ONE),PPOINTR+ONE 20690020 * MOVE DATA PTR TO TEMPORARY PDE 20700020 */* P MOVE DATA LENGTH */ 20702021 MVC DATALEN3,PLENGTH MOVE DATA LENGTH 20710020 */* P TURN ON CONTROL BIT FOR PL1 */ 20712021 OI DATAFLA3,PL1BIT CONTROL BIT FOR PL1 20720020 */* P STORE NUMBER OF LEVELS OF INDIRECT ADDRESSING */ 20722021 STH LEVELS,DATAICT STORE NOMBER OF LEVELS OF 20730020 * INDIRECT ADDRESSING. IF NONE, 20740020 * THEN R3(LEVELS)WILL BE ZERO. 20750020 LA XINPUT,ONE(,XINPUT) INCREMENT SCAN REGISTER 20760020 * TO LAST CHARACTER SCANNED 20770020 LR XINPUTB,XINPUT SET BACKUP REGISTER 20780020 */* R RETURN */ 20782021 BR LINK2 AND RETURN 20790020 SPACE 20800020 */*TURNOFF: D (,ILLADDR) BRANCH TO ILLADDR RTN */ 20802021 TURNOFF DS 0H * * * * 20810020 B ILLADDR BRANCH TO ILLADDR RTN 20820020 SPACE 20822020 * END OF INPUT HAS BEEN REACHED DURNING ADDRESS PARSE. CHECK FLAGS AND* 20824020 * BIT SETTINGS TO SEE IF ADDRESS IS CORRECT. IF ADDRESS IS COMPLETE * 20826020 * BRANCH TO END PROCESSING ROUTINE, IF NOT INVALID ADDRESS * 20828020 SPACE 20828420 */*CHECKEND: E CHECK FOR END OF INPUT */ 20828521 CHECKEND DS 0H * * * * 20828820 */* D (YES,ABCDE,NO,) END OF INPUT */ 20828921 C XINPUT,ENDINPUT END OF INPUT M4789 20829220 */* R RETURN AND CONTINUE PROCESSING */ 20829321 BL ZERO(LINK1) NO, CONTINUE M4789 20829620 SPACE 20829720 */*ABCDE: D (YES,TURNOFF,NO,) INVALID ADDRESS */ 20830721 LTR COUNTER,COUNTER YES CHECK SIZE OF ADDRESS M4789 20833321 BZ TURNOFF ZERO,INVALID ADDRESS M4789 20834321 * A + OR . WAS FOUND OR M4789 20835321 * A LOADNAME. OR ENTRY. M4789 20836321 * OR ADDRESS OF THE FORM M4789 20837321 * 7R%+ M4789 20838321 */* P SET ENDINPUT INDICATOR */ 20839121 OI PFLAGS,PFENDF SET ENDINPUT INDICATOR M4789 20839321 SPACE 20840321 */* D (YES,ENDPDE,NO,) PROCESSING EXPRESSION */ 20841021 TM PFLAGS,ADREXP PROCESSING EXPRESSION M4789 20841321 BO ENDPDE YES MOVE DATA IN PDE M4789 20842321 */* D (YES,RANGECK,NO,) WANT TO CHECK FOR RANGE */ 20842921 TM PFLAGS4,CKRANGE MAKE CHECK FOR RANGE M4789 20843321 BO RANGECK YES,BRANCH M4789 20844321 SPACE 20845321 */* D (YES,NOTABS,NO,) FLAG HAS BEEN SET FOR ANY CORRECT ADDR */ 20846221 TM DATAFLG,REG+RELADR+SYMADR+DPFPR+SPFPR IF THE FLAG M4789 20846321 * HAS BEEN SET FOR A REG M4789 20847321 * SYMBOLIC,RELATIVE OR M4789 20848321 * FLOATING POINT REG M4789 20849321 * ADDRESS,THE ADDRESS IS M4789 20850321 * CORRECT M4789 20851321 BNZ NOTABS YES, MOVE DATA IN PDE M4789 20852321 SPACE 20853321 */* D (YES,DELIMITR,NO,) PROCESSING ENTRYNAME */ 20853721 TM PFLAGS2,ENTRYBIT PROCESSING ENTRYNAME M5028 20854321 BO DILIMITR YES, MOVE IN PDE M5028 20855321 */* D (YES,,NO,CHKABS) FLTERBIT ON */ 20855721 TM PFLAGS2,FLTERBIT FLTERBIT ON M4789 20856321 BNO CHKABS NO CHECK FOR ABSOLUTE M4789 20857321 */* P TURN OFF FLTERBIT */ 20857721 NI PFLAGS2,HFF-FLTERBIT TURN OFF FILTER BIT M4789 20858321 */* P INDICATE MUST BE SYMBOLIC ADDRESS */ 20858721 MVI DATAFLG,SYMADR A SYMBOLIC ADDRESS M4789 20859321 */* D (,NOTABS) MOVE IN PDE */ 20859721 B NOTABS INDICATE AND NOVE IN PDE M4789 20860321 SPACE 20861321 */*CHKABS: D (,WHATISIT) CHECK IF VALID ADDRESS */ 20861721 CHKABS DS 0H * * * * 20862321 SPACE 20863320 CLI DATAFLG,ABSADR ABSOLUTE ADDRESS M5957 20865320 BE ABSADDR M5957 20867321 * A46773 20869821 BCT XINPUT,WHATISIT SEE IF VALID ADDRESS M4789 20872521 EJECT 20875021 *********************************************************************** 21890020 * * 21900020 * POSITIONAL USERID ROUTINE * 21910020 * * 21920020 *********************************************************************** 21930020 SPACE 21940020 */*USERID: P GET PDE SIZE */ 21942021 USERID DS 0H USERID ROUTINE 21950020 LA R1,FIFTEEN GET PDE SIZE-1 21960020 STC R1,PPCOUNT SAVE 21970020 */* S SKIPB: SKIP SEPARATORS */ 21972021 BAL LINK2,SKIPB SKIP SEPARATORS 21980020 * 21990020 */* D (YES,,NO,USIDPRQ) DATA IN BUFFER TO SCAN */ 21992021 B USIDPRQ +0 RETURN - NO DATA, TRY TO 22000020 * PROMPT OR DEFAULT 22010020 * 22020020 * +4 RETURN - DATA TO SCAN, XINPUT 22030020 * POINTS TO A SEPARATOR 22040020 * 22050020 */* S LISTT: TEST AND SET UP FOR LIST */ 22052021 BAL LINK1,LISTT TEST AND SET UP FOR LIST 22060020 * 22070020 */* D (YES,ILLUSID,NO,) INPUT ENDED AFTER ( WAS FOUND */ 22072021 B ILLUSID +0 RETURN - ERROR, INPUT ENDED 22080020 * AFTER LEFT PAREN WAS FOUND 22090020 * 22100020 * +4 RETURN - POSITIONED AT NEXT 22110020 * ITEM IN LIST IF LIST PRESENT 22120020 SPACE 22130020 * ENTRY POINT TO RESCAN NEW DATA FROM PROMPT OR DEFAULT 22140020 * 22150020 */*USIDRSC: P SAVE PTR FOR INVALID MSG */ 22152021 USIDRSC DS 0H * * * * 22160020 MVC INVPSAVE,PPOINTR SAVE PTR FOR INVALID MSG 22170020 MVC DATAPTR1,PPOINTR SAVE ID POINTER 22180020 */* P INDICATE PARAMETER PRESENT */ 22182021 OI DATAFLA1,PRESENT SET PARM-IS-PRESENT FLAG 22190020 * (CLEARED LATER IF MISSING) 22200020 LA R1,USIDCNTL GET ADDR OF GENSCAN CONTROL INFO 22210020 * FOR AN ID 22220020 ST R1,PDWORD SAVE FOR GENSCAN 22230020 L R15,AGENSCAN GET ADDRESS OF GENSCAN ROUTINE 22240020 */* P USE GENSCAN FOR SYNTAX CHECKING */ 22242021 BALR LINK2,R15 USE GENSCAN FOR SYNTAX CHECKING 22250020 * 22260020 */* D (YES,USIDPRQ,NO,) ID IS MISSING */ 22262021 BCT XINPUT,USIDPRQ +0 RETURN - ID IS MISSING, 22270020 * BACKUP AND TRY TO PROMPT OR 22280020 * DEFAULT 22290020 * 22300020 */* D (YES,ILLUSID,NO,) ID TOO LONG */ 22302021 B ILLUSID +4 RETURN - ILLEGAL ID, TOO LONG 22310020 * 22320020 */* D (YES,USIDEND,NO,) ID ENDED AT END OF INPUT */ 22322021 B USIDEND +8 RETURN - ID ENDED AT END OF 22330020 * CURRENT INPUT, SKIP DELIMITER 22340020 * CHECK 22350020 * 22360020 * +12 RETURN - GOOD, CHECK DELIM 22370020 * 22380020 */* P SAVE LENGTH OF ID */ 22382021 S XINPUTB,PPOINTR COMPUTE LENGTH OF ID 22390020 STH XINPUTB,DATALEN1 SAVE 22400020 STH XINPUTB,PLENGTH SET UP FOR TRANSQ 22410020 L R15,ATRANSQ GET ADDRESS OF EXTERNAL 22420020 * TRANSLATE ROUTINE 22430020 */* P TRANSLATE USERID TO UPPERCASE */ 22432021 BALR LINK1,R15 TRANSLATE USERID TO UPPERCASE 22440020 SPACE 22450020 */* D (YES,USIDPSWD,NO,) DELIMITER IS A SLASH */ 22452021 CLI ZERO(XINPUT),SLASH IS DELIMITER A SLASH 22460020 BE USIDPSWD YES, SCAN FOR PASSWORD 22470020 * 22480020 LA R1,SEPAR SET UP TO TEST IF DELIM 22490020 * IS A SEPARATOR 22500020 */* S TYPETEST: CHECK IF DELIMITER IS A SEPARATOR */ 22502021 BAL LINK1,TYPETEST USE TYPETEST 22510020 * 22520020 */* D (YES,USID02,NO,USID01) DELIMITER IS A SEPARATOR */ 22522021 B USID01 + 0 RETURN - NON-SEPARATOR, GO 22530020 * CHECK FOR VALID DELIMITER 22540020 * 22550020 B USID02 +4 RETURN - SEPARATOR, GO CHECK 22560020 * FOR POSSIBLE PASSWORD 22570020 */*USID01: S TYPETEST: CHECK FOR VALID DELIMITER */ 22572021 USID01 DS 0H 22580020 LA R1,NSEPDLIM SET UP TO TEST FOR DELIM 22590020 BAL LINK1,TYPETEST USE TYPETEST 22600020 */* D (YES,USIDXIT,NO,ILLUSID) VALID DELIMITER */ 22602021 B ILLUSID +0 RETURN - INVALID DELIMITER, 22610020 * THEN INVALID ID 22620020 B USIDXIT +4 RETURN - VALID DELIMITER,EXIT 22630020 */*USID02: S SKIPB: SKIP SEPARATORS TO SLASH */ 22632021 USID02 DS 0H 22640020 * 22650020 BAL LINK2,SKIPB SKIP SEPARATORS TO SLASH 22660020 * 22670020 */* D (YES,USIDXIT,NO,) REACHED END OF INPUT */ 22672021 B USIDXIT +0 RETURN - END OF INPUT, EXIT 22680020 * 22690020 * +4 RETURN - CONTINUE 22700020 * 22710020 */* D (YES,,NO,USIDXIT) NEXT CHARACTER IS A SLASH */ 22712021 LA XINPUT,ONE(XINPUT) GET NEXT CHARACTER 22720020 CLI ZERO(XINPUT),SLASH IS IT A SLASH 22730020 BNE USIDXIT NO, EXIT 22740020 * 22750020 */*USIDPSWD: S SKIPB: SKIP SEPARATORS TO PASSWORD */ 22752021 USIDPSWD DS 0H 22760020 BAL LINK2,SKIPB SKIP SEPARATORS TO PASSWORD 22770020 */* D (YES,,NO,PSWDPRQ) DATA TO SCAN */ 22772021 B PSWDPRQ +0 RETURN - END OF INPUT DO 22780020 * BYPASS PROMPT FOR PASSWORD 22790020 * 22800020 * +4 RETURN - DATA TO SCAN 22810020 * 22820020 * ENTRY POINT TO RESCAN NEW DATA FROM PROMPT FOR PASSWORD 22830020 * 22840020 */*UIDPSRSC: D (YES,,NO,UDPSRSC1) NULL LINE WAS ENTERED */ 22842021 UIDPSRSC DS 0H * * * * 22850020 TM PFLAGS3,PFNULL WAS A NULL LINE ENTERED 22860020 BZ UDPSRSC1 NO, CONTINUE 22870020 * 22880020 */* P TURN OFF NULL LINE FLAG */ 22882021 NI PFLAGS3,HFF-PFNULL YES-TURN OFF NULL LINE FLAG 22890020 */* P CLEAR PASSWORD DATA */ 22892021 XC DATAPTR2(SEVEN),DATAPTR2 CLEAR PASSWORD DATA 22900020 */* D (,UIDEXIT1) EXIT */ 22902021 B UIDEXIT1 EXIT 22910020 */*UDPSRSC1: P USE GENSCAN FOR SYNTAX CHECKING */ 22912021 UDPSRSC1 DS 0H 22920020 BAL LINK2,SKIPB GO TO SKIP BLANKS 1A45368 22922021 B PSWDPRQ +0 RETURN - PASSWORD IS MISSING 22924021 * GO TO PROMPT FOR PASSWORD IN 22926021 * - BYPASS MODE 1A45368 22928021 * +4 RETURN OK 1A45368 22928421 LA R1,PWSYNTAX GET ADDR OF GENSCAN CONTROL INFO 22930020 * FOR A PASSWORD 22940020 ST R1,PDWORD SAVE FOR GENSCAN 22950020 L R15,AGENSCAN GET ADDRESS OF GENSCAN ROUTINE 22960020 BALR LINK2,R15 USE GENSCAN FOR SYNTAX CHECKING 22970020 * 22980020 */* D (YES,PSWDPRQ,NO,) PASSWORD IS MISSING */ 22982021 BCT XINPUT,PSWDPRQ +0 RETURN - PASSWORD IS MISSING, 22990020 * DO BYPASS PROMPT 23000020 * 23010020 */* D (YES,ILLUIDPS,NO,) ILLEGAL PASSWORD */ 23012021 B ILLUIDPS +4 RETURN - ILLEGAL PASSWORD 23020020 * 23030020 */* D (YES,PSWDEND,NO,) END OF PARAMETER IS ALSO END OF INPUT */ 23032021 B PSWDEND +8 RETURN - GOOD, END OF PARM IS 23040020 * ALSO END OF INPUT 23050020 * 23060020 * +12 RETURN - GOOD, CHECK DELIM 23070020 * 23080020 */* S TYPETEST: CHECK FOR VALID DELIMITER */ 23082021 LA R1,DLIMREQD CHECK FOR VALID DELIMITER 23090020 BAL LINK1,TYPETEST * * * * 23100020 * 23110020 */* D (YES,,NO,ILLUIDPS) DELIMITER IS VALID */ 23112021 B ILLUIDPS +0 RETURN - DELIMITER IS BAD 23120020 * 23130020 * +4 RETURN - OK 23140020 * 23150020 * CONSTRUCT TEMPORARY PDE FOR PASSWORD PORTION OF ID 23160020 * 23170020 */*PSWDEND: P COMPUTE LENGTH OF PASSWORD */ 23172021 PSWDEND DS 0H * * * * 23180020 MVC DATAPTR2,PPOINTR SAVE PASSWORD POINTER 23190020 S XINPUTB,PPOINTR COMPUTE LENGTH 23200020 STH XINPUTB,DATALEN2 SAVE 23210020 STH XINPUTB,PLENGTH SET UP FOR TRANSLATE 23220020 L R15,ATRANSQ GET ADDRESS OF EXTERNAL 23230020 * TRANSLATE ROUTINE 23240020 */* P TRANSLATE PASSWORD TO UPPERCASE */ 23242021 BALR LINK1,R15 TRANSLATE PASSWORD TO UPPERCASE 23250020 */* P SET INDICATOR THAT PARM IS PRESENT */ 23252021 OI DATAFLA2,PRESENT SET PARM-IS-PRESENT FLAG 23260020 */*USIDXIT: P BACK UP SCAN POINTER */ 23262021 USIDXIT DS 0H * * * * 23270020 BCTR XINPUT,ZERO BACK UP SCAN POINTER FOR LATER 23280020 SPACE 23290020 */*UIDEXIT1: P INDICATE TO MOVE FOUR WORDS */ 23292021 UIDEXIT1 DS 0H $ $ $ $ 23300020 LA R1,FIFTEEN TELL EXIT ROUTINE TO MOVE FOUR 23310020 * WORDS 23320020 */* D (,POSITX) TAKE POSITIONAL EXIT */ 23322021 B POSITX TAKE POSITIONAL EXIT 23330020 SPACE 23340020 */*USIDEND: P SAVE LENGTH */ 23342021 USIDEND DS 0H * * * * 23350020 S XINPUTB,PPOINTR COMPUTE LENGTH 23360020 STH XINPUTB,DATALEN1 SAVE 23370020 STH XINPUTB,PLENGTH STORE LENGTH FOR TRANSLATION 23380020 L R15,ATRANSQ GET ADDR OF TRANSLATE ROUTINE 23390020 */* P TRANSLATE TO UPPERCASE */ 23392021 BALR LINK1,R15 LINK TO IT 23400020 SPACE 23410020 */* P INDICATE SCAN STARTED FOR SLASH */ 23412021 OI PFLAGS4,PFSLASH INDICATE SCAN STARTED FOR SLASH 23420020 */* S SCANF: TRY TO POP STACK */ 23422021 BAL LINK1,SCANF TRY TO POP STACK 23430020 SPACE 23440020 */* D (YES,,NO,USIDXIT) DATA RETURNED */ 23442021 B USIDXIT +0 RETURN - NO MORE DATA, EXIT 23450020 SPACE 23460020 * +4 RETURN - MORE DATA OR BLANK 23470020 SPACE 23480020 */* D (YES,USIDPSWD,NO,) NEXT CHARACTER IS A SLASH */ 23482021 LA XINPUT,ONE(XINPUT) BUMP UP PTR 23490020 CLI ZERO(XINPUT),SLASH IS NEXT CHARACTER A SLASH 23500020 BE USIDPSWD YES, PROCESS PASSWORD 23510020 */* S TYPETEST: CHECK IF NEXT CHARACTER IS A SEPARATOR */ 23512021 LA R1,SEPAR NO - IS THE NEXT CHARACTER 23520020 BAL LINK1,TYPETEST A SEPARATOR - USE TYPETEST 23530020 SPACE 23540020 */* D (YES,USID02,NO,USIDXIT) CHARACTER IS SEPARATOR */ 23542021 B USIDXIT +0 RETURN - NO, EXIT 23550020 * 23560020 B USID02 +4 RETURN - YES, GO SKIP BLANKS 23570020 * AND PROCESS POSSIBLE PASSWORD 23580020 SPACE 23590020 */*PSWDPRQ: P LOAD POINTER TO AND LENGTH OF USERID */ 23592021 PSWDPRQ DS 0H * * * * 23600020 TM PFLAGS5,INVPRMPT WAS PROMPTING DONE BEFORE A45352 23602021 * FOR THIS PARAETER? A45352 23602421 BO ILLUIDPS YES,ISSUE INVALID MESSAGE A45352 23604021 OI PFLAGS5,INVPRMPT NO, INDICATE FIRST PROMPT A45352 23606021 L R2,DATAPTR1 LOAD USERID POINTER 23610020 LH R1,DATALEN1 LOAD LENGTH OF USERID 23620020 LR R3,R1 SAVE DATA LENGTH 23630020 LA R1,FOUR(R3) GET SIZE OF CORE FOR MESSAGE SEG 23640020 * PLUS FOUR FOR HEADER 23650020 */* S GETCORE: GET CORE FOR MESSAGE SEGMENT */ 23652021 BAL LINK1,GETCORE GET CORE FOR MESSAGE SEGMENT 23660020 SPACE 23670020 * CORE ADDRESS RETURNED IN R1 23680020 */* P MOVE MESSAGE TEXT */ 23682021 ST R1,SEGLIST+TWELVE STORE ADDRESS IN LIST OF SEGMENT 23690020 LA R0,FOUR(R3) GET SIZE OF MESSAGE SEGMENT 23700020 STH R0,ZERO(R1) STORE INTO SEGMENT 23710020 MVI TWO(R1),ZERO SET FIRST BYTE OF OFFSET TO ZERO 23720020 MVI THREE(R1),OFFSET2 SET OFFSET INTO 'ENTER PASSWORD 23730020 * FOR' MESSAGE 23740020 BCTR R3,ZERO REDUCE LENGTH FOR 'EX' 23750020 LR R15,R2 LOAD START OF DATA ADDRESS 23760020 EX R3,BUILDSEG MOVE TEXT TO NEW SEGMENT 23770020 OI PFLAGS,PFBYPAS INDICATE BYPASS MODE REQUIRED 23780020 */* P INDICATE MESSAGE TO WRITE */ 23782021 MVI MSGCODE,MSG15 INDICATE MESSAGE TO WRITE 23790020 LA R0,TWO INDICATE 2 SEGMENT MSG 23800020 */* S WRITER2: ISSUE PROMPT MESSAGE */ 23802021 BAL LINK1,WRITER2G PROMPT IN BYPASS MODE 23810020 SPACE 23820021 B UIDPSRSC RESCAN NEW DATA 23830020 SPACE 23840020 */*USIDPRQ: S PROMPTQ: PROMPT OR DEFAULT */ 23842021 USIDPRQ DS 0H ID IS MISSING 23850020 NI DATAFLA1,HFF-PRESENT RESET USER ID PRESENT BIT A45368 23852021 * 23854021 BAL LINK1,PROMPTQ PROMPT OR DEFAULT 23860020 * 23870020 */* D (YES,USIDRSC,NO,UIDEXIT1) DATA RETURNED */ 23872021 B USIDRSC +0 RETURN - NEW DATA TO SCAN 23880020 * 23890020 * +4 RETURN - NO DATA RETURNED 23900020 * 23910020 B UIDEXIT1 EXIT 23920020 EJECT 23930020 *********************************************************************** 23932021 * * 23934021 * POSITIONAL DSNAME ROUTINE * 23936021 * * 23937221 *********************************************************************** 23940421 */*DSNAME: P GET PDE SIZE */ 23943621 DSNAME DS 0H DSNAME ROUTINE 23946821 LA R1,TWENTY3 GET PDE SIZE-1 23950020 STC R1,PPCOUNT SAVE 23960020 * (ALSO USED FOR DSTHING) 23970020 */* S SKIPB: SKIP SEPARATORS */ 23972021 BAL LINK2,SKIPB SKIP BLANKS TO BEGINNING OF PARM 23980020 SPACE 23990020 */* D (YES,DSNAMPRQ,NO,) END OF CURRENT INPUT */ 23992021 B DSNAMPRQ +0 RETURN, END OF CURRENT INPUT, 24000020 * TRY TO PROMPT OR DEFAULT FOR 24010020 * PARAMETER 24020020 SPACE 24030020 * +4 RETURN, OK 24040020 SPACE 24050020 */* S LISTT: TEST AND SET UP FOR LIST */ 24052021 BAL LINK1,LISTT TEST AND SET UP FOR LIST 24060020 SPACE 24070020 */* D (YES,ILLDSN,NO,) INPUT ENDED AFTER LEFT PAREN WAS FOUND */ 24072021 B ILLDSN +0 RETURN, INPUT ENDED AFTER 24080020 * LEFT PAREN WAS FOUND, INVALID 24090020 * PARM 24100020 SPACE 24110020 * +4 RETURN, OK 24120020 SPACE 24130020 * 24140020 * ENTRY FOR RESCANNING NEW DATA AFTER PROMPT OR DEFAULT 24150020 * 24160020 */*DSNAMRSC: D (YES,DSTHING1,NO,) PROCESSING DSTHING */ 24162021 DSNAMRSC DS 0H * * * * 24170020 MVC INVPSAVE,PPOINTR SAVE START OF PARM IN CASE IT IS 24180020 * INVALID 24190020 CLI PCEPOST(XPCE),(DSTHIB-POSITB)/FOUR PROCESSING DSTHING 24200020 BE DSTHING1 YES, SET UP FOR DSTHING 24210020 SPACE 24220020 */* P GET ADDR OF GENSCAN CONTROL INFO FOR DSNAME */ 24220421 LA R1,DSNCNTL GET ADDR OF GENSCAN CONTROL INFO 24230020 * FOR DSNAME 24240020 */* D (,DSN01) BRANCH */ 24242021 B DSN01 CONTINUE 24250020 SPACE 24260020 */*DSTHING1: P GET ADDR OF GENSCAN CONTROL INFO FOR DSTHING */ 24262021 DSTHING1 LA R1,DSTCNTL GET ADDR OF GENSCAN CONTROL INFO 24270020 * FOR DSTHING 24280020 SPACE 24290020 */*DSN01: P CLEAR FLAGS FOR DSNAME PROCESSING */ 24292021 DSN01 DS 0H * * * * 24300020 ST R1,PDWORD PUT ADDR OF GENSCAN CONTROL INFO 24310020 * IN PDWORD 24320020 NI RFLAGS,HFF-RFQDSNM-RFMEMB-RFNOTQ1 CLEAR FLAGS FOR 24330020 * DSNAME PROCESSING 24340020 LA XINPUT,ONE(XINPUT) GET NEXT CHARACTER (SKIPB HAS 24350020 * ALREADY CHECKED FOR END) 24360020 LR XINPUTB,XINPUT SET LAST CHARACTER SCANNED 24370020 */* D (YES,DSNQUOTE,NO,) FIRST CHARACTER IS A QUOTE */ 24372021 CLI ZERO(XINPUT),QUOTE IS FIRST CHARACTER A QUOTE? 24380020 BE DSNQUOTE YES, SET UP FOR QUOTED DSNAME 24390020 SPACE 24400020 */* D (YES,DSNMEMB,NO,) FIRST CHARACTER IS LEFT PAREN */ 24402021 CLI ZERO(XINPUT),LEFTPRN IS FIRST CHARACTER A LEFT PAREN 24410020 BE DSNMEMB YES, SET UP FOR MEMBER 24420020 SPACE 24430020 ST XINPUT,DATAPTR1 STORE PTR TO DSNAME 24440020 */* P INDICATE DSNAME IS PRESENT */ 24442021 OI DATAFLA1,PRESENT INDICATE DSNAME IS PRESENT 24450020 SPACE 24460020 */*DSNSCAN: P USE GENSCAN FOR SYNTAX CHECKING */ 24462021 DSNSCAN DS 0H * * * * 24470020 BCTR XINPUT,ZERO BACK UP INPUT FOR GENSCAN 24480020 L R15,AGENSCAN GET ADDRESS OF GENSCAN ROUTINE 24490020 BALR LINK2,R15 USE GENSCAN FOR SYNTAX CHECKING 24500020 * 24510020 * SCAN QUALIFIER OR MEMBER 24520020 * ACCORDING TO GENSCAN CONTROL 24530020 * INFO PREVIOUSLY SET UP 24540020 SPACE 24550020 */* D (YES,DSNMSNG,NO,) QUALIFIER OR MEMBER IS MISSING */ 24552021 BCT XINPUT,DSNMSNG +0 RETURN, QUALIFIER OR MEMBER 24560020 * IS MISSING 24570020 SPACE 24580020 */* D (YES,ILLDSN,NO,) QUALIFIER OR MEMBER IS ILLEGAL */ 24582021 B ILLDSN +4 RETURN, QUALIFIER OR MEMBER 24590020 * IS ILLEGAL 24600020 SPACE 24610020 */* D (YES,DSNEND,NO,) QUALIFIER OR MEMBER DELIMITED BY END OF INPUT */ 24612021 B DSNEND +8 RETURN, QUALIFIER OR MEMBER 24620020 * DELIMITED BY END OF 24630020 * CURRENT INPUT 24640020 SPACE 24650020 * +12 RETURN, GOOD CHECK DELIM 24660020 SPACE 24670020 */* D (YES,DSNMEMDL,NO,) PROCESSING MEMBER */ 24672021 TM RFLAGS,RFMEMB IS A MEMBER BEING PROCESSED 24680020 BO DSNMEMDL YES, GO CHECK MEMBER DELIMITER 24690020 SPACE 24700020 */* D (YES,,NO,DSN02) FIRST QUALIFIER BEING PROCESSED */ 24702021 TM RFLAGS,RFNOTQ1 IS THIS THE FIRST QUALIFIER 24710020 * BEING PROCESSED 24720020 BO DSN02 NO, CONTINUE 24730020 SPACE 24740020 */* P TURN ON NOT-FIRST-QUALIFIER INDICATOR */ 24742021 OI RFLAGS,RFNOTQ1 YES, TURN ON NOT-FIRST-QUALIFIER 24750020 * INDICATOR 24760020 SPACE 24770020 */*DSN02: D (YES,,NO,DSNENDNM) DELIMITER IS A PERIOD */ 24772021 DSN02 DS 0H * * * * 24780020 CLI ZERO(XINPUT),PERIOD IS DELIM A PERIOD 24790020 BNE DSNENDNM NO, GO PROCESS END OF DSNAME 24800020 SPACE 24810020 LA XINPUT,ONE(XINPUT) GET NEXT CHARACTER 24820020 LR XINPUTB,XINPUT SET LAST CHARACTER SCANNED 24830020 */* D (YES,ILLDSN,NO,DSNSCAN) END OF CURRENT INPUT */ 24832021 C XINPUT,ENDINPUT AT END OF CURRENT INPUT 24840020 BL DSNSCAN NO, SCAN FOR NEXT QUALIFIER 24850020 SPACE 24860020 B ILLDSN YES, INVALID (PERIOD CANNOT END 24870020 * A DSNAME) 24880020 SPACE 24890020 */*DSN025: D (YES,,NO,DSN03) QUOTED DSNAME BEING PROCESSED */ 24892021 DSN025 DS 0H * * * * 24900020 TM RFLAGS,RFQDSNM IS QUOTED DSNAME BEING PROCESSED 24910020 BZ DSN03 NO, CONTINUE 24920020 SPACE 24930020 */* D (YES,,NO,ILLDSN) CHARACTER A QUOTE */ 24932021 CLI ZERO(XINPUT),QUOTE YES, CHECK FOR QUOTE 24940020 BNE ILLDSN NOT A QUOTE, INVALID PARM 24950020 SPACE 24960020 LA XINPUT,ONE(XINPUT) QUOTE FOUND, GET NEXT CHARACTER 24970020 LR XINPUTB,XINPUT SET LAST CHARACTER SCANNED 24980020 */* D (YES,,NO,DSN03) END OF CURRENT INPUT */ 24982021 C XINPUT,ENDINPUT AT END OF CURRENT INPUT 24990020 BL DSN03 N0 - CONTINUE 25000020 */*DSN026: P INDICATE SCAN STARTED FOR SLASH */ 25002021 DSN026 DS 0H * * * * 25010020 OI PFLAGS4,PFSLASH INDICATE SCAN STARTED FOR SLASH 25020020 SPACE 25030020 */* S SCANF: TRY TO POP STACK */ 25032021 BAL LINK1,SCANF YES - TRY TO POP STACK 25040020 SPACE 25050020 */* D (YES,DSNEXIT,NO,) NO NEW DATA */ 25052021 B DSNEXIT +0 RETURN - NO NEW DATA, EXIT 25060020 * 25070020 * +4 RETURN - MORE DATA, CONTINUE 25080020 * 25090020 LA XINPUT,ONE(XINPUT) BUMP PTR 25100020 */* D (YES,DSNPS01,NO,) NEXT CHARACTER IS A SLASH */ 25102021 CLI ZERO(XINPUT),SLASH IS NEXT CHARACTER A SLASH 25110020 BE DSNPS01 YES, PROCESS PASSWORD 25120020 LA R1,SEPAR NO - IS NEXT CHARACTER A 25130020 */* S TYPETEST: CHECK IF CHARACTER IS SEPARATOR */ 25132021 BAL LINK1,TYPETEST SEPARATOR - USE TYPETEST 25140020 SPACE 25150020 */* D (YES,DSN04,NO,DSNEXIT) CHARACTER IS SEPARATOR */ 25152021 B DSNEXIT +0 RETURN - NO, EXIT 25160020 SPACE 25170020 B DSN04 +4 RETURN - YES, GO SKIP BLANKS 25180020 * AND PROCESS POSSIBLE PASSWORD 25190020 SPACE 25200020 */*DSN03: D (YES,DSNPSRSC,NO,) NEXT CHARACTER IS SLASH */ 25202021 DSN03 DS 0H * * * * 25210020 CLI ZERO(XINPUT),SLASH IS NEXT CHARACTER A SLASH 25220020 BE DSNPSRSC YES, SCAN FOR PASSWORD 25230020 LA R1,SEPAR NO, SEE IF DELIMITER IS A 25240020 * SEPARATOR 25250020 */* S TYPETEST: CHECK IF DELIMITER IS SEPARATOR */ 25252021 BAL LINK1,TYPETEST USE TYPETEST 25260020 */* D (YES,DSN04,NO,DSN031) VALID SEPARATOR */ 25262021 B DSN031 +0 RETURN_NON_SEPARATOR, CHECK 25270020 * FOR VALID DELIMITER 25280020 B DSN04 +4 RETURN- VALID SEPARATOR, SEE 25290020 * IF SLASH IS PRESENT 25300020 */*DSN031: S TYPETEST: CHECK FOR DELIMITER */ 25302021 DSN031 DS 0H * * * * 25310020 LA R1,NSEPDLIM SET UP TEST FOR DELIMITER 25320020 BAL LINK1,TYPETEST USE TYPETEST 25330020 */* D (YES,DSNEXIT,NO,ILLDSN) VALID DELIMITER */ 25332021 B ILLDSN +0 RETURN INVALID DELIMITER, 25340020 * DSNAME IS INVALID 25350020 B DSNEXIT +4 RETURN_ EXIT 25360020 SPACE 25370020 */*DSN04: S SKIPB: SKIP BLANKS TO SLASH */ 25372021 DSN04 DS 0H * * * * 25380020 BAL LINK2,SKIPB SKIP BLANKS TO SLASH 25390020 SPACE 25400020 */* D (YES,DSNEXIT1,NO,) REACHED END OF INPUT,SLASH MISSING */ 25402021 B DSNEXIT1 +0 RETURN, REACHED END OF INPUT 25410020 * SLASH MISSING, EXIT 25420020 * 25430020 * +4 RETURN, 0K 25440020 SPACE 25450020 LA XINPUT,ONE(XINPUT) GET NEXT CHARACTR (SKIPB HAS 25460020 * ALREADY CHECKED FOR END) 25470020 LR XINPUTB,XINPUT SET LAST CHARACTER SCANNED 25480020 */* D (YES,,NO,DSNEXIT) NEXT CHARACTER IS SLASH */ 25482021 CLI ZERO(XINPUT),SLASH IS CURRENT CHARACTER A SLASH 25490020 BNE DSNEXIT NO, SLASH MISSING, EXIT 25500020 SPACE 25510020 * 25520020 * ENTRY AFTER PROMPT FOR PASSWORD 25530020 * 25540020 */*DSNPSRSC: D (YES,,NO,DSNPS01) NULL LINE WAS ENTERED */ 25542021 DSNPSRSC DS 0H * * * * 25550020 TM PFLAGS3,PFNULL WAS A NULL LINE ENTERED 25560020 BZ DSNPS01 NO, CONTINUE 25570020 */* P TURN OFF NULL LINE FLAG */ 25572021 NI PFLAGS3,HFF-PFNULL YES, TURN OFF NULL LINE FLAG 25580020 */* P CLEAR PASSWORD DATA */ 25582021 XC DATAPTR3(SEVEN),DATAPTR3 CLEAR PASSWORD DATA 25590020 */* D (,DSNEXIT1) EXIT */ 25592021 B DSNEXIT1 EXIT DSNAME PROCESSING 25600020 */*DSNPS01: S SKIPB: SKIP BLANKS TO PASSWORD */ 25602021 DSNPS01 DS 0H * * * * 25610020 BAL LINK2,SKIPB SKIP BLANKS TO PASSWD 25620020 SPACE 25630020 */* D (YES,DSNAMPWQ,NO,) REACHED END OF INPUT,PASSWORD MISSING */ 25632021 B DSNAMPWQ +0 RETURN, REACHED END OF INPUT 25640020 SPACE 25650020 * PASSWD MISSING, SET UP FOR 25660020 * BYPASS PROMPT FOR PASSWORD 25670020 SPACE 25680020 * +4 RETURN, OK 25690020 SPACE 25700020 LA R1,PWSYNTAX GET ADDR OF CONTROL INFO FOR 25710020 ST R1,PDWORD GENSCAN, SAVE 25720020 L R15,AGENSCAN GET ADDRESS OF GENSCAN ROUTINE 25730020 */* P USE GENSCAN FOR SYNTAX CHECKING */ 25732021 BALR LINK2,R15 USE GENSCAN FOR SYNTAX CHECKING 25740020 * 25750020 * SCAN PASSW0RD 25760020 SPACE 25770020 */* D (YES,DSNAMPWQ,NO,) PASSWORD MISSING */ 25772021 BCT XINPUT,DSNAMPWQ +0 RETURN,MISSING, BACK UP, SET 25780020 * UP FOR BYPASS PROMPT 25790020 SPACE 25800020 */* D (YES,ILLDSNPS,NO,) INVALID PASSWORD */ 25802021 BCT XINPUT,ILLDSNPS +4 RETURN,TOO LONG, BACK UP 25810020 * INPUT, PASSWORD IS INVALID 25820020 SPACE 25830020 */* D (YES,DSNPWEND,NO,) DELIMITER IS END OF INPUT */ 25832021 B DSNPWEND +8 RETURN, DELIMITER IS END, 25840020 * SKIP DELIMITER TEST 25850020 SPACE 25860020 * +12 RETURN, CHECK DELIMITER 25870020 SPACE 25880020 */* S TYPETEST: TEST FOR VALID DELIMITER */ 25882021 LA R1,DLIMREQD TEST FOR VALID DELIMITER 25890020 BAL LINK1,TYPETEST USING TYPETEST 25900020 SPACE 25910020 */* D (YES,,NO,ILLDSNPS) VALID DELIMITER */ 25912021 B ILLDSNPS +0 RETURN, INVALID, PASSWORD IS 25920020 * INVALID 25930020 SPACE 25940020 * +4 RETURN, GOOD DELIM 25950020 SPACE 25960020 */*DSNPWEND: P INDICATE PASSWORD IS PRESENT */ 25962021 DSNPWEND DS 0H 25970020 MVC DATAPTR3(FOUR),PPOINTR STORE PTR TO PASSWORD IN 25980020 * DATA AREA 25990020 OI DATAFLA3,PRESENT INDICATE PASSWORD IS PRESENT 26000020 */* P COMPUTE LENGTH OF PASSWORD */ 26002021 S XINPUTB,PPOINTR COMPUTE LENGTH OF PASSWORD 26010020 STH XINPUTB,DATALEN3 STORE LENGTH IN DATA AREA 26020020 STH XINPUTB,PLENGTH SET UP FOR TRANSLATE 26030020 L R15,ATRANSQ GET ADDRESS OF TRANSLATE 26040020 * ROUTINE 26050020 */* P TRANSLATE TO UPPER CASE */ 26052021 BALR LINK1,R15 TRANSLATE TO UPPER CASE 26060020 */* D (,DSNEXIT) EXIT */ 26062021 B DSNEXIT EXIT 26070020 SPACE 26080020 */*DSNMEMDL: D (YES,,NO,ILLDSN) DELIMITER IS RIGHT PAREN */ 26082021 DSNMEMDL DS 0H CHECK MEMBER DELIMITER 26090020 CLI ZERO(XINPUT),RIGHTPRN IS DELIM A RIGHT PAREN 26100020 BNE ILLDSN NO, INVALID PARM 26110020 SPACE 26120020 */* P COMPUTE LENGTH OF MEMBER */ 26122021 S XINPUTB,DATAPTR2 COMPUTE LENGTH OF MEMBER 26130020 STH XINPUTB,DATALEN2 STORE IN DATA AREA 26140020 MVC PPOINTR(SIX),DATAPTR2 SET UP POINTERS FOR TRANSLATE 26150020 L R15,ATRANSQ GET ADDRESS OF TRANSLATE 26160020 * ROUTINE 26170020 */* P TRANSLATE TO UPPERCASE */ 26172021 BALR LINK1,R15 TRANSLATE TO UPPER CASE 26180020 LA XINPUT,ONE(XINPUT) GET NEXT CHARACTER 26190020 LR XINPUTB,XINPUT SET LAST CHARACTER SCANNED 26200020 */* D (YES,,NO,DSN025) REACHED END OF INPUT */ 26202021 C XINPUT,ENDINPUT AT END OF CURRENT INPUT 26210020 BL DSN025 NO, CHECK FOR QUOTE AS IN 26220020 * QUOTED DSNAME 26230020 SPACE 26240020 */* D (YES,ILLDSN,NO,DSN026) DSNAME IS QUOTED */ 26242021 TM RFLAGS,RFQDSNM IS DSNAME QUOTED 26250020 BO ILLDSN YES, INVALID PARM 26260020 SPACE 26270020 B DSN026 NO - TRY TO POP STACK 26280020 SPACE 26290020 */*DSNQUOTE: P INDICATE QUOTED DSNAME BEING PROCESSED */ 26292021 DSNQUOTE DS 0H SET UP FOR QUOTED DSNAME 26300020 OI RFLAGS,RFQDSNM INDICATE A QUOTED DSNAME IS 26310020 * BEING PROCESSED 26320020 LA XINPUT,ONE(XINPUT) GET NEXT CHARACTER 26330020 LR XINPUTB,XINPUT SET LAST CHARACTER SCANNED 26340020 */* D (YES,ILLDSN,NO,) REACHED END OF INPUT */ 26342021 C XINPUT,ENDINPUT AT END OF INPUT 26350020 BNL ILLDSN YES, ILLEGAL DSNAME 26360020 SPACE 26370020 */* P SET PTR TO DSNAME IN DATA AREA */ 26372021 ST XINPUT,PPOINTR SET PTR TO BEGINNING OF PARM 26380020 ST XINPUT,DATAPTR1 SET PTR TO DSNAME IN DATA AREA 26390020 */* P INDICATE QUOTED DSNAME IS PRESENT */ 26392021 OI DATAFLA1,QUOTED+PRESENT INDICATE DSNAME IS PRESENT AND 26400020 * QUOTED 26410020 */* D (,DSNSCAN) SCAN FOR DSNAME QUALIFIER */ 26412021 B DSNSCAN SCAN FOR DSNAME QUALIFIER 26420020 SPACE 26430020 */*DSNMEMB: P INDICATE PROCESSING MEMBER */ 26432021 DSNMEMB DS 0H SET UP FOR MEMBER 26440020 OI RFLAGS,RFMEMB INDICATE A MEMBER IS BEING 26450020 * PROCESSED 26460020 LA XINPUT,ONE(XINPUT) GET NEXT CHARACTER 26470020 LR XINPUTB,XINPUT SET LAST CHARACTER SCANNED 26480020 */* D (YES,ILLDSN,NO,) REACHED END OF INPUT */ 26482021 C XINPUT,ENDINPUT AT END OF INPUT 26490020 BNL ILLDSN YES, ILLEGAL DSNAME 26500020 SPACE 26510020 */* P SET PTR TO MEMBER NAME IN DATA AREA */ 26512021 ST XINPUT,DATAPTR2 SET PTR TO MEMBER NAME 26520020 * IN DATA AREA 26530020 */* P INDICATE MEMBER IS PRESENT */ 26532021 OI DATAFLA2,PRESENT INDICATE MEMBER IS PRESENT 26540020 */* P GET GENSCAN CONTROL INFO FOR MEMBER NAME */ 26542021 LA R1,MEMBCNTL PUT ADDR OF GENSCAN CONTROL INFO 26550020 ST R1,PDWORD FOR MEMBER NAME IN PDWORD 26560020 */* D (,DSNSCAN) SCAN FOR MEMBER NAME */ 26562021 B DSNSCAN SCAN FOR MEMBER NAME 26570020 SPACE 26580020 */*DSNMSNG: P ZERO TEMPORARY PDE */ 26582021 DSNMSNG DS 0H NEXT QUALIFIER OR MEMBER IS 26590020 * MISSING 26600020 XC TEMPPDE(LTPDE),TEMPPDE ZERO TEMPORARY PDE M2379 26602020 */* D (YES,DSNAMPRQ,NO,ILLDSN) PARM IS MISSING */ 26604021 TM RFLAGS,RFMEMB+RFQDSNM+RFNOTQ1 THE PARM IS MISSING ONLY 26610020 * 26620020 * NOTE- THE PARM IS MISSING ONLY IF THE FIRST QUALIFIER OF DSNAME 26630020 * IS BEING PROCESSED AND THE DSNAME IS NOT QUOTED. 26640020 * OTHERWISE, THE PARM IS INVALID. 26650020 * 26660020 BZ DSNAMPRQ PARM IS MISSING, PROMPT OR 26670020 * DEFAULT 26680020 SPACE 26690020 B ILLDSN PARM IS INVALID 26700020 SPACE 26710020 */*DSNEND: D (YES,ILLDSN,NO,) PROCESSING MEMBER OR QUOTED DSNAME */ 26712021 DSNEND DS 0H DELIMITER IS END OF INPUT 26720020 TM RFLAGS,RFMEMB+RFQDSNM IF MEMBER OR QUOTED DSNAME IS 26730020 BNZ ILLDSN BEING PROCESSED, THE PARM 26740020 * IS INVALID 26750020 SPACE 26760020 */*DSNENDNM: P COMPUTE LENGTH OF DSNAME */ 26762021 DSNENDNM DS 0H END OF DSNAME PROCESSING 26770020 S XINPUTB,DATAPTR1 COMPUTE LENGTH OF DSNAME 26780020 LA R14,DSNMAXLN GET MAX LENGTH OF DSNAME 26790020 */* D (YES,ILLDSN,NO,) LENGTH GREATER THAN MAX */ 26792021 CR XINPUTB,R14 IS LENGTH GREATER THAN 44 26800020 BH ILLDSN YES, PARM IS INVALID 26810020 SPACE 26820020 STH XINPUTB,DATALEN1 NO, SAVE LENGTH IN DATA AREA 26830020 MVC PPOINTR(SIX),DATAPTR1 SET UP POINTERS FOR TRANSLATE 26840020 L R15,ATRANSQ GET ADDRESS OF TRANSLATE ROUTINE 26850020 */* P TRANSLATE TO UPPER CASE */ 26852021 BALR LINK1,R15 TRANSLATE TO UPPER CASE 26860020 */* D (YES,DSN026,NO,) REACHED END OF INPUT */ 26862021 C XINPUT,ENDINPUT IS SCAN AT END OF INPUT 26870020 BNL DSN026 YES - TRY TO POP STACK 26880020 */* D (YES,DSNMEMB,NO,DSN025) CURRENT CHARACTER A LEFT PAREN */ 26882021 CLI ZERO(XINPUT),LEFTPRN IS CURRENT CHAR A LEFT PAREN 26890020 BE DSNMEMB YES, PROCESS MEMBER 26900020 B DSN025 NO, CONTINUE DSNAME PROCESSING 26910020 SPACE 26920020 */*DSNEXIT: P BACK UP SCAN PTR */ 26922021 DSNEXIT DS 0H DSNAME EXIT 26930020 BCTR XINPUT,ZERO BACK UP SCAN PTR FOR LATER 26940020 SPACE 26950020 */*DSNEXIT1: P INDICATE TO MOVE SIX WORDS */ 26952021 DSNEXIT1 DS 0H EXIT WHEN BACK UP IS UNNECESSARY 26960020 LA R1,TWENTY3 TELL EXIT ROUTINE TO MOVE SIX 26970020 * WORDS 26980020 */* D (,POSITX) TAKE POSITIONAL EXIT */ 26982021 B POSITX TAKE POSITIONAL EXIT 26990020 SPACE 27000020 */*DSNAMPRQ: S PROMPTQ: TYR TO PROMPT OR DEFAULT */ 27002021 DSNAMPRQ DS 0H PARM IS MISSING. 27010020 BAL LINK1,PROMPTQ TRY TO PROMPT OR DEFAULT 27020020 * IF ANY 27030020 * 27040020 */* D (YES,DSNAMRSC,NO,) DATA RETURNED */ 27042021 B DSNAMRSC +0 RETURN, NEW DATA, RESCAN IT 27050020 * 27060020 * +4 RETURN, NO DATA RETURNED 27070020 * 27080020 */* P CLEAR TEMPORARY PDE */ 27082021 XC TEMPPDE(LTPDE),TEMPPDE CLEAR TEMPORARY PDE 27090020 */* D (,DSNEXIT1) EXIT */ 27092021 B DSNEXIT1 EXIT 27100020 SPACE 27110020 */*DSNAMPWQ: P LOAD LENGTH OF DSNAME */ 27112021 DSNAMPWQ DS 0H * * * * 27120020 TM PFLAGS5,INVPRMPT WAS PROMPTING DONE BEFORE A45352 27122021 * FOR THIS PARAMETER? A45352 27124021 BO ILLDSNPS YES,ISSUE INVALID MESSAGE A45352 27126021 OI PFLAGS5,INVPRMPT NO, INDICATE FIRST PROMPT A45352 27128021 L R2,DATAPTR1 GET DSNAME POINTER 27130020 LH R1,DATALEN1 LOAD LENGTH OF DSNAME 27140020 */* D (YES,DSNAMPWR,NO,) SEE IF SPECIFIED */ 27142021 LTR R2,R2 SEE IF SPECIFIED 27150020 BNZ DSNAMPWR YES, GOOD 27160020 SPACE 27170020 */* P LOAD MEMBER NAME PTR AND LENGTH */ 27172021 L R2,DATAPTR2 LOAD MEMBER NAME POINTER 27180020 LH R1,DATALEN2 LOAD LENGTH OF MEMBER NAME 27190020 SPACE 27200020 */*DSNAMPWR: S GETCORE: GET CORE FOR MESSAGE */ 27202021 DSNAMPWR DS 0H * * * * 27210020 LR R3,R1 SAVE DATA LENGTH 27220020 LA R1,FOUR(R3) GET SIZE OF CORE FOR MESSAGE SEG 27230020 * PLUS FOUR FOR HEADER 27240020 BAL LINK1,GETCORE GET CORE FOR MESSAGE SEGMENT 27250020 SPACE 27260020 * CORE ADDRESS RETURNED IN R1 27270020 ST R1,SEGLIST+TWELVE STORE ADDRESS IN LIST OF SEGMENT 27280020 LA R0,FOUR(R3) GET SIZE OF MESSAGE SEGMENT 27290020 STH R0,ZERO(R1) STORE INTO SEGMENT 27300020 MVI TWO(R1),ZERO SET FIRST BYTE OF OFFSET TO ZERO 27310020 MVI THREE(R1),OFFSET2 SET OFFSET INTO 'ENTER PASSWORD 27320020 * FOR' MESSAGE 27330020 BCTR R3,ZERO REDUCE LENGTH FOR 'EX' 27340020 LR R15,R2 LOAD START OF DATA ADDRESS 27350020 */* P MOVE MESSAGE TEXT TO SEGMENT */ 27352021 EX R3,BUILDSEG MOVE TEXT TO NEW SEGMENT 27360020 OI PFLAGS,PFBYPAS INDICATE BYPASS MODE REQUIRED 27370020 */* P INDICATE MESSAGE TO WRITE */ 27372021 MVI MSGCODE,MSG15 INDICATE MESSAGE TO WRITE 27380020 LA R0,TWO INDICATE TWO SEGMENT MSG 27390020 */* S WRITER2: PROMPT */ 27392021 BAL LINK1,WRITER2G PROMPT IN BYPASS MODE 27400020 SPACE 27410020 */* D (,DSNPSRSC) PROCESS PROMPT DATA */ 27412021 B DSNPSRSC PROCESS PROMPT DATA 27420020 EJECT 27430020 *********************************************************************** 27440020 * * 27450020 * POSITIONAL QUOTED STRING ROUTINE * 27460020 * * 27470020 *********************************************************************** 27480020 */*QSTRING: S SKIPB: SKIP SEPARATORS */ 27482021 SPACE 27490020 QSTRING DS 0H QSTRING ROUTINE 27500020 BAL LINK2,SKIPB SKIP BLANKS TO BEGINNING OF PARM 27510020 * 27520020 */* D (YES,QSTRPRQ1,NO,) REACHED END OF INPUT */ 27522021 B QSTRPRQ1 +0 RETURN - END OF INPUT REACHED 27530020 * PARM IS MISSING 27540020 * 27550020 * +4 RETURN - BEGINNING OF PARM 27560020 * IS ESTABLISHED 27570020 * 27580020 * ENTRY TO RESCAN NEW DATA FROM PROMPT OR DEFAULT 27590020 * 27600020 */*QSTRIRSC: P SAVE PTR FOR INVALID MSG */ 27602021 QSTRIRSC DS 0H * * * * 27610020 MVC INVPSAVE,PPOINTR SAVE PTR FOR INVALID MSG 27620020 */* P INCREMENT SCAN POINTER */ 27622021 LA XINPUT,ONE(XINPUT) INCREMENT SCAN REGISTER (SKIPB 27630020 * HAS ALREADY SET XINPUTB AND 27640020 * CHECKED FOR END OF INPUT) 27650020 SPACE 27660020 * 27670020 * COMMON CODE FOR PARSING QSTRING AND VALUE STRING 27680020 * 27690020 */*VALENTRY: D (YES,QSTR01,NO,) FIRST CHARACTER IS A QUOTE */ 27692021 VALENTRY DS 0H * * * * 27700020 CLI ZERO(XINPUT),QUOTE IS FIRST CHARACTER A QUOTE 27710020 BE QSTR01 YES - CONTINUE 27720020 */* D (YES,VALUPRQX,NO,QSTRPRQ) A VALUE IS BEING PROCESSED */ 27722021 SPACE 27730020 CLI PCEPOST(XPCE),(VALUEB-POSITB)/FOUR IS A VALUE BEING 27740020 * PROCESSED 27750020 BNE QSTRPRQ NO - PROMPT FOR A QSTRING 27760020 SPACE 27770020 BCT XINPUT,VALUPRQX YES - BAKUP AND PROMPT FOR VALUE 27780020 SPACE 27790020 QSTR01 DS 0H * * * * 27800020 */*QSTR01: P STORE ADDRESS OF NEXT CHARACTER AS POINTER TO STRING */ 27802021 LA R2,ONE(XINPUT) STORE ADDRESS OF NEXT CHARACTER 27810020 ST R2,PPOINTR AS POINTER TO STRING 27820020 */*QSTRLOOP: D (YES,QSMSGEND,NO,) AT END OF CURRENT LEVEL OF INPUT */ 27822021 QSTRLOOP DS 0H 27830020 SPACE 27840020 LA XINPUT,ONE(XINPUT) INCREMENT SCAN TO NEXT CHARACTER 27850020 LR XINPUTB,XINPUT SET LAST CHARACTER SCANNED REG 27860020 C XINPUT,ENDINPUT IS SCAN AT END OF CURRENT LEVEL 27870020 * OF INPUT 27880020 BNL QSMSGEND YES, BRANCH TO ISSUE MSG AND 27890020 * PROCESS END 27900020 */* D (YES,,NO,QSTRLOOP) CURRENT CHARACTER IS A QUOTE */ 27902021 CLI ZERO(XINPUT),QUOTE IS CURRENT CHARACTER A QUOTE 27910020 BNE QSTRLOOP NO, BRANCH TO SCAN NEXT CHAR 27920020 * 27930020 LA XINPUT,ONE(XINPUT) INCREMENT SCAN TO NEXT CHARACTER 27940020 LR XINPUTB,XINPUT SET LAST CHARACTER SCANNED 27950020 */* D (YES,QSTREND,NO,) NEXT CHARACTER IS AT END OF INPUT */ 27952021 C XINPUT,ENDINPUT IS SCAN AT END OF CURRENT LEVEL 27960020 * OF INPUT 27970020 BNL QSTREND YES, BRANCH TO PROCESS END 27980020 */* D (YES,,NO,QNORMEND) CURRENT CHARACTER IS A QUOTE */ 27982021 SPACE 27990020 CLI ZERO(XINPUT),QUOTE IS CURRENT CHARACTER A QUOTE 28000020 BNE QNORMEND NO, BRANCH TO PROCESS END 28010020 */* D (NO,POSITQS,YES,) PROCESSING COBOL PCE'S? */ 28010121 TM CBFLAGS1,COBOLMOD ARE WE PROCESSING COBOL F41448 28010421 * PCE'S? F41448 28010821 BZ POSITQS IF NOT, CONTINUE NORMALLY F41448 28011221 */* P LOAD RETURN ADDRESS IN IKJPARS2 */ 28011321 */* E () EXIT TO IKJPARS2 */ 28011421 L LINK2,CBLNKSV2 IF IN COBOL MODE, RETURN F41448 28011621 BR LINK2 COBOL PROCESSORS F41448 28011721 */*POSITQS: D (YES,QSTRLOOP,NO,) A VALUE IS BEING PROCESSED */ 28012000 SPACE 28020020 POSITQS CLI PCEPOST(XPCE),(VALUEB-POSITB)/FOUR IS A VALUE BEING 28030021 * PROCESSED 28040020 BE QSTRLOOP YES - DO NOT REMOVE SECOND QUOTE 28050020 SPACE 28060020 * 28070020 * REMOVE SECOND QUOTE FROM BUFFER 28080020 * 28090020 */* P REMOVE SECOND QUOTE FROM BUFFER */ 28092021 L R2,ENDINPUT COPY END OF INPUT ADDR 28100020 SR R2,XINPUT COMPUTE LENGTH OF REMAINING 28110020 * DATA IN CURRENT LEVEL OF 28120020 * INPUT 28130020 MOVIT DS 0H 28142021 BCTR R2,ZERO SUBTRACT ONE FOR EXECUTE INSTR. 28142421 LA R3,HFF SET WORK REGISTER TO 255 S21105 28144021 NR R3,R2 GET TRUE LENGTH TO MOVE S21105 28146021 EX R3,QSTRMVC REMOVE SECOND QUOTE BY SHIFTING 28150021 * REMAINDER OF BUFFER ONE TO 28160020 * THE LEFT S21105 28170021 LA XINPUT,ONE(R3,XINPUT) INCREMENT SCAN POINTER S21105 28172021 XR R2,R3 MORE IN BUFFER TO MOVE S21105 28174021 BNZ MOVIT YES, CALCULATE HOW MUCH S21105 28176021 BCTR XINPUT,ZERO COMPUTE ADDR OF LAST BYTE OF 28180021 * BUFFER S21105 28190021 MVI ZERO(XINPUT),BLNK REPLACE WITH A BLANK 28200021 LR XINPUT,XINPUTB RESET XINPUT S21105 28202021 BCT XINPUT,QSTRLOOP BACK UP XINPUT TO 28210020 * ACCOUNT FOR REMOVAL 28220020 * OF THE QUOTE AND BRANCH 28230020 * TO SCAN NEXT CHAR 28240020 */* P ACCOUNT FOR REMOVAL OF QUOTE */ 28242021 */* D (,QSTRLOOP) SCAN NEXT CHARACTER */ 28244021 SPACE 28250020 * 28260020 * PROCESS END 28270020 * 28280020 */*QNORMEND: D (YES,QSTREND1,NO,) PROCESSING COBOL PCE'S? */ 28280421 */* D (YES,,NO,QSTREND1) A VALUE IS BEING PROCESSED */ 28282021 QNORMEND DS 0H * * * * 28290020 TM CBFLAGS1,COBOLMOD PROCESSING COBOL PCE'S? F41448 28292021 BO QSTREND1 IF YES, BRANCH AROUND F41448 28294021 * CHECKS F41448 28296021 CLI PCEPOST(XPCE),(VALUEB-POSITB)/FOUR IS A VALUE BEING 28300020 * PROCESSED 28310020 BNE QSTREND1 NO - QSTRING, EXIT 28320020 */* S RANGE: CHECK FOR POSSIBLE RANGE */ 28322021 BAL LINK1,RANGE CHECK FOR RANGE 28330020 */* D (YES,QSTREND1,NO,) EITHER RANGE NOT ALLOWED,RANGE NOT PRESENT, OR 28332021 */* 2ND VALUE OF RANGE */ 28334021 B QSTREND1 +0 RETURN - RANGE NOT ALLOWED OR 28340020 * RANGE NOT PRESENT OR 28350020 * 2ND VALUE OF RANGE 28360020 */* P SET UP ADDRESS FOR SCAN OF 2ND VALUE */ 28362021 LA LINK2,VAL2RSC SET UP ADDR FOR SCAN OF 2ND VALU 28370020 */* D (YES,QSTREND1) PROCESS END */ 28372021 B QSTREND1 PROCESS END 28380020 */*QSTREND: D (YES,,NO,QSTREND1) FIRST VALUE OF RANGE WAS ENTERED */ 28382021 SPACE 28390020 SPACE 28400020 QSTREND DS 0H * * * * 28410020 */* D (YES,QSTREND1,NO,) PROCESSING COBOL PCE'S? */ 28410121 */* COMMENT (1,15) BYPASS RANGE CHECK */ 28410221 TM CBFLAGS1,COBOLMOD PROCESSING COBOL PCE'S? F41448 28410421 BO QSTREND1 YES - BYPASS RANGE CHECK F41448 28410821 */* P TURN OFF 1ST VALUE FLAG AND TURN ON 2ND VALUE FLAG */ 28412021 TM PFLAGS2,RNGEVAL1 WAS 1ST VALUE OF RANGE ENTERED 28420020 BZ QSTREND1 NO, CONTINUE 28430020 NI PFLAGS2,HFF-RNGEVAL1 YES, TURN OFF 1ST VALUE FLAG 28440020 OI PFLAGS2,RNGEVAL2 TURN ON 2ND VALUE FLAG 28450020 */*QSTREND1: P COMPUTE AND SAVE LENGTH OF STRING EXCLUDING END QUOTE */ 28452021 QSTREND1 DS 0H * * * * 28460020 BCTR XINPUTB,ZERO BACKUP TO EXCLUDE END QUOTE FROM 28470020 * LENGTH 28480020 S XINPUTB,PPOINTR COMPUTE LENGTH 28490020 STH XINPUTB,PLENGTH SAVE 28500020 */* D (NO,QSTEXIT,YES,) PROCESSING COBOL PCE'S? */ 28500121 TM CBFLAGS1,COBOLMOD PROCESSING COBOL PCE'S F41448 28500421 BZ QSTEXIT NO -CONTINUE NORMAL PARSE F41448 28500821 */*CBLRETQS: P LOAD RETURN ADDRESS INTO IKJPARS2 */ 28500921 */* R () RETURN TO IKJPARS2 ON +4 */ 28501021 CBLRETQS L LINK2,CBLNKSV2 LOAD RETURN REG FROM F41448 28501221 * COBOL SAVE AREA F41448 28501621 B FOUR(LINK2) RETURN +4 F41448 28501721 */*QSTEXIT: D (,POSITX1) EXIT */ 28502000 QSTEXIT BCT XINPUT,POSITX1 EXIT 28510021 SPACE 28520020 * 28530020 * TRY TO PROMPT OR DEFAULT FOR MISSING QSTRING 28540020 * 28550020 */*QSTRPRQ: P PREPARE FOR PROMPT/DEFAULT */ 28552021 QSTRPRQ DS 0H NORMAL ENTRY 28560020 BCTR XINPUT,ZERO BACK UP SCAN POINTR 28570020 * 28580020 */*QSTRPRQ1: S PROMPTQ: TEST FOR PROMPT/DEFAULT DATA */ 28582021 QSTRPRQ1 DS 0H ENTRY AFTER SKIPB 28590020 BAL LINK1,PROMPTQ TEST FOR PROMPT OR DEFAULT 28600020 * 28610020 */* D (YES,QSTRIRSC,NO,POSITX2) NEW DATA RETURN */ 28612021 B QSTRIRSC +0 RETURN - RESCAN NEW DATA 28620020 * 28630020 B POSITX2 +4 RETURN - NO DATA, TAKE NULL 28640020 * PDE EXIT 28650020 SPACE 28660020 * 28670020 * ISSUE 'ENDING QUOTE ASSUMED' MESSAGE AND TREAT AS IF ENTERED. 28680020 * 28690020 QSMSGEND DS 0H * * * * 28700020 */*QSMSGEND: P COMPUTE AND SAVE LENGTH OF STRING */ 28702021 S XINPUTB,PPOINTR COMPUTE LENGTH 28710020 STH XINPUTB,PLENGTH SAVE LENGTH 28720020 LA R1,SIX(XINPUTB) GET SIZE OF CORE FOR MESSAGE SEG 28730020 * PLUS HEADER, LEFT QUOTE AND 28740020 * POSSIBLE TYPE-CHARACTER 28750020 */* S GETCORE: GET CORE FOR MESSAGE SEGMENT */ 28752021 BAL LINK1,GETCORE GET CORE FOR MESSAGE SEGMENT 28760020 SPACE 28770020 * CORE ADDRESS RETURNED IN R1 28780020 ST R1,SEGLIST+TWELVE STORE ADDRESS IN LIST OF SEGMENT 28790020 LA R0,SIX(XINPUTB) GET SIZE OF MESSAGE SEGMENT 28800020 STH R0,ZERO(R1) STORE INTO SEGMENT 28810020 MVI TWO(R1),ZERO SET FIRST BYTE OF OFFSET TO ZERO 28820020 MVI THREE(R1),OFFSET5 SET OFFSET TO LENGTH OF 'END 28830020 * QUOTE ASSUMED' MESSAGE 28840020 L R15,PPOINTR LOAD START OF DATA ADDRESS 28850020 BCTR R15,ZERO INCLUDE BEGINNING QUOTE IN 28860020 * SECOND SEGMENT 28870020 */* D (YES,QSMSG01,NO,) PROCESSING COBOL PCE'S? */ 28870121 */* COMMENT (1,15) CONTINUE MESSGE */ 28870221 */* COMMENT (2,15) BUILD */ 28870321 TM CBFLAGS1,COBOLMOD PROCESSING COBOL PCE'S? F41448 28870421 BO QSMSG01 YES-CONTINUE MESSAGEBUILD F41448 28870821 */* D (YES,,NO,QSMSG01) A VALUE IS BEING PROCESSED */ 28872021 CLI PCEPOST(XPCE),(VALUEB-POSITB)/FOUR IS A VALUE BEING 28880020 * PROCESSED 28890020 BNE QSMSG01 IF NO CONTINUE 28900020 */* P ALLOW FOR TYPE CHARACTER IN MESSAGE */ 28902021 SPACE 28910020 BCTR R15,ZERO IF YES INCLUDE TYPE-CHARACTER 28920020 * IN MESSAGE 28930020 LA XINPUTB,ONE(XINPUTB) INCLUDE TYPE-CHARACTER IN LENGTH 28940020 */*QSMSG01: P INDICATE 'ENDING QUOTE ASSUMED' MESSAGE */ 28942021 SPACE 28950020 QSMSG01 DS 0H * * * * 28960020 LA R14,FIVE(XINPUTB,R1) GET ADDRESS OF POSSIBLE EXTRA 28970020 * BUFFER CHARACTER 28980020 MVI ZERO(R14),BLNK BLANK IT OUT 28990020 EX XINPUTB,BUILDSEG MOVE TEXT TO NEW SEGMENT 29000020 MVI MSGCODE,MSG7 INDICATE MESSAGE TO WRITE 29010020 */* S WRITER1: WRITE THE MESSAGE */ 29012021 BAL LINK1,WRITER1 WRITE THE MESSAGE 29020020 */* D (YES,CBLRETQS,NO,) PROCESSING COBOL PCE'S? */ 29020121 */* COMMENT (1,15) RETURN TO */ 29020221 */* COMMENT (2,15) IKJPARS2 */ 29020321 TM CBFLAGS1,COBOLMOD PROCESSING COBOL PCE'S? F41448 29020421 BO CBLRETQS YES - RETURN TO THE F41448 29020821 * COBOL MACRO PROCESSORS F41448 29021221 */* D (YES,,NO,POSITX1) FIRST VALUE OF RANGE WAS ENTERED */ 29022021 SPACE 29030020 TM PFLAGS2,RNGEVAL1 WAS 1ST VALUE OF RANGE ENTERED 29040020 BZ POSITX1 NO, CONTINUE 29050020 */* P TURN OFF FIRST VALUE FLAG AND TURN ON SECOND VALUE FLAG */ 29052021 SPACE 29060020 NI PFLAGS2,HFF-RNGEVAL1 YES, TURN OFF VALUE 1 FLAG 29070020 OI PFLAGS2,RNGEVAL2 TURN ON VALUE 2 FLAG 29080020 */* D (,POSITX1) BRANCH TO EXIT */ 29082021 B POSITX1 BRANCH TO POSITIONAL EXIT RTN. 29090020 EJECT 29100020 *********************************************************************** 29110020 * * 29120020 * POSITIONAL SPACE ROUTINE * 29130020 * * 29140020 * THIS POSITIONAL PARAMETER IS INTENDED TO BE FOLLOWED BY A * 29150020 * POSITIONAL SELF-DELIMITING STRING PARAMETER. THE TSO EDIT COMMAND * 29160020 * PROCESSOR IS THE SOLE USER OF THIS FUNCTION. NO OPTIONS ARE * 29170020 * AVAILABLE WITH THE SPACE PARAMETER. ALSO EDIT DOES NOT SUPPLY ANY * 29180020 * OPTIONS WITH THE FOLLOWING STRING PARAMETER. * 29190020 * SINCE THE COMMAND NAME HAS BEEN PREVIOUSLY DELIMITED BY A BLANK, * 29200020 * COMMA OR TAB CHARACTER THE SPACE PARAMETER DOES EXIST (NO ERROR * 29210020 * CONDITION POSSIBLE). IF THE DELIMITER IS A TAB, THE TAB IS TO BE * 29220020 * THE FIRST CHARACTER OF THE FOLLOWING STRING. THE END OF THE STRING * 29230020 * IS DELIMITED BY THE END OF THE BUFFER. * 29240020 * * 29250020 *********************************************************************** 29260020 */*SPACE: P INDICATE SPACE/STRING SEQUENCE FOR STRING RTN */ 29262021 SPACE 29270020 SPACE DS 0H SPACE ROUTINE 29280020 OI PFLAGS3,PFSPACE INDICATE THIS IS A SPACE/STRING 29290020 * SEQUENCE FOR STRING ROUTINE 29300020 LA XINPUT,ONE(XINPUT) INCREMENT SCAN POINTER 29310020 */* D (YES,,NO,POSITX3) NEXT CHARACTER IS A TAB */ 29312021 CLI ZERO(XINPUT),TABCHAR IS NEXT CHARACTER A TAB 29320020 BNE POSITX3 IF NO BRANCH 29330020 */* D (,POSITX3) USE TAB CHARACTER AS FIRST CHARACTER OF STRING AND 29332021 */*EXIT */ 29334021 SPACE 29340020 BCT XINPUT,POSITX3 USE TAB CHARACTER AS FIRST 29350020 * CHARACTER OF STRING 29360020 EJECT 29370020 *********************************************************************** 29380020 * * 29390020 * POSITIONAL PDE ERASE ROUTINE * 29400020 * * 29410020 * THIS ROUTINE DETERMINES THE LENGTH OF THE PDE TO BE ERASED AND * 29420020 * THEN PROCEEDS TO ZERO IT OUT (ERASE). * 29430020 * ERASE MODE IS ENTERED BY SETTING THE RFERASE FLAG IN THE RECURSIVE* 29440020 * WORKSPACE AREA (RFLAGS). ITS SET TO INDICATE THAT A DUPLICATE * 29450020 * KEYWORD PARAMETER HAS BEEN FOUND IN THE INPUT BUFFER AND THE * 29460020 * PREVIOUS KEYWORD AND ASSOCIATED SUBFIELD, IF ANY, MUST BE ERASED * 29470020 * AND REPLACED WITH NEW DATA. * 29480020 * THE ROUTINE IS ENTERED FROM THE POSIT AND IDENT ROUTINES. * 29490020 * ENTRY - R2 POSITIONAL TYPE CODE * 29500020 * * 29510020 *********************************************************************** 29520020 */*POSITERS: P STORE TYPE CODE */ 29522021 SPACE 29530020 POSITERS DS 0H POSITIONAL PDE ERASE ROUTINE 29540020 STC R2,PDWORD STORE MASSAGED TYPE CODE 29550020 LA R2,TWENTY3 LOAD LENGTH-1 OF DSNAME AND 29560020 * DSTHING PDE 29570020 */* D (YES,POSITER1,NO,) PDE IS 6 WORDS LONG(DSNAME) */ 29572021 */* D (YES,POSITER1,NO,) PDE IS 6 WORDS LONG(DSTHING) */ 29574021 CLI PDWORD,(DSNAMB-POSITB) IS PDE 6 WORDS LONG - DSNAME 29580020 BE POSITER1 YES --- BRANCH 29590020 SPACE 29600020 CLI PDWORD,(DSTHIB-POSITB) IS PDE 6 WORDS LONG - DSTHING 29610020 BE POSITER1 YES --- BRANCH 29620020 SPACE 29630020 LA R2,THIRTY5 LOAD LENGTH-1 OF ADDRESS PDE 29640020 CLI PDWORD,(ADDRB-POSITB) IS PDE 9 WORDS LONG - ADDRESS 29650020 BE POSITER1 YES --- BRANCH 29660020 SPACE 29670020 LA R2,FIFTEEN LOAD LENGTH-1 OF USERID PDE 29680020 CLI PDWORD,(USIDB-POSITB) IS PDE 4 WORDS LONG 29690020 BE POSITER1 YES --- BRANCH 29700020 SPACE 29710020 * 29720020 * IT MUST BE A TWO WORD PDE BEING ERASED. 29730020 * 29740020 */*IDENTERS: P ERASE 2 WORD PDE(IDENT) */ 29742021 IDENTERS DS 0H ENTRY FOR ERASING AN IDENT PDE 29750020 LA R2,SEVEN LOAD LENGTH OF REMAINING PDES OR 29760020 * LENGTH OF IDENT PDE 29770020 */*POSITER1: D (YES,,NO,POSITER2) RANGE IS ALLOWED */ 29772021 SPACE 29780020 POSITER1 DS 0H * * * * 29790020 TM PCEFLGB2(XPCE),PCEFRNGE IS A RANGE ALLOWED 29800020 BZ POSITER2 IF NO BRANCH 29810020 */* P DOUBLE SIZE OF PDE TO ERASE */ 29812021 SPACE 29820020 LA R2,ONE(R2,R2) IF YES DOUBLE THE SIZE OF PDE 29830020 * TO ERASE 29840020 */*POSITER2: P GET TRUE ADDRESS OF PDE */ 29842021 SPACE 29850020 POSITER2 DS 0H * * * * 29860020 MVC PDWORD(TWO),PCEPDEO(XPCE) ALIGN THE PDE OFFSET ON PROPER 29870020 * BOUNDARY 29880020 LH R3,PDWORD LOAD THE PDE OFFSET 29890020 A R3,XPDL GET TRUE ADDRESS OF PDE 29900020 */* P EXECUTE INSTRUCTION TO ERASE OLD INFORMATION FROM PDE */ 29902021 EX R2,ERASEXC ERASE OLD INFORMATION FROM PDE 29910020 */* D (YES,,NO,POSITX3) LIST IS ALLOWED */ 29912021 TM PCEFLGB2(XPCE),PCEFLIST IS A LIST ALLOWED 29920020 BZ POSITX3 NO ERASE COMPLETE --- BRANCH 29930020 SPACE 29940020 AR R2,R3 GET PTR TO LIST CHAIN -1 29950020 */* P INDICATE NO LIST PRESENT */ 29952021 MVC ONE(L'ENDCHAIN,R2),ENDCHAIN INDICATE NO LIST PRESENT 29960020 */* D (,POSITX3) EXIT */ 29962021 B POSITX3 ERASE COMPLETE --- BRANCH 29970020 EJECT 29980020 *********************************************************************** 29990020 * * 30000020 * POSITIONAL EXIT ROUTINE * 30010020 * * 30020020 * THIS ROUTINE IS ENTERED BY THE IKJPOSIT AND IKJIDENT PARAMETER * 30030020 * ROUTINES AT THE CONCLUSION OF THEIR PROCESSING. THE PDE IS FILLED * 30040020 * IN, A VALIDITY CHECK EXIT IS TAKEN AND THE NEXT PCE ADDRESS IS * 30050020 * CALCULATED. * 30060020 * * 30070020 *********************************************************************** 30080020 SPACE 30090020 */*POSITX2: P INDICATE NULL DATA WAS ACCEPTED */ 30092021 POSITX2 DS 0H INDICATE NULL DATA WAS ACCEPTED 30100020 XC PPOINTR(L'PPOINTR+L'PLENGTH),PPOINTR ZERO PTR AND 30110020 * LENGTH FIELDS 30120020 SPACE 30130020 * 30140020 * ENTRY POINT FOR STRING, PSTRING, QSTRING AND VALUE ROUTINES. THE PDE 30150020 * LENGTH FOR THESE POSITIONAL TYPES IS TWO WORDS. ALSO THE DATA MAY 30160020 * HAVE TO BE TRANSLATED TO UPPERCASE. 30170020 * 30180020 */*POSITX1: P TRANSLATE TO UPPERCASE */ 30182021 POSITX1 DS 0H * * * * 30190020 L R15,ATRANSQ GET ADDRESS OF TRANSLATE 30200020 * ROUTINE 30210020 BALR LINK1,R15 TRANSLATE TO UPPER CASE 30220020 SPACE 30230020 */* P MOVE PTR TO AND LENGTH OF DATA TO TEMP PDE */ 30232021 MVC DATAPTR1+ONE(L'DATAPTR1-ONE+L'DATALEN1),PPOINTR+ONE 30240020 * MOVE PTR TO DATA AND LENGTH OF DATA TO TEMPORARY PDE 30250020 SPACE 30260020 * 30270020 ******** 30280020 ******** N O T E - THE ABOVE INSTRUCTION ASSUMES PPOINTR AND PLENGTH 30290020 ******** ARE CONTIGUOUS AND DATAPTR1 AND DATALEN1 ARE 30300020 ******** CONTIGUOUS. 30310020 ******** 30320020 * 30330020 SPACE 30340020 */* D (YES,,NO,POSITX0) DATA IS PRESENT */ 30342021 NC PPOINTR,PPOINTR IS DATA PRESENT 30350020 BZ POSITX0 IF NO BRANCH 30360020 SPACE 30370020 */* P INDICATE IN PDE DATA PRESENT */ 30372021 OI DATAFLA1,DATAPRES YES - INDICATE SO IN PDE 30380020 SPACE 30390020 */*POSITX0: P INDICATE PDE TWO WORDS LONG */ 30392021 POSITX0 DS 0H * * * * 30400020 LA R1,SEVEN INDICATE PDE IS TWO WORDS LONG 30410020 SPACE 30420020 * 30430020 * ENTRY POINT FOR ADDRESS, DSNAME AND USERID ROUTINES. THE PDE LENGTH 30440020 * IS IN R1. TRANSLATION TO UPPERCASE HAS ALREADY TAKEN PLACE. 30450020 * 30460020 */*POSITX: P SAVE LENGTH OF DATA */ 30462021 POSITXCB EQU * ENTRY FROM COBOL SUPPORT F41448 30464021 * MODULE F41448 30466021 POSITX DS 0H * * * * 30470020 ST LINK2,PLINKSV1 SAVE RETURN ADDR FOR 30480020 * POSSIBLE 2ND RANGE VALUE 30490020 */* D (NO,POSITXC,YES,) PROCESSING COBOL PCE'S? */ 30490421 TM CBFLAGS1,COBOLMOD PROCESSING COBOL PCE'S? F41448 30492021 BZ POSITXC NO-CONTINUE NORMAL PARSE F41448 30494021 */* P STORE RETURN ADDRESS INTO IKJPARS2 */ 30494421 L LINK2,CBLNKSV2 STORE CORRECT RETURN F41448 30496021 ST LINK2,PLINKSV1 ADDRESS INTO PLINKSV1 F41448 30498021 * FOR RET TO COBOL MODULE F41448 30498421 */*POSITXC: P SAVE PDESIZE */ 30498800 POSITXC STC R1,PPCOUNT SAVE LENGTH FOR FUTURE USE 30500021 STC R1,PPDESIZE SAVE SIZE OF PDE-1 30510020 */* D (YES,POSITX12,NO,) 2ND RANGE VALUE */ 30512021 TM PFLAGS2,RNGEVAL2 IS THIS THE 2ND RANGE VALUE 30520020 BO POSITX12 YES, SPECIAL PROCESSING 30530020 SPACE 30540020 * 30550020 * CALCULATE PDE ADDRESS. 30560020 * 30570020 MVC PDWORD(TWO),PCEPDEO(XPCE) ALIGN PDE OFFSET ON PROPER 30580020 * BOUNDARY 30590020 LH R3,PDWORD LOAD THE PDE OFFSET 30600020 */* P GET TRUE ADDRESS OF PDE */ 30602021 A R3,XPDL GET TRUE ADDRESS OF PDE 30610020 ST R3,PDEADR STORE ADDR OF PDE IN PARM LIST 30620020 * FOR POSSIBLE VALIDITY 30630020 * CHECK EXIT 30640020 XC PREVPDEL,PREVPDEL CLEAR PREVIOUS PDE POINTER --- 30650020 * ITS USED AS A SWITCH IN THE 30660020 * VALIDITY CHECK ROUTINE 30670020 LA R2,ONE(R1) GET SIZE OF DATA 30680020 AR R2,R3 OBTAIN ADDR OF POSSIBLE 30690020 * 2ND HALF OF PDE 30700020 ST R2,RNG2ADDR SAVE FOR POSSIBLE 2ND 30710020 * RANGE VALUE 30720020 */* D (YES,,NO,POSITX55) RANGE SPACE ALOTTED IN PDE */ 30722021 TM PCEFLGB2(XPCE),PCEFRNGE IS RANGE SPACE ALOTTED IN PDE 30730020 BZ POSITX55 NO, CONTINUE 30740020 SPACE 30750020 */* P GET ACTUAL SIZE OF PDE */ 30752021 LA R1,ONE(R1,R1) YES, ADD LENGTH OF 2ND PDE TO 30760020 * GET ACTUAL SIZE OF PDE-1 30770020 STC R1,PPDESIZE SAVE 30780020 SPACE 30790020 */*POSITX55: D (YES,,NO,POSITX9A) PROCESSING A LIST */ 30792021 POSITX55 DS 0H * * * * 30800020 TM PFLAGS,PFLIST ARE WE PROCESSING A LIST 30810020 BZ POSITX9A NO BIT ZERO --- BRANCH 30820020 SPACE 30830020 * 30840020 * FIND LAST LIST ELEMENT ON LIST CHAIN. STORAGE FOR THE FIRST PDE IN 30850020 * A LIST IS OBTAINED BY THE INITIALIZATION ROUTINE. 30860020 * 30870020 */*POSITX5: P INDICATE AT LEAST ONE PDE BUILT */ 30872021 POSITX5 DS 0H * * * * 30880020 OI PFLAGS3,PFONE INDICATE AT LEAST ONE PDE 30890020 * HAS BEEN BUILT 30900020 */* P GET PTR TO CHAIN PTR */ 30902021 LA R15,ONE(R1,R3) GET PTR TO CHAIN PTR 30910020 */* D (YES,POSITXLE,NO,) FIRST ELEMENT OF LIST BEING STORED */ 30912021 EX R1,POSITXNC IS ACTUAL PDE EMPTY --- FIRST 30920020 * ELEMENT OF LIST BEING STORED 30930020 BZ POSITXLE YES IF ZERO --- BRANCH 30940020 SPACE 30950020 */* D (YES,POSITXCE,NO,) LAST PDE IN CHAIN */ 30952021 CLI ZERO(R15),HFF IS THIS THE LAST PDE IN CHAIN 30960020 BE POSITXCE IF YES BRANCH 30970020 SPACE 30980020 */* P GET PTR TO NEXT CHAIN ELEMENT */ 30982021 L R3,ZERO(R15) FETCH PTR TO NEXT CHAIN ELEMENT 30990020 */* D (,POSITX5) LOOP THROUGH CHAIN */ 30992021 B POSITX5 LOOP THROUGH CHAIN 31000020 SPACE 31010020 * 31020020 * ALLOCATE NEW PDE FOR CHAIN. 31030020 * 31040020 */*POSITXCE: P ZERO LAST ELEMENT IN CHAIN INDICATOR */ 31042021 POSITXCE DS 0H * * * * 31050020 MVI ZERO(R15),ZERO ZERO LAST ELEMENT IN CHAIN 31060020 * INDICATOR 31070020 LR R3,R15 SAVE CHAIN POINTER 31080020 ST R3,PREVPDEL SAVE PREVIOUS PDE POINTER 31090020 */* P INDICATE HOW MUCH CORE NEEDED */ 31092021 LA R1,FIVE(R1) INDICATE TO STORAGE ALLOCATION 31100020 * ROUTINE HOW MUCH CORE NEEDED 31110020 */* S STALOC: ALLOCATE STORAGE */ 31112021 BAL LINK2,STALOC ALLOCATE STORAGE 31120020 SPACE 31130020 * STORAGE ADDRESS RETURNED IN R1 31140020 */* P FORWARD CHAIN ELEMENTS */ 31142021 ST R1,ZERO(R3) FORWARD CHAIN ELEMENTS 31150020 LR R3,R1 SAVE NEW ELEMENT ADDRESS 31160020 ST R3,PDEADR STORE ADDRESS OF NEW PDE FOR 31170020 * POSSIBLE VALIDITY CHECK EXIT 31180020 SR R1,R1 ZERO REG TO HOLD ONE BYTE LENGTH 31190020 IC R1,PPCOUNT GET SIZE OF DATA -1 31200020 */* P GET ACTUAL SIZE OF DATA */ 31202021 LA R2,ONE(R1) GET ACTUAL SIZE OF DATA 31210020 */* P SAVE ADDR OF POSSIBLE 2ND HALF OF PDE */ 31212021 AR R2,R3 OBTAIN ADDR OF POSSIBLE 31220020 * 2ND HALF OF PDE 31230020 ST R2,RNG2ADDR SAVE FOR POSSIBLE 2ND VALUE 31240020 SR R1,R1 ZERO REG TO HOLD ONE BYTE LENGTH 31250020 IC R1,PPDESIZE LOAD SIZE OF PDE-1 31260020 */* P GET NEXT PDE PTR */ 31262021 LA R15,ONE(R1,R3) POINT TO NEXT PDE PTR 31270020 SPACE 31280020 */*POSITXLE: P SET LAST ELEMENT IN CHAIN INDICATOR */ 31282021 POSITXLE DS 0H * * * * 31290020 MVI ZERO(R15),HFF SET LAST ELEMENT IN CHAIN 31300020 * INDICATOR 31310020 */* D (YES,POSITX9,NO,) FIRST VALUE OF A RANGE */ 31312021 TM PFLAGS2,RNGEVAL1 IS THIS THE 1ST VALUE OF A RANGE 31320020 BO POSITX9 YES, EXIT 31330020 * 31340020 */*POSITX13: S SKIPB: SKIP SEPARATORS */ 31342021 POSITX13 DS 0H ENTRY FOR 2ND VALUE OF RANGE 31350020 BAL LINK2,SKIPB SKIP BLANKS 31360020 * 31370020 */* D (YES,POSITX9,NO,) LIST COMPLETE */ 31372021 B POSITX9 +0 RETURN - LIST COMPLETE 31380020 * 31390020 */* P INCREMENT SCAN PTR */ 31392021 LA XINPUT,ONE(XINPUT) +4 RETURN - BUMP SCAN PTR 31400020 */* D (YES,,NO,POSITX6) END OF LIST */ 31402021 CLI ZERO(XINPUT),RIGHTPRN IS THIS END OF LIST 31410020 BNE POSITX6 IF NO BRANCH 31420020 SPACE 31430020 */* P INDICATE LIST END DELIMITER FOUND */ 31432021 OI PFLAGS4,PFLSTEND INDICATE LIST END DELIMITER HAS 31440020 * BEEN FOUND 31450020 SPACE 31460020 */*POSITX9: P MOVE DATA TO PDE */ 31462021 POSITX9 DS 0H * * * * 31470020 XR R1,R1 CLEAR WORK REG TO ZERO 31480020 IC R1,PPCOUNT LOAD PDE LENGTH 31490020 EX R1,PDEXMV MOVE DATA TO PDE 31500020 */* D (YES,,NO,POSITX9B) FIRST VALUE OF RANGE BEING PROCESSED */ 31502021 TM PFLAGS2,RNGEVAL1 IS THE FIRST VALUE OF A RANGE 31510020 * BEING PROCESSED 31520020 BZ POSITX9B NO - CONTINUE 31530020 SPACE 31540020 L LINK2,PLINKSV1 RESTORE RETURN ADDR FOR RANGE 2 31550020 XC TEMPPDE(CBLTPDE),TEMPPDE ZERO TEMPORARY STORAGE AREA FOR 31560000 * PDE F41448 31570021 */* R RETURN TO CALLER */ 31572021 BR LINK2 YES, RETURN TO CALLER 31580020 SPACE 31590020 */*POSITX9B: D (YES,,NO,POSITX9C) LEFT PAREN USED AS BEGINNING OF SUBF 31592021 */* AND LIST */ 31594021 POSITX9B DS 0H * * * * 31600020 TM PFLAGS3,PFMORE WAS LEFT PAREN USED AS BEGINNING 31610020 * OF SUBFIELD AND LIST BECAUSE 31620020 * ONLY ONE PARAMETER WAS 31630020 * POSSIBLE WITHIN THE SUBFIELD 31640020 BZ POSITX9C IF NO BRANCH 31650020 */* D (YES,,NO,POSITX9C) THIS IS END OF FIELD */ 31650421 TM PFLAGS,PFENDF IS THIS THE END OF FIELD 31652020 BNZ POSITX9C NO, BRANCH 31654020 SPACE 31660020 */* P DECREMENT SCAN PTR */ 31662021 BCTR XINPUT,ZERO DECREMENT SCAN POINTER 31670020 SPACE 31680020 */*POSITX9C: D (,VCERTN) BRANCH TO VALIDITY CHECK EXIT RTN */ 31682021 POSITX9C DS 0H * * * * 31690020 BAL LINK1,VCERTN BRANCH TO VALIDITY CHECK EXIT 31700020 * ROUTINE 31710020 SPACE 31720020 */*POSITX4: P INDICATE POSSIBLE LIST NOT BEING PROCESSED ANY MORE */ 31722021 POSITX4 DS 0H * * * * 31730020 NI PFLAGS,HFF-PFLIST INDICATE POSSIBLE LIST NOT BEING 31740020 * PROCESSED ANY MORE 31750020 */* D (,POSITX3) BUMP TO NEXT PCE */ 31752021 B POSITX3 BUMP TO NEXT PCE 31760020 SPACE 31770020 */*POSITX9A: D (YES,,NO,POSITX9) LIST SPECIFIED IN PCE */ 31772021 POSITX9A DS 0H SET 'FF' IN PDE IF LIST WAS 31780020 * SPECIFIED IN PCE BUT NOT 31790020 * ENTERED 31800020 TM PCEFLGB2(XPCE),PCEFLIST IS LIST SPECIFIED IN PCE 31810020 BZ POSITX9 NO - CONTINUE 31820020 SPACE 31830020 XR R1,R1 ZERO WORK REG 31840020 IC R1,PPDESIZE GET LENGTH OF BASIC PDE -1 31850020 LA R1,ONE(R1,R3) GET ADDR OF LIST PTR 31860020 */* P INDICATE LIST NOT ENTERED */ 31862021 MVI ZERO(R1),HFF INDICATE LIST WAS NOT ENTERED 31870020 */* D (,POSITX9) CONTINUE */ 31872021 B POSITX9 CONTINUE 31880020 SPACE 31890020 */*POSITX6: P MOVE DATA TO PDE */ 31892021 POSITX6 DS 0H * * * * 31900020 XR R1,R1 CLEAR WORK REG TO ZERO 31910020 IC R1,PPCOUNT LOAD PDE LENGTH 31920020 EX R1,PDEXMV MOVE DATA TO PDE 31930020 */* D (YES,,NO,POSITX8) RIGHT PAREN FOUND */ 31930421 TM PFLAGS4,PFLSTEND RIGHT PAREN FOUND M3333 31932020 BZ POSITX8 NO, CONTINUE M3333 31934020 */* D (YES,POSITX7,NO,) THIS CHARACTER RIGHT PAREN */ 31934421 CLI ONE(XINPUT),RIGHTPRN CHARACTER A RIGHT PAREN M3333 31936020 BE POSITX7 YES CONTINUE M3333 31938020 SPACE 31938120 */*POSITX8: P DECREMENT SCAN PTR BEFORE EXIT */ 31938221 POSITX8 DS 0H * * * * 31938420 BCTR XINPUT,ZERO DECREMENT SCAN PTR BEFORE EXIT 31940020 * IN CASE A NON-ZERO RETURN 31950020 * CODE IS RETURNED 31960020 */*POSITX7: S VCERTN: BRANCH TO VALIDITY CHECK EXIT RTN */ 31960421 POSITX7 DS 0H * * * * 31962020 BAL LINK1,VCERTN BRANCH TO VALIDITY CHECK EXIT 31970020 * ROUTINE 31980020 SPACE 31990020 */* D (YES,POSITX71,NO,) LIST END DELIMITER BEEN FOUND */ 31992000 TM PFLAGS4,PFLSTEND HAS LIST END DELIMITER BEEN 32000020 * FOUND 32010020 BO POSITX71 IF END OF LIST, CONTINUE F41448 32020021 * NORMAL PARSE F41448 32022021 */*NOTEND1: D (NO,NEXTPCE,YES,) PROCESSING COBOL PCE'S? */ 32022421 NOTEND1 TM CBFLAGS1,COBOLMOD PROCESSING COBOL PCE'S? F41448 32024021 * IF COBOL MODE AND NOT END F41448 32026021 * OF LIST, RETURN MUST BE F41448 32028021 * TO COBOL MACRO PROCESSORS F41448 32028421 BZ NEXTPCE IF NOT COBOL MODE, GO TO F41448 32028821 * PROCESS NEXT PCE F41448 32029221 */* P LOAD RETURN ADDRESS INTO IKJPARS2 */ 32029321 */* R () EXIT TO IKJPARS2 */ 32029421 L LINK2,CBLNKSV2 IF IN COBOL MODE, RETURN F41448 32029621 BR LINK2 TO MACRO PROCESSOR AT F41448 32029721 * ADDRESS IN CBLNKSV2 F41448 32029821 SPACE 32030020 */*POSITX71: P TURN OFF POSSIBLE LIST FLAG */ 32032000 POSITX71 NI PFLAGS,HFF-PFLIST YES, TURN OF POSSIBLE LIST FLAG 32040021 SPACE 32050020 * 32060020 * END OF POSITIONAL PARAMETER PROCESSING --- POINT TO NEXT PCE AND 32070020 * RETURN TO MAIN CONTROL ROUTINE. 32080020 * 32090020 */*POSITX3: P CLEAR POSSIBLE ONE-PDE AND NO-SKIP-AFTER-PROMPT FLAGS */ 32092021 POSITX3 DS 0H * * * * 32100020 NI PFLAGS3,HFF-PFONE CLEAR POSSIBLE ONE PDE FLAG 32110020 NI RFLAGS,HFF-RFNOSKIP CLEAR POSSIBLE NO SKIP AFTER 32120020 * PROMPT FLAG 32130020 */* D (YES,,NO,POSITX31) PROCESSING COBOL PCE'S? */ 32130421 TM CBFLAGS1,COBOLMOD PROCESSING COBOL PCE'S F41448 32132021 BZ POSITX31 NO-CONTINUE NORMAL PARSE F41448 32134021 */* P LOAD RETURN ADDRESS INTO IKJPARS2 */ 32134421 */* R () EXIT TO IKJPARS2 */ 32134821 L LINK2,CBLNKSV2 IF IN COBOL MODE, RETURN F41448 32136021 BR LINK2 TO MACRO PROCESSORS TO F41448 32138021 * HANDLE THE END OF LIST F41448 32138421 * AND NEXTPCE PROCESSING F41448 32138821 POSITX31 MVC PDWORD(TWO),PCELEN(XPCE) ALIGN PCE LENGTH ON PROPER 32140021 * BOUNDARY 32150020 AH XPCE,PDWORD COMPUTE THE NEXT PCE ADDRESS 32160020 */*POSITX31: D (,NEXTPCE) GET NEXT PCE ADDRESS */ 32162000 B NEXTPCE CONTINUE PARSE OF INPUT 32170020 SPACE 32180020 */*POSITX12: P SAVE ACTUAL SIZE OF PDE */ 32182021 POSITX12 DS 0H * * * * 32190020 LA R1,ONE(R1,R1) GET ACTUAL SIZE OF PDE -1 32200020 STC R1,PPDESIZE SAVE 32210020 */* P PREPARE TO MOVE DATA INTO 2ND HALF OF PDE */ 32212021 L R3,RNG2ADDR SET UP TO MOVE DATA INTO 32220020 * 2ND HALF OF PDE 32230020 */* P TURN OFF 2ND VALUE FLAG */ 32232021 NI PFLAGS2,HFF-RNGEVAL2 TURN OFF VAL 2 FLAG 32240020 */* D (YES,POSITX13,NO,POSITX9) LIST BEING PROCESSED */ 32242021 TM PFLAGS,PFLIST IS A LIST BEING PROCESSED 32250020 BZ POSITX9 N0, MOVE DATA AND EXIT 32260020 SPACE 32270020 B POSITX13 YES, CHECK FOR MORE DATA IN THE 32280020 * LIST 32290020 EJECT 32300020 * 32310020 * IDENT PCE ROUTINE 32320020 * 32330020 */*IDENT: P GET SIZE OF PDE */ 32332021 IDENT DS 0H PROCESS IDENT-TYPE POSITIONAL 32340020 * PARAMETERS 32350020 LA R1,SEVEN GET SIZE OF PDE-1 32360020 STC R1,PPCOUNT SAVE 32370020 */* D (YES,IDENTERS,NO,) IN ERASE MODE */ 32372021 TM RFLAGS,RFERASE IS THE SCAN IN ERASE MODE 32380020 BO IDENTERS YES, BRANCH TO ERASE THE PDE 32390020 * 32400020 */* S SCANF: POP STACK IF POSSIBLE */ 32402021 BAL LINK1,SCANF IF POSSIBLE POP THE INPUT STACK 32410020 * TO GET NEXT LEVEL OF DATA 32420020 * BEFORE THE SCAN BEGINS 32430020 * 32440020 NOP ZERO +0 RETURN - NO INPUT DATA LEFT 32450020 * 32460020 * +4 RETURN - DATA REMAINS IN 32470020 * CURRENT LEVEL OR POP OCCURRED 32480020 * 32490020 XC DATAPTR1(LTPDE),DATAPTR1 ZERO TEMPORARY 32500020 * STORAGE AREA FOR PDE 32510020 * 32520020 */* S SKIPB: SKIP SEPARATORS */ 32522021 BAL LINK2,SKIPB SKIP BLANKS TO BEGINNING OF PARM 32530020 * 32540020 */* D (YES,IDMSNG,NO,) END OF INPUT REACHED (PARM IS MISSING) */ 32542021 B IDMSNG +0 RETURN - END OF INPUT REACHED 32550020 * PARM IS MISSING 32560020 * 32570020 * +4 RETURN - BEGINNING OF PARM 32580020 * ESTABLISHED 32590020 * 32600020 */* S LISTT: TEST AND SET UP FOR LIST */ 32602021 BAL LINK1,LISTT TEST AND SET UP FOR LIST 32610020 * XINPUT POINTS TO NEXT ITEM IN 32620020 * THE LIST IF LIST IS PRESENT 32630020 */* D (YES,,NO,ILLIDENT) DATA IN LIST */ 32632021 B ILLIDENT RETURN +0, NO DATA IN LIST, ERR 32640020 * 32650020 * RETURN +4, DATA TO SCAN 32660020 SPACE 32670020 * 32680020 * ENTRY POINT FOR RESCANNING NEW DATA 32690020 * 32700020 */*IDENTRSC: P SAVE PTR FOR INVALID MSG */ 32702021 IDENTRSC DS 0H * * * * 32710020 MVC INVPSAVE,PPOINTR SAVE PTR FOR INVALID MSG 32720020 */*IDRNG2SC: D (YES,ID00,NO,) MAX LENGTH SPECIFIED */ 32722021 IDRNG2SC DS 0H ENTRY TO SCAN 2ND RANGE VALUE 32730020 TM PCEOPT(XPCE),PCEFMAXL IS A MAX LENGTH SPECIFIED 32740020 BNZ ID00 YES, CONTINUE 32750020 * 32760020 */* P GET ADDR OF GENSCAN CONTROL INFO */ 32762021 LA R3,PCEOPT(XPCE) NO, GET ADDR OF GENSCAN CONTROL 32770020 */* D (,ID005) BRANCH */ 32772021 B ID005 INFO 32780020 SPACE 32790020 */*ID00: P MOVE INFO FROM IDENT PCE TO WORK AREA */ 32792021 ID00 MVC PDWORD+FOUR(THREE),PCEOPT(XPCE) NO, MOVE OPTIONS, FIRST, 32800020 * AND OTHER BYTES FROM IDENT 32810020 * PCE TO WORK AREA 32820020 MVC PDWORD(TWO),PCEPARMT(XPCE) ALIGN PARAMETER TYPE LENGTH 32830020 * ON PROPER BOUNDARY 32840020 LH R2,PDWORD LOAD THE LENGTH 32850020 LA R2,PCEPARMT(R2,XPCE) COMPUTE ADDRESS OF MAXLNTH 32860020 */* P MAKE MAXLENGTH CONTIGUOUS TO TYPE FIELD IN WORK AREA */ 32862021 MVC PDWORD+SEVEN(ONE),ZERO(R2) MAKE MAXLENGTH 32870020 * CONTIGUOUS TO OTHER TYPE 32880020 * FIELD IN WORK AREA 32890020 */* P GET ADDR OF GENSCAN CONTROL INFO */ 32892021 LA R3,PDWORD+FOUR GET ADDR OF GENSCAN CONTROL INFO 32900020 SPACE 32910020 */*ID005: P USE GENSCAN FOR SYNTAX CHECKING */ 32912021 ID005 DS 0H * * * * 32920020 ST R3,PDWORD SAVE ADR OF GENSCAN CONTROL INFO 32930020 * IN PDWORD 32940020 L R15,AGENSCAN GET ADDRESS OF GENSCAN ROUTINE 32950020 BALR LINK2,R15 USE GENSCAN FOR SYNTAX CHECKING 32960020 * THIS LINKAGE CLOBBERS R0, 32970020 * R1, R2, R14 AND LINK1 AND 32980020 * ALSO MODIFIES XINPUT, XINPUTB 32990020 * PPOINTR 33000020 * 33010020 */* D (YES,IDMSNG,NO,) PARAMETER MISSING */ 33012021 BCT XINPUT,IDMSNG +0 RETURN - MISSING, BACK UP 33020020 * 33030020 */* D (YES,ILLIDENT,NO,) PARAMETER TOO LONG */ 33032021 BCT XINPUT,ILLIDENT +4 RETURN - TOO LONG, BACK UP 33040020 * INPUT, PROCESS INVALID 33050020 * 33060020 */* D (YES,IDEND,NO,) END OF INPUT IS DELIMITER */ 33062021 B IDEND +8 RETURN - END IS DELIMITER 33070020 * 33080020 * +12 RETURN - OK, CHECK DELIMITER 33090020 */* S RANGE: CHECK FOR RANGE */ 33092021 BAL LINK1,RANGE CHECK FOR RANGE 33100020 */* D (YES,,NO,IDGOOD1) FIRST VALUE OF RANGE */ 33102021 B IDGOOD1 +0 RETURN - RANGE NOT ALLOWED OR 33110020 * RANGE NOT PRESENT OR 33120020 * 2ND VALUE OF RANGE 33130020 * +4 RETURN - 1ST VALUE OF RANGE 33140020 */* P LOAD ADDR OF 2ND VALUE SCAN */ 33142021 LA LINK2,IDRNG2SC LOAD ADDR OF 2ND VALUE SCAN 33150020 */* D (,IDEND1) PROCESS END */ 33152021 B IDEND1 PROCESS END 33160020 SPACE 33170020 */*IDGOOD1: S TYPETEST: CHECK FOR DELIMITER CHARACTER */ 33172021 IDGOOD1 DS 0H * * * * 33180020 LA R1,DLIMREQD SET CHAR TYPE FOR DELIMITER TEST 33190020 BAL LINK1,TYPETEST TEST 33200020 * 33210020 */* D (YES,IDEND1,NO,ILLIDENT) GOOD DELIMITER */ 33212021 BCT XINPUT,ILLIDENT +0 RETURN - BAD 33220020 * 33230020 B IDEND1 +4 RETURN - GOOD DELIMITER 33240020 SPACE 33250020 */*IDEND: D (YES,,NO,IDEND1) FIRST VALUE OF RANGE ENTERED */ 33252021 IDEND DS 0H * * * * 33260020 TM PFLAGS2,RNGEVAL1 WAS 1ST VALUE OF RANGE ENTERED 33270020 BZ IDEND1 NO, CONTINUE 33280020 */* P TURN OFF FIRST VALUE SWITCH */ 33282021 NI PFLAGS2,HFF-RNGEVAL1 TURN OFF 1ST VALUE SWITCH 33290020 */* P TURN ON 2ND VALUE SWITCH */ 33292021 OI PFLAGS2,RNGEVAL2 TURN ON 2ND VALUE SWITCH 33300020 */*IDEND1: P SAVE LENGTH */ 33302021 IDEND1 DS 0H * * * * 33310020 S XINPUTB,PPOINTR COMPUTE LENGTH 33320020 STH XINPUTB,PLENGTH SAVE 33330020 */* D (,POSITX1) EXIT */ 33332021 BCT XINPUT,POSITX1 BACK UP, EXIT TYPE 1 33340020 SPACE 33350020 */*IDMSNG: D (YES,ILLIDENT,NO,) FIRST RANGE VALUE FOUND */ 33352021 IDMSNG DS 0H 33360020 TM PFLAGS2,RNGEVAL1 WAS THE 1ST RANGE VALUE FOUND 33370020 BO ILLIDENT YES, THEN IT IS INVALID 33380020 * 33390020 */* S PROMPTQ: TRY TO PROMPT OR DEFAULT */ 33392021 BAL LINK1,PROMPTQ TRY TO PROMPT OR DEFAULT 33400020 * 33410020 */* D (YES,IDENTRSC,NO,POSITX2) NEW DATA TO SCAN */ 33412021 B IDENTRSC +0 RETURN - NEW DATA TO SCAN 33420020 * 33430020 B POSITX2 +4 RETURN - NO DATA, TAKE NULL 33440020 * PDE EXIT 33450020 SPACE 33460020 * 33470020 * ADDRESS OF NEXT CSECT. 33480020 * 33490020 ADRCST2 DC V(IKJEFP02) ADDRESS OF THIRD CSECT 33500020 EJECT 33510020 *********************************************************************** 33520020 * * 33530020 * THE POINTER TO THE FIRST KEYWORD PCE IS SAVED AND THE INPUT IS * 33540020 * SCANNED FOR THE NEXT IDENTIFIER. THE PCL IS SEARCHED FOR A MATCHING * 33550020 * KEYWORD AS FOLLOWS - * 33560020 * 1. A KEYWORD PCE RESETS THE NAME COUNTER TO ONE. * 33570020 * 2. WHEN AN NAME PCE IS FOUND THE NAME IS COMPARED TO * 33580020 * THE KEYWORD IN THE INPUT BUFFER. IF ITS NOT EQUAL * 33590020 * THE NEXT PCE IS USED. * 33600020 * * 33610020 * EVENTUALLY, A MATCH IS FOUND AND THE NAME COUNTER IS STORED INTO * 33620020 * THE PDE. * 33630020 * IF A SUBFIELD IS NOT REQUIRED THE NEXT IDENTIFIER IS SCANNED. IF * 33640020 * IT IS A TEST IS MADE TO SEE IF IT WAS ENTERED. IF IT WAS NOT, A * 33650020 * DUMMY () PAIR IS PLACED INTO THE INPUT STACK FOR LATER SCANNING. IF * 33660020 * THE FIRST SUBFIELD PARAMETER IS A POSITIONAL LIST, THE SCAN POINTER * 33670020 * IS RESET SO THAT THE LEFT PARENTHESIS IS RESCANNED LATER FOR THE * 33680020 * LIST. * 33690020 * * 33700020 *********************************************************************** 33710020 SPACE 33720020 IKJEFP02 CSECT 33730020 SPACE 33740020 */*KEYWD: P SET KEYWORD PARSED ONCE FLAG */ 33742021 KEYWD DS 0H PROCESS KEYWORD PARAMETERS 33750020 ST XPCE,RKEYSV SAVE START OF KEYWORD PCL SECT. 33760020 OI RFLAGS,RFKYPRSE SET PARSED ONCE FLAG 33770020 SPACE 33780020 * 33790020 * SCAN FOR NEXT IDENTIFIER. 33800020 * 33810020 */*KEYWDSCN: S SCANF: POP STACK IF POSSIBLE */ 33812021 KEYWDSCN DS 0H * * * * 33820020 BAL LINK1,SCANF IF POSSIBLE POP THE INPUT STACK 33830020 * TO GET NEXT LEVEL OF DATA 33840020 * BEFORE THE SCAN BEGINS 33850020 * 33860020 */* D (YES,,NO,KEYWDXI2) DATA REMAINS */ 33862021 B KEYWDXI2 +0 RETURN - NO INPUT DATA LEFT 33870020 * 33880020 * +4 RETURN - DATA REMAINS IN 33890020 * CURRENT LEVEL OR POP OCURRED 33900020 SPACE 33910020 */* S SKIPB: SKIP SEPARATORS */ 33912021 BAL LINK2,SKIPB SKIP BLANKS 33920020 * 33930020 */* D (YES,,NO,KEYWDXI2) DATA LEFT TO SCAN */ 33932021 B KEYWDXI2 +0 RETURN - NO DATA LEFT TO SCAN 33940020 * 33950020 * +4 RETURN - SCAN NEXT CHARACTER 33960020 LA R1,KEYSYNTX GET REQUIRED SYNTAX FOR A KEYWD 33970020 ST R1,PDWORD SAVE FOR GENSCAN 33980020 L R15,AGENSCAN GET ADDRESS OF GENSCAN ROUTINE 33990020 */* P USE GENSCAN FOR SYNTAX CHECKING */ 33992021 BALR LINK2,R15 USE GENSCAN FOR SYNTAX CHECKING 34000020 * 34010020 * SYNTAX CHECK FOR A KEYWORD 34020020 * 34030020 */* D (YES,KEYWDMIS,NO,) INVALID 1ST CHARACTER */ 34032021 B KEYWDMIS +0 RETURN - INVALID 1ST M3337 34040020 * CHAR, TEST FOR END OF M3337 34050020 * SUBFIELD OR SEMICOLON M3337 34052020 * 34060020 */* D (YES,ILLKEYWD,NO,) PARAMETER TOO LONG */ 34062021 BCT XINPUT,ILLKEYWD +4 RETURN - TOO LONG, BACKUP AND 34070020 * PROCESS INVALID 34080020 * 34090020 */* D (YES,KEYWDEND,NO,) END OF BUFFER IS DELIMITER */ 34092021 B KEYWDEND +8 RETURN - END IS DELIMITER 34100020 * 34110020 * +12 RETURN - CHECK DELIMITER 34120020 */* D (YES,KEYWDEND,NO,) IS DELIMITER LEFT PAREN FOR SUBFIELD */ 34122021 CLI ZERO(XINPUT),LEFTPRN IS THE DELIMITER A LEFT PAREN 34130020 * FOR A SUBFIELD 34140020 BE KEYWDEND YES - GOOD, GO COMPUTE LENGTH 34150020 SPACE 34160020 LA R1,DLIMREQD TEST FOR LEGAL END DELIMITER 34170020 */* S TYPETEST: TEST FOR VALID END DELIMITER */ 34172021 BAL LINK1,TYPETEST * * * * 34180020 SPACE 34190020 */* D (YES,ILLKEYWD,NO,) INVALID DELIMITER */ 34192021 BCT XINPUT,ILLKEYWD +0 RETURN - ILLEGAL 34200020 SPACE 34210020 * +4 RETURN - GOOD DELIMITER 34220020 SPACE 34230020 */*KEYWDEND: P COMPUTE KEYWORD LENGTH */ 34232021 KEYWDEND DS 0H 34240020 S XINPUTB,PPOINTR COMPUTE KEYWORD LENGTH 34250020 STH XINPUTB,PLENGTH SAVE LENGTH OF KEYWORD 34260020 BCTR XINPUT,ZERO BACK UP INPUT POINTER BY ONE 34270020 SPACE 34280020 * 34290020 * LOCATE THE IKJNAME PCE THAT CORRESPONDS TO THE ENTERED KEYWORD. IF 34300020 * A KEYWORD PCE IS FOUND THE NAME COUNTER IS RESET TO ONE. A NAME PCE 34310020 * CAUSES THE NAME IN THE PCE TO BE COMPARED TO THE ENTERED KEYWORD, IF 34320020 * UNEQUAL, GO TO THE NEXT PCE. 34330020 * 34340020 L R15,ATRANSQ GET ADDRESS OF TRANSLATE 34350020 * ROUTINE 34360020 */* P TRANSLATE KEYWORD TO UPPER CASE IF NECESSARY */ 34362021 BALR LINK1,R15 TRANSLATE THE KEYWORD TO UPPER 34370020 * CASE IF NECESSARY 34380020 SPACE 34390020 */* P GET FIRST KEYWORD ENTRY */ 34392021 L XPCE,RKEYSV PICK UP FIRST KEYWORD ENTRY 34400020 XR R14,R14 CLEAR MATCH COUNTER P 34402020 SPACE 34410020 */*KEYWDTL2: P FIND KEYWROD PROCESSOR ROUTINE */ 34412021 KEYWDTL2 DS 0H * * * * 34420020 XR R2,R2 CLEAR WORK REGISTER TO ZERO 34430020 IC R2,PCEFLGB1(XPCE) LOAD TYPE INDICATOR 34440020 N R2,TYPEMASK ISOLATE TYPE INDICATOR BITS 34450020 SRL R2,THREE POSITION BITS FOR INDEXED BRANCH 34460020 B *+FOUR(R2) FIND KEYWORD PROCESSOR ROUTINE 34470020 * 34480020 */* D (YES,KEYWDXIT,NO,) END-OF-FIELD */ 34482021 B KEYWDXIT END-OF-FIELD --- EXIT 34490020 * 34500020 */* D (YES,KEYWDXIT,NO,) POSITIONAL */ 34502021 B KEYWDXIT POSITIONAL --- EXIT 34510020 * 34520020 */* D (YES,KEYWDTL3,NO,) NEW KEYWORD SPECIFICATION */ 34522021 B KEYWDTL3 NEW KEYWORD SPECIFICATION 34530020 * 34540020 */* D (YES,KEYWDNAM,NO,) NAME PCE */ 34542021 B KEYWDNAM NAME PCE --- PROCESS IT 34550020 * 34560020 */* D (YES,KEYWDXIT,NO,) IDENT */ 34562021 B KEYWDXIT IDENT PCE --- EXIT 34570020 SPACE 34580020 */*KEYWDNAM: P COMPARE KEYWORD ENTERED TO NAME PCE */ 34582021 KEYWDNAM DS 0H * * * * 34590020 XC TEMPPDE(LTPDE),TEMPPDE CLEAR WORK AREA 34600020 IC R1,PCENAML(XPCE) LOAD LENGTH OF NAME-1 FROM NAME 34610020 * PCE 34620020 EX R1,NAMEMVC MOVE NAME TO WORK AREA 34630020 LH R2,PLENGTH LOAD KEYWORD LENGTH FOR COMPARE 34640020 BCTR R2,ZERO REDUCE LENGTH FOR 'EX' INSTR. 34650020 L R1,PPOINTR LOAD ADDRESS OF KEYWORD 34660020 EX R2,KEYWDCLC COMPARE KEYWORD ENTERED TO NAME 34670020 * PCE - KEYWORD LENGTH 34680020 * MAXIMUM IS 31 34690020 */* D (YES,KEYWDTL6,NO,) BRANCH IF EQUAL */ 34692021 BE KEYWDTL6 IF EQUAL BRANCH 34700020 SPACE 34710020 */*KEYWDTL5: P BUMP PTR TO NEXT PCE */ 34712021 KEYWDTL5 DS 0H * * * * 34720020 LA R3,ONE(R3) BUMP NAME COUNTER BY ONE 34730020 MVC PDWORD(TWO),PCELEN(XPCE) ALIGN PCE LENGTH FIELD ON 34740020 * PROPER BOUNDARY 34750020 AH XPCE,PDWORD BUMP PTR TO NEXT PCE 34760020 */* D (,KEYWDTL2) GET NEXT PCE */ 34762021 B KEYWDTL2 GET NEXT PCE 34770020 SPACE 34780020 */*KEYWDTL3: P SET NAME COUNTER TO ONE */ 34782021 KEYWDTL3 DS 0H * * * * 34790020 LA R3,ONE SET NAME COUNTER TO ONE 34800020 */* S KEYWDX1: SKIP THIS KEYWORD ENTRY */ 34802021 BAL LINK1,KEYWDX1 SKIP THIS KEYWORD ENTRY 34810020 SPACE 34820020 */* D (,KEYWDTL2) GET NEXT PCE */ 34822021 B KEYWDTL2 GET NEXT PCE 34830020 SPACE 34840020 * 34850020 * A MATCH WAS FOUND, THE NAME COUNTER IS STORED INTO THE PDE AND A TEST 34860020 * IS MADE TO SEE IF A SUBFIELD MAY BE PRESENT. IF A SUBFIELD MAY BE 34870020 * SPECIFIED THE PROCESS IS REPEATED. IF A SUBFIELD WAS NOT SPECIFIED A 34880020 * DUMMY SET OF PARENTHESIS, (), IS PLACED ONTO THE INPUT STACK FOR 34890020 * LATER SCANNING. IF THE FIRST SUBFIELD PARAMETER IS A POSITIONAL LIST, 34900020 * THE SCAN POINTER IS RESET SO THAT THE LEFT PARENTHESIS IS RESCANNED 34910020 * LATER FOR THE LIST. 34920020 * 34930020 */*KEYWDTL6: P COMPARE LENGTH OF NAME TO LENGTH OF KEYWORD ENTERED */ 34932021 KEYWDTL6 DS 0H * * * * 34940020 ST XPCE,PKEYWDTB SAVE TABLE POINTER FOR KEYWORD 34950020 MVC PKEYWDPM,PKEYWDPS SAVE CURRENT NAME PCE POINTER 34960020 MVC PKEYWDPX,PKEYWDPC SAVE CURRENT KEYWD PCE POINTER 34970020 STH R3,PKEYWDVL SAVE NAME NUMBER 34980020 XR R1,R1 CLEAR FOR INSERT 34990020 IC R1,PCENAML(XPCE) LOAD LENGTH OF NAME-1 FROM NAME 35000020 * PCE 35010020 CR R1,R2 COMPARE LENGTH-1 OF KEYWORD 35020020 * ENTERED TO LENGTH-1 OF NAME 35030020 * IN PCE 35040020 */* D (YES,KEYWDFN1,NO,) LENGTHS EQUAL */ 35042021 BE KEYWDFN1 IF EQUAL DO NOT CHECK FOR 35050020 * AMBIGUITY 35060020 SPACE 35070020 */* D (,KEYWDTL5) CHECK FOR FURTHER MATCHES */ 35072021 LA R14,ONE(R14) INDICATE MATCH FOUND M2574 35080020 B KEYWDTL5 CHECK FOR FURTHER MATCHES 35120020 SPACE 35130020 */*KEYWDFNO: P STORE MATCH NUMBER IN PDE */ 35132021 KEYWDFN0 DS 0H STORE MATCH NUMBER IN PDE 35140020 NI RFLAGS,HFF-RFERASE CLEAR ERASE INDICATOR 35150020 SPACE 35160020 */*KEYWDFN1: P RESTORE PDE AND PCE POINTERS */ 35162021 KEYWDFN1 DS 0H * * * * 35170020 L XPCE,PKEYWDTB RESTORE PCE POINTER TO PLACE 35200020 * WHEN FOUND 35210020 L R3,PKEYWDPM RESTORE PDE POINTER ALSO 35220020 * COMPUTED EARLIER 35230020 */* D (YES,KEYWDRPT,NO,) PDE ALREADY FILLED IN */ 35232021 NC ZERO(TWO,R3),ZERO(R3) WAS PDE ALREADY FILLED IN 35240020 BNZ KEYWDRPT YES --- BRANCH --- ERROR 35250020 SPACE 35260020 MVC ZERO(TWO,R3),PKEYWDVL STORE MATCH VALUE IN PDE 35270020 */* D (YES,KEYWDSUB,NO,) IS SUBFIELD POSSIBLE */ 35272021 TM PCEFLGB1(XPCE),PCEFSUBF IS A SUBFIELD POSSIBLE 35280020 BO KEYWDSUB YES --- PROCESS SUBFIELD 35290020 SPACE 35300020 */*KEYWDINS: D (YES,,NO,KEYWDSCN) IS INSERT OPTION SPECIFIED */ 35302021 KEYWDINS DS 0H CHECK FOR INSERT OPTION 35310020 TM PCEFLGB2(XPCE),PCEFINST IS INSERT OPTION SPECIFIED 35320020 BZ KEYWDSCN NO --- GET NEXT KEYWORD 35330020 */* P POINT TO FIRST CHAR. AFTER INSERTING KEYWORD */ 35332021 LA XINPUT,ONE(XINPUT) YES, POINT TO FIRST CHARACTER 35340020 * AFTER INSERTING THE KEYWORD 35350020 SPACE 35360020 */* S PUSHI: PUSH STACK FOR DATA */ 35362021 BAL LINK1,PUSHI PUSH STACK FOR DATA 35370020 * DATA 35380020 SPACE 35390020 XR R2,R2 CLEAR WORK REG 35400020 */* P GET LENGTH OF NAME IN PCE */ 35402021 IC R2,PCENAML(XPCE) GET LENGTH OF NAME IN PCE 35410020 LA R2,PCENAML+TWO(R2,XPCE) BUMP PTR PAST NAME 35420020 */* D (YES,,NO,KEYWDIN1) IS SUBFIELD SPECIFIED */ 35422021 TM PCEFLGB1(XPCE),PCEFSUBF IS A SUBFIELD SPECIFIED 35430020 BZ KEYWDIN1 NO, ALREADY POSITIONED AT INSERT 35440020 * DATA 35450020 SPACE 35460020 */* P BUMP PTR PAST OFFSET TO SUBFIELD */ 35462021 LA R2,TWO(R2) BUMP PTR PAST OFFSET TO SUBFLD 35470020 SPACE 35480020 */*KEYWDIN1: P POINT TO START OF INSERT DATA */ 35482021 KEYWDIN1 DS 0H * * * * 35490020 LA XINPUT,ONE(R2) POINT TO START OF INSERT DATA 35500020 ST XINPUT,PPOINTR SAVE FOR LATER 35510020 XR R1,R1 CLEAR WORK REG TO ZERO 35520020 */* P LOAD LENGTH OF INSERT DATA */ 35522021 IC R1,ZERO(R2) LOAD LENGTH-1 OF INSERT DATA 35530020 LA R1,TWO(R1,R2) GET PTR TO END OF INSERT DATA 35540020 */* P POINT TO END OF INSERT DATA */ 35542021 ST R1,ENDINPUT SAVE END OF INSERT DATA 35550020 */* D (,KEYWDSCN) GET NEXT KEYWORD */ 35552021 BCT XINPUT,KEYWDSCN REDUCE PTR AND GET NEXT KEYWORD 35560020 SPACE 35570020 */*KEYWDSUB: P SET UP FOR SUBFIELD */ 35572021 KEYWDSUB DS 0H SET UP FOR SUBFIELD 35580020 XR R1,R1 CLEAR WORK REGISTER TO ZERO 35590020 IC R1,PCENAML(XPCE) LOAD LENGTH - 1 OF NAME 35600020 AR R1,XPCE POINT INTO IKJNAME PCE 35610020 MVC PDWORD(TWO),SIX(R1) ALIGN SUBFIELD OFFSET ON PROPER 35620020 * BOUNDARY 35630020 LH R3,PDWORD LOAD THE SUBFIELD OFFSET 35640020 */* P COMPUTE SUBFIELD ADDRESS */ 35642021 A R3,PTABLEAD COMPUTE REAL SUBFIELD ADDRESS 35650020 * 35660020 ******** 35670020 ******** NOTE - R3 NOW POINTS TO SECOND BYTE OF IKJSUBF PCE 35680020 ******** 35690020 * 35700020 LA XINPUT,ONE(XINPUT) MORE DATA IN BUFFER 35750020 LR XINPUTB,XINPUT SET BACKUP REGISTER 35760020 */* D (YES,KEYWDRS1,NO,) CHARACTER IS LEFT PAREN */ 35762021 CLI ZERO(XINPUT),LEFTPRN IS CHARACTER A LEFT PARENTHESIS 35770020 BE KEYWDRS1 IF YES BRANCH 35780020 SPACE 35790020 */* D (YES,KEYWDFN2,NO,) END OF INPUT */ 35790421 C XINPUT,ENDINPUT END OF INPUT M2454 35792020 BNL KEYWDFN2 YES, DON'T SAVE INPUT M2454 35794020 SPACE 35796020 BCTR XINPUT,ZERO REDUCE SCAN PTR BY ONE 35810020 SPACE 35812020 */* S PUSHI: PUSH INPUT STACK */ 35814021 BAL LINK1,PUSHI PUSH DOWN INPUT STACK 35820020 SPACE 35830020 */*KEYWDFN2: P POINT TO DUMMY () */ 35830421 KEYWDFN2 DS 0H * * * * 35832020 LA XINPUT,LRPAREN POINT TO DUMMY () 35840020 LA R0,LRPAREN+L'LRPAREN SET END OF INPUT POINTER 35850020 ST R0,ENDINPUT SAVE POINTER 35860020 SPACE 35870020 */*KEYWDRS1: D (YES,KEYWDRS3,NO,) IKJPOSIT PCE */ 35872021 KEYWDRS1 DS 0H * * * * 35880020 MVC PDWORD(ONE),TWO(R3) MOVE FLAG BYTE ONE OF PCE 35890020 NI PDWORD,HE0 ISOLATE THE TYPE INDICATOR BITS 35900020 * FOLLOWING SUBFIELD PCE TO 35910020 * WORK AREA 35920020 CLI PDWORD,EIGHT*(POSITBB-MAINB) IS IT A IKJPOSIT PCE 35930020 BE KEYWDRS3 IF YES BRANCH 35940020 SPACE 35950020 */* D (YES,,NO,KEYWDRS2) IKJIDENT PCE */ 35952021 CLI PDWORD,EIGHT*(IDENTB-MAINB) IS IT AN IKJIDENT PCE 35960020 BNE KEYWDRS2 IF NO BRANCH 35970020 SPACE 35980020 * 35990020 * IF THE SUBFIELD CAN CONTAIN ONLY ONE PARAMETER AND THAT PARAMETER CAN 36000020 * BE A LIST THE PARENTHESIS OF THE SUBFIELD IS ALSO USED AS THE 36010020 * DELIMITERS OF THE LIST. FOR EXAMPLE, KEYWORD(ITEM1 ITEM2). A LIST OF 36020020 * THE FORM KEYWORD((ITEM1 ITEM2)), CAUSES THE MIDDLE SET OF 36030020 * PARENTHESIS TO BE PICKED UP AS INVALID ITEMS IN THE LIST. 36040020 * IF THE SUBFIELD CAN CONTAIN MORE THAN ONE PARAMETER AND THE FIRST 36050020 * PARAMETER CAN BE A LIST THE SUBFIELD PARENTHESIS ARE NOT USED AS THE 36060020 * DELIMITERS OF THE LIST. IN THIS CASE THE PARENTHESIS DELIMITING 36070020 * THE LIST MUST BE SPECIFIED. FOR EXAMPLE, KEYWORD((ITEM1 ITEM2) (ITEM1 36080020 * ITEM2)). 36090020 * IF THE FIRST PARAMETER CAN NOT BE A LIST THERE IS NO ADDITIONAL 36100020 * CONSIDERATION REQUIRED. 36110020 * 36120020 */*KEYWDRS3: D (YES,,NO,KEYWDRS2) LIST IS SPECIFIED */ 36122021 KEYWDRS3 DS 0H * * * * 36130020 TM THREE(R3),PCEFLIST IS A LIST SPECIFIED 36140020 BZ KEYWDRS2 IF NO DON'T BACK UP 36150020 SPACE 36160020 SPACE 36170020 MVC PDWORD(TWO),PCELEN+TWO(R3) ALIGN PCE LENGTH ON PROPER 36180020 * BOUNDARY 36190020 SPACE 36200020 * 36210020 ******** 36220020 ******** N O T E - ABOVE MVC AND TM ARE DEPENDENT ON THE LENGTH OF THE 36230020 ******** SUBFIELD PCE. 36240020 ******** 36250020 * 36260020 SPACE 36270020 */* P COMPUTE TRUE ADDRESS OF NEXT PCE */ 36272021 LH R2,PDWORD LOAD THE PCE LENGTH 36280020 LA R2,TWO(R3,R2) OBTAIN TRUE ADDRESS OF NEXT PCE 36290020 MVC PDWORD(ONE),PCEFLGB1(R2) ISOLATE FLAG BYTE ONE 36300020 NI PDWORD,HE0 ISOLATE THE TYPE INDICATOR BITS 36310020 */* D (YES,,NO,KEYWDRS2) IS IT AN END PCE */ 36312021 CLI PDWORD,EIGHT*(ENDB-MAINB) IS IT AN END PCE 36320020 BNE KEYWDRS2 IF NO BRANCH 36330020 SPACE 36340020 */* P INDICATE LEFT PAREN USED AS DELIMITER OF SUBF AND LIST */ 36342021 OI PFLAGS3,PFMORE INDICATE LEFT PAREN USED AS 36350020 * DELIMITER OF SUBFIELD AND 36360020 * LIST 36370020 */* P BACK UP OVER LEFT PAREN */ 36372021 BCTR XINPUT,ZERO BACK UP OVER LEFT PARENTHESIS 36380020 SPACE 36390020 */*KEYWDRS2: P INDICATE KEYWORD WITH SUBFIELD */ 36392021 KEYWDRS2 DS 0H * * * * 36400020 LR R2,R3 SET PCE PTR FOR RECURSE ROUTINE 36410020 * XPCE WILL BE SET TO NEXT PCE 36420020 * IN RECURSE ROUTINE 36430020 OI RFLAGS,RFKEYWDS INDICATE KEYWORD WITH SUBFIELD 36440020 */* S REUCRSE: PROCESS SUBFIELD */ 36442021 BAL LINK1,RECURSE PROCESS SUBFIELD 36450020 SPACE 36460020 */* D (,KEYWDINS) SCAN NEXT KEYWORD */ 36462021 B KEYWDINS SCAN NEXT KEYWORD 36470020 SPACE 36480020 */*KEYWDRPT: P GET ADDRESS FOR ERASE PDE */ 36482021 KEYWDRPT DS 0H * * * * 36490020 OI RFLAGS,RFERASE SET ERASE IN PROCESS FLAG 36500020 LA R0,KEYWDFN0 SET RETURN ADDRESS FROM ERASE TO 36510020 ST R0,RLINKSV1 BE ADDRESS FOR NEW KEYWORD 36520020 LR R2,R3 PICK UP ADDRESS FOR ERASE PDE 36530020 L XPCE,PKEYWDPX PICK UP PCE ADDRESS FOR IKJKEYWD 36540020 */* D (,KEYWDER4) START ERASE */ 36542021 B KEYWDER4 START ERASE 36550020 SPACE 36560020 */*KEYWDXIT: D (YES,ILLKEYWD,NO,) NO MATCHES FOUND */ 36562021 KEYWDXIT DS 0H * * * * 36570020 * M2574 36570420 LA R0,ONE GET NUMBER OF VALID MATCHES 36572020 CR R14,R0 HOW MANY MATCHES FOUND M2574 36574020 BL ILLKEYWD NONE, INVALID KEYWORD M2574 36576020 SPACE 36576420 */* D (YES,KEYWDAMB,NO,) MORE THAN ONE MATCH FOUND */ 36576821 BH KEYWDAMB MORE THAN ONE, AMBIGIOUS M2574 36578020 SPACE 36578120 */* D (,KEYWDFN1) ONLY ONE - PROCESS IT */ 36578221 B KEYWDFN1 ONE, PROCESS IT M2574 36578420 SPACE 36578820 */*KEYWDXI2: P RESTORE ENTRY PCE ADDRESS */ 36628821 KEYWDXI2 DS 0H * * * * 36630020 L XPCE,RKEYSV RESTORE ENTRY PCE ADDRESS 36640020 */* D (,NEXTPCE) GET NEXT PCE */ 36642021 B NEXTPCE GET NEXT PCE. 36650020 SPACE 36660020 * 36670020 * AN AMBIGOUS MESSAGE IS ISSUED IF MORE THAN ONE MATCH IS FOUND. 36680020 * THIS IS DONE USING THE SAME INVALID PROCESSING TO KEEP THE 36690020 * HANDLING OF INVALID DATA CONSISTENT. SOME SPECIAL HANDLING IS DONE 36700020 * WITH REGARD TO THE MSG SEGMENTS SINCE THE FORMAT OF THE MSG IS 36710020 * DIFFERENT. 36720020 * 36730020 */*KEYWDAMB: P INDICATE AMBIGUOUS MSG TO BE WRITTEN */ 36732021 KEYWDAMB DS 0H * * * * 36740020 MVI MSGCODE,MSG4 INDICATE AN AMBIGUOUS MSG 36750020 * SHOULD BE WRITTEN 36760020 */* D (,ILLKAMB1) BRANCH TO ILLKEYWD PROCESSING */ 36770021 B ILLKAMB1 BRANCH TO ILLKEYWD PROCESSING 36780020 SPACE 36782020 * 36784020 * THE FIRST CHARACTER OF A KEYWORD IS INVALID. CHECK IF IT IS THE M3337 36786020 * CLOSING PAREN OF A SUBFIELD OR A SEMICOLON. IF YES, EXIT THE M3337 36788020 * KEYWORD SCANNING. IF NO, PROCESS IT AS AN INVALID KEYWORD. M3337 36788420 * 36788820 */*KEYWDMIS: D (YES,KEYWDXI2,NO,) FIRST CHAR A SEMICOLON */ 36788921 KEYWDMIS DS 0H * * * * 36789220 LR R1,XINPUT SAVE XINPUT M3337 36789620 BCTR XINPUT,ZERO DECREMENT AS USUAL M3337 36789720 CLI ZERO(R1),SEMICOLN IS 1ST CHAR A SEMICOLON M3337 36789820 BE KEYWDXI2 YES, END OF KEYWORD SCAN M3337 36789920 */* D (YES,,NO,ILLKEYWD) SUBFIELD BEING PROCESSED */ 36791921 NC RBASESV,RBASESV IS A SUBFIELD BEING M3337 36793220 * PROCESSED M3337 36795220 BZ ILLKEYWD NO, IT IS AN INVALID KEYWD M3337 36795620 */* D (YES,KEYWDXI2,NO,ILLKEYWD) FIRST CHAR. A RIGHT PAREN */ 36795721 CLI ZERO(R1),RIGHTPRN IS 1ST CHAR A RT. PAREN M3337 36796020 BNE ILLKEYWD NO, IT IS AN INVALID KEYWD M3337 36796420 B KEYWDXI2 YES, IT IS THE CLOSING M3337 36796520 * PAREN OF A SUBFIELD M3337 36796620 * EXIT KEYWD SCAN M3337 36799920 EJECT 36803420 *********************************************************************** 36806720 * * 36810020 * PROMPT/DEFAULT SUBROUTINE * 36820020 * * 36830020 * DETERMINE IF A PROMPT OR DEFAULT WAS SPECIFIED BY THE CALLER, IF * 36840020 * NOT, RETURN +4. IF A DEFAULT WAS SPECIFIED PREPARE TO TREAT IT AS * 36850020 * IF IT WAS NEW DATA RECEIVED FROM A PROMPT. * 36860020 * IF A PROMPT IS REQUIRED, THE PROMPT DATA IS ADDED TO THE 'ENTER' * 36870020 * MESSAGE. * 36880020 * * 36890020 *********************************************************************** 36900020 SPACE 36910020 */*PROMPTQ: E PROMPT/DEFAULT ROUTINE */ 36912021 */*PROMPTZ: D (YES,,NO,PROMPTQ0) LIST IS BEING PROCESSED */ 36914021 PROMPTQ DS 0H PROMPT/DEFAULT ROUTINE 36920020 TM PFLAGS,PFLIST IS A LIST BEING PROCESSED 36930020 BZ PROMPTQ0 NO, CONTINUE WITH PROMPT/DEFAULT 36940020 SPACE 36950020 */* P GET ADDRESS OF DUMMY () */ 36952021 LA R0,LRPAREN+ONE GET ADDRESS OF DUMMY ( ) 36960020 * INSERTED BY PARSE WHEN KEY- 36970020 * WORD SPECIFYING SUBFIELD 36980020 * ENTERED WITHOUT SUBFIELD AND 36990020 * WHERE CURRENT SCAN PROCESSING 37000020 * COULD BE 37010020 */* D (YES,PROMPTQ0,NO,CODE4) PROCESSING THIS () */ 37012021 CR R0,XINPUT PROCESSING THIS ( ) 37020020 BE PROMPTQ0 YES, PROMPT/DEFAULT IF CAN 37030020 SPACE 37040020 B CODE4 IF NO BRANCH - THE FIRST 37050020 * CHARACTER OF CURRENT INPUT 37060020 * PARAMETER MUST BE INVALID FOR 37070020 * THE TYPE OF PARAMETER 37080020 * PRESENTLY BEING CHECKED FOR. 37090020 * IF A LIST IS BEING PROCESSED 37100020 * THIS PARAMETER IS TREATED AS 37110020 * AN INVALID PARAMETER, TO 37120020 * AVOID A LOOP FROM OCCURING. 37130020 SPACE 37140020 SPACE 37150020 */*PROMPTQ0: D (YES,PROMPTQY,NO,) PROMPT/DEFAULT IS SPECIFIED */ 37152021 PROMPTQ0 DS 0H * * * 37160020 TM PCEFLGB1(XPCE),PCEFPRPT+PCEFDFLT IS PROMPT OR DEFAULT 37170020 * SPECIFIED 37180020 */* R RETURN +4 */ 37182021 BZ FOUR(LINK1) NO RETURN +4 37190020 SPACE 37200020 TM PFLAGS5,INVPRMPT HAS PROMPTING BEEN DONE A45352 37200421 * PREVIOUSLY FOR THIS PARAMETER? 37200821 BO CODE4 YES,PROMPT WITH INVALID MESSAGE 37201621 * A45352 37201721 */*PROMPTQY: P SAVE RETURN ADDRESS */ 37202021 OI PFLAGS5,INVPRMPT INDICATE PROMPT FOR THIS PCE 37206021 * A45352 37208021 ST LINK1,PLINKSV1 SAVE RETURN ADDRESS 37210021 */* S PUSHI: PUSH STACK TO GET NEW INPUT */ 37212021 BAL LINK1,PUSHI PUSH STACK TO RECEIVE NEW INPUT 37220020 SPACE 37230020 */*PROMPTQ1: P GET PCE TYPE INDICATORS */ 37232021 PROMPTQ1 DS 0H ENTERED FROM WRITER2 ROUTINE TO 37240020 * USE DEFAULT IN PLACE OF A 37250020 * NULL LINE 37260020 */* D (NO,PROMPTQ2,YES,) PROCESSING COBOL PCE'S? */ 37260421 TM CBFLAGS1,COBOLMOD PROCESSING COBOL PCE'S? F41448 37262021 BZ PROMPTQ2 NO-CONTINUE NORMAL PARSE F41448 37264021 * IF IN COBOL MODE, SPECIAL F41448 37266021 * CODE REQUIRED TO POSITION F41448 37268021 * TO DEFAULT WITHIN THE F41448 37268421 * COBOL PCE'S F41448 37268821 */* D (YES,TERMPCE1,NO,) IS THE PCE TYPE A TERM PCE? */ 37268921 TM PCEFLGB1(XPCE),HA0 IF PCETYPE IS MIXED HERE, F41448 37269221 * MUST BE A TERM PCE F41448 37269621 BM TERMPCE1 PCETYPES ARE AS FOLLOWS: F41448 37269721 * TERM - 110 F41448 37269821 * OPER - 111 F41448 37269921 * RESERVED WORD - 101 F41448 37273221 */* P OPER OR RESERVED WORD PCE - PARM TYPE FIELD AT OFFSET +6 */ 37273621 MVC PDWORD(TWO),SIX(XPCE) IF OPER OR RESRVD WORD, F41448 37275221 * THE PARM TYPE FIELD IS AT F41448 37275621 * OFFSET 6. F41448 37276021 LH R2,PDWORD BUMP PASSED PARM TYPE F41448 37276421 LA R2,SIX(R2) FIELD F41448 37276521 */* D (NO,CHKDEFLT,YES,) IS THIS AN OPER PCE? */ 37277621 TM PCEFLGB1(XPCE),HE0 IF AN OPER PCE MUST BUMP F41448 37280021 * PASSED 8 BYTES OF OFFSET F41448 37280521 * FIELDS F41448 37282521 BM CHKDEFLT IF MIXE, IS A RSVWD WORD F41448 37282921 */* P (,CHKDEFLT) BUMP PASSED 8 BYTES OF OFFSET FIELDS */ 37283021 LA R2,EIGHT(R2) BUMP PASSED OFFSET FIELDS F41448 37283321 B CHKDEFLT BRANCH TO CHECK DEFAULT F41448 37283721 */*TERMPCE1: P TERM PCE - PARM TYPE FIELD AT OFFSET 7 */ 37283821 */* P (,CHKDEFLT) BUMP PASSED PARM TYPE FIELD IN TERM PCE */ 37283921 TERMPCE1 MVC PDWORD(TWO),SEVEN(XPCE) IF IS A TERM PCE, THE F41448 37284121 * PARM TYPE FIELD IS AT F41448 37284221 * OFFSET SEVEN F41448 37284321 LH R2,PDWORD BUMP PASSED PARM TYPE F41448 37285721 LA R2,SEVEN(R2) NOW POSITIONED AT DEFAULT F41448 37287721 B CHKDEFLT BRANCH TO CHECK DEFAULT F41448 37288121 PROMPTQ2 MVC PDWORD(ONE),PCEFLGB1(XPCE) MOVE TYPE INDICATORS 37288621 NI PDWORD,HE0 ISOLATE PCE TYPE INDICATORS 37290021 */*PROMPTQ2: D (YES,POSITPMT,NO,) IT IS AN IKJPOSIT PCE */ 37292200 CLI PDWORD,EIGHT*(POSITBB-MAINB) IS IT AN IKJPOSIT PCE 37296121 BE POSITPMT IF YES BRANCH 37300020 SPACE 37310020 */* D (YES,KEYWDPMT,NO,) IKJKEYWD PCE - IF NOT,MUST BE IKJIDENT */ 37312021 CLI PDWORD,EIGHT*(KEYWDB-MAINB) IS IT AN IKJKEYWD PCE 37320020 BE KEYWDPMT IF YES BRANCH 37330020 SPACE 37340020 * IT MUST BE AN IKJIDENT PCE 37350020 MVC PDWORD(TWO),PCEPARMT(XPCE) ALIGN PARAMETER TYPE LENGTH 37360020 * ON PROPER BOUNDARY 37370020 LH R2,PDWORD LOAD THE LENGTH 37380020 */* P GET PTR TO PROMPT/DEFAULT DATA */ 37382021 LA R2,PCEPARMT(R2) LOAD PTR TO PROMPT/DEFAULT DATA 37390020 */* D (YES,,NO,CHKDEFLT) MAXLNTH WAS SPECIFIED */ 37392021 TM PCEOPT(XPCE),PCEFMAXL WAS MAXLNTH SPECIFIED 37400020 BZ CHKDEFLT IF NO BRANCH 37410020 SPACE 37420020 */* P ADD ADDITIONAL BYTE */ 37422021 LA R2,ONE(R2) IF YES ADD AN ADDITIONAL BYTE 37430020 */* D (,CHKDEFLT) BRANCH TO MAIN STREAM */ 37432021 B CHKDEFLT BRANCH BACK TO MAIN STREAM 37440020 SPACE 37450020 */*KEYWDPMT: P LOAD PTR TO PROMPT/DEFAULT DATA */ 37452021 KEYWDPMT DS 0H * * * * 37460020 LA R2,PCEPDEO+TWO LOAD PTR TO PROMPT/DEFAULT DATA 37470020 */* D (,CHKDEFLT) BRANCH TO MAIN STREAM */ 37472021 B CHKDEFLT BRANCH BACK TO MAIN STREAM 37480020 SPACE 37490020 */*POSITPMT: P LOAD PTR TO PROMPT/DEFAULT DATA */ 37492021 POSITPMT DS 0H * * * * 37500020 LA R2,PCEPOST+ONE LOAD PTR TO PROMPT/DEFAULT DATA 37510020 SPACE 37520020 */*CHKDEFLT: D (YES,,NO,PROMPT) DEFAULT WAS SPECIFIED */ 37522021 CHKDEFLT DS 0H * * * * 37530020 AR R2,XPCE CALCULATE ACTUAL ADDRESS OF DATA 37540020 TM PCEFLGB1(XPCE),PCEFDFLT WAS A DEFAULT SPECIFIED 37550020 BNO PROMPT NO BRANCH TO PROMPT 37560020 */* D (YES,INVPARMS,NO,PROMPDFL) ALREADY BEEN TAKEN */ 37562021 TM PFLAGS,PFDEFLT YES,HAS IT BEEN TAKED 37570020 BZ PROMPDFL NO, BRANCH TO TAKE DEFAULT 37580020 B INVPARMS YES,DEFAULT INVALID CLEANUP AND 37590020 * EXIT 37600020 SPACE 37610020 * 37620020 * ISSUE PROMPT MESSAGE 'ENTER XXX'. 37630020 * 37640020 */*PROMPT: P GET LENGTH OF DATA */ 37642021 PROMPT DS 0H * * * * 37650020 XR R1,R1 ZERO REG FOR LENGTH PICKUP 37660020 IC R1,ZERO(R2) PICKUP LENGTH-1 OF PROMPT DATA 37670020 LA R1,FIVE(R1) GET SIZE OF CORE FOR MESSAGE SEG 37680020 * ONE PLUS FOUR FOR HEADER 37690020 LR R3,R1 SAVE CALCULATED LENGTH 37700020 */* S GETCORE: GET CORE FOR MESSAGE */ 37702021 BAL LINK1,GETCORE GET CORE FOR MESSAGE SEGMENT 37710020 SPACE 37720020 * CORE ADDRESS RETURNED IN R1 37730020 ST R1,SEGLIST+TWELVE STORE ADDRESS IN LIST OF SEGMENT 37740020 STH R3,ZERO(R1) STORE LENGTH INTO SEGMENT 37750020 MVI TWO(R1),ZERO SET FIRST BYTE OF OFFSET TO ZERO 37760020 MVI THREE(R1),OFFSET1 SET OFFSET TO LENGTH OF 'ENTER' 37770020 * MESSAGE 37780020 SH R3,H5 REDUCE LENGTH FOR 'EX' 37790020 LA R15,ONE(R2) GET START OF DATA ADDRESS 37800020 */* P MOVE TEXT TO SEGMENT */ 37802021 EX R3,BUILDSEG MOVE TEXT TO NEW SEGMENT 37810020 MVI MSGCODE,MSG1 INDICATE MESSAGE TO PRINT 37820020 L R1,ADRMSGC LOAD ADDRESS OF MESSAGE CSECT 37830020 L R1,MSG1(R1) LOAD ADDRESS OF MESSAGE SEGMENT 37840020 MVC PRIMSGID+FOUR(EIGHT),FOUR(R1) SAVE PRIMARY MESSAGE ID 37850020 * FOR HELP MESSAGES 37860020 */* P INDICATE TWO SEGMENT MESSAGE */ 37862021 LA R0,TWO INDICATE A TWO SEGMENT MESSAGE 37870020 ST R0,SEGLIST+FOUR STORE SEGMENT NUMBER FOR PRIMARY 37880020 * MESSAGE 37890020 */* D (,WRITER2A) BRANCH TO PROMPT */ 37892021 B WRITER2A BRANCH TO PROMPT WITH A TWO 37900020 * SEGMENT MESSAGE 37910020 SPACE 37920020 * 37930020 * A DEFAULT WAS SPECIFIED. 37940020 * 37950020 */*PROMPDFL: P INDICATE DEFAULT TAKEN */ 37952021 PROMPDFL DS 0H * * * * 37960020 OI PFLAGS,PFDEFLT INDICATE DEFAULT TAKEN 37970020 OI PFLAGS4,PFPDDATA INDICATE DEFAULT DATA PICKED UP 37980020 */* P POINT TO START AND END OF DEFAULT DATA */ 37982021 LA XINPUT,ONE(R2) POINT TO START OF DEFAULT TEXT 37990020 ST XINPUT,PPOINTR SAVE FOR FUTURE USE 38000020 XR R1,R1 CLEAR WORK REG. TO ZERO 38010020 */* P LOAD LENGTH OF DEFAULT DATA */ 38012021 IC R1,ZERO(R2) LOAD LENGTH OF DEFAULT TEXT - 1 38020020 LA R1,TWO(R1,R2) GET PTR TO END OF DEFAULT DATA 38030020 ST R1,ENDINPUT SAVE END OF DATA PTR 38040020 */* D (,NOTENTER) BACK UP AND BRANCH */ 38042021 BCT XINPUT,NOTENTER BACK UP AND BRANCH 38050020 SPACE 38060020 EJECT 38070020 *********************************************************************** 38080020 * * 38090020 * FORCE PUSHDOWN STACK POP SUBROUTINE * 38100020 * * 38110020 * REGISTER RESTRICTIONS - * 38120020 * R3 CANNOT BE USED BY THIS ROUTINE * 38130020 * * 38140020 *********************************************************************** 38150020 SPACE 38160020 */*SCANF: E STACK POP ROUTINE */ 38162021 SCANF DS 0H * * * * 38170020 */*SCANF9: P POINT TO NEXT CHARACTER */ 38172021 LA R0,ONE(XINPUT) POINT TO NEXT SCANX CHARACTER 38180020 SPACE 38190020 */*SCANF1: D (YES,SCANDLSN,NO,) REACHED END */ 38192021 SCANF1 DS 0H * * * * 38200020 C R0,ENDINPUT SEE IF SCANX OFF THE END 38210020 */* R RETURN */ 38212021 BL FOUR(LINK1) NO, GOOD FOR USE - RETURN +4 38220020 SPACE 38220420 */*SCANDLSN: D (YES,SCANDSY,NO,) STACK IS TO BE POPPED */ 38230421 SCANDLSN DS 0H * * * * 38240020 TM PFLAGS4,PFNOPOP IS STACK TO BE POPPED M0911 38242020 */* R RETURN - DON'T POP */ 38242421 BNZ ZERO(LINK1) NO, DON'T POP M0911 38244020 */*SCANDSY: D (YES,SCANPOP,NO,) ANYTHING ON INPUT STACK */ 38246021 CLI PIPDLX,ZERO ANYTHING ON INPUT STACK 38250020 BNZ SCANPOP YES - POP ONE LEVEL 38260020 SPACE 38270020 L R1,PIPDLCUR LOAD PTR TO CURRENT STACK 38280020 */* D (YES,,NO,SCANPOP2) FIRST STACK IN CHAIN */ 38282021 NC ONE(THREE,R1),ONE(R1) IS THIS FIRST STACK IN CHAIN 38290020 BNZ SCANPOP2 IF NO BRANCH 38300020 SPACE 38310020 OI PFLAGS,PFENDF SET END-OF-FILE INDICATOR 38320020 NI PFLAGS4,HFF-PFSLASH INDICATE SLASH SCAN M3098 38330020 * COMPLETE AND NO DECREMENT 38334020 */* R RETURN - ERROR +0 */ 38336021 BR LINK1 ERROR RETURN +0 38340020 SPACE 38350020 */*SCANPOP: D (NO,SCANPOP3,YES,) PROCESSING COBOL PCE'S? */ 38350421 */* D (YES,SCANF2,NO,SCANPOP4) HAS STACK BEEN POPPED ONCE? */ 38350821 */*SCANPOP3: D (YES,,NO,SCANF2) END OF INPUT ON PROMPT/DEFAULT DATA */ 38352021 */* D (YES,,NO,SCANF2) SCAN FOR POSSIBLE PASSWORD */ 38354021 SCANPOP DS 0H * * * * 38360021 TM CBFLAGS1,COBOLMOD PROCESSING COBOL PCE'S F41448 38362021 BZ SCANPOP3 NO-CONTINUE NORMAL PARSE F41448 38364021 TM CBFLAGS2,BUFPOPED HAS STACK BEEN POPPED F41448 38366021 * ONCE? F41448 38368021 BZ SCANPOP4 IF NOT, SET UP PFENDSET F41448 38368421 B SCANF2 IF YES, DON'T SET PFENDSETF41448 38368821 SCANPOP3 TM PFLAGS4,PFPDDATA+PFSLASH END OF INPUT ON PROMPT/DEFAULT 38370021 * DATA OR IS SCAN FOR POSSIBLE 38380020 * PASSWORD 38390020 BZ SCANF2 NO, CONTINUE 38400020 SPACE 38410020 */*SCANPOP4: P INDICATE ENDINPUT BAKUP IS SET (PFENDSET) */ 38412000 SCANPOP4 OI PFLAGS4,PFENDSET INDICATE ENDINPUT BAKUP IS SET 38420021 */* P SAVE END OF PROMPT/DEFAULT DATA */ 38422021 MVC ENDBAKUP,ENDINPUT SAVE END OF PROMPT/DEFAULT DATA 38430020 * FOR POSSIBLE INVALID MESSAGE 38440020 */* P INDICATE SCAN COMPLETE FOR SLASH OR PROMPT/DEFAULT DATA */ 38442021 NI PFLAGS4,HFF-PFPDDATA-PFSLASH INDICATE SCAN COMPLETE FOR 38450020 * SLASH OR PROMPT/DEFAULT DATA 38460020 SPACE 38470020 */*SCANF2: P GET INDEX TO NEXT EMPTY SLOT IN STACK */ 38472021 SCANF2 DS 0H * * * * 38480020 NI PFLAGS,HFF-PFENDF TURN OFF POSSIBLE END OF FIELD 38482020 * FLAG 38484020 XR R1,R1 ZERO WORK REGISTER 38490020 IC R1,PIPDLX GET INDEX TO NEXT EMPTY SLOT IN 38500020 * PUSHDOWN STACK 38510020 SH R1,H8 DECREMENT TO PREVIOUS LEVEL 38520020 STC R1,PIPDLX REPLACE THE INDEX 38530020 A R1,PIPDLCUR COMPUTE ADDRESS FOR RESTORE 38540020 LA R1,FOUR(R1) ACCOUNT FOR CHAIN WORD 38550020 */* P RESET POINTERS */ 38552021 MVC ENDINPUT,FOUR(R1) RESET END POINTER 38560020 L XINPUT,ZERO(R1) RESET SCAN POINTER 38570020 LR R0,XINPUT COPY SCAN POINTER FOR TEST AT 38590020 * SCANF1 38590420 */* D (NO,SCANF4,YES,) PROCESSING COBOL PCE'S? */ 38600421 */* P (,SCANF9) TURN BUFFER POPPED ONCE INDICATOR ON - BUFPOPED */ 38610421 TM CBFLAGS1,COBOLMOD PROCESSING COBOL PCE'S? F41448 38628321 BZ SCANF NO-CONTINUE NORMAL PARSE F41448 38638321 OI CBFLAGS2,BUFPOPED IF COBOL, TURN BUFFER F41448 38648321 * POPPED FLAG ON F41448 38658321 */*SCANF4: D (,SCANF9) REPEAT END OF DATA TEST */ 38666300 B SCANF REPEAT END OF DATA TEST M1647 38704221 SPACE 38742121 * 38780020 * DROP BACK TO PREVIOUS STACK IN CHAIN. 38790020 * 38800020 */*SCANPOP2: P DROP BACK TO PREVIOUS STACK */ 38802021 SCANPOP2 DS 0H DROP BACK TO PREVIOUS STACK 38810020 MVC PIPDLCUR+ONE(L'PIPDLCUR-ONE),ONE(R1) RESET CURRENT STACK 38820020 * PTR TO PREVIOUS STACK 38830020 LA R0,EIGHT*(IPDLMAXE)+FOUR LOAD STACK SIZE FOR FREEMAIN 38840020 SPACE 38850020 */* P ISSUE FREEMAIN TO FREE LAST INPUT STACK */ 38852021 FREEMAIN R,LV=(0),A=(1) FREE LAST INPUT PUSHDOWN STACK 38860020 SPACE 38870020 */* P RESET STACK INDEX */ 38872021 MVI PIPDLX,EIGHT*(IPDLMAXE) RESET PUSHDOWN STACK INDEX TO 38880020 * INDICATE A FULL STACK 38890020 */* D (,SCANPOP) POP THE STACK */ 38892021 B SCANPOP 38942000 EJECT 39850020 *********************************************************************** 39860020 * * 39870020 * SKIP BLANKS SUBROUTINE * 39880020 * * 39890020 * THE FUNCTION OF THIS ROUTINE IS TO SKIP BLANKS, COMMAS AND TABS IN* 39900020 * THE INPUT BUFFER. * 39910020 * UPON ENTRY - * 39920020 * XINPUT CONTAINS THE BUFFER ADDRESS * 39930020 * LINK2 CONTAINS THE RETURN ADDRESS * 39940020 * AN EXIT TO NSI +0 IS TAKEN IF THE END OF THE BUFFER HAS BEEN * 39950020 * REACHED. A RETURN TO NSI +4 INDICATES THE XINPUT ADDRESS POINTS TO * 39960020 * THE LAST SEPARATOR CHARACTER AND PPOINTR POINTS TO THE FIRST * 39970020 * NON-SEPARATOR CHARACTER. * 39980020 * * 39990020 *********************************************************************** 40000020 SPACE 40010020 */*SKIPB: E SKIP SEPARATORS SUBROUTINE */ 40012021 */*SKIPB2: P INCREMENT POINTER */ 40014021 SKIPB DS 0H SKIP SEPARATORS SUBROUTINE 40020020 LA XINPUT,ONE(XINPUT) BUMP INPUT PTR BY ONE 40030020 LR XINPUTB,XINPUT SET BACKUP REGISTER 40040020 */* D (YES,,NO,SKIPB1) REACHED END OF INPUT */ 40042021 C XINPUT,ENDINPUT END OF INPUT 40050020 BL SKIPB1 NO - BRANCH 40060020 SPACE 40070020 */* S SCANDLSN: TRY TO POP STACK */ 40072021 BAL LINK1,SCANDLSN NO, TRY TO POP PUSHDOWN STACK 40080020 * 40090020 */* D (YES,SKIPBX,NO,) END OF GROUP EXIT */ 40092021 B SKIPBX +0 RETURN - END-OF-GROUP EXIT 40100020 * 40110020 LA XINPUT,ONE(XINPUT) INCREMENT FOR DECREMENT M3337 40122020 */* D (NO,SKIPB1,YES,) PROCESSING COBOL PCE'S? */ 40122421 TM CBFLAGS1,COBOLMOD PROCESSING COBOL PCE'S? F41448 40124021 BZ SKIPB1 NO-CONTINUE NORMAL PARSE F41448 40126021 */* P SET XINPUTB = XINPUT IF IN COBOL MODE */ 40126421 LR XINPUTB,XINPUT IF YES, SET XINPUTB IN F41448 40128021 * CASE DATA IS NOT PRECEEDEDF41448 40128421 * BY BLANKS - PARS2 DEPENDS F41448 40128821 * ON SETTING OF XINPUTB F41448 40129221 SPACE 40130020 */*SKIPB1: D (YES,SKIPB2,NO,) CHARACTER IS BLANK,COMMA OR TAB */ 40132021 SKIPB1 DS 0H * * * * 40140020 CLI ZERO(XINPUT),BLNK IS IT A BLANK 40150020 BE SKIPB IF YES REPEAT LOOP 40160020 SPACE 40170020 CLI ZERO(XINPUT),COMMA IS IT A COMMA 40180020 BE SKIPB IF YES REPEAT LOOP 40190020 SPACE 40200020 CLI ZERO(XINPUT),TABCHAR IS IT A TAB 40210020 BE SKIPB IF YES REPEAT LOOP 40220020 SPACE 40230020 */* P STORE ADDRESS OF NON-SEPARATOR */ 40232021 ST XINPUT,PPOINTR STORE ADDRESS OF NON-SEPARATOR 40240020 */* R BACK UP SCAN PTR BY ONE AND RETURN +4 */ 40242021 BCT XINPUT,FOUR(LINK2) BACK UP INPUT PTR BY ONE AND 40250020 * RETURN TO NSI +4 40260020 SPACE 40270020 */*SKIPBX: P STORE ADDRESS */ 40272021 SKIPBX DS 0H * * * * 40280020 ST XINPUT,PPOINTR STORE ADDRESS 40290020 */* D (NO,DECEXIT,YES,) PROCESSING COBOL PCE'S? */ 40290121 TM CBFLAGS1,COBOLMOD PROCESSING COBOL PCE'S F41448 40290421 BZ DECEXIT NO-CONTINUE NORMAL PARSE F41448 40290821 */* R () DO NOT DECREMENT SCAN PTR BEFORE RETURN TO IKJPARS2 */ 40290921 BR LINK2 IF YES, DO NOT DECREMENT F41448 40291221 * XINPUT A SECOND TIME F41448 40291621 */*DECEXIT: R BACK UP SCAN PTR BY ONE AND RETURN +0 */ 40292000 DECEXIT BCTR XINPUT,LINK2 BACK UP INPUT PTR BY ONE AND 40300021 * RETURN TO NSI +0 40310020 EJECT 40320020 *********************************************************************** 40330020 * * 40340020 * PUSH INPUT STACK SUBROUTINE * 40350020 * * 40360020 * IN THIS ROUTINE THE INPUT STACK IS PUSHED- THE CURRENT STATUS OF * 40370020 * XINPUT AND ENDINPUT ARE SAVED IN THE STACK. * 40380020 * * 40390020 *********************************************************************** 40400020 SPACE 40410020 */*PUSHI: E PUSH INPUT STACK SUBROUTINE */ 40412021 PUSHI DS 0H PUSH INPUT STACK SUBROUTINE 40420020 */* D (YES,,NO,PUSHIX) CURRENT STATUS IS TO BE SAVED */ 40422021 TM PFLAGS,PFENDF IS CURRENT STATUS TO BE SAVED 40430020 BNZ PUSHIX NO DON'T PUSH STACK THEN 40440020 SPACE 40450020 */* D (YES,,NO,PUSHGET) ROOM LEFT IN CURRENT STACK */ 40452021 CLI PIPDLX,EIGHT*(IPDLMAXE) ANY ROOM IN CURRENT STACK 40460020 BNL PUSHGET NO - GET ANOTHER STACK 40470020 SPACE 40480020 * 40490020 * PUSH THE INPUT PUSHDOWN STACK. 40500020 * 40510020 */*PUSHIT: P PUSH THE STACK */ 40512021 PUSHIT DS 0H PUSH THE STACK 40520020 XR R15,R15 ZERO WORK REGISTER 40530020 IC R15,PIPDLX FETCH CURRENT AMOUNT OF INPUT 40540020 * STACK USED 40550020 LA R1,EIGHT(R15) BUMP INDEX FOR NEXT PUSH ATTEMPT 40560020 STC R1,PIPDLX STORE THE NEW INDEX 40570020 A R15,PIPDLCUR COMPUTE THE SAVE ADDRESS 40580020 ST XINPUT,FOUR(R15) SAVE SCAN PTR IN STACK 40590020 MVC EIGHT(L'ENDINPUT,R15),ENDINPUT SAVE END OF SCAN PTR IN 40600020 * STACK 40610020 SPACE 40620020 */*PUSHIX: P CLEAR END OF FILE INDICATOR */ 40622021 PUSHIX DS 0H * * * * 40630020 NI PFLAGS,HFF-PFENDF CLEAR END-OF-FILE INDICATOR 40640020 */* R RETURN TO CALLER */ 40642021 BR LINK1 RETURN TO CALLER 40650020 SPACE 40660020 * 40670020 * GET SPACE FOR ANOTHER INPUT PUSHDOWN STACK AND CHAIN IT TO THE 40680020 * PREVIOUS ONE. 40690020 * 40700020 */*PUSHGET: S GETCORE: GET CORE FOR PUSHDOWN STACK */ 40702021 PUSHGET DS 0H GET ANOTHER PUSHDOWN STACK 40710020 LA R1,EIGHT*(IPDLMAXE)+FOUR LOAD AMOUNT OF CORE NEEDED 40720020 LR R3,LINK1 SAVE RETURN REGISTER 40730020 BAL LINK1,GETCORE GET CORE FOR PUSHDOWN STACK 40740020 SPACE 40750020 LR LINK1,R3 RESTORE RETURN REGISTER 40760020 MVC ONE(THREE,R1),PIPDLCUR+ONE BACKCHAIN THE NEW STACK 40770020 */* P INDICATE NEW STACK IS NOW CURRENT ONE */ 40772021 ST R1,PIPDLCUR INDICATE NEW STACK IS NOW 40780020 * THE CURRENT ONE 40790020 MVI PIPDLX,ZERO RESET THE PUSHDOWN INDEX SO THAT 40800020 * FIRST SPACE IS USED 40810020 */* D (,PUSHIT) PUSH DOWN INTO NEW STACK */ 40812021 B PUSHIT PUSH DOWN INTO NEW STACK 40820020 EJECT 40830020 *********************************************************************** 40840020 * * 40850020 * SET UP TO PROCESS LIST SUBROUTINE * 40860020 * * 40870020 * THIS ROUTINE DOES VARIOUS SET UP WORK TO PROCESS A LIST. THE * 40880020 * RETURN ADDRESS IS IN LINK1. * 40890020 * * 40900020 *********************************************************************** 40910020 SPACE 40920020 */*LISTT: E LIST SET UP SUBROUTINE */ 40922021 LISTT DS 0H LIST SET UP SUBROUTINE 40930020 */* D (YES,LISTTY,NO,) LIST IS A LEGAL OPTION */ 40932021 TM PCEFLGB2(XPCE),PCEFLIST IS A LIST A LEGAL OPTION 40940020 */* R RETURN +4 */ 40942021 BZ FOUR(LINK1) IF NO RETURN +4 40950020 SPACE 40960020 */*LISTTY: D (YES,,NO,LISTTZ) ALREADY PROCESSING A LIST */ 40962021 TM PFLAGS,PFLIST ALREADY PROCESSING A LIST 40970020 */* R RETURN +4 */ 40972021 BO FOUR(LINK1) IF YES, RETURN +4 40980020 SPACE 40990020 */*LISTTZ: P INCREMENT SCAN PTR */ 40992021 ST LINK1,PLINKSV1 SAVE RETURN REGISTER 41000020 LA XINPUT,ONE(XINPUT) INCREMENT SCAN PTR BY ONE 41010020 LR XINPUTB,XINPUT SET BACKUP REGISTER 41020020 */* D (YES,,NO,LISTX) THIS IS A LIST */ 41022021 CLI ZERO(XINPUT),LEFTPRN IS THIS A LIST 41030020 BNE LISTX NO RETURN 41040020 SPACE 41050020 */* S SKIPB: SKIP SEPARATORS AFTER ( */ 41052021 ST XINPUT,INVPSAVE YES - SAVE PTR TO PAREN 41060020 * IN CASE IT IS INVALID 41070020 BAL LINK2,SKIPB SKIP SEPARATORS 41080020 * 41090020 */* D (YES,,NO,LISTERR) DATA RETURNED */ 41092021 B LISTERR +0 RETURN - NO DATA IN LIST 41100020 SPACE 41110020 * +4 RETURN - DATA TO SCAN 41120020 LA XINPUT,ONE(XINPUT) BUMP TO NEXT CHARACTER FOR LATER 41130020 * DECREMENT 41140020 */* P INDICATE PROCESSING A LIST */ 41142021 OI PFLAGS,PFLIST INDICATE PROCESSING A LIST 41150020 SPACE 41160020 */*LISTX: R REDUCE SCAN PTR BY ONE AND RETURN +4 */ 41162021 LISTX DS 0H * * * * 41170020 L LINK1,PLINKSV1 RESTORE RETURN ADDRESS 41180020 BCT XINPUT,FOUR(LINK1) REDUCE SCAN PTR BY ONE AND 41190020 * RETURN +4 TO CALLER 41200020 */*LISTERR: P POINT TO INVALID PARAMETER */ 41202021 LISTERR DS 0H * * * * 41210020 L LINK1,PLINKSV1 RESTORE RETURN ADDRESS 41220020 MVC PPOINTR,INVPSAVE SET PTR TO INVALID PARM 41230020 */* R RETURN +0 */ 41232021 BR LINK1 RETURN +0 - ERROR 41240020 EJECT 41250020 * * ** * 41260020 * * 41270020 * RANGE SUBROUTINE * 41280020 * * 41290020 * * 41300020 * THIS ROUTINE DOES VARIOUS SET UP WORK TO PROCESS A RANGE. * 41310020 * A RETURN CODE OF +0 SPECIFIES THAT THE RANGE OPTION IS 41320020 * 1)NOT VALID, 2)VALID BUT AN ERROR CONDITION IS DETECTED, 41330020 * 3)VALID OPTION BUT NOT SPECIFIED, 4)VALID RANGE PARAMETER TO BE 41340020 * CHECKED FOR VALID DELIMITER. 41350020 * A +4 RETURN CODE DENTOES THE FIRST VALUE OF A RANGE PARAMETER 41360020 * DETECTED 41370020 * THE RETURN ADDRESS IS IN LINK1. * 41380020 SPACE 41390020 */*RANGE: E RANGE SET UP ROUTINE */ 41392021 RANGE DS 0H RANGE SET UP ROUTINE 41400020 */* D (YES,RANGEY,NO,) RANGE IS A LEGAL OPTION */ 41402021 TM PCEFLGB2(XPCE),PCEFRNGE IS A RANGE A LEGAL OPTION 41410020 */* R RETURN +0 */ 41412021 BCR CC8,LINK1 IF NO, RETURN +0 (1) 41420020 SPACE 41430020 */*RANGEY: D (YES,,NO,VALUE1) A RANGE IS ALREADY BEING PROCESSED */ 41432021 TM PFLAGS2,RNGEVAL1 ARE WE ALREADY PROCESSING A 41440020 * RANGE PARAMETER 41450020 BZ VALUE1 NO, BRANCH 41460020 SPACE 41470020 */* D (YES,,NO,RANGEZ) THIS IS RANGE DELIMITER (:) */ 41472021 CLI ZERO(XINPUT),COLON IS THES A RANGE DELIMITER 41480020 */* R RETURN +0 */ 41482021 BCR CC8,LINK1 YES, ERROR, RETURN CODE OF +0(2) 41490020 SPACE 41500020 */*RANGEZ: P TURN ON BIT FOR SECOND VALUE OF RANGE */ 41502021 NI PFLAGS2,HFF-RNGEVAL1 TURN OFF CONTROL BIT FOR FIRST 41510020 * VALUE OF RANGE PARAMETER 41520020 OI PFLAGS2,RNGEVAL2 TURN ON CONTROL BIT FOR SECOND 41530020 * VALUE OF RANGE PARAMETER 41540020 */* R RETURN +4 */ 41542021 BR LINK1 RETURN (4) 41550020 SPACE 41560020 */*VALUE1: D (YES,RANGEW,NO,) THIS IS RANGE DELIMITER (:) */ 41562021 VALUE1 DS 0H * * * * 41570020 CLI ZERO(XINPUT),COLON IS THIS A RANGE DELIMITER 41580020 */* R RETURN +0 */ 41582021 BCR CC7,LINK1 NO, BRANCH (3) 41590020 SPACE 41600020 */*RANGEW: P INDICATE PROCESSING A RANGE */ 41602021 OI PFLAGS2,RNGEVAL1 INDICATE PROCESSING A RANGE 41610020 LA XINPUT,ONE(XINPUT) TEMPORARILY INCREMENT SCAN REG 41620020 * DECREMENTED BEFORE EXITING 41630020 */* R RETURN +4 */ 41632021 B FOUR(LINK1) RETURN +4 41640020 EJECT 41650020 *********************************************************************** 41660020 * * 41670020 * CONDITIONAL GETMAIN SUBROUTINE 41680020 * 41690020 * A CONDITIONAL GETMAIN IS ISSUED FOR THE AMOUNT OF SPACE REQUESTED * 41700020 * FROM THE SUBPOOL INDICATED. IF THE REQUESTED SPACE CANNOT BE * 41710020 * ALLOCATED, A RETURN CODE OF 16 IS SET AND PROCESSING IS TERMINATED * 41720020 * VIA CLEANUP. * 41730020 * * 41740020 * ARG - R1=BYTE 0 SUBPOOL NUMBER * 41750020 * BYTES 1-3 NUMBER OF BYTES * 41760020 * * 41770020 * OUT - R1=ADDRESS OF ALLOCATED SPACE 41780020 * * 41790020 * RETURN - LINK1 * 41800020 * * 41810020 * ERROR EXIT - CLEANUP * 41820020 * * 41830020 * REGISTER RESTRICTIONS - * 41840020 * R2 OR R3 CANNOT BE USED BY THIS ROUTINE * 41850020 * * 41860020 *********************************************************************** 41870020 SPACE 41880020 */*GETCORE: E GET STORAGE ROUTINE */ 41882021 GETCORE DS 0H GET STORAGE ROUTINE 41890020 */* P STORE LENGTH REQUESTED */ 41892021 ST R1,PGETLNTH PUT LENGTH REQUESTED IN GETMAIN 41900020 * PARAMETER LIST 41910020 MVC PGETMDSP+ONE(ONE),PGETLNTH MOVE SUBPOOL FROM LENGTH WORD 41920020 * TO GETMAIN PARM LIST 41930020 NI PGETLNTH,ZERO CLEAR SUBPOOL INDICATOR FROM 41940020 * LENGTH WORD 41950020 LA R1,PGETLIST PUT ADDR OF GETMAIN PLIST IN R1 41960020 SPACE 41970020 */* P ISSUE GETMAIN */ 41972021 GETMAIN EC,A=SUBRWORK,MF=(E,(1)) ISSUE CONDITIONAL GETMAIN 41980020 SPACE 41990020 */* D (YES,,NO,GETERROR) STORAGE WAS ALLOCATED */ 41992021 LTR R15,R15 WAS STORAGE ALLOCATED 42000020 BNZ GETERROR NO, PROCESS ERROR 42010020 SPACE 42020020 */* P SAVE ADDR OF AREA */ 42022021 L R1,SUBRWORK YES, PUT ADDR OF AREA IN R1 42030020 LA R1,ZERO(R1) CLEAR HIGH ORDER BYTE 42040020 */* R RETURN TO CALLER */ 42042021 BR LINK1 RETURN TO CALLER 42050020 SPACE 42060020 */*GETERROR: P SET RETURN CODE */ 42062021 GETERROR DS 0H * * * * 42070020 MVI RETCODE,RCNOCORE OTHERWISE - REPLACE 42080020 */* D (,CLEANUP) GO CLEANUP */ 42082021 B CLEANUP GO CLEANUP AND RETURN 42090020 EJECT 42100020 *********************************************************************** 42110020 * * 42120020 * CHARACTER TYPE TEST UTLITY ROUTINE * 42130020 * * 42140020 * THIS SUBROUTINE CHECKS THE CURRENT INPUT CHARACTER FOR THE * 42150020 * CHARACTER TYPE GIVEN IN R1. IF THE SPECIFIED CHARACTER TYPE IS * 42160020 * FOUND RETURN IS TO LINK1+4. OTHERWISE RETURN IS TO LINK1. * 42170020 * * 42180020 *********************************************************************** 42190020 SPACE 42200020 */*TYPETEST: E CHARACTER TEST ROUTINE */ 42202021 TYPETEST DS 0H CHARACTER TEST ROUTINE 42210020 XR R15,R15 CLEAR WORK REG 42220020 */* P USE CURRENT CHAR AS OFFSET INTO TABLE */ 42222021 IC R15,ZERO(XINPUT) USE CURRENT CHAR AS OFFSET INTO 42230020 * TESTAB 42240020 A R15,ATRTAB GET ADDRESS IN TABLE 42250020 */* P EXECUTE TEST UNDER MASK FOR CHARACTER */ 42252021 EX R1,TYPETM EXECUTE TEST UNDER MASK OF 42260020 * TYPEBYTE FOR CHAR 42270020 * SPECIFICATION GIVEN IN R1 42280020 */* D (YES,,NO,TESTA) TYPE MATCHES */ 42282021 */* R RETURN TO CALLER +4 */ 42284021 */*TESTA: R RETURN TO CALLER +0 */ 42286021 BC CC5,FOUR(LINK1) TYPE MATCHES, RETURN +4 42290020 BR LINK1 TYPE DOESN'T MATCH,RETURN +0 42300020 EJECT 42310020 *********************************************************************** 42320020 * * 42330020 * INFORMATIONAL MESSAGE SUBROUTINE * 42340020 * * 42350020 * THIS ROUTINE USES PUTLINE TO WRITE INFORMATIONAL MESSAGES TO THE * 42360020 * TERMINAL USER. * 42370020 * UPON ENTRY THE ENTERED DATA TO BE INSERTED IN THE MESSAGE MUST BE * 42380020 * BUILT INTO A SEGMENT AND THE ADDRESS OF THE SEGMENT STORED INTO * 42390020 * SEGLIST + EIGHT. THE RETURN ADDRESS MUST BE IN LINK1. * 42400020 * * 42410020 *********************************************************************** 42420020 SPACE 42430020 */*WRITER1: E WRITE INFORMATIONAL MESSAGE */ 42432021 WRITER1 DS 0H WRITE INFORMATIONAL MESSAGE 42440020 */* P INDICATE NO HELP MESSAGES */ 42442021 MVC SEGLIST(L'ENDCHAIN),ENDCHAIN INDICATE NO HELP MESSAGES 42450020 SPACE 42460020 */*WRITER1C: P INDICATE TWO SEGMENT MSG */ 42462021 WRITER1C DS 0H * * * * 42470020 LA R15,TWO INDICATE ONLY TWO SEGMENT MSG 42480020 */* D (YES,,NO,WRITER1A) INVALID IDENT MSG BEING WRITTEN */ 42482021 CLI MSGCODE,MSG6 IS AN INVALID IDENT MSG BEING 42490020 * WRITTEN 42500020 BNE WRITER1A IF NO BRANCH 42510020 SPACE 42520020 */* P SWAP LAST TWO SEGMENTS */ 42522021 XC SEGLIST+TWELVE(FOUR),SEGLIST+SIXTEEN SWAP THE LAST 42530020 XC SEGLIST+SIXTEEN(FOUR),SEGLIST+TWELVE TWO SEGMENT 42540020 XC SEGLIST+TWELVE(FOUR),SEGLIST+SIXTEEN ADDRESSES 42550020 */* P INDICATE THREE SEGMENT MESSAGE */ 42552021 LA R15,THREE INDICATE A THREE SEGMENT MSG 42560020 */* D (YES,WRITER1F,NO,) COBOL PCE'S - SKIP PRINT INHIBIT MODE CHECKS 42562421 */**/ 42562821 TM CBFLAGS1,COBOLMOD PROCESSING COBOL PCE'S? F41448 42563921 BO WRITER1F YES, SKIP CHECKS FOR F41448 42565821 * PRINT INHIBIT MODE F41448 42567721 */* D (YES,,NO,WRITER1A) PRINT INHIBIT MODE DESIRED */ 42569600 TM PCEOPT(XPCE),PCEFPTBY PRINT INIBIT MODE DESIRED M1564 42571500 BZ WRITER1A NO,BRANCH M1564 42573400 */* P INDICATE MESSAGE TO WRITE */ 42575300 MVI MSGCODE,MSG18 INCICATE MESSAGE TO WRITE M1564 42577200 */* P INDICATE TWO SEGMENT MESSAGE */ 42579100 LA R15,TWO INDICATE TWO SEGMENT MSG M1564 42581000 B WRITER1F M1564 42582900 SPACE 42584800 */*WRITER1A: D (YES,WRITER1E,NO,) INVALID PASSWORD MSG BEING WRITTEN */ 42586700 WRITER1A DS 0H * * * * 42588600 CLI MSGCODE,MSG9 IS AN INVALID PASSWORD MSG 42590500 * BEING WRITTEN M1564 42592400 BE WRITER1E YES,BRANCH M1564 42594300 */*WRITER1F: P GET MESSAGE TO WRITE */ 42596200 WRITER1F ST R15,SEGLIST+FOUR STORE SEGMENT NUMBER IN LIST 42598100 IC R15,MSGCODE GET MESSAGE CODE 42600020 L R1,ADRMSGC LOAD ADDRESS OF MESSAGE CSECT 42610020 L R15,ZERO(R15,R1) POINT TO MESSAGE SEGMENT 42620020 ST R15,SEGLIST+EIGHT STORE PROTOTYPE MESSAGE PTR IN 42630020 * MESSAGE SEGMENT LIST 42640020 MVC PRIMSGID+FOUR(EIGHT),FOUR(R15) SAVE PRIMARY MESSAGE ID 42650020 * FOR HELP MESSAGES 42660020 L R15,PUTLPTR LOAD PUTLINE ADDRESS 42670020 SPACE 42680020 */* P ISSUE PUTLINE TO WRITE MESSAGE */ 42682021 PUTLINE PARM=PUTLINE,OUTPUT=(SEGLIST,MULTLVL),ENTRY=(15), *42690020 MF=(E,SRPARAMS) WRITE MESSAGE 42700020 SPACE 42710020 */* D (,PLRCACT) TAKE ACTION ON PUTLINE RETURN CODE */ 42712021 B PLRCACT TAKE APPROPRIATE ACTION FOR 42720020 * PUTLINE RETURN CODE 42730020 SPACE 42740020 * 42750020 * FREE SPACE OBTAINED FOR MESSAGE SEGMENT. THE EXECUTION OF THE 42760020 * FREEMAIN IS DEPENDENT ON THE RETURN CODE RETURNED FROM PUTLINE. 42770020 * 42780020 */*WRITER1D: P LOAD ADDRESS OF MESSAGE SEGMENT */ 42782021 WRITER1D DS 0H RETURN FROM RETURN CODE CHECKER 42790020 L R1,SEGLIST+TWELVE LOAD ADDRESS OF MESSAGE SEGMENT 42800020 */* D (YES,WRITER1G,NO,) INVALID IDENT MSG WRITTEN */ 42802021 CLI MSGCODE,MSG6 WAS AN INVALID IDENT MSG WRITTEN 42810020 BE WRITER1G IF YES,BRANCH M1564 42820020 */* D (YES,,NO,WRITER1B) INVALID IDENT MSG IN BYPASS MODE */ 42820421 CLI MSGCODE,MSG18 WAS INVALID IDENT MSG IN BYPASS 42822020 * MODE WRITTEN M1564 42822420 BNE WRITER1B IF NO BRANCH M1564 42822820 SPACE 42830020 */*WRITER1G: P LOAD ADDR OF CORE TO FREE */ 42832021 WRITER1G L R1,SEGLIST+SIXTEEN IF YES LOAD ADR. OF CORE TO FREE 42840020 SPACE 42850020 */*WRITER1B: P LOAD LENGTH OF MSG SEGMENT */ 42852021 WRITER1B DS 0H * * * * 42860020 LH R0,ZERO(R1) LOAD LENGTH OF MESSAGE SEGMENT 42870020 SPACE 42880020 */* P FREE THE STORAGE */ 42882021 FREEMAIN R,LV=(0),A=(1) FREE THE STORAGE 42890020 SPACE 42900020 */* R RETURN TO CALLER */ 42902021 BR LINK1 RETURN TO CALLING ROUTINE 42910020 */*WRITER1E: P INDICATE ONE SEGMENT MSG */ 42910421 WRITER1E LA R15,ONE INDICATE ONE SEGMENT MSG M1564 42912020 */* D (,WRITER1F) CONTINUE */ 42912421 B WRITER1F M1564 42914020 EJECT 42920020 *********************************************************************** 42930020 * * 42940020 * PROMPT MESSAGE SUBROUTINE * 42950020 * * 42960020 * THIS SUBROUTINE USES THE PUTGET I/O SERVICE ROUTINE TO PROMPT * 42970020 * FOR ANY MISSING OR INVALID PARAMETERS. A MAJOR PORTION OF THIS * 42980020 * SUBROUTINE IS DEVOTED TO THE HANDLING OF HELP MESSAGES. PARSE WILL * 42990020 * PASS THE HELP MESSAGES SUPPLIED BY THE CP ON EITHER THE IKJIDENT * 43000020 * OR IKJPOSIT MACROS ALONG WITH THE PRIMARY MESSAGE TO THE PUTGET * 43010020 * I/O SERVICE ROUTINE. EXTENSIVE USE IS MADE OF THE TEXT INSERTION * 43020020 * FEATURE OF THE I/O ROUTINES. * 43030020 * IF THE TERMINAL USER RESPONDED WITH A NULL LINE AND IF THE * 43040020 * PARAMETER IS REQUIRED, PROMPTING CONTINUES UNTIL A PARAMETER IS * 43050020 * ENTERED. IF NOT REQUIRED, AND A DEFAULT WAS SPECIFIED A EXIT TO * 43060020 * THE PROMPTQ ROUTINE IS TAKEN AND THE DEFAULT IS RETURNED AS NEW * 43070020 * DATA TO BE PARSED. IF NEITHER OF THE ABOVE, THE INPUT PUSHDOWN STACK* 43080020 * IS POPPED. * 43090020 * * 43100020 *********************************************************************** 43110020 SPACE 43120020 */*WRITER2: E PROMPT ROUTINE */ 43122021 WRITER2 DS 0H PROMPT ROUTINE 43130020 */* P INDICATE ONE WEGMENT MESSAGE */ 43132021 LA R0,ONE INDICATE A ONE SEGMENT MESSAGE 43140020 SPACE 43150020 */*WRITER2G: P STORE SEGMENT NUMBER FOR PRIMARY MSG */ 43152021 WRITER2G DS 0H ENTERED HERE WHEN OUTPUTING A 43160020 * TWO SEGMENT MESSAGE - R0 43170020 * CONTAINS SEGMENT NUMBER 43180020 ST R0,SEGLIST+FOUR STORE SEGMENT NUMBER FOR PRIMARY 43190020 * MESSAGE 43200020 ST LINK1,PLINKSV1 SAVE RETURN ADDRESS 43210020 */* S PUSHI: PUSH INPUT STACK */ 43212021 BAL LINK1,PUSHI ADD TO INPUT STACK 43220020 SPACE 43230020 */*WRITER2A: P GET MESSAGE CODE */ 43232021 WRITER2A DS 0H BRANCHED TO WHEN PROMPTING 43240020 * WITH ENTER MESSAGE - SEGMENT 43250020 * NUMBER STORED INTO SEGLIST + 43260020 * FOUR BY CALLER 43270020 XR R15,R15 CLEAR WORK REGISTER 43280020 STH R15,SAVLSLEN CLEAR SAVE AREA FOR CORE SIZE 43290020 * OBTAINED FOR HELP MESSAGES 43300020 IC R15,MSGCODE GET MESSAGE CODE 43310020 L R1,ADRMSGC LOAD ADDRESS OF MESSAGE CSECT 43320020 L R15,ZERO(R15,R1) POINT TO MESSAGE SEGMENT 43330020 ST R15,SEGLIST+EIGHT STORE PTR TO MESSAGE SEGMENT 43340020 MVC SEGLIST(L'ENDCHAIN),ENDCHAIN INDICATE NO HELP MESSAGES 43350020 SPACE 43360020 * 43370020 * PASS ALONG SECOND LEVEL HELP MESSAGES IF USER HAD ANY. 43380020 * 43390020 */* D (YES,,NO,WRITER2R) 2ND LEVEL MSG SUPPLIED BY VALIDITY CK */ 43392021 TM PFLAGS4,PFVCMSG HAS A SECOND LEVEL MESSAGE BEEN 43400020 * SUPPLIED BY A VALIDITY CHECK 43410020 BZ WRITER2R NO, CONTINUE PROCESSING 43420020 SPACE 43430020 LA R1,ONE LOAD THE NUMBER OF SECOND LEVEL 43450020 * MESSAGES AVAILABLE FROM A 43460020 * VALIDITY CHECK ROUTINE 43470020 L R2,VALMSG PICK UP ADDRESS OF MESSAGE SEG- 43480020 * MENT FOR PUTGET 43490020 */* D (,VCHELP) PROCESS MESSAGE */ 43492021 B VCHELP PROCESS MESSAGE 43500020 SPACE 43510020 */*WRITER2R: D (YES,,NO,WRITER2B) USER SPECIFIED HELP MSGS */ 43512021 WRITER2R DS 0H * * * 43520020 TM PCEFLGB1(XPCE),PCEFHELP DID THE USER SPECIFY HELP MSGS. 43530020 BZ WRITER2B BIT ZERO IF NO --- BRANCH 43540020 */* D (NO,WRITR2R1,YES,) PROCESSING COBOL PCE'S? */ 43540421 TM CBFLAGS1,COBOLMOD PROCESSING COBOL PCE'S? F41448 43542021 BZ WRITR2R1 NO-CONTINUE NORMAL PARSE F41448 43544021 */* D (YES,TERMPCE,NO,) IS THIS A TERM PCE? */ 43544421 */* P OPER OR RESERVED WORD - PARM TYPE AT OFFSET 6 */ 43544821 */* P BUMP PASSED PARM TYPE FIELD */ 43545221 TM PCEFLGB1(XPCE),HA0 IF MISED-KNOW IS A TERM F41448 43546021 * PCE. GO TO ROUTINE TO F41448 43548021 * POSITION TO TERM HELP F41448 43548421 * MESSAGES. F41448 43548821 BM TERMPCE GO TO ROUTINE TO POSIT- F41448 43548921 * ION TO TERM HELP MESSAGES F41448 43549021 MVC PDWORD(TWO),SIX(XPCE) IF NOT A TERM, OPER AND F41448 43549221 * RESRVD WORD PARM TYPE AT F41448 43549621 LH R15,PDWORD LOAD FOR INCREMENTING F41448 43549721 */* D (YES,NOMAXL, NO,) IS THIS AN OPER - POSITIONED AT P/D DATA */ 43549821 LA R15,SIX(R15) BUMP PASSED THE PAREMETER F41448 43549921 * TYPE FIELD IN THE PCE F41448 43550021 TM PCEFLGB1(XPCE),HE0 IF ALL THESE BITS ON - F41448 43553921 * KNOW THIS IS AN OPER PCE F41448 43555921 BM NOMAXL IF NOT, KNOW IS A RSVRD F41448 43557921 * WORD AND WE ARE POSIT- F41448 43558621 * IONED AT THE PROMPT/ F41448 43559021 * DEFAULT DATA F41448 43559421 */* P (,NOMAXL) IF OPER - BUMP PASSED 8 BYTES OF OFFSET FIELDS */ 43559521 LA R15,EIGHT(R15) IF AN OPER, MUST BUMP F41448 43559821 * PASSED 8 BYTES OF OFFSETS F41448 43559921 B NOMAXL BRANCH TO PROMPT/DEFAULT F41448 43563221 * PROCESSING F41448 43565221 */*TERMPCE: P (,NOMAXL) IF TERM - BUMP PASSED PARM TYPE FIELD */ 43565621 TERMPCE MVC PDWORD(TWO),SEVEN(XPCE) IF IS A TERM PCE, THE F41448 43566421 * PARM TYPE FIELD IS AT F41448 43566521 * OFFSET SEVEN F41448 43566621 LH R15,PDWORD ALLIGN FOR INCREMENTING F41448 43566721 LA R15,SEVEN(R15) INCREMENT PASSED THE PARM F41448 43567821 * TYPE FIELDS - NOW POINT- F41448 43569821 * ING AT LENGTH OF PROMPT/ F41448 43569921 * DEFAULT DATA F41448 43572721 B NOMAXL GOTO ROUTINE TO BYPASS F41448 43574721 * THE PRMPT/DEFLT DATA F41448 43575121 SPACE 43576000 */*WRITR2R1: D (YES,,NO,NOTREQ) IDENT PCE WITH PROMPT SPECIFIED */ 43578800 WRITR2R1 TM PCEFLGB1(XPCE),PCEFIDNT+PCEFPRPT IS THIS AN IKJIDENT PCE 43581600 * WITH PROMPT SPECIFIED 43584400 BZ NOTREQ IF NO FORGET TESTS FOR PRINT 43587200 * INHIBIT MODE 43590020 SPACE 43600020 */* D (YES,ALLOWHLP,NO,) PRINT INHIBIT MODE DESIRED */ 43602021 TM PCEOPT(XPCE),PCEFPTBY YES - ITS A REQUIRED PARAMETER 43610020 * BEING PROMPTED FOR. IS PRINT 43620020 * INHIBIT MODE DESIRED 43630020 BO ALLOWHLP IF YES BRANCH - ALLOW HELP 43640020 * MESSAGES 43650020 SPACE 43660020 */*NOTREQ: D (YES,WRITER2B,NO,) BYPASS MODE TO BE USED */ 43662021 NOTREQ DS 0H * * * * 43670020 TM PFLAGS,PFBYPAS IS BYPASS MODE TO BE USED 43680020 BO WRITER2B IF YES SKIP HELP MESSAGE SUPPORT 43690020 SPACE 43700020 */*ALLOWHLP: D (YES,POSITHLP,NO,) IKJPOSIT PCE */ 43702021 ALLOWHLP DS 0H * * * * 43710020 MVC PDWORD(ONE),PCEFLGB1(XPCE) ISOLATE PCE TYPE INDICATORS 43720020 NI PDWORD,HE0 CLEAR OTHER BITS IN BYTE 43730020 CLI PDWORD,EIGHT*(POSITBB-MAINB) IS IT AN IKJPOSIT PCE 43740020 BE POSITHLP IF YES BRANCH 43750020 SPACE 43760020 * IT MUST BE AN IKJIDENT PCE 43770020 */* P MUST BE IKJIDENT - LOAD TYPE LENGTH */ 43772021 MVC PDWORD(TWO),PCEPARMT(XPCE) ALIGN PARAMETER TYPE LENGTH 43780020 * ON PROPER BOUNDARY 43790020 LH R15,PDWORD LOAD THE LENGTH 43800020 LA R15,PCEPARMT(R15) BUMP PTR BY BASIC IKJIDENT SIZE 43810020 */* D (YES,,NO,NOMAXL) MAXLNTH WAS SPECIFIED */ 43812021 TM PCEOPT(XPCE),PCEFMAXL WAS MAXLNTH SPECIFIED 43820020 BZ NOMAXL IF NO SKIP ADDING ITS LENGTH 43830020 SPACE 43840020 */* P ADD LENGTH TO TOTAL */ 43842021 LA R15,ONE(R15) IF YES ADD LENGTH TO TOTAL 43850020 SPACE 43860020 */*NOMAXL: D (YES,,NO,HAVEHELP) PROMPT/DEFAULT DATA SPECIFIED */ 43862021 NOMAXL DS 0H * * * * 43870020 TM PCEFLGB1(XPCE),PCEFPRPT+PCEFDFLT WAS PROMPT/DEFAULT DATA 43880020 * SPECIFIED 43890020 BZ HAVEHELP IF ZERO NO --- BRANCH 43900020 SPACE 43910020 XR R14,R14 CLEAR WORK REGISTER 43920020 */* P LOAD LENGTH OF DATA */ 43922021 IC R14,ZERO(R15,XPCE) LOAD LENGTH - 1 OF DATA 43930020 LA R15,TWO(R15,R14) BUMP TOTAL BY LENGTH 43940020 */* D (,HAVEHELP) POSITIONED TO HELP MSGS */ 43942021 B HAVEHELP SHOULD BE POSITIONED TO HELP 43950020 * MESSAGES NOW 43960020 SPACE 43970020 */*POSITHLP: D (,NOMAXL) CHECK FOR PROMPT/DEFAULT DATA */ 43972021 POSITHLP DS 0H * * * * 43980020 LA R15,PCEPOST+ONE BUMP PTR BY BASIC IKJPOSIT 43990020 * LENGTH 44000020 B NOMAXL CHECK FOR PROMPT/DEFAULT DATA 44010020 SPACE 44020020 */*HAVEHELP: P GET NUMBER OF HELP MSGS */ 44022021 HAVEHELP DS 0H AT THIS POINT R15 SHOULD BE 44030020 * POSITIONED TO HELP MESSAGES 44040020 */* D (NO,HELPCONT,YES,) PROCESSING COBOL PCE'S */ 44040421 TM CBFLAGS1,COBOLMOD PROCESSING COBOL PCE'S F41448 44042021 BZ HELPCONT IF NOT CONTINUE F41448 44044021 */* D (NO,HELPCONT, YES,) IS IT A TERM PCE? */ 44044421 TM PCEFLGB1(XPCE),HA0 IF COBOL, IS IT A TERM F41448 44046021 BC CC9,HELPCONT IF NOT, CONTINUE F41448 44048021 */* D (NO,HELPCONT,YES,) IS RESVD WORD OR SUBSCRIPT SPECIFIED? */ 44048121 TM PCEFLGB2(XPCE),H18 IS RESVD WORD OR SUBS- F41448 44048421 * SCRIPT SPECIFIED? F41448 44048821 BC CC8,HELPCONT IF NOT, CONTINUE F41448 44049221 */* P INCREMENT PASSED THE OFFSET FIELDS FOR RSVWD WRD OR SUBSCRPT */ 44049321 BC CC4,UP2 IF ONLY ONE SPCEDIFIED, F41448 44049621 * INCREMENT R15 BY TWO F41448 44049721 LA R15,TWO(R15) IF BOTH SPECIFIED, INC- F41448 44049821 * REMENT R15 BY FOUR F41448 44049921 UP2 LA R15,TWO(R15) INCREMENT R15 BY TWO F41448 44053221 HELPCONT XR R1,R1 CLEAR WORK REGISTER 44056700 IC R1,TWO(R15,XPCE) LOAD NUMBER OF HELP MESSAGES 44060020 */*HELPCONT: P GET TRUE ADDR OF PCE HELP DATA */ 44062000 LA R2,THREE(R15,XPCE) SAVE TRUE ADDRESS OF PCE 44070020 * HELP DATA 44080020 SPACE 44090020 */*VCHELP: P VALID CHK SPCEIFIED 2ND LEVEL MSG */ 44092021 VCHELP DS 0H BRANCHED TO WHEN A VALIDITY 44100020 * CHECK ROUTINE SPECIFIED A 44110020 * SECOND LEVEL MESSAGE 44120020 LR R3,R1 SAVE NUMBER OF HELP MESSAGES FOR 44130020 * LOOP CONTROL 44140020 MH R1,LISTLEN MULTIPLY NUMBER OF MESSAGES BY 44150020 * AMOUNT OF STORAGE EACH MSG 44160020 * WILL TAKE 44170020 STH R1,SAVLSLEN SAVE CORE SIZE FOR FREEMAIN 44180020 */* S GETCORE: GET STORAGE FOR MSGS */ 44182021 BAL LINK1,GETCORE BRANCH TO GET STORAGE ROUTINE 44190020 SPACE 44200020 ST R1,SEGLIST SAVE PTR TO OBTAINED CORE 44210020 SPACE 44220020 * 44230020 * BUILD MULTI-LEVEL MESSAGE CHAIN IN THE OBTAINED CORE. THE FIRST WORD 44240020 * OF EACH ELEMENT POINTS TO THE NEXT ELEMENT, THE LAST ELEMENT POINTER 44250020 * CONTAINS X'FF000000'. THE SECOND WORD CONTAINS THE NUMBER OF SEGMENTS 44260020 * IN THE ELEMENT. THE THIRD WORD POINTS TO THE FIRST MESSAGE SEGMENT 44270020 * WHICH IS THE HELP MESSAGE ITSELF LOCATED IN THE PCE. THE LAST 44280020 * WORD POINTS TO THE SECOND MESSAGE SEGMENT WHICH IS THE WORD 'ENTER' 44290020 * WITH THE LAST PRIMARY MESSAGE ID AS A PREFIX. 44300020 * HELP MESSAGES ARE GENERATED BY THE IKJPOSIT AND IKJIDENT MACROS IN 44310020 * THE FOLLOWING FORM - 44320020 * 44330020 * ******************************************** 44340020 * / LENGTH / X'0000' / TEXT / 44350020 * ******************************************** 44360020 * 0 2 4 44370020 * 44380020 * SINCE THE MESSAGE ID/MESSAGE SEGMENT SEGMENT CONTAIN AN OFFSET OF 44390020 * ZERO INSERTED BEFORE THE HELP MESSAGE SEGMENT. IF IT WERE NOT DONE 44400020 * IN THIS MANNER THE WORD 'ENTER' COULD NOT BE REPLACED WITH 'MISSING' 44410020 * IF THE USER WAS IN NO-PROMPT MODE. 44420020 * 44430020 */*NEXTLIST: P STORE HELP MSG SEGMENT ADDR */ 44432021 NEXTLIST DS 0H * * * * 44440020 ST R2,EIGHT(R1) STORE THE HELP MESSAGE SEGMENT 44450020 * ADDRESS - HELP MESSAGE 44460020 * SEGMENTS ARE CONSTRUCTED BY 44470020 * THE PARSE MACROS 44480020 */* D (YES,,NO,WRITER2S) 2ND LEVEL MSG SUPPLIED BY VALID CHK */ 44480421 TM PFLAGS4,PFVCMSG HAS SECOND LEVEL MESSAGE BEEN 44482020 * SUPPLIED BY VALIDITY EXIT 44484020 BZ WRITER2S NO, CONTINUE 44486020 */* P TURN OFF INDICATOR */ 44486421 NI PFLAGS4,HFF-PFVCMSG YES, TURN OFF INDICATOR 44488020 LA R0,ONE LOAD THE NUMBER OF SEGMENTS 44488420 ST R0,FOUR(R1) STORE NUMBER IN ELEMENT 44488520 */* D (,WRITER2T) CONTINUE */ 44488621 B WRITER2T CONTINUE 44488820 SPACE 44489220 */*WRITER2S: P LOAD FIRST SEGMENT ADDR */ 44489321 WRITER2S DS 0H * * * * 44489620 LA R0,TWO LOAD THE NUMBER OF SEGMENTS 44490020 ST R0,FOUR(R1) STORE SEGMENT NUMBER IN ELEMENT 44500020 LA R0,PRIMSGID LOAD FIRST SEGMENT ADDRESS 44510020 */* P STORE IT IN ELEMENT */ 44512021 ST R0,TWELVE(R1) STORE IT IN ELEMENT 44520020 LA R0,LENMLLST(R1) GET PTR TO NEXT ELEMENT 44530020 ST R0,ZERO(R1) STORE PTR TO NEXT ELEMENT 44540020 LR R1,R0 BUMP INDEX REGISTER TO NEXT 44550020 * ELEMENT 44560020 MVC PDWORD(TWO),ZERO(R2) ALIGN LENGTH OF CURRENT HELP 44570020 * MESSAGE ON PROPER BOUNDARY 44580020 */* P POINT TO NEXT HELP MSG IF ANY */ 44582021 AH R2,PDWORD BUMP PCE PTR TO NEXT HELP 44590020 * MESSAGE IF ANY 44600020 */* P REDUCE HELP MSG COUNT */ 44602021 BCT R3,NEXTLIST REDUCE HELP MESSAGE COUNT AND 44610020 */* D (YES,,NO,NEXTLIST) LAST ONE */ 44612021 * BRANCH IF NOT LAST ONE --- IF 44620020 * LAST ONE WAS PROCESSED FALL 44630020 * THROUGH 44640020 SPACE 44650020 SH R1,LISTLEN REDUCE ELEMENT PTR TO POINT TO 44660020 * LAST ELEMENT 44670020 SPACE 44672020 */*WRITER2T: P INDICATE END OF CHAIN */ 44672421 WRITER2T DS 0H * * * * 44674020 MVC ZERO(L'ENDCHAIN,R1),ENDCHAIN INDICATE END OF CHAIN 44680020 SPACE 44690020 */*WRITER2B: D (YES,,NO,NOTIDPR) IKJIDENT PCE WITH PROMPT SPECIFIED */ 44692021 WRITER2B DS 0H BRANCHED TO TO REISSUE PROMPT 44700020 * MESSAGE OR BYPASS HELP MSGS. 44710020 L R15,PUTGPTR LOAD PUTGET ADDRESS 44720020 */* D (YES,NOTIDPR,NO,) IF COBOL MODE - NO TESTS FOR PRINT INHIBIT MODE 44720421 */* */ 44720821 TM CBFLAGS1,COBOLMOD ARE WE PROCESSING COBOL F41448 44722021 * PCE'S? F41448 44724021 BO NOTIDPR IF YES, FORGET TESTS FOR F41448 44726021 * PRINT INHIBIT MODE - GO F41448 44728021 * DIRECTLY TO WRITE OUT F41448 44728421 * MESSAGE F41448 44728821 TM PCEFLGB1(XPCE),PCEFIDNT+PCEFPRPT IS THIS AN IKJIDENT PCE 44730020 * WITH PROMPT SPECIFIED 44740020 BZ NOTIDPR IF NO FORGET TESTS FOR PRINT 44750020 * INHIBIT MODE 44760020 SPACE 44770020 */* D (YES,BYPASS,NO,) PRINT INHIBIT MODE DESIRED */ 44772021 TM PCEOPT(XPCE),PCEFPTBY YES - ITS A REQUIRED PARAMETER 44780020 * BEING PROMPTED FOR. IS PRINT 44790020 * INHIBIT MODE DESIRED 44800020 BO BYPASS IF YES BRANCH - ALLOW HELP 44810020 SPACE 44820020 */* D (YES,BYPASS,NO,) BYPASS MODE TO BE USED */ 44822021 TM PFLAGS,PFBYPAS IS BYPASS MODE TO BE USED 44830020 BO BYPASS IF YES BRANCH 44840020 SPACE 44850020 */*NOTIDPR: P ISSUE PUTGET */ 44852021 NOTIDPR DS 0H * * * * 44860020 PUTGET PARM=PUTGET,OUTPUT=(SEGLIST,MULTLVL),ENTRY=(15), *44870020 MF=(E,SRPARAMS) WRITE/READ OPERATION 44880020 SPACE 44890020 */*WRITER2C: D (,PGRCACT) TAKE ACTION FOR PUTGET RETURN CODE */ 44892021 WRITER2C DS 0H BRANCHED TO BY BYPASS ROUTINE 44900020 B PGRCACT TAKE APPROPRIATE ACTION FOR 44910020 * PUTGET RETURN CODE 44920020 SPACE 44930020 */*WRITER2J: D (YES,,NO,WRITER2K) 2ND VALUE OF RANGE BEING PROCESSED */ 44932021 WRITER2J DS 0H * * * * 44940020 SPACE 44950020 TM PFLAGS2,RNGEVAL2+RNGEVAL1 IS THE 2ND VALUE OF A RANGE 44952020 * BEING PROCESSED 44954020 BZ WRITER2K NO, CONTINUE 44956020 SPACE 44958020 * 44958420 * ERASE POSSIBLE 1ST HALF OF RANGE ALREADY IN THE PDE. RANGE IS 44958820 * ALLOWED ONLY FOR AN IDENT, ADDRESS, OR VALUE PCE. 44959220 * 44959620 XR R2,R2 CLEAR WORK REGISTER 44959720 */* P GET PDE SIZE FOR RANGE */ 44961721 IC R2,PPCOUNT GET PDE SIZE STORED BY 44964021 * ROUTINES WHICH PROCESS 44966021 * RANGES 44968021 MVC PDWORD(TWO),PCEPDEO(XPCE) ALIGN PDE OFFSET ON PROPER 44970021 * BOUNDARY 44972021 LH R3,PDWORD LOAD THE PDE OFFSET 44974021 A R3,XPDL GET TRUE ADDRESS OF PDE 44976021 */* P ERASE PDE */ 44977121 EX R2,ERASEXC ERASE THE PDE 44978021 SPACE 44980021 */*WRITER2K: P LOAD INPUT BUFFER RETURN ADDRESS */ 44980421 WRITER2K DS 0H * * * * 44982021 L R3,PUTGET+TWELVE LOAD INPUT BUFFER RETURN ADDRESS 44984021 MVC PDWORD(TWO),ZERO(R3) ALIGN LENGTH OF DATA ON PROPER 44986021 * BOUNDARY 44988021 */* D (YES,,NO,PROMPGO) RESPONSE IS NULL */ 44988421 CLC PDWORD(TWO),H4 IS THE RESPONSE NULL 44990020 BH PROMPGO IF NOT CONTINUE PROCESSING 45000020 SPACE 45010020 * 45020020 * NULL RESPONSE --- FREE PUTGETS BUFFER AND DETERMINE WHAT TO 45030020 * RETURN TO CALLER. 45040020 * 45050020 LR R1,R3 MOVE BUFFER ADDRESS 45060020 LH R0,PDWORD LOAD BUFFER SIZE 45070020 AL R0,SUBPOOLN ADD SUBPOOL NUMBER TO SIZE 45080020 SPACE 45090020 */* P ISSUE FREEMAIN TO FREE PUTGETS BUFFER */ 45092021 FREEMAIN R,LV=(0),A=(1) FREE BUFFER 45100020 SPACE 45110020 */*WRITER2D: D (YES,WRITER2F,NO,) PROMPTING FOR PASSWORD */ 45112021 WRITER2D DS 0H * * * * 45120020 * M0911 45120420 NI PFLAGS4,HFF-PFNOPOP TURN OFF POSSIBLE NOPOP FLAG 45122020 TM PFLAGS,PFBYPAS PROMPTING FOR A PASSWORD 45130020 BO WRITER2F IF YES BRANCH 45140020 SPACE 45150020 */* D (YES,YESLIST,NO,) PROCESSING LIST */ 45152021 TM PFLAGS,PFLIST IS A LIST BEING PROCESSED 45160020 BO YESLIST YES, CHECK FOR PROMPT/DEFAULT 45170020 */* D (YES,YESLIST,NO,) COBOL PCE'S - GOTO TEST FOR PROMPT/DEFAULT */ 45170421 TM CBFLAGS1,COBOLMOD PROCESSING COBOL PCE'S F41448 45172021 BO YESLIST IF YES, TEST FOR F41448 45174021 * PROMPT/DEFAULT F41448 45176021 SPACE 45180020 MVC PDWORD(ONE),PCEFLGB1(XPCE) MOVE TYPE INDICATORS 45190020 NI PDWORD,HE0 ISOLATE PCE TYPE INDICATORS 45200020 */* D (YES,WRITER2E,NO,) IKJKEYWD PCE */ 45202021 CLI PDWORD,EIGHT*(KEYWDB-MAINB) IS IT AN IKJKEYWD PCE 45210020 BE WRITER2E YES, DO NOT TEST FOR DEFAULT 45220020 SPACE 45230020 */*YESLIST: D (YES,WRITER2B,NO,) PARAMETER IS REQUIRED */ 45232021 YESLIST DS 0H * * * * 45240020 TM PCEFLGB1(XPCE),PCEFPRPT IS THE PARAMETER REQUIRED 45250020 BO WRITER2B IF YES BRANCH - REPEAT PROMPT 45260020 SPACE 45270020 */* D (YES,PROMPTQ1,NO,) IS THERE A DEFAULT */ 45272000 TM PCEFLGB1(XPCE),PCEFDFLT DOES PARAMETER HAVE A DEFAULT 45280020 BO PROMPTQ1 IF YES PASS BACK DEFAULT 45290020 */* D (YES,WRITER2F,NO,WRITER2E) PROCESSING COBOL PCE'S? */ 45290421 */* COMMENT (1,15) IF COBOL - GET */ 45290821 */* COMMENT (2,15) PFNULL ON */ 45291221 TM CBFLAGS1,COBOLMOD PROCESSING COBOL PCE'S? F41448 45292021 BO WRITER2F IF YES, SET PFNULL ON SO F41448 45294021 * WILL KNOW RECEIVED NULL F41448 45296021 * LINE FROM PROMPT F41448 45298021 SPACE 45300020 B WRITER2E NO --- POP STACK 45310020 SPACE 45320020 */*WRITER2F: P INDICATE NULL LINE ENTERED */ 45322021 WRITER2F DS 0H * * * * 45330020 OI PFLAGS3,PFNULL INDICATE A NULL LINE WAS ENTERED 45340020 SPACE 45350020 */*WRITER2E: S SCANF: RE-POP THE STACK */ 45352021 WRITER2E DS 0H * * * * 45360020 BAL LINK1,SCANDLSN RE-POP STACK M3337 45370020 * 45380020 NOP ZERO +0 RETURN 45390020 * 45400020 * +4 RETURN 45410020 */* D (YES,PROMPXIT,NO,) PROMPTING FOR PASSWORD */ 45412021 TM PFLAGS,PFBYPAS PROMPTING FOR A PASSWORD 45420020 BO PROMPXIT IF YES BRANCH --- EXIT 45430020 SPACE 45640020 */* D (YES,WRITER2H,NO,) PROCESSING LIST */ 45642021 TM PFLAGS,PFLIST IS A LIST BEING PROCESSED 45650020 BO WRITER2H IF YES CHECK FOR MORE LIST DATA 45660020 */* D (YES,WRITR2E1,NO,) PROCESSING COBOL PCE'S? */ 45660421 */* COMMENT (1,15) SKIP KEYWD */ 45660821 */* COMMENT (2,15) + ENDP TESTS */ 45661221 TM CBFLAGS1,COBOLMOD PROCESSING COBOL PCE'S? F41448 45662021 BO WRITR2E1 IF YES, SKIP OVER TEST F41448 45664021 * FOR KEYWRD AND ENDP PCE'S F41448 45666021 SPACE 45670020 MVC PDWORD(ONE),PCEFLGB1(XPCE) MOVE TYPE INDICATORS 45680020 NI PDWORD,HE0 ISOLATE PCE TYPE INDICATORS 45690020 */* D (YES,PROMPXIT,NO,) IKJKEYWD PCE */ 45692021 CLI PDWORD,EIGHT*(KEYWDB-MAINB) IS IT AN IKJKEYWD PCE 45700020 BE PROMPXIT YES - EXIT 45710020 SPACE 45720020 */* D (YES,PROMPXIT,NO,) IKJENDP PCE */ 45722021 CLI PDWORD,EIGHT*(ENDB-MAINB) IS IT AN IKJENDP PCE 45730020 BE PROMPXIT IF YES EXIT 45740020 SPACE 45750020 */*WRITR2E1: D (YES,,NO,WRITER2L) LIST SPECIFIED IN PCE */ 45752000 WRITR2E1 TM PCEFLGB2(XPCE),PCEFLIST IS LIST SPECIFIED IN PCE 45760000 BZ WRITER2L NO, EXIT NORMALLY 45770020 SPACE 45780020 */*WRITER2M: P STORE RETURN ADDRESS */ 45782021 WRITER2M DS 0H * * * * 45790020 LA R0,POSITX STORE POSITX - 45800020 ST R0,PLINKSV1 AS RETURN ADDRESS 45810020 */* D (,PROMPXIT) EXIT */ 45812021 B PROMPXIT EXIT WRITER2 45820020 SPACE 45830020 */*WRITER2L: P STORE RETURN ADDRESS */ 45832021 WRITER2L DS 0H * * * * 45840020 LA R0,POSITX3 STORE POSITX3 - 45850020 ST R0,PLINKSV1 AS RETURN ADDRESS - 45860020 */* D (,PROMPXIT) EXIT */ 45862021 B PROMPXIT AND EXIT. 45870020 SPACE 45880020 */*WRITER2H: S SKIPB: SKIP SEPARATORS */ 45882021 WRITER2H DS 0H * * * * 45890020 SPACE 45920020 BAL LINK2,SKIPB SKIP SEPARATORS 45930020 * 45940020 */* D (YES,,NO,WRITER2P) DATA TO SCAN */ 45942021 B WRITER2P +0 RETURN --- NO MORE DATA --- 45950020 * BRANCH TO POSITIONAL EXIT RTN 45960020 * 45970020 * +4 RETURN --- DATA TO SCAN 45980020 LA XINPUT,ONE(XINPUT) BUMP INPUT POINTER 45990020 */* D (YES,WRITER2P,NO,PROMPXIT) REACHED END OF THE LIST */ 45992021 CLI ZERO(XINPUT),RIGHTPRN IS THIS THE END OF THE LIST 46000020 BE WRITER2P IF YES TAKE POSITIONAL EXIT 46010020 SPACE 46020020 BCT XINPUT,PROMPXIT NO --- DECREMENT POINTER -- EXIT 46030020 SPACE 46040020 */*WRITER2P: D (YES,WRITER2N,NO,) AT LEAST ONE PDE WAS BUILT */ 46042021 WRITER2P DS 0H * * * * 46050020 TM PFLAGS3,PFONE WAS AT LEAST ONE PDE BUILT 46060020 * M0911 46062020 BO WRITER2N YES, THEN LIST PTR IS ALREADY 46070020 * SET - TAKE POSIT EXIT 46080020 SPACE 46090020 */* P TURN OFF LIST PTR */ 46092021 NI PFLAGS,HFF-PFLIST TURN OFF LIST PTR 46100020 */* D (,WRITER2M) GO TO SET UP LIST PTR */ 46102021 B WRITER2M NO, GO SET UP TO SET LIST PTR 46110020 SPACE 46120020 */*WRITER2N: D (YES,POSITX4,NO,) PROCESSING COBOL PCE'S? */ 46120121 */* D (YES,POSITX4,NO,) REACHED END OF INPUT */ 46120421 WRITER2N DS 0H * * * * 46122021 TM CBFLAGS1,COBOLMOD PROCESSING COBOL PCE'S? F41448 46122121 BO POSITX4 IF YES, DON'T DECREMENT F41448 46122221 * THE INPUT POINTER F41448 46122321 TM PFLAGS,PFENDF IS THIS THE END OF INPUT M3337 46122420 BNZ POSITX4 YES, DON'T DECREMENT M3337 46122820 */* P DECREMENT SCAN POINTER */ 46123221 */* D (,POSITX4) EXIT */ 46123621 BCT XINPUT,POSITX4 DECREMENT BEFORE EXIT M0911 46124020 SPACE 46126020 * 46130020 * DATA OBTAINED FROM THE PROMPT - MOVE IT TO PARSES CORE SO USER CAN 46140020 * USE IT. 46150020 * 46160020 */*PROMPGO: S STALOC: ALLOCATE SPACE TO COPY NEW DATA */ 46162021 PROMPGO DS 0H * * * * 46170020 LH R1,PDWORD LOAD LENGTH OF RETURNED DATA 46180020 LR R2,R1 SAVE LENGTH 46190020 SH R1,H4 TO ACCOUNT FOR HEADER 46200020 BAL LINK2,STALOC ALLOCATE SPACE TO COPY NEW DATA 46210020 SPACE 46220020 LR XINPUT,R1 SAVE PTR TO NEW DATA AREA 46230020 BCTR XINPUT,ZERO REDUCE ONE FOR FUTURE SCANX 46240020 SH R2,H5 REDUCE LENGTH OF NEW DATA BY 46250020 * LENGTH OF HEADER PLUS ONE 46260020 * FOR EXECUTE INSTRUCTION 46270020 LA R1,TWO(R2,XINPUT) GET NEW END ADDRESS 46280020 ST R1,ENDINPUT SAVE FOR SCANNING 46290020 * NEW DATA ADDRESS IN R3 46300020 */* P COPY NEW DATA TO PARSE STORAGE */ 46302021 EX R2,IOBMVC2 COPY NEW DATA TO PARSE STORAGE 46310020 SPACE 46320020 * 46330020 * FREE PUTGETS BUFFER. 46340020 * 46350020 LR R1,R3 MOVE BUFFER ADDRESS 46360020 LA R0,FIVE(R2) COMPUTE BUFFER SIZE 46370020 AL R0,SUBPOOLN ADD SUBPOOL NUMBER TO SIZE 46380020 SPACE 46390020 */* P ISSUE FREEMAIN TO FREE PUTGETS BUFFER */ 46392021 FREEMAIN R,LV=(0),A=(1) FREE BUFFER 46400020 SPACE 46410020 */* D (YES,,NO,PROMPXIT) SHOULD BLANKS BE SKIPPED */ 46412021 TM RFLAGS,RFNOSKIP SEE IF BLANKS SHOULD BE 46420020 * SKIPPED IN THE NEW BUFFER 46430020 BO PROMPXIT NO, (FLAG ON) - EXIT 46440020 SPACE 46450020 */* P INDICATE NOT TO POP STACK IF ALL BLANKS IN BUFFER */ 46450421 OI PFLAGS4,PFNOPOP DON'T POP STACK IF ALL M0911 46452020 * SEPARATORS IN PROMPT BUFFER 46454020 */* S SKIPB: SKIP SEPARATORS */ 46456021 BAL LINK2,SKIPB SKIP BLANKS IN NEW BUFFER 46460020 SPACE 46470020 */* D (YES,WRITER2D,NO,) ALL SEPARATORS IN BUFFER */ 46472021 B WRITER2D +0 RETURN - ALL SEPARATERS - 46480020 * REPROMPT 46490020 * 46500020 * +4 RETURN - EXIT 46510020 SPACE 46520020 NI PFLAGS4,HFF-PFNOPOP TURN OFF NOPOP FLAG M0911 46522020 */* P INDICATE PROMPT DATA PICKED UP */ 46524021 OI PFLAGS4,PFPDDATA INDICATE PROMPT DATA PICKED UP 46530020 * 46540020 * RETURN TO CALLER AFTER FREEING CORE OBTAINED FOR HELP MESSAGES 46550020 * AND 'ENTER' MESSAGE IF PREVIOUSLY OBTAINED. 46560020 * 46570020 */*PROMPXIT: D (YES,,NO,NOHELP) ANY HELP MSG STORAGE TO FREE */ 46572021 PROMPXIT DS 0H EXIT FROM PUTGET ROUTINE 46580020 NC SAVLSLEN,SAVLSLEN ANY HELP MESSAGE STORAGE TO FREE 46590020 BZ NOHELP IF NO BRANCH 46600020 SPACE 46610020 L R1,SEGLIST LOAD ADDRESS OF STORAGE 46620020 LH R0,SAVLSLEN LOAD SIZE OF STORAGE OBTAINED 46630020 SPACE 46640020 */* P ISSUE FREEMAIN TO FREE THE STORAGE */ 46642021 FREEMAIN R,LV=(0),A=(1) FREE THE STORAGE 46650020 SPACE 46660020 */*NOHELP: D (YES,YESENTER,NO,) 'ENTER' MSG WAS WRITTEN */ 46662021 NOHELP DS 0H * * * * 46670020 CLI MSGCODE,MSG1 WAS AN 'ENTER' MESSAGE WRITTEN 46680020 BE YESENTER IF YES BRANCH 46690020 SPACE 46700020 */* D (YES,,NO,NOTENTER) 'ENTER PASSWORD' MSG WAS WRITTEN */ 46702021 CLI MSGCODE,MSG15 WAS AN 'ENTER PASSWORD' MESSAGE 46710020 * WRITTEN 46720020 BNE NOTENTER IF NO BRANCH 46730020 SPACE 46740020 */*YESENTER: P ISSUE FREEMAIN TO FREE THE STORAGE */ 46742021 YESENTER DS 0H * * * * 46750020 L R1,SEGLIST+TWELVE LOAD ADDRESS OF STORAGE 46760020 LH R0,ZERO(R1) LOAD SIZE OF STORAGE OBTAINED 46770020 SPACE 46780020 FREEMAIN R,LV=(0),A=(1) FREE THE STORAGE 46790020 SPACE 46800020 */*NOTENTER: P TURN OFF POSSIBLE FLAGS FOR BYPASS AND RANGE */ 46802021 NOTENTER DS 0H * * * * 46810020 NI PFLAGS,HFF-PFBYPAS CLEAR POSSIBLE BYPASS FLAG 46820020 NI PFLAGS2,HFF-RNGEVAL1-RNGEVAL2 TURN OFF POSSIBLE RANGE 46830020 * FLAGS TO REMOVE POSSIBLE 46840020 * INVALID DATA IN PDE 46850020 L LINK1,PLINKSV1 LOAD RETURN ADDRESS 46860020 XR R1,R1 SET R1 TO BASIC PCE SIZE 46870020 IC R1,PPCOUNT FOR POSSIBLE USE BY POSITX 46880020 */* R RETURN +0 */ 46882021 BR LINK1 RETURN +0 46890020 SPACE 46900020 */*BYPASS: P ISSUE PUTGET */ 46902021 BYPASS DS 0H * * * * 46910020 PUTGET PARM=PUTGET,OUTPUT=(SEGLIST,MULTLVL,PTBYPS), *46920020 ENTRY=(15),MF=(E,SRPARAMS) WRITE/READ IN BYPASS MODE 46930020 SPACE 46940020 */* D (,WRITER2C) RETURN TO MAINLINE CODE */ 46942021 B WRITER2C RETURN TO MAINLINE CODE 46950020 EJECT 46960020 */*VCERTN: D (YES,VCERA,NO,) VALIDCHK EXIT WANTED */ 46962021 VCERTN DS 0H VALIDITY CHECK EXIT ROUTINE 46970020 TM PCEFLGB1(XPCE),PCEFVCHK IS A VALIDITY CHECK EXIT WANTED 46980020 BO VCERTN2 IF SO CONTINUE NORMAL F41448 46992021 * PARSE F41448 46994021 */*COBRET1: D (NO,VCRTN,YES,) PROCESSING COBOL PCE'S? */ 46994421 COBRET1 TM CBFLAGS1,COBOLMOD IF NO V.C. EXIT, CHECK TO F41448 46996021 * SEE IF PROCESSING COBOL F41448 46998021 * PCE'S F41448 46998421 BCR CC8,LINK1 NO - BIT ZERO - RETURN F41448 46998821 */*COBRET2: P CLEAR THE COBOL TEMPORARY PDE */ 46998921 */*VCRTN: R () RETURN */ 46999021 COBRET2 XC TEMPPDE(CBLTPDE),TEMPPDE IF IN COBOL MODE, CLEAR F41448 46999221 * THE TEMPORARY PDE F41448 46999621 BR LINK1 RETURN ON LINK1 F41448 46999721 SPACE 47000020 * M3318 47002020 */*VCERA: D (YES,VCERB,NO,) PDE CONTAINS DATA */ 47004021 VCERTN2 MVI DATAEXP,H00 CLEAR EXPRESSION ADDRESS FLAG 47010000 * IN TEMPPDE IN CASE NO DATA IS 47020020 * IN ADDRESS PDE 47030020 NI DATAFLG,HFF-EMPTYFLG TURN EMPTY FLAG BIT OFF A45355 47040421 NC TEMPPDE(LTPDE),TEMPPDE DOES THE PDE CONTAIN DATA? 47040821 */* R RETURN */ 47042021 BCR CC8,LINK1 IF NO BRANCH 47050020 SPACE 47060020 OI DATAFLG,EMPTYFLG TURN EMPTY FLAG BIT ON A45355 47060421 */*VCERB: P GET ADDR OF VALIDITY CHECK ROUTINE */ 47062021 MVC PDWORD(TWO),PCELEN(XPCE) ALIGN PCE LENGTH FIELD ON 47070020 * PROPER BOUNDARY 47080020 LH R15,PDWORD LOAD PCE LENGTH 47090020 SH R15,H3 GET ADDRESS OF VALIDITY CHECK 47100020 AR R15,XPCE ROUTINE ADDRESS 47110020 MVC PDWORD+ONE(THREE),ZERO(R15) ALIGN ADDRESS ON PROPER 47120020 * BOUNDARY 47130020 */* D (YES,,NO,INVPARMS) VALID ADDRESS - ON HALFWD BOUNDARY */ 47132021 TM PDWORD+THREE,H01 IS IT VALID ADDRESS - ON 47140020 * HALFWORD BOUNDARY 47150020 BO INVPARMS NO - BRANCH 47160020 SPACE 47170020 L R15,PDWORD LOAD ROUTINE ADDRESS 47180020 MVC VALMSG(L'ENDCHAIN),ENDCHAIN CLEAR VALIDITY CHECK MES- 47190020 * SAGE FIELD 47200020 LA R1,VCEPARAM LOAD PARAMETER LIST ADDRESS 47210020 */* P GO TO VALIDITY CHECK ROUTINE */ 47212021 BALR R14,R15 BRANCH TO VALIDITY CHECK ROUTINE 47220020 SPACE 47230020 */* D (YES,,NO,COBRET1) PROMPT IS REQUIRED */ 47232021 LTR R15,R15 IS A PROMPT REQUIRED 47240020 BZ COBRET1 IF ZERO RETURN , GO TO F41448 47252021 * NORMAL RETRUN ROUTINE F41448 47254021 */* D (NO,VCERC,YES,) IS IT THE SPECIAL COBOL RET - 16? */ 47254421 CH R15,H16 IF NOT ZERO RETURN, CHECK F41448 47256021 * TO SEE IF IT IS THE F41448 47258021 * SPECIAL COBOL RETURN F41448 47258421 * CODE = 16 F41448 47258821 BNE VCERTN3 IF NOT, CONTINUE PARSE F41448 47259221 */* D (YES,INVPARMS,NO,) HAVE WE RECEIVED A 16 RET BEFORE ON THIS PCE? 47259321 */**/ 47259421 TM CBFLAGS1,RC16 IF IS, HAVE WE GOTTEN F41448 47259621 * THIS RETURN BEFORE FOR F41448 47259721 * THIS DATA NAME F41448 47259821 BO INVPARMS IF SO, ERROR F41448 47259921 */* P TURN ON RET CODE 16 INDICATOR = RC16 FLAG */ 47261921 OI CBFLAGS1,RC16 IF NOT, TURN ON RET CODE F41448 47263921 * 16 INDICATOR F41448 47265921 */* D (NO,INVPARMS,YES,) ARE WE PROCESSING A CHAINED TERM OFF AN OPER? 47266321 */**/ 47266721 TM CBFLAGS2,CHAINTRM IF RC = 16, IS THIS A F41448 47267921 * CHAINED TERM PCE OFF AN F41448 47268621 * OPER PCE, IF NOT, A F41448 47269021 BZ INVPARMS R.C. OF 16 IS INVALID F41448 47269421 */* P LOAD RETURN ADDRESS INTO IKJPARS2 */ 47269521 */* R () RETURN TO IKJPARS2 ON +4 */ 47269621 L LINK2,CBLNKSV2 IF THE RET CODE 16 IS F41448 47269821 B FOUR(LINK2) VALID, BRANCH BACK TO F41448 47269921 * COBOL PROCESSORS ON +4 TO F41448 47273221 * INDICATE A 16 R.C. WAS F41448 47275221 * RECEIVED F41448 47275621 SPACE 47276800 */*VCERC: P ZERO THE PDE */ 47280100 VCERTN3 XR R1,R1 CLEAR REG TO HOLD PDE LENGTH 47283400 IC R1,PPDESIZE LOAD PDE LENGTH-1 47286700 L R3,PDEADR LOAD R3 WITH PDEADR STORED BY 47290020 * THE POSITIONAL EXIT ROUTINE 47300020 EX R1,ERASEXC ZERO THE PDE - IT MUST BE 47310020 * RECONSTRUCTED 47320020 */* P MOVE V.C. ERROR RETURN ADDRESS FOR RETURN TO IKJPARS2 */ 47320121 MVC GOREGSV(L'GOREGSV),PLINKSV2 F41448 47320421 * IF AN ERROR HAS BEEN RET- F41448 47320821 * URNED BY THE V.C. EXIT, F41448 47321221 * THE ERROR RETURN ADDRESS F41448 47321621 * INTO THE COBOL MACRO PRO- F41448 47321721 * CESSOR MUST BE STORED F41448 47321821 * INTO GOREGSV SO THAT F41448 47321921 * RETURN WILL BE AT THE F41448 47326421 * PROPER PLACE TO INDICATE F41448 47328421 * THAT THE V.C. EXIT RET- F41448 47330421 * URNED WITH AN ERROR F41448 47330821 */* D (YES,,NO,VCERTN1) PROCESSING A LIST */ 47331000 NC PREVPDEL,PREVPDEL IS A LIST BEING PROCESSED 47335500 BZ VCERTN1 IF NO BRANCH 47340020 SPACE 47350020 */* P INDICATE LAST PDE PROCESSED WAS LAST ONE IN CHAIN */ 47352021 L R14,PREVPDEL LOAD THE PREVIOUS PDE ADDRESS 47360020 MVC ZERO(L'ENDCHAIN,R14),ENDCHAIN INDICATE THE LAST PDE 47370020 * PROCESSED WAS THE LAST ONE IN 47380020 * THE CHAIN 47390020 SPACE 47400020 */*VCERTN1: D (YES,CODE4,NO,) SHOULD INVALID MSG BE WRITTEN */ 47402021 VCERTN1 DS 0H * * * * 47410020 CH R15,H4 SHOULD AN INVALID MESSAGE BE 47420020 * WRITTEN 47430020 BE CODE4 YES - FULL ERROR TREATMENT 47440020 SPACE 47450020 */* D (YES,VCERR,NO,) SHOULD PARSE QUIT */ 47452021 CH R15,H12 SHOULD PARSE QUIT 47460020 BE VCERR IF YES BRANCH 47470020 SPACE 47480020 */* D (YES,,NO,INVPARMS) SHOULD ONLY REENTER MSG BE WRITTEN */ 47482021 CH R15,H8 SHOULD ONLY REENTER MESSAGE BE 47490020 * WRITTEN 47500020 BNE INVPARMS IF NO ITS AN INVALID RETURN CODE 47510020 SPACE 47520020 */* P INDICATE TO PRINT ONLY REENTER MSG */ 47522021 OI PFLAGS2,PFSKPINV SET FLAG TO SKIP INVALID MESSAGE 47530020 * AND PRINT ONLY REENTER 47540020 * MESSAGE 47550020 L R15,ADRMSGC LOAD ADDRESS OF MESSAGE CSECT 47560020 L R15,MSG3(R15) LOAD ADDRESS OF REENTER MESSAGE 47570020 MVC PRIMSGID+FOUR(EIGHT),FOUR(R15) SAVE MESSAGE ID FOR HELP 47580020 * MESSAGES 47590020 */* D (YES,,NO,CODE4) HAS VALIDCHK RTN SUPPLIED HELP MSG */ 47592021 CLC VALMSG,ENDCHAIN HAS THE VALIDITY CHECK ROUTINE 47600020 * SUPPLIED A HELP MESSAGE 47610020 BE CODE4 NO, CONTINUE PROCESSING 47620020 SPACE 47630020 */* P INDICATE MSG IS PRESENT */ 47632021 OI PFLAGS4,PFVCMSG YES, TURN ON FLAG TO INDICATE 47640020 * A MESSAGE IS PRESENT 47650020 SPACE 47660020 */*CODE4: D (NO,CODE41,YES,) PROCESSING COBOL PCE'S? */ 47660421 */* P CLEAR THE TEMPORARY PDE (COBOL) */ 47660821 */* R () RETURN TO IKJPARS2 */ 47661221 */*CODE41: D (YES,ILLIDENT,NO,) IKJIDENT PDE */ 47662021 CODE4 DS 0H * * * * 47670021 TM CBFLAGS1,COBOLMOD ARE WE PROCESSING COBOL F41448 47672021 * PCE'S? F41448 47674021 BZ CODE41 IF NOT, CONTINUE PARSE F41448 47676021 XC TEMPPDE(CBLTPDE),TEMPPDE IF IN COBOL MODE F41448 47678021 * CLEAR THE TEMP. PDE F41448 47678421 L LINK1,CBLNKSV2 RETURN TO COBOL PROCESSRS F41448 47678821 * WITH INDICATION THAT F41448 47679221 BR LINK1 V.C. RETURNED AN ERROR F41448 47679621 * INDICATION F41448 47679721 CODE41 MVC PDWORD(ONE),PCEFLGB1(XPCE) MOVE PCE TYPE INDICATORS 47680000 NI PDWORD,HE0 ISOLATE TYPE INDICATOR 47690020 CLI PDWORD,EIGHT*(IDENTB-MAINB) IS IT AN IKJIDENT PCE 47700020 BE ILLIDENT YES -- PROCESS INVALID IDENT 47710020 SPACE 47720020 * R1 CLEARED ABOVE 47730020 IC R1,PCEPOST(XPCE) PICK UP TYPE OF POSITIONAL PCE 47740020 * FROM PCE 47750020 SLL R1,TWO MULTIPLY IT BY FOUR 47760020 B *+FOUR(R1) DETERMINE WHAT TYPE OF 47770020 * POSITIONAL IT IS 47780020 * 47790020 */* D (YES,INVPARMS,NO,) NON-EXISTENT TYPE PCE */ 47792021 B INVPARMS TYPE 0 - NONEXISTENT 47800020 * 47810020 */* D (YES,INVPARMS,NO,) DELIMITER TYPE PCE */ 47812021 B INVPARMS TYPE 1 - DELIMITER 47820020 * 47830020 */* D (YES,INVPARMS,NO,) SELF-DELIMITING STRING */ 47832021 B INVPARMS TYPE 2 - SELF-DELIMITING STRING 47840020 * 47850020 */* D (YES,ILLVALU,NO,) VALUE TYPE PCE */ 47852021 B ILLVALU TYPE 3 - VALUE 47860020 * 47870020 */* D (YES,ILLADDR,NO,) ADDRESS TYPE PCE */ 47872021 B ILLADDR TYPE 4 - ADDRESS 47880020 * 47890020 */* D (YES,ILLPSTR,NO,) PARENTHESIZED STRING */ 47892021 B ILLPSTR TYPE 5 - PARENTHESIZED STRING 47900020 * 47910020 */* D (YES,ILLUSID,NO,) USERID TYPE PCE */ 47912021 B ILLUSID TYPE 6 - USERID 47920020 * 47930020 */* D (YES,ILLDSN,NO,) DSNAME TYPE PCE */ 47932021 B ILLDSN TYPE 7 - DSNAME 47940020 * 47950020 */* D (YES,ILLDSN,NO,) ASTERISK FOR DSNAME */ 47952021 B ILLDSN TYPE 8 - * FOR DSNAME 47960020 * 47970020 */* D (YES,ILLQSTR,NO,) QUOTED STRING TYPE PCE */ 47972021 B ILLQSTR TYPE 9 - QUOTED STRING 47980020 SPACE 47990020 * 48000020 ******** 48010020 ******** N O T E - ANY OF THE ABOVE BRANCHES TO INVPARMS MEANS THAT 48020020 ******** AN UNSUPPORTED VALIDITY CHECK EXIT WAS TAKEN. 48030020 ******** 48040020 * 48050020 EJECT 48060020 *********************************************************************** 48070020 * * 48080020 * ERROR HANDLING SUBROUTINE * 48090020 * * 48100020 * THIS ROUTINE WRITES THE 'INVALID' MESSAGE AND PROMPTS FOR THE * 48110020 * CORRECT PARAMETER. IT ALSO CALCULATES THE LENGTH OF THE INVALID DATA* 48120020 * AND BUILDS THE APPROPRIATE MESSAGE SEGMENT. * 48130020 * A RETURN IS MADE TO THE APPRIPRIATE RESCAN ROUTINE. * 48140020 * * 48150020 *********************************************************************** 48160020 SPACE 48170020 * 48180020 * INVALID DSNAME. 48190020 * 48200020 */*ILLDSN: P INDICATE MESSAGE TO WRITE */ 48202021 ILLDSN DS 0H * * * * 48210020 MVI MSGCODE,MSG10 INDICATE MESSAGE TO WRITE 48220020 MVI PERRCODE,ZERO SET INDEX VALUE FOR DSNAME 48230020 */* D (,SYSR1) BRANCH TO ERROR HANDLER */ 48232021 B SYSR1 BRANCH TO ERROR HANDLER 48240020 SPACE 48250020 * 48260020 * INVALID USERID 48270020 * 48280020 */*ILLUSID: P INDICATE MESSAGE TO WRITE */ 48282021 ILLUSID DS 0H * * * * 48290020 MVI MSGCODE,MSG11 INDICATE MESSAGE TO WRITE 48300020 MVI PERRCODE,THIRTY6 SET INDEX VALUE FOR USERID 48310020 */* D (,SYSR1) BRANCH TO ERROR HANDLER */ 48312021 B SYSR1 BRANCH TO ERROR HANDLER 48320020 SPACE 48330020 * 48340020 * INVALID ADDRESS. 48350020 * 48360020 */*ILLADDR: P INDICATE MESSAGE TO WRITE */ 48362021 ILLADDR DS 0H * * * * 48370020 NI PFLAGS,HFF-HEXBIT-DECBIT-PFNEW-ADREXP * M4789 48380020 NI PFLAGS2,H80 CLEARS ALL BUT BIT 0 IN PFLAGS2 48390020 NI PFLAGS3,HFF-ONERBIT-TWORBIT * 48400020 MVI MSGCODE,MSG12 INDICATE MESSAGE TO WRITE 48410020 MVI PERRCODE,TWELVE SET ERROR CODE FOR ADDRESS 48420020 */* D (,SYSR1) BRANCH TO ERROR HANDLER */ 48422021 B SYSR1 BRANCH TO ERROR HANDLER 48430020 SPACE 48440020 * 48450020 * INVALID VALUE. 48460020 * 48470020 */*ILLVALU: P INDICATE MESSAGE TO WRITE */ 48472021 ILLVALU DS 0H * * * * 48480020 MVI MSGCODE,MSG14 INDICATE MESSAGE TO WRITE 48490020 MVI PERRCODE,SIXTEEN SET INDEX VALUE FOR VALUE 48500020 */* D (,SYSR1) BRANCH TO ERROR HANDLER */ 48502021 B SYSR1 BRANCH TO ERROR HANDLER 48510020 SPACE 48520020 * 48530020 * INVALID IDENT. 48540020 * 48550020 */*ILLIDENT: P INDICATE MESSAGE TO WRITE */ 48552021 ILLIDENT DS 0H * * * * 48560020 MVI MSGCODE,MSG6 INDICATE MESSAGE TO WRITE 48570020 MVI PERRCODE,TWENTY4 SET INDEX VALUE FOR IDENT 48580020 LA R0,PCEPARMT(XPCE) COMPUTE ADDRESS OF PARAMETER 48590020 * TYPE MESSAGE SEGMENT IN PCE 48600020 ST R0,SEGLIST+SIXTEEN STORE ADDRESS IN PARAMETER LIST 48610020 * FOR PUTLINE 48620020 */* D (,SYSR1) BRANCH TO ERROR HANDLER */ 48622021 B SYSR1 BRANCH TO ERROR HANDLER 48630020 SPACE 48640020 * 48650020 * INVALID PASSWORD FOR A DSNAME. 48660020 * 48670020 */*ILLDSNPS: P SET INDEX VALUE TO RESCAN DSNAME PASSWORD */ 48672021 ILLDSNPS DS 0H * * * * 48680020 MVI PERRCODE,EIGHT SET INDEX VALUE TO RESCAN 48690020 * DSNAME PASSWORD 48700020 */* D (,ILLPASWD) BRANCH */ 48702021 B ILLPASWD BRANCH 48710020 SPACE 48720020 * 48730020 * INVALID PASSWORD FOR A USERID. 48740020 * 48750020 */*ILLUIDPS: P SET INDEX VALUE TO RESCAN USERID PASSWORD */ 48752021 ILLUIDPS DS 0H * * * * 48760020 MVI PERRCODE,THIRTY2 SET INDEX VALUE TO RESCAN 48770020 * USERID PASSWORD 48780020 SPACE 48790020 */*ILLPASWD: P INDICATE MESSAGE TO WRITE */ 48792021 ILLPASWD DS 0H * * * * 48800020 MVI MSGCODE,MSG9 INDICATE MESSAGE TO WRITE 48810020 */* P INDICATE PROMPT IN BYPASS MODE */ 48812021 OI PFLAGS,PFBYPAS INDICATE PROMPTING TO BE DONE IN 48820020 * BYPASS MODE 48830020 MVC DATAUSER,INVPSAVE SAVE ERR PTR TO DSNAME OR USERID 48840020 MVC INVPSAVE,PPOINTR REPLACE ERR PTR WITH PASSWD PTR 48850020 */* D (,SYSR1) BRANCH TO ERROR HANDLER */ 48852021 B SYSR1 BRANCH TO ERROR HANDLER 48860020 SPACE 48870020 * 48880020 * INVALID QUOTED STRING OR INVALID PARENTHESIZED STRING 48890020 * 48900020 */*ILLPSTR: P SET INDEX VALUE FOR PSTRING */ 48902021 ILLPSTR DS 0H INVALID PSTRING 48910020 MVI PERRCODE,TWENTY SET INDEX VALUE FOR PSTRING 48920020 */* D (,ILLSTR1) BRANCH */ 48922021 B ILLSTR1 BRANCH 48930020 SPACE 48940020 */*ILLQSTR: P SET INDEX VALUE FOR QSTRING */ 48942021 ILLQSTR DS 0H INVALID QSTRING 48950020 MVI PERRCODE,TWENTY8 SET INDEX VALUE FOR QSTRING 48960020 SPACE 48970020 */*ILLSTR1: P INDICATE MESSAGE TO WRITE */ 48972021 ILLSTR1 DS 0H * * * * 48980020 MVI MSGCODE,MSG16 INDICATE MESSAGE TO WRITE 48990020 SPACE 49000020 * 49010020 * PREPARE POINTERS TO CREATE 2ND SEGMENT FOR 'INVALID STRING' MESSAGE. 49020020 * THIS MESSAGE IS ISSUED ONLY AT THE REQUEST OF A VALIDITY CHECKING 49030020 * ROUTINE. COMMON CODE FOR PSTRING AND QSTRING. 49040020 * 49050020 */* D (YES,JUSTPROM,NO,) VALIDCHK RTN SPECIFIED ONLY REENTER MSG */ 49052021 TM PFLAGS2,PFSKPINV DID THE VALIDITY CHECK ROUTINE 49060020 * SPECIFY ONLY A REENTER MSG 49070020 BO JUSTPROM YES IF BIT ON --- BRANCH 49080020 SPACE 49090020 SPACE 49100020 */*ILLSTR2: D (YES,ILLSTR3,NO,) STRING ENDS AT END OF INPUT */ 49102021 ILLSTR2 DS 0H * * * * 49110020 LH XINPUTB,PLENGTH GET LENGTH OF STRING 49120020 LA XINPUTB,ONE(XINPUTB) INCREASE BY ONE TO INCLUDE 49130020 * BEGINNING PUNCTUATION 49140020 L R3,INVPSAVE LOAD POINTER TO STRING 49150020 AR R3,XINPUTB COMPUTE ENDING ADDRESS OF STRING 49160020 C R3,ENDINPUT DOES STRING END AT END OF INPUT 49170020 BNL ILLSTR3 YES, CONTINUE NORMALLY 49180020 SPACE 49190020 */* P INCREASE LENGTH BY 1 TO INCLUDE ENDING DELIMITER */ 49192021 LA XINPUTB,ONE(XINPUTB) INCREASE LENGTH BY ONE TO 49200020 * INCLUDE ENDING PUNCTUATION 49210020 */* D (,ILLSTR3) CONTINUE NORMALLY */ 49212021 */*ILLKEYWD: P INDICATE MESSAGE TO WRITE */ 49214021 B ILLSTR3 CONTINUE NORMALLY 49220020 SPACE 49230020 * 49240020 * INVALID KEYWORD. 49250020 * 49260020 ILLKEYWD DS 0H * * * * 49270020 MVI MSGCODE,MSG13 INDICATE MESSAGE TO WRITE 49280020 SPACE 49290020 * 49300020 * ENTRY FOR AMBIGUOUS MESSAGE 49310020 * 49320020 */*ILLKAMB1: P LOAD OFFSET TO KEYWORD OR END OF FIELD PCE */ 49322021 ILLKAMB1 DS 0H * * * * 49330020 MVI PERRCODE,FOUR SET INDEX VALUE FOR KEYWORD 49340020 L XPCE,RPCEAD LOAD ADDRESS OF SUBFIELD PCE 49350020 MVC PDWORD(TWO),ZERO(XPCE) ALIGN DATA ON PROPER BOUNDARY 49360020 LH XPCE,PDWORD LOAD OFFSET TO KEYWORD OR 49370020 * END-OF-FIELD PCE 49380020 A XPCE,PTABLEAD OBTAIN TRUE PCE ADDRESS 49390020 NI RFLAGS,HFF-RFKYPRSE CLEAR ALREADY PARSED FLAG 49400020 MVC INVPSAVE,PPOINTR REPLACE WITH PTR TO KEYWORD 49410020 SPACE 49420020 * 49430020 * CALCULATE LENGTH OF DATA ENTERED. 49440020 * 49450020 */*SYSR1: D (YES,JUSTPROM,NO,) VALIDCHK RTN SPECIFY ONLY REENTER MSG */ 49452021 SYSR1 DS 0H * * * * 49464021 OI PFLAGS5,INVPRMPT INDICATE PROMPT FOR THIS PARAM 49466021 * A42352 49468021 TM PFLAGS2,PFSKPINV DID THE VALIDITY CHECK ROUTINE 49470020 * SPECIFY ONLY A REENTER MSG 49480020 BO JUSTPROM YES IF BIT ON --- BRANCH 49490020 SPACE 49500020 XC PLENGTH,PLENGTH CLEAR LENGTH FIELD 49510020 */* D (YES,SYSR4,NO,) PROCESSING COBOL PCE'S? */ 49510121 */* COMMENT (1,15) DO NOT TEST */ 49510221 */* COMMENT (2,15) PFENDSET */ 49510321 TM CBFLAGS1,COBOLMOD PROCESSING COBOL PCE'S F41448 49510421 BO SYSR4 NO, CONTINUE PARSE F41448 49510821 */* D (YES,SYSR2,NO,) ENDBAKUP HAS BEEN SET */ 49512021 TM PFLAGS4,PFENDSET HAS ENDBAKUP BEEN SET 49520020 BZ SYSR2 NO, CONTINUE 49530020 SPACE 49540020 LA XINPUT,ONE(XINPUT) INCREMENT SCAN POINTER M0882 49542020 */* S PUSHI: SAVE CURRENT LEVEL */ 49544021 BAL LINK1,PUSHI YES, SAVE CURRENT LEVEL 49550020 SPACE 49560020 */* P (,SYSR2) SAVE END OF DATA THAT IS INVALID */ 49562000 MVC ENDINPUT,ENDBAKUP GET END OF DATA THAT IS INVALID 49570020 */*SYSR4: P TURN PFENDSET OFF */ 49570400 SYSR4 NI PFLAGS4,HFF-PFENDSET TURN OFF END SET FLAG M0882 49572000 SPACE 49580020 */*SYSR2: P RESET SCAN PTR */ 49582021 SYSR2 DS 0H * * * * 49590020 */* D (YES,SYSRINDL,NO,) PROCESSING COBOL PCE'S? */ 49590421 TM CBFLAGS1,COBOLMOD PROCESSING COBOL PCE'S? F41448 49592021 BO SYSR3 YES, SKIP SCAN F41448 49594021 L XINPUT,INVPSAVE RESET SCAN PTR TO START OF 49600020 */* D (,SYSRSTR) START SCAN */ 49602021 B SYSRISTR START SCAN 49610020 SPACE 49620020 */*SYSRISCN: D (YES,,NO,SYSRSTR) REACHED END OF INPUT */ 49622021 SYSRISCN DS 0H * * * * 49630020 LA XINPUT,ONE(XINPUT) BUMP SCAN REGISTER BY ONE 49640020 LR XINPUTB,XINPUT SET BACKUP REGISTER 49650020 C XINPUT,ENDINPUT END OF INPUT 49660020 BL SYSRISTR NO --- BRANCH 49670020 SPACE 49680020 */* P SET END OF FILE INDICATOR */ 49682021 OI PFLAGS,PFENDF SET END-OF-FILE INDICATOR SO 49690020 * CURRENT STATUS OF SCAN WILL 49700020 * NOT BE SAVED BEFORE PROMPT 49710020 */* D (,SYSRINDL) BRANCH TO BUILD MSG SEGMENT */ 49712021 B SYSRINDL BRANCH TO BUILD MESSAGE SEGMENT 49720020 SPACE 49730020 */*SYSRSTR: D (YES,,NO,SYSRSTR1) CHARACTER IS LEFT PAREN */ 49732021 SYSRISTR DS 0H * * * * 49740020 CLI ZERO(XINPUT),LEFTPRN IS CHARACTER A LEFT PAREN 49750020 BNE SYSRSTR1 NO CONTINUE PROCESSING 49760020 SPACE 49770020 */* P INDICATE LEFT PAREN FOUND */ 49772021 OI PFLAGS3,LPRNFND YES - INDICATE A LEFT PAREN WAS 49780020 * FOUND 49790020 SPACE 49800020 */*SYSRSTR1: S TYPETEST: CHECK IF CHARACTER IS DELIMITER */ 49802021 SYSRSTR1 DS 0H * * * * 49810020 LA R1,DLIMREQD SEE IF THE CHARACTER IS A 49820020 * DELIMITER 49830020 BAL LINK1,TYPETEST BRANCH TO CHARACTER TEST ROUTINE 49840020 * 49850020 */* D (YES,,NO,SYSRISCN) CHARACTER IS DELIMITER */ 49852021 B SYSRISCN +0 RETURN - NON DELIMITER 49860020 * 49870020 * +4 RETURN - DELIMITER FOUND 49880020 */* D (YES,,NO,SYSRINDL) DELIMITER IS RIGHT PAREN */ 49882021 CLI ZERO(XINPUT),RIGHTPRN IS DELIMITER A RIGHT PAREN 49890020 BNE SYSRINDL NO CONITNUE PROCESSING 49900020 SPACE 49910020 */* D (YES,,NO,SYSRINDL) LEFT PAREN WAS FOUND */ 49912021 TM PFLAGS3,LPRNFND YES - WAS A LEFT PAREN FOUND 49920020 BZ SYSRINDL NO - CONTINUE PROCESSING 49930020 SPACE 49940020 */* P TURN OFF LEFT PAREN FLAG */ 49942021 NI PFLAGS3,HFF-LPRNFND YES - TURN OFF LEFT PAREN FLAG 49950020 */* D (,SYSRISCN) SKIP RIGHT PAREN */ 49952021 B SYSRISCN SKIP THE RIGHT PAREN 49960020 SPACE 49970020 * 49980020 * BUILD MESSAGE SEGMENT FOR DATA-ENTERED 49990020 * 50000020 */*SYSRINDL: P COMPUTE LENGTH OF ERROR FIELD */ 50002021 SYSRINDL DS 0H * * * * 50010020 NI PFLAGS3,HFF-LPRNFND TURN OFF POSSIBLE LEFT PAREN 50020020 * FLAG 50030020 * INVPSAVE POINTS TO START OF 50040020 * ERROR FIELD 50050020 SYSR3 S XINPUTB,INVPSAVE COMPUTE LENGTH OF ERROR FIELD 50060000 */* D (YES,SYSRISCN,NO,) IF LENGTH ZERO SKIP PAST DELIMITER */ 50062021 BZ SYSRISCN IF LENGTH ZERO SKIP PAST 50070020 * DELIMITER 50080020 SPACE 50090020 */* P DECREMENT SCAN POINTER */ 50090421 BCTR XINPUT,ZERO DECREMENT SCAN POINTER M2454 50092020 SPACE 50150020 */*ILLSTR3: S GETCORE: GET CORE FOR MESSAGE SEGMENT */ 50152021 ILLSTR3 DS 0H ENTER HERE TO BUILD SEGMENT FOR 50160020 * INVALID STRING MSG 50170020 LA R1,FOUR(XINPUTB) GET SIZE OF CORE FOR MESSAGE SEG 50180020 * PLUS FOUR FOR HEADER 50190020 BAL LINK1,GETCORE GET CORE FOR MESSAGE SEGMENT 50200020 SPACE 50210020 * CORE ADDRESS RETURNED IN R1 50220020 ST R1,SEGLIST+TWELVE STORE ADDRESS IN LIST OF SEGMENT 50230020 LA R0,FOUR(XINPUTB) GET SIZE OF MESSAGE SEGMENT 50240020 STH R0,ZERO(R1) STORE INTO SEGMENT 50250020 */* D (YES,ILLKAMB2,NO,) AMBIGUOUS MSG BEING WRITTEN */ 50252021 CLI MSGCODE,MSG4 IS AN AMBIGUOUS MSG BEING 50260020 * WRITTEN 50270020 BE ILLKAMB2 YES, GO BUILD AMBIGUOUS SEGMENT 50280020 * 50290020 XR R15,R15 CLEAR WORK INDEX REGISTER 50300020 IC R15,MSGCODE INSERT MESSAGE INDEX 50310020 L R3,ADRMSGC LOAD ADDRESS OF MESSAGE CSECT 50320020 L R15,ZERO(R15,R3) LOAD ADDRESS OF MESSAGE 50330020 LH R15,ZERO(R15) LOAD THE PROTOTYPE MESSAGE LEN. 50340020 SH R15,H4 COMPENSATE FOR HEADER 50350020 */* P STORE TRUE LENGTH OF MSG */ 50352021 STH R15,TWO(R1) STORE TRUE LENGTH AS OFFSET FOR 50360020 * NEW SEGMENT 50370020 * 50380020 * ENTRY FROM SETTING OF AMBIGUOUS MSG OFFSET. 50390020 * 50400020 */*ILLKAMB3: P MOVE TEXT TO NEW SEGMENT */ 50402021 ILLKAMB3 DS 0H * * * * 50410020 L R15,INVPSAVE LOAD START OF DATA ADDRESS 50420020 EX XINPUTB,BUILDSEG MOVE TEXT TO NEW SEGMENT 50430020 * MSGCODE SETUP PREVIOUSLY 50440020 */* S WRITER1: BRANCH TO PUTLINE ROUTINE */ 50442021 BAL LINK1,WRITER1 BRANCH TO PUTLINE ROUTINE 50450020 SPACE 50460020 */*JUSTPROM: D (YES,,NO,JUSTPRM2) INVALID PASSWORD MSG WRITTEN */ 50462021 JUSTPROM DS 0H * * * * 50470020 NI PFLAGS2,HFF-PFSKPINV SET POSSIBLE 50480020 * FLAGS TO ZERO 50490020 CLI MSGCODE,MSG9 IS AN INVALID PASSWORD MSG BEING 50500020 * WRITTEN 50510020 BNE JUSTPRM2 IF NO BRANCH - ZERO TEMP PDE 50520020 SPACE 50530020 */* P RESTORE ERR PTR TO DSNAME OR USERID */ 50532021 MVC INVPSAVE,DATAUSER RESTORE ERR PTR TO DSNAME OR 50540020 * USERID FOR POSSIBLE INVALID 50550020 * MSG FROM VALIDITY CHECK 50560020 */* D (,JUSTPRM1) BRANCH */ 50562021 B JUSTPRM1 BRANCH - TEMPORARY PDE 50570020 * CANNOT BE ZEROED BECAUSE 50580020 * DATA GATHERED SO FAR IS 50590020 * GOOD 50600020 SPACE 50610020 */*JUSTPRM2: P ZERO TEMPORARY PDE */ 50612021 JUSTPRM2 DS 0H * * * * 50620020 XC TEMPPDE(LTPDE),TEMPPDE ZERO THE TEMPORARY PDE 50630020 SPACE 50640020 */*JUSTPRM1: P INDICATE MSG TO PROMPT WITH */ 50642021 JUSTPRM1 DS 0H * * * * 50650020 MVI MSGCODE,MSG3 INDICATE MESSAGE TO PROMPT WITH 50660000 */* D (NO,JUSTPRM3,YES,) PROCESSING COBOL PCE'S? */ 50660421 TM CBFLAGS1,COBOLMOD PROCESSING COBOL PCE'S F41448 50662021 BZ JUSTPRM3 NO, CONTINUE NORMAL PARSE F41448 50664021 */* P LOAD RETURN ADDRESS SUPPLIED BY IKJPARS2 INTO LINK1 */ 50664421 */* R () BRANCH TO WRITER2 */ 50664821 L LINK1,CBLNKSV2 IF IN COBOL MODE, LOAD F41448 50666021 * RETURN ADDRESS SUPPLIED F41448 50668021 * BY COBOL MODULE F41448 50668421 B WRITER2 BRANCH TO WRITER2 TO F41448 50668821 * WRITE MSG F41448 50669221 JUSTPRM3 XR R1,R1 CLEAR WORK REG TO ZERO 50670000 IC R1,PERRCODE LOAD RESCAN INDEX VALUE 50680020 L LINK1,RETRNTAB(R1) GET APPROPRIATE RESCAN ADDRESS 50690020 */*JUSTPRM3: D (,WRITER2) PROMPT FOR NEW DATA */ 50692000 B WRITER2 PROMPT USER FOR NEW DATA 50700020 SPACE 50710020 * 50720020 * SET OFFSET FOR AMBIGUOUS MESSAGE. 50730020 * 50740020 */*ILLKAMB2: P SET OFFSET TO PLACE IN MSG TO INSERT TEXT */ 50742021 ILLKAMB2 DS 0H * * * * 50750020 MVI TWO(R1),ZERO SET FIRST BYTE OF OFFSET TO 0 50760020 MVI THREE(R1),OFFSET6 SET OFFSET TO PLACE IN MSG 50770020 * TO INSERT TEXT 50780020 */* D (,ILLKAMB3) RETURN TO MAINLINE CODE */ 50782021 B ILLKAMB3 RETURN TO MAINLINE INVALID MSG 50790020 * PROCESSING 50800020 EJECT 50810020 *********************************************************************** 50820020 * * 50830020 * CLEANUP ROUTINE * 50840020 * * 50850020 * WHEN AN IRRECOVERABLE ERROR OCCURS OR WHEN AN I/O SERVICE ROUTINE * 50860020 * INDICATES AN ATTENTION HAS BEEN ISSUED, THIS ROUTINE IS ENTERED TO * 50870020 * FREE THE VARIABLE RESOURCES OBTAINED DURING PROCESSING AND THEN * 50880020 * BRANCHES TO THE NORMAL EXIT ROUTINE. * 50890020 * * 50900020 *********************************************************************** 50910020 */*CLEANUP: P FREE CORE OBTAINED FOR INPUT PUSHDOWN STACK CHAIN */ 50912021 SPACE 50920020 * 50930020 * FREE CORE OBTAINED FOR INPUT PUSHDOWN STACK CHAIN. 50940020 * 50950020 CLEANUP DS 0H ERROR CLEANUP ROUTINE 50960020 L R1,PIPDLCUR LOAD THE CURRENT INPUT PUSHDOWN 50970020 * STACK POINTER 50980020 NC ONE(THREE,R1),ONE(R1) IS THE CHAIN WORD ZERO 50990020 BZ GETPDLAD IF YES THERE ARE NO ADDITIONAL 51000020 * STACKS --- BRANCH 51010020 SPACE 51020020 MVC PIPDLCUR+ONE(L'PIPDLCUR-ONE),ONE(R1) SAVE PREVIOUS STACK 51030020 * ADDRESS 51040020 LA R0,EIGHT*(IPDLMAXE)+FOUR LOAD STACK SIZE AND SUBPOOL 51050020 * NUMBER FOR FREEMAIN 51060020 SPACE 51070020 FREEMAIN R,LV=(0),A=(1) FREE INPUT PUSHDOWN STACK 51080020 SPACE 51090020 B CLEANUP CONTINUE LOOP 51100020 SPACE 51110020 * 51120020 * OBTAIN PDL ADDRESS AND RESET PDL POINTER. 51130020 * 51140020 */*GETPDLAD: P OBTAIN PDL ADDR AND RESET PDL POINTER */ 51142021 */* D (YES,,NO,CLEANUP2) WAS A PDL EVER OBTAINED */ 51144021 GETPDLAD DS 0H GET PDL ADDRESS 51150020 L R2,FOUR(PBASE) LOAD CALLERS SAVEAREA ADDR 51160020 L R2,TWENTY4(R2) LOAD INPUT PARAMETERS ADDR 51170020 L R2,SIXTEEN(R2) LOAD ANSWER PLACE ADDR 51180020 L R1,ZERO(R2) LOAD PDL ADDR 51190020 MVC ZERO(L'ENDCHAIN,R2),ENDCHAIN INDICATE NO PDL EXISTS 51200020 LTR R1,R1 WAS A PDL OBTAINED - MAY HAVE 51210020 * FAILED TRYING TO GETMAIN 51220020 * FOR THE PDL 51230020 BZ CLEANUP2 IF NO PDL BRANCH 51240020 SPACE 51250020 * 51260020 * FREE CORE OBTAINED FOR PDL AND NEW DATA 51270020 * 51280020 */*CLEANUP1: P FREE PDL CORE AND NEW DATA CORE */ 51282021 CLEANUP1 DS 0H FREE SUBPOOL 1 CORE 51290020 L R3,ZERO(R1) SAVE ADDR OF NEXT AREA TO FREE 51300020 L R0,FOUR(R1) LOAD SUBPOOL NO. AND LENGTH INTO 51310020 * R0 51320020 SPACE 51330020 FREEMAIN R,LV=(0),A=(1) ISSUE FREEMAIN 51340020 SPACE 51350020 LA R3,ZERO(R3) CLEAR HIGH ORDER BYTE 51360020 LTR R1,R3 COPY NEXT CORE ELEMENT ADDR 51370020 BNZ CLEANUP1 REPEAT IF NOT ZERO 51380020 SPACE 51390020 * 51400020 * FREE RECURSIVE WORK SPACES 51410020 * 51420020 */*CLEANUP2: P (,EXITNORM) FREE RECURSIVE WORK SPACES */ 51422021 CLEANUP2 DS 0H * * * * 51430020 L R2,RBASESV SEE IF THERE IS A PREVIOUS 51440020 LTR R2,R2 RECURSIVE WORKSPACE 51450020 BZ EXITNORM IF NO, GO TO NORMAL EXIT 51460020 * PROCEDURE 51470020 SPACE 51480020 LR R1,RBASE IF YES, LOAD ADDR OF CURRENT 51490020 * RECURSIVE WORKAREA 51500020 SPACE 51510020 FREEMAIN R,LV=RWORKSZ,A=(1) ISSUE FREEMAIN 51520020 SPACE 51530020 LR RBASE,R2 ESTABLISH NEW BASE REGISTER 51540020 B CLEANUP2 CONTINUE 51550020 EJECT 51560020 *********************************************************************** 51570020 * * 51580020 * CHECK RETURN CODES FROM PUTLINE AND PUTGET. SET PARSE RETURN * 51590020 * CODES ACCORDINGLY. * 51600020 * * 51610020 *********************************************************************** 51620020 SPACE 51630020 INVPARMS DS 0H * * * * 51640020 */*INVPARMS: P (,CLEANUP) INDICATE PARSE RETURN CODE */ 51642021 MVI RETCODE,RCERROR INDICATE PARSE RETURN CODE 51650020 B CLEANUP CLEANUP AND EXIT 51660020 SPACE 51670020 ATTNEXIT DS 0H * * * * 51680020 */*ATTNEXIT: P (,CLEANUP) INDICATE PARSE RETURN CODE */ 51682021 MVI RETCODE,RCATTN INDICATE PARSE RETURN CODE 51690020 B CLEANUP CLEANUP AND EXIT 51700020 SPACE 51710020 * 51720020 * VALIDITY CHECK EXIT ROUTINE INDICATED IT COULD NOT CONTINUE AND WANTS 51730020 * PARSE TO TERMINATE. 51740020 * 51750020 */*VCERR: P (,CLEANUP) INDICATE PARSE RETURN CODE */ 51752021 VCERR DS 0H * * * * 51760020 MVI RETCODE,RCVCERR INDICATE PARSE RETURN CODE 51770020 B CLEANUP CLEANUP AND EXIT 51780020 SPACE 51790020 * 51800020 * THE FOLLOWING ACTIONS ARE TAKEN FOR THE VARIOUS RETURN CODES FROM 51810020 * PUTLINE 51820020 * 51830020 */*PLRCACT: D (0,WRITER1D,4,ATTNEXIT,8,INVPARMS,12,INVPARMS,16, 51832021 */*GETERROR,,INVPARMS) IS PUTLINE RETURN CODE */ 51834021 PLRCACT DS 0H * * * * 51840020 LTR R15,R15 IS THE RETURN CODE 0 51850020 BZ WRITER1D YES, SUCCESSFUL COMPLETION, 51860020 * CONTINUE 51870020 SPACE 51880020 CH R15,H4 IS THE RETURN CODE FROM 51890020 * PUTLINE 4 51900020 BE ATTNEXIT YES, AN ATTENTION INTERRUPT 51910020 * OCCURRED DURING PUTLINE 51920020 * PROCESSING, GO SET PARSE 51930020 * RETURN CODE AND EXIT 51940020 SPACE 51950020 CH R15,H8 IS THE RETURN CODE FROM 51960020 * PUTLINE 8 51970020 BE INVPARMS YES, 'NOWAIT' WAS SPECIFED TO 51980020 * PUTLINE, THIS IS AN INVALID 51990020 * RETURN CODE TO PARSE 52000020 * GO SET PARSE RETURN CODE 52010020 * AND EXIT 52020020 SPACE 52030020 CH R15,H12 IS THE RETURN CODE FROM 52040020 * PUTLINE TWELVE 52050020 BE INVPARMS YES, INVALID PARAMETERS WERE 52060020 * PASSED TO PUTLINE, GO SET 52070020 * PARSE RETURN CODE AND EXIT 52080020 SPACE 52090020 CH R15,H16 IS THE RETURN CODE FROM 52100020 * PUTLINE SIXTEEN 52110020 BZ GETERROR YES, A CONDITIONAL GETMAIN WAS 52120020 * ISSUED BY PUTLINE AND THERE 52130020 * WAS NOT SUFFICIENT SPACE TO 52140020 * SATISFY THE REQUEST, GO SET 52150020 * PARSE RETURN CODE AND EXIT 52160020 SPACE 52170020 B INVPARMS NO, AN INVALID RETURN CODE WAS 52180020 * RETURNED FROM PUTLINE, SET 52190020 * PARSE RETURN CODE AND EXIT 52200020 SPACE 52210020 * 52220020 * THE FOLLOWING ACTIONS ARE TAKEN FOR THE VARIOUS RETURN CODES FROM 52230020 * PUTGET. 52240020 * 52250020 */*PGRCACT: D (0,WRITER2J,4,INVPARMS,8,ATTNEXIT,12,MSNGMSG,16, 52252021 */*INVPARMS,20,INVPARMS,24,INVPARMS,28,GETERROR,,INVPARMS) 52254021 */* IS PUTGET RETURN CODE */ 52256021 PGRCACT DS 0H * * * * 52260020 LTR R15,R15 IS THE RETURN CODE FROM PUTGET 52270020 * ZERO 52280020 BZ WRITER2J YES, SUCCESSFUL COMPLETION, 52290020 * CONTINUE 52300020 SPACE 52310020 CH R15,H4 IS THE RETURN CODE FROM PUTGET 52320020 * FOUR 52330020 BE INVPARMS YES, INPUT LINE RETURNED IS NOT 52340020 * FROM A TERMINAL, INVALID 52350020 * RETURN CODE TO PARSE, GO SET 52360020 * PSRSE RETURN CODE AND EXIT 52370020 SPACE 52380020 CH R15,H8 IS THE RETURN CODE FROM PUTGET 52390020 * EIGHT 52400020 BE ATTNEXIT YES, AN ATTENTION INTERRUPT 52410020 * OCCURRED DURING THE EXECUTION 52420020 * OF PUTGET, GO SET PARSE 52430020 * RETURN CODE AND EXIT 52440020 SPACE 52450020 CH R15,H12 IS THE RETURN CODE FROM PURGET 52460020 * TWELVE 52470020 BE MSNGMSG YES, NO INPUT LINE RETURNED 52480020 * BECAUSE NO PROMPTING WAS 52490020 * SPECIFIED, GO ISSUE MISSING 52500020 * MESSAGE 52510020 SPACE 52520020 CH R15,H16 IS THE RETURN CODE FROM PUTGET 52530020 * SIXTEEN 52540020 BE INVPARMS YES, 'NOWAIT' WAS SPECIFIED,THIS 52550020 * IS AN INVALID RETURN CODE 52560020 * TO PARSE, GO SET PARSE RETURN 52570020 * CODE AND EXIT 52580020 SPACE 52590020 CH R15,H20 IS THE RETURN CODE FROM PUTGET 52600020 * TWENTY 52610020 BE INVPARMS YES, 'NOWAIT' WAS SPECIFIED THIS 52620020 * IS AN INVALID RETURN CODE 52630020 * TO PARSE, GO SET PARSE RETURN 52640020 * CODE AND EXIT 52650020 SPACE 52660020 CH R15,H24 IS THE RETURN CODE FROM PUTGET 52670020 * TWENTY-FOUR 52680020 BE INVPARMS YES, INVALID PARAMETERS WERE 52690020 * PASSED TO PUTGET, GO SET 52700020 * PARSE RETURN CODE AND EXIT 52710020 SPACE 52720020 CH R15,H28 IS THE RETURN CODE FROM PUTGET 52730020 * TWENTY-EIGHT 52740020 BE GETERROR YES, A CONDITIONAL GETMAIN WAS 52750020 * ISSUED BY PUTGET AND THERE 52760020 * WAS NOT SUFFICIENT SPACE TO 52770020 * SATISFY THE REQUEST, GO SET 52780020 * PARSE RETURN CODE AND EXIT 52790020 SPACE 52800020 B INVPARMS NO AN INVALID RETURN CODE WAS 52810020 * RETURNED FROM PUTGET, SET 52820020 * PARSE RETURN CODE AND EXIT 52830020 SPACE 52840020 EJECT 52850020 *********************************************************************** 52860020 * * 52870020 * THIS ROUTINE CONSTRUCTS THE MSG SEGMENTS TO WRITE A 'MISSING' * 52880020 * MSG. IT IS ENTERED WHEN PROMPTING IS ATTEMPTED, BUT PUTGET * 52890020 * INDICATES THE USER SPECIFIED NO PROMPT OR INPUT IS FROM A COMMAND * 52900020 * PROCEDURE. IF PUTGET WAS NOT ISSUING AN 'ENTER' MSG THE 'MISSING' * 52910020 * MSG IS NOT SENT. EXIT IS TO CLEANUP. * 52920020 * * 52930020 *********************************************************************** 52940020 SPACE 52950020 MSNGMSG DS 0H WRITE 'MISSING' MSG SUBROUTINE 52960020 */*MSNGMSG: D (YES,,NO,CLEANUP) DID PUTGET ISSUE 'ENTER' */ 52962021 */* P SET UP 'MISSING' OR 'MISSING PASSWORD' MSG INDEX */ 52964021 MVI RETCODE,RCNOPRMT INDICATE PARSE RETURN CODE 52970020 LA R14,MSG2 INDICATE MESSAGE TO WRITE 52980020 CLI MSGCODE,MSG1 WAS AN 'ENTER' MSG SENT TO 52990020 * PUTGET 53000020 BE ISSUEMSG YES - THEN 'MISSING' MSG SHOULD 53010020 * BE ISSUED - BRANCH 53020020 SPACE 53030020 LA R14,MSG5 INDICATE MESSAGE TO WRITE 53040020 CLI MSGCODE,MSG15 IS A MISSING PASSWORD BEING 53050020 * PROMPTED FOR 53060020 BNE CLEANUP IF NO BRANCH - NO FURTHER MSGS. 53070020 SPACE 53080020 * 53090020 * EITHER AN 'ENTER' OR AN 'ENTER PASSWORD FOR' MESSAGE WAS TO BE 53100020 * OUTPUTED, IN WHICH CASE, A 'MISSING' OR A 'MISSING PASSWORD FOR' 53110020 * MESSAGE WILL BE OUTPUTED. 53120020 * 53130020 */*ISSUEMSG: P FIND MSG AND MSG ATTRIBUTES IN MSG CSECT */ 53132021 ISSUEMSG DS 0H * * * * 53140020 STC R14,MSGCODE INDICATE MESSAGE TO WRITE 53150020 L R15,ADRMSGC GET ADDR OF MSG CSECT 53160020 L R14,ZERO(R14,R15) GET ADDRESS OF MESSAGE 53170020 LH R15,ZERO(R14) LOAD PROTOTYPE MESSAGE LENGTH 53180020 SH R15,H4 COMPENSATE FOR HEADER 53190020 L R1,SEGLIST+TWELVE LOAD PTR TO SECOND SEGMENT 53200020 STH R15,TWO(R1) MODIFY THE OFFSET IN SEGMENT TWO 53210020 * TO CORRESPOND TO MISSING MSG 53220020 MVC PLUSSEG+TWO(TWO),TWO(R1) USE SAME OFFSET FOR PLUS 53230020 * SEGMENT 53240020 SPACE 53250020 * 53260020 * LOOP THROUGH THE HELP MESSAGE SEGMENT LISTS REPLACING THE 'ENTER' 53270020 * MESSAGE ADDRESS WITH THE 'MISSING' MESSAGE ADDRESS. THIS IS THE ONLY 53280020 * CASE WHERE A INFORMATIONAL MESSAGE MAY HAVE ASSOCIATED HELP MESSAGES. 53290020 * 53300020 */* P REPLACE 'ENTER' MSG ADDR IN HELP SEGMENTS WITH 'MISSING' ADDR */ 53302021 LA R1,SEGLIST LOAD PTR TO FIRST SEGMENT LIST 53310020 SPACE 53320020 MSNGLOOP DS 0H * * * * 53330020 CLC ZERO(L'ENDCHAIN,R1),ENDCHAIN IS THIS LAST LEVEL MESSAGE 53340020 BE MSNGEXIT IF YES BRANCH 53350020 SPACE 53360020 L R1,ZERO(R1) IF NO - LOAD PTR TO NEXT LEVEL 53370020 ST R14,TWELVE(R1) STORE ADDRESS OF 'MISSING' MSG. 53380020 B MSNGLOOP CONTINUE THROUGH HELP MESSAGES 53390020 SPACE 53400020 MSNGEXIT DS 0H * * * * 53410020 */*MSNGEXIT: D (YES,,NO,WRITER1C) ANY HELP MESSAGES ? */ 53412021 */* P (,WRITER1A) FORMAT THE HELP MESSAGES */ 53414021 LA LINK1,CLEANUP SET RETURN FROM WRITER1 TO 53420020 * CLEANUP ROUTINE 53430020 CLC SEGLIST(L'ENDCHAIN),ENDCHAIN WERE THERE ANY HELP MSGS. 53440020 BE WRITER1C IF NO BRANCH 53450020 SPACE 53460020 MVC PLUSSEG(L'H5),H5 INDICATE SEGMENT LENGTH 53470020 MVI PLUSSEG+FOUR,PLUS PUT THE PLUS IN THE SEGMENT 53480020 LA R0,PLUSSEG GET ADDRESS OF PLUS MSG SEGMENT 53490020 ST R0,SEGLIST+SIXTEEN STORE AS THIRD SEGMENT OF 53500020 * INFORMATIONAL MESSAGE 53510020 LA R15,THREE TELL WRITER1 THREE SEGMENT MSG 53520020 B WRITER1A WRITE THE MESSAGE AND EXIT 53530020 */*IKJEFP00: END */ 53532000 EJECT 53540020 *********************************************************************** 53550020 * * 53560020 * CONSTANT AREA * 53570020 * * 53580020 *********************************************************************** 53590020 SPACE 53600020 * 53610020 * THE FOLLOWING TWO FIELDS MUST BE CONTIGUOUS. 53620020 * 53630020 LRPAREN DC C'( )' FOR NULL SUBFIELD 53640020 * 53650020 SPACE 53660020 * 53670020 * VARIOUS NUMERIC QUANTITIES. 53680020 * 53690020 H8 DC H'8' LENGTH OF ENTRY IN PUSH DOWN 53700020 * STACK 53710020 * 53720020 H4 DC H'4' TO USE AS A FOUR 53730020 * 53740020 H3 DC H'3' USED TO OBTAIN VALIDITY CHECK 53750020 * ROUTINE ADDRESS FROM PCE 53760020 * 53770020 H5 DC H'5' TO OBTAIN NEW BUFFER OFFSET IN 53780020 * EXIT ROUTINE 53790020 H12 DC H'12' USED TO TEST FOR A VALIDITY 53800020 * CHECK EXIT RETURN CODE 53810020 * OF TWELVE 53820020 H16 DC H'16' USED TO TEST RETURN CODES 53830020 H20 DC H'20' USED TO TEST RETURN CODES 53840020 H24 DC H'24' USED TO TEST RETURN CODES 53850020 H28 DC H'28' USED TO TEST RETURN CODES 53860020 DEC7 DC H'7' TYPES OF ADDRESSES 53870020 DEC9 DC H'9' * * * * 53880020 DEC32 DC H'32' * * * * 53890020 DATALEN DC H'200' LENGTH OF INVALID DATA PRINTED 53892020 TWO55 DC H'255' MAX. LENGTH FOR EXECUTE INSTR. 53894021 TWO56 DC H'256' EXCEDES MAXIMUM NUMBER OF LEVELS 53900020 * OF INDIRECT ADDRESSING BY ONE 53910020 SPACE 53920020 * 53930020 * USED TO OBTAIN CORE TO BUILD HELP MESSAGE SEGMENTS. 53940020 * 53950020 LISTLEN DC 0H'0' HALFWORD BOUNDARY ALIGNMENT 53960020 DC AL2(LENMLLST) LENGTH OF MULTI-LEVEL ELEMENT 53970020 * USED FOR GETMAIN 53980020 SPACE 53990020 * 54000020 * VARIOUS INSTRUCTIONS THAT ARE 'EX'. 54010020 * 54020020 KEYWDCLC CLC ZERO(*-*,R1),TEMPPDE USED TO COMPARE NAME IN 54030020 * IKJNAME PCE TO BUFFER DATA 54040020 * 54050020 NAMEMVC MVC TEMPPDE(*-*),PCENAMN(XPCE) MOVE NAME FROM PCE TO 54060020 * WORKAREA 54070020 * 54080020 IOBMVC2 MVC ONE(*-*,XINPUT),FOUR(R3) TO COPY DATA RECEIVED FROM 54090020 * PROMPT TO PARSE STORAGE 54100020 * 54110020 CLEARXC XC ZERO(*-*,R1),ZERO(R1) TO CLEAR ALLOCATED STORAGE 54120020 * 54130020 BUILDSEG MVC FOUR(*-*,R1),ZERO(R15) TO BUILD A MESSAGE SEGMENT 54140020 * 54150020 ERASEXC XC ZERO(*-*,R3),ZERO(R3) TO ERASE POSITIONAL PDE 54160020 * 54170020 PDEXMV MVC ZERO(*-*,R3),TEMPPDE TO COPY DATA FROM TEMPORARY PDE 54180020 * TO USERS PDE 54190020 * 54200020 POSITXNC NC ZERO(*-*,R3),ZERO(R3) TO TEST FOR END OF PDE CHAIN 54210020 * 54220020 TYPETM TM ZERO(R15),*-* TEST FOR CHARACTER TYPE 54230020 * 54240020 QSTRMVC MVC ZERO(*-*,XINPUT),ONE(XINPUT) USED TO REMOVE SECOND QUOTE 54250020 * FROM QSTRING 54260020 SPACE 54270020 * 54280020 * VARIOUS BIT CONFIGURATIONS USED AS MASKS. THEY MUST BE ON FULL WORD 54290020 * BOUNDARIES 54300020 * 54310020 TYPEMASK DC 0A(0) ALIGN ON FULL WORD BOUNDARY 54320020 DC X'000000E0' USED TO SELECT TYPE INDICATOR 54330020 * FROM PCE 54340020 * 54350020 EIGHTMAK DC X'FFFFFFF8' USED TO ROUND TO EIGHT 54360020 * 54370020 CLEARMK1 DC X'000000FF' USED IN STORAGE ALLOCATION RTN. 54380020 * 54390020 CLEARMK2 DC X'FFFFFF00' USED TO MASK REMAINDER LESS 54400020 * THAN 256 54410020 * 54420020 SUBPOOLN DC AL1(1,0,0,0) SUBPOOL NUMBER USED TO FREE 54430020 * PUTGETS BUFFERS --- THIS 54440020 * CONSTANT IS ALSO USED TO 54450020 * SET THE SPECIAL FLAG IN 54460020 * XINPUT BY THE INVALID RTN. 54470020 SPLNGTH DC X'01000010' CORE USED FOR EXPRESSION VALUE 54480020 * PDE'S 54490020 SPACE 54500020 * 54510020 * SUBPOOL NUMBER AND CHAINING OVERHEAD FOR GETMAIN IN STORAGE 54520020 * ALLOCATION SUBROUTINE. 54530020 * 54540020 SPOVRHD DC 0A(0) ALIGN ON FULL WORD BOUNDARY 54550020 DC AL1(1,0,0,8) SUBPOOL NUMBER AND OVERHEAD 54560020 SPACE 54570020 * 54580020 * TABLE OF ADDRESSES FOR RESCANNING AFTER AN INVALID MESSAGE AND A 54590020 * PROMPT. THE INDEX VALUE TO THE APPROPRIATE ADDRESS IS IN PERRCODE. 54600020 * 54610020 RETRNTAB DC 0A(0) ALIGN ON FULL WORD BOUNDARY 54620020 DC A(DSNAMRSC) PERRCODE = 0 DSNAME 54630020 DC A(NEXTPCE) PERRCODE = 4 KEYWORDS 54640020 DC A(DSNPSRSC) PERRCODE = 8 DSNAME PASSWORDS 54650020 DC A(ADDRERSC) PERRCODE = 12 ADDRESS 54660020 DC A(VALUERSC) PERRCODE = 16 VALUE 54670020 DC A(PSTRIRSC) PERRCODE = 20 PSTRING 54680020 DC A(IDENTRSC) PERRCODE = 24 IDENT 54690020 DC A(QSTRIRSC) PERRCODE = 28 QSTRING 54700020 DC A(UIDPSRSC) PERRCODE = 32 USERID PASSWORDS 54710020 DC A(USIDRSC) PERRCODE = 36 USERID 54720020 SPACE 54730020 * TABLE OF ADDRESSES USED BY COBOL ROUTINES TO ENTER PARSE F41448 54732021 * SUBROUTINES TO ACCOMPLISH SPECIFIC FUNCTIONS IN THE SCAN F41448 54734021 * AND PROMPTING UNDER COBOL SYMBOLIC DEBUG F41448 54736021 SPACE 54738021 QSTRINGA DC A(QSTR01) QSTRING ROUTINE ADDRESS F41448 54738421 DC A(PROMPTQ) PROMPT ROUTINE F41448 54738821 DC A(POSITXCB) ADD PDE TO PERM PDE F41448 54739221 DC A(SYSR1) WRITE INVALID MESSAGE F41448 54739621 DC A(SKIPB) SKIP BLANKS F41448 54739721 DC A(RANGE) RANGE DETERMINER F41448 54739821 DC V(GENSCAN) SCAN STRING ROUTINE F41448 54739921 DC A(TYPETEST) DETERMINE CHARACTER TYPE F41448 54743221 DC V(TRANSQ) TRANSLATE TO UPPERCASE F41448 54745221 DC A(PSTRIMSG) ENDING PAREN ASSUMED F41448 54745621 DC A(LISTT) LIST PROCESSOR F41448 54746021 DC A(STALOC) ALLOCTE STORAGE IN SBPL 1 F41448 54746421 DC A(SCANF) POP THE STACK F41448 54746521 DC A(GETCORE) GET CORE WHICH WILL BE F41448 54746621 * RELEASE BEFORE EXIT F41448 54749921 DC A(NAMESKP3) SKIP TO THE NEXT PCE F41448 54751921 DC A(CLEANUP) FREE CORE, DELETE MODULES F41448 54752321 * EXIT F41448 54752721 DC A(PUSHI) PUSH THE STACK F41448 54753121 DC A(PARS2ENT) ENTRY POINT FROM IKJPARS2 F41448 54753221 * WHEN SUBROUTINE FUNCTIONS F41448 54753321 * REQUIRED F41448 54756621 DC A(NEXTPCE) GOTO NEXT PCE ROUTINE F41448 54758621 MAXBLKSZ DC F'248' BLOCK SIZE FOR GETMAINS BY 54760100 * STORAGE ALLOCATION ROUTINE 54763400 SPACE 54766700 ADRMSGC DC A(IKJEFP10) ADDRESS OF MESSAGE CSECT 54770020 SPACE 54780020 ENDCHAIN DC XL4'FF000000' LAST ELEMENT INDICATOR FOR 54790020 * CHAINS CONSTRUCTED WITHIN 54800020 * PROGRAM 54810020 SPACE 54820020 * 54830020 * CONTROL INFORMATION FOR GENSCAN WHEN SCANNING FOR A DSNAME 54840020 * QUALIFIER, MEMBER NAME, OR COMMAND NAME. 54850021 * 54860020 DSNCNTL EQU * * * * * 54870020 MEMBCNTL EQU * * * * * 54890020 DC X'40' ASTERISK NOT ALLOWED, MAXIMUM 54900020 * LENGTH SPECIFIED 54910020 DC X'01' FIRST CHARACTER MUST BE 54920020 * ALPHABETIC 54930020 DC X'03' OTHER CHARACTERS MUST BE 54940020 * ALPHAMERIC 54950020 DC X'08' MAXIMUM LENGTH = 8 54960020 SPACE 54970020 * 54970421 * 54971221 * CONTROL INFORMATION FOR GENSCAN WHEN SCANNING FOR A PASSWORD 54971621 * 54972021 * 54972821 PWSYNTAX EQU * * * * * A45306 54974021 DC X'40' ASTERISK NOT ALLOWED, MAXIMUM 54976021 * LENGTH SPECIFIED A45306 54978021 * LENGTH SPECIFIED A45306 54978121 DC X'03' FIRST CHARACTER MUST BE 54978421 * ALPHAMERIC A45306 54978821 DC X'03' OTHER CHARACTERS MUST BE 54979221 * 54979621 * 54979721 * 54979821 * 54979921 * 54980021 * 54980121 * ALPHAMERIC A45306 54981621 DC X'08' MAXIMUM LENGTH = 8 A45306 54984021 SPACE 54986021 * 54988021 * CONTROL INFORMATION FOR GENSCAN WHEN SCANNING FOR A USERID 54990020 * 55000020 USIDCNTL EQU * * * * * 55010020 DC X'40' ASTERISK NOT ALLOWED, MAXIMUM 55020020 * LENGTH SPECIFIED 55030020 DC X'01' FIRST CHARACTERS MUST BE 55040020 * ALPHABETIC 55050020 DC X'03' OTHER CHARACTERS MUST BE 55060020 * ALPHANUMERIC 55070020 DC X'07' MAXIMUM LENGTH = 7 55080020 SPACE 55090020 * 55100020 * CONTROL INFORMATION FOR GENSCAN WHEN SCANNING FOR A DSTHING 55110020 * 55120020 DSTCNTL EQU * * * * * 55130020 DC X'C0' ASTERISK ALLOWED, MAXIMUM 55140020 * LENGTH SPECIFIED 55150020 DC X'01' FIRST CHARACTER MUST BE 55160020 * ALPHABETIC 55170020 DC X'03' OTHER CHARACTERS MUST BE 55180020 * ALPHAMERIC 55190020 DC X'08' MAXIMUM LENGTH = 8 55200020 SPACE 55210020 * 55220020 * CONTROL INFORMATION FOR GENSCAN WHEN SCANNING FOR A KEYWORD 55230020 * 55240020 KEYSYNTX EQU * * * * * 55250020 DC X'40' ASTERISK NOT ALLOWED, MAXIMUM 55260020 * LENGTH SPECIFIED 55270020 DC X'01' FIRST CHARACTER MUST BE 55280020 * ALPHABETIC 55290020 DC X'03' OTHER CHARACTERS MUST BE 55300020 * ALPHAMERIC 55310020 DC X'1F' MAXIMUM LENGTH = 31 55320020 SPACE 55330020 * 55340020 * L FORM OF I/O SERVICE ROUTINE MACROS. 55350020 * 55360020 LPUTLINE PUTLINE ,MF=L * * * * 55370020 SPACE 55380020 LPLEND EQU * USED TO GET LENGTH OF LPUTLINE 55390020 SPACE 55400020 LPUTGET PUTGET ,MF=L * * * * 55410020 SPACE 55420020 LPGEND EQU * USED TO GET LENGTH OF LPUTGET 55430020 SPACE 55440020 AGENSCAN DC V(GENSCAN) ADDRESS OF GENSCAN ROUTINE 55450020 * CONTAINED IN IKJEFP20 55460020 ATRANSQ DC V(TRANSQ) ADDRESS OF TRANSLATE ROUTINE 55470020 * CONTAINED IN IKJEFP20 55480020 ATRTAB DC A(TRTAB) ADDRESS OF TABLE USED BY 55490020 * TYPETEST IN SYNTAX CHECKING 55500020 * CONTAINED IN IKJEFP20 55510020 AUPTAB DC A(UPPERTAB) ADDRESS OF TABLE USED TO 55520020 * TRANSLATE DATA TO UPPERCASE 55530020 * CONTAINED IN IKJEFP20 55540020 EJECT 55550020 PWORK IKJEFPWA 55560020 EJECT 55570020 *********************************************************************** 55580020 * * 55590020 * RECURSIVE WORKSPACE * 55600020 * * 55610020 *********************************************************************** 55620020 SPACE 55630020 RWORK DSECT 55640020 SPACE 55650020 RPCEAD DS A ADDRESS OF SUBFIELD PCE 55660020 SPACE 55670020 RBASESV DS A BACK CHAIN TO PREVIOUS RWORK 55680020 SPACE 55690020 RXPCESV DS A RESUME PCE ADDRESS WHEN GO BACK 55700020 SPACE 55710020 RLINKSV DS A RETURN ADDRESS FROM RECURSE 55720020 SPACE 55730020 RKEYSV DS A STARTING KEYWORD ADDRESS 55740020 SPACE 55750020 RLINKSV1 DS A SAVE LINKAGE DURING ERASE 55760020 SPACE 55770020 RFLAGS DS X FLAG BYTE 55780020 SPACE 55790020 RWORKSZ EQU *-RWORK RECURSIVE WORKSPACE LENGTH 55800020 EJECT 55810020 END 55820020 ./ ADD SSI=01010690,NAME=IKJEFP10,SOURCE=0 MACRO 00062020 MESSAGE &TEXT 00062120 .* 00062220 .* THIS MACRO IS USED TO DEFINE THE MESSAGE FORMATS. EACH MESSAGE IS 00062320 .* GENERATED INTO A FORM ACCEPTABLE TO THE TSO I/O ROUTINES. 00062420 .* 00062520 LCLA &LENGTH 00062620 LCLC &NAME 00062720 &LENGTH SETA K'&TEXT-2 LENGTH OF MESSAGE MINUS QUOTES 00062820 &NAME SETC '&TEXT'(2,8) USE 8 BYTES OF MESSAGE ID AS 00062920 .* LABEL 00063020 &NAME DC 0H'0' ALIGN MESSAGE SEGMENT 00063120 DC AL2(&LENGTH+4) SEGMENT LENGTH 00063220 DC AL2(0) FIRST SEGMENT OFFSET 00063320 DC C&TEXT MESSAGE TEXT 00063420 MEND 00063520 P10 TITLE 'IKJEFP10 TSO PARSE MESSAGE MODULE VERSION 2 DATE 3/*00063920 9/71' 00064020 *********************************************************************** 00064220 * * 00064320 * TITLE -- 'IKJEFP10 MESSAGE MODULE FOR TSO PARSE ROUTINE * 00064420 * * 00064520 * STATUS -- VERSION 2 * 00064620 * * 00064720 * FUNCTION -- THIS MODULE CONTAINS THE MESSAGE SEGMENTS USED BY * 00064820 * THE TSO PARSE ROUTINE (MODULE IKJEFP00) TO CONSTRUCT THE * 00064920 * MESSAGES WHICH MAY BE SENT TO THE TERMINAL USER IN THE COURSE * 00065020 * OF ITS PROCESSING. THE MESSAGE SEGMENTS ARE IN THE FORMAT * 00065120 * REQUIRED BY THE TSO I/O SERVICE ROUTINES. THEY ARE ACCESSED * 00065220 * BY INDEXING INTO A TABLE WHICH CONTAINS THE ADDRESSES OF * 00065320 * THE MESSAGE SEGMENTS. * 00065420 * * 00065520 * ENTRY POINTS - THIS MODULE CONTAINS NO EXECUTABLE CODE. * 00065620 * IKJEFP10: ADDRESS OF THE TABLE USED TO ACCESS THE * 00065720 * MESSAGE SEGMENTS. * 00065820 * * 00065920 * INPUT -- N/A * 00066020 * * 00066120 * OUTPUT -- N/A * 00066220 * * 00066320 * EXTERNAL REFERENCES -- NONE * 00066420 * * 00066520 * EXISTS,NORMAL -- N/A * 00066620 * * 00066720 * EXITS,ERROR -- N/A * 00066820 * * 00066920 * TABLES/WORK AREAS -- THE MESSAGE SEGMENTS ARE ACCESSED BY * 00067020 * INDEXING INTO A TABLE WHICH CONTAINS THE ADDRESSES OF THE * 00067120 * MESSAGE SEGMENTS. * 00067220 * * 00067320 * ATTRIBUTES -- N/A * 00067420 * * 00067520 * CHARACTER CODE DEPENDENCY -- CLASS A: THE OPERATION OF THIS * 00067620 * MODULE DOES NOT DEPEND UPON A PARTICULAR INTERNAL REPRESENTATION * 00067720 * OF THE EXTERNAL CHARACTER SET. * 00067820 * * 00067920 * NOTES -- THE BEGINNING OF THIS MODULE CONTAINS A PRIVATE MACRO * 00068020 * WHICH IS USED TO DEFINE THE MESSAGE SEGMENT FORMAT. * 00068120 * * 00068220 * RELEASE 20 SUPPORT CODE -- 20035 * 00068320 * * 00068620 *********************************************************************** 00068920 EJECT 00069020 IKJEFP10 CSECT 00080020 * M1564 00082020 SPACE 00090020 DC A(IKJ56700) CODE = 0 ENTER 00100020 DC A(IKJ56701) CODE = 4 MISSING 00110020 DC A(IKJ56703) CODE = 8 REENTER 00120020 DC A(IKJ56704) CODE = 12 AMBIGUOUS 00130020 DC A(IKJ56705) CODE = 16 MISSING PASSWORD 00140020 DC A(IKJ56702) CODE = 20 INVALID 00150020 DC A(IKJ56706) CODE = 24 END QUOTE ASSUMED 00160020 DC A(IKJ56707) CODE = 28 RIGHT PAREN ASSUMED 00170020 DC A(IKJ56708) CODE = 32 INVALID PASSWORD M1564 00180020 DC A(IKJ56709) CODE = 36 INVALID DATA SET NAME 00190020 DC A(IKJ56710) CODE = 40 INVALID USERID 00200020 DC A(IKJ56711) CODE = 44 INVALID ADDRESS 00210020 DC A(IKJ56712) CODE = 48 INVALID KEYWORD 00220020 DC A(IKJ56713) CODE = 52 INVALID VALUE 00230020 DC A(IKJ56714) CODE = 56 ENTER PASSWORD 00240020 DC A(IKJ56715) CODE = 60 INVALID STRING 00250020 DC A(IKJ56716) CODE = 64 EXTRANEOUS INFORMATION 00260020 DC A(IKJ56717) CODE = 68 INVALID M1564 00264020 SPACE 00270020 MESSAGE 'IKJ56700A ENTER -' 00280020 SPACE 00290020 MESSAGE 'IKJ56701I MISSING ' 00300020 SPACE 00310020 MESSAGE 'IKJ56702I INVALID , ' 00320020 SPACE 00330020 MESSAGE 'IKJ56703A REENTER -' 00340020 SPACE 00350020 MESSAGE 'IKJ56704I AMBIGUOUS' 00360020 SPACE 00370020 MESSAGE 'IKJ56705I MISSING PASSWORD FOR ' 00380020 SPACE 00390020 MESSAGE 'IKJ56706I ENDING QUOTE ASSUMED, ' 00400020 SPACE 00410020 MESSAGE 'IKJ56707I RIGHT PARENTHESIS ASSUMED, ' 00420020 SPACE 00430020 MESSAGE 'IKJ56708I INVALID PASSWORD ' 00440020 SPACE 00450020 MESSAGE 'IKJ56709I INVALID DATA SET NAME, ' 00460020 SPACE 00470020 MESSAGE 'IKJ56710I INVALID USERID, ' 00480020 SPACE 00490020 MESSAGE 'IKJ56711I INVALID ADDRESS, ' 00500020 SPACE 00510020 MESSAGE 'IKJ56712I INVALID KEYWORD, ' 00520020 SPACE 00530020 MESSAGE 'IKJ56713I INVALID VALUE, ' 00540020 SPACE 00550020 MESSAGE 'IKJ56714A ENTER PASSWORD FOR -' 00560020 SPACE 00570020 MESSAGE 'IKJ56715I INVALID STRING, ' 00580020 SPACE 00590020 MESSAGE 'IKJ56716I EXTRANEOUS INFORMATION - IGNORED, ' 00600020 SPACE 00600420 MESSAGE 'IKJ56717I INVALID ' 00602020 END 00610020 ./ ADD SSI=21181225,NAME=IKJEFP20,SOURCE=0 P20 TITLE 'IKJEFP20 COMMON MODULE FOR PARSE AND COMMAND SCAN *00020120 VERSION TWO DATE 8/7/70' 00020220 ********************************************************************** 00022320 * 00022720 * TITLE -- IKJEFP20- COMMON MODULE FOR PARSE AND COMMAND SCAN 00024320 * 00024420 * STATUS -- VERSION THREE 00040400 * 00042020 * FUNCTION/OPERATION -- GENERALIZED SCAN SYNTAX CHECKS PARAMETERS FOR 00043620 * PARSE AND COMMAND SCAN ACCORDING TO CONTROL INFORMATION 00045220 * SET UP BY THE CALLER FOR THE SCAN. THIS ROUTINE ALSO TRANSLATES 00046820 * A PARAMETER TO UPPER CASE. 00048420 * 00050020 * ENTRY POINTS -- GENSCAN -- ENTRY POINT AT WHICH SYNTAX CHECKING OF A 00051620 * PARAMETER IS DONE ACCORDING TO CONTROL INFORMATION PASSED. 00053220 * TRANSQ -- ENTRY POINT AT WHICH A PARAMETER IS TRANSLATED TO UPPER- 00054820 * CASE. 00056420 * TRANSX -- ENTRY POINT TO TRANSLATE TO UPPERCASE IF PARAMETER 00058020 * IS KNOWN NOT TO BE DEFAULTED. 00059620 * TRTAB -- ENTRY POINT TO ACCESS TABLE ASSIGNING A CHARACTER CLASS 00061220 * TO AN EBCIDIC CHARACTER. 00062820 * UPPERTAB -- ENTRY POINT TO ACCESS TRANSLATE TABLE ONLY. 00064420 * 00066020 * INPUT -- PDWORD CONTAINS A POINTER TO A WORD CONTAINING 00067620 * CONTROL INFORMATION 00069220 * ********************************************************** 00070820 * / SCAN OPTIONS / FIRST CHARACTER /OTHER CHARACTER/MAXIMUM/ 00072420 * / / TYPE / TYPE /LENGTH / 00074020 * ********************************************************** 00075620 * 0 1 2 3 00077220 * REGISTER FOUR CONTAINS POINTER TO PARAMETER TO BE SCANNED. 00078820 * --TRANSLATION FUNCTION - PPOINTER CONTAINS ADDRESS 00080420 * OF PARAMETER TO BE TRANSLATED 00082020 * PLENGTH CONTAINS LENGTH OF PARAMETER. 00083620 * 00085220 * OUTPUT -- THE TRANSLATED PARAMETER IN ITS ORIGINAL BUFFER. 00086820 * 00088420 * EXTERNAL REFERENCES -- NONE 00090020 * 00091620 * EXITS- NORMAL-- FROM SCAN ROUTINE EXITS TO THE LINK REGISTER 00093220 * ADDRESS 00094820 * +0 - IF PARAMETER IS MISSING 00096420 * +4 - IF PARAMETER IS INVALID 00098020 * +8 - IF END OF BUFFER IS ALSO PARAMETER END 00099620 * +12- IF PARAMETER NOT AT END OF BUFFER 00101220 * 00102820 * --FROM TRANSLATION ROUTINE EXITS TO LINK REGISTER ADDRESS 00104420 * 00106020 * EXITS- ERROR-- NONE 00107620 * 00109220 * TABLES/WORKAREAS -- TRTAB-TABLE WHICH ASSIGNS CHARACTER CLASS TO 00110820 * EACH EBCIDIC CONFIGURATION 00112420 * CHARTYPE-TABLE WHICH SELECTS MASK FOR TYPE OF CHARACTER REQUIRED 00114020 * BY ROUTINE WHICH TEST CHARACTER TYPE. 00115620 * IKJEFPWA-MACRO MAPPING WORK AREA. 00117220 * ATTRIBUTES -- REENTRANT 00118820 * 00120420 * CHARACTER CODE DEPENDENCY -- CLASS C. THE OPERATION OF THIS MODULE 00122020 * IS DEPENDENT UPON AN INTERNAL REPRESENTATION OF THE EXTERNAL CHAR 00123620 * ACTER SET WHICH IS EQUIVALENT TO THE ONE USED AT ASSEMBLY TIME. 00125220 * THE CODING HAS BEEN ARRANGED SO THAT REDEFINITION OF 'CHARACTER' 00126820 * CONSTANTS,BY REASSEMBLY, WILL RESULT IN A CORRECT MODULE FOR THE 00128420 * NEW DEFINITION. 00130020 * 00131620 * RELEASE 20 SUPPORT CODE -- 20035 00133220 * 00134820 ********************************************************************** 00136420 EJECT 00138020 IKJEFP20 CSECT 00139620 * F41448 - COBOL SYMBOLIC DEBUG SUPPORT 00140000 ENTRY GENSCAN,TRANSQ,TRANSX,TRTAB,UPPERTAB 00141220 SPACE 00142820 * 00144420 * REGISTER EQUATES. 00146020 * 00147620 R0 EQU 0 SCRATCH/PARAMETER REGISTER -- 00149220 * MUST BE 0 00150820 R1 EQU 1 SCRATCH/PARAMETER REGISTER -- 00152420 * MUST BE 1 00154020 R2 EQU 2 GENERAL SCRATCH REGISTER 00155620 R3 EQU 3 GENERAL SCRATCH REGISTER 00157220 XINPUT EQU 4 NEXT CHARACTER TO SCAN 00158820 XINPUTB EQU 5 LAST CHARACTER SCANNED USED TO 00160420 * COMPUTE LENGTH OF SCANNED 00162020 * DATA 00163620 XPCE EQU 6 IF CALLED BY PARSE, POINTS TO 00165220 * THE CURRENT PCE. IF CALLED 00166820 * BY COMMAND SCAN, NOT USED. 00168420 R7 EQU 7 NOT USED 00170020 LINK2 EQU 8 SECOND LEVEL RETURN REGISTER 00171620 LINK1 EQU 9 FIRST LEVEL RETURN REGISTER 00173220 R10 EQU 10 NOT USED 00174820 R11 EQU 11 NOT USED 00176420 R12 EQU 12 NOT USED 00178020 WORKBASE EQU 13 BASE REGISTER FOR COMMON 00179620 * WORKSPACE -- MUST BE 13 00181220 R14 EQU 14 SCRATCH REGISTER 00182820 BASE EQU 15 LINKAGE REGISTER USED AS 00184420 * BASE REGISTER 00186020 * 00187620 * BIT SETTINGS FOR CHARACTER TYPES USED BY TYPETEST 00189220 * 00190820 HEX EQU X'80' HEX CHARACTER 00192420 OLETTER EQU X'40' LETTER NOT A HEX CHARACTER 00194020 NATL EQU X'20' NATIONAL CHARACTER 00195620 NUMBER EQU X'10' NUMBER 00197220 SEPAR EQU X'08' SEPARATOR 00198820 NSEPDLIM EQU X'04' DELIMITER THAT IS NOT A 00200420 * A SEPARATOR 00202020 NDLIMSPC EQU X'02' SPECIAL CHARACTER THAT IS NOT 00203620 * ALSO A DELIMITER OR A 00205220 * SEPARATOR 00206820 CMDDLIM EQU X'01' COMMAND NAME DELIMITER 00208420 INVALID EQU X'00' INVALID CHARACTER 00210020 SPACE 00211620 * 00213220 * BIT PATTERNS USED TO TEST THE OPTIONS SELECTED BY THE PARSE USER AND 00214820 * REFLECTED IN VARIOUS BYTES IN THE PCE. 00216420 * 00218020 PCEFPRPT EQU B'00010000' BIT 3 - PROMPT IS SPECIFIED 00219620 PCEFDFLT EQU B'00001000' BIT 4 - DEFAULT IS SPECIFIED 00221220 PCEFSUBF EQU B'00000100' BIT 5 - SUBFIELD IS SPECIFIED 00222820 PCEFHELP EQU B'00000010' BIT 6 - HELP IS SPECIFIED 00224420 PCEFVCHK EQU B'00000001' BIT 7 - VALIDITY CHECK EXIT IS 00226020 * SPECIFIED 00227620 PCEFLIST EQU B'10000000' BIT 8 - LIST IS SPECIFIED 00229220 PCEFASIS EQU B'01000000' BIT 9 - NO TRANSLATION REQUIRED 00230820 PCEFRNGE EQU B'00100000' BIT 10 - RANGE IS SPECIFIED 00232420 PCEFINST EQU B'00010000' BIT 11 - INSERT IS SPECIFIED 00234020 PCEFASTK EQU B'10000000' BIT 0 - ASTERISK IS ALLOWED 00235620 PCEFMAXL EQU B'01000000' BIT 1 - MAXLNTH IS SPECIFIED 00237220 SPACE 00238820 * 00240420 * OFFSETS FOR REQUIRED FIELDS IN PARSE PCE'S. 00242020 * 00243620 PCEPCLLN EQU 0 PCL LENGTH FIELD IN IKJPARM 00245220 PCEPDLLN EQU 2 PDL LENGTH FIELD IN IKJPARM 00246820 PCEKYEND EQU 4 IKJKEYWD OR END-OF-FIELD OFFSET 00248420 * IN IKJPARM 00250020 PCEFLGB1 EQU 0 FLAG BYTE 1 00251620 PCEFLGB2 EQU 1 FLAG BYTE 2 00253220 PCELEN EQU 2 - 3 PCE LENGTH 00254820 PCEPDEO EQU 4 - 5 PDE OFFSET INTO PDL 00256420 PCEPOST EQU 6 TYPE OF POSITIONAL PARAMETER 00258020 PCENAML EQU 4 LENGTH OF NAME FOR IKJNAME 00259620 PCENAMN EQU 5 - N NAME SPECIFIED 00261220 PCEOPT EQU 6 IKJIDENT OPTION BYTE 00262820 PCEFIRST EQU 7 IKJIDENT FIRST CHARACTER FLAGS 00264420 PCEOTHER EQU 8 IKJIDENT OTHER CHARACTER FLAGS 00266020 PCEPARMT EQU 9 IKJIDENT PARAMETER TYPE SEGMENT 00267620 EJECT 00269220 * 00270820 * MISCELLANEOUS EQUATES 00272420 * 00274020 ZERO EQU 0 USED AS A 0 00275620 ONE EQU 1 USED AS A 1 00277220 TWO EQU 2 USED AS A 2 00278820 FOUR EQU 4 USED AS A 4 00280420 EIGHT EQU 8 USED AS A 8 00282020 TWELVE EQU 12 USED AS A 12 00283620 CC1 EQU 1 CONDITION CODE 1 00285220 CC5 EQU 5 CONDITION CODE 5 00286820 CC8 EQU 8 CONDITION CODE 8 00288420 CC13 EQU 13 CONDITION CODE 13 00290020 IPDLMAXE EQU 10 MAXIMUM INPUT STACKING DEPTH FOR 00291620 * A INPUT PUSHDOWN STACK 00293220 ASTERISK EQU C'*' ASTERISK 00294820 LEFTPRN EQU C'(' LEFT PARENTHESIS 00296420 RIGHTPRN EQU C')' RIGHT PARENTHESIS 00298020 HE0 EQU X'E0' USED TO OBTAIN TYPE INDICATOR 00299620 * FROM PCE FLAG BYTE 00301220 SPACE 00302820 * 00304420 * PCE TYPE USED TO DETERMINE THE TYPE OF PCE BEING PROCESSED 00306020 * 00307620 KEYWDPCE EQU X'40' KEYWORD PCE 00309220 RSVDPCE EQU X'A0' RESERVED WORD PCE FOR F41448 00309600 * COBOL F41448 00310000 EJECT 00310800 GENSCAN DS 0H GENERALIZED SCAN ROUTINE 00312420 SPACE 00314020 * 00315620 * ESTABLISH ADDRESSABILITY USING THE CALL REGISTER (R15) AS A 00317220 * BASE REGISTER. 00318820 * 00320420 USING *,BASE ESTABLISH ADDRESSABILITY 00322020 * FOR GENSCAN 00323620 USING PWORK,WORKBASE ESTABLISH ADDRESSABILITY TO 00325220 * COMMON WORKAREA 00326820 L R3,PDWORD GET PTR TO GENSCAN CONTROL INFO 00328420 USING GCONTROL,R3 ESTABLISH ADDRESSABILITY TO 00330020 * GENSCAN CONTROL INFORMATION 00331620 LA XINPUT,ONE(XINPUT) GET NEXT CHARACTER 00333220 CLC GFIRST(L'GFIRST+L'GOTHER),H0 IS THIS AN ANY/ANY 00334820 * COMBINATION 00336420 BZ GS02 IF YES BRANCH --- IF ASTERISK 00338020 * WAS SUPPLIED IT IS REDUNDANT 00339620 * WITH ANY/ANY OPTIONS 00341220 SPACE 00342820 TM GOPTIONS,ASTKALWD IS AN ASTERISK ALLOWED 00344420 BZ GS02 NO, CONTINUE 00346020 SPACE 00347620 CLI ZERO(XINPUT),ASTERISK IS THERE AN ASTERISK IN THE 00349220 * BUFFER 00350820 BNE GS02 NO, CONTINUE 00352420 SPACE 00354020 GS015 DS 0H ONE CHARACTER RETURN 00355620 LA XINPUT,ONE(XINPUT) GET NEXT CHARACTER 00357220 LR XINPUTB,XINPUT SET LAST CHAR SCANNED 00358820 C XINPUTB,ENDINPUT IS SCAN AT END OF CURRENT INPUT 00360420 BNL EIGHT(LINK2) YES, RETURN +8 INDICATING THE 00362020 * PARAMETER IS GOOD AND ENDED 00363620 * AT THE END OF THE BUFFER 00365220 SPACE 00366820 B TWELVE(LINK2) NO, RETURN +12 INDICATING THE 00368420 * PARAMETER IS GOOD BUT THE 00370020 * DELIMITER MUST BE CHECKED 00371620 SPACE 00373220 GS02 DS 0H CHECK FIRST CHARACTER 00374820 XR R2,R2 CLEAR DEPTH METER 00376420 XR R1,R1 CLEAR WORK REG 00378020 IC R1,GFIRST GET FIRST CHARACTER TYPE 00379620 * INDICATOR AND USE AS INDEX 00381220 * INTO TYPE DESIRED TABLE 00382820 IC R1,CHARTYPE(R1) SET TYPE DESIRED FOR TYPETEST 00384420 BAL LINK1,TYPETEST TEST FIRST CHARACTER SYNTAX 00386020 SPACE 00387620 B ZERO(LINK2) +0 RETURN - THE FIRST CHARACTER 00389220 * IS INVALID. RETURN IS TO 00390820 * LINK2+0 INDICATING THE 00392420 * PARAMETER IS MISSING 00394020 * 00395620 * +4 RETURN - THE FIRST CHARACTER 00397220 * IS VALID, CONTINUE 00398820 SPACE 00400420 CLI ZERO(XINPUT),LEFTPRN IS THE CHARACTER A LEFT PAREN 00402020 BNE GS03 IF NO SKIP SETTING OF DEPTH 00403620 * METER 00405220 SPACE 00406820 LA R2,ONE SET DEPTH METER TO ONE 00408420 SPACE 00410020 GS03 DS 0H * * * * 00411620 ST XINPUT,PPOINTR SAVE PTR TO PARM 00413220 TM GOPTIONS,MAXLSPEC IS A MAX LENGTH SPECIFIED 00414820 BZ GS04 NO, CONTINUE 00416420 SPACE 00418020 CLI GMAXLNTH,ONE IS THE MAX LENGTH 1 00419620 BE GS015 YES, RETURN AS WITH ASTERISK 00421220 SPACE 00422820 XR R0,R0 ZERO LOOP CONTROL REG 00424420 IC R0,GMAXLNTH USE MAXLENGTH FOR CONTROL OF 00426020 * SCAN LOOP 00427620 SPACE 00429220 GS04 DS 0H * * * * 00430820 XR R1,R1 CLEAR WORK REG 00432420 IC R1,GOTHER GET OTHER CHARACTER TYPE 00434020 * INDICATOR AND USE AS INDEX 00435620 * INTO TYPE DESIRED TABLE 00437220 IC R1,CHARTYPE(R1) SET TYPE DESIRED FOR TYPETEST 00438820 SPACE 00440420 GSLOOP DS 0H OTHER LOOP 00442020 LA XINPUT,ONE(XINPUT) GET NEXT CHARACTER 00443620 LR XINPUTB,XINPUT SET LAST CHARACTER SCANNED 00445220 C XINPUT,ENDINPUT IS SCAN AT END OF CURRENT INPUT 00446820 BNL EIGHT(LINK2) YES, RETURN +8 INDICATING THE 00448420 * PARAMETER IS GOOD AND ENDED 00450020 * AT THE END OF THE BUFFER 00451620 SPACE 00453220 BAL LINK1,TYPETEST TEST CHARACTER SYNTAX 00454820 SPACE 00456420 B GS06 +0 RETURN - THE CHARACTER IS 00458020 * AN INVALID OTHER CHARACTER. 00459620 * SEE IF THE DEPTH METER 00461220 * SHOULD BE CHECKED 00462820 SPACE 00464420 * +4 RETURN - THE CHARACTER IS 00466020 * A VALID OTHER CHARACTER, 00467620 * CONTINUE 00469220 SPACE 00470820 CLI GOTHER,ZERO IS THE OTHER CHARACTER AN ANY 00472420 BNE GS05 IF NO SKIP OVER FURTHER CHECKS 00474020 SPACE 00475620 CLI ZERO(XINPUT),LEFTPRN IS THE NEXT CHARACTER A LEFT 00477220 * PARENTHESIS 00478820 BNE GS05 IF NO SKIP SETTING DEPTH METER 00480420 SPACE 00482020 LA R2,ONE(R2) INCREMENT DEPTH METER BY ONE 00483620 SPACE 00485220 GS05 DS 0H * * * * 00486820 TM GOPTIONS,MAXLSPEC IS A MAX LENGTH SPECIFIED 00488420 BZ GSLOOP NO, SCAN NEXT CHAR 00490020 SPACE 00491020 BCT R0,GSLOOP YES, DECREMENT LENGTH AND TEST 00500020 * FOR 0, IF GREATER THAN 0 SCAN 00510020 * NEXT CHARACTER 00520020 SPACE 00530020 B FOUR(LINK2) IF R0 REACHES 0, THE 00540020 * MAXIMUM LENGTH HAS BEEN 00541020 * EXCEEDED. RETURN IS TO LINK2+4 00542020 * INDICATING THE PARAMETER IS 00543020 * INVALID 00544020 SPACE 00544120 GS06 DS 0H * * * * 00544420 CLI GOTHER,ZERO IS THE OTHER CHARACTER AN ANY 00544520 BNE TWELVE(LINK2) RETURN TO LINK2+12 INDICATING 00544620 * THE PARAMETER IS GOOD BUT THE 00544820 * DELIMITER MUST BE CHECKED 00544920 SPACE 00545020 CLI ZERO(XINPUT),RIGHTPRN IS CHARACTER A RIGHT PAREN 00545120 BNE TWELVE(LINK2) IF NO EXIT 00545220 SPACE 00545320 BCTR R2,ZERO DECREMENT DEPTH METER 00545420 LTR R2,R2 IS THIS THE END OF THE PARAMETER 00545520 BM TWELVE(LINK2) IF YES EXIT 00545620 SPACE 00545720 B GS05 NOT PARAMETER END CONTINUE SCAN 00545820 EJECT 00545920 *********************************************************************** 00546020 * * 00547020 * CHARACTER TYPE TEST ROUTINE * 00548020 * * 00549020 * THIS IS AN INTERNAL SUBROUTINE WHICH CHECKS THE CURRENT CHARACTER * 00549120 * FOR BELONGING TO A SPECIFIED CHARACTER CLASS. * 00549520 * * 00549620 * INPUT - R1=MASK OF DESIRED CHARACTER CLASS. * 00549720 * XINPUT=POINTER TO CHARACTER TO BE CHECKED. * 00549820 * * 00549920 * OUTPUT - THE RESULT OF THE TEST IS INDICATED BY THE * 00550020 * LOCATION TO WHICH CONTROL IS RETURNED. * 00550120 * * 00550220 * EXISTS - LINK1+0=THE CHARACTER DOES NOT BELONG TO THE SPECIFIED * 00550320 * CHARACTER CLASS. * 00550420 * * 00550520 * - LINK1+4=THE CHARACTER BELONGS TO THE CHARACTER CLASS * 00550620 * SPECIFIED. * 00550720 * * 00550820 *********************************************************************** 00550920 SPACE 00551020 TYPETEST DS 0H * * * * 00551120 XR R14,R14 CLEAR WORK REG 00551220 IC R14,ZERO(XINPUT) USE CURRENT CHARACTER AS 00551320 * OFFSET INTO TESTING TABLE 00551420 LA R14,TRTAB(R14) GET ADDRESS IN TABLE 00551520 * CORRESPONDING TO CHARACTER IN 00551620 * QUESTION 00551720 EX R1,TYPETM EXECUTE TEST UNDER MASK OF 00551820 * TYPEBYTE FOR CHARACTER 00551920 * SPECIFICATION GIVEN IN R1 00552020 * 00552120 BC CC5,FOUR(LINK1) TYPE MATCHES, RETURN +4 00552320 * 00552420 BR LINK1 TYPE DOESN'T MATCH, RETURN +0 00552520 EJECT 00552720 *********************************************************************** 00560020 * * 00570020 * TRANSLATE INPUT DATA SUBROUTINE * 00580020 * * 00590020 * THIS ROUTINE TRANSLATES THE INPUT DATA TO UPPERCASE UNLESS THE * 00600020 * ASIS OPTION WAS SELECTED BY THE USER. THE INPUT DATA ADDRESS IS * 00610020 * TAKEN FROM PPOINTR AND THE LENGTH FROM PLENGTH. IF THE DATA LIES * 00620020 * WITHIN THE PCE (DEFAULTED) NO TRANSLATION TAKES PLACE. * 00630020 * * 00640020 *********************************************************************** 00650020 SPACE 00660020 TRANSQ DS 0H TRANSLATION SUBROUTINE 00670020 USING *,BASE ESTABLISH ADDRESSABILITY 00671020 * FOR TRANSLATE ROUTINE 00672020 SPACE 00675020 MVC PDWORD(ONE),PCEFLGB1(XPCE) MOVE PCE FLAG 00676020 * BYTE TO WORKAREA 00677020 NI PDWORD,HE0 ISOLATE PCE TYPE INDICATORS 00678020 CLI PDWORD,KEYWDPCE IS IT A KEYWORD PCE 00679020 BE TRANS YES, TRANSLATE 00679120 SPACE 00679220 CLI PDWORD,RSVDPCE IS IT A RESERVED WORD F41448 00679600 * PCE? F41448 00679700 BO TRANS IF YES, TRANSLATE F41448 00679800 * REGARDLESS F41448 00679900 SPACE 00683200 TM PCEFLGB2(XPCE),PCEFASIS SHOULD THE DATA BE TRANSLATED TO 00686700 * UPPERCASE 00690020 BCR CC1,LINK1 NO RETURN TO CALLER 00700020 SPACE 00710020 TRANS DS 0H BRANCHED TO FOR TRANSLATION OF A 00720020 * KEYWORD PARAMETER 00730020 NC PPOINTR+ONE(L'PPOINTR-ONE),PPOINTR+ONE IS THERE ANY DATA 00740020 * TO CONVERT 00750020 BCR CC8,LINK1 IF NO RETURN TO CALLER 00760020 SPACE 00770020 CLC PPOINTR+ONE(L'PPOINTR-ONE),PTABLEAD+ONE DOES THE DATA 00780020 * LIE WITHIN THE PCL 00790020 BL TRANS1 NO BRANCH - CANNOT BE DEFAULT 00800020 SPACE 00810020 CLC PPOINTR+ONE(L'PPOINTR-ONE),PTABLEND+ONE DOES THE DATA 00820020 * LIE WITHIN THE PCL 00830020 BCR CC13,LINK1 YES WITHIN PCL MUST BE DEFAULT 00840020 B TRANS1 BRANCH AROUND TRANSX CODE 00841020 SPACE 00850020 *********************************************************************** 00881020 * * 00882020 * IF TRANSLATE ROUTINE IS ENTERED AT ENTRY POINT TRANSX, ADJUST * 00883020 * THE VALUE OF THE BASE REGISTER (WHICH IS ALSO THE CALL REGISTER) * 00884020 * SO THAT LOCATIONS ABOVE THIS ENTRY POINT WILL BE ADDRESSABLE * 00885020 * BY INSTRUCTIONS BELOW THIS ENTRY POINT. * 00886020 *********************************************************************** 00887020 SPACE 00888020 TRANSX DS 0H * * * * 00890020 LA R14,TRANSX-TRANSQ LOAD SCRATCH REG WITH 00891020 * DIFFERENCE IN ENTRY POINTS 00892020 SR BASE,R14 ADJUST VALUE OF BASE REGISTER 00893020 * TO THAT AT ENTRY POINT TRANSQ 00894020 SPACE 00896020 * 00896220 * PROCEED TO TRANSLATE DATA TO UPPERCASE. 00896320 * 00896420 TRANS1 DS 0H * * * * 00897020 LH R14,PLENGTH LOAD LENGTH OF DATA 00900020 LTR R14,R14 ANY DATA TO TRANSLATE 00910020 BCR CC8,LINK1 NO ZERO RETURN TO CALLER 00920020 SPACE 00930020 BCTR R14,ZERO REDUCE FOR 'EX' INSTRUCTION 00940020 L R1,PPOINTR LOAD ADDRESS OF DATA 00950020 EX R14,TRANSTR TRANSLATE TO UPPERCASE 00960020 BR LINK1 RETURN TO CALLER 00970020 SPACE 00980020 H0 DC H'0' HALFWORD OF ZEROES FOR CLC 00981020 SPACE 00982020 DATE DC C'IKJEFP20-8/7/70' MODULE LEVEL IDENTITY CONSTANT 00983020 SPACE 00990020 * 01000020 * TRANSLATION TABLE USED BY TRANSLATE TO UPPERCASE ROUTINE. 01010020 * 01020020 UPPERTAB DC 256AL1(*-UPPERTAB) GENERATE BASIC TABLE 01030020 ORG UPPERTAB+C'A'-X'40' POSITION INST. CTR. TO SMALL A-Z 01040020 DC (C'Z'-C'A'+1)AL1(*-UPPERTAB+X'40') RAISE LOWER TO UPPER 01050020 ORG UPPERTAB+256 RESET INSTRUCTION COUNTER 01060020 EJECT 01070020 * 01080020 * THIS 256 BYTE TABLE IS USED TO TEST IF A GIVEN INPUT CHARACTER 01090020 * BELONGS TO A CHARACTER CLASS. EACH EBCIDIC CONFIGURATION IS 01100020 * ASSIGNED A CHARACTER CLASS 01110020 * 01120020 TRTAB DC 256AL1(INVALID) INITIALIZE TYPETEST TABLE 01130020 ORG TRTAB+X'05' 01140020 DC AL1(SEPAR+CMDDLIM) HORIZONTAL TAB = SEPARATOR AND 01150020 * COMMAND DELIMITER 01160020 ORG TRTAB+C' ' 01170020 DC AL1(NSEPDLIM+CMDDLIM) NEW LINE CHAR = DELIMITER AND 01180020 * COMMAND DELIMITER 01190020 ORG TRTAB+C' ' 01200020 DC AL1(SEPAR+CMDDLIM) BLANK = SEPARATOR AND COMMAND 01210020 * DELIMITER 01220020 ORG TRTAB+C'›' 01230020 DC AL1(NDLIMSPC) CENT SIGN = SPECIAL 01240020 ORG TRTAB+C'.' 01250020 DC AL1(NDLIMSPC+CMDDLIM) PERIOD = SPECIAL 01260020 * AND COMMAND DELIMITER 01270020 ORG TRTAB+C'<' 01280020 DC AL1(NDLIMSPC) LESS THAN = SPECIAL 01290020 ORG TRTAB+C'(' 01300020 DC AL1(NDLIMSPC+CMDDLIM) LEFT PAREN = SPECIAL 01310020 * AND COMMAND DELIMITER 01320020 ORG TRTAB+C'+' 01330020 DC AL1(NDLIMSPC) PLUS = SPECIAL 01340020 ORG TRTAB+C'³' 01350020 DC AL1(NDLIMSPC) OR = SPECIAL 01360020 ORG TRTAB+C'&&' 01370020 DC AL1(NDLIMSPC+CMDDLIM) AMPERSAND = SPECIAL 01380020 * AND COMMAND DELIMITER 01390020 ORG TRTAB+C'!' 01400020 DC AL1(NDLIMSPC) EXCLAMATION = SPECIAL 01410020 ORG TRTAB+C'$' 01420020 DC AL1(NATL) DOLLAR SIGN = NATIONAL 01430020 ORG TRTAB+C'*' 01440020 DC AL1(NDLIMSPC) ASTERISK= SPECIAL 01450020 * AND COMMAND DELIMITER 01460020 ORG TRTAB+C')' 01470020 DC AL1(NSEPDLIM+CMDDLIM) RIGHT PAREN = SPECIAL 01480020 * AND COMMAND DELIMITER 01490020 ORG TRTAB+C';' 01500020 DC AL1(NSEPDLIM+CMDDLIM) SEMICOLON = DELIMITER 01510020 * AND COMMAND DELIMITER 01520020 ORG TRTAB+C'ª' 01530020 DC AL1(NDLIMSPC) NOT SIGN = SPECIAL 01540020 ORG TRTAB+C'-' 01550020 DC AL1(NDLIMSPC+CMDDLIM) MINUS = SPECIAL 01560020 * AND COMMAND DELIMITER 01570020 ORG TRTAB+C'/' 01580020 DC AL1(NDLIMSPC+CMDDLIM) SLASH = DELIMITER 01590020 * AND COMMAND DELIMITER 01600020 ORG TRTAB+C',' 01610020 DC AL1(SEPAR+CMDDLIM) COMMA = SEPARATOR 01620020 * AND COMMAND DELIMITER 01630020 ORG TRTAB+C'%' 01640020 DC AL1(NDLIMSPC) PERCENT = SPECIAL 01650020 ORG TRTAB+C'_' 01660020 DC AL1(NDLIMSPC) DASH = SPECIAL 01670020 ORG TRTAB+C'>' 01680020 DC AL1(NDLIMSPC) GREATER-THAN = SPECIAL 01690020 ORG TRTAB+C'?' 01700020 DC AL1(NDLIMSPC) QUESTION MARK = SPECIAL 01710020 ORG TRTAB+C':' 01720020 DC AL1(NDLIMSPC) COLON = SPECIAL 01730020 ORG TRTAB+C'#' 01740020 DC AL1(NATL) POUND SIGN = NATIONAL 01750020 ORG TRTAB+C'@' 01760020 DC AL1(NATL) AT SIGN = NATIONAL 01770020 ORG TRTAB+C'''' QUOTE 01780020 DC AL1(NDLIMSPC+CMDDLIM) QUOTE = SPECIAL 01790020 * AND COMMAND DELIMITER 01800020 ORG TRTAB+C'=' 01810020 DC AL1(NDLIMSPC+CMDDLIM) EQUAL = SPECIAL 01820020 * AND COMMAND DELIMITER 01830020 ORG TRTAB+C'"' 01840020 DC AL1(NDLIMSPC) DOUBLE QUOTE = SPECIAL 01850020 ORG TRTAB+X'81' 01860020 DC (C'F'-C'A'+1)AL1(HEX) SMALL A THRU F = HEX 01870020 DC (C'I'-C'G'+1)AL1(OLETTER) SMALL G THRU I = OTHER LETTER 01880020 ORG TRTAB+C'J' 01890020 ORG TRTAB+X'91' 01900020 DC (C'R'-C'J'+1)AL1(OLETTER) SMALL J THRU R = OTHER LETTER 01910020 ORG TRTAB+C'S' 01920020 ORG TRTAB+X'A2' 01930020 DC (C'Z'-C'S'+1)AL1(OLETTER) SMALL S THRU Z = OTHER LETTER 01940020 ORG TRTAB+C'A' 01950020 DC (C'F'-C'A'+1)AL1(HEX) A THRU F = HEX 01960020 DC (C'I'-C'G'+1)AL1(OLETTER) G THRU I = OTHER LETTER 01970020 ORG TRTAB+C'J' 01980020 DC (C'R'-C'J'+1)AL1(OLETTER) J THRU R = OTHER LETTER 01990020 ORG TRTAB+C'S' 02000020 DC (C'Z'-C'S'+1)AL1(OLETTER) S THRU Z = OTHER LETTER 02010020 ORG TRTAB+C'0' 02020020 DC (C'9'-C'0'+1)AL1(NUMBER) 0 THRU 9 = NUMBER 02030020 ORG TRTAB+256 02030120 SPACE 02031020 TRANSTR TR ZERO(*-*,R1),UPPERTAB TO CONVERT TO UPPERCASE 02032020 SPACE 02033020 TYPETM TM ZERO(R14),*-* USED BY TYPETEST TO TEST 02033120 * FOR A CHARACTER TYPE 02033220 SPACE 02033420 * 02033520 * TABLE USED BY GENSCAN TO SELECT THE CORRECT MASK TO BE PASSED 02033620 * TO TYPETEST GIVEN THE TYPE OF CHARACTER REQUIRED IN THE FORM 02033720 * OF A HEX NUMBER. 02033820 * 02033920 CHARTYPE DC 0H'0' * * * * 02034020 ANY DC AL1(HEX+OLETTER+NATL+NUMBER+NDLIMSPC) ALL ALPHABETIC 02034120 * NUMERIC,NATIONAL AND 02034220 * ENTERABLE SPECIAL CHARACTERS 02034320 * THAT ARE NOT DELIMITERS 02034420 ALPHA DC AL1(HEX+OLETTER+NATL) ALL ALPHABETIC CHARACTERS 02034520 NUMERIC DC AL1(NUMBER) ALL NUMERIC CHARACTERS 02034620 ALPHANUM DC AL1(HEX+OLETTER+NATL+NUMBER) ALL ALPHABETIC AND 02034720 * NUMERIC CHARACTERS 02034820 SPACE 02034920 * 02035220 * MAPPING OF THE CONTROL INFORMATION PASSED TO GENSCAN BY THE CALLER 02035320 * THE ADDRESS OF THE CONTROL INFORMATION IS CONTAINED IN PDWORD 02036020 * IN THE COMMON WORKAREA. 02037020 * 02038020 GCONTROL DSECT 02039020 GOPTIONS DS X FLAG BYTE WHICH INDICATES THE 02039120 * SCAN OPTIONS 02039220 GFIRST DS X FIRST CHARACTER TYPE - A HEX 02039320 * NUMBER 02039420 GOTHER DS X OTHER CHARACTERS TYPE - A HEX 02039520 * NUMBER 02039620 GMAXLNTH DS X MAXIMUM LENGTH (OPTIONAL) 02039720 SPACE 02039820 * 02039920 * GENSCAN OPTIONS FLAGS. 02040020 * 02040120 ASTKALWD EQU X'80' AN ASTERISK MAY BE SUBSTITUTED 02040220 * FOR THE PARM 02040320 MAXLSPEC EQU X'40' MAXIMUM LENGTH IS SPECIFIED 02040420 EJECT 02040620 PWORK IKJEFPWA 02050020 END 02060020 ./ ADD SSI=01012948,NAME=IKJEFP30,SOURCE=0 P30 TITLE 'IKJEFP30 TSO COMMAND SCAN PROGRAM VERSION 2 DATE 7/*00021020 10/70' 00022020 *********************************************************************** 00023020 * * 00030020 * TITLE -- 'IKJEFP30 - COMMAND SCAN FOR TSO COMMANDS' * 00040020 * * 00041020 * STATUS -- VERSION 2 * 00042020 * * 00043020 * FUNCTION/OPERATION -- COMMAND SCAN SCANS THE TSO COMMAND BUFFER FOR * 00044020 * THE COMMAND NAME, OPTIONALLY SYNTAX CHECKS IT, INDICATES * 00045020 * IF THERE ARE PARAMTERS ON THE COMMAND, AND TRANSLATES THE * 00046020 * COMMAND NAME TO UPPER CASE. SYNTAX CHECKING IS DONE BY USING * 00047020 * GENSCAN ROUTINE AND CHARACTER TYPE TABLE OF MODULE IKJEFP20. * 00048020 * TRANSLATION TO UPPERCASE IS DONE USING THE TRANSX ROUTINE OF * 00049020 * MODULE IKJEFP20. * 00049120 * * 00049220 * ENTRY POINTS -- * 00049320 * * 00049420 * IKJSCAN - PURPOSE: TO OBTAIN ALL OF THE ABOVE FUNCTION * 00049520 * - CALLING SEQUENCE: LA R1,CSPL * 00049720 * LINK EP=IKJSCAN * 00049820 * * 00049920 * INPUT -- REGSITER 1 POINTS TO THE COMMAND SCAN PARAMETER LIST * 00050020 * (CSPL). THE CSPL CONTAINS THE FOLLOWING: * 00050120 * * 00050220 * /-----------------------------------------------/ * 00050320 * / A POINTER TO THE UPT / * 00050420 * /-----------------------------------------------/ * 00050520 * / A POINTER TO THE ECT / * 00050620 * /-----------------------------------------------/ * 00050720 * / A POINTER TO THE CP'S ECB / * 00050820 * /-----------------------------------------------/ * 00050920 * / A POINTER TO A FLAG WORD / * 00051020 * /-----------------------------------------------/ * 00051120 * / A POINTER TO THE OUTPUT AREA / * 00051220 * /-----------------------------------------------/ * 00051420 * / A POINTER TO THE COMMAND BUFFER / * 00051720 * /-----------------------------------------------/ * 00051820 * 0 4 * 00051920 * * 00052020 * THE UPT, ECT, AND CP'S ECB ARE NOT USED BY COMMAND SCAN. * 00052120 * THE FLAG WORD IS OBTAINED AND FREED BY THE CALLER. BIT 0 SET TO * 00052220 * 0 = SYNTAX CHECKING. BIT 0 SET TO 1 = NO SYNTAX CHECKING. * 00052320 * THE OUTPUT AREA IS TWO WORDS IN LENGTH AND IS OBTAINED AND * 00052420 * FREED BY THE INVOKER. IT IS USED FOR THE RESULTS OF THE SCAN. * 00052520 * THE COMMAND BUFFER CONTAINS THE COMMAND TO BE SCANNED. * 00052720 * IT HAS THE FOLLOWING FORMAT: * 00052820 * * 00052920 * /-----------------------------------------------/ * 00053020 * / LENGTH / OFFSET / TEXT / * 00053120 * /-----------------------------------------------/ * 00053220 * 0 2 4 * 00053320 * * 00053420 * THE FIRST 2 BYTES CONTAIN THE TOTAL LENGTH OF THE COMMAND * 00053520 * AND HEADER. THE SECOND 2 BYTES CONTAIN THE OFFSET INTO THE * 00053620 * TEXT AT WHICH THE SCAN SHOULD BEGIN. * 00053720 * * 00053820 * OUTPUT -- THE RESULTS OF THE SCAN ARE PLACED IN THE OUTPUT AREA. * 00053920 * A POINTER TO THE OUTPUT AREA IS IN THE CSPL. IT HAS THE * 00054020 * FOLLOWING FORMAT: * 00054120 * * 00054220 * /-----------------------------------------------/ * 00054320 * / A POINTER TO THE COMMAND NAME / * 00054420 * /-----------------------------------------------/ * 00054520 * / LENGTH OF CMD. NAME / FLAGS / RESERVED / * 00054620 * /-----------------------------------------------/ * 00054720 * 0 2 3 4 * 00054820 * * 00055020 * THE POINTER AND LENGTH ARE ZERO IF THE BUFFER IS EMPTY OR * 00055120 * THE COMMAND NAME IS INVALID. THE FLAGS ARE SET AS FOLLOWS: * 00055220 * * 00055320 * X'80' VALID COMMAND WITH PARAMETERS * 00055420 * X'40' VALID COMMAND WITH NO PARAMETERS * 00055520 * X'20' QUESTION MARK * 00055620 * X'10' BUFFER IS EMPTY * 00055720 * X'08' INVALID COMMAND NAME * 00055820 * * 00055920 * THE OFFSET IN THE COMMAND BUFFER HEADER IS ALSO UPDATED. * 00056020 * IT IS SET TO THE FIRST PARAMETER FOLLOWING THE COMMAND * 00056120 * OR THE END OF THE BUFFER IF THERE ARE NO PARAMETERS * 00056220 * OR THE BUFFER WAS EMPTY. IF THE COMMAND IS INVALID THE * 00056320 * OFFSET IS UNCHANGED. * 00056420 * * 00056520 * EXTERNAL REFERENCHES -- 00056620 * GENSCAN: A SUBROUTINE OF MODULE IKJEFP20 USED TO SYNTAX * 00056720 * CHECK THE COMMAND NAME. * 00056820 * TRANSX: A SUBROUTINE OF MODULE IKJEFP20 USED TO TRANSLATE * 00056920 * THE COMMAND NAME TO UPPER CASE. * 00057020 * TRTAB: A 256 BYTE TABEL IN MODULE IKJEFP20 USED TO CHECK A * 00057120 * CHARACTER FOR A SPECIFIED CHARACTER TYPE. * 00057220 * * 00057320 * EXISTS,NORMAL -- THE FOLLOWING RETURN CODES ARE SET IN REGISTER 15. * 00057420 * 0 SUCCESSFUL COMPLETION * 00057520 * 4 THE CSPL CONTAINS INVALID PARAMETERS * 00057620 * * 00057720 * FOR A NON-ZERO RETURN CODE, THE OUTPUT AREA AND COMMAND BUFFER * 00057820 * OFFSET ARE UNCHANGED. * 00058020 * * 00058120 * EXISTS,ERROR -- N/A * 00058220 * * 00058320 * TABLES/WORK AREAS -- * 00058420 * IKJCSPL: MAPPING OF COMMAND SCAN PARAMETER LIST * 00058520 * IKJCSOA: MAPPING OF COMMAND SCAN OUTPUT AREA * 00058620 * IKJEFPWA: MAPPING OF WORKAREA USED BY COMMAND SCAN AND * 00058720 * UTILITY MODULE IKJEFP20. * 00058820 * * 00058920 * ATTRIBUTES -- REENTRANT * 00059020 * * 00059120 * CHARACTER CODE DEPENDENCY -- CLASS C. THE OPERATION OF THIS MODULE * 00059220 * DEPENDS UPON AN INTERNAL REPRESENTATION OF THE EXTERNAL * 00059420 * CHARACTER SET WHICH IS EQUIVALENT TO THE ONE USED AT * 00059520 * ASSEMBLY TIME. THE CODING HAS BEEN ARRANGED SO THAT * 00059620 * REDEFINITION OF 'CHARACTER' CONSTANTS, BY REASSEMBLY, * 00059720 * WILL RESULT IN A CORRECT MODULE FOR THE NEW DEFINITION. * 00059820 * * 00059920 * RELEASE 20 SUPPORT CODE -- 20035 * 00060020 * * 00060220 *********************************************************************** 00060320 SPACE 00070020 IKJEFP30 CSECT 00080020 ENTRY IKJSCAN ESTABLISH ENTRY POINT FOR 00090020 * COMMAND SCAN 00090120 EXTRN TRTAB EXTERNAL TABLE USED BY TYPETEST 00091020 IKJSCAN DS 0H * * * * 00100020 SPACE 00111020 * 00112020 * REGISTER EQUATES. 00113020 * 00114020 R0 EQU 0 SCRATCH/PARAMETER REGISTER -- 00115020 * MUST BE 0 00116020 R1 EQU 1 SCRATCH/PARAMETER REGISTER -- 00117020 * MUST BE 1 00118020 R2 EQU 2 GENERAL SCRATCH REGISTER 00119020 R3 EQU 3 GENERAL SCRATCH REGISTER 00119120 XINPUT EQU 4 NEXT CHARACTER TO SCAN 00119220 XINPUTB EQU 5 LAST CHARACTER SCANNED USED TO 00119320 * COMPUTE LENGTH OF SCANNED 00119420 * DATA 00119520 XFLAGS EQU 6 PTR TO INPUT FLAG WORD 00119620 CSOAPTR EQU 7 ADDRESS OF OUTPUT AREA 00119720 LINK2 EQU 8 SECOND LEVEL LINKAGE REGISTER 00120220 * FOR LINKAGE BETWEEN 00120320 * SUBROUTINES 00120420 LINK1 EQU 9 FIRST LEVEL LINKAGE REGISTER FOR 00120520 * LINKAGE BETWEEN MAINLINE AND 00120620 * SUBROUTINES 00120720 CSPLPTR EQU 10 ADDRESS OF COMMAND SCAN 00120820 * PARAMETER LIST 00120920 CBUFPTR EQU 11 ADDRESS OF COMMAND BUFFER 00121020 BASE EQU 12 BASE REGISTER FOR COMMAND SCAN 00121120 * CSECT 00121220 WORKBASE EQU 13 BASE REGISTER FOR COMMAND SCAN 00121520 * WORKSPACE -- MUST BE 13 00121920 R14 EQU 14 SCRATCH/CALL REGISTER -- MUST BE 00122020 * 14 00122120 R15 EQU 15 SCRATCH/CALL REGISTER -- MUST BE 00122220 * 15 00122320 SPACE 00122420 * 00122520 * BIT SETTINGS FOR CHARACTER TYPES USED BY TYPETEST 00122620 * 00122720 HEX EQU X'80' HEX CHARACTER 00122820 OLETTER EQU X'40' LETTER NOT A HEX CHARACTER 00122920 NATL EQU X'20' NATIONAL CHARACTER 00123020 NUMBER EQU X'10' NUMBER 00123120 SEPAR EQU X'08' SEPARATOR 00123220 NSEPDLIM EQU X'04' DELIMITER THAT IS NOT A 00123320 * A SEPARATOR 00123420 NDLIMSPC EQU X'02' SPECIAL CHARACTER THAT IS NOT 00123520 * ALSO A DELIMITER OR A 00123620 * SEPARATOR 00123720 CMDDLIM EQU X'01' COMMAND NAME DELIMITER 00123820 INVALID EQU X'00' INVALID CHARACTER 00123920 SPACE 00124020 * 00124120 * MSICELLANEOUS EQUATES 00124220 * 00124320 ZERO EQU 0 USED AS A ZERO 00124420 ONE EQU 1 USED AS A ONE 00124520 TWO EQU 2 USED AS A TWO 00124620 THREE EQU 3 USED AS A THREE 00124720 FOUR EQU 4 USED AS A FOUR 00124820 EIGHT EQU 8 USED AS AN EIGHT 00125020 QUESTMRK EQU C'?' QUESTION MARK 00125120 CC5 EQU 5 CONDITION CODE 5 00125220 SPACE 00125520 * 00125620 * COMMAND SCAN INPUT FLAGS 00125720 * 00125820 NOSYNCHK EQU X'80' INDICATES NOT TO SYNTAX CHECK 00125920 * THE COMMAND NAME 00126020 SPACE 00126120 * 00126220 * RETURN CODES 00126320 * 00126420 RCGOOD EQU 0 SUCESSFUL COMPLETION 00126520 RCINVP EQU 4 INVALID PARAMETERS - THE OFFSET 00126620 * IN THE COMMAND BUFFER IS 00127020 * GREATER THAN THE LENGTH-4 00127120 EJECT 00127320 * 00127420 * ENTRY CODE: SAVE REGISTERS AND ESTABLISH ADDRESSABILITY TO COMMAND 00127520 * SCAN CSECT AND COMMAND SCAN PARAMETER LIST. 00127620 * 00127920 SAVE (14,12),,IKJSCAN-7/10/70 SAVE CALLERS REGISTERS 00128120 SPACE 00130020 BALR BASE,ZERO ESTABLISH ADDRESSABILITY TO 00140020 USING *,BASE COMMAND SCAN CSECT 00150020 SPACE 00190020 LR CSPLPTR,R1 SAVE INPUT PARAMETER LIST ADDR 00200020 USING CSPL,CSPLPTR ESTABLISH ADDRESSABILITY TO 00201020 * COMMAND SCAN PARMATER LIST 00202020 SPACE 00210020 * 00220020 * DO UNCONDITIONAL GETMAIN FOR SAVEAREA AND FOR WORKSPACE 00230020 * NECESSARY FOR COMMAND SCAN PROCESSING. 00231020 * 00240020 GETMAIN R,LV=CSWORKSZ UNCONDITIONAL REQUEST FOR 00250020 * COMMAND SCAN WORKAREA 00260020 SPACE 00261020 * 00262020 * STANDARD LINKAGE CONVENTIONS. 00263020 * 00264020 LR R2,WORKBASE SAVE ADDRESS OF CALLER'S SAVE 00270020 * AREA 00280020 LR WORKBASE,R1 ESTABLISH COMMAND SCAN SAVEAREA 00290020 * ADDRESS AND INITIALIZE 00300020 * WORKSPACE BASE REGISTER 00310020 USING CSWORK,WORKBASE ESTABLISH ADDRESSABILITY TO 00311020 * COMMAND SCAN WORKSPACE 00312020 ST R2,FOUR(WORKBASE) BACK CHAIN TO CALLER'S SAVEAREA 00320020 ST WORKBASE,EIGHT(R2) FORWARD CHAIN TO COMMAND SCAN'S 00330020 * SAVEAREA 00340020 SPACE 00370020 * 00380020 * ESTABLISH ADDRESSABILITY TO COMMAND SCAN OUTPUT AREA 00390020 * OBTAINED BY THE INVOKER. 00391020 * 00400020 NI RETCODE,RCGOOD SET RETURN CODE TO 0 00401020 L XFLAGS,CSPLFLG GET ADDRESS OF FLAG WORD 00410020 L CSOAPTR,CSPLOA GET ADDRESS OF OUTPUT AREA 00430020 USING CSOA,CSOAPTR ESTABLISH ADDRESSABILITY TO 00440020 * OUTPUT AREA PROVIDED BY USER 00441020 SPACE 00442020 * 00442120 * ESTABLISH ADDRESSABILITY TO COMMAND BUFFER PASSED IN PARM LIST 00443020 * AND CHECK THAT THE OFFSET IS NOT GREATER THAN THE LENGTH-4. 00444020 * 00445020 L CBUFPTR,CSPLCBUF GET ADDRESS OF COMMAND BUFFER 00450020 USING CBUF,CBUFPTR ESTABLISH ADDRESSABILITY TO 00460020 * COMMAND BUFFER 00461020 XC CSOA(EIGHT),CSOA CLEAR OUTPUT AREA 00461120 MVC PDWORD(FOUR),CBUFLEN ALIGN BUFFER LENGTH ON FULL 00462020 * WORD BOUNDARY AND OFFSET ON 00463020 * HALF WORD BOUNDARY 00464020 LH R2,PDWORD LOAD LENGTH 00465020 LA R3,FOUR LOAD A FOUR FOR SUBTRACT 00466020 SR R2,R3 SUBTRACT FOUR FROM LENGTH 00467020 STH R2,PDWORD+FOUR PUT ADJUSTED LENGTH IN 00468020 * PDWORD+4 00469020 CLC PDWORD+FOUR(TWO),PDWORD+TWO IS THE LENGTH-4 GREATER 00469120 * OR EQUAL TO THE OFFSET 00469220 BNL CS01 YES,CONTINUE 00469420 SPACE 00469520 OI RETCODE,RCINVP NO, SET THE RETURN CODE TO 00469620 * INVALID PARAMETERS 00469720 B CSEXIT EXIT 00469820 SPACE 00469920 * 00470020 * START SCAN AT OFFSET INDICATED IN COMMAND BUFFER HEADER. 00470120 * 00470220 CS01 DS 0H * * * * 00470320 LR R2,CBUFPTR COPY COMMAND BUFFER ADDRESS 00470620 AH R2,PDWORD COMPUTE ADDRESS OF END OF BUFFER 00490020 ST R2,ENDINPUT SAVE FOR FUTURE COMPARES 00500020 LH R2,PDWORD+TWO LOAD CURRENT BUFFER OFFSET 00530020 LA XINPUT,THREE(R2,CBUFPTR) SET STARTING ADDRESS OF SCAN AT 00540020 * ONE BEFORE THE LOCATION 00550020 * INDICATED BY THE CURRENT 00560020 * BUFFER OFFSET 00570020 SPACE 00570220 * 00570420 * CHECK ALL COMMANDS FOR A POSSIBLE QUESTION MARK IN PLACE OF THE 00571020 * COMMAND NAME. 00572020 * 00573020 LA XINPUT,ONE(XINPUT) GET FIRST CHARACTER 00574020 LR XINPUTB,XINPUT SET LAST CHARACTER SCANNED 00575020 CLI ZERO(XINPUT),QUESTMRK IS FIRST CHAR A QUESTION MARK 00580020 BE CSEXIT20 YES,SET FLAG TO INDICATE 00590020 * QUESTION MARK IS PRESENT 00590120 BCTR XINPUT,ZERO NO CHECK FOR VALID COMMAND 00591020 SPACE 00600020 * 00651020 * SKIP SEPARATORS TO BEGINNING OF COMMAND NAME. 00652020 * A +4 RETURN FROM SKIPB INDICATES THE COMMAND BUFFER IS EMPTY. 00653020 * 00654020 BAL LINK2,SKIPB SKIP BLANKS TO BEGINNING OF 00660020 * COMMAND NAME 00670020 B CSEXIT10 RETURN +0, END OF BUFFER REACHED 00680020 * TAKE NULL EXIT 00690020 * RETURN +4, START OF COMMAND NAME 00700020 * HAS BEEN ESTABLISHED 00710020 LA XINPUT,ONE(XINPUT) GET FIRST CHARACTER 00720020 LR XINPUTB,XINPUT SET LAST CHARACTER SCANNED 00730020 SPACE 00730120 * 00751120 * ONCE IT IS ESTABLISHED THAT THERE IS A COMMAND NAME AND IT IS NOT 00752020 * A QUESTION MARK, CHECK THE FLAG WORD SET BY THE INVOKER TO 00753020 * DETERMINE IF THE COMMAND NAME SHOULD BE SYNTAX CHECKED. 00754020 * 00755020 TM ZERO(XFLAGS),NOSYNCHK TEST INPUT FLAG BYTE TO 00760020 * DETERMINE IF SYNTAX CHECKING 00770020 * IS REQUESTED 00780020 BO CSNOSYN NO, GO SCAN FOR END ONLY 00790020 BCTR XINPUT,ZERO BACK UP INPUT PTR FOR GENSCAN 00800020 SPACE 00801020 * 00802020 * THE GENERAL SCAN ROUTINE OF MODULE IKJEFP20 IS USED TO SYNTAX 00803020 * CHECK THE COMMAND. PDWORD IN THE COMMON WORK AREA MUST CONTAIN THE 00804020 * ADDRESS OF THE CONTROL BITS FOR SYNTAX CHECKING. THE FIRST CHARACTER 00805020 * OF A COMMAND NAME MUST BE ALPHABETIC. THE OTHER CHARACTERS MUST 00806020 * BE ALPHAMERIC. THE MAXIMUM LENGTH IS 8. 00807020 * 00808020 LA R3,CMDSYNTX GET ADDR OF CMND SYNTAX REQD 00810020 ST R3,PDWORD SAVE FOR GENSCAN 00820020 L R15,AGSCAN GET ADDRESS OF GENSCAN ROUTINE 00821020 BALR LINK2,R15 LINK TO GENSCAN TO 00830020 * SYNTAX CHECK COMMAND NAME 00831020 * 00832020 B CSEXIT08 RETURN +0, FIRST CHAR IS INVALID 00840020 * TAKE ERROR EXIT 00850020 * 00851020 B CSEXIT08 RETURN +4, TOO LONG, TAKE ERROR 00860020 * EXIT 00870020 * 00871020 B CS03 RETURN +8, OK, REACHED END, GO 00880020 * SET PTR AND LENGTH 00890020 * 00891020 * RETURN +12, OK, CHECK DELIMITER 00900020 * 00901020 SPACE 00902020 * 00903020 * GENSCAN RETURNS CONTROL WITH XINPUT POINTING TO THE DELIMITER 00904020 * CHARACTER OF THE COMMAND NAME. THE DELIMITER MUST BE A SEPARATOR OR 00905020 * THE END OF THE BUFFER. IF THE END OF THE BUFFER WAS NOT REACHED 00906020 * DURING GENSCAN, THE DELIMITER MUST BE CHECKED. TYPETEST IS 00907020 * USED TO PERFORM THIS TEST. 00908020 * 00909020 LA R1,SEPAR SET UP TEST FOR VALID COMMAND 00910020 * NAME SEPARATOR 00910120 BAL LINK1,TYPETEST LINK TO TYPETEST TO 00920020 * PERFORM TEST 00921020 * 00922020 B CSEXIT08 RETURN +0, INVALID, TAKE ERROR 00930020 * EXIT 00940020 * 00940120 * RETURN +4, VALID, CONTINUE 00941020 SPACE 00941120 * 00941220 * IF THE COMMAND NAME IS VALID, IT IS TRANSLATED TO UPPERCASE 00941320 * USING THE TRANSX ROUTINE OF MODULE IKJEFP20. PPOINTR AND PLENGTH 00941420 * IN THE COMMON WORKAREA MUST CONTAIN A POINTER TO THE COMMAND 00941520 * NAME AND THE LENGTH. 00941620 * 00942020 CS03 DS 0H * * * * 00950020 MVC CSOACNM,PPOINTR PUT PTR TO COMMAND NAME IN 00960020 * OUTPUT AREA 00970020 S XINPUTB,PPOINTR COMPUTE LENGTH OF COMMAND NAME 00980020 STH XINPUTB,CSOALNM PUT LENGTH IN OUTPUT AREA 00990020 STH XINPUTB,PLENGTH STORE LENGTH FOR TRANSLATE 01000020 L R15,ATRANSX GET ADDRESS OF TRANSLATE ROUTINE 01001020 BALR LINK1,R15 LINK TO TRANSX TO TRANSLATE 01010020 * THE COMMAND TO UPPER CASE 01011020 SPACE 01011120 * 01012020 * SKIP SEPARATORS TO THE FIRST PARAMETER OF THE COMMAND OF THE END 01013020 * OF THE BUFFER. THE OUTPUT FLAGS ARE SET ACCORDING TO THE RESULTS. 01014020 * 01015020 BCTR XINPUT,ZERO BACK UP FOR SKIPB 01020020 BAL LINK2,SKIPB SKIP BLANKS TO FIRST PARAMETER 01030020 B CSEXIT40 RETURN +0, REACHED END OF BUFFER 01040020 * TAKE VALID EXIT 2 01050020 B CSEXIT80 RETURN +4, REACHED FIRST 01060020 * PARAM,TAKE VALID EXIT 1 01070020 SPACE 01071020 * 01311020 * IF THE COMMAND NAME IS NOT SYNTAX CHECKED IT IS SCANNED AS FOLLOWS 01312020 * USING THE TYPETEST ROUTINE: 01313020 * 1. THE FIRST CHARACTER MUST BE AN ENTERABLE CHARACTER 01314020 * THAT IS NOT A COMMAND DELIMITER. 01315020 * 2. THE OTHER CHARACTERS MUST BE ENTERABLE CHARACTERS. 01316020 * 3. THE SCAN STOPS WHEN A COMMAND DELIMITER IS FOUND. 01317020 * 01317120 * NOTE: THE FOLLOWING ARE COMMAND DELIMITERS -- BLANK, TAB, COMMA, 01317220 * EQUAL SIGN, MINUS SIGN, SLASH, PERIOD, SEMI-COLON, QUOTE, 01317320 * AMPERSAND, LEFT PAREN, RIGHT PAREN. 01317420 * 01318020 CSNOSYN DS 0H NO SYNTAX CHECKING REQUESTED 01320020 LA R1,CMDDLIM SET UP TO TEST FOR VALID 01330020 * COMMAND DELIMITER 01340020 BAL LINK1,TYPETEST LINK TO TYPETEST TO 01342020 * PERFORM TEST 01343020 * 01344020 B CS11 +0 RETURN - NOT A COMMAND 01370020 * DELIMITER, CHECK IF GOOD 01380020 * CHARACTER 01390020 * 01400020 B CSEXIT08 +4 RETURN - A COMMAND DELIMITER, 01410020 * THEN COMMAND NAME IS INVALID 01420020 SPACE 01430020 CS11 DS 0H * * * * 01440020 *** 01450020 * 01460020 * DEPENDS UPON CONTENTS OF R15 FROM TYPETEST 01470020 * 01480020 *** 01490020 CLI ZERO(R15),INVALID IS CURRENT CHARACTER AN 01500020 * INVALID CHARACTER 01510020 BE CSEXIT08 YES, TAKE ERROR EXIT 01520020 SPACE 01530020 LA XINPUT,ONE(XINPUT) NO, GET NEXT CHARACTER 01540020 LR XINPUTB,XINPUT SET LAST CHARACTER SCANNED 01550020 C XINPUT,ENDINPUT IS SCAN AT END OF BUFFER 01560020 BNL CS03 YES, EXIT NORMALLY 01570020 SPACE 01580020 LA R1,CMDDLIM SET UP TO TEST FOR VALID 01581020 * COMMAND DELIMITER 01582020 BAL LINK1,TYPETEST LINK TO TYPETEST TO 01584020 * PERFORM TEST 01585020 * 01586020 B CS11 +0 RETURN - NOT A COMMAND 01612720 * DELIMITER, CHECK IF GOOD 01620020 * CHARACTER 01630020 * 01640020 B CS03 +4 RETURN - A COMMAND DELIMITER, 01650020 * EXIT NORMALLY 01660020 SPACE 01670020 CSEXIT80 DS 0H * * * * 01680020 OI CSOAFLG,CSOAVWP SET FLAG IN OUTPUT AREA TO 01690020 * INDICATE COMMAND NAME IS 01700020 * VALID AND THERE ARE NON- 01710020 * SEPARATORS REMAINING 01720020 B SETOFF GO SET OFFSET 01730020 SPACE 01740020 CSEXIT40 DS 0H * * * * 01750020 OI CSOAFLG,CSOAVNP SET FLAG IN OUTPUT AREA TO 01760020 * INDICATE COMMAND NAME IS 01770020 * VALID AND THERE ARE NO NON- 01780020 * SEPARATORS REMAINING 01790020 B SETOFF GO SET OFFSET 01800020 SPACE 01810020 CSEXIT20 DS 0H * * * * 01820020 OI CSOAFLG,CSOAQM SET FLAG IN OUTPUT AREA TO 01830020 * INDICATE COMMAND NAME IS A 01840020 * QUESTION MARK 01850020 B CSEXIT EXIT 01860020 SPACE 01870020 CSEXIT10 DS 0H * * * * 01880020 OI CSOAFLG,CSOANOC SET FLAG IN OUTPUT AREA TO 01890020 * INDICATE BUFFER IS EMPTY 01900020 B SETOFF GO SET OFFSET 01910020 SPACE 01920020 CSEXIT08 DS 0H * * * * 01930020 OI CSOAFLG,CSOABAD SET FLAG IN OUTPUT AREA TO 01940020 * INDICATE COMMAND NAME IS 01950020 * INVALID 01960020 B CSEXIT EXIT 01970020 SPACE 01980020 SETOFF DS 0H RESET OFFSET WITHIN COMMAND 01990020 * BUFFER 02000020 LA R2,CBUFTEXT GET ADDR OF COMMAND BUFFER TEXT 02060020 SR XINPUTB,R2 COMPUTE CURRENT OFFSET 02070020 STH XINPUTB,PDWORD STORE CURRENT OFFSET IN 02080020 MVC CBUFOFST,PDWORD COMMAND BUFFER HEADER 02090020 SPACE 02100020 CSEXIT DS 0H SUCCESSFUL COMPLETION EXIT 02110020 XR R3,R3 CLEAR WORK REG 02111020 IC R3,RETCODE SAVE RETURN CODE 02112020 LR R1,WORKBASE LOAD CORE ADDRESS FOR FREEMAIN 02120020 L WORKBASE,FOUR(WORKBASE) RESTORE CALLERS SAVE AREA ADDR 02130020 FREEMAIN R,LV=CSWORKSZ,A=(1) RELEASE WORKAREA 02140020 LR R15,R3 LOAD RETURN CODE REGISTER 02150020 RETURN (14,12),RC=(15) EXIT FROM COMMAND SCAN 02160020 EJECT 02170020 *********************************************************************** 02171020 * * 02172020 * SKIP BLANKS SUBROUTINE * 02173020 * * 02174020 * THE FUNCTION OF THIS ROUTINE IS TO SKIP BLANKS, COMMAS AND TABS IN* 02175020 * THE COMMAND BUFFER. 02176020 * 02176120 * 02177020 * INPUT - XINPUT=POINTER TO THE LAST CHARACTER SCANNED. 02178020 * (THE SCAN FOR SEPARATORS BEGINS AT THE NEXT 02179020 * CHARACTER.) 02179120 * 02179220 * OUTPUT - IF A NON-SEPARATOR WAS FOUND: 02179320 * XINPUT=POINTER TO THE LAST SEPARATOR SCANNED. 02179420 * PPOINTR=POINTER TO THE FIRST NON-SEPARATOR. 02179520 * 02179620 * - IF THE END OF THE BUFFER WAS REACHED BEFORE A 02179720 * NON-SEPARATOR WAS FOUND: 02179820 * XINPUT=POINTER TO THE LAST CHARACTER IN THE BUFFER. 02179920 * PPOINTR=POINTER TO THE END OF THE BUFFER. 02180020 * 02180120 * EXITS - LINK2+0=THE END OF THE BUFFER WAS REACHED BEFORE A 02180220 * NON-SEPARATOR WAS FOUND. 02180320 * 02180420 * - LINK2+4=A NON-SEPARATOR CHARACTER WAS FOUND. 02180520 * * 02180720 *********************************************************************** 02180820 SPACE 02180920 SKIPB DS 0H SKIP SEPARATORS SUBROUTINE 02181020 LA XINPUT,ONE(XINPUT) BUMP INPUT PTR BY ONE 02181120 LR XINPUTB,XINPUT SET BACKUP REGISTER 02181220 C XINPUT,ENDINPUT END OF INPUT 02181320 * 02181420 BNL SKIPBX YES - EXIT 02181720 * 02181820 * NO - TEST FOR A SEPARATOR 02181920 LA R1,SEPAR SET UP TEST FOR VALID SEPARATOR 02182020 BAL LINK1,TYPETEST LINK TO TYPETEST TO 02182320 * PERFORM TEST 02182420 * 02182520 B SKIPB2 +0 RETURN - NON-SEPARATOR, GO 02182620 * SET PPOINTR AND EXIT 02182720 * 02182820 B SKIPB +4 RETURN - SEPARATOR, CONTINUE 02182920 * LOOP 02183020 SPACE 02183220 SKIPB2 DS 0H * * * * 02183320 ST XINPUT,PPOINTR STORE ADDRESS OF NON-SEPARATOR 02183620 BCT XINPUT,FOUR(LINK2) BACK UP INPUT PTR BY ONE AND 02183720 * RETURN TO NSI +4 02183820 SPACE 02183920 SKIPBX DS 0H * * * * 02184020 ST XINPUT,PPOINTR STORE ADDRESS 02184120 BCTR XINPUT,LINK2 BACK UP INPUT PTR BY ONE AND 02184220 * RETURN TO NSI +0 02184320 EJECT 02184420 *********************************************************************** 02184520 * * 02184620 * CHARACTER TYPE TEST ROUTINE * 02184820 * * 02184920 * THIS SUBROUTINE CHECKS THE CURRENT INPUT CHARACTER FOR 02185020 * BELONGING TO A SPECIFIED CHARACTER CLASS. * 02185120 * * 02185220 * INPUT - R1=MASK OF DESIRED CHARACTER CLASS. * 02185320 * XINPUT=POINTER TO CHARACTER TO BE CHECKED. * 02185420 * * 02185520 * OUTPUT - THE RESULT OF THE TEST IS INDICATED BY THE * 02185620 * LOCATION TO WHICH CONTROL IS RETURNED. * 02185720 * * 02185820 * EXISTS - LINK1+0=THE CHARACTER DOES NOT BELONG TO THE SPECIFIED * 02185920 * CHARACTER CLASS. * 02186020 * * 02186120 * - LINK1+4=THE CHARACTER BELONGS TO THE CHARACTER CLASS * 02186220 * SPECIFIED. * 02186320 * * 02186420 *********************************************************************** 02186520 SPACE 02186720 TYPETEST DS 0H * * * * 02186820 XR R15,R15 CLEAR WORK REG 02186920 IC R15,ZERO(XINPUT) USE CURRENT CHARACTER AS 02187020 * OFFSET INTO TESTING TABLE 02187120 A R15,ATRTAB GET ADDRESS IN TABLE 02187220 * CORRESPONDING TO CHARACTER IN 02187320 * QUESTION 02187420 EX R1,TYPETM EXECUTE TEST UNDER MASK OF 02187620 * TYPEBYTE FOR CHARACTER 02187720 * SPECIFICATION GIVEN IN R1 02187820 * 02187920 BC CC5,FOUR(LINK1) TYPE MATCHES, RETURN +4 02188220 * 02188320 BR LINK1 TYPE DOESN'T MATCH, RETURN +0 02188420 EJECT 02188620 *********************************************************************** 02188720 * * 02190020 * CONSTANT AREA * 02200020 * * 02210020 *********************************************************************** 02220020 SPACE 02221020 * 02222020 * CONTROL INFORMATION FOR GENSCAN WHEN SCANNING FOR A COMMAND NAME 02223020 * 02224020 CMDSYNTX EQU * * * * * 02225020 DC X'40' ASTERISK NOT ALLOWED, MAXIMUM 02226020 * LENGTH SPECIFIED 02227020 DC X'01' FIRST CHARACTER MUST BE 02228020 * ALPHABETIC 02229020 DC X'03' OTHER CHARACTERS MUST BE 02229120 * ALPHAMERIC 02229220 DC X'08' MAXIMUM LENGTH = 8 02229320 * 02229420 * VCON'S FOR EXTERNAL UTILITY ROUTINES 02229520 * 02229620 AGSCAN DC V(GENSCAN) ADDRESS OF GENERALIZED SCAN 02230420 * UTILITY ROUTINE USED TO 02230520 * SYNTAX CHECK THE COMMAND NAME 02230620 SPACE 02230720 ATRANSX DC V(TRANSX) ADDRESS OF TRANSLATE UTILITY 02230920 * ROUTINE USED TO TRANSLATE THE 02231220 * COMMAND NAME TO UPPER CASE 02231320 SPACE 02231420 * 02231520 * ADCON FOR EXTERNAL TABLE USED BY TYPETEST TO TEST FOR A 02231620 * GIVEN CHARACTER CLASS 02231720 * 02231820 ATRTAB DC A(TRTAB) ADDRESS OF EXTERNAL TABLE USED 02231920 * BY TYPETEST 02232020 SPACE 02232120 TYPETM TM ZERO(R15),*-* USED BY TYPETEST TO TEST 02232220 * FOR A CHARACTER TYPE 02232320 EJECT 02232420 CSWORK IKJEFPWA 02232520 SPACE 02233920 IKJCSPL 02234220 SPACE 02234320 IKJCSOA 02234620 SPACE 02234720 *********************************************************************** 02235020 * * 02235120 * THE COMMAND BUFFER IS A BUFFER POINTED TO BY THE CSPL. * 02235320 * IT CONTAINS THE COMMAND TO BE SCANNED. * 02235420 * * 02235520 *********************************************************************** 02235620 SPACE 02235720 CBUF DSECT * * * * 02235920 CBUFLEN DS CL2 LENGTH OF COMMAND BUFFER 02236020 CBUFOFST DS CL2 OFFSET INTO BUFFER TEXT 02236120 CBUFTEXT EQU * TEXT 02236220 END 02236320 ./ ADD SSI=03010384,NAME=IKJEFP60,SOURCE=1 TITLE 'IKJEFP60 - IKJPARS2 INTERFACE AND INITIALIZATION' 00010000 * GEN (EJECT); 00020000 EJECT 00030000 * 00040000 * /******************************************************************** 00050000 * /* * 00060000 * /* TITLE: IKJPEF60 - IKJPARS2 LOAD MODULE * 00070000 * /* * 00080000 * /* STATUS: CHANGE LEVEL - 000 * 00090000 * /* * 00100000 * /* FUNCTION: * 00110000 * /* * 00120000 * /* IKJPARS2 IS A SEPARATE LOAD MODULE OF THE IKJPARS * 00130000 * /* SERVICE ROUTINE IN TSO. IKJPARS2 CONTROLS THE SYNTACTICAL * 00140000 * /* SCAN OF COBOL SYMBOLIC DEBUG COMMAND PARAMETERS. SYNTAX * 00150000 * /* CHECKING IS PERFORMED, AND PROMPTING IS ACCOMPLISHED, * 00160000 * /* THROUGH INTERFACES WITH THE IKJPARS LOAD MODULE. CONSISTENCY * 00170000 * /* IS MAINTAINED IN ALL EXTERNAL INTERFACES WITH THE TERMINAL * 00180000 * /* IN SO FAR AS PROMPTING IS CONCERNED. * 00190000 * /* THE INTERFACE WITH THE CP IS THE SAME AS WITH IKJPARS. * 00200000 * /* * 00210000 * /* ENTRY POINT: IKJPARS2 * 00220000 * /* * 00230000 * /* INPUT: * 00240000 * /* * 00250000 * /* THE PAREMETER CONTROL LIST (PCL) IS CREATED BY THE CP * 00260000 * /* USING PARSE MACROS. THE COBOL SYMBOLIC DEBUG COMMAND * 00270000 * /* SYNTAX IS DESCRIBED BY THREE MACROS: * 00280000 * /* * 00290000 * /* 1) IKJTERM - VARIABLES, CONSTANTS, STATEMENTS * 00300000 * /* * 00310000 * /* 2) IKJOPER - EXPRESSIONS * 00320000 * /* * 00330000 * /* 3) IKJRSVWD - RESERVED WORDS. * 00340000 * /* * 00350000 * /* EACH MACRO GENERATES AN ENTRY IN THE PCL, (PCE). * 00360000 * /* CONTROL IS PASSED TO IKJPARS2 BY THE IKJPARS LOAD MODULE * 00370000 * /* WHENEVER ONE OF THESE PCE TYPES IS ENCOUNTERED. * 00380000 * /* IKJPARS2 INITIALIZATION INTERROGATES THE PCE TYPE AND * 00390000 * /* PASSES CONTROL TO ONE OF THREE SCAN ROUTINES TO HANDLE THE * 00400000 * /* PARTICULAR INPUT PARAMETER: * 00410000 * /* * 00420000 * /* 1) IKJOPER - IKJEFP50 CSECT * 00430000 * /* 2) IKJRSVWD - IKJEFP40 CSECT * 00440000 * /* 3) IKJTERM - IKJEFP60 CSECT * 00450000 * /* * 00460000 * /* THE PDL ADDRESS IS PLACED IN A 4 BYTE AREA PROVIDED AS INPUT * 00470000 * /* BY THE CP. * 00480000 * /* THE INPUT BUFFER RECEIVED BY IKJPARS IS PASSED TO IKJPARS2 * 00490000 * /* WITH POINTERS INITIALIZED TO THE COBOL COMMAND PARAMETER * 00500000 * /* TO BE SCANNED UNDER THE PCE. A POINTER TO THE PCE TO CONTROL * 00510000 * /* THE SCAN IS ALSO PASSED TO IKJPARS2. * 00520000 * /* * 00530000 * /* OUTPUT: * 00540000 * /* * 00550000 * /* PARAMETER DESCRIPTOR LIST (PDL) POINTED TO BY THE ANSWER * 00560000 * /* PLACE. THE PDL CONTAINS THE PDE'S BUILT BY IKJPARS2 WHILE * 00570000 * /* SCANNING THE INPUT COMMAND PARAMETERS. * 00580000 * /* EACH PDE CORRESPONDS TO ONE PCE AND CONTAINS POINTER TO THE * 00590000 * /* INPUT PARAMETER, PLUS INDICATORS TO TYPE, LENGTH, ETC. THE * 00600000 * /* PDE FULLY DESCRIBES THE INPUT PARAMETER TO THE CP. * 00610000 * /* * 00620000 * /* EXTERNAL REFERENCES: * 00630000 * /* * 00640000 * /* IKJPARS - SEVERAL SUBROUTINES IN THE PARSE SERVICE ROUTINE * 00650000 * /* ARE USED BY THE IKJPARS2 LOAD MODULE TO ACCOMPLISH THE SCAN, * 00660000 * /* PDL BUILD AND PROMPTING. THESE ROUTINES ARE ENTERED THROUGH * 00670000 * /* THE COMMON IKJPARS2 INTERFACE ROUTINE - LINKRET. ADDRESSES * 00680000 * /* WITHIN IKJPARS ARE OBTAINED FROM AN ADCON TABLE CREATED * 00690000 * /* IN IKJPARS. INDICES INTO THE ADCON TABLE ARE PASSED TO * 00700000 * /* LINKRET FROM THE PARS2 ROUTINES TO CONTROL THE LINKAGE TO THE * 00710000 * /* PROPER SUBROUTINE. * 00720000 * /* MAINLINE IKJPARS INITIALIZATION IS ENTERED FIRST. IF A * 00730000 * /* COBOL PCE IS ENCOUNTERED, THE IKJPARS2 LOAD MODULE IS BROUGHT * 00740000 * /* INTO CORE AND CONTROL PASSED TO IT. * 00750000 * /* SUBROUTINES OF IKJPARS USED BY IKJPARS2 ARE: * 00760000 * /* * 00770000 * /* 1) QSTR01 - QSTRING ROUTINE * 00780000 * /* 2) PROMPTQ - PROMPT WITH 'ENTER ..' ROUTINE * 00790000 * /* 3) POSITXCB - ADD PDE TO PERMANENT PDL ROUTINE * 00800000 * /* 4) SYSR1 - WRITE INVALID MESSAGE AND PROMPT WITH REENTER * 00810000 * /* 5) SKIPB - SKIP BLANKS ROUTINE * 00820000 * /* 6) RANGE - DETERMINE IF RANGE ENTERED * 00830000 * /* 7) GENSCAN - PARAMETER SCAN ROUTINE * 00840000 * /* 8) TYPETEST - DETERMINE CHARACTER TYPE ROUTINE * 00850000 * /* 9) TRANSQ - TRANSLATE TO UPPER CASE ROUTINE * 00860000 * /* 10) PSTRIMSG - WRITE OUT ENDING PAREN ASSUMED MESSAGE * 00870000 * /* 11) LISTT - DETERMINE IF A LIST ENTERED * 00880000 * /* 12) STALOC - ALLOCATE STORAGE IN SUBPOOL 1 - PASSED BACK * 00890000 * /* TO CP. * 00900000 * /* 13) SCANF - POP THE STACK ROUTINE * 00910000 * /* 14) GETCORE - GET CORE WHICH WILL BE RELEASED BEFORE EXIT * 00920000 * /* 15) NAMESKP3 - SKIP TO NEXT PCE ROUTINE * 00930000 * /* 17) CLEANUP - FREE CORE, DELETE MODULES AND EXIT * 00940000 * /* 18) PUSHI - PUSH THE STACK ROUTINE * 00950000 * /* 19) PARS2ENT - ENTRY POINT FROM IKJPARS2 WHEN SUBROUTINE * 00960000 * /* FUNCTIONS ARE REQUIRED. * 00970000 * /* 20) NEXTPCE - GOTO NEXT PCE ROUTINE * 00980000 * /* * 00990000 * /* EXITS NORMAL: * 01000000 * /* * 01010000 * /* REGISTER 15 CONTAINS A 00 RETURN CODE. * 01020000 * /* ANSWER PLACE CONTAINS PDL ADDRESS. * 01030000 * /* * 01040000 * /* EXITS ERROR: * 01050000 * /* * 01060000 * /* REGISTER 15 CONTAINS A 24 RETURN CODE INDICATING AN ERROR * 01070000 * /* WAS DETECTED IN THE PARAMETERS PASSED TO THE IKJPARS2 LOAD * 01080000 * /* MODULE. * 01090000 * /* ALL PRESENT RETURN CODES FROM IKJPARS MAY ALSO BE RETURNED * 01100000 * /* IF AN ERROR IS DETECTED BY IKJPARS OUTSIDE THE IKJPARS2 MODULE. * 01110000 * /* THE ANSWER PLACE CONTAINS A X'FF000000' IF AN ERROR WAS * 01120000 * /* DETECTED. * 01130000 * /* * 01140000 * /* TABLES AND WORK AREAS: * 01150000 * /* * 01160000 * /* MACRO IKJEFPWA IS USED TO DEFINE THE WORK AREA OBTAINED * 01170000 * /* BY IKJEFP00 DURING INITIALIZATION. THIS MACRO HAS BEEN CHANGED * 01180000 * /* IN RELEASE 21.6 TO CONTIAN NECESSARY FIELDS FOR IKJPARS2 * 01190000 * /* PROCESSING. THIS MACRO IS EXPANDED IN BOTH IKJPARS AND * 01200000 * /* IKJEFP20. * 01210000 * /* * 01220000 * /* ATTRIBUTES: * 01230000 * /* * 01240000 * /* REENTRANT * 01250000 * /* * 01260000 * /* CHARACTER CODE DEPENDENCY: * 01270000 * /* * 01280000 * /* CLASS C. THE OPERATION OF THIS PROGRAM IS DEPENDENT UPON * 01290000 * /* AN INTERNAL REPRESENTATION OF THE EXTERNAL CHARACTER SET * 01300000 * /* WHICH IS EQUIVALENT TO THE ONE USED AT ASSEMBLY TIME. THE * 01310000 * /* CODING HAS BEEN DONE SO THAT REDEFINITION OF THE 'CHARACTER' * 01320000 * /* CONSTANTS, THROUGH MACRO VARIABLES, BY REASSEMBLY, WILL RESULT * 01330000 * /* IN A CORRECT PROGRAM FOR THE NEW DEFINITION. * 01340000 * /* * 01350000 * /* RELEASE 21.6 SUPPORT CODE: F00969 * 01360000 * /* * 01370000 * /******************************************************************** 01380000 * /* A 328320-328380,329320-329360,400320-400360,458320-458388 A56847 * 01390000 * /* A 337220-337260,430420-430496 A56847 * 01400000 * /* A 264420-264440,271920-271960,282510-282540,288220-288280 A56847 * 01410000 * /* A 295020,298520,304520,368820,381220,447220-447300,295020 A56847 * 01420000 * /* A 298520,304520,368820,381220,447220-447300,467920-467980 A56847 * 01430000 * /* A 521700,632720-633388,572126-572200 A56847 * 01440000 * /* C 246524,247200,265420,295000,298500,304500,316700,348300 A56847 * 01450000 * /* C 337300-338400,363600,368800,381200,383500,454000-454300 A56847 * 01460000 * /* C 523300,536600-536800,538500,546600-546700 A56847 * 01470000 * /* C 337300-338400,342000 A56847 * 01480000 * /* D 247300-247400,287800-288200,383600-383700,523400 A56847 * 01490000 * /* D 326700-326800 A56847 * 01500000 * /* C 395100 M4151 * 01510000 * /* C 129328-129385,522140-522319 M4161 * 01520000 * /* A 356900-356980,374300 SA66973* 01530000 * /* D 356900,374300-374400 SA66973* 01540000 * 01550000 * GEN (EJECT); 01560000 EJECT 01570000 * 01580000 * IKJPARS2: 01590000 * PROC OPTIONS(DONTSAVE,CODEREG(2,3),NOSAVEAREA, REENTRANT); 01600000 LCLA &T,&SPN 0003 01610000 .@001 ANOP 0003 01620000 IKJPARS2 CSECT , 0003 01630000 BALR @2,0 0003 01640000 @PSTART DS 0H 0003 01650000 USING @PSTART+00000,@2 0003 01660000 LA @3,4095(0,@2) 0003 01670000 USING @PSTART+04095,@3 0003 01680000 L @0,@SIZ001 0003 01690000 GETMAIN R,LV=(0) 0003 01700000 LR @C,@1 0003 01710000 USING @DATD+00000,@C 0003 01720000 XC @TEMPS(@L),@TEMPS 0003 01730000 * 01740000 * /***************************************************************** 01750000 * /* * 01760000 * /* MACRO VARIABLES * 01770000 * /* * 01780000 * /***************************************************************** 01790000 * 01800000 * GEN (SPACE); 01810000 SPACE 01820000 DS 0H 01830000 * GEN (EJECT); 01840000 EJECT 01850000 DS 0H 01860000 * 01870000 * /***************************************************************** 01880000 * /* * 01890000 * /* DECLARATIONS * 01900000 * /* * 01910000 * /***************************************************************** 01920000 * 01930000 * DCL 01940000 * R0 REG(0); /* REGISTER 0 - WORK REG * 01950000 * DCL 01960000 * R1 PTR(31)REG(1); /* REGISTER 1 - WORK REGISTER * 01970000 * DCL 01980000 * R2 REG(2); /* BASE REGISTER * 01990000 * DCL 02000000 * R3 REG(3); /* BASE REGISTER * 02010000 * DCL 02020000 * XINPUT REG(4) PTR(31); /* POINTER IN COMMAND BUFFER * 02030000 * DCL 02040000 * XINPUTB REG(5) PTR(31); /* BACKUP POINTER * 02050000 * DCL 02060000 * XPCE REG(6) PTR(31); /* POINTER TO CURRENT PCE * 02070000 * DCL 02080000 * R7 REG(7); /* WORK REGISTER * 02090000 * DCL 02100000 * LINK1 REG(8); /* LINKAGE REGISTER FOR PARSE 02110000 * SUBROUTINES * 02120000 * DCL 02130000 * INDEX REG(8) PTR(31); /* USED AS INDEX INTO SPECIAL 02140000 * MESSAGE AREA * 02150000 * DCL 02160000 * LINK2 REG(9); /* LINKAGE REGISTER FOR PARSE 02170000 * SUBROUTINES * 02180000 * DCL 02190000 * R10 REG(10); /* REGISTER 10 - WORK REG * 02200000 * DCL 02210000 * PWAREG REG(11) PTR(31); /* BASE REGISTER TO PERMANENT 02220000 * WORK AREA * 02230000 * DCL 02240000 * OPCEPTR AUTOMATIC PTR(31); /* BASE FOR OPER PCE DSECT * 02250000 * DCL 02260000 * RSVDRTN AUTOMATIC PTR(31); /* RETURN LOCATION FROM P40 * 02270000 * /* F41448 * 02280000 * DCL 1 PWORK BASED(PWAREG) BDY(DWORD), /* F41448 * 02290000 * /* F41448 * 02300000 * /* PARSE PERMANENT WORKSPACE * 02310000 * /* F41448 * 02320000 * 2 DUMMY1, /* USED TO FIND LEN OF CSWORK * 02330000 * 4 SAVE1(18) PTR(31), /* SAVE AREA F41448 * 02340000 * /* F41448 * 02350000 * 4 PDWORD(2) PTR(31) BDY(DWORD), /* SCRATCH/SAVE/CONVERT*/ 02360000 * /* F41448 * 02370000 * 4 ENDINPUT PTR(31), /* LAST INPUT CHAR. ADDRESS * 02380000 * /* F41448 * 02390000 * /*USED TO DETERMINE END OF DAT* 02400000 * /* F41448 * 02410000 * /* POINTER TO START OF DATA BEING SCANNED SET BY SKIPB SUBROUTINE * 02420000 * /* ALSO LENGTH OF DATA FIELD. THESE AREAS MUST BE CONTIGUOUS F41448 * 02430000 * /* F41448 * 02440000 * 4 PPOINTR PTR(31), /* LAST ENTITY START F41448 * 02450000 * 02460000 * 4 PLENGTH FIXED(15), /* LAST ENTITY LENGTH F41448 * 02470000 * /* F41448 * 02480000 * 4 RETCODE PTR(8), /* RETURN CODE AREA * 02490000 * /* F41448 * 02500000 * 2 DUMMY2 BDY(DWORD), /* TO PUT SUBRWORK ON DWRD BDY* 02510000 * /* F41448 * 02520000 * 3 SUBRWORK(2) PTR(31), /* SCRATCH/SAVE AREA * 02530000 * /* F41448 * 02540000 * 2 XPDL PTR(31), /* ADDRESS OF PDL * 02550000 * /* F41448 * 02560000 * 2 TEMPSAVE PTR(31), /*USED TO TEMPORARILY SAVE R1 * 02570000 * /* F41448 * 02580000 * /*BEFORE LINKING TO TRANSLATE * 02590000 * /* ROUTINE F41448 * 02600000 * 02610000 * /* PREMANENT WORKSPACE FLAGS F41448 * 02620000 * 02630000 * 2 PFLAGS BIT(8), /* FIRST FLAG BYTE F41448 * 02640000 * /* F41448 * 02650000 * 3 PFLIST BIT(1), /* CURRENTLY PROCESSING LIST */ 02660000 * /* F41448 * 02670000 * 3 PFDEFLT BIT(1), /* INDICATES A DEFAULT TAKEN * 02680000 * /* F41448 * 02690000 * 3 PFENDF BIT(1), /* END OF INPUT AREA HAS BEEN * 02700000 * /* REACHED F41448 * 02710000 * /* F41448 * 02720000 * 3 ADREXP BIT(1), /* INDICATE ADDRESS EXPRESSION* 02730000 * /* F41448 * 02740000 * 3 HEXBIT BIT(1), /* ADDRESS EXPRESSION CONTAINS* 02750000 * /* A HEX CHARACTER F41448 * 02760000 * /* F41448 * 02770000 * 3 PFBYPAS BIT(1), /* BYPASS MODE IS TO BE ESTAB*/ 02780000 * /* F41448 * 02790000 * 3 PFNEW BIT(1), /* USED BY ADDRESS ROUTINE TO * 02800000 * /* F41448 * 02810000 * /* DENOTE A NEW VALID ADDRESS * 02820000 * /* F41448 * 02830000 * /* ENTRYNAME (WITH OR WITHOUT * 02840000 * /* F41448 * 02850000 * /* LOADNAME QUALIFICATION * 02860000 * /* F41448 * 02870000 * 3 DECBIT BIT(1), /* ADDR EXPRESSION IS DECIMAL * 02880000 * /* F41448 * 02890000 * 2 PFLAGS2 BIT(8), /* SECOND FLAG BYTE * 02900000 * /* F41448 * 02910000 * 3 PFSKPINV BIT(1), /* VALIDITY CHECK ROUTINE * 02920000 * /* F41448 * 02930000 * /* REQUESTED A REENTER MESSAGE* 02940000 * /* ONLY F41448 * 02950000 * /* F41448 * 02960000 * 3 RNGEVAL1 BIT(1), /* ADDRESS ROUTINE PROCESSED * 02970000 * /* FIRST VAL OF RANGE F41448 * 02980000 * /* PARAMETER F41448 * 02990000 * /* F41448 * 03000000 * 3 ONERBIT BIT(1), /* CONTROL BIT USED DURING * 03010000 * /* F41448 * 03020000 * /* SCAN BY ADDRESS ROUTINE * 03030000 * /* F41448 * 03040000 * 3 TWORBIT BIT(1), /* CONTROL BIT USED DURING * 03050000 * /* F41448 * 03060000 * /* SCAN BY ADDRESS ROUTINE * 03070000 * /* F41448 * 03080000 * 3 RNGEVAL2 BIT(1), /* ADDRESS ROUTINE PROCESSED * 03090000 * /* F41448 * 03100000 * /* SECOND VALUE OF RANGE * 03110000 * /* PARAMETER F41448 * 03120000 * /* F41448 * 03130000 * 3 REGBIT BIT(1), /* CONTROL BIT USED DURING * 03140000 * /* F41448 * 03150000 * /* SCAN BY ADDRESS ROUTINE * 03160000 * /* F41448 * 03170000 * 3 FLTERBIT BIT(1), /* CONTROL BIT USED DURING * 03180000 * /* F41448 * 03190000 * /* SCAN BY ADDRESS ROUTINE * 03200000 * /* F41448 * 03210000 * 3 BREAKBIT BIT(1), /* USED BY ADDRESS ROUTINE TO * 03220000 * /* F41448 * 03230000 * 2 PFLAGS3 BIT(8), /* THIRD FLAG BYTE * 03240000 * 3 PFSTPRMT BIT(1), /* PROMPT FOR STRING F41448 * 03250000 * /* F41448 * 03260000 * 3 PFONE BIT(1), /* INDICATES AT LEAST ONE PDE * 03270000 * /* HAS BEEN BUILT F41448 * 03280000 * /* F41448 * 03290000 * 3 LOADBIT BIT(1), /* CONTROL BIT USED BY ADDRESS* 03300000 * /* F41448 * 03310000 * /* RTN DENOTING LOADNAME DATA * 03320000 * /* F41448 * 03330000 * 3 ENTRYBIT BIT(1), /* CONTROL BIT USED BY ADDRESS* 03340000 * /* F41448 * 03350000 * /* RTN DENOTING ENTRYNAME DATA* 03360000 * /* F41448 * 03370000 * 3 PFNULL BIT(1), /* INDICATES A NULL LINE WAS * 03380000 * /* F41448 * 03390000 * /* ENTERED AFTER A PROMPT * 03400000 * /* F41448 * 03410000 * 3 LPRNFND BIT(1), /* USED TO INDICATE A LEFT * 03420000 * /* F41448 * 03430000 * /* PAREN WAS FND BY THE ERROR * 03440000 * /* ROUTINE F41448 * 03450000 * /* F41448 * 03460000 * 3 PFSPACE BIT(1), /* USED TO INDICATE A F41448 * 03470000 * /* F41448 * 03480000 * /* POSITIONAL SPACE PARAMETER * 03490000 * /* F41448 * 03500000 * /* WAS ENCOUNTERED SO THAT THE* 03510000 * /* F41448 * 03520000 * /* SO THAT THE POSITIONAL * 03530000 * /* F41448 * 03540000 * /* STRING RTN KNOWS WHEN TO * 03550000 * /* END THE STRING F41448 * 03560000 * /* F41448 * 03570000 * 3 PFMORE BIT(1), /* USED TO INDICATE IF THE * 03580000 * /* F41448 * 03590000 * /* LEFT PAREN OF A SUBFIELD * 03600000 * /* F41448 * 03610000 * /* WAS ALSO USED AS THE LEFT * 03620000 * /* F41448 * 03630000 * /* PAREN OF THE LIST WITHIN * 03640000 * /* THE SUBFIELD F41448 * 03650000 * /* F41448 * 03660000 * 2 PFLAGS4 BIT(8), /* FOURTH FLAG BYTE * 03670000 * /* F41448 * 03680000 * 3 PFENDLIM BIT(1), /* INDICATES END DILIMETER FOR* 03690000 * /* F41448 * 03700000 * /* SELF-DILIMITING STRING HAS * 03710000 * /* BEEN FOUND F41448 * 03720000 * 3 PFLSTEND BIT(1), /* INDICATES LIST END F41448 * 03730000 * /* F41448 * 03740000 * /* DILIMETER HAS BEEN FOUND * 03750000 * /* F41448 * 03760000 * 3 PFVCMSG BIT(1), /* INDICATES A VALIDITY CHECK * 03770000 * /* F41448 * 03780000 * /* ROUTINE HAS SUPPLIED A * 03790000 * /* SECOND LEVEL MESSAG F41448 * 03800000 * /* F41448 * 03810000 * 3 PFPDDATA BIT(1), /* INDICATE PROCESSING PROMPT * 03820000 * /* OR DEFAULT DATA F41448 * 03830000 * /* F41448 * 03840000 * 3 PFSLASH BIT(1), /* INDICATE DSNAME/USERID RTN * 03850000 * /* F41448 * 03860000 * /* IS SCANNING FOR PASSWORD * 03870000 * /* F41448 * 03880000 * 3 PFENDSET BIT(1), /* INDICATES BACKUP POINTER * 03890000 * /* F41448 * 03900000 * /* FOR ENDINPUT HAS BEEN SET * 03910000 * /* F41448 * 03920000 * 3 PFNOPOP BIT(1), /* INDICATES STACK IS NOT TO * 03930000 * /* F41448 * 03940000 * /* BE POPPED IF ALL SEPARATORS* 03950000 * /* IN PROMPT BUFFER F41448 * 03960000 * /* F41448 * 03970000 * 3 CKRANGE BIT(1), /* ADDR RTN SHOULD CHECK FOR * 03980000 * /* RANGE F41448 * 03990000 * /* F41448 * 04000000 * 2 PFLAGS5 BIT(8), /* FIFTH FLAG BYTE * 04010000 * /* F41448 * 04020000 * 3 PFSQSTR BIT(1), /* SPECIAL QSTRING HANDLING * 04030000 * /* DONE AT LEAST ONCE F41448 * 04040000 * /* F41448 * 04050000 * 3 INVPRMPT BIT(1), /* CHECK FOR INVALID MSG PRMT * 04060000 * /* F41448 * 04070000 * 3 RD1 BIT(1), /* RESERVED * 04080000 * /* F41448 * 04090000 * 3 RD2 BIT(1), /* RESERVED * 04100000 * /* F41448 * 04110000 * 3 RD3 BIT(1), /* RESERVED * 04120000 * /* F41448 * 04130000 * 3 RD4 BIT(1), /* RESERVED * 04140000 * /* F41448 * 04150000 * 3 RD5 BIT(1), /* RESERVED * 04160000 * /* F41448 * 04170000 * 3 RD6 BIT(1), /* RESERVED * 04180000 * 04190000 * /* F41448 * 04200000 * /* WORKSPACE NEEDED FOR STORAGE ALLOCATION SUBROUTINE * 04210000 * /* F41448 * 04220000 * 2 PANCHOR PTR(31), /* ANCHOR FOR STORAGE CHAIN * 04230000 * /* F41448 * 04240000 * 04250000 * /* F41448 * 04260000 * 2 PANCHORT PTR(31), /* INTERNAL MSS CHAIN FREE * 04270000 * /* F41448 * 04280000 * /* Q ANCHOR * 04290000 * 04300000 * /* F41448 * 04310000 * /* PARAMETER LIST FOR CONDITIONAL GETMAIN SUBROUTINE * 04320000 * 04330000 * /* F41448 * 04340000 * 2 PGETLIST, 04350000 * /* F41448 * 04360000 * 5 PGETLNTH FIXED(31), /* LENGTH REQUESTED * 04370000 * /* F41448 * 04380000 * 5 PGETRADR PTR(31), /* ADDR IN WHICH ALLOCATED * 04390000 * /* F41448 * 04400000 * /* SPACE ADDR IS PLACED * 04410000 * /* F41448 * 04420000 * 5 PGETMDSP FIXED(15), /* MODE AND SUBPOOL * 04430000 * 04440000 * /* THE FIRST INPUT PUSHDOWN STACK. IF THIS STACK FILLS UP A F41448 * 04450000 * /* GETMAIN IS ISSUED FOR AN ADDITIONAL STACK. THIS PROCESS F41448 * 04460000 * /* CONTINUES INDEFINITELY. THE STACKS ARE BACKWARD CHAINED F41448 * 04470000 * /* WITH THE FIRST STACKS CHAIN WORD REMAINING ZERO.EACH NEW F41448 * 04480000 * /* ENTRY IN THE STACK CONSISTS OF TWO WORDS. THE FIRST IS F41448 * 04490000 * /* THE CONTENTS OF XINPUT,AND THE SECOND IS THE CONTENTS OF F41448 * 04500000 * /* ENDINPUT. THE NEXT FREE AREA IN THE STACK IS FOUND BY F41448 * 04510000 * /* USING PIPDLX AS AN INDEX INTO THE STACK. F41448 * 04520000 * 04530000 * /* F41448 * 04540000 * 2 PIPDLCUR PTR(31), /* ADDRESS OF CURRENT INPUT * 04550000 * /* PUSHDOWN STACK F41448 * 04560000 * /* F41448 * 04570000 * 2 PIPDLCHN PTR(31), /* STORAGE CHAIN - SHOULD * 04580000 * 2 NME(20) PTR(31), /*FIRST INPUT PUSHDOWN F41448 * 04590000 * /* STACK F41448 * 04600000 * /* F41448 * 04610000 * 2 PIPDLX PTR(8), /*INDEX TO NEXT FREE AREA IN * 04620000 * /* F41448 * 04630000 * /*CURRENT PUSHDOWN STACK * 04640000 * /* F41448 * 04650000 * 2 PLINKSV1 PTR(31), /*SAVE AREA FOR RETURN ADDRESS* 04660000 * /* F41448 * 04670000 * /*OF LINK1 ROUTINES WHICH USE * 04680000 * /* F41448 * 04690000 * /*LINK2 ROUTINES AS SUBRTNS * 04700000 * /* F41448 * 04710000 * 2 INVPSAVE PTR(31), /*BEGINNING ADDR OF PARM -USED* 04720000 * /*IF PARM IS INVALID F41448 * 04730000 * /* ADDRESSES FOR KEYWORD SCANS F41448 * 04740000 * /* F41448 * 04750000 * 2 PKEYWDPS PTR(31), /*PTR TO CURRENT NAME ENTRY * 04760000 * /* F41448 * 04770000 * 2 PKEYWDPC PTR(31), /*PTR TO CURRENT IKJKEYWD PCE * 04780000 * /* F41448 * 04790000 * 2 PKEYWDPX PTR(31), /*TO SAVE IKJKEYWD PCE ADDR * 04800000 * /* F41448 * 04810000 * 2 PKEYWDTB PTR(31), /*PCL RESULT DURING KEYWORD * 04820000 * /*PROCESSING F41448 * 04830000 * /* F41448 * 04840000 * 2 PKEYWDPM PTR(31), /*SAVE AREA FOR PDE DURING * 04850000 * /*KEYWORD PROCESSING F41448 * 04860000 * 2 PTABLEAD PTR(31), /*START OF PCL ADDRESS F41448 * 04870000 * 2 PTABLEND PTR(31), /*END OF PCL ADDRESS F41448 * 04880000 * /* F41448 * 04890000 * /* THE FOLLOWING FIELDS ARE USED AS TEMPORARY POSITIONAL PDE.F41448 * 04900000 * /* THE FIELDS ARE MOVED FROM HERE TO THE ACTUAL PDE BY THE F41448 * 04910000 * /* POSITIONAL EXIT ROUTINE. THE AREAS MUST BE CONTIGUOUS F41448 * 04920000 * /* F41448 * 04930000 * 2 TEMPPDE, /* NAME OF TEMPORARY AREA * 04940000 * 8 TEMPPDE2, /*LEN FOR NORMAL PARSE F41448 * 04950000 * /* F41448 * 04960000 * 9 DATAPTR1 PTR(31), /*PTR TO STRING, PSTRING * 04970000 * /* F41448 * 04980000 * /*QSTRING,PASSWORD,DSNAME * 04990000 * /*LOADNAME, OR VALUE F41448 * 05000000 * 9 DATALEN1 FIXED(15), /*LENGTH OF ABOVE DATA F41448 * 05010000 * 9 DATAFLA1 BIT(8), /*FLAG BYTE F41448 * 05020000 * 9 DATAFLB1 BIT(8), /*TYPE CODE FOR VALUE F41448 * 05030000 * /* F41448 * 05040000 * 9 DATAPTR2 PTR(31), /*PTR TO MEMBER OR ENTRY NAME * 05050000 * 9 DATALEN2 FIXED(15), /*LENGTH OF ABOVE DATA F41448 * 05060000 * 9 DATAFLA2 BIT(8), /*FLAG BYTE F41448 * 05070000 * 9 DATAFLB2 BIT(8), /*RESERVED BYTE F41448 * 05080000 * /* F41448 * 05090000 * 9 DATAPTR3 PTR(31), /*PTR TO PASSWORD OR ADDRESS * 05100000 * 9 DATALEN3 FIXED(15), /*LENGTH OF ABOVE DATA F41448 * 05110000 * 9 DATAFLA3 BIT(8), /*FLAG BYTE F41448 * 05120000 * 9 DATAFLB3 BIT(8), /*RESERVED BYTE F41448 * 05130000 * /* F41448 * 05140000 * 9 DATAFLG BIT(8), /*REGISTER NOTATION FLAGS * 05150000 * 9 DATASGN BIT(8), /*SIGN OF FIRST VALUE F41448 * 05160000 * /* F41448 * 05170000 * 9 DATAICT FIXED(15), /*INDIRECT ADDRESSING COUNT * 05180000 * /* F41448 * 05190000 * 9 DATAEXP PTR(31), /*PTR TO NEXT EXPRESSION * 05200000 * /* VALUE PDE F41448 * 05210000 * 9 DATAUSER FIXED(31), /*USER WORD F41448 * 05220000 * /* F41448 * 05230000 * 8 CBADD(11) PTR(31), /*COBOL ADDITIONS TO PARSE * 05240000 * /*TEMPORARY PDE F41448 * 05250000 * /* F41448 * 05260000 * 2 ENDBAKUP PTR(31), /*BACKUP FOR ENDINPUT IF * 05270000 * /* PFSCANX FLAG IS ON F41448 * 05280000 * /* F41448 * 05290000 * 2 PDELIM CHAR(1), /*SELF-DEFINED DELIMETER * 05300000 * /* F41448 * 05310000 * /*STORED BY DELIMETER ROUTINE * 05320000 * 2 PPCOUNT PTR(8), /*POSITIONAL DATA SIZE F41448 * 05330000 * 2 PPDESIZE PTR(8), /*POSIITONAL PDE SIZE F41448 * 05340000 * /* F41448 * 05350000 * 2 PERRCODE PTR(8), /*INDEX TO RESCAN ADDR TABLE * 05360000 * 2 PKEYWDVL FIXED(15), /*TO SAVE VALUE DURING F41448 * 05370000 * /* KEYWORD LOOKUP F41448 * 05380000 * /* F41448 * 05390000 * 2 RNG2ADDR PTR(31), /*ADDR OF 2ND PDE FOR A RANGE * 05400000 * /* F41448 * 05410000 * 2 SEGLIST(5) PTR(31), /*LIST OF MESSAGE SEGMENTS * 05420000 * /* F41448 * 05430000 * /* FOR I/O SERVICE ROUTINES * 05440000 * /* F41448 * 05450000 * 2 PREVPDEL PTR(31), /*USED TO CONTAIN THE PREV- * 05460000 * /* F41448 * 05470000 * /*IOUS PDE ADDRESS SO THAT * 05480000 * /* F41448 * 05490000 * /*THE VALIDITY CHECK ROUTINE * 05500000 * /* F41448 * 05510000 * /*CAN FETCH IT WHEN A RETURN * 05520000 * /* F41448 * 05530000 * /*CODE OF 4 OR 8 IS RETURNED * 05540000 * /*TO IT BY THE USER F41448 * 05550000 * /* F41448 * 05560000 * 2 VCEPARAM, /*VALIDITY CHECK EXIT PARAM- * 05570000 * /* ETERS F41448 * 05580000 * 11 PDEADR PTR(31), /*ADDRESS OF PDE JUST F41448 * 05590000 * /* CONSTRUCTED F41448 * 05600000 * /* F41448 * 05610000 * 11 USERWORD FIXED(31), /*USER DATA PASSED IN PARSE * 05620000 * /* F41448 * 05630000 * /* INPUT PARAMETER LIST * 05640000 * /* F41448 * 05650000 * 11 VALMSG PTR(31), /*ADDRESS OF SECOND LEVEL MSG * 05660000 * /* FROM VALIDITY CHECK F41448 * 05670000 * 11 MSGCODE PTR(8), /*OFFSET TO MSG ADDRES F41448 * 05680000 * /* MESSAGE SEGMENT CONTAINING THE LAST PRIMARY MESSAGE ID. F41448 * 05690000 * /* THIS IS USED AS SEGMENT 1 OF HELP MESSAGES PASSED TO THE F41448 * 05700000 * /* I/O SERVICE ROUTINES. IT INCLUDES THE FOUR BYTE HEADER F41448 * 05710000 * /* REQUIRED BY THE I/O ROUTINES, AND THE WORD 'ENTER'. F41448 * 05720000 * /* F41448 * 05730000 * 2 PRIMSGID CHAR(20), /* PRIMARY MESSAGE SEGMENT * 05740000 * /* F41448 * 05750000 * 2 SAVLSLEN FIXED(15), /* USED TO SAVE THE CORE SIZE * 05760000 * /* F41448 * 05770000 * /* REQUESTED BY THE HELP * 05780000 * /* MESSAGE ROUTINE. F41448 * 05790000 * /* F41448 * 05800000 * 2 PLUSSEG CHAR(5), /* PLUS SIGN MESSAGE SEGMENT * 05810000 * /* F41448 * 05820000 * /* F41448 * 05830000 * /* SAVE AREAS FOR ADDRESSES OF I/O SERVICE ROUTINES 'LOADED' DURING* 05840000 * /* INITIALIZATION F41448 * 05850000 * /* F41448 * 05860000 * /* * 05870000 * 2 PUTLPTR PTR(31), /* NAME THE LIST * 05880000 * 2 PUTGPTR PTR(31), /* PTR TO IKJPTGT RTN F41448 * 05890000 * /* F41448 * 05900000 * 2 UPTADDR PTR(31), /* FIRST WORD OF INPUT PARMS * 05910000 * /* F41448 * 05920000 * 2 ECTADDR PTR(31), /* SECOND WORD OF INPUT PARMS * 05930000 * /* F41448 * 05940000 * 2 ECBADDR PTR(31), /* THIRD WORD OF INPUT PARMS * 05950000 * /* F41448 * 05960000 * 2 * PTR(31), /* FOURTH WORD OF INPUT PARMS * 05970000 * 05980000 * /* F41448 * 05990000 * 2 OPEREND PTR(31), /* PTR TO LAST PCE UNDER OPER * 06000000 * 06010000 * /* F41448 * 06020000 * 2 RSVWDPCE PTR(31), /* PTR TO PCE BEING USED BY * 06030000 * /* IKJRSVWD F41448 * 06040000 * 06050000 * /* F41448 * 06060000 * 2 TERMXPCE PTR(31), /* PTR TO MAJOR TERM * 06070000 * 06080000 * /* F41448 * 06090000 * 2 OPERPCE PTR(31), /* PTR TO CURRENT OPER PCE * 06100000 * 06110000 * /* F41448 * 06120000 * 2 OPERSVE PTR(31), /* PTR TO LEFT PAREN OF EXPR.* 06130000 * 06140000 * 2 RSVWDSV1 PTR(31), /* LINK REG. SAV AREA F41448 * 06150000 * 06160000 * 2 RSVWDSV2 PTR(31), /* LINK REG. SAVE AREA F41448 * 06170000 * 06180000 * 2 CBLNKSV1 PTR(31), /* LINK REG. SAVE AREA F41448 * 06190000 * 06200000 * 2 CBLNKSV2 PTR(31), /* LINK REG. SAVE AREA F41448 * 06210000 * 06220000 * /* F41448 * 06230000 * 2 ENDNMPTR PTR(31), /* PTR TO END OF CURRENT * 06240000 * /* F41448 * 06250000 * /* DATANAME BEING SCANNED * 06260000 * 06270000 * /* F41448 * 06280000 * 2 CHAINPTR PTR(31), /*PTR TO CHAIN WD FOR DATANAME* 06290000 * /* QUALIFIER PDE'S F41448 * 06300000 * 06310000 * /* F41448 * 06320000 * 2 PDEPTR PTR(31), /* PTR TO NEXT AVAIL. SPACE IN* 06330000 * /* THE TEMPPDE F41448 * 06340000 * 06350000 * /* F41448 * 06360000 * 2 AANC PTR(31), /* ANCHORS TO CONTROL THE * 06370000 * /* F41448 * 06380000 * 2 TANC PTR(31), /* ALLOCATION OF DATANAME * 06390000 * /* F41448 * 06400000 * 2 OANC PTR(31), /* QUALIFIER PDE'S - IN CORE * 06410000 * /* F41448 * 06420000 * 2 ENDANC PTR(31), /* GOTTEN VIA STALOC ROUTINE * 06430000 * 06440000 * /* F41448 * 06450000 * 2 PRMTPTR PTR(31), /* PTR TO START OF INVALID * 06460000 * /* F41448 * 06470000 * /* DATA FOR SPECIAL MSG. * 06480000 * 06490000 * /* F41448 * 06500000 * 2 OPERLL FIXED(15), /*LEN OF PDE FLDS UNDER OPER * 06510000 * 06520000 * /* F41448 * 06530000 * 2 MSGAREA BDY(BYTE), /* PARMS PASSED TO PROMPT FOR * 06540000 * /* F41448 * 06550000 * /* SPECIAL MSG. CONSTRUCTION * 06560000 * /* F41448 * 06570000 * 7 MSGLEN FIXED(15), /* LENGTH OF FIRST SEGMENT * 06580000 * /* F41448 * 06590000 * 7 MSGADDR PTR(31), /* ADDR OF FIRST SEGMENT * 06600000 * 06610000 * /* F41448 * 06620000 * 2 DIGITCT PTR(8), /* DIGIT COUNTER FOR STRINGS * 06630000 * 06640000 * /* F41448 * 06650000 * 2 ELEMNCT PTR(8), /* NUMBER OF SUBSCRIPTS * 06660000 * 06670000 * /* F41448 * 06680000 * 2 QUALCT PTR(8), /* NUMBER OF QUALIFIERS * 06690000 * 06700000 * 2 CBFLAGS1 BIT(8), /* FIRST FLAG BYT F41448 * 06710000 * /* F41448 * 06720000 * 7 COBOLMOD BIT(1), /* COBOL PROCESSING SWITCH * 06730000 * /* F41448 * 06740000 * 7 OPERMODE BIT(1), /* EXPRESSION PROCESSING SW * 06750000 * /* F41448 * 06760000 * 7 SUBSMODE BIT(1), /* TERM - SUBSCRIPT MODE SW * 06770000 * /* F41448 * 06780000 * 7 NAMEREQD BIT(1), /* TERM - DATANAME EXPECTED * 06790000 * /* F41448 * 06800000 * 7 ERRORBIT BIT(1), /* TERM - ERROR HAS OCCURED * 06810000 * /* F41448 * 06820000 * 7 RSVDPRMT BIT(1), /* RSVWD HAS BEEN PRMPTED FOR * 06830000 * 7 OPERPRMT BIT(1), /* EXPRESSION HAS BEEN F41448 * 06840000 * /* F41448 * 06850000 * /* PROMPTED FOR BY OPER * 06860000 * /* F41448 * 06870000 * 7 RC16 BIT(1), /* A 16 RETURN CODE HAS BEEN * 06880000 * /* F41448 * 06890000 * /* ENCOUNTERED FROM VALIDITY * 06900000 * /* CHECK ROUTINE F41448 * 06910000 * 06920000 * 2 CBFLAGS2 BIT(8), /* SECOND FLAG BYTE F41448 * 06930000 * /* F41448 * 06940000 * 7 SPECMSG BIT(1), /* SPECIAL MSG. FORMAT IS TO * 06950000 * /* F41448 * 06960000 * /* BE USED IN PROMPTING * 06970000 * /* F41448 * 06980000 * 7 LFTPAREN BIT(1), /* A LEFT PAREN IS TO BE * 06990000 * /* F41448 * 07000000 * /* ADDED TO SPECIAL MSG * 07010000 * /* F41448 * 07020000 * 7 RHTPAREN BIT(1), /* A RIGHT PAREN IS TO BE * 07030000 * /* F41448 * 07040000 * /* ADDED TO SPECIAL MSG. TEXT * 07050000 * /* F41448 * 07060000 * 7 CHAINTRM BIT(1), /* A TERM CHAINED FROM AN * 07070000 * /* F41448 * 07080000 * /* OPER IS BEING PROCESSED * 07090000 * /* F41448 * 07100000 * 7 PARS2IN BIT(1), /* PARS2 HAS BEEN LOADED * 07110000 * /* F41448 * 07120000 * 7 PRMTSCAN BIT(1), /* USED BY TERM FOR PRMT DATA * 07130000 * /* F41448 * 07140000 * 7 BUFPOPED BIT(1), /* RECURSION IN SCANF ROUTINE * 07150000 * /* F41448 * 07160000 * 7 RNGADDED BIT(1), /* 1ST VALUE OF RNG ADDED * 07170000 * 07180000 * 2 CBFLAGS3 BIT(8), /* FLAG BYTE THREE F41448 * 07190000 * /* F41448 * 07200000 * 7 FIRSTNAM BIT(1), /* 1ST DN. OF VAR ENCOUNTERED * 07210000 * /* F41448 * 07220000 * 7 CTFOUND BIT(1), /*BEGIN. OF CHNTRM SBSCRPT FND* 07230000 * /* F41448 * 07240000 * 7 BLNKFLAG BIT(1), /* OPER PTING AT BLNK FOR * 07250000 * /* INVALID MSG. FORMAT F41448 * 07260000 * 07270000 * /* F41448 * 07280000 * 2 CBFLAGS4 BIT(8), /* FLAG BYTE FOUR - RSVD * 07290000 * 07300000 * /* F41448 * 07310000 * 2 TRANAREA CHAR(2) BDY(HWORD),/* TRANSLATE AREA FOR TERM * 07320000 * 07330000 * 2 CORELEN FIXED(15), /* RESERVED F41448 * 07340000 * 07350000 * /* F41448 * 07360000 * 2 PARS2ADR PTR(31), /* ADDR OF IKJPARS2 LOAD MOD * 07370000 * 07380000 * /* F41448 * 07390000 * 2 VCONAD PTR(31), /*ADDR OF VCON TAB IN IKJPARS * 07400000 * 07410000 * /* F41448 * 07420000 * 2 GOREGSV PTR(31), /*RETURN ADDR FROM SUBROUTINE * 07430000 * 07440000 * /* F41448 * 07450000 * 2 TERMBASE PTR(31), /*TERM BASE REG SAVE AREA * 07460000 * 07470000 * /* F41448 * 07480000 * 2 OPERBASE PTR(31), /*OPER BASE REG SAVE AREA * 07490000 * 07500000 * /* F41448 * 07510000 * 2 BASE3SV PTR(31), /*SAVE AREA - PARSE BASE REG3 * 07520000 * 07530000 * /* F41448 * 07540000 * 2 BASE2SV PTR(31), /*SAVE AREA - PARSE BASE REG2 * 07550000 * 07560000 * /* F41448 * 07570000 * 2 BASE1SV PTR(31), /*SAVE AREA - PARSE BASE REG1 * 07580000 * 07590000 * /* F41448 * 07600000 * 2 RBASESV PTR(31), /*SAVE AREA - PARSE RBASE * 07610000 * 07620000 * /* F41448 * 07630000 * 2 CBLRET PTR(31), /* POINT TO RETURN TO IN THE * 07640000 * /* F41448 * 07650000 * /* NEW IKJPARS2 LOAD * 07660000 * /* F41448 * 07670000 * /* AFTER EXECUTION OF ANY * 07680000 * /* F41448 * 07690000 * /* SUBROUTINE IN IKJPARS * 07700000 * /* F41448 * 07710000 * 2 COREADDR PTR(31), /* ADDR OF CORE GOTTEN FOR MSG* 07720000 * 07730000 * /* F41448 * 07740000 * 2 AUTOBASE PTR(31), /*SAVE AREA FOR DATAREG (BSL) * 07750000 * 07760000 * /* F41448 * 07770000 * 2 WORKSAVE(4) PTR(31), /* WORKREG SAVE AREA -LINKAGE * 07780000 * 07790000 * /* F41448 * 07800000 * 2 PLINKSV2 PTR(31); /* RETURN ADDR SAVE AREA FROM * 07810000 * /* F41448 * 07820000 * /* VALIDITY CHECK AND CODE4 * 07830000 * /* F41448 * 07840000 * /* ALLOCATE SPACE IN WHICH TO MOVE THE L FORM OF THE I/O F41448 * 07850000 * /* SERVICE ROUTINE MACROS. F41448 * 07860000 * /* F41448 * 07870000 * GENERATE DATA; 07880000 * /* END OF IKJEFPWA F41448 * 07890000 * DCL 07900000 * R12 REG(12); /* WORK REG - REGISTER 12 * 07910000 * DCL 07920000 * R13 REG(13); /* WORK REG - REGISTER 13 * 07930000 * DCL 07940000 * GOREG REG(14); /* USED AS RETURN REGISTER WHEN 07950000 * GO TO PARSE SUB- ROUTINES * 07960000 * DCL 07970000 * R14 REG(14); /* USED AS RETURN REGISTER * 07980000 * DCL 07990000 * R15 REG(15); /* SUBROUTINE ADDRESS LOADED HERE 08000000 * BY PARS2 - RETURN CODE HERE 08010000 * FROM IKJPARS * 08020000 * DCL 08030000 * INDEX1 PTR(31); /* USED AS INDEX PTR INTO SPECIAL 08040000 * MESSAGE AREA * 08050000 * 08060000 * /***************************************************************** 08070000 * /* * 08080000 * /* LABEL FOR REFERENCING PCE TYPE TO DETERMINE WHETHER OPER, TERM* 08090000 * /* OR RESERVED WORD PCE * 08100000 * /* * 08110000 * /***************************************************************** 08120000 * 08130000 * DCL 08140000 * 1 MASK BASED(XPCE), /* LABEL FOR REFERENCING PCE TYPE 08150000 * MASK IN FIRST BYTE OF * 08160000 * 2 PCETYPE BIT(3), /* PCE * 08170000 * 2 * BIT(5); 08180000 * 08190000 * /***************************************************************** 08200000 * /* * 08210000 * /* IKJOPER PCE MAPPING * 08220000 * /* * 08230000 * /***************************************************************** 08240000 * 08250000 * DCL 08260000 * 1 OPCEFLD1 BASED(OPERPCE) BDY(BYTE), /* MAP FIRST FIXED 08270000 * OPER FIELD * 08280000 * 2 OPCEBYT1 BIT (16), /* FIRST BYTE OF INDICATORS * 08290000 * 3 OPERMASK BIT(3), /* INDICATES PCE TYPE * 08300000 * 3 OPRMTI BIT(1), /* PROMPT DATA SUPPLIED * 08310000 * 3 ODLFTI BIT(1), /* DEFAULT DATA SUPPLIED * 08320000 * 3 * BIT(11), /* NOT REFERENCED * 08330000 * 2 OPCELNTH FIXED(15), /* OPER PCE LENGTH * 08340000 * 2 OPDEINDX FIXED(15), /* OFFSET TO OPER PDE FROM START 08350000 * OF PDL * 08360000 * 2 OPCEPTL FIXED(15), /* PARAMETER TYPE FIELD LENGTH * 08370000 * 2 * FIXED(15); /* NOT REFERENCED * 08380000 * 08390000 * /***************************************************************** 08400000 * /* * 08410000 * /* MAP SECOND FIXED FIELD IN THE IKJOPER PCE * 08420000 * /* * 08430000 * /***************************************************************** 08440000 * 08450000 * DCL 08460000 * 1 OPCEFLD2 BASED(OPCEPTR) BDY(BYTE), /* MAP SECOND FIXED 08470000 * OPER FIELD * 08480000 * 2 RPCEINDX FIXED(15), /* OFFSET TO RSVWD PCE FROM START 08490000 * OF PDL * 08500000 * 2 T1PCEIDX FIXED(15), /* OFFSET TO MINOR TERM1 PCE * 08510000 * 2 T2PCEIDX FIXED(15), /* OFFSET TO MINOR TERM2 PCE * 08520000 * 2 T3PCEIDX FIXED(15), /* OFFSET TO MINOR TERM3 PCE * 08530000 * 2 * FIXED(15); /* NOT REFERENCED * 08540000 * 08550000 * /***************************************************************** 08560000 * /* * 08570000 * /* NAME REFERENCING PDE SPACE UNDER THE OPER PDE * 08580000 * /* * 08590000 * /***************************************************************** 08600000 * 08610000 * DCL 08620000 * OPDE CHAR(256) BASED(INDEX); 08630000 * DCL 08640000 * ADDR1 FIXED(15); /* INDEX INTO LINE SCANNING * 08650000 * DCL 08660000 * LINKRET INTERNAL ENTRY LOCAL; /* SUBROUTINE TO PROVIDE 08670000 * LINKAGE WITH IKJPARS * 08680000 * DCL 08690000 * MSGSETUP INTERNAL ENTRY LOCAL; /* SUBROUTINE TO BUILD THE 08700000 * SPECIAL MESSAGE REQUIRED BY 08710000 * IKJPARS2 * 08720000 * DCL 08730000 * VCONTAB(19) PTR(31) BASED(VCONAD); /* VCON TABLE FOR 08740000 * RESOLVING * 08750000 * DCL 08760000 * DTANME (*) CHAR(1) BASED(MSGADDR); /* FIRST DATA NAME WHICH 08770000 * IS INVALID - PINTED TO BY MSG 08780000 * ADDR FIELD SET BY MACRO 08790000 * PROCESSORS * 08800000 * DCL 08810000 * INVDATA (*) CHAR(1) BASED(INVPSAVE); /* DATA FOUND TO BE 08820000 * INVALID MUST BE MOVED INTO THE 08830000 * 'INVALID...' MESSAGE * 08840000 * 08850000 * /***************************************************************** 08860000 * /* * 08870000 * /* POINTER TO NEXT LIST PDE FOR ELIMINATING LAST PDE FROM CHAIN * 08880000 * /* * 08890000 * /***************************************************************** 08900000 * 08910000 * DCL 08920000 * LISTPTR PTR(31) BASED(PREVPDEL); 08930000 * 08940000 * /***************************************************************** 08950000 * /* * 08960000 * /* NAME FOR REFERENCING THE COBOL TEMPORARY PDE AREA WHEN MUST * 08970000 * /* ERASE * 08980000 * /* * 08990000 * /***************************************************************** 09000000 * 09010000 * DCL 09020000 * CBLTEMP CHAR(LENGTH(TEMPPDE)) BASED(ADDR(TEMPPDE)); 09030000 * DCL 09040000 * MSGAREA1 (*) CHAR(1) BASED(COREADDR); /* CORE GOTTEN TO 09050000 * BUILD SPECIAL MESSAGE * 09060000 * DCL 09070000 * MSGA (*) CHAR(1) BASED(INDEX1); /* ALSO USED AS MESSAGE 09080000 * AREA * 09090000 * DCL 09100000 * TERM LABEL GENERATED; /* LABEL FOR TERM PCE * 09110000 * DCL 09120000 * OPERLD LABEL GENERATED; /* LABEL FOR OPER PCE * 09130000 * DCL 09140000 * RSVD LABEL GENERATED; /* LABEL FOR RSVD WORD PCE * 09150000 * DCL 09160000 * RTRNAD LABEL GENERATED; /* ENTRY RETURN FROM IKJPARS * 09170000 * 09180000 * /***************************************************************** 09190000 * /* * 09200000 * /* GENERATE ENTRY CODE TO LOAD REQUIRED MACRO PROCESSOR ADDRESS * 09210000 * /* * 09220000 * /***************************************************************** 09230000 * 09240000 * RESPECIFY 09250000 * (XPCE, 09260000 * XINPUT, 09270000 * XINPUTB, 09280000 * PWAREG) RESTRICTED; 09290000 * TERMBASE = R2; /* SAVE IKJPARS2 BASE * 09300000 ST @2,556(0,@B) 0048 09310000 * OPERBASE = R3; /* REGISTERS * 09320000 ST @3,560(0,@B) 0049 09330000 * AUTOBASE = R12; /* SAVE BASE REGISTER TO AUTO- 09340000 * MATIC STORAGE * 09350000 ST @C,588(0,@B) 0050 09360000 * CBLRET = ADDR(RTRNAD); /* SAVE RETURN ADDRESS FROM 09370000 * IKJPARS IN THE WORK AREA * 09380000 LA @F,RTRNAD 0051 09390000 ST @F,580(0,@B) 0051 09400000 * IF PCETYPE = '110'B /* IF THIS IS A TERM PCE GO * 09410000 * THEN 09420000 TM 0(@6),B'11000000' 0052 09430000 BC 12,@9FF 0051 09440000 TM 0(@6),B'00100000' 0052 09450000 * GOTO TERM; /* TO LOAD IKJEFP60 ADDRESS * 09460000 BC 10,TERM 0053 09470000 * IF PCETYPE = '111'B /* IF THIS IS AN OPER PCE GO * 09480000 * THEN 09490000 @9FE EQU * 0054 09500000 @9FF TM 0(@6),B'11100000' 0054 09510000 * GOTO OPERLD; /* LOAD IKJEFP50 ADDRESS * 09520000 BC 01,OPERLD 0055 09530000 * IF PCETYPE = '101'B /* IF RESERVED WORD PCE GO * 09540000 * THEN 09550000 TM 0(@6),B'10100000' 0056 09560000 BC 12,@9FD 0055 09570000 TM 0(@6),B'01000000' 0056 09580000 * GOTO RSVD; /* LOAD IKJEFP40 ADDRES * 09590000 BC 10,RSVD 0057 09600000 * GOTO ERROR; /* IF NONE OF COBOL PCE'S IT IS 09610000 * AN ERROR * 09620000 BC 15,ERROR 0058 09630000 * 09640000 * /***************************************************************** 09650000 * /* * 09660000 * /* GENERATE CODE TO LOAD THE MACRO PROCESSOR ENTRY ADDRESS INTO * 09670000 * /* REGISTER 1 AND BRANCH TO THE REQUIRED ENTRY * 09680000 * /* * 09690000 * /***************************************************************** 09700000 * 09710000 * GENERATE; 09720000 RSVD L R1,RSVDENT RESERVED WORD MACRO PROCESSOR 09730000 BR R1 GO TO RESERVED WORD 09740000 TERM L R1,TERMENT LOAD TERM MACRO PROCESSOR 09750000 BR R1 ADDRESS AND BRANCH 09760000 OPERLD L R1,OPERENT LOAD OPER MACRO PROCESSOR 09770000 BR R1 ADDRESS AND BRANCH 09780000 TERMENT DC A(IKJEFP60) ENTRY - TERM MACRO PROCESSOR 09790000 RSVDENT DC A(IKJEFP40) ENTRY - RESERVED WORD MACRO 09800000 * PROCESSOR 09810000 OPERENT DC A(IKJEFP50) ENTRY - OPER MACRO PROCESSOR 09820000 EJECT 09830000 DS 0H 09840000 * 09850000 * /***************************************************************** 09860000 * /* * 09870000 * /* INTERNAL PROCEDURE - LINKRET THE MACRO PROCESSORS COME HERE TO* 09880000 * /* GO TO PARSE TO USE A SUBROUTINE OF IKJPARS - IKJEFP00 * 09890000 * /* * 09900000 * /***************************************************************** 09910000 * 09920000 * 09930000 * LINKRET: 09940000 * PROC OPTIONS(DONTSAVE,NOSAVEAREA); 09950000 @EL01 LR @1,@C 0060 09960000 L @0,@SIZ001 0060 09970000 FREEMAIN R,LV=(0),A=(1) 0060 09980000 BCR 15,@E 0060 09990000 LINKRET EQU * 0060 10000000 * 10010000 * /***************************************************************** 10020000 * /* * 10030000 * /* RESTRICT REQUIRED REGISTERS * 10040000 * /* * 10050000 * /***************************************************************** 10060000 * 10070000 * RESPECIFY 10080000 * (XPCE, 10090000 * XINPUT, 10100000 * XINPUTB, 10110000 * PWAREG, 10120000 * R7, 10130000 * R1) RESTRICTED; 10140000 * 10150000 * /***************************************************************** 10160000 * /* * 10170000 * /* GENERATE THE CODE TO HANDLE THE LINKAGE BETWEEN IKJPARS AND * 10180000 * /* IKJPARS2. THIS MUST BE DONE BECAUSE THE VALUES IN REGISTER 14 * 10190000 * /* AND REGISTER 15 MUST REMAIN UNCHANGED. * 10200000 * /* * 10210000 * /***************************************************************** 10220000 * 10230000 * GENERATE; /* SAVE WORK REGISTERS * 10240000 USING PWORK,PWAREG ESTABLIST PWORK ADDRESSABILITY 10250000 STM R7,R10,WORKSAVE SAVE WORK REGISTERS 10260000 DROP PWAREG FREE BASE REGISTER 10270000 DS 0H 10280000 * BUFPOPED='0'B; /* SET CONTRL FOR POPSTCK RTN * 10290000 NI 536(@B),B'11111101' 0063 10300000 * INVPRMPT='0'B; /* TURN OFF INVALID PROMPT IND- 10310000 * ICATOR FOR IKJPARS1 * 10320000 NI 116(@B),B'10111111' 0064 10330000 * R15 = VCONTAB(R15); /* LOAD THE REQUIRED IKJPARS 10340000 * ROUTINE ADDRESS FROM THE VCON 10350000 * TABLE - INDEX INTO THE TABLE 10360000 * IS IN R15 * 10370000 LR @8,@F 0065 10380000 BCTR @8,0 0065 10390000 SLA @8,2 0065 10400000 L @9,548(0,@B) 0065 10410000 L @F,0(@8,@9) 0065 10420000 * GOREGSV=GOREG; /* STORE RETURN ADDRESS IN WORK 10430000 * AREA * 10440000 ST @E,552(0,@B) 0066 10450000 * GOREG=VCONTAB (18); /* LOAD ENTRY PT INTO IKJPARS * 10460000 L @8,548(0,@B) 0067 10470000 L @E,68(0,@8) 0067 10480000 * RESPECIFY 10490000 * R1 UNRESTRICTED; /* RELEASE REGISTER 1 * 10500000 * GENERATE; 10510000 USING PWORK,PWAREG ADDRESSABILITY TO PWORK 10520000 LR R13,PWAREG RESTORE IKJPARS' WORK AREA 10530000 * BASE REGISTER 10540000 L R7,BASE3SV RESTORE BASE REGISTERS 10550000 LM R10,R12,BASE2SV RESTORE BASE REGS AND BASE 10560000 * REGISTER TO RECURSIVE WORK 10570000 * AREA 10580000 BR GOREG BRANCH TO IKJPARS ENTRY 10590000 RTRNAD L R14,GOREGSV LAOD RETURN ADDRESS TO PROPER 10600000 * ROUTINE IN IKJPARS2 10610000 AR R14,R15 ADD RETURN CODE TO RETURN ADDR 10620000 LM 7,10,WORKSAVE RESTORE WORK REGISTERS 10630000 BR R14 RETURN TO ROUTINE ADDRESS PLUS 10640000 * RETURN CODE 10650000 DROP PWAREG FREE BASE REG FOR WORKAREA 10660000 EJECT 10670000 DS 0H 10680000 * 10690000 * /***************************************************************** 10700000 * /* * 10710000 * /* TESTING * 10720000 * /* * 10730000 * /***************************************************************** 10740000 * 10750000 * 10760000 * EL: 10770000 * END LINKRET; /* END INTERFACE PROCEDURE * 10780000 EL EQU * 0070 10790000 @EL02 BCR 15,@E 0070 10800000 * 10810000 * /***************************************************************** 10820000 * /* * 10830000 * /* INTERNAL PROCEDURE - MSGSETUP THIS ROUTINE PREPARES THE * 10840000 * /* 'INVALID - PARAMETER TYPE - INVALID DATA' MESSAGE BEFORE GOING* 10850000 * /* TO IKJPARS TO WRITE IT TO THE TERMINAL. COBOL SUPPORT HAS A * 10860000 * /* SPECIAL MESSAGE FORMAT WHICH THIS ROUITNE HANDLES. CORE IS * 10870000 * /* GOTTEN FOR THE SPECIAL MESSAGE AND ALL THE INVALID DATA IS * 10880000 * /* MOVED INTO A CONTIGUOUS AREA SO THAT THE SPECIAL MESSAGE * 10890000 * /* APPEARS IDENTICAL TO ALL OTHER MESSAGES IKJPARS MUST HANDLE. * 10900000 * /* THE MESSAGE FORMAT IS THE FOLLOWING: 'INVALID PARMATER TYPE * 10910000 * /* DATA * 10920000 * /* ...DATA' THE ELLIPSES REPRESENT A NEW FUNCTION ADDED TO * 10930000 * /* THE INVALID MESSAGE. * 10940000 * /* * 10950000 * /***************************************************************** 10960000 * 10970000 * 10980000 * MSGSETUP: 10990000 * PROC OPTIONS(DONTSAVE,NOSAVEAREA); 11000000 MSGSETUP EQU * 0071 11010000 * 11020000 * /***************************************************************** 11030000 * /* * 11040000 * /* RESTRICT REQUIRED REGISTERS * 11050000 * /* * 11060000 * /***************************************************************** 11070000 * 11080000 * RESPECIFY 11090000 * (XPCE, 11100000 * XINPUT, 11110000 * XINPUTB, 11120000 * PWAREG, 11130000 * INDEX) RESTRICTED; 11140000 * PLINKSV2 = CBLNKSV2; /* RETURN ADDRESS IN CASE OF AN 11150000 * ERROR FROM VALIDITY CHECK MUST 11160000 * BE SAVED. IKJPARS WILL RESTORE 11170000 * ADDR. FROM PLINKSV2 IF AN 11180000 * ERROR IS RETURNED FROM THE 11190000 * V.C. EXIT * 11200000 MVC 608(4,@B),488(@B) 0073 11210000 * 11220000 * /***************************************************************** 11230000 * /* * 11240000 * /* CHECK TO SEE IF IT IS AN IKJTERM PCE * 11250000 * /* * 11260000 * /***************************************************************** 11270000 * 11280000 * IF PCETYPE = '110'B THEN /* IS IT AN IKJTERM * 11290000 TM 0(@6),B'11000000' 0074 11300000 BC 12,@9FB 0073 11310000 TM 0(@6),B'00100000' 0074 11320000 BC 05,@9FA 0074 11330000 * DO; /* IF IS , DO THE FOLLOWING 11340000 * INITIALIZATION * 11350000 * TANC = AANC; /* RESET CORE ANCHORS TO ERASE 11360000 * ALL QUALIFIER PDE'S WHICH MAY 11370000 * HAVE BEEN ADDED * 11380000 MVC 508(4,@B),504(@B) 0076 11390000 * SEGLIST (5)= XPCE+7; /* INITIALIZE MESSAGE PARM 11400000 * FIELD FOR THE PUTLINE TO POINT 11410000 * TO THE PARAMETER TYPE FIELD IN 11420000 * THE PCE * 11430000 LA @F,7 0077 11440000 AR @F,@6 0077 11450000 ST @F,380(0,@B) 0077 11460000 * GOTO MSGSET; /* GO TO FORMAT THE MESSAGE * 11470000 BC 15,MSGSET 0078 11480000 * END; 11490000 * 11500000 * /***************************************************************** 11510000 * /* * 11520000 * /* DETERMINE IF THE PCETYPE IS AN OPER * 11530000 * /* * 11540000 * /***************************************************************** 11550000 * 11560000 * IF PCETYPE = '111'B THEN /* IF PCE TYPE IS AN OPER * 11570000 @9FA EQU * 0080 11580000 @9FB TM 0(@6),B'11100000' 0080 11590000 BC 12,@9F9 0080 11600000 * DO; /* DO THE FOLLOWING INIDTIAL- 11610000 * IZATION * 11620000 * TANC=OANC; /* RESET CORE ANCHORS TO WIPE * 11630000 MVC 508(4,@B),512(@B) 0082 11640000 * AANC = OANC; /* OUT ANY QUALIFIER PDE'S * 11650000 MVC 504(4,@B),512(@B) 0083 11660000 * INDEX = XPDL + OPDEINDX; /* ADD OPER PDE OFFSET FROM THE 11670000 * PCE TO THE BEGINNING OF THE 11680000 * PDE TO GET OPER PDE ADDRESS * 11690000 L @1,468(0,@B) 0084 11700000 MVC @TEMP2+2(2),4(@1) 0084 11710000 LH @8,@TEMP2+2 0084 11720000 A @8,104(0,@B) 0084 11730000 * 11740000 * /************************************************************* 11750000 * /* * 11760000 * /* CLEAR THE PERMANENT PDE UNDER THE OPER PDE TO GET RID OF * 11770000 * /* ANY INFORMATION WHICH MAY HAVE BEEN FILLED IN UNDER THE * 11780000 * /* OPER * 11790000 * /* * 11800000 * /************************************************************* 11810000 * 11820000 * OPDE (1:OPERLL) = OPDE(1:OPERLL)&&OPDE(1:OPERLL); 11830000 LR @E,@8 0085 11840000 LH @7,524(0,@B) 0085 11850000 BCTR @7,0 0085 11860000 LR @A,@8 0085 11870000 EX @7,@XC 0085 11880000 * SEGLIST (5) = XPCE+6; /* FILL IN PUTLINE PARAMETER 11890000 * LIST WITH ADDR OF PARAMETER 11900000 * TYPE FIELD IN THE PCE * 11910000 LA @F,6 0086 11920000 AR @F,@6 0086 11930000 ST @F,380(0,@B) 0086 11940000 * GOTO MSGSET; /* GO TO FORMAT THE MESSAGE * 11950000 BC 15,MSGSET 0087 11960000 * END; /* END OPER PCE PROCESSING * 11970000 * 11980000 * /***************************************************************** 11990000 * /* * 12000000 * /* DETERMINE IF PROCESSING UNDER A RESERVED WORD PCE * 12010000 * /* * 12020000 * /***************************************************************** 12030000 * 12040000 * IF PCETYPE = '101'B THEN /* SEE IF PROCESSING A RESERVD * 12050000 @9F9 TM 0(@6),B'10100000' 0089 12060000 BC 12,@9F8 0088 12070000 TM 0(@6),B'01000000' 0089 12080000 BC 05,@9F7 0089 12090000 * DO; /* WORD PCE * 12100000 * SEGLIST (5)= XPCE+6; /* POSITION TO PARAMETER TYPE 12110000 * FIELD IN THE PCE * 12120000 LA @F,6 0091 12130000 AR @F,@6 0091 12140000 ST @F,380(0,@B) 0091 12150000 * GOTO MSGSET; /* GO TO FORMAT THE MESSAGE * 12160000 BC 15,MSGSET 0092 12170000 * END; /* END SPECIAL RESERVED WORD PCE 12180000 * PROCESSING * 12190000 * 12200000 * ERROR: /* ERROR ENTRY * 12210000 * RETCODE = 24; /* IF FALL THROUGH TO HERE. 12220000 * MSGSETUP WAS ENTERED UNDER AN 12230000 * INVALID PCE TYPE AND AN ERROR 12240000 * RETURN MUST BE MADE * 12250000 @9F7 EQU * 0094 12260000 @9F8 EQU * 0094 12270000 ERROR MVI 90(@B),24 0094 12280000 * R15 = 16; /* LOAD R15 WITH ADDRESS OF 12290000 * CLEANUP ROUTINE IN IKJPARS * 12300000 LA @F,16 0095 12310000 * GOTO LINKRET; /* GO TO ROUTINE TO HANDLE 12320000 * LINKAGE TO IKJPARS * 12330000 BC 15,LINKRET 0096 12340000 * 12350000 * /***************************************************************** 12360000 * /* * 12370000 * /* ROUTINE TO FORMAT THE SPECIAL MESSAGE IF REQUIRED * 12380000 * /* * 12390000 * /***************************************************************** 12400000 * 12410000 * 12420000 * MSGSET: 12430000 * MSGCODE = 20; /* INDICATE INVALID MESSAGE TO BE 12440000 * WRITTEN * 12450000 MSGSET MVI 400(@B),20 0097 12460000 * CBLTEMP = CBLTEMP && CBLTEMP; /* CLEAR THE COBOL TEMPORARY PDE * 12470000 XC 268(80,@B),268(@B) 0098 12480000 * 12490000 * /***************************************************************** 12500000 * /* * 12510000 * /* IF XINPUTB IS GREATER THAN THE END OF THE BUFFER, MUST SET IT * 12520000 * /* EQUAL TO ENDINPUT SO WON'T GET GARBAGE IN THE ERROR MESSAGE * 12530000 * /* * 12540000 * /***************************************************************** 12550000 * 12560000 * IF BLNKFLAG ª= '1'B /* IF OPER SAYS NOT PTING AT A * 12570000 * THEN /* BLANK OUT OF BUFFER THEN * 12580000 TM 537(@B),B'00100000' 0099 12590000 BC 01,@9F6 0099 12600000 * IF XINPUTB>ENDINPUT /* IF XINPUTB IS OFF THE * 12610000 * THEN /* BUFFER, RESET IT SO * 12620000 C @5,80(0,@B) 0100 12630000 BC 12,@9F5 0100 12640000 * XINPUTB=ENDINPUT; /* NO GARBAGE IN MESSAGE * 12650000 L @5,80(0,@B) 0101 12660000 * BLNKFLAG = '0'B; /* RESET BLANK INDICATOR * 12670000 @9F5 EQU * 0102 12680000 @9F6 NI 537(@B),B'11011111' 0102 12690000 * INDEX = XINPUTB - INVPSAVE; /* GET LENGTH OF INVALID DATA * 12700000 L @8,236(0,@B) 0103 12710000 LCR @8,@8 0103 12720000 AR @8,@5 0103 12730000 * IF INDEX <= 0 /* IF LENGTH IS ZERO OR LESS * 12740000 * THEN 12750000 LTR @8,@8 0104 12760000 * GOTO ERROR; /* IT IS AN ERROR * 12770000 BC 12,ERROR 0105 12780000 * 12790000 * /***************************************************************** 12800000 * /* * 12810000 * /* DETERMINE IF A SPECIAL MESSAGE IS REQUIRED * 12820000 * /* * 12830000 * /***************************************************************** 12840000 * 12850000 * IF SPECMSG = '1'B THEN /* IF SPECIAL MESSAGE, MUST DO 12860000 * INITIALIZATION BEFORE GO TO 12870000 * IKJPARS TO WRITE IT OUT * 12880000 TM 536(@B),B'10000000' 0106 12890000 BC 12,@9F4 0106 12900000 * DO; /* DO SPECIAL MESSAGE PROCESS * 12910000 * RESPECIFY 12920000 * R1 RESTRICTED; /* RESTRICT R1 BECAUSE IKJPARS IS 12930000 * DEPENDENT ON VALUES IN 1 * 12940000 * XINPUTB = XINPUTB-INVPSAVE; /* GET LENGTH OF INVALID DATA 12950000 * INTO XINPUTB * 12960000 S @5,236(0,@B) 0109 12970000 * R1 = XINPUTB + 5 + MSGLEN; /* GET TOTAL LENGTH OF CORE 12980000 * REQUIRED IN WHICH TO BUILD THE 12990000 * SPECIAL MESSAGE * 13000000 LH @1,526(0,@B) 0110 13010000 AH @1,@D1 0110 13020000 AR @1,@5 0110 13030000 * CORELEN = R1; /* SAVE THE LENGTH OF THE GET- 13040000 * MAIN FOR SUBSEQUEND FREEMAN * 13050000 STH @1,542(0,@B) 0111 13060000 * R15 = 14; /* LOAD THE ADDRESS OF THE 13070000 * GETMAIN ROUTINE IN IKJPARS * 13080000 LA @F,14 0112 13090000 * CALL LINKRET; /* GO TO PROCEDURE WHICH HANDLES 13100000 * LINKAGES TO IKJPARS. * 13110000 BAL @E,LINKRET 0113 13120000 * COREADDR = SUBRWORK(1); /* SAVE ADDR OF CORE GOTTEN FOR 13130000 * SUBSEQUENT FREEMAIN * 13140000 MVC 584(4,@B),96(@B) 0114 13150000 * INDEX1=SUBRWORK (1); /* SET BASE FOR MSGA * 13160000 MVC INDEX1(4),96(@B) 0115 13170000 * 13180000 * /************************************************************* 13190000 * /* * 13200000 * /* DETERMINE IF IT IS NECESSARY TO INSERT A LEFT PARENTHESIS * 13210000 * /* INTO THE SPECIAL MESSAGE BUFFER. THIS BIT IS SET BY THE * 13220000 * /* INDIVIDUAL MACRO PROCESSORS * 13230000 * /* * 13240000 * /************************************************************* 13250000 * 13260000 * IF LFTPAREN = '1'B /* IS LEFT PAREN REQUIRED * 13270000 * THEN 13280000 TM 536(@B),B'01000000' 0116 13290000 BC 12,@9F3 0116 13300000 * MSGAREA1 (1) = '('; /* IF SO, INSERT LEFT PAREN * 13310000 L @7,584(0,@B) 0117 13320000 MVI 0(@7),C'(' 0117 13330000 BC 15,@9F2 0118 13340000 * ELSE 13350000 * MSGAREA1 (1) = ' '; /* IF NOT, BLANK OUT FIRST BYTE 13360000 * OF THE MESSAGE BUFFER * 13370000 @9F3 L @7,584(0,@B) 0118 13380000 MVI 0(@7),C' ' 0118 13390000 * INDEX1=INDEX1+1; /* INCREMENT MSGA BASE * 13400000 @9F2 LA @F,1 0119 13410000 A @F,INDEX1 0119 13420000 ST @F,INDEX1 0119 13430000 * 13440000 * /************************************************************* 13450000 * /* * 13460000 * /* MOVE IN THE FIRST PART OF THE INVALID MESSAGE. THIS MOVES * 13470000 * /* IN THE FIRST DATA NAME MOVE DATA INTO FIRST PART OF * 13480000 * /* MESSAGE AREA * 13490000 * /* * 13500000 * /************************************************************* 13510000 * 13520000 * DO INDEX=MSGLEN TO 1 BY -1; /* MOVE 1 CHARACTER AT A TIME 13530000 * FROM THE END BACKWARDS * 13540000 LH @F,526(0,@B) 0120 13550000 LTR @8,@F 0120 13560000 BC 12,@DO9F0 0120 13570000 * MSGA (INDEX) = DTANME(INDEX); /* 1 CHARACTER OF DATA FOR 13580000 * SPECIFIED LENGTH * 13590000 @DO9F1 LR @7,@8 0121 13600000 BCTR @7,0 0121 13610000 L @9,528(0,@B) 0121 13620000 LA @E,0(@7,@9) 0121 13630000 L @9,INDEX1 0121 13640000 LA @A,0(@7,@9) 0121 13650000 MVC 0(1,@A),0(@E) 0121 13660000 * END; /* LENGTH OF FIRST DATA NAME * 13670000 * INDEX1 = INDEX1 + MSGLEN; /* INCREASE ADDRESS INTO SPECIAL 13680000 * MESSAGE LINE BY LENGTH OF DATA 13690000 * JUST MOVED IN * 13700000 BCT @8,@DO9F1 0122 13710000 @DO9F0 LH @F,526(0,@B) 0123 13720000 A @F,INDEX1 0123 13730000 ST @F,INDEX1 0123 13740000 * 13750000 * /************************************************************* 13760000 * /* * 13770000 * /* MOVE IN ELLIPSES * 13780000 * /* * 13790000 * /************************************************************* 13800000 * 13810000 * DO INDEX=3 TO 1 BY -1; /* MOVE IN ELLIPSES * 13820000 LA @8,3 0124 13830000 * MSGA (INDEX) = '.'; /* MOVE IN ELLIPSES - 3 PERIOD * 13840000 @DO9ED LR @7,@8 0125 13850000 BCTR @7,0 0125 13860000 L @9,INDEX1 0125 13870000 LA @A,0(@7,@9) 0125 13880000 MVI 0(@A),C'.' 0125 13890000 * END; /* END MOVE * 13900000 * INDEX1 = INDEX1+3; /* INCREMENT MSGA ADDRESS PASSED 13910000 * THE '...' * 13920000 BCT @8,@DO9ED 0126 13930000 LA @F,3 0127 13940000 A @F,INDEX1 0127 13950000 ST @F,INDEX1 0127 13960000 * 13970000 * /************************************************************* 13980000 * /* * 13990000 * /* MOVE IN VARIABLE LENGTH DATA INTO SPECIAL MESSAGE AREA * 14000000 * /* * 14010000 * /************************************************************* 14020000 * 14030000 * DO INDEX=XINPUTB TO 1 BY -1; /* MOVE IN INVALID DATA * 14040000 LR @8,@5 0128 14050000 LTR @8,@8 0128 14060000 BC 12,@DO9E8 0128 14070000 * MSGA (INDEX) = INVDATA(INDEX); /* MOVE IN VARIABLE LENGTH 14080000 * INVALID DATA * 14090000 @DO9E9 LR @7,@8 0129 14100000 BCTR @7,0 0129 14110000 L @9,236(0,@B) 0129 14120000 LA @E,0(@7,@9) 0129 14130000 L @9,INDEX1 0129 14140000 LA @A,0(@7,@9) 0129 14150000 MVC 0(1,@A),0(@E) 0129 14160000 * END; /* END VARIABLE LENGTH MOVE * 14170000 * 14180000 * /************************************************************* 14190000 * /* * 14200000 * /* DETERMINE IF A RIGHT PARENTHESIS MUST BE INCLUDED * 14210000 * /* * 14220000 * /************************************************************* 14230000 * 14240000 * IF RHTPAREN = '1'B THEN 14250000 BCT @8,@DO9E9 0130 14260000 @DO9E8 TM 536(@B),B'00100000' 0131 14270000 BC 12,@9E5 0131 14280000 * MSGAREA1 (MSGLEN+XINPUTB+5) = ')'; /* MOVE IN RIGHT 14290000 * PARENTHESIS * 14300000 LR @7,@5 0132 14310000 AH @7,526(0,@B) 0132 14320000 BCTR @7,0 0132 14330000 L @9,584(0,@B) 0132 14340000 LA @A,5(@7,@9) 0132 14350000 MVI 0(@A),C')' 0132 14360000 BC 15,@9E4 0133 14370000 * ELSE 14380000 * MSGAREA1 (MSGLEN+XINPUTB+5) = ' '; 14390000 @9E5 LR @7,@5 0133 14400000 AH @7,526(0,@B) 0133 14410000 BCTR @7,0 0133 14420000 L @9,584(0,@B) 0133 14430000 LA @A,5(@7,@9) 0133 14440000 MVI 0(@A),C' ' 0133 14450000 * INVPSAVE = SUBRWORK(1); /* POINT INVPSAVE TO NEW BUFFER 14460000 * SO IKJPARS WILL PICK UP 14470000 * SPECIAL MESSAGE JUST BUILT * 14480000 @9E4 MVC 236(4,@B),96(@B) 0134 14490000 * PPOINTR = SUBRWORK(1); /* SET PPOINTR = TO CORE ADDRESS 14500000 * IN CASE GOING TO WRITE OUT 14510000 * CLOSING PAREN ASSUMED MSAGE * 14520000 MVC 84(4,@B),96(@B) 0135 14530000 * XINPUTB = SUBRWORK(1) + MSGLEN + /* POINT XINPUTB TO END FOR * 14540000 * XINPUTB + 5; /* SAME REASON - SO LENGTH WILL 14550000 * BE FOR SPECIAL MESSAGE * 14560000 LA @F,5 0136 14570000 AR @F,@5 0136 14580000 AH @F,526(0,@B) 0136 14590000 A @F,96(0,@B) 0136 14600000 LR @5,@F 0136 14610000 * END; 14620000 * R15 = 4; /* LOAD SUBROUTINE ADDRESS FOR 14630000 * WRITING INVALID MESSAGE * 14640000 @9F4 LA @F,4 0138 14650000 * CALL LINKRET; /* CALL INTERFACE ROUTINE * 14660000 BAL @E,LINKRET 0139 14670000 * IF SPECMSG = '1'B THEN /* WAS A SPECIAL MESSAGE * 14680000 TM 536(@B),B'10000000' 0140 14690000 BC 12,@9E3 0140 14700000 * DO; /* WRITTEN * 14710000 * RESPECIFY 14720000 * R1 RESTRICTED; /* IF SO, MUST FREE CORE - NEED 14730000 * REG1 * 14740000 * 14750000 * /************************************************************* 14760000 * /* * 14770000 * /* ISSUE FREEMAIN FOR CORE IN WHICH BUILT SPECIAL MESSAGE * 14780000 * /* * 14790000 * /************************************************************* 14800000 * 14810000 * 14820000 * FREE: 14830000 * GENERATE; 14840000 FREE EQU * 0143 14850000 USING PWORK,PWAREG ADDRESSABILITY TO PWORK 14860000 L R1,COREADDR RESTORE ADDRESS OF CORE 14870000 LH R0,CORELEN LOAD LENGTH INTO R0 14880000 DROP PWAREG FREE BASE REG FOR WORKAREA 14890000 FREEMAIN R,LV=(0),A=(1) FREE THE CORE 14900000 DS 0H 14910000 * RESPECIFY 14920000 * R1 UNRESTRICTED; /* RELEASE REGISTER 1 * 14930000 * END; 14940000 * LFTPAREN = '0'B; /* TURN SPECIAL MESSAGE AND * 14950000 @9E3 NI 536(@B),B'00011111' 0146 14960000 * RHTPAREN = '0'B; /* FORMAT INDICATORS * 14970000 * SPECMSG = '0'B; /* OFF * 14980000 * R14 = PLINKSV2; /* RESTORE RETURN REGISTER * 14990000 L @E,608(0,@B) 0149 15000000 * RETURN; /* MACRO PROCESSORS AND RETURN * 15010000 * END MSGSETUP; /* END MSGSET UP PROCEDURE * 15020000 @EL03 BCR 15,@E 0151 15030000 * 15040000 * /***************************************************************** 15050000 * /* * 15060000 * /* IKJOPER MACRO PROCESSING * 15070000 * /* * 15080000 * /***************************************************************** 15090000 * 15100000 * 15110000 * IKJEFP50: /* ENTRY POINT * 15120000 * PROC OPTIONS(NOSAVEAREA, /* NO STANDARD LINKAGE * 15130000 * DONTSAVE); /* NO STANDARD LINKAGE * 15140000 IKJEFP50 EQU * 0152 15150000 * 15160000 * /***************************************************************** 15170000 * /* * 15180000 * /* REGISTER DECLARES AND RESTRICTIONS * 15190000 * /* * 15200000 * /***************************************************************** 15210000 * 15220000 * DCL 15230000 * R4 REG(4) PTR(31); /* REGISTER 4 * 15240000 * DCL 15250000 * R5 REG(5) PTR(31); /* REGISTER 5 * 15260000 * DCL 15270000 * R6 REG(6) PTR(31); /* REGISTER 6 * 15280000 * DCL 15290000 * R8 REG(8) PTR(31); /* REGISTER 8 * 15300000 * DCL 15310000 * R9 REG(9) PTR(31); /* REGISTER 9 * 15320000 * DCL 15330000 * R11 REG(11) PTR(31); /* REGISTER 11 * 15340000 * RESTRICT (R4,R5,R6); /* KEEP SCAN PTRS INTACT * 15350000 * RESTRICT (PWAREG); /* KEEP WORKAREA REFERENCE * 15360000 * RESTRICT (R8); /* COUNTER * 15370000 * 15380000 * /***************************************************************** 15390000 * /* * 15400000 * /* DATA VARIABLES * 15410000 * /* * 15420000 * /***************************************************************** 15430000 * 15440000 * DCL 15450000 * COMBUF CHAR(1) BASED(R4); /* CHARACTER IN THE COMMAND 15460000 * BUFFER POINTED TO BY XINPUT * 15470000 * DCL 15480000 * COMBUFBV CHAR(256) BASED(R5); /* CHARACTERS IN THE 15490000 * COMMAND BUFFER POINTED TO BY 15500000 * XINPUT * 15510000 * DCL 15520000 * COMBUFP CHAR(256) BASED(PPOINTR); /* CHARACTER IN THE 15530000 * COMMAND BUFFER POINTED TO BY 15540000 * PPOINTR * 15550000 * DCL 15560000 * COMBUFB CHAR(1) BASED (R5); /* CHARACTER IN THE 15570000 * COMMAND BUFFER POINTED TO BY 15580000 * XINPUTB * 15590000 * DCL 15600000 * BLNK STATIC INTERNAL CHAR(1) INIT(' '); /* BLANK * 15610000 * DCL 15620000 * P40PR LABEL LOCAL INTERNAL; /* RETURN AFTER PROMPTING * 15630000 * DCL 15640000 * P50PR LABEL LOCAL INTERNAL; /* RETURN AFTER PROMPTING * 15650000 * DCL 15660000 * IP LABEL LOCAL INTERNAL; /* OPER INVALID MSG SET UP * 15670000 * 15680000 * /***************************************************************** 15690000 * /* * 15700000 * /* THE SAME PDE MAP IS USED TO REFERENCE ALL FOUR TYPES OF * 15710000 * /* IKJTERM PDE'S -CONSTANT,STATEMENT NUMBER,VARIBLE, AND PDE'S * 15720000 * /* FOR DATA NAME QUALIFIERS. * 15730000 * /* * 15740000 * /***************************************************************** 15750000 * 15760000 * DCL 15770000 * 1 PDEMPT BASED(PDEPTR), /* MAP OF PDE * 15780000 * 2 DNAMEPTR PTR(31), /* PTR TO DATA NAME * 15790000 * 3 LNGTH1 PTR(8), /* LENGTH OF DIGITS OR PGM.ID * 15800000 * 3 LNGTH2 PTR(8), /* LENGTH OF EXPONENT OR LINE# * 15810000 * 3 LNGTH3 PTR(8), /* LENGTH OF VERB NO. * 15820000 * 3 RESVA CHAR(1), /* RESERVE BYTE * 15830000 * 2 RESWDNUM PTR(15), /* NUMBER OF RESERVE WORDS * 15840000 * 3 LNGTH4 PTR(8), /* LENGTH OF DATA NAME * 15850000 * 3 RESV2 CHAR(1), /* RESERVE BYTE * 15860000 * 2 FLAG1 BIT(8), /* TYPE INDICATOR * 15870000 * 3 PARMIND BIT(1), /* PARAMETER PRESENT * 15880000 * 3 CONST BIT(1), /* TYPE EQUAL CONSTANT * 15890000 * 3 VARIA BIT(1), /* TYPE EQUAL VARIABLE * 15900000 * 3 STATE BIT(1), /* TYPE EQUAL STATEMENT NO. * 15910000 * 3 FIXED BIT(1), /* FIXED PTR. NUMERIC LITERAL * 15920000 * 3 NONNUM BIT(1), /* NON-NUMERIC LITERAL * 15930000 * 3 FIGUR BIT(1), /* FIGURATIVE CONSTANT * 15940000 * 3 FLOAT BIT(1), /* FLOATING PT.NUMERIC LITERAL * 15950000 * 2 FLAG2 BIT(8), /* SIGN INDICATOR * 15960000 * 3 SIGN BIT(1), /* SIGN IS PLUS OR MINUS * 15970000 * 3 EXPSIGN BIT(1), /* SIGN ON EXPONENT IS (+)OR(-) * 15980000 * 3 DECPT BIT(1), /* DECIMAL PTR INDICATOR * 15990000 * 3 RESV3 BIT(5), /* RESERVE BITS * 16000000 * 2 DATAPTRH PTR(32), /* SPACE FOR LAST INDICATOR * 16010000 * 3 DATAPTR PTR(31), /* PTR TO STRING OF DIGITS OR PTR 16020000 * TO PGM.ID OR PTR TO PDE FOR 16030000 * NXT QUALIFIER * 16040000 * 2 DATAPTRA PTR(31), /* PTR TO EXPONENT OR PTR TO LINE 16050000 * NUMBER OR PTR TO PGM.ID NAME * 16060000 * 2 DATAPTRB PTR(31), /* PTR TO PERIOD OR PTR TO VERB 16070000 * NUMBER * 16080000 * 3 LNGTH5 PTR(8), /* LENGTH OF PGM.ID (VAR PDE) * 16090000 * 3 NUMQUAL CHAR(1), /* NUMBER OF QUALIFIERS-VAR PDE * 16100000 * 3 NUMSUB CHAR(1), /* NUMBER OF SUBCRIPTS-VAR PDE * 16110000 * 3 RESV4 CHAR(1); /* RESERVE BYTE (VAR PDE) * 16120000 * 16130000 * /***************************************************************** 16140000 * /* * 16150000 * /* IKJTERM PCE MAPPING * 16160000 * /* * 16170000 * /***************************************************************** 16180000 * 16190000 * DCL 16200000 * 1 PCEMPT BASED(R6), /* MAP OF PCE * 16210000 * 2 PCEFLG1 BIT(16), /* MESSAGE INDICATOR * 16220000 * 3 TERPCE BIT(3), /* IKJTERM PCE * 16230000 * 3 PROMPT BIT(1), /* PROMPT SPECIFIED * 16240000 * 3 DEFAULT BIT(1), /* DEFAULT SPECIFIED * 16250000 * 3 RESERV1 BIT(1), /* RESERVE BIT * 16260000 * 3 HELP BIT(1), /* HELP MESSAGE PROVIDED * 16270000 * 3 VALCHK BIT(1), /* VALIDITY CHECK EXIT * 16280000 * 3 LIST BIT(1), /* LIST SPECIFIED * 16290000 * 3 ASIS BIT(1), /* ASIS SPECIFIED * 16300000 * 3 RANG BIT(1), /* RANGE SPECIFIED * 16310000 * 3 SUBSCRP BIT(1), /* TERM MAY BE SUBSCRIPTED * 16320000 * 3 RESVCHA BIT(1), /* RESERVE WORD PCE CHAINED * 16330000 * 3 RESERV2 BIT(3), /* RESERVE BIT * 16340000 * 2 PCELNGTH CHAR(2), /* HEX LENGTH OF THIS PCE * 16350000 * 2 PDEOFST CHAR(2), /* OFFSET IN PDL FOR PDE * 16360000 * 2 PCEFLG2 BIT(8), /* PCE TYPE OPERAND * 16370000 * 3 STMT BIT(1), /* TYPE EQUAL STATEMENT * 16380000 * 3 VAR BIT(1), /* TYPE EQUAL VARIBLE * 16390000 * 3 CNST BIT(1), /* TYPE EQUAL CONSTANT * 16400000 * 3 ANY BIT(1), /* TYPE EQUAL ANY * 16410000 * 3 SUBSCPPT BIT(1), /* TERM DESCRIBING A SUBSCRIPT * 16420000 * 3 RESERV3 BIT(3), /* RESERVE BITS * 16430000 * 2 TPTSL PTR(15) BDY(BYTE); /* LENGTH OF THE PARAMETER 16440000 * TYPE SEGMENT * 16450000 * 16460000 * /***************************************************************** 16470000 * /* * 16480000 * /* MAP THE SECOND FIXED FIELD IN THE IKJTERM PCE * 16490000 * /* * 16500000 * /***************************************************************** 16510000 * 16520000 * DCL 16530000 * TPODL BIT(8) BASED(R6); /* LENGTH OF PROMPT DEFAULT 16540000 * SEGMENT IN TERM PCE * 16550000 * 16560000 * /***************************************************************** 16570000 * /* * 16580000 * /* MAP THE THIRD FIXED FIELD IN THE IKJTERM PCE * 16590000 * /* * 16600000 * /***************************************************************** 16610000 * 16620000 * DCL 16630000 * RSVWDIDX FIXED(15) BASED(R6) /* OFFSET TO CHAINED * 16640000 * BDY(BYTE); /* RSVWD FROM TOP OF PDL * 16650000 * 16660000 * /***************************************************************** 16670000 * /* * 16680000 * /* IKJNAME PCE MAPPING * 16690000 * /* * 16700000 * /***************************************************************** 16710000 * 16720000 * DCL 16730000 * 1 NPCE1 BASED(R6) BDY(BYTE), /* IKJNAME PCE * 16740000 * 2 NPCE BIT(16), /* MASK AND FLAG DATA AREA * 16750000 * 3 NPCEMASK BIT(3), /* MASK INDICATING TYPE PCE * 16760000 * 3 * BIT(13), /* NOT REFERENCED * 16770000 * 2 NPCELNTH FIXED(15), /* LENGTH OF PCE * 16780000 * 2 NAMELM1 PTR(8), /* LENGTH OF NAME DATA -1 * 16790000 * 2 NAMEDATA CHAR(256); /* FIRST CHAR OF NAME * 16800000 * 16810000 * /***************************************************************** 16820000 * /* * 16830000 * /* IKJRSVWD PCE MAPPING * 16840000 * /* * 16850000 * /***************************************************************** 16860000 * 16870000 * DCL 16880000 * 1 RPCEFLD BASED(R6)BDY(BYTE), /* MAP RSVWD PCE * 16890000 * 2 RPCEBYT1 BIT (16), /* FIRST BYTE OF INDICATORS * 16900000 * 3 RSVWMASK BIT(3), /* INDICATES PCE TYPE * 16910000 * 3 RPRMTI BIT(1), /* PROMPT DATA SUPPLIED * 16920000 * 3 RDFLTI BIT(1), /* DEFAULT DATA SUPPLIED * 16930000 * 3 * BIT(3), /* NOT REFERENCED * 16940000 * 3 RFCONST BIT(1), /* FIGURATIVE CONSTANT IF ON * 16950000 * 3 * BIT(7), /* NOT REFERENCED * 16960000 * 2 RPCELNTH FIXED(15), /* RSVWD PCE LENGTH * 16970000 * 2 RPDEINDX FIXED(15); /* OFFSET TO RSVWD PDE FROM START 16980000 * OF PDL * 16990000 * 17000000 * /***************************************************************** 17010000 * /* * 17020000 * /* SAVE AREA FOR SPECIAL MESSAGE DATA --- THIS INFORMATION IS * 17030000 * /* USED TO PROMPT FOR AN EXPRESSION * 17040000 * /* * 17050000 * /***************************************************************** 17060000 * 17070000 * DCL 17080000 * 1 OPERSPM AUTOMATIC, /* MSGAREA SAVE * 17090000 * 2 OPERSPM1 FIXED(15), /* SAVE TERM1 WORD1 LENGTH * 17100000 * 2 OPERSPM2 FIXED(31); /* SAVE ADDR TERM1 WORD1 * 17110000 * 17120000 * /***************************************************************** 17130000 * /* * 17140000 * /* IKJOPER PDE AND IKJRSVWD PDE MAPPING * 17150000 * /* * 17160000 * /***************************************************************** 17170000 * 17180000 * DCL 17190000 * 1 ORPDE BASED(ADDR(TEMPPDE)) BDY(BYTE), /* MAP OPER & RSVWD 17200000 * PDE * 17210000 * 2 * CHAR(2), 17220000 * 2 RNAMENUM FIXED (15), /* IKJNAME NUMBER * 17230000 * 2 * CHAR(2), 17240000 * 2 ORPDEFLG BIT(8), /* FLAG DATA * 17250000 * 3 ORFND BIT(1), /* INDICATES THAT THE DATA 17260000 * DESCRIBED BY THE PCE WAS FOUND* 17270000 * 3 ORPDERD2 BIT(7), /* RESERVED FLAG AREA * 17280000 * 2 ORPDERD3 CHAR(1); /* RESERVED DATA AREA * 17290000 * 17300000 * /***************************************************************** 17310000 * /* * 17320000 * /* INITIATE IKJOPER MACRO PROCESSING * 17330000 * /* * 17340000 * /***************************************************************** 17350000 * 17360000 * COBOLMOD = '1'B; /* INDICATE THAT A COBOL SCAN IS 17370000 * IN PROGRESS * 17380000 OI 535(@B),B'11000000' 0178 17390000 * OPERMODE = '1'B; /* INDICATE THAT A SCAN OF AN 17400000 * EXPRESSION IS IN PROGRESS * 17410000 * OPERPRMT = '0'B; /* TURN OFF INDICATOR FOR 17420000 * EXPRESSION PROMPT RETURN 17430000 * PROCESSING * 17440000 NI 535(@B),B'11111101' 0180 17450000 * OANC = AANC; /* SAVE PTR TO TERM QUALIFIER PDE 17460000 * CORE ON ENTRY - THE PTR WILL 17470000 * BE RESET TO THIS VALUE IF THE 17480000 * ENTIRE EXPRESSION IS FOUND TO 17490000 * BE INVALID * 17500000 MVC 512(4,@B),504(@B) 0181 17510000 * OPERPCE = R6; /* SAVE PTR TO IKJOPER PCE * 17520000 ST @6,468(0,@B) 0182 17530000 * RESPECIFY 17540000 * (R7, 17550000 * R9) RESTRICTED; /* KEEP TEMP WORKAREA * 17560000 * OPCEPTR = R6 + OPCEPTL + 6; /* ESTABLISH ADDRESSABILITY FOR 17570000 * THE OPCEFLD2 DSECT THAT MAPS 17580000 * THE SECOND FIXED DATA AREA IN 17590000 * THE OPER PCE * 17600000 LA @F,6 0184 17610000 L @1,468(0,@B) 0184 17620000 MVC @TEMP2+2(2),6(@1) 0184 17630000 LH @0,@TEMP2+2 0184 17640000 AR @F,@0 0184 17650000 AR @F,@6 0184 17660000 ST @F,OPCEPTR 0184 17670000 * R7 = PTABLEAD; /* SET UP PTR TO TOP OF PCL * 17680000 L @7,260(0,@B) 0185 17690000 * R9 = R6; /* SAVE PCE PTR FOR 'OTERMCK' * 17700000 LR @9,@6 0186 17710000 * R6 = R7 + T1PCEIDX; /* PLACE TERM1 PCE ADDR INXPCE * 17720000 LR @1,@F 0187 17730000 MVC @TEMP2+2(2),2(@1) 0187 17740000 LH @6,@TEMP2+2 0187 17750000 AR @6,@7 0187 17760000 * CALL TERMOCK; /* TERMINATE THE SCAN IF THE 17770000 * FORMAT OF THE MINOR TERM PCE 17780000 * IS INCORRECT * 17790000 L @F,@V1 ADDRESS OF TERMOCK 0188 17800000 BALR @E,@F 0188 17810000 * R6 = R7 + RPCEINDX; /* PLACE RSVWD PCE ADR IN XPCE * 17820000 L @1,OPCEPTR 0189 17830000 MVC @TEMP2+2(2),0(@1) 0189 17840000 LH @6,@TEMP2+2 0189 17850000 AR @6,@7 0189 17860000 * 17870000 * /***************************************************************** 17880000 * /* * 17890000 * /* IF THE MINOR RSVWD PCE ADDRESS DOES NOT REFERENCE A RSVWD PCE * 17900000 * /* THE SCAN IS TERMINATED * 17910000 * /* * 17920000 * /***************************************************************** 17930000 * 17940000 * IF RSVWMASK ª= '101'B /* COMPARE THE RSVWD PCE TYPE * 17950000 * THEN 17960000 TM 0(@6),B'10100000' 0190 17970000 BC 12,@9E2 0189 17980000 TM 0(@6),B'01000000' 0190 17990000 BC 08,@9E1 0190 18000000 * GOTO RTNCLNUP; /* MASK TO THE PCE * 18010000 BC 15,RTNCLNUP 0191 18020000 * 18030000 * /***************************************************************** 18040000 * /* * 18050000 * /* IF THE FIGURATIVE CONSTANT INDICATOR BIT IS ON IN THE RSVWD * 18060000 * /* PCE DESCRIBING AN OPERATOR THE SCAN IS TERMINATED * 18070000 * /* * 18080000 * /***************************************************************** 18090000 * 18100000 * THEN 18110000 @9E1 TM 1(@6),B'10000000' 0192 18120000 * GOTO RTNCLNUP; /* BIT IS ON GOTO 'CLEANUP' * 18130000 BC 01,RTNCLNUP 0193 18140000 * 18150000 * /***************************************************************** 18160000 * /* * 18170000 * /* THE RSVWD PCE ADDRESS MUST BE GREATER THAN THE FIRST OPERAND * 18180000 * /* ADDRESS. THE FIRST OPERAND ADDRESS IS PLACED IN PRIOPPCE BY * 18190000 * /* TERMOCK. * 18200000 * /* * 18210000 * /***************************************************************** 18220000 * 18230000 * IF R6 ª> R9 /* IF XPCE NOT GREATER * 18240000 * THEN 18250000 CR @6,@9 0194 18260000 * GOTO RTNCLNUP; /* GOTO CLEANUP * 18270000 BC 12,RTNCLNUP 0195 18280000 * R9 = R6; /* PRIORPCE = ADDR RSVWD PCE * 18290000 LR @9,@6 0196 18300000 * R6 = R7 + T2PCEIDX; /* PLACE TERM2 PCE ADR IN XPCE * 18310000 L @1,OPCEPTR 0197 18320000 MVC @TEMP2+2(2),4(@1) 0197 18330000 LH @6,@TEMP2+2 0197 18340000 AR @6,@7 0197 18350000 * CALL TERMOCK; /* TERMINATE THE SCAN IF THE 18360000 * FORMAT OF THE MINOR TERM PCE 18370000 * IS INCORRECT * 18380000 L @F,@V1 ADDRESS OF TERMOCK 0198 18390000 BALR @E,@F 0198 18400000 * 18410000 * /***************************************************************** 18420000 * /* * 18430000 * /* IF THERE IS A THIRD TERM PCE, TEST IT WITH TERMOCK * 18440000 * /* * 18450000 * /***************************************************************** 18460000 * 18470000 * IF T3PCEIDX ª= 0 /* IF THE TERM3 ADDRESS * 18480000 * THEN /* IN THE OPER PCE IS NOT * 18490000 SR @F,@F 0199 18500000 L @1,OPCEPTR 0199 18510000 MVC @TEMP2+2(2),6(@1) 0199 18520000 LH @0,@TEMP2+2 0199 18530000 CR @F,@0 0199 18540000 BC 08,@9E0 0199 18550000 * DO; /* SET TO ZEROS, * 18560000 * /* THERE IS AN OPTIONAL THIRD * 18570000 * /* TERM UNDER THE OPER PCE * 18580000 * R6 = R7 + T3PCEIDX; /* XPCE = TERM3 PCE ADDR * 18590000 MVC @TEMP2+2(2),6(@1) 0201 18600000 LH @6,@TEMP2+2 0201 18610000 AR @6,@7 0201 18620000 * CALL TERMOCK; /* TEST MINOR TERM PCE * 18630000 L @F,@V1 ADDRESS OF TERMOCK 0202 18640000 BALR @E,@F 0202 18650000 * END; 18660000 * RESPECIFY 18670000 * (R8) RESTRICTED; /* RESTRICT TERMPORARY INDEX * 18680000 * 18690000 * /***************************************************************** 18700000 * /* * 18710000 * /* CALCULATE THE LENGTH OF THE LAST MINOR TERM PDE * 18720000 * /* * 18730000 * /***************************************************************** 18740000 * 18750000 * IF SUBSCRP = '1'B /* IF PCE IS SUBSCRIPTABLE * 18760000 * THEN /* THEN SET I EQUAL TO * 18770000 @9E0 TM 1(@6),B'00010000' 0205 18780000 BC 12,@9DF 0205 18790000 * DO; /* THE LENGTH OF A * 18800000 * R8 = 80; /* SUBSCRIPT PDE * 18810000 LA @8,80 0207 18820000 * R9 = R9 + PCELNGTH; /* UPDATE TO NEXT PCE * 18830000 MVC @TEMP2+2(2),2(@6) 0208 18840000 A @9,@TEMP2 0208 18850000 * 18860000 * /************************************************************* 18870000 * /* * 18880000 * /* THE PCE FOLLOWING A SUBSCRIPTABLE TERM MUST BE A TERM * 18890000 * /* PCE. * 18900000 * /* * 18910000 * /************************************************************* 18920000 * 18930000 * IF R9 -> TERPCE ª= '110'B THEN /* IS THE * 18940000 TM 0(@9),B'11000000' 0209 18950000 BC 12,@9DE 0208 18960000 TM 0(@9),B'00100000' 0209 18970000 BC 08,@9DD 0209 18980000 * GOTO RTNCLNUP; /* PCE A TERM PCE * 18990000 BC 15,RTNCLNUP 0210 19000000 * 19010000 * /************************************************************* 19020000 * /* * 19030000 * /* THE SUBSCRIPT TERM MUST HAVE THE SUBSCRIPT OPTION CODED * 19040000 * /* * 19050000 * /************************************************************* 19060000 * 19070000 * IF R9 -> SUBSCPPT = '0'B THEN /* ISSUE RETURN CODE 19080000 @9DD TM 6(@9),B'00001000' 0211 19090000 * GOTO RTNCLNUP; /* AND TERMINATE SCAN IF 0 * 19100000 BC 08,RTNCLNUP 0212 19110000 BC 15,@9DC 0214 19120000 * END; 19130000 * ELSE 19140000 * R8 = 20; /* SET I EQUAL LENGTH NON- 19150000 * SUBSCRIPT PCE * 19160000 @9DF LA @8,20 0214 19170000 * RESPECIFY 19180000 * (R7) UNRESTRICTED; /* FREE TEMP PTRS * 19190000 @9DC EQU * 0215 19200000 * 19210000 * /***************************************************************** 19220000 * /* * 19230000 * /* CALCULATE THE LENGTH OF THE PDE STRUCTURE UNDER THE IKJOPER * 19240000 * /* PCE * 19250000 * /* * 19260000 * /***************************************************************** 19270000 * 19280000 * RESPECIFY 19290000 * (R7) RESTRICTED; /* SET UP NEW TEMP AREA * 19300000 * R7 = PDEOFST + XPDL + R8; /* PLACE END ADDR OF LAST TERM 19310000 * PDE IN ENDTPDE * 19320000 LR @7,@8 0217 19330000 A @7,104(0,@B) 0217 19340000 MVC @TEMP2+2(2),4(@6) 0217 19350000 A @7,@TEMP2 0217 19360000 * OPERLL = R7 -(XPDL + OPDEINDX); /* PLACE THE PDE STRUCTURE 19370000 * LENGTH IN OPERLL * 19380000 L @1,468(0,@B) 0218 19390000 MVC @TEMP2+2(2),4(@1) 0218 19400000 LH @F,@TEMP2+2 0218 19410000 A @F,104(0,@B) 0218 19420000 LCR @F,@F 0218 19430000 AR @F,@7 0218 19440000 STH @F,524(0,@B) 0218 19450000 * OPEREND = R9; /* SAVE THE ADDR OF LAST MINOR 19460000 * TERM PCE * 19470000 ST @9,456(0,@B) 0219 19480000 * RESPECIFY 19490000 * (R7, 19500000 * R9) UNRESTRICTED; /* RELEASE PTRS * 19510000 * R15 = 5; /* PLACE THE ADDRESS OF THE * 19520000 LA @F,5 0221 19530000 * /* SKIPB ROUTINE IN LINKB * 19540000 * 19550000 * /***************************************************************** 19560000 * /* * 19570000 * /* SKIP OVER ANY SEPARATOR IN THE INPUT LINE VIA SKIPB RTN * 19580000 * /* * 19590000 * /***************************************************************** 19600000 * 19610000 * CALL LINKRET; /* PASS CONTROL TO SKIPB * 19620000 BAL @E,LINKRET 0222 19630000 * GOTO D1; /* SKIPB RETURN +0 - END OF * 19640000 BC 15,D1 0223 19650000 * /* INPUT ENCOUNTERED -- * 19660000 * /* PROMPT FOR MISSING VIA * 19670000 * /* 'PROMPTQ' ROUTINE * 19680000 * 19690000 * PR: 19700000 * 19710000 * /***************************************************************** 19720000 * /* * 19730000 * /* RECEIVE CONTROL AFTER DATA IS RETURNED FROM THE PROMPT FOR AN * 19740000 * /* EXPRESSION * 19750000 * /* * 19760000 * /***************************************************************** 19770000 * 19780000 * OPERSVE = R5; /* SKIPB RETURN +4 - * 19790000 PR ST @5,472(0,@B) 0224 19800000 * /* SAVE PTR TO START OF DATA * 19810000 * 19820000 * /***************************************************************** 19830000 * /* * 19840000 * /* IF A LEFT PAREN IS NOT THE FIRST CHARACTER POINTED TO BY * 19850000 * /* XINPUT, PROCESS THE ENTRY AS A CHAINED TERM * 19860000 * /* * 19870000 * /***************************************************************** 19880000 * 19890000 * IF COMBUFB ª= '(' /* IF THE CHARACTER POINTED * 19900000 * THEN /* TO BY XINPUTB IS NOT A * 19910000 CLI 0(@5),C'(' 0225 19920000 BC 08,@9DB 0225 19930000 * DO; /* LEFT PARENTHESIS... * 19940000 * IF COMBUFB = ';' THEN /* IF XINPUTB POINTS TO A * 19950000 CLI 0(@5),C';' 0227 19960000 * GOTO I1; /* SEMICOLON, THE EXPRESSION * 19970000 BC 08,I1 0228 19980000 * /* IS MISSING * 19990000 * GOTO OPTTERM; /* ELSE, PROCESS CHAINED TERM * 20000000 BC 15,OPTTERM 0229 20010000 * END; 20020000 * 20030000 * /***************************************************************** 20040000 * /* * 20050000 * /* THIS SECTION OF CODE CONTROLS THE SCAN OF THE INDIVIDUAL * 20060000 * /* ELEMENTS OF AN EXPRESSION * 20070000 * /* * 20080000 * /***************************************************************** 20090000 * 20100000 * R4 = R4 + 1; /* UP THE INPUT LINE PTR BY 1 * 20110000 @9DB AH @4,@D2 0231 20120000 * CHAINTRM = '0'B; /* TURN OF CHAINED TERM SWITCH * 20130000 NI 536(@B),B'11101111' 0232 20140000 * R6 = T1PCEIDX + PTABLEAD; /* PLACE THE ADDRESS OF THE TERM1 20150000 * PCE IN XPCE * 20160000 L @6,260(0,@B) 0233 20170000 L @1,OPCEPTR 0233 20180000 MVC @TEMP2+2(2),2(@1) 0233 20190000 LH @0,@TEMP2+2 0233 20200000 AR @6,@0 0233 20210000 * CALL IKJEFP60; /* CALL THE TERM SCAN ROUTINE * 20220000 L @F,@V2 ADDRESS OF IKJEFP60 0234 20230000 BALR @E,@F 0234 20240000 * GOTO F1; /* ON +O RETURN PROMPT WITH 20250000 * INVALID EXPRESSION MSG * 20260000 BC 15,F1 0235 20270000 * OPERSPM1 = MSGLEN; /* ON +4 RETURN SAVE THE TERM1 * 20280000 MVC OPERSPM(2),526(@B) 0236 20290000 * OPERSPM2 = MSGADDR; /* SPECIAL MSG DATA * 20300000 MVC OPERSPM+4(4),528(@B) 0237 20310000 * PFNOPOP='0'B; /* ALLOW BUFFER POP M0000 * 20320000 NI 115(@B),B'11111101' 0238 20330000 * R6 = RPCEINDX + PTABLEAD; /* XPCE = ADDR RSVWD PCE * 20340000 L @6,260(0,@B) 0239 20350000 L @1,OPCEPTR 0239 20360000 MVC @TEMP2+2(2),0(@1) 0239 20370000 LH @0,@TEMP2+2 0239 20380000 AR @6,@0 0239 20390000 * CALL IKJEFP40; /* CALL THE RSVWD SCAN RTN * 20400000 L @F,@V3 ADDRESS OF IKJEFP40 0240 20410000 BALR @E,@F 0240 20420000 * GOTO OSPMSG; /* ON +0 RETURN PROMPT WITH 20430000 * INVALID EXPRESSION MSG * 20440000 BC 15,OSPMSG 0241 20450000 * R6 = T2PCEIDX + PTABLEAD; /* ON +4 RETURN PLACE THE ADDR OF 20460000 * THE TERM2 PCE IN XPCE * 20470000 L @6,260(0,@B) 0242 20480000 L @1,OPCEPTR 0242 20490000 MVC @TEMP2+2(2),4(@1) 0242 20500000 LH @0,@TEMP2+2 0242 20510000 AR @6,@0 0242 20520000 * PFNOPOP = '0'B; /* ALLOW BUFFER TO BE POPED * 20530000 NI 115(@B),B'11111101' 0243 20540000 * R15 = 5; /* SKIP TO NEXT BUFFER IF AT THE 20550000 * END OF A BUFFER * 20560000 LA @F,5 0244 20570000 * CALL LINKRET; /* GOTO PARS2 * 20580000 BAL @E,LINKRET 0245 20590000 * GEN (NOP 0); /* GOTO IKJEFP60 ON +0 & +4 * 20600000 NOP 0 20610000 DS 0H 20620000 * CALL IKJEFP60; /* CALL THE TERM SCAN ROUTINE * 20630000 L @F,@V2 ADDRESS OF IKJEFP60 0247 20640000 BALR @E,@F 0247 20650000 * GOTO OSPMSG; /* ON +0 RETURN PROMPT WITH 20660000 * INVALID EXPRESSION MSG * 20670000 BC 15,OSPMSG 0248 20680000 * IF PFENDSET ='1'B /* PFENDSET IS ON IF TERM * 20690000 * THEN /* POPPED TO LOWER BUFFER * 20700000 TM 115(@B),B'00000100' 0249 20710000 BC 12,@9DA 0249 20720000 * DO; /* IF SO , SET OPERSVE = * 20730000 * OPERSVE = ENDBAKUP; /* END OF BUFFER POPPED OFF * 20740000 MVC 472(4,@B),348(@B) 0251 20750000 * GOTO SK; /* GO TO SKIP BLANKS M4161 * 20760000 BC 15,SK 0252 20770000 * END; /* ROUTINE M4161 * 20780000 * IF PFNOPOP = '1'B /* PFENDSET NOT, ON CHECK M4161 * 20790000 * THEN /* PFNOPOP. IF ON, M4161 * 20800000 @9DA TM 115(@B),B'00000010' 0254 20810000 BC 12,@9D9 0254 20820000 * DO; /* SUBSCRIPT WAS PROCESSED M4161 * 20830000 * OPERSVE=R4; /* SET BAKUP POINTER TO R4 M4161 * 20840000 ST @4,472(0,@B) 0256 20850000 * PFNOPOP='0'B; /* RESET PFNOPOP, SO WILL M4161 20860000 * POP TO LOWER BUFFERS M4161 * 20870000 NI 115(@B),B'11111101' 0257 20880000 BC 15,@9D8 0259 20890000 * END; /* END, PFNOPOP PROCESS M4161 * 20900000 * ELSE 20910000 * OPERSVE = R4 +1; /* THAT DID NOT CONTAIN PART * 20920000 @9D9 LA @F,1 0259 20930000 AR @F,@4 0259 20940000 ST @F,472(0,@B) 0259 20950000 * /* OF A VARIABLE * 20960000 * SK: R15 = 5; /* LOAD ADDR SKIPB SUBROUTINE * 20970000 @9D8 EQU * 0260 20980000 SK LA @F,5 0260 20990000 * CALL LINKRET; /* GOTO SKIPB TO SKIP OVER 21000000 * SEPARATORS BEFORE RHT PAREN * 21010000 BAL @E,LINKRET 0261 21020000 * GOTO A; /* ON +0 RETURN -E0F- GOTO A * 21030000 BC 15,A 0262 21040000 * 21050000 * /***************************************************************** 21060000 * /* * 21070000 * /* TEST FOR A CLOSING RIGHT PARENTHESIS * 21080000 * /* * 21090000 * /***************************************************************** 21100000 * 21110000 * IF COMBUFB ª= ')' THEN /* ISSUE CLOSING PAREN ASSUMED * 21120000 CLI 0(@5),C')' 0263 21130000 * GOTO A; /* MESSAGE IF NO RIGHT PAREN * 21140000 BC 07,A 0264 21150000 * INVPSAVE = PRMTPTR; /* SAVE PTR TO THE LAST WORD OF 21160000 * OPERAND2 FOR VALIDITY CHECK 21170000 * FAILURE PROMPTING * 21180000 MVC 236(4,@B),520(@B) 0265 21190000 * R4 = R5; /* UPDATE XINPUT TO THE RIGHT 21200000 * PAREN * 21210000 LR @4,@5 0266 21220000 * GOTO B; /* PREPARE TO ADD PDE * 21230000 BC 15,B 0267 21240000 * 21250000 * /***************************************************************** 21260000 * /* * 21270000 * /* THE OPTTERM SECTION OF CODE RECEIVES CONTROL WHEN THE DATA * 21280000 * /* REFERENCED BY THE INPUT LINE POINTER, XINPUT, DOES NOT START * 21290000 * /* WITH A RIGHT PARENTHESIS ON ENTRY, OR AFTER A PROMPT REPLY * 21300000 * /* * 21310000 * /***************************************************************** 21320000 * 21330000 * 21340000 * OPTTERM: /* CHAINED TERM PROCESSING * 21350000 * 21360000 * /***************************************************************** 21370000 * /* * 21380000 * /* DETERMINE IF THE CHAIN OPTION IS CODED ON THE OPER MACRO * 21390000 * /* * 21400000 * /***************************************************************** 21410000 * 21420000 * IF T3PCEIDX = 0 /* IF THE INDEX TO THE CHAINED * 21430000 * THEN /* TERM PCE IS ZERO THEN THE * 21440000 OPTTERM SR @F,@F 0268 21450000 L @1,OPCEPTR 0268 21460000 MVC @TEMP2+2(2),6(@1) 0268 21470000 LH @0,@TEMP2+2 0268 21480000 CR @F,@0 0268 21490000 * DO; /* DATA IN THE INPUT LINE * 21500000 * GOTO I1; /* MUST BE IN PARENTHESIS * 21510000 BC 08,I1 0270 21520000 * END; /* BEFORE IT CAN BE PROCESSED * 21530000 * /* UNDER AN OPER PCE * 21540000 * R6 = PTABLEAD + T3PCEIDX; /* PLACE THE ADDRESS OF THE 21550000 * CHAINED TERM PCE IN XPCE * 21560000 @9D7 L @1,OPCEPTR 0272 21570000 MVC @TEMP2+2(2),6(@1) 0272 21580000 LH @6,@TEMP2+2 0272 21590000 A @6,260(0,@B) 0272 21600000 * CHAINTRM = '1'B; /* TURN ON CHAINED TERM 21610000 * PROCESSING INDICATOR BIT * 21620000 OI 536(@B),B'00010000' 0273 21630000 * CALL IKJEFP60; /* SCAN THE INPUT LINE * 21640000 L @F,@V2 ADDRESS OF IKJEFP60 0274 21650000 BALR @E,@F 0274 21660000 * 21670000 * /***************************************************************** 21680000 * /* * 21690000 * /* RETURN ON +0 IF THE TERM PROCESSOR DID NOT SCAN A VALID TERM -* 21700000 * /* RETURN ON +4 IF A VALID TERM WAS FOUND * 21710000 * /* * 21720000 * /***************************************************************** 21730000 * 21740000 * GEN; 21750000 BC 15,D1 /* TERM +0 RETURN */ 21760000 BC 15,B /* TERM +4 RETURN */ 21770000 DS 0H 21780000 * 21790000 * /***************************************************************** 21800000 * /* * 21810000 * /* THIS SECTION OF CODE RECEIVES CONTROL WHEN THE FIRST CHARACTER* 21820000 * /* OF DATA IS INVALID. * 21830000 * /* * 21840000 * /***************************************************************** 21850000 * 21860000 * 21870000 * I1: 21880000 * IF OPERPRMT = '1'B /* IF THE DATA WAS RETURNED * 21890000 * THEN /* IN THE PROMPT FOR AN * 21900000 I1 TM 535(@B),B'00000010' 0276 21910000 BC 12,@9D6 0276 21920000 * DO; /* EXPRESSION, THE FIRST 21930000 * CHARACTER IS ALWAYS INVALID * 21940000 * INVPSAVE = OPERSVE; /* POINT INVPSAVE TO THE START OF 21950000 * THE INPUT LINE * 21960000 MVC 236(4,@B),472(@B) 0278 21970000 * R4 = R5; /* INCREMENT TO FIRST CHARACTER * 21980000 LR @4,@5 0279 21990000 * R8 = 'FFFF'X; /* NO-OP THE PAREN COUNTER 22000000 * FOR THE END OF DATA SCAN * 22010000 L @8,@X11 0280 22020000 * GOTO A1I; /* GO TO THE SECTION OF CODE 22030000 * WHICH SCANS TO THE END OF THE * 22040000 BC 15,A1I 0281 22050000 * END; /* INVALID DATA --- 22060000 * BEGIN SCAN AFTER FIRST CHAR * 22070000 * 22080000 * D1: 22090000 * R6 = OPERPCE; /* WHEN OPERPRMT IS SET TO ZERO, 22100000 * POINT XPCE AT THE OPER PCE * 22110000 @9D6 EQU * 0283 22120000 D1 L @6,468(0,@B) 0283 22130000 * R15 = 2; /* LOAD THE ADDRESS OF THE 22140000 * PROMPTQ ROUTINE * 22150000 LA @F,2 0284 22160000 * CALL LINKRET; /* PASS CONTROL TO PROMPTQ * 22170000 BAL @E,LINKRET 0285 22180000 * GEN; /* GENERATE PROMPTQ RETURNS * 22190000 BC 15,P50PR /* TEST FOR NEW DATA, +0 RTN */ 22200000 BC 15,EP /* EXIT IF NO NEW DATA, +4 RTN*/ 22210000 DS 0H 22220000 * 22230000 * /***************************************************************** 22240000 * /* * 22250000 * /* BUILD THE PARAMETERS NEEDED BY THE 'MSGSETUP' ROUTINE FOR * 22260000 * /* CONSTRUCTION OF THE SPECIAL MESSAGE. * 22270000 * /* * 22280000 * /***************************************************************** 22290000 * 22300000 * 22310000 * OVCERR: /* HANDLE VALIDITY CHECK ERRORS * 22320000 * RHTPAREN = '1'B; /* TURN ON INDICATOR TO ADD RIGHT 22330000 * PAREN TO PROMPT MSG * 22340000 OVCERR OI 536(@B),B'11100000' 0287 22350000 * LFTPAREN = '1'B; /* ADD LEFT PAREN TO MSG * 22360000 * SPECMSG = '1'B; /* INDICATE MESSAGE TYPE * 22370000 * MSGLEN = OPERSPM1; /* INDICATE TERM1 WORD1 LENGTH * 22380000 MVC 526(2,@B),OPERSPM 0290 22390000 * MSGADDR = OPERSPM2; /* INDICATE TERM1 WORD1 ADDR * 22400000 MVC 528(4,@B),OPERSPM+4 0291 22410000 * R4 = R4 +1; /* INCREMENT PAST RIGHT PAREN * 22420000 AH @4,@D2 0292 22430000 * GOTO WWW; /* SET UP FOR PROMPT * 22440000 BC 15,WWW 0293 22450000 * 22460000 * /***************************************************************** 22470000 * /* * 22480000 * /* SET UP SPECIAL MESSAGE WHEN MISSING OPERAND1 * 22490000 * /* * 22500000 * /***************************************************************** 22510000 * 22520000 * 22530000 * F1: 22540000 * MSGADDR = OPERSVE; /* SET UP PTR TO LEFT PAREN * 22550000 F1 MVC 528(4,@B),472(@B) 0294 22560000 * MSGLEN = 1; /* LEFT PAREN 1 CHAR LONG * 22570000 LA @F,1 0295 22580000 STH @F,526(0,@B) 0295 22590000 * GOTO F2; /* FINISH SET UP OF SPM MSG * 22600000 BC 15,F2 0296 22610000 * 22620000 * OSPMSG: /* SET UP SPECIAL MESSAGE WHEN 22630000 * MISSING RSVWD OR OPERAND2 * 22640000 * LFTPAREN = '1'B; /* INSERT LEFT PAREN BEFORE 22650000 * MSGAREA DATA * 22660000 OSPMSG OI 536(@B),B'01000000' 0297 22670000 * MSGLEN = OPERSPM1; /* MOVE PTRS TO FIRST ELEMENT * 22680000 MVC 526(2,@B),OPERSPM 0298 22690000 * MSGADDR = OPERSPM2; /* OF THE EXPRESSION INTO 22700000 * 'MSGSETUP' COMMUNICATION AREA * 22710000 MVC 528(4,@B),OPERSPM+4 0299 22720000 * 22730000 * F2: 22740000 * SPECMSG = '1'B; /* INDICATE THAT A SPECIAL 22750000 * MESSAGE FORMAT IS BEING USED * 22760000 F2 OI 536(@B),B'10000000' 0300 22770000 * R15 = 5; /* SKIP OVER SEPARATORS * 22780000 LA @F,5 0301 22790000 * CALL LINKRET; /* GOTO PARS1 * 22800000 BAL @E,LINKRET 0302 22810000 * GEN (BC 15,T); /* GOTO T ON END OF INPUT * 22820000 BC 15,T 22830000 DS 0H 22840000 * INVPSAVE = R5; /* SET INVPSAVE = TO START OF 22850000 * INVALID DATA ON +4 RTN * 22860000 ST @5,236(0,@B) 0304 22870000 * R4 = R5; /* SET XINPUT TO FIRST CHAR * 22880000 LR @4,@5 0305 22890000 * R8 = 1; /* INITIALIZE PAREN COUNTER TO 22900000 * ONE ----- SCAN PICKS UP AFTER 22910000 * THE LEFT PAREN * 22920000 LA @8,1 0306 22930000 * 22940000 * /***************************************************************** 22950000 * /* * 22960000 * /* SCAN FOR CLOSING PAREN WHEN AN EXPRESSION IS INVALID * 22970000 * /* * 22980000 * /* THE SCAN LOOP IS EXITED UNDER ONE OF THREE CIRCUMSTANCES: * 22990000 * /* (1) THE SCAN FINDS BALANCED LEFT & RIGHT PARENTHESIS * 23000000 * /* (2) THE SCAN REACHES END OF INPUT * 23010000 * /* (3) A SEMICOLON IS ENCOUNTERED IN THE ORIGINAL INPUT BUFFER * 23020000 * /* * 23030000 * /***************************************************************** 23040000 * 23050000 * 23060000 * R: /* TEST THE CHARACTER POINTED TO 23070000 * BY XINPUT FOR A RIGHT PAREN * 23080000 * IF COMBUF = ')' /* IF THE CHARACTER IN THE * 23090000 * THEN /* COMMAND BUFFER IS A * 23100000 R CLI 0(@4),C')' 0307 23110000 BC 07,@9D5 0307 23120000 * DO; /* RIGHT PAREN THEN * 23130000 * R8 = R8 - 1; /* SUBTRACT ONE FROM THE PAREN 23140000 * COUNT * 23150000 BCTR @8,0 0309 23160000 * 23170000 * /************************************************************* 23180000 * /* * 23190000 * /* TEST THE PAREN COUNT FOR ZERO * 23200000 * /* * 23210000 * /************************************************************* 23220000 * 23230000 * IF R8 > 0 THEN /* A COUNT GREATER THAN ZERO * 23240000 LTR @8,@8 0310 23250000 * DO; /* MEANS THE RIGHT PAREN DOES * 23260000 * GOTO A1I; /* NOT BALANCE THE OPENING * 23270000 BC 03,A1I 0312 23280000 * END; /* LEFT PAREN - REPEAT LOOP * 23290000 * R4 = R4 + 1; /* UP THE INPUT PTR PAST * 23300000 @9D4 AH @4,@D2 0314 23310000 * GOTO WW; /* THE RIGHT PAREN & SET UP * 23320000 BC 15,WW 0315 23330000 * END; /* REMAINING PARAMETERS * 23340000 * 23350000 * /***************************************************************** 23360000 * /* * 23370000 * /* TEST FOR LEFT PARENTHESIS * 23380000 * /* * 23390000 * /***************************************************************** 23400000 * 23410000 * IF COMBUF = '(' /* IF XINPUT POINTS * 23420000 * THEN 23430000 @9D5 CLI 0(@4),C'(' 0317 23440000 BC 07,@9D3 0317 23450000 * R8 = R8 + 1; /* TO A LEFT PAREN ADD 1 TO THE 23460000 * PAREN COUNT * 23470000 AH @8,@D2 0318 23480000 * 23490000 * /***************************************************************** 23500000 * /* * 23510000 * /* IF IN THE ORIGINAL INPUT BUFFER, TREAT A SEMICOLON AS THOUGH * 23520000 * /* IT WERE END OF INPUT * 23530000 * /* * 23540000 * /***************************************************************** 23550000 * 23560000 * IF COMBUF = ';' /* IF A SEMICOLON IS * 23570000 * THEN /* FOUND IN THE * 23580000 @9D3 CLI 0(@4),C';' 0319 23590000 BC 07,@9D2 0319 23600000 * DO; /* INPUT BUFFER, END THE SCAN * 23610000 * 23620000 * /************************************************************* 23630000 * /* * 23640000 * /* TEST FOR A ZERO LENGTH INVALID DATA SEGMENT * 23650000 * /* * 23660000 * /************************************************************* 23670000 * 23680000 * IF INVPSAVE - R4 = 0 23690000 * THEN 23700000 LCR @F,@4 0321 23710000 A @F,236(0,@B) 0321 23720000 CH @F,@D3 0321 23730000 * GOTO T; /* GOTO 'T' IF SEMCOL FIRST CHAR * 23740000 BC 08,T 0322 23750000 * GOTO WW; /* TERMINATE INVALID DATA SCAN * 23760000 BC 15,WW 0323 23770000 * END; 23780000 * 23790000 * A1I: 23800000 * R4 = R4 + 1; /* ADD ONE TO THE INPUT PTR * 23810000 @9D2 EQU * 0325 23820000 A1I AH @4,@D2 0325 23830000 * IF R4 ª< ENDINPUT THEN /* TERMINATE SCAN IF AT * 23840000 C @4,80(0,@B) 0326 23850000 * GOTO WW; /* ENDINPUT, ELSE... * 23860000 BC 10,WW 0327 23870000 * GOTO R; /* CONTINUE THE PAREN SCAN * 23880000 BC 15,R 0328 23890000 * 23900000 * T: /* SET UP ZERO LENGTH INVALID 23910000 * DATA MESSAGE SEGMENT * 23920000 * BLNKFLAG = '1'B; /* SIGNAL MSGSETUP THAT XINPUTB * 23930000 T OI 537(@B),B'00100000' 0329 23940000 * /* IS OUT OF BUFFER ON PURPOSE * 23950000 * INVPSAVE = ADDR(BLNK); /* FOR THE INVALID DATA PORTION * 23960000 LA @F,BLNK 0330 23970000 ST @F,236(0,@B) 0330 23980000 * R5 = ADDR(BLNK) +1; /* OF THE MESSAGE - SET UP THE * 23990000 LA @5,BLNK+1 0331 24000000 * GOTO W; /* REMAING PARAMETERS FOR THE * 24010000 BC 15,W 0332 24020000 * /* MSGSETUP RTN AT W * 24030000 * 24040000 * /***************************************************************** 24050000 * /* * 24060000 * /* PROMPT WITH THE INVALID DATA * 24070000 * /* * 24080000 * /***************************************************************** 24090000 * 24100000 * 24110000 * WW: 24120000 * R5 = R4; /* SET UP XINPUTB TO POINT AT * 24130000 WW LR @5,@4 0333 24140000 * /* THE END OF THE INVALID DATA * 24150000 * 24160000 * W: 24170000 * R6 = OPERPCE; /* RESTORE THE PCE PTR TO THE 24180000 * IKJOPER PCE * 24190000 W L @6,468(0,@B) 0334 24200000 * 24210000 * WWW: 24220000 * PPCOUNT = 7; /* SET PPCOUNT TO THE LENGTH OF 24230000 * THE OPER PDE -1 * 24240000 WWW MVI 353(@B),7 0335 24250000 * CBLNKSV2 = ADDR(P50PR); /* PLACE THE RETURN ADDRESS IN 24260000 * CBLNKSV2 * 24270000 LA @F,P50PR 0336 24280000 ST @F,488(0,@B) 0336 24290000 * CALL MSGSETUP; /* GOTO MSGSETUP TO FORMAT THE 24300000 * SPECIAL MESSAGE PROMPT - 24310000 * RETURN AFTER THE USER REPLIES 24320000 * TO A PROMPT * 24330000 BAL @E,MSGSETUP 0337 24340000 * 24350000 * /***************************************************************** 24360000 * /* * 24370000 * /* RECEIVE CONTROL AFTER A PROMPT FOR AN EXPRESSION * 24380000 * /* * 24390000 * /***************************************************************** 24400000 * 24410000 * 24420000 * P50PR: /* RETURN FROM PROMPT * 24430000 * 24440000 * /***************************************************************** 24450000 * /* * 24460000 * /* PFNULL IS OFF IF DATA WAS RETURNED FROM THE PROMPT * 24470000 * /* * 24480000 * /***************************************************************** 24490000 * 24500000 * IF PFNULL = '1'B THEN /* GOTO EXIT PROCESSING IF * 24510000 P50PR TM 114(@B),B'00001000' 0338 24520000 BC 12,@9D1 0338 24530000 * DO; /* THERE IS * 24540000 * PFNULL = '0'B; /* NO PROMPT DATA RETURNED - * 24550000 NI 114(@B),B'11110111' 0340 24560000 * GOTO EP; /* ELSE - * 24570000 BC 15,EP 0341 24580000 * END; 24590000 * OPERPRMT = '1'B; /* ------ GOTO PROCESS THE * 24600000 @9D1 OI 535(@B),B'00000010' 0343 24610000 * GOTO PR; /* PROMPT RETURN * 24620000 BC 15,PR 0344 24630000 * 24640000 * A: 24650000 * CBLNKSV1 = ADDR(B); /* PLACE RETURN ADDRESS IN 24660000 * CBLNKSV1 * 24670000 A LA @F,B 0345 24680000 ST @F,484(0,@B) 0345 24690000 * PPOINTR = PRMTPTR+1; /* SET UP PTR TO LAST WORD OF THE 24700000 * SECOND OPERAND * 24710000 LA @F,1 0346 24720000 A @F,520(0,@B) 0346 24730000 ST @F,84(0,@B) 0346 24740000 * R5 = OPERSVE; /* SET PTR TO END OF LAST WORD * 24750000 L @5,472(0,@B) 0347 24760000 * R15 = 10; /* LOAD ADDR PSTRIMSG ROUTINE * 24770000 LA @F,10 0348 24780000 * CALL LINKRET; /* GIVE CONTROL TO PSTRIMSG RTN 24790000 * TO WRITE OUT THE CLOSING PAREN 24800000 * ASSUMED MESSAGE * 24810000 BAL @E,LINKRET 0349 24820000 * 24830000 * B: /* FILL IN OPER TEMPORARY PDE * 24840000 * ORFND = '1'B; /* TURN ON BIT IN THE TEMP PDE TO 24850000 * INDICATE THAT THE DATA 24860000 * DESCRIBED UNDER THE OPER PCE 24870000 * WAS FOUND * 24880000 B OI 274(@B),B'10000000' 0350 24890000 * R6 = OPERPCE; /* RESTORE XPCE TO OPER PCE * 24900000 L @6,468(0,@B) 0351 24910000 * CHAINTRM = '0'B; /* BIT INDICATING CHAIN TERM 24920000 * PROCESSING MUST BE ZERO BEFORE 24930000 * THE END OF OPER PROCESSING * 24940000 NI 536(@B),B'11101111' 0352 24950000 * RESPECIFY 24960000 * (R1)RESTRICTED; /* RESTRICT PTRS FOR USE BY 24970000 * SUBROUTINE 'POSITXCB' * 24980000 * R1 = 7; /* PLACE LENGTH OF PDE -1 IN 24990000 * COMMUNICATION REG FOR POSITXCB 25000000 * RTN * 25010000 LA @1,7 0354 25020000 * PLINKSV2 = ADDR(OVCERR); /* OVCERR WILL RECEIVE CONTROL IF 25030000 * THE VALIDITY CHECK ROUTINE 25040000 * REJECTS THE EXPRESSION * 25050000 LA @F,OVCERR 0355 25060000 ST @F,608(0,@B) 0355 25070000 * R15 = 3; /* PLACE PTR TO SUBROUTINE 25080000 * POSITXCB IN LINKAGE REG * 25090000 LA @F,3 0356 25100000 * CALL LINKRET; /* PASS CONTROL TO POSITXCB * 25110000 BAL @E,LINKRET 0357 25120000 * RESPECIFY 25130000 * (R1) UNRESTRICTED; /* PTR NO LONGER REQUIRED * 25140000 * 25150000 * /***************************************************************** 25160000 * /* * 25170000 * /* THE FOLLOWING SECTION PERFORMS NORMAL EXIT PROCESSING * 25180000 * /* * 25190000 * /***************************************************************** 25200000 * 25210000 * 25220000 * EP: /* SET PTRS FOR NORMAL EXIT * 25230000 * R6 = OPEREND; /* PLACE THE ADDRESS OF THE LAST 25240000 * MINOR TERM PCE IN XPCE * 25250000 EP L @6,456(0,@B) 0359 25260000 * OPERMODE = '0'B; /* TURN OFF OPER MODE INDICATOR * 25270000 NI 535(@B),B'10111111' 0360 25280000 * GOTO RTNNSKP3; /* UPDATE TO NEXT PCE * 25290000 BC 15,RTNNSKP3 0361 25300000 * 25310000 * /***************************************************************** 25320000 * /* * 25330000 * /* INITIATE IKJRSVWD MACRO PROCESSING * 25340000 * /* * 25350000 * /***************************************************************** 25360000 * 25370000 * 25380000 * IKJEFP40: /* ENTRY POINT RSVWD PROCESSOR * 25390000 * PROC OPTIONS(NOSAVEAREA, /* IKJEFP40 * 25400000 * DONTSAVE); /* NO STANDARD LINKAGE * 25410000 @EL04 BCR 15,@E 0362 25420000 * RESPECIFY 25430000 * (R6, 25440000 * R4, 25450000 * R8, 25460000 * R5) RESTRICTED; /* SAVE PTRS * 25470000 * RESPECIFY 25480000 * (PWAREG, 25490000 * R1) RESTRICTED; /* SAVE PTRS * 25500000 * RSVDRTN = R14; /* SAVE RETURN ADDR * 25510000 IKJEFP40 ST @E,RSVDRTN 0365 25520000 * RSVWDSV2 = R6; /* SAVE PCE POINTER * 25530000 ST @6,480(0,@B) 0366 25540000 * RSVDPRMT = '0'B; /* ZERO RSVD PROMPT BIT * 25550000 NI 535(@B),B'11111011' 0367 25560000 * 25570000 * /***************************************************************** 25580000 * /* * 25590000 * /* IF XPCE POINTS TO A TERM PCE CALCULATE THE RSVWD PCE ADR * 25600000 * /* * 25610000 * /***************************************************************** 25620000 * 25630000 * IF TERPCE = '110'B THEN /* IF XPCE POINTS TO A TERM * 25640000 TM 0(@6),B'11000000' 0368 25650000 BC 12,@9D0 0367 25660000 TM 0(@6),B'00100000' 0368 25670000 BC 05,@9CF 0368 25680000 * GOTO RCT; /* PCE ON ENTRY, * 25690000 BC 15,RCT 0369 25700000 * /* GOTO RCT AND UPDATE THE PCE 25710000 * PTR TO THE CHAINED IKJRSVWD 25720000 * PCE * 25730000 * 25740000 * /***************************************************************** 25750000 * /* * 25760000 * /* CALL CLEANUP IF XPCE DOES NOT POINT TO A RSVWD PCE OR A TERM * 25770000 * /* PCE * 25780000 * /* * 25790000 * /***************************************************************** 25800000 * 25810000 * IF RSVWMASK ª= '101'B THEN /* IF XPCE DOES NOT POINT TO * 25820000 @9CF EQU * 0370 25830000 @9D0 TM 0(@6),B'10100000' 0370 25840000 BC 12,@9CE 0369 25850000 TM 0(@6),B'01000000' 0370 25860000 BC 08,@9CD 0370 25870000 * GOTO RTNCLNUP; /* A RSVD PCE OR A TERM PCE ON 25880000 * ENTRY, TERMINATE SCAN. GOTO 25890000 * CLEANUP WITH THE RETURN CODE 25900000 * IN RETCODE. * 25910000 BC 15,RTNCLNUP 0371 25920000 * 25930000 * /***************************************************************** 25940000 * /* * 25950000 * /* SKIP OVER RSVWD PCE, IF IT DESCRIBES A FIGURATIVE CONSTANT * 25960000 * /* * 25970000 * 25980000 * IF RFCONST = '1'B THEN /* IF THE RFCONST BIT IS ON, * 25990000 @9CD TM 1(@6),B'10000000' 0372 26000000 * GOTO RTNNSKP3; /* UPDATE THE PCE POINTR * 26010000 BC 01,RTNNSKP3 0373 26020000 * /* TO THE NEXT PCE. ROUTINE * 26030000 * /* NAMESKP3 PERFORMS * 26040000 * /* THIS FUNCTION AND THEN GIVES * 26050000 * /* CONTROL TO THE APPROPRIATE * 26060000 * /* PCE PROCESSOR. * 26070000 * COBOLMOD = '1'B; /* INDICATE COBOL MODE * 26080000 OI 535(@B),B'10000000' 0374 26090000 * GOTO EE; /* INITIATE SCAN OF RSVWD * 26100000 BC 15,EE 0375 26110000 * 26120000 * RCT: 26130000 * R6 = ADDR(RSVWDSV2 -> TPTSL) /* UPDATE XPCE PAST THE TERM * 26140000 * + RSVWDSV2 -> TPTSL; /* PCE'S FIRST VARIABLE LENGTH 26150000 * FIELD TO BASE DSECT * 26160000 RCT L @7,480(0,@B) 0376 26170000 MVC @TEMP2+2(2),7(@7) 0376 26180000 LH @F,@TEMP2+2 0376 26190000 LA @0,7(0,@7) 0376 26200000 AR @F,@0 0376 26210000 LR @6,@F 0376 26220000 * IF RSVWDSV2 -> PROMPT = '1'B /* IF PROMPT DATA PRESENT * 26230000 * ³ /* OR * 26240000 * RSVWDSV2 -> DEFAULT = '1'B /* IF DEFAULT DATA PRESENT * 26250000 * THEN /* THEN * 26260000 TM 0(@7),B'00010000' 0377 26270000 BC 01,@9CC 0377 26280000 TM 0(@7),B'00001000' 0377 26290000 BC 12,@9CB 0377 26300000 * R8 = ADDR(TPODL) + TPODL + 2; /* SET UP DSECT BASE FOR NEXT 26310000 * FIELD IN TERM PCE * 26320000 @9CC LA @F,2 0378 26330000 SR @0,@0 0378 26340000 IC @0,0(0,@6) 0378 26350000 AR @F,@0 0378 26360000 AR @F,@6 0378 26370000 LR @8,@F 0378 26380000 BC 15,@9CA 0379 26390000 * ELSE /* ELSE * 26400000 * R8 = R6; /* XPCE IS ALREADY POSITIONED * 26410000 @9CB LR @8,@6 0379 26420000 * IF RSVWDSV2 -> SUBSCRP = '1'B /* IF SUBSCRPTS ALLOWED * 26430000 * THEN /* THEN * 26440000 @9CA L @7,480(0,@B) 0380 26450000 TM 1(@7),B'00010000' 0380 26460000 BC 12,@9C9 0380 26470000 * R8 = R8 + 2; /* INCREMENT PAST SUBSC. OFFSET * 26480000 AH @8,@D4 0381 26490000 * R6 = PTABLEAD + R8 -> RSVWDIDX; /* XPCE = RSVWD PCE ADDR * 26500000 @9C9 MVC @TEMP2+2(2),0(@8) 0382 26510000 LH @F,@TEMP2+2 0382 26520000 A @F,260(0,@B) 0382 26530000 LR @6,@F 0382 26540000 * 26550000 * /***************************************************************** 26560000 * /* * 26570000 * /* CALL CLEANUP IF THE CHAINED PCE IS NOT A RSVWD PCE * 26580000 * /* * 26590000 * /***************************************************************** 26600000 * 26610000 * IF RSVWMASK ª= '101'B THEN /* RETURN CODE IN RETCODE * 26620000 TM 0(@6),B'10100000' 0383 26630000 BC 12,@9C8 0382 26640000 TM 0(@6),B'01000000' 0383 26650000 BC 08,@9C7 0383 26660000 * GOTO RTNCLNUP; /* IS RETURNED TO THE CP IF NO 26670000 * CHAINED RSVWD PCE * 26680000 BC 15,RTNCLNUP 0384 26690000 * 26700000 * /***************************************************************** 26710000 * /* * 26720000 * /* CALL CLEANUP IF THE CHAINED RSVWD PCE DOES NOT HAVE THE * 26730000 * /* FIGURATIME CONSTANT INDICATOR BIT ON * 26740000 * /* * 26750000 * /***************************************************************** 26760000 * IF RFCONST = '0'B THEN /* TERMINATE SCAN IF NOT AN * 26770000 @9C7 TM 1(@6),B'10000000' 0385 26780000 * GOTO RTNCLNUP; /* RFCONST RSVWD PCE * 26790000 BC 08,RTNCLNUP 0386 26800000 * RSVWDSV1 = R4; /* SAVE POINTER TO START OF DATA * 26810000 ST @4,476(0,@B) 0387 26820000 * EE: 26830000 * RSVWDPCE = R6; /* SAVE RSVWD PCE ADDRESS * 26840000 EE ST @6,460(0,@B) 0388 26850000 * R15 = 5; /* PLACE THE ADDRESS OF THE SKIPB 26860000 * ROUTINE IN LINKB * 26870000 LA @F,5 0389 26880000 * CALL LINKRET; /* GOTO SKIPB ROUTINE * 26890000 BAL @E,LINKRET 0390 26900000 * GOTO A1; /* ON +0 RETURN - PROMPT * 26910000 BC 15,A1 0391 26920000 * /* ON +4 RETURN INITIATE SCAN * 26930000 * RESPECIFY 26940000 * (R8, 26950000 * R1) RESTRICTED; /* SET UP TEMP AREAS * 26960000 * 26970000 * E: 26980000 * R8 = 0; /* ZERO LENGTH COUNTER * 26990000 E SR @8,@8 0393 27000000 * RSVWDSV1 = R4; /* SAVE PTR TO START OF DATA * 27010000 ST @4,476(0,@B) 0394 27020000 * R1 = '08'X; /* SET UP TYPE TEST MASK FOR 27030000 * SEPARATOR CHARACTERS * 27040000 LA @1,X'08' 0395 27050000 * 27060000 * /***************************************************************** 27070000 * /* * 27080000 * /* INITIATE SCAN FOR RSVWD LENGTH * 27090000 * /* * 27100000 * /***************************************************************** 27110000 * 27120000 * 27130000 * SL: 27140000 * R4 = R4 + 1; /* INCREMENT INPUT POINTER * 27150000 SL AH @4,@D2 0396 27160000 * 27170000 * /***************************************************************** 27180000 * /* * 27190000 * /* EXIT LOOP IF END OF INPUT IS REACHED * 27200000 * /* * 27210000 * /***************************************************************** 27220000 * 27230000 * IF R4 ª< ENDINPUT THEN /* IF THE END OF INPUT IS * 27240000 C @4,80(0,@B) 0397 27250000 * GOTO F; /* REACHED, I EQUALS RSVWD LENGTH* 27260000 BC 10,F 0398 27270000 * R15 = 8; /* PLACE ADDR OF TYPETEST ROUTINE 27280000 * IN LINKB * 27290000 LA @F,8 0399 27300000 * 27310000 * /***************************************************************** 27320000 * /* * 27330000 * /* EXIT THE LOOP IF XINPUT POINTS TO A BLANK, COMMA OR TAB * 27340000 * /* * 27350000 * /***************************************************************** 27360000 * 27370000 * CALL LINKRET; /* CALL TYPETEST ROUTINE * 27380000 BAL @E,LINKRET 0400 27390000 * GEN; /* GENERATE TYPETEST RETURNS * 27400000 BC 15,RPTEST /* +0 RETURN - CONTINUE SCAN */ 27410000 BC 15,OMODCK /* +4 RETURN - EXIT LOOP */ 27420000 DS 0H 27430000 * 27440000 * /***************************************************************** 27450000 * /* * 27460000 * /* TERMINATE SCAN IF A RIGHT PAREN IS FOUND WHEN NOT ALLOWED * 27470000 * /* * 27480000 * /***************************************************************** 27490000 * 27500000 * 27510000 * RPTEST: 27520000 * IF COMBUF = ')' /* A RIGHT PAREN TERMINATES * 27530000 * THEN 27540000 RPTEST CLI 0(@4),C')' 0402 27550000 BC 07,@9C6 0402 27560000 * DO; /* THE RSVWD SCAN * 27570000 * IF OPERMODE = '1'B THEN /* WHEN PROCESSING EITHER * 27580000 TM 535(@B),B'01000000' 0404 27590000 * GOTO OMODCK2; /* AN EXPRESSION, * 27600000 BC 01,OMODCK2 0405 27610000 * IF SUBSMODE = '1'B ³ /* OR A FIGURATIVE * 27620000 * PFLIST = '1'B THEN /* CONST WITHIN * 27630000 TM 535(@B),B'00100000' 0406 27640000 BC 01,@9C5 0406 27650000 TM 112(@B),B'10000000' 0406 27660000 BC 12,@9C4 0406 27670000 * GOTO F; /* A LIST OR * 27680000 BC 03,F 0407 27690000 * END; /* SUBSCRIPT * 27700000 @9C4 EQU * 0408 27710000 * 27720000 * /***************************************************************** 27730000 * /* * 27740000 * /* WHEN PROCESSING A MEMBER OF A RANGE, A COLON DELIMITS * 27750000 * /* THE SCAN FOR A FIGURATIVE CONSTANT * 27760000 * /* * 27770000 * /***************************************************************** 27780000 * 27790000 * IF COMBUF = ':' & /* A RANGE CAN ONLY BE * 27800000 * RSVWDPCE -> RFCONST = '1'B & /* ENTERED UNDER A TERM PCE * 27810000 * RSVWDSV2 -> RANG = '1'B THEN /* THAT IS NOT UNDER AN * 27820000 @9C6 CLI 0(@4),C':' 0409 27830000 BC 07,@9C3 0409 27840000 L @7,460(0,@B) 0409 27850000 TM 1(@7),B'10000000' 0409 27860000 BC 12,@9C2 0409 27870000 L @9,480(0,@B) 0409 27880000 TM 1(@9),B'00100000' 0409 27890000 * GOTO F; /* OPER PCE * 27900000 BC 03,F 0410 27910000 * 27920000 * /***************************************************************** 27930000 * /* * 27940000 * /* TEST FOR A SEMICOLON * 27950000 * /* * 27960000 * /***************************************************************** 27970000 * 27980000 * IF COMBUF = ';' /* END THE SCAN IF A SEMICOLON * 27990000 * THEN 28000000 @9C1 EQU * 0411 28010000 @9C2 EQU * 0411 28020000 @9C3 EQU * 0411 28030000 CLI 0(@4),C';' 0411 28040000 BC 07,@9C0 0411 28050000 * DO; /* IS ENCOUNTERED IN THE * 28060000 * IF RSVDPRMT = '0'B THEN /* INITIAL INPUT BUFFER... * 28070000 TM 535(@B),B'00000100' 0413 28080000 * GOTO F; /* END THE SCAN IF A SEMICOLON * 28090000 BC 08,F 0414 28100000 * IF OPERMODE = '0'B & /* IS ENCOUNTERED IN A NON OPER * 28110000 * R8 ª= 0 THEN /* MODE PROMPT REPLY ON OTHER * 28120000 TM 535(@B),B'01000000' 0415 28130000 BC 05,@9BF 0415 28140000 LTR @8,@8 0415 28150000 * GOTO F2R; /* THE FIRST CHARACTER * 28160000 BC 07,F2R 0416 28170000 * END; 28180000 @9BE EQU * 0417 28190000 @9BF EQU * 0417 28200000 * 28210000 * AI1: 28220000 * R8 = R8 + 1; /* UP THE LENGTH COUNTER AND * 28230000 @9C0 EQU * 0418 28240000 AI1 AH @8,@D2 0418 28250000 * GOTO SL; /* RETURN TO THE ENTRY POINT * 28260000 BC 15,SL 0419 28270000 * 28280000 * /***************************************************************** 28290000 * /* * 28300000 * /* *************END OF LENGTH SCAN LOOP********************** * 28310000 * /* CHECK FOR ZERO LENGTH RSVWD * 28320000 * /* * 28330000 * /***************************************************************** 28340000 * 28350000 * 28360000 * F: 28370000 * IF R8 = 0 /* WAS THE FIRST CHAR OF * 28380000 * THEN /* THE RSVWD A * 28390000 F LTR @8,@8 0420 28400000 BC 07,@9BD 0420 28410000 * DO; /* DELIMITER * 28420000 * 28430000 * /************************************************************* 28440000 * /* * 28450000 * /* PROMPT FOR MISSING IF NOT RETURNED FROM RSVWD PROMPT * 28460000 * /* * 28470000 * /************************************************************* 28480000 * 28490000 * IF RSVDPRMT = '1'B /* DATA RETURNED IN A PROMPT * 28500000 * THEN /* FOR A RSVWD IS INVALID * 28510000 TM 535(@B),B'00000100' 0422 28520000 BC 12,@9BC 0422 28530000 * DO; /* UNLESS THERE IS A NAME MATCH * 28540000 * 28550000 * /********************************************************* 28560000 * /* * 28570000 * /* REJECT ENTIRE BUFFER IF RETURNED FROM PROMPT IN OPER * 28580000 * /* MODE * 28590000 * /* * 28600000 * /********************************************************* 28610000 * 28620000 * IF OPERMODE = '1'B THEN /* PROMPT WITH THE ENTIRE * 28630000 TM 535(@B),B'01000000' 0424 28640000 * GOTO IPA; /* BUFFER WHEN IN OPER MODE --- * 28650000 BC 01,IPA 0425 28660000 * GOTO A1I; /* ELSE, PROMPT WITH DATA UP TO * 28670000 BC 15,A1I 0426 28680000 * END; /* FIRST VALID DELIMITER, * 28690000 * /* WHEN NO MATCH CAN * 28700000 * /* BE FOUND * 28710000 * R4 = R4 -1; /* DECREMENT XINPUT FOR NEXT * 28720000 @9BC BCTR @4,0 0428 28730000 * GOTO A1; /* ROUTINES SKIPB CALL AND * 28740000 BC 15,A1 0429 28750000 * END; /* ASSUME RSVWD IS MISSING * 28760000 * 28770000 * /***************************************************************** 28780000 * /* * 28790000 * /* WAS THE MAXIMUM LENGTH EXCEEDED IN THE SCAN * 28800000 * /* * 28810000 * /***************************************************************** 28820000 * 28830000 * F2R: 28840000 * IF R8 > 256 THEN /* ASSUME NAME DOESN'T MATCH * 28850000 @9BD EQU * 0431 28860000 F2R CH @8,@D5 0431 28870000 * GOTO NOMATCH2; /* IF MAX LENGTH EXCEEDED * 28880000 BC 02,NOMATCH2 0432 28890000 * PLENGTH = R8; /* PLENGTH = RSVWD LENGTH * 28900000 STH @8,88(0,@B) 0433 28910000 * 28920000 * /***************************************************************** 28930000 * /* * 28940000 * /* DATA CAN'T BE TRANSLATED TO UPPER CASE IN THE COMMAND BUFFER * 28950000 * /* BEFORE AN IKJNAME MATCH IS FOUND * 28960000 * /* * 28970000 * /***************************************************************** 28980000 * 28990000 * R1 =R8; /* PASS NUMBER OF BYTES NEEDED IN 29000000 * R1 * 29010000 LR @1,@8 0434 29020000 * R15 = 14; /* LOAD ADR GETCORE ROUTINE * 29030000 LA @F,14 0435 29040000 * CALL LINKRET; /* OBTAIN WORK AREA FOR RSVWD'S * 29050000 BAL @E,LINKRET 0436 29060000 * /* TRANSLATION TO UPPER CASE * 29070000 * PPOINTR = R1; /* PLACE ADDR OF WORK AREA IN 29080000 * PPOINTR * 29090000 ST @1,84(0,@B) 0437 29100000 * R1 -> COMBUFP(1:R8) = COMBUFBV(1:R8);/* 29110000 * COPY RSVWD * 29120000 LR @E,@5 0438 29130000 LR @7,@8 0438 29140000 BCTR @7,0 0438 29150000 LR @A,@1 0438 29160000 EX @7,@MVC 0438 29170000 * 29180000 * RTQ: 29190000 * R15 = 9; /* PLACE ADDR TRANSQ ROUTINE * 29200000 RTQ LA @F,9 0439 29210000 * CALL LINKRET; /* IN LINKB AND CALL TRANSQ * 29220000 BAL @E,LINKRET 0440 29230000 * R5 = PPOINTR; /* POINT XINPUTB TO THE UPPER 29240000 * CASE COPY OF THE RSVWD * 29250000 L @5,84(0,@B) 0441 29260000 * PPOINTR = RSVWDSV1 + 1; /* RESTORE PPOINTR TO ADDR OF 29270000 * FIRST CHAR OF RSVWD * 29280000 LA @F,1 0442 29290000 A @F,476(0,@B) 0442 29300000 ST @F,84(0,@B) 0442 29310000 * R4 = R8 + PPOINTR; /* POINT XINPUT PAST THE RSVWD * 29320000 L @4,84(0,@B) 0443 29330000 AR @4,@8 0443 29340000 * RESPECIFY 29350000 * (R9) RESTRICTED; /* SAVE IKJNAME COUNTER * 29360000 * R9 = 0; /* SET COUNTER TO ZERO * 29370000 SR @9,@9 0445 29380000 * 29390000 * /***************************************************************** 29400000 * /* * 29410000 * /* THIS LOOP COMPARES THE RSVWD IN THE BUFFER TO THE NAMES IN THE* 29420000 * /* IKJNAME PCE'S * 29430000 * /* * 29440000 * /***************************************************************** 29450000 * 29460000 * 29470000 * NAMECK: 29480000 * R6 = R6 + NPCELNTH; /* UPDATE XPCE TO NEXT PCE * 29490000 NAMECK MVC @TEMP2+2(2),2(@6) 0446 29500000 AH @6,@TEMP2+2 0446 29510000 * R9 = R9 + 1; /* UPDATE IKJNAME # COUNTER * 29520000 AH @9,@D2 0447 29530000 * 29540000 * /***************************************************************** 29550000 * /* * 29560000 * /* EXIT WHEN ALL THE NAMES HAVE BEEN EXHAUSTED * 29570000 * /* * 29580000 * /***************************************************************** 29590000 * 29600000 * IF NPCEMASK ª= '011'B THEN /* GOTO NOMATCH WHEN XPCE NO * 29610000 TM 0(@6),B'01100000' 0448 29620000 BC 12,@9BB 0447 29630000 TM 0(@6),B'10000000' 0448 29640000 BC 08,@9BA 0448 29650000 * GOTO NOMATCH; /* LONGER POINTS TO A NAME PCE * 29660000 BC 07,NOMATCH 0449 29670000 * 29680000 * /***************************************************************** 29690000 * /* * 29700000 * /* REPEAT LOOP IF NAME AND RSVWD LENGTHS DO NOT MATCH * 29710000 * /* * 29720000 * /***************************************************************** 29730000 * 29740000 * IF R8 ª= NAMELM1 +1 THEN /* COMPARE RSVWD LENGTH TO * 29750000 @9BA LA @F,1 0450 29760000 SR @0,@0 0450 29770000 IC @0,4(0,@6) 0450 29780000 AR @F,@0 0450 29790000 CR @F,@8 0450 29800000 * GOTO NAMECK; /* NAME LENGTH * 29810000 BC 07,NAMECK 0451 29820000 * 29830000 * /***************************************************************** 29840000 * /* * 29850000 * /* REPEAT LOOP IF NAME AND UPPER CASE RSVWD DO NOT MATCH * 29860000 * /* * 29870000 * /***************************************************************** 29880000 * 29890000 * IF R5 -> COMBUFBV(1:R8) ª= NAMEDATA(1:R8) THEN /* COMPARE 29900000 * RSVWD TO * 29910000 LA @E,5(0,@6) 0452 29920000 LR @7,@8 0452 29930000 BCTR @7,0 0452 29940000 LR @A,@5 0452 29950000 EX @7,@CLC 0452 29960000 * GOTO NAMECK; /* THE NAME * 29970000 BC 07,NAMECK 0453 29980000 * 29990000 * /***************************************************************** 30000000 * /* * 30010000 * /* *********END OF NAME COMPARE LOOP************************* * 30020000 * /* FREE CORE FOR UPPER CASE RSVWD COPY * 30030000 * /* * 30040000 * /***************************************************************** 30050000 * 30060000 * CALL FREECORE; /* FREE RSVWD COPY AREA * 30070000 L @F,@V4 ADDRESS OF FREECORE 0454 30080000 BALR @E,@F 0454 30090000 * 30100000 * /***************************************************************** 30110000 * /* * 30120000 * /* RETURN TO IKJEFP60 IF A FIGURATIVE CONSTANT IS FOUND * 30130000 * /* * 30140000 * /***************************************************************** 30150000 * 30160000 * IF RSVWDPCE -> RFCONST = '1'B /* THE RFCONST SWITCH IS ON * 30170000 * THEN /* ONLY IN A TERM CHAINED * 30180000 L @7,460(0,@B) 0455 30190000 TM 1(@7),B'10000000' 0455 30200000 BC 12,@9B9 0455 30210000 * DO; /* RSVWD PCE. * 30220000 * PDEPTR -> RESWDNUM = R9; /* PLACE NAME # IN TEMP PDE * 30230000 L @7,500(0,@B) 0457 30240000 STH @9,4(0,@7) 0457 30250000 * GOTO RTN4; /* RETURN ON LINK REG +4 WHEN * 30260000 BC 15,RTN4 0458 30270000 * END; /* MATCH FOUND. * 30280000 * R4 = R4 -1; /* DECREMENT FOR NEXT SUBRTN * 30290000 @9B9 BCTR @4,0 0460 30300000 * R6 = RSVWDPCE; /* PLACE PTR TO RSVWD PCE IN XPCE* 30310000 L @6,460(0,@B) 0461 30320000 * 30330000 * /***************************************************************** 30340000 * /* * 30350000 * /* FILL IN TEMPORARY RSVWD PDE * 30360000 * /* * 30370000 * /***************************************************************** 30380000 * 30390000 * RNAMENUM = R9; /* PLACE IKJNAME NUMBER IN 30400000 * TEMPORARY PDE * 30410000 ST @9,@TEMP4 0462 30420000 MVC 270(2,@B),@TEMP4+2 0462 30430000 * ORFND = '1'B; /* INDICATE THAT MATCH WAS FOUND * 30440000 OI 274(@B),B'10000000' 0463 30450000 * R5 = R4; /* UPDATE XINPUTB PAST RSVWD * 30460000 LR @5,@4 0464 30470000 * INVPSAVE = PPOINTR; /* INVPSAVE = FIRST CHAR RSVWD * 30480000 MVC 236(4,@B),84(@B) 0465 30490000 * R1 = 7; /* R1 = PDELENGTH -1 * 30500000 LA @1,7 0466 30510000 * R15 = 3; /* LOAD ADDR POSITXCB ROUTINE * 30520000 LA @F,3 0467 30530000 * CALL LINKRET; /* GOTO ADD PERMANENT PDE VIA 30540000 * POSITXCB ROUTINE * 30550000 BAL @E,LINKRET 0468 30560000 * 30570000 * /***************************************************************** 30580000 * /* * 30590000 * /* DETERMINE IDENTITY OF CALLING ROUTINE WHEN NOT IKJEFP60 * 30600000 * /* * 30610000 * /***************************************************************** 30620000 * 30630000 * IF OPERMODE = '0'B THEN /* GOTO NAMESKP3 IF CALLER * 30640000 TM 535(@B),B'01000000' 0469 30650000 * GOTO RTNNSKP3; /* IS NOT IKJOPER PROCESSOR * 30660000 BC 08,RTNNSKP3 0470 30670000 * GOTO RTN4; /* RETURN TO IKJOPER PROCESSOR * 30680000 BC 15,RTN4 0471 30690000 * 30700000 * /***************************************************************** 30710000 * /* * 30720000 * /* RECEIVE CONTROL WHEN NO MATCH IS FOUND * 30730000 * /* * 30740000 * /***************************************************************** 30750000 * 30760000 * 30770000 * NOMATCH: 30780000 * CALL FREECORE; /* FREE CORE USED FOR UPPER * 30790000 NOMATCH L @F,@V4 ADDRESS OF FREECORE 0472 30800000 BALR @E,@F 0472 30810000 * /* CASE RSVWD COPY * 30820000 * 30830000 * /***************************************************************** 30840000 * /* * 30850000 * /* SET UP PROMPT MESSAGE UNLESS A FIGURATIME CONSTANT IS BEING * 30860000 * /* PROCESSED UNDER A TERM PCE * 30870000 * /* * 30880000 * /***************************************************************** 30890000 * 30900000 * 30910000 * NOMATCH2: 30920000 * IF RSVWDPCE -> RFCONST = '1'B THEN /* RETURN TO IKJEFP50 IF * 30930000 NOMATCH2 L @7,460(0,@B) 0473 30940000 TM 1(@7),B'10000000' 0473 30950000 * GOTO RTN0; /* RFCONST BIT IS ON * 30960000 BC 01,RTN0 0474 30970000 * 30980000 * /***************************************************************** 30990000 * /* * 31000000 * /* DETERMINE IF RSVWD IS INVALID WHEN NO MATCH IS FOUND * 31010000 * /* * 31020000 * /***************************************************************** 31030000 * 31040000 * IF RSVDPRMT = '1'B ³ /* RSVWD IS INVALID IF * 31050000 * OPERMODE = '1'B ³ /* IT IS A RSVWD PROMPT * 31060000 * RSVWDPCE -> RPRMTI = '1'B ³ /* REPLY, IF IN OPER MODE, * 31070000 * RSVWDPCE -> RDFLTI = '1'B THEN /* OR IF PROMPT-DEFAULT * 31080000 TM 535(@B),B'00000100' 0475 31090000 BC 01,@9B8 0475 31100000 TM 535(@B),B'01000000' 0475 31110000 BC 01,@9B7 0475 31120000 TM 0(@7),B'00010000' 0475 31130000 BC 01,@9B6 0475 31140000 TM 0(@7),B'00001000' 0475 31150000 BC 12,@9B5 0475 31160000 * GOTO IP; /* DATA IS PRESENT * 31170000 BC 03,IP 0476 31180000 * R6 = RSVWDSV2; /* RESTORE XPCE TO ENTRY VALUE * 31190000 @9B5 L @6,480(0,@B) 0477 31200000 * R4 = RSVWDSV1; /* POINT XINPUT TO CHAR BEFORE * 31210000 L @4,476(0,@B) 0478 31220000 * GOTO RTNNSKP3; /* RSVWD, THEN EXIT * 31230000 BC 15,RTNNSKP3 0479 31240000 * 31250000 * /***************************************************************** 31260000 * /* * 31270000 * /* SET UP PARAMETERS WHEN PROMPTING WITH INVALID DATA * 31280000 * /* * 31290000 * /***************************************************************** 31300000 * 31310000 * 31320000 * IPA: 31330000 * R4 = ENDINPUT; /* PROMPT WITH REMAINDER * 31340000 IPA L @4,80(0,@B) 0480 31350000 * /* OF BUFFER * 31360000 * 31370000 * IP: 31380000 * INVPSAVE = RSVWDSV1 + 1; /* SET INVPSAVE TO FIRST CHAR * 31390000 IP LA @F,1 0481 31400000 A @F,476(0,@B) 0481 31410000 ST @F,236(0,@B) 0481 31420000 * /* OF INVALID DATA * 31430000 * PPCOUNT = 7; /* SET PPCOUNT = PDE LENGTH -1 * 31440000 MVI 353(@B),7 0482 31450000 * R6 = RSVWDPCE; /* SET PCE PTR TO RSVWD PCE * 31460000 L @6,460(0,@B) 0483 31470000 * R5 = R4; /* SET XINPUTB TO NEXT CHAR AFTER 31480000 * INVALID DATA * 31490000 LR @5,@4 0484 31500000 * CBLNKSV2 = ADDR(P40PR); /* CBLNKSV2 = RETURN ADDR * 31510000 LA @F,P40PR 0485 31520000 ST @F,488(0,@B) 0485 31530000 * GOTO MSGSETUP; /* PROMPT * 31540000 BC 15,MSGSETUP 0486 31550000 * 31560000 * /***************************************************************** 31570000 * /* * 31580000 * /* PROMPT FOR MISSING DATA UNLESS PROCESSING A FIGURATIVE * 31590000 * /* CONSTANT * 31600000 * /* * 31610000 * /***************************************************************** 31620000 * 31630000 * 31640000 * A1: 31650000 * IF RSVWDPCE -> RFCONST = '1'B THEN /* RETURN TO TERM * 31660000 A1 L @7,460(0,@B) 0487 31670000 TM 1(@7),B'10000000' 0487 31680000 * GOTO RTN0; /* PROCESSOR IF RSVWD PCE IS 31690000 * CHAINED TO A TERM PCE * 31700000 BC 01,RTN0 0488 31710000 * R6 = RSVWDPCE; /* PLACE PROMPT PCE IN XPCE * 31720000 L @6,460(0,@B) 0489 31730000 * R15 = 2; /* LOAD PROMPTQ RTN ADDR * 31740000 LA @F,2 0490 31750000 * CALL LINKRET; /* CALL PROMPTQ * 31760000 BAL @E,LINKRET 0491 31770000 * GEN (BC 15,P40PR); /* ON +0 RETURN -- DATA RETURNED * 31780000 BC 15,P40PR 31790000 DS 0H 31800000 * GEN (BC 15,RPQRTN4); /* ON +4 RETURN -- NO NEW DATA * 31810000 BC 15,RPQRTN4 31820000 DS 0H 31830000 * 31840000 * /***************************************************************** 31850000 * /* * 31860000 * /* RECEIVE CONTROL AFTER THE PROMPT REPLY * 31870000 * /* * 31880000 * /***************************************************************** 31890000 * 31900000 * 31910000 * P40PR: /* DETERMINE IF NEW DATA WAS 31920000 * RETURNED FROM THE PROMPT * 31930000 * IF PFNULL = '0'B /* IF DATA WAS RETURNED * 31940000 * THEN /* FROM THE PROMPT, SCAN THE * 31950000 P40PR TM 114(@B),B'00001000' 0494 31960000 BC 05,@9B4 0494 31970000 * DO; /* NEW RSVWD DATA. SET * 31980000 * RSVDPRMT = '1'B; /* RSVDPRMT TO INDITCATE THAT * 31990000 OI 535(@B),B'00000100' 0496 32000000 * GOTO E; /* THE DATA MUST BE INVALID * 32010000 BC 15,E 0497 32020000 * END; /* IF NO MATCH IS FOUND * 32030000 * PFNULL = '0'B; /* TURN OFF NULL REPLY SWITCH * 32040000 @9B4 NI 114(@B),B'11110111' 0499 32050000 * 32060000 * /***************************************************************** 32070000 * /* * 32080000 * /* DETERMINE CALLING ROUTINE AFTER A NULL PROMPT REPLY * 32090000 * /* * 32100000 * /***************************************************************** 32110000 * 32120000 * 32130000 * RPQRTN4: 32140000 * IF OPERMODE = '1'B THEN /* RETURN TO OPER PROCESSOR * 32150000 RPQRTN4 TM 535(@B),B'01000000' 0500 32160000 * GOTO RTNO0; /* IF IN OPER MODE. GIVE * 32170000 BC 01,RTNO0 0501 32180000 * ELSE /* CONTROL TO NAMESKP3 IF * 32190000 * GOTO RTNNSKP3; /* CALLED BY MAIN LINE PARSE * 32200000 BC 15,RTNNSKP3 0502 32210000 * 32220000 * /***************************************************************** 32230000 * /* * 32240000 * /* CHECK FOR INVALID OPTIONAL DATA ON THE REPLY TO RSVWD * 32250000 * /* PROMPTING IN THE OPER MODE * 32260000 * /* * 32270000 * /***************************************************************** 32280000 * 32290000 * OMODCK: 32300000 * IF OPERMODE = '0'B THEN /* OPTIONAL DATA IS INVALID * 32310000 OMODCK TM 535(@B),B'01000000' 0503 32320000 * GOTO F; /* ONLY WHEN IN OPER MODE * 32330000 BC 08,F 0504 32340000 * 32350000 * /***************************************************************** 32360000 * /* * 32370000 * /* CHECK FOR INVALID OPTIONAL DATA ON THE PROMPT REPLY * 32380000 * /* * 32390000 * /***************************************************************** 32400000 * 32410000 * OMODCK2: 32420000 * IF RSVDPRMT = '0'B THEN /* THE CHECK ONLY APPLIES TO * 32430000 OMODCK2 TM 535(@B),B'00000100' 0505 32440000 * GOTO F; /* DATA RETURNED FROM A PROMPT * 32450000 BC 08,F 0506 32460000 * PFNOPOP = '1'B; /* ENSURE THAT SKIPB DOES NOT POP 32470000 * PROMPT BUFFER * 32480000 OI 115(@B),B'00000010' 0507 32490000 * R15 = 5; /* LOAD ADDR SKIPB RTN * 32500000 LA @F,5 0508 32510000 * CALL LINKRET; /* CALL SKIPB TO SKIP OVER 32520000 * SEPARATORS * 32530000 BAL @E,LINKRET 0509 32540000 * GOTO NOPRMT; /* +0 RETURN-- NO OPTIONAL DATA 32550000 * BEFORE END OF BUFFER * 32560000 BC 15,NOPRMT 0510 32570000 * PFNOPOP = '0'B; /* +4 RETURN-- INVALID OPTIONAL 32580000 * DATA FOUND * 32590000 NI 115(@B),B'11111101' 0511 32600000 * GOTO IPA; /* PROMPT * 32610000 BC 15,IPA 0512 32620000 * 32630000 * NOPRMT: 32640000 * PFNOPOP = '0'B; /* ALLOW SKIPB TO POP BUFFER ON 32650000 * FUTURE CALLS * 32660000 NOPRMT NI 115(@B),B'11111101' 0513 32670000 * R5 = RSVWDSV1 + 1; /* SET PTR TO RSVWD FIRST CHAR * 32680000 LA @5,1 0514 32690000 A @5,476(0,@B) 0514 32700000 * GOTO F; /* CONTINUE RSVWD SCAN * 32710000 BC 15,F 0515 32720000 * 32730000 * /***************************************************************** 32740000 * /* * 32750000 * /* RETURN CONTROL TO THE CALLING ROUTINE * 32760000 * /* * 32770000 * /***************************************************************** 32780000 * 32790000 * 32800000 * RTN0: 32810000 * R4 = RSVWDSV1; /* RESTORE XINPUT TO ENTRY VALUE * 32820000 RTN0 L @4,476(0,@B) 0516 32830000 * 32840000 * RTNO0: 32850000 * R8 = 0; /* RETURN ON +0 * 32860000 RTNO0 SR @8,@8 0517 32870000 * GOTO RTNC; /* SKIP OVER +4 RETURN * 32880000 BC 15,RTNC 0518 32890000 * 32900000 * RTN4: 32910000 * R8 = 4; /* RETURN ON +4 * 32920000 RTN4 LA @8,4 0519 32930000 * 32940000 * RTNC: 32950000 * R6 = RSVWDSV2; /* RESTORE XPCE TO ENTRY VALUE * 32960000 RTNC L @6,480(0,@B) 0520 32970000 * R14 = RSVDRTN + R8; /* LOAD RETURN ADDR * 32980000 LR @E,@8 0521 32990000 A @E,RSVDRTN 0521 33000000 * RETURN; /* RETURN TO CALLER * 33010000 BC 15,@EL05 0522 33020000 * 33030000 * RTNNSKP3: 33040000 * COBOLMOD = '0'B; /* LEAVE COBOL MODE * 33050000 RTNNSKP3 NI 535(@B),B'01111111' 0523 33060000 * GEN (BAL 14,@EL01); /* FREE AUTOMATIC STORAGE * 33070000 BAL 14,@EL01 33080000 DS 0H 33090000 * R15 = 15; /* LOAD ADDR NAMESKP3 ROUTINE * 33100000 LA @F,15 0525 33110000 * CALL LINKRET; /* GIVE CONTROL - NO RETURN * 33120000 BAL @E,LINKRET 0526 33130000 * 33140000 * RTNCLNUP: 33150000 * RETCODE = 24; /* PASS RETURN CODE FOR BAD PCE 33160000 * BACK TO THE CP * 33170000 RTNCLNUP MVI 90(@B),24 0527 33180000 * GEN (BAL 14,@EL01); /* FREE AUTOMATIC STORAGE * 33190000 BAL 14,@EL01 33200000 DS 0H 33210000 * R15 = 16; /* LOAD ADDR CLEANUP RTN * 33220000 LA @F,16 0529 33230000 * CALL LINKRET; /* TERMINATE SCAN AND GOTO 33240000 * CLEANUP * 33250000 BAL @E,LINKRET 0530 33260000 * END IKJEFP40; 33270000 @EL05 BCR 15,@E 0531 33280000 * 33290000 * /***************************************************************** 33300000 * /* * 33310000 * /* FREE STORAGE OBTAINED BY THE GETCORE SUBROUTINE * 33320000 * /* * 33330000 * /***************************************************************** 33340000 * 33350000 * 33360000 * FREECORE: /* ENTRY FREECORE * 33370000 * PROC OPTIONS(NOSAVEAREA, /* NO STANDARD LINKAGE * 33380000 * DONTSAVE); /* NO STANDARD LINKAGE * 33390000 * RESPECIFY 33400000 * (R8, 33410000 * R9, 33420000 * R4, 33430000 * R6, 33440000 * R5, 33450000 * PWAREG) RESTRICTED; /* SAVE CRITICAL POINTERS * 33460000 * GOREGSV = R14; /* SAVE RETURN ADDR * 33470000 FREECORE ST @E,552(0,@B) 0534 33480000 * GEN; /* FREE STORAGE * 33490000 LR R0,R8 /* R8 = I = # OF BYTES */ 33500000 LR R1,R5 /* R5 = XINPUTB = ADDR CORE */ 33510000 FREEMAIN R,LV=(0),A=(1) /* FREE CORE */ 33520000 DS 0H 33530000 * R14 = GOREGSV; /* RESTORE RETURN ADDR * 33540000 L @E,552(0,@B) 0536 33550000 * END FREECORE; 33560000 @EL06 BCR 15,@E 0537 33570000 * 33580000 * /***************************************************************** 33590000 * /* * 33600000 * /* THIS ROUTINE VALIDITY CHECKS THE STRUCTURE OF TERM PCE'S CODED* 33610000 * /* UNDER THE OPER PCE * 33620000 * /* * 33630000 * /***************************************************************** 33640000 * 33650000 * 33660000 * TERMOCK: 33670000 * PROC OPTIONS(NOSAVEAREA, /* ENTRY TERMOCK * 33680000 * DONTSAVE); /* NO STANDARD LINKAGE * 33690000 * RESPECIFY 33700000 * (R6, 33710000 * R4, 33720000 * R5, 33730000 * R7, 33740000 * R9, 33750000 * PWAREG) RESTRICTED; /* SAVE POINTERS * 33760000 * GOREGSV = R14; /* SAVE RETURN ADDR * 33770000 TERMOCK ST @E,552(0,@B) 0540 33780000 * IF TERPCE ª= '110'B /* COMPARE THE TERM PCE TYPE * 33790000 * THEN 33800000 TM 0(@6),B'11000000' 0541 33810000 BC 12,@9B3 0540 33820000 TM 0(@6),B'00100000' 0541 33830000 BC 08,@9B2 0541 33840000 * GOTO RTNCLNUP; /* MASK TO THE MINOR TERM * 33850000 BC 15,RTNCLNUP 0542 33860000 * /* PCE LOCATION - IF THERE IS * 33870000 * /* NO MATCH GOTO CLEANUP WITH * 33880000 * /* THE RETURN CODE IN RETCODE * 33890000 * 33900000 * /***************************************************************** 33910000 * /* * 33920000 * /* IF THE MINOR TERM PCE HAS LIST OR RANGE SPECIFIED IT CAN NOT * 33930000 * /* BE CODED UNDER AN OPER PCE * 33940000 * /* * 33950000 * /***************************************************************** 33960000 * 33970000 * IF LIST = '1'B ³ /* TEST THE LIST AND THE RANGE * 33980000 * RANG = '1'B /* BITS IN THE MINOR TERM PCE * 33990000 * THEN 34000000 @9B2 TM 1(@6),B'10000000' 0543 34010000 BC 01,@9B1 0543 34020000 TM 1(@6),B'00100000' 0543 34030000 BC 12,@9B0 0543 34040000 * GOTO RTNCLNUP; /* - IF THEY ARE ON GOTO THE * 34050000 BC 15,RTNCLNUP 0544 34060000 * /* PARSE SUBROUTINE 'CLEANUP' * 34070000 * /* WHICH PASSES THE PCE ERROR * 34080000 * /* RETURN CODE -RETCODE- BACK * 34090000 * /* TO THE COMMAND PROCESS * 34100000 * 34110000 * /***************************************************************** 34120000 * /* * 34130000 * /* THE MINOR TERM PCE ADDRESS MUST BE LESS THAN THE PCE ADDRESS * 34140000 * /* FOUND IN 'PRIORPCE' * 34150000 * /* * 34160000 * /***************************************************************** 34170000 * 34180000 * IF R6 ª> R9 /* COMPARE THE ADDRESS OF THE * 34190000 * THEN 34200000 @9B0 CR @6,@9 0545 34210000 * GOTO RTNCLNUP; /* TERM PCE BEING TESTED WITH * 34220000 BC 12,RTNCLNUP 0546 34230000 * /* THE PRIOR PCE - IF THE * 34240000 * /* CURRENT TERM IS NOT THE * 34250000 * /* GREATER GOTO 'CLEANUP'. * 34260000 * R9 = R6; /* UPDATE PRIORPCE BEFORE THE * 34270000 LR @9,@6 0547 34280000 * R14 = GOREGSV; /* RESTORE RETURN ADDR * 34290000 L @E,552(0,@B) 0548 34300000 * END TERMOCK; /* END OF PROCEDURE TERMOCK * 34310000 @EL07 BCR 15,@E 0549 34320000 * END IKJEFP50; 34330000 * 34340000 * IKJEFP60: /* TERM PROCESSOR * 34350000 * PROC OPTIONS(DONTSAVE,NOSAVEAREA); /* MAIN ENTRY POINT * 34360000 IKJEFP60 EQU * 0551 34370000 * 34380000 * /***************************************************************** 34390000 * /* * 34400000 * /* REGISTER DECLARES AND RESTRICTIONS * 34410000 * /* * 34420000 * /***************************************************************** 34430000 * 34440000 * DCL 34450000 * PARS2BAS REG(2) PTR(31); /* TERM BASE REGISTER * 34460000 * DCL 34470000 * OTHBASE REG(3) PTR(31); /* OPER/RESVWD BASE REG * 34480000 * DCL 34490000 * ADDCDE REG(15) PTR(31); /* SUBROUTINE ADDR AND RET/CODE * 34500000 * RESTRICT (R4,R5); /* KEEP COMMAND PTRS INTACT * 34510000 * RESTRICT (R6); /* KEEP PTR TO NEXT PCE * 34520000 * RESTRICT (PWAREG); /* KEEP WORKAREA INTACT * 34530000 * RESTRICT (LINK2); /* SAVE LINKAGE REG * 34540000 * 34550000 * /***************************************************************** 34560000 * /* * 34570000 * /* COMPILE TIME VARIBLES * 34580000 * /* * 34590000 * /***************************************************************** 34600000 * 34610000 * 34620000 * /***************************************************************** 34630000 * /* * 34640000 * /* TABLES AND WORKAREAS THE FOLLOWING AREA CONTAIN CONTROL INFO * 34650000 * /* FOR GENSCAN * 34660000 * /* * 34670000 * /***************************************************************** 34680000 * 34690000 * DCL 34700000 * 1 WORKAR AUTO, /* GENSCAN CONTROL OPTIONS * 34710000 * 2 GOPTION CHAR(1), /* SCAN OPTIONS * 34720000 * 2 GFIRST CHAR(1), /* FIRST CHAR TYPE * 34730000 * 2 GOTHER CHAR(1), /* OTHER CHAR TYPE * 34740000 * 2 GOMAX CHAR(1); /* MAXIMUN SCAN LENGTH * 34750000 * DCL 34760000 * 1 WORKAR1 BASED(TANC), /* AREA FOR QUALIFIER PDE * 34770000 * 2 QNAMEPTR PTR(31), /* PTR TO DATA NAME * 34780000 * 2 QNGTH4 PTR(8), /* LENGTH OF DATA NAME * 34790000 * 2 QRESV CHAR(3), /* RESERVE FIELD * 34800000 * 2 QATAPTRH PTR(32); /* SPACE FOR LAST INDICATOR * 34810000 * DCL 34820000 * PTRARE PTR(31) BASED(CHAINPTR); /* DSECT FOR CHAINPTR AREA * 34830000 * DCL 34840000 * COMBUFA CHAR(2) BASED(R4); /* TWO BYTE COMMAND BUFFER * 34850000 * DCL 34860000 * VCOMBF CHAR(1) BASED(R4-1); /* PREV INPUT CHAR * 34870000 * DCL 34880000 * CNSTTEMP CHAR(20) BASED(PDEPTR); /*PDE TO ZERO IF TYPE ANY * 34890000 * 34900000 * /***************************************************************** 34910000 * /* * 34920000 * /* MAP OF VARIABLE PDE * 34930000 * /* * 34940000 * /***************************************************************** 34950000 * 34960000 * DCL 34970000 * 1 VARIPDE BASED(ADDR(TEMPPDE)), /* PDE MAP * 34980000 * 2 * CHAR(18), /* DUMMY AREA * 34990000 * 2 NUMSUB1 CHAR(1); /* NUMBER OF SUBSCRIPTS * 35000000 * DCL 35010000 * BUMP INTERNAL LABEL LOCAL; /* INTERNAL PROCDURE TO UPDATE 35020000 * INPUT POINTER * 35030000 * 35040000 * /***************************************************************** 35050000 * /* * 35060000 * /* THIS ROUTINE PERFORMS INITIALIZATION FUNCTIONS, INTERROGATES * 35070000 * /* THE PCE TYPE(CONST, STMT, VAR, OR ANY) AND BRANCHES TO THE * 35080000 * /* CORRESPONDING ROUTINE. * 35090000 * /* * 35100000 * /***************************************************************** 35110000 * 35120000 * 35130000 * TERMBGN: 35140000 * COBOLMOD='1'B; /* TURN ON COBOL SWITCH * 35150000 TERMBGN OI 535(@B),B'10000000' 0567 35160000 * PRMTSCAN='0'B; /* MISSING PARM PROMPTED FOR * 35170000 NI 536(@B),B'11111011' 0568 35180000 * PFENDSET='0'B; /* SET POP STACK SWITCH TO 35190000 * CONTROL VARIABLE SCAN * 35200000 NI 115(@B),B'11111011' 0569 35210000 * PREVPDEL=0; /* LIST PTR TO ZERO * 35220000 SR @F,@F 0570 35230000 ST @F,384(0,@B) 0570 35240000 * RC16='0'B; /* TURN VALIDITY CHECK BIT OFF * 35250000 NI 535(@B),B'11111110' 0571 35260000 * PDEPTR=ADDR (TEMPPDE); /* SET PDE PTR TO TEMPORARY PDE * 35270000 LA @F,268(0,@B) 0572 35280000 ST @F,500(0,@B) 0572 35290000 * CBLNKSV1=GOREG; /* SAVE RETURN ADDRESS * 35300000 ST @E,484(0,@B) 0573 35310000 * TERMXPCE=R6; /* SAVE CURRENT PCE POINTER * 35320000 ST @6,464(0,@B) 0574 35330000 * ADDCDE=5; /* ADDR OF SKIPB IN REG 15 * 35340000 LA @F,5 0575 35350000 * CALL LINKRET; /* BRANCH TO PARSE2 * 35360000 BAL @E,LINKRET 0576 35370000 * GOTO PROMPT01; /* BRANCH ON ZERO RETURN * 35380000 BC 15,PROMPT01 0577 35390000 * 35400000 * /***************************************************************** 35410000 * /* * 35420000 * /* GENERATE BRANCH AROUND SETTING PRMTSCAN IF MORE * 35430000 * /* * 35440000 * /***************************************************************** 35450000 * 35460000 * GEN (BC 15,OPER); 35470000 BC 15,OPER 35480000 DS 0H 35490000 * 35500000 * /***************************************************************** 35510000 * /* * 35520000 * /* TEST TO DETERMINE IF IKJOPER HAS BEEN ENTERED * 35530000 * /* * 35540000 * /***************************************************************** 35550000 * 35560000 * 35570000 * OPER1: 35580000 * PRMTSCAN='1'B; /* RETURN HERE AFTER DATA 35590000 * RETURNED FROM PROMPT - TURN 35600000 * PRMTSCAN ON FOR INVALID * 35610000 OPER1 OI 536(@B),B'00000100' 0579 35620000 * 35630000 * OPER: 35640000 * IF OPERMODE='1'B /* IS THIS IN OPER MODE ? * 35650000 * THEN /* IF YES * 35660000 OPER TM 535(@B),B'01000000' 0580 35670000 BC 12,@9AF 0580 35680000 * DO; /* TEST FOR SUBSCRIPTS * 35690000 * 35700000 * /************************************************************* 35710000 * /* * 35720000 * /* TEST TO DETERMINE IF SUBSCRIPTS ARE ALLOWED * 35730000 * /* * 35740000 * /************************************************************* 35750000 * 35760000 * 35770000 * PDESIZ: 35780000 * IF SUBSCRP='1'B /* ARE SUBSCRIPTS ALLOWED ? * 35790000 * THEN /* IF YES * 35800000 PDESIZ TM 1(@6),B'00010000' 0582 35810000 BC 12,@9AE 0582 35820000 * DO; /* SET LENGTHS * 35830000 * PPCOUNT=79; /* DATA SIZE EQUAL 3 SUBSCRIPTS * 35840000 MVI 353(@B),79 0584 35850000 * GOTO INVPSAV; /* BRANCH TO UPDATE INPUT PTR * 35860000 BC 15,INVPSAV 0585 35870000 * END; /* IF SUBSCRIPTS NOT ALLOWED * 35880000 * PPCOUNT=19; /* DATA SIZE EQUAL 1 SUBSCRIPT * 35890000 @9AE MVI 353(@B),19 0587 35900000 * 35910000 * /************************************************************* 35920000 * /* * 35930000 * /* CHECK FOR RANGE PROCESSING * 35940000 * /* * 35950000 * /************************************************************* 35960000 * 35970000 * 35980000 * INVPSAV: 35990000 * IF RNGEVAL1='1'B /* TEST FOR FIRST VAL OF RANGE * 36000000 * THEN /* IF YES * 36010000 INVPSAV TM 113(@B),B'01000000' 0588 36020000 BC 12,@9AD 0588 36030000 * DO; /* SET UP FOR TYPETEST * 36040000 * IF R4=>ENDINPUT /* IF XINPUT IS AT ENDINPUT 36050000 * A56847 * 36060000 * THEN /* OR AT A SEMICOLON * 36070000 C @4,80(0,@B) 0590 36080000 * GOTO RANGERR1; /* IS AN ERROR * 36090000 BC 10,RANGERR1 0591 36100000 * IF COMBUF=';' /* IS IT A SEMI COLON * 36110000 * THEN /* IF SO IS AN * 36120000 CLI 0(@4),C';' 0592 36130000 * GOTO RANGERR1; /* ERROR TOO * 36140000 BC 08,RANGERR1 0593 36150000 * ADDCDE=8; /* ADDR OF TYPE TEST REG 15 * 36160000 LA @F,8 0594 36170000 * R1='08'X; /* BLK-TAB-COMMA MASK REG 1 * 36180000 LA @1,X'08' 0595 36190000 * CALL LINKRET; /* BRANCH TO PARSE2 * 36200000 BAL @E,LINKRET 0596 36210000 * GOTO INVPSAV1; /* BRANCH AROUND * 36220000 BC 15,INVPSAV1 0597 36230000 * RANGERR1: 36240000 * ERRORBIT='1'B; /* SET ERROR BIT * 36250000 RANGERR1 OI 535(@B),B'00001000' 0598 36260000 * PFNOPOP='1'B; /* PREVENT STACK POPPING * 36270000 OI 115(@B),B'00000010' 0599 36280000 * CALL TSTRNGE; /* CHECK RANGE A56847 * 36290000 L @F,@V5 ADDRESS OF TSTRNGE 0600 36300000 BALR @E,@F 0600 36310000 * GOTO EXIT; /* BRANCH FOR ERROR PROC * 36320000 BC 15,EXIT 0601 36330000 * END; /* IF NOT RANGE PROCESSING * 36340000 * 36350000 * INPUTUP: 36360000 * R4=R4+1; /* PTR TO NEXT CHAR IN BUFFER * 36370000 @9AD EQU * 0603 36380000 INPUTUP AH @4,@D2 0603 36390000 * INVPSAVE=R4; /* RESET INVPSAVE TO BEG OF THIS 36400000 * TERM * 36410000 ST @4,236(0,@B) 0604 36420000 * 36430000 * /************************************************************* 36440000 * /* * 36450000 * /* IF THE ERROR BIT IS NOT ON, SET INVPSAVE AND PRMTPTR EQUAL* 36460000 * /* TO XINPUT. RANGES ARE NOT ALLOWED WITHIN AN EXPRESSION. * 36470000 * /* THE ERRORBIT CANNOT BE ON UNLESS HAVE COME INTO * 36480000 * /* INITIALIZATION CODE AFTER SCANNING PART OF A RANGE, I.E., * 36490000 * /* THE FIRST VALUE. * 36500000 * /* * 36510000 * /************************************************************* 36520000 * 36530000 * 36540000 * INVPSAV1: /* IF ERROR BIT IS * 36550000 * IF ERRORBITª='1'B /* NOT ON, * 36560000 * THEN /* WANT TO SET INVPSAVE AND * 36570000 INVPSAV1 TM 535(@B),B'00001000' 0605 36580000 BC 01,@9AC 0605 36590000 * DO; /* PRMTPTR * 36600000 * PRMTPTR=R4; /* BEGINNING OF VARIABLE * 36610000 ST @4,520(0,@B) 0607 36620000 * END; /* END SET OF POINTERS * 36630000 * 36640000 * /************************************************************* 36650000 * /* * 36660000 * /* DETERMINE PCE TYPE AND BRANCH TO SUBROUTINE * 36670000 * /* * 36680000 * /************************************************************* 36690000 * 36700000 * 36710000 * PCETYPE1: 36720000 * IF VAR='1'B /* IF TYPE EQUAL VARIABLE * 36730000 * THEN /* IF YES * 36740000 @9AC EQU * 0609 36750000 PCETYPE1 TM 6(@6),B'01000000' 0609 36760000 * GOTO IKJEFP6V; /* BRANCH TO VARIABLE RTN * 36770000 BC 01,IKJEFP6V 0610 36780000 * 36790000 * /************************************************************* 36800000 * /* * 36810000 * /* TEST FOR TYPE EQUAL STATEMENT NUMBER * 36820000 * /* * 36830000 * /************************************************************* 36840000 * 36850000 * IF STMT='1'B /* IF TYPE EQUAL STATEMENT NO. * 36860000 * THEN /* IF YES * 36870000 TM 6(@6),B'10000000' 0611 36880000 * GOTO IKJEFP6S; /* BRANCH TO STATEMENT RTN * 36890000 BC 01,IKJEFP6S 0612 36900000 * 36910000 * /************************************************************* 36920000 * /* * 36930000 * /* TEST FOR TYPE EQUAL CONSTANT * 36940000 * /* * 36950000 * /************************************************************* 36960000 * 36970000 * IF CNST='1'B /* IF TYPE EQUAL CONSTANT * 36980000 * THEN /* IF YES * 36990000 TM 6(@6),B'00100000' 0613 37000000 * GOTO SUBTEST; /* BRANCH TO CONSTANT RTN * 37010000 BC 01,SUBTEST 0614 37020000 * 37030000 * /************************************************************* 37040000 * /* * 37050000 * /* TEST FOR TYPE EQUAL ANY * 37060000 * /* * 37070000 * /************************************************************* 37080000 * 37090000 * IF ANY='1'B /* IF TYPE EQUAL ANY * 37100000 * THEN /* IF YES * 37110000 TM 6(@6),B'00010000' 0615 37120000 * GOTO SUBTEST; /* BRANCH TO CONSTANT RTN * 37130000 BC 01,SUBTEST 0616 37140000 * END; /* IF OPER MODE NOT SET * 37150000 * ADDCDE=11; /* ADDR OF LISTT IN REG 15 * 37160000 @9AF LA @F,11 0618 37170000 * CALL LINKRET; /* BRANCH TO PARSE2 * 37180000 BAL @E,LINKRET 0619 37190000 * GOTO VARCODE3; /* GOTO RESET PTRS SO WON'T MISS 37200000 * END OF LIST * 37210000 BC 15,VARCODE3 0620 37220000 * GEN (BC 15,PDESIZ); /* BRANCH TO SET PDE SIZE * 37230000 BC 15,PDESIZ 37240000 DS 0H 37250000 * 37260000 * VARCODE3: /* MUST RESET XINPUTB SO * 37270000 * R5=PPOINTR+1; /* END OF LIST WILL NOT BE MISSED* 37280000 VARCODE3 LA @5,1 0622 37290000 A @5,84(0,@B) 0622 37300000 * GOTO VARCODE4; /* ISSUE INVALID MESSAGE * 37310000 BC 15,VARCODE4 0623 37320000 * 37330000 * PROMPT01: /* DETERMINE IF PARM OPTIONAL * 37340000 * ADDCDE=2; /* ADDR OF PROMPTQ IN REG 15 * 37350000 PROMPT01 LA @F,2 0624 37360000 * CALL LINKRET; /* BRANCH TO PARSE2 * 37370000 BAL @E,LINKRET 0625 37380000 * GOTO OPER; /* TEST FOR OPER MODE * 37390000 BC 15,OPER 0626 37400000 * 37410000 * /***************************************************************** 37420000 * /* * 37430000 * /* TEST TO DETERMINE IF IKJOPER HAS BEEN ENTERED * 37440000 * /* * 37450000 * /***************************************************************** 37460000 * 37470000 * 37480000 * NTRQEXT: 37490000 * IF OPERMODE='1'B /* IS THIS OPER MODE ? * 37500000 * THEN /* IF YES * 37510000 NTRQEXT TM 535(@B),B'01000000' 0627 37520000 BC 12,@9AB 0627 37530000 * DO; /* RETURN TO CALLER * 37540000 * GOREG=CBLNKSV1; /* RESTORE REG 14 * 37550000 L @E,484(0,@B) 0629 37560000 * RETURN; /* RETURN TO CALLER * 37570000 BC 15,@EL08 0630 37580000 * END; /* IF OPERMODE NOT SET * 37590000 * GOTO UPDTPCE; /* EXIT TO UPDATE PCE * 37600000 * 37610000 * OPERTEST: /* ENTRY AFTER PROMPT RESPONSE * 37620000 * R6=TERMXPCE; /* LOAD PRIMARY PCE * 37630000 OPERTEST L @6,464(0,@B) 0633 37640000 * 37650000 * /***************************************************************** 37660000 * /* * 37670000 * /* DETERMINE IF PROCESSING PROMPT OR DEFAULT DATA * 37680000 * /* * 37690000 * /***************************************************************** 37700000 * 37710000 * PDEPTR=ADDR (TEMPPDE); /* RESET PDEPTR FOR RANGE * 37720000 LA @F,268(0,@B) 0634 37730000 ST @F,500(0,@B) 0634 37740000 * IF PFNULL='1'B /* NULL LINE RETURNED ? * 37750000 * THEN /* IF YES * 37760000 TM 114(@B),B'00001000' 0635 37770000 BC 12,@9AA 0635 37780000 * DO; /* SET SWITCH OFF * 37790000 * PFNULL='0'B; /* TURN SWITCH OFF * 37800000 NI 114(@B),B'11110111' 0637 37810000 * IF PFLIST='1'B /* IF PROCESSING A LIST, MUST * 37820000 * THEN /* GO TO PROCESSOR TO EITHER * 37830000 TM 112(@B),B'10000000' 0638 37840000 * GOTO LISTEST; /* CATCH NEXT ELEMENT OF THE LIST 37850000 * OR THE END OF LIST * 37860000 BC 01,LISTEST 0639 37870000 * GOTO NTRQEXT; /* PICK UP NEXT PCE * 37880000 BC 15,NTRQEXT 0640 37890000 * END; /* IF SWITCH NOT ON * 37900000 * GOTO OPER; /* TEST FOR OPER MODE * 37910000 * 37920000 * /***************************************************************** 37930000 * /* * 37940000 * /* THE STATEMENT PROCESSING ROUTINE IS ENTERED WHEN THE TYPE * 37950000 * /* PARAMETER IN THE CURRENT PCE IS STMT. * 37960000 * /* * 37970000 * /***************************************************************** 37980000 * 37990000 * 38000000 * IKJEFP6S: /* ENTRY FOR TYPE EQUAL STMT * 38010000 * 38020000 * /***************************************************************** 38030000 * /* * 38040000 * /* TEST FOR OPER MODE * 38050000 * /* * 38060000 * /***************************************************************** 38070000 * 38080000 * IF OPERMODEª='1'B /* IS THIS OPER MODE ? * 38090000 * THEN /* IF NO * 38100000 IKJEFP6S TM 535(@B),B'01000000' 0643 38110000 * GOTO CONT; /* BRANCH AROUND * 38120000 BC 12,CONT 0644 38130000 * 38140000 * /***************************************************************** 38150000 * /* * 38160000 * /* TEST FOR CHAIN TERM * 38170000 * /* * 38180000 * /***************************************************************** 38190000 * 38200000 * IF CHAINTRM='1'B /* CHAIN TERM BIT ON ? * 38210000 * THEN /* IF YES * 38220000 TM 536(@B),B'00010000' 0645 38230000 * GOTO CONT; /* BRANCH AROUND * 38240000 * GOTO COD24; /* BRANCH TO ISSUE ERROR MSG * 38250000 BC 14,COD24 0647 38260000 * 38270000 * CONT: 38280000 * ADDCDE=8; /* ADDR OF TYPETEST IN REG 15 * 38290000 CONT LA @F,8 0648 38300000 * R1='C0'X; /* ALPHA MASK IN REG 1 * 38310000 LA @1,X'C0' 0649 38320000 * CALL LINKRET; /* BRANCH TO PARSE2 * 38330000 BAL @E,LINKRET 0650 38340000 * GEN; /* RETURN BRANCHES * 38350000 BC 15,STRINPTR BRANCH AROUND 38360000 BC 15,STRPGMID BRANCH TO STORE PGM ID 38370000 DS 0H 38380000 * 38390000 * STRINPTR: /* STORE INPUT POINTER * 38400000 * DATAPTRA=R4; /* STOR INPUT PTR AS LINE NUMBER 38410000 * PTR IN PDE * 38420000 STRINPTR L @1,500(0,@B) 0652 38430000 ST @4,12(0,@1) 0652 38440000 * 38450000 * NUMCK1: 38460000 * ADDCDE=8; /* ADDR OF TYPE TEST IN REG 15 * 38470000 NUMCK1 LA @F,8 0653 38480000 * R1='10'X; /* NUMERIC MASK IN REG 1 * 38490000 LA @1,X'10' 0654 38500000 * CALL LINKRET; /* BRANCH TO PARSE2 * 38510000 BAL @E,LINKRET 0655 38520000 * GOTO MAXLNGTH; /* CHECK LENGTH OF LINE NO. * 38530000 BC 15,MAXLNGTH 0656 38540000 * NUMCK2: /* BRANCH FROM PGMID A56847 38550000 * PROCESSING A56846 * 38560000 * DIGITCT=DIGITCT+1; /* ADD ONE TO DATE COUNT * 38570000 NUMCK2 LA @F,1 0657 38580000 SR @0,@0 0657 38590000 IC @0,532(0,@B) 0657 38600000 AR @F,@0 0657 38610000 STC @F,532(0,@B) 0657 38620000 * R4=R4+1; /* POINT TO NEXT CHAR IN BUFFER * 38630000 AH @4,@D2 0658 38640000 * 38650000 * /***************************************************************** 38660000 * /* * 38670000 * /* DETERMINE IF END OF BUFFER HAS BEEN REACHED * 38680000 * /* * 38690000 * /***************************************************************** 38700000 * 38710000 * IF R4=>ENDINPUT /* IS THIS END OF INPUT BUFFER 38720000 * A56847 * 38730000 * THEN /* IF YES * 38740000 C @4,80(0,@B) 0659 38750000 BC 04,@9A9 0659 38760000 * DO; /* CHECK LENGTH OF LINE NO. * 38770000 * 38780000 * /************************************************************* 38790000 * /* * 38800000 * /* TEST LINE NUMBER FOR GREATER THAN SIX NUMERIC DIGIT * 38810000 * /* * 38820000 * /************************************************************* 38830000 * 38840000 * 38850000 * MAXLNGTH: 38860000 * IF DIGITCT>6 /* LINE NO. GREATER THAN 6 ? * 38870000 * THEN /* IF YES * 38880000 MAXLNGTH CLI 532(@B),6 0661 38890000 * GOTO SEPSCAN; /* SCAN FOR A SEPARATOR * 38900000 BC 02,SEPSCAN 0662 38910000 * 38920000 * /************************************************************* 38930000 * /* * 38940000 * /* DETERMINE IF THIS IS THE FIRST CHARACTER IN BUFFER * 38950000 * /* * 38960000 * /************************************************************* 38970000 * 38980000 * IF R4=INVPSAVE /* FIRST CHAR IN INPUT BUFFER * 38990000 * THEN /* IF YES * 39000000 C @4,236(0,@B) 0663 39010000 BC 07,@9A8 0663 39020000 * DO; /* TEST FOR LIST PROCESSING * 39030000 * 39040000 * /********************************************************* 39050000 * /* * 39060000 * /* DETERMINE IF THIS PROCESSING IS FOR A LIST * 39070000 * /* * 39080000 * /********************************************************* 39090000 * 39100000 * IF PFLIST='1'B /* IS THIS LIST PROCESSING * 39110000 * THEN /* IF YES * 39120000 TM 112(@B),B'10000000' 0665 39130000 * GOTO SEPSCAN; /* SCAN FOR A SEPARATOR * 39140000 BC 01,SEPSCAN 0666 39150000 * 39160000 * /********************************************************* 39170000 * /* * 39180000 * /* DETERMINE IF PROCESSING FIRST VALUE OF RANGE * 39190000 * /* * 39200000 * /********************************************************* 39210000 * 39220000 * IF RNGEVAL1='1'B /* IS THIS RANGE PROCESSING * 39230000 * THEN /* IF YES * 39240000 TM 113(@B),B'01000000' 0667 39250000 * GOTO SEPSCAN; /* SCAN FOR A SEPARATOR * 39260000 BC 01,SEPSCAN 0668 39270000 * GOTO PROMPT05; /* DETERMINE IF PARAMETER REQ * 39280000 BC 15,PROMPT05 0669 39290000 * END; /* IF NOT FIRST CHAR OF BUFFER * 39300000 * 39310000 * /************************************************************* 39320000 * /* * 39330000 * /* DETERMINE IF THIS IS THE 1ST CHARACTER OF LINE NO. * 39340000 * /* * 39350000 * /************************************************************* 39360000 * 39370000 * IF R4=DATAPTRA /* FIRST CHAR OF LINE NO. ? * 39380000 * THEN /* IF YES * 39390000 @9A8 L @1,500(0,@B) 0671 39400000 C @4,12(0,@1) 0671 39410000 * GOTO SEPSCAN; /* SCAN FOR A SEPARATOR * 39420000 BC 08,SEPSCAN 0672 39430000 * LNGTH2=DIGITCT; /* STORE LINE NO. SIZE IN PDE * 39440000 MVC 1(1,@1),532(@B) 0673 39450000 * DIGITCT=0; /* ZERO DATA COUNT * 39460000 MVI 532(@B),0 0674 39470000 * 39480000 * /************************************************************* 39490000 * /* * 39500000 * /* CHECK INPUT LINE FOR PERIOD AFTER LINE NO. * 39510000 * /* * 39520000 * /************************************************************* 39530000 * 39540000 * IF R4=>ENDINPUT /* IF AT END OF BUFFER A56847 * 39550000 * THEN /* GO TO END A56847 * 39560000 C @4,80(0,@B) 0675 39570000 * GOTO RANGECK; /* OF STATEMENT A56847 39580000 * PROCESSING A56847 * 39590000 BC 10,RANGECK 0676 39600000 * IF COMBUF='4B'X /* PERIOD AFTER LINE NO. * 39610000 * THEN /* IF YES * 39620000 CLI 0(@4),X'4B' 0677 39630000 * GOTO BUMP1; /* CHECK NEXT CHARACTER * 39640000 BC 08,BUMP1 0678 39650000 * GOTO RANGECK; /* SET UP RANGE PROCESSING * 39660000 BC 15,RANGECK 0679 39670000 * END; /* IF END OF BUFFER NOT REACHED * 39680000 * 39690000 * /***************************************************************** 39700000 * /* * 39710000 * /* HAS THE END OF A STATEMENT BEEN REACHED ? * 39720000 * /* * 39730000 * /***************************************************************** 39740000 * 39750000 * IF COMBUF=';' /* INPUT LINE EQUAL SEMICOLON * 39760000 * THEN /* IF YES * 39770000 @9A9 CLI 0(@4),C';' 0681 39780000 * GOTO MAXLNGTH; /* CHECK LENGTH OF LINE NO. * 39790000 BC 08,MAXLNGTH 0682 39800000 * GOTO NUMCK1; /* TEST FOR NUMERIC CHARACTER * 39810000 BC 15,NUMCK1 0683 39820000 * /***************************************************************** 39830000 * /* THE STRPGMID ROUTINE SILL SCAN THE INPUT LINE TO ENSURE THAT * 39840000 * /* A PROGRAM ID PRECEEDS A LINE NUMBER. THIS MUST BE DONE IN * 39850000 * /* ORDER TO ENSURE THAT THE PARAMETER IS INDEED A STATEMENT * 39860000 * /* NUMBER OR SHOULD BE PARSED ON THE NEXT PCE. IF A VALID PGMID * 39870000 * /* IS FOUND, FOLLOWED BY A NUMERIC, THE PARAMETER IS ASSUMED * 39880000 * /* TO BE A STATEMENT NUMBER. IF THE INPUT LINE DOES NOT CONTAIN * 39890000 * /* A PGMID.NUMERIC, THE PARAMETER (STATEMENT NUMBER) IS ASSUMED * 39900000 * /* MISSING AND THE PROMPT ROUTINE WILL BE ENTERED TO EITHER * 39910000 * /* PROMPT THE USER WITH THE "ENTER ..." MESSAGE OR IF NOT * 39920000 * /* REQUIRED, GO THE PROCESS THE PARAMETER ON THE NEXT PCE * 39930000 * /***************************************************************** 39940000 * STRPGMID: /* SCAN FOR VALID DATANAME * 39950000 * FIRSTNAM='0'B; /* INITIALIZE SWITCH USED IN SCAN* 39960000 STRPGMID NI 537(@B),B'01111111' 0684 39970000 * DIGITCT=DIGITCT+1; /* INITIALIZE DIGITCOUNT - THE 39980000 * FIRST CHAR WAS FOUND TO BE 39990000 * ALPHABETIC * 40000000 LA @F,1 0685 40010000 SR @0,@0 0685 40020000 IC @0,532(0,@B) 0685 40030000 AR @F,@0 0685 40040000 STC @F,532(0,@B) 0685 40050000 * CHK: /* CHECK OTHER CHARS FOR VALIDITY* 40060000 * R4=R4+1; /* UPDATE TO NEXT CHARACTER * 40070000 CHK AH @4,@D2 0686 40080000 * IF R4=>ENDINPUT /* IF AT END OF BUFFER, THIS * 40090000 * THEN /* IS NOT A STATEMENT NUMBER * 40100000 C @4,80(0,@B) 0687 40110000 * GOTO REJECT; /* CONSIDER JUST LIKE INVALID 40120000 * FIRST CHARACTER * 40130000 BC 10,REJECT 0688 40140000 * IF COMBUF=';' /* IF INPUT POINTING TO SEMI * 40150000 * THEN /* TREAT JUST LIKE * 40160000 CLI 0(@4),C';' 0689 40170000 * GOTO REJECT; /* EOB * 40180000 BC 08,REJECT 0690 40190000 * IF FIRSTNAM='1'B /* IF FIRST NAME SWITCH ON WE * 40200000 * THEN /* ARE LOOKING AT WHAT SHOULD * 40210000 TM 537(@B),B'10000000' 0691 40220000 BC 12,@9A7 0691 40230000 * DO; /* BE A NUMERIC * 40240000 * FIRSTNAM='0'B; /* TURN CONTROL SWITCH OFF * 40250000 NI 537(@B),B'01111111' 0693 40260000 * GOTO NUMERCK; /* GO MAKE SURE NUMERIC FOLLOWS * 40270000 BC 15,NUMERCK 0694 40280000 * END; /* WHAT APPEARED TO BE A VALID 40290000 * PGMID PART OF A STATEMENT 40300000 * NUMBER - IF NOT NUMERIC, WILL 40310000 * ASSUME STATEMENT NUMBER WAS 40320000 * NOT ENTERED * 40330000 * IF DIGITCT>8 /* IF MORE THAN EIGHT CHARS * 40340000 * THEN /* SCANNED IS NOT A PGMID * 40350000 @9A7 CLI 532(@B),8 0696 40360000 * GOTO REJECT; /* PORTION OF A STATEMENT NUMBER 40370000 * CONSIDER THE STATEMENT NUMBER 40380000 * NOT ENTERED * 40390000 BC 02,REJECT 0697 40400000 * ADDCDE=8; /* IF STILL IN PGMID SCAN GO * 40410000 LA @F,8 0698 40420000 * R1='D0'X; /* TO TYPETEST TO SEE IF VALID * 40430000 LA @1,X'D0' 0699 40440000 * CALL LINKRET; /* CHAR FOR A PGMID * 40450000 BAL @E,LINKRET 0700 40460000 * GOTO PERCHK; /* IF NOT VALID, CHECK FOR PERIOD* 40470000 BC 15,PERCHK 0701 40480000 * GEN; /* GENERATE PROPER BRANCHES * 40490000 BC 15,STRPGMID IF VALID, CONTINUE CHECK 40500000 DS 0H 40510000 * PERCHK: /* CHECK - MAKE SURE INVALID 40520000 * CHAR IS A PERIOD * 40530000 * IF COMBUFª='4B'X /* IF NOT PERIOD, IS NOT A VALID * 40540000 * THEN /* PGMID, DONSIDER THE STATEMENT * 40550000 PERCHK CLI 0(@4),X'4B' 0703 40560000 * GOTO REJECT; /* NUMBER MISSING * 40570000 BC 07,REJECT 0704 40580000 * FIRSTNAM='1'B; /* INDICATE NUMERIC MUST FOLLOW * 40590000 OI 537(@B),B'10000000' 0705 40600000 * GOTO CHK; /* GO CHECK FOR VALID CHARACTER * 40610000 BC 15,CHK 0706 40620000 * NUMERCK: /* MAKE SURE NUMERIC AFER PGMID * 40630000 * R1='10'X; /* PLACE NUMERIC MASK IN R1 * 40640000 NUMERCK LA @1,X'10' 0707 40650000 * ADDCDE=8; /* FOR TYPETEST * 40660000 LA @F,8 0708 40670000 * CALL LINKRET; /* CHECK FOR NUMERIC * 40680000 BAL @E,LINKRET 0709 40690000 * GOTO REJECT; /* IF +0 - NOT NUMERIC - CONSIDER 40700000 * THAT THE PARAMETER IS NOT 40710000 * A STATEMENT NUMBER * 40720000 BC 15,REJECT 0710 40730000 * DATAPTR=INVPSAVE; /* IF NUMERIC, PARAMETER IS A 40740000 * STATEMENT NUMBER - FILL IN 40750000 * PDE WITH POINTER TO PGMID 40760000 * PORTION OF STATEMENT NUMBER * 40770000 L @1,500(0,@B) 0711 40780000 MVC 8(4,@1),236(@B) 0711 40790000 * LNGTH1=DIGITCT; /* FILL IN LENGTH OF PGMID * 40800000 MVC 0(1,@1),532(@B) 0712 40810000 * DIGITCT=0; /* ZERO DIGIT COUNT * 40820000 MVI 532(@B),0 0713 40830000 * DATAPTRA=R4; /* FILL IN POINTER TO LINE 40840000 * NUMBER IN PDE * 40850000 L @1,500(0,@B) 0714 40860000 ST @4,12(0,@1) 0714 40870000 * GOTO NUMCK2; /* GO TO SCAN REST OF STATEMENT 40880000 * NUMBER BEGINNING WITH 2ND 40890000 * CHAR OF LINE NUMBER * 40900000 BC 15,NUMCK2 0715 40910000 * REJECT: /* PARAMETER NOT A VALID STATE- 40920000 * MENT NUMBER - MUST PARSE ON 40930000 * NEXT PCE * 40940000 * FIRSTNAM='0'B; /* SET CONTROL SWITCH OFF * 40950000 REJECT NI 537(@B),B'01111111' 0716 40960000 * DIGITCT=0; /* REINITIALIZE ALL FIELDS USED * 40970000 MVI 532(@B),0