!
!***********************************************************************
!
!***********************************************************************
!*
!* DIRECTOR ROUTINES DCONNECT & DDISCONNECT REPLACED BY SUBSYSTEM
!* ROUTINES CONNECT & DISCONNECT 
!* 14/11/78  --  L.A.B.
!*
!**********************************************************************
!
!
!*
!*                EMAS 2900 INTERFACE FOR KENT BASIC
!*
!**********************************************************************
!
!
!**********************************************************************
!*
!*                            CONSTANTS
!*
!**********************************************************************
!
%CONSTSTRING(4) VERSION = "1.5"
%CONSTINTEGER SEG SHIFT = 18
%CONSTINTEGER NO = 0,         %C
              YES = 1,        %C
              FALSE = 0,      %C
              TRUE = 1
%CONSTINTEGER CODE DESC = X'E1000000'
%CONSTINTEGER NIL = 0
%CONSTINTEGER NOT IMPLEMENTED = X'8000'
!?1; %CONSTINTEGER JS VAR LIMIT = 7    ;! SET TO 7 FOR TEST PURPOSES %C
%CONSTINTEGER JS VAR LIMIT = 30
%CONSTINTEGER FILE LIMIT = 20
%CONSTINTEGER FOREGROUND = 1
%CONSTINTEGER BACKGROUND = 2
%CONSTSTRING(8) SOURCE = E"SOURCE"
%CONSTBYTEINTEGERARRAY CONTINGENCY MAP (0:79) =  %C
    1,2,3,4,5,6,7,8,9,10,11,12,13,14,
    0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,33,
    0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
    0,0,0,0,0,0,0,0,0,0,0,0,0,64,51,66,
    0,0,0,0,0,0,0,0,0,0,0,0,0
%CONSTINTEGERARRAY VALID ACTION (0:5)     =     %C
    0,X'00000003',X'000000A1',X'00000081',X'00000020',X'00008000'
%CONSTINTEGERARRAY VALID ACTION ID (0:5)     =    %C
    0,    1      ,     0     ,     2     ,     3     ,     4
%CONSTINTEGER VA COUNT = 5
%CONSTINTEGERARRAY DML DECODE(0:14,0:1) =      %C
     0, 2, 0, 0, 0, 2, 2, 0, 0, 2, 1, 1, 1, 0, 0,
     0,11, 0, 0, 0, 0, 2, 0, 0, 4, 6, 7, 9, 0, 0
%CONSTBYTEINTEGERARRAY RAF SWITCH (0:4,0:4)  =       %C
      0,0,0,0,0,
      0,1,3,6,7,
      0,1,3,6,7,
      0,2,5,8,7,
      0,1,0,0,7
!  THE DIMENSIONS FOR RAF SWITCH CORRESPOND TO VALID ACTION ID
!  AND DATA FORMAT VALUES
%CONSTINTEGERARRAY FCR DML INFO DEFAULTS (0:12)  =   %C
    0,0,0,0,0,0,2,1,-1,-1,-1,0,0
%CONSTSTRING(1)%ARRAY HEX TAB(0:15)="0","1","2","3","4","5","6","7", %C
              "8","9","A","B","C","D","E","F"
!
!
!
!**********************************************************************
!*
!*                            GLOBALS
!*
!**********************************************************************
!
%RECORDFORMAT JS VAR RF (%STRING(8) NAME,%STRING(80) VALUE,    %C
                         %INTEGER MAX LEN)
!?2; %OWNINTEGER TRACE COUNT
%OWNRECORDARRAY JS VAR (0:29) (JS VAR RF)
%RECORDFORMAT FHDR FORMAT        %C
       (%INTEGER DATA END,DATA START,FILE SIZE,FILE TYPE,   %C
                CHECK SUM,DANDT,FORMAT,RECORD COUNT)
%RECORDFORMAT FCR FORMAT             %C
       (%INTEGER EP,PC,LNB,      %C
                 ROUTE,RAF SWITCH,CON ADDR,DATA FORMAT,   %C
      %RECORDNAME FHDR,             %C
        %INTEGER DATA LIMIT,RMIN,RMAX,CUR PTR,CUR LEN,    %C
                 BUFF DR0,BUFF DR1,XFER DR0,XFER DR1,KEY DR0,KEY DR1, %C
                 POSITION,DISPLCMNT,ALL ACTIONS,NEW ACTIONS,       %C
                 ACC ACTIONS,CURR DR0,CURR DR1,           %C
     %STRING(32) NAME,%STRING(6) OWNER)
%RECORDSPEC FCR FORMAT_FHDR (FHDR FORMAT)
%OWNRECORDARRAY FCT (0:20)   (FCR FORMAT);!  FILE CONTROL TABLE BEING A
                                       !  TABLE OF FILE CONTROL RECORDS
%RECORDFORMAT CONNECTFORM(%INTEGER CONAD,FILETYPR,DATASTART,DATAEND)
%OWNINTEGERARRAYFORMAT FDI FORMAT (0:12)  ;! FCR DML INFORMATION
%OWNINTEGER ENTRY LNB
%OWNINTEGER RAM PC
%OWNINTEGER RAM LNB
%OWNINTEGER EXEC MODE
%OWNINTEGER JS VAR COUNT
%OWNLONGREAL INITIAL CPU TIME
!?2; %OWNINTEGER TRACE STREAM
%OWNINTEGER LOG STREAM
!?3; %OWNINTEGER DIAG STREAM
%OWNINTEGER IT PROMPT FLAG
!
%OWNINTEGER INT DATA FLAG
%OWNINTEGERARRAY INT DATA (0:17)
%OWNLONGINTEGERARRAY CONT RTN DESC (0:63)
%OWNSTRING(6) USER NAME
!
!**********************************************************************
!*
!*                      EXTERNAL  REFERENCES - SUBSYSTEM
!*
!**********************************************************************
!
!?1; %EXTERNALINTEGERFNSPEC RETURN CODE
%EXTERNALINTEGERFNSPEC OUT STREAM
%EXTERNALROUTINESPEC DEFINE (%STRING(255) PARMS)
%EXTERNALROUTINESPEC PROMPT(%STRING(15) NEW PROMPT)
%EXTERNALLONGREALFNSPEC   CPU TIME
%EXTERNALSTRINGFNSPEC DATE
%EXTERNALSTRINGFNSPEC TIME
%SYSTEMROUTINESPEC    DESTROY   (%STRING(31) FILE NAME,              %C
                                %INTEGERNAME FLAG)
%SYSTEMSTRINGFNSPEC   CONFILE   (%INTEGER ADDRESS)
%SYSTEMROUTINESPEC CONNECT(%STRING(31) FILENAME,                      %C
                           %INTEGER MODE,HOLE,PROTECT,                %C
                           %RECORDNAME R, %INTEGERNAME FLAG)
%SYSTEMROUTINESPEC    CHANGE ACCESS (%STRING(31) FILE NAME,          %C
                                %INTEGER NEW ACCESS,        %C
                               %INTEGERNAME FLAG)
%SYSTEMROUTINESPEC    CHANGE FILE SIZE (%STRING(31) FILENAME,     %C
                                %INTEGER NEW SIZE,                   %C
                                %INTEGERNAME FLAG)
%SYSTEMROUTINESPEC DISCONNECT(%STRING(31) FILENAME, %INTEGERNAME FLAG)
%SYSTEMROUTINESPEC    OUTFILE   (%STRING(31) FILE NAME,              %C
                                %INTEGER SIZE,GAP,PROTECTION,       %C
                                %INTEGERNAME CONNECTED ADDR,FLAG)
%SYSTEMSTRINGFNSPEC   NEXT TEMP
%SYSTEMROUTINESPEC    MOVE      (%INTEGER LENGTH,FROM ADDR,TO ADDR)
%SYSTEMROUTINESPEC    ITOE      (%INTEGER ADDRESS,LENGTH)
%SYSTEMROUTINESPEC    ETOI      (%INTEGER ADDRESS,LENGTH)
%SYSTEMROUTINESPEC    FILL      (%INTEGER LENGTH,ADDRESS,FILLER)
%EXTERNALROUTINESPEC  SET RETURN CODE (%INTEGER RES)
%EXTERNALINTEGERFNSPEC UINFI (%INTEGER ENTRY)
%EXTERNALSTRINGFNSPEC UINFS (%INTEGER ENTRY)
!
!**********************************************************************
!*
!*                  EXTERNAL  REFERENCES - DIRECTOR
!*
!**********************************************************************
!
%EXTERNALINTEGERFNSPEC DCREATE (%STRING(6) USER,     %C
                           %STRING(15) FILE,          %C
                   %INTEGER FSYS,FILE SIZE,X)
%EXTERNALROUTINESPEC DRESUME (%INTEGER LNB,PC,ADDRESS)
%EXTERNALINTEGERFNSPEC PRIME CONTINGENCY (%ROUTINE ONTRAP)
%EXTERNALROUTINESPEC DRESET CONTINGENCY
%EXTERNALINTEGERFNSPEC READ ID (%INTEGER ADDRESS)
%EXTERNALINTEGERFNSPEC DISC ID
!%EXTERNALINTEGERFNSPEC DCONNECT (%STRING(6) USER,  %C
!      %STRING(15) FILE,%INTEGER FSYS,MODE,APF,   %C
!        %INTEGERNAME SEG,GAP)
!%EXTERNALINTEGERFNSPEC DDISCONNECT (%STRING(6) USER,   %C
!                                  %STRING(15) FILE,%INTEGER FSYS,DSTRY)
! DDISCONNECT PARAMETER DSTRY-- 0 FILE NOT DESTROYED -- 1 FILE DESTROYED
!
!**********************************************************************
!*
!*                   MISCELLANEOUS  DECLARATIONS
!*
!**********************************************************************
%EXTERNALROUTINESPEC KBASC(%INTEGER DR0,DR1)
!?3; %EXTERNALROUTINESPEC XDUMP (%STRING(120) COMMENT,%INTEGER A,L)
!%EXTERNALINTEGERFNSPEC OMF LOAD (%STRING(63) FILE NAME)
!%EXTERNALROUTINESPEC FIND OMF ENTRY(%STRING(32) NAME,   %C
!                         %INTEGERNAME DR0,DR1)
%INTEGERFNSPEC ASSIGN FILE (%INTEGER ROUTE DR0,ROUTE DR1,   %C
                  NIL0,NAME DR0,NAME DR1,GENERATION,NIL1,     %C
                    DESC DR0,DESC DR1)
%INTEGERFNSPEC LOG MESSAGE (%INTEGER NIL0,NIL1,DR0,DR1)
%INTEGERFNSPEC DE ASSIGN FILE (%INTEGER ROUTE,ST DR0,ST DR1)
%ROUTINESPEC ABANDON(%INTEGER I,%STRING(120) COMMENT)
!
!
!**********************************************************************
!*
!*                        SERVICE  ROUTINES
!*
!**********************************************************************
!
%INTEGERFN I2(%INTEGER AD)
!AD POINTS TO THE FIRST OF A PAIR OF DECIMAL CHARACTERS. THE RESULT
!IS THE NUMERIC VALUE OF THE CHAS
   %RESULT = 10*(BYTEINTEGER(AD)&X'F')+(BYTEINTEGER(AD+1)&X'F')
%END;                                   !OF I2

