!
!***********************************************************************
!
!***********************************************************************
!*
!* 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)
!??; LOG("NEWACTRAM= ".SFROMI(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
!??; LOG("RAFSWITCH= ".SFROMI(FCR_RAFSWITCH))
%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 = 8
%CONSTINTEGERARRAY RESULT MAP (0:7,0:1) = %C
152, 173, 175, 176, 201, 216, 218, 273,
X'0C02',X'0C02',X'0811',X'0C06',X'0C02',X'0C02',X'0C02',X'0C03'
%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)
!??; LOG("SELRAMPPS --- ALLACT,NEWACT,ACCACT --- ")
!??; LOG(SFROMI(FCR_ALLACTIONS))
!??;LOG(SFROMI(FCR_NEWACTIONS))
!??; LOG(SFROMI(FCR_ACCACTIONS))
DERIVE RAF SWITCH (FCR_NEW ACTIONS,FCR_DATA FORMAT,X)
%IF X < 0 %THEN %RESULT = X'0902' ;! NO SUITABLE ALGORITHM
!??; LOG("X= ".SFROMI(X))
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
%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