%OWNSTRING(63) RAM NAME = "Character file (ISO)"
%CONSTINTEGER PLACEMENT = 130
%CONSTINTEGER CONAD = 133
%CONSTLONGINTEGER NIL = -1
%CONSTINTEGER STRING DESC = X'58000000'
%CONSTINTEGER LENGTH MASK = X'00FFFFFF'
%CONSTLONGINTEGER ADDRESS MASK = X'00000000FFFFFFFF'
!
%OWNINTEGER DATA LENGTH, FILE LENGTH, ICOMB, LABEL, START ADR, END ADR
%OWNINTEGER LAST BYTE
!
! Descriptors to the entire file (FDESC, FADDR), the current
! record (CDESC, CADDR), the rest of the file (RDESC, RADDR) and
! the caller's buffer (BDESC, BADDR).  These must be declared
! in pairs.
!
%OWNINTEGER FDESC, FADDR, RDESC, RADDR, CDESC, CADDR, BDESC, BADDR
%OWNINTEGER QBEFORE
%OWNLONGINTEGER FILE ROUTE
%OWNLONGINTEGERARRAY A(0:31) = -1(32)
!
%SYSTEMROUTINESPEC ETOI(%INTEGER ADDRESS, LENGTH)
%SYSTEMROUTINESPEC ITOE(%INTEGER ADDRESS, LENGTH)
%SYSTEMROUTINESPEC CHANGE FILE SIZE(%STRING(31) FILE,  %C
      %INTEGER SIZE, %INTEGERNAME FLAG)
!
%EXTERNALINTEGERFNSPEC ECTM PROCESS PP(%INTEGER DR0, DR1,  %C
      %LONGINTEGERARRAYNAME A)
%EXTERNALINTEGERFNSPEC ECTM DESC I(%LONGINTEGER ROUTE, %INTEGER ID)
%EXTERNALSTRINGFNSPEC ECTM DESC S(%LONGINTEGER ROUTE, %INTEGER ID)
%EXTERNALROUTINESPEC ECTM REPORT INT(%STRING(63) MESS, %INTEGER I)
%EXTERNALROUTINESPEC ECTM DUMP PPAIRS(%INTEGER DR0, DR1)
!
%EXTERNALINTEGERFN RAM(%LONGINTEGER ROUTE,  %C
      %INTEGER PP DR0, PP DR1)
!
ECTM DUMP PPAIRS(PP DR0 & LENGTH MASK, PP DR1)
FILE ROUTE = ROUTE
ICOMB = ECTM PROCESS PP(PP DR0, PP DR1, A)
ECTM REPORT INT("Action combination", ICOMB)
LABEL = ECTM DESC I(FILE ROUTE, CONAD)
START ADR = LABEL + INTEGER(LABEL+4)
FILE LENGTH = INTEGER(LABEL)
DATA LENGTH = FILE LENGTH - INTEGER(LABEL+4)
END ADR = START ADR + DATA LENGTH
LAST BYTE = END ADR - 1
*LDTB_   STRING DESC
*LDA_    START ADR
*LDB_    DATA LENGTH
*STD_    FDESC
%IF A(29) = 3 %THEN %START
      RDESC = STRING DESC;  RADDR = END ADR
      CDESC = STRING DESC;  CADDR = END ADR
      QBEFORE = 0
      %FINISH  %C
%ELSE %START
      RDESC = FDESC;  RADDR = FADDR
      %IF RDESC = STRING DESC %THEN %START
         CDESC = STRING DESC;  CADDR = FADDR
         %FINISH  %C
      %ELSE %START
         CADDR = RADDR
         *LD_     RDESC
         *SWNE_   %L=%DR,0,10
         *JCC_    8,<EOF>
         *MODD_   1
EOF:     *STD_    RDESC
         CDESC = STRING DESC ! (RADDR - CADDR - 1)
         %IF RADDR >= END ADR %THEN RDESC = STRING DESC
      %FINISH
      QBEFORE = 1
      %FINISH
%RESULT = 0
%END
!
%INTEGERFN DO IO
!
%INTEGER FLAG
%OWNINTEGER RC
%SWITCH CASE(1:22)
!
-> CASE(ICOMB)
!
CASE(1):
!
! Select just before first
!
      RDESC = FDESC;  RADDR = FADDR
      CDESC = STRING DESC;  CADDR = FADDR
      %UNLESS RDESC = STRING DESC %THEN %START
         *LD_     RDESC
         *SWNE_   %L=%DR,0,10
         *JCC_    8,<EOF1>
         *MODD_   1
