ibm:vm370-lib:cms:dmsext.assemble_src
Table of Contents
DMSEXT Source
References
- Fixes Applied : 6
- This Source Date : Tuesday, December 12, 1978
- Last Fix ID : [HRC380DS]
Source Listing
- DMSEXT.ASSEMBLE.txt
- 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
ibm/vm370-lib/cms/dmsext.assemble_src.txt · Last modified: 2023/08/06 13:35 by Site Administrator