LD00E TITLE 'DMKLD00E (CP) VM/370 - RELEASE 6' 00001000
PUNCH 'SLC 002000' 00002000
* 00003000
* THE LOADER HAS BEEN MODIFIED TO HANDLE ASSEMBLER AND 00004000
* FORTRAN OUTPUT FROM BPS, BOS, AND OS ASSEMBLERS AND 00005000
* COMPILERS. THE ORDER THE DECKS ARE LOADED IS NOT 00006000
* IMPORTANT. LOADING WILL START AT X'100' UNLESS 00007000
* MODIFIED VIA AN 'SLC' CARD. THE LOADER WILL NOT PERMIT 00008000
* ITSELF OR THE BOTTOM 128 LOCATIONS OF CORE TO BE 00009000
* OVERLAID BY INCOMING TEXT. IT WILL, HOWEVER, ALLOW 00010000
* THE DEFINITION OF CONTROL SECTIONS SPANNING THIS AREA. 00011000
* 00012000
* MODIFIED FOR BETTER I/O HANDLING AND TO PERMIT CHOICE 00013000
* OF PRINTER AND READER DYNAMICALLY. ALSO, 'SKIP' OPTION 00014000
* INCLUDED TO PERMIT SELECTIVE REPLACEMENT OF MODULES 00015000
* FROM PRESTORED TAPE. NEW CTL CARDS ARE 'RDR XXX', WTR 00016000
* XXX', AND 'SKIP NAME '. GOOD LUCK! 00017000
* 00018000
*********************************************************************** 00019000
* 00020000
* THE RELOCATING LOADER CAN LOAD ASSEMBLED 00021000
* PROGRAM MODULES INTO STORAGE AT LOCATIONS 00022000
* OTHER THAN THOSE ASSIGNED BY THE ASSEMBLER-- 00023000
* IT COMPLETES LINKAGE AMONG THE MODULES SO 00024000
* THAT ONE PROGRAM MODULE MAY REFER TO ANOTH- 00025000
* ER-- IT ALLOWS CORRECTIONS OR ADDITIONS TO 00026000
* BE MADE TO THE PROGRAM AT LOAD TIME-- AND IT 00027000
* TRANSFERS CONTROL TO ONE OF THE LOADED 00028000
* MODULES FOR EXECUTION. 00029000
* 00030000
* THE OPERATION OF THIS PROGRAM, EXCEPT AS 00031000
* NOTED BELOW, DEPENDS UPON AN INTERNAL REPRE- 00032000
* SENTATION OF THE EXTERNAL CHARACTER SET 00033000
* WHICH IS EQUIVALENT TO THE ONE USED AT AS- 00034000
* SEMBLY TIME. THE CODING HAS BEEN ARRANGED SO 00035000
* THAT REDEFINITION OF CHARACTER CONSTANTS, BY 00036000
* REASSEMBLY, WILL RESULT IN A CORRECT MODULE 00037000
* FOR THE NEW DEFINITIONS. 00038000
* 00039000
* THOSE STATEMENTS MARKED WITH AN * 00040000
* 71 BELOW DO NOT DEPEND UPON A PARTICULAR IN- 00041000
* TERNAL REPRESENTATION OF THE EXTERNAL CHAR- 00042000
* ACTER SET EXCEPT THAT THE DECIMAL NUMBERS 00043000
* MUST BE CODED SO THAT THE LOW ORDER FOUR 00044000
* BITS, WHEN CONSIDERED AS A BINARY INTEGER, 00045000
* IDENTIFY THE VALUE OF THAT DIGIT. 00046000
* 00047000
* THE CONSTANT MARKED WITH A DOUBLE * 00048000
* COLUMNS 70 AND 71 REPRESENT THE DIFFERENCE 00049000
* BETWEEN THE HEXIDECIMAL VALUE OF THE NUMBER 00050000
* A AND THE INTERNAL BINARY VALUE OF THE CHAR- 00051000
* ACTER A, AND MUST BE ALTERED SHOULD THE IN- 00052000
* TERNAL REPRESENTATIONS OF THE LETTERS A 00053000
* THROUGH F CHANGE. 00054000
* 00055000
* THE CONSTANTS WITH *** IN COL. 00056000
* THE X'02' EQUAL A T-2-9 PUNCH AND MUST BE 00057000
* MODIFIED IF THE PROPERTIES OF THE CHARACTER 00058000
* SET ARE CHANGED. 00059000
* 00060000
*********************************************************************** 00061000
EJECT 00062000
RELDR START 8192 00063000
ENTRY LDRGEN 00064000
ALPHA DS 0D 00065000
DS 0D ALIGNMENT 00066000
* 00067000
MON EQU * 00068000
* 00069000
*********************************************************************** 00070000
* 00071000
* APOINT - ADD TO THE POINTER TABLES 00072000
* 00073000
* THIS ROUTINE ADDS TO THE STRING OF LOCATIONS WAITING FOR 00074000
* AN UNDEFINED SYMBOL TO BE DEFINED (BY AN ENTRY POINT OR 00075000
* AN ICS CARD) 00076000
* IT IS REACHED BY A BRANCH FROM THE RLD SUBROUTINE 00077000
* 00078000
* REGISTER USE 00079000
* 00080000
* 3. LOCATION AT WHICH CONSTANT SHOULD BE STORED 00081000
* 4. CURRENT VALUE OF CONSTANT 00082000
* 5. BYTE COUNT - 1 (LENGTH OF CONSTANT) 00083000
* 10. POINTER TO FLAG BYTE 00084000
* 11. ONE 00085000
* 12. ENTRY OF SYMBOL IN REFTBL 00086000
* 13. SAVE AREA LOCATION 00087000
* 14. RETURN LOCATION 00088000
* 00089000
*********************************************************************** 00090000
* 00091000
APOINT STM 0,15,APSV(13) 00092000
BALR 6,0 00093000
USING *,6 ESTABLISH ADDRESSABILITY 00094000
L 9,SECBASE 00095000
L 6,RLDR 00096000
USING RELDR,6,9 00097000
SR 2,2 ZERO OUT REGISTER 2 00098000
LA 0,2 LOAD REG 0 WITH TWO 00099000
CR 5,0 IS BYTE COUNT EQUAL TO THREE 00100000
BC 8,APOIN9 YES 00101000
LA 3,0(,3) INSURE THAT FIRST BYTE IS ALL ZERO 00102000
O 3,ONEBIT NO - SET A MINUS BIT IN LOC. POINTER 00103000
APOIN9 NC 13(3,12),13(12) ANY MORE BLOCKS 00104000
BZ APOIN1 00105000
L 12,12(,12) 00106000
B APOIN9 00107000
APOIN1 L 15,AFREE YES - GET TWO DOUBLE WORDS OF STORAGE 00108000
BALR 14,15 00109000
O 1,12(,12) LEAVE COMP. FLAG INTACT 00110000
ST 1,12(,12) STORE THE LOCATION OF THE DOUBLE WORDS 00111000
ST 4,0(,1) IN POINTER AND STORE CONSTANT 00112000
ST 3,4(,1) SET UP FIRST LOCATION POINTER 00113000
ST 3,8(,1) AND LAST LOCATION POINTER 00114000
ST 2,12(,1) MAKE POINTER TO NEXT BLOCK EQUAL ZERO 00115000
TM 0(10),X'02' IS COMP. FLAG ON 00116000
BC 8,APOIN2 NO 00117000
MVI 12(1),X'02' 00118000
APOIN2 LM 0,15,APSV(13) RESTORE REGISTERS 00119000
BCR 15,14 AND RETURN TO CALLER 00120000
RLDR DC A(RELDR) 00121000
SECBASE DC A(RELDR+4096) 00122000
* 00123000
DROP 6 00124000
EJECT 00125000
*********************************************************************** 00126000
* 00127000
* ADDEF - SUBROUTINE TO REMOVE UNDEFINED BIT FROM REFTBL AND 00128000
* REPLACE THE STRING ADDRESSES WITH THEIR PROPER VALUE 00129000
* 00130000
* REGISTER SETTINGS UPON ENTRY 00131000
* 1. ABSOLUTE LOCATION OF SYMBOL 00132000
* 12. ENTRY POINT IN REFTBL 00133000
* 13. SAVE AREA LOCATION 00134000
* 14. RETURN 00135000
* 00136000
*********************************************************************** 00137000
* 00138000
ADDEF TM 8(12),X'80' IS UNDEFINED BIT ON 00139000
BCR 8,14 NO - RETURN TO CALLER 00140000
NI 8(12),X'7F' YES - TURN IT OFF 00141000
L 10,12(,12) POINTER TO FIRST CONSTANT 00142000
LTR 10,10 IS THERE A POINTER 00143000
BCR 8,14 NO - RETURN TO CALLER 00144000
STM 0,15,APSV(13) YES - SAVE REGISTERS 00145000
BALR 11,0 ESTABLISH ADDRESSABILITY 00146000
USING *,11 00147000
SR 2,2 ZERO OUT REG 2 00148000
LR 3,1 PUT ABS LOCATION IN REG 3 00149000
ADDEF7 LR 6,10 SAVE POINTER TO FIRST CONSTANT 00150000
L 8,4(,10) ADCON CORE LOC. 00151000
LTR 8,8 00152000
BM GETVAL4 4 BYPE 00153000
MVC 1(3,10),0(8) GET 3-BYTE VALUE 00154000
B EVAL 00155000
GETVAL4 MVC 0(4,10),0(8) GET 4-BYTE VALUE 00156000
EVAL DS 0H 00157000
LM 7,10,0(10) REG 7 CONTAINS THE CONSTANT 00158000
* REG 8 HAS FIRST MEM LOCATION 00159000
* REG 9 HAS LAST MEM LOCATION 00160000
* REG 10 HAS POINTER TO NEXT CONSTANT 00161000
LR 5,9 LOAD REG 5 WITH LAST MEN LOCATION 00162000
L 9,APSV+36(13) RESTORE 2ND BASE REG. 00163000
TM 12(6),X'02' IS COMP. FLAG ON 00164000
BC 8,ADDEF1 NO 00165000
SR 7,3 00166000
ST 7,TEMPST(,13) STORE LOCATION TEMPORARILY 00167000
BC 15,ADDEF2 00168000
ADDEF1 AR 7,3 VALUE OF THE SYMBOL 00169000
ST 7,TEMPST(,13) STORE VALUE TEMPORARILY 00170000
ADDEF2 LTR 8,8 IS THE LOCATION FOUR BYTES LONG 00171000
BC 4,ADDEF8 YES - BRANCH 00172000
MVC TMPLOC+1(3,13),0(8) N0 - MOVE ADDRESS PTR 00173000
TM TMPLOC+1(13),X'80' IS NEXT ADDR 4 BYTES 00174000
BC 7,SIGN YES 00175000
NI TMPLOC(13),0 00176000
ADDMOV MVC 0(3,8),TEMPST+1(13) MOVE IN CONST 00177000
BC 15,ADDEF9 AND CHECK NEXT ADDR 00178000
SIGN OI TMPLOC(13),X'80' TURN ON SIGN BIT 00179000
NI TMPLOC+1(13),X'7F' AND TURN OFF SIGN BIT IN 00180000
* SECOND BYTE. 00181000
BC 15,ADDMOV GO MOVE IN CONSTANT 00182000
ADDEF8 MVC TMPLOC(4,13),0(8) MOVE NEW ADDRESS TO TEMP LOC. 00183000
MVC 0(4,8),TEMPST(13) MOVE IN CONSTANT 00184000
ADDEF9 CLR 8,5 00185000
BC 8,ADDEF6 YES - PICK UP POINTER TO NEXT CPMSTAMT 00186000
L 8,TMPLOC(,13) NO - PICK UP NEXT MEMORY LOCATION 00187000
BC 15,ADDEF2 AND GO WORK ON NEXT LOCATION 00188000
ADDEF6 LA 0,2 NO OF DOUBLE WORDS TO GIVE BACK 00189000
LR 1,6 LOCATION WE ARE THROUGH WITH 00190000
L 15,AFRETX 00191000
BALR 14,15 AND BRANCH TO FRET 00192000
LA 10,0(,10) 00193000
LTR 10,10 00194000
BC 7,ADDEF7 NO - GO TO NEXT AREA 00195000
LM 0,15,APSV(13) YES - RESTORE REGISTERS 00196000
BCR 15,14 AND RETURN 00197000
* 00198000
DROP 11 00199000
EJECT 00200000
********************************************************************** 00201000
* 00202000
* HEX-BINARY CONVERSION ROUTINE 00203000
* 00204000
* PLACE THE NUMBER OF CHARACTERS IN REG 4 00205000
* ADDRESS OF HIGH ORDER IN REG 5 00206000
* LINKAGE-- L 1,HEXADD 00207000
* RETURN ADDRESS IN REG 0. 00208000
* BALR 0,1 00209000
* ANSWER RETURNED IN REG 0 00210000
* 00211000
* 00212000
********************************************************************** 00213000
* 00214000
HEXB EQU * 00215000
USING HEXB,1 00216000
ST 0,RETT(,13) 00217000
SR 3,3 00218000
LR 0,3 00219000
LA 2,ERR2 00220000
L1 CLI 0(5),C'0' CMP TO VALUE OF ZERO 00221000
BC 4,L3 BR IF NOT 0 THRU 9 00222000
CLI 0(5),C'9' CMP TO VALUE OF NINE 00223000
BCR 3,2 ERROR. 00224000
* CLEAR HIGH ORDER BITS OF CHAR 00225000
NI 0(5),X'0F' * 00226000
IC 3,0(0,5) * 00227000
L2 SLL 0,4 * 00228000
AR 0,3 * 00229000
LA 5,1(,5) 00230000
BCT 4,L1 00231000
L 2,RETT(,13) 00232000
BCR 15,2 00233000
L3 CLI 0(5),C'A' 00234000
BCR 4,2 BR IF VALUE LESS 00235000
CLI 0(5),C'F' 00236000
BCR 3,2 ERROR. 00237000
IC 3,0(0,5) 00238000
SH 3,CONST 00239000
BC 15,L2 00240000
ERR2 MVC CDIMJ(80),SPEC(13) 00241000
LA 7,SPEC+5(,13) LET REGISTER FIVE HOLD NO. OF POSITIONS 00242000
SR 5,7 IN REP CARD TO BLANK OUT FOR PRINTING 00243000
MVI SPEC+5(13),C' ' MOVE IN ONE BLANK 00244000
LTR 5,5 ARE THERE ANY MORE TO MOVE 00245000
BC 4,LDERRA NO - GO PRINT ERROR MESSAGE 00246000
EX 5,MVC4 YES - MOVE IN REMAINING BLANKS 00247000
LDERRA LA 5,ERRORA 00248000
BAL R14,ERPRNT BAD CONVERSION 00249000
BAL R14,PAGER EJECT PAGE 00250000
SVC 100 DIE... 00251000
* 00252000
MVC4 MVC SPEC+6(1,13),SPEC+5(13) 00253000
* 00254000
DS 0H 00255000
* 00256000
CONST DC X'00B7' 00257000
* 00258000
DROP 1 00259000
EJECT 00260000
*********************************************************************** 00261000
* 00262000
* ROUTINE TO EXTEND MEMORY BOUND DOWN 00263000
* 00264000
*********************************************************************** 00265000
* 00266000
USING *,15 00267000
* 00268000
EXTEND STM 6,7,EPSW 00269000
L 15,BREG1 ESTABLISH GOOD ADDRESSABILITY. 00270000
USING RELDR,15 00271000
CLI CNTR,0 00272000
BC 8,FIRST YES 00273000
L 7,HILOW LOAD HIGHEST LOCATION USED BELOW LOADER. 00274000
L 6,FREEST(,13) AND LOWER BOUND OF FREE STORAGE 00275000
S 6,ONTHOU 00276000
S 6,F32 DROP THE LOWER BOUNDARY BY 4 DW'S 00277000
A 7,TWTHOU ALLOW TWO-THOUSAND MORE BYTES FOR TEXT 00278000
CR 6,7 ENOUGH ROOM FOR MORE FREE STORAGE 00279000
BC 12,NOMORE NO - COMPLAIN 00280000
LA 0,1000 NO OF BYTES 00281000
LR 1,6 ADDRESS OF START OF DOUBLE WORDS 00282000
ST 1,FREEST(,13) 00283000
ST 1,BELOW 00284000
ERET LM 6,7,EPSW 00285000
BCR 15,14 00286000
* 00287000
FIRST L 1,TOP 00288000
L 0,AMAXREF MAX NO. OF UNRESOLVED REF. 00289000
SLL 0,4 00290000
SR 1,0 00291000
LA 0,1264 00292000
SR 1,0 00293000
S 1,F32 00294000
ST 1,T1 00295000
MVI CNTR,1 00296000
BCR 15,14 00297000
* 00298000
NOMORE LA 5,ERRORO 00299000
BAL R14,ERPRNT NO FREE STORAGE LEFT 00300000
BAL R14,PAGER EJECT PAGE 00301000
SVC 101 DIE... 00302000
ONTHOU DC F'1000' 00303000
TWTHOU DC F'2000' 00304000
EPSW DS 2F 00305000
CNTR DC X'00' 00306000
T1 DS 1F .. 00307000
HILOW DC F'0' HIGHEST LOCATION USED BELOW LOADER. 00308000
F32 DC F'32' CONSTANT 00309000
EJECT 00310000
*********************************************************************** 00311000
* 00312000
* PROGRAM INITIAL LOADING ENTRY 00313000
* 00314000
* 00315000
* SWS(13) BIT POSITION 0 = ABS LOAD FLAG 00316000
* 1 = FTTR1 FLAG - FIRST TIME TRANSFER 00317000
* 2 = NO HEX ADDR IN SLC CARD 00318000
* 3 = END CRD ADDR SAVED 00319000
* 4 = TWO OR MORE REP ENTRIES IN CRD 00320000
* 00321000
*********************************************************************** 00322000
* 00323000
LOAD2 BALR 15,0 00324000
USING *,15 00325000
L 9,BASE 00326000
L 15,BREG1 00327000
USING RELDR,15,9 00328000
MVI DEVSW,X'01' 00329000
XC SWS(2),SWS CLEAR SWITCH SETTINGS. 00330000
LA 1,0 TABLE COUNT INITIALLY 00331000
STH 1,TBLCT(,13) .. 00332000
L 11,CTRSET 00333000
ST 11,LOCCT(,13) STARTING LOCTION TO LOAD SAVED 00334000
EJECT 00335000
*********************************************************************** 00336000
* 00337000
* RESUME LOADING ENTRY 00338000
* 00339000
*********************************************************************** 00340000
* 00341000
OVRLDR EQU * 00342000
RESUME BALR 15,0 00343000
USING *,15 00344000
L 15,BREG1 00345000
USING RELDR,15 00346000
SR 1,1 00347000
ST 1,BRAD(,13) 00348000
MVI SWS,ABS+ENDB+FTTR1 TURN ON BITS. 00349000
SSM CH0OFF NO INTERRUPTS PLEASE @V60B9BA 00349100
LH 2,PRNTR GET THE PRINTER ADDRESS @V60B9BA 00349200
MVC ZCAW(4),INITCCW GET INITIALIZE PRINTER CCW @V60B9BA 00349300
TIO 0(2) CLEAR THE PATH @V60B9BA 00349400
BC 2,*-4 KEEP ON UNTIL IT'S CLEAR @V60B9BA 00349500
SIO 0(2) DO THE INITIALIZE PRINTER @V60B9BA 00349600
BC 4+1,RD FORGET ABOUT IT, THEN @V60B9BA 00349700
TIO 0(2) WAIT TILL THE INTERRUPT CLEARS @V60B9BA 00349800
BNZ *-4 ... @V60B9BA 00349900
RD EQU * 00350000
LOOP L 1,LOCCT(,13) CHECK FOR HIGHEST LOCATION BELOW LOADER. 00351000
C 1,LEND AND SEE IF IT HAS CHANGED. BRANCH IF 00352000
BC 2,LOOP1 LOCATION COUNTER IS ABOVE LOADER. 00353000
C 1,HILOW .. 00354000
BC 4,LOOP1 NO CHANGE. 00355000
ST 1,HILOW UPDATE HIGHEST LOCATION USED BELOW LDR. 00356000
LOOP1 BAL 10,LOOP2 BRANCH TO START I/O 00357000
B CONTIN CONTINUE 00358000
LOOP2 MVC ZCAW(4),RDCCW READ CONTROL WORD TO LOWER CORE. 00359000
SIO2 SSM CH0OFF TURN OFF MULTIPLEX CHANNEL 00360000
LH 2,READER 00361000
SIO 0(2) START INPUT OPERATION 00362000
BC 8,WAITXX CHECK FOR SUCCESS - IF 0 EVERYTHING O.K 00363000
BC 4,WAIT1 CSW STORED 00364000
BC 2,WAIT5 BUSY 00365000
NOTOP1 LA 5,RETYRD INTERVENTION REQUIRED 00366000
MVC PRNTR(2),CNSL SET UP TO PRINT MSG ON CONSOLE 00367000
BAL 14,ERPRNT GO TELL USER 00368000
BAL 14,PAGER SKIP TO NEW PAGE ON PRINTER 00369000
MVC PRNTR(2),PRNTSET RESTORE PRNTR ADDRESS 00370000
WAIT7 MVC ZIONP+2(2),READER SET UP FOR DEVICE END 00371000
CNOP 4,8 00372000
WAIT2 LPSW *+4 00373000
DC X'FF020000' WAIT FOR INTERRUPT 00374000
WAIT2AD DC A(LOOP2) AND THEN RETRY READ 00375000
SPACE 2 00376000
WAIT5 STH 2,ZIONP+2 WAIT FOR ANY INTERRUPT ON THIS CNANNEL 00377000
OI ZIONP+2,X'80' 00378000
B WAIT2 00379000
SPACE 3 00380000
WAIT1 TM ZCSW+4,X'02' IS IT UNIT CHECK 00381000
BC 1,NOTOP1 YES - INTERVENTION REQUIRED 00382000
TM ZCSW+4,X'14' IS IT BUSY 00383000
BC 1,LOOP2 NOT ANY MORE 00384000
BC 4,WAIT7 YES - WAIT TO READ 00385000
TM ZCSW+4,X'01' IS IT END OF FILE 00386000
BC 1,C6AC3 YES - ENTER LDT PROCESSOR 00387000
SPACE 3 00388000
WAIT6 BAL 14,PAGER EJECT PAGE - WAIT FOR OPERATOR. 00389000
CNOP 4,8 .. 00390000
LPSW *+4 .. 00391000
DC X'00020000' 00392000
DC 4X'CC' 00393000
SPACE 3 00394000
CNOP 0,8 -ALIGNMENT- 00395000
* 00396000
WAITXX STH 2,ZIONP+2 00397000
LPSW *+4 00398000
DC X'FE020000' 00399000
WAITXXAD DC A(*+4) PROCEED WHEN INPUT OPERATION FINISHED. 00400000
CLC ZIOOP+2(2),ZIONP+2 00401000
BNE WAITXX 00402000
TM ZCSW+4,1 END-OF-FILE? 00403000
BC 1,C6AC3 YES - BRANCH 00404000
TM ZCSW+4,X'02' WAS THERE A VALIDITY CHECK 00405000
BCR 8,10 NO -GO PROCESS 00406000
CLI ERETRYSW,X'80' IS THE ERROR RETRY SWITCH ON 00407000
BE TAPERR YES ISSUE SENSE COMMAND 00408000
STM 2,9,ERRSAV SAVE REGS 00409000
B TAPERR BRANCH TO TAPE ERROR ROUTINE 00410000
NOISERTN LM 2,9,ERRSAV RESTORE REGS 00411000
MVI ERETRYSW,X'00' RESET SWITCH 00412000
B LOOP1 00413000
CONTINUE LM 2,9,ERRSAV RESTORE REGS 00414000
B CONTIN 00415000
CARDRTN LM 2,9,ERRSAV RESTORE REGS 00416000
MVI ERETRYSW,X'00' RESET SWITCH 00417000
CONTCARD LA 5,VALCHK YES SEND A MSG TO THE USER 00418000
TIO 0(2) DRAIN THE READER 00419000
TM ZCSW+4,X'10' 00420000
BC 1,*-8 UNTIL NOT BUSY 00421000
LA 14,NOTOP1 AND THEN WAIT FOR USER TO 00422000
BC 15,ERPRNT CORRECT ERROR BEFORE WE REREAD 00423000
CONTIN SR 6,6 00424000
LA 11,1 REGISTER 11 ALWAYS SET TO 1 00425000
L 1,SPEC(,13) 00426000
TM SWS+1,ENDFLG IS FLUSH-TO-END SWITCH ON 00427000
BC 1,FLUSH YES - BRANCH 00428000
TM DEVSW,X'01' 00429000
BO DEVHNDLR 00430000
CONTINU C 1,SLC 00431000
BNE C2AE2 00432000
BC 15,C2AD1 00433000
FLUSH C 1,END ALL OVER IF THIS IS THE END 00434000
BC 7,RD NOT SO 00435000
MVC READER(2),RDR RESTORE THE READER 00436000
NI SWS+1,255-ENDFLG CLEAR FLAG 00437000
BC 15,RD AND CONTINUE 00438000
EJECT 00439000
*********************************************************************** 00440000
* 00441000
* SET LOCATION COUNTER ROUTINE (SLC) 00442000
* THIS ROUTINE HAS TWO ENTRIES 00443000
* (1) AT THE BEGINNING WHEN RESUME FALLS THRU 00444000
* (2) ORG2- USED TO OBTAIN THE CURRENT ADDRESS OF A GIVEN 00445000
* SYMBOLIC LOCATION. 00446000
* THIS ROUTINE SETS THE LOCATION COUNTER TO THE SLC- 00447000
* CARD SPECIFIED ADDRESS AND/OR OBTAINS THE CURRENT 00448000
* ADDRESS OF A GIVEN SYMBOLIC LOC. FROM THE REFTBL TABLE. 00449000
* NOTE THAT IF NO ABS LOC IS PUNCHED AND THE SYMBOLIC NAME 00450000
* IS AS YET UNDEFINED, AN ERROR IS CREATED. 00451000
* 00452000
*********************************************************************** 00453000
* 00454000
C2AD1 CLI SPEC+6(13),C' ' CMP ADDR FOR BLANKS 00455000
BC 7,C2AD BR- ADDR IN CRD 00456000
OI SWS,BRSW NO ADDRESS - TURN ON SWITCH. 00457000
BC 15,C2A 00458000
C2AD LA 4,6(0,0) CONVERT ADDR TO BINARY 00459000
LA 5,SPEC+6(,13) 00460000
L 1,HEXBB LOAD CONVERSION ROUTINE ADDRESS 00461000
BALR 0,1 BR TO HEXB ROUTINE 00462000
LR 6,0 SAVE ADDR IN REGISTER 00463000
C2A CLI SPEC+16(13),C' ' TEST IMAGE FOR NAME 00464000
* SYMBOL IS LEFT ADJUSTED 00465000
BC 7,C2AE3 BR- NAME IN CRD 00466000
LA 5,ERRORA 00467000
MVC CDIMJ(80),SPEC(13) 00468000
LA 14,RD 00469000
TM SWS,BRSW 00470000
BC 1,ERPRNT 00471000
SR 0,0 00472000
C2X NI SWS,255-BRSW TURN OFF SWITCH. 00473000
AR 6,0 ADD CONVERTED ADDR TO ORG2 00474000
ST 6,LOCCT(,13) SET THE LOCATION COUNTER 00475000
B RD RETURN TO READ A CARD. 00476000
C2AE3 LA 2,ERRSLC 00477000
BAL 3,SERCH 00478000
LA 14,C2X LINK AGE 00479000
ORG2 L 0,8(0,12) THE ABSOLUTE LOCATION 00480000
BCR 15,14 00481000
ERRSLC LH 3,TBLCT(,13) 00482000
SR 3,11 00483000
STH 3,TBLCT(,13) 00484000
LA 5,ERRORU 00485000
MVC ERRU(8),0(12) 00486000
LA 14,RD 00487000
BC 15,ERPRNT 00488000
EJECT 00489000
* SET PAGE BOUNDRY ROUTINE (SPB) 00490000
* THIS ROUTINE ROUNDS THE LOCATION COUNTER 00491000
* TO THE NEAREST HIGHER PAGE BOUNDRY 00492000
C2AE2 C 1,SPB 00493000
BNE C2AE1 00494000
L 1,LOCCT(,13) 00495000
LA 1,4095(,1) 00496000
N 1,PAGENO 00497000
ST 1,LOCCT(,13) 00498000
B RD 00499000
EJECT 00500000
*********************************************************************** 00501000
* 00502000
* INCLUDE CONTROL SECTION 00503000
* ROUTINE (ICS) 00504000
* 00505000
*********************************************************************** 00506000
* 00507000
C2AE1 C 1,ICS 00508000
BC 7,C3AA1 BR NO 00509000
LA 5,ERRORA 00510000
MVC CDIMJ(80),SPEC(13) 00511000
LA 14,RD 00512000
CLI SPEC+24(13),C' ' TEST FOR HEX ADDR 00513000
BC 8,ERPRNT 00514000
LA 4,4 00515000
LA 5,SPEC+24(,13) TO BINARY 00516000
L 1,HEXBB LOAD CONVERSION ROUTINE ADDRESS 00517000
BALR 0,1 BR TO HEXB 00518000
LR 6,0 SAVE LENGTH IN REG 00519000
LA 14,RD LOAD LINKAGE TO BRANCH TO RD WHEN DONE 00520000
LA 3,SYMDEF IF NAME IN REFTBL, IS IT DEFINED 00521000
BAL 2,SERCH 00522000
* ENTERED C2AJ1 FROM ESD00 ROUTINE 00523000
C2AJ1 L 1,LOCCT(,13) LOD PRESENT LOCATION 00524000
LTR 6,6 IS THE SEGMENT LENGTH EQUAL TO ZERO 00525000
BC 8,C2AJ4 YES - BRANCH OUT 00526000
ADJ TM LOCCT+3(13),X'07' TEST FOR MULT OF EIGHT 00527000
BC 8,C2AJ4 BR YES 00528000
AR 1,11 ADD ONE 00529000
ST 1,LOCCT(,13) 00530000
BC 15,ADJ 00531000
C2AJ4 LR 7,14 TEST FOR UNDEFINED BIT 00532000
L 5,AADDEF AND DEFINE IF NECESSARY 00533000
BALR 14,5 00534000
STOABS ST 1,8(,12) STORE VALUE OF LOCCT IN REFTBL 00535000
AR 1,6 UPDATE LOCCT 00536000
ST 1,LOCCT(,13) 00537000
MVC LOC1(8),0(12) MOVE NAME TO PRINT STATEMENT 00538000
UNPK LOC1+12(7),9(4,12) 00539000
TR LOC1+12(8),DMPTBL-240 TRANSLATE LOCATION INTO EBCD 00540000
MVC LOC1+18(20),ORAREA CLEAR PRINT AREA 00541000
MVC LOC1+38(11),ORAREA ... 00542000
CLI SPEC+24(R13),X'00' ESD TYPE 0 CARD ? 00543000
BNE NOTESD0 NO 00544000
MVC LOC1+24(21),ESDHDR MOVE IN ESD HEADING INFORMATION 00545000
UNPK LOC1+39(7),SPEC+29(4,R13) UNPACK THE LENGTH 00546000
TR LOC1+39(8),DMPTBL-240 TRANSLATE PRINTABLE 00547000
NOTESD0 EQU * HERE IF NOT ESD TYPE 0 00548000
LA 5,ERRORL 00549000
BAL 14,ERPRNT AND GO PRINT PIECE OF LOADER MAP 00550000
MVC LOC1+18(20),ORAREA CLEAR PRINT AREA 00551000
MVC LOC1+38(9),ORAREA .... 00552000
LR 14,7 00553000
SR 6,6 00554000
BCR 15,14 RETURNS TO RD OR C3AD4 (IN ESD T-0) 00555000
SYMDEF TM 8(12),X'80' IS UNDEFINED BIT ON 00556000
BCR 8,14 IF DEFINED, IGNORE ICS CARD 00557000
BC 15,C2AJ1 YES - ALIGN ABS ADDR OF PROGRAM ON DOUBL 00558000
* WORD BOUNDARY AND GO GET NEXT CARD 00559000
EJECT 00560000
*********************************************************************** 00561000
* 00562000
* DETERMINE IF ESD TYPE CARD 00563000
* 00564000
*********************************************************************** 00565000
* 00566000
C3AA1 C 1,ESD 00567000
BC 7,C4AA1 NO- TEST FOR TXT CRD 00568000
CA3A1 NI SPEC+24(13),X'0F' 00569000
CLI SPEC+24(13),X'00' * 00570000
BZ C3AA3 (SD)-- ESD TYPE 0 @VA04840 00571500
LA 5,ERRORA 00574000
MVC CDIMJ(80),SPEC(13) 00575000
LA 14,RD 00576000
* VALID ESD TEST 00577000
CLI SPEC+24(13),X'03' * 00578000
BC 10,ERPRNT 00579000
CLI SPEC+24(13),X'02' * 00580000
BC 10,C3AH1 BR, EXTERNAL SYMBOL ESD 00581000
EJECT 00582000
*********************************************************************** 00583000
* 00584000
* ESD TYPE 1 ROUTINE (ENTRY) 00585000
* 00586000
*********************************************************************** 00587000
* 00588000
LH 3,SPEC+30(,13) LOAD EXTERNAL SYMBOL ID NO. 00589000
BAL 14,REFADR OBTAINS ADDR OF THE ENTRY IN REFTBL 00590000
STC 6,SPEC+24(,13) 00591000
L 7,12(,12) LOAD REL FACTOR OF CONTROL SEGMENT 00592000
A 7,SPEC+24(,13) FORM ENTRY POINT 00593000
LA 2,C3AD1 NOT FOUND RETURN 00594000
BAL 3,SERCH SEARCH FOR NAME IN REFTBL 00595000
L 0,8(,12) LOAD RELOCATED ADDRESS 00596000
LA 5,ERRORD 00597000
MVC ERRD(8),0(12) 00598000
TM 8(12),X'80' IS ENTRY DEFINED 00599000
BC 1,C3AD2 NO - DEFINE IT 00600000
CR 7,0 YES - CMP ORG2 TO GENERATED ADDR 00601000
BE GOODCMP 00602000
BAL R14,ERPRNT PRINT BAD NEWS 00603000
DUPESD BAL R14,PAGER EJECT PAGE @VA08186 00604100
SVC 102 DIE ..... 00605000
GOODCMP MVC NAME,0(12) MOVE ENTRY NAME TO ERROR MESSAGE 00606000
LA 5,ERRORM DUPLICATE IDENTIFIER-FATAL ERROR @VA08186 00607100
BAL 14,ERPRNT 00608000
BC 15,DUPESD DUPLICATE ESD ENTRY @VA08186 00609100
C3AD2 LR 1,7 LOAD REG 1 FROM 7 00610000
L 5,AADDEF 00611000
BALR 14,5 00612000
ST 1,8(,12) AND UPDATE CORE - STORE ABS ADDR 00613000
BC 15,PRNT 00614000
C3AD1 ST 7,8(,12) STORE ABS VALUE IN REFTBL 00615000
PRNT MVC LOC1(8),0(12) MOVE NAME TO PRINT STATEMENT 00616000
UNPK LOC1+12(7),9(4,12) 00617000
TR LOC1+12(8),DMPTBL-240 TRANSLATE LOCATION INTO EBCD 00618000
MVC LOC1+18(2),ORAREA CLEAR 2 BYTES FROM PRINT LINE 00619000
LA 5,ERRORL 00620000
BAL 14,ERPRNT AND GO PRINT PIECE OF LOADER MAP 00621000
BC 15,ESD00 AND GO CHECK FOR MULTIPLE ENTRIES 00622000
EJECT 00623000
*********************************************************************** 00624000
* 00625000
* ESD TYPE 0 ROUTINE (SEGMENT NAME) 00626000
* 00627000
*********************************************************************** 00628000
* 00629000
C3AA3 TM SWS+1,SKPFLG SHOULD WE TEST FOR SKIP? 00630000
BC 1,SKPTST YES - BRANCH 00631000
C3AA3B NI SWS,255-ABS TURN OFF ABSOLUTE LOAD FLAG 00632000
TM SWS,ESDSW HAVE WE SEEN TYPE 0 OR 2 BEFORE. 00633000
BZ C3AA3A NO. - CONTINUE AS USUAL. 00634000
LH 2,SPEC+14(,13) BUMP ESID NO. BY ONE FOR EXTRA ENTRIES. 00635000
LA 2,1(,2) .. 00636000
STH 2,SPEC+14(,13) .. 00637000
C3AA3A OI SWS,ESDSW SET ESID SWITCH. 00638000
LA 2,C3AC3 NAME NOT IN TBL RETURN 00639000
BAL 3,SERCH SEARCH FOR NAME IN REFTBL 00640000
TM 8(12),X'80' IS ENTRY DEFINED 00641000
BC 7,C3AC3 NO - GET STARTING LOCATION 00642000
MVC NAME,0(12) MOVE ESD NAME TO ERROR MESSAGE 00643000
LA 5,ERRORM 00644000
BAL 14,ERPRNT POSSIBLE OVERLAYING OF A PREVIOUS DECK 00645000
C3AD4 L 0,8(,12) COMPUTE RELOCATION FACTOR 00646000
LH 2,SPEC+14(,13) LOD ESID 00647000
SLL 2,1 TIMES 2 FOR HALFWORD ENTRY 00648000
STH 4,ESIDTB(13,2) REFTBLE POSITION TO ESIDTB(13) 00649000
SRL 2,1 BACK AGAIN 00650000
STC 6,SPEC+24(,13) LOD ASSEMBLED ADDR 00651000
L 2,SPEC+24(,13) 00652000
CR 0,2 00653000
BC 5,COMP BR- ORG2 LESS THAN ADDR 00654000
SR 0,2 00655000
RELF ST 0,12(,12) SAVE RELOCATION FACTOR 00656000
BC 15,ESD00 READ ANOTHER CARD 00657000
COMP SR 2,0 ADDRESS MINUS ORIGIN 00658000
LCR 0,2 COMPLEMENT (TWOS) 00659000
BC 15,RELF 00660000
C3AC3 STC 6,SPEC+28(,13) RETURNED HERE FOR NAME NOT FND 00661000
L 6,SPEC+28(,13) LOD SEGMENT LENGTH 00662000
LA R0,XTRSIZE SIZE OF BUFFER FOR EXTRNS 00663000
L R15,AFREE ADDRESS OF FREE STORAGE ROUTINE 00664000
BALR R14,R15 CALL FREE FOR STORAGE 00665000
L R15,BREG1 RESTORE REG-15 00666000
ST R1,PNTXTR0 REMEMBER ESD TYPE 0 CHAIN @VA04840 00667000
USING XTRBLOK,R3 ADDRESSABILITY 00668000
LR R3,R1 PUT IN PROPER REGISTER 00669000
XC XTRPNT(16),XTRPNT CLEAR OUT ADDRESS POINTER FILES 00670000
MVI XTRDATA,C' ' CLEAR PRINTER AREA TO BLANKS 00671000
MVC XTRDATA+1(XTRDATAL-1),XTRDATA ... 00672000
MVC XTRDATA+26(34),HEADING PUN IN THE HEADING LINE 00673000
LA R1,XTRDATA ADDRESS WHERE PRINT DATA CAN BE FOUND 00674000
ST R1,XTRLINE SAVE IT IN THE CONTROL BLOK 00675000
MVI XTRLEN+1,86 MAKE THIS LINE LOOK LIKE ITS FULL 00676000
MVC XTRDATA+62(8),0(R12) FILL IN CSECT NAME 00677000
CLC 0(6,R12),DMKPSA LOADING VM/370 SYSTEM ? 00678000
BNE *+8 NO- NOT FOUND 00679000
MVI VM370,X'FF' INDICATE LOADING VM/370 00680000
CLC 0(6,R12),DMKCPE REACH END OF NUCLEUS YET ? 00681000
BNE *+12 NO - 00682000
MVI CPEND,X'FF' FLAG FOR SKIP TO CHANNEL 1 00683000
MVI ENDNUC,X'FF' INDICATE END OF NUCLEUS HAS BEEN REACHED 00684000
LA R14,C3AD4 RETURN ADDRESS 00685000
CLI VM370,X'FF' IS THIS VM/370 OR CMS . 00686000
BNE C2AJ1 MUST BE CMS 00687000
CLI ENDNUC,X'FF' REACHED END OF NUCLEUS YET ? 00688000
BNE C2AJ1 NO - DON'T CHECK SPB YET 00689000
CLC 0(6,R12),DMKWRM IS THIS DMKWRM ? 00690000
BE C2AJ1 YES - SKIP OVER PAGE BOUNDARY 00691000
L R2,LOCCT(,R13) GET LOCATION COUNTER 00692000
LA R2,4095(,R2) FORCE TO NEXT PAGE BOUNDARY 00693000
N R2,PAGENO REMOVE THE DISPLACEMENT 00694000
L R1,LOCCT(,R13) RELOAD LOCATION COUNTER 00695000
CLR R1,R2 ALREADY ON PAGE BOUNDARY ? 00696000
BE C2AJ1 YES - DON'T CHECK FURTHER. 00697000
ADJ1 EQU * @VA01938 00698000
TM LOCCT+3(13),X'07' TEST FOR DOUBLEWORD BOUNDARY @VA01938 00699000
BC 8,CKFIT YES, SEE IF IT'LL FIT @VA01938 00700000
AR 1,11 NO, ADD ONE @VA01938 00701000
ST 1,LOCCT(,13) @VA01938 00702000
BC 15,ADJ1 DO IT AGAIN @VA01938 00703000
CKFIT EQU * @VA01938 00704000
AR R1,R6 ADD TO IT LENGTH OF THIS MODULE 00705000
CR R1,R2 SHOULD WE FORCE MODULE TO PAGE BOUNDARY 00706000
BNH C2AJ1 NO - DID NOT SPILL INTO NEXT PAGE 00707000
ST R2,LOCCT(,R13) FORCE THIS MODULE TO NEXT PAGE BOUNDARY. 00708000
MVC XTRDATA+70(15),SPBHDR ALSO FLAG IT. 00709000
DROP R3 00710000
B C2AJ1 CONTINUE 00711000
SPACE 1 00712000
SPACE 00713000
SKPTST CLC SPEC+16(8,13),SKPMSG IS THIS THE ONE TO SKIP? 00714000
BC 7,C3AA3B 00715000
XI SWS+1,SKPFLG+ENDFLG YES - SKIP TO END CARD 00716000
BC 15,RD 00717000
EJECT 00718000
*********************************************************************** 00719000
* 00720000
* ESD TYPE 2 ROUTINE (EXTRN) 00721000
* THIS ROUTINE HAS TWO ENTRY POINTS. LOC C3AH1 AND LOC ESD00 00722000
* LOCATION C3AH1 IS ENTERED FROM THE ESD CARD ANALYSIS ROUTINE 00723000
* LOCATION ESD00 IS ENTERED FROM... 00724000
* 1. THE ESD CARD ANALYSIS ROUTINE WHEN THE CARD BEING 00725000
* PROCESSED IS A TYPE 1OR 2 , AND AN ABS LOAD IS INDICATED 00726000
* 2. THE ESD TYPE 0 ROUTINE AND TYPE 1 ENTER AS THE LAST 00727000
* STEP OF THESE ROUTINES 00728000
*********************************************************************** 00729000
* 00730000
C3AH1 TM SWS,ESDSW HAVE WEE SEEN TYPE 0 OR 2 ON THIS CARD. 00731000
BC 8,C3AH3 00732000
LH 2,SPEC+14(,13) 00733000
LA 2,1(,2) 00734000
STH 2,SPEC+14(,13) 00735000
C3AH3 LA 2,C3AH2 00736000
OI SWS,ESDSW INDICATE WE HAVE ESD 2 ON THIS CARD. 00737000
USING XTRBLOK,R3 ADDRESSABILITY 00738000
L R3,PNTXTR GET POINTER TO LIST OF CHAIN 00739000
LTR R3,R3 CHAIN EMPTY ? @VA04840 00740100
BZ FNDONE1 IF YES,ADD NEW BUFFER TO LIST @VA04840 00740150
SLR R0,R0 CLEAR A COMPARISON REGISTER @VA04840 00740200
LA R3,PNTXTR YES,POINT TO ANCHOR @VA04840 00740250
NXTBUF CL R0,0(,R3) ARE WE AT THE END OF THE CHAIN 00741000
BE FNDONE YES - 00742000
L R3,0(,R3) NO - KEEP SEARCHING 00743000
B NXTBUF .. 00744000
FNDONE CLI XTRLEN+1,XTRFULL IS THIS BUFFER FULL UP ? 00745000
BNH NOXFREE IF NOT THEN DON'T CALL FREE 00746000
FNDONE1 LA R0,XTRSIZE SIZE OF EXT BUFFER @VA04840 00747500
L R15,AFREE ADDRESS OF FREE STORAGE ROUTINE 00748000
BALR R14,R15 CALL FREE 00749000
L R15,BREG1 RESTORE REG-15 00750000
LTR R3,R3 CHAIN EMPTY ? @VA04840 00751100
BNZ FNDONE2 NO,PATCH TO LAST BUFFER @VA04840 00751200
ST R1,PNTXTR ELSE,INIT ANCHOR @VA04840 00751300
B FNDONE3 @VA04840 00751400
FNDONE2 ST R1,0(,R3) PATCH TO EXISTING CHAIN @VA04840 00751500
FNDONE3 LR R3,R1 START WORKING W/ NEW BUFR @VA04840 00751600
XC XTRPNT(16),XTRPNT CLEAR OUT CONTROL DATA POINTERS 00753000
MVI XTRLEN+1,25 START AT PRINT POSITION 26 00754000
MVI XTRDATA,C' ' CLEAR PRINTER INFORMATION TO BLANKS 00755000
MVC XTRDATA+1(XTRDATAL-1),XTRDATA ... 00756000
LA R0,XTRDATA GET ADDRESS WHERE PRINT DATA WILL GO 00757000
ST R0,XTRLINE AND SAVE ITS ADDRESS 00758000
NOXFREE SLR R1,R1 CLEAR 00759000
LH R1,XTRLEN GET NUMBER OF BYTES IN USE. 00760000
LA R1,XTRDATA(R1) POINT TO CORRECT BUFFER LOCATION 00761000
MVC 0(8,R1),SPEC+16(R13) MOVE IN EXTRN NAME 00762000
LH R1,XTRLEN GET NUMBER OF BYTES AGAIN 00763000
LA R1,10(,R1) INCREMENT TO NEXT BUFFER LOCATION 00764000
STH R1,XTRLEN AND STORE IT BACK 00765000
DROP R3 00766000
SPACE 00767000
BAL 3,SERCH SEARCH FOR NAME IN REFTBL 00768000
LH 2,SPEC+14(,13) LOAD ESID 00769000
SLL 2,1 TIMES 2 FOR HALFWORD ENTRY 00770000
STH 4,ESIDTB(13,2) REFTBLE POSITION TO ESIDTB 00771000
SRL 2,1 BACK AGAIN 00772000
TM 8(12),X'80' IS UNDEFINED BIT ON 00773000
BC 1,ESD00 YES - CHECK FOR MULTIPLE ENTRIES 00774000
L 0,8(,12) LOAD RELOCATED ADDRESS 00775000
ST 0,12(,12) STORE RELFAC IN REFTBL 00776000
ESD00 LA 2,16 TEST FOR MULTIPLE ENTRIES IN CARD 00777000
LH 1,SPEC+10(,13) 00778000
SR 1,2 00779000
BC 3,C3AH5 00780000
NI SWS,255-ESDSW CLEAR SWITCH FOR START OF NEXT CARD. 00781000
BC 15,RD 00782000
C3AH5 MVC SPEC+16(32,13),SPEC+32(13) 00783000
STH 1,SPEC+10(,13) 00784000
BC 15,CA3A1 00785000
C3AH2 OI 8(12),X'80' PLACE UNDEFINED BIT ON 00786000
SR 3,3 CLEAR REGISTER 3 00787000
ST 3,12(,12) STORE ZERO IN RELOCATION FACTOR 00788000
LH 2,SPEC+14(,13) LOAD ESID. 00789000
SLL 2,1 TIMES 2 FOR HALFWORD ENTRY 00790000
STH 4,ESIDTB(13,2) REFTBL POSITION TO ESIDTB 00791000
SRL 2,1 BACK AGAIN 00792000
BC 15,ESD00 AND CHECK FOR MULTIPLE ENTRIES 00793000
EJECT 00794000
*********************************************************************** 00795000
* 00796000
* TEXT CARD ROUTINE (TXT) 00797000
* 00798000
*********************************************************************** 00799000
* 00800000
C4AA1 C 1,TXT 00801000
BC 7,C4AA3 BR- NOT TEXT CRD 00802000
STC 6,SPEC+4(,13) 00803000
LH 7,SPEC+10(,13) NUM OF BYTES 00804000
LTR 7,7 00805000
BZ RD ZERO COUNT - DON'T MOVE TEXT. 00806000
LA 8,C4AK2+2 00807000
REPENT TM SWS,ABS TEST ABSOLUTE LOAD FLAG. 00808000
BC 8,C4AC1 BR, RELOCATABLE LOAD 00809000
APR1 SR 10,10 00810000
BC 15,C4AC2 00811000
C4AC1 LH 3,SPEC+14(,13) LOD ESID TO FIND ADDR 00812000
BAL 14,REFADR 00813000
L 10,12(,12) LOAD RELFAC 00814000
C4AC2 A 10,SPEC+4(,13) ADD ADDR TO RELFAC 00815000
ST 10,SPEC+4(,13) 00816000
LR 1,10 00817000
AR 1,7 00818000
LA 5,ERRORO 00819000
C 10,LEND TEST ADDR ABOVE LDR 00820000
BC 10,C4AG2 BR- YES 00821000
C 1,BELOW TEST ADDR BELOW LDR 00822000
BC 2,UNDERLDR 00823000
C 1,ABOVE 00824000
BC 4,PROTREG ADDRESS BELOW INTERRUPT REGION - AN ERRO 00825000
C4AG2 TM SWS,ABS TEST ABSOLUTE LOAD FLAG. 00826000
C4AJ2 TM SWS,FTTR1 .. 00827000
BC 14,C4AK2 BR-OFF 00828000
LA 0,128 IS ADDR BELOW FIRST 128 BYTES 00829000
CR 1,0 00830000
BC 5,C4AK2 BR, DO NOT SAVE ADDR 00831000
NI SWS,255-FTTR1 .. 00832000
ST 10,BRAD(,13) SAVE FIRST ADDR LOADED INTO 00833000
C4AK2 BCR 15,8 00834000
SR 7,11 SUB ONE FROM NUM OF BYTES 00835000
EX 7,CHAR MOVE TEXT TO STORAGE 00836000
BC 15,RD AND GO READ A CARD 00837000
SPACE 1 00838000
UNDERLDR BAL R14,ERPRNT PRINT IT 00839000
BAL R14,PAGER EJECT PAGE 00840000
SVC 106 DIE... 00841000
SPACE 1 00842000
PROTREG BAL R14,ERPRNT PRINT IT 00843000
BAL R14,PAGER EJECT PAGE 00844000
SVC 107 DIE... 00845000
* 00846000
CHAR MVC 0(1,10),SPEC+16(13) 00847000
EJECT 00848000
*********************************************************************** 00849000
* 00850000
* REPLACE CARD ROUTINE (REP) 00851000
* 00852000
*********************************************************************** 00853000
* 00854000
C4AA3 C 1,REP 00855000
BC 7,C5AA1 BR- NOT REPLACE CARD 00856000
TM SWS,REPSW DO WE WANT REP CARDS PRINTED. 00857000
BC 1,C4AA4 NO 00858000
MVC CDIMJ(80),SPEC(13) 00859000
MVI CDIMJ,C' ' BLANK OUT 12-2-9 PUNCH. 00860000
LA 5,CRDIMJ GO PRINT OUT REP CARD IMAGE 00861000
BAL 14,ERPRNT 00862000
C4AA4 LA 4,6 CONVERT REP CRD HEX ADDR TO BIN 00863000
LA 5,SPEC+6(,13) 00864000
L 1,HEXBB LOAD CONVERSION ROUTINE ADDRESS 00865000
BALR 0,1 BR TO HEXB 00866000
ST 0,SPEC+4(,13) SAVE ADDR IN CARD IMAGE 00867000
LA 4,2(0,0) 00868000
LA 5,SPEC+14(,13) CONVERT REP ESID TO BIN 00869000
L 1,HEXBB LOAD CONVERSION ROUTINE ADDRESS 00870000
BALR 0,1 BR TO HEXB 00871000
STH 0,SPEC+14(,13) SAVE THE ESID IN CARD IMAGE 00872000
LA 5,SPEC+16(,13) 00873000
NUM LA 7,2 NUM OF BYTES 00874000
ST 5,TMPLOC(,13) 00875000
TM SWS,FREPSW .. 00876000
BC 1,APR10 00877000
BAL 8,REPENT 00878000
APRIL LA 4,4 CONVERT HALF WORD OF CORRECTIONS 00879000
L 5,TMPLOC(,13) 00880000
L 1,HEXBB LOAD CONVERSION ROUTINE ADDRESS 00881000
BALR 0,1 BR TO HEXB 00882000
L 8,SPEC+4(,13) LOD REPLACE ADDR 00883000
STH 0,0(0,8) PLACE CORRECTION IN STORAGE 00884000
NI SWS,255-FREPSW .. 00885000
CLI 0(5),C',' 00886000
BC 7,RD 00887000
OI SWS,FREPSW TURN ON REP FIRST SWITCH. 00888000
LA 8,2(8,0) 00889000
ST 8,SPEC+4(,13) SAVE REPLACE ADDR 00890000
AR 5,11 00891000
BC 15,NUM 00892000
APR10 LA 8,APRIL 00893000
BC 15,APR1 00894000
EJECT 00895000
*********************************************************************** 00896000
* 00897000
* RELOCATION DICTIONARY CARD (RLD) 00898000
* REG 6= 0 UPON ENTRY INTO C5AA1 00899000
* 00900000
*********************************************************************** 00901000
* 00902000
C5AA1 C 1,RLD 00903000
BC 7,C6AA1 BR-NOT RLD CARD 00904000
TM SWS,ABS TEST ABSOLUTE LOAD FLAG. 00905000
BC 1,RD ON ABS LOAD ONLY 00906000
* REL. HEADER ON CARD USED TO OBTAIN CURRENT ADDR 00907000
* OF SYMBOL. THIS ADDR IS FOUND IN REL FAC. OF REFTBL 00908000
LA 10,SPEC+16(,13) 00909000
C5AC1 LH 3,0(,10) RH ESID 00910000
LTR 3,3 ERROR IF RH ESI=0 00911000
BC 8,ERRLD 00912000
BAL 14,REFADR COMPUTE POS OF ENTRY IN TABLE (REG 12) 00913000
ST 12,TEMPST(,13) AND SAVE ADDRESS 00914000
TM 8(12),X'80' IS THE UNDEF. BIT=1 00915000
BC 8,PLOAD NO - PROGRAM PREVIOUSLY LOADED 00916000
LA 8,0 YES, USE A REL. FACTOR OF ZERO 00917000
BC 15,PLOAD1 SKIP AN INSTR TO RELOAD REL FAC IN 8 00918000
PLOAD L 8,12(,12) OBTAIN REL FACTOR OF SYMBOL 00919000
PLOAD1 LH 3,2(,10) POSITION HEADER OF CURRENT SEGMENT 00920000
LTR 3,3 00921000
BC 8,ERRLD 00922000
BAL 14,REFADR 00923000
L 0,12(,12) RELFACT OF CURRENT SYMBOL 00924000
LH 1,MVC1+2(,13) MVC (TO) WD DECREMENT 00925000
LH 2,MVC2+4(,13) MVC FROM WD TO STORAGE 00926000
BAL 14,CTR REDUCES CD BYTE COUNT BY 4, TEST FOR ZERO 00927000
* IF NON 0, RETURNS, IF =0 BRANCHES TO RD 00928000
* LENGTH OF SYMBOL IN BYTES IN REG 5 00929000
C5AA3 AR 10,5 00930000
LR 3,1 00931000
LR 4,2 00932000
TM 0(10),X'0C' TEST FOR FOUR BYTES 00933000
BC 14,C5AB3 BR-TEST FOR THREE 00934000
C5AF3 SR 5,11 00935000
AR 3,6 TO MVC 'TO' 00936000
AR 4,6 TO MVC 'FROM' 00937000
STH 3,MVC1+2(,13) 'TO' 00938000
STH 4,MVC2+4(,13) 'FROM' 00939000
L 3,0(10,0) LOAD ADDR 00940000
LA 3,0(,3) AND TAKE OUT FLAGS FROM 1ST BYTE 00941000
AR 3,0 00942000
EX 5,MVC1(,13) MVC WD(1,13),0(3) 00943000
STH 1,MVC1+2(,13) 00944000
L 4,WD(,13) THE SYMBOL VALUE W/O CONATANT 00945000
TM 0(10),X'02' TEST COMPLEMENT FLAG 00946000
BC 1,C5AE4 BR YES 00947000
AR 4,8 ADD TO CONTENTS OF CELL 00948000
COMPP ST 4,WD(,13) THE COMPLETE VALUE OF THE CONSTANT 00949000
L 12,TEMPST(,13) RESTORE REFTBL ENTRY POINT OF SUBR 00950000
TM 8(12),X'80' IS UNDEF BIT =1 00951000
BC 8,CTEX 00952000
STH 2,MVC2+4(,13) RESTORE ORIGINAL MVC2. 00953000
L 7,APPNT 00954000
BALR 14,7 UPDATE POINTERS 00955000
BC 15,CTEX1 RESUME 00956000
CTEX EX 5,MVC2(,13) MVC 0(1,3),WD(13) 00957000
STH 2,MVC2+4(,13) 00958000
CTEX1 BAL 14,CTR REDUCES BYTE COUNT OF CARD 00959000
SR 6,6 00960000
TM 0(10),X'01' TEST CONTINUATION FLAG 00961000
BC 1,C5AA3 BR, FLAG-ADR FOLLOWS 00962000
AR 10,5 00963000
BC 14,C5AC1 BR, RH FOLLOWS 00964000
CTR LA 5,4 CLOSED SBR, REDUCING BYTE COUNT BY 4 00965000
SR 4,4 CLEAR OUT WORD 00966000
ST 4,WD(,13) 00967000
LH 4,SPEC+10(,13) BYTE COUNT 00968000
SR 4,5 00969000
BC 8,RD BYTES COUNT = 0 00970000
STH 4,SPEC+10(,13) 00971000
BCR 15,14 00972000
C5AE4 SR 4,8 ADDR MINUS RELFAC 00973000
BC 15,COMPP 00974000
C5AB3 AR 6,11 00975000
SR 5,11 00976000
TM 0(10),X'08' TEST FOR THREE BYTE LOAD 00977000
BC 1,C5AF3 BR-THREE BYTE 00978000
AR 6,11 00979000
SR 5,11 00980000
TM 0(10),X'04' TEST FOR TWO BYTE LOAD 00981000
BC 1,C5AF3 BR-TWO BYTE 00982000
AR 6,11 00983000
SR 5,11 00984000
BC 15,C5AF3 00985000
ERRLD LA 5,ERRORA 00986000
MVC CDIMJ(80),SPEC(13) 00987000
LA 14,RD 00988000
BC 15,ERPRNT 00989000
EJECT 00990000
*********************************************************************** 00991000
* 00992000
* END CARD ROUTINE (END) 00993000
* 00994000
*********************************************************************** 00995000
* 00996000
C6AA1 C 1,END 00997000
BC 7,C6AC1 BR-NOT END CARD 00998000
CLC SPEC+28(4,13),BLANKS CHECK FOR CSECT LENGTH IN END. 00999000
BE C6AB5 NO - CONTINUE NORMALLY. 01000000
L 1,LOCCT(,13) YES - UPDATE THE LOCATION COUNTER. 01001000
A 1,SPEC+28(,13) .. 01002000
AH 1,HW7 FORCE ALIGNMENT ON DOUBLE WORD. 01003000
SRL 1,3 .. 01004000
SLL 1,3 .. 01005000
ST 1,LOCCT(,13) .. 01006000
C6AB5 SR 2,2 .. 01007000
CLI SPEC+5(13),C' ' 01008000
BC 8,C6AB3 BR IF NO ADDR 01009000
STC 6,SPEC+4(,13) 01010000
TM SWS,ENDB END BIT ON --- 01011000
BC 8,C6AB3 BR NO, ADDR SAVED 01012000
NI SWS,255-(FTTR1+ENDB) .. 01013000
TM SWS,ABS TEST ABSOLUTE LOAD FLAG. 01014000
BC 1,C6AB4 BR, ABS-LOAD FLAG ON 01015000
LH 3,SPEC+14(,13) LOD ESID 01016000
BAL 14,REFADR 01017000
L 2,12(,12) RELOCATION FACTOR 01018000
C6AB4 A 2,SPEC+4(,13) FORM ADDR 01019000
ST 2,BRAD(,13) 01020000
C6AB3 DS 0H 01021000
LA 2,ESIDTB(,13) CLEAR ESIDTB TABLE 01022000
LA 3,NOESD*2/256 GET NUMBER OF XC'S NEEDED 01023000
XC 0(256,2),0(2) CLEAR 01024000
LA 2,256(,2) BUMP PTR 01025000
BCT 3,*-10 01026000
OI SWS,ABS ABSOLUTE FLAG ON. 01027000
USING XTRBLOK,R3 ADDRESSABILITY 01028000
L R1,PNTXTR GET EXTRN BUFFER @VA04840 01029100
L R3,PNTXTR0 GET ESD TYPE 0 HEADER @VA04840 01029200
ST R1,0(,R3) PATCH TO EXISTING CHAIN @VA04840 01029300
XC PNTXTR,PNTXTR ZIP EXTRN BUFFER PNTR @VA04840 01029400
NXTLINE LA R5,XTRLINE POINT TO CONTROL LIST FOR PRINTER 01030000
BAL R14,ERPRNT GO PRINT THIS LINE 01031000
LR R1,R3 ADDRESS INTO R1 FOR FRET 01032000
LA R0,XTRSIZE AND SIZE OF BLOK 01033000
L R3,XTRPNT GET POINTER TO NEXT BUFFER (IF ANY) 01034000
L R15,AFRETX ADDRESS OF FRET ROUTINE 01035000
BALR R14,R15 NOW FRET IT. 01036000
L R15,BREG1 RESTORE REG-15 01037000
LTR R3,R3 ANY MORE BUFFERS IN THE CHAIN 01038000
BNZ NXTLINE YES - GO PROCESS THEM 01039000
XC PNTXTR0,PNTXTR0 ZIP ESD TYPE 0 BUFFER PNTR @VA04840 01040500
LA R5,SPACE1 SPACE PRINTER ONE LINE 01041000
BAL R14,ERPRNT ... 01042000
LA R5,SPACE1 SPACE PRINTER 1 ADDITIONAL LINE 01043000
BAL R14,ERPRNT ... 01044000
DROP R3 01045000
BC 15,RD TO RD 01046000
EJECT 01047000
*********************************************************************** 01048000
* 01049000
* LOAD TERMINATE CARD ROUTINE (LDT) 01050000
* 01051000
*********************************************************************** 01052000
* 01053000
C6AC1 C 1,LDT 01054000
BC 7,CTLCRD NOT LDT - IS IT CTL CARD 01055000
C6AC2 CLI SPEC+16(13),C' ' IS THERE A NAME 01056000
BC 7,C6AD3 YES 01057000
C6AC3 C 6,BRAD(,13) NO - IS THERE AN ADDRESS 01058000
BC 8,C6AD4 BR-NO ADDR DEVELOPED 01059000
L 0,BRAD(,13) LOD SAVED BR ADDR 01060000
EXEC DS 0H 01061000
LA 2,ESIDTB(,13) CLEAR ESIDTB TABLE 01062000
LA 3,NOESD*2/256 GET NUMBER OF XC'S NEEDED 01063000
XC 0(256,2),0(2) CLEAR 01064000
LA 2,256(,2) BUMP PTR 01065000
BCT 3,*-10 01066000
OI SWS,ABS SET ABSOLUTE LOAD FLAG. 01067000
ST 0,PSW+4 01068000
TM SWS+1,SKPFLG 01069000
BC 1,SKPERR 01070000
L 12,TBLREF(,13) 01071000
LH 4,TBLCT(,13) 01072000
LA 3,16 01073000
SUB1 SR 12,3 POINT TI FIRST ENTRY IN REFTBL 01074000
TM 8(12),X'80' IS UNDEFINED BIT ON 01075000
BC 8,NO1 NO - PICK UP NEXT ENTRY 01076000
MVC ERRU(8),0(12) 01077000
LA 5,ERRORU YES - GO PRINT UNDEFINED NAME 01078000
BAL 14,ERPRNT 01079000
SR 1,1 01080000
L 7,AADDEF DEFINE UNDEFINED SYMBOL AT ZERO 01081000
BALR 14,7 01082000
NO1 BCT 4,SUB1 01083000
BAL 14,PAGER 01084000
LH 3,TBLCT(,13) GET COUNT OF ENTRIES IN REFTBL 01085000
LR 2,3 AND PLACE IN REGISTER TWO 01086000
SLL 3,4 GET THE NUMBER OF BYTES IN REFTBL AND 01087000
L 1,TBLREF(,13) SUBTRACT QUANTITY FROM LARGEST ADDRESS O 01088000
SR 1,3 TABLE+1 TO GET START OF REFTBL IN REG. 1 01089000
LPSW PSW MUST BE CHANGED LATER 01090000
* 01091000
C6AC4 LA 3,1 01092000
BAL 14,REFADR 01093000
CA6D4 L 0,8(,12) 01094000
BC 15,EXEC 01095000
C6AD3 LA 2,ERLDT 01096000
BAL 3,SERCH GO FIND THE NAME 01097000
BC 15,CA6D4 NAME FOUND 01098000
C6AD4 L 12,TBLREF(,13) 01099000
LA 6,16 01100000
SR 12,6 01101000
BC 15,CA6D4 01102000
* 01103000
ERLDT MVC ERRU(6),SPEC+16(13) 01104000
MVC ERRU+6(2),BLANKS 01105000
LA 5,ERRORU 01106000
BAL R14,ERPRNT PRINT ERROR 01107000
BAL R14,PAGER EJECT PAGE 01108000
SVC 103 DIE..... 01109000
SPACE 01110000
SKPERR LA 5,SKIPM CONTROL SECTION NOT FOUND BY EOF 01111000
BAL R14,ERPRNT PRINT ERROR 01112000
BAL R14,PAGER EJECT PAGE 01113000
SVC 104 DIE... 01114000
EJECT 01115000
*********************************************************************** 01116000
* 01117000
* CONTROL CARD ROUTINE (CTL) 01118000
* 01119000
* 01120000
* THIS ROUTINE PROVIDES FOR THE OPTIONAL PRINTING OF 01121000
* INVALID CARDS, REPLACE CARDS, AND LOAD LISTING. 01122000
* 01123000
*********************************************************************** 01124000
* 01125000
CTLCRD C 1,CTL 01126000
BC 8,SETSWS THIS IS A CONTROL CARD 01127000
TM SWS,INVSW ILLEGAL CARD - DO WE PRINT IT. 01128000
BC 8,BADCRD YES 01129000
BC 15,RD NO - IGNORE AND GET ANOTHER CARD 01130000
SPACE 3 01131000
SETSWS MVC CDIMJ(80),SPEC+1(13) 01132000
LA 5,CRDIMJ 01133000
BAL 14,ERPRNT PRINT CTL CARD IMAGE 01134000
LA 5,SPEC+4(,13) SET UP TO SCAN REAST OF CONTROL 01135000
LA 6,1 CARD FOR FIELDS 01136000
LA 7,SPEC+79(,13) 01137000
LOOKBL CLI 0(5),C' ' IS THIS A BLANK 01138000
BC 8,BUMP YES - BUMP COUNTER 01139000
TM SWS+1,RDRSWT+WTRSWT 01140000
BC 7,UNITB 01141000
CLC 0(4,5),REPS NO - IS IT SREP 01142000
BC 7,REPPT NO 01143000
OI SWS,REPSW YES. 01144000
BC 15,MOVEUP POINT TO NEXT FIELD 01145000
REPPT CLC 0(4,5),REPP IS IT PREP 01146000
BC 7,INVSP NO 01147000
NI SWS,255-REPSW .. 01148000
BC 15,MOVEUP POINT TO NEXT FIELD 01149000
INVSP CLC 0(4,5),INVS IS IT SINV 01150000
BC 7,INVPT NO 01151000
OI SWS,INVSW YES. 01152000
BC 15,MOVEUP POINT TO NEXT FIELD 01153000
INVPT CLC 0(4,5),INVP IS IT VINP 01154000
BC 7,UNIT 01155000
NI SWS,255-INVSW .. 01156000
MOVEUP A 5,THREE NO - LOOK FOR ANOTHER FIELD 01157000
BUMP BXLE 5,6,LOOKBL 01158000
BC 15,RD ALL DONE - GET NEXT CARD 01159000
EJECT 01160000
BADCRD DS 0H 01161000
CLI SPEC(13),2 LOADER CARD? 01162000
BE BDCRDB YES 01163000
CLI SPEC(13),C'A' COMMENT CARD? 01164000
BNL BDCRDA YES 01165000
CLI SPEC(13),C'*' COMMENT CARD? 01166000
BE BDCRDA YES 01167000
CLC SPEC(5,13),CMSREAD CMS 'READ' CARD 01168000
BE CMSCARD YES 01169000
CLI SPEC(13),C' ' COMMENT CARD? 01170000
BNE BDCRDB NOP 01171000
B BDCRDA YES 01172000
CMSCARD EQU * HERE FOR SPECIAL CMS 'READ' CARD 01173000
CLI CPEND,X'FF' IS THIS FIRST 'READ' CARD AFTER DMKCPE ? 01174000
BNE NOTCPE NO - 01175000
BAL R14,SET YES - SKIP TO CHANNEL 1 01176000
MVC CDCOM+80(25),ORAREA CLEAR PRINT AREA 01177000
MVC CDCOM(80),ASTRIS PUT IN EYE CHATCHER 01178000
LA R5,PRCOM ADDRESS OF CHANNEL PROGRAM 01179000
BAL R14,ERPRNT PRINT IT... 01180000
MVC CDCOM(80),CPEHDR PUT IN HEADING LINE. 01181000
LA R5,PRCOM ADDRESS OF CHANNEL PROGRAM 01182000
BAL R14,ERPRNT PRINT IT. 01183000
MVC CDCOM(80),ASTRIS PUT IT EYE CHATCHER. 01184000
LA R5,PRCOM ADDRESS OF CHANNEL PROGRAM 01185000
BAL R14,ERPRNT PRINT IT 01186000
MVI CPEND,X'00' CLEAR DMKCPE SWITCH 01187000
LA R5,SPACE1 ADDRESS OF CCW TO SPACE PRINTER 01188000
BAL R14,ERPRNT DO IT. 01189000
LA R5,SPACE1 CAUSE A DOUBLE SPACE 01190000
BAL R14,ERPRNT ... 01191000
NOTCPE MVC CDCOM(80),SPEC(R13) MOVE IN CARD IMAGE 01192000
MVC CDCOM+80(25),ORAREA BLANK REMAINDER 01193000
MVI CDCOM,C'*' REPLACE COLON WITH AN ASTERISK @VA11453 01193100
LA R5,PRCOM PRINT CMS CARD 01194000
B BDCRDC REJOIN 01195000
BDCRDA DS 0H 01196000
MVC CDCOM(25),ORAREA 01197000
MVC CDCOM+25(80),SPEC(13) MOVE CARD IMAGE 01198000
LA 5,PRCOM PRINT COMMENT 01199000
B BDCRDC REJOIN 01200000
BDCRDB DS 0H 01201000
LA 5,ERRORA 01202000
MVC CDIMJ(80),SPEC(13) 01203000
MVC CDCOM+80(25),ORAREA 01204000
BDCRDC DS 0H 01205000
LA 14,RD 01206000
BC 15,ERPRNT 01207000
UNIT CLC 0(3,5),RDRCTL RDR CTL CARD 01208000
BC 7,UNITA NO 01209000
OI SWS+1,RDRSWT YES - CONTINUE SCAN 01210000
BC 15,MOVEUP 01211000
SPACE 01212000
UNITA CLC 0(3,5),WTRCTL 01213000
BC 7,SKIPX 01214000
OI SWS+1,WTRSWT 01215000
BC 15,MOVEUP 01216000
SPACE 01217000
UNITB LA 4,3 01218000
L 1,HEXBB CONVERT UNIT ADDRESS AND STORE IN PACE 01219000
BALR 0,1 01220000
TM SWS+1,RDRSWT 01221000
BC 1,UNITC 01222000
STH 0,PRNTR 01223000
LR 1,5 IF PRINTER IS SWITCHED, LET BOTH KNOW 01224000
LA 5,CRDIMJ 01225000
BAL 14,ERPRNT 01226000
LR 5,1 01227000
NI SWS+1,255-WTRSWT 01228000
BC 15,MOVEUP 01229000
SPACE 01230000
UNITC STH 0,READER 01231000
NI SWS+1,255-RDRSWT 01232000
BC 15,MOVEUP 01233000
SPACE 01234000
SKIPX CLC 0(4,5),SKIPWD SPECIAL CONTROL CARD ? 01235000
BC 7,BUMP 01236000
OI SWS+1,SKPFLG 01237000
MVC RDR(2),READER SAVE CURRENT READER 01238000
MVC SKPMSG(8),5(5) SAVE CSECT NAME TO BE SKIPPED 01239000
BC 15,RD 01240000
* SKIP CSECTNAME CAUSES LOADING TO CONTINUE NORMALLY UNTIL 01241000
* 'CSECTNAME' OCCURS ON AN ESD 0 CARD. AT THAT TIME, ALL INPUT 01242000
* CARDS ARE SKIPPED UNTIL AND 'END' CARD APPEARS AAT WHICH 01243000
* TIME 'READER' IS SET BACK TO 'RDR', AND LAODING CONTINUES 01244000
* NORMALLY. USEFULE FOR SLEECTIVE REPLACEMENT OF DECKS. 01245000
EJECT 01246000
*********************************************************************** 01247000
* 01248000
* ROUTINE TO LOCATE REFTBL ENTRIES 01249000
* THRU ESID 01250000
* 01251000
* LH 3, WITH ESID, RH, OR PH 01252000
* VALUE BEFORE ENTERING ROUTINE 01253000
* THIS ROUTINE COMPUTES THE STORAGE ADDRESS OF A GIVEN ENTRY IN REF 01254000
* 01255000
*********************************************************************** 01256000
* 01257000
REFADR L 12,TBLREF(,13) 01258000
SLL 3,1 TIMES 2 FOR HALFWORD ENTRY 01259000
LH 3,ESIDTB(13,3) OBTAINS FROM ESIDTB TABLE ENTRY 01260000
SLL 3,4 MULTIPLY BY 16 01261000
SR 12,3 SIZE-(ESID X 16) 01262000
BCR 15,14 01263000
SPACE 3 01264000
*********************************************************************** 01265000
* 01266000
* ROUTINE TO SEARCH REFERENCE TABLE 01267000
* FOR A GIVEN NAME 01268000
* 01269000
*********************************************************************** 01270000
* 01271000
* CALLING SEQUENCE-- 01272000
* L(LA) 2,NOT FOUND RETURN 01273000
* BAL 3,ENTRY FOUND RETURN 01274000
* REG 12 = ADDR OF ENTRY IN REFTBL.REG 11=1,REG 1= NAME OF PROG 01275000
* THIS ROUTINE COMPARES EACH REFERENCE TABLE ENTRY 01276000
* WITH THE GIVEN NAME,DETERMINING FIRST WHETHER THERE 01277000
* IS AN ENTRY FOR THAT NAME AND 2ND WHAT THE 01278000
* STORAGE ADDRESS OF THAT ENTRY IS. 01279000
* 01280000
*********************************************************************** 01281000
* 01282000
SERCH LH 0,TBLCT(,13) NO. OF ENTRIES IN REFTBL 01283000
LA 1,SPEC+16(,13) ADDR OF NAME IN CRD 01284000
SR 4,4 01285000
LA 5,16 LOAD ENTRY SIZE 01286000
L 12,TBLREF(,13) LARGEST ADDR IN STORAGE+1 01287000
LTR 0,0 01288000
BC 8,NOT 01289000
CLC 0(8,1),BLANKS IS IT A BLANK NAME 01290000
BC 7,CMP NO 01291000
LR 4,0 UPDATE REG 4 WITH TBLCT 01292000
SLL 0,4 SET REGISTER 12 TO POINT TO 01293000
SR 12,0 NEXT ENTRY IN REFTBL 01294000
BC 15,NOT RETURN 01295000
CMP SR 12,5 01296000
AR 4,11 TO ACCUM ENTRY POSITION 01297000
CLC 0(8,1),0(12) COMPARE NAME IN CARD TO NAME IN REFTBL 01298000
BCR 8,3 BR- NAME FOUND 01299000
BCT 0,CMP 01300000
NOT SR 12,5 01301000
AR 4,11 ADD TO TOTAL ENTRIES 01302000
L 0,AMAXREF MAX NO. OF UNRESOLVED REF, 01303000
CR 4,0 01304000
BC 10,ERREF REFERENCE TABLE OVERFLOW 01305000
STH 4,TBLCT(,13) NO. FO ENTRIES IN TBLREF 01306000
MVC 0(8,12),0(1) PLACE NAME IN TABLE 01307000
XC 8(8,12),8(12) CLEAR OTHER HALF ON ENTRY. 01308000
BCR 15,2 01309000
ERREF LA 5,ERRORR GO TO ERPRNT WITH COMMENT OF REFERENCE 01310000
BAL R14,ERPRNT PRINT TABLE OVERFLOW 01311000
BAL R14,PAGER EJECT PAGE 01312000
SVC 105 DIE... 01313000
EJECT 01314000
*********************************************************************** 01315000
* 01316000
* ERROR MESSAGES ROUTINE 01317000
* 01318000
*********************************************************************** 01319000
* 01320000
RDCONSL L 0,RDCLCCW 01321000
N 0,R3BIT 01322000
O 0,0(,5) 01323000
ST 0,RDCLCCW 01324000
LH 0,4(,5) 01325000
LTR 0,0 01326000
BCR 8,14 01327000
STH 0,RDCLCCW+6 01328000
LA 8,10 LOAD RETRY COUNTER 01329000
LH 2,PRNTR 01330000
ERPR2 SSM CH0OFF 01331000
MVC ZCAW(4),RDCCA 01332000
LA 0,ERPR2 01333000
ST 0,PRTWAT+8 01334000
B STARTIO 01335000
ERPRNT CLI CPUID,X'FF' RUNNING UNDER CP? HRC031DK 01336000
BNER R14 NO, MUST BE BARE MACHINE HRC031DK 01336333
LH R0,4(,R5) GET LENGTH HRC031DK 01336666
LTR R0,R0 IS ANY THERE ? 01337000
BCR 8,R14 NO - RETURN 01338000
MVI PRTLINE,C' ' BLANKS 01339000
MVC PRTLINE+1(129),PRTLINE FOR STARTER 01340000
L R2,0(,R5) ADDRESS OF DATA 01341000
LH R8,4(,R5) AND ITS LENGTH 01342000
BCTR R8,R0 MINUS 1 BYTE FOR EXCUTE INST. 01343000
EX R8,PRTMOVE MOVE TO OUTPUT AREA 01344000
LA R0,ERRCCW ADDRESS OF CCW 01345000
ST R0,ZCAW STORE IN CAW 01346000
LA R8,10 RETRY ERROR COUNTER 01347000
LH R2,PRNTR ADDRESS OF I/O DEVICE 01348000
ERPR1 SSM CH0OFF MASK OFF CHANNEL 01349000
LA R0,ERPR1 01350000
ST R0,PRTWAT+8 01351000
STARTIO SIO 0(2) AND START I/O 01352000
SPACE 01353000
BC 8,PRTDRN SIO OK, .. GO WAIT FOR CE 01354000
BC 2,PRTWAT UNIT BUSY - WAIT. 01355000
BCR 1,14 UNIT UNAVAILABLE - FORGET IT AND PAY 01356000
CH 2,CNSL 01357000
BE CKERR 01358000
TM IGNSW,X'01' 01359000
BZ CKERR 01360000
BC 15,14 01361000
CKERR BCT 8,CONT RETRY 10 TIMES? 01362000
MVC 0(15,0),MSG5 01363000
B WAITLCMG 01364000
PRTMOVE MVC PRTLINE(*-*),0(R2) SET UP PRINT LINE 01365000
CONT TM ZCSW+4,X'02' TEST FOR UNIT CHECK 01366000
BC 1,ERPR1 YES - CONTINUE TO TRY. 01367000
TM ZCSW+4,X'14' TEST FOR BUSY AND DEVICE END 01368000
BC 1,ERPR1 BOTH - TRY AGAIN. 01369000
TM ZCSW+4,X'10' TEST FOR BUSY. 01370000
BC 1,PRTWAT YES - WAIT FOR INTERRUPT. 01371000
BC 15,ERPR1 OTHERWISE - TRY AGAIN. 01372000
* 01373000
PRTDRN TIO 0(2) TIO 'TIL CE 01374000
BC 2,*-4 01375000
L R0,LINECNT GET CURRENT NUMBER LINES ON THIS PAGE 01376000
AL R0,CONST1 BUMP IT BY 1. 01377000
ST R0,LINECNT SAVE IT. 01378000
CH R0,LINEMAX 60 LINES ON THIS PAGE YET? 01379000
BCR 4,R14 NO - RETURN TO CALLER 01380000
B SET YES - SKIP TO PAGE 1. 01381000
* 01382000
CNOP 4,8 01383000
* 01384000
PRTWAT LPSW *+4 01385000
DC X'FE020000' 01386000
PRTWATAD DC AL4(ERPR1) 01387000
* 01388000
DMPTBL DC C'0123456789ABCDEF' DUMP CONVERTER 01389000
* 01390000
PAGER CLI CPUID,X'FF' UNDER CONTROL OF CP? HRC031DK 01391000
BNER R14 NO, NO MAP ON BARE MACHINE HRC031DK 01391333
LA 8,5 SET UP RETRY COUNTER HRC031DK 01391666
LH 2,PRNTR GET PRINTER ADDRESS. 01392000
TESTIO TIO 0(2) CLEAR CHANNEL 01393000
BC 2,*-4 TRY AGAIN 01394000
BC 8,SET 01395000
TM ZCSW+4,X'10' BUSY ? 01396000
BO TESTIO YES 01397000
TM IGNSW,X'01' 01398000
BO RTURN 01399000
BCT 8,TESTIO 01400000
ST 14,LINKSAV 01401000
INT LA 5,INTPRT 01402000
MVC PRNTR(2),CNSL 01403000
INTVENP BAL 14,ERPRNT 01404000
CNOP 4,8 01405000
WAITPRNT LPSW *+4 01406000
DC X'FE020000' 01407000
WAITPRAD DC A(*+4) 01408000
CLC READER,58 01409000
BE WAITPRNT 01410000
CLC CNSL,58 01411000
BE IGNOR 01412000
MVC PRNTR,58 01413000
MVC PRNTSET,58 01414000
L 14,LINKSAV 01415000
B PAGER 01416000
LINKSAV DS 1F 01417000
SPACE , HRC031DK 01418000
SET CLI CPUID,X'FF' RUNNING UNDER VM? HRC031DK 01418250
BNER R14 NO, FORGET SKIPS TO CH 1 HRC031DK 01418500
SSM CH0OFF HRC031DK 01418750
LH R2,PRNTR GET PRINTER ADDRESS 01419000
TIO 0(R2) DRAIN OUTSTANDING INTERRUPTS 01420000
BC 4+2,*-4 ... 01421000
SLR R0,R0 CLEAR 01422000
ST R0,LINECNT CURRENT LINE NUMBER COUNTER 01423000
LA R0,PGRSTR ADDRESS OF SKIP CCW. 01424000
ST R0,ZCAW STORE IT IN CAW 01425000
SIO 0(R2) NOW SKIP TO 1 01426000
SSM CH0ON ENABLE FOR INTERRUPTS 01427000
RTURN BR R14 RETURN TO CALLER 01428000
IGNOR TM 68,X'80' 01429000
BZ WAITPRNT 01430000
LA 5,IGNMSG 01431000
BAL 14,RDCONSL 01432000
MVC PRNTR(2),PRNTSET 01433000
OC MSG4,ORAREA 01434000
CLC MSG4,IGN 01435000
BNE INT 01436000
MVI IGNSW,X'01' 01437000
L 14,LINKSAV 01438000
B RTURN 01439000
ORAREA DC CL25' ' 01440000
IGNMSG DC A(MSG4) 01441000
DC H'0006' 01442000
IGN DC C'IGNORE' 01443000
IGNSW DC X'00' 01444000
MSG5 DC C'UNRECOVERABLE ERROR' 01445000
EJECT 01446000
********************************************************************* 01447000
* 01448000
* PRINTED MESSAGES 01449000
* 01450000
********************************************************************* 01451000
* 01452000
RMES1 DC C'INTERVENTION ' 01453000
DC C'REQUIRED - ' 01454000
RMES2 DC C'UNIT CHECK. RETURN LAST CARD TO HOPPER' 01455000
RMES3 EQU * 01456000
ERRU DS 8C 01457000
DC C' IS UNDEFINED' 01458000
ERRA DC C'INVALID CARD...' 01459000
CDIMJ DS 80C 01460000
ERRD DS 8C 01461000
DC C' IS DEFINED MORE' 01462000
DC C' THAN ONCE' 01463000
ERRO DC C'OVERLAY ERROR' 01464000
ERRP DC C' ' 01465000
ERRF DC C' ' 01466000
RLDREFXT DC CL7' ' 01467000
LOC1 DS CL8 01468000
DC C' AT ' 01469000
DC CL35' ' 01470000
ERRR DC C'REFERENCE TABLE ' 01471000
DC C'OVERFLOW.' 01472000
ERRM DC C'DUPLICATE ' 01473000
DC C'IDENTIFIER - ' 01474000
NAME DS CL8 01475000
ENDERR EQU * 01476000
SKPMSG DS 8C 01477000
DC C' NOT FOUND BY EOF TIME' 01478000
SKPMSG1 EQU * 01479000
* 01480000
CDCOM DC CL105' ' 01481000
PRCOM DC A(CDCOM) 01482000
DC H'105' 01483000
RETYRD DC A(RMES1) 01484000
DC AL2(RMES2-RMES1) 01485000
VALCHK DC A(RMES2) 01486000
DC AL2(RMES3-RMES2) 01487000
ERRORU DC A(ERRU) 01488000
DC AL2(ERRA-ERRU) 01489000
ERRORA DC A(ERRA) 01490000
DC AL2(ERRD-ERRA) 01491000
ERRORD DC A(ERRD) 01492000
DC AL2(ERRO-ERRD) 01493000
ERRORO DC A(ERRO) 01494000
DC AL2(ERRP-ERRO) 01495000
ERRORL DC A(RLDREFXT) 01496000
DC AL2(ERRR-RLDREFXT-2) 01497000
ERRORR DC A(ERRR) 01498000
DC AL2(ERRM-ERRR) 01499000
ERRORM DC A(ERRM) 01500000
DC AL2(ENDERR-ERRM) 01501000
CRDIMJ DC A(CDIMJ) 01502000
DC AL2(ERRD-CDIMJ) 01503000
SKIPM DC A(SKPMSG) 01504000
DC AL2(SKPMSG1-SKPMSG) 01505000
SPACE1 DC A(ORAREA) 01506000
DC AL2(1) 01507000
INTPRT DC A(MSG1) 01508000
DC X'0020' 01509000
MSG1 DC C'INTERVENTION REQUIRED - PRINTER ' 01510000
MSG4 DC 3H'0' 01511000
HEADING DC C'** EXTERNAL SYMBOL DICTIONARY FOR ' 01512000
DS 0F 01513000
PNTXTR0 DC F'0' PNTR TO ESD TYPE 0 ESID HEADER @VA04840 01513500
PNTXTR DC F'0' POINTER TO LIST OF EXTRNS TO PRINT. 01514000
LINECNT DC F'0' CURRENT LINES PRINTED ON PAGE. 01515000
LINEMAX DC H'60' MAX. NUMBER LINES ALLOWED ON PAGE 01516000
CONST1 DC F'1' CONSTANT 01517000
SPACE 1 01518000
DMKPSA DC CL6'DMKPSA' MODULE USED BY VM/370 01519000
DMKCPE DC CL6'DMKCPE' MODULE INDICATING END OF NUCLEUS 01520000
DMKWRM DC CL6'DMKWRM' DON'T FORCE ON PAGE BOUNDARY 01521000
SPBHDR DC CL15' (SPB INSERTED)' MESSAGE INDICATOR 01522000
ASTRIS DC CL80'*** X01523000
***' 01524000
CPEHDR DC CL80' END OF VM/370 RESIDENT NUCLEUS' 01525000
ESDHDR DC CL21'MODULE SIZE IS XXXXXX' 01526000
VM370 DC X'00' FF IF DMKPSA FOUND 01527000
ENDNUC DC X'00' FF IF DMKCPE FOUND 01528000
CPEND DC X'00' SWITCH FOR FIRST READ CARD AFTER DMKCPE 01529000
EJECT 01530000
*********************************************************************** 01531000
* 01532000
* CONSTANTS AREA 01533000
* 01534000
*********************************************************************** 01535000
* 01536000
BELOW DC A(ALPHA) 01537000
* 01538000
SLC DC X'02' *** 01539000
DC C'SLC' 01540000
SPB DC X'02' *** 01541000
DC C'SPB' 01542000
ICS DC X'02' *** 01543000
DC C'ICS' 01544000
ESD DC X'02' *** 01545000
DC C'ESD' 01546000
TXT DC X'02' *** 01547000
DC C'TXT' 01548000
REP DC X'02' *** 01549000
DC C'REP' 01550000
RLD DC X'02' *** 01551000
DC C'RLD' 01552000
END DC X'02' *** 01553000
DC C'END' 01554000
LDT DC X'02' *** 01555000
DC C'LDT' 01556000
CTL DC X'02' 01557000
DC C'CTL' 01558000
* 01559000
BLANKS DC CL8' ' 01560000
SKIPWD DC C'SKIP' 01561000
RDRCTL DC C'RDR' READER CONTROL CARD 01562000
WTRCTL DC C'WTR' PRINTER CONTROL CARD 01563000
CMSREAD DC C':READ' SPECIAL CMS CARD ? 01564000
HW7 DC H'7' CONSTANT 01565000
* 01566000
* THE FOLLOWING INSTRUCTION 01567000
* SHOULD BE ADJUSTED TO READ-- 01568000
*CTRSET DC A(CTRR) 01569000
* FOR LOW ASSEMBLIES, AND 01570000
*CTRSET DC A(256) 01571000
* FOR HIGH ASSEMBLIES. 01572000
* INITIAL VALUE FOR LOCCT(13) 01573000
* 01574000
CTRSET DC A(0) INITIAL LOCATION COUNTER SETTING 01575000
* 01576000
ABOVE DC A(256) 01577000
* 01578000
LEND DC A(OMEGA) 01579000
AADDEF DC A(ADDEF) 01580000
AFRINI DC A(FRINIT) 01581000
AFREE DC A(FREE) 01582000
AFRETX DC A(FRET) ADDRESS OF FRET. 01583000
APPNT DC A(APOINT) 01584000
HEXBB DC A(HEXB) 01585000
TOP DC A(MON) 01586000
AMAXREF DC A(MAXREF) MAXIMUM NUMBER OF ESD ENTRIES 01587000
ANOESD DS A(NOESD) MAXIMUN NUMBER OF EXTERNS IN 1 MODULE 01588000
* 01589000
THREE DC F'3' 01590000
* 01591000
REPS DC C'SREP' 01592000
REPP DC C'PREP' 01593000
INVS DC C'SINV' 01594000
INVP DC C'PINV' 01595000
* 01596000
DS 0D 01597000
* 01598000
PSW DC XL16'00' 01599000
* 01600000
CTLIST EQU * 01601000
DC 2D'0' ADDRESS POINTER 01602000
DC F'3' COMMON NUMBER OF DW'S USED ALOT 01603000
DC F'0' USAGE COUNTER CONTAINING CALL TO FREE 01604000
DC D'0' ALIGNMENT FOR DW BOUNDARY 01605000
DC 4D'0' NEXT ENTRY IN THE CONTROL LIST 01606000
* 01607000
ONEBIT DC X'80000000' 01608000
R3BIT DC X'FF000000' 01609000
PAGENO DC X'00FFF000' 01610000
* 01611000
BYTE1 EQU R3BIT 01612000
* 01613000
CTRR DS 0D 01614000
* 01615000
* 01616000
EJECT 01617000
* 01618000
********************************************************************* 01619000
* 01620000
* CHANNEL AREA 01621000
* 01622000
********************************************************************* 01623000
* 01624000
ZEXOP EQU 24 01625000
ZPROP EQU 40 01626000
ZMCOP EQU 48 01627000
ZIOOP EQU 56 01628000
ZCSW EQU 64 CHANNEL STATUS WORD. 01629000
ZCAW EQU 72 CHANNEL ADDRESS WORD 01630000
ZEXNP EQU 88 EXTERNAL INTERRUPT NEW PSW. 01631000
ZSUPNP EQU 96 01632000
ZPRNP EQU 104 01633000
ZMCNP EQU 112 01634000
ZIONP EQU 120 INPUT-OUTPUT NEW PSW 01635000
* 01636000
SPACE 3 01637000
*********************************************************************** 01638000
* 01639000
* I-O INTERRUPT HANDLER 01640000
* 01641000
*********************************************************************** 01642000
* 01643000
IOINT NI ZIOOP+1,X'FD' 01644000
MVI ZIOOP,X'00' DONT ALLOW ANY INTERRUPTS 01645000
LPSW ZIOOP REMOVE USER FROM WAIT 01646000
SPACE 01647000
*********************************************************************** 01648000
* 01649000
* EXTERNAL INTERRUPT HANDLER 01650000
* 01651000
*********************************************************************** 01652000
* 01653000
EXTINT NI ZEXOP+1,X'FD' REMOVE USER FROM WAIT 01654000
LPSW ZEXOP 01655000
SPACE 3 01656000
DROP 15 01657000
DS 0D 01658000
IONP DC F'0' 01659000
IONPAD DC A(IOINT) 01660000
EXNP DC X'01040000' 01661000
EXNPAD DC A(EXTINT) 01662000
SUPNP DC X'00060000' 01663000
DC 4X'99' 01664000
MCNP DC X'00020000' 01665000
DC 4X'BB' 01666000
PRNP DC X'00060000' WAIT WITH CODE 111111 ON PROGRAM CK. 01667000
DC 4X'11' .. 01668000
* DC A(PROGI) TO PROGRAM INTERRUPT ROUTINE LATER. 01669000
* 01670000
ERRSAV DC 8F'00' 01671000
ERETRYSW DC X'00' 01672000
CNSL DC H'09' ADDR OF CONSOLE 01673000
PRNTSET DC H'14' 01674000
PRNTR DC H'14' 01675000
READER DS H 01676000
RDR DS H 01677000
READ EQU 2 READNAD SLCT 1 01678000
WRITE EQU 9 01679000
SKIP1 EQU X'8B' 01680000
SLI EQU X'20' 01681000
* 01682000
READCL EQU X'0A' 01683000
* 01684000
INITCCW DC A(INITCCWA) INITIALIZE PRINTER CCW @V60B9BA 01684100
INITCCWA CCW X'37',0,SLI,1 ... @V60B9BA 01684200
RDCCW DC A(RDCCWA) 01685000
RDCCWA CCW READ,*-*,0,80 01686000
ERRCCA DC A(ERRCCW) 01687000
ERRCCW CCW WRITE,PRTLINE,SLI,130 @V60A6B6 01688000
PGRSTR CCW SKIP1,*-*,SLI,1 01689000
RDCLCCW CCW READCL,*-*,0,0 01690000
RDCCA DC A(RDCLCCW) 01691000
CH0OFF DC X'00' 01692000
CH0ON DC X'FE' 01693000
PRTLINE DC CL130' ' 01694000
* 01695000
* THE FOLLOWING BITS ARE DESIGNATED IN SWS --- 01696000
* 01697000
SWS DS 2C .. 01698000
* 01699000
ABS EQU X'80' ABSOLUTE LOAD FLAG. 01700000
FTTR1 EQU X'40' 01701000
BRSW EQU X'20' 01702000
ENDB EQU X'10' 01703000
FREPSW EQU X'08' 01704000
ESDSW EQU X'04' 01705000
INVSW EQU X'02' 01706000
REPSW EQU X'01' 01707000
RDRSWT EQU X'80' SWITCH THE READER 01708000
WTRSWT EQU X'40' SWITCH THE WTR 01709000
SKPFLG EQU X'20' SKIP CONTROL SECTION AND SWITCH READER 01710000
ENDFLG EQU X'10' SKIP TO END CARD 01711000
SPACE 1 01712000
DROP 9 01713000
EJECT 01714000
*********************************************************************** 01715000
* 01716000
* INITIAL ENTRY ROUTINE (RELLDR) 01717000
* 01718000
*********************************************************************** 01719000
* 01720000
BETA DS 0D 01721000
RELLDR EQU * 01722000
BALR 12,0 01723000
USING *,12 01724000
L 9,BASE 01725000
L 12,BREG1 01726000
USING RELDR,12,9 01727000
STIDP CPUID GET CPUID HRC031DK 01727500
MVI CNTR,0 REINITIALIZE TO SHOW NO FREE STORAGE 01728000
MVC READER(2),2 IPL DEVICE BECOMES READER 01729000
* 01730000
* 01731000
* HERE TO CAUSE RELOCATION TO HIGH CORE 01732000
* 01733000
LA R1,PROGINT ADDR. OF PROGRAM INTERRUPT RETURN 01734000
ST R1,ZPRNP+4 SAVE ADDR. IN NEW PROG. PSW 01735000
SLR R1,R1 CLEAR.. 01736000
ST R1,ZPRNP ZERO OUT ALL BUT ADDRESS 01737000
L R2,ENDE LOAD END ADDRESS OF THIS MODULE 01738000
L R3,SIZFE CONSTANT BET. 15 AND 16 MEG @VA04629 01739000
MVCL R2,R2 FORCE PROGRAM CHECK 01740000
* 01741000
* 01742000
PROGINT EQU * P.C. RETURN-- REG-2 = TOP OF STORAGE 01743000
S R2,PROGSIZE SUBTRACT SIZE OF THIS MODULE 01744000
L R3,FFF000 ZERO OUT LOW ORDER 12 BITS 01745000
NR R2,R3 FORCE TO 1K BOUNDARY 01746000
L R3,PROGSIZE NUMBER OF BYTES TO MOVE TO HIGH CORE 01747000
LR R4,R2 SAVE FOR RELOCATION FACTOR 01748000
SLR R4,R12 REG4 NOW HAS RELOCATION FACTOR 01749000
SLR R8,R8 CLEAR 01750000
LA R5,ADCONSLG NUMBER OF ADCONS TO RESOLVE 01751000
LA R6,ADCONS POINTER TO BEGINING OF ADCON LIST 01752000
NXTADCON L R7,0(,R6) GET ADCON ENTRY ADDRESS 01753000
ICM R8,B'0111',1(R7) GET ACTUAL ADCON 01754000
ALR R8,R4 ADD IT TO RELOCATION VALUE 01755000
STCM R8,B'0111',1(R7) PUT IT BACK 01756000
LA R6,4(,R6) BUMP TO GET NEXT ADCON IN THE LIST 01757000
BCT R5,NXTADCON PROCESS TILL LIST IS DELETED 01758000
LR R5,R2 SAVE R2 BEOFRE MVCL INSTRUCTION 01759000
LR R13,R3 SECOND OPERAND FOR 'MVCL' INSTRUCTION 01760000
LA R14,RELDR REMEMBER OLD ADDRESS AND ... @VA03812 01761000
L R15,ATOTSIZE TOTAL SIZE OF THE LOADER. @VA03812 01762000
MVCL R2,R12 MOVE MODULE TO HIGH CORE 01763000
LR R2,R5 RESTORE REG 2 01764000
LA R1,NEWSTART EXCUTION RESUME ADDRESS WITH 01765000
ALR R1,R4 PROPER RELOCATION FACTOR 01766000
ST R1,ZPROP+4 STORE IN OLD PROGRAM CHECK PSW 01767000
LR R9,R2 NEW BASE REG MUST BE LOADED WITH 01768000
LA R9,4095(,R9) VALUE OF NEW REG-12 PLUS ADDING 01769000
LA R9,1(,R9) 4096 BYTES TO IT. 01770000
LR R12,R2 ... 01771000
LPSW ZPROP TAKE OFF AT THE NEW LOCATION 01772000
* 01773000
SPACE 01774000
NEWSTART EQU * RESUME EXCUTION AT NEW STARTING LOCATION 01775000
SR R1,R1 CLEAR R1 (R0 IS IMMATERIAL) @VA03812 01776000
MVCL R14,R0 CLEAR WHERE THE OLD LOADER WAS @VA03812 01777000
LA 0,158 01778000
L 15,AFRINI 01779000
LA 1,CTLIST 01780000
BALR 14,15 01781000
L 15,AFREE 01782000
BALR 14,15 01783000
LR 13,1 01784000
LH 1,READER DRAIN ANY READER CONDITIONS. 01785000
TIO 0(1) .. 01786000
BC 7,*-4 01787000
MVC ZIONP(8),IONP MOVE IO NEW PSW TO 3OWER CORE. 01788000
MVC ZEXNP(8),EXNP SAME FOR EXTERNAL INTERRUPT. 01789000
MVC ZSUPNP(8),SUPNP 01790000
MVC ZMCNP(8),MCNP 01791000
MVC ZPRNP(8),PRNP 01792000
L 3,RDCCWA 01793000
N 3,R3BIT 01794000
LA 2,SPEC(,13) 01795000
OR 3,2 01796000
ST 3,RDCCWA READER CHANNEL COMMAND WORD 01797000
LA 0,X'B7' 01798000
STC 0,CONS(,13) 01799000
L 1,TOP 01800000
ST 1,TBLREF(,13) 01801000
MVC MVC1(12,13),MMMVC INITIALIZATION INTO STO MOVE 01802000
L 1,T1 01803000
ST 1,FREEST(,13) 01804000
L 15,BREG2 01805000
BCR 15,15 INITIAL LOADING ENTRY 01806000
DROP 12 01807000
* 01808000
CPUID DS D CPUID STORED HERE HRC031DK 01808500
PROGSIZE DC A(OMEGA-RELDR) SIZE OF THIS MODULE 01809000
SIZFE DC X'00FE0000' CONSTANT BET. 15 AND 16 MEG @VA04629 01810000
FFF000 DC X'00FFF000' USED TO FORCE TO 1K BOUNDARY 01811000
BREG1 DC A(RELDR) BASE ADDR OF LOADER 01812000
BREG2 DC A(LOAD2) INITIAL LOADING ENTRY 01813000
BASE DC A(RELDR+4096) 01814000
ATOTSIZE DC A(TOTLSIZE) TOTAL SIZE OF LOADER @VA03812 01815000
* 01816000
MMMVC MVC WD(1,13),0(3) INITIALIZATION FOR RLD SUPROUTINE 01817000
MVC 0(1,3),WD(13) 01818000
* 01819000
ADCONS DS 0F TABLE OF ADDRESS CONSTANTS 01820000
DC A(RLDR) 01821000
DC A(SECBASE) 01822000
DC A(WAIT2AD) 01823000
DC A(WAITXXAD) 01824000
DC A(PRTWATAD) 01825000
DC A(WAITPRAD) 01826000
DC A(IGNMSG) 01827000
DC A(PRCOM) 01828000
DC A(RETYRD) 01829000
DC A(VALCHK) 01830000
DC A(ERRORU) 01831000
DC A(ERRORA) 01832000
DC A(ERRORD) 01833000
DC A(ERRORO) 01834000
DC A(ERRORL) 01835000
DC A(ERRORR) 01836000
DC A(ERRORM) 01837000
DC A(CRDIMJ) 01838000
DC A(SKIPM) 01839000
DC A(SPACE1) 01840000
DC A(INTPRT) 01841000
DC A(BELOW) 01842000
DC A(LEND) 01843000
DC A(AADDEF) 01844000
DC A(AFRINI) 01845000
DC A(AFREE) 01846000
DC A(AFRETX) 01847000
DC A(APPNT) 01848000
DC A(HEXBB) 01849000
DC A(TOP) 01850000
DC A(IONPAD) 01851000
DC A(EXNPAD) 01852000
DC A(RDCCW) 01853000
DC A(INITCCW) @V60B9BA 01853100
DC A(ERRCCA) 01854000
DC AL1(128),AL3(ERRCCW) 01855000
DC A(RDCCA) 01856000
DC A(BREG1) 01857000
DC A(BREG2) 01858000
DC A(BASE) 01859000
DC A(SNSWAIAD) 01860000
DC A(INTVRAD) 01861000
DC AL1(128),AL3(TIECCW) 01862000
DC AL1(128),AL3(SENSCCW) 01863000
DC A(EQCKMSG) 01864000
DC A(NOTOPMG) 01865000
DC A(UNRECMG) 01866000
DC A(LPMSG) 01867000
DC A(SECDBASE) 01868000
DC A(RDATCKMG) 01869000
DC A(ARELDR) @VA02639 01870000
DC A(IOTAA) 01871000
DC AL1(128),AL3(IPLCCW) 01872000
DC AL1(128),AL3(IPCCW2) 01873000
DC A(BETAA) 01874000
DC A(ENDE) 01875000
DC A(START) 01876000
DC A(STOPP) 01877000
DC AL1(128),AL3(TOPX) 01878000
DC AL1(128),AL3(CARD3) @VA02018 01879000
DC AL1(128),AL3(CRD3CCW2) @VA02018 01880000
DC A(FRETAD) 01881000
DC A(AFRET) 01882000
DC A(AEXTND) 01883000
ADCONSLG EQU (*-ADCONS)/4 NUMBER OF ENTRIES IN LIST 01884000
EJECT 01885000
TAPERR BALR 3,0 01886000
USING *,3 01887000
L 9,SECDBASE 01888000
L 4,ARELDR LOAD ADDR OF RELDR 01889000
USING RELDR,4,9 ESTABLISH ADDRESSABILITY 01890000
MVC SENSFLD(6),CLEAR CLEAR OUT SENSE FIELD 01891000
MVC CSWSAV(8),ZCSW SAVE CSW 01892000
MVI ERETRYSW,X'80' SET SWITCH 01893000
SNSSIO LA 2,SENSCCW LOAD ADDR OF SENSE CCW 01894000
SSM DISABLE DISABLE IO INT 01895000
ST 2,72 STORE CCW ADDR IN CAW 01896000
LH 2,READER LOAD ADDR OF DEVICE TO BE STARTED 01897000
SENCK SIO 0(2) START DEVICE 01898000
BC 8,SNSWAIT DEVICE STARTED 01899000
BC 3,SIOERR UNIT NOT OPERATIONAL 01900000
TM 68,X'02' WAS THERE AN ERROR ON SENSE 01901000
BO EQUIPCHK YES GIVE MSG TERMINATE 01902000
B SENCK LOOP TILL SIO TAKES 01903000
CNOP 0,8 ALIGNMENT 01904000
SNSWAIT STH 2,ZIONP+2 STORE 01905000
LPSW *+4 LOAD 01906000
DC X'FE020000' PSW 01907000
SNSWAIAD DC A(*+4) 01908000
CLC ZIOOP+2(2),ZIONP+2 COMPARE 01909000
BNE SNSWAIT WAIT 01910000
TM SENSFLD,X'80' IS IT COMMAND REJECT 01911000
BO CARDRTN YES CONTINUE AS A CARD ERROR 01912000
TM SENSFLD,X'40' IS IT INTERVENTION REQ 01913000
BO INTVREQ YES 01914000
TM SENSFLD+1,X'08' IS TAPE AT LOAD POINT 01915000
BO TAPELP YES 01916000
TM SENSFLD,X'08' IS IT A DATA CHECK 01917000
BO DATACK YES 01918000
TM SENSFLD+1,X'80' IS IT NOISE 01919000
BO DATACK YES 01920000
B UNRCTPER 01921000
DATACK L 7,CSWSAV GET ADDR OF ERROR CCW 01922000
S 7,EIGHT GET ADDR OF ERROR CCW 01923000
MVC TIECCW1(8),0(7) LOAD ERROR CCW IN TIE LIST 01924000
LH 8,6(7) LOAD COUNT OF ERROR CCW IN REG 8 01925000
SH 8,CSWSAV+6 SUBTRACT TO GET NR OF BYTES READ 01926000
CH 8,TWELVE TEST FOR TWELVE BYTES 01927000
BC 10,READTAPE 12 BYTES OR MORE RECORD LENGTH 01928000
TM SENSFLD+1,X'80' LESS THAN 12 BYTES CHECK NOISE BIT 01929000
BC 7,READTAPE NOISE BIT ON GO TO READ TAPE ROUTINE 01930000
NOISEREC B NOISERTN IGNORE NOISE RECORD GET NEXT RECORD 01931000
READTAPE LA 2,BSPACE GET BS CCW ADDR 01932000
BAL 6,SIORTN START DEVICE 01933000
L 7,READTEN SETUP CNTR FOR READ RETRY 01934000
BCT 7,READLOOP PERFORM TEN RETRIES 01935000
TM SENSFLD+1,X'08' IS TAPE AT LOAD POINT 01936000
BC 1,NOCLEAN YES BYPASS TAPE CLEAN ROUTINE 01937000
MVI LPSWITCH,X'EE' SET LOOP SWITCH TO DETECT BS TO LP 01938000
LA 2,CLEANTP GET ADDR OF TAPE CLEAN CCWS 01939000
BAL 6,SIORTN START DEVICE 01940000
MVI LPSWITCH,X'00' RESET LP SWITCH TO OFF 01941000
NOCLEAN L 8,CLEANCTR SET UP TAPE CLEAN ENTRY CTR 01942000
BCT 8,CLEANLOP BRANCH ALLOW TEN ENTRIES INTO TP CLN RTN 01943000
MVC READTEN(4),READSET SOLID ERROR RESET COUNTER TO 10 01944000
MVC CLEANCTR(4),CLEANSET 10 ENTRIES TO TAPE CLEAN/RESET 01945000
MVI LPSWITCH,X'00' RESET LOAD POINT SWITCH OFF 01946000
B RDATCK LOAD ADDR OF READ DATA CHECK MSG 01947000
CLEANLOP ST 8,CLEANCTR SAVE DEC CTR VALUE 01948000
L 7,READSET 10TH READ RETRY, RESET READTEN 01949000
READLOOP ST 7,READTEN SAVE DEC CTR VALUE 01950000
MVC TIEBYTE(1),SENSFLD+2 PUT SENSE BYTE 2 IN TIE CCW LIST 01951000
LA 2,TIECCW LOAD TRACK IN ERROR CCW LIST ADDR 01952000
ST 2,72 SET UP CAW 01953000
BAL 10,SIO2 START DEVICE 01954000
MVC READTEN(4),READSET NO ERROR RETURN RESET COUNTER 01955000
MVC CLEANCTR(4),CLEANSET NO ERROR RETURN RESET COUNTER 01956000
MVI ERETRYSW,X'00' RESET SWITCH 01957000
B CONTINUE 01958000
SIORTN SSM DISABLE DISABLE IO 01959000
ST 2,72 STORE CCW ADDR IN CAW 01960000
LH 2,READER LOAD DEVICE ADDR 01961000
WAITLOOP TIO 0(2) TEST DEVICE STATUS 01962000
BC 2,WAITLOOP YES 01963000
SIO1 SIO 0(2) START DEVICE 01964000
BC 8,IOWAIT STARTED 01965000
BC 2,WAITLOOP BUSY TRY AGAIN 01966000
BC 1,SIOERR NOT OPERATIONAL 01967000
B TIO3 CHECK FOR ANY ERRORS 01968000
IOWAIT TIO 0(2) IS IO COMPLETE 01969000
BC 2,IOWAIT NO KEEP LOOPING 01970000
BR 6 YES RETURN 01971000
TIO3 TM 68,X'03' IS STATUS UC OR UE 01972000
BC 5,TIO2 YES 01973000
TM 69,X'FF' ANY OTHER ERRORS 01974000
BC 5,TIO2 YES 01975000
TM 68,X'04' IS IT DEVICE END 01976000
BC 8,TIO1 NO 01977000
BR 6 YES IT IS 01978000
TIO2 TM 68,X'02' IS IT UNIT CHECK 01979000
BC 1,SNSSIO YES 01980000
B UNRCTPER ITS UNIT EXCEPTION 01981000
TIO1 TM 68,X'30' CNTL UNIT END 01982000
BC 5,SIO1 01983000
TM 68,X'08' CHANNEL END 01984000
BC 1,IOWAIT WAIT FOR DEVICE END 01985000
B SNSSIO CHECK ERROR 01986000
INTVREQ LA 5,RETYRD LOAD ADDR OF INT REG MSG 01987000
MVC PRNTR(2),CNSL SET UP TO PRINT MSG ON CONSOLE 01988000
BAL 14,ERPRNT GO TELL USER 01989000
BAL 14,PAGER SKIP TO NEW PAGE ON PRINTER 01990000
MVC PRNTR(2),PRNTSET RESTORE PRNTR ADDRESS 01991000
MVC ZIONP+2(2),READER SET UP FOR DEVICE END 01992000
CNOP 4,8 01993000
LPSW *+4 01994000
DC X'FF020000' WAIT FOR INTERRUPT ON THIS CHAN 01995000
INTVRAD DC A(DATACK) 01996000
TAPELP TM LPSWITCH,X'EE' LP OCCURED DURING TAPE CLEAN RTN 01997000
BC 1,LPDATA YES GO TO DATA CHECK AT LP EXIT 01998000
RDATCK LA 5,RDATCKMG LOAD ADDR OF READ DATA CK MSG 01999000
MVC PRNTR(2),CNSL PUT MSG OUT ON THE CONSOLE 02000000
BAL 14,ERPRNT PRINT MSG 02001000
LPSW ERRPSW LOAD ERROR PSW 02002000
LPDATA LA 5,LPMSG LOAD ADDR OF LOAD POINT MSG 02003000
MVC PRNTR(2),CNSL PUT MSG ON CONSOLE 02004000
BAL 14,ERPRNT PRINT MSG 02005000
LPSW ERRPSW LOAD ERROR PSW 02006000
EQUIPCHK LA 5,EQCKMSG LOAD ADDR OF EQUIP CK MSG 02007000
MVC PRNTR(2),CNSL PUT MSG OUT ON THE CONSOLE 02008000
BAL 14,ERPRNT PRINT MSG 02009000
LPSW ERRPSW LOAD ERROR PSW 02010000
SIOERR LA 5,NOTOPMG LOAD ADDR OF NOT OPERATIONAL MSG 02011000
MVC PRNTR(2),CNSL PUT MSG OUT ON THE CONSOLE 02012000
BAL 14,ERPRNT PRINT MSG 02013000
LPSW ERRPSW LOAD ERROR PSW 02014000
UNRCTPER LA 5,UNRECMG LOAD ADDR OF UNRECOVERABLE ERROR MSG 02015000
MVC PRNTR(2),CNSL PUT MSG OUT ON THE CONSOLE 02016000
BAL 14,ERPRNT PRINT MSG 02017000
SVC 108 DIE..... 02018000
DS 0D 02019000
TIECCW DC X'1B' TRACK IN ERROR COMMAND CODE 02020000
DC AL3(TIEBYTE) ADDR OF TRACK IN ERROR 02021000
DC X'60000001' CHAIN BIT ON SLI BIT ON 02022000
TIECCW1 DC X'0000000000000000' SPACE FOR INSERTING READ CCW 02023000
TIEBYTE DC X'00' SPACE TO INSERT SENSE BYTE TWO 02024000
DS 0F 02025000
READTEN DC X'0000000A' COUNT OF RETRIES 02026000
READSET DC X'0000000A' RESTORE VALUE 02027000
CLEANCTR DC X'0000000A' COUNT OF TAPE CLEANER RETRYS 02028000
CLEANSET DC X'0000000A' RESTORE VALUE 02029000
DS 0F 02030000
EIGHT DC F'08' 02031000
TWELVE DC H'12' 02032000
SENSFLD DC 6X'00' 02033000
DISABLE DC X'00' 02034000
CSWSAV DC 2F'00' 02035000
DS 0D 02036000
CLEANTP DC X'27' BACKSPACE OP CODE 02037000
DC X'00000060000001' CHAIN BIT ON SLI BIT ON 02038000
DC X'27' BACKSPACE OP CODE 02039000
DC X'00000060000001' CHAIN BIT ON SLI BIT ON 02040000
DC X'37' FOWARD SPACE OP CODE 02041000
DC X'00000060000001' CHAIN BIT ON SLI BIT ON 02042000
DC X'37' FOWARD SPACE OP CODE 02043000
DC X'00000020000001' CHAIN BIT OFF SLI BIT ON 02044000
DS 0D 02045000
BSPACE DC X'27' BACKSPACE OP CODE 02046000
DC X'00000020000001' REST OF CCW 02047000
SENSCCW DC X'04' SENSE CCW OP CODE 02048000
DC AL3(SENSFLD) ADDR OF READIN AREA 02049000
DC X'20000006' REST OF CCW 02050000
LPSWITCH DC X'00' SWITCH AT EE DATA CHECK AT LP 02051000
CLEAR DC XL8'00' 02052000
CNOP 0,8 02053000
ERRPSW DC X'00020000' 02054000
DC X'0000FFFF' 02055000
EQCKMSG DC A(REQCKMSG) 02056000
DC AL2(RNOTOPMG-REQCKMSG) 02057000
NOTOPMG DC A(RNOTOPMG) 02058000
DC AL2(RUNRECMG-RNOTOPMG) 02059000
UNRECMG DC A(RUNRECMG) 02060000
DC AL2(RLPMSG-RUNRECMG) 02061000
LPMSG DC A(RLPMSG) 02062000
DC AL2(RRDATCK-RLPMSG) 02063000
SECDBASE DC A(RELDR+4096) 02064000
RDATCKMG DC A(RRDATCK) 02065000
DC AL2(LASTMSG-RRDATCK) 02066000
REQCKMSG DC C'TAPE EQUIP CHECK' 02067000
RNOTOPMG DC C'TAPE NOT OPERATIONAL' 02068000
RUNRECMG DC C'UNRECOVERABLE TAPE ERROR' 02069000
RLPMSG DC C'TAPE AT LOAD POINT' 02070000
RRDATCK DC C'TAPE READ DATA CHECK' 02071000
LASTMSG EQU * 02072000
EJECT 02073000
DROP 3 02074000
DROP 4 02075000
********************************************************************* 02076000
* CHANGE PRINTER AND TYPEWRITER ADDRESS ROUTINE 02077000
********************************************************************* 02078000
L 15,ARELDR LOAD ADDR OF RELDR 02079000
USING RELDR,15 02080000
DEVHNDLR STM 0,15,SAV 02081000
C 1,DEV 02082000
BE PROC 02083000
MVI DEVSW,X'00' 02084000
BAL 14,PAGER 02085000
LM 0,15,SAV 02086000
B CONTINU 02087000
CNOP 0,8 02088000
DC X'00020000FFFFFFFF' 02089000
WAITLCMG LPSW *-8 02090000
PROC LA 5,SPEC+4(,13) SET UP TO SCAN THE FIRST FIELD 02091000
LA 6,1 02092000
LA R7,SPEC+71(,R13) SET UPPER LIMIT TO SCAN @VA04726 02093100
LOOKUP CLI 0(5),C' ' IS THIS A BLANK 02094000
BC 8,BPNTR 02095000
SCAN CLC 0(5,5),TYP 02096000
BE TYPTR 02097000
CLC 0(5,5),PRT 02098000
BE PRTER 02099000
BAD MVC 0(15,0),MSG2 02100000
B WAITLCMG 02101000
BPNTR BXLE 5,6,LOOKUP 02102000
B NXTCARD 02103000
PRTER LA 5,5(5) 02104000
BAL 14,PACKUNT 02105000
MVC PRNTR,PAREA1 02106000
MVC PRNTSET,PRNTR 02107000
B RTN 02108000
TYPTR LA 5,5(5) 02109000
BAL 14,PACKUNT 02110000
MVC CNSL,PAREA1 02111000
RTN LA 5,3(5) 02112000
CLI 0(5),C',' 02113000
BE BPNTR YES, GO CHECK NEXT COL. @VA04087 02114000
CLI 0(R5),C' ' BLANK? @VA04087 02115000
BE BPNTR YES, GO CHECK NEXT COL. @VA04087 02116000
B BAD INVALID DEV CARD @VA04087 02117000
NXTCARD BAL 14,PAGER 02118000
MVI DEVSW,X'00' 02119000
LM 0,15,SAV 02120000
BC 15,RD 02121000
PACKUNT LA 1,3 GET NUMBER OF DIGITS @VA10508 02122100
SR 3,3 CLEAR WORK REG @VA10508 02122600
LR 4,5 POINT TO DEVICE ADDRESS @VA10508 02123100
GETNEXT MVC PAREA2,0(4) LOAD FOR CHECKING @VA10508 02123600
SLL 3,4 SHIFT THE GENERATED ADDRESS @VA10508 02124100
CLI PAREA2,X'C1' IS IT A? @VA10508 02124600
BL BADDEV LOWER THAN A -- NO GOOD @VA10508 02125100
CLI PAREA2,X'C6' MAYBE F @VA10508 02125600
BH NOTALPH HIGHER THAN F @VA10508 02126100
XI PAREA2,X'C0' CLEAR 'C' @VA10508 02126600
AH 3,DIG9 ADD ADJUSTMENT @VA10508 02127100
B ADDDIG GO FINISH THE PACK @VA10508 02127600
DIG9 DC X'0009' ADJUSTMENT NUMBER @VA10508 02128100
NOTALPH CLI PAREA2,X'F0' IS IT NUMERIC? @VA10508 02128600
BL BADDEV NO--NOT A VALID DEV ADDRESS @VA10508 02129100
XI PAREA2,X'F0' CLEAR 'F' @VA10508 02129600
ADDDIG AH 3,PAREA ADD LOW ORDER BITS @VA10508 02130100
LA 4,1(4) INDEX THE POINTER @VA10508 02130600
BCT 1,GETNEXT HAVE WE DONE THREE? @VA10508 02131100
STH 3,PAREA1 @VA10508 02131600
BR 14 02136000
BADDEV MVC 0(24,0),MSG3 02137000
B WAITLCMG 02138000
DEVSW DS CL1 02144000
SAV DS 16F 02145000
MSG2 DC C'BAD DEVICE CARD' 02146000
MSG3 DC C'INVALID DEVICE SPECIFIED' 02147000
PRT DC C'PRNT=' 02148000
TYP DC C'TYPW=' 02149000
CTN DC H'0' 02150000
PARLMT DC H'0' 02151000
UNT DC X'000A0B0C0D0E0F' 02152000
PAREA1 DC H'0' 02153000
PAREA DC X'0' @VA10508 02154000
PAREA2 DC X'0' @VA10508 02154500
DS F 02155000
DEV DC X'02' 02156000
DC C'DEV' 02157000
DS 0F 02158000
ARELDR DC A(RELDR) ADDRESS OF BASE MODULE 02159000
EJECT 02160000
*********************************************************************** 02161000
* STORAGE USING REGISTER 13 AND THE FOLLOWING SYMBOLS 02162000
*********************************************************************** 02163000
* 02164000
* TO BEGIN ON DOUBLE WORD BOUNDRY 02165000
* 02166000
NOESD EQU 512 NUMBER OF EXTERNS IN 1 MODULE 02167000
MAXREF EQU 1280 NUMBER OF TYPE 0 & 1 ESD ENTRIES @VA03724 02168000
* 02169000
GREG EQU 0 16 WORDS, GEN REGS SAVED BY RELLDR 02170000
EMSG EQU GREG+64 4 BYTES TO INDICATE ERROE 02171000
RETT EQU 0 USED BY HEXB SUBROUTINE 02172000
LOCCT EQU RETT+4 4 BYTES LOC TO BEGIN LOADING (ADDR SV 02173000
NARG EQU LOCCT+4 4 BYTES ,NO. OF ARG. IN INPUT LIST 02174000
MVC1 EQU NARG+4 THESE TWO INITIALIZED BY DOLLA. 02175000
MVC2 EQU MVC1+6 .. 02176000
WD EQU MVC2+6 4 BYTES, STORAGE FOR RLD SBR 02177000
BRAD EQU WD+4 4 BYTES, STORAGE 02178000
SPEC EQU BRAD+4 80 BYTES-------------THE I/O BUFFER 02179000
CONS EQU SPEC+80 4 BYTES-B7000000 STORAGE 02180000
* EQU CONS+1 FORMERLY SWS(13) 02181000
ESIDTB EQU CONS+4 64 BYTES A TABLE 02182000
TBLCT EQU CONS+2 1 BYTES - NO OF ENTRIES IN TBLREF 02183000
TBLREF EQU ESIDTB+NOESD*2 HALFWORD ENTRIES 02184000
APSV EQU TBLREF+4 64 BYTES - REG SAVED 02185000
PLIST EQU APSV+64 4 BYTES, POINTER TO PARAM LIST 02186000
TEMPST EQU PLIST+4 02187000
TMPLOC EQU TEMPST+4 02188000
FREEST EQU TMPLOC+4 02189000
EPSV EQU FREEST+4 02190000
EJECT 02191000
* 02192000
* THE OPERATION OF THIS PROGRAM DEPENDS UPON 02193000
* AN INTERNAL REPRESENTATION OF THE EXTERNAL 02194000
* CHARACTER SET WHICH IS EQUIVALENT TO THE ONE 02195000
* USED AT ASSEMBLY TIME. THE CODING HAS BEEN 02196000
* ARRANGED SO THAT REDEFINITION OF CHARACTER 02197000
* CONSTANTS, BY REASSEMBLY, WILL RESULT IN A 02198000
* CORRECT MODULE FOR THE NEW DEFINITIONS. 02199000
* THE CONSTANTS WITH *** IN COL. 69-71 REQUIRE 02200000
* THE X'02' EQUAL A T-2-9 PUNCH AND MUST BE 02201000
* MODIFIED IF THE PROPERTIES OF THE CHARACTER 02202000
* SET ARE CHANGED. 02203000
EJECT 02204000
* 02205000
LDRGEN DS 0D -LOADER CONTROL- 02206000
* 02207000
* 02208000
EOPSW EQU 24 EXTERNAL OLD PSW 02209000
MCOP EQU 32 SUPERVISOR CALL OLD PSW 02210000
PRLOD EQU 40 PROGRAM OLD PSW 02211000
IOOP EQU 56 I/O OLD PSW 02212000
CSW EQU 64 CHANNEL STATUS WORD ADDR 02213000
CAW EQU 72 CHANNEL ADDRESS WORD 02214000
EXNPSW EQU 88 EXTERNAL NEW PSW 02215000
NSVCPSW EQU 96 SUPERVISOR CALL NEW PSW 02216000
NPROG EQU 104 PROGRAM NEW PSW 02217000
MKNEW EQU 112 MACHINE CHECK NEW PSW 02218000
NIOPSW EQU 120 I/O NEW PSW 02219000
* 02220000
ZUSER EQU 2048 SET BY CONTROL PROGRAM OR IPL SIMULATOR 02221000
* 02222000
EJECT 02223000
BALR 15,0 02224000
USING *,15 02225000
L 4,IOTAA LOD BUFFER ADDR 02226000
LH 8,DEVICE OUTPUT DEVICE ADDRESS 02227000
LA 11,QRCD I/O ROUTINE ADDR 02228000
LR 1,8 DEVICE ADDR TO REG-1 02229000
SRL 1,8 ADJUST REG TO DEVELOP 02230000
LA 2,256 CHANNEL MASK 02231000
N6 SRL 2,1 CHANNEL MASK 02232000
SH 1,N6+2 COUNT DOWN 02233000
BC 10,N6 BR IF NOT CORRECT CHAN 02234000
STC 2,WAIT1X CHAN MASK TO WAIT PSW 02235000
LA 2,1(2) INCLUDE EXTERNAL INTERUP 02236000
STC 2,WAIT2X 02237000
STC 2,WAIT3X CHAN MASK TO WAIT PSW 02238000
MVI CMD+1,EJECT EJECT LAST CARD. 02239000
SR 1,1 02240000
LA 2,ERR 02241000
BALR 12,11 BR TO I/O ROUTINE 02242000
CLL L 1,IOTAA LOD BUFF ADDR 02243000
ST 1,TOPX PLACE BUF ADDR IN BOOT- 02244000
MVI TOPX,X'02' MOVE IN READ C6MMAND. 02245000
ST 1,CARD3 STORE ADDRESS IN 3RD IPL CCW @VA02018 02246000
MVI CARD3,X'02' RESTORE READ OP CODE @VA02018 02247000
LA 1,80(1) BUMP ADDR TO NEXT CARD @VA02018 02248000
ST 1,CRD3CCW2 STORE ADDRESS IN 4TH IPL CCW @VA02018 02249000
MVI CRD3CCW2,X'02' RESTORE READ OP CODE @VA02018 02250000
LA 1,80(1) MOD I/P BUF ADDR 02251000
ST 1,IPLCCW STORE ADDRESS IN 1ST IPL CCW @VA02018 02252000
MVI IPLCCW,X'02' RESTORE READ OP CODE @VA02018 02253000
ST 1,IPCCW2 STORE ADDRESS 02254000
MVI IPCCW2,X'08' RESTORE TIC OP CODE @VA02018 02255000
LOXP L 14,ENDE OBJECT PROG END ADDR 02256000
L 13,START OBJECT PROG START ADDR 02257000
SR 14,13 DIFF = NUM OF BYTES TO PCH 02258000
MVI MVCX+1,71 RESTORE BYTE COUNT 02259000
MVI CMD+1,WRITEC WRITE AND EJECT 02260000
MVI CCW1+7,24 IPL CARD BYTE COUNT 02261000
LA 1,IPLPSW ADDR OF IPL CARD 02262000
LA 2,ERR ERROR RETURN 02263000
BALR 12,11 BR TO I/O ROUTINE 02264000
MVI CCW1+7,80 02265000
LA 1,ENTRY+160 3RD CARD OF BOOTSTRAP RTN @VA02018 02266000
LA 2,ERR ERROR RETURN @VA02018 02267000
BALR 12,11 BR TO I/O ROUTINE @VA02018 02268000
LA 1,ENTRY BOOTSTRAP ROUTINE ADDR 02269000
LA 2,ERR 02270000
BALR 12,11 BR TO I/O ROUTINE 02271000
LA 1,ENTRY+80 PCH SECOND BOOTSTRAP 02272000
LA 2,ERR CARD 02273000
BALR 12,11 WRITE RECORD 02274000
LA 10,72 LOD RECORD BYTE SIZE 02275000
EXC L 7,CONUM RESTORE TO ZEROS 02276000
LA 6,10 SETUP CARD SEQ PATTERN 02277000
LA 5,10 SEQUENCE CONTROLS 02278000
PCH L 1,BETAA+4 LOD BLANKS TO REPLACE 02279000
ST 1,0(0,4) BYTES 1-75 IN BUFFER 02280000
MVC 1(75,4),0(4) 02281000
MVCX MVC 0(72,4),0(13) MOVE TXT TO BUFFER 02282000
ST 7,76(0,4) ST SEQ NUM 02283000
LR 1,4 SETUP I/O CALL 02284000
LA 2,ERR 02285000
BALR 12,11 WRITE RECORD 02286000
PCH1 LA 1,1 LOD SEQ INCREMENT 02287000
TM ERR0+4,X'80' TEST LAST CRD SWITCH 02288000
BC 1,OUT BR IF LAST CARD 02289000
AR 13,10 MODIFY FOR NEXT RECORD 02290000
LR 9,14 SAVE REMAINING BYTE COUNT 02291000
AR 7,1 INCREMENT CARD SEQ 02292000
BCT 5,LO2 02293000
LA 5,10 RESTORE COUNTER 02294000
SRL 7,8 ADJUST FOR NEXT CTR 02295000
AR 7,1 INCREMENT CARD SEQ 02296000
SLL 7,8 REAJUST REGISTER 02297000
IC 7,CONUM INSERT ZERO 02298000
BCT 6,LO2 CONTROL 02299000
LA 6,10 RESTORE COUNTER 02300000
SRL 7,16 ADJUST TO HUNDREDS POSITION 02301000
LO1 AR 7,1 INCREMENT CARD SEQ 02302000
SLL 7,8 LOD ZEROS 02303000
IC 7,CONUM LOD ZEROS 02304000
SLL 7,8 LOD ZEROS 02305000
IC 7,CONUM LOD ZEROS 02306000
IC 1,SSM+1 HUNDREDS POSITION COUNTER 02307000
SH 1,PCH1+2 HUNDREDS POSITION CTL 02308000
STC 1,SSM+1 RESTORE COUNTER 02309000
BC 2,LO2 02310000
LA 1,10 COUNTER WRAPS AROUND 02311000
STC 1,SSM+1 RESTORE TO ZEROS 02312000
EX 0,EXC RESTORE TO ZEROS 02313000
SRL 1,3 RESTORE ONE IN REG 02314000
LO2 SR 14,10 MODIFY FOR NEXT RECORD 02315000
*********************************************************************** 02316000
BC 8,OUT BR IF NOTHING MORE 02317000
*********************************************************************** 02318000
CR 14,10 CHECK REMAINING. 02319000
BC 11,PCH RETURN FOR MORE. 02320000
OI ERR0+4,X'80' LAST CRD SW ON 02321000
SR 14,1 SETUP MOVE INST. 02322000
STC 14,MVCX+1 .. 02323000
*********************************************************************** 02324000
BC 15,PCH 02325000
OUT NI ERR0+4,X'7F' SWITCH OFF 02326000
LA 1,24 SETUP TO PUNCH END CRD 02327000
STH 1,CCW1+6 STORE BYTE COUNT 02328000
MVI CEND+1,C'L' FLAG LAST CARD 02329000
MVI CEND+2,C'D' ... 02330000
LA 1,CEND END CARD ADDRESS 02331000
LA 2,ERR 02332000
BALR 12,11 BR TO I/O ROUTINE 02333000
LH 1,CON LOAD DECK COUNT 02334000
SH 1,PCH1+2 SUBTRACT ONE FROM REG 02335000
STH 1,CON RESTORE COUNT 02336000
BC 2,LOXP BR IF COUNT NOT ZERO 02337000
L 6,EASY LOD EOJ INDICATOR 02338000
ST 6,ERR0+4 ST IN PSW IMAGE 02339000
LPSW ERR0 END-OF-JOB 02340000
* 02341000
ERR LPSW ERR0 AB-END-OF-JOB 02342000
* 02343000
DEVICE DC AL2(OUTPUT) CELL FOR DEVICE ADDR 02344000
CON DC XL2'1' PUNCH X MANY DECKS 02345000
* 02346000
DS 0D 02347000
ERR0 DC X'0006000000' 02348000
DC C'GNA' DEVICE NOT AVAILABLE 02349000
* 02350000
IPLPSW DC X'00040000' 02351000
* 02352000
IOTAA DC A(IOTA) BUFFER ADDRESS 02353000
* 02354000
IPLCCW DC X'02' 02355000
DC AL3(IOTA+160) CCW FOR READING IN 3RD @VA02018 02356000
* BOOTSTRAP CARD 02357000
DC X'60000050' 02358000
IPCCW2 DC X'08' TIC CCW @VA02018 02359000
DC AL3(IOTA+160) TIC TO 3RD CARD, JUST READ IN @VA02018 02360000
DC X'00000000' @VA02018 02361000
CEND DC X'02' *** 02362000
DC C'XX' END OF LOADER FLAG 02363000
DC X'02' ... 02364000
BETAA DC A(BETA) LOAD END TR ADDR 02365000
DC C' 01' 02366000
DC C' ' 02367000
CONUM DC C'0000' CONSTANT ZEROS 02368000
ENDE DC A(OMEGA) 02369000
START DC A(ALPHA) 02370000
EASY DC C' GEA' EOJ 02371000
* 02372000
ALPHAA EQU START 02373000
OMEGAA EQU ENDE 02374000
* 02375000
DROP 15 02376000
EJECT 02377000
*********************************************************************** 02378000
* 02379000
* CARD READ ROUTINE 02380000
* 02381000
*********************************************************************** 02382000
* 02383000
USING *,11 -ADDRESSIBILITY- 02384000
QRCD ST 1,CCW1 I/O BUFFER ADDR 02385000
CMD MVI CCW1,X'02' I/O COMMAND 02386000
LA 1,CCW1 SETUP CHAN ADDR WORD 02387000
ST 1,CAW 02388000
ST 2,REG2 SAVE REGISTER TWO 02389000
LA 1,WAITX NORMAL WAIT PSW 02390000
LA 2,TIOA CHAN BUSY RETURN 02391000
TIOA TIO 0(8) CLEAR CHANNEL 02392000
BC 1,ERRR1X 02393000
GO LA 0,SIOD LOD INTERRUPTION ADDR 02394000
ST 0,NIOPSW+4 ST AT I/O NEW PSW 02395000
SSM SSM MASK OUT OTHER CHANNELS 02396000
SIOA SIO 0(8) CMD TO READ/WRITE 02397000
BCR 8,1 CMD ACCEPTED,WAIT 02398000
BCR 2,2 TO RETRY,CHAN BUSY 02399000
TM CSW+4,X'10' TEST FOR UNIT BUSY 02400000
BCR 1,2 BR-UNIT BUSY 02401000
BC 15,TEST TEST CONDITIONS 02402000
SIOD CH 8,IOOP+2 TEST CHAN AND DEVICE 02403000
BC 8,*+8 TEST FURTHER IF SAME 02404000
LPSW IOOP OTHERWISE WAIT 02405000
* 02406000
TEST TM CSW+5,X'3F' TEST FOR CHANNEL ERROR 02407000
BC 7,ERRR1X CHAN ERROR BR 02408000
TM CSW+4,X'0E' DATA ERROR CHECK 02409000
BC 1,SIOC INDICATE THRU WAIT 02410000
TM CSW+4,X'0A' DATA ERROR CHECK 02411000
BC 1,SIOC INDICATE THRU WAIT 02412000
TM CSW+4,X'06' DATA ERROR CHECK 02413000
BC 1,SIOC INDICATE THRU WAIT 02414000
TM CSW+4,X'02' INTERVENTION REQUIRED 02415000
BC 1,SIOB HOPPER EMPTY 02416000
TM CSW+4,X'01' LAST CRD TEST 02417000
BC 1,LAST BR IF LAST CRD READ 02418000
TM CSW+4,X'04' TEST FOR DEVICE END 02419000
BC 8,WAIO BR TO WAIT FOR IT 02420000
BCR 15,12 RETURN 02421000
* 02422000
WAIO LPSW IOOP WAIT FOR DEVICE END 02423000
* 02424000
LAST L 12,REG2 LAST CRD RETURN ADDR 02425000
BCR 15,12 RETURN TO OBJECT PROG 02426000
* 02427000
WAITX LPSW WAIT1X NORMAL WAIT 02428000
* 02429000
SIOB ST 2,EXNPSW+4 READY READER WAIT 02430000
LPSW WAIT2X 02431000
* 02432000
SIOC ST 2,NIOPSW+4 DATA ERROR(S) 02433000
LPSW WAIT3X 02434000
* 02435000
ERRR1X ST 2,NIOPSW+4 02436000
ST 2,EXNPSW+4 02437000
LPSW WAIT4X 02438000
* 02439000
REG2 DS 1F 02440000
SSM DC X'0009' MASK OFF ALL CHAN 02441000
* 02442000
DS 0D 02443000
CCW1 DC X'0000000020000050' 02444000
* 02445000
WAIT1X DC X'8006' NORMAL WAIT 02446000
DC XL6'F' PSW 02447000
* 02448000
WAIT2X DC X'0106' INTERRUPT TO RESUME 02449000
DC XL3'0' 02450000
DC C'GIA' HOPPER EMPTY 02451000
* 02452000
* WAIT3X DATA ERROR(S) CHECK 02453000
* 02454000
WAIT3X DC X'8106' 02455000
DC XL3'0' 02456000
DC C'GDD' DATA ERROR 02457000
* 02458000
* WAIT4X CHANNEL ERROR(S) 02459000
* 02460000
WAIT4X DC X'0106' INTERRUPT TO RESUME 02461000
DC XL3'0' 02462000
DC C'GCA' CHANNEL ERROR 02463000
DROP 11 02464000
* 02465000
NOP EQU 3 02466000
EJECT EQU NOP 02467000
WRITEC EQU 1 02468000
OUTPUT EQU X'D' 02469000
FREE DS 0D 02470000
ENTRY FRINIT FREE STORAGE INITIALIZATION 02471000
ENTRY FRET RETURN FREE STORAGE BLOCKS 02472000
SPACE 02473000
SPACE 02474000
* BLOCK DEFINITIONS 02475000
* 02476000
BSIZE EQU 0 BACKWARD SIZE POINTER. 02477000
FSIZE EQU 4 FORWARD SIZE POINTER 02478000
BSTOR EQU 8 BACKWARD STORAGE POINTER 02479000
FSTOR EQU 12 FORWARD STORAGE POINTER 02480000
SIZE EQU 16 LOCATION OF SIZE BYTE (IF NOT TWO) 02481000
SPACE 02482000
CTLSIZ EQU 16 CONTROL LIST SIZE 02483000
CTLCNT EQU 20 CONTROL LIST USAGE COUNT 02484000
CTLLEN EQU 32 02485000
* 02486000
EJECT 02487000
*********************************************************************** 02488000
* 02489000
* 'FREE' IS THE ENTRY TO OBTAIN BLOCKS OF FREE STORAGE 02490000
* OF A SPECIFIED SIZE. ITS OPERATION IS DESCRIBED BELOW. 02491000
* 02492000
* 'FREE' SEARCHES DOWN THE LIST OF SPECIFIED SIZES 02493000
* FOR A MATCH WITH THE REQUEST. IF IT FINDS AN ENTRY WHICH 02494000
* CONTAINS SOMETHING ON ITS STRING, IT WILL DETACH THE FIRST 02495000
* BLOCK ON THE STRING AND RETURN IT TO THE USER. IF IT FAILS TO 02496000
* FIND A MATCHING ENTRY, IT WILL LOOK ON THE JUNK LIST FOR AN 02497000
* ENTRY OF A LARGER SIZE. IF IT FINDS ONE, IT WILL SPLIT OFF 02498000
* THE USER'S REQUEST FROM THE TOP AND RETURN THE BOTTOM HALF 02499000
* TO FREE STORAGE VIA A CALL TO 'FRET'. IF IT FAILS TO FIND ONE, 02500000
* IT WILL LOOK ON THE LIST OF STANDARD SIZES FOR A LARGER SIZE. 02501000
* IF IT FINDS ONE, IT WILL PERFORM THE SAME OPERATION AS FOR THE 02502000
* JUNK LIST. IF IT FAILS, IT WILL CALL THE USER ROUTINE 'EXTEND' 02503000
* FOR AN INCREASE IN THE 'MEMORY BOUND' AND PROCEED TO TRY AGAIN 02504000
* 02505000
* IT CHECKS TO SEE WHETHER 'FRINIT' HAS BEEN PREVIOUSLY CALLED 02506000
* (BY 'FRLIST' BEING NON-ZERO). IF NOT IT WILL INITIALIZE ITSELF 02507000
* INTERNALLY TO AN ALL GARBAGE LIST AND CLEAR OUT THE STORAGE 02508000
* THREAD POINTER. 02509000
* 02510000
********************************************************************** 02511000
SPACE 02512000
USING *,R15 ADDRESSIBILITY- 02513000
SPACE 02514000
STM R0,R15,FREREG SAVE REGISTERS 02515000
ST R14,RETREG SAVE RETURN REG. 02516000
BAL R5,ROUNDUP ROUND UP TO 3 DW BOUNDARY 02517000
STH R0,NREQ SAVE NUM. OF DW'S WANTED. 02518000
SLR R3,R3 CLEAR OUT LSTENT FOR USAGE COUNTER 02519000
ST R3,LSTENT ... 02520000
FREEX SLR R3,R3 ZERO REG 02521000
L R1,FRLIST GET ADDRESS OF FREE CONTROL LIST. 02522000
LTR R1,R1 CHECK FOR PROPER FRINIT INITIALIZATION. 02523000
BNZ FREE3 YES. 02524000
LA R1,FRGARB NO - GET GARBAGE LIST POINTER. 02525000
ST R1,FRLIST ... 02526000
ST R3,STHRED CLEAR OUT STORAGE THREAD. 02527000
FREE3 L R2,CTLSIZ(R1) GET COUNT VALUE 02528000
LTR R2,R2 AND TEST FOR END OF LIST. 02529000
BZ FREE1 IF END OF LIST BRANCH 02530000
CR R0,R2 COMPARE FOR DESIRED VALUE. 02531000
BE FREE2 YES - FOUND ONE 02532000
BNM FREE4 NO- SAVE STRING WITH HIGHER VALUE 02533000
LTR R3,R3 SEE IF WE HAVE A HIGHER ONE. 02534000
BNZ FREE4 YES - WE DO 02535000
L R3,FSIZE(R1) NO - PICK UP ADDRESS. 02536000
FREE4 LA R1,CTLLEN(R1) GO GET NEXT ELEMENT. 02537000
B FREE3 ... 02538000
SPACE 02539000
FREE2 ST R1,LSTENT SAVE LIST ENTRY. 02540000
L R4,FSIZE(R1) GET FORWARD SIZE POINTER. 02541000
LTR R4,R4 ... 02542000
BZ FREE4 ZERO - NO HIGHER VALUE - GO TO MISC. 02543000
LR R1,R4 SAVE FOR UNZIP. 02544000
SPACE 02545000
FREE6 BAL R10,UNZIP REMOVE FROM ITS LIST (POINTED TO BY 1) 02546000
SPACE 02547000
FREXIT L R2,LSTENT BUMP USAGE COUNTER. 02548000
L R3,CTLCNT(R2) .. 02549000
LA R3,1(R3) ... 02550000
ST R3,CTLCNT(R2) ... 02551000
LM R2,R15,FREREG+8 RESTORE REGISTERS 02552000
LH R0,NREQ RETURN REQUESTED NUMBER ALSO. 02553000
L R14,RETREG RESTORE RETURN REGISTER 02554000
BR R14 EXIT. 02555000
SPACE 02556000
FREE1 L R4,LSTENT CHECK FOR SOMETHING IN LSTENT. 02557000
LTR R4,R4 IS ANYTHING THERE ? 02558000
BNZ *+8 YES - DON'T CHANGE IT. 02559000
ST R1,LSTENT NO - ASSUME GARBAGE REQUEST. 02560000
L R1,FSIZE(R1) ... 02561000
LTR R1,R1 02562000
BNZ FREE9 EXTRACT IF THERE IS 02563000
FREE7A LTR R1,R3 IS THERE ANYTHING IN A LARGER SIZE ? 02564000
BNZ FREE9 YES - EXTRACT FROM THERE. 02565000
SPACE 02566000
FREE7 LR R3,R15 PREPARE TO CALL FOR EXTENSION OF MEMORY. 02567000
L R5,AFRET CALL FREE RETURN. 02568000
L R15,AEXTND CALL FOR EXTENSION. 02569000
BALR R14,R15 ... 02570000
LR R15,R5 ... 02571000
SRA R0,3 NO. OF BYTES TO DOUBLE WORDS. 02572000
BALR R14,R15 ... 02573000
LR R15,R3 RESTORE ADDRESSABILITY 02574000
LH R0,NREQ RELOAD NUMBER REQUESTED 02575000
B FREEX AND CONTINUE FROM START. 02576000
SPACE 02577000
FREE5 L R1,FSIZE(R1) GO DOWN LIST TO FIND LARGER OR EQUAL. 02578000
LTR R1,R1 WAS ANYTHING FOUND. 02579000
BZ FREE7A NO - LIST EMPTY. 02580000
FREE9 L R2,SIZE(R1) GET SIZE OF THIS BEAD. 02581000
CR R0,R2 COMPARE AGAINST REQUEST 02582000
BE FREE6 EQUAL. 02583000
BH FREE5 HIGH. 02584000
SPACE 02585000
FREE8 BAL R10,UNZIP REMOVE TOP SECT. OF LARGER BEAD 02586000
L R2,SIZE(R1) FORM TOP ADDRESS OF NEW BEAD. 02587000
SLR R2,R0 NEW LENGHT 02588000
ST R2,SIZE(R1) SAVE NEW LENGTH OF OLD HOLE. 02589000
LR R4,R0 ... 02590000
SLA R4,3 ... 02591000
LR R3,R1 SAVE REG 1 FOR CALL TO 'FRET' 02592000
AR R1,R4 ... 02593000
L R0,SIZE(R3) RESTORE SIZE OF NEWLY FORMED. 02594000
LR R5,R15 SAVE ADDRESSABILITY AND RETURN 02595000
L R15,AFRET CALL FREE RETURN. 02596000
BALR R14,R15 ... 02597000
LR R15,R5 RESTORE ADDRESSABILITY. 02598000
LR R1,R3 RESTORE ADDRESS TO RETURN TO USER. 02599000
B FREXIT EXIT.. 02600000
SPACE 02601000
EJECT 02602000
********************************************************************** 02603000
* 02604000
* 'FRET' IS CALLED TO RETURN BLOCKS TO FREE STORAGE. 02605000
* ITS OPERATION IS DESCRIBED BELOW--- 02606000
* 02607000
* 'FRET' SEARCHES THROUGH A 'STORAGE' THREAD 02608000
* IN ORDER TO DETERMINE IF THE RETURNED BLOCKS ADJOINS A BLOCK 02609000
* ALREADY IN FREE STORAGE. IF IT IS FOUND TO ADJOIN ON EITHER 02610000
* OR BOTH ENDS, A NEW BLOCK IS FORMED OUT OF THE TWO BLOCKS AND 02611000
* THE PROCESS IS REPEATED. IN THIS WAY, CORE FRAGMENTATION IS 02612000
* AVOIDED AT THE COST OF SOME PROGRAM EFFICIENCY. 02613000
* IF AN ATTEMPT IS MADE TO RETURN A WRONGLY ALIGNED (NOT DOUBLE 02614000
* WORD BOUNDARIED) BLOCK TO FRET, A WAIT STATE PSW WILL BE 02615000
* LOADED (WITH INTERRUPT AND MPX CHANNEL ENABLED) POINTING TO 02616000
* 'FRET'. 02617000
*********************************************************************** 02618000
SPACE 02619000
USING *,R15 ADDRESSABILITY 02620000
SPACE 02621000
FRET STM R0,R15,FRTREG SAVE REGISTERS 02622000
BAL R5,ROUNDUP ROUND UP TO 3 DW BOUNDARY 02623000
N R1,AMASK CLEAR OUT ALL BUT THE ADDRESS. 02624000
TM FRTREG+7,X'07' TEST FOR WRONG ALIGMENT. 02625000
BZ FRETX ALIGNMENT OK. 02626000
SVC 109 DIE... 02627000
FRETAD DC A(FRET) 02628000
SPACE 02629000
FRETX L R2,STHRED PICK UP STORAGE THREAD 02630000
LA R3,FRLIST PICK UP THE ADDRESS OF STHRED. 02631000
N R2,AMASK CLEAR OUT ALL BUT THE ADDRESS 02632000
BNZ FRET1 NO. 02633000
SPACE 02634000
FRET3 SLR R4,R4 ZERO REG. 4 02635000
ST R4,BSIZE(R1) ZERO OUT TOP REGISTER 02636000
ST R4,BSTOR(R1) ... 02637000
ST R4,FSIZE(R1) 02638000
ST R4,FSTOR(R1) 02639000
ST R3,BSTOR(R1) AND SAVE. 02640000
ST R1,STHRED NEW POINTER ADDRESS. 02641000
OI STHRED,X'80' INDICATE SINGLE LENGTH. 02642000
B FRET8 02643000
SPACE 02644000
FRET1 L R2,FSTOR(R3) GET ADDRESS OF NEXT ELEMENT. 02645000
LTR R2,R2 IS THERE ONE THERE 02646000
BZ FRET2 NO - 02647000
CR R1,R2 YES - COMPARE WITH PROVIDED ADDRESS. 02648000
BL FRET2 ELEMENT DOES HERE. 02649000
LR R3,R2 ADVANCE A STAGE 02650000
B FRET1 ... 02651000
SPACE 02652000
FRET2 LR R4,R3 SEE IF NEW ONE SPLICES WITH OLD ONE. 02653000
L R5,SIZE(R3) ... 02654000
SLA R5,3 EXPAND INTO BYTES 02655000
AR R4,R5 FORM TOP ADDRESS OF BACKWARD. 02656000
CR R4,R1 AND COMPARE WITH RETURN ADDRESS. 02657000
BNE FRET6 NO MATCH. 02658000
SRA R5,3 RECOMPRESS LENGTH. 02659000
AR R5,R0 A MATCH - MERGE COUNTS ONLY HERE. 02660000
ST R5,SIZE(R3) ... 02661000
LR R1,R3 ... 02662000
LR R0,R5 NEW SIZE 02663000
BAL R10,UNZIP REMOVE THIS ONE FROM ITS STRING 02664000
B FRETX EXIT 02665000
SPACE 02666000
FRET6 LTR R2,R2 CHECK FOR END OF LIST. 02667000
BZ FRET7A YES - END OF LIST 02668000
LR R4,R1 SEE IF THIS ONE ADJOINS ONE ABOVE 02669000
SLA R0,3 CHANGE DW'S TO BYTES 02670000
AR R4,R0 ... 02671000
SRA R0,3 RECOMPRESS LENGTH 02672000
CR R4,R2 02673000
BNE FRET7 NO MATCH. 02674000
LR R3,R1 SAVE REGISTER 1 02675000
LR R1,R2 AND LOAD REG 2 INTO REG 1 02676000
LR R4,R0 AND SAVE REG 0 ALSO 02677000
L R0,SIZE(R2) GET SIZE OF FORWARD BEAD. 02678000
BAL R10,UNZIP AND REMOVE IT FROM STRING. 02679000
AR R0,R4 GET NEW SIZE OF WHOLE THING. 02680000
LR R1,R3 RETURN REG 1 02681000
B FRETX AND RETURN TO START THE MESS AGAIN. 02682000
SPACE 02683000
FRET7A ST R2,FSTOR(R1) IT GOES AT THE END OF LIST - PATCH IT IN 02684000
ST R1,FSTOR(R3) ... 02685000
ST R3,BSTOR(R1) ... 02686000
B FRET8 02687000
SPACE 02688000
FRET7 LR R4,R1 FORM COMPRESSED ADDRESS OF THIS BEAD. 02689000
L R5,FSTOR(R3) ... 02690000
ST R5,FSTOR(R1) ... 02691000
L R5,BSTOR(R2) ... 02692000
N R5,AMASK CLEAR OUT ALL BUT THE ADDRESS 02693000
ST R5,BSTOR(R1) ... 02694000
ST R4,FSTOR(R3) ... 02695000
ST R4,BSTOR(R2) ... 02696000
SPACE 02697000
FRET8 L R2,FRLIST GET ADDRESS OF CONTROL LIST 02698000
FRET9 L R3,CTLSIZ(R2) GET THE SIZE. 02699000
LTR R3,R3 CHECK FOR ZERO 02700000
BZ FRET10 ZERO - INSERT HERE IN MISCELLANEOUS 02701000
CR R0,R3 COMPARE WITH REQUEST. 02702000
BE FRET10 YES - MATCH 02703000
LA R2,CTLLEN(R2) NO - BUMP POINTER 02704000
B FRET9 ... 02705000
FRET10 L R4,FSIZE(R2) ... 02706000
ST R4,FSIZE(R1) PROCEED TO PATCH IN SIZE SLOT. 02707000
ST R0,SIZE(R1) 02708000
ST R2,BSIZE(R1) 02709000
LTR R4,R4 02710000
BZ *+8 02711000
ST R1,BSIZE(R4) 02712000
ST R1,FSIZE(R2) 02713000
SPACE 02714000
FRTXIT LM R0,R15,FRTREG RELOAD REGISTERS 02715000
BR R14 RETURN TO CALLER 02716000
SPACE 1 02717000
ROUNDUP SLR R2,R2 CLEAR 02718000
LR R3,R0 NUMBER OF DW INTO R3 02719000
LA R3,2(,R3) ROUND TO 3 DW BOUNDARY 02720000
LA R4,3 DIVIDE CONSTANT 02721000
DR R2,R4 FIND NUMBER OF 3 DW FOR THIS REQUEST 02722000
MR R2,R4 CONVERT BACK TO EVEN DIVISOR 02723000
LR R0,R3 THIS IS THE NUMBER WE WILL GET UP 02724000
BR R5 RETURN 02725000
SPACE 02726000
DROP R15 02727000
SPACE 02728000
EJECT 02729000
*********************************************************************** 02730000
* 02731000
* 'FRINIT' IS THE INITIALIZATION ENTRY OF THE FREE STORAGE 02732000
* PACKAGE. WITH IT THE USER PROVIDES A LIST OF STANDARD SIZES 02733000
* WHICH WILL BE USED BY THE FREE STORAGE PACKAGE TO PROVIDE 02734000
* SMALL ACCESS TIMES TO MOST OFTEN USED BLOCK SIZES. THE FORMAT 02735000
* OF THE LIST IS AS FOLLOWS -- 02736000
* 02737000
* DS 0D -ALIGNMENT- 02738000
*LIST EQU * LOCATION OF CONTROL LIST. 02739000
* 02740000
* DC 2D'0' WILL BE USED BY FREE PACKAGE FOR PNTR. 02741000
* DC F'3' DESIGNATION OF SIZE OF THIS STRING 02742000
* DC F'0' WILL BE USED AS COUNTER FOR NUM. OF 02743000
* TIMES REFERENCED. 02744000
* DC D'0' BOUNDARY ALIGNMENT. 02745000
* 02746000
* 02747000
* DC 4D'0' END OF LIST DESIGNATOR. 02748000
* 02749000
*********************************************************************** 02750000
SPACE 02751000
USING *,R15 -ADDRESSABILITY- 02752000
SPACE 02753000
FRINIT STM R0,R15,FREREG SAVE REGISTERS 02754000
ST R1,FRLIST SAVE ADDRESS OF FREE STORAGE CONTROL LIST 02755000
SLR R3,R3 ZERO REG 02756000
ST R3,STHRED ENSURE PROPER STORAGE INITIALIZATION 02757000
FRINI2 L R4,CTLSIZ(R1) GET SIZE OF THIS LIST. 02758000
ST R3,CTLCNT(R1) ZERO OUT VITAL PARTS OF CONTROL LIST. 02759000
ST R3,BSIZE(R1) ... 02760000
LTR R4,R4 SEE IF THIS IS END OF CONTROL LIST 02761000
BZ FRINI1 YES - 02762000
LA R1,CTLLEN(R1) NO - BUMP COUNT 02763000
B FRINI2 GET NEXT ENTRY 02764000
FRINI1 LM R0,R15,FREREG RELOAD REGISTERS 02765000
BR R14 RETURN TO CALLER 02766000
SPACE 02767000
DROP R15 02768000
SPACE 02769000
EJECT 02770000
*********************************************************************** 02771000
* 02772000
* 'UNZIP' IS AN INTERNAL ROUTINE CALLED TO REMOVED 02773000
* THE FREE STORAGE BLOCK POINTED TO BY GPR 1 FROM ITS STRINGS. 02774000
* 02775000
*********************************************************************** 02776000
SPACE 02777000
UNZIP BALR R9,R0 -ADDRESSABILITY- 02778000
USING *,R9 ... 02779000
L R8,BSIZE(R1) REMOVE THIS ELEMENT FROM SIZE STRING 02780000
LR R5,R8 ... 02781000
L R6,FSIZE(R1) ... 02782000
ST R6,FSIZE(R5) ... 02783000
LTR R6,R6 02784000
BZ *+8 BRANCH IF END OF LIST. 02785000
ST R8,BSIZE(R6) .. 02786000
L R8,BSTOR(R1) NOW PATCH STORAGE STRING FOR THIS ELEMENT 02787000
N R8,AMASK REMOVE SIZE BIT. 02788000
LR R5,R8 .. 02789000
L R6,FSTOR(R1) 02790000
ST R6,FSTOR(R5) 02791000
LTR R6,R6 ARE WE AT END OF LIST 02792000
BCR 8,R10 IF YES - RETURN TO CALLER 02793000
ST R8,BSTOR(R6) NO 02794000
BR R10 RETURN TO CALLER 02795000
SPACE 02796000
DROP R9 ADDRESSABILITY 02797000
SPACE 02798000
FREREG DS 16F STORAGE FOR FREE. 02799000
FRTREG DS 16F FRET REGISTER SAVE AREA 02800000
SPACE 02801000
DS 0D -ALIGNMENT- 02802000
FRLIST DS 1F ADDRESS OF FREE CONTROL LIST 02803000
DC F'0' FILLER 02804000
DC F'0' FILLER 02805000
STHRED DC F'0' ADDRESS OF STORAGE THREAD (DOUBLE+4) 02806000
DC F'0' FILLER 02807000
DC F'0' FILLER 02808000
AFRET DC A(FRET) ADDRESS OF FRET 02809000
AEXTND DC A(EXTEND) ADDRESS OF EXTEND ROUTINE 02810000
ONE DC F'1' CONSTANT OF (1) 02811000
NREQ DS 1H NUM. OF DOUBLE WORDS DESIRED (FREE). 02812000
HW3 DC H'3' MINIMUM NUMBER OF DW'S FOR FREE CALL 02813000
SPACE 02814000
DS 0F ALIGNMENT 02815000
AMASK DC X'00FFFFFF' USED TO CLEAR OUT UNWANTED BITS 02816000
RETREG DS 1F RETURN SAVE REGISTER 02817000
LSTENT DS 1F POINTER TO ACTIVE LIST ENTRY. 02818000
FRGARB DC 2D'0' DEFAULT GARBAGE LIST 02819000
OMEGA DC CL160'O' END OF PROGRAM 02820000
DS 0D ALIGEMENT 02821000
IOTA DC CL240'I' INPUT CARD READIN AREA @VA02018 02822000
LTORG @VA08517 02869010
EJECT 02869020
DS 0D @VA08517 02869030
ENTRY L R13,4 ADDRESS OF "ENTRY" @VA08517 02869040
USING ENTRY,R13 ESTABLISH ADDRESSABILITY @VA08517 02869050
LH R1,2 OBTAIN IPL ADDRESS @VA08517 02869060
SRL R1,8 CH PORTION TO LOW ORDER BITS @VA08517 02869070
LA R2,1 INCREMENT @VA08517 02869080
SR R3,R3 CLEAR WORK REG @VA08517 02869090
AR R1,R2 INCREMENT CH NUMBER BY ONE @VA08517 02869100
SHFTLOOP SRDL R2,1 R3 CONTAINS MASK BITS FOR CR2 @VA08517 02869110
BCT R1,SHFTLOOP WHEN THRU... @VA08517 02869120
STCM R3,B'1000',WAIT11 SAVE IN PSW IN CASE CH 0-5 @VA08517 02869130
NI WAIT11,X'FC' ONLY WANT TO SET BITS IF 0-5 @VA08517 02869140
BNZ READY MUST BE CH 0-5 IF BNZ @VA08517 02869150
ST R3,CREG2 CH 6 AND ABOVE, MUST SET UP CR2 @VA08517 02869160
LCTL C2,C2,CREG2 LOAD CREG2 @VA08517 02869170
OI WAIT11,IOMASK TURN ON I/O SUMMARY BIT IN PSW @VA08517 02869180
READY STCM R13,B'0111',CCW+1 SETUP CAW TO READ FROM @VA08517 02869190
LA R1,CCW IPL DEVICE @VA08517 02869200
ST R1,CAW ... @VA08517 02869210
SR R0,R0 CLEAR @VA08517 02869220
LA R1,INTRPT SET UP TO POINT TO I/O NEW PSW @VA08517 02869230
STM R0,R1,NIOPSW FOR RETURN WHEN I/O IS HANDLED @VA08517 02869240
L R3,STOPP STARTING LOAD ADDRESS @VA08517 02869250
LH R8,2 IPL ADDRESS AGAIN @VA08517 02869260
TIO TIO 0(R8) CLEAR CHANNEL @VA08517 02869270
BNZ TIO LOOP IF BUSY @VA08517 02869280
ALLSET SSM *+1 DISABLE ALL I/O @VA08517 02869290
SIO 0(R8) GO AHEAD AND PERFORM I/O @VA08517 02869300
WAITT LPSW WAIT11 NORMAL WAIT PSW @VA08517 02869310
INTRPT TM CCW+4,UC IF UNIT CHECK, ERROR @VA08517 02869320
BO UCLPSW LOAD DISABLED WAIT @VA08517 02869330
TM CSW+4,DE IF DEVICE-END, @VA08517 02869340
BZ WAITT CONTINUE TO WAIT @VA08517 02869350
LM R4,R5,ENTRY PREPARE TO CHECK IF LAST @VA08517 02869360
C R4,ENDX CARD READ; IF YES, BR TO @VA08517 02869370
BER R5 STARTING ROUTINE @VA08517 02869380
MVC 0(72,R3),ENTRY OTHERWISE, MOVE CARD AND @VA08517 02869390
LA R3,72(R3) PREPARE FOR NEXT READ @VA08517 02869400
B ALLSET GO LOOP AGAIN @VA08517 02869410
* 02870000
DS 0D -ALIGNMENT- 02871000
* 02872000
ENDX DC X'02' *** 02873000
DC C'LD' END OF LOADER FLAG 02874000
DC X'02' ... 02875000
* 02876000
STOPP DC A(ALPHA) STARTING LOAD ADDRESS. 02877000
* 02878000
* 02879000
ORG ENTRY+160 ORG FOR THIRD CARD @VA02018 02880000
* 02881000
CARD3 DC X'02' IPL CCW TO READ 1ST BOOTSTRP CARD@VA02018 02882000
DC AL3(IOTA) @VA02018 02883000
DC X'60000050' @VA02018 02884000
CRD3CCW2 DC X'02' IPL CCW TO READ 2ND BOOTSTRP CARD@VA02018 02885000
DC AL3(IOTA+80) @VA02018 02886000
DC X'20000050' @VA02018 02887000
* 02888000
UCLPSW LPSW DISABW LOAD DISABLED WAIT PSW WITH UNIT @VA02018 02889000
* CHECK ERROR CODE 02890000
* 02891000
DS 0D ALIGNMENT @VA02018 02892000
WAIT11 DC X'FF020000' ENABLED WAIT PSW @VA02018 02893000
TOPX DC AL1(2),AL3(ENTRY) @VA02018 02894000
DISABW DC X'00020000' DISABLED WAIT PSW @VA02018 02895000
DC X'22222222' UNIT CHECK ERROR CODE @VA02018 02896000
* 02896100
CREG2 DS F WORK AREA FOR CREG2 @VA08517 02896200
CCW CCW 2,0,SILI,80 READ TAPE CCW @VA08517 02896300
LTORG (IF ANY) @VA03812 02897000
TOTLSIZE EQU *-RELDR TOTAL SIZE OF LOADER @VA03812 02898000
* 02899000
ORG ENTRY+240 RESERVE SPACE FOR 3 CARDS @VA02018 02900000
* 02901000
DROP 13 @VA02018 02902000
EJECT 02903000
XTRBLOK DSECT 02904000
XTRPNT DS 1F POINTER TO NEXT XTRBLOK 02905000
XTRLINE DS 1F ADDRESS OF DATA TO PRINT 02906000
XTRLEN DS 1H NUMBER OF BYTES PRESENTLY IN USE 02907000
DS 1H FILLER 02908000
DS 1F FILLER 02909000
XTRDATA DS CL96 EXTRN DATA ENTRIES 02910000
XTRDATAL EQU L'XTRDATA NUMBER OF BYTES TO CLEAR 02911000
XTRFULL EQU 84 MAX. NUMBER OF BUFFER PRINT POSITIONS 02912000
DS 0D FORCE ALIGNMENT 02913000
XTRSIZE EQU (*-XTRBLOK)/8 NUMBER OF DOUBLE WORDS OF BLOK. 02914000
SPACE 2 02915000
COPY EQU 02916000
END LDRGEN 02917000