%INTEGERFN PACKDATE(%STRING (8) DATE)
%INTEGER AD
   AD = ADDR(DATE)
   %RESULT = ((I2(AD+7)-70)<<26)!(I2(AD+4)<<22)!(I2(AD+1)<<17)
%END;                                   !OF PACKDATE

%INTEGERFN PACKDATEANDTIME(%STRING (8) DATE, TIME)
%INTEGER AT
   AT = ADDR(TIME)
   %RESULT = PACKDATE(DATE)!(I2(AT+1)<<12)!(I2(AT+4)<<6)!(I2( %C
      AT+7))
%END;                                   !OF PACKDATEANDTIME
!
%INTEGERFN FILE TIME STAMP
%RESULT = PACK DATE AND TIME(DATE,TIME)
%END        ;!   OF FILE TIME STAMP
!
%ROUTINE DECODE PPLIST (%INTEGER PP DR0,PP DR1,         %C
                        %INTEGERARRAYNAME DECODE,ENCODE)
!
!  THIS ROUTINE DECODES A LIST OF PARAMETER PAIRS ( DEFINED BY
!  THE DESCRIPTOR PP DR0,PP DR1) INTO AN ARRAY, ENCODE, BY A MAPPING
!  DEFINED BY THE ARRAY DECODE.  NOTE THAT THE DESCRIPTOR
!  IS A WORD TYPE DESCRIPTOR, IE SCALED TO 4 BYTES.
!
!  THE LIST OF PARAMETER PAIRS CONSISTS OF CONSECUTIVE TRIPLETS
!  OF WORDS, EACH TRIPLET CONSTITUTING A PARAMETER PAIR.
!  THE FIRST WORD IS ITS IDENTIFIER AND THE OTHER
!  TWO BEING THE CORRESPONDING VALUE.  THE LAST WORD NEED 
!  NOT NECESSARILY BE USED.
!  THE 'ENCODE' ARRAY IS A SINGLE DIMENSION ARRAY (WHOSE LOWER
!  BOUND IS ZERO) INTO WHICH THE VALUES FROM THE PARM PAIR
!  LIST ARE COPIED
!  THE 'DECODE' ARRAY IS TWO DIMENSIONAL (0:N,0:1) WHERE N IS
!  THE HIGHEST VALUE OF PARM PAIR IDENTIFIER EXPECTED.  FOR EACH
!  IDENTIFIER VALUE THERE ARE TWO ELEMENTS IN THIS ARRAY:
!
!    DECODE(N,0) - THE NUMBER OF WORDS TO BE COPIED FROM THE
!                  PARM PAIR WITH IDENTIFIER N.  IF ZERO, THIS
!                  PARM PAIR NOT OF INTEREST.
!    DECODE(N,1) - AN INDEX INTO THE 'ENCODE' ARRAY POINTING TO
!                  ELEMENT(S) TO RECEIVE THE PARM PAIR VALUE.
!
%INTEGER I,ID
%SWITCH S (0:2)
!
%CYCLE I =PPDR1,12,(PPDR1+(PP DR0&X'00FFFFFF')*4)-12
    ID = INTEGER(I)
    -> S(DECODE(ID,0))
S(2):  ENCODE(DECODE(ID,1)+1) = INTEGER (I+8)
S(1):  ENCODE(DECODE(ID,1)) = INTEGER (I+4)
S(0):
%REPEAT
%RETURN
%END      ;!  OF DECODE PP LIST
!
%INTEGERFN CREATE JS VAR (%STRING(8) NAME,%STRING(80) VALUE,   %C
                          %INTEGER MAX LEN)
JS VAR COUNT = JS VAR COUNT + 1
%IF JS VAR COUNT = JS VAR LIMIT %THEN %RESULT = X'B01'
JS VAR(JS VAR COUNT)_NAME = NAME
JS VAR(JS VAR COUNT)_VALUE = VALUE
%IF MAX LEN < 0 %THEN JS VAR(JS VAR COUNT)_MAX LEN = LENGTH(VALUE) %C
                %ELSE JS VAR(JS VAR COUNT)_MAX LEN = MAX LEN
%RESULT = -2
%END     ;!  OF CREATE JS VAR
!
!?1; %STRING(255)%FN ISOF(%STRING(255) ESTRING)
!?1; ETOI(ADDR(ESTRING)+1,LENGTH(ESTRING))
!?1; %RESULT = ESTRING
!?1; %END      ;!  OF ISOF
!
%STRING(8)%FN BIN STRING(%INTEGER M,N)
%STRING(8) WORK
LENGTH(WORK) = 8
MOVE(4,ADDR(M),ADDR(WORK)+1)
MOVE(4,ADDR(N),ADDR(WORK)+5)
%RESULT = WORK
%END      ;!  OF BIN STRING
!
%SYSTEMSTRING(15)%FN SFROMI (%INTEGER X)
%INTEGER REM,NUMB,NF
%STRING(15) ANS
ANS = ''
%IF X < 0 %THEN %START
    NF = YES
    X = X*(-1)
%FINISH %ELSE NF = NO
%CYCLE
NUMB = X
X = X//10
REM = NUMB - X*10
ANS = TOSTRING(REM+'0').ANS
%EXIT %IF X = 0
%REPEAT
%IF NF = YES %THEN ANS = "-".ANS
%RESULT = ANS
%END     ;!  OF SFROMI
!
%INTEGERFN IFROMS (%STRING(20) NUMBER)
%INTEGER I,J,K,L
K=ADDR(NUMBER)
J=0
%CYCLE I=1,1,20
    L = BYTEINTEGER(K+I)
    %IF L<'0' %OR L>'9' %THEN %RESULT = J
    J=(J*10)+L-'0'
%REPEAT
%END     ;!  OF IFROMS
!
%ROUTINE LOG (%STRING(120) MSG)
%INTEGER CURRENT STREAM
CURRENT STREAM = OUTSTREAM
SELECT OUTPUT (LOG STREAM)
SPACES(9)
PRINTSTRING(MSG) ; NEWLINE
SELECT OUTPUT(CURRENT STREAM)
%RETURN
%END     ;!  OF LOG
!
!?3; %ROUTINE LOG DIAG (%STRING(120) MSG)
!?3; %INTEGER CURRENT STREAM
!?3; CURRENT STREAM = OUT STREAM
!?3; SELECT OUTPUT (DIAG STREAM)
!?3; NEWLINE
!?3; PRINTSTRING('KBB DIAG:'.MSG)
!?3; NEWLINE
!?3; SELECT OUTPUT(CURRENT STREAM)
!?3; %RETURN
!?3; %END      ;!   OF LOG DIAG
!
!?1; %STRING(8)%FN HEXOF (%INTEGER X)
!?1; %STRING(8) ANS
!?1; %INTEGER I
!?1; ANS = ''
!?1; %CYCLE I=0,4,28
!?1;     ANS = HEXTAB((X>>I)&X'0000000F').ANS
!?1; %REPEAT
!?1; %RESULT = ANS
!?1; %END     ;!  OF HEXOF
!
!
%LONGINTEGERFN LONG INT (%LONGREAL X)
*LSQ  _X
*RAD  _R'40800000000000000000000000000000'
*RSC  _47
*RSC  _-47
*FIX  _%B
*MYB  _4
*CPB  _-64
*JCC  _10,<LI>
*LB   _-64
LI:
*ISH  _%B
*EXIT _-64
%END       ;!  OF LONG INT
!
%STRING(255)%FN STRING FROM (%INTEGER LENGTH,ADDRESS)
%STRING(255) S
*LB   _LENGTH
*LDA  _ADDRESS
*LDTB _X'18000000'
*LDB  _%B
*CYD  _0
*LD   _S
*MVL  _%L=1
*MV   _%L=%DR,0,129
%RESULT = S
%END       ;!  OF STRING FROM
!
%ROUTINE FIND JS VAR (%STRING(8) NAME,%INTEGERNAME POINTER)
%INTEGER I
%CYCLE I=0,1,JS VAR COUNT
    %IF NAME = JS VAR(I)_NAME %THEN POINTER = I %AND %RETURN
