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