         TITLE    'APLFIO-B00,10/16/73,DWG702985'
         SYSTEM   SIG7F
         SYSTEM   BPM
         PAGE
*
*  REF'S
*
         REF      ACQCC             ACQUIRE CHARACTER AND CODE
         REF      ACQIT             ACQUIRE ALPHANUMERIC ITEM           U20-0004
         REF      ACQNB             ACQUIRE NON-BLANK CHAR AND CODE     U20-0005
         REF      ACQNXCC           ACQ. NEXT CHAR. AND CODE
         REF      ACQNXNB           ACQUIRE NEXT NON-BLANK CHAR.        U20-0007
         REF      ALOCBLK           ALLOCATE DATA BLOCK
         REF      ALOCHNW           DATA BLOCK ALLOCATION ROUTINE
         REF      BITPOS            BIT MASK TABLE
         REF      BLANKS            WORD OF BLANKS
         REF      BREAKFLG          BREAK FLAG
         REF      CKVDB             CHECK DATA BLOCK VALIDITY           U20-0009
         REF      CLOSR             CLOSE AND RELEASE DCB
         REF      CLOSV             CLOSE AND SAVE DCB
         REF      CONSTBUF          CONSTANT BUFFER
         REF      CURRKEYT          CURRENT KEY IN FILE
         REF      DREF              DEREFERENCE DATA BLOCK
         REF      DXRETURN          DYADIC EXECUTION RETURN
         REF      ERDOMAIN          DOMAIN ERROR
         REF      ERLENGTH          LENGTH ERROR
         REF      ERRANK            RANK ERROR
         REF      F:TF              DCB
         REF      FFFFFFFE          MASK
         REF      FIOABNT           FIO  INABN MODE FLAG
         REF      FIOACCC            ACCOUNT CONTROL WORD IN FPT
         REF      FIOACCT           ACCOUNT IN FIO FPT
         REF      FIOBUF            ADDRESS OF FIO BUFFER
         REF      FIODCB            FIO DCB ADDRESS
         REF      FIODCBNO          DCB #
         REF      FIODCBT           TABLE OF FIO DCB ADDRESSES
         REF      FIOTIE            TABLE OF FILE TIE NUMBERS           U20-0011
         REF      FIOKEY            KEY IN USE
         REF      FIOMODE           MODE CONTROL
         REF      FIONAME
         REF      FIOPASC           FIO PASSWORD CONTROL
         REF      FIOPASS           FIO PASSWORD
         REF      FIOREADC          READ  CONTROL
         REF      FIOSIZ            FIO REC SIZE
         REF      FIOWRITC          WRITE CONTROL
         REF      FPTOPFIO          FPT TO OPEN FIO FILE
         REF      FPTOPNXT          OPEN TO NEXT FILE IN ACCT
         REF      FPTOP1ST          OPEN TO FIRST FILE IN ACCT
         REF      FPTRD1ST          READ 1ST RECORD OF FILE-FOR ID
         REF      FRSTKEYT          FIRST KEY IN FILE
         REF      GARBCOLL          GARBAGE COLLECT
         REF      GETTIME           CAL TO GET TIME-DATE
         REF      GIVEBACK          GIVE BACK UNUSED MEMORY IN DB       U20-0013
         REF      IDBUF             FIO ID REC. BUFFER
         REF      IV1               REDUCE RTARG TO SCALAR INT. OR QUIT
         REF      J:ACCN            USER ACCOUNT
         REF      LASTKEYT          LAST KEY IN FILE
         REF      LFARG             LEFT ARG ADDRESS
         REF      NAMEBUF           NAME BUFFER                         U20-0015
         REF      NONAME            TEST FOR LETTER-DIGIT
         REF      NUMFILES          NO OF FIO CHANNELS
         REF      OP1STACC          ACCOUNT IN FPTOP1ST
         REF      OP1STACT          ACCT CONTROL IN FPTOP1ST
         REF      RESULT            RESULT ADDRESS
         REF      RTARG             RIGHT ARG ADDRESS
         REF      XFFFF             HW MASK
         REF      X1FFFF            ADDRESS MASK
         REF      ZEROZERO          0,0 DW BOUND
         REF      FIOSN             SERIAL NO. ENTRIES IN FPT           U20-0017
         REF      FIOSNC            SERIAL NO. CONTROL WORD IN FPT      U20-0018
         REF      WHATERR           HOLDS INTR. I.D. 0=14T1 & NZ=14T2.
         REF      IOERCODE          I/O ERR OR ABN WD.
         REF      ERFILEIO          FILE I/O ERROR PROCESSOR.
         REF      IDFILSPC,IDFIOERR,IDFILDAM,IDFILNAM,IDNOTAPL,IDFTFULL
         REF      IDFILACC,IDFILTIE,IDNOPACK,IDFILIDX,IDFILBSY
         PAGE
*
*  DEF'S
*
         DEF      APLFIO@           START OF PROCEDURE
         DEF      ERRFTFIO          FIO ERR ON F:TF DCB
         DEF      FILEOPS           ENTRY POINT
         DEF      FIOERR            FIO MONITOR ERROR
         PAGE
*
*  STANDARD EQU'S
*    REGISTERS
*
R0       EQU      0
R1       EQU      1
R2       EQU      2
R3       EQU      3
R4       EQU      4
R5       EQU      5
R6       EQU      6
R7       EQU      7
R8       EQU      8
R9       EQU      9
R10      EQU      10
R11      EQU      11
R12      EQU      12
R13      EQU      13
R14      EQU      14
R15      EQU      15
*
NFIOPS   EQU      27                NO. OF FILE I/O OPERATIONS
SAVER4   EQU      CONSTBUF+12       TEMP FOR R4                         U20-0021
TYPEINTG EQU      3                 INTEGER DATA BLOCK TYPE
         PAGE
*
*
*  MODULE DESCRIPTION:
*    THIS MODULE CONTAINS THE PROCEDURE FOR THE APL FIO SUBSYSTEM
*         THE ENTRY POINT IS FILEOPS,WHICH IS REACHED BYTHE
*        DYADIC INTRINSIC OPERATOR FOR FILE I/O
*
*        THIS MODULE IS PRIMARILY A UTS INTRFACE MODULE, BUT HAS BEEN
*        SEPARATED FROM APLUTSI TO ALLOW OVERLAY OF APLFIO
*
*        THE CONTEXT USED BY APLFIO IS PRIMARILY IN THE CONTEXT
*        REGION OF APLUTSI
*
*     EXITS FROM APLFIO ARE TO VARIOUS EXECUTION ERROR ROUTINES,
*        SUCH AS ERDOMAIN,ERLENGTH,ETC OR TO DXRETURN
*
*
*  FILEOPS-PRECHECKS THE ARGUMENTS AND,IF NO ERROR IS INDICATED
*        BRANCHES TO ONE OF 27 FILE I/O PRIMITIVE ROUTINES
*
*  FIO1- SET A DCB #   RANGE  1 TO NUMFILES
*  FIO2- SET FILE NAME
*  FIO3- SET OR RESET ACCOUNT
*  FIO4- SET OR RESET PASSWORD
*  FIO5- OPEN A DCB (SET MODE-READ CONTROL-WRITE CONTROL-INABN FLAG)
*  FIO6- CLOSE AND SAVE INDICATED DCG
*  FIO7- CLOSE AND RELEASE INDICATED DCB
*  FIO8- GET FIRST,CURRENT,OR LAST KEY VALUE FOR DCB
*  FIO9- SET CURRENT KEY (AND POSSIBLY LAST KEY) FOR DCB
*  FIO10-WRITE A DATA RECORD
*  FIO11-WRITE AN ID RECORD AND A DATA RECORD
*  FIO12-READ A DATA RECORD USING CURRENTKEY
*  FIO13-READ AN ID RECORD AND DATA RECORD-KEYED OR SEQUENTIALLY
*  FIO14-READ AN ID RECORD ONLY-KEYED OR SEQUENTIALLY
*  FIO15-DELETE  RECORD WITH GIVEN KEY
*  FIO16-DELETE ID AND DATA RECORDS-ID REC MATCHES GIVEN KEY
*  FIO17-SKIP RECORD OR READ RECORD SEQUENTIALLY
*  FIO18-GENERATE TEXT ARRAY OF FIO FILES IN INDICATED ACCT.
*  FIO19-GENERATE TEXT ARRAY OF OPEN FILES OR NUMERIC VECTOR OF OPEN #'S
*  FIO20-SET OR RESET SERIAL NO. FOR PRIVATE PACK                       U20-0025
*  FIO21-SET FILE ID-SINGLE PRIMITIVE FOR NAME,ACCT,PASSWORD            U20-0026
*  FIO22-WRITE A NON-APL DATA RECORD
*  FIO23-READ A NON-APL DATA RECORD USING CURRENT KEY
*  FIO24-READ A NON-APL DATA RECORD SEQUENTIALLY
*  FIO25-CONVERT TEXT VECTOR TO LOGIC VECTOR
*  FIO26-CONVERT TEXT VECTOR TO INTEGER VECTOR
*  FIO27-CONVERT TEXT VECTOR TO REAL VECTOR
*
         PAGE
APLFIO@  CSECT    1
         BOUND    8
*
* CONSTANTS
*
YEARANGE DATA     4718765,5046272    6172-1/77 (CHANGE LATER)
NONEALL  TEXT     'NONEALL '
FIOMBSN  DATA     X'0C000000'+BA(FIONAME)
FIOMBSN1 DATA     X'0B000001'+BA(FIONAME)                               U20-0028
FIOIDHDR DATA     X'03010008'       INTEGER VECTOR-8 WORD DATA BLOCK
FIOTXMAT DATA     X'02020004'
X1F      DATA     X'1F'             MASK
X3F      DATA     X'3F'             MASK
XFFFFFF  DATA     X'00FFFFFF'       MASK TO DELETE BYTE 0
KEYBYTE  DATA     X'03000000'
MAXKEY   DATA     9999998           MAXIMUM KEY VALUE
         PAGE
*
* FILEOPS-CHECKS ARGUMENTS-ERROR EXITS OR BRANCHES TO 1 OF 19 ROUTINES
*
FILEOPS  STW,R6   WHATERR           SAVE INTRINSIC IDENTIFIER.
         LH,R5   *LFARG             CHECK LEFT ARGUMENT.
         LW,R4    LFARG
         LW,R4    2,R4              ASSUME SCALAR-CHECK VALUE
         BLZ      FILEOP1            NEGATIVE-CHCK FOR LOGIC 1 SCALAR
         BEZ      ERDOMAIN           ZERO-NOT VALID IN ANY CASE
         CI,R5    X'300'            POSITIVE-VERIFY INTEGER SCALAR
         BNE      ERDOMAIN            NO-ERROR
         CI,R4    NFIOPS             RANGE TEST
         BLE      FILEOP2             OK
         B        ERDOMAIN            NO-ERROR