%REPEAT
POINTER = -1
%RETURN
%END     ;!  OF FIND JS VAR
!
!?1; %STRING(80)%FN NEXT LINE
!?1; %INTEGER I
!?1; %BYTEINTEGERARRAY LINE (0:80)
!?1; %WHILE NEXT SYMBOL = NL %THEN SKIP SYMBOL
!?1; %CYCLE I=1,1,80
!?1;     READ SYMBOL(LINE(I))
!?1;     %IF LINE(I) = NL %THEN %EXIT
!?1; %REPEAT
!?1; LINE(0) = I-1
!?1; %RESULT = STRING(ADDR(LINE(0)))
!?1; %END     ;!  OF NEXT LINE
!
%STRING(255)%FN DE SPACED (%STRING(255) S)
%STRING(255) B,A
%WHILE S -> B.(" ").A %THEN S = B.A
%RESULT = S
%END    ;!  OF DE SPACED
!
!?1; %ROUTINE ASK FOR STREAM(%INTEGERNAME STREAM,%STRING(15) P)
!?1; %INTEGER X,RC
!?1; %STRING(80) REPLY
!?1; !
!?1; RC = 1
!?1; PROMPT(P)
!?1; %WHILE RC > 0 %THEN %CYCLE
!?1;     REPLY = DESPACED(NEXT LINE)
!?1;     %IF REPLY = "" %THEN %RETURN
!?1;     X = IFROMS(REPLY)
!?1;     %IF X>0 %AND X<80 %THEN STREAM = X %AND %RETURN
!?1;     DEFINE(SFROMI(STREAM).",".REPLY)
!?1;     X = RETURN CODE
!?1;     %IF X = 0 %THEN %RETURN
!?1;     PRINTSTRING("REPLY NOT VALID")
!?1;     NEWLINE
!?1; %REPEAT
!?1; %RETURN
!?1; %END      ;!  OF ASK FOR STREAM
!
!?2; %ROUTINE TRACE (%STRING(40) RTN,MSG,%INTEGER LNB,N,PPO)
!?2; %STRING (132) WORKA,WORKB
!?2; %INTEGER PPDESC ADDR,PPADDR,PPLEN,CURRENT STREAM
!?2; TRACE COUNT = TRACE COUNT + 1
!?2; WORKA="TRACE CALL >>".SFROMI(TRACE COUNT)."<<  ".RTN."  ".MSG
!?2; CURRENT STREAM = OUT STREAM
!?2; SELECT OUTPUT (TRACE STREAM)
!?2; NEWLINES(2)
!?2; PRINTSTRING(WORKA)
!?2; NEWLINE
!?2; WORKB="STACK DUMP STARTING FROM LNB, ".SFROMI(N)." WORDS OF PARMS"
!?2; XDUMP(WORKB,LNB,(10+N)*4)
!?2; %IF PPO > -1 %THEN %START
!?2;    NEWLINE
!?2;    PPDESC ADDR = LNB + 20 +(PPO*4)
!?2;    PPLEN = INTEGER(PPDESC ADDR)&X'0000FFFF'
!?2;    PPADDR = INTEGER(PPDESC ADDR+4)
!?2;    %UNLESS PPADDR = NIL %OR PPLEN = NIL %THEN %START
!?2;        WORKB="PARAMETER PAIR LIST DUMP FOLLOWS ,"
!?2;        WORKB=WORKB.SFROMI(PPLEN)." WORDS IN LIST"
!?2;        XDUMP(WORKB,PPADDR,PPLEN*4)
!?2;    %FINISH %ELSE %START
!?2;        PRINTSTRING("PARAMETER PAIR LIST IS NIL") ; NEWLINE
!?2;    %FINISH
!?2; %FINISH
!?2; NEWLINE
!?2; SELECT OUTPUT(CURRENT STREAM)
!?2; !?3; LOG DIAG(WORKA)
!?2; %RETURN
!?2; %END       ;!  OF TRACE
!
!?2; %ROUTINE RESULT TRACE (%STRING(32) RTN NAME,%INTEGER RC)
!?2; %STRING(132) S
!?2; %INTEGER CURRENT STREAM
!?2; S = "                      RESULT = ".SFROMI(RC)
!?2; S = S." FROM ".RTN NAME
!?2; CURRENT STREAM=OUT STREAM
!?2; SELECT OUTPUT(TRACE STREAM)
!?2; PRINTSTRING(S)
!?2; SELECT OUTPUT(CURRENT STREAM)
!?2; !?3; LOG DIAG(S)
!?2; %RETURN
!?2; %END         ;!  OF RESULT TRACE
!
!?3; %ROUTINE PRINT FCT
!?3; %INTEGER I
!?3; %RECORDNAME FCR (FCR FORMAT)
!?3; !
!?3; NEWLINE
!?3; PRINTSTRING("FILE CONTROL TABLE, FILE LIMIT = ".SFROMI(FILE LIMIT))
!?3; NEWLINE
!?3; PRINTSTRING("        FILE NAME") ; SPACES(22)
!?3; PRINTSTRING(" ROUTE RAFS FORMAT    ALL ACTS")
!?3; NEWLINE
!?3; %CYCLE I=0,1,FILE LIMIT
!?3;     FCR == FCT(I)
!?3;     %IF FCR_PC=0 %THEN -> REP
!?3;     NEWLINE
!?3;     WRITE(I,2)  ;  SPACES(4)
!?3;     PRINTSTRING(FCR_OWNER.".".FCR_NAME)
!?3;     SPACES(31-LENGTH(FCR_OWNER)-LENGTH(FCR_NAME))
!?3;     WRITE(FCR_ROUTE,3)
!?3;     WRITE(FCR_RAF SWITCH,5)
!?3;     WRITE(FCR_DATA FORMAT,5)
!?3;     PRINTSTRING("   ".HEXOF(FCR_ALL ACTIONS))
!?3; REP:
!?3; %REPEAT
!?3; NEWLINE
!?3; %RETURN
!?3; %END      ;!  OF PRINT FCT
!?3; !
!?3; %ROUTINE PRINT JSV TABLE
!?3; %INTEGER I,J,K
!?3; %RECORDNAME VAR (JS VAR RF)
!?3; !
!?3; NEWLINES(2)
!?3; PRINTSTRING("TABLE OF JOB SPACE VARIABLES, JS VAR LIMIT =")
!?3; WRITE(JS VAR LIMIT,0)
!?3; NEWLINE
!?3; %CYCLE I = 0,1,JS VAR COUNT
!?3;     VAR == JS VAR(I)
!?3;     NEWLINE
!?3;     WRITE(I,3) ; SPACES(4)
!?3;     PRINTSTRING(ISOF(VAR_NAME))
!?3;     SPACES(8-LENGTH(VAR_NAME))
!?3;     WRITE(VAR_MAX LEN,6)
!?3;     WRITE(LENGTH(VAR_VALUE),4)
!?3;     PRINTSTRING("    ".ISOF(VAR_VALUE))
!?3;     %IF CHARNO(VAR_VALUE,1) < X'C1' %THEN %START
!?3;         SPACES(4)
!?3;         MOVE(4,ADDR(VAR_VALUE)+1,ADDR(J))
!?3;         MOVE(4,ADDR(VAR_VALUE)+5,ADDR(K))
!?3;         PRINTSTRING("X(".HEXOF(J).HEXOF(K).")")
!?3;     %FINISH
!?3; %REPEAT
!?3; NEWLINES(2)
!?3; %RETURN
!?3; %END     ;!  OF PRINT JSV TABLE
!
!**********************************************************************
!
!*                   RECORD  ACCESS  SERVICE  ROUTINES
!*
!**********************************************************************
!
%ROUTINE DERIVE RAF SWITCH (%INTEGER ACTION,DATA FORMAT,    %C
                           %INTEGERNAME VALUE)
%INTEGER I,J
%CYCLE I = 1,1, VA COUNT
    %IF ACTION = VALID ACTION(I) %THEN J = I %AND -> AF
%REPEAT
VALUE = -1 %AND %RETURN    ;!  NOT A VALID ACTION
AF:
VALUE = RAF SWITCH(VALID ACTION ID(J),DATA FORMAT)
%RETURN
%END        ;!  OF DERIVE RAF SWITCH
!
%INTEGERFN DERIVE CUR LEN (%RECORDNAME FCR)
!
!  THIS ROUTINE DERIVES THE LENGTH OF THE RECORD POINTED TO BY
!  CUR PTR.  WHEN THE LENGTH OF THE RECORD HAS BEEN
!  WRITTEN INTO FCR_CUR LEN, THE RECORD, IN THE TERMS OF
!  THIS INTERFACE, IS SAID TO BE SELECTED.
!
%RECORDSPEC FCR (FCR FORMAT)
%INTEGER I,J
%SWITCH DFP(0:4)
%INTEGER RC
!
RC = 0
FCR_CUR LEN = 0
-> DFP(FCR_DATA FORMAT)
DFP(1):  !  FIXED FORMAT RECORDS IN FILE
FCR_CUR LEN = FCR_RMIN
-> OUT
DFP(2):   !  VARIABLE LENGTH RECORDS, TWO BYTE LENGTH FIELD
MOVE(2,FCR_CON ADDR + FCR_CUR PTR,ADDR(FCR_CUR LEN)+2)
-> OUT
DFP(3):     !NOT RELEVANT, INTERACTIVE TERMINAL I/0
            !HANDLED INDEPENTANTLY OF THIS ROUTINE
%RESULT = X'8000'
DFP(4):    !  TEXT OR CHARACTER FILE,  MUST FIND NEXT NEWLINE
%CYCLE I=FCR_CON ADDR + FCR_CUR PTR,1,FCR_CON ADDR + FCR_DATA LIMIT-1
    %IF BYTEINTEGER(I) = X'0A' %THEN J = I %AND -> NF
%REPEAT
J = FCR_CON ADDR + FCR_DATA LIMIT - 1
NF:  FCR_CUR LEN = J - FCR_CON ADDR - FCR_CUR PTR + 1
-> OUT
OUT:  
%IF FCR_CUR LEN > FCR_RMAX %THEN RC = X'0541'
%RESULT = RC
%END      ;!  OF DERIVE CUR LEN
!
%INTEGERFN SERIAL SELECT (%RECORDNAME FCR)
!
!  ON ENTRY CUR PTR AND CUR LEN ARE SET TO POINT AT THE CURRENTLY
!  'SELECTED' RECORD AND ITS LENGTH.  FOR SELECTING THE FIRST 
!  RECORD IN A FILE, CUR PTR IS SET TO POINT
! TO THE START OF DATA (OR FIRST RECORD)
!  AND CUR LEN IS SET TO ZERO.  THE OFFSET OF THE NEXT RECORD IS
! CALCULATED (FROM CUR PTR AND CUR LEN)
! AND ITS LENGTH DERIVED TO MAKE IT THE CURRENTLY
!  SELECTED RECORD.
!
%RECORDSPEC FCR (FCR FORMAT)
FCR_CUR PTR = FCR_CUR PTR + FCR_CUR LEN
%IF FCR_CUR PTR < FCR_DATA LIMIT %THEN %RESULT = DERIVE CUR LEN %C
        (FCR)
!   READING OFF END OF DATA IF REACHED HERE
!
FCR_CUR PTR = FCR_DATA LIMIT
FCR_CUR LEN = 0
%RESULT = X'0603'
%END       ;!  OF SERIAL SELECT
!
%ROUTINE CLEAR FILES
%INTEGER I,X,Y,RC
!
X = NIL  ;  Y = NIL
%CYCLE I=2,1,FILE LIMIT
    !  FCT ENTRIES 0&1 CONTAIN TERMINAL I/O ENTRIES
    -> REP %UNLESS FCT(I)_PC > 0
    RC = DE ASSIGN FILE(I,X,Y)
REP:
%REPEAT
%END      ;!  OF CLEAR FILES
!
!**********************************************************************
!*
!*                        RECORD  ACCESS  FUNCTIONS
!*
!**********************************************************************
!
!
%ROUTINE SERIAL REWIND (%RECORDNAME FCR)
!
!   THIS ROUTINE SETS THE RELEVANT FIELDS IN THE CURRENT FCR 
!   SUCH THAT THE NEXT CALL ON SERIAL SELECT WILL SELECT THE
!   FIRST RECORD IN THE FILE.
!
%RECORDSPEC FCR (FCR FORMAT)
FCR_CUR PTR = FCR_FHDR_DATA START
FCR_CUR LEN = 0
FCR_DATA LIMIT = FCR_FHDR_DATA END
%RETURN
%END      ;!  OF SERIAL REWIND
!
%ROUTINE SERIAL UNWIND (%RECORDNAME FCR)
!
!  THIS ROUTINE SETS THE RELEVANT ENTRIES IN THE FCR SUCH
!   THAT THE NEXT RECORD WRITTEN WILL BE ADDED TO THE END 
!  OF THE FILE.
!
%RECORDSPEC  FCR (FCR FORMAT)
FCR_CUR PTR = FCR_FHDR_DATA END
%RETURN
%END      ;!  OF SERIAL UNWIND
!
%ROUTINE TRUNCATE (%RECORDNAME FCR)
!
!  THIS ROUTINE SETS ENTRIES IN THE CURRENT FCR SUCH THAT ALL RECORDS 
!   FROM AND INCLUDING THAT CURRENTLY SELECTED ARE DELETED.
!
%RECORDSPEC FCR (FCR FORMAT)
FCR_FHDR_DATA END = FCR_CUR PTR
FCR_CUR LEN = 0
FCR_FHDR_RECORD COUNT = -1
%IF FCR_FHDR_DATA END=FCR_FHDR_DATA START %THEN       %C
            FCR_FHDR_RECORD COUNT = 0   ;!IE TRUNCATED AT START OF FILE
%RETURN
%END     ;!  OF TRUNCATE
!
%ROUTINE DESELECT (%RECORDNAME FCR)
!
!  THIS ROUTINE EFFECTIVLY STOPS ALL FURTHER TANSFERS VIA THE 
!   CURRENT FILE ROUTE (FCR) UNTIL A FURTHER CALL IS MADE ON
!   SELECT RAM FOR THIS FILE ROUTE.  THE ROUTE IS MARKED
!   AS 'UNSELECTED' BY SETTING THE RAF SWITCH ENTRY T0 -1.
!
%RECORDSPEC FCR (FCR FORMAT)
FCR_RAF SWITCH = -1
%RETURN
%END      ;!  OF DESELECT
!
%INTEGERFN SERIAL READ (%RECORDNAME FCR)
%INTEGER RC,POS,LEN
%RECORDSPEC FCR(FCR FORMAT)
!
!  ON ENTRY CUR PTR AND CUR LEN IDENTIFY THE PREVIOUSLY
!  SELECTED RECORD.  THEREFORE MUST CALL SERIAL SELECT TO IDENTIFY
!  THE NEXT RECORD AND THEN MOVE IT INTO THE USERS BUFFER.
!
RC = 0
RC = SERIAL SELECT (FCR)
%IF RC > 0 %THEN %RESULT = RC
POS = FCR_CUR PTR
LEN = FCR_CUR LEN
%IF FCR_DATA FORMAT = 2 %THEN %START
    !  VARIABLE LENGTH RECORDS WITH 2 BYTE HEADERS
    POS = POS + 2
    LEN = LEN -2
