Columbia Kermit

home *** CD-ROM | disk | FTP | other *** search

/ Columbia Kermit / kermit.zip / gould2 / gm2kerm.asm next >

Wrap

Assembly Source File | 2020-01-01 | 55KB | 1,419 lines

TITLE DIO V17 -- DISK INPUT OUTPUT PROGRAM PROGRAM DIO 17 * DEF FCBINIT FILE CONTROL BLOCK INITIALIZE *= SUBROUTINE FCBINIT (LFC, PBLK, FUNC, RECLEN, *ERR, *NOWAIT) * INTEGER LFC logical file code * INTEGER PBLK(4) parameter block to be filled * INTEGER FUNC function code for FCB * INTEGER RECLEN length of record for blocking * ADDRESS ERR error return address * ADDRESS NOWAIT no wait normal return address *= Initialize the parameter block for future reads and writes SPACE 3 DEF DPWRITE NO-WAIT I/O COMPLETE SECTOR WRITE *= SUBROUTINE DPWRITE (PBLK, BUFFER, COUNT, RECORD, *ERR, *NOWAIT) * INTEGER PBLK(4) parameter block * * BUFFER buffer to write (int *1,2,4,char) * INTEGER COUNT count of bytes to write * INTEGER RECORD record number to write to *= Write unblocked to device/file defined by PBLK SPACE 3 DEF DPREAD NO-WAIT I/O COMPLETE SECTOR READ * INTEGER PBLK(4) parameter block to be filled *= SUBROUTINE DPREAD (PBLK, BUFFER, COUNT, RECORD, *ERR, *NOWAIT) *= Read unblocked from device/file defined by PBLK DEF DWRITE WAIT I/O PARTIAL SECTOR WRITE * INTEGER PBLK(4) parameter block to be filled *= SUBROUTINE DWRITE (PBLK, BUFFER, COUNT, RECORD, *ERR, *NOWAIT) *= Write blocked to a file defined by PBLK DEF DREAD WAIT I/O PARTIAL SECTOR READ *= SUBROUTINE DREAD (PBLK, BUFFER, COUNT, RECORD, *ERR, *NOWAIT) * INTEGER PBLK(4) parameter block to be filled *= Read blocked from a file defined by PBLK DEF DERROR RETURN ERROR CODES *= INTEGER FUNCTION DERROR (PBLK) *= Return status of last io on the PBLK DEF DPCOUNT COUNT OF BYTES TRANSFERED *= INTEGER FUNCTION DPCOUNT (PBLK) *= Return byte count of last io transfer on the PBLK PAGE * * AUTHOR: A D PATEL DATE: 1982 * REVISIONS: * X14 L. TATE (4/29/84) * -NO WAIT IO DOES NOT CHECK ERROR OF PREVIOUS ATTEMPT * -ENTRY DERROR ADDED TO RETURN ERROR CODE (REENTRANT) * X15 L. TATE (7/5/84) * -DATA BUFFER MAY BE IN EXTENDED MEMORY. * X15.1 L. TATE (9/5/84) * -THE FORMAT BIT IS NOW CLEARED ON BYTE BUFFERS * X16 L. TATE (1/7/85) * -ALLOW LOCAL ERROR/END ACTION RETURNS * X16.1 LTATE (4/15/85) * -REARRANGED ERROR TESTING SO EOF WILL BE DETECTED. * X16.2 LTATE (5/13/85) * -ENSURED EXTENDED ADDRESSING WAS CANCELED WHEN SET. * X17 LTATE (5/27/85) * -RETURN TRANSFER COUNT AS FUNCTION VALUE * * * TO USE THESE FUNCTIONS INCLUDE $OBJECT * $SELECTF ^(SEMS)O.DIO15 * * THIS SET OF PROGRAMS CAN BE CALLED * FROM FORTRAN BY THE FOLLOWING CSQ'S * * CALL FCBINIT (LU ,PBLK ,FUNC ,RECLN,$NN,$NN1) * CALL DREAD (PBLK ,BUFFER,BYTECNT,RECNO,$NN,$NN1)!WAIT I/O * CALL DPREAD (PBLK ,BUFFER,BYTECNT,RECNO,$NN,$NN1)!NO_WAIT I/O * CALL DWRITE (PBLK ,BUFFER,BYTECNT,RECNO,$NN,$NN1)!WAIT I/O * CALL DPWRITE (PBLK ,BUFFER,BYTECNT,RECNO,$NN,$NN1)!NO_WAIT I/O * ERROR = DERROR(PBLK) !ERROR CHECK * COUNT = DPCOUNT(PBLK) !BYTE COUNT * * BYTECNT= INTEGER*4; # OF BYTES FOR THIS I/O * * LU = INTEGER*4; NO-CHARACTER ARGUMENTS ALLOWED * PLEASE DEFINE LU AS A PARAMETER SUCH THAT * IT CAN BE REASSIGNED TO DIFFRNT DEVICE EASE * PBLK = INTEGER*4; PBLK(4); PBLK FOR FCB ADDRS STOR & ERR STAT * * PBLK(1); FCB ADDRESS STORAGE LOCATION * PBLK(2); NOT USED (SPARE) * PBLK(3); NOT USED (SPARE) * PBLK(4); ERROR STATUS AS SPECIFIED BELOW * * PBLK(4)= ERROR STATUS; FOLLOWING CODES ARE IMPLEMENTED * * 0 = I/O COMPLETE WITHOUT ERROR * 1 = REC # .LE. 0 * 2 = BYTECNT .LE. 0 * 3 = EOF * 4 = EOM * 5 = RECORD LENGTH .LT. 0 * * BUFFER = DATA BUFFER IN INTEGER OR CHARACTER FORMAT * MAY BE IN EXTENDED MEMORY * * BYTECNT # OF BYTES FOR THIS TRANSFER * * RECNO RECORD # FOR THIS I/O * * FUNC INTEGER*4 ; FUNC DATA/8Z0A000000/ * REFER TO TABLE 7_4 OF MPX2.1 VOL 1, * PAGE 7-33 FOR DETAILS ON THESE BITS * BIT ASSIGNMENT: NO_WAIT I/O SPECIFICATION BIT 0 * NO ERROR RETURN PROCESSING BIT 1 * BINARY TRANSFER DFI BIT 2 * NO STATUS CHECK BY HANDLER BIT 3 * RANDOM ACCESS BIT 4 * BLOCKED I/O (DISC & TAPE) BIT 5 * EXPANDED FCB (MUST BE ON) BIT 6 * TASK WILL NOT ABORT BIT 7 * DEVICE FORMAT DEFINATION BIT 8 * * $NN = FATAL ERROR RETURN CHECK ENTIRE WORD & REFER TO * MPX2.1 VOLM 1.; FIG: 7-3; TABLE 7-4; FCB BIT INTERP * *NOTE* CAN BE SPECIFIED AT READ/WRITE CALL, BUT * FUTURE CALLS USE LAST SUPPLIED VALUE. * * $NN1 = NO_WAIT I/O NORMAL RETURN STATEMENT LABEL; AFTER THIS * LABLE YOU MUST HAVE ( CALL X:XNWIO) TO TERMINATE * NO_WAIT I/O. * *NOTE* CAN BE SPECIFIED AT READ/WRITE CALL, BUT * FUTURE CALLS USE LAST SUPPLIED VALUE. * * * * The DREAD & DRITE routines can be used to perform I/O to disk * files where record length are such that FORTRAN random * access routines cannot be used; (e.g. record length > 248 * bytes). These routines perform BLOCKING of data within the * physical sector and has minimum overhead for the operation. * * * The DPREAD & DPWRITE routines are general purpose I/O * functions to perform I/O operations to any device. The FUNC * word defines the type of operation that the routine will * accomplish. It is totaly dependent on the functions implemented * by the specific device driver. User can perform I/O in wait * mode or no-wait mode. If the user wants to perform no-wait I/O * he has to have $NN1; end action receiver established. The * example of no-wait I/O is as follows: * * CALL FCBINIT (LFC,PBLK,FUNC,RECLN,$NN,$NN1) * * 10 CONTINUE * * CALL DPWRITE (PBLK,BUF,BYTECNT, irec ) ! irec option for random * access disk files only * * * any FORTRAN or ASSEMBLY code * * nn1 CONTINUE * * Any code including I/O to same LFC or any other * device. The I/O to the same LFC shold be before * the following X:XNWIO function. * * CALL X:XNWIO * * * * * REV 1.1 BY A. PATEL IMPELMET CHECKING OF NO WAIT BIT * TO BYPASS ERROR CHECKING FOR LAST I/O * ALSO ADD CODE TO CHECK ERR AT THE COMLETION OF I/O * IF THE WAIT BIT IS SET * * REV 14.0 BY L.TATE IMPLEMENT DERROR ROUTINE * * ERROR = DERROR(PBLK) * * REENTRANT.... CAN BE CALLED FROM THE * ERROR AND END ACTION HANDLERS. * * ERROR CODES: * * 0 - NO ERROR * 1 - REC # .LE. 0 * 2 - BYTECNT .LE. 0 * 3 - EOF * 4 - EOM * 5 - RECORD LENGTH .LT. 0 * 6 - INVALID BLOCKING BUFFER * 7 - WRITE PROTECT * 8 - INOPERABLE DEVICE * 9 - BEGINNING OF MEDIUM * * REV 15.0 BY L.TATE EXTENDED MEMORY BUFFER CAPABILITY * REV 15.1 BY L.TATE CORRECTED CHARACTER ADDRESS MASKING * REV 16 BY L.TATE ADDED LOCAL ERROR/END ACTION RETURNS. * * PAGE * * EXTERNAL REFERENCES * EXT R.EF POINTER TO # PARMS IN BL EXT E.RR ERROR PROCESSOR EXT I.IO15 GET FCB + CHECKS EXT N.X USER'S RETURN ADDRESS EXT R.X ALTERNATE RETURN ADDRESS EXT F.F FLAGS FOR I/O INITIALIZATION EXT N.CL USER'S CALL ADDRESS EXT F.C CURRENT FCB ADDRESS EXT REQ.PARM REQUIRED PARAMETER PROCESSOR EXT OPT.ADDR OPTIONAL ADDRESS PROCESSOR EXT REQ.ADDR REQUIRED ADDRESS PROCESSOR EXT P_BLOCK 192W TEMPARARY WORK BUFFER PAGE * * EQUATES * M.EQUS GENERAL EQUATES M.TBLS EQUATES FOR ALL TABLES SPACE 3 * * RANACCRL EQU 1W RANDOM ACCESS RECOD LENGTH STORED IN PBK.SFLG EQU 3W PARAMETER BLOCK ERROR STATUS BUFADDR EQU 2W BUFERR ADDRES POINTER IN ARG PBKADDR EQU 1W PARAMETER BLOCK POINTER IN ARG FTN.I EQU 0 INDIRECT BIT OF FORTRAN PARAMETER FTN.X EQU 1 INDICATES ADDRESS IS 24 BITS LONG * * ERROR CODES * NOERR EQU 0 NO ERROR RECNERR EQU 1 RECORD #.LT. 0 BCNTERR EQU 2 TRANSFER COUNT .LT. 0 EOFERR EQU 3 EOF EOMERR EQU 4 EOM RECLERR EQU 5 RECORD LENGTH .LT. 0 BB.ERR EQU 6 INVALID BLOCKING BUFFER PRO.ERR EQU 7 WRITE PROTECT VIOLATION INOP.ERR EQU 8 DEVICE IS INOPERABLE BOM.ERR EQU 9 BEGINNING OF MEDIUM PAGE * * LOCAL MEMORY * BOUND 1W BLKSIZE DATAW 768 BYTES IN A SECTOR X1SAVE DATAW 0 SAVE OF PARAMETER POINTER ACW A(LFC) NEEDED FOR I.IO15 LFC DATAW 0 XMASK DATAW X'FFFFFF' 24 BIT ADDRESS MASK WMASK DATAW X'0007FFFF' DATA BUFFER MASK; NO EXTENDED ADDRESS UBA DATAW 0 USER BUFFER ADDRESS STORAGE TC DATAW 0 USER REQUESTED TRANSFER COUNT IN BYTE RN DATAW 0 USER REQUESTED RECORD # BSA DATAW 0 SECTOR # FORM ORIGIN OF THE DISC FILE SWN DATAW 0 RELATIVE WIDTH OF PARTIAL SECTOR I/O PBLKA DATAW 0 TEMP STORAGE FOR PBLK ADDRESS FLAG DATAH 0 B0.FLAG EQU 0 FLAG B1.FLAG EQU 1 DIRECT PROCEED I/O READ/WRITE FLAG X.FLAG EQU 2 THE BUFFER IS IN EXTENDED MEMORY COUNT RES 1W COUNT OF BYTES TRANSFERED PAGE BOUND 1W FCBINIT EQU $ TRR R0,X1 SAVE R0 FOR ARG POINTER LW R7,0W,X1 GET # PARMS ABR R7,29 BUMP BY 4 FOR RETURN LOCATION ADR R7,R0 FIND RETURN LOCATION STD R0,N.X * ERROR EXITS STW X1,X1SAVE SAVE X1 FOR LATER USE BL REQ.PARM GET LFC STW R7,LFC SAVE LFC LA X1,X1SAVE PUT ADDRESS # OF PARAMETERS IN X1 LI R7,1 STB R7,F.F BL I.IO15 FIND FCB ADDRESS LW X1,X1SAVE RESTORE ARG POINTER IN X1 STW X3,*2W,X1 SAVE FCB ADDRESS FOR LATER USE LA R5,*5W,X1 ERROR SUB ADDR TO R5 ANMW R5,WMASK STRIP HIGH BITS STW R5,FCB.ERRT,X3 PUT ERR ADDR AT FCB(6) LW R6,*3W,X1 GET EFUNCTION CODE & PUT IT IN FCB(2) STW R6,FCB.CBRA,X3 STORE AT GENERAL CONTROL SPEC TBR R6,4 IS THIS RAN ACCESS RECORD BNS FCB.1 NO RECL-LENGTH FOR THIS I/O LW R7,*4W,X1 GET RECORD LENGHT BCT LE,RELRTRN RECORD LENGTH .LT. 0 STW R7,RANACCRL,X3 STORE RANDOM ACCESS RECL-LENGTH IN 1W BU FCB.2 * FCB.1 EQU $ ZMW RANACCRL,X3 CLEAR THE RANDOM ACCESS STORAGE * FCB.2 EQU $ TBR R6,0 IS IT A NO WAIT I/O BNS FCB.3 BY PASS STUFFING NO WAIT DATA STW R5,FCB.NWER,X3 PUT NO_WAIT ERROR RETURN ADDRESS IN F LA R5,*6W,X1 GET THE NORMAL RETURN ADDRESS ANMW R5,WMASK MASK OUT HI LOW BITS STW R5,FCB.NWOK,X3 PUT NO_WAIT NORMAL RETURN ADDRESS * FCB.3 EQU $ BU *N.X PAGE * * DPWRITE ENTRY POINT * BOUND 1W DPWRITE EQU $ SBM B1.FLAG,FLAG SET WRITE IND BU DP.01 COMMON ROUTINE SPACE 3 * * DPREAD ENTRY POINT * DPREAD EQU $ ZBM B1.FLAG,FLAG CLEAR WRITE IND SPACE 3 DP.01 EQU $ TRR R0,X2 PUT LIST POINTER INTO X2 ABR R0,29 +1W FOR ARG CNT ADMW R0,0W,X2 ADD # OF LIST BYTES STD R0,N.X SAVE RETURN ADDRESS BL SETUP SETUP ARGUMENTS FOR THIS CALL LW R5,UBA GET USER BUFFER ADDRESS STW R5,FCB.ERWA,X1 STORE BUFFER ADDRESS IN FCB LW R6,TC LOAD TRANSFER COUNT STW R6,FCB.EQTY,X1 STORE BYT CNT IN FCB(9) TBM 4,FCB.GCFG,X1 IS IT A RANDOM ACCESS I/O BNS $+3W BYPASS STORING OF RANDOM ACCESS ADR. LW R7,BSA GET SECTOR # STW R7,FCB.ERAA,X1 STORE IT IN RANDOM ACESS ADDRESS TBM B1.FLAG,FLAG TEST R/W FLAG BCT SET,WRIT BR IF WRITE SVC 1,X'31' READ RECORD SVC BU DP.1 RETURN TO CALLER WRIT SVC 1,X'32' WRITE RECORD SVC * DP.1 EQU $ TBM 0,FCB.GCFG,X1 IS IT A NO_WAIT I/O ? BS $+2W BYPASS ERROR CHECKING & RTRN TO CALLE BL CHKERR CHECK IF ANY ERROR DURING PREVIOUS I/ BU *N.X RETURN TO CALLER PAGE * * DREAD ENTRY POINT * BOUND 1W DREAD EQU $ TRR R0,X2 PUT LIST POINTER INTO X2 ABR R0,29 +1W FOR ARG CNT ADMW R0,0W,X2 ADD # OF LIST BYTES STD R0,N.X SAVE RETURN ADDRESS BL SETUP SETUP WORK AREA DREAD.1 LW R6,TC GET TRANSFER COUNT BCT LE,*N.X EXIT IF NEG OR ZERO LW R5,SWN GET STARTING WD NUMBER BCF ZR,DREAD.2 BR IF NOT START OF SECT LW R5,UBA START OF SECT, GET BUFFER ADDR STW R6,FCB.EQTY,X1 PUT BYTE COUNT IN FCB(9) STW R5,FCB.ERWA,X1 STORE ADDRESS IN FCB(8) LW R5,BSA GET STARTING SECT NO STW R5,FCB.ERAA,X1 PUT IN FCB(10) SVC 1,X'31' READ FILE BL DWAIT WAIT FOR I/O COMP BU *N.X RETURN DREAD.2 LA R5,P_BLOCK GET TEMP WORK BUF ADDRESS STW R5,FCB.ERWA,X1 PUT IN FCB LW R6,BLKSIZE GET BLKSIZE IN BYTES STW R6,FCB.EQTY,X1 PUT IT IN FCB(9) LW R5,BSA GET SECT ADDR STW R5,FCB.ERAA,X1 PUT SECT ADDRESS IN FCB(10) ABM 31,BSA BUMP SECTOR ADDR SVC 1,X'31' READ A SECT BL DWAIT WAIT FOR I/O COMP LNW R5,BLKSIZE GET MAX BYT CNT ADMW R5,SWN ONLY REST OF BUFFER FOR TRANSFER LA X3,P_BLOCK GET BUFFER ADDR ADMW X3,SWN POINT TO START WD LW X2,UBA GET USER BUFFER ADDR LW R4,TC GET TRANSFER COUNT ZMW SWN ZERO START WD NO TBM X.FLAG,FLAG TEST FOR EXTENDED MEMORY BNS DREAD.3 SKIP OVER EXTENDED ADDRESSING SEA SET EXTENDED ADDRESSING DREAD.3 LB R6,0B,X3 GET BYTE STB R6,0B,X2 PUT BYTE SUI R4,1 REDUCE TC BZ DREAD.4 RETURN IF COMPLETE STW R4,TC UPDATE LOCN ABR X3,31 BUMP ADDR ABR X2,31 BUMP ADDRE ABM 31,UBA BUMP USER BUFFER ADDR BIB R5,DREAD.3 LOOP UNTIL TRANSFER COMP CEA CANCEL WHEN MOVE DONE, SET OR NOT BU DREAD.1 GO GET REST OF DATA DREAD.4 EQU $ CEA CANCEL EXTENDED ADDRESSING ON EXIT BU *N.X RETURN PAGE * * DERROR * BOUND 1W DERROR EQU $ LW X2,0,X1 GET FCB ADDRESS LW R5,FCB.SFLG,X2 GET FCB STATUS TBR R5,2 BLOCKING BUFFER BS DERR.2 TBR R5,3 WRITE PROTECT BS DERR.3 TBR R5,4 DEVICE INOPERABLE BS DERR.4 TBR R5,5 BEGINNING OF MEDIUM BS DERR.5 TBR R5,6 EOF BS DERR.6 TBR R5,7 EOM BS DERR.7 TBR R5,1 ERROR BNS DERR.1 NO ERROR FOUND SLL R5,10 STRIP OUT PRE SRL R5,10 PUT BACK TRN R5,R7 RETURN IT BU DERR.99 RETURN DERR.1 EQU $ LW R7,PBK.SFLG,X1 GET ANY PBLK ERRORS BU DERR.99 DERR.2 EQU $ LI R7,BB.ERR BLOCKING ERROR BU DERR.99 DERR.3 EQU $ LI R7,PRO.ERR PROTECT ERROR BU DERR.99 DERR.4 EQU $ LI R7,INOP.ERR INOPERABLE BU DERR.99 DERR.5 EQU $ LI R7,BOM.ERR BEGINNING OF MEDIUM BU DERR.99 DERR.6 EQU $ LI R7,EOFERR EOF BU DERR.99 DERR.7 EQU $ LI R7,EOMERR BU DERR.99 DERR.99 EQU $ TRSW R0 RETURN PAGE * * DPCOUNT RETURN COUNT OF BYTES TRANSFERED IN LAST READ * BOUND 1W DPCOUNT EQU $ LW X2,0,X1 GET FCB ADDRESS BZ DPCNT.Z NOT A PROPER PBLK YET TBM 0,3W,X2 TEST FOR OPERATION IN PROGRESS BS DPCNT.Z NOT VALID COUNT YET LW R7,4W,X2 GET BYTE COUNT TRSW R0 DPCNT.Z EQU $ ZR R7 NOTHING TO RETURN TRSW R0 PAGE * * * GET ARGUMENTS AND FIND SECTOR # * * BOUND 1W SETUP EQU $ LW X1,*PBKADDR,X2 GET FCB ADDR LA X3,*PBKADDR,X2 GET ADDRESS OF PARAMETERS BLOCK STW X3,PBLKA STORE PBLK ADDRESS FOR ERR REPORTING ZMW PBK.SFLG,X3 ZERO PREVIOUS ERRORS ZMW FCB.SFLG,X1 ZERO PREVIOUS ERRORS SPACE 3 * * BUFFER MAY BE IN EXTENDED MEMORY, MUST MANUALLY GO DOWN * INDIRECT CHAIN TILL REACHED. * TBM FTN.I,BUFADDR,X2 TEST FOR PARAMETER WORD BNS SETUP.3 NORMAL PARAMETER SPACE 3 * * EXTENDED ADDRESS TYPE * SBM X.FLAG,FLAG NOTE EXTENDED BUFFER LW X3,BUFADDR,X2 PARAMETER WORD LW X3,0,X3 GET FIRST ADDRESS SETUP.1 EQU $ TBR X3,FTN.I TEST FOR PSEUDO-INDIRECT BNS SETUP.2 END OF LOOK LW X3,0,X3 NEXT WORD IN CHAIN BU SETUP.1 LOOP SETUP.2 EQU $ TRR X3,R6 PUT LIKE REST ANMW R6,XMASK MASK OUT NON-ADDRESS DATA ANMW X3,=X'0F000000' CLEAR OUT REST SRL X3,24 ISOLATE BYTE TRR X3,R5 PUT IN 5 FOR TESTING LW X3,PBLKA GET BACK THE PBLK ADDRESS BU SETUP.4 CONTINUE SPACE 3 * * NORMAL BUFFER ADDRESS FETCH * SETUP.3 EQU $ NORMAL ARGUMENT PROCESSING ZBM X.FLAG,FLAG NOTE NON-EXTENDED BUFFER LA R6,*BUFADDR,X2 GET CONTENT OF BUF ADDRESS LOCATION ANMW R6,WMASK MASK OUT UNWANTED DATA LB R5,BUFADDR,X2 GET DATA TYPE OF BUFFER SPACE 3 * * TEST FOR TYPING NOW * SETUP.4 EQU $ CI R5,X'B' IS IT CHARCTER TYPE BNE SETUP.5 NO, IT IS NOT CHARCTER ADI X2,4 ADJUST ARG PTR FOR DBL WRD ARG SETUP.5 EQU $ CI R5,X'01' IS IT INTEGER*2 ARG BNE SETUP.6 NO, IT IS NOT INTEGRE*2 ZBR R6,31 CLEAR C BIT SETUP.6 EQU $ STW R6,UBA STORE IT LW R6,*3W,X2 GET BYTE COUNT BCT LE,TCERR IF ZERO, RETURN STW R6,TC SAVE TBM 4,FCB.GCFG,X1 IS THIS A RANDOM ACCESS I/O BNS SETUP.7 NO NEED TO CALCULATE LW R7,*4W,X2 GET REL REC NO BCT LE,RNERR IF ZERO, RETURN STW R7,RN SAVE RECORD NUMBER SUI R7,1 CALCULATE MPMW R6,RANACCRL,X1 GET RECL-LN & MPMW TO GET POSITION DVMW R6,BLKSIZE PHYSICAL STW R7,BSA SECTOR NUM, STW R6,SWN REL WD WITH SECTOR SPACE 3 * * GET OPTIONAL ERROR RETURN AND END ACTION ADDRESSES X16 * SETUP.7 EQU $ ADI X2,5W BUMP PARAMETER POINTER TO ERROR RET CAMW X2,N.X IS THERE AN ERROR RETURN? BGE SETUP.8 NO, USE PREVIOUS LA R7,*0,X2 GET ADDRESS STW R7,FCB.ERRT,X1 PUT IN WAIT ERROR RETURN TBM 0,FCB.GCFG,X1 NO WAIT I/O BNS SETUP.8 DO NOT SETUP NO WAIT RETURN STW R7,FCB.NWER,X1 PUT IN NO-WAIT ERROR RETURN SETUP.8 EQU $ ADI X2,1W BUMP PARAMETER POINTER TO NORMAL RET CAMW X2,N.X IS THERE A NORMAL RETURN? BGE SETUP.9 NO, USE PREVIOUS LA R7,*0,X2 GET ADDRESS STW R7,FCB.NWOK,X1 PUT IN NO-WAIT END ACTION RETURN SETUP.9 EQU $ TRSW R0 PAGE * * DWRITE ENTRY POINT * BOUND 1W DWRITE EQU $ WRITE ENTRY TRR R0,X2 PUT LIST POINTER INTO X2 ABR R0,29 +1W FOR ARG CNT ADMW R0,0W,X2 ADD # OF LIST BYTES STD R0,N.X SAVE RETURN ADDRESS BL SETUP SETUP WORD AREA DWRITE.1 LW R6,TC GET WC BCT LE,*N.X EXIT IF NEG OR ZERO LW R5,SWN GET START WD NO BCF ZR,DWRITE.2 BR IF NOT FIRST CAMW R6,BLKSIZE SEE IF OVER 192 BCT LT,DWRITE.2 BR IF ONLY PART OF SECTOR LW R5,UBA GET USER ADDR LW R6,BLKSIZE GET SECT BYTE COUNT STW R5,FCB.ERWA,X1 PUT IN FCB STW R6,FCB.EQTY,X1 PUT BYTE COUNT IN FCB(9) LW R5,BSA GET REL SECT NO STW R5,FCB.ERAA,X1 PUT SECTOR # IN FCB(10) SVC 1,X'32' WRITE THE WHOLE SECTOR BL DWAIT WAIT FOR I/O COMPLETE ABM 31,BSA BUMP SECT ADDR LW R5,UBA GET USER ADDR ADMW R5,BLKSIZE UPDATE BY 192 WORDS STW R5,UBA RESTORE IT LW R5,TC GET TC SUMW R5,BLKSIZE REDUCE BY 192 STW R5,TC UPDATE TRANSFER COUNT BU DWRITE.1 GO AGAIN DWRITE.2 LA R5,P_BLOCK PARTIAL SECT WRITE, GET WORK BUF ADDR STW R5,FCB.ERWA,X1 STO IN FCB LW R6,BLKSIZE SECTOR SIZE STW R6,FCB.EQTY,X1 PUT IT IN BYTE COUNT FCB(9) LW R5,BSA GET REL SECTNO STW R5,FCB.ERAA,X1 PUT SECTOR # IN FCB(10) SVC 1,X'31' READ SECTOR BL DWAIT WAIT FORI/O COMPLETE LNW R5,BLKSIZE SET MAX TRANSFER CNT ADMW R5,SWN ONLY REST OF BUFFER FOR TRANSFER LA X3,P_BLOCK GET WORK BUFFER ADDR ADMW X3,SWN POINT TO STARTING WORD LW X2,UBA GET USERT BUFFER ADDR LW R4,TC GET TC ZMW SWN RESET START WORD NO TBM X.FLAG,FLAG EXTENDED ADDRESSING? BNS DWRITE.4 SKIP SET SEA NOP FORCE BOUNDING DWRITE.4 EQU $ LB R6,0B,X2 GET ONE BYTE STB R6,0B,X3 PUT ONE BYTE SUI R4,1 REDUCE TC STW R4,TC STORE IT TRR R4,R4 BCT ZR,DWRITE.3 CONTINUE ABR X3,31 BUMP ADDR ABR X2,31 BUMP ADDR ABM 31,UBA BUMP USER BUFFER POINTER BIB R5,DWRITE.4 LOOP TIL DONE DWRITE.3 EQU $ CEA LA R5,P_BLOCK GET WORK BUF ADDRESS STW R5,FCB.ERWA,X1 PUT IN WORK BUF ADDRESS IN FCB(8) LW R5,BSA GET SA STW R5,FCB.ERAA,X1 PUT SECTOR # IN FCB(10) ABM 31,BSA BUMP SA SVC 1,X'32' WRITE TO DISK UPDATE SECT BL DWAIT WAIT FOR I/O COMP BU DWRITE.1 CONTINUE PROCESSING SPACE 3 * DWAIT EQU $ TBM 0,FCB.GCFG,X1 IS IT A NO_WAIT I/O ? BNS $+2W BYPASS I/O WAIT SVC SVC 1,X'3C' I/O WAIT SVC LW X3,PBLKA GET PBLK ADDRESS FOR ERROR REPORTING SPACE 3 CHKERR EQU $ TBM 1,FCB.SFLG,X1 TEST FOR I03 ERROR BIT BCF SET,NERROR SKIP TO NERROR IF BIT NO SET TBM 6,FCB.SFLG,X1 EOF CHECK BS EOFRTRN TBM 7,FCB.SFLG,X1 EOM CHECK BS EOMRTRN LW R6,FCB.SFLG,X1 GET ENTIRE STATUS WORD BU RETURN PAGE * * ERROR RETURNS * NERROR EQU $ ZMW 3W,X3 SET NO ERROR DATA TRSW R0 PROCESS ADDITIONAL DATA SPACE 1 EOFRTRN EQU $ LI R6,EOFERR LOAD EOF ERROR DATA BU RETURN SPACE 1 EOMRTRN EQU $ LI R6,EOMERR LOAD EOM ERROR DATA BU RETURN SPACE 1 TCERR EQU $ LI R6,BCNTERR LOAD INCORRECT BYTE CNT ERROR BU RETURN SPACE 1 RNERR EQU $ LI R6,RECNERR LOAD REC # ERROR DATA BU RETURN SPACE 1 RELRTRN EQU $ LI R6,RECLERR GET ERROR CODE & PUT IN R6 LA X3,*2W,X1 GET ADDRESS OF PBLK * RETURN EQU $ STW R6,PBK.SFLG,X3 PUT DATA IN PBLK(3) BU *N.X RETURN TO CALLING PROGRAM * END PROGRAM MSEC DEF MSEC *= SUBROUTINE MSEC (TIME) * INTEGER TIME !time in milliseconds *= Time in milliseconds since midnight * * CALL MSEC(I) * * I = INTEGER*4 * I = TIME IN M-SEC * * M.EQUS * * BOUND 1W MSEC EQU $ LW R5,C.BTIME GET TIME IN 100 MICRO SECOND UNIT ZR R4 DVI R4,10 CONVERT TO MILI SECOND STW R5,0W,R1 STORE CURRENT VALUE OF TIME TRSW R0 RETURN TO CALLING PROGRAM * * END PROGRAM TLINE 0.0 DEF TLINE * *= SUBROUTINE TLINE (S) * CHARACTER*(*) S !STRING FROM TERMINAL LINE BUFFER * *= Extracts the current terminal line buffer * M.EQUS CR EQU X'0D' NULL EQU 0 BLANK EQU C' ' S EQU 1W SLEN EQU 2W * * DATA * BOUND 1W RETURN RES 1W * * TLINE * BOUND 1W TLINE EQU $ TRR R0,X1 INDEX ARGUMENTS ABR R0,29 ADMW R0,0,X1 BUMP OVER ARGUEMENT COUNT STW R0,RETURN SAVE FOR RETURN SPACE 3 * * LOOP AND COPY LINE BUF * LA X3,*S,X1 GET S ADDRESS LW R5,*SLEN,X1 GET LENGTH OF S LW X2,C.TSAD TSA ADDRESS LW X2,T.LINBUF,X2 LINE BUFFER ADDRESS BZ TLINE.3 NO LINE BUFFER, DO NOT READ LB R6,4W,X2 TSM BUFFER SIZE SLA R6,2 CONVERT WORD TO BYTE COUNT CAR R5,R6 WHICH IS GREATER FOR XFER LIMIT BLE TLINE.1 TSM BUFFER IS SMALLER TRR R5,R6 STRING TO XFER TO IS SMALLER TLINE.1 EQU $ ADI X2,5W TSM LINE BUFFER ADDRESS TRN R6,R6 NEGATIVE FOR LOOP TLINE.2 EQU $ TOP OF LOOP LB R7,0,X2 GET FIRST BYTE CI R7,CR END OF INPUT? BEQ TLINE.3 CI R7,NULL GUARD AGAINST OVER RUN BEQ TLINE.3 STB R7,0,X3 PUT IN STRING ADI X2,1B NEXT CHARACTER ADI X3,1B NEXT SLOT IN S SUI R5,1B DECREMENT S LENGTH LEFT BIB R6,TLINE.2 TLINE.3 EQU $ SPACE 3 * * NOW BLANK FILL IF NECESSARY * TRN R5,R5 TEST FOR ANY LEFT BNN TLINE.5 FILLED UP LI R7,BLANK TLINE.4 EQU $ STB R7,0,X3 BLANK FILL ADI X3,1B NEXT BYTE BIB R5,TLINE.4 CONTINUE TLINE.5 EQU $ BU *RETURN RETURN END PROGRAM M_UPRIV DEF M_PRIV * *= SUBROUTINE M_PRIV * *= converts the calling task to privileged. * Note that the task must have been cataloged privileged for this * to work. * * DEF M_UPRIV *= SUBROUTINE M_UPRIV * *= converts the calling task to unprivileged. * * Privilege * By: L. Tate * On: May 17, 1983 * Purpose: Call these two routines to change from a privileged * state to an unprivileged. * * Inputs: none * Outputs: none * * Notes: Must be cataloged privileged to call these routines. ****************************************************************** M.EQUS !system equates * * M_PRIV * M_PRIV EQU $ M.PRIV !ref. mpx 32 2.1 vol I: 8.2.36 TRSW R0 !done and home * * M_UPRIV * M_UPRIV EQU $ M.UPRIV !ref mpx 32 2.1 vol I: 8.2.54 TRSW R0 !done and home END PROGRAM HIO 2.0 DEF HIO *= LOGICAL FUNCTION HIO (LFC) * INTEGER LFC logical file to halt io on * LOGICAL HIO success = T, failure = F * *= Halts the io over the specified lfc. * This is a privileged instrucion and results will be unpredicable * if you halt something other than a terminal. Be careful. * 1.0 LHT automatically attempts to make user privileged if unprivileged * 2.0 LHT fault in determining if integer or not and error test M.EQUS M.TBLS PARMAREA REZ 8W parameter area for inquiry LFCINQ REZ 1D local lfc as parameter RETURN REZ 1W return address SRL SRL R6,0 dummy shift right logical SLLD SLLD R6,0 dummy shift left logical double SLL SLL R6,0 BOUND 1W HIO EQU $ STW R0,RETURN save return address * * lfc is either integer or character, determine which and handle * LW R7,0,X1 get LFC SRL R7,24 isolate first byte TRR R7,R7 test first byte BZ HIO.INT integer * * character in integer format * LW R6,0W,X1 get lfc SRL R6,8 right justify lfc ZR R7 clear 7 BU HIO.LFC now set up inquiry * * integer version * HIO.INT EQU $ LW R5,0W,X1 get lfc SVC 1,X'2A' convert to decimal LI R5,-3 loop three times TRR R7,R3 store in 3 for destructive test SLL R7,8 left justify ZR R4 zero counter ZBR R0,0 reset flag HIO.SHF EQU $ ZR R6 SLLD R6,8 get first byte CI R6,X'30' zero BNE HIO.SH1 donot count TBR R0,0 test for leading BS HIO.SH2 no count ADI R4,1 increment BU HIO.SH2 skip HIO.SH1 EQU $ SBR R0,0 set non zero flag HIO.SH2 EQU $ BIB R5,HIO.SHF SLL R4,3 *8 TRR R3,R6 retrieve lfc ADI R4,8 8 bit shift plus LH R1,SLL going to strip leading zeros BL SHIFTER LH R1,SRL right bound BL SHIFTER SUI R4,8 back to original count LW R7,=C' ' blank mask LH R1,SLLD get slld instruction BL SHIFTER shift ZR R7 BU HIO.LFC rejoin mainstream HIO.LFC EQU $ STD R6,LFCINQ set up inquiry M.INQUIRY PARMAREA,LFCINQ inquiry for udt table BS ERROR branch if inquire error LW R1,2W+PARMAREA udt address BZ ERROR not a device TBM UDT.IOUT,UDT.FLGS,X1 test for outstanding io BNS ERROR no io to halt LW R6,1W,X1 get logical address SLL R6,8 strip status SRLD R6,24 strip logical address SRL R7,16 right justify logical address CI R6,X'0C' test for TY type BEQ HIO.TY CI R6,X'11' test for u0 BLT ERROR CI R6,X'1A' test for u9 BGT ERROR HIO.TY EQU $ LW R6,3W,X1 get physical address SRL R6,16 right justified TRR R6,R6 test for zero BZ HIO.1 use logical address TRR R6,R7 use physical address HIO.1 EQU $ TBM 0,RETURN test for priv BS HIO.5 M.PRIV make priv HIO.5 EQU $ HIO R7,0 halt io BCT 6,ERROR error on cc3 or cc4 BCT 2,ERROR error on cc2 set LI R7,-1 fortran true BU HIO.10 ERROR EQU $ ZR R7 fortran false BU HIO.10 HIO.10 EQU $ TBM 0,RETURN BS HIO.15 leave in entrance state M.UPRIV HIO.15 EQU $ BU *RETURN home * * SHIFTER merges N and instruction and perfroms shift * * R1 - instruction * R4 - count * R1 is destroyed * SHIFTER EQU $ ORR R4,R1 or in count EXRR R1 perform shift TRSW R0 return END PROGRAM TTYF 0.0 DEF TTYCURF *= LOGICAL FUNCTION TTYCURF (PBLK, SENSE) * INTEGER PBLK(4) !dio parameter block * INTEGER*8 SENSE !returns the result of sense test * *= TTYCUR tests the port for current configuration. * DEF TTYINIF *= SUBROUTINE TTYINIF (PBLK, INIT) * INTEGER PBLK(4) dio parameter block * INTEGER INIT initialization word * *= Inits the port to the specified initialization. * * TTYCURR returns the current initialization of a terminal on an * asynchronus eight line. This version is compatable with with the * magical FCBINIT/DPREAD/DPWRITE/DREAD/DWRITE routines. Since the * address of the fcb is the first word of the parameter block, just * specify the parameter block as the first parameter. * EX: * CALL TTYCURF(PBLK, SENSE) * OR: * CALL TTYINIF(PBLK, INIT) * major problem with previous version was the internal open involved. * * definitions * M.EQUS ARGS EQU 0 offset to find argument count FCB EQU 1W offset to find lfc SENSE EQU 2W offset to place initialization INIT EQU 2W initialization command ERROR EQU 1 bit 1 of word 3 is error flag * * local variables * BOUND 1D OLDCOM DATAW 1W FCBADDR DATAW 0 RETURN DATAW 0 C.SENSE DATAW X'02000000' expanded format C.SPCHR DATAW X'02000000' expanded format C.INIT DATAW X'22400000' expanded format WORDMASK DATAW X'0007FFFC' ensure word address BOUND 1W INITPARM EQU $ ACE DATAB 0,0,0 ace parameters to use SPECHAR DATAB 0 special character INITBUF DATAW 0 SPCHRBUF DATAW 0 SPCHRAD ACW SPCHRBUF byte address of special character ACEADDR ACW INITBUF byte address of ace parameters ENTRY DATAW 0 * * ttycurr * TTYCURF EQU $ LA R7,TTY.10 sense program STW R7,ENTRY set up future BU TTY.5 set up return * * ttyinit * TTYINIF EQU $ LA R7,TTY.20 STW R7,ENTRY save for future BU TTY.5 * * set up return * TTY.5 EQU $ TRR R0,R1 save arguement pointer ABR R0,29 bump over arguement counter ADMW R0,ARGS,X1 add number of arguements STW R0,RETURN save returen address BU *ENTRY perform task * * set up fcb and open * BOUND 1W TTY.10 EQU $ LW R4,WORDMASK address mask LW R2,*FCB,X1 get lfc LW R7,2W,X2 save old command STW R7,OLDCOM LA R7,*SENSE,X1 STMW R7,8W,X2 use SENSE for buffer LW R7,C.SENSE place commands in fcb STW R7,2W,X2 LI R7,8B byte count for sense STW R7,9W,X2 STW R2,FCBADDR save fcb address * * sense terminal * TRR R2,R1 set up sense SVC 1,X'37' stat LW R2,FCBADDR retrieve fcb address LW R7,OLDCOM retrieve STW R7,2W,X2 TBM ERROR,3W,X2 check error bit BS TTY.19 error * * return true * LI R7,-1 return true BU *RETURN * * error * TTY.19 EQU $ ZR R7 BU *RETURN * * initialize terminal * BOUND 1W TTY.20 EQU $ LW R7,*INIT,X1 initialize to perform STW R7,INITPARM isolate for commands STW R7,INITBUF LB R7,SPECHAR special character STB R7,SPCHRBUF * * open * LW R2,*FCB,X1 get fcb address LW R7,2W,X2 get old command STW R7,OLDCOM * * initialize ace parameters * LW R7,C.INIT init ace command STW R7,2W,X2 LW R7,ACEADDR address of ace STW R7,8W,X2 command buffer LI R7,3B transfer 3 bytes STW R7,9W,X2 byte count STW R2,FCBADDR save address TRR R2,R1 set up write SVC 1,X'32' LW R2,FCBADDR retrieve fcb address TBM ERROR,3W,X2 error bit BS TTY.29 error return * * special character * LW R7,C.SPCHR special character command STW R7,2W,X2 new command LW R7,SPCHRAD special character address STW R7,8W,X2 LI R7,1B transfer 1 byte STW R7,9W,X2 TRR R2,R1 set up special char init SVC 1,X'0D' set special char LW R2,FCBADDR retrieve fcb address TBM ERROR,3W,X2 test for error BS TTY.29 error return * * return good news * LW R7,OLDCOM STW R7,2W,X2 replace LI R7,-1 fortran true BU *RETURN * * error address * TTY.29 EQU $ LW R7,OLDCOM STW R7,2W,X2 replace ZR R7 fortran false BU *RETURN END PROGRAM L.UDT 1.1 DEF SUDT *= SUBROUTINE SUDT(PBLK, MODE) * INTEGER PBLK dio parameter block attached to ty * CHARACTER*4 MODE mode to set * *= Sets the terminal to the specified operating mode. DEF TUDT * *= LOGICAL FUNCTION TUDT(PBLK, MODE) * * INTEGER*4 PBLK(4) !dio parameter block attached to ty * CHARACTER*4 MODE !mode to test or set * * Result is returned as a logical function * *= Tests for a particular mode. * M.EQUS M.TBLS * * data * BOUND 1D LFCB RES 8W LOCAL FCB FOR SVC'S RETURN RES 1W UDTA RES 1W ADDRESS OF TERMINAL LMODE RES 1W LOCAL MODE FOR COMPARE FLAGS RES 1W TEST EQU 0 FIRST BIT IS TEST MODE FLAG MODES DATAW C'ONLI' DATAW C'TSM ' DATAW C'LOGO' USER LOGGED ON DATAW C'FULL' DATAW C'HALF' DATAW C'ECHO' DATAW C'NOEC' NO ECHO DATAW C'DEAD' DATAW C'USE ' IN USE DATAW C'ALIV' ALIVE DATAW C'DUAL' DUAL CHANNEL MODE DATAW C'SING' SINGLE CHANNEL MODE NMODES EQU $-MODES TESTBITS EQU $ TBM UDT.ONLI,UDT.STAT,X3 TEST FOR ONLINE TBM UDT.TSM,UDT.STAT,X3 TEST FOR TSM TBM UDT.LOGO,UDT.FLGS,X3 TEST FOR LOGON TBM UDT.FDUX,UDT.BIT2,X3 FULL DUPLEX TBM UDT.FDUX,UDT.BIT2,X3 HALF DUPLEX TBM UDT.ECHO,UDT.BIT2,X3 ECHO TBM UDT.ECHO,UDT.BIT2,X3 NO ECHO TBM UDT.DEAD,UDT.BIT2,X3 DEAD TBM UDT.USE,UDT.BIT2,X3 IN USE NOP DUAL NOP NOP SINGLE NOP SETBITS EQU $ TBM UDT.ONLI,UDT.STAT,X3 TEST FOR ONLINE TBM UDT.TSM,UDT.STAT,X3 TEST FOR TSM TBM UDT.LOGO,UDT.FLGS,X3 TEST FOR LOGON SBM UDT.FDUX,UDT.BIT2,X3 FULL DUPLEX ZBM UDT.FDUX,UDT.BIT2,X3 HALF DUPLEX SBM UDT.ECHO,UDT.BIT2,X3 ECHO ZBM UDT.ECHO,UDT.BIT2,X3 NO ECHO SBM UDT.DEAD,UDT.BIT2,X3 DEAD TBM UDT.USE,UDT.BIT2,X3 IN USE ZBM UDT.DEAD,UDT.BIT2,X3 ALIVE SVC 1,X'27' DUAL SVC 1,X'26' SINGLE MODTEST EQU $ MODIFY THE RESULT OF TEST DATAB 0 ONLINE DATAB 0 TSM DATAB 0 LOGON DATAB 0 FULL DATAB 255 NOT FULL DATAB 0 ECHO DATAB 255 NOT ECHO DATAB 0 DEAD DATAB 0 IN USE DATAB 0 NOT ALIVE DATAB 0 DUAL DATAB 0 SINGLE * SUDT EQU $ ZBM TEST,FLAGS SHOW ENTRANCE BU UDT.1 TUDT EQU $ SBM TEST,FLAGS SHOW ENTRANCE BU UDT.1 UDT.1 EQU $ COMMON CODE TRR R0,X1 INDEX REGISTER ABR R0,29 BUMP OVER COUNT ADMW R0,0,X1 ADD COUNT STW R0,RETURN RETURN ADDRESS LW X2,*1W,X1 GET FCB ADDRESS BZ FALSE NO FCB ADDRESS LW R7,0,X2 GET LFC LW X2,C.TSAD START OF TSA LW X3,T.FPTA,X2 FILE POINT TABLE ADDRESS LNB R5,T.FILES,X2 NUMBER OF FPT'S LW R4,=X'00FFFFFF' LFC MASK UDT.2 EQU $ CMMW R7,0,X3 IS THIS THE LFC BEQ UDT.3 ADI X3,3W BUMP FPT POINTER BIB R5,UDT.2 LOOP BU FALSE NOT HERE UDT.3 EQU $ FOUND TBM 4,4B,X3 ENTRY IN USE? BS FALSE NO LW X3,2W,X3 FAT ADDRESS LH X3,3H,X3 UDT INDEX BZ FALSE NO UDT INDEX SLA X3,6 * WORD SIZE * UDT SIZE ADMW X3,C.UDTA MAKE A UDT ADDRESS LB R7,UDT.DTC,X3 GET TYPE CI R7,X'C' MUST BE TY TYPE BNE FALSE NOT GOOD STW X3,UDTA STORE IN UDT ADDRESS * * NOW DETERMINE WHICH FLAG I WANT TO SET * LNW R5,*3W,X1 GET STRING SIZE LI R4,-4 SIZE OF LMODE LA X2,*2W,X1 MODE STRING POINTER LA X3,LMODE LOCAL COPY OF MODE LW R7,=C' ' BLANK OUT LOCAL COPY STW R7,LMODE UDT.4 EQU $ LB R7,0,X2 GET FIRST BYTE STB R7,0,X3 PUT AWAY ABR X2,31 BUMP POINTERS ABR X3,31 BUMP POINTERS ADI R4,1 INCREMENT LOCAL COUNTER BZ UDT.5 ENOUGH BIB R5,UDT.4 MORE TO COME UDT.5 EQU $ LI R4,-NMODES GET NUMBER OF MODES LW R7,LMODE GET MODE SELECTED ZR X2 OFFSET OF FIRST MODE UDT.6 EQU $ CAMW R7,MODES,X2 IS THIS THE MODE BEQ UDT.7 FOUND ADI X2,1W BUMP INDEX BIW R4,UDT.6 CONTINUE SEARCH BU FALSE NOT FOUND IN LIST UDT.7 EQU $ FOUND * * LETS DO IT! * ZMD LFCB MUST ZERO LOCAL FCB ZMD LFCB+2W ZMD LFCB+4W ZMD LFCB+6W LW X1,*1W,X1 GET FCB ADDRESS LW R7,0,X1 GET LFC STW R7,LFCB STORE LOCALY LA X1,LFCB USE LOCAL FCB LW X3,UDTA RETREIVE UDT ADDRESS TBM TEST,FLAGS TEST ONLY? BS UDT.TST TBR R0,0 ARE WE PRIVILEGED? BS UDT.8 YEP M.PRIV UDT.8 EQU $ LW R7,SETBITS,X2 GET COMMAND EXR R7 DO IT TBR R0,0 WHERE WE PRIVILEGED BS UDT.9 YEP M.UPRIV EXIT WAY CAME UDT.9 EQU $ LI R7,-1 BU *RETURN GO HOME * * TEST LOGIC * UDT.TST EQU $ ZR R7 ASSUME FALSE LW R6,TESTBITS,X2 GET TEST INSTRUCTION EXR R6 TEST BIT BNS UDT.10 NOT SET LI R7,255 SET UDT.10 EQU $ SRA X2,2 BYTE BOUND INDEX EOMB R7,MODTEST,X2 SOME ARE NOT'S BU *RETURN HOME * * ERROR RETURN * FALSE EQU $ ZR R7 BU *RETURN HOME END PROGRAM INKEY 0.0 DEF INKEY *= LOGICAL FUNCTION INKEY(LFC, FCB, CHR) * INTEGER LFC lfc to read from * INTEGER FCB(9) fcb to use (zero'd initially) * INTEGER*1,*2,*4 CHR character read in nowait form * * returns .true. if character input * *= Returns a single character typed to lfc. User must echo. * M.EQUS M.TBLS LFC EQU 1W FCB EQU 2W CHR EQU 3W * * inkey * R0 return * X1 fcb address * X2 arguement list pointer * R4 mask to extract leading byte * R5 numeric lfc * R7 alpha lfc and transient register * BOUND 1W INKEY EQU $ TRR R0,X2 arg pointer ABR R0,29 bump over arg count ADMW R0,0W,X2 bump over args * * check for initialization * LA X1,*FCB,X2 get fcb address LW R7,FCB.LFC,X1 get first word of fcb BNZ INKEY.10 already initialized * * initialize * LW R7,*LFC,X2 get lfc LW R4,=X'FF000000' lfc mask TRRM R7,R5 test for numeric or alpha BNZ INKEY.5 alpha TRR R7,R5 set up conversion SVC 1,X'2A' convert binary to decimal CI R5,100 less than 100? BGE INKEY.2 no shift since uses 3 digits SLC R7,8 move leading blank to end CI R5,10 only one byte long? BGE INKEY.2 no SLC R7,8 move leading blank to end INKEY.2 EQU $ SLL R7,8 make like alpha INKEY.5 EQU $ SRL R7,8 right justify 3 chr lfc STW R7,FCB.LFC,X1 store lfc in fcb LW R7,=X'E0600000' nowait,noerror,dfi,noecho,noconv STW R7,FCB.GCFG,X1 store in control flags TRR X1,R7 fcb address ADI R7,8W buffer to use is end of fcb SBR R7,12 make byte address SBR R7,11 count of one STW R7,FCB.TCW,X1 store tcw * * do normal processing * INKEY.10 EQU $ TBM 0,FCB.SFLG,X1 test for io completion BS INKEY.20 still processing LB R7,8W,X1 get character received STW R7,*CHR,X2 return character input LNW R7,FCB.RECL,X1 transfer count of -1 is T, 0 is F SVC 1,X'31' read BU INKEY.30 read processing done INKEY.20 EQU $ read not complete ZMW *CHR,X2 zero out character input LI R7,0 false INKEY.30 EQU $ exit TRSW R0 return END PROGRAM HIOALL 0.0 DEF HIOALL *= SUBROUTINE HIOALL * *= Kills all pending io for this task. * Must be privileged to do this * M.EQUS * BOUND 1W HIOALL EQU $ TBR R0,0 privileged? BS ALL.1 yes M.PRIV ALL.1 EQU $ M.CALL H.IOCS,38 do it TBR R0,0 privileged? BS ALL.2 yes M.PRIV ALL.2 EQU $ TRSW R0 return END