FILEOP1  CI,R5    X'100'            CHECK-TYPE,LOGIC-RANK, 0
         BNE      ERDOMAIN           NO
         LI,R4    1                  YES-VALUE IS 1
FILEOP2  LB,R5   *RTARG             CHECK THE RIGHT ARGUMENT
         CI,R5    5                 CHECK IF RTARG IS DATA TYPE
         BG       ERDOMAIN           NO-ERROR
         LW,R15   FIOPSTBL,R4       GET VALIDITY MASK AND BRANCH ADDRESS
         LH,R7    R15
         BGEZ     FILEOPS1          NO TEST NEEDED FOR FILE-OPEN
         LW,R8   *FIODCB            TEST IF FILE IS OPEN
         CW,R8    BITPOS-10
         BANZ     FILEOPS1           YES-OK
FIOCLSD  LW,R12   R4                 NO-ERROR EXIT
         B        ERRAPL
FILEOPS1 CI,R7    X'4000'            CHECK IF WRITE OPERATION
         BANZ    *R15                 YES-ANY RTARG IS VALID
         CI,R5    2                   NO-CHECK DATA TYPE
         BE       FILEOPS2              TEXT
         CI,R7    X'2000'               NUMERIC-CHECK IF PERMITTED
         BAZ      ERDOMAIN                NO
         STW,R4   SAVER4                  YES-SAVE R4
         BAL,R14  IV1               GET INTEGER OR ERROR EXIT
         LW,R4    SAVER4
         AI,R7    0                 CHECK VALUE
         BLZ      ERDOMAIN           ERROR ON NEGATIVE RTARG
         B       *R15                 OK
FILEOPS2 CI,R7    X'1000'           CHECK FOR CONVERTER PRIMITIVE
         BANZ     FIO25               YES-USE FIO25 FOR ALL 3
         CI,R7    X'0800'           CHECK IF TEXT PERMITTED
         BAZ      ERDOMAIN            NO
         LH,R5   *RTARG               YES-GET TYPE AND RANK
         LW,R6    RTARG
         AI,R5    -X'201'           CHECK RANK
         BEZ      FILEOPS3           VECTOR
         BGZ      ERRANK             ARRAY
         LI,R8    1                  SCALAR-SET LENGTH 1
         LW,R9    2,R6
         STD,R8   CONSTBUF          SET LENGTH AND BYTE
         B        FILEOPS4
FILEOPS3 LW,R8    2,R6              GET LENGTH OV VECTOR
         BLEZ     ERLENGTH           TOO SMALL
         LI,R7    BA(CONSTBUF+1)
         CI,R8    40
         BG       ERLENGTH           TOO BIG
         STB,R8   R7                SET BYTE COUNT FOR MBS
         STW,R8   CONSTBUF          SET BYTE COUNT FOR TEXTC
         AI,R6    3                 WA(TEXT STRING)
         SLS,R6   2                 BA(TEXT STRING)
         MBS,R6   0                  FORM TEXTC IN CONSTBUF
         LW,R6    FIOPSTBL,R4       GET MAX TEXT LENGTH
         SLS,R6   -20                WHICH IS IN BYTES 5-11
         AND,R6   X3F                 MASK OFF OTHER BITS
         CW,R8    R6
         BG       ERLENGTH          TOO LONG
FILEOPS4 LI,R7    -1                SET TEXT FLAG
FIOPSTBL B       *R15                GO TO PROPER ROUTINE
         GEN,1,1,1,1,1,7,20   0,0,1,0,0,0,FIO1    TIE NUMBER-INTEGER
         GEN,1,1,1,1,1,7,20   0,0,0,0,1,11,FIO2   NAME-TEXT
         GEN,1,1,1,1,1,7,20   0,0,1,0,1,8,FIO3    ACCOUNT-TEXT OR 0
         GEN,1,1,1,1,1,7,20   0,0,1,0,1,8,FIO4    PASSWORD-TEXT OR 0
         GEN,1,1,1,1,1,7,20   0,0,1,0,0,0,FIO5    OPEN-INTEGER
         GEN,1,1,1,1,1,7,20   0,0,1,0,0,0,FIO6    CLOSE-SAVE-INTEGER
         GEN,1,1,1,1,1,7,20   0,0,1,0,0,0,FIO7    CLOSE-REL-INTEGER
         GEN,1,1,1,1,1,7,20   1,0,1,0,0,0,FIO8    GET KEY-INTEGER
         GEN,1,1,1,1,1,7,20   1,0,1,0,0,0,FIO9    SET KEY-INTEGER
         GEN,1,1,1,1,1,7,20   1,1,0,0,0,0,FIO10   WRITE-ANY DATA
         GEN,1,1,1,1,1,7,20   1,1,0,0,0,0,FIO11   WRITE COMP-ANY DATA
         GEN,1,1,1,1,1,7,20   1,0,1,0,0,0,FIO12   READ-INTEGER
         GEN,1,1,1,1,1,7,20   1,0,1,0,0,0,FIO13   READ COMP-INTEGER
         GEN,1,1,1,1,1,7,20   1,0,1,0,0,0,FIO14   READ ID-INTEGER
         GEN,1,1,1,1,1,7,20   1,0,1,0,0,0,FIO15   DELREC-INTEGER
         GEN,1,1,1,1,1,7,20   1,0,1,0,0,0,FIO16   DELCOMP-INTEGER
         GEN,1,1,1,1,1,7,20   1,0,1,0,0,0,FIO17   SKIP OR READ-INTEGER
         GEN,1,1,1,1,1,7,20   0,0,1,0,1,8,FIO18   LIB-TEXT OR 0
         GEN,1,1,1,1,1,7,20   0,0,1,0,0,0,FIO19   FNAM-FNUM-INTEGER
         GEN,1,1,1,1,1,7,20   0,0,1,0,1,12,FIO20  PACK NO-TEXT OR 0
         GEN,1,1,1,1,1,7,20   0,0,0,0,1,40,FIO21  FID-TEXT
         GEN,1,1,1,1,1,7,20   1,1,0,0,0,0,FIO22   WRITE RAW-ANY DATA
         GEN,1,1,1,1,1,7,20   1,0,1,0,0,0,FIO23   READ RAW-INTEGER
         GEN,1,1,1,1,1,7,20   1,0,1,0,0,0,FIO24   SEQ READ RAW-INTEGER
         GEN,1,1,1,1,1,7,20   0,0,0,1,0,0,FIO25   CNVRT C TO L-TEXT
         GEN,1,1,1,1,1,7,20   0,0,0,1,0,0,FIO25   CNVRT C TO I-TEXT
         GEN,1,1,1,1,1,7,20   0,0,0,1,0,0,FIO25   CNVRT C TO R-TEXT
*
* THE FIELDS IN FIOPSTBL,ABOVE,HAVE THE FOLLOWING MEANING
*
*     FIELD 1 (1 BIT)  1=TEST IF FILE OPEN
*     FIELD 2 (1 BIT)  1=WRITE OPERATION, ANY RTARG OK
*     FIELD 3 (1 BIT)  1=NUMERIC INTEGER OK FOR RTARG
*     FIELD 4 (1 BIT)  1='CONVERT' PRIMITIVE-RTARG MUST BE TEXT VECTOR
*     FIELD 5 (1 BIT)  1=RTARG MAY BE TEXT VECTOR OF SPECIFIED MAX LNGTH
*     FIELD 6 (7 BITS)    MAX LENGTH IF FIELD 5=1
*     FIELD 7 (20 BITS)   ADDRESS OF PRIMITIVE ROUTINE
*
*
* FI01-SET FIODCB AND FIODCBNO (INDICATES I/O STREAM FOR LATER ACTIONS)
*
FIO1     BLEZ     ERDOMAIN         STREAM NO. MUST BE POSITIVE          U20-0071
         LI,R3    NUMFILES         SET LOOP TO LOOK FOR EXISTING TIE    U20-0072
FIO1A    CW,R7    FIOTIE-1,R3       CHECK FOR MATCH                     U20-0073
         BE       FIO1D              SCORE                              U20-0074
         BDR,R3   FIO1A              NO-LOOP                            U20-0075
         LI,R3    NUMFILES         SET LOOP TO LOOK FOR NEW SLOT        U20-0076
FIO1B    LW,R5    FIOTIE-1,R3       CHECK FOR UNUSED SLOT               U20-0077
         BEZ      FIO1C              FOUND--USE IT                      U20-0078
         BDR,R3   FIO1B               LOOP                              U20-0079
         LI,R12   3                TABLE FULL                           U20-0080
         B        ERRAPL
FIO1C    STW,R7   FIOTIE-1,R3      FILL NEW SLOT                        U20-0082
FIO1D    STW,R3   FIODCBNO          SET DCB NO.                         U20-0083
         LW,R5    FIODCBT-1,R3                                          U20-0084
         STW,R5   FIODCB            SET DCB ADDRESS                     U20-0085
         B        FIOEX
*
* FIO2-SET FILE NAME IN FIO  OPEN FPT
*
FIO2     BGEZ     ERDOMAIN          NUMERIC-INVALID
         LI,R6    BA(CONSTBUF)+3    SET-UP
         LW,R7    FIOMBSN            MBS
         MBS,R6   0                 FORM NAME IN TEXTC
         B        FIOEX
*
* FIO3-SET(OR RESET) ACCOUNT IN FIO FPT
*
FIO3     BLZ      FIO3A             TEXT-SET ACCT
         BGZ      ERDOMAIN           ERROR
         LI,R4    BA(FIOACCC)+2     RESET ACCOUNT
         B        FIO3OR4R           (R7=0)
FIO3A    LI,R3    FIOACCT            ACCT ADDRESS
         LI,R4    BA(FIOACCC)+2      ACCT CONTROL (BA)
         LI,R7    BA(FIOACCT)        ACCT ADDRESS (BA)-FOR MBS
FIO3OR4S LW,R9    CONSTBUF          BYTE COUNT
         STB,R9   R7                SET MBS COUNT
         LW,R5    BLANKS
         STD,R5  *R3                PRE-BLANK ACCT OR PASSWORD
         LI,R6    BA(CONSTBUF+1)    SET UPMBS
         MBS,R6   0                 SET ACCT OR PASS
         LI,R7    2
FIO3OR4R STB,R7   0,R4              SET OR RESET ACCT OR PASS CONTROL
         B        FIOEX              EXIT