%FINISH
MOVE(LEN,FCR_CON ADDR+POS,FCR_BUFF DR1)
%IF FCR_DATA FORMAT = 4 %THEN %START
    !  CHARACTER FILE, MUST TRANSLATE
    ITOE(FCR_BUFF DR1,LEN)
    BYTEINTEGER(FCR_BUFF DR1+LEN-1)=X'15'
%FINISH
%IF FCR_XFER DR0 # NIL %THEN INTEGER(FCR_XFER DR1)=LEN
%RESULT = RC
%END      ;!  OF SERIAL READ
!
%INTEGERFN IT READ (%RECORDNAME FCR)
%RECORDSPEC FCR(FCR FORMAT)
!?3;%INTEGER X
%INTEGER I,J,LINE LENGTH,PROMPT LENGTH
%BYTEINTEGERARRAY LINE BUFFER (0:FCR_RMAX)
%STRING(15) NEW PROMPT
!
%IF FCR_KEY DR0 # 0 %THEN %START
    !  USER HAS SPECIFIED A PROMPT
    PROMPT LENGTH = FCR_KEY DR0 & X'0000000F'
    !  ONLY TAKE FIRST 15 CHARS OF PROMPT
    NEW PROMPT = STRING FROM (PROMPT LENGTH,FCR_KEY DR1)
    ETOI(ADDR(NEW PROMPT)+1,PROMPT LENGTH)
    PROMPT(NEW PROMPT)
    IT PROMPT FLAG = YES
%FINISH %ELSE %START
%IF IT PROMPT FLAG = YES %THEN PROMPT("BASIC INPUT:   ")      %C
                  %AND IT PROMPT FLAG = NO
%FINISH
%CYCLE I=1,1,FCR_RMAX
    READ SYMBOL(LINE BUFFER(I))
    %IF LINE BUFFER(I) = NL %THEN J=I %AND -> EOL
%REPEAT
!   LINE TOO LONG, TRUNCATE
J = FCR_RMAX
EOL:
!?3;X=OUTSTREAM
!?3;SELECTOUTPUT(DIAGSTREAM)
%IF J>(FCR_BUFF DR0&X'00FFFFFF') %THEN LINE LENGTH   %C
    = FCR_BUFF DR0&X'00FFFFFF' %ELSE LINE LENGTH = J
!?3;XDUMP("LINEBUFFER",ADDR(LINEBUFFER(0)),30)
ITOE(ADDR(LINE BUFFER(1)),LINE LENGTH)
LINEBUFFER(LINELENGTH)=X'15'
MOVE(LINE LENGTH,ADDR(LINE BUFFER(1)),FCR_BUFF DR1)
!?3;XDUMP("USERBUFF",FCR_BUFF DR1,30)
!?3;NEWLINE;WRITE(LINELENGTH,1)
!?3;SELECTOUTPUT(X)
INTEGER(FCR_XFER DR1) = LINE LENGTH
%RESULT = 0
%END    ;!  OF IT READ
!
%INTEGERFN IT WRITE (%RECORDNAME FCR)
%INTEGER LINE LENGTH
%RECORDSPEC FCR(FCR FORMAT)
%BYTEINTEGERARRAY LINE BUFFER (0:FCR_RMAX)
!
LINE LENGTH = FCR_BUFF DR0&X'00FFFFFF'
%IF LINE LENGTH > FCR_RMAX %THEN LINE LENGTH = FCR_RMAX
MOVE(LINE LENGTH,FCR_BUFF DR1,ADDR(LINE BUFFER(1)))
ETOI(ADDR(LINE BUFFER(1)),LINE LENGTH)
LINE BUFFER(0) = LINE LENGTH
PRINTSTRING (STRING(ADDR(LINE BUFFER(0))))
NEWLINE
%RESULT = 0
%END      ;!  OF IT WRITE
!
%INTEGERFN SERIAL APPEND (%RECORDNAME FCR)
%INTEGER RECORD LENGTH,XL,XP
%RECORDSPEC FCR(FCR FORMAT)
%SWITCH S(0:5)
!
RECORD LENGTH = FCR_BUFF DR0 & X'00FFFFFF'
%IF RECORD LENGTH > FCR_RMAX %THEN %RESULT = X'0541'
SERIAL UNWIND(FCR)
XL = RECORD LENGTH
-> S(FCR_DATA FORMAT)
!
S(1): !  FIXED LENGTH RECORDS
      %IF FCR_CUR PTR + RECORD LENGTH > FCR_FHDR_FILE SIZE %THEN   %C
                   %RESULT = X'0506'
      XP = FCR_CUR PTR
      -> XFER
S(2): !  VARIABLE LENGTH RECORDS WITH 2 BYTE HEADER
      RECORD LENGTH = RECORD LENGTH + 2
      %IF FCR_CUR PTR + RECORD LENGTH > FCR_FHDR_FILE SIZE %THEN  %C
                   %RESULT = X'0506'
      MOVE(2,ADDR(RECORD LENGTH)+2,FCR_CON ADDR + FCR_CUR PTR)
      XP = FCR_CUR PTR + 2
      -> XFER
!
XFER:
MOVE(XL,FCR_BUFF DR1,FCR_CON ADDR + XP)
!    NEW RECORD BECOMES CURRENTLY SELECTED RECORD
!    FCR_CUR PTR REMAINS UNCHANGED
FCR_CUR LEN = RECORD LENGTH
FCR_FHDR_DATA END = FCR_CUR PTR + RECORD LENGTH
FCR_FHDR_RECORD COUNT = FCR_FHDR_RECORD COUNT + 1
%RESULT = 0
%END      ;!  OF SERIAL APPEND
!
!
!***********************************************************************
!*
!*                              QUIT
!*
!**********************************************************************
!
!  THIS ROUTINE IS CALLED TO FORCE A RETURN TO COMMAND LEVEL.
!  THE RETURN IS MADE VIA THE LNB SAVED ON INITIAL ENTRY (BASICBASE)
!  FOR THE PURPOSE.
!
%EXTERNALROUTINE SSQT (%INTEGER RESULT CODE)
%INTEGER X,RC
!?2; *STLN _X
!?2; TRACE("QUIT","",X,1,-1)
CLEAR FILES
SET RETURN CODE (RESULT CODE)
!
!  JUST IN CASE THERE ARE ANY REMAINING QUEUED INTERRUPTS
!  DO A DDISC ID TO CLEAR THEM.  IF THERE ARE ANY THE
!  CALL ON DISC WILL HAVE HE EFFECT OF INVOKING ANOTHER ENTRY
!  INTO THE "BBONTRAP" ROUTINE.  HIS SHOULD ENABLE ALL QUEUED 
!  INTERRUPTS TO BE CLEARED BEFORE RETURN TO COMMAND
!  LEVEL.
!
RC = DISC ID
DRESET CONTINGENCY
X = ENTRY LNB
*LLN_X          ;!  RESTORE LNB AND RETURN AS IF
*EXIT_-64       ;!  FROM ENTRY ROUTINE, BASICBASE
%END         ;!  OF QUIT
!
!**********************************************************************
!*
!*                        ABANDON
!*
!**********************************************************************
!
%ROUTINE ABANDON (%INTEGER OPTIONS,%STRING(120) COMMENT)
!  RETURN TO COMMAND LEVEL
!  OPTION 1 => RETURN WITHOUT DIAGS
!         2 => LANGUAGE DIAGS
!          3 => STACK DUMP
!         4 => TOTAL DUMP
!
%UNLESS COMMENT = '' %THEN LOG(COMMENT.' - ABANDONING')
!
!  OTHER DUMPING CODE IN HERE
!
SSQT(1000)
%END       ;!  OF ABANDON
!
!**********************************************************************
!*
!*                    SET  CONTINGENCY
!*
!**********************************************************************
!
%EXTERNALINTEGERFN SET CONTINGENCY (%LONGINTEGER DESC,MASK)
%INTEGER I
%LONGINTEGER X
!?2; *STLN _I
!?2; TRACE("SET CONTINGENCY","",I,4,-1)
X=MASK
%CYCLE I = 0,1,63
    %IF X&X'0000000000000001' = 0 %THEN CONT RTN DESC(I) = DESC
    X = X>>1
%REPEAT
%RESULT = 0
%END         ;!  OF SET CONTINGENCY
!
!**********************************************************************
!*
!*                     READ  INTERRUPT  DATA
!*
!**********************************************************************
!
%EXTERNALINTEGERFN READ INTERRUPT DATA (%INTEGER ID DR0,ID DR1)
%INTEGER L,RC
!?2; *STLN _L
!?2; TRACE("READ INTERRUPT DATA","",L,2,-1)
%IF INT DATA FLAG = NO %THEN %RESULT = X'F02'
RC = 0
L= ID DR0 & X'00FFFFFF'
%IF L < 18 %THEN RC = -1
%IF L > 18 %THEN L = 18
MOVE (L * 4,ADDR(INT DATA(0)),ID DR1)
%RESULT = RC
%END       ;!  OF READ INTERRUPT DATA
!
!**********************************************************************
!*
!*                DISCARD  INTERRUPT  DATA
!*
!**********************************************************************
!
%EXTERNALINTEGERFN DISCARD INTERRUPT DATA
!?2; %INTEGER X
!?2; *STLN _X
!?2; TRACE("DISCARD INTERRUPT DATA","",X,0,-1)
!
!  SINCE A CALL ON DIRECTOR'S DISC ID INTERFACE IS MADE
!  IMMEDIATELY ON RECEIVING AN INTERRUPT (SEE BBONTRAP)
!  THERE IS NO NEED TO DO ANYTHING HERE EXCEPT TO SET A
!  FLAG TO INDICATE WHETHER OR NOT BASIC HAS "DISCARDED".
!  THIS IS THE SAME AS A CHECK ON WHETHER THERE SHOULD BE 
!  MEANINGFULL INTERRUPT DATA AVAILABLE.
!
%IF INT DATA FLAG = NO %THEN %RESULT = X'F02'
INT DATA FLAG = NO
%RESULT = 0
%END        ;!  OF DISCARD INTERUPT DATA
!
!**********************************************************************
!*
!*                       BBONTRAP
!*
!**********************************************************************
!
%EXTERNALROUTINE BBONTRAP (%INTEGER CLASS,SUBCLASS)
%INTEGER KCLASS,RC,X
!?2; %INTEGER CURRENT STREAM
!
%LONGINTEGER DESC
!
!?2;  *STLN _X
!?2;  TRACE("BBONTRAP","",X,2,-1)

KCLASS = CONTINGENCY MAP(CLASS) - 1
%IF KCLASS < 0 %THEN %START
    ABANDON(0,'CONTINGENCY CLASS '.SFROMI(CLASS).', SUBCLASS '.    %C
        SFROMI(SUBCLASS))
