home *** CD-ROM | disk | FTP | other *** search
/ Columbia Kermit / kermit.zip / archives / gould2.tar.gz / gould2.tar / gm2kerm.asm next >
Assembly Source File  |  1988-08-16  |  55KB  |  1,419 lines

  1.          TITLE     DIO V17 -- DISK INPUT OUTPUT PROGRAM
  2.          PROGRAM   DIO   17
  3. *
  4.          DEF       FCBINIT         FILE CONTROL BLOCK INITIALIZE
  5. *=    SUBROUTINE FCBINIT (LFC, PBLK, FUNC, RECLEN, *ERR, *NOWAIT)
  6. *          INTEGER    LFC          logical file code
  7. *          INTEGER    PBLK(4)      parameter block to be filled
  8. *          INTEGER    FUNC         function code for FCB
  9. *          INTEGER    RECLEN       length of record for blocking
  10. *          ADDRESS    ERR          error return address
  11. *          ADDRESS    NOWAIT       no wait normal return address
  12. *= Initialize the parameter block for future reads and writes
  13.            SPACE   3
  14.          DEF       DPWRITE         NO-WAIT I/O COMPLETE SECTOR WRITE
  15. *=    SUBROUTINE DPWRITE (PBLK, BUFFER, COUNT, RECORD, *ERR, *NOWAIT)
  16. *          INTEGER    PBLK(4)      parameter block
  17. *          *          BUFFER       buffer to write (int *1,2,4,char)
  18. *          INTEGER    COUNT        count of bytes to write
  19. *          INTEGER    RECORD       record number to write to
  20. *= Write unblocked to device/file defined by PBLK
  21.          SPACE     3
  22.          DEF       DPREAD          NO-WAIT I/O COMPLETE SECTOR READ
  23. *          INTEGER    PBLK(4)      parameter block to be filled
  24. *=    SUBROUTINE DPREAD (PBLK, BUFFER, COUNT, RECORD, *ERR, *NOWAIT)
  25. *= Read unblocked from device/file defined by PBLK
  26.          DEF       DWRITE          WAIT I/O PARTIAL SECTOR WRITE
  27. *          INTEGER    PBLK(4)      parameter block to be filled
  28. *=    SUBROUTINE DWRITE (PBLK, BUFFER, COUNT, RECORD, *ERR, *NOWAIT)
  29. *= Write blocked to a file defined by PBLK
  30.          DEF       DREAD           WAIT I/O PARTIAL SECTOR READ
  31. *=    SUBROUTINE DREAD (PBLK, BUFFER, COUNT, RECORD, *ERR, *NOWAIT)
  32. *          INTEGER    PBLK(4)      parameter block to be filled
  33. *= Read blocked from a file defined by PBLK
  34.          DEF       DERROR          RETURN ERROR CODES
  35. *=    INTEGER FUNCTION DERROR (PBLK)
  36. *= Return status of last io on the PBLK
  37.          DEF       DPCOUNT         COUNT OF BYTES TRANSFERED
  38. *=    INTEGER FUNCTION DPCOUNT (PBLK)
  39. *= Return byte count of last io transfer on the PBLK
  40.          PAGE
  41. *
  42. * AUTHOR: A D PATEL               DATE: 1982
  43. * REVISIONS:
  44. *     X14          L. TATE (4/29/84)
  45. *                  -NO WAIT IO DOES NOT CHECK ERROR OF PREVIOUS ATTEMPT
  46. *                  -ENTRY DERROR ADDED TO RETURN ERROR CODE (REENTRANT)
  47. *     X15          L. TATE (7/5/84)
  48. *                  -DATA BUFFER MAY BE IN EXTENDED MEMORY.
  49. *     X15.1        L. TATE (9/5/84)
  50. *                  -THE FORMAT BIT IS NOW CLEARED ON BYTE BUFFERS
  51. *     X16          L. TATE (1/7/85)
  52. *                  -ALLOW LOCAL ERROR/END ACTION RETURNS
  53. *     X16.1        LTATE (4/15/85)
  54. *                  -REARRANGED ERROR TESTING SO EOF WILL BE DETECTED.
  55. *     X16.2        LTATE (5/13/85)
  56. *                  -ENSURED EXTENDED ADDRESSING WAS CANCELED WHEN SET.
  57. *     X17          LTATE (5/27/85)
  58. *                  -RETURN TRANSFER COUNT AS FUNCTION VALUE
  59. *
  60. *
  61. *        TO USE THESE FUNCTIONS INCLUDE  $OBJECT
  62. *                                        $SELECTF ^(SEMS)O.DIO15
  63. *
  64. *        THIS SET OF PROGRAMS CAN BE CALLED
  65. *        FROM FORTRAN BY THE FOLLOWING CSQ'S
  66. *
  67. *        CALL FCBINIT (LU   ,PBLK  ,FUNC   ,RECLN,$NN,$NN1)
  68. *        CALL DREAD   (PBLK ,BUFFER,BYTECNT,RECNO,$NN,$NN1)!WAIT I/O
  69. *        CALL DPREAD  (PBLK ,BUFFER,BYTECNT,RECNO,$NN,$NN1)!NO_WAIT I/O
  70. *        CALL DWRITE  (PBLK ,BUFFER,BYTECNT,RECNO,$NN,$NN1)!WAIT I/O
  71. *        CALL DPWRITE (PBLK ,BUFFER,BYTECNT,RECNO,$NN,$NN1)!NO_WAIT I/O
  72. *        ERROR = DERROR(PBLK)                              !ERROR CHECK
  73. *        COUNT = DPCOUNT(PBLK)                             !BYTE COUNT
  74. *
  75. *        BYTECNT= INTEGER*4; # OF BYTES FOR THIS I/O
  76. *
  77. *        LU     = INTEGER*4; NO-CHARACTER ARGUMENTS ALLOWED
  78. *                            PLEASE DEFINE LU AS A PARAMETER SUCH THAT
  79. *                            IT CAN BE REASSIGNED TO DIFFRNT DEVICE EASE
  80. *        PBLK   = INTEGER*4; PBLK(4); PBLK FOR FCB ADDRS STOR & ERR STAT
  81. *
  82. *                            PBLK(1); FCB ADDRESS STORAGE LOCATION
  83. *                            PBLK(2); NOT USED (SPARE)
  84. *                            PBLK(3); NOT USED (SPARE)
  85. *                            PBLK(4); ERROR STATUS AS SPECIFIED BELOW
  86. *
  87. *        PBLK(4)= ERROR STATUS; FOLLOWING CODES ARE IMPLEMENTED
  88. *
  89. *        0      = I/O COMPLETE WITHOUT ERROR
  90. *        1      = REC # .LE. 0
  91. *        2      = BYTECNT .LE. 0
  92. *        3      = EOF
  93. *        4      = EOM
  94. *        5      = RECORD LENGTH .LT. 0
  95. *
  96. *        BUFFER = DATA BUFFER IN INTEGER OR CHARACTER FORMAT
  97. *                 MAY BE IN EXTENDED MEMORY
  98. *
  99. *        BYTECNT  # OF BYTES FOR THIS TRANSFER
  100. *
  101. *        RECNO    RECORD # FOR THIS I/O
  102. *
  103. *        FUNC      INTEGER*4  ; FUNC DATA/8Z0A000000/
  104. *                               REFER TO TABLE 7_4 OF MPX2.1 VOL 1,
  105. *                               PAGE 7-33 FOR DETAILS ON THESE BITS
  106. *        BIT ASSIGNMENT:        NO_WAIT I/O SPECIFICATION    BIT 0
  107. *                               NO ERROR RETURN PROCESSING   BIT 1
  108. *                               BINARY TRANSFER DFI          BIT 2
  109. *                               NO STATUS CHECK BY HANDLER   BIT 3
  110. *                               RANDOM ACCESS                BIT 4
  111. *                               BLOCKED I/O (DISC & TAPE)    BIT 5
  112. *                               EXPANDED FCB (MUST BE ON)    BIT 6
  113. *                               TASK WILL NOT ABORT          BIT 7
  114. *                               DEVICE FORMAT DEFINATION     BIT 8
  115. *
  116. *        $NN    = FATAL ERROR RETURN CHECK ENTIRE WORD & REFER TO
  117. *                 MPX2.1 VOLM 1.; FIG: 7-3; TABLE 7-4; FCB BIT INTERP
  118. *                 *NOTE* CAN BE SPECIFIED AT READ/WRITE CALL, BUT
  119. *                 FUTURE CALLS USE LAST SUPPLIED VALUE.
  120. *
  121. *        $NN1   = NO_WAIT I/O NORMAL RETURN STATEMENT LABEL; AFTER THIS
  122. *                 LABLE YOU MUST HAVE ( CALL X:XNWIO) TO  TERMINATE
  123. *                 NO_WAIT I/O.
  124. *                 *NOTE* CAN BE SPECIFIED AT READ/WRITE CALL, BUT
  125. *                 FUTURE CALLS USE LAST SUPPLIED VALUE.
  126. *
  127. *
  128. *
  129. *        The DREAD & DRITE routines can be used to perform I/O to disk
  130. *        files where record length are such that  FORTRAN random
  131. *        access routines cannot be used; (e.g. record length > 248
  132. *        bytes). These routines perform BLOCKING of data within the
  133. *        physical sector and has minimum overhead for the operation.
  134. *
  135. *
  136. *        The DPREAD & DPWRITE routines are general purpose I/O
  137. *        functions to perform I/O operations to any device. The FUNC
  138. *        word defines the type of operation that the routine will
  139. *        accomplish. It is totaly dependent on the functions implemented
  140. *        by the specific device driver. User can perform I/O in wait
  141. *        mode or no-wait mode. If the user wants to perform no-wait I/O
  142. *        he has to have $NN1; end action receiver established. The
  143. *        example of no-wait I/O is as follows:
  144. *
  145. *        CALL FCBINIT (LFC,PBLK,FUNC,RECLN,$NN,$NN1)
  146. *
  147. *        10        CONTINUE
  148. *
  149. *        CALL DPWRITE (PBLK,BUF,BYTECNT, irec ) ! irec option for random
  150. *                                                 access disk files only
  151. *
  152. *
  153. *        any FORTRAN or ASSEMBLY code
  154. *
  155. *        nn1       CONTINUE
  156. *
  157. *                  Any code including I/O to same LFC or any other
  158. *                  device. The I/O to the same LFC shold be before
  159. *                  the following X:XNWIO  function.
  160. *
  161. *                  CALL X:XNWIO
  162. *
  163. *
  164. *
  165. *
  166. *        REV 1.1   BY A. PATEL IMPELMET CHECKING OF NO WAIT BIT
  167. *                  TO BYPASS ERROR CHECKING FOR LAST I/O
  168. *                  ALSO ADD CODE TO CHECK ERR AT THE COMLETION OF I/O
  169. *                  IF THE WAIT BIT IS SET
  170. *
  171. *        REV 14.0  BY L.TATE IMPLEMENT DERROR ROUTINE
  172. *
  173. *                        ERROR = DERROR(PBLK)
  174. *
  175. *                  REENTRANT.... CAN BE CALLED FROM THE
  176. *                  ERROR AND END ACTION HANDLERS.
  177. *
  178. *            ERROR CODES:
  179. *
  180. *                  0  - NO ERROR
  181. *                  1  - REC # .LE. 0
  182. *                  2  - BYTECNT .LE. 0
  183. *                  3  - EOF
  184. *                  4  - EOM
  185. *                  5  - RECORD LENGTH .LT. 0
  186. *                  6  - INVALID BLOCKING BUFFER
  187. *                  7  - WRITE PROTECT
  188. *                  8  - INOPERABLE DEVICE
  189. *                  9  - BEGINNING OF MEDIUM
  190. *
  191. *        REV 15.0  BY L.TATE EXTENDED MEMORY BUFFER CAPABILITY
  192. *        REV 15.1  BY L.TATE CORRECTED CHARACTER ADDRESS MASKING
  193. *        REV 16    BY L.TATE ADDED LOCAL ERROR/END ACTION RETURNS.
  194. *
  195. *
  196.          PAGE
  197. *
  198. * EXTERNAL REFERENCES
  199. *
  200.          EXT       R.EF            POINTER TO # PARMS IN BL
  201.          EXT       E.RR            ERROR PROCESSOR
  202.          EXT       I.IO15          GET FCB + CHECKS
  203.          EXT       N.X             USER'S RETURN ADDRESS
  204.          EXT       R.X             ALTERNATE RETURN ADDRESS
  205.          EXT       F.F             FLAGS FOR I/O INITIALIZATION
  206.          EXT       N.CL            USER'S CALL ADDRESS
  207.          EXT       F.C             CURRENT FCB ADDRESS
  208.          EXT       REQ.PARM        REQUIRED PARAMETER PROCESSOR
  209.          EXT       OPT.ADDR        OPTIONAL ADDRESS PROCESSOR
  210.          EXT       REQ.ADDR        REQUIRED ADDRESS PROCESSOR
  211.          EXT       P_BLOCK         192W TEMPARARY WORK BUFFER
  212.          PAGE
  213. *
  214. * EQUATES
  215. *
  216.          M.EQUS                    GENERAL EQUATES
  217.          M.TBLS                    EQUATES FOR ALL TABLES
  218.          SPACE     3
  219. *
  220. *
  221. RANACCRL EQU       1W              RANDOM ACCESS RECOD LENGTH STORED IN
  222. PBK.SFLG EQU       3W              PARAMETER BLOCK ERROR STATUS
  223. BUFADDR  EQU       2W              BUFERR ADDRES POINTER  IN ARG
  224. PBKADDR  EQU       1W              PARAMETER BLOCK POINTER IN ARG
  225. FTN.I    EQU       0               INDIRECT BIT OF FORTRAN PARAMETER
  226. FTN.X    EQU       1               INDICATES ADDRESS IS 24 BITS LONG
  227. *
  228. *        ERROR CODES
  229. *
  230. NOERR    EQU       0               NO  ERROR
  231. RECNERR  EQU       1               RECORD #.LT. 0
  232. BCNTERR  EQU       2               TRANSFER COUNT .LT. 0
  233. EOFERR   EQU       3               EOF
  234. EOMERR   EQU       4               EOM
  235. RECLERR  EQU       5               RECORD LENGTH .LT. 0
  236. BB.ERR   EQU       6               INVALID BLOCKING BUFFER
  237. PRO.ERR  EQU       7               WRITE PROTECT VIOLATION
  238. INOP.ERR EQU       8               DEVICE IS INOPERABLE
  239. BOM.ERR  EQU       9               BEGINNING OF MEDIUM
  240.          PAGE
  241. *
  242. * LOCAL MEMORY
  243. *
  244.          BOUND     1W
  245. BLKSIZE  DATAW     768             BYTES IN A SECTOR
  246. X1SAVE   DATAW     0               SAVE OF PARAMETER POINTER
  247.          ACW       A(LFC)          NEEDED FOR I.IO15
  248. LFC      DATAW     0
  249. XMASK    DATAW     X'FFFFFF'       24 BIT ADDRESS MASK
  250. WMASK    DATAW     X'0007FFFF'     DATA BUFFER MASK; NO EXTENDED ADDRESS
  251. UBA      DATAW     0               USER BUFFER ADDRESS STORAGE
  252. TC       DATAW     0               USER REQUESTED TRANSFER COUNT IN BYTE
  253. RN       DATAW     0               USER REQUESTED RECORD #
  254. BSA      DATAW     0               SECTOR # FORM ORIGIN OF THE DISC FILE
  255. SWN      DATAW     0               RELATIVE WIDTH OF PARTIAL SECTOR I/O
  256. PBLKA    DATAW     0               TEMP STORAGE FOR PBLK ADDRESS
  257. FLAG     DATAH     0
  258. B0.FLAG  EQU       0               FLAG
  259. B1.FLAG  EQU       1               DIRECT PROCEED I/O READ/WRITE FLAG
  260. X.FLAG   EQU       2               THE BUFFER IS IN EXTENDED MEMORY
  261. COUNT    RES       1W              COUNT OF BYTES TRANSFERED
  262.          PAGE
  263.          BOUND     1W
  264. FCBINIT  EQU       $
  265.          TRR       R0,X1           SAVE R0 FOR ARG POINTER
  266.          LW        R7,0W,X1        GET # PARMS
  267.          ABR       R7,29           BUMP BY 4 FOR RETURN LOCATION
  268.          ADR       R7,R0           FIND RETURN LOCATION
  269.          STD       R0,N.X          *   ERROR EXITS
  270.          STW       X1,X1SAVE       SAVE X1 FOR LATER  USE
  271.          BL        REQ.PARM        GET LFC
  272.          STW       R7,LFC          SAVE LFC
  273.          LA        X1,X1SAVE       PUT ADDRESS # OF PARAMETERS IN X1
  274.          LI        R7,1
  275.          STB       R7,F.F
  276.          BL        I.IO15          FIND FCB ADDRESS
  277.          LW        X1,X1SAVE       RESTORE ARG POINTER IN X1
  278.          STW       X3,*2W,X1       SAVE FCB ADDRESS FOR LATER USE
  279.          LA        R5,*5W,X1       ERROR SUB ADDR TO R5
  280.          ANMW      R5,WMASK        STRIP HIGH BITS
  281.          STW       R5,FCB.ERRT,X3  PUT ERR ADDR AT FCB(6)
  282.          LW        R6,*3W,X1       GET EFUNCTION CODE & PUT IT IN FCB(2)
  283.          STW       R6,FCB.CBRA,X3  STORE AT GENERAL CONTROL SPEC
  284.          TBR       R6,4            IS THIS RAN ACCESS RECORD
  285.          BNS       FCB.1           NO RECL-LENGTH FOR THIS I/O
  286.          LW        R7,*4W,X1       GET RECORD LENGHT
  287.          BCT       LE,RELRTRN      RECORD LENGTH .LT. 0
  288.          STW       R7,RANACCRL,X3  STORE RANDOM ACCESS RECL-LENGTH IN 1W
  289.          BU        FCB.2
  290. *
  291. FCB.1    EQU       $
  292.          ZMW       RANACCRL,X3     CLEAR THE RANDOM ACCESS STORAGE
  293. *
  294. FCB.2    EQU       $
  295.          TBR       R6,0            IS IT A NO WAIT I/O
  296.          BNS       FCB.3           BY PASS STUFFING NO WAIT DATA
  297.          STW       R5,FCB.NWER,X3  PUT NO_WAIT ERROR RETURN ADDRESS IN F
  298.          LA        R5,*6W,X1       GET THE NORMAL RETURN ADDRESS
  299.          ANMW      R5,WMASK        MASK OUT HI LOW BITS
  300.          STW       R5,FCB.NWOK,X3  PUT NO_WAIT NORMAL RETURN ADDRESS
  301. *
  302. FCB.3    EQU       $
  303.          BU        *N.X
  304.          PAGE
  305. *
  306. *        DPWRITE   ENTRY POINT
  307. *
  308.          BOUND     1W
  309. DPWRITE  EQU       $
  310.          SBM       B1.FLAG,FLAG    SET WRITE IND
  311.          BU        DP.01           COMMON ROUTINE
  312.          SPACE     3
  313. *
  314. *        DPREAD    ENTRY POINT
  315. *
  316. DPREAD   EQU       $
  317.          ZBM       B1.FLAG,FLAG    CLEAR WRITE IND
  318.          SPACE     3
  319. DP.01    EQU       $
  320.          TRR       R0,X2           PUT LIST POINTER INTO X2
  321.          ABR       R0,29           +1W FOR ARG CNT
  322.          ADMW      R0,0W,X2        ADD # OF LIST BYTES
  323.          STD       R0,N.X          SAVE RETURN ADDRESS
  324.          BL        SETUP           SETUP ARGUMENTS FOR THIS CALL
  325.          LW        R5,UBA          GET USER BUFFER ADDRESS
  326.          STW       R5,FCB.ERWA,X1  STORE BUFFER ADDRESS IN FCB
  327.          LW        R6,TC           LOAD TRANSFER COUNT
  328.          STW       R6,FCB.EQTY,X1  STORE BYT CNT IN FCB(9)
  329.          TBM       4,FCB.GCFG,X1   IS IT A RANDOM ACCESS I/O
  330.          BNS       $+3W            BYPASS STORING OF RANDOM ACCESS ADR.
  331.          LW        R7,BSA          GET SECTOR #
  332.          STW       R7,FCB.ERAA,X1  STORE IT IN RANDOM ACESS ADDRESS
  333.          TBM       B1.FLAG,FLAG    TEST R/W FLAG
  334.          BCT       SET,WRIT        BR IF WRITE
  335.          SVC       1,X'31'         READ RECORD SVC
  336.          BU        DP.1            RETURN TO CALLER
  337. WRIT     SVC       1,X'32'         WRITE RECORD SVC
  338. *
  339. DP.1     EQU       $
  340.          TBM       0,FCB.GCFG,X1   IS IT A NO_WAIT I/O ?
  341.          BS        $+2W            BYPASS ERROR CHECKING & RTRN TO CALLE
  342.          BL        CHKERR          CHECK IF ANY ERROR DURING PREVIOUS I/
  343.          BU        *N.X            RETURN TO CALLER
  344.          PAGE
  345. *
  346. *        DREAD     ENTRY POINT
  347. *
  348.          BOUND     1W
  349. DREAD    EQU       $
  350.          TRR       R0,X2           PUT LIST POINTER INTO X2
  351.          ABR       R0,29           +1W FOR ARG CNT
  352.          ADMW      R0,0W,X2        ADD # OF LIST BYTES
  353.          STD       R0,N.X          SAVE RETURN ADDRESS
  354.          BL        SETUP           SETUP WORK AREA
  355. DREAD.1  LW        R6,TC           GET TRANSFER COUNT
  356.          BCT       LE,*N.X         EXIT IF NEG OR ZERO
  357.          LW        R5,SWN          GET STARTING WD NUMBER
  358.          BCF       ZR,DREAD.2      BR IF NOT START OF SECT
  359.          LW        R5,UBA          START OF SECT, GET BUFFER ADDR
  360.          STW       R6,FCB.EQTY,X1  PUT BYTE COUNT IN FCB(9)
  361.          STW       R5,FCB.ERWA,X1  STORE ADDRESS IN FCB(8)
  362.          LW        R5,BSA          GET STARTING SECT NO
  363.          STW       R5,FCB.ERAA,X1  PUT IN FCB(10)
  364.          SVC       1,X'31'         READ FILE
  365.          BL        DWAIT           WAIT FOR I/O COMP
  366.          BU        *N.X            RETURN
  367. DREAD.2  LA        R5,P_BLOCK      GET TEMP WORK BUF ADDRESS
  368.          STW       R5,FCB.ERWA,X1  PUT IN FCB
  369.          LW        R6,BLKSIZE      GET BLKSIZE IN BYTES
  370.          STW       R6,FCB.EQTY,X1  PUT IT IN FCB(9)
  371.          LW        R5,BSA          GET SECT ADDR
  372.          STW       R5,FCB.ERAA,X1  PUT SECT ADDRESS IN FCB(10)
  373.          ABM       31,BSA          BUMP SECTOR ADDR
  374.          SVC       1,X'31'         READ A SECT
  375.          BL        DWAIT           WAIT FOR I/O COMP
  376.          LNW       R5,BLKSIZE      GET MAX BYT CNT
  377.          ADMW      R5,SWN          ONLY REST OF BUFFER FOR TRANSFER
  378.          LA        X3,P_BLOCK      GET BUFFER ADDR
  379.          ADMW      X3,SWN          POINT TO START WD
  380.          LW        X2,UBA          GET USER BUFFER ADDR
  381.          LW        R4,TC           GET TRANSFER COUNT
  382.          ZMW       SWN             ZERO START WD NO
  383.          TBM       X.FLAG,FLAG     TEST FOR EXTENDED MEMORY
  384.          BNS       DREAD.3         SKIP OVER EXTENDED ADDRESSING
  385.          SEA                       SET EXTENDED ADDRESSING
  386. DREAD.3  LB        R6,0B,X3        GET BYTE
  387.          STB       R6,0B,X2        PUT BYTE
  388.          SUI       R4,1            REDUCE TC
  389.          BZ        DREAD.4         RETURN IF COMPLETE
  390.          STW       R4,TC           UPDATE LOCN
  391.          ABR       X3,31           BUMP ADDR
  392.          ABR       X2,31           BUMP ADDRE
  393.          ABM       31,UBA          BUMP USER BUFFER ADDR
  394.          BIB       R5,DREAD.3      LOOP UNTIL TRANSFER COMP
  395.          CEA                       CANCEL WHEN MOVE DONE, SET OR NOT
  396.          BU        DREAD.1         GO GET REST OF DATA
  397. DREAD.4  EQU       $
  398.          CEA                      CANCEL EXTENDED ADDRESSING ON EXIT
  399.          BU        *N.X            RETURN
  400.          PAGE
  401. *
  402. * DERROR
  403. *
  404.          BOUND     1W
  405. DERROR   EQU       $
  406.          LW        X2,0,X1         GET FCB ADDRESS
  407.          LW        R5,FCB.SFLG,X2  GET FCB STATUS
  408.          TBR       R5,2            BLOCKING BUFFER
  409.          BS        DERR.2
  410.          TBR       R5,3            WRITE PROTECT
  411.          BS        DERR.3
  412.          TBR       R5,4            DEVICE INOPERABLE
  413.          BS        DERR.4
  414.          TBR       R5,5            BEGINNING OF MEDIUM
  415.          BS        DERR.5
  416.          TBR       R5,6            EOF
  417.          BS        DERR.6
  418.          TBR       R5,7            EOM
  419.          BS        DERR.7
  420.          TBR       R5,1            ERROR
  421.          BNS       DERR.1          NO ERROR FOUND
  422.          SLL       R5,10           STRIP OUT PRE
  423.          SRL       R5,10           PUT BACK
  424.          TRN       R5,R7           RETURN IT
  425.          BU        DERR.99         RETURN
  426. DERR.1   EQU       $
  427.          LW        R7,PBK.SFLG,X1  GET ANY PBLK ERRORS
  428.          BU        DERR.99
  429. DERR.2   EQU       $
  430.          LI        R7,BB.ERR       BLOCKING ERROR
  431.          BU        DERR.99
  432. DERR.3   EQU       $
  433.          LI        R7,PRO.ERR      PROTECT ERROR
  434.          BU        DERR.99
  435. DERR.4   EQU       $
  436.          LI        R7,INOP.ERR     INOPERABLE
  437.          BU        DERR.99
  438. DERR.5   EQU       $
  439.          LI        R7,BOM.ERR      BEGINNING OF MEDIUM
  440.          BU        DERR.99
  441. DERR.6   EQU       $
  442.          LI        R7,EOFERR       EOF
  443.          BU        DERR.99
  444. DERR.7   EQU       $
  445.          LI        R7,EOMERR
  446.          BU        DERR.99
  447. DERR.99  EQU       $
  448.          TRSW      R0              RETURN
  449.          PAGE
  450. *
  451. * DPCOUNT          RETURN COUNT OF BYTES TRANSFERED IN LAST READ
  452. *
  453.          BOUND     1W
  454. DPCOUNT  EQU       $
  455.          LW        X2,0,X1         GET FCB ADDRESS
  456.          BZ        DPCNT.Z         NOT A PROPER PBLK YET
  457.          TBM       0,3W,X2         TEST FOR OPERATION IN PROGRESS
  458.          BS        DPCNT.Z         NOT VALID COUNT YET
  459.          LW        R7,4W,X2        GET BYTE COUNT
  460.          TRSW      R0
  461. DPCNT.Z  EQU       $
  462.          ZR        R7              NOTHING TO RETURN
  463.          TRSW      R0
  464.          PAGE
  465. *
  466. *
  467. *                                  GET ARGUMENTS AND FIND SECTOR #
  468. *
  469. *
  470.          BOUND     1W
  471. SETUP    EQU       $
  472.          LW        X1,*PBKADDR,X2  GET FCB ADDR
  473.          LA        X3,*PBKADDR,X2  GET ADDRESS OF PARAMETERS BLOCK
  474.          STW       X3,PBLKA        STORE PBLK ADDRESS FOR ERR REPORTING
  475.          ZMW       PBK.SFLG,X3     ZERO PREVIOUS ERRORS
  476.          ZMW       FCB.SFLG,X1     ZERO PREVIOUS ERRORS
  477.          SPACE     3
  478. *
  479. * BUFFER MAY BE IN EXTENDED MEMORY, MUST MANUALLY GO DOWN
  480. * INDIRECT CHAIN TILL REACHED.
  481. *
  482.          TBM       FTN.I,BUFADDR,X2   TEST FOR PARAMETER WORD
  483.          BNS       SETUP.3         NORMAL PARAMETER
  484.          SPACE     3
  485. *
  486. * EXTENDED ADDRESS TYPE
  487. *
  488.          SBM       X.FLAG,FLAG     NOTE EXTENDED BUFFER
  489.          LW        X3,BUFADDR,X2   PARAMETER WORD
  490.          LW        X3,0,X3         GET FIRST ADDRESS
  491. SETUP.1  EQU       $
  492.          TBR       X3,FTN.I        TEST FOR PSEUDO-INDIRECT
  493.          BNS       SETUP.2         END OF LOOK
  494.          LW        X3,0,X3         NEXT WORD IN CHAIN
  495.          BU        SETUP.1         LOOP
  496. SETUP.2  EQU       $
  497.          TRR       X3,R6           PUT LIKE REST
  498.          ANMW      R6,XMASK        MASK OUT NON-ADDRESS DATA
  499.          ANMW      X3,=X'0F000000' CLEAR OUT REST
  500.          SRL       X3,24           ISOLATE BYTE
  501.          TRR       X3,R5           PUT IN 5 FOR TESTING
  502.          LW        X3,PBLKA        GET BACK THE PBLK ADDRESS
  503.          BU        SETUP.4         CONTINUE
  504.          SPACE     3
  505. *
  506. * NORMAL BUFFER ADDRESS FETCH
  507. *
  508. SETUP.3  EQU       $               NORMAL ARGUMENT PROCESSING
  509.          ZBM       X.FLAG,FLAG     NOTE NON-EXTENDED BUFFER
  510.          LA        R6,*BUFADDR,X2  GET CONTENT OF BUF ADDRESS LOCATION
  511.          ANMW      R6,WMASK        MASK OUT UNWANTED DATA
  512.          LB        R5,BUFADDR,X2   GET DATA TYPE OF BUFFER
  513.          SPACE     3
  514. *
  515. * TEST FOR TYPING NOW
  516. *
  517. SETUP.4  EQU       $
  518.          CI        R5,X'B'         IS IT CHARCTER TYPE
  519.          BNE       SETUP.5         NO, IT IS NOT CHARCTER
  520.          ADI       X2,4            ADJUST ARG PTR FOR DBL WRD ARG
  521. SETUP.5  EQU       $
  522.          CI        R5,X'01'        IS IT INTEGER*2 ARG
  523.          BNE       SETUP.6         NO, IT IS NOT INTEGRE*2
  524.          ZBR       R6,31           CLEAR C BIT
  525. SETUP.6  EQU       $
  526.          STW       R6,UBA          STORE IT
  527.          LW        R6,*3W,X2       GET BYTE COUNT
  528.          BCT       LE,TCERR        IF ZERO, RETURN
  529.          STW       R6,TC           SAVE
  530.          TBM       4,FCB.GCFG,X1   IS THIS A RANDOM ACCESS I/O
  531.          BNS       SETUP.7         NO NEED TO CALCULATE
  532.          LW        R7,*4W,X2       GET REL REC NO
  533.          BCT       LE,RNERR        IF ZERO, RETURN
  534.          STW       R7,RN           SAVE RECORD NUMBER
  535.          SUI       R7,1            CALCULATE
  536.          MPMW      R6,RANACCRL,X1  GET RECL-LN & MPMW TO GET POSITION
  537.          DVMW      R6,BLKSIZE      PHYSICAL
  538.          STW       R7,BSA          SECTOR NUM,
  539.          STW       R6,SWN          REL WD WITH SECTOR
  540.          SPACE     3
  541. *
  542. * GET OPTIONAL ERROR RETURN AND END ACTION ADDRESSES               X16
  543. *
  544. SETUP.7  EQU       $
  545.          ADI       X2,5W           BUMP PARAMETER POINTER TO ERROR RET
  546.          CAMW      X2,N.X          IS THERE AN ERROR RETURN?
  547.          BGE       SETUP.8         NO, USE PREVIOUS
  548.          LA        R7,*0,X2        GET ADDRESS
  549.          STW       R7,FCB.ERRT,X1  PUT IN WAIT ERROR RETURN
  550.          TBM       0,FCB.GCFG,X1   NO WAIT I/O
  551.          BNS       SETUP.8         DO NOT SETUP NO WAIT RETURN
  552.          STW       R7,FCB.NWER,X1  PUT IN NO-WAIT ERROR RETURN
  553. SETUP.8  EQU       $
  554.          ADI       X2,1W           BUMP PARAMETER POINTER TO NORMAL RET
  555.          CAMW      X2,N.X          IS THERE A NORMAL RETURN?
  556.          BGE       SETUP.9         NO, USE PREVIOUS
  557.          LA        R7,*0,X2        GET ADDRESS
  558.          STW       R7,FCB.NWOK,X1  PUT IN NO-WAIT END ACTION RETURN
  559. SETUP.9  EQU       $
  560.          TRSW      R0
  561.          PAGE
  562. *
  563. *        DWRITE    ENTRY POINT
  564. *
  565.          BOUND     1W
  566. DWRITE   EQU       $               WRITE ENTRY
  567.          TRR       R0,X2           PUT LIST POINTER INTO X2
  568.          ABR       R0,29           +1W FOR ARG CNT
  569.          ADMW      R0,0W,X2        ADD # OF LIST BYTES
  570.          STD       R0,N.X          SAVE RETURN ADDRESS
  571.          BL        SETUP           SETUP WORD AREA
  572. DWRITE.1 LW        R6,TC           GET WC
  573.          BCT       LE,*N.X         EXIT IF NEG OR ZERO
  574.          LW        R5,SWN          GET START WD NO
  575.          BCF       ZR,DWRITE.2     BR IF NOT FIRST
  576.          CAMW      R6,BLKSIZE      SEE IF OVER 192
  577.          BCT       LT,DWRITE.2     BR IF ONLY PART OF SECTOR
  578.          LW        R5,UBA          GET USER ADDR
  579.          LW        R6,BLKSIZE      GET SECT BYTE COUNT
  580.          STW       R5,FCB.ERWA,X1  PUT IN FCB
  581.          STW       R6,FCB.EQTY,X1  PUT BYTE COUNT IN FCB(9)
  582.          LW        R5,BSA          GET REL SECT NO
  583.          STW       R5,FCB.ERAA,X1  PUT SECTOR # IN FCB(10)
  584.          SVC       1,X'32'         WRITE THE WHOLE SECTOR
  585.          BL        DWAIT           WAIT FOR I/O COMPLETE
  586.          ABM       31,BSA          BUMP SECT ADDR
  587.          LW        R5,UBA          GET USER ADDR
  588.          ADMW      R5,BLKSIZE      UPDATE BY 192 WORDS
  589.          STW       R5,UBA          RESTORE IT
  590.          LW        R5,TC           GET TC
  591.          SUMW      R5,BLKSIZE      REDUCE BY 192
  592.          STW       R5,TC           UPDATE TRANSFER COUNT
  593.          BU        DWRITE.1        GO AGAIN
  594. DWRITE.2 LA        R5,P_BLOCK      PARTIAL SECT WRITE, GET WORK BUF ADDR
  595.          STW       R5,FCB.ERWA,X1  STO IN FCB
  596.          LW        R6,BLKSIZE      SECTOR SIZE
  597.          STW       R6,FCB.EQTY,X1  PUT IT IN BYTE COUNT FCB(9)
  598.          LW        R5,BSA          GET REL SECTNO
  599.          STW       R5,FCB.ERAA,X1  PUT SECTOR # IN FCB(10)
  600.          SVC       1,X'31'         READ SECTOR
  601.          BL        DWAIT           WAIT FORI/O COMPLETE
  602.          LNW       R5,BLKSIZE      SET MAX TRANSFER CNT
  603.          ADMW      R5,SWN          ONLY REST OF BUFFER FOR TRANSFER
  604.          LA        X3,P_BLOCK      GET WORK BUFFER ADDR
  605.          ADMW      X3,SWN          POINT TO STARTING WORD
  606.          LW        X2,UBA          GET USERT BUFFER ADDR
  607.          LW        R4,TC           GET TC
  608.          ZMW       SWN             RESET START WORD NO
  609.          TBM       X.FLAG,FLAG     EXTENDED ADDRESSING?
  610.          BNS       DWRITE.4        SKIP SET
  611.          SEA
  612.          NOP                       FORCE BOUNDING
  613. DWRITE.4 EQU       $
  614.          LB        R6,0B,X2        GET ONE BYTE
  615.          STB       R6,0B,X3        PUT ONE BYTE
  616.          SUI       R4,1            REDUCE TC
  617.          STW       R4,TC           STORE IT
  618.          TRR       R4,R4
  619.          BCT       ZR,DWRITE.3     CONTINUE
  620.          ABR       X3,31           BUMP ADDR
  621.          ABR       X2,31           BUMP ADDR
  622.          ABM       31,UBA          BUMP USER BUFFER POINTER
  623.          BIB       R5,DWRITE.4     LOOP TIL DONE
  624. DWRITE.3 EQU       $
  625.          CEA
  626.          LA        R5,P_BLOCK      GET WORK BUF ADDRESS
  627.          STW       R5,FCB.ERWA,X1  PUT IN WORK BUF ADDRESS IN FCB(8)
  628.          LW        R5,BSA          GET SA
  629.          STW       R5,FCB.ERAA,X1  PUT SECTOR # IN FCB(10)
  630.          ABM       31,BSA          BUMP SA
  631.          SVC       1,X'32'         WRITE TO DISK UPDATE SECT
  632.          BL        DWAIT           WAIT FOR I/O COMP
  633.          BU        DWRITE.1        CONTINUE PROCESSING
  634.          SPACE     3
  635. *
  636. DWAIT    EQU       $
  637.          TBM       0,FCB.GCFG,X1   IS IT A NO_WAIT I/O ?
  638.          BNS       $+2W            BYPASS I/O WAIT SVC
  639.          SVC       1,X'3C'         I/O   WAIT SVC
  640.          LW        X3,PBLKA        GET PBLK ADDRESS FOR ERROR REPORTING
  641.          SPACE     3
  642. CHKERR   EQU       $
  643.          TBM       1,FCB.SFLG,X1   TEST FOR I03 ERROR BIT
  644.          BCF       SET,NERROR      SKIP TO NERROR IF BIT NO SET
  645.          TBM       6,FCB.SFLG,X1   EOF CHECK
  646.          BS        EOFRTRN
  647.          TBM       7,FCB.SFLG,X1   EOM CHECK
  648.          BS        EOMRTRN
  649.          LW        R6,FCB.SFLG,X1  GET ENTIRE STATUS WORD
  650.          BU        RETURN
  651.          PAGE
  652. *
  653. *        ERROR RETURNS
  654. *
  655. NERROR   EQU       $
  656.          ZMW       3W,X3           SET  NO ERROR DATA
  657.          TRSW      R0              PROCESS ADDITIONAL DATA
  658.          SPACE     1
  659. EOFRTRN  EQU       $
  660.          LI        R6,EOFERR       LOAD EOF ERROR DATA
  661.          BU        RETURN
  662.          SPACE     1
  663. EOMRTRN  EQU       $
  664.          LI        R6,EOMERR       LOAD EOM ERROR DATA
  665.          BU        RETURN
  666.          SPACE     1
  667. TCERR    EQU       $
  668.          LI        R6,BCNTERR      LOAD INCORRECT BYTE CNT ERROR
  669.          BU        RETURN
  670.          SPACE     1
  671. RNERR    EQU       $
  672.          LI        R6,RECNERR      LOAD REC # ERROR DATA
  673.          BU        RETURN
  674.          SPACE     1
  675. RELRTRN  EQU       $
  676.          LI        R6,RECLERR      GET ERROR CODE & PUT IN R6
  677.          LA        X3,*2W,X1       GET ADDRESS OF PBLK
  678. *
  679. RETURN   EQU       $
  680.          STW       R6,PBK.SFLG,X3  PUT DATA IN PBLK(3)
  681.          BU        *N.X            RETURN TO CALLING PROGRAM
  682. *
  683.          END
  684.          PROGRAM   MSEC
  685.          DEF       MSEC
  686. *=    SUBROUTINE MSEC (TIME)
  687. *          INTEGER   TIME         !time in milliseconds
  688. *= Time in milliseconds since midnight
  689. *
  690. *        CALL MSEC(I)
  691. *
  692. *        I = INTEGER*4
  693. *        I = TIME IN M-SEC
  694. *
  695. *
  696.          M.EQUS
  697. *
  698. *
  699.          BOUND     1W
  700. MSEC     EQU       $
  701.          LW        R5,C.BTIME      GET TIME IN 100 MICRO SECOND UNIT
  702.          ZR        R4
  703.          DVI       R4,10           CONVERT TO MILI SECOND
  704.          STW       R5,0W,R1        STORE CURRENT VALUE OF TIME
  705.          TRSW      R0              RETURN TO CALLING PROGRAM
  706. *
  707. *
  708.          END
  709.          PROGRAM   TLINE           0.0
  710.          DEF       TLINE
  711. *
  712. *=       SUBROUTINE TLINE (S)
  713. *             CHARACTER*(*) S      !STRING FROM TERMINAL LINE BUFFER
  714. *
  715. *= Extracts the current terminal line buffer
  716. *
  717.          M.EQUS
  718. CR       EQU       X'0D'
  719. NULL     EQU       0
  720. BLANK    EQU       C' '
  721. S        EQU       1W
  722. SLEN     EQU       2W
  723. *
  724. * DATA
  725. *
  726.          BOUND     1W
  727. RETURN   RES       1W
  728. *
  729. * TLINE
  730. *
  731.          BOUND     1W
  732. TLINE    EQU       $
  733.          TRR       R0,X1           INDEX ARGUMENTS
  734.          ABR       R0,29
  735.          ADMW      R0,0,X1         BUMP OVER ARGUEMENT COUNT
  736.          STW       R0,RETURN       SAVE FOR RETURN
  737.          SPACE     3
  738. *
  739. * LOOP AND COPY LINE BUF
  740. *
  741.          LA        X3,*S,X1        GET S ADDRESS
  742.          LW        R5,*SLEN,X1     GET LENGTH OF S
  743.          LW        X2,C.TSAD       TSA ADDRESS
  744.          LW        X2,T.LINBUF,X2  LINE BUFFER ADDRESS
  745.          BZ        TLINE.3         NO LINE BUFFER, DO NOT READ
  746.          LB        R6,4W,X2        TSM BUFFER SIZE
  747.          SLA       R6,2            CONVERT WORD TO BYTE COUNT
  748.          CAR       R5,R6           WHICH IS GREATER FOR XFER LIMIT
  749.          BLE       TLINE.1         TSM BUFFER IS SMALLER
  750.          TRR       R5,R6           STRING TO XFER TO IS SMALLER
  751. TLINE.1  EQU       $
  752.          ADI       X2,5W           TSM LINE BUFFER ADDRESS
  753.          TRN       R6,R6           NEGATIVE FOR LOOP
  754. TLINE.2  EQU       $               TOP OF LOOP
  755.          LB        R7,0,X2         GET FIRST BYTE
  756.          CI        R7,CR           END OF INPUT?
  757.          BEQ       TLINE.3
  758.          CI        R7,NULL         GUARD AGAINST OVER RUN
  759.          BEQ       TLINE.3
  760.          STB       R7,0,X3         PUT IN STRING
  761.          ADI       X2,1B           NEXT CHARACTER
  762.          ADI       X3,1B           NEXT SLOT IN S
  763.          SUI       R5,1B           DECREMENT S LENGTH LEFT
  764.          BIB       R6,TLINE.2
  765. TLINE.3  EQU       $
  766.          SPACE     3
  767. *
  768. * NOW BLANK FILL IF NECESSARY
  769. *
  770.          TRN       R5,R5           TEST FOR ANY LEFT
  771.          BNN       TLINE.5         FILLED UP
  772.          LI        R7,BLANK
  773. TLINE.4  EQU       $
  774.          STB       R7,0,X3         BLANK FILL
  775.          ADI       X3,1B           NEXT BYTE
  776.          BIB       R5,TLINE.4      CONTINUE
  777. TLINE.5  EQU       $
  778.          BU        *RETURN         RETURN
  779.          END
  780.         PROGRAM M_UPRIV
  781.         DEF         M_PRIV
  782. *
  783. *=    SUBROUTINE M_PRIV
  784. *
  785. *= converts the calling task to privileged.
  786. * Note that the task must have been cataloged privileged for this
  787. * to work.
  788. *
  789. *
  790.         DEF        M_UPRIV
  791. *=    SUBROUTINE M_UPRIV
  792. *
  793. *= converts the calling task to unprivileged.
  794. *
  795. * Privilege
  796. * By: L. Tate
  797. * On: May 17, 1983
  798. * Purpose: Call these two routines to change from a privileged
  799. *          state to an unprivileged.
  800. *
  801. * Inputs: none
  802. * Outputs: none
  803. *
  804. * Notes: Must be cataloged privileged to call these routines.
  805. ******************************************************************
  806.          M.EQUS                        !system equates
  807. *
  808. * M_PRIV
  809. *
  810. M_PRIV   EQU       $
  811.          M.PRIV                        !ref. mpx 32 2.1 vol I: 8.2.36
  812.          TRSW      R0                  !done and home
  813. *
  814. * M_UPRIV
  815. *
  816. M_UPRIV  EQU       $
  817.          M.UPRIV                       !ref mpx 32 2.1 vol I: 8.2.54
  818.          TRSW      R0                  !done and home
  819.          END
  820.          PROGRAM HIO         2.0
  821.          DEF       HIO
  822. *=      LOGICAL FUNCTION HIO (LFC)
  823. *          INTEGER     LFC      logical file to halt io on
  824. *          LOGICAL     HIO      success = T, failure = F
  825. *
  826. *= Halts the io over the specified lfc.
  827. * This is a privileged instrucion and results will be unpredicable
  828. * if you halt something other than a terminal.  Be careful.
  829. * 1.0 LHT automatically attempts to make user privileged if unprivileged
  830. * 2.0 LHT fault in determining if integer or not and error test
  831.          M.EQUS
  832.          M.TBLS
  833. PARMAREA REZ       8W              parameter area for inquiry
  834. LFCINQ   REZ       1D              local lfc as parameter
  835. RETURN   REZ       1W              return address
  836. SRL      SRL       R6,0            dummy shift right logical
  837. SLLD     SLLD      R6,0            dummy shift left logical double
  838. SLL      SLL       R6,0
  839.          BOUND     1W
  840. HIO      EQU       $
  841.          STW       R0,RETURN       save return address
  842. *
  843. * lfc is either integer or character, determine which and handle
  844. *
  845.          LW        R7,0,X1        get LFC
  846.          SRL       R7,24           isolate first byte
  847.          TRR       R7,R7           test first byte
  848.          BZ        HIO.INT        integer
  849. *
  850. * character in integer format
  851. *
  852.          LW        R6,0W,X1        get lfc
  853.          SRL       R6,8            right justify lfc
  854.          ZR        R7              clear 7
  855.          BU        HIO.LFC         now set up inquiry
  856. *
  857. * integer version
  858. *
  859. HIO.INT  EQU       $
  860.          LW        R5,0W,X1        get lfc
  861.          SVC       1,X'2A'         convert to decimal
  862.          LI        R5,-3           loop three times
  863.          TRR       R7,R3           store in 3 for destructive test
  864.          SLL       R7,8            left justify
  865.          ZR        R4              zero counter
  866.          ZBR       R0,0            reset flag
  867. HIO.SHF  EQU       $
  868.          ZR        R6
  869.          SLLD      R6,8            get first byte
  870.          CI        R6,X'30'        zero
  871.          BNE       HIO.SH1         donot count
  872.          TBR       R0,0            test for leading
  873.          BS        HIO.SH2         no count
  874.          ADI       R4,1            increment
  875.          BU        HIO.SH2         skip
  876. HIO.SH1  EQU       $
  877.          SBR       R0,0            set non zero flag
  878. HIO.SH2  EQU       $
  879.          BIB       R5,HIO.SHF
  880.          SLL       R4,3            *8
  881.          TRR       R3,R6           retrieve lfc
  882.          ADI       R4,8            8 bit shift plus
  883.          LH        R1,SLL          going to strip leading zeros
  884.          BL        SHIFTER
  885.          LH        R1,SRL          right bound
  886.          BL        SHIFTER
  887.          SUI       R4,8            back to original count
  888.          LW        R7,=C'    '     blank mask
  889.          LH        R1,SLLD         get slld instruction
  890.          BL        SHIFTER         shift
  891.          ZR        R7
  892.          BU        HIO.LFC         rejoin mainstream
  893. HIO.LFC  EQU       $
  894.          STD       R6,LFCINQ       set up inquiry
  895.          M.INQUIRY PARMAREA,LFCINQ inquiry for udt table
  896.          BS        ERROR           branch if inquire error
  897.          LW        R1,2W+PARMAREA  udt address
  898.          BZ        ERROR           not a device
  899.          TBM       UDT.IOUT,UDT.FLGS,X1 test for outstanding io
  900.          BNS       ERROR           no io to halt
  901.          LW        R6,1W,X1        get logical address
  902.          SLL       R6,8            strip status
  903.          SRLD      R6,24           strip logical address
  904.          SRL       R7,16           right justify logical address
  905.          CI        R6,X'0C'        test for TY type
  906.          BEQ       HIO.TY
  907.          CI        R6,X'11'        test for u0
  908.          BLT       ERROR
  909.          CI        R6,X'1A'        test for u9
  910.          BGT       ERROR
  911. HIO.TY   EQU       $
  912.          LW        R6,3W,X1        get physical address
  913.          SRL       R6,16           right justified
  914.          TRR       R6,R6           test for zero
  915.          BZ        HIO.1           use logical address
  916.          TRR       R6,R7           use physical address
  917. HIO.1    EQU       $
  918.          TBM       0,RETURN        test for priv
  919.          BS        HIO.5
  920.          M.PRIV                    make priv
  921. HIO.5    EQU       $
  922.          HIO       R7,0            halt io
  923.          BCT       6,ERROR         error on cc3 or cc4
  924.          BCT       2,ERROR         error on cc2 set
  925.          LI        R7,-1           fortran true
  926.          BU        HIO.10
  927. ERROR    EQU       $
  928.          ZR        R7              fortran false
  929.          BU        HIO.10
  930. HIO.10   EQU       $
  931.          TBM       0,RETURN
  932.          BS        HIO.15          leave in entrance state
  933.          M.UPRIV
  934. HIO.15   EQU       $
  935.          BU        *RETURN         home
  936. *
  937. * SHIFTER merges N and instruction and perfroms shift
  938. *
  939. *   R1  - instruction
  940. *   R4  - count
  941. *   R1 is destroyed
  942. *
  943. SHIFTER EQU $
  944.          ORR       R4,R1          or in count
  945.          EXRR       R1              perform shift
  946.          TRSW       R0              return
  947.          END
  948.          PROGRAM   TTYF                0.0
  949.          DEF       TTYCURF
  950. *=    LOGICAL FUNCTION TTYCURF (PBLK, SENSE)
  951. *          INTEGER    PBLK(4)         !dio parameter block
  952. *          INTEGER*8  SENSE           !returns the result of sense test
  953. *
  954. *= TTYCUR tests the port for current configuration.
  955. *
  956.          DEF       TTYINIF
  957. *=    SUBROUTINE TTYINIF (PBLK, INIT)
  958. *          INTEGER    PBLK(4)         dio parameter block
  959. *          INTEGER    INIT            initialization word
  960. *
  961. *= Inits the port to the specified initialization.
  962. *
  963. * TTYCURR returns the current initialization of a terminal on an
  964. * asynchronus eight line.  This version is compatable with with the
  965. * magical FCBINIT/DPREAD/DPWRITE/DREAD/DWRITE routines.  Since the
  966. * address of the fcb is the first word of the parameter block, just
  967. * specify the parameter block as the first parameter.
  968. *   EX:
  969. *         CALL TTYCURF(PBLK, SENSE)
  970. *   OR:
  971. *         CALL TTYINIF(PBLK, INIT)
  972. * major problem with previous version was the internal open involved.
  973. *
  974. * definitions
  975. *
  976.          M.EQUS
  977. ARGS     EQU       0               offset to find argument count
  978. FCB      EQU       1W              offset to find lfc
  979. SENSE    EQU       2W              offset to place initialization
  980. INIT     EQU       2W              initialization command
  981. ERROR    EQU       1               bit 1 of word 3 is error flag
  982. *
  983. * local variables
  984. *
  985.          BOUND     1D
  986. OLDCOM   DATAW     1W
  987. FCBADDR  DATAW     0
  988. RETURN   DATAW     0
  989. C.SENSE  DATAW     X'02000000'     expanded format
  990. C.SPCHR  DATAW     X'02000000'     expanded format
  991. C.INIT   DATAW     X'22400000'     expanded format
  992. WORDMASK DATAW     X'0007FFFC'     ensure word address
  993.          BOUND     1W
  994. INITPARM EQU       $
  995. ACE      DATAB     0,0,0           ace parameters to use
  996. SPECHAR  DATAB     0               special character
  997. INITBUF  DATAW     0
  998. SPCHRBUF DATAW     0
  999. SPCHRAD  ACW       SPCHRBUF        byte address of special character
  1000. ACEADDR  ACW       INITBUF         byte address of ace parameters
  1001. ENTRY    DATAW     0
  1002. *
  1003. * ttycurr
  1004. *
  1005. TTYCURF  EQU       $
  1006.          LA        R7,TTY.10       sense program
  1007.          STW       R7,ENTRY        set up future
  1008.          BU        TTY.5           set up return
  1009. *
  1010. * ttyinit
  1011. *
  1012. TTYINIF  EQU       $
  1013.          LA        R7,TTY.20
  1014.          STW       R7,ENTRY        save for future
  1015.          BU        TTY.5
  1016. *
  1017. * set up return
  1018. *
  1019. TTY.5    EQU       $
  1020.          TRR       R0,R1           save arguement pointer
  1021.          ABR       R0,29           bump over arguement counter
  1022.          ADMW      R0,ARGS,X1      add number of arguements
  1023.          STW       R0,RETURN       save returen address
  1024.          BU        *ENTRY          perform task
  1025. *
  1026. * set up fcb and open
  1027. *
  1028.          BOUND     1W
  1029. TTY.10   EQU       $
  1030.          LW        R4,WORDMASK     address mask
  1031.          LW        R2,*FCB,X1      get lfc
  1032.          LW        R7,2W,X2        save old command
  1033.          STW       R7,OLDCOM
  1034.          LA        R7,*SENSE,X1
  1035.          STMW      R7,8W,X2        use SENSE for buffer
  1036.          LW        R7,C.SENSE      place commands in fcb
  1037.          STW       R7,2W,X2
  1038.          LI        R7,8B           byte count for sense
  1039.          STW       R7,9W,X2
  1040.          STW       R2,FCBADDR      save fcb address
  1041. *
  1042. * sense terminal
  1043. *
  1044.          TRR       R2,R1           set up sense
  1045.          SVC       1,X'37'         stat
  1046.          LW        R2,FCBADDR      retrieve fcb address
  1047.          LW        R7,OLDCOM       retrieve
  1048.          STW       R7,2W,X2
  1049.          TBM       ERROR,3W,X2     check error bit
  1050.          BS        TTY.19          error
  1051. *
  1052. * return true
  1053. *
  1054.          LI        R7,-1           return true
  1055.          BU        *RETURN
  1056. *
  1057. * error
  1058. *
  1059. TTY.19   EQU       $
  1060.          ZR        R7
  1061.          BU        *RETURN
  1062. *
  1063. * initialize terminal
  1064. *
  1065.          BOUND     1W
  1066. TTY.20   EQU       $
  1067.          LW        R7,*INIT,X1     initialize to perform
  1068.          STW       R7,INITPARM     isolate for commands
  1069.          STW       R7,INITBUF
  1070.          LB        R7,SPECHAR      special character
  1071.          STB       R7,SPCHRBUF
  1072. *
  1073. * open
  1074. *
  1075.          LW        R2,*FCB,X1      get fcb address
  1076.          LW        R7,2W,X2        get old command
  1077.          STW       R7,OLDCOM
  1078. *
  1079. * initialize ace parameters
  1080. *
  1081.          LW        R7,C.INIT       init ace command
  1082.          STW       R7,2W,X2
  1083.          LW        R7,ACEADDR      address of ace
  1084.          STW       R7,8W,X2        command buffer
  1085.          LI        R7,3B           transfer 3 bytes
  1086.          STW       R7,9W,X2        byte count
  1087.          STW       R2,FCBADDR      save address
  1088.          TRR       R2,R1           set up write
  1089.          SVC       1,X'32'
  1090.          LW        R2,FCBADDR      retrieve fcb address
  1091.          TBM       ERROR,3W,X2     error bit
  1092.          BS        TTY.29          error return
  1093. *
  1094. * special character
  1095. *
  1096.          LW        R7,C.SPCHR      special character command
  1097.          STW       R7,2W,X2        new command
  1098.          LW        R7,SPCHRAD      special character address
  1099.          STW       R7,8W,X2
  1100.          LI        R7,1B           transfer 1 byte
  1101.          STW       R7,9W,X2
  1102.          TRR       R2,R1           set up special char init
  1103.          SVC       1,X'0D'         set special char
  1104.          LW        R2,FCBADDR      retrieve fcb address
  1105.          TBM       ERROR,3W,X2     test for error
  1106.          BS        TTY.29          error return
  1107. *
  1108. * return good news
  1109. *
  1110.          LW        R7,OLDCOM
  1111.          STW       R7,2W,X2        replace
  1112.          LI        R7,-1           fortran true
  1113.          BU        *RETURN
  1114. *
  1115. * error address
  1116. *
  1117. TTY.29   EQU       $
  1118.          LW        R7,OLDCOM
  1119.          STW       R7,2W,X2        replace
  1120.          ZR        R7              fortran false
  1121.          BU        *RETURN
  1122.          END
  1123.          PROGRAM   L.UDT               1.1
  1124.          DEF       SUDT
  1125. *=    SUBROUTINE SUDT(PBLK, MODE)
  1126. *         INTEGER    PBLK         dio parameter block attached to ty
  1127. *         CHARACTER*4 MODE        mode to set
  1128. *
  1129. *= Sets the terminal to the specified operating mode.
  1130.          DEF       TUDT
  1131. *
  1132. *=    LOGICAL FUNCTION TUDT(PBLK, MODE)
  1133. *
  1134. *        INTEGER*4  PBLK(4)     !dio parameter block attached to ty
  1135. *        CHARACTER*4 MODE       !mode to test or set
  1136. *
  1137. *  Result is returned as a logical function
  1138. *
  1139. *= Tests for a particular mode.
  1140. *
  1141.          M.EQUS
  1142.          M.TBLS
  1143. *
  1144. * data
  1145. *
  1146.          BOUND     1D
  1147. LFCB     RES       8W                 LOCAL FCB FOR SVC'S
  1148. RETURN   RES       1W
  1149. UDTA     RES       1W                  ADDRESS OF TERMINAL
  1150. LMODE    RES       1W                  LOCAL MODE FOR COMPARE
  1151. FLAGS    RES       1W
  1152. TEST     EQU       0                   FIRST BIT IS TEST MODE FLAG
  1153. MODES    DATAW     C'ONLI'
  1154.          DATAW     C'TSM '
  1155.          DATAW     C'LOGO'             USER LOGGED ON
  1156.          DATAW     C'FULL'
  1157.          DATAW     C'HALF'
  1158.          DATAW     C'ECHO'
  1159.          DATAW     C'NOEC'             NO ECHO
  1160.          DATAW     C'DEAD'
  1161.          DATAW     C'USE '             IN USE
  1162.          DATAW     C'ALIV'             ALIVE
  1163.          DATAW     C'DUAL'             DUAL CHANNEL MODE
  1164.          DATAW     C'SING'             SINGLE CHANNEL MODE
  1165. NMODES   EQU       $-MODES
  1166. TESTBITS EQU       $
  1167.          TBM       UDT.ONLI,UDT.STAT,X3  TEST FOR ONLINE
  1168.          TBM       UDT.TSM,UDT.STAT,X3   TEST FOR TSM
  1169.          TBM       UDT.LOGO,UDT.FLGS,X3  TEST FOR LOGON
  1170.          TBM       UDT.FDUX,UDT.BIT2,X3  FULL DUPLEX
  1171.          TBM       UDT.FDUX,UDT.BIT2,X3  HALF DUPLEX
  1172.          TBM       UDT.ECHO,UDT.BIT2,X3  ECHO
  1173.          TBM       UDT.ECHO,UDT.BIT2,X3  NO ECHO
  1174.          TBM       UDT.DEAD,UDT.BIT2,X3  DEAD
  1175.          TBM       UDT.USE,UDT.BIT2,X3   IN USE
  1176.          NOP                           DUAL
  1177.          NOP
  1178.          NOP                           SINGLE
  1179.          NOP
  1180. SETBITS  EQU       $
  1181.          TBM       UDT.ONLI,UDT.STAT,X3  TEST FOR ONLINE
  1182.          TBM       UDT.TSM,UDT.STAT,X3   TEST FOR TSM
  1183.          TBM       UDT.LOGO,UDT.FLGS,X3  TEST FOR LOGON
  1184.          SBM       UDT.FDUX,UDT.BIT2,X3  FULL DUPLEX
  1185.          ZBM       UDT.FDUX,UDT.BIT2,X3  HALF DUPLEX
  1186.          SBM       UDT.ECHO,UDT.BIT2,X3  ECHO
  1187.          ZBM       UDT.ECHO,UDT.BIT2,X3  NO ECHO
  1188.          SBM       UDT.DEAD,UDT.BIT2,X3  DEAD
  1189.          TBM       UDT.USE,UDT.BIT2,X3   IN USE
  1190.          ZBM       UDT.DEAD,UDT.BIT2,X3  ALIVE
  1191.          SVC       1,X'27'             DUAL
  1192.          SVC       1,X'26'             SINGLE
  1193. MODTEST  EQU       $                   MODIFY THE RESULT OF TEST
  1194.          DATAB     0                   ONLINE
  1195.          DATAB     0                   TSM
  1196.          DATAB     0                   LOGON
  1197.          DATAB     0                   FULL
  1198.          DATAB     255                 NOT FULL
  1199.          DATAB     0                   ECHO
  1200.          DATAB     255                 NOT ECHO
  1201.          DATAB     0                   DEAD
  1202.          DATAB     0                   IN USE
  1203.          DATAB     0                   NOT ALIVE
  1204.          DATAB     0                   DUAL
  1205.          DATAB     0                   SINGLE
  1206. *
  1207. SUDT     EQU       $
  1208.          ZBM       TEST,FLAGS          SHOW ENTRANCE
  1209.          BU        UDT.1
  1210. TUDT     EQU       $
  1211.          SBM       TEST,FLAGS          SHOW ENTRANCE
  1212.          BU        UDT.1
  1213. UDT.1    EQU       $                   COMMON CODE
  1214.          TRR       R0,X1               INDEX REGISTER
  1215.          ABR       R0,29               BUMP OVER COUNT
  1216.          ADMW      R0,0,X1             ADD COUNT
  1217.          STW       R0,RETURN           RETURN ADDRESS
  1218.          LW        X2,*1W,X1           GET FCB ADDRESS
  1219.          BZ        FALSE               NO FCB ADDRESS
  1220.          LW        R7,0,X2             GET LFC
  1221.          LW        X2,C.TSAD           START OF TSA
  1222.          LW        X3,T.FPTA,X2        FILE POINT TABLE ADDRESS
  1223.          LNB       R5,T.FILES,X2       NUMBER OF FPT'S
  1224.          LW        R4,=X'00FFFFFF'     LFC MASK
  1225. UDT.2    EQU       $
  1226.          CMMW      R7,0,X3             IS THIS THE LFC
  1227.          BEQ       UDT.3
  1228.          ADI       X3,3W               BUMP FPT POINTER
  1229.          BIB       R5,UDT.2            LOOP
  1230.          BU        FALSE               NOT HERE
  1231. UDT.3    EQU       $                   FOUND
  1232.          TBM       4,4B,X3             ENTRY IN USE?
  1233.          BS        FALSE               NO
  1234.          LW        X3,2W,X3            FAT ADDRESS
  1235.          LH        X3,3H,X3            UDT INDEX
  1236.          BZ        FALSE               NO UDT INDEX
  1237.          SLA       X3,6                * WORD SIZE * UDT SIZE
  1238.          ADMW      X3,C.UDTA           MAKE A UDT ADDRESS
  1239.          LB        R7,UDT.DTC,X3       GET TYPE
  1240.          CI        R7,X'C'             MUST BE TY TYPE
  1241.          BNE       FALSE               NOT GOOD
  1242.          STW       X3,UDTA             STORE IN UDT ADDRESS
  1243. *
  1244. * NOW DETERMINE WHICH FLAG I WANT TO SET
  1245. *
  1246.          LNW       R5,*3W,X1           GET STRING SIZE
  1247.          LI        R4,-4               SIZE OF LMODE
  1248.          LA        X2,*2W,X1           MODE STRING POINTER
  1249.          LA        X3,LMODE            LOCAL COPY OF MODE
  1250.          LW        R7,=C'    '         BLANK OUT LOCAL COPY
  1251.          STW       R7,LMODE
  1252. UDT.4    EQU       $
  1253.          LB        R7,0,X2             GET FIRST BYTE
  1254.          STB       R7,0,X3             PUT AWAY
  1255.          ABR       X2,31               BUMP POINTERS
  1256.          ABR       X3,31               BUMP POINTERS
  1257.          ADI       R4,1                INCREMENT LOCAL COUNTER
  1258.          BZ        UDT.5               ENOUGH
  1259.          BIB       R5,UDT.4            MORE TO COME
  1260. UDT.5    EQU       $
  1261.          LI        R4,-NMODES          GET NUMBER OF MODES
  1262.          LW        R7,LMODE            GET MODE SELECTED
  1263.          ZR        X2                  OFFSET OF FIRST MODE
  1264. UDT.6    EQU       $
  1265.          CAMW      R7,MODES,X2         IS THIS THE MODE
  1266.          BEQ       UDT.7               FOUND
  1267.          ADI       X2,1W               BUMP INDEX
  1268.          BIW       R4,UDT.6            CONTINUE SEARCH
  1269.          BU        FALSE               NOT FOUND IN LIST
  1270. UDT.7    EQU       $                   FOUND
  1271. *
  1272. * LETS DO IT!
  1273. *
  1274.          ZMD       LFCB               MUST ZERO LOCAL FCB
  1275.          ZMD       LFCB+2W
  1276.          ZMD       LFCB+4W
  1277.          ZMD       LFCB+6W
  1278.          LW        X1,*1W,X1           GET FCB ADDRESS
  1279.          LW        R7,0,X1             GET LFC
  1280.          STW       R7,LFCB             STORE LOCALY
  1281.          LA        X1,LFCB             USE LOCAL FCB
  1282.          LW        X3,UDTA             RETREIVE UDT ADDRESS
  1283.          TBM       TEST,FLAGS          TEST ONLY?
  1284.          BS        UDT.TST
  1285.          TBR       R0,0                ARE WE PRIVILEGED?
  1286.          BS        UDT.8               YEP
  1287.          M.PRIV
  1288. UDT.8    EQU       $
  1289.          LW        R7,SETBITS,X2       GET COMMAND
  1290.          EXR       R7                  DO IT
  1291.          TBR       R0,0                WHERE WE PRIVILEGED
  1292.          BS        UDT.9               YEP
  1293.          M.UPRIV                       EXIT WAY CAME
  1294. UDT.9    EQU       $
  1295.          LI        R7,-1
  1296.          BU        *RETURN             GO HOME
  1297. *
  1298. * TEST LOGIC
  1299. *
  1300. UDT.TST  EQU       $
  1301.          ZR        R7                  ASSUME FALSE
  1302.          LW        R6,TESTBITS,X2      GET TEST INSTRUCTION
  1303.          EXR       R6                  TEST BIT
  1304.          BNS       UDT.10              NOT SET
  1305.          LI        R7,255              SET
  1306. UDT.10   EQU       $
  1307.          SRA       X2,2                BYTE BOUND INDEX
  1308.          EOMB      R7,MODTEST,X2       SOME ARE NOT'S
  1309.          BU        *RETURN             HOME
  1310. *
  1311. * ERROR RETURN
  1312. *
  1313. FALSE    EQU       $
  1314.          ZR        R7
  1315.          BU        *RETURN             HOME
  1316.          END
  1317.          PROGRAM   INKEY           0.0
  1318.          DEF       INKEY
  1319. *=    LOGICAL FUNCTION INKEY(LFC, FCB, CHR)
  1320. *          INTEGER    LFC          lfc to read from
  1321. *          INTEGER    FCB(9)       fcb to use (zero'd initially)
  1322. *          INTEGER*1,*2,*4 CHR     character read in nowait form
  1323. *
  1324. *          returns .true. if character input
  1325. *
  1326. *= Returns a single character typed to lfc.  User must echo.
  1327. *
  1328.          M.EQUS
  1329.          M.TBLS
  1330. LFC      EQU       1W
  1331. FCB      EQU       2W
  1332. CHR      EQU       3W
  1333. *
  1334. * inkey
  1335. *        R0        return
  1336. *        X1        fcb address
  1337. *        X2        arguement list pointer
  1338. *        R4        mask to extract leading byte
  1339. *        R5        numeric lfc
  1340. *        R7        alpha lfc and transient register
  1341. *
  1342.          BOUND     1W
  1343. INKEY    EQU       $
  1344.          TRR       R0,X2           arg pointer
  1345.          ABR       R0,29           bump over arg count
  1346.          ADMW      R0,0W,X2        bump over args
  1347. *
  1348. * check for initialization
  1349. *
  1350.          LA        X1,*FCB,X2      get fcb address
  1351.          LW        R7,FCB.LFC,X1   get first word of fcb
  1352.          BNZ       INKEY.10        already initialized
  1353. *
  1354. * initialize
  1355. *
  1356.          LW        R7,*LFC,X2      get lfc
  1357.          LW        R4,=X'FF000000' lfc mask
  1358.          TRRM      R7,R5           test for numeric or alpha
  1359.          BNZ       INKEY.5         alpha
  1360.          TRR       R7,R5           set up conversion
  1361.          SVC       1,X'2A'         convert binary to decimal
  1362.          CI        R5,100          less than 100?
  1363.          BGE       INKEY.2         no shift since uses 3 digits
  1364.          SLC       R7,8            move leading blank to end
  1365.          CI        R5,10           only one byte long?
  1366.          BGE       INKEY.2         no
  1367.          SLC       R7,8            move leading blank to end
  1368. INKEY.2  EQU       $
  1369.          SLL       R7,8            make like alpha
  1370. INKEY.5  EQU       $
  1371.          SRL       R7,8            right justify 3 chr lfc
  1372.          STW       R7,FCB.LFC,X1   store lfc in fcb
  1373.          LW        R7,=X'E0600000' nowait,noerror,dfi,noecho,noconv
  1374.          STW       R7,FCB.GCFG,X1  store in control flags
  1375.          TRR       X1,R7           fcb address
  1376.          ADI       R7,8W           buffer to use is end of fcb
  1377.          SBR       R7,12           make byte address
  1378.          SBR       R7,11           count of one
  1379.          STW       R7,FCB.TCW,X1   store tcw
  1380. *
  1381. * do normal processing
  1382. *
  1383. INKEY.10 EQU       $
  1384.          TBM       0,FCB.SFLG,X1   test for io completion
  1385.          BS        INKEY.20        still processing
  1386.          LB        R7,8W,X1        get character received
  1387.          STW       R7,*CHR,X2      return character input
  1388.          LNW       R7,FCB.RECL,X1  transfer count of -1 is T, 0 is F
  1389.          SVC       1,X'31'         read
  1390.          BU        INKEY.30        read processing done
  1391. INKEY.20 EQU       $               read not complete
  1392.          ZMW       *CHR,X2         zero out character input
  1393.          LI        R7,0            false
  1394. INKEY.30 EQU       $               exit
  1395.          TRSW      R0              return
  1396.          END
  1397.          PROGRAM   HIOALL          0.0
  1398.          DEF       HIOALL
  1399. *=    SUBROUTINE HIOALL
  1400. *
  1401. *= Kills all pending io for this task.
  1402. *  Must be privileged to do this
  1403. *
  1404.          M.EQUS
  1405. *
  1406.          BOUND     1W
  1407. HIOALL   EQU       $
  1408.          TBR       R0,0            privileged?
  1409.          BS        ALL.1           yes
  1410.          M.PRIV
  1411. ALL.1    EQU       $
  1412.          M.CALL    H.IOCS,38       do it
  1413.          TBR       R0,0            privileged?
  1414.          BS        ALL.2           yes
  1415.          M.PRIV
  1416. ALL.2    EQU       $
  1417.          TRSW      R0              return
  1418.          END
  1419.