EOF1:    *STD_    RDESC
         CDESC = STRING DESC ! (RADDR - CADDR - 1)
         %IF RADDR >= END ADR %THEN RDESC = STRING DESC
         %FINISH
      RC = -9015
      -> RETURN
!
CASE(2):
!
! Select just after last
!
      RDESC = STRING DESC;  RADDR = END ADR
      CDESC = STRING DESC;  CADDR = END ADR
      RC = -9015
      -> RETURN
!
CASE(3):
!
! Select next
!
      %IF RC > 0 %THEN RC = 9034 %AND -> RETURN
      %UNLESS QBEFORE = 1 %THEN %START
         %IF RDESC = STRING DESC %THEN -> CASE(2)
         CADDR = RADDR
         *LD_     RDESC
         *SWNE_   %L=%DR,0,10
         *JCC_    8,<EOF3>
         *MODD_   1
EOF3:    *STD_    RDESC
         CDESC = STRING DESC ! (RADDR - CADDR - 1)
         %IF RADDR >= END ADR %THEN RDESC = STRING DESC
         %FINISH
      RC = 0
      -> RETURN
!
CASE(4):
!
! Select previous
!
      %IF RC > 0 %THEN RC = 9034 %AND -> RETURN
      RADDR = CADDR
      %IF RDESC = STRING DESC %THEN RDESC = CDESC  %C
      %ELSE RDESC = STRING DESC !  %C
            (CDESC & LENGTH MASK + RDESC & LENGTH MASK + 1)
      CDESC = STRING DESC
      CADDR = RADDR - 1
      %CYCLE
         CADDR = CADDR - 1
         %IF CADDR < START ADR %THEN -> CASE(1)
         %IF BYTEINTEGER(CADDR) = NL %THEN %EXIT
         CDESC = CDESC + 1
         %REPEAT
      CADDR = CADDR + 1
      RC = 0
      -> RETURN
!
CASE(5):
!
! Select just before current
!
      %IF RC > 0 %THEN RC = 9034 %AND -> RETURN
      RC = -9015
      -> RETURN
!
CASE(6):
!
! Select by key
!
      RC = 9006
      -> RETURN
!
CASE(7):
!
! Select next and read
!
      %IF RC > 0 %THEN RC = 9034 %AND -> RETURN
      %UNLESS QBEFORE = 1 %THEN %START
         %IF RDESC = STRING DESC %THEN RC = 9034 %AND -> RETURN
         CADDR = RADDR
         *LD_     RDESC
         *SWNE_   %L=%DR,0,10
         *JCC_    8,<EOF7>
         *MODD_   1
EOF7:    *STD_    RDESC
         CDESC = STRING DESC ! (RADDR - CADDR - 1)
         %IF RADDR >= END ADR %THEN RDESC = STRING DESC
         %FINISH
      BDESC = INTEGER(ADDR(A(7)));  BADDR = INTEGER(ADDR(A(7))+4)
      %UNLESS A(9) = NIL %THEN BDESC =  %C
         STRING DESC ! INTEGER(A(9)&ADDRESS MASK)
      *LSD_    CDESC
      *LD_     BDESC
      *MV_     %L=%DR,0,0
      ITOE(BADDR, BDESC & LENGTH MASK)
      %UNLESS A(9) = NIL %THEN  %C
         INTEGER(A(9)&ADDRESS MASK) = CDESC & LENGTH MASK
      RC = 0
      -> RETURN
!
CASE(8):
!
! Select previous and read
!
      %IF RC > 0 %THEN RC = 9034 %AND -> RETURN
      RADDR = CADDR
      %IF RDESC = STRING DESC %THEN RDESC = CDESC  %C
      %ELSE RDESC = STRING DESC !  %C
            (CDESC & LENGTH MASK + RDESC & LENGTH MASK + 1)
      CDESC = STRING DESC
      CADDR = RADDR - 1
      %CYCLE
         %IF CADDR <= START ADR %THEN %EXIT
         CADDR = CADDR - 1
         %IF BYTEINTEGER(CADDR) = NL %THEN %EXIT
         CDESC = CDESC + 1
         %REPEAT
      CADDR = CADDR + 1
      BDESC = INTEGER(ADDR(A(7)));  BADDR = INTEGER(ADDR(A(7))+4)
      %UNLESS A(9) = NIL %THEN BDESC =  %C
         STRING DESC ! INTEGER(A(9)&ADDRESS MASK)
      *LSD_    CDESC
      *LD_     BDESC
      *MV_     %L=%DR,0,0
      ITOE(BADDR, BDESC & LENGTH MASK)
      %UNLESS A(9) = NIL %THEN  %C
         INTEGER(A(9)&ADDRESS MASK) = CDESC & LENGTH MASK
      RC = 0
      -> RETURN