%FINISH
%IF INT DATA FLAG = YES %THEN %START
    ABANDON(2,'ERROR ON ERROR')
%FINISH
RC = READ ID (ADDR(INT DATA(0)))
%IF RC # 0 %THEN ABANDON(1,'NO INT DATA AFTER INTERRUPT')
INT DATA FLAG = YES
!?2; CURRENT STREAM = OUT STREAM
!?2; SELECT OUTPUT (TRACE STREAM)
!?2; XDUMP ("INTERRUPT DATA",ADDR(INT DATA(0)),18*4)
!?2; %MONITOR
!?2; SELECT OUTPUT (CURRENT STREAM)
!
!  THE FOLLOWING CALL ON DISC ID EFFECTIVELY INFORMS
!  DIRECTOR THAT THE CURRENT INTERRUPT HAS BEEN DEALT WITH.
!  ALTHOUGH THIS IS NOT STRICTLY TRUE UNTIL BASIC'S 
!  CONTINGENCY ROUTINE HAS PROCESSED IT, IT MUST BE POSSIBLE FOR
!  FURTHER ASYNCRONOUS INTERRUPTS TO GET THROUGH, TO KILL
!  DIAGNOSTIC OUTPUT, SAY.
!
RC = DISC ID
DESC = CONT RTN DESC(KCLASS)
%IF DESC = 0 %THEN ABANDON(1,'NO RTN TO HANDLE CLASS '.SFROMI(KCLASS) %C
        .'CONTINGENCY')
!
!  ENTER MACHINE CODE SEQUENCE TO CALL THE CONTINGENCY ROUTINE
!  SPECIFIED BY THE CONTENTS OF 'DESC'
!
*LD   _DESC
*STLN _%TOS
*ASF  _4
*LSS  _SUBCLASS
*SLSS _KCLASS
*ST   _%TOS
*RALN _7
*CALL _(%DR)
!
!  IF BASIC RETURNS TO HERE THEN A NORMAL RETURN HAS BEEN
!  MADE FROM BASIC'S CONTINGENCY HANDLING ROUTINE WHICH
!  IMPLIES A NEED TO RESUME AT THE POINT OF INTERRUPTION.
!  CHECK TO SEE IF INT DATA HAS
!  BEEN DISCARDED.  IF YES THEN DUMP.  IF NOT RESUME AT 
!  ENVIRONMENT DESCRIBED BY INT DATA
!
%IF INT DATA FLAG = NO %THEN     %C
    ABANDON(1,'NO INT DATA FOR NORMAL RETURN')
INT DATA FLAG = NO
DRESUME(0,0,ADDR(INT DATA(0)))
%END     ;!  OF BBONTRAP
!
!
!**********************************************************************
!*
!*                 ENTRY  ROUTINE  FOR  KENT  BASIC  INTERFACE
!*
!**********************************************************************
!
%EXTERNALROUTINE BASIC(%STRING(255) PARMS)
%INTEGER X,Y,RC,RAM USER LNB,RAM RC,I,CURRENT STREAM
%INTEGER BP DR0,BP DR1,APP DR0,APP DR1
%INTEGERARRAY ENTRY DESC (0:1)
%LONGINTEGER FCR DESC,EX DESC
%STRING(32) LOAD FILE
%SWITCH RAF (0:10)       ;!  RECORD ACCESS FUNCTION SWITCH
%RECORDNAME FCR (FCR FORMAT)
%INTEGERARRAYNAME FCR DML INFO
*STLN_X         ;!  ( SAVE LNB AT ENTRY FOR USE IN
ENTRY LNB = X   ;!  (  EXIT FROM QUIT
!?2; TRACE COUNT = 0
LOG("EMAS 2900 - KENT BASIC INTERFACE, VERSION ".VERSION)
!?3; DIAG STREAM = 60
LOG STREAM = 61
!?2; TRACE STREAM = 62
!?3  %C
DEFINE("61,.OUT")
!?3; ASK FOR STREAM (DIAG STREAM,"DIAG STREAM?   ")
!?3; ASK FOR STREAM (LOG STREAM,"LOG STREAM?    ")
!?2; ASK FOR STREAM (TRACE STREAM,"TRACE STREAM?  ")
FILL(64*8,ADDR(CONT RTN DESC(0)),X'00')
INT DATA FLAG = NO
INITIAL CPU TIME = CPU TIME
IT PROMPT FLAG = YES   ;!  IE REQUIRING PROMPT TO BE REFRESHED
!
!
JS VAR(0)_NAME = E"RESULT"            ;!)  SET UP FIRST JS VAR
JS VAR(0)_VALUE = BIN STRING(0,0)    ;!)  IN JS VAR LIST
                                     ;!)  SUCH THAT THE
JS VAR(0)_MAX LEN = 8                 ;!)  POINTERS IN THE ROUTINE
JS VAR COUNT = 0                      ;!)  'CREATE JS VAR' WORK PROPERLY
%CYCLE I=0,1,FILE LIMIT - 1
    FCT(I)_PC = 0
    FCT(I)_RAF SWITCH = -1
%REPEAT
USER NAME = UINFS (1)
*JLK  _<RI>         ;!  JUMP AROUND RECMAN RAM PROCESSING
!
!***********************************************************************
!               RECORD  ACCESS HANDLING
!**********************************************************************
!
*STLN _%B         ;!  SAVE  LNB TEMPORARILY IN B REGISTER
*LDTB _X'29000003'   ;! LOAD TYPE & BOUND FOR A WORD DESC
*LLN  _(%DR+2)    ;!  DR AFTER ESCAPE POINTS TO ESCAPE DESCRIPTOR
                   !  TARGET SET UP AT ASSIGN TIME.  DR IS UNSCALED
                   !  WORD DESCRIPTOR.  LOAD LNB FOR THIS
                   !  FOR THIS ENVIRONMENT AS SAVED AT RI.
*STD  _FCR DESC      ;!  STORE DESCRIPTOR REGISTER
*STB  _RAM USER LNB      ;!  STORE CALLER'S LNB FOR RETURN
!
!  FOR EXPLANATION OF ESCAPE MECHANISM SEE 2.5.1 PP 48,53,74,102
!
!  CODE FOR HANDLING CALLS ON RECORD CURRENCIES OR RECORD
!  ACCESS METHODS, IE. RAMS.  THESE ARE IN FACT THE ESCAPE 
!  DESCRIPTORS SET UP WHEN A CALL IS MADE ON ASSIGNFILE.
!
FCR == RECORD(INTEGER(ADDR(FCR DESC)+4))
!?2; TRACE("ACCESS","ROUTE - ".SFROMI(FCR_ROUTE),RAMUSERLNB,2,0)
%IF FCR_RAF SWITCH < 0 %THEN RAM RC = X'0530' %AND -> RAM RETURN
APP DR0 = INTEGER(RAM USER LNB+20)
APP DR1 = INTEGER(RAM USER LNB+24)
%UNLESS APP DR0 = NIL %THEN %START
    !  DECODE PARM PAIR LIST
    FCRDMLINFO==ARRAY(ADDR(FCR_BUFF DR0),FDI FORMAT)
    DECODE PPLIST(APP DR0,APP DR1,DML DECODE,FCR DML INFO)
    %UNLESS FCR_NEW ACTIONS=-1 %THEN %START 
        !ACTION APPEARED IN PARM PAIR LIST
        DERIVE RAF SWITCH(FCR_NEW ACTIONS,FCR_DATA FORMAT,X)
        %IF X<1 %THEN RAM RC = X'0902' %AND -> RAM RETURN
        FCR_RAF SWITCH = X
        FCR_ACC ACTIONS=FCR_NEW ACTIONS
        FCR_NEW ACTIONS = -1
    %FINISH
%FINISH
%IF FCR_RAF SWITCH<1 %THEN RAM RC = X'0902' %AND -> RAM RETURN
RAM RC = 0
-> RAF(FCR_RAF SWITCH)
!
RAF(1):                               !  SERIAL READ    
!
RAM RC = SERIAL READ (FCR)
-> RAM RETURN
!
RAF(2):                               !  INTERACTIVE TERMINAL READ    
RAM RC = IT READ(FCR)
-> RAM RETURN
!
RAF(3):                               !  SERIAL APPEND     
!
RAM RC = SERIAL APPEND (FCR) 
-> RAM RETURN
!
RAF(5):                               !  INTERACTIVE TERMINAL WRITE    
RAM RC = IT WRITE(FCR)
-> RAM RETURN
!
RAF(6):                               !  TRUNCATE
TRUNCATE(FCR)
RAM RC = 0
-> RAM RETURN
!
RAF(7):                               ! DESELECT RAM
DESELECT(FCR)
RAM RC = 0
-> RAM RETURN
!
!
RAF(8):       ;!  DUMMY I/O OPERATION
RAM RETURN:
*LSS  _RAM RC
*LLN _RAM USER LNB
*EXIT _-40
!
!*********************************************************************
!                  END  OF  RECORD  ACCESS  PROCESSING
!**********************************************************************
!
!
RI:  !RAM INIT SEQUENCE
!   STORE REGISTERS TO ENABLE RE-ESTABLISHMENT OF ENVIRONMENT
!  FOR HANDLING RAM CALLS
*LSS  _%TOS         ;!  LOAD PC AS STACKED BY JLK INSTRUCTION
*ST   _X       ;!  STORE PC TO BE USED BY ESCAPE
RAM PC = X
*STLN _X      ;!  STORE LNB TO BE USED BY ESCAPE
RAM LNB = X
! 
!   THESE TWO VALUES ARE COPIED INTO THE FILE CONTROL RECORD
!   FOR EACH FILE AS IT IS ASSIGNED.  THE ESCAPE DESCRIPTOR
!   THAT IS RETURNED BY SELECT RAM AS THE RECORD CURRENCY POINTS
!   TO THE PC ENTRY IN THAT FILE CONTROL RECORD.
!
!  THIS NEXT BIT MUST COME AFTER SAVING RAM PC & RAM LNB
!
EXEC MODE = UINFI(2)
%IF EXEC MODE = FOREGROUND %THEN %START
    X = CREATE JS VAR (E"ICL9XJST",BIN STRING(0,0),-1)
    FIND JS VAR (E"ICL9XJST",X)
    LENGTH(JS VAR(X)_VALUE) = 4
    X = CREATE JS VAR (E"INPUT",BIN STRING(0,0),-1)
    X = CREATE JS VAR (E"OUTPUT",BIN STRING(0,1),-1)
    RC = ASSIGN FILE(X'28000001',ADDR(X),     %C
                 NIL,X'18000006',ADDR(SOURCE)+1,      %C
                NIL,NIL,NIL,NIL)
    %IF RC # 0 %THEN ABANDON(1,"FAILED TO ASSIGN TERMINAL")
    %IF X # 0 %THEN ABANDON(1,"TERMINAL INCORRECTLY ASSIGNED")
    RC = ASSIGN FILE (X'28000001',ADDR(X),       %C
                 NIL,X'18000006',ADDR(SOURCE)+1,    %C
                NIL,NIL,NIL,NIL)
    %IF RC # 0 %THEN ABANDON(1,"FAILED TO ASSIGN TERMINAL - OUTPUT")
    %IF X # 1 %THEN ABANDON(1,"TERMINAL OUTPUT INCORRECTLY ASSIGNED")
