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