!
CASE(9):
!
! Select by key and read
!
      RC = 9006
      -> RETURN
!
CASE(10):
!
! New write (at end of file)
!
      %UNLESS RDESC = STRING DESC %THEN RC = 9043 %AND -> RETURN
      BDESC = INTEGER(ADDR(A(7)));  BADDR = INTEGER(ADDR(A(7))+4)
      %UNLESS A(9) = NIL %THEN BDESC =  %C
         STRING DESC ! INTEGER(A(9)&ADDRESS MASK)
      %IF END ADR + BDESC & LENGTH MASK + 1 > LAST BYTE %THEN %START
         FILE LENGTH = FILE LENGTH + 4096
         CHANGE FILE SIZE(ECTM DESC S(FILE ROUTE, PLACEMENT),  %C
            FILE LENGTH, FLAG)
         %IF FLAG > 0 %THEN RC = 9040 %AND -> RETURN
         LAST BYTE = LAST BYTE + 4096
         %FINISH
      BYTEINTEGER(END ADR) = NL
      END ADR = END ADR + 1
      *LDTB_   BDESC
      *LDA_    END ADR
      *LSD_    BDESC
      *MV_     %L=%DR,0,0
      ETOI(END ADR, BDESC & LENGTH MASK)
      END ADR = END ADR + BDESC & LENGTH MASK
      DATA LENGTH = DATA LENGTH + BDESC & LENGTH MASK + 1
      FDESC = STRING DESC ! DATA LENGTH
      INTEGER(LABEL) = INTEGER(LABEL+4) + DATA LENGTH
      RC = 0
      -> RETURN
!
CASE(11):
!
! Select by key and new write
!
      RC = 9006
      -> RETURN
!
CASE(12):
!
! Overwrite current
!
      RC = 9006
      -> RETURN
!
CASE(13):
!
! Select by key and overwrite
!
      RC = 9006
      -> RETURN
!
CASE(14):
!
! Destroy current
!
      RC = 9006
      -> RETURN
!
CASE(15):
!
! Select by key and destroy
!
      RC = 9006
      -> RETURN
!
CASE(16):
!
! Extended destroy from current
!
      %IF RC > 0 %THEN RC = 9034 %AND -> RETURN
      END ADR = CADDR
      DATA LENGTH = END ADR - START ADR
      FDESC = STRING DESC ! DATA LENGTH
      INTEGER(LABEL) = INTEGER(LABEL+4) + DATA LENGTH
      RC = 0
      -> RETURN
!
CASE(17):; CASE(18):; CASE(19):; CASE(20):; CASE(21):
!
! Various obscure combinations
!
      RC = 9006
      -> RETURN
!
CASE(22):
!
! Read key
!
      RC = 9006
      -> RETURN
!
RETURN:
!
QBEFORE = 0
%IF ICOMB = 1 %OR ICOMB = 5 %THEN QBEFORE = 1
ECTM REPORT INT("ACCESS result code =", RC)
%RESULT = RC
%END
!
%EXTERNALINTEGERFN ACCESS1(%INTEGER DR0, DR1)
!
ECTM DUMP PPAIRS(DR0 & LENGTH MASK, DR1)
ICOMB = ECTM PROCESS PP(DR0, DR1, A)
ECTM REPORT INT("Action combination", ICOMB)
%IF ICOMB = 25 %THEN %RESULT = 0;  ! NO-OP
%UNLESS 0 < ICOMB < 23 %THEN %RESULT = 9006
%RESULT = DO IO
%END
!
%EXTERNALINTEGERFN ACCESS2
!
%IF ICOMB = 25 %THEN %RESULT = 0
%UNLESS 0 < ICOMB < 23 %THEN %RESULT = 9006
%RESULT = DO IO
%END
!
%ENDOFFILE