%FINISH
!
!  NOW FOR SEQUENCE TO SET UP ENTRY FOR BASIC PROPER
!
CURRENT STREAM = OUT STREAM
!?3; -> BYPASS
DEFINE("20,.NULL")
SELECT OUTPUT(20)
!?3; BYPASS:
SELECT OUTPUT(CURRENT STREAM)
!
!  NOW SET UP CONTINGENCY HANDLIG
!
!?3; PROMPT("CONTINGENCIES?")
!?3; %IF DE SPACED(NEXTLINE)="NO" %THEN ->LAB2
RC = PRIME CONTINGENCY (BBONTRAP)
%IF RC # 0 %THEN ABANDON(0,"FAILED TO PRIME CONTINGENCIES")
!?3; LAB2:
!
KBASC(NIL,NIL)
!
!  SHOULD RETURN TO HERE FROM BASIC
!
%RETURN
%END        ;!  OF BASICBASE
!
!**********************************************************************
!*
!*                        JS  WRITE
!*
!**********************************************************************
!
%EXTERNALINTEGERFN JS WRITE (%INTEGER NAME DR0,NAME DR1,   %C
                                      NIL0,NIL1,           %C
                                      VAL DR0,VAL DR1)
%INTEGER RC,POINTER
%STRING(80) VALUE
!?2; %STRING(80) TTWORK
%STRING(8) NAME
!
!  NOTE THAT ALL JS VARS ARE STORED IN EBCDIC
!
!
!?2; *STLN _RC
!?2; TTWORK=STRINGFROM(NAME DR0,NAME DR1)
!?2; ETOI(ADDR(TTWORK)+1,LENGTH(TTWORK))
!?2; TRACE("JS WRITE",TTWORK,RC,6,-1)
%IF NAME DR0&X'000000FF' > 8 %THEN %RESULT = X'401'
%IF VAL DR0 & X'000000FF' > 80 %THEN %RESULT = X'403'
RC = 0
NAME = STRING FROM (NAME DR0,NAME DR1)
VALUE = STRING FROM (VAL DR0,VAL DR1)
FIND JS VAR (NAME,POINTER)
%IF POINTER = -1 %THEN %RESULT = CREATE JS VAR (NAME,VALUE,-1)
!  JS VAR FOUND, NEED TO UPDATE VALUE
%IF LENGTH(VALUE) > JS VAR(POINTER)_MAX LEN %THEN    %C

    LENGTH(VALUE) = JS VAR(POINTER)_MAX LEN %AND RC = -1
JS VAR(POINTER)_VALUE = VALUE
%RESULT = RC
%END      ;!  OF JS WRITE
!
!
!**********************************************************************
!*
!*                             JS  READ
!*
!**********************************************************************
!
%EXTERNALINTEGERFN JS READ (%INTEGER NAME DR0,NAME DR1,     %C
                                     NIL0,NIL1,             %C
                                     VAL DR0,VAL DR1)
%INTEGER POINTER,VAL LEN,RC
%STRING(80) VALUE
!?2; %STRING(80) NAME
!
!?2; *STLN _RC
!?2; NAME = STRING FROM (NAME DR0,NAME DR1)
!?2; ETOI(ADDR(NAME)+1,LENGTH(NAME))
!?2; TRACE("JS READ",NAME,RC,6,-1)
RC = 0
VAL LEN = VAL DR0 & X'0000FFFF'
%IF NAME DR0 & X'000000FF' > 8 %THEN RC = X'401' %AND -> OUT
VALUE = STRING FROM(NAME DR0,NAME DR1)   ;! USE VALUE TEMPORARILY
%WHILE CHARNO(VALUE,LENGTH(VALUE)) = X'40' %THEN    %C
                     LENGTH(VALUE)=LENGTH(VALUE)-1
FIND JSVAR(VALUE,POINTER)
%IF POINTER = -1 %THEN RC = X'B03' %AND -> OUT
VALUE = JS VAR(POINTER)_VALUE
FILL(VAL LEN,VAL DR1,64)      ;!  SPACE FILL AREA FOR RETURN VALUE
%IF VAL LEN < LENGTH(VALUE) %THEN LENGTH(VALUE) = VAL LEN %AND RC=-1
MOVE(LENGTH(VALUE),ADDR(VALUE)+1,VAL DR1)
OUT:
!?2; RESULT TRACE("JS READ",RC)
%RESULT = RC
%END      ;!  OF JS READ
!
!
!**********************************************************************
!*
!*                               LOG  MESSAGE
!*
!**********************************************************************
!
%EXTERNALINTEGERFN LOG MESSAGE (%INTEGER NIL0,NIL1,  %C
                                    MSG DR0,MSG DR1)
%INTEGER RC,L,DSTREAM,CURRENT STREAM
%STRING(138) S
DSTREAM = LOG STREAM
RC = 0
L = MSG DR0&X'000000FF'
%IF L > 108 %THEN L = 108 %AND RC = -1
CURRENT STREAM = OUTSTREAM
SELECT OUTPUT(LOG STREAM)
S = STRING FROM (L,MSG DR1)
ETOI(ADDR(S)+1,L)
PRINTSTRING(TIME." ".S)
NEWLINE
SELECT OUTPUT(CURRENT STREAM)
%RESULT = RC
%END      ;!  OF LOG MESSAGE
!
!
!*
!**********************************************************************
!*
!*                    GIVE  PROCESS  TIME
!*
!**********************************************************************
!
!
%EXTERNALINTEGERFN GIVE PROCESS TIME (%INTEGER TOTAL,       %C
                                           PT DR0,PT DR1)
%LONGINTEGER ANSWER
%LONGREAL REQUIRED CPU TIME
!?2; %INTEGER X
!?2; *STLN _X
!?2; TRACE("GIVE PROCESS TIME","",X,3,-1)
REQUIRED CPU TIME = CPU TIME
%IF TOTAL = 1 %THEN        %C
      REQUIRED CPU TIME = REQUIRED CPU TIME - INITIAL CPU TIME
ANSWER = LONGINT(REQUIRED CPU TIME * 1000)
LONGINTEGER(PT DR1) = ANSWER
%RESULT = 0
%END       ;!  OF GIVE PROCESS TIME
!
!
!**********************************************************************
!*
!*                         GIVE  DATE  AND  TIME
!*
!**********************************************************************
!
%EXTERNALINTEGERFN GIVE DATE AND TIME (%INTEGER                  %C
                                  DATE DR0,DATE DR1,                 %C
                                   TIME DR0,TIME DR1,               %C
                                  DATE FORMAT)
%CONSTINTEGERARRAY MD MAP (1:12) = 0,31,59,90,120,154,   %C
                      181,212,243,273,304,334
%CONSTSTRING(3)%ARRAY MONTH NAME (1:12) = 'JAN','FEB','MAR',
      'APR','MAY','JUN','JUL','AUG','SEP','OCT','NOV','DEC'
%STRING(8) WORK
%STRING(2) DAY,MONTH,YEAR
%INTEGER NMONTH,NDAYS,NYEAR,L,RC
%SWITCH FORMAT (0:2)
!
!?2; *STLN _RC
!?2; TRACE("GIVE DATE AND TIME","",RC,5,-1)
RC = 0
%IF TIME DR1 # NIL %THEN %START
    WORK = TIME
    L = TIME DR0 & X'000000FF'
    ITOE(ADDR(WORK)+1,8)
    %IF L > 8 %THEN L = 8
    %IF L < 8 %THEN RC = -2
    MOVE(L,ADDR(WORK)+1,TIME DR1)
%FINISH
%IF DATE DR1 # NIL %THEN %START
    L = DATE DR0 & X'000000FF'
    WORK = DATE
    DAY = FROM STRING (WORK,7,8)
    MONTH = FROM STRING (WORK,4,5)
    YEAR = FROM STRING (WORK,1,2)
    NMONTH = IFROMS(MONTH)
    -> FORMAT ( DATE FORMAT)
FORMAT(0):    ;!  DDMMMYY ,   EG.  05SEP77
    WORK = DAY.MONTH NAME(NMONTH).YEAR
    -> OUT