*
* FIO4-SET (OR RESET) PASSWORD IN FIO FPT
*
FIO4     BLZ      FIO4A             TEXT-SET PASS
         BGZ      ERDOMAIN           ERROR
         LI,R4    BA(FIOPASC)+2     0-RESET PASS
         B        FIO3OR4R
FIO4A    LI,R3    FIOPASS            PASS ADDRESS
         LI,R4    BA(FIOPASC)+2      PASS CONTROL (BA)
         LI,R7    BA(FIOPASS)        PASS ADDRESS (BA)-FOR MBS
         B        FIO3OR4S            SET PASSWORD
*
* FIO5-SET FIO MODE,READ AND WRITE CONTROL AND FIOABNT FLAG-
*        OPEN CURRENT I/O CHANNEL IN INDICATED MODE
*
*        ERROR IN CAL----  EXITS TO ERRFF FOR PROCESSING
*
*        ON SUCCESS,OUT OR OUTIN, SET FIRST,CURRENT, AND LAST KEYS=1000
*                   IN  OR INOUT,GET FIRST KEY FROM DCB,POSITION FILE
*                                TO END,GET LAST KEY FROM DCB,REPOSITION
*                                TO BEGINNING,SET CURRENT KEY=FIRST
*
FIO5     CI,R7    104               64+32+8
         BG       ERDOMAIN           UNGOOD
         LW,R5    FIODCBNO          CHECK IF TIE NO. EXISTS             U20-0087
         LW,R5    FIOTIE-1,R5                                           U20-0088
         BLEZ     FIOCLSD            ERROR EXIT IF NOT                  U20-0089
         LD,R4    ZEROZERO          PRESET TO 'NONE'
         STW,R4   FIOABNT           RESET FIOABN FLAG
         CI,R7    64                CHECK WRITE CONTROL
         BAZ      FIO5A
         LI,R4    1                 'ALL'
FIO5A    CI,R7    32                CHECK READ CONTROL
         BAZ      FIO5B
         LI,R5    1                 'ALL'
FIO5B    LW,R6    NONEALL,R4
         STW,R6   FIOWRITC          SET WRITE CONTROL
         LW,R6    NONEALL,R5
         STW,R6   FIOREADC          SET READ CONTROL
         AND,R7   X1F               MASK OFF READ-WRITE
         BEZ      ERDOMAIN          NO IO MODE
         CI,R7    17                CHECK FOR INABN
         BNE      FIO5C              NO
         LI,R7    1                  YES-SET MODE TO IN
         STW,R7   FIOABNT                AND SET INABN FLAG
         B        FIOSMODE
FIO5C    CI,R7    8                 CHECK I/O MODE
         BE       FIOSMODE          OUTIN
         CI,R7    4
         BE       FIOSMODE          INOUT
         CI,R7    2
         BLE      FIOSMODE          IN OR OUT
         B        ERDOMAIN          INCONSISTENT I/O MODE
FIOSMODE STW,R7   FIOMODE
CALOPFIO CAL1,1   FPTOPFIO          OPEN DCB
         LW,R6    FIOABNT           CHECK IF INABN
         BNEZ     FIOINABN           YES-ERROR
         LW,R5    FIODCBNO
         CI,R7    10                CHECK IF OUT OR OUTIN
         BAZ      FIOINOK            NO-MUST BE IN OR INOUT
FIOMPTF  LW,R6    MAXKEY            SET FIRST KEY FOR EMPTY FILE        20-00002
         STW,R6   FRSTKEYT-1,R5
         LI,R6    1                 SET CURR.-LAST KEYS FOR EMPTY FILE  20-00004
         STW,R6   LASTKEYT-1,R5
         STW,R6   CURRKEYT-1,R5
         B        FIOEX
FIOINABN LI,R12   0                 ERROR TYPE=0 (OLD FILE)
         LW,R5    FIODCB             DCB ADDRESS
         LI,R6    ERRAPL              ERROR EXIT
         B        CLOSV                CLOSE AND SAVE
FIOINOK  RES      0
CALRDFII CAL1,1   FPTRDFIS          READ 1ST RECORD
         BAL,R8   FIOSETKY          GET KEY FROM DCB
         STW,R4   FRSTKEYT-1,R5      SET FIRST KEY
CALFPFEX CAL1,1   FPTFPFE           POSITION TO END OF FILE
         BAL,R8   FIOSETKY          GET KEY FROM DCB
         STW,R4   LASTKEYT-1,R5      SET LAST KEY
         LW,R4    FRSTKEYT-1,R5     SET CURRENT
         STW,R4   CURRKEYT-1,R5      KEY=FIRST KEY
CALFPFBX CAL1,1   FPTFPFB           POSITION TO BEGINNING OF FILE
         B        FIOEX
*
* FIO6-CLOSE AND SAVE FILE FOR INDICATED DCB #
*
FIO6     BAL,R6   FIONUMCK         GET DCB NO. (OR ERROR EXIT)          U20-0091
         LI,R6    FIOEX              SET EXIT
         B        CLOSV               CLOSE AND SAVE
*
* FIO7-CLOSE AND RELEASE FILE FOR INDICATED DCB #
*
FIO7     BAL,R6   FIONUMCK         GET DCB NO. (OR ERROR EXIT)          U20-0093
         LI,R6    X'FF00'           SET MASK                            U20-0094
         AND,R6   26,R5              CHECK IF ACCT SET IN DCB           U20-0095
         BEZ      FIO7A               NO-OK                             U20-0096
         LW,R6    J:ACCN              YES-CHECK IF USERS ACCT           U20-0097
         LW,R7    J:ACCN+1                                              U20-0098
         LW,R8    27,R5               (ACCT IN DCB)                     U20-0099
         LW,R9    28,R5                                                 U20-0100
         CD,R6    R8                                                    U20-0101
         BE       FIO7A            OK                                   U20-0102
         BAL,R6   CLOSV            NOT USERS ACCT,CLOSE AND SAVE        U20-0103
         LI,R12   4                 SET ERROR VALUE                     U20-0104
         B        ERRAPL
FIO7A    LI,R6    FIOEX            SET EXIT                             U20-0106
         B        CLOSR               CLOSE AND RELEASE
*
*  FIONUMCK-SEARCH DCB TABLE FOR TIE NO. IN R7-ERROR EXIT IF NOT FOUND  U20-0108
*           USED IN 'CLOSE' OPERATIONS ONLY-'UNTIES' FILE               U20-0109
*           IF FOUND,SET R5 TO ADDRESS OF DCB                           U20-0110
*                        R3 IS TABLE INDEX                              U20-0111
*                        R6 IS LINK                                     U20-0112
*           TABLE VALUE IS ZEROED                                       U20-0113
*                                                                       U20-0114
*
FIONUMCK BLEZ     ERDOMAIN          OUT OF RANGE
         LI,R3    NUMFILES          SET LOOP                            U20-0116
FIONUMC1 CW,R7    FIOTIE-1,R3        CHECK FOR TIE NUMBER               U20-0117
         BE       FIONUMC2            FOUND                             U20-0118
         BDR,R3   FIONUMC1             LOOP                             U20-0119
         B        FIOCLSD               NOT FOUND-NO OPEN FILE          U20-0120
FIONUMC2 LI,R5    0                                                     U20-0121
         STW,R5   FIOTIE-1,R3       ZERO TABLE ENTRY (FOR 'UNTIE')      U20-0122
         LW,R5    FIODCBT-1,R3       GET DCB ADDRESS (FOR CLOSE)        U20-0123
         B        0,R6                RETURN                            U20-0124
*
* FIO8-GETS VALUE OF FIRST,CURRENT,OR LAST KEY  FOR DCB
*
FIO8     BLEZ     ERDOMAIN          OUT OF RANGE
         CI,R7    3
         BG       ERDOMAIN          OUT OF RANGE
         LW,R7    WHICHKEY-1,R7     GET KEY TABLE ADDRESS
         AW,R7    FIODCBNO           OFFSET BY DCB #
         LW,R12   0,R7                GET KEY VALUE
         B        GENSCLR           GEN. SCALAR INTG DATA BLK & EXIT.
WHICHKEY DATA     FRSTKEYT-1
         DATA     CURRKEYT-1
         DATA     LASTKEYT-1
*
* FIO9-SET CURRENT KEY FOR DCB                                          20-00006
*
FIO9     BLEZ     ERDOMAIN          OUT OF RANGE
         BAL,R4   FIOKEYSZ          CHECK IF IN KEY RANGE
         LW,R6    FIODCBNO          GET DCB #
         STW,R7   CURRKEYT-1,R6      SET CURRENT KEY
         B        FIOEX
*
* FIO10-WRITE A DATA RECORD WITH CURRENT KEY AND DCBNO
*       USES FIORECSU,IN FIO11, AND GOES TO CALWRFD IN FIO11
*       TO WRITE THE RECORD
*
FIO10    BAL,R6   FIORECSU          SET UP TO WRITE RECORD
         B        CALWRFD
*
* FIO11-WRITE AN FIO ID RECORD AND A DATA RECORD
*       THIS MAKES UP ONE FIO-'COMPONENT'
*
*  ERROR IN CAL---- EXITS TO ERRFF FOR PROCESSING
*
FIO11    BAL,R7   GETTIME           LEAVES TIME IN R8-R9  USES R6-R10
         BAL,R6   FIORECSU          SET UP TO WRITE RECORDS-SIZE IN R7
         LW,R10   J:ACCN
         LW,R11   J:ACCN+1          ACCOUNT IN R10-R11
         LCI      5
         STM,R7   FIDBUF            FORM ID RECORD
CALWRFI  CAL1,1   FPTWRFI            WRITE IT
         BAL,R8   FIOSETKY           FIRST KEY MAY NEED UPDATE          20-00009
         MTW,1    FIOKEY            UPDATE KEYS
CALWRFD  CAL1,1   FPTWRFD           WRITE DATA RECORD
         BAL,R8   FIOSETKY          UPDATE CURRENT (AND MAYBE LAST)KEY
         B        FIOEX
*
* FIORECSU-ROUTINE TO SETUP FOR WRITE OF DATA RECORD
*          GETS ADDRESS AND SIZE OF RTARG-CONTINUE AT-
* FIORCSUA-SECOND ENTRY POINT
*          SETS RECORD SIZE IN BYTES
*          SETS KEY
*  R6=LINK R4,R5,R7 USED
*
FIORECSU LW,R5    RTARG             SET-UP TO WRITE FIO RECORD
         STW,R5   FIOBUF             ADDRESS
         LW,R7   *RTARG
FIORCSUA AND,R7   XFFFF
         SLS,R7   2
