!
!***********************************************************************
!*
!*                EMAS 2900 INTERFACE FOR KENT BASIC
!*
!**********************************************************************
!
!***********************************************************************
!*
!*                             EXTERNALS
!*
!***********************************************************************
!
%EXTERNALSTRING(16) INPUTFILE,OUTPUTFILE
!
!
!**********************************************************************
!*
!*                            CONSTANTS
!*
!**********************************************************************
!
%CONSTINTEGER NO = 0,         %C
              YES = 1
%CONSTINTEGER NIL = 0
!?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
%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
%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
%OWNINTEGER ENTRY 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    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    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
!*
!**********************************************************************
!
%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 LOG MESSAGE (%INTEGER NIL0,NIL1,DR0,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 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
!
!
!***********************************************************************
!*
!*                              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,RC,I,CURRENTSTREAM
*STLN_X         ;!  ( SAVE LNB AT ENTRY FOR USE IN
ENTRY LNB = X   ;!  (  EXIT FROM QUIT
!?2; TRACE COUNT = 0
!?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
USER NAME = UINFS (1)
! PROCESS PARAMS
%UNLESS PARMS->INPUTFILE.(",").PARMS %THEN %START
  INPUTFILE=PARMS
  OUTPUTFILE=""
%FINISH %ELSE %START
  %UNLESS PARMS->OUTPUTFILE.(",").PARMS %THEN OUTPUTFILE=PARMS
%FINISH
!
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
%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  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; %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
%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