TITLE DIO V17 -- DISK INPUT OUTPUT PROGRAM 0001.000 PROGRAM DIO 17 0002.000 * 0003.000 DEF FCBINIT FILE CONTROL BLOCK INITIALIZE 0004.000 *= SUBROUTINE FCBINIT (LFC, PBLK, FUNC, RECLEN, *ERR, *NOWAIT) 0005.000 * INTEGER LFC logical file code 0006.000 * INTEGER PBLK(4) parameter block to be filled 0007.000 * INTEGER FUNC function code for FCB 0008.000 * INTEGER RECLEN length of record for blocking 0009.000 * ADDRESS ERR error return address 0010.000 * ADDRESS NOWAIT no wait normal return address 0011.000 *= Initialize the parameter block for future reads and writes 0012.000 SPACE 3 0013.000 DEF DPWRITE NO-WAIT I/O COMPLETE SECTOR WRITE 0014.000 *= SUBROUTINE DPWRITE (PBLK, BUFFER, COUNT, RECORD, *ERR, *NOWAIT) 0015.000 * INTEGER PBLK(4) parameter block 0016.000 * * BUFFER buffer to write (int *1,2,4,char) 0017.000 * INTEGER COUNT count of bytes to write 0018.000 * INTEGER RECORD record number to write to 0019.000 *= Write unblocked to device/file defined by PBLK 0020.000 SPACE 3 0021.000 DEF DPREAD NO-WAIT I/O COMPLETE SECTOR READ 0022.000 * INTEGER PBLK(4) parameter block to be filled 0023.000 *= SUBROUTINE DPREAD (PBLK, BUFFER, COUNT, RECORD, *ERR, *NOWAIT) 0024.000 *= Read unblocked from device/file defined by PBLK 0025.000 DEF DWRITE WAIT I/O PARTIAL SECTOR WRITE 0026.000 * INTEGER PBLK(4) parameter block to be filled 0027.000 *= SUBROUTINE DWRITE (PBLK, BUFFER, COUNT, RECORD, *ERR, *NOWAIT) 0028.000 *= Write blocked to a file defined by PBLK 0029.000 DEF DREAD WAIT I/O PARTIAL SECTOR READ 0030.000 *= SUBROUTINE DREAD (PBLK, BUFFER, COUNT, RECORD, *ERR, *NOWAIT) 0031.000 * INTEGER PBLK(4) parameter block to be filled 0032.000 *= Read blocked from a file defined by PBLK 0033.000 DEF DERROR RETURN ERROR CODES 0034.000 *= INTEGER FUNCTION DERROR (PBLK) 0035.000 *= Return status of last io on the PBLK 0036.000 DEF DPCOUNT COUNT OF BYTES TRANSFERED 0037.000 *= INTEGER FUNCTION DPCOUNT (PBLK) 0038.000 *= Return byte count of last io transfer on the PBLK 0039.000 PAGE 0040.000 * 0041.000 * AUTHOR: A D PATEL DATE: 1982 0042.000 * REVISIONS: 0043.000 * X14 L. TATE (4/29/84) 0044.000 * -NO WAIT IO DOES NOT CHECK ERROR OF PREVIOUS ATTEMPT 0045.000 * -ENTRY DERROR ADDED TO RETURN ERROR CODE (REENTRANT) 0046.000 * X15 L. TATE (7/5/84) 0047.000 * -DATA BUFFER MAY BE IN EXTENDED MEMORY. 0048.000 * X15.1 L. TATE (9/5/84) 0049.000 * -THE FORMAT BIT IS NOW CLEARED ON BYTE BUFFERS 0050.000 * X16 L. TATE (1/7/85) 0051.000 * -ALLOW LOCAL ERROR/END ACTION RETURNS 0052.000 * X16.1 LTATE (4/15/85) 0053.000 * -REARRANGED ERROR TESTING SO EOF WILL BE DETECTED. 0054.000 * X16.2 LTATE (5/13/85) 0055.000 * -ENSURED EXTENDED ADDRESSING WAS CANCELED WHEN SET. 0056.000 * X17 LTATE (5/27/85) 0057.000 * -RETURN TRANSFER COUNT AS FUNCTION VALUE 0058.000 * 0059.000 * 0060.000 * TO USE THESE FUNCTIONS INCLUDE $OBJECT 0061.000 * $SELECTF ^(SEMS)O.DIO15 0062.000 * 0063.000 * THIS SET OF PROGRAMS CAN BE CALLED 0064.000 * FROM FORTRAN BY THE FOLLOWING CSQ'S 0065.000 * 0066.000 * CALL FCBINIT (LU ,PBLK ,FUNC ,RECLN,$NN,$NN1) 0067.000 * CALL DREAD (PBLK ,BUFFER,BYTECNT,RECNO,$NN,$NN1)!WAIT I/O 0068.000 * CALL DPREAD (PBLK ,BUFFER,BYTECNT,RECNO,$NN,$NN1)!NO_WAIT I/O 0069.000 * CALL DWRITE (PBLK ,BUFFER,BYTECNT,RECNO,$NN,$NN1)!WAIT I/O 0070.000 * CALL DPWRITE (PBLK ,BUFFER,BYTECNT,RECNO,$NN,$NN1)!NO_WAIT I/O 0071.000 * ERROR = DERROR(PBLK) !ERROR CHECK 0072.000 * COUNT = DPCOUNT(PBLK) !BYTE COUNT 0073.000 * 0074.000 * BYTECNT= INTEGER*4; # OF BYTES FOR THIS I/O 0075.000 * 0076.000 * LU = INTEGER*4; NO-CHARACTER ARGUMENTS ALLOWED 0077.000 * PLEASE DEFINE LU AS A PARAMETER SUCH THAT 0078.000 * IT CAN BE REASSIGNED TO DIFFRNT DEVICE EASE0079.000 * PBLK = INTEGER*4; PBLK(4); PBLK FOR FCB ADDRS STOR  ERR STAT0080.000 * 0081.000 * PBLK(1); FCB ADDRESS STORAGE LOCATION 0082.000 * PBLK(2); NOT USED (SPARE) 0083.000 * PBLK(3); NOT USED (SPARE) 0084.000 * PBLK(4); ERROR STATUS AS SPECIFIED BELOW 0085.000 * 0086.000 * PBLK(4)= ERROR STATUS; FOLLOWING CODES ARE IMPLEMENTED 0087.000 * 0088.000 * 0 = I/O COMPLETE WITHOUT ERROR 0089.000 * 1 = REC # .LE. 0 0090.000 * 2 = BYTECNT .LE. 0 0091.000 * 3 = EOF 0092.000 * 4 = EOM 0093.000 * 5 = RECORD LENGTH .LT. 0 0094.000 * 0095.000 * BUFFER = DATA BUFFER IN INTEGER OR CHARACTER FORMAT 0096.000 * MAY BE IN EXTENDED MEMORY 0097.000 * 0098.000 * BYTECNT # OF BYTES FOR THIS TRANSFER 0099.000 * 0100.000 * RECNO RECORD # FOR THIS I/O 0101.000 * 0102.000 * FUNC INTEGER*4 ; FUNC DATA/8Z0A000000/ 0103.000 * REFER TO TABLE 7_4 OF MPX2.1 VOL 1, 0104.000 * PAGE 7-33 FOR DETAILS ON THESE BITS 0105.000 * BIT ASSIGNMENT: NO_WAIT I/O SPECIFICATION BIT 0 0106.000 * NO ERROR RETURN PROCESSING BIT 1 0107.000 * BINARY TRANSFER DFI BIT 2 0108.000 * NO STATUS CHECK BY HANDLER BIT 3 0109.000 * RANDOM ACCESS BIT 4 0110.000 * BLOCKED I/O (DISC  TAPE) BIT 5 0111.000 * EXPANDED FCB (MUST BE ON) BIT 6 0112.000 * TASK WILL NOT ABORT BIT 7 0113.000 * DEVICE FORMAT DEFINATION BIT 8 0114.000 * 0115.000 * $NN = FATAL ERROR RETURN CHECK ENTIRE WORD  REFER TO 0116.000 * MPX2.1 VOLM 1.; FIG: 7-3; TABLE 7-4; FCB BIT INTERP 0117.000 * *NOTE* CAN BE SPECIFIED AT READ/WRITE CALL, BUT 0118.000 * FUTURE CALLS USE LAST SUPPLIED VALUE. 0119.000 * 0120.000 * $NN1 = NO_WAIT I/O NORMAL RETURN STATEMENT LABEL; AFTER THIS 0121.000 * LABLE YOU MUST HAVE ( CALL X:XNWIO) TO TERMINATE 0122.000 * NO_WAIT I/O. 0123.000 * *NOTE* CAN BE SPECIFIED AT READ/WRITE CALL, BUT 0124.000 * FUTURE CALLS USE LAST SUPPLIED VALUE. 0125.000 * 0126.000 * 0127.000 * 0128.000 * The DREAD  DRITE routines can be used to perform I/O to disk 0129.000 * files where record length are such that FORTRAN random 0130.000 * access routines cannot be used; (e.g. record length > 248 0131.000 * bytes). These routines perform BLOCKING of data within the 0132.000 * physical sector and has minimum overhead for the operation. 0133.000 * 0134.000 * 0135.000 * The DPREAD  DPWRITE routines are general purpose I/O 0136.000 * functions to perform I/O operations to any device. The FUNC 0137.000 * word defines the type of operation that the routine will 0138.000 * accomplish. It is totaly dependent on the functions implemented0139.000 * by the specific device driver. User can perform I/O in wait 0140.000 * mode or no-wait mode. If the user wants to perform no-wait I/O 0141.000 * he has to have $NN1; end action receiver established. The 0142.000 * example of no-wait I/O is as follows: 0143.000 * 0144.000 * CALL FCBINIT (LFC,PBLK,FUNC,RECLN,$NN,$NN1) 0145.000 * 0146.000 * 10 CONTINUE 0147.000 * 0148.000 * CALL DPWRITE (PBLK,BUF,BYTECNT, irec ) ! irec option for random0149.000 * access disk files only0150.000 * 0151.000 * 0152.000 * any FORTRAN or ASSEMBLY code 0153.000 * 0154.000 * nn1 CONTINUE 0155.000 * 0156.000 * Any code including I/O to same LFC or any other 0157.000 * device. The I/O to the same LFC shold be before 0158.000 * the following X:XNWIO function. 0159.000 * 0160.000 * CALL X:XNWIO 0161.000 * 0162.000 * 0163.000 * 0164.000 * 0165.000 * REV 1.1 BY A. PATEL IMPELMET CHECKING OF NO WAIT BIT 0166.000 * TO BYPASS ERROR CHECKING FOR LAST I/O 0167.000 * ALSO ADD CODE TO CHECK ERR AT THE COMLETION OF I/O 0168.000 * IF THE WAIT BIT IS SET 0169.000 * 0170.000 * REV 14.0 BY L.TATE IMPLEMENT DERROR ROUTINE 0171.000 * 0172.000 * ERROR = DERROR(PBLK) 0173.000 * 0174.000 * REENTRANT.... CAN BE CALLED FROM THE 0175.000 * ERROR AND END ACTION HANDLERS. 0176.000 * 0177.000 * ERROR CODES: 0178.000 * 0179.000 * 0 - NO ERROR 0180.000 * 1 - REC # .LE. 0 0181.000 * 2 - BYTECNT .LE. 0 0182.000 * 3 - EOF 0183.000 * 4 - EOM 0184.000 * 5 - RECORD LENGTH .LT. 0 0185.000 * 6 - INVALID BLOCKING BUFFER 0186.000 * 7 - WRITE PROTECT 0187.000 * 8 - INOPERABLE DEVICE 0188.000 * 9 - BEGINNING OF MEDIUM 0189.000 * 0190.000 * REV 15.0 BY L.TATE EXTENDED MEMORY BUFFER CAPABILITY 0191.000 * REV 15.1 BY L.TATE CORRECTED CHARACTER ADDRESS MASKING 0192.000 * REV 16 BY L.TATE ADDED LOCAL ERROR/END ACTION RETURNS. 0193.000 * 0194.000 * 0195.000 PAGE 0196.000 * 0197.000 * EXTERNAL REFERENCES 0198.000 * 0199.000 EXT R.EF POINTER TO # PARMS IN BL 0200.000 EXT E.RR ERROR PROCESSOR 0201.000 EXT I.IO15 GET FCB + CHECKS 0202.000 EXT N.X USER'S RETURN ADDRESS 0203.000 EXT R.X ALTERNATE RETURN ADDRESS 0204.000 EXT F.F FLAGS FOR I/O INITIALIZATION 0205.000 EXT N.CL USER'S CALL ADDRESS 0206.000 EXT F.C CURRENT FCB ADDRESS 0207.000 EXT REQ.PARM REQUIRED PARAMETER PROCESSOR 0208.000 EXT OPT.ADDR OPTIONAL ADDRESS PROCESSOR 0209.000 EXT REQ.ADDR REQUIRED ADDRESS PROCESSOR 0210.000 * EXT P_BLOCK 192W TEMPARARY WORK BUFFER 0211.000 PAGE 0212.000 * 0213.000 * EQUATES 0214.000 * 0215.000 M.EQUS GENERAL EQUATES 0216.000 M.TBLS EQUATES FOR ALL TABLES 0217.000 SPACE 3 0218.000 * 0219.000 * 0220.000 RANACCRL EQU 1W RANDOM ACCESS RECOD LENGTH STORED IN 0221.000 PBK.SFLG EQU 3W PARAMETER BLOCK ERROR STATUS 0222.000 BUFADDR EQU 2W BUFERR ADDRES POINTER IN ARG 0223.000 PBKADDR EQU 1W PARAMETER BLOCK POINTER IN ARG 0224.000 FTN.I EQU 0 INDIRECT BIT OF FORTRAN PARAMETER 0225.000 FTN.X EQU 1 INDICATES ADDRESS IS 24 BITS LONG 0226.000 * 0227.000 * ERROR CODES 0228.000 * 0229.000 NOERR EQU 0 NO ERROR 0230.000 RECNERR EQU 1 RECORD #.LT. 0 0231.000 BCNTERR EQU 2 TRANSFER COUNT .LT. 0 0232.000 EOFERR EQU 3 EOF 0233.000 EOMERR EQU 4 EOM 0234.000 RECLERR EQU 5 RECORD LENGTH .LT. 0 0235.000 BB.ERR EQU 6 INVALID BLOCKING BUFFER 0236.000 PRO.ERR EQU 7 WRITE PROTECT VIOLATION 0237.000 INOP.ERR EQU 8 DEVICE IS INOPERABLE 0238.000 BOM.ERR EQU 9 BEGINNING OF MEDIUM 0239.000 PAGE 0240.000 * 0241.000 * LOCAL MEMORY 0242.000 * 0243.000 BOUND 1W 0244.000 BLKSIZE DATAW 768 BYTES IN A SECTOR 0245.000 X1SAVE DATAW 0 SAVE OF PARAMETER POINTER 0246.000 ACW A(LFC) NEEDED FOR I.IO15 0247.000 LFC DATAW 0 0248.000 XMASK DATAW X'FFFFFF' 24 BIT ADDRESS MASK 0249.000 WMASK DATAW X'0007FFFF' DATA BUFFER MASK; NO EXTENDED ADDRESS0250.000 UBA DATAW 0 USER BUFFER ADDRESS STORAGE 0251.000 TC DATAW 0 USER REQUESTED TRANSFER COUNT IN BYTE0252.000 RN DATAW 0 USER REQUESTED RECORD # 0253.000 BSA DATAW 0 SECTOR # FORM ORIGIN OF THE DISC FILE0254.000 SWN DATAW 0 RELATIVE WIDTH OF PARTIAL SECTOR I/O 0255.000 PBLKA DATAW 0 TEMP STORAGE FOR PBLK ADDRESS 0256.000 FLAG DATAH 0 0257.000 B0.FLAG EQU 0 FLAG 0258.000 B1.FLAG EQU 1 DIRECT PROCEED I/O READ/WRITE FLAG 0259.000 X.FLAG EQU 2 THE BUFFER IS IN EXTENDED MEMORY 0260.000 COUNT RES 1W COUNT OF BYTES TRANSFERED 0261.000 P_BLOCK RES 192W 192W TEMPARARY WORK BUFFER 0261.100 PAGE 0262.000 BOUND 1W 0263.000 FCBINIT EQU $ 0264.000 TRR R0,X1 SAVE R0 FOR ARG POINTER 0265.000 LW R7,0W,X1 GET # PARMS 0266.000 ABR R7,29 BUMP BY 4 FOR RETURN LOCATION 0267.000 ADR R7,R0 FIND RETURN LOCATION 0268.000 STD R0,N.X * ERROR EXITS 0269.000 STW X1,X1SAVE SAVE X1 FOR LATER USE 0270.000 BL REQ.PARM GET LFC 0271.000 STW R7,LFC SAVE LFC 0272.000 LA X1,X1SAVE PUT ADDRESS # OF PARAMETERS IN X1 0273.000 LI R7,1 0274.000 STB R7,F.F 0275.000 BL I.IO15 FIND FCB ADDRESS 0276.000 LW X1,X1SAVE RESTORE ARG POINTER IN X1 0277.000 STW X3,*2W,X1 SAVE FCB ADDRESS FOR LATER USE 0278.000 LA R5,*5W,X1 ERROR SUB ADDR TO R5 0279.000 ANMW R5,WMASK STRIP HIGH BITS 0280.000 STW R5,FCB.ERRT,X3 PUT ERR ADDR AT FCB(6) 0281.000 LW R6,*3W,X1 GET EFUNCTION CODE  PUT IT IN FCB(2)0282.000 STW R6,FCB.CBRA,X3 STORE AT GENERAL CONTROL SPEC 0283.000 TBR R6,4 IS THIS RAN ACCESS RECORD 0284.000 BNS FCB.1 NO RECL-LENGTH FOR THIS I/O 0285.000 LW R7,*4W,X1 GET RECORD LENGHT 0286.000 BCT LE,RELRTRN RECORD LENGTH .LT. 0 0287.000 STW R7,RANACCRL,X3 STORE RANDOM ACCESS RECL-LENGTH IN 1W0288.000 BU FCB.2 0289.000 * 0290.000 FCB.1 EQU $ 0291.000 ZMW RANACCRL,X3 CLEAR THE RANDOM ACCESS STORAGE 0292.000 * 0293.000 FCB.2 EQU $ 0294.000 TBR R6,0 IS IT A NO WAIT I/O 0295.000 BNS FCB.3 BY PASS STUFFING NO WAIT DATA 0296.000 STW R5,FCB.NWER,X3 PUT NO_WAIT ERROR RETURN ADDRESS IN F0297.000 LA R5,*6W,X1 GET THE NORMAL RETURN ADDRESS 0298.000 ANMW R5,WMASK MASK OUT HI LOW BITS 0299.000 STW R5,FCB.NWOK,X3 PUT NO_WAIT NORMAL RETURN ADDRESS 0300.000 * 0301.000 FCB.3 EQU $ 0302.000 BU *N.X 0303.000 PAGE 0304.000 * 0305.000 * DPWRITE ENTRY POINT 0306.000 * 0307.000 BOUND 1W 0308.000 DPWRITE EQU $ 0309.000 SBM B1.FLAG,FLAG SET WRITE IND 0310.000 BU DP.01 COMMON ROUTINE 0311.000 SPACE 3 0312.000 * 0313.000 * DPREAD ENTRY POINT 0314.000 * 0315.000 DPREAD EQU $ 0316.000 ZBM B1.FLAG,FLAG CLEAR WRITE IND 0317.000 SPACE 3 0318.000 DP.01 EQU $ 0319.000 TRR R0,X2 PUT LIST POINTER INTO X2 0320.000 ABR R0,29 +1W FOR ARG CNT 0321.000 ADMW R0,0W,X2 ADD # OF LIST BYTES 0322.000 STD R0,N.X SAVE RETURN ADDRESS 0323.000 BL SETUP SETUP ARGUMENTS FOR THIS CALL 0324.000 LW R5,UBA GET USER BUFFER ADDRESS 0325.000 STW R5,FCB.ERWA,X1 STORE BUFFER ADDRESS IN FCB 0326.000 LW R6,TC LOAD TRANSFER COUNT 0327.000 STW R6,FCB.EQTY,X1 STORE BYT CNT IN FCB(9) 0328.000 TBM 4,FCB.GCFG,X1 IS IT A RANDOM ACCESS I/O 0329.000 BNS $+3W BYPASS STORING OF RANDOM ACCESS ADR. 0330.000 LW R7,BSA GET SECTOR # 0331.000 STW R7,FCB.ERAA,X1 STORE IT IN RANDOM ACESS ADDRESS 0332.000 TBM B1.FLAG,FLAG TEST R/W FLAG 0333.000 BCT SET,WRIT BR IF WRITE 0334.000 SVC 1,X'31' READ RECORD SVC 0335.000 BU DP.1 RETURN TO CALLER 0336.000 WRIT SVC 1,X'32' WRITE RECORD SVC 0337.000 * 0338.000 DP.1 EQU $ 0339.000 TBM 0,FCB.GCFG,X1 IS IT A NO_WAIT I/O ? 0340.000 BS $+2W BYPASS ERROR CHECKING  RTRN TO CALLE0341.000 BL CHKERR CHECK IF ANY ERROR DURING PREVIOUS I/0342.000 BU *N.X RETURN TO CALLER 0343.000 PAGE 0344.000 * 0345.000 * DREAD ENTRY POINT 0346.000 * 0347.000 BOUND 1W 0348.000 DREAD EQU $ 0349.000 TRR R0,X2 PUT LIST POINTER INTO X2 0350.000 ABR R0,29 +1W FOR ARG CNT 0351.000 ADMW R0,0W,X2 ADD # OF LIST BYTES 0352.000 STD R0,N.X SAVE RETURN ADDRESS 0353.000 BL SETUP SETUP WORK AREA 0354.000 DREAD.1 LW R6,TC GET TRANSFER COUNT 0355.000 BCT LE,*N.X EXIT IF NEG OR ZERO 0356.000 LW R5,SWN GET STARTING WD NUMBER 0357.000 BCF ZR,DREAD.2 BR IF NOT START OF SECT 0358.000 LW R5,UBA START OF SECT, GET BUFFER ADDR 0359.000 STW R6,FCB.EQTY,X1 PUT BYTE COUNT IN FCB(9) 0360.000 STW R5,FCB.ERWA,X1 STORE ADDRESS IN FCB(8) 0361.000 LW R5,BSA GET STARTING SECT NO 0362.000 STW R5,FCB.ERAA,X1 PUT IN FCB(10) 0363.000 SVC 1,X'31' READ FILE 0364.000 BL DWAIT WAIT FOR I/O COMP 0365.000 BU *N.X RETURN 0366.000 DREAD.2 LA R5,P_BLOCK GET TEMP WORK BUF ADDRESS 0367.000 STW R5,FCB.ERWA,X1 PUT IN FCB 0368.000 LW R6,BLKSIZE GET BLKSIZE IN BYTES 0369.000 STW R6,FCB.EQTY,X1 PUT IT IN FCB(9) 0370.000 LW R5,BSA GET SECT ADDR 0371.000 STW R5,FCB.ERAA,X1 PUT SECT ADDRESS IN FCB(10) 0372.000 ABM 31,BSA BUMP SECTOR ADDR 0373.000 SVC 1,X'31' READ A SECT 0374.000 BL DWAIT WAIT FOR I/O COMP 0375.000 LNW R5,BLKSIZE GET MAX BYT CNT 0376.000 ADMW R5,SWN ONLY REST OF BUFFER FOR TRANSFER 0377.000 LA X3,P_BLOCK GET BUFFER ADDR 0378.000 ADMW X3,SWN POINT TO START WD 0379.000 LW X2,UBA GET USER BUFFER ADDR 0380.000 LW R4,TC GET TRANSFER COUNT 0381.000 ZMW SWN ZERO START WD NO 0382.000 TBM X.FLAG,FLAG TEST FOR EXTENDED MEMORY 0383.000 BNS DREAD.3 SKIP OVER EXTENDED ADDRESSING 0384.000 SEA SET EXTENDED ADDRESSING 0385.000 DREAD.3 LB R6,0B,X3 GET BYTE 0386.000 STB R6,0B,X2 PUT BYTE 0387.000 SUI R4,1 REDUCE TC 0388.000 BZ DREAD.4 RETURN IF COMPLETE 0389.000 STW R4,TC UPDATE LOCN 0390.000 ABR X3,31 BUMP ADDR 0391.000 ABR X2,31 BUMP ADDRE 0392.000 ABM 31,UBA BUMP USER BUFFER ADDR 0393.000 BIB R5,DREAD.3 LOOP UNTIL TRANSFER COMP 0394.000 CEA CANCEL WHEN MOVE DONE, SET OR NOT 0395.000 BU DREAD.1 GO GET REST OF DATA 0396.000 DREAD.4 EQU $ 0397.000 CEA CANCEL EXTENDED ADDRESSING ON EXIT 0398.000 BU *N.X RETURN 0399.000 PAGE 0400.000 * 0401.000 * DERROR 0402.000 * 0403.000 BOUND 1W 0404.000 DERROR EQU $ 0405.000 LW X2,0,X1 GET FCB ADDRESS 0406.000 LW R5,FCB.SFLG,X2 GET FCB STATUS 0407.000 TBR R5,2 BLOCKING BUFFER 0408.000 BS DERR.2 0409.000 TBR R5,3 WRITE PROTECT 0410.000 BS DERR.3 0411.000 TBR R5,4 DEVICE INOPERABLE 0412.000 BS DERR.4 0413.000 TBR R5,5 BEGINNING OF MEDIUM 0414.000 BS DERR.5 0415.000 TBR R5,6 EOF 0416.000 BS DERR.6 0417.000 TBR R5,7 EOM 0418.000 BS DERR.7 0419.000 TBR R5,1 ERROR 0420.000 BNS DERR.1 NO ERROR FOUND 0421.000 SLL R5,10 STRIP OUT PRE 0422.000 SRL R5,10 PUT BACK 0423.000 TRN R5,R7 RETURN IT 0424.000 BU DERR.99 RETURN 0425.000 DERR.1 EQU $ 0426.000 LW R7,PBK.SFLG,X1 GET ANY PBLK ERRORS 0427.000 BU DERR.99 0428.000 DERR.2 EQU $ 0429.000 LI R7,BB.ERR BLOCKING ERROR 0430.000 BU DERR.99 0431.000 DERR.3 EQU $ 0432.000 LI R7,PRO.ERR PROTECT ERROR 0433.000 BU DERR.99 0434.000 DERR.4 EQU $ 0435.000 LI R7,INOP.ERR INOPERABLE 0436.000 BU DERR.99 0437.000 DERR.5 EQU $ 0438.000 LI R7,BOM.ERR BEGINNING OF MEDIUM 0439.000 BU DERR.99 0440.000 DERR.6 EQU $ 0441.000 LI R7,EOFERR EOF 0442.000 BU DERR.99 0443.000 DERR.7 EQU $ 0444.000 LI R7,EOMERR 0445.000 BU DERR.99 0446.000 DERR.99 EQU $ 0447.000 TRSW R0 RETURN 0448.000 PAGE 0449.000 * 0450.000 * DPCOUNT RETURN COUNT OF BYTES TRANSFERED IN LAST READ 0451.000 * 0452.000 BOUND 1W 0453.000 DPCOUNT EQU $ 0454.000 LW X2,0,X1 GET FCB ADDRESS 0455.000 BZ DPCNT.Z NOT A PROPER PBLK YET 0456.000 TBM 0,3W,X2 TEST FOR OPERATION IN PROGRESS 0457.000 BS DPCNT.Z NOT VALID COUNT YET 0458.000 LW R7,4W,X2 GET BYTE COUNT 0459.000 TRSW R0 0460.000 DPCNT.Z EQU $ 0461.000 ZR R7 NOTHING TO RETURN 0462.000 TRSW R0 0463.000 PAGE 0464.000 * 0465.000 * 0466.000 * GET ARGUMENTS AND FIND SECTOR # 0467.000 * 0468.000 * 0469.000 BOUND 1W 0470.000 SETUP EQU $ 0471.000 LW X1,*PBKADDR,X2 GET FCB ADDR 0472.000 LA X3,*PBKADDR,X2 GET ADDRESS OF PARAMETERS BLOCK 0473.000 STW X3,PBLKA STORE PBLK ADDRESS FOR ERR REPORTING 0474.000 ZMW PBK.SFLG,X3 ZERO PREVIOUS ERRORS 0475.000 ZMW FCB.SFLG,X1 ZERO PREVIOUS ERRORS 0476.000 SPACE 3 0477.000 * 0478.000 * BUFFER MAY BE IN EXTENDED MEMORY, MUST MANUALLY GO DOWN 0479.000 * INDIRECT CHAIN TILL REACHED. 0480.000 * 0481.000 TBM FTN.I,BUFADDR,X2 TEST FOR PARAMETER WORD 0482.000 BNS SETUP.3 NORMAL PARAMETER 0483.000 SPACE 3 0484.000 * 0485.000 * EXTENDED ADDRESS TYPE 0486.000 * 0487.000 SBM X.FLAG,FLAG NOTE EXTENDED BUFFER 0488.000 LW X3,BUFADDR,X2 PARAMETER WORD 0489.000 LW X3,0,X3 GET FIRST ADDRESS 0490.000 SETUP.1 EQU $ 0491.000 TBR X3,FTN.I TEST FOR PSEUDO-INDIRECT 0492.000 BNS SETUP.2 END OF LOOK 0493.000 LW X3,0,X3 NEXT WORD IN CHAIN 0494.000 BU SETUP.1 LOOP 0495.000 SETUP.2 EQU $ 0496.000 TRR X3,R6 PUT LIKE REST 0497.000 ANMW R6,XMASK MASK OUT NON-ADDRESS DATA 0498.000 ANMW X3,=X'0F000000' CLEAR OUT REST 0499.000 SRL X3,24 ISOLATE BYTE 0500.000 TRR X3,R5 PUT IN 5 FOR TESTING 0501.000 LW X3,PBLKA GET BACK THE PBLK ADDRESS 0502.000 BU SETUP.4 CONTINUE 0503.000 SPACE 3 0504.000 * 0505.000 * NORMAL BUFFER ADDRESS FETCH 0506.000 * 0507.000 SETUP.3 EQU $ NORMAL ARGUMENT PROCESSING 0508.000 ZBM X.FLAG,FLAG NOTE NON-EXTENDED BUFFER 0509.000 LA R6,*BUFADDR,X2 GET CONTENT OF BUF ADDRESS LOCATION 0510.000 ANMW R6,WMASK MASK OUT UNWANTED DATA 0511.000 LB R5,BUFADDR,X2 GET DATA TYPE OF BUFFER 0512.000 SPACE 3 0513.000 * 0514.000 * TEST FOR TYPING NOW 0515.000 * 0516.000 SETUP.4 EQU $ 0517.000 CI R5,X'B' IS IT CHARCTER TYPE 0518.000 BNE SETUP.5 NO, IT IS NOT CHARCTER 0519.000 ADI X2,4 ADJUST ARG PTR FOR DBL WRD ARG 0520.000 SETUP.5 EQU $ 0521.000 CI R5,X'01' IS IT INTEGER*2 ARG 0522.000 BNE SETUP.6 NO, IT IS NOT INTEGRE*2 0523.000 ZBR R6,31 CLEAR C BIT 0524.000 SETUP.6 EQU $ 0525.000 STW R6,UBA STORE IT 0526.000 LW R6,*3W,X2 GET BYTE COUNT 0527.000 BCT LE,TCERR IF ZERO, RETURN 0528.000 STW R6,TC SAVE 0529.000 TBM 4,FCB.GCFG,X1 IS THIS A RANDOM ACCESS I/O 0530.000 BNS SETUP.7 NO NEED TO CALCULATE 0531.000 LW R7,*4W,X2 GET REL REC NO 0532.000 BCT LE,RNERR IF ZERO, RETURN 0533.000 STW R7,RN SAVE RECORD NUMBER 0534.000 SUI R7,1 CALCULATE 0535.000 MPMW R6,RANACCRL,X1 GET RECL-LN  MPMW TO GET POSITION 0536.000 DVMW R6,BLKSIZE PHYSICAL 0537.000 STW R7,BSA SECTOR NUM, 0538.000 STW R6,SWN REL WD WITH SECTOR 0539.000 SPACE 3 0540.000 * 0541.000 * GET OPTIONAL ERROR RETURN AND END ACTION ADDRESSES X16 0542.000 * 0543.000 SETUP.7 EQU $ 0544.000 ADI X2,5W BUMP PARAMETER POINTER TO ERROR RET 0545.000 CAMW X2,N.X IS THERE AN ERROR RETURN? 0546.000 BGE SETUP.8 NO, USE PREVIOUS 0547.000 LA R7,*0,X2 GET ADDRESS 0548.000 STW R7,FCB.ERRT,X1 PUT IN WAIT ERROR RETURN 0549.000 TBM 0,FCB.GCFG,X1 NO WAIT I/O 0550.000 BNS SETUP.8 DO NOT SETUP NO WAIT RETURN 0551.000 STW R7,FCB.NWER,X1 PUT IN NO-WAIT ERROR RETURN 0552.000 SETUP.8 EQU $ 0553.000 ADI X2,1W BUMP PARAMETER POINTER TO NORMAL RET 0554.000 CAMW X2,N.X IS THERE A NORMAL RETURN? 0555.000 BGE SETUP.9 NO, USE PREVIOUS 0556.000 LA R7,*0,X2 GET ADDRESS 0557.000 STW R7,FCB.NWOK,X1 PUT IN NO-WAIT END ACTION RETURN 0558.000 SETUP.9 EQU $ 0559.000 TRSW R0 0560.000 PAGE 0561.000 * 0562.000 * DWRITE ENTRY POINT 0563.000 * 0564.000 BOUND 1W 0565.000 DWRITE EQU $ WRITE ENTRY 0566.000 TRR R0,X2 PUT LIST POINTER INTO X2 0567.000 ABR R0,29 +1W FOR ARG CNT 0568.000 ADMW R0,0W,X2 ADD # OF LIST BYTES 0569.000 STD R0,N.X SAVE RETURN ADDRESS 0570.000 BL SETUP SETUP WORD AREA 0571.000 DWRITE.1 LW R6,TC GET WC 0572.000 BCT LE,*N.X EXIT IF NEG OR ZERO 0573.000 LW R5,SWN GET START WD NO 0574.000 BCF ZR,DWRITE.2 BR IF NOT FIRST 0575.000 CAMW R6,BLKSIZE SEE IF OVER 192 0576.000 BCT LT,DWRITE.2 BR IF ONLY PART OF SECTOR 0577.000 LW R5,UBA GET USER ADDR 0578.000 LW R6,BLKSIZE GET SECT BYTE COUNT 0579.000 STW R5,FCB.ERWA,X1 PUT IN FCB 0580.000 STW R6,FCB.EQTY,X1 PUT BYTE COUNT IN FCB(9) 0581.000 LW R5,BSA GET REL SECT NO 0582.000 STW R5,FCB.ERAA,X1 PUT SECTOR # IN FCB(10) 0583.000 SVC 1,X'32' WRITE THE WHOLE SECTOR 0584.000 BL DWAIT WAIT FOR I/O COMPLETE 0585.000 ABM 31,BSA BUMP SECT ADDR 0586.000 LW R5,UBA GET USER ADDR 0587.000 ADMW R5,BLKSIZE UPDATE BY 192 WORDS 0588.000 STW R5,UBA RESTORE IT 0589.000 LW R5,TC GET TC 0590.000 SUMW R5,BLKSIZE REDUCE BY 192 0591.000 STW R5,TC UPDATE TRANSFER COUNT 0592.000 BU DWRITE.1 GO AGAIN 0593.000 DWRITE.2 LA R5,P_BLOCK PARTIAL SECT WRITE, GET WORK BUF ADDR0594.000 STW R5,FCB.ERWA,X1 STO IN FCB 0595.000 LW R6,BLKSIZE SECTOR SIZE 0596.000 STW R6,FCB.EQTY,X1 PUT IT IN BYTE COUNT FCB(9) 0597.000 LW R5,BSA GET REL SECTNO 0598.000 STW R5,FCB.ERAA,X1 PUT SECTOR # IN FCB(10) 0599.000 SVC 1,X'31' READ SECTOR 0600.000 BL DWAIT WAIT FORI/O COMPLETE 0601.000 LNW R5,BLKSIZE SET MAX TRANSFER CNT 0602.000 ADMW R5,SWN ONLY REST OF BUFFER FOR TRANSFER 0603.000 LA X3,P_BLOCK GET WORK BUFFER ADDR 0604.000 ADMW X3,SWN POINT TO STARTING WORD 0605.000 LW X2,UBA GET USERT BUFFER ADDR 0606.000 LW R4,TC GET TC 0607.000 ZMW SWN RESET START WORD NO 0608.000 TBM X.FLAG,FLAG EXTENDED ADDRESSING? 0609.000 BNS DWRITE.4 SKIP SET 0610.000 SEA 0611.000 NOP FORCE BOUNDING 0612.000 DWRITE.4 EQU $ 0613.000 LB R6,0B,X2 GET ONE BYTE 0614.000 STB R6,0B,X3 PUT ONE BYTE 0615.000 SUI R4,1 REDUCE TC 0616.000 STW R4,TC STORE IT 0617.000 TRR R4,R4 0618.000 BCT ZR,DWRITE.3 CONTINUE 0619.000 ABR X3,31 BUMP ADDR 0620.000 ABR X2,31 BUMP ADDR 0621.000 ABM 31,UBA BUMP USER BUFFER POINTER 0622.000 BIB R5,DWRITE.4 LOOP TIL DONE 0623.000 DWRITE.3 EQU $ 0624.000 CEA 0625.000 LA R5,P_BLOCK GET WORK BUF ADDRESS 0626.000 STW R5,FCB.ERWA,X1 PUT IN WORK BUF ADDRESS IN FCB(8) 0627.000 LW R5,BSA GET SA 0628.000 STW R5,FCB.ERAA,X1 PUT SECTOR # IN FCB(10) 0629.000 ABM 31,BSA BUMP SA 0630.000 SVC 1,X'32' WRITE TO DISK UPDATE SECT 0631.000 BL DWAIT WAIT FOR I/O COMP 0632.000 BU DWRITE.1 CONTINUE PROCESSING 0633.000 SPACE 3 0634.000 * 0635.000 DWAIT EQU $ 0636.000 TBM 0,FCB.GCFG,X1 IS IT A NO_WAIT I/O ? 0637.000 BNS $+2W BYPASS I/O WAIT SVC 0638.000 SVC 1,X'3C' I/O WAIT SVC 0639.000 LW X3,PBLKA GET PBLK ADDRESS FOR ERROR REPORTING 0640.000 SPACE 3 0641.000 CHKERR EQU $ 0642.000 TBM 1,FCB.SFLG,X1 TEST FOR I03 ERROR BIT 0643.000 BCF SET,NERROR SKIP TO NERROR IF BIT NO SET 0644.000 TBM 6,FCB.SFLG,X1 EOF CHECK 0645.000 BS EOFRTRN 0646.000 TBM 7,FCB.SFLG,X1 EOM CHECK 0647.000 BS EOMRTRN 0648.000 LW R6,FCB.SFLG,X1 GET ENTIRE STATUS WORD 0649.000 BU RETURN 0650.000 PAGE 0651.000 * 0652.000 * ERROR RETURNS 0653.000 * 0654.000 NERROR EQU $ 0655.000 ZMW 3W,X3 SET NO ERROR DATA 0656.000 TRSW R0 PROCESS ADDITIONAL DATA 0657.000 SPACE 1 0658.000 EOFRTRN EQU $ 0659.000 LI R6,EOFERR LOAD EOF ERROR DATA 0660.000 BU RETURN 0661.000 SPACE 1 0662.000 EOMRTRN EQU $ 0663.000 LI R6,EOMERR LOAD EOM ERROR DATA 0664.000 BU RETURN 0665.000 SPACE 1 0666.000 TCERR EQU $ 0667.000 LI R6,BCNTERR LOAD INCORRECT BYTE CNT ERROR 0668.000 BU RETURN 0669.000 SPACE 1 0670.000 RNERR EQU $ 0671.000 LI R6,RECNERR LOAD REC # ERROR DATA 0672.000 BU RETURN 0673.000 SPACE 1 0674.000 RELRTRN EQU $ 0675.000 LI R6,RECLERR GET ERROR CODE  PUT IN R6 0676.000 LA X3,*2W,X1 GET ADDRESS OF PBLK 0677.000 * 0678.000 RETURN EQU $ 0679.000 STW R6,PBK.SFLG,X3 PUT DATA IN PBLK(3) 0680.000 BU *N.X RETURN TO CALLING PROGRAM 0681.000 * 0682.000 END 0683.000 PROGRAM MSEC 0684.000 DEF MSEC 0685.000 *= SUBROUTINE MSEC (TIME) 0686.000 * INTEGER TIME !time in milliseconds 0687.000 *= Time in milliseconds since midnight 0688.000 * 0689.000 * CALL MSEC(I) 0690.000 * 0691.000 * I = INTEGER*4 0692.000 * I = TIME IN M-SEC 0693.000 * 0694.000 * 0695.000 M.EQUS 0696.000 LNEQU 0696.100 * 0697.000 * 0698.000 BOUND 1W 0699.000 MSEC EQU $ 0700.000 LW R5,C.INTC GET TIME IN 100 MICRO SECOND UNIT 0701.000 ZR R4 0702.000 MPI R4,20 CONVERT TO MILI SECOND 0703.000 STW R5,0W,R1 STORE CURRENT VALUE OF TIME 0704.000 TRSW R0 RETURN TO CALLING PROGRAM 0705.000 * 0706.000 * 0707.000 END 0708.000 PROGRAM TLINE 0.0 0709.000 DEF TLINE 0710.000 * 0711.000 *= SUBROUTINE TLINE (S) 0712.000 * CHARACTER*(*) S !STRING FROM TERMINAL LINE BUFFER 0713.000 * 0714.000 *= Extracts the current terminal line buffer 0715.000 * 0716.000 M.EQUS 0717.000 CR EQU X'0D' 0718.000 NULL EQU 0 0719.000 BLANK EQU C' ' 0720.000 S EQU 1W 0721.000 SLEN EQU 2W 0722.000 * 0723.000 * DATA 0724.000 * 0725.000 BOUND 1W 0726.000 RETURN RES 1W 0727.000 * 0728.000 * TLINE 0729.000 * 0730.000 BOUND 1W 0731.000 TLINE EQU $ 0732.000 TRR R0,X1 INDEX ARGUMENTS 0733.000 ABR R0,29 0734.000 ADMW R0,0,X1 BUMP OVER ARGUEMENT COUNT 0735.000 STW R0,RETURN SAVE FOR RETURN 0736.000 SPACE 3 0737.000 * 0738.000 * LOOP AND COPY LINE BUF 0739.000 * 0740.000 LA X3,*S,X1 GET S ADDRESS 0741.000 LW R5,*SLEN,X1 GET LENGTH OF S 0742.000 LW X2,C.TSAD TSA ADDRESS 0743.000 LW X2,T.LINBUF,X2 LINE BUFFER ADDRESS 0744.000 BZ TLINE.3 NO LINE BUFFER, DO NOT READ 0745.000 LB R6,4W,X2 TSM BUFFER SIZE 0746.000 SLA R6,2 CONVERT WORD TO BYTE COUNT 0747.000 CAR R5,R6 WHICH IS GREATER FOR XFER LIMIT 0748.000 BLE TLINE.1 TSM BUFFER IS SMALLER 0749.000 TRR R5,R6 STRING TO XFER TO IS SMALLER 0750.000 TLINE.1 EQU $ 0751.000 ADI X2,5W TSM LINE BUFFER ADDRESS 0752.000 TRN R6,R6 NEGATIVE FOR LOOP 0753.000 TLINE.2 EQU $ TOP OF LOOP 0754.000 LB R7,0,X2 GET FIRST BYTE 0755.000 CI R7,CR END OF INPUT? 0756.000 BEQ TLINE.3 0757.000 CI R7,NULL GUARD AGAINST OVER RUN 0758.000 BEQ TLINE.3 0759.000 STB R7,0,X3 PUT IN STRING 0760.000 ADI X2,1B NEXT CHARACTER 0761.000 ADI X3,1B NEXT SLOT IN S 0762.000 SUI R5,1B DECREMENT S LENGTH LEFT 0763.000 BIB R6,TLINE.2 0764.000 TLINE.3 EQU $ 0765.000 SPACE 3 0766.000 * 0767.000 * NOW BLANK FILL IF NECESSARY 0768.000 * 0769.000 TRN R5,R5 TEST FOR ANY LEFT 0770.000 BNN TLINE.5 FILLED UP 0771.000 LI R7,BLANK 0772.000 TLINE.4 EQU $ 0773.000 STB R7,0,X3 BLANK FILL 0774.000 ADI X3,1B NEXT BYTE 0775.000 BIB R5,TLINE.4 CONTINUE 0776.000 TLINE.5 EQU $ 0777.000 BU *RETURN RETURN 0778.000 END 0779.000 PROGRAM M_UPRIV 0780.000 DEF M_PRIV 0781.000 * 0782.000 *= SUBROUTINE M_PRIV 0783.000 * 0784.000 *= converts the calling task to privileged. 0785.000 * Note that the task must have been cataloged privileged for this 0786.000 * to work. 0787.000 * 0788.000 * 0789.000 DEF M_UPRIV 0790.000 *= SUBROUTINE M_UPRIV 0791.000 * 0792.000 *= converts the calling task to unprivileged. 0793.000 * 0794.000 * Privilege 0795.000 * By: L. Tate 0796.000 * On: May 17, 1983 0797.000 * Purpose: Call these two routines to change from a privileged 0798.000 * state to an unprivileged. 0799.000 * 0800.000 * Inputs: none 0801.000 * Outputs: none 0802.000 * 0803.000 * Notes: Must be cataloged privileged to call these routines. 0804.000 ****************************************************************** 0805.000 M.EQUS !system equates 0806.000 LNEQU LN EQUATES 0806.100 * 0807.000 * M_PRIV 0808.000 * 0809.000 M_PRIV EQU $ 0810.000 SVC 1,CHPRIV !ref. mpx 32 2.1 vol 0811.000 TRSW R0 !done and home 0812.000 * 0813.000 * M_UPRIV 0814.000 * 0815.000 M_UPRIV EQU $ 0816.000 SVC 1,CHUNPRIV !ref mpx 32 2.1 vol 0817.000 TRSW R0 !done and home 0818.000 END 0819.000 PROGRAM HIO 2.0 0820.000 DEF HIO 0821.000 *= LOGICAL FUNCTION HIO (LFC) 0822.000 * INTEGER LFC logical file to halt io on 0823.000 * LOGICAL HIO success = T, failure = F 0824.000 * 0825.000 *= Halts the io over the specified lfc. 0826.000 * This is a privileged instrucion and results will be unpredicable 0827.000 * if you halt something other than a terminal. Be careful. 0828.000 * 1.0 LHT automatically attempts to make user privileged if unprivileged0829.000 * 2.0 LHT fault in determining if integer or not and error test 0830.000 M.EQUS 0831.000 M.TBLS 0832.000 LNEQU LN EQUATES 0832.100 PARMAREA REZ 8W parameter area for inquiry 0833.000 LFCINQ REZ 1D local lfc as parameter 0834.000 RETURN REZ 1W return address 0835.000 SRL SRL R6,0 dummy shift right logical 0836.000 SLLD SLLD R6,0 dummy shift left logical double 0837.000 SLL SLL R6,0 0838.000 BOUND 1W 0839.000 HIO EQU $ 0840.000 STW R0,RETURN save return address 0841.000 * 0842.000 * lfc is either integer or character, determine which and handle 0843.000 * 0844.000 LW R7,0,X1 get LFC 0845.000 SRL R7,24 isolate first byte 0846.000 TRR R7,R7 test first byte 0847.000 BZ HIO.INT integer 0848.000 * 0849.000 * character in integer format 0850.000 * 0851.000 LW R6,0W,X1 get lfc 0852.000 SRL R6,8 right justify lfc 0853.000 ZR R7 clear 7 0854.000 BU HIO.LFC now set up inquiry 0855.000 * 0856.000 * integer version 0857.000 * 0858.000 HIO.INT EQU $ 0859.000 LW R5,0W,X1 get lfc 0860.000 SVC 1,X'2A' convert to decimal 0861.000 LI R5,-3 loop three times 0862.000 TRR R7,R3 store in 3 for destructive test 0863.000 SLL R7,8 left justify 0864.000 ZR R4 zero counter 0865.000 ZBR R0,0 reset flag 0866.000 HIO.SHF EQU $ 0867.000 ZR R6 0868.000 SLLD R6,8 get first byte 0869.000 CI R6,X'30' zero 0870.000 BNE HIO.SH1 donot count 0871.000 TBR R0,0 test for leading 0872.000 BS HIO.SH2 no count 0873.000 ADI R4,1 increment 0874.000 BU HIO.SH2 skip 0875.000 HIO.SH1 EQU $ 0876.000 SBR R0,0 set non zero flag 0877.000 HIO.SH2 EQU $ 0878.000 BIB R5,HIO.SHF 0879.000 SLL R4,3 *8 0880.000 TRR R3,R6 retrieve lfc 0881.000 ADI R4,8 8 bit shift plus 0882.000 LH R1,SLL going to strip leading zeros 0883.000 BL SHIFTER 0884.000 LH R1,SRL right bound 0885.000 BL SHIFTER 0886.000 SUI R4,8 back to original count 0887.000 LW R7,=C' ' blank mask 0888.000 LH R1,SLLD get slld instruction 0889.000 BL SHIFTER shift 0890.000 ZR R7 0891.000 BU HIO.LFC rejoin mainstream 0892.000 HIO.LFC EQU $ 0893.000 STD R6,LFCINQ set up inquiry 0894.000 * M.INQUIRY PARMAREA,LFCINQ inquiry for udt table 0895.000 LI R4,X'FFFFFF' Set up MASK 0895.050 LW R1,C.TSAD Get TSA address 0895.100 LNW R2,T.FILES,X1 Set up loop counter 0895.150 LW R1,T.FPTA,X1 Get address of first FPT 0895.200 LOOP LW R5,0,X1 Get first word of FPT 0895.250 CMR R5,R6 Compare LFC's 0895.300 BEQ FOUND Match 0895.350 ADI R1,3 0895.400 BIB R2,LOOP Check next FPT 0895.450 BU ERROR No match 0895.500 FOUND EQU $ 0895.550 LMW R1,2,X1 Get address of FAT 0895.600 LH R7,3,X1 Get UDT index from FAT 0895.650 MPI R6,16 Set up offset from start of UDT's 0895.700 TRR R7,R3 0895.750 LW R1,C.UDTA Get address of first UDT 0895.800 ADR R3,R1 Set up address of required UDT in R1 0895.850 BS ERROR branch if inquire error 0896.000 LW R1,2W+PARMAREA udt address 0897.000 BZ ERROR not a device 0898.000 TBM UDT.IOUT,UDT.FLGS,X1 test for outstanding io 0899.000 BNS ERROR no io to halt 0900.000 LW R6,1W,X1 get logical address 0901.000 SLL R6,8 strip status 0902.000 SRLD R6,24 strip logical address 0903.000 SRL R7,16 right justify logical address 0904.000 CI R6,X'0C' test for TY type 0905.000 BEQ HIO.TY 0906.000 CI R6,X'11' test for u0 0907.000 BLT ERROR 0908.000 CI R6,X'1A' test for u9 0909.000 BGT ERROR 0910.000 HIO.TY EQU $ 0911.000 LW R6,3W,X1 get physical address 0912.000 SRL R6,16 right justified 0913.000 TRR R6,R6 test for zero 0914.000 BZ HIO.1 use logical address 0915.000 TRR R6,R7 use physical address 0916.000 HIO.1 EQU $ 0917.000 TBM 0,RETURN test for priv 0918.000 BS HIO.5 0919.000 SVC 1,CHPRIV make priv 0920.000 HIO.5 EQU $ 0921.000 HIO R7,0 halt io 0922.000 BCT 6,ERROR error on cc3 or cc4 0923.000 BCT 2,ERROR error on cc2 set 0924.000 LI R7,-1 fortran true 0925.000 BU HIO.10 0926.000 ERROR EQU $ 0927.000 ZR R7 fortran false 0928.000 BU HIO.10 0929.000 HIO.10 EQU $ 0930.000 TBM 0,RETURN 0931.000 BS HIO.15 leave in entrance state 0932.000 SVC 1,CHUNPRIV 0933.000 HIO.15 EQU $ 0934.000 BU *RETURN home 0935.000 * 0936.000 * SHIFTER merges N and instruction and perfroms shift 0937.000 * 0938.000 * R1 - instruction 0939.000 * R4 - count 0940.000 * R1 is destroyed 0941.000 * 0942.000 SHIFTER EQU $ 0943.000 ORR R4,R1 or in count 0944.000 EXRR R1 perform shift 0945.000 TRSW R0 return 0946.000 END 0947.000 PROGRAM TTYF 0.0 0948.000 DEF TTYCURF 0949.000 *= LOGICAL FUNCTION TTYCURF (PBLK, SENSE) 0950.000 * INTEGER PBLK(4) !dio parameter block 0951.000 * INTEGER*8 SENSE !returns the result of sense test 0952.000 * 0953.000 *= TTYCUR tests the port for current configuration. 0954.000 * 0955.000 DEF TTYINIF 0956.000 *= SUBROUTINE TTYINIF (PBLK, INIT) 0957.000 * INTEGER PBLK(4) dio parameter block 0958.000 * INTEGER INIT initialization word 0959.000 * 0960.000 *= Inits the port to the specified initialization. 0961.000 * 0962.000 * TTYCURR returns the current initialization of a terminal on an 0963.000 * asynchronus eight line. This version is compatable with with the 0964.000 * magical FCBINIT/DPREAD/DPWRITE/DREAD/DWRITE routines. Since the 0965.000 * address of the fcb is the first word of the parameter block, just 0966.000 * specify the parameter block as the first parameter. 0967.000 * EX: 0968.000 * CALL TTYCURF(PBLK, SENSE) 0969.000 * OR: 0970.000 * CALL TTYINIF(PBLK, INIT) 0971.000 * major problem with previous version was the internal open involved. 0972.000 * 0973.000 * definitions 0974.000 * 0975.000 M.EQUS 0976.000 ARGS EQU 0 offset to find argument count 0977.000 FCB EQU 1W offset to find lfc 0978.000 SENSE EQU 2W offset to place initialization 0979.000 INIT EQU 2W initialization command 0980.000 ERROR EQU 1 bit 1 of word 3 is error flag 0981.000 * 0982.000 * local variables 0983.000 * 0984.000 BOUND 1D 0985.000 OLDCOM DATAW 1W 0986.000 FCBADDR DATAW 0 0987.000 RETURN DATAW 0 0988.000 C.SENSE DATAW X'02000000' expanded format 0989.000 C.SPCHR DATAW X'02000000' expanded format 0990.000 C.INIT DATAW X'22400000' expanded format 0991.000 WORDMASK DATAW X'0007FFFC' ensure word address 0992.000 BOUND 1W 0993.000 INITPARM EQU $ 0994.000 ACE DATAB 0,0,0 ace parameters to use 0995.000 SPECHAR DATAB 0 special character 0996.000 INITBUF DATAW 0 0997.000 SPCHRBUF DATAW 0 0998.000 SPCHRAD ACW SPCHRBUF byte address of special character 0999.000 ACEADDR ACW INITBUF byte address of ace parameters 1000.000 ENTRY DATAW 0 1001.000 * 1002.000 * ttycurr 1003.000 * 1004.000 TTYCURF EQU $ 1005.000 LA R7,TTY.10 sense program 1006.000 STW R7,ENTRY set up future 1007.000 BU TTY.5 set up return 1008.000 * 1009.000 * ttyinit 1010.000 * 1011.000 TTYINIF EQU $ 1012.000 LA R7,TTY.20 1013.000 STW R7,ENTRY save for future 1014.000 BU TTY.5 1015.000 * 1016.000 * set up return 1017.000 * 1018.000 TTY.5 EQU $ 1019.000 TRR R0,R1 save arguement pointer 1020.000 ABR R0,29 bump over arguement counter 1021.000 ADMW R0,ARGS,X1 add number of arguements 1022.000 STW R0,RETURN save returen address 1023.000 BU *ENTRY perform task 1024.000 * 1025.000 * set up fcb and open 1026.000 * 1027.000 BOUND 1W 1028.000 TTY.10 EQU $ 1029.000 LW R4,WORDMASK address mask 1030.000 LW R2,*FCB,X1 get lfc 1031.000 LW R7,2W,X2 save old command 1032.000 STW R7,OLDCOM 1033.000 LA R7,*SENSE,X1 1034.000 STMW R7,8W,X2 use SENSE for buffer 1035.000 LW R7,C.SENSE place commands in fcb 1036.000 STW R7,2W,X2 1037.000 LI R7,8B byte count for sense 1038.000 STW R7,9W,X2 1039.000 STW R2,FCBADDR save fcb address 1040.000 * 1041.000 * sense terminal 1042.000 * 1043.000 TRR R2,R1 set up sense 1044.000 SVC 1,X'37' stat 1045.000 LW R2,FCBADDR retrieve fcb address 1046.000 LW R7,OLDCOM retrieve 1047.000 STW R7,2W,X2 1048.000 TBM ERROR,3W,X2 check error bit 1049.000 BS TTY.19 error 1050.000 * 1051.000 * return true 1052.000 * 1053.000 LI R7,-1 return true 1054.000 BU *RETURN 1055.000 * 1056.000 * error 1057.000 * 1058.000 TTY.19 EQU $ 1059.000 ZR R7 1060.000 BU *RETURN 1061.000 * 1062.000 * initialize terminal 1063.000 * 1064.000 BOUND 1W 1065.000 TTY.20 EQU $ 1066.000 LW R7,*INIT,X1 initialize to perform 1067.000 STW R7,INITPARM isolate for commands 1068.000 STW R7,INITBUF 1069.000 LB R7,SPECHAR special character 1070.000 STB R7,SPCHRBUF 1071.000 * 1072.000 * open 1073.000 * 1074.000 LW R2,*FCB,X1 get fcb address 1075.000 LW R7,2W,X2 get old command 1076.000 STW R7,OLDCOM 1077.000 * 1078.000 * initialize ace parameters 1079.000 * 1080.000 LW R7,C.INIT init ace command 1081.000 STW R7,2W,X2 1082.000 LW R7,ACEADDR address of ace 1083.000 STW R7,8W,X2 command buffer 1084.000 LI R7,3B transfer 3 bytes 1085.000 STW R7,9W,X2 byte count 1086.000 STW R2,FCBADDR save address 1087.000 TRR R2,R1 set up write 1088.000 SVC 1,X'32' 1089.000 LW R2,FCBADDR retrieve fcb address 1090.000 TBM ERROR,3W,X2 error bit 1091.000 BS TTY.29 error return 1092.000 * 1093.000 * special character 1094.000 * 1095.000 LW R7,C.SPCHR special character command 1096.000 STW R7,2W,X2 new command 1097.000 LW R7,SPCHRAD special character address 1098.000 STW R7,8W,X2 1099.000 LI R7,1B transfer 1 byte 1100.000 STW R7,9W,X2 1101.000 TRR R2,R1 set up special char init 1102.000 SVC 1,X'0D' set special char 1103.000 LW R2,FCBADDR retrieve fcb address 1104.000 TBM ERROR,3W,X2 test for error 1105.000 BS TTY.29 error return 1106.000 * 1107.000 * return good news 1108.000 * 1109.000 LW R7,OLDCOM 1110.000 STW R7,2W,X2 replace 1111.000 LI R7,-1 fortran true 1112.000 BU *RETURN 1113.000 * 1114.000 * error address 1115.000 * 1116.000 TTY.29 EQU $ 1117.000 LW R7,OLDCOM 1118.000 STW R7,2W,X2 replace 1119.000 ZR R7 fortran false 1120.000 BU *RETURN 1121.000 END 1122.000 PROGRAM L.UDT 1.1 1123.000 DEF SUDT 1124.000 *= SUBROUTINE SUDT(PBLK, MODE) 1125.000 * INTEGER PBLK dio parameter block attached to ty 1126.000 * CHARACTER*4 MODE mode to set 1127.000 * 1128.000 *= Sets the terminal to the specified operating mode. 1129.000 DEF TUDT 1130.000 * 1131.000 *= LOGICAL FUNCTION TUDT(PBLK, MODE) 1132.000 * 1133.000 * INTEGER*4 PBLK(4) !dio parameter block attached to ty 1134.000 * CHARACTER*4 MODE !mode to test or set 1135.000 * 1136.000 * Result is returned as a logical function 1137.000 * 1138.000 *= Tests for a particular mode. 1139.000 * 1140.000 M.EQUS 1141.000 M.TBLS 1142.000 LNEQU LN EQUATES 1142.100 * 1143.000 * data 1144.000 * 1145.000 BOUND 1D 1146.000 LFCB RES 8W LOCAL FCB FOR SVC'S 1147.000 RETURN RES 1W 1148.000 UDTA RES 1W ADDRESS OF TERMINAL 1149.000 LMODE RES 1W LOCAL MODE FOR COMPARE 1150.000 FLAGS RES 1W 1151.000 TEST EQU 0 FIRST BIT IS TEST MODE FLAG 1152.000 MODES DATAW C'ONLI' 1153.000 DATAW C'TSM ' 1154.000 DATAW C'LOGO' USER LOGGED ON 1155.000 DATAW C'FULL' 1156.000 DATAW C'HALF' 1157.000 DATAW C'ECHO' 1158.000 DATAW C'NOEC' NO ECHO 1159.000 DATAW C'DEAD' 1160.000 DATAW C'USE ' IN USE 1161.000 DATAW C'ALIV' ALIVE 1162.000 DATAW C'DUAL' DUAL CHANNEL MODE 1163.000 DATAW C'SING' SINGLE CHANNEL MODE 1164.000 NMODES EQU $-MODES 1165.000 TESTBITS EQU $ 1166.000 TBM UDT.ONLI,UDT.STAT,X3 TEST FOR ONLINE 1167.000 TBM UDT.TSM,UDT.STAT,X3 TEST FOR TSM 1168.000 TBM UDT.LOGO,UDT.FLGS,X3 TEST FOR LOGON 1169.000 TBM UDT.FDUX,UDT.BIT2,X3 FULL DUPLEX 1170.000 TBM UDT.FDUX,UDT.BIT2,X3 HALF DUPLEX 1171.000 * TBM UDT.ECHO,UDT.BIT2,X3 ECHO 1172.000 * TBM UDT.ECHO,UDT.BIT2,X3 NO ECHO 1173.000 TBM UDT.DEAD,UDT.BIT2,X3 DEAD 1174.000 TBM UDT.USE,UDT.BIT2,X3 IN USE 1175.000 NOP DUAL 1176.000 NOP 1177.000 NOP SINGLE 1178.000 NOP 1179.000 SETBITS EQU $ 1180.000 TBM UDT.ONLI,UDT.STAT,X3 TEST FOR ONLINE 1181.000 TBM UDT.TSM,UDT.STAT,X3 TEST FOR TSM 1182.000 TBM UDT.LOGO,UDT.FLGS,X3 TEST FOR LOGON 1183.000 SBM UDT.FDUX,UDT.BIT2,X3 FULL DUPLEX 1184.000 ZBM UDT.FDUX,UDT.BIT2,X3 HALF DUPLEX 1185.000 * SBM UDT.ECHO,UDT.BIT2,X3 ECHO 1186.000 * ZBM UDT.ECHO,UDT.BIT2,X3 NO ECHO 1187.000 SBM UDT.DEAD,UDT.BIT2,X3 DEAD 1188.000 TBM UDT.USE,UDT.BIT2,X3 IN USE 1189.000 ZBM UDT.DEAD,UDT.BIT2,X3 ALIVE 1190.000 SVC 1,X'27' DUAL 1191.000 SVC 1,X'26' SINGLE 1192.000 MODTEST EQU $ MODIFY THE RESULT OF TEST 1193.000 DATAB 0 ONLINE 1194.000 DATAB 0 TSM 1195.000 DATAB 0 LOGON 1196.000 DATAB 0 FULL 1197.000 DATAB 255 NOT FULL 1198.000 DATAB 0 ECHO 1199.000 DATAB 255 NOT ECHO 1200.000 DATAB 0 DEAD 1201.000 DATAB 0 IN USE 1202.000 DATAB 0 NOT ALIVE 1203.000 DATAB 0 DUAL 1204.000 DATAB 0 SINGLE 1205.000 * 1206.000 SUDT EQU $ 1207.000 ZBM TEST,FLAGS SHOW ENTRANCE 1208.000 BU UDT.1 1209.000 TUDT EQU $ 1210.000 SBM TEST,FLAGS SHOW ENTRANCE 1211.000 BU UDT.1 1212.000 UDT.1 EQU $ COMMON CODE 1213.000 TRR R0,X1 INDEX REGISTER 1214.000 ABR R0,29 BUMP OVER COUNT 1215.000 ADMW R0,0,X1 ADD COUNT 1216.000 STW R0,RETURN RETURN ADDRESS 1217.000 LW X2,*1W,X1 GET FCB ADDRESS 1218.000 BZ FALSE NO FCB ADDRESS 1219.000 LW R7,0,X2 GET LFC 1220.000 LW X2,C.TSAD START OF TSA 1221.000 LW X3,T.FPTA,X2 FILE POINT TABLE ADDRESS 1222.000 LNB R5,T.FILES,X2 NUMBER OF FPT'S 1223.000 LW R4,=X'00FFFFFF' LFC MASK 1224.000 UDT.2 EQU $ 1225.000 CMMW R7,0,X3 IS THIS THE LFC 1226.000 BEQ UDT.3 1227.000 ADI X3,3W BUMP FPT POINTER 1228.000 BIB R5,UDT.2 LOOP 1229.000 BU FALSE NOT HERE 1230.000 UDT.3 EQU $ FOUND 1231.000 TBM 4,4B,X3 ENTRY IN USE? 1232.000 BS FALSE NO 1233.000 LW X3,2W,X3 FAT ADDRESS 1234.000 LH X3,3H,X3 UDT INDEX 1235.000 BZ FALSE NO UDT INDEX 1236.000 SLA X3,6 * WORD SIZE * UDT SIZE 1237.000 ADMW X3,C.UDTA MAKE A UDT ADDRESS 1238.000 LB R7,UDT.DTC,X3 GET TYPE 1239.000 CI R7,X'C' MUST BE TY TYPE 1240.000 BNE FALSE NOT GOOD 1241.000 STW X3,UDTA STORE IN UDT ADDRESS 1242.000 * 1243.000 * NOW DETERMINE WHICH FLAG I WANT TO SET 1244.000 * 1245.000 LNW R5,*3W,X1 GET STRING SIZE 1246.000 LI R4,-4 SIZE OF LMODE 1247.000 LA X2,*2W,X1 MODE STRING POINTER 1248.000 LA X3,LMODE LOCAL COPY OF MODE 1249.000 LW R7,=C' ' BLANK OUT LOCAL COPY 1250.000 STW R7,LMODE 1251.000 UDT.4 EQU $ 1252.000 LB R7,0,X2 GET FIRST BYTE 1253.000 STB R7,0,X3 PUT AWAY 1254.000 ABR X2,31 BUMP POINTERS 1255.000 ABR X3,31 BUMP POINTERS 1256.000 ADI R4,1 INCREMENT LOCAL COUNTER 1257.000 BZ UDT.5 ENOUGH 1258.000 BIB R5,UDT.4 MORE TO COME 1259.000 UDT.5 EQU $ 1260.000 LI R4,-NMODES GET NUMBER OF MODES 1261.000 LW R7,LMODE GET MODE SELECTED 1262.000 ZR X2 OFFSET OF FIRST MODE 1263.000 UDT.6 EQU $ 1264.000 CAMW R7,MODES,X2 IS THIS THE MODE 1265.000 BEQ UDT.7 FOUND 1266.000 ADI X2,1W BUMP INDEX 1267.000 BIW R4,UDT.6 CONTINUE SEARCH 1268.000 BU FALSE NOT FOUND IN LIST 1269.000 UDT.7 EQU $ FOUND 1270.000 * 1271.000 * LETS DO IT! 1272.000 * 1273.000 ZMD LFCB MUST ZERO LOCAL FCB 1274.000 ZMD LFCB+2W 1275.000 ZMD LFCB+4W 1276.000 ZMD LFCB+6W 1277.000 LW X1,*1W,X1 GET FCB ADDRESS 1278.000 LW R7,0,X1 GET LFC 1279.000 STW R7,LFCB STORE LOCALY 1280.000 LA X1,LFCB USE LOCAL FCB 1281.000 LW X3,UDTA RETREIVE UDT ADDRESS 1282.000 TBM TEST,FLAGS TEST ONLY? 1283.000 BS UDT.TST 1284.000 TBR R0,0 ARE WE PRIVILEGED? 1285.000 BS UDT.8 YEP 1286.000 SVC 1,CHPRIV 1287.000 UDT.8 EQU $ 1288.000 LW R7,SETBITS,X2 GET COMMAND 1289.000 EXR R7 DO IT 1290.000 TBR R0,0 WHERE WE PRIVILEGED 1291.000 BS UDT.9 YEP 1292.000 SVC 1,CHUNPRIV EXIT WAY CAME 1293.000 UDT.9 EQU $ 1294.000 LI R7,-1 1295.000 BU *RETURN GO HOME 1296.000 * 1297.000 * TEST LOGIC 1298.000 * 1299.000 UDT.TST EQU $ 1300.000 ZR R7 ASSUME FALSE 1301.000 LW R6,TESTBITS,X2 GET TEST INSTRUCTION 1302.000 EXR R6 TEST BIT 1303.000 BNS UDT.10 NOT SET 1304.000 LI R7,255 SET 1305.000 UDT.10 EQU $ 1306.000 SRA X2,2 BYTE BOUND INDEX 1307.000 EOMB R7,MODTEST,X2 SOME ARE NOT'S 1308.000 BU *RETURN HOME 1309.000 * 1310.000 * ERROR RETURN 1311.000 * 1312.000 FALSE EQU $ 1313.000 ZR R7 1314.000 BU *RETURN HOME 1315.000 END 1316.000 PROGRAM INKEY 0.0 1317.000 DEF INKEY 1318.000 *= LOGICAL FUNCTION INKEY(LFC, FCB, CHR) 1319.000 * INTEGER LFC lfc to read from 1320.000 * INTEGER FCB(9) fcb to use (zero'd initially) 1321.000 * INTEGER*1,*2,*4 CHR character read in nowait form 1322.000 * 1323.000 * returns .true. if character input 1324.000 * 1325.000 *= Returns a single character typed to lfc. User must echo. 1326.000 * 1327.000 M.EQUS 1328.000 M.TBLS 1329.000 LFC EQU 1W 1330.000 FCB EQU 2W 1331.000 CHR EQU 3W 1332.000 * 1333.000 * inkey 1334.000 * R0 return 1335.000 * X1 fcb address 1336.000 * X2 arguement list pointer 1337.000 * R4 mask to extract leading byte 1338.000 * R5 numeric lfc 1339.000 * R7 alpha lfc and transient register 1340.000 * 1341.000 BOUND 1W 1342.000 INKEY EQU $ 1343.000 TRR R0,X2 arg pointer 1344.000 ABR R0,29 bump over arg count 1345.000 ADMW R0,0W,X2 bump over args 1346.000 * 1347.000 * check for initialization 1348.000 * 1349.000 LA X1,*FCB,X2 get fcb address 1350.000 LW R7,FCB.LFC,X1 get first word of fcb 1351.000 BNZ INKEY.10 already initialized 1352.000 * 1353.000 * initialize 1354.000 * 1355.000 LW R7,*LFC,X2 get lfc 1356.000 LW R4,=X'FF000000' lfc mask 1357.000 TRRM R7,R5 test for numeric or alpha 1358.000 BNZ INKEY.5 alpha 1359.000 TRR R7,R5 set up conversion 1360.000 SVC 1,X'2A' convert binary to decimal 1361.000 CI R5,100 less than 100? 1362.000 BGE INKEY.2 no shift since uses 3 digits 1363.000 SLC R7,8 move leading blank to end 1364.000 CI R5,10 only one byte long? 1365.000 BGE INKEY.2 no 1366.000 SLC R7,8 move leading blank to end 1367.000 INKEY.2 EQU $ 1368.000 SLL R7,8 make like alpha 1369.000 INKEY.5 EQU $ 1370.000 SRL R7,8 right justify 3 chr lfc 1371.000 STW R7,FCB.LFC,X1 store lfc in fcb 1372.000 LW R7,=X'E0600000' nowait,noerror,dfi,noecho,noconv 1373.000 STW R7,FCB.GCFG,X1 store in control flags 1374.000 TRR X1,R7 fcb address 1375.000 ADI R7,8W buffer to use is end of fcb 1376.000 SBR R7,12 make byte address 1377.000 SBR R7,11 count of one 1378.000 STW R7,FCB.TCW,X1 store tcw 1379.000 * 1380.000 * do normal processing 1381.000 * 1382.000 INKEY.10 EQU $ 1383.000 TBM 0,FCB.SFLG,X1 test for io completion 1384.000 BS INKEY.20 still processing 1385.000 LB R7,8W,X1 get character received 1386.000 STW R7,*CHR,X2 return character input 1387.000 LNW R7,FCB.RECL,X1 transfer count of -1 is T, 0 is F 1388.000 SVC 1,X'31' read 1389.000 BU INKEY.30 read processing done 1390.000 INKEY.20 EQU $ read not complete 1391.000 ZMW *CHR,X2 zero out character input 1392.000 LI R7,0 false 1393.000 INKEY.30 EQU $ exit 1394.000 TRSW R0 return 1395.000 END 1396.000 PROGRAM HIOALL 0.0 1397.000 DEF HIOALL 1398.000 *= SUBROUTINE HIOALL 1399.000 * 1400.000 *= Kills all pending io for this task. 1401.000 * Must be privileged to do this 1402.000 * 1403.000 M.EQUS 1404.000 LNEQU LN EQUATES 1404.100 * 1405.000 BOUND 1W 1406.000 HIOALL EQU $ 1407.000 TBR R0,0 privileged? 1408.000 BS ALL.1 yes 1409.000 SVC 1,CHPRIV 1410.000 ALL.1 EQU $ 1411.000 M.CALL H.IOCS,38 do it 1412.000 TBR R0,0 privileged? 1413.000 BS ALL.2 yes 1414.000 SVC 1,CHPRIV 1415.000 ALL.2 EQU $ 1416.000 TRSW R0 return 1417.000 END 1418.000