FIORCSUB STW,R7   FIOSIZ            SIZE IN BYTES
         LW,R5    FIODCBNO           DCB #
         LW,R4    CURRKEYT-1,R5
         OR,R4    KEYBYTE
         STW,R4   FIOKEY            KEY
         B        0,R6
*
* FIO12-READ A DATA RECORD  USING  CURRENT KEY
*
*  ALSO ENTERED AT FIO14D FROM FIO13-FIO14(AFTER READING ID RECORD)
*
*   INCLUDES ROUTINES:
*      FIOSETRD-SETUP FOR READ-(CALLED FROM FIO17)
*           *    R8=LINK
*           *    R4,R5,R6,R7,R10,R11 USED
*           *    CALLS ALOCBLK AND FIORCSUA
*      FIOENDRD-SET UP RESULT AFTER READ-(CALLED FROM FIO17)
*           *    R8=LINK
*           *    R4,R5,R7 USED
*
*  ERROR IN CALRDFDK EXITS TO ERRFF FOR PROCESSING
*
FIO14D   MTW,1    CURRKEYT-1,R5     SET KEY TO READ DATA RECORD
         LW,R7    FIDBUF
FIO12    BLEZ     ERDOMAIN          NO DICE
         LI,R8    CALRDFDK          SET EXIT FROM FIOSETRD
FIOSETRD AI,R7    3                 ADD 3 BYTES FOR WORD BOUND          20-00012
         SLS,R7   -2                SET WORD SIZE                       20-00013
         LW,R11   R7                                                    20-00014
         AI,R11   1
         AND,R11  FFFFFFFE          INSURE EVEN VALUE FOR DATA BLOCK
         STW,R11  CONSTBUF           SAVE SIZE IN WORDS
         BAL,R7   ALOCBLK             ALLOCATE DATA BLOCK
         STW,R4   RESULT               SET RESULT
         STW,R4   FIOBUF            SET READ ADDRESS
         LW,R7    CONSTBUF           RESTORE SIZE IN WORDS
         BAL,R6   FIORCSUA          SET SIZE IN BYTES AND KEY
         B       *R8                RETURN
CALRDFDK CAL1,1   FPTRDFDK           READ RECORD
         LI,R8    DXRETURN          SET EXIT FROM FIOENDRD
FIOENDRD LH,R6   *RESULT            SAVE TYPE-RANK IN R6                U20-0126
         LW,R4    CONSTBUF           ALLOCATED SIZE,TEMP TYPE-RANK=0    U20-0127
         LI,R5    1                  REF COUNT=1                        U20-0128
         STD,R4  *RESULT                                                U20-0129
         LI,R7    13                                                    U20-0130
         LW,R11  *FIODCB,R7         GET ACTUAL RECORD SIZE              U20-0131
         AI,R11   7                                                     U20-0132
         SLS,R11  -2                                                    U20-0133
         AND,R11  FFFFFFFE           NO. OF WORDS,ROUNDED TO EVEN NO.   U20-0134
         XW,R11   CONSTBUF           SWITCH WITH ALLOCATED SIZE         U20-0135
         SW,R11   CONSTBUF           ALLOCATED SIZE-NEEDED SIZE         U20-0136
         LW,R4    RESULT            DB POINTER                          U20-0137
         BAL,R7   GIVEBACK          RETURN UNUSED MEMORY                U20-0138
         STH,R6  *RESULT             RESTORE ORIGINAL TYPE-RANK         U20-0139
         SLS,R6   -8                R6=TYPE                             U20-0140
         LW,R4    RESULT                                                U20-0141
         LH,R7   *RESULT            CHECK FOR SCALAR INTEGER            20-00045
         CI,R7    X'0300'                                               20-00046
         BNE      FIOVCK             NO                                 20-00047
         STB,R5  *RESULT,R5          YES,SET TO VECTOR                  20-00048
         XW,R5    2,R4                SET LENGTH TO ONE                 20-00049
         STW,R5   3,R4                 AND MOVE VALUE DOWN              20-00050
FIOVCK   BAL,R7   CKVDB             CHECK VALIDITY OF DATA BLOCK        U20-0143
         B        ERRBADDB           NO GOOD                            U20-0144
         B       *R8                EXIT
*
*  FIO13-READ AN ID RECORD AND DATA RECORD-KEYED OR SEQUENTIALLY
*  FIO14-READ AN ID RECORD ONLY-KEYED OR SEQUENTIALLY
*
* COMMON CODE USED TO READ THE ID RECORD FOR EITHER ENTRY
*
*
*  ERROR IN CAL---- EXITS TO ERRFF FOR PROCESSING
*
*  IF SEQUENTIAL,FIO14C DOES THE READ
*
*      FIOSETKY-GETS KEY FROM DCB,SETS AS CURRENT KEY
*           *   (CALLED FROM FIO5 AND FIO17)
*           *    R8=LINK
*           *    R4,R5 USED
*
*   FIO14B-CHECKS ID RECORD FOR APPARENT VALIDITY
*          -SIZE =20 BYTES
*          -TIME WORD IN REASONABLE RANGE
*           DAY #173 OF YEAR #72 TO DAY #0 OF YEAR #77
*        THIS TEST SHOULD ELIMINATE ESSENTIALLY ALL FALSE FIO ID RECRDS
*
*   FIO14B THEN CHECKS IF ENTRY WAS FOR ID RECORD ONLY OR 'COMPONENT'
*        IF COMPONENT, GOES TO FIO14D
*        IF ID RECORD ONLY, FORMS RESULT AND EXITS
*
FIO13    RES      0
FIO14    BEZ      FIO14C            SEQUENTIAL READ
         BAL,R4   FIOKEYSZ           RANGE CHECK KEY
         LW,R5    FIODCBNO            GET DCB H
         STW,R7   CURRKEYT-1,R5       SET CURR KEY
         OR,R7    KEYBYTE
         STW,R7   FIOKEY              AND FIOKEY
CALRDFIK CAL1,1   FPTRDFIK          READ ID RECORD
FIO14B   LI,R4    8                 CHECK ID RECORD FORMAT
         LI,R12   1                 ERROR CODE=0,SUBCODE=1
         LH,R14  *FIODCB,R4
         SLS,R14  -1                CHECK ARS
         AI,R14   -20                IF NOT 20,ERROR EXIT
         BNEZ     ERRAPL
         LW,R14   FIDBUF+1          CHECK TIME WORD
         CLM,R14  YEARANGE           IF NOT IN REASONABLE
         BCS,9    ERRAPL
         LW,R14   SAVER4            CHECK IF                            U20-0146
         CI,R14   13                 ID ONLY
         BEZ      FIO14D              NO-PROCEED TO READ DATA RECORD
         LI,R11   8                 YES-CREATE
         BAL,R7   ALOCBLK                TEXT DATA BLOCK
         STW,R4   RESULT                  FOR ID REC
         LW,R5    FIOIDHDR                 AS RESULT
         LI,R6    1                 MOVE DATA          REF COUNT=1
         LI,R7    5                  AND HEADER        LENGTH=5
         LCI      5                   TO ALLOCATED
         LM,R8    FIDBUF               DATA BLOCK
         LCI      8
         STM,R5  *R4
         B        DXRETURN
*
FIO14C   RES      0
CALRDFIS CAL1,1   FPTRDFIS          READ SEQUENTIAL-LOOK FOR ID REC.
         LI,R8    FIO14B            SET EXIT FROM FIOSETKY
FIOSETKY LW,R4    FIODCB
         LW,R4    10,R4             GET KEY FROM DCB
         LW,R4   *R4
         AND,R4   XFFFFFF           MASK OFF  BYTE 0
         LW,R5    FIODCBNO
         STW,R4   CURRKEYT-1,R5     SET IN CURRKEYT
         CW,R4    LASTKEYT-1,R5
         BLE      FIOSK1                                                20-00016
         STW,R4   LASTKEYT-1,R5
FIOSK1   CW,R4    FRSTKEYT-1,R5     CHECK FIRST KEY                     20-00018
         BGE     *R8                                                    20-00019
         STW,R4   FRSTKEYT-1,R5     SET NEW FIRST KEY                   20-00020
         B       *R8
*
* FIO15-DELETE A RECORD WITH INDICATED KEY
*
*  ERROR IN CALDELR EXITS TO ERRFF FOR PROCESSING
*
FIO15    BAL,R4   FIOMODCK          CHECK FOR MODE AND KEY              U20-0148
         BAL,R4   FIOKEYSZ          CHECK RANGE
         OR,R7    KEYBYTE
         STW,R7   FIOKEY            SET KEY
CALDELR  CAL1,1   FPTDELR           DELETE RECORD
CALFPFBD CAL1,1   FPTFPFB           POSITION TO BEGINNING OF FILE       20-00022
         B        FIOINOK           GET NEW FIRST AND LAST KEYS         20-00023
*
* FIO16-DELETE 'COMPONEMT'-ID REC AND DATA REC WITH INDICATED KEY
*        TRIES TO DELETE DATA RECORD FIRST,THEN ID REC
*
*  ERROR IN CALDELR1 EXITS TO ERRFF FOR PEOCESSING
*
FIO16    BAL,R4   FIOMODCK          CHECK FOR MODE AND KEY              U20-0150
         AI,R7    1                 GET KEY OF DATA RECORD
         BAL,R4   FIOKEYSZ           CHECK RANGE
         OR,R7    KEYBYTE
         STW,R7   FIOKEY            SET KEY
CALDELR1 CAL1,1   FPTDELR           DELETE DATA RECORD
         MTW,-1   FIOKEY            BACK UP TO ID RECORD
         B        CALDELR           DELETE IT
*                                                                       U20-0152
*  FIOMODCK-CHECK FOR NEGATIVE KEY OR NON-UPDATE MODE ON DELETE OPER.   U20-0153
*        R4=LINK,R5 AND R6 USED                                         U20-0154
*                                                                       U20-0155
FIOMODCK BLEZ     ERDOMAIN          BAD KEY VALUE                       U20-0156
         LI,R6    5                                                     U20-0157
         LB,R5   *FIODCB,R6         GET MODE FROM DCB                   U20-0158
         SLS,R5   -1                                                    U20-0159
         AI,R5    -4                                                    U20-0160
         BEZ      0,R4              UPDATE-RETURN                       U20-0161
         LI,R12   20                 OTHER MODE-SET ERROR CODE
         B        ERRAPL
*
* FIO17-READ DATA RECORD SEQUENTIALLY OR SKIP RECORD
*
*  ERROR IN CALRDFDS EXITS TO ERRFF FOR PROCESSING
*
FIO17    BGZ      FIO17A
CALFPR   CAL1,1   FPTFPR            SKIP RECORD
         BAL,R8   FIOSETKY          SET CURRENT KEY FROM DCB
         B        FIOEX
