EXT TITLE 'DMSEXT (CMS) VM/370 - RELEASE 6' 00001000
* 00002000
* MODULE NAME - 00003000
* 00004000
* DMSEXT (EXECTOR) 00005000
* 00006000
* FUNCTION - 00007000
* 00008000
* PERFORM PROCESSING ASSOCIATED WITH 'EXEC' COMMAND. 00009000
* 00010000
* ATTRIBUTES - 00011000
* 00012000
* REENTRANT, SEGMENT RESIDENT 00013000
* 00014000
* ENTRY POINTS - 00015000
* 00016000
* DMSEXT 00017000
* 00018000
* ENTRY CONDITIONS - 00019000
* 00020000
* AT ENTRY, R1 POINTS TO THE 'EXEC' PLIST: 00021000
* 00022000
* DC CL8'EXEC' 00023000
* DC CL8'FILE-NAME' 00024000
* DC CL8'OPTION1', ... 00025000
* DC XL8'FF' 00026000
* 00027000
* EXIT CONDITIONS - 00028000
* 00029000
* NORMAL - 00030000
* REG 15 CONTAINS THE RETURN CODE OF 0. 00031000
* 00032000
* ERROR - 00033000
* RC = 28: FILE NOT FOUND 00034000
* RC = 32: ERROR ENCOUNTERED IN PROCESSING EXEC COMMANDS: 00035000
* FILE NOT FIXED FORMAT 00036000
* 801-FILE NOT FOUND 00036500
* 802-&SKIP OR &GOTO ERROR 00037000
* 803-BAD FILE FORMAT-NOT IN EXEC GUIDE 00038000
* 804-TOO MANY ARGUMENTS 00039000
* 805-MAX DEPTH OF LOOP NESTING EXCEEDED 00040000
* 806-RDBUF OR WAITRD ERROR DISK OR TERM ERROR 00041000
* 807-INVALID SYNTAX 00042000
* 808-INVALID FORM OF CONDITION 00043000
* 809-INVALID ASSIGNMENT 00044000
* 810-MISUSE OF SPECIAL VARIABLE 00045000
* 811-ERROR IN &ERROR ACTION 00046000
* 812-CONVERSION ERROR 00047000
* 813-TOO MANY TOKENS IN STATEMENT 00048000
* 814-MISUSE OF BUILT-IN FUNCTION 00049000
* 815-EOF FOUND IN LOOP 00050000
* 816-INVALID CONTROL WORD 00051000
* 817-EXEC ARITHMETIC UNDERFLOW NEW VM02322 00052000
* 818-EXEC ARITHMETIC OVERFLOW NEW VM02322 00053000
* 819-INVALID CHARACTER IN VARIABLE SYMBOL 00053500
* 00054000
* 00055000
* CALLS TO OTHER ROUTINES - 00056000
* 00057000
* DMSINM -- TO DETERMINE THE TIME OF DAY 00058000
* 00059000
* DMSBRD -- TO READ FROM THE EXEC FILE 00060000
* 00061000
* DMSFNS -- TO CLOSE THE EXEC FILE 00062000
* 00063000
* DMSCWR -- TO TYPE A LINE ON THE TERMINAL 00064000
* 00065000
* DMSCRD -- TO READ A LINE FROM THE TERMINAL 00066000
* 00067000
* DMSCAT -- TO HANDLE THE &STACK FUNCTION 00068000
* 00069000
* DMSSTT -- TO DETERMINE THE EXISTENCE OF THE EXEC FILE 00070000
* 00071000
* DMSPNT -- TO OPEN THE EXEC FILE 00072000
* 00073000
* DMSCWT -- TO WAIT FOR TERMINAL OUTPUT TO COMPLETE. 00074000
* 00075000
* DMSCIO -- TO PUNCH A CARD 00076000
* 00077000
* EXTERNAL REFERENCES - 00078000
* 00079000
* NONE 00080000
* 00081000
* TABLES / WORKAREAS - 00082000
* 00083000
* CONTAINS A DSECT, CALLED 'FREEST', WHICH IS DESCRIBED IN 00084000
* NOT BY A MACRO. SPACE FOR THE WORKAREA DESCRIBED BY THI 00085000
* DSECT IS ALLOCATED BY A CALL TO DMSFREE. 00086000
* 00087000
* REGISTER USAGE - 00088000
* 00089000
* R2 = PLIST POINTER 00090000
* R7 = INTERNAL LINK REGISTER 00091000
* R10 = INTERNAL LINK REGISTER 00092000
* R11 AND R12 = BASE REGISTERS 00093000
* R13 -> TO FREEST WORK AREA 00094000
* 00095000
* NOTES - 00096000
* 00097000
* NONE 00098000
* 00099000
* OPERATION - 00100000
* 00101000
* EXECUTABLE STATEMENTS ARE INTERPRETED, ONE AT A TIME, AC 00102000
* ING TO THE FOLLOWING STEPS. 00103000
* 00104000
* EXCEPT FOR THOSE COMMANDS THAT TAKE A 'LINE' (AN 00105000
* ARBITRARY, UNSUBSTITUTED, COLLECTION OF WORDS) AS 00106000
* ARGUMENT, THE WORDS FORMING A STATEMENT ARE 00107000
* 'TOKENIZED'. THAT IS, EACH WORD IS TREATED AS AN 00108000
* EIGHT-BYTE QUANTITY AND IS PADDED WITH BLANKS OR 00109000
* TRUNCATED, AS NECESSARY. 00110000
* 00111000
* THE TOKENS ARE SEARCHED FOR THE NAMES OF ANY EXEC 00112000
* VARIABLE, WHICH ARE REPLACED BY THEIR VALUES. THE 00113000
* IS AN EXCEPTION IF THE TOKEN IS THE TARGET OF AN 00114000
* ASSIGNMENT: IN THIS CASE THE NAME OF THE VARIABLE 00115000
* IS RETAINED. 00116000
* 00117000
* IF AT THIS POINT THE TOKEN IS ENTIRELY BLANK, IT I 00118000
* DISCARDED FROM THE STATEMENT, SO THAT THE NEXT TOK 00119000
* IS DEEMED IMMEDIATELY TO FOLLOW THE PREVIOUS ONE. 00120000
* 00121000
* THE STATEMENT IS ANALYZED SYNTACTICALLY, AND EXECU 00122000
* ACCORDING TO THE FOLLOWING RULES: 00123000
* 00124000
* NULL STATEMENT -- NOTHING TO DO 00125000
* 00126000
* CMS COMMANDS -- IT IS EXECUTED BY PASSING IT AS A PLIST 00127000
* CMS BY EXECUTING SVC 202. 00128000
* The address of the command's parameter list is HRC309DS 00128050
* passed in R1. The high order byte of R1 is HRC309DS 00128100
* set to one of the following values: HRC309DS 00128150
* x'0D' &CONTROL CMS or &CONTROL ALL is in HRC309DS 00128200
* effect. (No change from VM/370 R6.) HRC309DS 00128250
* x'01' &CONTROL OFF is in effect. (This is as HRC309DS 00128300
* a call from EXEC 2 or REXX.) HRC309DS 00128350
* The CMS commands ERASE (DMSERS) LISTFILE HRC309DS 00128400
* (DMSLST), RENAME (DMSRNM) and STATE (DMSSTT) HRC309DS 00128450
* control what messages they emit based on the HRC309DS 00128500
* setting of this flag byte. HRC309DS 00128550
* HRC309DS 00128600
* The address of the command's extended paramter HRC309DS 00128650
* list (the untranslated, untokenized command HRC309DS 00128700
* string) is passed in R0. HRC309DS 00128750
* 00129000
* ASSIGNMENT STATEMENTS -- THE EXPRESSION IS COMPUTED, AND 00130000
* VALUE IS ASSIGNED TO THE SPECIFIED VARIABLE. 00131000
* 00132000
* CONTROL STATEMENTS (&GOTO, &EXIT, &IF) -- THE APPROPRIAT 00133000
* FUNCTION IS EXECUTED. 00134000
* 00135000
* COMMENT STATEMENTS (WHICH BEGIN WITH AN ASTERISK) -- NOT 00136000
* TO DO. 00137000
* 00138000
EJECT 00139000
* DMSEXT IS NOW REENTRANT WITH THE INCLUSION OF AN UPDATED 00140000
* NUCLEUS WHICH INCLUDES A COMMON SVC 202. 00141000
*. 00142000
EJECT 00143000
PUNCH 'SPB' @VM03178 00144000
DMSEXT START 0 P0816 00145000
EXECTOR EQU * 00146000
LR BASE,R15 00147000
USING EXECTOR,BASE,BASE1 00148000
USING FREEST,BFREE 00149000
USING NUCON,R0 00150000
B STRTCODE LET PUT IN AN IDENTIFIER @VA05520 00151000
DC C'DMSEXT30' EYECATCHER IN CORE DUMPS @VA05520 00152000
STRTCODE EQU * @VA05520 00153000
LA BASE1,4095(,BASE) 00154000
LA BASE1,1(,BASE1) 00155000
SPACE 2 00156000
LR PTR,R1 P LIST PTR IN 2 00157000
LR R3,R14 RETURN IN FREE STORAGE 00158000
USING OPSECT,R9 @V305614 00159000
L R9,AOPSECT POINT TO OPSECT IN NUCLEUS @V305614 00160000
L R1,EXADD+4 GLOBAL ADR IF NESTED EXEC @V305614 00161000
LA R6,ONE IF EXEC RECURSION @V305666 00162000
L R4,EXLEVEL LEVEL IS GREATER @V305614 00163000
CR R6,R4 THAN 1 DON'T DISTURB @V305614 00164000
BL SKGLBL GLOBALS @V305614 00165000
SPACE 1 00166000
LA R0,SEVDWS GET 7 DOUBLEWORDS @V305666 00167000
DMSFREE DWORDS=(0),TYPCALL=BALR OF FREE STORAGE @VM03083 00168000
* FOR GLOBALS 00169000
SPACE 1 00170000
USING XGLBL,R1 @V305614 00171000
MVC GLOBAL(55),INITFREE INITIALIZE GLOBALS @V305614 00172000
ST R1,EXADD+4 SAVE GLOBAL STORAGE ADDRESS @V305614 00173000
SPACE 1 00174000
SKGLBL AP GLOBAL(5),DECONE(1) INCREASE RECURSION LEVEL @V305614 00175000
DROP R1,R9 @V304514 00176000
LA R0,NEED NO. OF DOUBLE WORDS FOR FREE 00177000
DMSFREE DWORDS=(0),TYPCALL=BALR ... @VM03083 00178000
SSM ON ENABLE FOR INTERRUPTS @VA04297 00179000
LR BFREE,R1 BASE FOR FREEST AREA 00180000
SR R9,R9 CLEAR FREE STORAGE @V305614 00181000
LR R6,R1 OBTAINED THROUGH @V305614 00182000
LA R7,8*NEED MVCL @V305614 00183000
MVCL R6,R8 ..... @V305614 00184000
SPACE 1 00185000
MVC TIMBUF(FOUR8),FREECON INITIALIZE SOME OF IT @VA06278 00186000
MVC STACKLST(12),ATTNFIFO MIGHT AS WELL @V305614 00187000
MVC CARDPCH(8),CARDPH INITIALIZE THESE NOW @V305614 00188000
MVC POINT(8),POINTC ...... @V305614 00189000
LA R6,ONE INITIALIZE POINT @V305666 00190000
STH R6,PPTR READ POINTER @V305614 00191000
LA R7,4095(,BASE1) NOW SAVE THE ADDRESS OF @VM03209 00192000
LA R7,1(,R7) ..... @VM03209 00193000
ST R7,ASUBSTIT THE SUBSTITUTE RTN IN FREEST @VM03209 00194000
USING SUBSTIT,R7 HRC309DS 00194100
LA R7,EPLBUILD get address of EPLIST code HRC309DS 00194200
DROP R7 HRC309DS 00194300
ST R7,AEPLBLD save its address HRC309DS 00194400
SPACE 1 00195000
STM R3,R5,SAVRET SAVE RETURN,SYSREF & R5 @V305614 00196000
LR R7,PTR PARM LIST POINTER INTO R7 00197000
MVI TFLAG,TYPCMS+TYPPAC SET TYPEOUT TO CMS, PACK 00198000
MVC TYPINPUT(16),ABCD SET UP WAITRD PLIST 00199000
ZAP LINENUM(4),DECZERO(1) INITIALISE LINE NO TO 0 00200000
MVC CMSTIME(8),=CL8'CMSTIME ' SET UP CMSTIME PLIST 00201000
MVC TYPLIN(8),TYPLIST SET UP TYPLIN PLIST 00202000
MVC DSKLIN(40),SETDSK SET UP RDBUF PLIST 00203000
MVC FNAME(8),8(PTR) PUT FILE NAME IN DSK PLIST 00204000
MVC ARGTABLE(8),8(PTR) AND INTO &0 00205000
MVC EXEC(8),8(PTR) 00206000
MVI HEXSW,HEX00 HEX CNVRT OFF INITIALLY @VA04294 00207000
SPACE 2 00208000
MVC PBUFF,=4C'*' TELL 'STATE' NO '*'S... @VM08647 00209000
LA R1,DSKLIN ... 00210000
LR R5,R14 SAVE RETURN ADDRESS @VM03209 00211000
L R15,ASTATE GET DMSSTT ADDRESS @VM03093 00212000
BALR R14,R15 AND SEE IF FILE EXISTS @VM03093 00213000
STATCKLR LR R14,R5 RESTORE RETURN REGISTER @VM03209 00214000
LTR R15,R15 CHECK RC FROM 'STATE' @V305614 00215000
BZ FOUND NO PROBLEM @VM08647 00216000
CH R15,=H'28' @VM08647 00217000
BE NOFILE FILE NOT FOUND @VM08647 00218000
LR R7,R15 OTHERWISE, SOME OTHER PROBLE@VM08647 00219000
B CLOSE2 EXIT WITH 'STATE' RC... @VM08647 00220000
FOUND EQU * SUCH A FILE, ALREADY @VM08647 00221000
L R5,FSTLOC GET PTR TO FILE STATUS TABLE 00222000
MVC PFLAG,FFORM(R5) SAVE FORMAT IN PLIST @V305604 00223000
CLC FSIZE(2,R5),=H'130' IS LENGTH > 130 ? @V305604 00224000
BH BADSIZ YES, DON'T ALLOW IT @V305604 00225000
MVC PREVEXEC(8),LASTEXEC 00226000
MVC LASTEXEC(8),8(PTR) 00227000
MVC PMODE(2),FMODE(R5) ALSO SAVE FILEMODE 00228000
LA R3,UNSCND ADDRESS OF INPUT BUFFER 00229000
ST R3,PBUFF SET BUFF ADDRESS FOR DISK CALL 00230000
SPACE 2 00231000
LR R5,R3 00232000
O R5,TYRD2 SET CONSOLE AND ADDRESS FOR WAITRD 00233000
ST R5,TYRD2 00234000
ZAP RETCODE(5),DECZERO(1) @VA03453 00235000
LA PTR,16(,PTR) POINT TO ARGS 00236000
LA R14,ALLIN 00237000
SPACE 1 00238000
SETARGS EQU * 00239000
MVI ARGTABLE+8,C' ' BLANK OUT ARGS 00240000
MVC ARGTABLE+9(ARGSIZE-9),ARGTABLE+8 00241000
LA R5,ARGTABLE+8 00242000
LA R6,8 00243000
ZAP INDEX(4),DECZERO(1) SET NO. OF ARGS = 0 00244000
LA R7,ARGEND 00245000
TBLSET CLI 0(PTR),X'FF' END OF PLIST? 00246000
BCR 8,R14 00247000
CR R5,R7 00248000
BH ERRARGS BRANCH IF TOO MANY ARGUMENTS 00249000
AP INDEX(4),DECONE(1) 00250000
CLC 0(2,PTR),=CL2'% ' IS IT THE IGNORE ARG? P0816 00251000
BE *+10 00252000
MVC 0(8,R5),0(PTR) MOVE IN ARGUMENT 00253000
AR R5,R6 00254000
AR PTR,R6 00255000
B TBLSET 00256000
SPACE 1 00257000
ALLIN L R8,ASCANO 00258000
ST R8,SCNPTR 00259000
MVC PITEM(2),=H'1' SET TO KEEP COUNT OF ITEM NO. 00260000
SPACE 00261000
BAL RET,TIMSETA DO THE INITIAL RESET OF CPU TIMES 00262000
EJECT 00263000
LOOP EQU * MAIN LOOP FOR NEXT LINE OF FILE 00264000
TM STCKFLAG,HEXF0 WITHIN '&BEG..' SECTION ? @VM03208 00265000
BNZ LINEREAD BRANCH IF SO (DON'T TEST FOR LOOP END) 00266000
TM VSAMFLG1,VIPINIT OS VSAM PROGRAM FINISH? @V305106 00267000
BZ GETITEM IF NOT, CONTINUE TO READ @V305106 00268000
TM SUBFLAG,X'01' TEST FOR SUBSET @VA08831 00268100
BO GETITEM YES THEN DON'T FREE VSAM @VA08831 00268200
LA R1,GETITEM IF SO, FIRST IGNORE ERRS @V305106 00269000
ST R1,ERR$202 FOR THIS SVC CALL... @V305106 00270000
LA R1,VSRLIST GET READY TO CALL DMSVSR @V305106 00271000
LR R8,R14 SAVE R14 CONTENTS @V305106 00272000
BAL R14,SVC$202 CALL TO CLEANUP VSAM @V305106 00273000
LR R14,R8 RESTORE R14 CONTENTS @V305106 00274000
GETITEM EQU * @V305106 00275000
LH R8,PITEM FILE ITEM NO. TO BE READ 00276000
LTR R8,R8 TEST IT 00277000
BNH SKPERR BRANCH IF -VE (ERROR) 00278000
NI ERACT,X'0F' TURN OFF ERROR ACTION FLAG 00279000
L R9,READCNT WILL WE BE READING FROM CONSOLE? 00280000
LTR R9,R9 00281000
BH LINEREAD BRANCH IF SO (DON'T LOOK FOR LOOP END) 00282000
CLC GOSTOP(2),ZERO ARE WE LOOKING FOR A LABEL FOR &GOTO? 00283000
BNE LINEREAD BRANCH IF SO 00284000
TM CONTFLAG,X'F0' ARE WE SCANNING THE RANGE OF A LOOP? 00285000
BNZ LINEREAD BRANCH IF SO 00286000
LH R6,LOPLEVEL GET LOOP LEVEL 00287000
LTR R6,R6 TEST IT 00288000
BZ LINEREAD BRANCH IF ZERO (NOT IN A LOOP) 00289000
BCTR R6,0 FIDDLE IT FOR DUMMY BASE 00290000
SLA R6,1 00291000
CH R8,SCOPEBEG(R6) COMPARE THIS ITEM NO. WITH... 00292000
BL DESTROY TOP OF LOOP RANGE, AND BRANCH IF ABOVE 00293000
CH R8,SCOPEND(R6) SIMILARLY COMPARE IT WITH BOTTOM OF... 00294000
BH DESTROY LOOP RANGE, AND BRANCH IF BELOW 00295000
BL LINEREAD GO READ LINE IF SAFELY INSIDE LOOP 00296000
LR R8,R6 LOOP BASE INTO R8 00297000
SLA R8,1 SHIFT FOR FULLWORD ENTRY 00298000
L R7,LOOPCNT(R8) NO. OF TIMES WE HAVE TO LOOP 00299000
LTR R7,R7 TEST IT 00300000
BL CONDCHK BRANCH IF -VE (SIGNALS END BY CONDITION) 00301000
SH R7,=H'1' SUBTRACT ONE 00302000
BL DESTROY BRANCH IF WE'VE FINISHED 00303000
ST R7,LOOPCNT(R8) SAVE THE NO. STILL LEFT TO DO 00304000
B ITERATE AND TURN, TURN, TURN... 00305000
CONDCHK EQU * TEST CONDITION 00306000
LR R8,R6 00307000
MH R8,=H'14' FIDDLE BASE FOR LOOP CONDITION 00308000
LA R7,LOOPCOND(R8) ITS ADDDRESS 00309000
BAL RET,SETUP SET VALUES OF READFLAG AND TYPEFLAG 00310000
BAL RET,CHKALL TEST THE CONDITION 00311000
BNZ ITERATE BRANCH IF NOT SATISFIED ('LOOP UNTIL...') 00312000
DESTROY EQU * DESTROY THE LOOP 00313000
SRA R6,1 UNFIDDLE R6 00314000
STH R6,LOPLEVEL SAVE AS NEW LOOP LEVEL 00315000
B LOOP AND BACK FOR ANY OTHERS WE OUGHT TO CLOSE 00316000
ITERATE EQU * TURN, TURN, TURN... 00317000
LH R7,SCOPEBEG(R6) ITEM NO. FOR TOP OF LOOP 00318000
STH R7,PITEM SET IT AS NEXT LINE TO READ 00319000
EJECT 00320000
LINEREAD MVI FLAG1,HEX00 RESET MISCELLANEOUS FLAGS @VM03209 00321000
L R7,READCNT TEST READOUT @VM03209 00322000
LTR R7,R7 IS IT ZERO? 00323000
BNP LINREAD Y, READ FROM DISK 00324000
MVI CONRDFLG,X'FF' SET CONSOLE READ FLAG 00325000
BCTR R7,0 N, DECR READCNT BY 1 00326000
ST R7,READCNT 00327000
LA R1,RDERR 00328000
ST R1,ERR$202 FILL ERROR RETURN FOR SVC @V305614 00329000
LA R1,TYPINPUT N, GET PLIST FOR TYPE READ 00330000
LR R5,R14 SAVE RETURN REGISTER @VM03209 00331000
BAL R14,SVC$202 READ @V305614 00332000
LR R14,R5 RESTORE RETURN REGISTER @VM03209 00333000
LH R0,TYPINPUT+14 NO. OF CHARS READ 00334000
B LENLIN 00335000
LINREAD EQU * 00336000
MVI CONRDFLG,X'00' CLEAR CONSOLE READ FLAG 00337000
LA R1,DSKLIN READ ANOTHER CARD 00338000
LR R5,R14 SAVE RETURN REGISTER @VM03209 00339000
SSM OFF DISABLE FOR INTERRUPTS @VA05743 00340000
L R15,ARDBUF GET DMSBRD ADDRESS @VM03093 00341000
BALR R14,R15 AND GO READ @VM03093 00342000
SSM ON ENABLE FOR INTERRUPTS @VA05743 00343000
BNZ CHK12 BRANCH IF ERROR @VM03093 00344000
LR R14,R5 RESTORE RETURN REGISTER @VM03209 00345000
LH R7,PITEM UPDATE ITEM NOS. 00346000
LA R7,1(,R7) 00347000
STH R7,PITEM 00348000
L R0,PNREAD NO. OF CHARS READ 00349000
STH R0,FILWIDTH SAVE FOR LATER @V305604 00350000
CLI PFLAG,FIXED FIXED LENGTH FILE ? @V305666 00351000
BNE LENLIN NO, ALLOW FULL LENGTH @V305604 00352000
CH R0,=H'72' MORE THAN 72? 00353000
BNH LENLIN BRANCH IF NOT (ACCEPT THEM ALL) 00354000
LA R0,72 ACCEPT ONLY THE FIRST 72 00355000
LENLIN EQU * 00356000
TM STCKFLAG,HEXF0 ANY 'BEGIN' FLAGS ON ? @VM03208 00357000
BZ LENLIN2 BRANCH IF NOT 00358000
CLC UNSCND(4),EENDS CHECK FOR '&END...' 00359000
BNE *+10 SKIP IF NOT THERE 00360000
NI STCKFLAG,X'00' CLEAR STCKFLAG 00361000
BR R14 READ NEXT LINE (R14 SET FROM BEFORE) 00362000
LA PTR,UNSCND POINT TO THE UNSCANNED CARD-IMAGE 00363000
TM STCKFLAG,X'10' BEGSTACK? 00364000
BO CWSTAC2 BRANCH IF SO 00365000
TM STCKFLAG,X'20' BEGPRINT? 00366000
BO CWPRIN2 BRANCH IF SO 00367000
TM STCKFLAG,BEMSG &BEGEMSG ? @VM03208 00368000
BNO CWPUNC2 NO, MUST BE &BEGPUNCH @VM03208 00369000
LR R5,PTR SHIFT POINTERS @VM03208 00370000
LR R15,R0 AND SHIFT LENGTH REG. @VM03208 00371000
B CWTYPER1 GO TYPE ERROR MESSAGE @VM03208 00372000
SPACE 00373000
LENLIN2 EQU * HASN'T MUCH TO DO WITH LINE LENGTH 00374000
TM AFLG1,X'FF' IS IT &READ ARGS OR &READ VARS? 00375000
BNZ SCANIT BRANCH IF SO 00376000
LTR R5,R0 LENGTH OF LINE INTO R5 00377000
BZ SCANIT BRANCH IF NOTHING THERE 00378000
LR R6,R0 ALSO LENGTH IN R6 @VA07078 00379000
LA R7,UNSCND SET UP TO SEARCH FOR COMMENT OR LABEL 00380000
LA R4,1 INCREMENT 00381000
AR R5,R7 ADDR. OF CHAR BEYOND LAST TO INSPECT 00382000
BCTR R5,0 ADDR. OF LAST CHAR TO INSPECT 00383000
LENLIN3 EQU * @VA07078 00384000
CLI 0(R7),C' ' BLANK? 00385000
BNE UNSCFND BRANCH IF NOT (FOUND SOMETHING) 00386000
BCTR R6,0 KEEP COUNT OF BLANKS @VA07078 00387000
BXLE R7,R4,LENLIN3 LOOP @VA07078 00388000
B LOOP BACK FOR NEXT LINE (THIS ONE IS BLANK) 00389000
SPACE 00390000
UNSCFND EQU * FOUND A CHARACTER IN UNSCANNED LINE 00391000
CLI 0(R7),C'*' COMMENT? 00392000
BE LOOP BRANCH IF SO (BACK FOR NEXT LINE) 00393000
TM CONRDFLG,X'FF' WAS THIS LINE READ FROM CONSOLE? 00394000
BNZ SCANIT BRANCH IF SO (DON'T LOOK FOR LABEL) 00395000
CLC GOSTOP(2),ZERO ARE WE DOING A '&GOTO'? 00396000
BNE *+12 SKIP IF SO (SEE IF THIS IS IT) 00397000
TM CONTFLAG,X'F0' ARE WE SCANNING THE RANGE OF A LOOP? 00398000
BZ SCANIT BRANCH IF NOT 00399000
CLI 0(R7),C'-' IS THIS A LABEL? 00400000
BNE ITCHK BRANCH IF NOT (CHECK ITEM AGAINST GOSTOP) 00401000
LR R8,R7 GET READY TO LOOK FOR END OF LABEL 00402000
LA R9,7(,R8) SPOT TO STOP 00403000
LABLENLP EQU * 00404000
CLI 1(R8),C' ' END? 00405000
BE LABLEN BRANCH IF SO 00406000
LA R8,1(,R8) LOOK AT NEXT CHAR 00407000
BCT R6,CHECK8 MAY BE VARIABLE LENGTH @VM03247 00408000
BCTR R8,0 FORCE VALID LENGTH @VM03208 00409000
B LABLEN SKIP IF SO @VM03208 00410000
CHECK8 CR R8,R9 REACHED LENGTH EIGHT ? @VM03208 00411000
BL LABLENLP LOOP IF NOT YET 00412000
LABLEN EQU * 00413000
SR R8,R7 LENGTH-1 00414000
MVC TEMPD(8),BLANKS CLEAR TEMPD 00415000
EX R8,MOVLAB MOVE THE LABEL WE'VE FOUND INTO TEMPD 00416000
CLC TEMPD(8),GOLAB DOES IT MATCH? 00417000
BE GOTOHERE BRANCH IF SO 00418000
MVC TEMPD2,TEMPD HERE FOR SUBSTITUTE ROUTINE HRC007DS 00418100
LA R6,TEMPD2 ADDR OF LABEL TO SUBSTITUTE HRC007DS 00418200
L R15,ASUBSTIT ADDR SUBSTITUTION ROUTINE HRC007DS 00418300
BALR RET,R15 GOTO ROUTINE HRC007DS 00418400
MVC TEMPD,TEMPD2 REPLACE FOR OTHER ROUTINES HRC007DS 00418500
CLC TEMPD(8),GOLAB DOES IT MATCH HRC007DS 00418600
BE GOTOHERE YES.... HRC007DS 00418700
ITCHK EQU * CHECK WHETHER DUD GOTO 00419000
CLC PITEM(2),GOSTOP IS THIS THE LIMIT? 00420000
BNE LOOP BRANCH IF NOT (CARRY ON LOOKING) 00421000
SPACE 00422000
SKPERR EQU * &SKIP OR &GOTO ERROR 00423000
LA R10,ERRGOTO SET THINGS UP 00424000
B LEAVE AND LEAVE THIS LEVEL OF EXECUTION 00425000
SPACE 00426000
MOVLAB MVC TEMPD(*-*),0(R7) 00427000
SPACE 00428000
GOTOHERE EQU * FOUND WHAT WE WANTED 00429000
LH R6,LOPLEVEL GET LOOP LEVEL 00430000
CLC GOSTOP(2),ZERO WAS IT A &GOTO WE WERE DOING? 00431000
BNE CLRGOTO BRANCH IF SO (GO CLEAR GOTO FLAG) 00432000
NI CONTFLAG,X'00' CLEAR CONTFLAG 00433000
BCTR R6,0 FIDDLE TO GET THE ADDRESS OF... 00434000
SLA R6,1 SCOPEND ETC. 00435000
LH R8,PITEM FILE ITEM NO. 00436000
STH R8,SCOPEND(R6) AND SAVE AS END OF LOOP RANGE 00437000
B LOOP NOW WE CAN START EXECUTING THE LOOP 00438000
SPACE 00439000
CLRGOTO EQU * 00440000
XC GOSTOP(2),GOSTOP CLEAR LABEL SEARCH STOP SPOT 00441000
LEFTLOOP EQU * CHECK ON ANY LOOPS JUMPED OUT OF 00442000
LTR R6,R6 TEST LOOP LEVEL 00443000
BZ SCANIT BRANCH OUT IF ZERO 00444000
BCTR R6,0 DECREMENT LOOP DEPTH 00445000
SLA R6,1 FIDDLE BASE 00446000
LH R8,PITEM GET NO. OF NEXT LINE TO READ 00447000
CH R8,SCOPEBEG(R6) ARE WE ABOVE CURRENT LOOP? 00448000
BNH DESTROY1 BRANCH IF SO (DESTROY LOOP) 00449000
CH R8,SCOPEND(R6) ARE WE BELOW BOTTOM OF LOOP? 00450000
BNH SCANIT BRANCH IF NOT (CARRY ON) 00451000
DESTROY1 EQU * DESTROY THE LOOP 00452000
SRA R6,1 UNFIDDLE R6 00453000
STH R6,LOPLEVEL STORE AS NEW LOOP LEVEL 00454000
B LEFTLOOP AND CHECK FOR ANY MORE TO CLOSE 00455000
SPACE 00456000
SCANIT EQU * SCAN THE LINE 00457000
MVC RAWBUF,UNSCND save unscanned line for EPLIST HRC309DS 00457100
ST R0,RAWBUFLN and save the length HRC309DS 00457200
SR R1,R1 HRC309DS 00457300
ST R1,CMDLSTRT initialize this variable HRC309DS 00457400
LR R6,R0 SAVE LENGTH IN R6 (SCAN DESTROYS R0) 00458000
ST R0,SCANBUFF PUT LENGTH FOR SCAN TO SEE 00459000
LA R1,SCANBUFF LENGTH OF LINE FOR SCAN 00460000
L R15,SCNPTR GET ADDR OF SCAN 00461000
BALR R14,R15 GO GET A PLIST 00462000
LR R0,R6 RESTORE LENGTH INTO R0 00463000
TM AFLG1,X'FF' IS THIS &READ ARGS OR VARS? 00464000
MVI AFLG1,X'00' (CLEAR THE FLAG) 00465000
BM READVARS BRANCH IF IT'S &READ VARS 00466000
LR PTR,R1 SCAN'S BUFFER 00467000
BZ SCANNED BRANCH IF NOT &READ ARGS 00468000
BAL 14,SETARGS CALL SUBROUTINE TO DO THE WORK 00469000
B LOOP AND RETURN FOR NEXT LINE 00470000
READVARS EQU * DEAL WITH &READ VARS 00471000
LA PTR,8(,PTR) (STILL SET FROM BEFORE, AMAZINGLY) 00472000
READVAR1 EQU * HEAD OF LOOP 00473000
LA PTR,8(,PTR) LOOK AT NEXT VAR 00474000
CLI 0(PTR),X'FF' IS THERE ONE? 00475000
BE LOOP BRANCH IF ALL DONE 00476000
BAL RET,LHS GET ADDRESS OF TARGET IN R7 00477000
BH READVAR2 BRANCH IF IT'S A NUMERIC VARIABLE 00478000
CLI 0(R1),X'FF' END OF VALUE LIST? 00479000
BE READVAR3 BRANCH IF SO 00480000
MVC 0(8,R7),0(R1) MOVE VALUE INTO VARIABLE 00481000
CLC 0(2,R7),=CL2'% ' IS IT THE IGNORE ARG? P0816 00482000
BNE READVIN BRANCH IF NOT (THAT'S OK) 00483000
MVI 0(R7),C' ' CLOBBER IT 00484000
READVIN EQU * 00485000
LA R1,8(,R1) LOOK AT NEXT VALUE 00486000
B READVAR1 LOOP BACK 00487000
READVAR3 EQU * COME HERE IS AT END OF VALUE LIST 00488000
MVC 0(8,R7),BLANKS USE BLANKS 00489000
B READVAR1 LOOP BACK 00490000
READVAR2 EQU * IT'S A NUMERIC TARGET 00491000
CLI 0(R1),X'FF' AT END OF VALUE LIST? 00492000
BE ERRCONV BRANCH IF SO (SIMULATE CONV. ERROR) 00493000
MVC TEMPD(8),0(R1) MOVE VALUE INTO TEMPD 00494000
BAL R14,ASSINDX USE ASSINDX AS A PRETTY QUEER SUBROUTINE 00495000
B READVIN INCREMENT VALUE PTR AND CARRY ON 00496000
SCANNED EQU * 00497000
TM CONRDFLG,X'FF' WAS THIS LINE READ FROM CONSOLE? 00498000
BNZ SCANNED2 BRANCH IF SO 00499000
CLI 0(PTR),C'-' DOES IT START WITH A LABEL? 00500000
BNE SCANNED2 BRANCH IF NOT 00501000
LA PTR,8(,PTR) SKIP OVER THE LABEL 00502000
SCANNED2 EQU * 00503000
LH R7,PITEM SET LINENUM TO... 00504000
BCTR R7,0 ONE LESS THAN PITEM, WHICH... 00505000
CVD R7,CVDSPACE WILL BE THE NUMBER OF... 00506000
MVC LINENUM(4),CVDSPACE+4 THE CURRENT LINE 00507000
BAL RET,SETUP SET UP READFLAG AND TYPEFLAG 00508000
LA R4,BUFFER USE BUFFER WORK AREA @VA06278 00509000
MVC BUFFER(BUFSIZE-EIGHT),0(PTR) COPY THE ORIGINAL @VA08168 00509700
MVC BUFFER+TWO56(EIGHT),TWO56(PTR) STATEMENT @VA08168 00510400
LR R3,R4 00511000
SR R5,R5 CLEAR ASSIGNMENT INDICATOR 00512000
NI FLAG,X'00' CLEAR FLAG 00513000
EJECT 00514000
SPACE 2 00515000
PSCAN EQU * SCAN LINE AND SUBSTITUTE VARIABLES 00516000
MVC 0(8,R4),0(PTR) MOVE TOKEN INTO BUFFER 00517000
CLI 0(R4),X'FF' END OF LINE? 00518000
BE LABELCK BRANCH IF SO 00519000
TM FLAG,X'0F' ARE WE SCANNING '&ERROR'? 00520000
BO UPR4 BRANCH IF SO (NO SUBSTITUTION) 00521000
LR R6,R4 SET R6 FOR SUBSTIT LATER 00522000
LA R9,BUFFER USE BUFFER WORK AREA @VA06278 00523000
SPACE 00524000
IFLOOP EQU * LOOK FOR IF CLAUSES 00525000
CLC 0(4,R9),EIFXX IS THIS '&IF'? 00526000
BNE NOTIF BRANCH IF NOT 00527000
SR R15,R15 get a zero HRC309DS 00527100
C R15,CMDLSTRT been here before HRC309DS 00527200
BNE IFLOOP1 yes, so don't save it again HRC309DS 00527300
ST R9,CMDLSTRT save start of command line HRC309DS 00527400
IFLOOP1 DS 0H HRC309DS 00527500
LA R9,32(,R9) SKIP OVER CONDITION 00528000
CR R9,R4 HAVE WE GONE TOO FAR? 00529000
BL IFLOOP NO-CONTINUE IN LOOP @VA08016 00530100
BH NOTIF YES-NO MORE IFS @VA08016 00530200
NI FLAG1,X'7F' TURN OFF ASSIGNMENT FLAG @VA08016 00530300
B IFLOOP CONTINUE IN LOOP @VA08016 00530400
SPACE 00531000
NOTIF EQU * NOT AN IF CLAUSE 00532000
L R15,ASUBSTIT GET SUBSTIT ADDRESS @VM03209 00533000
BALR RET,R15 AND SUBSTITUTE ON TOKEN @VM03209 00534000
MVI LAST3LIT+3,HEX00 CLEAR LITERAL FLAG @VA04597 00535000
CLC 0(8,R4),ELITERAL IS THIS '&LITERAL'? 00536000
BNE NOTLIT BRANCH IF NOT 00537000
MVI LAST3LIT+THREE,FF SET LITERAL FLAG TO LITERAL @VA06278 00538000
MVC 0(EIGHT,R4),BLANKS MAKE TOKEN BLANK @VA06278 00539000
LA PTR,8(,PTR) BUMP UP PTR 00540000
CLI 0(PTR),X'FF' WELL, ARE WE AT END? 00541000
BNE TOKE NO NOT AT FENCE @VA06278 00542000
MVI EIGHT(PTR),FF YES - MOVE IN FENCE @VA06278 00543000
B NOTASS8 CONTINUE @VA06278 00544000
TOKE EQU * @VA06278 00545000
MVC 0(EIGHT,R4),0(PTR) REPLACE CURRENT TOKEN @VA06278 00546000
B NOTASS8 @V305604 00547000
SPACE 00548000
NOTLIT EQU * NOT '&LITERAL' 00549000
CR R4,R9 THE RIGHT PLACE FOR AN ASSIGNMENT? 00550000
BNE NOTASS BRANCH IF NOT 00551000
CLI PENULT,X'50' IS THERE A POSSIBILITY OF A VARIABLE? 00552000
BNE NOTASS BRANCH IF NOT 00553000
CLC 8(2,PTR),=CL2'= ' IS NEXT TOKEN A LITERAL '='? 00554000
BE SETASS BRANCH IF SO 00555000
CLC 0(6,PTR),EERRO IS THIS '&ERROR'? 00556000
BE ISERROR BRANCH IF SO 00557000
B NOTASS 00558000
SETASS EQU * 00559000
LR R5,R4 SET ASSIGNMENT INDICATOR 00560000
OI FLAG1,ASSNBIT AND FLAG BIT @VM03209 00561000
SETASSX EQU * 00562000
MVC 0(8,R4),PENULT USE THE PENULTIMATE SUBSTITUTION 00563000
B NOTASS8 00564000
SPACE 00565000
ISERROR EQU * 00566000
OI FLAG,X'0F' SET '&ERROR' FLAG 00567000
B UPR4 00568000
SPACE 00569000
NOTASS EQU * 00570000
LA R6,16(,R9) WHERE VARS WOULD START FOR '&READ VARS' 00571000
CR R4,R6 HOW DOES R4 COMPARE? 00572000
BL NOTASS6 BRANCH IF CANNOT BE 00573000
CLC 0(13,R9),=XL13'50D9C5C1C4404040E5C1D9E240' P0444 00574000
BNE NOTASS6 BRANCH IF NOT '&READ VARS' 00575000
CLI PENULT,X'50' DO WE HAVE A VARIABLE? 00576000
BNE ERRSYN BRANCH IF NOT (MISTAKE) 00577000
B SETASSX TREAT AS ASSIGNMENT 00578000
NOTASS6 EQU * 00579000
CLI 0(R4),C' ' BLANK? 00580000
BE UPPTR BRANCH IF SO (IGNORE IT) 00581000
NOTASS8 EQU * TRANSFER FROM NOTIF 00582000
MVC LAST3(TEN6),LAST3+EIGHT MAKE THE NEXT @VA06278 00583000
MVC LAST3+TEN6(EIGHT),BLANKS TOKEN BLANK @VA06278 00584000
CLI 0(PTR),FF AT THE FENCE @VA06278 00585000
BE NOTASGN9 YES- BYPASS @VA06278 00586000
MVC LAST3+TEN6(EIGHT),0(PTR) MOVE IN NEXT TOKEN @VA06278 00587000
NOTASGN9 EQU * @VA06278 00588000
MVC LAST3LIT(THREE),LAST3LIT+ONE AND LITERAL FLAG @VA06278 00589000
UPR4 EQU * 00590000
LA R4,8(,R4) BUMP UP THE BUFFER POINTER 00591000
LA R14,ENDOFBUF ADDRESS OF BUFFER END 00592000
CR R4,R14 ARE WE THERE? 00593000
BNL ERRBUST BRANCH IF SO (FATAL ERROR) 00594000
UPPTR EQU * 00595000
LA PTR,8(,PTR) BUMP UP THE OTHER POINTER TOO 00596000
B PSCAN DEAL WITH NEXT TOKEN 00597000
SPACE 4 00598000
LABELCK EQU * NOTHING TO DO WITH CHECKING LABELS... 00599000
* CHECK FOR &LOOP XXX CONDITION 00600000
CR R4,R3 FIRST CHECK WHETHER ANYTHING HERE AT ALL 00601000
BE LOOP BRANCH IF NOT 00602000
CLC 0(8,R9),ELOOP IS THIS A LOOP STATEMENT? 00603000
BNE NOLAB2 BRANCH IF NOT 00604000
LR PTR,R9 REMEMBER WHERE IT IS @VA04470 00605000
LA R9,32(,R9) POINT WHERE 2ND COMPARAND MAY BE 00606000
CR R4,R9 AND COMPARE WITH ADDRESS OF FENCE 00607000
BL NOLAB2 BRANCH IF DIDN'T GET THAT FAR 00608000
BH SETLOOP AND BRANCH IF WE PASSED IT (IS LOOP COND) 00609000
MVI LAST3LIT+3,X'00' SET LITERAL FLAG TO NOT LITERAL 00610000
MVC LAST3(TEN6),LAST3+EIGHT MAKE THE LAST @VA06278 00611000
MVC LAST3+TEN6(EIGHT),BLANKS TOKEN BLANK @VA06278 00612000
MVC LAST3LIT(3),LAST3LIT+1 SAME WITH LITERAL FLAGS 00613000
SETLOOP EQU * @VA06278 00614000
MVC TEN6(TWENTY4,PTR),LAST3 REPLACE WITH NON @VA09732 00615000
* SUBSTITUTED STATEMENT 00616000
EJECT 00617000
* R3 NOW POINTS TO BEGINNING OF STATEMENT IN BUFFER, R4 TO FENCE 00618000
NOLAB2 SR R4,R3 LENGTH OF EXEC STATEMENT 00619000
NOLAB3 LTR R4,R4 IS LENGTH ZERO? 00620000
BNH LOOP BRANCH IF SO (NEXT STATEMENT) 00621000
LR PTR,R3 POINT TO START OF STATEMENT 00622000
LR R6,R3 (SAME THING) 00623000
STM R3,R4,TYPLIN+8 SET UP FOR TYPEOUT 00624000
CLI 0(R6),X'50' EXEC WORD? 00625000
BNE NOTEXEC BRANCH IF DEFINITELY NOT 00626000
TM TFLAG,TYPALL IS IT '&TYPEOUT ALL'? 00627000
BNO *+8 SKIP IF NOT 00628000
BAL RET,TYPEOUT TYPE THE STATEMENT 00629000
LA R14,LOOP SET FOR 'BR R14' RETURNS 00630000
CR R3,R5 IS THIS AN ASSIGNMENT? 00631000
BE ASSIGN BRANCH IF SO 00632000
BAL RET,CWRET IS IT A CONTROL WORD OR SPECIAL VAR? 00633000
BNZ FULLNAM BRANCH IF SO (GO TO IT) 00634000
B ERRWORD BRANCH IF NOT 00635000
NOTEXEC EQU * IT'S NOT AN EXEC WORD 00636000
CLI 0(R3),C'*' DOES STATEMENT START WITH ASTERISK? 00637000
BE ERRSYN BRANCH IF SO (MISTAKE) 00638000
TM TFLAG,TYPCMS+TYPALL IS &TYPEOUT CMS OR ALL? 00639000
BZ *+8 SKIP IF NOT 00640000
BAL RET,TYPECRON TYPE COMMAND AND CHRON. TIME IF ON 00641000
MVC POINT+8(18),FNAME SET UP 'POINT' PLIST 00642000
* WE NOW USE 'POINT' TO RESET THE READ POINTER TO LINE 1, 00643000
* SO THAT IF ANYONE TRIES TO READ IT WHILE WE'RE GONE, IT WILL 00644000
* BE OK. THIS IS MUCH FASTER THAN ACTUALLY CLOSING THE FILE. 00645000
* IT WILL GET US INTO TROUBLE ONLY IF SOMEONE TRIES TO WRITE 00646000
* THE FILE WITHOUT FIRST CLOSING IT. 00647000
LA R1,POINT 00648000
LR R8,R14 SAVE RETURN REGISTER @VM03209 00649000
L R15,APOINT GET DMSPNT ADDRESS @VM03093 00650000
BALR R14,R15 AND POINT THE FILE @VM03093 00651000
ERRETPT LR R14,R8 RESTORE RETURN REGISTER @VM03209 00652000
BAL RET,TIMSET RESET CPU TIMES IF &TIME IS ON @V305614 00653000
LA R1,SVCERR 00654000
ST R1,ERR$202 FILL ERROR RETURN FOR SVC @V305614 00655000
LR R1,R3 00656000
MVC PREVCMND(8),LASTCMND 00657000
MVC LASTCMND(8),0(R1) 00658000
TM OSSFLAGS,OSRESET 00659000
BNO OSCLEAR 00660000
SVC 203 00661000
DC H'12' 00662000
MVI OSSFLAGS,X'00' 00663000
OSCLEAR EQU * 00664000
ICM R1,B'1000',=X'0D' 00665000
* ASSUMING '&CONTROL NOMSG' IS NOT IN EFFECT 00666000
TM TFLAG,NOMSG IS 'NOMSG' CURRENTLY IN EFFECT ? @VM01017 00667000
BZ *+8 NO - KEEP FLAG OF X'0D' @VM01017 00668000
ICM R1,B'1000',=X'01' yes - use x'01' instead HRC309DS 00669000
LR R8,R14 SAVE RETURN REGISTER @VM03209 00670000
SPACE 1 HRC309DS 00670100
L R15,AEPLBLD get EPLIST build routine address HRC309DS 00670200
BALR R14,R15 build EPLIST (R0 is updated) HRC309DS 00670300
SPACE 1 HRC309DS 00670400
BAL R14,SVC$202 EXECUTE @V305614 00671000
LR R14,R8 RESTORE RETURN REGISTER @VM03209 00672000
MVC PREVCMND(8),LASTCMND 00673000
RSETCMD MVC LASTCMND(8),SETDSK+16 00674000
ZAP RETCODE(5),DECZERO(1) @VA03453 00675000
SR LINK,LINK SHOW NO ERRORS 00688000
BAL RET,TIMSUB PRINT LATEST TIMES (IF &TIME IS ON) 00689000
B LOOP BACK FOR NEXT STATEMENT 00690000
SPACE 1 00691000
ASSIGN EQU * 00692000
BAL RET,LHS GET A(TARGET) 00693000
BH ASSIND BRANCH IF IT'S AN INDEX 00694000
BAL RET,RHS PUT VALUE OF RHS INTO TEMPD 00695000
MVC 0(8,R7),TEMPD MOVE LATTER INTO FORMER 00696000
BR R14 NEXT STATEMENT 00697000
ASSIND BAL RET,RHS GET VALUE OF RHS 00698000
ASSINDX LR R8,R7 (ENTER HERE FROM READVARS) 00699000
LA R7,TEMPD ADDRESS INTO R7 00700000
BAL RET,CVDBCD CONVERT TO NUMERICS 00701000
BNZ ERRCONV BRANCH IF CONVERSION ERROR 00702000
ZAP 0(5,R8),CVDSPACE(8) PUT VALUE INTO TARGET @VA02322 00703000
BO ERRCONV BRANCH IF OVERFLOW 00704000
BR R14 00705000
SPACE 3 00706000
CWLOOP EX R0,ZAPREAD ZERO READCNT 00707000
LH R8,LOPLEVEL INCREMENT LOOP LEVEL 00708000
LA R8,1(,R8) 00709000
STH R8,LOPLEVEL 00710000
LA R9,NOLOOPS DEPTH TOO GREAT? 00711000
CR R8,R9 00712000
BH ERDEPTH BRANCH IF SO 00713000
BCTR R8,0 FIDDLE TO GET OFFSET... 00714000
SLA R8,1 FOR HALFWORD ENTRIES 00715000
LH R7,PITEM CURRENT ITEM NO. 00716000
STH R7,SCOPEBEG(R8) SAVE AS LOOP SCOPE BEGINNING 00717000
CLI 8(PTR),C'-' LABEL END OR NUM OF LINES 00718000
BE LABELSET GO SET LABELEND 00719000
LA R7,8(,PTR) 00720000
BAL RET,CVDBCD GO BUILD NO 00721000
BNZ ERRCONV BRANCH IF CONVERSION ERROR 00722000
CVB R7,CVDSPACE GET BINARY NO OF LINES 00723000
AH R7,PITEM ADD TO NEXT LINE NO &.. 00724000
STH R7,SCOPEND(R8) SAVE AS LOOP SCOPE END 00725000
STH R7,PITEM AND SET AS NEXT ITEM NO. TO READ 00726000
B LABELSTA 00727000
LABELSET EQU * DEAL WITH LABEL ENDING 00728000
MVC GOLAB(8),8(PTR) FAKE IT AS A GOTO 00729000
OI CONTFLAG,X'F0' BUT MAKE A NOTE THAT IT'S REALLY LOOP 00730000
LABELSTA EQU * TEST WHETHER NO. OF TIMES OR CONDITION 00731000
SLA R8,1 ADJUST FOR FULLWORD BASE 00732000
CLI 24(PTR),X'FF' NUMBER OF TIMES? 00733000
BE NOTIMES BRANCH IF SO 00734000
SR R7,R7 ZERO 00735000
BCTR R7,0 -1 00736000
ST R7,LOOPCNT(R8) SIGNAL THAT LOOP END IS BY CONDITION 00737000
MH R8,=H'7' MAKE FAKE BASE FOR CONDITIONS 00738000
LA R8,LOOPCOND(R8) 00739000
MVC 0(24,R8),LAST3 MOVE IN CONDITION 00740000
MVC 24(3,R8),LAST3LIT AND SAME WITH LITERAL FLAGS 00741000
BR R14 GOTO LOOP 00742000
NOTIMES EQU * IT'S NO. OF TIMES 00743000
LA R7,16(,PTR) CONVERT THE NUMBER OF... 00744000
BAL RET,CVDBCD FIRST TO PACKED DECIMAL... 00745000
BNZ ERRCONV (BRANCH IF CONVERSION ERROR) 00746000
CVB R7,CVDSPACE AND THEN TO BINARY 00747000
ST R7,LOOPCNT(R8) SAVE IN LOOP DATA 00748000
BR R14 GOTO LOOP 00749000
SPACE 2 00750000
CWEXIT EQU * 00751000
LA R7,8(,PTR) GET NUM TO RETURN IF ANY 00752000
SR R8,R8 CLEAR RETURN CODE 00753000
CLI 0(R7),X'FF' ANYTHING TO RETURN? 00754000
BE CWEXIT1 BRANCH IF NOT 00755000
BAL RET,CVDBCD 00756000
BNZ ERRCONV BRANCH IF CONVERSION ERROR 00757000
CVB R8,CVDSPACE CONVERT TO BINARY 00758000
CWEXIT1 EQU * 00759000
LR LINK,R8 SET RETURN CODE 00760000
B CLOSE 00761000
SPACE 2 00762000
CWARG EQU * 00763000
LA PTR,8(,PTR) POINT TO TOKEN FOR ARG1 00764000
BAL R14,SETARGS CALL SUBROUTINE TO DO THE WORK 00765000
B LOOP 00766000
SPACE 2 00767000
CWREAD EQU * 00768000
LA R8,1 PROVISIONALLY SAY READ 1 LINE 00769000
CLI 8(PTR),X'FF' RIGHT TO ASSUME 1 LINE? 00770000
BE AREAD BRANCH IF SO 00771000
CLC 8(5,PTR),=CL5'ARGS ' IS IT 'ARGS'? 00772000
BNE CWRVAR SKIP IF NOT @V305604 00773000
OI AFLG1,X'FF' SIGNAL IT'S &READ ARGS 00774000
B AREAD 00775000
CWRVAR EQU * @V305604 00776000
CLC 8(5,PTR),=CL5'VARS ' IS IT 'VARS' 00777000
BNE CWRNUM SKIP IF NOT @V305604 00778000
OI AFLG1,X'0F' SIGNAL IT'S &READ VARS 00779000
B AREAD 00780000
CWRNUM EQU * @V305604 00781000
LA R7,8(,PTR) READY FOR CONVERSION 00782000
BAL RET,CVDBCD GET THE NUMBER 00783000
BNZ ERRCONV BRANCH IF CONVERSION ERROR 00784000
CVB R8,CVDSPACE CONVERT TO BINARY 00785000
AREAD EQU * 00786000
A R8,READCNT ADD THE NUMBER TO THAT ALREADY THERE 00787000
ST R8,READCNT SAVE THE NO. OF LINES 00788000
BCR 11,R14 BRANCH IF >= 0 (BACK FOR NEXT STMT) 00789000
SR R8,R8 SET READCNT TO ZERO 00790000
B *-8 (THIS DOES IT) 00791000
SPACE 2 00792000
CWBEGS EQU * &BEGSTACK 00793000
OI STCKFLAG,X'10' SET BEGSTACK BIT 00794000
MVI STACKLST+8,C'F' SET FOR FIFO 00795000
BEGSLP EQU * LOOP TO LOOK FOR OPTIONS 00796000
LA PTR,8(,PTR) LOOK AT NEXT OPTION 00797000
CLI 0(PTR),X'FF' END OF STATEMENT? 00798000
BCR 8,R14 RETURN IF SO 00799000
CLC 0(5,PTR),=CL5'FIFO ' IS 'FIFO' GIVEN? 00800000
BNE *+12 SKIP IF NOT 00801000
MVI STACKLST+8,C'F' RECORD THE FACT 00802000
B BEGSLP LOOK FOR NEXT OPTION 00803000
CLC 0(5,PTR),=CL5'LIFO ' IS 'LIFO' GIVEN? 00804000
BNE *+12 SKIP IF NOT 00805000
MVI STACKLST+8,C'L' RECORD THE FACT 00806000
B BEGSLP AND LOOP FOR NEXT OPTION 00807000
CLC 0(4,PTR),=CL4'ALL' IS 'ALL' GIVEN? 00808000
BNE ERRSYN BRANCH IF NOT (SYNTAX ERROR) 00809000
OI STCKFLAG,X'0F' RECORD THE FACT 00810000
B BEGSLP AND LOOP FOR NEXT OPTION 00811000
SPACE 2 00812000
CWSTAC MVI STACKLST+8,C'F' F FOR 1ST IN, 1ST OUT 00813000
CLC 8(5,PTR),=CL5'FIFO ' IS 'FIFO' GIVEN? 00814000
BE CWSTAC0 BRANCH IF SO 00815000
CLC 8(5,PTR),=CL5'LIFO ' IS 'LIFO' GIVEN? 00816000
BNE CWSTAC1 BRANCH IF NOT 00817000
MVI STACKLST+8,C'L' SET FOR LIFO 00818000
CWSTAC0 EQU * 00819000
LA PTR,8(,PTR) 00820000
CWSTAC1 EQU * STACK A SCANNED LINE IN FREE FORMAT 00821000
LA PTR,8(,PTR) POINT TO THE RIGHT PLACE 00822000
LA R5,UNSCND POINT TO THE FREE-FORMAT BUFFER 00823000
LA R15,130 TELL FREESUB HOW LONG IT MAY GO 00824000
BAL RET,FREESUB FREESUB DOES THE WORK (LEAVES R15=LEN) 00825000
B CWSTACGO 00826000
SPACE 00827000
CWSTAC2 EQU * STACK AN UNSCANNED LINE 00828000
LR 5,PTR ADDRESS OF LINE 00829000
LR R15,R0 LENGTH FROM READ 00830000
TM CONRDFLG,X'FF' WAS THIS LINE FROM CONSOLE? 00831000
BO CWSTACGO BRANCH IF SO 00832000
TM STCKFLAG,X'0F' IS THE 'ALL' OPTION IN EFFECT? 00833000
BZ CWSTACGO BRANCH IF NOT 00834000
LH R15,FILWIDTH SET IT TO THE FILE WIDTH 00835000
SPACE 00836000
CWSTACGO EQU * DO THE STACKING 00837000
ST R5,STACKLST+12 STORE ADDRESS FOR ATTN 00838000
STC R15,STACKLST+12 AND LENGTH 00839000
LA R1,STACKLST 00840000
SVC 202 00841000
BR R14 BACK TO LOOP FOR NEXT LINE 00842000
SPACE 2 00843000
* '&TIME' HAS BEEN REDEFINED AND REPLACED SO AS TO BE MORE RELIABLE 00844000
* AND TO REMOVE ITS EFFECTS ON THE TIMES PRINTED ON RETURN TO CMS 00845000
* COMMAND MODE, OR IN OTHER EXEC FILES. THIS HAS INVOLVED A REWRITE 00846000
* OF THE NUCLEUS TIMER ROUTINE 'CMSTIME' (Q.V.). '&TIME ON' NOW 00847000
* CAUSES A RESET OF THE CPU TIMES IMMEDIATELY BEFORE EVERY CMS 00848000
* COMMAND, AND THE TYPING OF THE TIMES USED (AND THE TIME-OF-DAY), 00849000
* TOGETHER WITH A FURTHER RESET, ON RETURN. '&TIME RESET' IS AN 00850000
* EXPLICIT RESET; AND '&TIME TYPE' IS AN EXPLICIT TYPING OF TIMES, 00851000
* TOGETHER WITH A RESET. 00852000
SPACE 00853000
CWTIME EQU * CODE FOR '&TIME ...' 00854000
LA PTR,8(,PTR) LOOK AT NEXT ARGUMENT 00855000
CLI 0(PTR),X'FF' END OF ARG LIST? 00856000
BE LOOP BRANCH IF SO (BACK FOR NEXT STATEMENT) 00857000
CLC 0(6,PTR),=CL6'RESET ' RESET? 00858000
BNE *+12 SKIP IF NOT 00859000
BAL RET,TIMSETA RESET TIME, EXPLICITLY 00860000
B CWTIME BACK FOR NEXT ARG 00861000
CLC 0(5,PTR),=CL5'TYPE ' TYPE? 00862000
BNE *+12 SKIP IF NOT 00863000
BAL RET,TIMSUBA PRINT TIME, EXPLICITLY 00864000
B CWTIME BACK FOR NEXT ARG 00865000
CLC 0(3,PTR),=CL3'ON ' ON? 00866000
BNE *+12 SKIP IF NOT 00867000
OI TIMFLG,TIMON SET TIMFLG 00868000
B CWTIME BACK FOR NEXT ARG 00869000
CLC 0(4,PTR),=CL4'OFF ' OFF? 00870000
BNE ERRSYN BRANCH IF NOT (MISTAKE) 00871000
NI TIMFLG,255-TIMON CLEAR TIMFLG 00872000
B CWTIME BACK FOR NEXT ARG 00873000
SPACE 00874000
TIMON EQU X'01' 00875000
SPACE 2 00876000
CWIFXX LA R6,24 USEFUL NUMBER 00877000
CR R4,R6 STATEMENT LONG ENOUGH FOR CONDITION? 00878000
BL ERRCOND BRANCH IF NOT 00879000
BH *+10 SKIP IF LARGE ENOUGH 00880000
MVC 24(8,PTR),BLANKS ADD A TOKEN OF BLANKS 00881000
LA R7,8(,PTR) ADDRESS OF CONDITIONAL PHRASE 00882000
BAL RET,CONDRET TEST IT 00883000
BCR 7,R14 NEXT STATEMENT IF NOT SATISFIED 00884000
LA R6,32 USEFUL NUMBER 00885000
AR R3,R6 BUMP UP STARTING SPOT FOR STATEMENT 00886000
SR R4,R6 ADJUST LENGTH 00887000
B NOLAB3 DEAL WITH IT 00888000
SPACE 2 00889000
CWGOTO EX R0,ZAPREAD ZERO READCNT 00890000
CLC 8(4,PTR),EEXIT+1 &GOTO EXIT? 00891000
BE CLOSE BRANCH IF SO 00892000
CLC 8(4,PTR),=C'TOP ' &GOTO TOP? 00893000
BNE GOTOLAB 00894000
LA R7,1 SET TO FIRST LINE 00895000
STH R7,PITEM STORE IT IN PLIST 00896000
BR R14 00897000
GOTOLAB CLI 8(PTR),C'-' LEGAL LABEL? 00898000
BNE GOTOLINE BRANCH IF NOT 00899000
MVC GOLAB(8),8(PTR) SAVE LABEL 00900000
MVC GOSTOP(2),PITEM SAVE STOP VALUE 00901000
BR R14 00902000
GOTOLINE EQU * MUST BE '&GOTO N' WHERE N=LINE NO. 00903000
LA R7,8(,PTR) POINT TO LINE NO. 00904000
BAL RET,CVDBCD CONVERT IT 00905000
BNZ SKPERR BRANCH IF NOT NUMERIC 00906000
CVB R8,CVDSPACE INTO R8 00907000
B SKIPX BRANCH INTO 'SKIP' ROUTINE 00908000
SPACE 2 00909000
CWSKIP LA R7,8(,PTR) GET ADDR OF SKIP VALUE 00910000
ZAPREAD XC READCNT(4),READCNT ZERO READCNT 00911000
LA R8,1 ASSUME ONE LINE 00912000
CLI 0(R7),X'FF' END OF LINE? 00913000
BE SKIP BRANCH IF SO 00914000
BAL RET,CVDBCD 00915000
BNZ SKPERR BRANCH IF CONVERSION ERROR P0816 00916000
CVB R8,CVDSPACE CONVERT TO BINARY 00917000
LTR R8,R8 TEST IT 00918000
BM SKIPNEG BRANCH IF -VE 00919000
SKIP EQU * 00920000
LH R7,PITEM NEXT ITEM NO. (ACCORDING TO OLD NOTIONS) 00921000
AR R8,R7 WHERE WE WANT TO GO NOW 00922000
SKIPX EQU * (COME HERE FROM 'GOTO', ABOVE) 00923000
C R8,=F'65535' ENSURE NEW ITEM NO. NOT TOO BIG 00924000
BH SKPERR BRANCH IF IT IS 00925000
STH R8,PITEM STORE IT 00926000
LH R6,LOPLEVEL LOOP LEVEL 00927000
SKIPLOOP EQU * (HEAD OF LOOP LOOP) 00928000
LTR R6,R6 ANY LOOPS? 00929000
BCR 8,R14 BRANCH IF NOT (BACK TO 'LOOP') 00930000
BCTR R6,0 FIDDLE FOR BASE 00931000
SLA R6,1 (MORE OF SAME) 00932000
CH R8,SCOPEND(R6) ARE WE SKIPPING BEYOND LOOP? 00933000
BCR 4,R14 BRANCH IF NOT ('BL') 00934000
SRA R6,1 SOME UNFIDDLING 00935000
STH R6,LOPLEVEL STORE NEW LOOP LEVEL 00936000
B SKIPLOOP BACK FOR MORE 00937000
SKIPNEG EQU * 00938000
BCT R8,SKIP 00939000
SPACE 2 00940000
CWERRO EQU * '&ERROR' 00941000
LA PTR,8(,PTR) POINT TO ERROR ACTION 00942000
LA R15,130 TELL FREESUB HOW LONG IT MAY BE 00943000
BAL RET,FREESUB PUT INTO FREE FORMAT 00944000
MVC ERACTION(1),CONRDFLG SAVE CONRDFLG 00945000
STC R15,ERACTION+1 SAVE LENGTH 00946000
MVC ERACTION+2(130),UNSCND SAVE ERROR ACTION LINE 00947000
BR R14 00948000
SPACE 2 00949000
CJS EQU * in memory of Chris Stephenson HRC380DS 00949100
OI TFLAG,NOMSG turn off NOMSG for EXEC 2 compat HRC380DS 00949200
CWTYPE EQU * CODE FOR '&TYPEOUT ...' 00950000
LA R7,TYPOPTZ-4 END OF LOOP 00951000
LA R6,9 INCREMENT 00952000
LA PTR,8(,PTR) INCREMENT THE ARG. POINTER 00953000
CLI 0(PTR),X'FF' ANY PARAMETERS AT ALL? 00954000
BNE TYPLOOP THERE ARE...GO SEE WHICH 00955000
MVI TFLAG,TYPCMS+TYPPAC REESTABLISH THE DEFAULTS 00956000
BR R14 RETURN 00957000
TYPLOOP EQU * HEAD OF LOOP FOR ARGS. TO '&TYPEOUT' 00958000
CLI 0(PTR),X'FF' END OF ARGS? 00959000
BCR 8,R14 RETURN IF SO 00960000
LA R5,TYPOPT START OF OPT TABLE 00961000
CLC 0(7,R5),0(PTR) IS THIS THE ONE? 00962000
BE OPTGOT BRANCH IF SO 00963000
BXLE R5,R6,*-10 LOOP THROUGH OPT TABLE 00964000
B ERRSYN BRANCH IF MATCH NOT FOUND (SYNTAX ERROR) 00965000
OPTGOT EQU * WE'VE FOUND A MATCH 00966000
NC TFLAG(1),7(R5) 'AND' THE FIRST FLAG BYTE 00967000
OC TFLAG(1),8(R5) AND 'OR' THE SECOND 00968000
LA PTR,8(,PTR) INCREMENT THE ARG. POINTER 00969000
B TYPLOOP AND LOOK AT NEXT ARG. 00970000
* 00971000
* THE BITS OF 'TFLAG' ARE USED AS FOLLOWS: 00972000
* 00973000
TYPERR EQU X'01' &TYPEOUT ERROR 00974000
TYPCMS EQU X'02' &TYPEOUT CMS (DEFAULT) 00975000
TYPALL EQU X'04' &TYPEOUT ALL 00976000
* IF NONE OF THESE BITS IS ON, &TYPEOUT IS OFF 00977000
NOMSG EQU X'08' SUPPRESS 'FILE NOT FOUND' ERR MSG @VM01017 00978000
* (FOR STATE/STATEW/ERASE/RENAME/LISTFILE) 00979000
TYPTIM EQU X'10' &TYPEOUT TIME 00980000
* IF THIS BIT IS NOT ON, IT IS &TYPEOUT NOTIME 00981000
TYPPAC EQU X'20' &TYPEOUT PACK 00982000
* IF THIS BIT IS NOT ON, IT IS &TYPEOUT NOPACK 00983000
* EQU X'40' (NOT USED) 00984000
* EQU X'80' (NOT USED) 00985000
* IF THIS BIT IS NOT ON, IT IS &TYPEOUT OFF 00986000
* 00987000
* IN THE FOLLOWING TABLE, THE FIRST BYTE OF EACH HEX 00988000
* FLAG IS 'ANDED' WITH THE CURRENT VALUE OF TFLAG, AFTER 00989000
* WHICH THE SECOND BYTE IS 'ORED'. 00990000
* 00991000
TYPOPT EQU * TYPEOUT OPTIONS 00992000
DC CL7'OFF',AL1(255-(TYPERR+TYPCMS+TYPALL)),AL1(0) 00993000
DC CL7'ERROR',AL1(255-(TYPCMS+TYPALL)),AL1(TYPERR) 00994000
DC CL7'CMS',AL1(255-(TYPERR+TYPALL)),AL1(TYPCMS) 00995000
DC CL7'ALL',AL1(255-(TYPERR+TYPCMS)),AL1(TYPALL) 00996000
DC CL7'NOMSG',AL1(255),AL1(NOMSG) @VM01017 00997000
DC CL7'MSG',AL1(255-NOMSG),AL1(0) @VM01017 00998000
DC CL7'TIME',AL1(255),AL1(TYPTIM) 00999000
DC CL7'NOTIME',AL1(255-TYPTIM),AL1(0) 01000000
DC CL7'PACK',AL1(255),AL1(TYPPAC) 01001000
DC CL7'NOPACK',AL1(255-TYPPAC),AL1(0) 01002000
TYPOPTZ EQU * END OF TYPEOUT OPTIONS 01003000
SPACE 1 01004000
CWHEX EQU * @VM03234 01005000
LA PTR,8(,PTR) POINT TO NEXT COMMAND ARG @VM03234 01006000
CLC 0(8,PTR),CHOFF HEX CONVERSION OFF ? @VM03234 01007000
BE HEXOFF YES, BRANCH @VM03234 01008000
CLC 0(8,PTR),CHON HEX CONVERSION ON ? @VM03234 01009000
BE HEXON YES, BRANCH @VM03234 01010000
B ERRSYN ERROR IF ANYTHING ELSE @VA04294 01011000
SPACE 1 01012000
HEXON MVI HEXSW,FF SET HEX SWITCH ON @VM03234 01013000
B HEXOUT ..... @VM03234 01014000
SPACE 1 01015000
HEXOFF MVI HEXSW,HEX00 SET HEX SWITCH OFF @VM03234 01016000
SPACE 1 01017000
HEXOUT CLI 8(PTR),FF CAN'T BE ANYMORE @VA04294 01018000
BNE ERRSYN ..... @VM03234 01019000
BR R14 BRANCH TO LOOP @VM03234 01020000
SPACE 2 01021000
CWBEGPR DS 0H &BEGPRINT 01022000
OI STCKFLAG,X'20' SET FLAG FOR BEGPRINT 01023000
CLI 8(PTR),X'FF' ANY OPTIONS? 01024000
BCR 8,R14 RETURN IF NOT 01025000
CLC 8(4,PTR),=CL4'ALL' IS ALL GIVEN? 01026000
BNE ERRSYN BRANCH IF NOT (SYNTAX ERROR) 01027000
OI STCKFLAG,X'0F' SET 'ALL' FLAG 01028000
BR R14 RETURN 01029000
SPACE 01030000
CWPRIN EQU * PRINT A SCANNED LINE IN FREE FORMAT 01031000
LA PTR,8(,PTR) POINT TO THE RIGHT PLACE 01032000
LA R5,UNSCND POINT TO THE FREE-FORMAT BUFFER 01033000
LA R15,130 TELL FREESUB HOW LONG IT MAY GO 01034000
BAL RET,FREESUB FREESUB DOES THE WORK (LEAVES R15=LEN) 01035000
B CWPRINGO GO AND PRINT 01036000
SPACE 01037000
CWPRIN2 EQU * PRINT AN UNSCANNED LINE 01038000
LR R5,PTR ADDRESS OF LINE TO BE PRINTED 01039000
LR R15,R0 GET LENGTH FROM READ 01040000
TM CONRDFLG,X'FF' WAS LINE FROM CONSOLE? 01041000
BO CWPRINGO BRANCH IF SO 01042000
TM STCKFLAG,X'0F' WAS 'ALL' GIVEN? 01043000
BZ CWPRINGO BRANCH IF NOT 01044000
LH R15,FILWIDTH SET IT TO THE FILE WIDTH 01045000
SPACE 01046000
CWPRINGO EQU * DO THE PRINTING 01047000
MVC TYPLIN+8(8),TYPLIST+8 SET UP THE TYPLIN PLIST 01048000
O R5,TYPLIN+8 'OR' IN THE CONSOLE NUMBER 01049000
ST R5,TYPLIN+8 STORE ADDRESS OF LINE TO BE TYPED 01050000
STH R15,TYPLIN+14 AND ITS LENGTH 01051000
LA R1,TYPLIN TYPE IT 01052000
SVC 202 01053000
BR R14 BRANCH TO LOOP 01054000
SPACE 1 01055000
CWBEGERR EQU * &BEGEMSG @VM03208 01056000
OI STCKFLAG,BEMSG SET FLAG FOR BEGEMSG @VM03208 01057000
CLI 8(PTR),FF ANY OPTIONS ? @VM03208 01058000
BER R14 RETURN IF NOT @VM03208 01059000
CLC 8(4,PTR),=CL4'ALL' ALL OPTION ? @VM03208 01060000
BNE ERRSYN ERROR IF NOT @VM03208 01061000
OI STCKFLAG,HEX0F SET ALL FLAG @VM03208 01062000
BR R14 RETURN @VM03208 01063000
SPACE 1 01064000
CWTYPER EQU * EXEC ERROR MESSAGE ROUTINE @VM03208 01065000
LA PTR,8(,PTR) POINT TO MESSAGE TEXT @VM03208 01066000
LA R5,UNSCND POINT TO FREE-FORMAT BUFFER @VM03208 01067000
LA R15,130 POSSIBLE LENGTH FOR FREESUB @VM03208 01068000
BAL RET,FREESUB PREPARE FOR TYPING (R15=LEN) @VM03208 01069000
SPACE 1 01070000
CWTYPER1 MVC MSGBUFF+1(3),DMS PLUG MESSAGE PREFIX @VM03208 01071000
TM CONRDFLG,FF WAS LINE FROM CONSOLE ? @VM03208 01072000
BO CWNALL YES, BRANCH @VM03208 01073000
TM STCKFLAG,HEX0F ALL OPTION ? @VM03208 01074000
BZ CWNALL NO, BRANCH @VM03208 01075000
LH R15,FILWIDTH SET LENGTH TO MAXIMUM @VM03208 01076000
SPACE 1 01077000
CWNALL DS 0H CHECK FOR A TOO LARGE MESSAGE @VA05715 01078000
CH R15,=H'129' USER MESSAGE EXCEEDS 129 @VA05715 01079000
* CHARACTERS 01080000
BNH CWTYPER2 NO - USE ALL OF IT @VA05715 01081000
LA R15,129 TRUNCATE TO 129 @VA05715 01082000
CWTYPER2 BCTR R15,0 DECREMENT BY 1 FOR EX @VA05715 01083000
EX R15,MVERRMSG MOVE IN THE MESSAGE @VA05715 01084000
LA R15,4(,R15) ADD 3 FOR DMS AND 1 SUBTRACTED @VA05715 01085000
* FOR EX 01086000
STCM R15,LOBYT,MSGBUFF PLUG MESSAGE LENGTH @VM03208 01087000
LA R15,MSGBUFF GET MESSAGE ADDRESS @VM03208 01088000
STCM R15,AL3,ATEXT AND PLUG INTO PLIST @VM03208 01089000
MVC TPLIST(2),ERRFLGS SET DMSERR FLAGS @VM03208 01090000
LA R1,TPLIST POINT TO DMSERR PLIST @VM03208 01091000
SVC 203 TYPE MESSAGE @VM03208 01092000
DC H'-6' @VM03208 01093000
BR R14 RETURN @VM03208 01094000
SPACE 1 01095000
MVERRMSG MVC MSGBUFF+4(*-*),0(R5) @VM03208 01096000
SPACE 1 01097000
CWBEGPUN EQU * &BEGPUNCH 01098000
OI STCKFLAG,X'40' SET BEGPUNCH FLAG 01099000
CLI 8(PTR),X'FF' ANY OPTIONS GIVEN? 01100000
BCR 8,R14 RETURN IF NOT 01101000
CLC 8(4,PTR),=CL4'ALL' IS 'ALL' GIVEN? 01102000
BNE ERRSYN BRANCH IF NOT (SYNTAX ERROR) 01103000
OI STCKFLAG,X'0F' SET 'ALL' FLAG 01104000
BR R14 RETURN 01105000
SPACE 01106000
CWPUNC EQU * PUNCH A SCANNED LINE IN FREE FORMAT 01107000
LA PTR,8(,PTR) POINT TO THE RIGHT PLACE 01108000
LA R5,UNSCND POINT TO FREE-FORMAT BUFFER 01109000
LA R15,80 TELL FREESUB HOW LONG IT MAY GO 01110000
BAL RET,FREESUB FREESUB DOES THE WORK (LEAVES R15=LEN) 01111000
B CWPUNCGO GO DO THE PUNCHING 01112000
SPACE 01113000
CWPUNC2 EQU * PUNCH AN UNSCANNED LINE 01114000
LR R5,PTR ADDRESS OF LINE TO BE PUNCHED 01115000
LR R15,R0 LENGTH READ 01116000
TM CONRDFLG,X'FF' WAS LINE FROM CONSOLE? 01117000
BO CWPUNCGO BRANCH IF SO 01118000
TM STCKFLAG,X'0F' WAS 'ALL' GIVEN? 01119000
BZ CWPUNCGO BRANCH IF NOT 01120000
LH R15,FILWIDTH SET IT TO THE FILE WIDTH 01121000
SPACE 01122000
CWPUNCGO EQU * DO THE PUNCHING 01123000
LA R1,79(R5) ADDRESS OF 80TH BYTE OF BUFFER 01124000
AR R15,R5 POINT TO THE BYTE BEYOND THE LAST 01125000
CR R15,R1 HOW MANY BYTES DO WE HAVE? 01126000
BH LONGENUF BRANCH IF ALL 80 ARE THERE 01127000
MVI 0(R15),C' ' MOVE IN A BLANK 01128000
BE LONGENUF BRANCH IF THAT WAS IN THE 80TH SPOT 01129000
SR R1,R15 NUMBER OF BYTES WE HAVE TO PAD 01130000
BCTR R1,0 DECREMENT FOR EXEC 01131000
EX 1,PUNPAD PAD THEM WITH BLANKS 01132000
SPACE 01133000
LONGENUF EQU * 01134000
ST R5,EXTND STORE THE ADDRESS IN CARDPH PLIST 01135000
LA R1,CARDPCH PUNCH IT 01136000
LA R5,ERRETPCH IGNORE ERROR RETURN @V305614 01137000
ST R5,ERR$202 FILL ERROR RETURN FOR SVC @V305614 01138000
LR R5,R14 SAVE RETURN REGISTER @VM03209 01139000
BAL R14,SVC$202 PUNCH @V305614 01140000
ERRETPCH LR R14,R5 RESTORE RETURN REGISTER @VM03209 01141000
BR R14 BRANCH TO LOOP @V305614 01142000
SPACE 01143000
PUNPAD MVC 1(*-*,R15),0(R15) 01144000
CWSPAC LA R8,1 &SPACE N 01145000
LA R7,8(,PTR) GETS R7 FOR CVDBCD 01146000
CLI 0(R7),X'FF' END OF THE LINE? 01147000
BE CWSP1 BRANCH IF SO 01148000
BAL RET,CVDBCD 01149000
BNZ ERRCONV BRANCH IF CONVERSION ERROR 01150000
CVB R8,CVDSPACE 01151000
LTR R8,R8 WHAT IS THE VALUE? 01152000
BCR 13,R14 RETURN IF <= 0 01153000
CWSP1 EQU * SET TYPLIN PLIST FOR BLANK LINE 01154000
MVC TYPLIN+8(8),TYPLIST+8 DONE 01155000
LA R1,TYPLIN READY TO TYPE 01156000
CWSP2 EQU * 01157000
SVC 202 TYPE BLANK LINE 01158000
BCT R8,CWSP2 01159000
BR R14 01160000
SPACE 2 01161000
* NOTE--ADD NEW EXEC COMMANDS JUST BEFORE THIS LINE 01162000
SPACE 2 01163000
NOFILE LA R10,FILENO ADDRESS OF MESSAGE P LIST 01164000
B LEAVE 01165000
SPACE 1 01166000
SVCERR CVD 15,PDOUT CVD AND STORE R15 FOR PRINTING LATER 01167000
LR R9,R15 01168000
MVC PREVCMND(8),LASTCMND 01169000
EX R0,RSETCMD RESET CURRENT COMMAND TO EXEC 01170000
ZAP RETCODE(5),PDOUT(8) @VA03453 01171000
TM TFLAG,TYPERR+TYPCMS+TYPALL ANY TYPEOUT ON? 01172000
BZ DONT BRANCH IF NOT (DON'T TYPE ANYTHING) 01173000
TM TFLAG,TYPERR IS IT &TYPEOUT ERROR? 01174000
BZ ERRPRNT BRANCH IF NOT (I.E. IT'S CMS OR ALL) 01175000
BAL RET,TYPEOUT TYPE THE CMS COMMAND (TYPLIN SET BEFORE) 01176000
ERRPRNT EQU * TYPE A CMS-TYPE 'E' MESSAGE 01177000
MVC BUFFER(16),PATTERN SET FOR 'ED' 01178000
* CONVERT ERROR RETURN CODE TO GRAPHICS... 01179000
ED BUFFER+5(6),PDOUT+5 ED INTO BUFFER 01180000
MVI BUFFER+5,C'(' FIX UP LEFT PAREN 01181000
LTR R9,R9 WAS ERROR +VE OR -VE? 01182000
BNM *+8 SKIP IF >= 0 01183000
MVI BUFFER+6,C'-' INSERT MINUS SIGN 01184000
LA R10,BUFFER ADDRESS OF 'E' MESSAGE 01185000
O R10,TYPLIST+8 SET CONSOLE NO. 01186000
ST R10,TYPLIN+8 STORE FOR TYPLIN 01187000
MVC TYPLIN+12(4),=XL4'D9000010' TYPE IN RED, 16 CHARS 01188000
LA R1,TYPLIN WITH AN SVC 01189000
SVC 202 WHICH ALWAYS BEHAVES 01190000
DONT EQU * 01191000
BAL RET,TIMSUB PRINT LATEST TIMES (IF &TIME IS ON) 01192000
TM ERACT,X'F0' ERROR IN &ERROR ACTION? 01193000
BO ERRERR BRANCH IF SO 01194000
OI ERACT,X'F0' NO, SET ACTION FLAG 01195000
MVC CONRDFLG(1),ERACTION SET CONRDFLG FROM ERACTION 01196000
SR R0,R0 CLEAR R0 01197000
IC R0,ERACTION+1 PICK UP LENGTH OF ERROR ACTION 01198000
MVC UNSCND(130),ERACTION+2 RESTORE WHOLE '&ERROR' LINE 01199000
B SCANIT AND GO RESCAN IT 01200000
SPACE 1 01201000
EOF CLC GOSTOP(2),ZERO FIRST CHK FOR &GOTO SEARCH 01202000
* NOTE--&GOTO LOOPS BACK TO TOP OF FILE DURING SEARCH 01203000
* --IT FINALLY STOPS WHERE IT STARTED 01204000
BE EOF1 BRANCH IF NOT &GOTO SEARCH 01205000
LA R7,1 RESET TO TOP OF FILE 01206000
STH R7,PITEM STORE IN PLIST 01207000
B LOOP 01208000
EOF1 EQU * EOF FOUND WHEN NOT IN &GOTO SEARCH 01209000
CLC LOPLEVEL(2),ZERO ARE WE IN A LOOP? 01210000
BNE ERRLOOP BRANCH IF SO (ERROR) 01211000
CLOSE EQU * CLOSE THE EXEC FILE 01212000
LM R8,R9,DSKLIN SAVE DSKLIN FUNCTION 01213000
LA 1,DSKLIN ... 01214000
LR R3,R14 SAVE RETURN REGISTER @VM03209 01215000
SSM OFF DISABLE FOR INTERRUPTS @VA05743 01216000
L R15,AFINIS GET DMSFNS ADDRESS @VM03093 01217000
BALR R14,R15 AND CLOSE THE FILE @VM03093 01218000
SSM ON ENABLE FOR INTERRUPTS @VA05743 01219000
LR R14,R3 RESTORE RETURN REGISTER @VM03209 01220000
CLOSE2 EQU * EARLY ERROR CLOSING @VM08647 01221000
USING OPSECT,R3 @V305614 01222000
L R3,AOPSECT ADDRESSABILITY FOR OPSECT @V305614 01223000
L R1,EXADD+4 POINT TO GLOBAL AREA @V305614 01224000
USING XGLBL,R1 @V305614 01225000
SP GLOBAL(5),DECONE(1) @VA02322 01226000
DROP R1,R3 @V305614 01227000
LA R1,KEYWORDS 01228000
ST R1,ANCHOR 01229000
MVC LINKLEN(4),=F'16' 01230000
BAL RET,UNCHALL 01231000
LR R1,BFREE SET TO RETURN FREE STORAGE 01232000
LA 0,NEED ... 01233000
LM R3,R5,SAVRET RESTORE RETURN,SYSREF,AND R5 01234000
SSM OFF DISABLE FOR INTERRUPTS @VA05743 01235000
DMSFRET DWORDS=(0),LOC=(1),TYPCALL=BALR @VM03083 01236000
LR R14,R3 RESTORE RETURN 01237000
LTR R15,LINK LOAD AND TEST RETURN CODE 01238000
BR R14 RETURN TO THE CALLER. P0816 01239000
SPACE 1 01240000
* * * * * * * * * * * * EXEC RETURNS TO BOOTSTRAP HERE * * * * * * 01241000
ERRARGS EQU * TOO MANY ARGUMENTS PASSED 01242000
LA R10,MERRARGS SET UP 01243000
SPACE 01244000
LEAVE EQU * TYPE AN ERROR MESSAGE 01245000
LR R8,R10 SAVE R10 (CLOBBERED BY REF. TO 'RET') 01246000
MVC UNSCND(L'ERRMSG),ERRMSG MOVE IN STANDARD START OF MSG 01247000
LA R7,UNSCND+L'ERRMSG AND POINT TO NEXT FREE BYTE 01248000
MVC 0(8,R7),FNAME MOVE IN FILENAME 01249000
BAL RET,GIVLEN FIND ITS LENGTH 01250000
AR R7,R15 POINT TO NEXT FREE BYTE 01251000
MVC 0(L'ERRLINE,R7),ERRLINE MOVE IN NEXT PIECE OF MSG 01252000
LA R7,L'ERRLINE(,R7) AND POINT TO NEXT FREE BYTE 01253000
LA R3,LINENUM GET THE LINE NUMBER 01254000
BAL RET,UNPACK4 @VA02322 01255000
MVC 0(8,R7),TEMPD MOVE IT INTO THE MESSAGE 01256000
BAL RET,GIVLEN GET ITS LENGTH 01257000
AR R7,R15 POINT TO NEXT FREE BYTE 01258000
MVC 0(L'ERRDASH,R7),ERRDASH MOVE IN A NICE DASH 01259000
LA R7,L'ERRDASH(,R7) AND POINT TO NEXT FREE BYTE 01260000
SR R4,R4 CLEAR R4 01261000
IC R4,0(,R8) AND GET L'PARTICULAR MESSAGE 01262000
LR R3,R8 01263000
SR R3,R4 POINT TO SPOT WHERE MESSAGE STARTS 01264000
BCTR R4,0 DECREASE LENGTH FOR EXEC 01265000
EX R4,MOVMSG MOVE THE PARTICULAR MESSAGE 01266000
LA R15,1(R4,R7) AND POINT TO NEXT FREE BYTE @VM03208 01267000
LA R5,UNSCND POINT TO ADDRESS OF BUFFER @VM03208 01268000
SR R15,R5 CALCULATE MESSAGE LENGTH @VM03208 01269000
BAL R14,CWTYPER1 AND TYPE IT @VM03208 01270000
SR R7,R7 CLEAR THIS FOR RETURN CODE @VM03208 01271000
IC R7,1(,R8) GET ERROR CODE (R7 = 'LINK') 01272000
AH R7,=H'800' ADD 800 TO THE RETURN CODE P0816 01273000
B CLOSE 01274000
SPACE 01275000
MOVMSG MVC 0(*-*,R7),0(R3) 01276000
SPACE 1 01277000
ERDEPTH LA R10,MERDEPTH 01278000
B LEAVE 01279000
SPACE 1 01280000
CHK12 SR LINK,LINK SET TO SHOW NO ERRORS 01281000
CH R15,=H'12' 12 IS END OF FILE ERROR 01282000
BE EOF 01283000
SPACE 01284000
RDERR EQU * ERROR FROM RDBUF 01285000
LA R10,MRDERR ADDRESS OF MESSAGE DATA 01286000
LH R7,PITEM UPDATE THE LINE NUMBER 01287000
CVD R7,CVDSPACE CONVERT TO DECIMAL 01288000
MVC LINENUM(4),CVDSPACE+4 AND MOVE INTO LINENUM 01289000
B LEAVE 01290000
SPACE 1 01291000
BADSIZ LA R10,SIZBAD 01292000
B LEAVE 01293000
SPACE 1 01294000
ERRCOND LA R10,MERRCOND 01295000
B LEAVE 01296000
SPACE 1 01297000
ERRINDX LA R10,MERRINDX 01298000
B LEAVE 01299000
SPACE 1 01300000
ERRERR LA R10,MERRERR ERROR IN &ERROR ACTION 01301000
B LEAVE 01302000
SPACE 01303000
ERRCONV LA R10,MERRCONV ERROR IN CONVERSION TO ARITHMETIC 01304000
B LEAVE 01305000
SPACE 01306000
ERRSYN LA R10,MERRSYN SYNTAX ERROR 01307000
B LEAVE 01308000
SPACE 01309000
ERRASS LA R10,MERRASS ASSIGNMENT ERROR 01310000
B LEAVE 01311000
SPACE 01312000
ERRBUST LA R10,MERRBUST TOO MANY TOKENS IN 1 STATEMENT 01313000
B LEAVE 01314000
SPACE 01315000
ERRBLTN LA R10,MERRBLTN BUILT-IN FUNCTION ERROR 01316000
B LEAVE 01317000
SPACE 01318000
ERRLOOP LA R10,MERRLOOP LOOP NOT TERMINATED 01319000
B LEAVE 01320000
SPACE 01321000
ERRWORD LA R10,MERRWORD BAD CONTROL WORD 01322000
B LEAVE 01323000
EJECT 01324000
ERRUFLW LA R10,MERRUFLW EXEC UNDERFLOW @VA02322 01325000
B LEAVE @VA02322 01326000
SPACE 1 01327000
ERROFLW LA R10,MERROFLW EXEC OVERFLOW @VA02322 01328000
B LEAVE @VA02322 01329000
SPACE , HRC007DS 01329070
ERRDIVZ LA R10,MERRDIVZ DIVIED BY ZERO ERROR HRC007DS 01329140
B LEAVE HRC007DS 01329210
SPACE 1 01329300
ERRCHAR LA R10,MERRCHAR INVALID CHAR IN VARIABLE SYMBOL @VA07374 01329600
B LEAVE @VA07374 01329900
SPACE 1 01330000
* 'TYPECRON' AND 'TYPEOUT' REWRITTEN. 01331000
SPACE 01332000
TYPECRON EQU * TYPE WITH CHRONOLOGICAL 01333000
TM TFLAG,TYPTIM IS IT &TYPEOUT TIME? 01334000
BZ TYPEOUT BRANCH IF NOT (SKIP TIME-OF-DAY) 01335000
LA R1,CONWAIT WAIT FOR CONSOLE TO SUBSIDE 01336000
SVC 202 01337000
LA R1,CURRDATE READ CP'S TIMER V0040 01338000
DC X'83',X'10',X'000C' V0040 01339000
MVC UNSCND(8),CURRTIME TOD TO UNSCND 01340000
MVI UNSCND+8,C' ' FOLLOW WITH A BLANK 01341000
LA R15,UNSCND+9 SET R15 FOR NEXT SPARE BYTE 01342000
B TYPEOUTA BRANCH INTO 'TYPEOUT' 01343000
SPACE 01344000
TYPEOUT EQU * TYPE OUT THE LINE 01345000
LA R15,UNSCND WHERE TO START IN UNSCND BUFFER 01346000
TYPEOUTA EQU * (TRANSFER HERE FROM 'TYPECRON') 01347000
STM R4,R10,TEMSUB2 SAVE NECESSARY REGISTERS 01348000
L R4,TYPLIN+8 ADDRESS OF LINE TO BE TYPED 01349000
LH R5,TYPLIN+14 LENGTH 01350000
AR R5,R4 ADDRESS OF BYTE AFTER LAST 01351000
LA R6,UNSCND ADDRESS OF NEW LINE IN UNSCND 01352000
LR R7,R15 WHERE TO PUT THE FIRST TOKEN IN UNSCND 01353000
LA R8,L'UNSCND LENGTH OF UNSCND IN R8 01354000
LA R9,UNTAIL ADDRESS OF UNSCND TAIL IN R9 01355000
TYPOLP EQU * MOVE LINE INTO UNSCND BUFFER, TOK BY TOK 01356000
CR R4,R5 HAVE WE REACHED END OF LINE? 01357000
BNL TYPIT BRANCH IF SO 01358000
CR R7,R9 IS UNSCND BUFFER EXHAUSTED? 01359000
BNL TYPCONT BRANCH IF SO (INDICATE TRUNCATED) 01360000
MVC 0(8,R7),0(R4) MOVE WHOLE OF NEXT TOK INTO UNSCND 01361000
MVI 8(R7),C' ' FOLLOW WITH A BLANK 01362000
LA R4,8(,R4) POINT R4 TO NEXT TOK 01363000
TM TFLAG,TYPPAC IS IT &TYPEOUT PACK? 01364000
BO TYPACK BRANCH IF SO 01365000
LA R7,9(,R7) SKIP OVER TOKEN AND BLANK 01366000
B TYPOLP BACK FOR NEXT TOK 01367000
TYPACK EQU * PACK THE LINE 01368000
BAL RET,GIVLEN LENGTH OF TOKEN INTO R15 01369000
LA R7,1(R7,R15) NEXT FREE BYTE IN UNSCND 01370000
B TYPOLP BACK FOR NEXT TOK 01371000
SPACE 01372000
TYPCONT EQU * TYPE WITH INDICATION OF TRUNCATION 01373000
MVC UNTAIL-3(3),=CL3'...' MOVE ELLIPSIS IN END OF UNSCND 01374000
LR R7,R8 L'UNSCND INTO R7 01375000
B TYPIT2 BRANCH INTO 'TYPIT' 01376000
TYPIT EQU * STRIP OFF ANY TRAILING BLANKS 01377000
CR R7,R6 IS OUTPUT LINE NULL? 01378000
BE TYPIT1 BRANCH IF SO 01379000
BCTR R7,0 LOOK AT LAST CHAR IN UNSCND 01380000
CLI 0(R7),C' ' IS IT A BLANK? 01381000
BE TYPIT LOOP BACK IF SO (STRIP IT OFF) 01382000
LA R7,1(,R7) INCREMENT R7 AGAIN TO COMPUTE LENGTH 01383000
TYPIT1 EQU * COMPUTE LENGTH OF LINE 01384000
SR R7,R6 LENGTH OF LINE TO TYPE 01385000
CR R7,R8 COMPARE WITH MAX. POSSIBLE LENGTH 01386000
BH TYPCONT BACK TO TYPCONT IF TOO LONG 01387000
TYPIT2 EQU * (TRANSFER HERE FROM 'TYPCONT') 01388000
ST R6,TYPLIN+8 ADDRESS OF UNSCND 01389000
MVI TYPLIN+8,X'01' FIX UP CONSOLE NO. 01390000
CLI TYPLIN+12,X'00' IS COLOUR SPECIFIED? 01391000
BNE *+8 SKIP IF SO 01392000
MVI TYPLIN+12,C'B' USE BLACK RIBBON 01393000
STH R7,TYPLIN+14 LENGTH OF LINE TO BE TYPED 01394000
LA R1,TYPLIN TYPE THE LINE (AT LAST) 01395000
SVC 202 01396000
LM R4,R10,TEMSUB2 RESTORE REGISTERS 01397000
BR RET RETURN TO CALLER 01398000
SPACE 2 01399000
ERRMSG DC C'EXT072E Error in EXEC file ' HRC309DS 01400000
ERRLINE DC C', line ' HRC309DS 01401000
ERRDASH DC C' - ' FINISHING TOUCH 01402000
SPACE 2 01403000
ERR1 DC C'File not found' HRC309DS 01404000
FILENO DC AL1(L'ERR1) 01405000
DC X'01' ERROR NUMBER 01406000
ERR2 DC X'50E2D2C9D74096994050C7D6E3D6408599999699' 01407000
* ABOVE SAYS &SKIP or &GOTO error 01408000
ERRGOTO DC AL1(L'ERR2) 01409000
DC X'02' 01410000
ERR3 DC C'Bad file format' HRC309DS 01411000
SIZBAD DC AL1(L'ERR3) 01412000
DC X'03' 01413000
ERR4 DC C'Too many arguments' HRC309DS 01414000
MERRARGS DC AL1(L'ERR4) 01415000
DC X'04' 01416000
ERR5 DC C'Max depth of loop nesting exceeded' HRC309DS 01417000
MERDEPTH DC AL1(L'ERR5) 01418000
DC X'05' 01419000
ERR6 DC C'Error reading file' HRC309DS 01420000
MRDERR DC AL1(L'ERR6) 01421000
DC X'06' 01422000
ERR7 DC C'Invalid syntax' HRC309DS 01423000
MERRSYN DC AL1(L'ERR7) 01424000
DC X'07' 01425000
ERR8 DC C'Invalid form of condition' HRC309DS 01426000
MERRCOND DC AL1(L'ERR8) 01427000
DC X'08' 01428000
ERR9 DC C'Invalid assignment' HRC309DS 01429000
MERRASS DC AL1(L'ERR9) 01430000
DC X'09' 01431000
ERR10 DC C'Misuse of special variable' HRC309DS 01432000
MERRINDX DC AL1(L'ERR10) 01433000
DC X'0A' 01434000
ERR11 DC X'C5999996994089954050C5D9D9D6D9408183A3899695' 01435000
* ABOVE SAYS 'Error in &ERROR action' 01436000
MERRERR DC AL1(L'ERR11) 01437000
DC X'0B' 01438000
ERR12 DC C'Conversion error' HRC309DS 01439000
MERRCONV DC AL1(L'ERR12) 01440000
DC X'0C' 01441000
ERR13 DC C'Too many tokens in statement' HRC309DS 01442000
MERRBUST DC AL1(L'ERR13) 01443000
DC X'0D' 01444000
ERR14 DC C'Misuse of built-in function' HRC309DS 01445000
MERRBLTN DC AL1(L'ERR14) 01446000
DC X'0E' 01447000
ERR15 DC C'EOF found in loop' HRC309DS 01448000
MERRLOOP DC AL1(L'ERR15) 01449000
DC X'0F' 01450000
ERR16 DC C'Invalid control word' HRC309DS 01451000
MERRWORD DC AL1(L'ERR16) 01452000
DC X'10' 01453000
ERR17 DC C'EXEC arithmetic underflow' HRC309DS 01454000
MERRUFLW DC AL1(L'ERR17) @VA02322 01455000
DC X'11' @VA02322 01456000
ERR18 DC C'EXEC arithmetic overflow' HRC309DS 01457000
MERROFLW DC AL1(L'ERR18) @VA02322 01458000
DC X'12' @VA02322 01459000
ERR19 DC C'Invalid char in variable symbol' HRC309DS 01459300
MERRCHAR DC AL1(L'ERR19) @VA07374 01459600
DC X'13' @VA07374 01459900
ERR30 DC C'EXEC divide by zero' HRC309DS 01459920
MERRDIVZ DC AL1(L'ERR30) HRC007DS 01459940
DC X'1E' HRC007DS 01459960
PATTERN DC C'+++ R' 01460000
DC X'F02020202020' FILL + DIGIT SELECTORS 01461000
DC C') +++' 01462000
SPACE 1 01463000
* SUBROUTINES HERE FOR EXEC 01464000
SPACE 01465000
* 'SETUP' IS A SUBROUTINE WHICH SETS UP READFLAG AND TYPEFLAG 01466000
* FROM THE CURRENT SETTINGS OF THE SYSTEM FLAGS. 01467000
SPACE 01468000
SETUP DS 0H 01469000
MVC READFLAG(8),=CL8'CONSOLE' SET READFLAG PROVISIONALLY 01470000
CLC FSTFINRD(4),ZERO ANY READS STACKED? 01471000
BE *+10 SKIP IF NOT 01472000
MVC READFLAG(8),=CL8'STACK' SET READFLAG FOR STACK 01473000
MVC TYPEFLAG(8),RTINIT SET TYPEFLAG TO 'RT' @VM03181 01474000
TM MSGFLAGS,NOTYPING IS "HT" FLAG SET? 01475000
BE DOSCHK SKIP IF NOT @V305101 01476000
MVI TYPEFLAG,C'H' SET TYPEFLAG TO 'HT' 01477000
* TM CONFLAG,X'01' IS THE CJS BIT SET FOR DT? 01478000
* BCR 8,RET RETURN IF NOT (ALL SET UP) 01479000
* MVI TYPEFLAG,C'D' SET TYPEFLAG TO 'DT' 01480000
DOSCHK MVC DOS(8),=CL8'OFF' SET DOS FLAG TO 'OFF' @V305101 01481000
TM DOSFLAGS,DOSSVC+DOSMODE ANYBODY ON ? @V305101 01482000
BZR RET RETURN IF NOT ON @V305101 01483000
MVC DOS(8),=CL8'ON' SET DOS FLAG TO 'ON' @V305101 01484000
BR RET RETURN 01485000
SPACE 2 01486000
* 'TIMSET' AND 'TIMSUB' RESET AND TYPE THE CMS TIMES 01487000
* (VIRCPU, TOTCPU AND TIME-OF-DAY). THE ENTRY POINTS 'TIMSET' 01488000
* AND 'TIMSUB' ARE EFFECTIVE ONLY IF THE TIMFLG IS ON; 'TIMSETA' 01489000
* AND 'TIMSUBA' ARE EXPLICIT. USES THE NEW NUCLEUS ROUTINE 01490000
* 'CMSTIME'. 01491000
SPACE 01492000
TIMSET EQU * RESET THE TIMES IF TIMFLG IS ON 01493000
TM TIMFLG,TIMON IS TIMFLG ON? 01494000
BCR 8,RET RETURN IF NOT 01495000
TIMSETA EQU * RESET THE TIMES EXPLICITLY 01496000
SR R0,R0 SIGNAL NOT ENTERED AT TIMSUB 01497000
SR R1,R1 READY TO TELL CMSTIME TO RESET ONLY 01498000
B TIMSUB2 BRANCH INTO 'TIMSUB' 01499000
SPACE 01500000
TIMSUB EQU * TYPE TIMES (AND RESET) IF TIMFLG IS ON 01501000
TM TIMFLG,TIMON IS TIMFLG ON? 01502000
BCR 8,RET RETURN IF NOT 01503000
LA R0,1 SIGNAL ENTERED AT TIMSUB 01504000
B *+6 SKIP NEXT INSTRUCTION 01505000
TIMSUBA EQU * TYPE AND RESET TIMES EXPLICITLY 01506000
SR R0,R0 SIGNAL NOT ENTERED AT TIMSUB 01507000
LA R1,CONWAIT WAIT FOR CONSOLE TO SUBSIDE 01508000
SVC 202 01509000
LA R1,TIMBUF+2 READY TO TELL CMSTIME TO USE OUR TIMBUF 01510000
TIMSUB2 EQU * (TRANSFER HERE FROM TIMSET) 01511000
ST R1,CMSTIME+16 TELL CMSTIME WHAT TO DO 01512000
LA R1,CMSTIME READY TO CALL CMSTIME 01513000
L R15,AGETCLK ACCESS CMS-TIME 01514000
BALR R14,R15 CALL CMSTIME 01515000
L R1,CMSTIME+16 WHAT WE ASKED CMSTIME TO DO 01516000
LTR R1,R1 WHAT WAS IT? 01517000
BCR 8,RET RETURN IF RESET 01518000
MVC TYPLIN+8(8),TYPLIST+8 SET UP TYPLIN PLIST 01519000
LA R1,TIMBUF ADDRESS OF WHAT TO TYPE 01520000
ST R1,TYPLIN+8 TELL TYPLIN 01521000
MVI TYPLIN+8,X'01' FIX UP CONSOLE NO. 01522000
L R1,CMSTIME+20 LENGTH OF TIMBUF WHICH IS OCCUPIED 01523000
LA R1,2(,R1) PLUS 2 FOR 'T=' 01524000
STH R1,TYPLIN+14 TELL TYPLIN 01525000
LA R1,TYPLIN TYPE THE LINE 01526000
SVC 202 01527000
LTR R0,R0 DID WE ENTER AT TIMSUB? 01528000
BCR 8,RET RETURN IF NOT 01529000
TM TFLAG,TYPCMS+TYPALL DID WE TYPE THE CMS COMMAND? 01530000
BCR 8,RET RETURN IF NOT 01531000
MVI TYPLIN+15,X'00' TELL TYPLIN TO TYPE BLANK LINE 01532000
SVC 202 01533000
BR RET RETURN 01534000
SPACE 2 01535000
* 'CONDRET' EXAMINES CONDITION POINTED TO BY R7 AND RETURNS 01536000
* CONDITION CODE = 0 IF AND ONLY IF THE CONDITION IS SATISFIED. 01537000
CONDRET STM R2,R10,TEMSUB 01538000
MVC COND(24),0(R7) 01539000
LA R8,COND USE R8 AS LOC OF COND 01540000
SR R5,R5 ZERO ALL COUNT 01541000
LR R6,R5 ZERO ANY COUNT 01542000
NI CONDFLG,X'0F' CLEAR 4 BITS OF FLAG 01543000
CLC 0(3,R8),ESTAR '&*'? 01544000
BNE *+12 01545000
LA R5,1 01546000
OI CONDFLG,X'20' PUT IN FLAGS.. 01547000
CLC 16(3,R8),ESTAR '&*'? 01548000
BNE *+12 01549000
LA R5,1 01550000
OI CONDFLG,X'10' 01551000
CLC 0(3,R8),EDOLL '&$'? 01552000
BNE *+12 01553000
LA R6,1 01554000
OI CONDFLG,X'80' 01555000
CLC 16(3,R8),EDOLL '&$'? 01556000
BNE *+12 01557000
LA R6,1 01558000
OI CONDFLG,X'40' 01559000
TM CONDFLG,X'A0' INIT ARGS? 01560000
BZ CONDZ 01561000
CONDCP CP INDEX(4),DECZERO(1) EXIT IF NONE SUPPLIED 01562000
BE WRAPRET 01563000
MVC 0(8,R8),8+ARGTABLE PUT IN FIRST DUMMY ARG 01564000
CONDZ TM CONDFLG,X'50' 01565000
BZ CDLOOP 01566000
EX R0,CONDCP 01567000
BE WRAPRET 01568000
MVC 16(8,R8),ARGTABLE+8 +8 BECAUSE FILNAM IS IN ARGTBLE 01569000
CDLOOP LR R7,R8 01570000
SR R2,R2 ZERO FOR LOGICAL COMPARE,6 FOR ARITH 01571000
BAL RET,CVDBCD RET SAVED-GO GET DECIMAL 01572000
BNZ LOGCF BRANCH IF CONVERSION ERROR 01573000
CVB R9,CVDSPACE NOT NECESSARILY,GET BIN VAL 01574000
LA R7,16(,R8) GET ADDR OF 3RD OPERAND 01575000
BAL RET,CVDBCD GO GET DEC 01576000
BNZ LOGCF BRANCH IF CONVERSION ERROR 01577000
CVB R7,CVDSPACE NO, SET FLAG TO... 01578000
LA R2,6 ..COMPARE ARITHMETICALLY 01579000
LOGCF LA R4,COMBEG LOOK FOR CONDITION 01580000
LA R3,COMEND 01581000
COMLOOP CLC 0(3,R4),8(R8) COMPARE TABLE ENTRY P0193 01582000
BE COMFND ... 01583000
LA R4,4(,R4) ... 01584000
CLR R4,R3 ... 01585000
BL COMLOOP ... 01586000
B ERRCOND NOT >,<,=,ETC. 01587000
COMFND IC R4,3(,R4) GET MASK FROM TABLE P0193 01588000
EX 0,COMPARE(R2) 01589000
LA R2,1(,R6) 01590000
LA RET,1(,R5) RET=R10 01591000
SLL R10,3 MPY BOTH BY 8 01592000
SLL R2,3 ... 01593000
LA R2,ARGTABLE(R2) 01594000
LA R10,ARGTABLE(R10) 01595000
EX R4,COMPAR 01596000
B CFALSE 01597000
COMPARE CLC 0(8,R8),16(R8) LOGICAL COMPARE 01598000
CR R9,R7 ARITHMETIC COMPARE 01599000
COMPAR BC 0,CTRUE COMPARE A TO B 01600000
CFALSE LTR R6,R6 TEST 'ANY' COUNT 01601000
BZ WRAPRET ZERO --RETURN 01602000
LA R6,1(,R6) ITERATE COMPARISON 01603000
CVD R6,CVDSPACE FOR EACH PARAM SUPPL'D 01604000
CP CVDSPACE(8),INDEX(4) ANY MORE? 01605000
BH WRAPRET NO-- RETURN 01606000
TM CONDFLG,X'80' TEST 1ST OPERAND 01607000
BZ *+10 NOPE--GO TEST 2ND 01608000
MVC 0(8,R8),0(R2) YEP--MOVE IN NEXT ARG 01609000
TM CONDFLG,X'40' TEST 2ND 01610000
BZ *+10 01611000
MVC 16(8,R8),0(R2) MOVE IN NXT ARG. 01612000
B CDLOOP BACK FOR NXT COMPARISON 01613000
SATOUT EQU * THIS USED TO RETURN R7 = 0 AND THEN 01614000
SR R7,R7 CHKALL WOULD CLOBBER THE 1ST 24 BYTES 01615000
B *+8 IN THE VIRTUAL MACHINE... 01616000
WRAPRET EQU * SO NOW IT JUST RETURNS WITH THE 01617000
LA R7,1 CONDITION CODE SET, BUT WITH R7 01618000
LTR R7,R7 SAFE AND SOUND 01619000
LM R2,R10,TEMSUB RESTORE REGISTERS 01620000
BR RET 01621000
CTRUE LTR R5,R5 'ALL' FLAG SET? 01622000
BZ SATOUT NO--RETURN 01623000
LA R5,1(,R5) ITERATE COMPARISON 01624000
CVD R5,CVDSPACE 01625000
CP CVDSPACE(8),INDEX(4) 01626000
BH SATOUT 01627000
TM CONDFLG,X'20' 01628000
BZ *+10 01629000
MVC 0(8,R8),0(R10) 01630000
TM CONDFLG,X'10' 01631000
BZ *+10 01632000
MVC 16(8,R8),0(R10) 01633000
B CDLOOP 01634000
SPACE 3 01635000
* CVDBCD CONVERTS TO PACKED DECIMAL IN CVDSPACE FROM EBCDIC IN 01636000
* LOCATION POINTED TO BY R7--WILL CONVERT 0-8 DIGITS,SIGN--IF 01637000
* LETTER IS ENCOUNTERED OTHER THAN BLANK, CVDFLAG IS SET TO 'F' 01638000
* OTHERWISE IT IS '0'AND NUM IS VALID UP TO LETTER--HOWEVER, 01639000
* IT WILL NOT LOOK ACROSS A DBL-WORD BOUNDARY. 01640000
* SETS CONDITION CODE BY MEANS OF: TM CVDFLAG,X'F0' 01641000
CVDBCD DS 0H 01642000
STM R3,R8,TEMSUB2 SAVE REGISTERS 01643000
ZAP CVDSPACE(8),DECZERO(1) ZERO CVDSPACE 01644000
CLI 0(R7),X'FF' ANYTHING THERE? 01645000
BE CVDBAD BRANCH IF NOT (CONVERSION ERROR) 01646000
LR R3,R7 1ST MOVE POINTERS TO CVD 01647000
LA R4,1 01648000
N R7,=X'FFFFFFF8' GET R7 ON DOUB WRD BOUNDARY 01649000
MVC CVD(8),0(R7) MOVE INTO WORK AREA 01650000
SR R3,R7 01651000
LA R7,CVD 01652000
AR R3,R7 01653000
LA R5,7(,R7) MAX VAL FOR BXLE 01654000
MVI CVDFLAG,X'00' ZERO CVDFLAG 01655000
XC CVDSPACE(8),CVDSPACE ZERO CVDSPACE 01656000
MVI CVDSPACE+7,X'F0' PUT IN ZERO 01657000
MVI SIGN,POS SET TO PLUS (COMPL) @V305666 01658000
CVD1 BAL R8,CHKLN IF LENGTH<1, SET DEFAULT & RETURN 01659000
CLI 0(R3),C' ' REMOVES LEADING BLANKS 01660000
BNE CVD2 ... 01661000
BXLE R3,R4,CVD1 01662000
CVD2 LCR R6,R4 SET R6=-1 01663000
LR R7,R3 01664000
CVD3 BAL R8,CHKLN REMOVE TRAILING BLANKS 01665000
CLI 0(R5),C' ' ... 01666000
BNE CVD4 ... 01667000
BXH R5,R6,CVD3 01668000
CVD4 CLI 0(R3),C'+' 01669000
BNE CVD6 01670000
CVD5 LA R3,1(,R3) 01671000
B CVD7 01672000
CVD6 CLI 0(R3),C'-' 01673000
BNE CVD7 01674000
MVI SIGN,NEG PUT IN - (COMPL) @V305666 01675000
B CVD5 01676000
CVD7 BAL R8,CHKLN 01677000
CVD8 TM 0(R3),X'F0' DIGIT? 01678000
BNO CVD9 01679000
TM 0(R3),X'0F' 01680000
BO CVD9 01681000
CLI 0(R3),X'FA' GREATER THAN 9? @VA02750 01682000
BNL CVD9 YES, TRANS @VA02750 01683000
MVC CVDSPACE(7),CVDSPACE+1 SHIFT LEFT 01684000
MVC CVDSPACE+7(1),0(R3) PUT IN NUMBER 01685000
BXLE R3,R4,CVD8 01686000
B SIGNIT NO MORE @V305614 01687000
CVD9 OI CVDFLAG,X'F0' SET FLAG TO INDICATE CHAR IN NO 01688000
SIGNIT XC CVDSPACE+7(1),SIGN PLUG SIGN @V305614 01689000
PACK CVDSPACE(8),CVDSPACE(8) 01690000
CVD11 LM R3,R8,TEMSUB2 01691000
TM CVDFLAG,X'F0' SET CONDITION CODE 01692000
BR RET RETURN TO CALLER 01693000
CHKLN CR R3,R5 01694000
BCR 13,R8 BR ON NOT HIGH THRU R8 01695000
CVDBAD EQU * CONVERSION ERROR 01696000
OI CVDFLAG,X'F0' SET ERROR FLAG 01697000
B CVD11 RETURN 01698000
SPACE 3 01699000
* CWRET RETURNS R7=ADDRESS OF NAME OF CONTROL WORD IF ADDR 01700000
* IN R6 CONTAINS A CONTROL WORD, R7=0 OTHERWISE 01701000
CWRET STM R1,R6,TEMSUB 01702000
LA R1,EXECWRDS BEG VALUS FOR LOOP 01703000
LA R3,ELITERAL SPOT TO STOP 01704000
LA R2,8 INCREMENT 01705000
CWLP2 EQU * 01706000
CLC 0(8,R6),0(R1) COMPARE FOR EXEC WORD 01707000
BE CWOUT ..CONTROL WORDS.. 01708000
BXLE R1,R2,CWLP2 01709000
SR R7,R7 SET R7, COND CODE TO 0 01710000
LMOUT LM R1,R6,TEMSUB 01711000
BR RET 01712000
CWOUT EQU * 01713000
LTR R7,R1 GET ADDR OF CONTRL WORD,& SET COND CODE 01714000
B LMOUT 01715000
SPACE 3 01716000
* KEYWCK SEARCHES KEYWORD CHAIN FOR KEYWORD VALUE 01717000
* CORRESPONDING TO KEYWORD IN TEMPD. R9 POINTS TO VALUE IF 01718000
* FOUND, R9=0 FOR NO MATCH. 01719000
KEYWCK EQU * @VA07244 01720000
ST RET,TEMSUB2 SAVE RETURN ADDRESS @VA07244 01721000
LA R9,KEYWORDS LOAD ANCHOR ADDRESS @VA07244 01722000
XC CHAD,CHAD KEEP DATA AREAS CORRECT @VA07244 01723000
KELOOP EQU * @VA07244 01724000
L R9,0(,R9) POINT TO NEXT CHAIN LINK @VA07244 01725000
LTR R9,R9 IS IT END OF CHAIN @VA07244 01726000
BZ KEOUT YES - BRANCH @VA07244 01727000
* 01728000
CLC TEMPD(8),4(R9) IS THIS THE KEYWORD @VA07244 01729000
BNE KELOOP NO - BRANCH @VA07244 01730000
* 01731000
ST R9,CHAD SAVE ADDRESS OF CHAIN LINK @VA07244 01732000
LA R9,12(,R9) POINT TO KEYWORD VALUE @VA07244 01733000
KEOUT EQU * @VA07244 01734000
L RET,TEMSUB2 RESTORE RETURN ADDRESS @VA07244 01735000
LTR R9,R9 SET CONDITION CODE @VA07244 01736000
BR RET RETURN TO CALLER @VA07244 01737000
SPACE 3 01738000
* FULLNAM WILL TRANSFER TO 01739000
* ADDR IN ADLIST AFTER CONTROL WORD MATCH. 01740000
FULLNAM STM R7,R8,TEMSUB2 01741000
LA R8,BLTINS CHECK THAT IT'S NOT A BUILT-IN FUNCTION 01742000
CR R7,R8 01743000
BNL ERRWORD BRANCH IF IT IS (ERROR) 01744000
LA RET,EXECWRDS READY TO FORM ADDRESS 01745000
SR R7,RET 01746000
SRA R7,2 DVD BY 4 TO GET DISPL 01747000
LA RET,ADLIST(R7) 01748000
LH RET,0(,RET) GET BRANCH ADDR 01749000
AR RET,BASE 01750000
LM R7,R8,TEMSUB2 01751000
BR RET 01752000
SPACE 3 01753000
CHKALL EQU * CHECK CONDITION FOR LOOP 01754000
STM R5,R10,TEMSUB3 SAVE REGISTERS 01755000
MVC COND1(24),0(R7) MOVE CONDITION INTO OUR TEMP 01756000
LA R5,24(,R7) POINT TO LITERAL FLAGS 01757000
LA R6,COND1 01758000
LA R9,16(,R6) SET UP FOR BXLE. THIS IS WHERE TO STOP 01759000
LA R8,8 THIS IS THE INCREMENT 01760000
CHKALL1 EQU * LOOP 01761000
TM 0(R5),X'FF' LITERAL FLAG SET? 01762000
BNZ CHKALL2 SKIP IF SO @VA04597 01763000
L R15,ASUBSTIT GET SUBSTIT ADDRESS @VM03209 01764000
BALR RET,R15 AND DO A SUBSTITUTION JOB @VM03209 01765000
CHKALL2 LA R5,1(,R5) INCREMENT POINTER @VA04597 01766000
BXLE R6,R8,CHKALL1 LOOP FOR ALL 3 TOKS 01767000
TM TFLAG,TYPALL IS IT &TYPEOUT ALL? 01768000
BNO CONDCALL BRANCH IF NOT 01769000
LA R5,CONDMSG POINT TO START OF MESSAGE 01770000
LA R6,40 LENGTH 01771000
STM R5,R6,TYPLIN+8 STORE IN TYPLIN PLIST 01772000
BAL RET,TYPEOUT TYPE THE CONDITION 01773000
CONDCALL EQU * 01774000
LA R7,COND1 POINT TO THE CONDITION 01775000
BAL RET,CONDRET CHECK THE CONDITION 01776000
LM R5,R10,TEMSUB3 RESTORE REGISTERS 01777000
BR RET RETURN 01778000
SPACE 2 01779000
* 'LHS' IS A SUBROUTINE WHICH RETURNS THE ADDRESS OF THE TARGET 01780000
* FOR AN ASSIGNMENT IN R7. SETS THE CONDITION CODE TO ZERO IF 01781000
* THE TARGET IS NOT A NUMERIC VARIABLE, TO 'HIGH' IF IT IS. 01782000
SPACE 01783000
LHS DS 0H 01784000
STM R8,R10,TEMSUB SAVE NECESSARY REGS 01785000
CLC 1(2,PTR),=CL2'0 ' IS IT '&0'? 01786000
BE ANDZRO SKIP IF SO @VA02750 01787000
CLI 1(PTR),X'F0' FIRST CHAR AFTER '&' NUMBER 1-9? 01788000
BNH TRYGLOB BRANCH IF NOT (TRY A GLOBAL) 01789000
CLI 1(PTR),X'FA' GREATER THAN 9? @VA02750 01790000
BNL TRYGLOB YES, TRANS @VA02750 01791000
ANDZRO LA R7,1(PTR) POINT R7 TO DIGIT @VA02750 01792000
BAL RET,CVDBCD TRY TO CONVERT TO NUMERICS 01793000
BNZ UVAR MUST BE A USER VARIABLE 01794000
CVB R7,CVDSPACE ARG. NO. INTO R7 01795000
CH R7,=H'30' TOO HIGH? 01796000
BH ERRINDX BRANCH IF SO (IMPLEMENTATION LIMIT) 01797000
SLL R7,3 MULTIPLY BY 8 01798000
LA R7,ARGTABLE(R7) ADDRESS OF TARGET 01799000
B LHSBOT RETURN 01800000
TRYGLOB LA R10,EBEGLOB SEE IF IT'S A GLOBAL 01801000
LA R8,8 SET INCREMENT FOR BXLE 01802000
LA R9,ETYPEFLG LIMIT 01803000
CLC 0(8,PTR),0(R10) SEARCH FOR NAME 01804000
BE FNDGLOB BRANCH IF FOUND 01805000
BXLE R10,R8,*-10 LOOP 01806000
B UVAR TREAT AS USER VARIABLE 01807000
FNDGLOB LA R9,EBEGLOB FOUND A SPECIAL VARIABLE 01808000
CR R10,R9 IS IT &GLOBAL? 01809000
BE ERRINDX BRANCH IF SO (ILLEGAL) 01810000
LA R9,EXECEND IS IT AMONG THE READ-ONLY VARS? 01811000
CR R10,R9 01812000
BNL ERRINDX BRANCH IF SO 01813000
LA R9,ERETCOD MAYBE ITS &RETCODE ? @VA03453 01814000
CR R10,R9 @VA03453 01815000
BNE NOTRTCD MUST BE A GLOBAL .... @VA03453 01816000
LA R7,RETCODE POINT TO ASSIGNMENT LOCATION @VA03453 01817000
B LHSIND AND EXIT GRACEFULLY ... @VA03453 01818000
NOTRTCD EQU * @VA03453 01819000
LA R9,EGLOB+8 ADDRESS OF &GLOBAL0 01820000
SR R10,R9 DIFFERENCE 01821000
SRL R10,3 DIVIDE BY 8 @VA02322 01822000
MH R10,=H'5' GET INDEX VALUE INTO GLOBALS .. @VA02322 01823000
USING OPSECT,R9 @V305614 01824000
L R9,AOPSECT POINT TO OPSECT IN NUCLEUS @V305614 01825000
USING XGLBL,R8 @V305614 01826000
L R8,EXADD+4 POINT TO GLOBAL AREA @V305614 01827000
LA R7,GLOBAL0(R10) ADDRESS OF TARGET 01828000
DROP R8,R9 @V305614 01829000
B LHSIND FIX COND. CODE AND RETURN 01830000
UVAR MVC TEMPD(8),0(PTR) MOVE NAME INTO TEMPD FOR KEYWCK 01831000
BAL RET,KEYWCK MUST BE A USER VARIABLE 01832000
LTR R7,R9 ALREADY DEFINED? 01833000
BNZ LHSBOT BRANCH IF SO 01834000
LA R7,KEYWORDS PUT IT IN THE CHAIN 01835000
ST R7,ANCHOR 01836000
LA R7,16 01837000
ST R7,LINKLEN 01838000
BAL RET,APPEND 01839000
L R7,ADDR 01840000
MVC 0(8,R7),0(PTR) 01841000
LA R7,8(,R7) 01842000
L R9,KPTR 01843000
LA R9,1(,R9) 01844000
ST R9,KPTR 01845000
LHSBOT SR R10,R10 SET COND. CODE 0 01846000
LHSRET LM R8,R10,TEMSUB RESTORE REGS 01847000
BR RET RETURN 01848000
LHSIND LA R10,1 SET COND. CODE 'HIGH' 01849000
LTR R10,R10 01850000
B LHSRET 01851000
SPACE 2 01852000
* 'RHS' IS A SUBROUTINE WHICH ANALYZES THE RIGHT-HAND SIDE 01853000
* OF AN ASSIGNMENT STATEMENT, LOOKING FOR BUILT-IN 01854000
* FUNCTIONS. 01855000
SPACE 01856000
RHS DS 0H 01857000
MVC TEMPD(8),BLANKS BLANK OUT THE ANSWER 01858000
CLC 16(8,PTR),=8X'FF' END OF THE PLIST @VA05428 01859000
BCR 8,RET RETURN IF SO 01860000
STM R3,R10,TEMSUB SAVE REGISTERS 01861000
LA R3,BLTINS ADDRESS OF BUILT-IN FUNCTION NAMES 01862000
LA R4,EBLTINS END OF SAME 01863000
LA R5,ABLTINS ADDRESS OF TRANSFER VECTOR 01864000
BLTLP EQU * BUILT-IN SEARCH LOOP 01865000
CLC 16(8,PTR),0(R3) MATCH? 01866000
BE BLDFND BRANCH IF SO 01867000
LA R3,8(,R3) LOOK AT NEXT BUILT-IN NAME 01868000
LA R5,2(,R5) AND BUMP UP R5 IN CASE WE FIND IT 01869000
CR R3,R4 END OF BUILT-INS? 01870000
BL BLTLP LOOP IF NOT 01871000
SPACE 1 01872000
NOTHEX MVC TEMPD(8),16(PTR) MOVE IN NON-HEX TOKEN @V305614 01873000
HEXASSN CLI 24(PTR),FF IS IT THE ONLY ONE ? @V305666 01874000
BE RHSRET RETURN IF SO 01875000
CLC 24(2,PTR),=CL2'+ ' PLUS? 01876000
BE PLUS BRANCH IF SO 01877000
CLC 24(2,PTR),=CL2'- ' MINUS? 01878000
BE MINUS BRANCH IF SO 01879000
CLC 24(2,PTR),=CL2'* ' MULTIPLY? HRC007DS 01879200
BE TIMES BRANCH IF SO HRC007DS 01879400
CLC 24(2,PTR),=CL2'/ ' DIVIDE? HRC007DS 01879600
BE DIVIDE BRANCH IF SO HRC007DS 01879800
B ERRASS ASSIGNMENT ERROR 01880000
BLDFND EQU * FOUND A BUILT-IN FUNCTION 01881000
LH R3,0(,R5) FORM TRANSFER ADDRESS 01882000
AR R3,BASE 01883000
LA R5,TEMPD POINT TO TEMPD WITH R5 01884000
LA R6,TEMPD+7 AND TO END OF IT WITH R6 01885000
LA R7,24(,PTR) POINT TO THE NEXT TOKEN WITH R7 01886000
BR R3 AND BRANCH TO THE RIGHT ROUTINE 01887000
SPACE 01888000
CONCAT EQU * 'CONCAT' BUILT-IN FUNCTION 01889000
CLI 0(R7),X'FF' NO MORE? 01890000
BE RHSRET BRANCH IF SO (RETURN) 01891000
BAL RET,GIVLEN GET LNEGTH OF TOKEN POINTED AT BY R7 01892000
LTR R9,R15 MOVE THE ANSWER INTO R9 01893000
BNH CONCAT1 BRANCH IF <= 0 01894000
BCTR R15,0 DECREASE FOR EXEC 01895000
EX R15,MOVCON MOVE IT IN (MAY OVERFLOW INTO CVD) 01896000
AR R5,R9 MOVE ALONG FOR NEXT ONE 01897000
CR R5,R6 PAST THE END? 01898000
BH RHSRET BRANCH IF SO (RETURN) 01899000
CONCAT1 EQU * 01900000
LA R7,8(,R7) LOOK AT NEXT TOKEN 01901000
B CONCAT REPEAT FOR THIS TOKEN 01902000
SPACE 01903000
MOVCON MVC 0(*-*,R5),0(R7) 01904000
SPACE 01905000
LENGTH EQU * 'LENGTH' BUILT-IN FUNCTION 01906000
SR R15,R15 SET FOR ZERO 01907000
CLI 24(PTR),X'FF' RIGHT? 01908000
BE *+8 SKIP IF SO 01909000
BAL RET,GIVLEN GET LENGTH 01910000
CVD R15,CVDSPACE CONVERT TO PACKED DECIMAL 01911000
LA R3,CVDSPACE+4 POINT TO THE LAST 4 BYTES OF IT 01912000
BAL RET,UNPACK4 UNPACK IT INTO TEMPD @VA02322 01913000
B RHSRET RETURN 01914000
SPACE 01915000
SUBSTR EQU * 'SUBSTR' BUILT-IN FUNCTION 01916000
CLI 0(R7),X'FF' ANY ARGS? 01917000
BE ERRBLTN BRANCH IF NOT (ERROR) 01918000
CLI 8(R7),X'FF' SECOND ARG PRESENT? 01919000
BE ERRBLTN BRANCH IF NOT (ERROR) 01920000
LA R9,7 SET R9 TO 7 FOR LATER 01921000
LA R7,8(,R7) POINT TO FIRST NUMERIC ARGUMENT 01922000
BAL RET,CVDBCD CONVERT TO DECIMAL 01923000
BNZ ERRCONV BRANCH IF CONVERSION ERROR 01924000
CVB R3,CVDSPACE CONVERT TO BINARY 01925000
BCTR R3,0 DECREASE FOR ADDRESS CALCULATION 01926000
LTR R3,R3 CHECK THAT IT'S >= 0 01927000
BL ERRBLTN BRANCH IF IT'S NOT (ERROR) 01928000
LR R4,R9 ASSUME 3RD ARGUMENT IS ABSENT (SET LEN=8) 01929000
LA R7,8(,R7) POINT TO LAST ARGUMENT 01930000
CLI 0(R7),X'FF' TRUE? 01931000
BE MOVSUBS BRANCH IF SO 01932000
BAL RET,CVDBCD CONVERT TO PACKED DECIMAL 01933000
BNZ ERRCONV BRANCH IF CONVERSION ERROR 01934000
CVB R4,CVDSPACE CONVERT TO BINARY 01935000
LTR R4,R4 TEST IT 01936000
BL ERRBLTN BRANCH IF < 0 (ERROR) 01937000
BZ RHSRET BRANCH IF ZERO (ALL DONE) 01938000
BCTR R4,0 DECREASE FOR EXEC 01939000
MOVSUBS EQU * 01940000
SR R9,R3 NUMBER OF BYTES AVAILABLE - 1 01941000
BL RHSRET BRANCH IF NONE (RETURN) 01942000
CR R4,R9 TOO MANY ASKED FOR? 01943000
BNH *+6 SKIP IF NOT 01944000
LR R4,R9 SET TO THE MAXIMUM 01945000
SH R7,=H'16' POINT TO TOKEN TO BE SUBSTRED 01946000
LA R7,0(R3,R7) POINT TO BYTE WHERE WE START 01947000
EX R4,MOVSUBST MOVE IN THE RIGHT SUBSTRING 01948000
B RHSRET RETURN 01949000
SPACE 01950000
MOVSUBST MVC TEMPD(*-*),0(R7) 01951000
SPACE 01952000
DATATYP EQU * RETURNS 'NUM' OR 'CHAR' 01953000
MVC TEMPD(3),=CL3'NUM' ASSUME IT'S A NUMBER 01954000
BAL RET,CVDBCD CONVERT TO NUMERICS 01955000
BZ RHSRET BRANCH IF SUCCESSFUL 01956000
MVC TEMPD(4),=CL4'CHAR' SAY 'CHAR' 01957000
B RHSRET 01958000
SPACE 01959000
PLUS EQU * 01960000
MINUS EQU * 01961000
TIMES EQU * HRC007DS 01961300
DIVIDE EQU * HRC007DS 01961600
LA R7,16(,PTR) ADDRESS OF FIRST TOKEN ON RHS 01962000
BAL RET,CVDBCD CONVERT TO PACKED 01963000
BNZ ERRCONV BRANCH IF CONVERSION ERROR 01964000
ZAP TEMPD(5),CVDSPACE(8) MOVE ANS INTO TOP TEMPD @VA02322 01965000
BC B'1110',NUMOK BRANCH IF NO OVERFLOW @VA02322 01966000
OVERFLOW EQU * @VA02322 01967000
TM TEMPD+4,X'0D' UNDERFLOW?? @VA02322 01968000
BO ERRUFLW YES... @VA02322 01969000
B ERROFLW NO, MUST BE OVERFLOW @VA02322 01970000
NUMOK EQU * @VA02322 01971000
BO ERRCONV BRANCH IF OVERFLOW 01972000
ASSLOOP EQU * LOOP THROUGH PLUSES AND MINUSES 01973000
LA R6,8(,R7) POINT TO + OR - 01974000
LA R7,16(,R7) POINT TO TOKEN TO BE ADDED OR SUBTRACTED 01975000
CLI 0(R7),X'FF' TOKEN ABSENT? 01976000
BE ERRASS BRANCH IF SO 01977000
SPACE 1 01978000
NOTHEX2 BAL RET,CVDBCD CONVERT TO PACKED @V305614 01979000
BNZ ERRCONV BRANCH IF CONVERSION ERROR 01980000
CLC 0(2,R6),=CL2'+ ' PLUS? 01981000
BNE ASGNSUB CHECK IF SUBTRACTION @VA02322 01982000
AP TEMPD(5),CVDSPACE(8) SUBTRACT THE NUMBER @VA02322 01983000
B ASGNEND CONTINUE WITH CHECK FOR OVERFLOW @VA02322 01984000
ASGNSUB EQU * @VA02322 01985000
CLC 0(2,R6),=CL2'- ' MINUS? 01986000
BNE ASGNUML NO, KEEP CHECKING HRC007DS 01987490
SP TEMPD(5),CVDSPACE(8) SUBTRACT THE NUMBER @VA02322 01988000
B ASGNEND CONTINUE WITH CHECK FOR OVERFLOW HRC007DS 01988040
ASGNUML CLC 0(2,R6),=CL2'* ' TIMES HRC007DS 01988080
BNE ASGNDIV NO.... HRC007DS 01988120
CVB R1,CVDSPACE GET MULTIPLIER HRC007DS 01988160
ZAP CVDSPACE(8),TEMPD(5) HRC007DS 01988200
CVB R15,CVDSPACE MULTIPLICAND HRC007DS 01988240
MR R0,R15 MULTIPLY HRC007DS 01988280
SLDA R0,32 CHECK FOR OVERFLOW HRC007DS 01988320
CVD R0,CVDSPACE CONVERT HRC007DS 01988360
MVC TEMPD+4(1),CVDSPACE+7 GET SIGN IN CASE OVERFLOW HRC007DS 01988400
BO OVERFLOW HRC007DS 01988440
ZAP TEMPD(5),CVDSPACE(8) HRC007DS 01988480
B ASGNEND CONT CHECK FOR OVERFLOW HRC007DS 01988520
ASGNDIV CLC 0(2,R6),=CL2'/ ' DIVIDE? HRC007DS 01988560
BNE ERRASS ERROR IF NOT HRC007DS 01988600
CVB R15,CVDSPACE GET DIVISOR HRC007DS 01988640
ZAP CVDSPACE(8),TEMPD(5) HRC007DS 01988680
CVB R1,CVDSPACE DIVIDEND HRC007DS 01988720
LTR R15,R15 HRC007DS 01988760
BZ ERRDIVZ CAN'T DIVIDE BY ZERO HRC007DS 01988800
SLR R0,R0 CLEAR FOR DIVIDE HRC007DS 01988840
DR R0,R15 DIVIDE HRC007DS 01988880
CVD R1,CVDSPACE QUOTIENT HRC007DS 01988920
ZAP TEMPD(5),CVDSPACE(8) HRC007DS 01988960
ASGNEND BO OVERFLOW REAL OVERFLOW? @VA02322 01989000
TM TEMPD,X'F0' TOO LARGE A NUMBER FOR EXEC? @VA02322 01990000
BNE OVERFLOW CHECK TYPE OF VIOLATION @VA02322 01991000
CLI 8(R7),X'FF' END? 01992000
BNE ASSLOOP LOOP IF NOT 01993000
LA R3,TEMPD POINT TO ANSWER 01994000
BAL RET,UNPACK5 AND UNPACK IT INTO TEMPD @VA02322 01995000
SPACE 01996000
RHSRET EQU * RETURN FROM RHS 01997000
LM R3,R10,TEMSUB RESTORE REGISTERS 01998000
BR RET RETURN 01999000
SPACE 2 02000000
* GIVLEN RETURNS THE LENGTH IN R15 OF THE TOKEN POINTED AT BY R7 02001000
SPACE 02002000
GIVLEN DS 0H 02003000
LA R15,7(,R7) LOOK AT LAST BYTE OF TOKEN 02004000
CLI 0(R15),C' ' BLANK? 02005000
BNE *+12 SKIP IF NOT 02006000
BCTR R15,0 LOOK AT PREVIOUS BYTE 02007000
CR R15,R7 HAVE WE GONE TOO FAR? 02008000
BNL GIVLEN+4 LOOP IF NOT 02009000
LA R15,1(,R15) INCREMENT R15 02010000
SR R15,R7 GET LENGTH 02011000
BR RET RETURN 02012000
SPACE 2 02013000
* 'UNPACK' IS A SUBROUTINE WHICH UNPACKS A PACKED 02014000
* DEC. NUM. OF LENGTH 4 OR 5, WHICH IS POINTED TO BY R3, 02015000
* AND MOVES THE ANSWER TO TEMPD. USES R9 AS A TEMP. 02016000
SPACE 02017000
UNPACK4 LA R9,3 LENGTH OF FIELD FOR COMPARE @VA02322 02018000
B UNPACK @VA02322 02019000
UNPACK5 LA R9,4 @VA02322 02020000
UNPACK EQU * @VA02322 02021000
SLL R9,4 SET UP L1, L2 FIELD FOR COMPARE @VA02322 02022000
EX R9,INS1 IS IT ZERO? @VA02322 02023000
BNE UNPNOTZ NO, UNPACK IT THEN @VA02322 02024000
MVC TEMPD(8),BLANKS SET RESULTING VALUE TO ZERO @VA02322 02025000
MVI TEMPD,X'F0' SINGLE 0 FOLLOWED BY BLANKS @VA02322 02026000
BR RET RETURN 02027000
UNPNOTZ EQU * IT'S NOT ZERO 02028000
SRL R9,4 SET UP L1, L2 FOR UNPACK @VA02322 02029000
O R9,=X'00000070' SET L1 LENGTH TO 8 @VA02322 02030000
EX R9,INS2 @VA02322 02031000
TM TEMPD+7,X'D0' MINUS SIGN? 02032000
BNO UNPIPLUS @VA02322 02033000
CLI TEMPD,X'F0' IF NEG, MUST BE < 8 DIGITS @VA02322 02034000
BNE ERRUFLW IF NOT, EXEC ARITHMETIC UNDERFLOW@VA02322 02035000
OI TEMPD+7,X'F0' SET ZONE 02036000
B *+8 02037000
UNPIAGN EQU * 02038000
MVI TEMPD+7,C' ' CLEAR THE LAST SPOT 02039000
CLI TEMPD+1,X'F0' LOOK AT 2ND SPOT 02040000
BNE UNPIOUT BRANCH IF NOT A ZERO 02041000
MVC TEMPD(7),TEMPD+1 SHIFT ONE CHARACTER TO LEFT 02042000
B UNPIAGN LOOP 02043000
UNPIOUT EQU * 02044000
MVI TEMPD,C'-' INSERT A MINUS SIGN 02045000
BR RET RETURN 02046000
UNPIPLUS EQU * IT'S PLUS 02047000
OI TEMPD+7,X'F0' SET ZONE @VA02322 02048000
CLI TEMPD,X'F0' LEADING ZERO? @VA02322 02049000
BNER RET NO, OK AS IS @VA02322 02050000
MVC TEMPD(7),TEMPD+1 SHIFT ONE CHARACTER TO LEFT 02051000
MVI TEMPD+7,C' ' AND CLEAR LAST SPOT 02052000
B UNPIPLUS+4 CONTINUE @VA02322 02053000
INS1 CP 0(*-*,R3),DECZERO(1) @VA02322 02054000
INS2 UNPK TEMPD(8),0(*-*,R3) @VA02322 02055000
SPACE 2 02056000
* 02057000
* THIS SUBROUTINE PUTS A LINE INTO FREE-FORMAT 02058000
* (TOKENS SEPARATED BY ONE BLANK) IN THE BUFFER UNSCND. 02059000
* ON ENTRY, R15 GIVES THE MAXIMUM ALLOWABLE LENGTH. 02060000
* RETURNS THE ACTUAL LENGTH IN R15. 02061000
SPACE 02062000
FREESUB DS 0H 02063000
STM R1,R4,TEMSUB2 SAVE REGISTERS 02064000
LR R4,R15 SAVE MAXIMUM ALLOWABLE LENGTH 02065000
LA R15,UNSCND GET ADDRESS OF UNSCND BUFFER 02066000
AR R4,R15 ADDRESS OF BYTE BEYOND LAST ALLOWABLE 02067000
LR R1,PTR LOOK AT FIRST TOKEN 02068000
CLI 0(R1),X'FF' END OF LINE? 02069000
BE FREEEND1 BRANCH IF SO 02070000
FREELP1 LA R3,7(R1) LOOK AT 8TH BYTE OF TOKEN 02071000
FREELP2 CLI 0(R3),C' ' IS THIS BYTE A BLANK? 02072000
BNE FREEMOV BRANCH IF NOT (MOVE TOKEN) 02073000
BCTR R3,0 LOOK AT PREVIOUS BYTE 02074000
CR R3,R1 HAVE WE GONE PAST 1ST BYTE OF TOKEN? 02075000
BNL FREELP2 BRANCH IF NOT (LOOP) 02076000
B FREENEXT GO DEAL WITH NEXT TOKEN 02077000
FREEMOV SR R3,R1 BYTES TO MOVE MINUS 1 02078000
LA R2,1(R15) POINT TO 2ND FREE BYTE OF FRELINE 02079000
AR R2,R3 AND ADD R3 02080000
CR R2,R4 IS TOKEN TOO LONG FOR REMAINING SPACE? 02081000
BH FREEEND BRNCH IF SO (ABNDN THIS AND RMNNG TOKS) 02082000
EX R3,FREEMVC MOVE THE TOKEN, LESS UNNECESSARY BLANKS 02083000
MVI 0(R2),C' ' AND FOLLOW WITH A BLANK 02084000
LA R15,1(R2) POINT TO NEXT FREE BYTE OF UNSCND 02085000
FREENEXT LA R1,8(R1) LOOK AT NEXT TOKEN 02086000
CLI 0(R1),X'FF' END OF SOURCE? 02087000
BNE FREELP1 LOOP IF NOT 02088000
FREEEND BCTR R15,0 POINT TO LAST BYTE USED (WILL BE BLANK) 02089000
FREEEND1 LA R2,UNSCND ADDRESS OF NEW BUFFER 02090000
SR R15,R2 NO. OF BYTES IN IT 02091000
LM R1,R4,TEMSUB2 RESTORE REGISTERS 02092000
BR RET RETURN 02093000
SPACE 02094000
FREEMVC MVC 0(0,R15),0(R1) MOVE A TOKEN 02095000
SPACE 1 02096000
FRET ST R14,SAV14 SAVE R14, @VM03083 02097000
SSM OFF DISABLE FOR INTERRUPTS @VA05743 02098000
DMSFRET DWORDS=(0),LOC=(1),TYPCALL=BALR @VM03083 02099000
SSM ON ENABLE FOR INTERRUPTS @VA05743 02100000
L R14,SAV14 RESTORE R14, @VM03093 02101000
BR RET AND RETURN. @VM03093 02102000
FREE ST R14,SAV14 SAVE R14, @VM03083 02103000
SSM OFF DISABLE FOR INTERRUPTS @VA05743 02104000
DMSFREE DWORDS=(0),TYPCALL=BALR @VM03083 02105000
SSM ON ENABLE FOR INTERRUPTS @VA05743 02106000
L R14,SAV14 RESTORE R14 02107000
BR RET 02108000
SPACE 1 02109000
APPEND ST RET,UNCHSAV+8 02110000
STM R0,R1,UNCHSAV 02111000
L R8,ANCHOR GET ADDRESS OF BASE BLOCK @VA07244 02112000
B CHCK1 START CHECKING @VA07244 02113000
CHCK0 EQU * @VA07244 02114000
L R8,0(,R8) GET ANOTHER BLOCK @VA07244 02115000
CHCK1 EQU * @VA07244 02116000
CLC 0(4,R8),ZERO IS THIS THE END OF CHAIN ? @VA07244 02117000
BNE CHCK0 NO,...CHECK AGAIN @VA07244 02118000
ST R8,CHAD SAVE ADDRESS OF CHAIN LINK @VA07244 02119000
L R0,LINKLEN 02120000
AH R0,=H'11' 4 FOR PTR + 7 FOR TRUNCATION 02121000
SRL R0,3 NO OF DOUBLE WORDS 02122000
BAL RET,FREE 02123000
XC 0(4,R1),0(R1) ZERO IT 02124000
L R10,CHAD 02125000
ST R1,0(,R10) 02126000
LA R10,4(,R1) GET ADDR OF DATA 02127000
ST R10,ADDR 02128000
LM R0,R1,UNCHSAV 02129000
L RET,UNCHSAV+8 02130000
BR RET 02131000
SPACE 2 02132000
* UNCHALL RELEASES ENTIRE CHAIN TO FREE STORAGE 02133000
* REQUIRES LINKLEN SET 02134000
UNCHALL STM R0,R3,UNCHSAV 02135000
LR R3,RET 02136000
L R0,LINKLEN 02137000
AH R0,=H'11' LA WONT WORK 02138000
SRL R0,3 NO DOUB WORDS 02139000
L R1,ANCHOR GET ADDR OF BASE BLOCK 02140000
L R2,0(,R1) 02141000
XC 0(4,R1),0(R1) 02142000
CHALG C R2,=F'0' 02143000
BZ CHAPF 02144000
LR R1,R2 02145000
L R2,0(,R2) 02146000
BAL RET,FRET 02147000
B CHALG 02148000
CHAPF LR RET,R3 02149000
LM R0,R3,UNCHSAV 02150000
BR RET 02151000
* AN ASSIGNMENT TOKEN PREFIXED BY 'X'' INDICATES A 02152000
* HEX VALUE. THE HEXDEC ROUTINE CONVERTS THE HEX VALUE 02153000
* TO THE USUAL PACKED DECIMAL FORM. 02154000
* AT INPUT REG 9 POINTS TO THE FIRST HEX DIGIT, AND 02155000
* REG 3 IS THE RETURN ADDRESS. 02156000
SPACE 1 02157000
HEXDEC EQU * @V305614 02158000
LR R10,R8 PICK UP MAX FIELD LENGTH @VA06198 02159000
SR R5,R5 CLEAR WORK REGISTER @V305614 02160000
SR R4,R4 CLEAR RESULT REGISTER @V305614 02161000
SPACE 1 02162000
HDLOOP CLI 0(R9),END IS THIS THE END ? @V305666 02163000
BE HDDONE YES, BR @V305614 02164000
IC R5,0(,R9) TAKE THE BYTE @V305614 02165000
CLI 0(R9),CHAR0 COULD IT BE 'A - 'F' ? @V305666 02166000
BL AFCHK YES, BR @V305614 02167000
SPACE 1 02168000
CLI 0(R9),CHAR9 ERROR IF GREATER @V305666 02169000
BH ERRCONV THAN 9 @VM03209 02170000
SH R5,CLR1 STRIP THE 'F' @V305614 02171000
HDLOOP1 SLL R4,4 MAKE ROOM FOR THE DIGIT @V305614 02172000
AR R4,R5 AND INSERT IT @V305614 02173000
SPACE 1 02174000
LA R9,1(,R9) POINT TO THE NEXT ONE @V305614 02175000
BCT R10,HDLOOP AND REPEAT @V305614 02176000
B HDDONE UNTIL DONE @V305614 02177000
SPACE 1 02178000
AFCHK CLI 0(R9),A HAS TO BE @V305666 02179000
BL ERRCONV AN 'A' TO 'F' RANGE @VM03209 02180000
CLI 0(R9),F RANGE @V305666 02181000
BH ERRCONV ELSE, ERROR @VM03209 02182000
SH R5,CLR2 TRANSLATE TO HEX @V305614 02183000
B HDLOOP1 AND CONTINUE @V305614 02184000
SPACE 1 02185000
HDDONE EQU * @V305614 02186000
TM FLAG1,SUBSTD IS NUMBER FROM TEMPD? @VA06198 02187000
BZ HDDONE3 NO - IT SHOULD BE OK - GO USE IT @VA06198 02188000
CLI 0(R6),DASH IS IT NEGATIVE? @VA06198 02189000
BNE HDDONE1 NO - USE PLUS LIMIT @VA06198 02190000
L R5,HMAXNEG LOAD NEG MAX NUMBER @VA06198 02191000
B HDDONE2 GO CHECK THE NUMBER @VA06198 02192000
HDDONE1 EQU * @VA06198 02193000
L R5,HMAXPLUS LOAD MAX POSITIVE NUMBER @VA06198 02194000
HDDONE2 EQU * @VA06198 02195000
CR R4,R5 IS NUMBER VALID? @VA06198 02196000
BH ERRCONV NO - GO TELL THE WORLD @VA06198 02197000
HDDONE3 EQU * @VA06198 02198000
CVD R4,CVD CONVERT TO DECIMAL @V305614 02199000
BR R3 RETURN TO CALLER @V305614 02200000
EJECT 02201000
DS 0F P0816 02202000
TYPLIST DC CL8'TYPLIN' 02203000
DC AL1(1) 02204000
DC AL3(0) 02205000
DC C'B' 02206000
DC AL3(0) 02207000
SPACE 2 02208000
ABCD DS 0D 02209000
DC CL8'WAITRD ' FOR READING FROM TYPEWRITER 02210000
DC AL1(1) 02211000
DC AL3(0) * WILL BE BUFFER FROM FREE STOR 02212000
DC CL1'U' FOR CLEANUP (AT SIGN AND CENT SIGN) 02213000
DC AL3(0) 02214000
SPACE 1 02215000
SPACE , HRC007DS 02215470
SETDSK DC CL8'STATE' 02216000
DC CL8'FNAME' 02217000
DC CL8'EXEC' 02218000
DC CL2' ' 02219000
DC H'1' WE KEEP TRACK OF ITEM NO. 02220000
DC AL4(0) 02221000
DC AL4(130) ALLOW FILE WIDTH UP TO 130 02222000
DC CL2'F' 02223000
DC H'1' 02224000
DC F'0' 02225000
* 02226000
CONWAIT DS 0F 02227000
DC CL8'CONWAIT' 02228000
DC CL4'CON1' 02229000
* 02230000
SPACE 1 02231000
SPACE 02232000
DS 0H 02233000
COMBEG EQU * 02234000
DC C'EQ ' P0193 02235000
DC X'80' P0193 02236000
DC C'NE ' P0193 02237000
DC X'70' P0193 02238000
DC C'GT ' P0193 02239000
DC X'20' P0193 02240000
DC C'LT ' P0193 02241000
DC X'40' P0193 02242000
DC C'LE ' P0193 02243000
DC X'D0' P0193 02244000
DC C'GE ' P0193 02245000
DC X'B0' P0193 02246000
SPACE 1 02247000
DC C'= ' @V305604 02248000
DC X'80' @V305604 02249000
DC C'¬= ' @V305604 02250000
DC X'70' @V305604 02251000
DC C'> ' @V305604 02252000
DC X'20' @V305604 02253000
DC C'< ' @V305604 02254000
DC X'40' @V305604 02255000
DC C'<= ' @V305604 02256000
DC X'D0' @V305604 02257000
DC C'>= ' @V305604 02258000
DC X'B0' @V305604 02259000
COMEND EQU * 02260000
EJECT 02261000
SPACE 1 02262000
ADLIST DS 0F 02263000
DC AL2(LOOP-EXECTOR) THIS IS FOR &CONTINUE 02264000
DC AL2(LOOP-EXECTOR) THIS IS FOR &COMMENT 02265000
DC AL2(CWIFXX-EXECTOR) 02266000
DC AL2(CWSKIP-EXECTOR) 02267000
DC AL2(CWSTAC-EXECTOR) 02268000
DC AL2(CWSPAC-EXECTOR) 02269000
DC AL2(CWTYPE-EXECTOR) 02270000
DC AL2(CJS-EXECTOR) HRC380DS 02270100
DC AL2(CWHEX-EXECTOR) @VM03234 02271000
DC AL2(CWTIME-EXECTOR) 02272000
DC AL2(CWERRO-EXECTOR) 02273000
DC AL2(CWEXIT-EXECTOR) 02274000
DC AL2(CWBEGS-EXECTOR) 02275000
DC AL2(CWPRIN-EXECTOR) 02276000
DC AL2(CWTYPER-EXECTOR) @VM03208 02277000
DC AL2(CWBEGERR-EXECTOR) @VM03208 02278000
DC AL2(CWPUNC-EXECTOR) 02279000
DC AL2(CWBEGPR-EXECTOR) 02280000
DC AL2(CWBEGPUN-EXECTOR) 02281000
DC AL2(CWGOTO-EXECTOR) 02282000
DC AL2(CWLOOP-EXECTOR) 02283000
DC AL2(CWREAD-EXECTOR) 02284000
DC AL2(CWARG-EXECTOR) 02285000
DS 0D 02286000
ABLTINS DS 0H 02287000
DC AL2(CONCAT-EXECTOR) 02288000
DC AL2(LENGTH-EXECTOR) 02289000
DC AL2(SUBSTR-EXECTOR) 02290000
DC AL2(DATATYP-EXECTOR) 02291000
EXECWRDS EQU * 02292000
ECONT DC X'50',CL7'CONTINU' 02293000
DC X'50',CL7'COMMENT' 02294000
EIFXX DC X'50',CL7'IF ' 02295000
DC X'50',CL7'SKIP ' 02296000
DC X'50',CL7'STACK ' 02297000
DC X'50',CL7'SPACE ' 02298000
DC X'50',CL7'CONTROL' 02299000
DC X'50',CL7'TRACE ' HRC380DS 02299100
DC X'50',CL7'HEX ' @VM03234 02300000
DC X'50',CL7'TIME ' 02301000
EERRO DC X'50',CL7'ERROR ' 02302000
EEXIT DC X'50',CL7'EXIT ' 02303000
DC X'50',CL7'BEGSTAC' 02304000
DC X'50',CL7'TYPE ' 02305000
DC X'50',CL7'EMSG ' @VM03208 02306000
DC X'50',CL7'BEGEMSG' @VM03208 02307000
DC X'50',CL7'PUNCH ' 02308000
DC X'50',CL7'BEGTYPE' 02309000
DC X'50',CL7'BEGPUNC' 02310000
DC X'50',CL7'GOTO ' 02311000
ELOOP DC X'50',CL7'LOOP ' 02312000
DC X'50',CL7'READ ' 02313000
DC X'50',CL7'ARGS ' 02314000
BLTINS EQU * 02315000
DC X'50',CL7'CONCAT' 02316000
DC X'50',CL7'LENGTH' 02317000
DC X'50',CL7'SUBSTR' 02318000
DC X'50',CL7'DATATYP' 02319000
EBLTINS EQU * 02320000
EBEGLOB EQU * 02321000
EGLOB DC X'50',CL7'GLOBAL ' 02322000
DC X'50',CL7'GLOBAL0' 02323000
DC X'50',CL7'GLOBAL1' 02324000
DC X'50',CL7'GLOBAL2' 02325000
DC X'50',CL7'GLOBAL3' 02326000
DC X'50',CL7'GLOBAL4' 02327000
DC X'50',CL7'GLOBAL5' 02328000
DC X'50',CL7'GLOBAL6' 02329000
DC X'50',CL7'GLOBAL7' 02330000
DC X'50',CL7'GLOBAL8' 02331000
DC X'50',CL7'GLOBAL9' 02332000
ERETCOD DC X'50',CL7'RETCODE' 02333000
EXECEND EQU * @VA03453 02334000
EINDE DC X'50',CL7'INDEX ' 02335000
ELINE DC X'50',CL7'LINENUM' 02336000
EEXEC DC X'50',CL7'EXEC ' 02337000
EREADFLG DC X'50',CL7'READFLA' 02338000
ETYPEFLG DC X'50',CL7'TYPEFLA' 02339000
ESTAR DC X'50',CL7'* ' 02340000
EDOLL DC X'50',CL7'$ ' 02341000
ELITERAL DC X'50',CL7'LITERAL' 02342000
EDISK DC X'50',CL7'DISK' @V305101 02343000
EDOS DC X'50',CL7'DOS ' @V305101 02344000
EENDS DC X'50',CL7'END ' 02345000
SPACE 1 02346000
VSRLIST DC CL8'DMSVSR',8X'FF' DMSVSR(VSAM CLEANUP) LIST @V305106 02347000
SPACE 1 02348000
ATTNFIFO DC CL8'ATTN' KEEP THESE TWO DC'S @V305614 02349000
DC CL4'FIFO' TOGETHER @V305614 02350000
SPACE 1 02351000
CARDPH DC CL8'CARDPH' @V305614 02352000
POINTC DC CL8'POINT' @V305614 02353000
CHON DC CL8'ON' @VM03234 02354000
CHOFF DC CL8'OFF' @VM03234 02355000
ON DC X'FF' ENABLE FOR ALL INTERRUPTS @VA06392 02356000
OFF DC X'00' DON'T SEPARATE OFF + DECZERO @V305614 02357000
XPREFIX DC CL2'X''' PREFIX FOR HEX ASSIGNMENT @V305614 02358000
CLR1 DC H'240' =X'00F0' @V305614 02359000
CLR2 DC H'183' =H'00B7' @V305614 02360000
DECZERO DC PL1'+0' @V305614 02361000
DECONE DC PL1'+1' @V305614 02362000
BLANKS DC CL8' ' @V305614 02363000
SPACE 1 02364000
CMSDSK DC CL8'CMS' @V305101 02365000
DOSDSK DC CL8'DOS' @V305101 02366000
OSDSK DC CL8'OS' @V305101 02367000
NODSK DC CL8'NA' @V305101 02368000
NONE DC CL8'NONE' @V305101 02369000
DMS DC C'DMS' FOR EMSG HEADER @VM03208 02370000
SPACE 1 02371000
* THE FOLLOWING GROUP OF CONSTANTS ARE USED TO INITIALIZE 02372000
* THE FREE STORAGE AREA. 02373000
INITFREE DC PL5'+000' @V305614 02374000
DC 10PL5'+001' @V305614 02375000
FREECON DC CL28'T= ' @V305614 02376000
DC CL20' LOOP UNTIL:' @VA06278 02377000
RTINIT DC CL8'RT' @VM03181 02378000
ERRFLGS DC X'8000' FLAGS FOR &EMSG @VM03208 02379000
AMPZERO DC CL2'0 ' @VM03209 02380000
H30 DC H'30' @VM03209 02381000
H5 DC H'5' @VM03209 02382000
HMAXNEG DC A(9999999) MAX NEG NUMBER FOR CONVERSION @VA06198 02383000
HMAXPLUS DC A(99999999) MAX POS NUMBER FOR CONVERT @VA06198 02384000
AMPASTER DC X'505C40' '&* ' @VA07374 02384200
F1 DC F'1' @VA07374 02384400
DISKASTR DC X'50C4C9E2D25C40' '&DISK* ' @VA07374 02384600
DISKQUES DC X'50C4C9E2D26F40' '&DISK? ' @VA07374 02384800
EJECT 02385000
LTORG @VM03209 02386000
EJECT 02387000
* 02388000
* 'SUBSTIT' SUBSTITUTES FOR ALL REPLACEABLE EXEC VARIABLES 02389000
* IN THE TOKEN POINTED TO BY R6. 02390000
* SCANNING STARTS FROM THE RIGHT, AND PROCEEDS UNTIL AN '&' 02391000
* IS FOUND. THEN AN ATTEMPT IS MADE TO FIND A MATCH WITH THE 02392000
* NAME OF A VARIABLE, AND THE VALUE IS USED. 02393000
* IF THE NAME IS OF A VARIABLE WHICH HAS NOT BEEN DEFINED, THEN 02394000
* IT IS REPLACED BY BLANKS. 02395000
* CONTROL WORDS AND FUNCTIONS ARE NOT AFFECTED. 02396000
* SCANNING THEN CONTINUES TO THE LEFT. 02397000
* IF THE FIRST 2 CHARACTERS OF THE TOKEN ARE X' AND THIS IS NOT 02398000
* AN ASSIGNMENT STATEMENT, THE VALUE, WHETHER IT IS SUBSTITUTED 02399000
* OR SPECIFIED EXPLICITLY, IS CONVERTED FROM DECIMAL TO HEX. 02400000
* IF THIS IS AN ASSIGNMENT STATEMENT, HEX TO DECIMAL CONVERSION IS 02401000
* DONE HERE. 02402000
SPACE 1 02403000
ORG DMSEXT+X'2000' @VM03209 02404000
SUBSTIT DS 0H @VM03209 02405000
USING *,R15 @VM03209 02406000
STM R3,R10,TEMSUB SAVE REGISTERS @VM03209 02407000
NI FLAG1,255-SUBSTD RESET SUBSTITUTE FLAG @VM03209 02408000
MVC PENULT(8),0(R6) SAVE TOKEN @VM03209 02409000
LA R7,7(,R6) POINT AT LAST CHAR OF TOKEN @VM03209 02410000
SUBLOOP EQU * SCAN THE TOKEN BACKWARDS @VM03209 02411000
CLI 0(R7),X'50' '&'? @VM03209 02412000
BE SUBGO BRANCH IF SO @VM03209 02413000
SUBLOOPA EQU * POINT FOR RETURN TO @VM03209 02414000
CR R7,R6 HAVE WE REACHED THE BEGINNING? @VM03209 02415000
BE SUBXCHK SEE IF CONVERSION REQUESTED @VM03209 02416000
BCT R7,SUBLOOP LOOP @VM03209 02417000
SPACE 1 02418000
SUBGO EQU * @VM03209 02419000
MVC PENULT(8),0(R6) SAVE TOKEN AS IT IS NOW@VM03209 02420000
LA R8,7(,R6) GET NUMBER OF CHARACTERS INVOLVED@VM03209 02421000
SR R8,R7 (MINUS 1) @VM03209 02422000
MVC TEMPD(8),BLANKS CLEAR OUR TEMP AREA @VM03209 02423000
EX R8,SUBMOVIN AND MOVE IN OUR VARIABLE @VM03209 02424000
CLC TEMPD+1(2),AMPZERO IS IT '&0'? @VM03209 02425000
BE *+12 SKIP IF SO @VM03209 02426000
CLI TEMPD+1,X'F0' IS NEXT CHARACTER A DIGIT 1-9? @VM03209 02427000
BNH SUBVAR BRANCH IF NOT (TRY FOR USER VARIABLE) @VM03209 02428000
LA R7,1(,R7) BUMP UP R7 TO POINT TO THE NUMBER@VM03209 02429000
BAL RET,CVDBCD CONVERT TO PACKED @VM03209 02430000
BCTR R7,0 RESTORE R7 @VM03209 02431000
BNZ SUBVAR BRANCH IF CONVERSION ERROR (TRY FOR VAR)@VM03209 02432000
CVB R9,CVDSPACE CONVERT TO BINARY @VM03209 02433000
CH R9,H30 TOO BIG? @VM03209 02434000
BH SUBNOT BRANCH IF SO (USE BLANKS) @VM03209 02435000
LTR R9,R9 IS THIS '&0'? @VM03209 02436000
SLL R9,3 MULTIPLY BY 8 @VM03209 02437000
LA R9,ARGTABLE(R9) POINT TO THE VALUE @VM03209 02438000
SUBARG1 EQU * SUBSTITUTE AN ARGUMENT (OR A VARIABLE)@VM03209 02439000
MVC TEMPD(8),0(R9) MOVE THE VALUE INTO OUR TEMP @VM03209 02440000
B SUBSET AND GO MAKE THE SUBSTITUTION @VM03209 02441000
SPACE 1 02442000
SUBXCHK EQU * @VM03234 02443000
CLI HEXSW,FF HEX CONVERSION ON ? @VM03234 02444000
BNE SUBRET NO, BRANCH @VM03234 02445000
CLC 0(2,R7),XPREFIX HEX PREFIX PROVIDED ? @VM03209 02446000
BNE SUBRET NO, NORMAL RETURN @VM03209 02447000
SPACE 1 02448000
TM FLAG1,SUBSTD EXPLICIT NUMBER SPECIFIED ? @VM03209 02449000
BNO SUBXPL YES, BRANCH @VM03209 02450000
LA R9,TEMPD GET 8 BYTE SUBSTITUTION VALUE @VM03209 02451000
LA R8,FULL MAX SIZE IS EIGHT @VM03209 02452000
B SUBXPL1 DETERMINE ACTUAL LENGTH @VM03209 02453000
SPACE 1 02454000
SUBXPL LA R9,2(,R7) POINT TO HEX VALUE @VM03209 02455000
LA R8,PART MAXIMUM SIZE OF NUMBER @VM03209 02456000
SUBXPL1 EQU * @VA06198 02457000
CLI 2(R7),DASH NEGATIVE NUMBER? @VA06198 02458000
BNE SUBXPL3 NO - DONT BUMP POINTERS @VA06198 02459000
LA R9,1(R9) POINT TO NUMBER @VA06198 02460000
BCTR R8,0 ADJUST LENGTH COUNTER @VA06198 02461000
MVI 0(R7),DASH SET MINUS SIGN @VA06198 02462000
LA R7,1(R7) POINT PAST MINUS SIGN @VA06198 02463000
SUBXPL3 EQU * @VA06198 02464000
TM FLAG1,ASSNBIT ASSIGNMENT STATEMENT? @VA06198 02465000
BZ SUBXPL2 NO - GO DO DEC TO HEX CONV @VA06198 02466000
BAL R3,HEXDEC GO DO HEX TO DEC CONVERSION @VA06198 02467000
LA R3,CVD+3 POINT TO CONVERTED NUMBER @VA06198 02468000
BAL RET,UNPACK5 GO UNPACK THE NUMBER @VA06198 02469000
CR R7,R6 NEGATIVE NUMBER? @VA06198 02470000
BNE SUBXMOV7 YES - GO DO SHORT MOVE @VA06198 02471000
MVC 0(8,R7),TEMPD SUBSTITUTE THE TOKEN @VA06198 02472000
B SUBRET RETURN TO CALLER @VA06198 02473000
SUBXMOV7 EQU * @VA06198 02474000
MVC 0(7,R7),TEMPD SUBSTITUTE THE TOKEN @VA06198 02475000
B SUBRET RETURN TO CALLER @VA06198 02476000
SUBXPL2 EQU * @VA06198 02477000
SR R3,R3 ZERO THE COUNT REGISTER @VA06198 02478000
LR R5,R9 SAVE FOR EXECUTE LATER @VA06198 02479000
SPACE 1 02480000
SUBXCNT CLI 0(R9),BLANK THIS LOOP DETERMINES THE SIZE OF @VM03209 02481000
BE SUBXPK THE NUMBER @VM03209 02482000
CLI 0(R9),HEXF0 MUST BE >= 0 @VM03209 02483000
BL SUBXERR ELSE, ERROR @VM03209 02484000
CLI 0(R9),NINE MUST BE <= 9 @VM03209 02485000
BH SUBXERR ELSE, ERROR @VM03209 02486000
SPACE 1 02487000
SUBXOK LA R9,1(,R9) REGISTER 3 WILL CONTAIN @VM03209 02488000
LA R3,1(,R3) THE LENGTH MINUS ONE @VM03209 02489000
BCT R8,SUBXCNT ..... @VM03209 02490000
SPACE 1 02491000
SUBXPK BCTR R3,R0 DECREMENT FOR EXECUTE @VM03209 02492000
LTR R3,R3 IT CAN'T BE AN @VM03209 02493000
BM SUBDH4 UNASSIGNED VARIABLE @VM03209 02494000
EX R3,SUBPACK PACK THE NUMBER FOR CONVERSION @VM03209 02495000
SPACE 1 02496000
CP CVD(8),DECZERO(1) IF IT'S ZERO @VM03209 02497000
BNE SUBNOT0 WE CAN SKIP MOST OF THIS @VM03209 02498000
MVC TEMPD(8),BLANKS BY JUST MOVING IN @VM03209 02499000
MVI TEMPD,HEXF0 A HEX 'F0' @VM03209 02500000
B SUBDH4 .... @VM03209 02501000
SPACE 1 02502000
SUBNOT0 CVB R3,CVD NOW CONVERT IT @VM03209 02503000
LA R5,FULL SET UP DH LOOP COUNT @VM03209 02504000
LA R4,TEMPD+7 FIRST PLACE TO MOVE INTO @VM03209 02505000
SPACE 1 02506000
SUBDH1 STCM R3,LOBYT,ORBYTE GET BINARY NUMBER @VM03209 02507000
NI ORBYTE,HEX0F STRIP TOP HALF @VM03209 02508000
SRL R3,SHFNUM SHIFT IT OUT @VM03209 02509000
CLI ORBYTE,HEX0A ALPHA OR NUMERIC ? @VM03209 02510000
BL SUBDH2 SKIP, IF NUMERIC @VM03209 02511000
SPACE 1 02512000
ICM R9,LOBYT,ORBYTE NOW AND HEX B7 @VM03209 02513000
AH R9,CLR2 TO CONVERT TO PRINTABLE @VM03209 02514000
STCM R9,LOBYT,ORBYTE FORM @VM03209 02515000
B SUBDH3 THEN MOVE IT @VM03209 02516000
SUBDH2 OI ORBYTE,HEXF0 SET NUMERIC ZONE @VM03209 02517000
SUBDH3 MVC 0(1,R4),ORBYTE MOVE IT INTO TEMPD @VM03209 02518000
BCTR R4,R0 BUMP THE TEMPD POINTER @VM03209 02519000
BCT R5,SUBDH1 LOOP 8 TIMES @VM03209 02520000
SPACE 1 02521000
SUBDHLP CLI TEMPD,HEXF0 NOW PAD NONZERO RESULT @VM03209 02522000
BNE SUBDH4 WITH BLANKS TO THE RIGHT @VM03209 02523000
MVC TEMPD(7),TEMPD+1 ..... @VM03209 02524000
MVI TEMPD+7,BLANK ..... @VM03209 02525000
B SUBDHLP ..... @VM03209 02526000
SPACE 1 02527000
SUBDH4 EQU * @VA06198 02528000
CR R6,R7 NEGATIVE NUMBER? @VA06198 02529000
BE SUBDH5 NO - SET UP 8 BYTE MOVE @VA06198 02530000
LA R8,PART SET UP SHORT MOVE @VA06198 02531000
B SUBSET GO MOVE THE NUMBER @VA06198 02532000
SUBDH5 EQU * @VA06198 02533000
LA R8,SEVEN FORCE FULL SUBSTITUTION @VA06198 02534000
B SUBSET AND RETURN TO CALLER @VM03209 02535000
SPACE 1 02536000
SUBPACK PACK CVD(8),0(*-*,R5) @VM03209 02537000
SPACE 1 02538000
SUBVAR EQU * DEAL WITH A POSSIBLE USER VARIABLE @VM03209 02539000
BAL RET,KEYWCK (ORIGINATOR CALLED THEM KEYWORDS)@VM03209 02540000
BNZ SUBARG1 GO USE THE VALUE IF WE FOUND IT @VM03209 02541000
CLC 0(THREE,R7),AMPASTER IS TOKEN '&* ' ? @VA07374 02541080
BE SUBTYPE YES,...BRANCH @VA07374 02541160
CLC 0(SEVEN,R7),DISKASTR IS TOKEN '&DISK* ' ? @VA07374 02541240
BE SUBTYPE YES,...BRANCH @VA07374 02541320
CLC 0(SEVEN,R7),DISKQUES IS TOKEN '&DISK? ' ? @VA07374 02541400
BE SUBTYPE YES,...BRANCH @VA07374 02541480
S R8,F1 GET LENGTH FOR TRANSLATE @VA07374 02541560
EX R8,CHKTOKN GO CHECK TOKEN FOR INVALID CHAR @VA07374 02541640
BNZ ERRCHAR BRANCH IF INVALID CHAR FOUND @VA07374 02541720
A R8,F1 RESTORE R8 @VA07374 02541800
SPACE 1 02542000
SUBTYPE EQU * @VM03209 02543000
CLC TEMPD(8),EEXEC IS THIS &EXEC? @VM03209 02544000
BNE *+14 SKIP IF NOT @VM03209 02545000
MVC TEMPD(8),EXEC SET TO VALUE OF &EXEC @VM03209 02546000
B SUBSET @VM03209 02547000
CLC TEMPD(8),EREADFLG IS THIS &READFLAG? @VM03209 02548000
BNE *+14 SKIP IF NOT @VM03209 02549000
MVC TEMPD(8),READFLAG SET TO VALUE OF &READFLAG @VM03209 02550000
B SUBSET @VM03209 02551000
CLC TEMPD(8),EDOS IS THIS &DOS? @VM03209 02552000
BNE DISKCHK SKIP IF NOT @VM03209 02553000
MVC TEMPD(8),DOS SET TO VALUE OF &DOS @VM03209 02554000
B SUBSET REPLACE @VM03209 02555000
DISKCHK CLC TEMPD(5),EDISK &DISKX? @VM03209 02556000
BNE CHKTYPF NO, TRY NEXT GUY @VM03209 02557000
CLI TEMPD+6,BLANK ONE CHAR ALLOWED FOR MODE @VM03209 02558000
BNE SUBINGL IF MORE, MUST BE USER VAR. @VM03209 02559000
MVC DSKADT(2),TEMPD+5 SET UP REQUEST IN PLIST @VM03209 02560000
LA R1,DSKADT-24 @VM03209 02561000
CLI TEMPD+5,CHARAST ANY READ/WRITE DISK? @VM03209 02562000
BE WRITSRCH IF SO, CALL DMSLADW @VM03209 02563000
CLI TEMPD+5,CHARQUES IF NOT, R/W WITH MOST SPACE @VM03209 02564000
BNE MODESRCH IF NEITHER, CALL DMSLADP @VM03209 02565000
MVI DSKADT+1,CHARQUES ADD ONE MORE '?' TO PLIST @VM03209 02566000
WRITSRCH SR R0,R0 START AT FIRST ADT @VM03209 02567000
LR R5,R15 SAVE OUR BASE @VM03209 02568000
L R15,VCADTLKW USE DMSLADW FOR SPECIALS @VM03209 02569000
BALR R14,R15 @VM03209 02570000
LR R15,R5 RESTORE OUR BASE @VM03209 02571000
BNZ NONESUCH BAD NEWS... @VM03209 02572000
USING ADTSECT,R1 @VM03209 02573000
MVC TEMPD(1),ADTM PLUG THE MODE IN EXEC LINE @VM03209 02574000
MVC TEMPD+1(7),BLANKS BLANK FILL THE REST @VM03209 02575000
B SUBSET CONTINUE... @VM03209 02576000
NONESUCH MVC TEMPD(8),NONE SUBSTITUTE 'NONE' @VM03209 02577000
B SUBSET AND KEEP GOING @VM03209 02578000
MODESRCH LR R5,R15 SAVE OUR BASE @VM03209 02579000
L R15,VCADTLKP USE DMSLADP FOR MODES @VM03209 02580000
BALR R14,R15 @VM03209 02581000
LR R15,R5 RESTORE OUR BASE @VM03209 02582000
BNZ SUBINGL IF NO ADT, ASSUME USER VAR. @VM03209 02583000
TM ADTFLG2,ADTFMFD IS CMS DISK ACCESSED? @VM03209 02584000
BZ CHEKDSK IF NOT CMS DISK, SEE WHAT.. @VM03209 02585000
MVC TEMPD(8),CMSDSK SUBSTITUTE 'CMS' @VM03209 02586000
B SUBSET AND KEEP GOING... @VM03209 02587000
CHEKDSK TM ADTFLG2,ADTFROS+ADTFDOS DOS OR OS DISK? @VM03209 02588000
BZ NODISK IF NEITHER, NOT ACCESSED @VM03209 02589000
BO DOSDISK IF BOTH, IT'S DOS DISK @VM03209 02590000
MVC TEMPD(8),OSDSK IF OS, SUBSTITUTE 'OS' @VM03209 02591000
B SUBSET AND KEEP GOING @VM03209 02592000
DOSDISK MVC TEMPD(8),DOSDSK YES, SUBSTITUTE 'DOS' @VM03209 02593000
B SUBSET AND KEEP GOING @VM03209 02594000
DROP R1 @VM03209 02595000
NODISK MVC TEMPD(8),NODSK IF NOT ACCESSED, MARK 'NA' @VM03209 02596000
B SUBSET AND GO... @VM03209 02597000
CHKTYPF EQU * @VM03209 02598000
* 02599000
CLC TEMPD(8),ETYPEFLG &TYPEFLAG? @VM03209 02600000
BNE SUBINGL BRANCH IF NOT (GO CHECK INDEXES ETC.) @VM03209 02601000
MVC TEMPD(8),TYPEFLAG MOVE IN THE CURRENT VALUE @VM03209 02602000
B SUBSET @VM03209 02603000
SPACE 1 02604000
SUBINGL EQU * CHECK FOR KEYWORDS, AND GLOBALS @VM03209 02605000
LA R3,EXECWRDS START OF EXEC WORDS @VM03209 02606000
LA R4,8 INCREMENT @VM03209 02607000
LA R5,ELITERAL END OF EXEC WORDS @VM03209 02608000
CLC TEMPD(8),0(R3) MATCH? @VM03209 02609000
BE SUBINGL1 BRANCH IF SO @VM03209 02610000
BXLE R3,R4,*-10 LOOP @VM03209 02611000
SPACE 1 02612000
SUBNOT EQU * UNDEFINED VARIABLE @VM03209 02613000
MVC TEMPD(8),BLANKS READY TO SET TO BLANKS @VM03209 02614000
B SUBSET (SINCE WE COULDN'T FIND THE NAME)@VM03209 02615000
SPACE 1 02616000
SUBINGL1 EQU * FOUND SOMETHING INTERESTING @VM03209 02617000
LA R5,EGLOB IS IT AN EXEC CONTROL WORD? @VM03209 02618000
CR R3,R5 BRANCH IF SO (NO MORE SUBSTITUTION) @VM03209 02619000
BL SUBLOOPA @VM03209 02620000
LA R5,ELINE IS IT A SPECIAL EXEC SYMBOL? @VM03209 02621000
CR R3,R5 @VM03209 02622000
BH SUBLOOPA BRANCH IF SO (NO MORE SUBSTITUTION) @VM03209 02623000
LA R9,RETCODE SAY IT'S &RETCODE. @VM03209 02624000
LA R5,ERETCOD @VM03209 02625000
CR R3,R5 IS IT? @VM03209 02626000
BE CNVRTCD YES @VM03209 02627000
LA R9,INDEX MAYBE IT'S &INDEX @VM03209 02628000
LA R5,EINDE OR EVEN &LINENUM @VM03209 02629000
CR R3,R5 WELL? @VM03209 02630000
BNL SUBINGL2 BRANCH IF SO. @VM03209 02631000
USING OPSECT,R5 @VM03209 02632000
L R5,AOPSECT POINT TO OPSECT IN NUCLEUS @VM03209 02633000
L R9,EXADD+4 GET GLOBAL ADDRESSABILITY @VM03209 02634000
LA R5,EGLOB @VM03209 02635000
CNVRTCD SR R3,R5 CALC DISPLACEMENT INTO GLOBAL @VM03209 02636000
SRA R3,3 STORAGE AREA ....... @VM03209 02637000
MH R3,H5 # 8BYTE FIELDS X L'PACKED FIELD @VM03209 02638000
AR R3,R9 @VM03209 02639000
BAL RET,UNPACK5 @VM03209 02640000
B SUBSET @VM03209 02641000
SPACE 1 02642000
SUBINGL2 EQU * @VM03209 02643000
SR R3,R5 UNPACK A GLOBAL @VM03209 02644000
SRA R3,1 (OR LINENUM) @VM03209 02645000
AR R3,R9 (OR EVEN AN INDEX) @VM03209 02646000
BAL RET,UNPACK4 UNPACK INTO TEMPD @VM03209 02647000
SUBSET EQU * @VM03260 02648000
EX R8,SUBREPL THEN REPLACE THE RIGHT PART @VM03260 02649000
CR R6,R7 START OF TOKEN? @VA06198 02650000
BNE SUBFLG WRONG PLACE FOR ASSIGNMENT @VA06198 02651000
CLI PENULT,X'50' POSSIBLE VARIABLE OF SORTS? @VA06198 02652000
BNE SUBFLG WRONG PLACE FOR ASSIGNMENT @VA06198 02653000
CLC 8(2,R7),=CL2'=' ELIMINATE HEX CONVERSION @VM03260 02654000
BNE SUBFLG FOR LH ASSIGNMENT TOKEN @VM03260 02655000
OI FLAG1,ASSNBIT ..... @VM03260 02656000
B SUBLOOPA ..... @VM03260 02657000
SPACE 1 02658000
SUBFLG EQU * @VA06198 02659000
CLC 0(L'XPREFIX,R6),XPREFIX HEX PREFIX HERE? @VA06198 02660000
BNE SUBLOOPA NO - FLAG NOT NEEDED @VA06198 02661000
LA R3,2(R6) POINT TO START OF NUMBER @VA06198 02662000
CR R7,R3 IS THIS START OF CONV FIELD @VA06198 02663000
BNE SUBLOOPA NO - TEMPD NG FOR CONVERSION @VA06198 02664000
OI FLAG1,SUBSTD SET TEMPD OK FOR CONVERSION @VA06198 02665000
B SUBLOOPA CARRY ON WITH SCAN @VM03260 02666000
SPACE 1 02667000
SUBXERR OI FLAG1,HEXERR SET CONVERSION ERROR INDICATOR @VM03209 02668000
SPACE 1 02669000
SUBRET EQU * @VM03209 02670000
LM R3,R10,TEMSUB RESTORE REGISTERS @VM03209 02671000
TM FLAG1,HEXERR HEX CONVERSION ERROR ? @VM03209 02672000
BO ERRCONV YES, TELL ABOUT IT @VM03209 02673000
BR RET RETURN @VM03209 02674000
SPACE 1 02675000
SUBMOVIN MVC TEMPD(*-*),0(R7) @VM03209 02676000
SUBREPL MVC 0(*-*,R7),TEMPD @VM03209 02677000
CHKTOKN TRT 1(0,R7),TOKCHK CHECK TOKEN FOR INVALID CHAR. @VA07374 02677500
SPACE 2 HRC007DS 02678090
TOKCHK DS 0H HRC007DS 02678180
DC 64X'FF' HRC007DS 02678270
DC X'00FFFFFFFFFFFFFFFFFFFFFFFFFFFFFF' BLANK HRC007DS 02678360
DC X'FFFFFFFFFFFFFFFFFFFFFF00FFFFFFFF' $ HRC007DS 02678450
DC 16X'FF' HRC007DS 02678540
DC X'FFFFFFFFFFFFFFFFFFFFFF0000FFFFFF' # @ HRC007DS 02678630
DC 64X'FF' HRC007DS 02678720
DC X'FF000000000000000000FFFFFFFFFFFF' A-I HRC007DS 02678810
DC X'FF000000000000000000FFFFFFFFFFFF' J-R HRC007DS 02678900
DC X'FFFF0000000000000000FFFFFFFFFFFF' S-Z HRC007DS 02678990
DC X'00000000000000000000FFFFFFFFFFFF' 0-9 HRC007DS 02679080
EJECT , HRC007DS 02679170
EPLBUILD DS 0H HRC309DS 02680000
* EPLBUILD builds an extended PLIST setting R0 to point to it. HRC309DS 02680005
* The untranslated argument string is in RAWBUF, and it scans HRC309DS 02680010
* that string for words that begin with &. SUBSTIT is called HRC309DS 02680015
* to retrieve the value for the variable, and that value is HRC309DS 02680020
* substuted for the variable in RAWBUF. Thus the EPLIST HRC309DS 02680025
* correctly contains any variable values from the EXEC HRC309DS 02680030
* procedure. Note that truncation of the argument string will HRC309DS 02680035
* occur if substitution causes the string to grow longer than HRC309DS 02680040
* 130 bytes. HRC309DS 02680045
USING *,R15 HRC309DS 02680050
STM R2,R14,EPLSAVE save the registers we use HRC309DS 02680055
LA R3,RAWBUF point to start of command line HRC309DS 02680060
* If the command was called as the clause in an &IF or &ERROR HRC309DS 02680065
* instruction, then RAWBUF points to the start of the EXEC HRC309DS 02680070
* line, not the start of the command line. We fix this. HRC309DS 02680075
SLR R5,R5 HRC309DS 02680080
C R5,CMDLSTRT HRC309DS 02680085
BZ EPBLD4 HRC309DS 02680090
S R2,CMDLSTRT has EXEC discarded tokens? HRC309DS 02680095
BZ EPBLD4 no, so proceed normally HRC309DS 02680100
LR R5,R2 R5 is num of bytes skipped HRC309DS 02680105
SRL R5,3 calc number of words to skip HRC309DS 02680110
A R3,RAWBUFLN get end of command line HRC309DS 02680115
BCTR R3,0 decrement for BXLE HRC309DS 02680120
LA R2,1 loop increment HRC309DS 02680125
LA R4,RAWBUF get start of command line again HRC309DS 02680130
EPBLD1 DS 0H HRC309DS 02680135
* Loop to skip R5 words in the command line. HRC309DS 02680140
CLI 0(R4),C' ' look for space after this word HRC309DS 02680145
BE EPBLD2 found it HRC309DS 02680150
BXLE R4,R2,EPBLD1 keep looping if not HRC309DS 02680155
B EPBLD4 should never get here! HRC309DS 02680160
EPBLD2 DS 0H HRC309DS 02680165
CLI 0(R4),C' ' eat up spaces between words HRC309DS 02680170
BNE EPBLD3 found next word HRC309DS 02680175
BXLE R4,R2,EPBLD2 keep looping if not HRC309DS 02680180
EPBLD3 DS 0H HRC309DS 02680185
SR R5,R2 decrement count of words to skip HRC309DS 02680190
BH EPBLD1 keep looping: more words to skip HRC309DS 02680195
LA R3,1(R3) point to end of command line HRC309DS 02680200
ST R3,EPLARGND store in EPLIST HRC309DS 02680205
BCTR R3,0 decrement for BXLE HRC309DS 02680210
B EPBLD6 continue scanning normally HRC309DS 02680215
EPBLD4 DS 0H HRC309DS 02680220
A R3,RAWBUFLN get end of command line HRC309DS 02680225
ST R3,EPLARGND store in EPLIST HRC309DS 02680230
BCTR R3,0 decrement for BXLE HRC309DS 02680235
LA R2,1 loop increment HRC309DS 02680240
LA R4,RAWBUF get start of command line again HRC309DS 02680245
EPBLD5 DS 0H HRC309DS 02680250
CLI 0(R4),C' ' eat up spaces between words HRC309DS 02680255
BNE EPBLD6 found next word HRC309DS 02680260
BXLE R4,R2,EPBLD5 keep looping if not HRC309DS 02680265
EPBLD6 DS 0H HRC309DS 02680270
* At this point R4 points to "start" of command line. HRC309DS 02680275
ST R4,EPLCMD store command name in EPLIST HRC309DS 02680280
EPLOOP1 DS 0H HRC309DS 02680285
* Loop to find the end of the command name. We scan for blanks HRC309DS 02680290
* as well as open and close parentheses. HRC309DS 02680295
CLI 0(R4),C' ' is it a space? HRC309DS 02680300
BE EPCMD1 found it HRC309DS 02680305
CLI 0(R4),C'(' is it an open parenthesis? HRC309DS 02680310
BE EPCMD2 this is the start of arguments HRC309DS 02680315
CLI 0(R4),C')' is it a close parenthesis? HRC309DS 02680320
BE EPCMD2 this is the start of arguments HRC309DS 02680325
BXLE R4,R2,EPLOOP1 keep looping if not HRC309DS 02680330
B EPCMD2 no arguments HRC309DS 02680335
EPCMD1 DS 0H HRC309DS 02680340
LA R4,1(R4) next byte is start of arguments HRC309DS 02680345
ST R4,EPLARGBG store start of arguments HRC309DS 02680350
B ENEXTARG look for start of next argument HRC309DS 02680355
EPCMD2 DS 0H HRC309DS 02680360
ST R4,EPLARGBG store start of arguments HRC309DS 02680365
LA R4,1(R4) next byte is blank or next arg HRC309DS 02680370
B ENEXTARG look for start of next argument HRC309DS 02680375
SPACE 1 HRC309DS 02680380
EARGSCAN DS 0H HRC309DS 02680385
* Scan the argument string, substituting EXEC variable values HRC309DS 02680390
* for any variables we find. During the scan: HRC309DS 02680395
* R3 points to last byte of the argument string. HRC309DS 02680400
* R4 advances through the string as we scan. HRC309DS 02680405
* R5 saves the start of the current argument. HRC309DS 02680410
LR R5,R4 save start of argument HRC309DS 02680415
EARGSCN1 DS 0H HRC309DS 02680420
* Scan for the argument end. R4 will advance as we scan. HRC309DS 02680425
CLI 0(R4),C' ' are we pointing to a space? HRC309DS 02680430
BE EGOTARG yes, we're at the end of the arg HRC309DS 02680435
CLI 0(R4),C'(' is this arg an open paren? HRC309DS 02680440
BE EARGSCN2 HRC309DS 02680445
CLI 0(R4),C')' is this arg a close paren? HRC309DS 02680450
BE EARGSCN2 HRC309DS 02680455
BXLE R4,R2,EARGSCN1 keep looping if not HRC309DS 02680460
B EGOTARG go process the last argument HRC309DS 02680465
EARGSCN2 DS 0H HRC309DS 02680470
LA R4,1(R4) start of next argument HRC309DS 02680475
B ENEXTARG HRC309DS 02680480
EGOTARG DS 0H HRC309DS 02680485
* R5 points to the argument start, R4 to the byte after. HRC309DS 02680490
CLI 0(R5),X'50' is argument a possible variable? HRC309DS 02680495
BNE ENEXTARG no, so no substitution required HRC309DS 02680500
SPACE 1 HRC309DS 02680505
* The argument is most likely an EXEC variable Lucky for us HRC309DS 02680510
* there is a subroutine that will substitute its value. HRC309DS 02680515
MVC EXECVAR,=C' ' clear the field HRC309DS 02680520
LR R7,R4 HRC309DS 02680525
SR R7,R5 calculate length of argument HRC309DS 02680530
LA R6,8 HRC309DS 02680535
CR R7,R6 greater than 8? HRC309DS 02680540
BNH EARGSCN3 no, it is OK HRC309DS 02680545
LR R7,R6 truncate at 8 HRC309DS 02680550
EARGSCN3 DS 0H HRC309DS 02680555
LR R0,R7 save length of argument HRC309DS 02680560
BCTR R7,0 less 1 for EX HRC309DS 02680565
LA R6,EXECVAR variable for SUBSTIT to scan HRC309DS 02680570
EX R7,MVVALARG MVC from R5 to R6 for R7 bytes HRC309DS 02680575
LR R7,R15 save our base register HRC309DS 02680580
L R15,ASUBSTIT address of SUBSTIT HRC309DS 02680585
BALR RET,R15 substitute the variable HRC309DS 02680590
LR R15,R7 recover our base register HRC309DS 02680595
SPACE 1 HRC309DS 02680600
* We must copy the EXEC variable value to replace the variable HRC309DS 02680605
* name in the argument string. HRC309DS 02680610
LA R8,1 loop increment HRC309DS 02680615
LA R9,7(R6) end of value (less 1 for BXLE) HRC309DS 02680620
LR R7,R6 start of value HRC309DS 02680625
EARGSCN4 DS 0H HRC309DS 02680630
CLI 0(R7),C' ' end of value yet? HRC309DS 02680635
BE EARGSCN5 yes, reached end of the value HRC309DS 02680640
BXLE R7,R8,EARGSCN4 keep looping if not HRC309DS 02680645
EARGSCN5 DS 0H HRC309DS 02680650
SR R7,R6 get length of value HRC309DS 02680655
LR R10,R7 save it HRC309DS 02680660
SR R7,R0 room needed (could be negative) HRC309DS 02680665
LR R14,R7 save it HRC309DS 02680670
BZ ECOPYVAL no need to make room for value HRC309DS 02680675
CR R4,R3 and are we at the last argument? HRC309DS 02680680
BH ECOPYVAL no need to make room for value HRC309DS 02680685
SPACE 1 HRC309DS 02680690
* Now we move the string after the current arg to make room HRC309DS 02680695
* for the token we are going to substitute. We first move it HRC309DS 02680700
* to a temporary buffer to avoid overwriting it with the MVC. HRC309DS 02680705
LA R9,1(R3) 1st byte after argstring HRC309DS 02680710
SR R9,R4 this way we copy the null byte HRC309DS 02680715
LA R8,TEMPBUF HRC309DS 02680720
EX R9,MVARGTMP MVC from R4 to R8 for R9 bytes HRC309DS 02680725
LR R7,R4 target for second move HRC309DS 02680730
AR R7,R14 make room for variable value HRC309DS 02680735
EX R9,MVTMPARG MVC from R8 to R7 for R9 bytes HRC309DS 02680740
ECOPYVAL DS 0H HRC309DS 02680745
* At last we copy the variable value into the argument string. HRC309DS 02680750
* Then we adjust the argument string scan and end pointers, HRC309DS 02680755
* truncating the string if necessary. HRC309DS 02680760
LTR R10,R10 check the length of the value HRC309DS 02680765
BH EARGSCN6 go copy it HRC309DS 02680770
SR R4,R2 prevent double blanks in eplist HRC309DS 02680775
B EARGSCN7 HRC309DS 02680780
EARGSCN6 DS 0H HRC309DS 02680785
BCTR R10,0 decrement value len by 1 for EX HRC309DS 02680790
EX R10,MVARGVAL MVC from R6 to R5 for R10 bytes HRC309DS 02680795
EARGSCN7 DS 0H HRC309DS 02680800
AR R3,R14 adjust argument end pointer HRC309DS 02680805
LA R8,RAWBUF+BUFL end of buffer -1 HRC309DS 02680810
CR R3,R8 have we overrun the buffer? HRC309DS 02680815
BNH EARGSCN8 branch if not HRC309DS 02680820
LR R3,R8 truncate it HRC309DS 02680825
EARGSCN8 DS 0H HRC309DS 02680830
AR R4,R14 adjust scan pointer HRC309DS 02680835
ENEXTARG DS 0H HRC309DS 02680840
* R4 points to the first char after the end of an argument. HRC309DS 02680845
* Loop to find the start of the next argument. But first HRC309DS 02680850
* check to see if we are at the end. HRC309DS 02680855
CR R4,R3 are we at the end? HRC309DS 02680860
BH EARGEND yes, go finish up HRC309DS 02680865
EARGSCN9 DS 0H HRC309DS 02680870
CLI 0(R4),C' ' is it still a space? HRC309DS 02680875
BNE EARGSCAN no, so found start of next arg HRC309DS 02680880
BXLE R4,R2,EARGSCN9 keep looping if not HRC309DS 02680885
EARGEND DS 0H HRC309DS 02680890
* We have reached the end of the argument list. HRC309DS 02680895
ST R4,EPLARGND store end of args in EPLIST HRC309DS 02680900
SLR R2,R2 get a zero HRC309DS 02680905
ST R2,EPLUWORD and store it in the EPLIST HRC309DS 02680910
SPACE 1 HRC309DS 02680915
* Our work here is done. Point R0 to the EPLIST and return. HRC309DS 02680920
LA R0,EPLIST pass the extended PLIST HRC309DS 02680925
LM R2,R14,EPLSAVE restore the registers HRC309DS 02680930
DROP R15 HRC309DS 02680935
BR R14 return to our caller HRC309DS 02680940
SPACE 1 HRC309DS 02680945
MVARGTMP MVC 0(0,R8),0(R4) make room for variable value HRC309DS 02680950
MVARGVAL MVC 0(0,R5),0(R6) copy to arg string from sub area HRC309DS 02680955
MVTMPARG MVC 0(0,R7),0(R8) make room for variable value HRC309DS 02680960
MVVALARG MVC 0(0,R6),0(R5) copy arg to val sub area HRC309DS 02680965
EJECT HRC309DS 02680970
FREEST DSECT @V305614 02680975
LINKLEN DS F LINK LENGTH @V305614 02681000
ADDR DS F DATA ADDRESS @V305614 02682000
ANCHOR DS F BASE BLOCK ADDRESS @V305614 02683000
CHAD DS F ADDRESS OF LINK TO BE CHAINED @V305614 02684000
SPACE 1 02685000
SAV14 DS F RETURN REG SAVE AREA @V305614 02686000
SPACE 1 02687000
UNCHSAV DS 4F UNCHAIN RTN SAVE AREA @V305614 02688000
ASUBSTIT DS F SUBSTITUTION ROUTINE ADDRESS @VM03209 02689000
SPACE 1 02690000
STACKLST DS 0F @V305614 02691000
DS CL8 @V305614 02692000
DS CL4 DEFAULT TO FIRST IN,FIRST OUT @V305614 02693000
DS X LENG OF MESSAGE @V305614 02694000
DS 3X ADDR OF MESSAGE @V305614 02695000
SPACE 1 02696000
POINT DS 0F PLIST FOR 'POINT' @V305614 02697000
DS CL8 @V305614 02698000
DS CL8 @V305614 02699000
DS CL8 @V305614 02700000
DS CL2 @V305614 02701000
DS H DON'T TOUCH THE WRITE POINTER @V305614 02702000
PPTR DS H RESET READ POINTER TO LINE 1 @V305614 02703000
* 02704000
DS 0F USED BY &PUNCH AND &BEGPUNCH @V305614 02705000
CARDPCH DS CL8 @V305614 02706000
EXTND DS X FOR 80 BYTES @V305614 02707000
PCHBUF DS 3X ADDRESS OF BUFFER TO BE PUNCH@V305614 02708000
PCHLGTH DS H NUMBER OF BYTES TO BE READ @V305614 02709000
DS H NUMBER OF BYTES READ @V305614 02710000
DSKADT DS CL2 @V305101 02711000
* 02712000
TPLIST DS 2X DMSERR FLAGS @VM03208 02713000
ATEXT DS 3X TEXT ADDRESS - KEEP WITH TPLIST @VM03208 02714000
* 02715000
SPACE 1 02716000
ZERO DS F @V305614 02717000
READFLAG DS CL8 WILL WAITRD FIND CONS STACK @V305614 02718000
DOS DS CL8 DOS ENVIRONMENT STATUS @V305101 02719000
TYPEFLAG DS CL8 @V305614 02720000
FLAG DS X @V305614 02721000
SIGN DS X @V305614 02722000
HEXSW DS X @VM03234 02723000
COND DS 3D FOR CONRET TO PUT THE CONDITION @V305614 02724000
TIMBUF DS CL28 BUFFER FOR CMS TIMES @V305614 02725000
CONDMSG DS 2D KEEP B4 COND1 AND ON DBL WRD @VA06278 02726000
COND1 DS 3D FOR CKALL TO SAVE THE CONDITION @V305614 02727000
PENULT DS D SPOT FOR PENULTIMATE SUBS. @V305614 02728000
TEMPD DS D TEMP AREA FOR SUBSTIT @V305614 02729000
CVD DS D TEMP FOR CVDBCD (FOLLOWS TEMPD) @V305614 02730000
TEMPD2 DS D LOCAL TEMP AREA HRC007DS 02730500
CVDSPACE DS PL8 SUBROUTINE CVDBCD PUTS ANSWER @V305614 02731000
LAST3 DS CL24 LAST 3 TOKENS (LITERAL VERSION) @V305614 02732000
GOLAB DS D TARGET OF &GOTO STATEMENT @V305614 02733000
LAST3LIT DS 4X &LITERAL FLAGS FOR LAST3 @V305614 02734000
TEMSUB DS 9F REG SAVE AREA 1 @V305614 02735000
TEMSUB2 DS 7F REG SAVE AREA 2 @V305614 02736000
TEMSUB3 DS 6F REG SAVE AREA 3 @V305614 02737000
SCANBUFF DS F SPOT FOR LENGTH FOR SCAN @V305614 02738000
UNSCND DS CL130 INPUT BUFFER, & FOR OTHER THINGS @V305614 02739000
UNTAIL DS CL8 OVERFLOW AREA FOR UNSCND @V305614 02740000
FLAG1 DS X MISCELLANEOUS FLAGS @VM03209 02741000
ORBYTE DS X WORK BYTE FOR DECHEX @VM03209 02742000
DS 0F @V305614 02743000
CMSTIME DS CL8 AREA FOR CMSTIME PLIST 02744000
DS F,F (VIRCPU AND TOTCPU) 02745000
DS A,F (ADDRESS AND LENGTH OF TIMBUF) 02746000
* Next two buffers are 6 bytes longer than needed to HRC309DS 02746050
* allow for overrun during variable substitution. HRC309DS 02746100
DS 0F HRC309DS 02746150
BUFL EQU 129 max length of RAWBUF/TEMPBUF -1 HRC309DS 02746200
CMDLSTRT DS F saved start of command line HRC309DS 02746250
RAWBUF DS CL136 unscanned untranslated input buf HRC309DS 02746300
TEMPBUF DS CL136 to avoid MVC overwrite HRC309DS 02746350
RAWBUFLN DS F length of line in RAWBUF HRC309DS 02746400
AEPLBLD DS A address of EPLIST subroutine HRC309DS 02746450
EPLSAVE DS 13F EPLBUILD register save area HRC309DS 02746500
EXECVAR DS CL8 for EXEC variable substitution HRC309DS 02746550
EPLIST CSECT HRC309DS 02746600
FILWIDTH DS H SPOT TO KEEP THE FILE ITEM LENGTH 02747000
READCNT DS F =NO. LINES TO READ FRM TYPEWRITER 02748000
ERACT DS X 02749000
STCKFLAG DS X IF ON--STACKS LINES UNTIL &ENDSTACK 02750000
CONDFLG DS X BITS, 1 IMPLIES &$ IN 1ST LOC 02751000
* BIT 2--&$ IN 2ND LOC, BIT3 FOR &* IN 1ST ETC 02752000
CONTFLAG DS X SAYS WE'RE SEEKING RANGE OF LOOP 02753000
GOSTOP DS H LINE NUM FOR &GOTO TO STOP AT.. 02754000
MSGBUFF DS CL133 &BEGEMSG AND &EMSG MESSAGE BUFFER@VA05715 02755000
* FIRST BYTE CONTAINS THE LENGTH 02756000
* NEXT THREE BYTES CONTAIN 'DMS' 02757000
* REMAINDER CONTAINS THE MESSAGE UP 02758000
* TO A MAXIMUM OF 129 CHARACTERS 02759000
ERACTION DS CL132 PLACE FOR UNSCANNED ERROR ACTION 02760000
* (1ST BYTE=CONRDFLG; 2ND=LENGTH; REST=ERROR ACTION) 02761000
SCNPTR DS F WORD FOR LOC OF SCAN ROUTINE 02762000
RETCODE DS PL5 @VA03453 02763000
DS 3X RESERVED FOR FUTURE USE???? @VA03453 02764000
INDEX DS PL4 02765000
LINENUM DS PL4 02766000
KEYWORDS DS F BASE BLOCK FOR KEYWORD CHAIN 02767000
ARGTABLE DS 30D SPACE FOR FILENAME+30... 02768000
ARGEND DS D ...SUBSTITUTABLE ARGUMENTS 02769000
ARGSIZE EQU *-ARGTABLE 02770000
EXEC DS D 02771000
KPTR DS F HAS ADDR OF 1ST EMPTY KEYWORD 02772000
NOLOOPS EQU 4 SET MAX DESIRED DEPTH OF NESTING 02773000
CONRDFLG DS X CONSOLE READ FLAG 02774000
CVDFLAG DS X 02775000
LOPLEVEL DS H HAS CURRENT DEPTH OF NESTING=0,1,2,.. 02776000
SCOPEBEG DS (NOLOOPS)H HAS LINE NO OF BEG OF SCOPE 02777000
SCOPEND DS (NOLOOPS)H HAS END OF LOOP LINE NO-1 (FOR NOTIMES) 02778000
LOOPCNT DS (NOLOOPS)F LOOPCOUNTS ARE COUNTED DOWN 02779000
LOOPCOND DS (NOLOOPS)CL28 SPACE FOR CONDITIONS & &LITERAL FLAGS 02780000
DSKLIN DS D MUST BE CONTIGUOUS THROUGH PNREAD 02781000
FNAME DS D 02782000
FTYPE DS D 02783000
PMODE DS H 02784000
PITEM DS H 02785000
FSTLOC EQU * 02786000
PBUFF DS F 02787000
PLENGTH DS F 02788000
PFLAG DS H 02789000
PNITEM DS H 02790000
PNREAD DS F 02791000
SPEXEC DS F FOR EXEC RECURSION 02792000
BUFFER DS 33D @VA08168 02793000
ENDOFBUF EQU * 02794000
BUFSIZE EQU *-BUFFER 02795000
PDOUT EQU *-8 02796000
TYPLIN DS 2D 02797000
TYPINPUT DS D 02798000
TYRD2 DS D 02799000
TFLAG DS X 02800000
TIMFLG DS X INDICATES WHETHER &TIME IS ON OR OFF 02801000
AFLG1 DS X 02802000
SAVRET DS F 02803000
DS 2F 02804000
ENDFREE DS 0D 02805000
SPACE 2 02806000
PTR EQU 2 02807000
LINK EQU 7 02808000
RET EQU 10 02809000
BASE1 EQU 11 02810000
BASE EQU 12 02811000
BFREE EQU 13 02812000
ONE EQU 1 @V305066 02813000
SEVDWS EQU 7 @V305066 02814000
FIXED EQU C'F' @V305066 02815000
LITFLAG EQU X'FF' @V305066 02816000
POS EQU X'30' @V305066 02817000
NEG EQU X'20' @V305066 02818000
HEXF0 EQU X'F0' @V305066 02819000
HEX00 EQU X'00' @VM03209 02820000
HEX0A EQU X'0A' @VM03209 02821000
HEX0F EQU X'0F' @VM03209 02822000
NINE EQU X'F9' @VM03209 02823000
THREE EQU 3 @VA06278 02824000
SEVEN EQU 7 @VM03209 02825000
EIGHT EQU 8 @VA06278 02826000
TEN6 EQU 16 @VA06278 02827000
TWENTY4 EQU 24 @VA06278 02828000
FOUR8 EQU 48 @VA06278 02829000
TWO56 EQU 256 @VA08168 02829500
PART EQU 6 @VM03209 02830000
FULL EQU 8 @VM03209 02831000
SHFNUM EQU 4 @VM03209 02832000
FF EQU X'FF' @V305066 02833000
ASSNBIT EQU X'80' ASSIGNMENT STATEMENT IN PROCESS @VM03209 02834000
SUBSTD EQU X'40' TOKEN SUBSTITUTION DONE @VM03209 02835000
HEXERR EQU X'20' HEX CONVERSION ERROR @VM03209 02836000
DIGIT6 EQU 6 @V305066 02837000
END EQU X'40' @V305066 02838000
CHAR0 EQU C'0' @V305066 02839000
CHAR9 EQU C'9' @V305066 02840000
A EQU C'A' @V305066 02841000
F EQU C'F' @V305066 02842000
BLANK EQU C' ' @V305066 02843000
CHARAST EQU C'*' @V305066 02844000
CHARQUES EQU C'?' @V305066 02845000
DASH EQU C'-' MINUS SIGN FOR IMMEDIATE OPERAND @VA06198 02846000
LOBYT EQU B'0001' @VM03208 02847000
AL3 EQU B'0111' @VM03208 02848000
BEMSG EQU X'80' BEGEMSG FLAG IN STCKFLAG @VM03208 02849000
SPACE 2 02850000
NEED EQU (ENDFREE-FREEST)/8 02851000
SPACE 1 02852000
XGLBL DSECT @V305614 02853000
GLOBAL DS CL5 RECURSION LEVEL FOR &GLOBAL @V305614 02854000
GLOBAL0 DS 10PL5 GLOBAL VARIABLES @VA07950 02855000
SPACE 2 02856000
FMODE EQU 24 02857000
FSIZE EQU 34 @VM03131 02858000
FFORM EQU 30 02859000
EJECT 02860000
NUCON 02861000
IO , @V305614 02862000
SPACE 2 02863000
SPACE 2 02864000
ADT @V305101 02865000
REGEQU 02866000
END 02867000