home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Columbia Kermit
/
kermit.zip
/
gould3
/
kermit6
< prev
Wrap
Text File
|
2020-01-01
|
117KB
|
1,442 lines
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