FIO17A   BAL,R8   FIOSETRD          SET UP FOR SEQ. READ(+UNUSED KEY)
CALRDFDS CAL1,1   FPTRDFDS          READ SEQUENTIAL DATA
         BAL,R8   FIOENDRD          CLEAN UP ALLOCATED DATA BLOCK
         BAL,R8   FIOSETKY          SET CURRENT KEY FROM DCB
         B        DXRETURN          RETURN
*
* FIO18-FORM TEXT ARRAY OF FILES IN INDICATED ACCOUNT
*        FILES LISTED ARE THOSE WHOSE FIRST RECORDS APPEAR
*        TO BE PROPERLY FORMATTED FIO ID RECORDS, AND FILES
*        WHICH ARE PASSWORDED OR READ PROTECTED
*
*  ERROR IN CAL---- EXITS TO ERRFF FOR PROCESSING
*
*    FIO18 CALLS GARBCOLL AND PERFORMS DATA BLOCK EXTENSION BECAUSE
*        THE SIZE OF THE RESULT CANNOT BE PREDETERMINED
*
FIO18    BGZ      ERDOMAIN          CHECK IF NUMERIC-YES-QUIT
         BEZ      %+2                ZERO-OK-RESET ACCT.
         LI,R7    2                  TEXT-SET ACCT
         LI,R6    2
         STB,R7   OP1STACC,R6       SET OR RESET ACCOUNT CONTROL
         LW,R5    BLANKS
         STD,R5   OP1STACT          PRESET ACCT DATA TO BLANKS
         AI,R7    0                 CHECK IF ACCT INDICATED
         BEZ      FIO18A             NO-LEAVE BLANKS
         LI,R6    BA(CONSTBUF+1)
         LI,R7    BA(OP1STACT)
         LW,R8    CONSTBUF
         STB,R8   R7
         MBS,R6   0                 SET ACCT DATA-WITH TRAILING BLANKS
FIO18A   BAL,R8   GARBCOLL          GARBAGE COLLECT-CONTIGUOUS SPACE
         LI,R11   4                  NEEDED FOR TEXT DATA BLOCK
         BAL,R7   ALOCBLK             GET 1ST 4 WORDS-WILL BE EXTENDED
         LW,R7    FIOTXMAT
         STW,R7  *R4                SET UP AS TEXT MATRIX-4 WORDS
         STW,R4   RESULT             SET AS RESULT
         LI,R7    0
         STW,R7   2,R4              SET # OF ROWS=0
         LI,R7    24
         STW,R7   3,R4              SET # OF COLUMNS=24
         AI,R4    2
         STW,R4   CONSTBUF          SAVE POINTER TO # OF ROWS
CALFION1 CAL1,1   FPTOP1ST
         B        CALFIOR1
FIONXTF  LI,R5    F:TF
         BAL,R6   CLOSV
         MTW,0    BREAKFLG          CHECK FOR BREAK
         BNEZ     DXRETURN           YES(OR HANGUP)-CLEAR OUT
CALFIONX CAL1,1   FPTOPNXT          OPEN NEXT FILE
CALFIOR1 CAL1,1   FPTRD1ST          READ 1ST RECORD
         LH,R14   F:TF+4            CHECK ARS
         SLS,R14  -1
         AI,R14   -20
         BNEZ     FIONXTF           NOT AN FIO ID REC.
         LW,R14   FIDBUF+1          CHECK TIME WORD
         CLM,R14  YEARANGE
         BCS,9    FIONXTF           NOT AN FIO ID REC
         LI,R0    X'40'             BLANK
FIO18B   LI,R11   6                 GET AN EXTENSION TO DATA BLOCK
         BAL,R7   ALOCBLK
         MTW,6   *RESULT            UPDATE TRU DATA BLOCK SIZE
         MTW,1   *CONSTBUF           AND # OF ROWS
         LD,R6    OP1STACT          STORE
         STD,R6  *R4                 ACCOUNT
         LW,R7    BLANKS
         SLS,R4   -1                DW ALIGNMENT
         STD,R7   2,R4               PREBLANK
         STD,R7   4,R4                NAME FIELD
         LI,R6    BA(F:TF+23)+1     SOURCE ADDRESS-NAME
         LW,R7    R4
         SLS,R7   3                 BYTE ALIGNMENT
         AI,R7    10                 DESTINATION ADDRES
         LB,R8    F:TF+23           BYTE COUNT
         STB,R8   R7
         MBS,R6   0                 MOVE NAME
         SLS,R4   3                 BA ALIGNMENT
         AI,R4    22                OFFSET TO END OF NAME
         STB,R0   0,R4              STORE BLANK OR ASTERISK
         B        FIONXTF           GO TO NEXT FILE
*
* FIO19-FORMS TEXT ARRAY OF CURRENTLY OPEN FILE-ACCT-NAMES
*        OR INTEGER VECTOR OF CURRENTLY OPEN DCB NO'S
*
FIO19    BLEZ     ERDOMAIN
         AI,R7    -2                RANGE TEST
         BGZ      ERDOMAIN           TOO BIG-QUIT
         LI,R6    1
         LI,R5    0                 PRESET ITEM COUNT
FIO19A   LW,R8    FIODCBT-1,R6      GET DCB ADDRESS
         LW,R8   *R8                CHECK IF OPEN
         CW,R8    BITPOS-10
         BAZ      FIO19B             NO
         AI,R5    1                  YES-KICK ITEM COUNT
         STW,R6   CONSTBUF+1,R5      STORE DCB  #
FIO19B   AI,R6    1
         CI,R6    NUMFILES
         BLE      FIO19A            LOOP
         STW,R5   CONSTBUF+1        SAVE ITEM COUNT
         AI,R7    0                 CHECK WHICH OPTION
         BLZ      FIO19C             TEXT
         AI,R5    4                  NUMBERS
         B        FIO19D
FIO19C   MI,R5    5                 TEXT TAKES 5 WORDS/ACCT-NAME        U20-0165
         AI,R5    5                  AND IS ARRAY (RANK 2)
FIO19D   AND,R5   FFFFFFFE
         LW,R11   R5
         BAL,R7   ALOCBLK           GET THE DATA BLOCK
         STW,R4   RESULT
         MTW,-2   CONSTBUF
         BLZ      FIO19E
         LI,R7    X'0301'           INTEGER VECTOR
         STH,R7  *R4                 SET TYPE AND RANK
         LW,R5    CONSTBUF+1        GET COUNT                           U20-0167
         BNEZ     FIO19S            BRANCH IF NOT EMPTY                 U20-0168
         STW,R5   2,R4              EMPTY-INDICATE IT                   U20-0169
         B        DXRETURN                                              U20-0170
FIO19S   LW,R6    CONSTBUF+1,R5      SWITCH FROM                        U20-0171
         LW,R6    FIOTIE-1,R6         DCB NUMBERS                       U20-0172
         STW,R6   CONSTBUF+1,R5        TO TIE NUMBERS                   U20-0173
         BDR,R5   FIO19S                LOOP                            U20-0174
         LW,R5    CONSTBUF+1        GET COUNT
         AI,R5    1                  +1
         SCS,R5   -4
         LC       R5
         LM,R5    CONSTBUF+1        GET COUNT+VALUES
         STM,R5   2,R4              STASH IN RESULT
         B        DXRETURN          RETURN
FIO19E   LI,R7    X'0202'           TEXT-MATRIX
         STH,R7  *R4                 SET TYPE-RANK
         LI,R6    20                NO. OF COLUMNS                      U20-0176
         STW,R6   3,R4
         LW,R7    CONSTBUF+1
         STW,R7   2,R4              # OF ROWS
         BEZ      DXRETURN           QUIT IF EMPTY
         LI,R5    1
FIO19F   LW,R6    CONSTBUF+1,R5     POINT TO DCB TABLE
         LW,R6    FIODCBT-1,R6       THEN TO DCB
         AI,R6    23                  THEN TO NAME
         LW,R9    BLANKS
         STD,R9   R10               BLANK R9-R11
         STD,R9   R12               BLANK R12-R13                       U20-0178
         LI,R7    X'FF00'           MASK                                U20-0179
         AND,R7   3,R6               CHECK IF ACCT SPECIFIED            U20-0180
         BEZ      FIO19G              NO                                U20-0181
         LW,R9    4,R6                YES-SET UP R9-R10                 U20-0182
         LW,R10   5,R6                                                  U20-0183
FIO19G   LB,R8   *R6                BYTE COUNT OF NAME                  U20-0184
         SLS,R6   2                 BA(NAME)-1
         AI,R6    1                  SOURCE ADDRESS FOR MBS
         LI,R7    45                BA(R11)+1,DESTINATION ADDRESS       U20-0186
         STB,R8   R7                 COUNT
         MBS,R6   0                 FORM NAME+TRAILING BLANKS IN R11-R13U20-0188
         LCI      5                                                     U20-0189
         STM,R9   4,R4              LOAD ACCT-NAME IN DATA BLOCK        U20-0190
         AI,R4    5                 UPDATE R4                           U20-0191
         AI,R5    1                  AND POINTER
         CW,R5    CONSTBUF+1        LOOP
         BLE      FIO19F
         B        DXRETURN          DONE
*
* FIOKEYSZ-CHECK FOR VALID KEY NUMBER
*        R4=LINK,R7 USED BUT NOT CHANGED
*
FIOKEYSZ CW,R7    MAXKEY
         BLE      0,R4
         B        ERDOMAIN
*                                                                       U20-0193
*  FIO20-SET(OR RESET) SERIAL NUMBER FOR PRIVATE PACKS                  U20-0194
*                                                                       U20-0195
FIO20    BLZ      FIO20A            TEXT-SET SERIAL NO.                 U20-0196
         BGZ      ERDOMAIN           ERROR                              U20-0197
         LI,R4    BA(FIOSNC)+2      RESET SERIAL NO. CONTROL            U20-0198
         B        FIO3OR4R           (R7=0)                             U20-0199
FIO20A   LI,R3    FIOSN             SERIAL NO. ADDRESS                  U20-0200
         LI,R4    BA(FIOSNC)+2      SN CONTROL WORD COUNT               U20-0201
         LI,R7    BA(FIOSN)         SERIAL NO. ADDRESS                  U20-0202
         LW,R9    CONSTBUF           GET COUNT                          U20-0203
         STB,R9   R7                  SET UP FOR MBS                    U20-0204
         LW,R5    BLANKS                                                U20-0205
         STD,R5  *R3                                                    U20-0206
         STW,R5   2,R3               PRE-BLANK FIOSN                    U20-0207
         LI,R6    BA(CONSTBUF+1)                                        U20-0208
         MBS,R6   0                  LOAD FIOSN                         U20-0209
         LW,R7    CONSTBUF           GET COUNT AGAIN                    U20-0210
         AI,R7    3                   ROUND UP TO                       U20-0211
         SLS,R7   -2                   NO. OF WORDS                     U20-0212
         B        FIO3OR4R           USE 'RESET' TO SET CONTROL WORD    U20-0213