FORMAT(2):      ;!  DDD/77 ,        EG.   248/77
    NDAYS = MD MAP(NMONTH) + IFROMS(DAY)
    NYEAR = IFROMS(YEAR)
    %IF NMONTH > 2 %AND NYEAR-((NYEAR//4)*4) = 0 %THEN %C
        NDAYS = NDAYS + 1
    WORK = SFROMI(NDAYS)."/".YEAR
FORMAT(1):      ;!  YY/MM/DD      EG. 77/09/05
OUT: ITOE(ADDR(WORK)+1,8)
    %IF L > 8 %THEN L = 8
    %IF L < 8 %THEN RC = RC + 1
    MOVE(L,ADDR(WORK)+1,DATE DR1)
%FINISH
%RESULT = RC
%END       ;!   OF GIVE DATE AND TIME
!
!
!**********************************************************************
!*
!*                       CREATE  FILE
!*
!**********************************************************************
!
%EXTERNALINTEGERFN CREATE FILE (%INTEGER                          %C
                                  ROUTE DR0,ROUTE DR1,             %C
                                  NIL0,                        %C
                                 NAME DR0,NAME DR1,               %C
                                 GENERATION,NIL1,                 %C
                                  DESC DR0,DESC DR1)
!
%INTEGER RC,I,X,CON SEG
%INTEGER RECORD TYPE,RECORD SIZE,FILE SIZE
%RECORDNAME FILE HEADER (FHDR FORMAT)
%RECORD R(CONNECTFORM)
%STRING(32) FILE NAME
%SWITCH S(104:118)
!
!?2; %STRING(80) TTWORK
!?2; *STLN _RC
!?2; TTWORK=STRING FROM (NAME DR0,NAME DR1)
!?2; ETOI(ADDR(TTWORK)+1,LENGTH(TTWORK))
!?2; TRACE("CREATE FILE",TTWORK,RC,9,7)
RECORD TYPE = 2 ; RECORD SIZE = 132 ; FILE SIZE = X'7880'
!  THIS LOOP A BIT GROTTY, MUST TIDY IT UP SOME TIME
%CYCLE I = DESC DR1,12,(DESC DR1 + (DESC DR0&X'00FFFFFF')*4)-12
    -> S(INTEGER(I))
S(104):  RECORD TYPE = INTEGER(I+4)
         -> REP
S(105):  RECORD SIZE = INTEGER(I+4)
         -> REP
S(118):  FILE SIZE = INTEGER(I+4)
REP:
%REPEAT
!
FILE NAME = STRING FROM (NAME DR0,NAME DR1)
ETOI(ADDR(FILE NAME)+1,LENGTH(FILE NAME))
FILE NAME = DE SPACED (FILE NAME)
RC = DCREATE (USER NAME,FILE NAME,-1,FILE SIZE >> 10,0)
%IF RC > 0 %THEN %START
    LOG("FAILED TO CREATE FILE ".FILE NAME." - ".SFROMI(RC))
    %RESULT = X'8000'
%FINISH
!
!     NOW TO CONSTRUCT A HEADER FOR THE FILE TO CONFORM TO
!     TO STANDARD SUBSYSTEM DISCRETE RECORD(VARIABLE) FILES
!
!  ROUND UP FILE SIZE TO NEXT UNIT OF ALLOCATION, IE 4K
!
X = FILE SIZE >> 12
%IF X << 12 < FILE SIZE %THEN FILE SIZE = (X+1)<<12
CON SEG = 0 ; X = 0
CONNECT(USERNAME.".".FILENAME,2,0,0,R,RC)
%IF RC > 0 %THEN %START
    LOG("FAILED TO CONNECT FILE ".FILE NAME." - ".SFROMI(RC))
    %RESULT = X'8000'
%FINISH
FILE HEADER ==  RECORD(R_CONAD)
FILE HEADER_DATA END      = 32         ;!  ALLOW FOR HEADER
FILE HEADER_DATA START    = 32            ;!  FILE EMPTY
FILE HEADER_FILE SIZE     = FILE SIZE       ;!  PHYSICAL FILE SIZE
FILE HEADER_FILE TYPE     = 4            ;!  DISCRETE RECORDS
FILE HEADER_CHECK SUM     = 0         ;!  NOT YET USED
FILE HEADER_DANDT         = FILE TIME STAMP    ;!  TIME LAST WRITTEN TO
FILE HEADER_FORMAT        = (RECORD SIZE<<16)!2     ;! ALWAYS VARIABLE
FILE HEADER_RECORD COUNT  = 0         ;!  FILE EMPTY
DISCONNECT(USERNAME.".".FILENAME,RC)
%IF RC > 0 %THEN %START
    LOG("CF - DDISCON FAILS, FILE ".FILE NAME." - ".SFROMI(RC))
    %RESULT = X'8000'
%FINISH
!
ITOE(ADDR(FILE NAME)+1,LENGTH(FILE NAME))
RC = ASSIGN FILE (ROUTE DR0,ROUTE DR1,       %C
              NIL,X'18000000'!LENGTH(FILE NAME),ADDR(FILE NAME)+1, %C
                  NIL,NIL,NIL,NIL)
%RESULT = RC
%END        ;!  OF CREATE FILE
!
!**********************************************************************
!*
!*                   DE  ASSIGN  FILE
!*
!**********************************************************************
!
%EXTERNALINTEGERFN DE ASSIGN FILE (%INTEGER ROUTE,ST DR0,ST DR1)
!
%INTEGER RC
%RECORDNAME FCR(FCR FORMAT)
!
!?2; *STLN _RC
!?2; TRACE("DE ASSIGN FILE","",RC,2,-1)
FCR ==FCT(ROUTE)
%IF FCR_PC = 0 %THEN %START
    !  FILE ROUTE NOT ASSIGNED
    LOG ('ATTEMPT TO DE-ASSIGN NON-ASSIGNED FILE ROUTE')
    %RESULT = X'0C07'
%FINISH
%IF FCR_RAF SWITCH # -1 %THEN %START
    !  FILE STILL OPEN, RAM NOT DESELECTED
    DESELECT(FCR)
%FINISH
FCR_PC = 0
!    NOW CALL DIRECTOR TO DISCONNECT FILE
DISCONNECT(FCR_OWNER.".".FCR_NAME,RC)
%IF RC > 0 %THEN %RESULT = X'0C07'
%RESULT = 0
%END       ;!  OF DE ASSIGN FILE
!
!
!**********************************************************************
!*
!*                       ASSIGN  FILE
!*
!**********************************************************************
!
!
%EXTERNALINTEGERFN ASSIGN FILE (%INTEGER                          %C
                                ROUTE DR0,ROUTE DR1,              %C
                                NIL0,                             %C
                                NAME DR0,NAME DR1,                %C
                                GENERATION,NIL1,                %C
                                    DESC DR0,DESC DR1)
!
%INTEGER I,ROUTE,CON SEG,CON GAP,CON ADDR,RC,RECTYPE,X
%INTEGER ST DR0,ST DR1
!?2; %STRING(80) TTWORK
%SWITCH S(0:7)
%CONSTINTEGER RM LIMIT = 5
%CONSTINTEGERARRAY RESULT MAP (0:4,0:1)  =  %C
          5,      6,     32,     34,     37,
       X'0811',X'0C03',X'0C02',X'0C06',X'0C02'
%RECORDNAME FILE HEADER (FHDR FORMAT)
%RECORDNAME FCR (FCR FORMAT)
%RECORD R(CONNECTFORM)
%ROUTINE FILL COMMON FCR FIELDS
FCR_CONADDR = CONADDR
FCR_FHDR == RECORD(CON ADDR)
FCR_CUR PTR = FCR_FHDR_DATA START
FCR_DATA LIMIT = FCR_FHDR_DATA END
FCR_CUR LEN = 0
FCR_RAF SWITCH = -1
%END
!
!?2; *STLN _RC
!?2; TTWORK = STRING FROM(NAME DR0,NAME DR1)
!?2; ETOI(ADDR(TTWORK)+1,LENGTH(TTWORK))
!?2; TTWORK = "- ".TTWORK
!?2; TRACE("ASSIGN FILE",TTWORK,RC,9,7)
!
ST DR0 = NIL  ;  ST DR1 = NIL    ;! STATS DESC USED IN CALLS ON DEASSIGN
!
!  MUST LOOK TO WHETHER THE REQUESTED FILE IS ALREADY ASSIGNED
!  AND USE THE EXISTING ENTRY IF IT IS NOT CONNECTED, IE. IF 
!  THE ROUTE IS NOT ALREADY IN USE.
!
!   FIND NEXT VACANT ROUTE (IE ENTRY) IN FILE CONTROL TABLE, FCT
%CYCLE I = 0,1,FILE LIMIT - 1
    %IF FCT(I)_PC = 0 %THEN ROUTE = I %AND -> RF
%REPEAT
!  FILE LIMIT REACHED, NO MORE SLOTS FOR FILE CURRENCIES
%RESULT = X'0903'
RF:    !  VACANT ROUTE FOUND IN FCT
FCR == FCT(ROUTE)
FCR_PC = 1            ;! )  ROUTE NOMINALLY
FCR_RAF SWITCH = -1   ;! )  OCCUPIED
FCR_ROUTE = ROUTE
FCR_ALL ACTIONS = 0
FCR_NAME = STRING FROM (NAME DR0,NAME DR1)
ETOI(ADDR(FCR_NAME)+1,LENGTH(FCR_NAME))
FCR_NAME = DE SPACED (FCR_NAME)
%IF FCR_NAME = 'SOURCE' %THEN -> S(6)
%IF DESC DR0 # NIL %AND INTEGER(DESC DR1) = 40 %THEN %START
    !  PARMS SPECIFIED AND ONLY TYPE 40 EXPECTED
    FCR_OWNER = STRING FROM (INTEGER(DESC DR1+4),INTEGER(DESC DR1+8))
    ETOI(ADDR(FCR_OWNER)+1,LENGTH(FCR_OWNER))
%FINISH %ELSE FCR_OWNER = USER NAME
FCR_OWNER = DE SPACED(FCR_OWNER)
CON SEG = 0  ; CON GAP = 0
CONNECT(FCR_OWNER.".".FCR_NAME,1,0,0,R,RC);   ! READ ONLY ACCESS
%IF RC > 0 %THEN %START
!?3;     LOG ("AF - RESULT CODE FROM DCONNECT = ".SFROMI(RC))
    X = DE ASSIGN FILE(ROUTE,ST DR0,ST DR1)
    %CYCLE I = 0,1,RM LIMIT - 1
        %IF RC = RESULT MAP (I,0) %THEN %RESULT = RESULT MAP (I,1)
    %REPEAT
    %RESULT = X'8000'
%FINISH
CONADDR = R_CONAD
ST DR0 = NIL  ;  ST DR1 = NIL
!  MAP FILE HEADER TEMPORARILY TO INVESTIGATE FILE
FILE HEADER == RECORD(CONADDR)
%IF FILE HEADER_FILE TYPE < 0 %OR FILE HEADER_FILE TYPE > 5 %C
       %THEN %START
    LOG('FILE '.FCR_OWNER.".".FCR_NAME.' HAS CORRUPT HEADER, FILE TYPE')
    RC = DE ASSIGN FILE (ROUTE,ST DR0,ST DR1)
    %RESULT = X'0C16'
%FINISH
-> S(FILE HEADER_FILE TYPE)
!
S(0):S(1):S(2):S(5): ! FILE TYPES NOT SUITABLE FOR DATA FOR BASIC
LOG('FILE '.FCR_NAME.' NOT VALID FOR CURRENT ACCESS')
RC = DE ASSIGN FILE (ROUTE,ST DR0,ST DR1)
%RESULT = X'0C15'
S(3):   !   CHARACTER FILE
FCR_RMIN = 1
FCR_RMAX = 255
FCR_DATA FORMAT = 4
FILL COMMON FCR FIELDS
->FINAL
S(4):   !   DATA FILE - DISCRETE RECORDS
REC TYPE = FILE HEADER_FORMAT & X'0000FFFF'
FCR_RMAX = FILE HEADER_FORMAT >> 16
%IF REC TYPE = 1 %THEN %START
    !  FIXED LENGTH RECORDS
    FCR_RMIN = FCR_RMAX
    FCR_DATA FORMAT = 1
    -> DFF
%FINISH
%IF REC TYPE = 2 %THEN %START
    !  VARIABLE LENGTH RECORDS
    FCR_RMIN = 1
    FCR_DATA FORMAT = 2
    -> DFF
%FINISH
LOG ('FILE '.FCR_NAME.' HAS CORRUPT HEADER WORD 6')
RC = DE ASSIGN FILE (ROUTE,ST DR0,ST DR1)
%RESULT = X'0C16'
DFF:
FILL COMMON FCR FIELDS
-> FINAL
S(6):   !  INTERACTIVE TERMINAL
FCR_CON ADDR = -1
FCR_OWNER = ""
FCR_DATA FORMAT = 3
FCR_RMIN = 0
FCR_RMAX = 255
->FINAL
!
FINAL:
FCR_LNB = RAM LNB
FCR_PC = RAM PC
FCR_EP=X'E1000000'
INTEGER(ROUTE DR1) = ROUTE
%RESULT = 0
%END        ;!  OF ASSIGN FILE
%EXTERNALINTEGERFN INTERROGATE FILE DESCRIPTION (%INTEGER         %C
                                    ROUTE,                        %C
                                     DESC DR0,DESC DR1)
%RESULT = NOT IMPLEMENTED
%END        ;!  OF INTERROGATE FILE DESCRIPTION
!
!
%EXTERNALINTEGERFN LIST FILE (%INTEGER             %C
                             DN DR0,DN DR1,                %C
                                   FN DR0,FN DR1)
%RESULT = NOT IMPLEMENTED
%END        ;!  OF LIST FILE
!
!
!**********************************************************************
!*
!*                  SELECT  RECORD  ACCESS  METHOD
!*
!**********************************************************************
!
%EXTERNALINTEGERFN SELECT RECORD ACCESS METHOD (%INTEGER           %C
                                ROUTE ,                   %C
                                 PP DR0,PP DR1)