*                                                                       U20-0214
*  FIO21-ESTABLISHES FILE ID (NAME-ACCT-PASSWORD) AS SINGLE PRIMITIVE   U20-0215
*                                                                       U20-0216
FIO21    BGEZ     ERDOMAIN          RTARG MUST BE TEXT                  U20-0217
         LW,R5    BLANKS                                                U20-0218
         STD,R5   FIOACCT           RESET ACCOUNT AND PASSWORD          U20-0219
         STD,R5   FIOPASS                                               U20-0220
         LI,R9    0                                                     U20-0221
         LI,R6    BA(FIOACCC)+2                                         U20-0222
         LI,R7    BA(FIOPASC)+2                                         U20-0223
         STB,R9   0,R6                                                  U20-0224
         STB,R9   0,R7                                                  U20-0225
         LW,R5    CONSTBUF                                              U20-0226
         LI,R8    X'15'                                                 U20-0227
         STB,R8   CONSTBUF+1,R5     SET CR AT END OF TEXT               U20-0228
         LI,R1    BA(CONSTBUF+1)     SET TO SCAN                        U20-0229
         BAL,R4   ACQNB             GET FIRST NON-BLANK IN TEXT         U20-0230
FIO21A   BAL,R14  ACQIT             ACQUIRE ALPHANUMERIC VALUE          U20-0231
         AI,R5    0                                                     U20-0232
         BEZ      FIO21E            QUIT IF EMPTY                       U20-0233
         CLM,R3   NONAME            CHECK IF NEXT ITEM IS ALPHANUMERIC  U20-0234
         BCR,9    FIO21B             NO                                 U20-0235
         AI,R9    0                  YES-CHECK IF ACCT ALREADY SET      U20-0236
         BNEZ     FIO21E              YES-ERROR                         U20-0237
         CI,R5    8                CHECK SIZE                           U20-0238
         BG       FIO21E                                                U20-0239
         LD,R8    NAMEBUF                                               U20-0240
         STD,R8   FIOACCT          SET ACCOUNT                          U20-0241
         LI,R9    2                                                     U20-0242
         STB,R9   0,R6                                                  U20-0243
         B        FIO21A           LOOP FOR NAME                        U20-0244
FIO21B   CI,R5    11               NAME ITEM                            U20-0245
         BG       FIO21E            TOO LONG                            U20-0246
         STB,R5   FIONAME                                               U20-0247
         LI,R4    BA(NAMEBUF)      MOVE NAME TO                         U20-0248
         LW,R5    FIOMBSN1          FIONAME IN TEXTC                    U20-0249
         MBS,R4   0                                                     U20-0250
         CI,R2    ':'              CHECK FOR PASSWORD                   U20-0251
         BE       FIO21C            YES                                 U20-0252
         CI,R2    '.'              CHECK FOR ACCT                       U20-0253
         BNE      FIO21X            NO                                  U20-0254
         BAL,R4   ACQNXNB           MAYBE                               U20-0255
         CI,R2    '.'                                                   U20-0256
         BE       FIO21C            NO-PASSWORD ONLY                    U20-0257
         BAL,R14  FIOAORP           YES-GET ACCOUNT                     U20-0258
         STD,R8   FIOACCT                                               U20-0259
         LI,R9    2                                                     U20-0260
         STB,R9   0,R6                                                  U20-0261
         BAL,R4   ACQNB            GET NON-BLANK                        U20-0262
         CI,R2    '.'               CHECK FOR PASSWORD                  U20-0263
         BE       FIO21C             YES                                U20-0264
FIO21X   CI,R2    X'15'            CHECK FOR CR                         U20-0265
         BE       FIOEX                                                 U20-0266
FIO21E   LI,R12   21               SET ERROR CODE                       U20-0267
         B        ERRAPL
FIO21C   BAL,R4   ACQNXNB          PROCESS PASSWORD                     U20-0269
         BAL,R14  FIOAORP                                               U20-0270
         STD,R8   FIOPASS                                               U20-0271
         LI,R9    2                                                     U20-0272
         STB,R9   0,R7                                                  U20-0273
         B        FIO21X                                                U20-0274
*                                                                       U20-0275
FIOAORP  AI,R1    -1                                                    U20-0276
         LW,R8    BLANKS                                                U20-0277
         LW,R9    BLANKS          PRESET R8-R9 TO BLANKS                U20-0278
         LI,R5    -1                                                    U20-0279
FIOAORP1 AI,R5    1                                                     U20-0280
         BAL,R4   ACQNXCC         GET NEXT CHAR.                        U20-0281
         CI,R2    X'40'            BLANK                                U20-0282
         BE       FIOAORP2          YES-QUIT                            U20-0283
         CI,R2    '.'              PERIOD                               U20-0284
         BE      *R14               YES-QUIT                            U20-0285
         CI,R2    ','              COMMA                                U20-0286
         BE      *R14               YES-QUIT                            U20-0287
         CI,R2    X'15'            CR                                   U20-0288
         BE      *R14               YES-QUIT                            U20-0289
         STB,R2   R8,R5           STASH BYTE                            U20-0290
         CI,R5    7                HOW MANY                             U20-0291
         BG       FIO21E            TOO MANY                            U20-0292
         B        FIOAORP1        LOOP                                  U20-0293
FIOAORP2 BAL,R4   ACQNXNB         SKIP TRAILING BLANKS                  U20-0294
         B       *R14
*
* FIO22-WRITES APL DATA WITHOUT HEADER INFORMATION FOR EXTERNAL
*       FILE CREATION. WRITES KEYED FILE.
*       SIZE IS ACTUAL SIZE OF DATA EXCEPT FOR LOGIC VALUES,WHICH
*       ARE ROUNDED UP TO BYTES(MULTIPLES OF 8 BITS)
*       INDEX SEQUENCES ARE CONVERTED TO INTEGER VECTORS PRIOR TO
*       OUTPUT.
*
FIO22    LB,R5   *RTARG             R5=DATA TYPE
         CI,R5    5
         BE       FIO22F            INDEX SEQ-NEEDS TO BE EXPANDED
FIO22A   LI,R7    1
         LB,R6   *RTARG,R7          R6=RANK
         LW,R4    RTARG             START OF DATA BLOCK HEADER
         AI,R4    2                  SKIP 2 HEADER WORDS
         AW,R4    R6                  SKIP LENGTH WORDS
         CI,R5    4                 IS DATA TYPE REAL
         BNE      FIO22B             NO
         AI,R4    1                  YES-ROUND TO DW BOUND
         AND,R4   FFFFFFFE
FIO22B   STW,R4   FIOBUF            WORD ADDRESS-OUTPUT BUFFER
         LI,R4    2
         LI,R7    1                 ASSUME SCALAR
         AI,R6    0                  CHECK IF IT IS
         BLEZ     FIO22D              YES
FIO22C   MW,R7   *RTARG,R4            NO-COMPUTE NO. OF UNITS
         AI,R4    1
         BDR,R6   FIO22C              LOOP
FIO22D   EXU      FIO22I-1,R5       CONVERT FROM NO. OF UNITS TO BYTES
FIO22E   LI,R6    CALWRFD           SET EXIT FROM FIORCSU
         B        FIORCSUB           COMPLETE PROCESSING
FIO22F   LW,R5    RTARG
         LW,R11   2,R5              LENGTH OF INDEX SEQUENCE
         AI,R11   1                  +1 FOR LENGTH WORD
         BAL,R7   ALOCHNW           ALLOCATE DATA BLOCK FOR INTEGER VECT
         XW,R4    RTARG             R4= ADDR OF ISEQ DB,RTARG =NEW DB
         LW,R5    RTARG             R5= ADDR OF NEW DB
         LI,R11   X'0301'
         STH,R11 *RTARG             SET TYPE AND RANK
         LW,R11   2,R4              LENGTH
         STW,R11  2,R5
         BEZ      FIO22H            EMPTY
         LW,R8    3,R4              BASE VALUE
FIO22G   AW,R8    4,R4              INCREMENT VALUE
         STW,R8   3,R5               STORE INTEGER VECTOR ELEMENT
         AI,R5    1
         BDR,R11  FIO22G             LOOP
FIO22H   BAL,R7   DREF              DROP THE INDEX SEQUENCE
         LI,R5    3                  SET INTEGER TYPE
         B        FIO22A              AND OUTPUT THAT BLOCK
FIO22I   B        FIO22J            LOGIC VALUE
         NOP                        CHARACTER
         SLS,R7   2                 INTEGER
         SLS,R7   3                 REAL
FIO22J   AI,R7    7                 ROUND LOGIC UP
         SLS,R7   -3                 DIVIDE BY 8
         B        FIO22E
*
*  FIO23-READ A DATA RECORD OF NON-APL FORM USING CURRENT KEY
*        RESULT IS A CHARACTER VECTOR WITH LENGTH=ARS
*        PRIMITIVES 25,26, AND 27 USED TO CONVERT CHARACTER
*        VECTOR RESULT TO LOGIC,INTEGER,OR REAL IF REQUIRED
*        FOR PROPER DATA REPRESENTATION.
*
FIO23    BLEZ     ERDOMAIN
         AI,R7    12                ADD 3 WORDS FOR HEADER
         BAL,R8   FIOSETRD           USE NORMAL SETUP FOR READ
         LI,R8    -12
         AWM,R8   FIOSIZ            ADJUST TO READ BEYOND HEADER
         MTW,3    FIOBUF
CALRDRDK CAL1,1   FPTRDFDK           READ KEYED RECORD
         LI,R8    DXRETURN            SET EXIT FROM FIOENDRR
FIOENDRR LW,R4    CONSTBUF          ALLOCATED NUMBER OF WORDS
         LI,R5    X'0201'           CHARACTER VECTOR ID
         STH,R5   R4
         LI,R5    1                 REF COUNT=1
         LI,R6    13
         LW,R6   *FIODCB,R6         R6=ARS
         LCI      3
         STM,R4  *RESULT            SET UP HEADER
         AI,R6    19                ARS+HEADER+DW ROUND
         SLS,R6   -2
         AND,R6   FFFFFFFE          SIZE OF BLOCK ACTUALLY NEEDED
         LW,R11   CONSTBUF          SIZE ALLOCATED
         SW,R11   R6                 SURPLUS
         LW,R4    RESULT
         BAL,R7   GIVEBACK            RETURN IT
         B       *R8                   EXIT
*
*  FIO24-READ SEQUENTIALLY,NON-APL DATA RECORD
*        SIMILAR TO FIO23 BUT NOT KEYED READ
*
FIO24    BLEZ     ERDOMAIN
         AI,R7    12                ADD 3 WORDS FOR HEADER
         BAL,R8   FIOSETRD           USE NORMAL SETUP FOR READ
         LI,R8    -12
         AWM,R8   FIOSIZ            ADJUST TO READ DATA ONLY
         MTW,3    FIOBUF
CALRDRDS CAL1,1   FPTRDFDS           SEQUENTIAL READ
         BAL,R8   FIOENDRR            PROCESS RESULT
         BAL,R8   FIOSETKY             SET KEY (IF ANY)
         B        DXRETURN              EXIT
*
*  FIO25-CONVERT CHARACTER VECTOR TO LOGIC VECTOR
* FIO26(EQU FIO25)                   INTEGER VECTOR
* FIO27(EQU FIO25)                   REAL VECTOR
*
FIO25    LH,R5   *RTARG
         CI,R5    X'0201'           CHECK IF TEXT VECTOR
         BNE      ERRANK             NO-RANK ERROR
         LW,R3    RTARG
         LW,R11   2,R3              CHECK LENGTH FOR CONFORMABILITY
         CW,R11   FIO25T1-25,R4      (0,3,OR 7)
         BANZ     ERLENGTH            LENGTH NOT CONFORMABLE
         LW,R6    R4                SAVE PRIMITIVE NO. IN R6
         LW,R5    1,R3               REF COUNT OF RTARG
         AI,R5    -1
         BEZ      FIO25D             DATA BLOCK IS REUSEABLE
         INT,R11  0,R3              NOT REUSEABLE,GET NEW BLOCK
         BAL,R7   ALOCBLK
         STW,R4   RESULT             SET RESULT
FIO25A   INT,R11  0,R3              LENGTH OF DATA BLOCK
         AW,R4    R11               POINT 1 PAST END OF RESULT
         AW,R3    R11               POINT 1 PAST END OF RTARG
         CI,R6    27                CHECK IF CONVERT TO REAL
         BNE      FIO25B             NO
         AI,R3    -1                 YES-SET FOR OFFSET
FIO25B   AI,R11   -3                SUBTRACT HEADER WORDS
FIO25C   AI,R3    -1                MOVE DATA
         AI,R4    -1                 FROM RTARG
         LW,R7    0,R3                TO RESULT,
         STW,R7   0,R4                 OFFSETTING IF
         BDR,R11  FIO25C                 RESULT IS REAL.
         LW,R3    RTARG
         LW,R4    RESULT
         B        FIO25E
FIO25D   MTW,1    1,R3              REUSE RTARG-INCREMENT REF COUNT
         LW,R4    RTARG
         STW,R4   RESULT             SET RESULT=RTARG
         CI,R6    27                CHECK IF REAL
         BE       FIO25A             YES-OFFSET DATA
FIO25E   LW,R7    FIO25T2-25,R6
         STH,R7  *RESULT            SET TYPE-RANK
         LW,R7    2,R3               GET LENGTH
         EXU      FIO25T3-25,R6       ADJUST TO NEW TYPE
         STW,R7   2,R4
         B        DXRETURN           EXIT
FIO25T1  DATA     0,3,7
FIO25T2  DATA     X'0101',X'0301',X'0401'
FIO25T3  SLS,R7   3
         SLS,R7   -2
         SLS,R7   -3
*
         PAGE
*
* FPT'S FOR FILE I/O SUBSYSTEM FOLLOW:
*
*        EXCEPTIONS: FPTOPFIO-IN CSECT 0 OF APLUTSI
*                    FPTOP1ST-IN CSECT 0 OF APLUTSI
*                    FPTOPNXT-IN CSECT 1 OF APLUTSI
*                    FPTRD1ST-IN CSECT 1 OF APLUTSI
*
*
*  ERROR EXIT 'EQUATES'-ERRFF IS COMMON ACTUAL FIO ERROR ADDRESS
ABNFPR   EQU      ERRFF             ABN-SKIP RECORD
ERRRDFI  EQU      ERRFF             READ ID REC-ERR
ABNRDFI  EQU      ERRFF             READ ID REC-ABN
ERRRDFD  EQU      ERRFF             READ DATA REC-ERR
ABNRDFD  EQU      ERRFF             READ DATA REC-ABN
ERRWRFI  EQU      ERRFF             WRITE ID REC-ERR
ABNWRFI  EQU      ERRFF             WRITE ID REC-ABN
ERRWRFD  EQU      ERRFF             WRITE DATA REC-ERR
ABNWRFD  EQU      ERRFF             WRITE DATA REC-ABN
* FPTRDFIS-FPT TO READ ID-FIO RECORD-SEQUENTIALLY
*
FPTRDFIS GEN,1,7,7,17  1,X'10',0,FIODCB    DCB ADDRESS-INDIRECT
         DATA     X'F4000010'       P1,2,3,4,6 AND WAIT
         DATA     ERRRDFI           ERR  (P1)
         DATA     ABNRDFI           ABN  (P2)
         DATA     FIDBUF            BUF  (P3)
         DATA     FIDSIZ            SIZ  (P4)
         DATA     0                 BTD  (P6)
FIDSIZ   EQU      20                BYTES PER  FID RECORD
FIDBUF   EQU      IDBUF
*
* FPTRDFIK-FPT TO READ KEYED  FIO-ID RECORD
*
FPTRDFIK GEN,1,7,7,17  1,X'10',0,FIODCB
         DATA     X'FC000010'       P1,2,3,4,5,6 AND WAIT
         DATA     ERRRDFI           ERR (P1)
         DATA     ABNRDFI           ABN (P2)
         DATA     FIDBUF            BUF (P3)
         DATA     FIDSIZ            SIZ (P4)
         DATA     FIOKEY            KEY (P5)
         DATA     0                 BTD (P6)
*
*  FPTRDFDS-FPT TO READ FIO RECORD-SEQUENTIALLY
*
FPTRDFDS GEN,1,7,7,17  1,X'10',0,FIODCB    DCB ADDRESS-INDIRECT
         DATA     X'F4000010'       P1,2,3,4,6 AND WAIT
         DATA     ERRRDFD           ERR (P1)
         DATA     ABNRDFD           ABN (P2)
         GEN,1,31 1,FIOBUF          BUF (P3)
         GEN,1,31 1,FIOSIZ          SIZ (P4)
         DATA     0                 BTD (P6)
*
*  FPTRDFDK-FPT TO READ FIO DATA RECORD-KEYED
*
FPTRDFDK GEN,1,7,7,17  1,X'10',0,FIODCB    DCB ADDRESS-INDIRECT
         DATA     X'FC000010'       P1,2,3,4,5,6 AND WAIT
         DATA     ERRRDFD           ERR (P1)
         DATA     ABNRDFD           ABN (P2)
         GEN,1,31 1,FIOBUF          BUF (P3)
         GEN,1,31 1,FIOSIZ          SIZ (P4)
         DATA     FIOKEY            KEY (P5)
         DATA     0                 BTD (P6)
*
* FPTWRFI-WRITE FIO ID RECORD
*
FPTWRFI  GEN,1,7,7,17  1,X'11',0,FIODCB    DCB ADDRESS-INDIRECT
         DATA     X'FC000070'       P1,2,3,4,5,6+WAIT,NEWKEY,ONEWKEY
         DATA     ERRWRFI           ERR  (P1)
         DATA     ABNWRFI           ABN  (P2)
         DATA     FIDBUF            BUF  (P3)
         DATA     FIDSIZ            SIZ  (P4)
         DATA     FIOKEY            KEY  (P5)
         DATA     0                 BTD  (P6)
*
* FPTWRFD-WRITE FIO DATA RECORD
*
FPTWRFD  GEN,1,7,7,17  1,X'11',0,FIODCB    DCB ADDRESS-INDIRECT
         DATA     X'FC000070'       P1,2,3,4,5,6+WAIT,NEWKEY,ONEWKEY
         DATA     ERRWRFD           ERR  (P1)
         DATA     ABNWRFD           ABN  (P2)
         GEN,1,31 1,FIOBUF          BUF  (P3)
         GEN,1,31 1,FIOSIZ          SIZ  (P4)
         DATA     FIOKEY            KEY  (P5)
         DATA     0                 BTD  (P6)
*
* FPTDELR-DELETE RECORD-KEYED
*
FPTDELR  GEN,1,7,7,17  1,X'0D',0,FIODCB    DCB ADDRESS-INDIRECT
         DATA     X'80000000'       P1
         DATA     FIOKEY            KEY
*
* FPTFPFB-POSITION TO BEGINNING OF FILE
*
FPTFPFB  GEN,1,7,7,17  1,X'1C',0,FIODCB    DCB ADDRESS-INDIRECT
         DATA     16
*
* FPTFPFE-POSITION TO END OF FILE
*
FPTFPFE  GEN,1,7,7,17  1,X'1C',0,FIODCB    DCB ADDRESS-INDIRECT
         DATA     0
*
* FPTFPR-SKIP RECORD -FORWARD
*
FPTFPR   GEN,1,7,7,17  1,X'1D',0,FIODCB    DCB ADDRESS-INDIRECT
         DATA     X'C0000000'       P1,2 FORWARD
         DATA     1                 SKIP 1 RECORD
         DATA     ABNFPR            ABN
*
         PAGE
*
* FIOERR-FILE I/O MONITIOR ERROR PROCESSOR
*
FIOERR   RES      0
ERRFF    STW,R10  IOERCODE          RECORD LATEST ERR OR ABN CONDITION.
         LH,R12   R10               GET ERROR CODE AND SUBCODE
         SLS,R12  -1                SHIFT OUT EXTRA BIT
         AND,R8   X1FFFF             MASK ERROR ADDRESS
         CI,R12   3*128             CHECK FOR FILE NOT FOUND
         BNE      ERRFF1             NO
         MTW,0    FIOABNT            YES-CHECK FOR INABN MODE
         BNEZ     FIOEX               YES-NORMAL EXIT