!
%INTEGER X,RC,Y
%INTEGERARRAYNAME   FCR DML INFO
%RECORDNAME FCR(FCR FORMAT)
%RECORD R(CONNECTFORM)
!?3; %INTEGER CURRENT STREAM
!?3; %STRING(100) DWORK
!
!?2; *STLN _X
!?2; TRACE("SELECT RAM","",X,3,1)
FCR == FCT(ROUTE)
%IF FCR_PC = 0 %THEN %RESULT = X'8000'  ;! ROUTE NOT ASSIGNED
%IF FCR_RAF SWITCH # -1 %THEN %RESULT = X'0901' ;! THIS ROUTE IN USE
FCR DML INFO == ARRAY(ADDR(FCR_BUFF DR0),FDI FORMAT)
MOVE (13*4,ADDR(FCR DML INFO DEFAULTS(0)),ADDR(FCR_BUFF DR0))
DECODE PP LIST (PP DR0,PP DR1,DML DECODE,FCR DML INFO)
DERIVE RAF SWITCH (FCR_NEW ACTIONS,FCR_DATA FORMAT,X)
%IF X < 0 %THEN %RESULT = X'0902'   ;!  NO SUITABLE ALGORITHM
FCR_RAF SWITCH = X
FCR_ALL ACTIONS = FCR_NEW ACTIONS
%IF X > 0 %THEN FCR_ACC ACTIONS = FCR_NEW ACTIONS
FCR_NEW ACTIONS = -1
!
%UNLESS FCR_DATA FORMAT = 3 %THEN %START
    !  IE FOR ALL FILES OTHER THAN INTERACTIVE TERMINAL STREAM
    SERIAL REWIND (FCR)       ;!  OK FOR KENT BASIC FILES
    %IF FCR_ALL ACTIONS&X'B8' > 0 %THEN %START
        !   WRITE ACCESS REQUIRED
        DISCONNECT(FCR_OWNER.".".FCR_NAME,RC)
        %IF RC > 0 %THEN %START
            ABANDON(1,"DDISCON FAILS ON ".FCR_NAME." - ".SFROMI(RC))
        %FINISH
        Y = FCR_CON ADDR << SEG SHIFT
        X = 0
        CONNECT(FCR_OWNER.".".FCR_NAME,3,0,0,R,RC)
        %IF RC > 0 %THEN %START
            ABANDON(1,"FAILED TO CONNECT ".FCR_NAME." - ".SFROMI(RC))
        %FINISH
    FCR_FHDR_DANDT = FILE TIME STAMP
     %FINISH
%FINISH
!?3;NEWLINE;WRITE(FCR_CURR DR1,10);NEWLINE
INTEGER(FCR_CURR DR1)=X'B1000000'  ;! RETURN RECORD CURRENCY VIA DESC
INTEGER(FCR_CURR DR1+4) = ADDR(FCR_EP) ;! GIVEN IN PARM PAIR LIST
!?3; CURRENT STREAM = OUT STREAM
!?3; SELECT OUTPUT(DIAG STREAM)
!?3; DWORK = "FILE ".FCR_OWNER.".".FCR_NAME." SELECTED, FCR FOLLOWS"
!?3; XDUMP(DWORK,ADDR(FCR_EP),120)
!?3; %IF FCR_CON ADDR > 0 %THEN %START
!?3;     XDUMP("FIRST 100 BYTES OF FILE",FCR_CON ADDR,100)
!?3; %FINISH
!?3; SELECT OUTPUT(CURRENT STREAM)
%RESULT = 0
%END         ;!  OF SELECT RECORD ACCESS METHOD
!
!**********************************************************************
!*
!*                           CREATE  AREA
!*
!**********************************************************************
!
!
%EXTERNALINTEGERFN CREATE AREA (%INTEGER                     %C
                                     NAME DR0,NAME DR1,          %C
                                     P DR0,P DR1,                %C
                                     A DR0,A DR1)
!
!   THE ROW OF WORDS PASSED AS THE PARAMETER PAIR LIST IS MAPPED
!   ONTO AN INTEGER ARRAY, PPLIST, USING AN INTEGER ARRAY
!   FORMAT, PPF, WITH DYNAMIC BOUNDS, THE BOUNDS BEING
!   BEING CALCULATED FROM THE LENGTH FIELD OF THE DESCRIPTOR
!   FOR THE PARAMETER PAIRS.  AN ARRAY OF POINTERS, IDPTR, EACH
!   ELEMENT OF WHICH CORRESPONDS TO A PARM PAIR IDENTIFIER, IS
!   INITIALISED SUCH THAT THE NTH ELEMENT POINTS TO THE
!   FIRST WORD (IDENTIFIER) OF THE PARM PAIR WITH IDENTIFIER N.
!   THE LENGTH OF THE ARRAY IDPTR IS DETERMINED BY THE 
!   LOWEST AND HIGHEST NUMERICAL VALUES OF THE PARM PAIR
!   IDENTIFIERS EXPECTED.
!   SEE K-SV9 BUPI MANUAL FOR FULL EXPLANATION OF THE PARM
!   MECHANISM.
!
!   THE ONLY TWO PARM PAIRS OF INTEREST TO EMAS WRT THIS
!   INTERFACE ARE SIZE AND MAXSIZE, IDENTIFIERS 1 AND 7
!   RESPECTIVLY.  THE ACCESS PERMISSION IS SET TO WRITE
!   AS THERE IS LITTLE POINT IN CONNECTING TO A NEW AREA IN OTHER
!   THAN WRITE MODE.  
!
!   THIS LAST POINT MAY HAVE TO BE REVISED TO TAKE ACCOUNT OF
!   THINGS LIKE READ AND WRITE INITIAL PERMISSION.
!
%INTEGERARRAYFORMAT  PPF (0:(P DR0 & X'00FFFFFF') - 1)
%INTEGERARRAYNAME PP LIST
%INTEGERARRAY IDPTR (0:14)
%INTEGER I,SIZE,MAX SIZE,FLAG,AREA ADDR,PPLIST LENGTH
!?2; %STRING(80) TTWORK
!?2; %INTEGER X
%STRING(30) FILE NAME
!
!?2; *STLN _X
!?2; TRACE("CREATE AREA","",X,6,2)
PPLIST LENGTH = P DR0 & X'00FFFFFF'
PP LIST == ARRAY(P DR1,PPF)
FILL (15*4,ADDR(IDPTR(0)),X'FF')
%CYCLE I = 0,2,PPLIST  LENGTH - 2
    IDPTR(PPLIST(I))=I
%REPEAT
%IF IDPTR(1) > -1 %THEN SIZE = PPLIST(IDPTR(1)+1)   %C
            %ELSE %RESULT = X'101'
%IF IDPTR(7) > -1 %THEN %START
    MAX SIZE = PPLIST(IDPTR(7)+1)
    %IF MAX SIZE < SIZE %THEN %RESULT = X'E03'
%FINISH %ELSE MAX SIZE = SIZE
FILE NAME = "T#".NEXT TEMP
OUT FILE (FILENAME,SIZE,MAX SIZE,0,AREA ADDR,FLAG)
%IF FLAG # 0 %THEN %START
    LOG ('FAILURE FROM EMAS ''OUTFILE'' = '  %C
       .SFROMI(FLAG))
    %RESULT = X'E08'
%FINISH
INTEGER(A DR1) = X'18000000' ! SIZE
INTEGER(ADR1+4) = AREA ADDR
!?2; TTWORK=STRINGFROM(NAMEDR0,NAMEDR1)
!?2; ETOI(ADDR(TTWORK)+1,LENGTH(TTWORK))
!?2; TTWORK="-".TTWORK
!?2; LOG("CREATE AREA- NAME IS >>".TTWORK."<<")
!?2; LOG("TEMPAREA FILENAME IS >>".FILENAME."<<")
!?2; TTWORK=HEXOF(INTEGER(ADR1)).HEXOF(INTEGER(ADR1+4))
!?2; LOG(">>".SFROMI(TRACECOUNT)."<< CREATE AREA DESCRIPTOR IS".TTWORK)
%RESULT = 0
%END     ;!   OF CREATE AREA
!
!**********************************************************************
!*
!*                           DELETE  AREA
!*
!**********************************************************************
!
!
%EXTERNALINTEGERFN DELETE AREA (%INTEGER A DR0,A DR1)
%STRING(31) FILE NAME
%INTEGER RC
!
!?2; *STLN _RC
!?2; TRACE("DELETE AREA","",RC,2,-1)
FILE NAME = CONFILE(ADR1)
%IF FILE NAME = '.NULL' %THEN %RESULT = X'401'
DESTROY(FILE NAME,RC)
%IF RC # 0 %THEN %RESULT = X'E0B'
%RESULT = 0
%END        ;!  OF DELETE AREA
!
!**********************************************************************
!*
!*                       UPDATE  AREA  LOCAL  PROPERTIES
!*
!**********************************************************************
!
!
%EXTERNALINTEGERFN UPDATE AREA LOCAL PROPERTIES (%INTEGER          %C
                              A DR0,A DR1,                         %C
                              P DR0,P DR1)
!
!   SEE CREATE AREA FOR DETAILS OF HANDLING OF PARAMETER PAIRS
!
!   THE ONLY PROPERTIES OF INTEREST HERE ARE THOSE WHICH IMPLY
!   A CHANGE IN AREA SIZE OR A CHANGE IN ACCESS PERMISSION TO THE
!   THE AREA SPECIFIED.  THE PARM PAIR ID'S OF INTEREST ARE
!  AS FOLLOWS:
!                   1   AREA SIZE
!                    2   READ ACCESS
!                   3   WRITE ACCESS
!                   4   EXECUTE ACCESS
%INTEGERARRAYFORMAT PPF (0:(P DR0 & X'00FFFFFF') - 1)
%INTEGERARRAYNAME PPLIST
%INTEGERARRAY IDPTR (0:14)
%STRING(15) FILE NAME
%INTEGER RC,NA,I,PPLIST LENGTH
!?3; %INTEGER CURRENT STREAM
!?3; %STRING(100) DWORK
!
!?2; *STLN _RC
!?2; TRACE("UPDATE ALP","",RC,4,2)
PPLIST LENGTH = P DR0 & X'00FFFFF'
PP LIST == ARRAY(P DR1,PPF)
FILL(15*4,ADDR(IDPTR(0)),X'FF')
%CYCLE I = 0,2,PPLIST LENGTH - 2
    IDPTR(PPLIST(I)) = I
%REPEAT
!
!?3; CURRENT STREAM=OUTSTREAM
!?3; SELECTOUTPUT(DIAGSTREAM)
!?3; DWORK="ENTERED UALP---FCR FOLLOWS"
!?3; XDUMP(DWORK,ADR1,120)
!?3; SELECTOUTPUT(CURRENTSTREAM)
FILE NAME = CONFILE(A DR1)
%IF FILE NAME = '.NULL' %THEN %RESULT = X'401'
%IF IDPTR(1) > -1 %THEN %START
    !  CHANGE FILE SIZE
    CHANGE FILE SIZE(FILE NAME,PPLIST(IDPTR(1)+1),RC)
    %IF RC # 0 %THEN %RESULT = X'E03'
%FINISH
NA = 0
%IF IDPTR(2) > -1 %THEN NA = 1
%IF IDPTR(3) > -1 %THEN NA = NA + 2
%IF IDPTR(4) > -1 %THEN NA = NA + 4
%IF NA > 0 %THEN %START
    CHANGE ACCESS (FILE NAME,NA,RC)
    %IF RC # 0 %THEN %RESULT = X'E03'
%FINISH
%RESULT = 0
%END        ;!  OF UPDATE AREA LOCAL PROPERTIES
!
%EXTERNALINTEGERFN DELETEFILE
%RESULT=0
%END
!
%ENDOFFILE
BP DR0 = NIL  ;  BP DR1 = NIL