ERRFF1   CI,R8    CALRDFII+1        CHECK IF READ FOR 'OPEN'            20-00025
         BE       ERRFF4             YES                                20-00026
         CI,R8    CALRDFDS+1         NO-CHECK IF READ ERROR             20-00027
         BE       ERRFF2             YES
         CI,R8    CALRDFDK+1         MAYBE
         BE       ERRFF2             YES
         CI,R8    CALRDRDS+1        MAYBE
         BE       ERRFF2            YES
         CI,R8    CALRDRDK+1        MAYBE
         BE       ERRFF2            YES
         CI,R8    CALRDFIS+1        CHECK IF SEQUENTIAL ID REC READ
         BNE      ERRFF3             NO
         CI,R12   7*128              YES-CHECK IF RECORD TOO BIG
         BNE      ERRFF3             NO
         B        CALRDFIS           YES-KEEP ON READING
ERRBADDB LI,R12   2                 ERROR CODE=0,SUBCODE=2
         LI,R10   X'40000'          FAKE SAME CODES FOR R10.
ERRFF2   LW,R6    CONSTBUF          ERROR ON READ,SET PROPER            20-00029
         LI,R7    1                  SIZE AND REF COUNT                 20-00030
         STD,R6  *RESULT              IN RESULT DATA BLOCK              20-00031
         LI,R4    0                    SET TO DEREF                     20-00032
         XW,R4    RESULT             DEREFERENCE THE RESULT BLOCK
         BAL,R7   DREF
ERRFF3   STW,R10  IOERCODE          SAVE CODE, SUBCODE, (MAYBE) DCB LOC.
         LW,R11   WHATERR           SHOULD APL PROCESS THE ERROR...
         BNEZ     HANDLERR            YES (14 T-BAR 2 WAS THE INTRINSIC)
GENSCLR  LI,R11   4                   NO (14 T-BAR 1 WAS THE INTRINSIC).
         BAL,R7   ALOCBLK           ALLOCATE DATA BLOCK
         LI,R11   TYPEINTG           INTEGER TYPE
         STB,R11 *R4
FIOEX1   STW,R12  2,R4
         STW,R4   RESULT             SET RESULT
         B        DXRETURN
ERRFF4   LW,R5    FIODCBNO          SET STREAM NO.                      20-00034
         CI,R12   6*128             CHECK IF EOF                        20-00035
         BE       FIOMPTF            YES-EMPTY FILE                     20-00036
         CI,R12   7*128             CHECK IF RECORD TOO BIG             20-00037
         BE       CALRDFII+1          YES-NOT ID RECORD-OK              20-00038
         B        ERRFF3               NO-REAL ERROR                    20-00039
*
* ERRFTFIO-MONITOR CALL ERROR ON F:TF (FIO18)
*
ERRFTFIO CI,R8    CALFION1+1        CHECK IF OPEN OF 1ST FILE
         BE       ERRFTFN1           YES-TREAT SAME AS NEXT FILE OPEN
         CI,R8    CALFIONX+1        CHECK IF NXTF OPEN
         BE       ERRFTFN1           YES-
         CI,R10   7                  NO-MUST BE READ,CHECK IF
         BE       FIONXTF               RECORD TOO BIG
         LI,R0    '*'               SET '*' FLAG
         B        FIO18B              NO-PROBABLY TIED,LIST IT
ERRFTFN1 CI,R10   2                 CHECK IF LAST FILE
         BE       DXRETURN           YES-QUIT
         LI,R0    '*'               SET '*' FLAG
         B        FIO18B             NO-ASSUME PROTECTED AND LIST IT
*
* FIOEX-EXIT WITH EMPTY VECTOR RESULT
*
FIOEX    LI,R11   4
         BAL,R7   ALOCBLK
         LI,R11   X'0301'           INTEGER VECTOR'
         STH,R11 *R4
         LI,R12   0
         B        FIOEX1
*
* ERRAPL-FILE I/O ERR DETECTED BY APL, NOT BY THE MONITOR.
*
ERRAPL   LW,R10   R12               COPY APL-ERROR (SUBCODE).  FAKE THE
         SLS,R10  17                  I/O ERR CODE WD: CODE=0,
         B        ERRFF3                SUBCODE=APL-ERR, DCB ADDR = 0.
 PAGE
*
*  THE 'CASECODE' & 'CASEID' TABLES ARE IN 1-TO-1 CORRESPONDENCE.
*  CASECODE CONSISTS OF HALFWDS CONTAINING AN I/O ERR OR ABN VALUE,
*        CODE & SUBCODE.  THESE HEX CODES OCCUPY BITS 1-8 & 9-15
*        RESPECTIVELY, WITH BIT 0 OF THE HALFWD ZEROED (NOTE THE GEN'S).
*  CASEID IS A MATCHED SET OF BYTES CONTAINING INTERNAL ERROR I.D.
*        VALUES FOR EACH CODE & SUBCODE OF INTEREST.
*
         BOUND    4
CASECODE GEN,1,8,7  0,X'FF',X'7F'   0 (NEVER USED)
         GEN,1,8,7  0,0,0           1
         GEN,1,8,7  0,0,21          2
         GEN,1,8,7  0,0,1           3
         GEN,1,8,7  0,0,2           4
         GEN,1,8,7  0,0,3           5
         GEN,1,8,7  0,0,4           6
         GEN,1,8,7  0,0,20          7
         GEN,1,8,7  0,X'03',0       8
         GEN,1,8,7  0,X'14',0       9
         GEN,1,8,7  0,X'14',X'01'   10
         GEN,1,8,7  0,X'56',0       11
         GEN,1,8,7  0,X'06',0       12
         GEN,1,8,7  0,X'0D',0       13
         GEN,1,8,7  0,X'42',0       14
         GEN,1,8,7  0,X'43',0       15
         GEN,1,8,7  0,X'57',0       16
         GEN,1,8,7  0,X'75',0       17
         GEN,1,8,7  0,X'75',X'01'   19
         GEN,1,8,7  0,X'75',X'02'   19
         GEN,1,8,7  0,X'75',X'03'   20
         GEN,1,8,7  0,X'75',X'04'   21
         GEN,1,8,7  0,X'75',X'05'   22
         GEN,1,8,7  0,X'75',X'06'   23
         GEN,1,8,7  0,X'20',X'01'   24
         GEN,1,8,7  0,X'20',X'02'   25
         GEN,1,8,7  0,X'20',X'03'   26
         GEN,1,8,7  0,X'20',X'04'   27
         GEN,1,8,7  0,0,5           28
         GEN,1,8,7  0,0,6           29
         GEN,1,8,7  0,0,7           30
         GEN,1,8,7  0,0,8           31
         GEN,1,8,7  0,0,9           32
         GEN,1,8,7  0,0,10          33
         GEN,1,8,7  0,0,11          34
         GEN,1,8,7  0,0,12          35
         GEN,1,8,7  0,0,13          36
         GEN,1,8,7  0,0,14          37
         GEN,1,8,7  0,0,15          38
         GEN,1,8,7  0,0,16          39
         GEN,1,8,7  0,0,17          40
         GEN,1,8,7  0,X'2E',0       41
         GEN,1,8,7  0,X'44',0       42
         GEN,1,8,7  0,X'51',X'00'   43
         GEN,1,8,7  0,X'25',0       44
 SPACE
NCASES   EQU      HA(%)-HA(CASECODE)    # SPEC.CASES OF INTEREST.
 SPACE
* NOTE -- CASEID TABLE MUST MATCH CASECODE TABLE.
 SPACE
         BOUND    4                    I.D. FOR:
CASEID   DATA,1   IDFIOERR          0  FILE I/O ERR
         DATA,1   IDFILNAM          1  FILE NAME ERR
         DATA,1   IDFILNAM          2
         DATA,1   IDFILDAM          3  FILE DAMAGE
         DATA,1   IDNOTAPL          4  NOT APL FILE
         DATA,1   IDFTFULL          5  FILE TBL FULL
         DATA,1   IDFILACC          6  FILE ACCESS ERR
         DATA,1   IDFILACC          7
         DATA,1   IDFILNAM          8  FILE NAME ERR
         DATA,1   IDFILACC          9  FILE ACCESS ERR
         DATA,1   IDFILBSY          10 FILE IN USE
         DATA,1   IDFILSPC          11 FILE SPACE TOO LOW
         DATA,1   IDFILIDX          12 FILE INDEX ERR
         DATA,1   IDFILIDX          13
         DATA,1   IDFILIDX          14
         DATA,1   IDFILIDX          15
         DATA,1   IDFILSPC          16 FILE SPACE TOO LOW
         DATA,1   IDFILDAM          17 FILE DAMAGE
         DATA,1   IDFILDAM          18
         DATA,1   IDFILDAM          19
         DATA,1   IDFILDAM          20
         DATA,1   IDFILDAM          21
         DATA,1   IDFILDAM          22
         DATA,1   IDFILDAM          23
         DATA,1   IDNOPACK          24 PRIVATE PACK UNAVAIL, CALL OPR.
         DATA,1   IDNOPACK          25
         DATA,1   IDNOPACK          26
         DATA,1   IDNOPACK          27
         DATA,1   IDFILTIE          28 FILE TIE ERR
         DATA,1   IDFILTIE          29
         DATA,1   IDFILTIE          30
         DATA,1   IDFILTIE          31
         DATA,1   IDFILTIE          32
         DATA,1   IDFILTIE          33
         DATA,1   IDFILTIE          34
         DATA,1   IDFILTIE          35
         DATA,1   IDFILTIE          36
         DATA,1   IDFILTIE          37
         DATA,1   IDFILTIE          38
         DATA,1   IDFILTIE          39
         DATA,1   IDFILTIE          40
         DATA,1   IDFILTIE          41
         DATA,1   IDFILTIE          42
         DATA,1   IDFILTIE          43
         DATA,1   IDFILTIE          44
 SPACE
         BOUND    4
 PAGE
*
* HANDLERR-ENTERED ON ERROR IF THE 'ERROR-HANDLING' VERSION OF THE
*          FILE I/O INTRINSIC (14 T-BAR 2) IS CURRENTLY APPLICABLE.
*
*       R10 CONTAINS THE ERROR CODE (BITS 0-7) & SUBCODE (BITS 8-14).
*
HANDLERR SLS,R10  -17               GET ONLY CODE & SUBCODE.
         LI,R1    NCASES            = NO.OF ERROR CASES TO CK.
CASECHK  CH,R10   CASECODE,R1       DOES CODE,SUBCODE MATCH A SPEC.CASE
         BNE      NEXTCASE            NO.
         B        CASEHIT             YES.
NEXTCASE BDR,R1   CASECHK           LOOP TILL R1=0 (JUST 'FILE I/O ERR')
CASEHIT  LB,R2    CASEID,R1         GET ERROR I.D. FOR THIS CASE.
         B        ERFILEIO          EXIT TO HANDLE ERR PROCESSING.
         END

