!TITLE Creating and Connecting Files
!
! [Maintenance Note]
! In addition to procedures for creating and connecting files,this module
! also contains the procedure to complete the loading process and hence
! must come first in the load module. DIRFIX has to plant a jump
! instruction of the form X1B8000nn at the word 16 bytes from the start
! of the object file. This jump takes control to the first instruction
! in DIRLDR. nn is a number of half words, current value X32. The first
! two instructions in DIRLDR are X5883 and X6E09 respectively. DIRFIX
! also puts the length of the GLAP into the header. On entry, B either
! contains the address of a record or, for an entry to SIGNAL, is 0.
!<BADPAGE
!%externalintegerfn BAD PAGE(%integer TYPE, FSYS, BITNO)
!
! This can be called by a privileged process with TYPE = 4 to clear bit
! BITNO in the bad pages list on fsys FSYS. The result returned is the
! original value of the bit.
!>
!
! sorry about that, its for VIEW you know !
!
ROUTINE DIRLDR
EXTERNALROUTINESPEC DIRECTOR(INTEGER DR0,DR1)
CONSTINTEGER BDESC=X'18000020'
EXTERNALROUTINESPEC SIGNAL
INTEGER CODES, DR1
*STD_(LNB +3); ! PLT DESCRIPTOR
*ASF_9; ! ROOM FOR CODES
*JAF_12,<DIRECT>; ! jump if B non-zero
!
SIGNAL
*OUT_0
DIRECT:
*JLK_1
*LSS_TOS
*USH_-18
*USH_18
*ST_CODES; ! start of code segment
!
*LXN_CODES
*LDTB_X'18000000'
*LDB_(XNB +7); ! length of GLAP
*LDA_(XNB +6); ! start of GLAP
*INCA_CODES
*CYD_0
*LDA_(LNB +4); ! start of GLA
*MV_L =DR ; ! copy GLAP to GLA
!
*LSS_B
*ST_DR1
DIRECTOR(BDESC, DR1)
*OUT_0
END
!
!
!
CONSTINTEGER ALLOW IC INTS = X'FFFFF7FF'
CONSTINTEGER ALLOW STACK = X'3000'
CONSTINTEGER BADKEY = 6
CONSTINTEGER BASEFILE SEG = 32
CONSTINTEGER BATCH = 2; ! reason for STARTP
CONSTINTEGER BITKEY = 0; ! SYSAD
CONSTINTEGER CHERSH = 16; ! CODES
CONSTINTEGER COMMS = 16; ! CODES2
CONSTINTEGER DDTSTATES = X'3F0'; ! ie states 4 - 9 valid
CONSTINTEGER DEFAULT MAXFILE = 1024; ! 1megabyte
CONSTINTEGER DEFAULT MAXKB = X'8000'; ! 32 megabytes
CONSTINTEGER DIRDACT = 5; ! special director async messages
CONSTINTEGER DT = 1
CONSTINTEGER ENDLIST = 255
CONSTINTEGER EPAGE SIZE = 4
CONSTINTEGER FEP OUTPUT REPLY MESS = 51
CONSTINTEGER GRACE KIC = 3072; ! i.e. 3million instructions
CONSTINTEGER HI D SEG = 31
CONSTINTEGER INH IC INTS = X'800'; ! bit 20
CONSTINTEGER INTER = 0; ! reason for STARTP
CONSTINTEGER LEAVE = 8
CONSTINTEGER LO D SEG = 16
CONSTINTEGER LOG = 2; ! route PRINTSTRING to MAINLOG
CONSTINTEGER LOUSEG = BASEFILE SEG
CONSTINTEGER NNTKEY = 1; ! SYSAD
CONSTINTEGER NO = 0
CONSTINTEGER NO ARCH = 128
CONSTINTEGER NORMAL STACK SEG = 4
CONSTINTEGER NOT SLAVED = 1
CONSTINTEGER OFFER = 2; ! CODES
CONSTINTEGER OLDGE = 4; !CODES2
CONSTINTEGER PON AND CONTINUE = 6
CONSTINTEGER PRIVBIT = X'00040000'
CONSTINTEGER READ ACR = 5
CONSTINTEGER RESERVED = 1
CONSTINTEGER STACK = 64; ! CODES2
CONSTINTEGER STREAM CONTROL MESSAGE = X'370007'
CONSTINTEGER TEMPFI = 4; ! CODES
CONSTINTEGER TEMPFS = 12
CONSTINTEGER TOP I VALUE = 5
CONSTINTEGER TOP J VALUE = 512
CONSTINTEGER UNAVA = 1; ! CODES
CONSTINTEGER USER STOPS DACT = 67
CONSTINTEGER VEC128 = X'38000000'
CONSTINTEGER VIOLAT = 64; ! CODES
CONSTINTEGER VTEMPF = 8; ! CODES
CONSTINTEGER WRCONN = 1; ! CODES2
CONSTINTEGER WSALLOW = 8; ! CODES2
CONSTINTEGER YES = 1
! %CONSTINTEGERNAME EXPRESS = X'001C0048' ! WORD 18 OF SEG 7
!
!
!
RECORDFORMAT C
ACF(LONGINTEGER MUSECS, INTEGER PTRNS, KINSTRS)
RECORDFORMAT C
CBTF(INTEGER DA, HALFINTEGER AMTX, BYTEINTEGER TAGS, LINK)
RECORDFORMAT C
DRF(INTEGER DR0, DR1)
RECORDFORMAT C
PROPF(INTEGER TRACKS, CYLS, PPERTRK, BLKSIZE, TOTPAGES, C
RQBLKSIZE, LBLKSIZE, ALISTSIZE, KEYLEN, SECTINDX)
RECORDFORMAT C
SCTIF(INTEGER DR0, DR1); ! horizontal, I-vector, format
RECORDFORMAT C
SCTJF(INTEGER TYPE, ACR, DRDR0, DRDR1); ! vertical, J-vector, format
!
INCLUDE "PD22S_C03FORMATS"
!
!
EXTERNALINTEGERFNSPEC C
ADESTROY(STRING (31)FULL, STRING (8)DATE, INTEGER FSYS, TYPE)
EXTERNALROUTINESPEC C
COMMSCLOSEDOWN
EXTERNALROUTINESPEC C
DAP INTERFACE(INTEGER ACT)
EXTERNALINTEGERFNSPEC C
DDAP(INTEGERFN A(INTEGER A, B, C), INTEGER ACT, ADR)
EXTERNALINTEGERFNSPEC C
DDELAY(INTEGER N)
EXTERNALROUTINESPEC C
DERR2(STRING (31) S,INTEGER FN, ERR)
EXTERNALINTEGERFNSPEC C
DMAGCLAIM(STRING (6)TSN, INTEGERNAME SNO, INTEGER REQ, MODE)
EXTERNALROUTINESPEC C
DOPER2(STRING (255)S)
EXTERNALROUTINESPEC C
DOUTI(RECORD (PARMF)NAME P)
EXTERNALINTEGERFNSPEC C
DPON3I(STRING (6) USER,RECORD (PARMF)NAME P, C
INTEGER INVOC,MSGTYPE,OUTNO)
EXTERNALROUTINESPEC C
DPONI(RECORD (PARMF)NAME P)
EXTERNALROUTINESPEC C
DREPORT(STRING (255)TEMPLATE)
EXTERNALROUTINESPEC C
DRESUME(INTEGER LNB, PC, ADR18)
ROUTINESPEC C
DSTOP(INTEGER N)
EXTERNALINTEGERFNSPEC C
DUNLOCK(INTEGER ADR)
INTEGERFNSPEC C
FBASE2(INTEGER FSYS, ADR)
EXTERNALINTEGERFNSPEC C
FILE INDEX PERM(STRING (31)INDEX, INTEGER FSYS)
INTEGERFNSPEC C
HINDA(STRING (6)USER, INTEGERNAME FSYS, INDAD, INTEGER TYPE)
EXTERNALINTEGERFNSPEC C
MOVESECTION(INTEGER FSYS1, STARTP1, FSYS2, STARTP2, EPGS)
EXTERNALINTEGERFNSPEC C
NEWAINDA(STRING (18)INDEX, INTEGER FSYS, INTEGERNAME AFINDAD)
EXTERNALINTEGERFNSPEC C
S11OK(STRINGNAME S11)
EXTERNALROUTINESPEC C
STOP FEPS
EXTERNALROUTINESPEC C
SYMBOLS(INTEGER N, SYMBOL)
EXTERNALINTEGERFNSPEC C
UFO(STRING (31)USER, FILE, STRINGNAME UNAME, INAME, FNAME, INDEX, FULL)
EXTERNALINTEGERFNSPEC C
UIO(STRING (31)USER, STRINGNAME UNAME, INAME, INDEX)
!
!
!
!
EXTRINSICINTEGER ACCTSA
EXTRINSICINTEGER AEXPRESS
EXTRINSICINTEGER AQD
EXTRINSICINTEGER AREVS
EXTRINSICINTEGER ASYNC INHIB
EXTRINSICINTEGER BLKSI
EXTRINSICINTEGER CBTA0
EXTRINSICINTEGER CBTASL0
EXTRINSICINTEGER DAP STATE
EXTRINSICINTEGER D CALLERS ACR; ! SET BY FN IN2
EXTRINSICINTEGER D CALLERS PSR
EXTRINSICINTEGER DEFAULT SS ACR
EXTRINSICINTEGER DINSTRS
EXTRINSICINTEGER DIRFLAG
EXTRINSICINTEGER DIRFN
EXTRINSICINTEGER DIRLEVEL
EXTRINSICINTEGER DIRLOGAD
EXTRINSICINTEGER DIRMON
EXTRINSICINTEGER D TRYING
EXTRINSICINTEGER ENDSST
EXTRINSICINTEGER FACILITYA
EXTRINSICINTEGER FSYS WARN
EXTRINSICINTEGER GOTSEMA
EXTRINSICINTEGER HISEG
EXTRINSICINTEGER HOTTOPA
EXTRINSICINTEGER HOTTOPN
EXTRINSICINTEGER INVOC; ! >=0
EXTRINSICINTEGER LOG ACTION
EXTRINSICINTEGER OUTPAD
EXTRINSICINTEGER OWNIND
EXTRINSICINTEGER PAGEMON
EXTRINSICINTEGER PROCESS
EXTRINSICINTEGER PROCFSYS
EXTRINSICINTEGER SAINDAD
EXTRINSICINTEGER SCTIAD
EXTRINSICINTEGER SEMADDRHELD
EXTRINSICINTEGER SEMANOHELD
EXTRINSICINTEGER SESSINSTRS
EXTRINSICINTEGER SESSKIC
EXTRINSICINTEGER SIGMO
EXTRINSICINTEGER SST0
EXTRINSICINTEGER TAPES CLAIMED
OWNINTEGERARRAY DIRFNS(1:16)
!
!
!
CONSTRECORD (DIROWNF)NAME DIROWN = X'C3000'
CONSTRECORD (UINFF)NAME UINF = 9<<18
!
EXTRINSICSTRING (23)LOUTPSTATE
EXTRINSICSTRING ( 6)PROCUSER
EXTRINSICSTRING (18)SELECTED INDEX
EXTRINSICSTRING (127)SELECTED NODE
EXTRINSICRECORD (FDF)LASTFD
EXTRINSICRECORD (PARMF)LOUTP
!
!
!
RECORDFORMAT STE(INTEGER APFLIM,USERA)
OWNRECORD (STE)ARRAYFORMAT STF(0:255)
OWNRECORD (STE)ARRAYNAME ST
!
RECORDFORMAT HOTTOPF(STRING (18)INDEX, BYTEINTEGER FSYS, INTEGER PT)
OWNRECORD (HOTTOPF)ARRAYFORMAT HOTTOPFS(0:1023)
OWNRECORD (HOTTOPF)ARRAYNAME HOTTOP
OWNINTEGER HOTTOPADR = 0
!
!-----------------------------------------------------------------------
!
OWNRECORD (CBTF)ARRAYFORMAT CBTAF(0:512)
OWNRECORD (CBTF)ARRAYNAME CBTA
OWNINTEGER CBT1, CBT2, CBTOP
OWNBYTEINTEGERARRAYNAME SSTB
OWNHALFINTEGERARRAYNAME SSTH
OWNBYTEINTEGERARRAYFORMAT BIFT(0:255)
OWNHALFINTEGERARRAYFORMAT HIFT(0:1023)
OWNINTEGERARRAYFORMAT IFT(0:254)
!
EXTRINSICBYTEINTEGERARRAY FSYS USECOUNT(0:99)
!
OWNINTEGER SEARCHENT=0; ! CONLIST(0) is not used, and CONLIST(1) contains "reserved".
EXTERNALRECORD (DRF)ARRAY DRS LOCKED(0:2)
OWNINTEGERARRAY SEGUSE(16:31) = -2(16); ! TO RECORD USE OF DIRECTORS INDEX SEGMENTS
OWNRECORD (ACF)NAME ACCTS
OWNRECORD (ACF)PREVA
!
!
OWNINTEGER SESSION PENCE = -1
!
!
!-----------------------------------------------------------------------
!
ROUTINE DMONW(BYTEINTEGER FLAG, SEG, STRING (63)FILE)
INTEGER J
RECORDFORMAT HF(INTEGER NEXT, RELST, MAX, A, B, C, CYCLIC, C
READ)
RECORD (HF)NAME H
RETURN IF PAGE MON = 0
H == RECORD(PAGE MON)
J = H_NEXT
RETURN UNLESS J+16 < H_MAX; ! not enough for 3 long ints
H_NEXT = J + 24
J = PAGE MON + J
BYTEINTEGER(J) = FLAG
BYTEINTEGER(J+1) = SEG
LENGTH(FILE) = 21 IF LENGTH(FILE) > 21
STRING(J+2) = FILE
END
!
!
!
EXTERNALSTRINGFN HTOS(INTEGER VALUE, PLACES)
INTEGER I
STRING (8)S
CONSTBYTEINTEGERARRAY H(0:15) = C
'0', '1', '2', '3', '4', '5', '6', '7',
'8', '9', 'A', 'B', 'C', 'D', 'E', 'F'
PLACES = 8 IF PLACES > 8
I = 64 - 4 * PLACES
*LD_S
*LSS_PLACES
*ST_(DR )
*INCA_1
*STD_TOS
*STD_TOS
*LSS_VALUE
*LUH_0
*USH_I
*MPSR_X'24'
*SUPK_L =8
*LD_TOS
*ANDS_L =8,0,15
*LSS_H+4
*LUH_X'18000010'
*LD_TOS
*TTR_L =8
RESULT = S
END
!
!-----------------------------------------------------------------------
!
EXTERNALSTRINGFN ITOS(INTEGER N)
STRING (16)S
INTEGER D0, D1, D2, D3
*LSS_N
*CDEC_0
*LD_S
*INCA_1
*CPB_B
*SUPK_L =15,0,32
*STD_D2
*JCC_8,<WASZERO>
*LSD_TOS
*ST_D0
*LD_S
*INCA_1
*MVL_L =15,15,48
BYTEINTEGER(D1) = '-' AND D1 = D1 - 1 IF N < 0
BYTEINTEGER(D1) = D3 - D1 - 1
RESULT = STRING(D1)
WASZERO:
RESULT = "0"
END
!
!-----------------------------------------------------------------------
!
EXTERNALINTEGERFN EQUAL(STRINGNAME NAME1, NAME2)
INTEGER L, A1, A2
! result is 1 if equivalent else 0
!
L = LENGTH(NAME1)
RESULT = 0 UNLESS L = LENGTH(NAME2)
RESULT = 1 IF L = 0; ! used to compare index names which are ususally 0
!
A1 = ADDR(NAME1) + 1
A2 = ADDR(NAME2) + 1
!
*LDTB_X'18000000'
*LDB_L
*LDA_A1
*STD_TOS
*LSD_TOS
*LDA_A2
*CPS_L =DR ,32,0
*JCC_8,<EQUIV>
RESULT = 0
EQUIV:
RESULT = 1
END ; ! EQUAL
!
!-----------------------------------------------------------------------
!
EXTERNALROUTINE WRS(STRING (255)S)
PRINTSTRING(S)
NEWLINE
END ; ! OF WRS
!
!-----------------------------------------------------------------------
!
EXTERNALROUTINE WRSS(STRING (255)S1, S2)
PRINTSTRING(S1)
PRINTSTRING(S2)
NEWLINE
END ; ! OF WRSS
!
!-----------------------------------------------------------------------
!
EXTERNALROUTINE WRSNT(STRING (255)S, INTEGER N, TYPE)
INTEGER J
SWITCH SW(0:3)
!
! type & 3 = 0 decimal if small else hex
! 1 decimal
! 2 hex
! 3 decimal and hex
! type & 4 = 1 dont put NL at end
! type & X70 gives number of digits, 0=8
PRINTSTRING(S)
SPACE
-> SW(TYPE & 3)
SW(0): -> SW(2) UNLESS -256 <= N <= 255
SW(3):
SW(1): PRINTSTRING(ITOS(N))
-> OUT IF TYPE & 2 = 0
SW(2): PRINTSTRING("X'")
J = TYPE >> 4 & 7
J = 8 IF J = 0
PRINTSTRING(HTOS(N, J))
OUT:
NEWLINE IF TYPE & 4 = 0
END ; ! OF WRSNT
!
!-----------------------------------------------------------------------
!
EXTERNALROUTINE WRSN(STRING (255)S, INTEGER N)
PRINTSTRING(S)
SPACE
WRITE(N, 1)
NEWLINE
END ; ! WRSN
!
!-----------------------------------------------------------------------
!
EXTERNALROUTINE WRS3N(STRING (255)S1, S2, S3, INTEGER N)
PRINTSTRING(S1); SPACE
PRINTSTRING(S2); SPACE
PRINTSTRING(S3); SPACE
WRITE(N, 1)
NEWLINE
END ; ! WRS3N
!
!-----------------------------------------------------------------------
!
ROUTINE PRX(INTEGER I,PL)
SPACES(1)
PRINTSTRING(HTOS(I,PL))
END ; ! PRX
!
!-----------------------------------------------------------------------
!
EXTERNALROUTINE ACTIVE BLOCK(STRING (31)FN, FULL, INTEGER FSYS)
WRS3N(FN, " BLOCK STILL ACTIVE ", FULL, FSYS)
! DIRMON = -1
END ; ! OF ACTIVE BLOCK
!
!-----------------------------------------------------------------------
!
EXTERNALINTEGERFN SST(INTEGER N)
IF CBTOP > 255 C
THEN RESULT = SSTH(N) C
ELSE RESULT = SSTB(N)
END
!
!
!
EXTERNALROUTINE SETSST(INTEGER N, VALUE)
IF CBTOP > 255 C
THEN SSTH(N) = VALUE C
ELSE SSTB(N) = VALUE
END
!
!
!
EXTERNALROUTINE INIT CBT
!
! With BLOCKSIZE=32 Epages (128K) a segment requires at most 2 CBT
! entries. The CBT is therefore arranged with all single entries
! packed at the front and all double entries packed at the back.
! Two pointers are maintained, CBT1 and CBT2 to the single and
! double entries adjacent to the free space in the middle. There
! is always at least one single DIRGLA and one double DIRCODE entry.
! The CBT is re-organised to this form at the first call of
! DISC SEG CONNECT (called by DIRECTOR to connect the SCT). We
! assume the initial status of the CBT and SST is
! SEGS 0, 1, 5 to 255 not used
! SEG2, DIRCODE, CBT entries 0 and 1
! SEG3, DIRGLA, CBT enty 2
! SEG4, normal stack segment(32 to 63 Epages) CBT entry 3
! CBTASL points to CBT entry 4, the head of the free chain
!
!
! Intend to replace 'LINK' by 'FLAGS'
! where
! 2**7 set=this block is a continuation block
! 6 advisory sequential, all blocks of file
!
INTEGER THIS, NEXT
!
!
ST == ARRAY(0, STF)
SSTB == ARRAY(SST0, BIFT)
SSTH == ARRAY(SST0, HIFT)
CBTA == ARRAY(CBTA0, CBTAF)
IF CBTASL0 >> 18 = 0 C
THEN NEXT = CBTASL0 C
ELSE NEXT = INTEGER(CBTASL0)
!
IF NEXT > 4 THEN THIS = NEXT ELSE START
WHILE NEXT # ENDLIST CYCLE
THIS = NEXT
CBTA(THIS)_DA = 0
NEXT = CBTA(NEXT)_LINK
REPEAT
FINISH
!
CBT2 = THIS - 1; ! LAST DOUBLE ENTRY
ENDSST = 255
ENDSST = X'FFFF' IF CBT2 > 255
CBTOP = CBT2 - 2; ! WHERE TO START LOOKING FOR A FREE DOUBLE ENTRY
CBT1 = 1; ! LAST SINGLE ENTRY
!
RETURN IF SST(3) = 0; ! New format has been set up by Supervisor
!
CBTA(CBT2) = CBTA(0); ! DIRCODE SEGMENT - 2 ENTRIES
CBTA(CBT2)_LINK = 0
CBTA(CBT2+1) = CBTA(1)
CBTA(CBT2+1)_LINK = 128; ! continuation block
SETSST(2, CBT2)
!
CBTA(0) = CBTA(2); ! DIR GLA - 1 ENTRY
CBTA(0)_LINK = 0
SETSST(3, 0)
!
CBTA(1) = CBTA(3); ! STACK
CBTA(1)_LINK = 0
SETSST(4, 1)
!
! OBSERVE THAT THERE WILL ALWAYS BE AT LEAST ONE SINGLE (DIRGLA) AND
! ONE DOUBLE (DIRCODE) CBT ENTRY
END ; ! OF INIT NEW CBT
!
!-----------------------------------------------------------------------
!
INTEGERFN GET1
INTEGER C
C = 2; ! LOWEST POSSIBLE FREE ENTRY
LOOP:
-> NO UNLESS CBTA(C)_DA = 0
CBT1 = C IF CBT1 < C
CBTA(C)_LINK = 0
RESULT = C
NO:
C = C + 1
-> LOOP UNLESS C >= CBT2
RESULT = -1
END
!
!
!
INTEGERFN GET2
INTEGER C
C = CBTOP; ! HIGHEST POSSIBLE FREE ENTRY
LOOP:
-> NO UNLESS CBTA(C)_DA = 0 AND CBTA(C+1)_DA = 0
CBT2 = C IF CBT2 > C
CBTA(C)_LINK = 0
CBTA(C+1)_LINK = 0
RESULT = C
NO:
C = C - 2
-> LOOP UNLESS C <= CBT1
RESULT = -1
END
!
!-----------------------------------------------------------------------
!
ROUTINE RECOVER CBT(INTEGER C)
!
CBTA(C)_DA = 0
CBTA(C+1)_DA = 0 UNLESS C < CBT2
END ; ! OF RECOVER CBT
!
!-----------------------------------------------------------------------
!
EXTERNALROUTINE FILL(INTEGER LENGTH,FROM,FILLER)
RETURN UNLESS LENGTH > 0
!
*LDTB_X'18000000'
*LDB_LENGTH
*LDA_FROM
*LB_FILLER
*MVL_L =DR
END ; ! OF FILL
!
!-----------------------------------------------------------------------
!
EXTERNALROUTINE MOVE(INTEGER LENGTH, FROM, TO)
RETURN UNLESS LENGTH > 0
!
*LDTB_X'18000000'
*LDB_LENGTH
*LDA_FROM
*CYD_0
*LDA_TO
*MV_L =DR
END ; ! OF MOVE
!
!-----------------------------------------------------------------------
!
EXTERNALINTEGERFN PACKDT
! Result is DATE and TIME packed
! into a word :
! Y-70(6)M(4)D(5)H(5)M(6)S(6)
BYTEINTEGERARRAYNAME X
BYTEINTEGERARRAYFORMAT XF(0:255)
X == ARRAY(X'80C00040', XF)
!
RESULT = (10*X(6) + X(7) - 86) << 26 ! C
(10*(X( 3)&15)+(X( 4)&15)) << 22 ! C
(10*(X( 0)&15)+(X( 1)&15)) << 17 ! C
(10*(X(12)&15)+(X(13)&15)) << 12 ! C
(10*(X(15)&15)+(X(16)&15)) << 6 ! C
(10*(X(18)&15)+(X(19)&15))
END ; ! OF PACKDT
!
!-----------------------------------------------------------------------
!
INTEGERFN DRANDOM(INTEGER N)
! PRODUCES A RANDOM NUMBER IN RANGE 0-N
! WHERE N IS 2**M - 1
*RRTC_0
*STUH_B
*AND_N
*EXIT_-64
END ; ! OF DRANDOM
!
!-----------------------------------------------------------------------
!
INTEGERFN DIRAPF
INTEGER ACR
*LSS_(LNB +1); ! BITS 8-11 OF THIS WORD HAVE CURRENT ACR
*ST_ACR
ACR=(ACR>>20) & 15
RESULT =X'100' ! (ACR<<4) ! READ ACR
END ; ! DIRAPF
!
!-----------------------------------------------------------------------
!
EXTERNALROUTINE GIVE APF(INTEGERNAME SAPF,NOTDRUM,SLAVED, C
INTEGER SEG)
! ASSUMES SEG CONNECTED. RETURNS APF OF THE SEG, AND NOTDRUM IS SET
! NON-ZERO IF FILE IS NOT TO HAVE DRUM ALLOCATION, ELSE ZERO
INTEGER TAGS,CELL
CELL=SST(SEG)
TAGS=CBTA(CELL)_TAGS
SAPF=(ST(SEG)_APFLIM>>20) & X'1FF'
NOTDRUM=TAGS & B'01000000'
SLAVED=ST(SEG)_APFLIM & X'20000000'; ! NON-SLAVED BIT
END ; ! GIVE APF
!
!-----------------------------------------------------------------------
!
EXTERNALINTEGERFN HASH(STRING (6)USER, INTEGER NNTHASH)
INTEGER A, J, W
CONSTINTEGERARRAY P(1:6) = 157, 257, 367, 599, 467, 709
A = ADDR(USER)
W = 0
CYCLE J = 1, 1, 6
W = W + (BYTEINTEGER(A+J) - 47) * P(J)
REPEAT
W = W - (W//NNTHASH)*NNTHASH
W = W + NNTHASH IF W < 0; ! just in case gash characters get through
RESULT = W
END ; ! HASH
!
!-----------------------------------------------------------------------
!
EXTERNALINTEGERFN VAL(INTEGER ADR,LEN,RW,PSR)
! RESULT = 1 AREA OK (ACCESSIBLE)
! 0 AREA NOT OK (INACCESSIBLE)
!
! RW SHOULD BE SET 0 (READ ACCESS)
! OR 1 (WRITE ACCESS)
!
! PARAM PSR IS USED IN THE VALIDATE, BUT IF ZERO, THE
! PSR OF THE CALLING ROUTINE IS USED
INTEGER INSEG0,BEYOND SEG0,SEG0,SEG0 AD
INTEGER DR0
SEG0=ADR>>18
RESULT =0 UNLESS 0<LEN<=32<<18; ! reject unreasonable values outright (e.g. > 32 segments)
IF PSR=0 START ; *LSS_(LNB +1); *ST_PSR; FINISH
IF SEG0 # (ADR+LEN-1)>>18 START
SEG0 AD=SEG0<<18
INSEG0=X'40000' - (ADR-SEG0 AD)
BEYOND SEG0=LEN - INSEG0
RESULT =VAL(ADR,INSEG0,RW,PSR) & C
VAL(ADR+INSEG0,BEYOND SEG0,RW,PSR)
FINISH
! WE SHOULD ALSO CHECK THAT THE AREA LIES WITHIN USER SEGMENTS, AND
! NOT IN ANY HIGHER ACR SEGMENTS AS WELL.
DR0=X'18000000' ! LEN
*LDTB_DR0
*LDA_ADR
*VAL_PSR
*JCC_8,<CCZER>
*JCC_4,<CCONE>
*JCC_2,<CCTWO>
! THEN CC=3, INVALID
RESULT =0
CCZER: ! READ AND WRITE PERMITTED
RESULT =1; ! OK
CCONE: ! READ, BUT NOT WRITE, PERMITTED
IF RW=1 THEN RESULT =0; ! BAD
RESULT =1; ! OK
CCTWO: ! WRITE, BUT NOT READ, PERMITTED
RESULT =0; ! BAD
END ; ! VAL
!
!-----------------------------------------------------------------------
!
ROUTINE SETIC(INTEGER KINSTRUCTIONS)
INTEGER(AREVS)=KINSTRUCTIONS>>14
KINSTRUCTIONS=KINSTRUCTIONS<<18>>8
*LSS_KINSTRUCTIONS
*ST_(6); ! IMAGE STORE 6 = IC
END ; ! SETIC
!
!-----------------------------------------------------------------------
!
EXTERNALINTEGERFN GETIC
INTEGER INSTRUCTIONS, CARRYREVS, NET
*LSS_(6); ! IMAGE STORE 6 = IC
*ST_INSTRUCTIONS
CARRYREVS = (INSTRUCTIONS >> 24) & 1
NET = INTEGER(AREVS) - CARRYREVS
RESULT = (NET << 14) ! (INSTRUCTIONS << 8 >> 18); ! ie thousands of instructions
END ; ! GETIC
!
!-----------------------------------------------------------------------
!
EXTERNALINTEGERFN DDAYNUMBER
! gives a number which increases by 1 each day. mod 7 -> mon=0 etc
CONSTLONGINTEGER JMS = X'141DD76000'
*RRTC_0
*USH_-1
*SHS_1
*USH_1
*IDV_JMS
*STUH_B
*EXIT_-64
END ; ! DDAYNUMBER
!
!-----------------------------------------------------------------------
!
INTEGERFN GETIT
INTEGER ITUNITS,J
IT AGAIN:
*LSS_(3); ! SSR
*ST_J
*LSS_(5); ! IT REGISTER
*ST_ITUNITS
! This bit should not be set ever, when Director is executing, because
! the interrupt isn't then masked and an interrupt should take control
! immediately to the local controller. However, the bit has repeatedly
! been observed here on 2960 and 2970.
IF ITUNITS>>24#0 THEN -> IT AGAIN
RESULT =COM_ITINT*ITUNITS; ! IE. MICROSECONDS
END ; ! GETIT
!
!-----------------------------------------------------------------------
!
EXTERNALINTEGERFN FUNDS(INTEGERNAME GPINDAD,INTEGER INDAD)
! This function delivers the no of resource units to which the user owning
! index at INDAD has access. If the user has a "group resource-unit" holder,
! the parameter GPINDAD is set to the address of the group-holder's index
! (else to the value of INDAD).
INTEGER FSYS,J, IAD, GPIAD, NUTS
STRING (31) GPH
RECORD (HF)NAME NH
IAD = INDAD
L:
NH == RECORD(IAD)
NUTS = NH_INUTS
-> OUT IF NH_GPHOLDR = ""
NUTS = 0
GPH <- NH_GPHOLDR
FSYS = NH_GPFSYS
J = HINDA(GPH, FSYS, GPIAD, 0)
UNLESS J = 0 START
FSYS = -1
J = HINDA(GPH, FSYS, GPIAD, 0)
NH_GPFSYS = FSYS IF J = 0
FINISH
!
-> OUT IF J > 0
IAD = GPIAD
-> L
OUT:
GPINDAD = IAD
RESULT = NUTS
END ; ! FUNDS
!
!-----------------------------------------------------------------------
!
EXTERNALROUTINE IUPDATE(INTEGER MODE,NEWCOUNT)
! MODE = -2 INITIALISE INDEX FOR SESSION
! MODE = -1 OUT OF DIRECTOR
! 0 IN OR INTO USER
! 1 INTO DIRECTOR
!
! WHEN CALLED WITH MODE -1, DO NOT UPDATE DIRECTOR RECORD UNLESS
! PREVIOUS MODE WAS 1 (WE DO NOT ATTEMPT TO RECORD EVERY EXIT FROM
! DIRECTOR).
RECORD (HF)NAME NH
LONGINTEGER TSINCELAST,TNOW
INTEGER PSINCELAST,ISINCELAST,PNOW,INOW,J,NEWT,NEWP,NEWC,NEWI,MSG
INTEGER DPENCE,CT SINCELAST,GPINDAD
INTEGERNAME HINSTRS,HPTRNS,HMSECS,HCONNECTT
OWNINTEGER INIT=0,PREV FRMN
OWNINTEGER PFACTOR = 0; ! TO IMPLEMENT PRIORITY IN ACCOUNTING FIELDS
!
!
!
RETURN IF OWNIND=0; ! SKIP UNTIL OWNIND SET UP AND FOR PROCESS1
!
MSG=0
NH == RECORD(OWNIND)
! I had to put this INIT in when we started to put the PREVIC value
! into the UINF segment: we call IUPDATE lots of times before getting
! that segment set up.
IF MODE=-3 START
J=PACKDT
!
SIGMO = NH_SIGMON
NH_SIGMON = 0
IF UINF_REASON = INTER C
THEN NH_LASTLOGON = J C
ELSE NH_LAST NON INT START = J
!
INIT=1
RETURN
FINISH
!
IF MODE=-2 START
ACCTS==RECORD(ACCTSA)
INTEGER(AREVS)=X'FFFF'
!
PREVA_MUSECS=ACCTS_MUSECS-GETIT
PREVA_PTRNS=ACCTS_PTRNS
!
PREV FRMN=COM_SECSFRMN
RETURN
FINISH
!
IF INIT=0 THEN RETURN
!
! Initialisation entries previously completed
!
IF SESSION PENCE < 0 START
SESSION PENCE = 0; ! Any charges incurred during periods of scarcity
! are accumulated in this own integer
!
! initialised to -1
!
UINF_FUNDS = FUNDS(GPINDAD, OWNIND)
IF UINF_REASON = BATCH ANDC
UINF_PRIORITY < 3 C
THEN PFACTOR = 1
FINISH
!
HCONNECTT == NH_CONNECTT
IF UINF_REASON = BATCH START
HINSTRS == NH_BINSTRS
HPTRNS == NH_BPTRNS
HMSECS == NH_BMSECS
FINISH ELSE START
HINSTRS == NH_IINSTRS
HPTRNS == NH_IPTRNS
HMSECS == NH_IMSECS
FINISH
!
INOW=GETIC
UINF_PREVIC=INOW IF UINF_PREVIC<INOW; ! PREVIC os zero at initialisation
ISINCELAST=UINF_PREVIC - INOW
UINF_PREVIC=INOW
!
TNOW=ACCTS_MUSECS - GETIT
TSINCELAST=(TNOW - PREVA_MUSECS)//1000
! A process start-up glitch in the sums somewhere:
IF 0>TSINCELAST>=-200 THEN TSINCELAST=0
! THE CONDITION BELOW FAILS ONLY IF WE GET TIME-SLICED BETWEEN
! READING IT AND SUBTRACTING THE RESULT OF THE FUNCTION GETIT FROM
! ACCTS_MUSECS
PREVA_MUSECS=TNOW IF TNOW>PREVA_MUSECS
!
PNOW=ACCTS_PTRNS
PSINCELAST=PNOW - PREVA_PTRNS
PREVA_PTRNS=ACCTS_PTRNS
IF MODE<0 THEN DINSTRS=DINSTRS+ISINCELAST
NEWI=HINSTRS + ISINCELAST >> PFACTOR
NEWT=HMSECS + TSINCELAST >> PFACTOR
NEWP=HPTRNS + PSINCELAST >> PFACTOR
CT SINCELAST=COM_SECSFRMN - PREV FRMN
PREV FRMN=COM_SECSFRMN
IF CT SINCELAST<0 THEN CT SINCELAST=CT SINCELAST+24*60*60
NEWC=HCONNECTT
IF UINF_REASON#BATCH THEN NEWC=NEWC+CT SINCELAST
! PREVENT OVERFLOW. ACCNTS SHOULD HAVE TAKEN IT BY NOW !
IF NEWI>>29#0 THEN MSG=1 AND NEWI=0
IF NEWT>>29#0 THEN MSG=2 AND NEWT=0
IF NEWP>>29#0 THEN MSG=3 AND NEWP=0
IF NEWC>>29#0 THEN MSG=4 AND NEWC=0
HINSTRS=NEWI
SESSINSTRS=SESSINSTRS + ISINCELAST
ACCTS_KINSTRS=SESSINSTRS
HMSECS=NEWT
HPTRNS=NEWP
HCONNECTT=NEWC
!
! Decrement Scarcity Ration according to site charging formula if we
! are in a time of scarcity.
! IF:
! no of interactive users >= current "scarcity" setting
IF COM_RATION&255 >= COM_RATION>>24 C
AND C
(UINF_REASON=INTER C
OR C
(UINF_REASON = BATCH AND UINF_PRIORITY > 3) ) C
START
!--------------------------------------------------------------------------------
!
! Site Formulae
!
!
DPENCE = 0; ! in hundredths of pence
!
IF COM_OCPTYPE = 2 C {KENT}
THEN DPENCE = INT(385 * (I SINCE LAST/COM_KINSTRS + C
P SINCE LAST/250 + CT SINCE LAST/60))
!
IF COM_OCPTYPE = 4 C {2988 see Newsletter July '83}
THEN DPENCE = INT(650 * (I SINCE LAST/COM_KINSTRS + C
P SINCE LAST/700))
!
IF 5 <= COM_OCPTYPE <= 6 C {2972}
THEN DPENCE = INT(850 * (I SINCE LAST/COM_KINSTRS + C
P SINCE LAST/600))
!
!----------------------------------------------------------------------------
!
SESSION PENCE = SESSION PENCE + DPENCE
!
J = UINF_FUNDS - DPENCE
J = 0 IF J < 0
UINF_FUNDS = J; ! Note: the group holders figure is not adjusted until end of session
!
FINISH
IF NEWCOUNT>0 START
SETIC(NEWCOUNT)
UINF_PREVIC=NEWCOUNT
FINISH
IF MSG#0 THEN WRSN("IUPDATE", MSG)
END ; ! IUPDATE
!
!-----------------------------------------------------------------------
!
EXTERNALINTEGERFN IN2(INTEGER FN)
INTEGER SF, STACKSEG, SEGLIM, LNBHERE, J
DIRLEVEL = DIRLEVEL + 1
IF 1 <= DIRLEVEL <= 16 C
THEN DIRFNS(DIRLEVEL) = FN C
ELSE WRSN("IN2: Dirlevel? ", DIRLEVEL) AND RESULT = 8
!
UNLESS FACILITY A = 0 START
J = FACILITY A + (FN&255) << 2
*LXN_J
*INCT_(XNB +0)
FINISH
!
*STLN_LNBHERE
D CALLERS PSR = INTEGER(INTEGER(LNBHERE) + 4)
D CALLERS ACR = D CALLERS PSR << 8 >> 28
!
RESULT = 0 IF FN > 255; ! set '256' bit for 'dont inhibit'
!
*LSS_(3)
*OR_INH IC INTS
*ST_(3)
!
ASYNC INHIB = ASYNC INHIB + 1
!
*STSF_SF; ! CHECK ENOUGH STACK
STACKSEG = SF >> 18
SF = SF & X'3FFFC'
SEGLIM = (ST(STACKSEG)_APFLIM & X'3FF80') ! X'7F'
RESULT = 47 UNLESS SF + ALLOW STACK < SEGLIM
!
IUPDATE(1, 0)
!
RESULT = 0
END ; ! IN2
!
!-----------------------------------------------------------------------
!
EXTERNALINTEGERFN OUT(INTEGER FLAG, STRING (63)TEMPLATE)
INTEGER FN, LNB, LNB1, GLA, T
FN = 0
IF 1 <= DIRLEVEL <= 16 C
THEN FN = DIRFNS(DIRLEVEL) C
ELSE WRSN("OUT: Dirlevel? ", DIRLEVEL)
DIRLEVEL = DIRLEVEL - 1
!
IF FN < 256 START
ASYNC INHIB = ASYNC INHIB - 1; ! un-inhibit
IF ASYNC INHIB <= 0 START ; ! and take any async messages
DRESUME(-4, 0, 0) UNLESS AQD = 0
!
*LSS_(3); ! SSR
*AND_ALLOW IC INTS; ! UNINHIBIT IC INTERRUPTS
*ST_(3)
!
IF ASYNC INHIB < 0 THEN WRS("OUT: ASYNC INHIB < 0")
!
! IUPDATE(-1, 0)
FINISH
FINISH
!
*STLN_LNB
LNB1 = INTEGER(LNB)
GLA = INTEGER(LNB1 + 16)
T = INTEGER(LNB1 + 12) << 8 >> 8
DIRFN = T + INTEGER(GLA + 12) + 12
DIRFLAG = FLAG
DREPORT(TEMPLATE) UNLESS DIRMON = 0 OR TEMPLATE = "NIL"
RESULT = FLAG
END ; ! OUT
!
!-----------------------------------------------------------------------
!
EXTERNALINTEGERFN DDT ENTRY(INTEGERNAME ENTAD,INTEGER FSYS)
INTEGER J,FS,DLVN
INTEGERARRAYNAME DIT
BYTEINTEGERARRAYNAME DLVNA
RECORD (DDTF)NAME DDT
INTEGERARRAYFORMAT DITF(0:COM_NDISCS-1)
DLVNA==ARRAY(COM_DLVNADDR,DLVNAF)
DIT==ARRAY(COM_DITADDR,DITF)
IF 0<=FSYS<=99 START
J=DLVNA(FSYS); ! pick up DIT entry number for FSYS
IF J<=250 START
DDT == RECORD(DIT(J))
DLVN=DDT_DLVN
FS=DLVN<<2>>2
IF (1<<DDT_STATE) & DDTSTATES > 0 AND FSYS=FS START
ENTAD=ADDR(DDT)
RESULT = 0
FINISH
FINISH
FINISH
RESULT = 23
END ; ! DDT ENTRY
!
!-----------------------------------------------------------------------
!
EXTERNALINTEGERFN DISC USE COUNT(INTEGER FSYS, INCR)
!
! 2**31 0=cck'd 1=not checked
! 2**30 0=available 1=closing
!
INTEGER ADR, J, C
BYTEINTEGERNAME N
RECORD (DDTF)NAME DDT
RESULT = 8 UNLESS INCR = 1 OR INCR = -1
!
J = DDT ENTRY(ADR, FSYS)
RESULT = J UNLESS J = 0
!
DDT == RECORD(ADR)
ADR = ADDR(DDT_CONCOUNT)
N == FSYSUSECOUNT(FSYS)
!
IF INCR = 1 START
N = N + 1
*LXN_ADR
*INCT_(XNB +0)
RESULT = 0
FINISH
!
IF N = 0 START ; ! !OOPS
DOPER2("Negative count on " . ITOS(FSYS))
RESULT = 6
FINISH
!
N = N - 1
*LXN_ADR
*TDEC_(XNB +0)
*ST_C; ! original value
IF C > 0 START ; ! we haven't made it negative
IF C = 1 AND DDT_DLVN << 1 < 0 START ; ! count now zero and
! fsys closing
DOPER2("Disc " . ITOS(FSYS) . " now free")
DDT_DLVN = (DDT_DLVN << 2 >> 2) ! (1 << 31); ! disc reverts to
! 'not-checked',
! 'available'
FINISH
RESULT = 0
FINISH
!
DOPER2("Negative sys count on " . ITOS(FSYS))
*LXN_ADR
*INCT_(XNB +0); ! put it back, Supervisor doesn't like if < 0
RESULT = 6
END ; ! DISC USE COUNT
!
!-----------------------------------------------------------------------
!
INTEGERFN DSEGMENT(INTEGER SEG,DSTRY)
! REQUESTS THE LOCAL CONTROLLER TO REMOVE ACTIVE MEMORY
! TABLE ENTRIES FOR SEGMENT SEG
RECORD (PARMF)NAME P
INTEGER J
P==RECORD(OUTPAD)
P=0
P_P1=SEG
P_P2=DSTRY
*OUT_3; ! SET P_P2=1 FOR "DESTROYING SEGMENT"
J = P_DEST
IF J=-1 THEN WRS("DSEGMENT")
RESULT = J
END ; ! DSEGMENT
!
!-----------------------------------------------------------------------
!
EXTERNALROUTINE DCHAIN(INTEGER SEG,DSTRY)
! Removes blocks for segment SEG from active memory and de-chains the
! CBT entries (putting them on the free list).
INTEGER CELL, J
CELL=SST(SEG)
IF CELL=ENDSST THEN RETURN
IF LODSEG<=SEG<=HIDSEG THEN C
J = DISC USE COUNT(CBTA(CELL)_DA>>24,-1)
J = DSEGMENT(SEG,DSTRY)
IF J = -1 START
WRSNT("DCHAIN SEG", SEG, 5)
WRSN(" CELL", CELL)
FINISH
! CBT ENTRIES BACK TO FREE LIST
SETSST(SEG, ENDSST)
RECOVER CBT(CELL)
! CLEAR APF FIELD IN SEGMENT TABLE, BECAUSE 'VAL' WORKS ON IT,
! IRRESPECTIVE OF WHETHER THE ENTRY IS OTHERWISE VALID !
*LSS_(1); ! pick up PSR
*AND_X'FF0FFFFF'; ! remove ACR bits
*OR_X'00100000'; ! set ACR to one
*ST_(1); ! and put it back
ST(SEG)_APFLIM=ST(SEG)_APFLIM & X'E00FFFFF'; ! REMOVE APF FIELD
END ; ! DCHAIN
!
!-----------------------------------------------------------------------
!
EXTERNALINTEGERFN SYSBASE(INTEGERNAME SYSTEM START, INTEGER FSYS)
INTEGER J, ENTAD
RECORD (DDTF)NAME DDT
J = DDT ENTRY(ENTAD, FSYS)
IF J = 0 START
DDT == RECORD(ENTAD)
SYSTEM START = DDT_SBASE; ! this is the origin of 'fixed' sites for Supervisor etc
FINISH
RESULT = J
END ; ! SYSBASE
!
!-----------------------------------------------------------------------
!
EXTERNALINTEGERFN PP(INTEGER SEMADDR,SEMANO, STRING (63)S)
! Four things get semaphored:
! file indexes/bitmap
! arch index
! #MSG
! #DIRLOG
!
! PP is called from
!
! CONN
! DGETDA
! DCHACCESS
! DCONNECTI
! DDDISCONNECTI
! DCHSIZE
! SMALLOC
! DEAL
! RETLIST
! DCREATEF
! DDESTROYF
! DRENAME
! DNEWGEN
! DIRECT
! TXTMESS
! DPERMISSIONI
! DFINFO
! DFSTATUS
! DSFI
! DOFFER
! DTRANSFER
! ARCHRECORD
! OFILES
! XOP
! D/PP
! MAG
! DPRGP
! GIVENEWSECTION
! DSYSAD
! DINDEX2
! DINDEX (OBSOLETE)
! PRINTSTRING
! If top bit is set in the semaphore number, we do not "express"
! the process. This (top bit) is currently being used
! (1) in semaphoring the "#MSG" file.
! (2) in semaphoring the Director logfile.
RECORD (PARMF)P
IF GOTSEMA#0 START
!
DOPER2("PP ERROR")
WRS(DIROWN_SEMA HOLDER." HAS: ".HTOS(SEMANOHELD,8)."@". HTOS(SEMADDRHELD, 8))
WRS(S." WANTS: ".HTOS(SEMANO, 8)."@".HTOS(SEMADDR, 8))
! PRINTMP(0, 0)
DIRMON = -1
RESULT = 94
FINISH
!
GOTSEMA=1
DIROWN_SEMA HOLDER = S
SEMANOHELD=SEMANO
SEMADDRHELD = SEMADDR
IF SEMANO >= 0 AND AEXPRESS # 0 C
THEN INTEGER(AEXPRESS) = PROCESS
LOOP:
*LXN_SEMADDR
*INCT_(XNB +0)
*JCC_8,<GOT>; ! GOT SEMA IF VALUE IS 0
*JCC_4,<NOTGOT>
DOPER2("SEMAP ".HTOS(SEMANO,8)."=".HTOS(INTEGER(SEMADDR),8)); ! disaster, sema -1 or less
INTEGER(SEMADDR) = 0
-> GOT
! -> LOOP
NOTGOT:
! SOMEONE ELSE HAS SEMA. CALL SPVR
P = 0
P_DEST = X'70001'
P_P1 = SEMANO
DOUTI(P)
INTEGER(SEMADDR) = 0 IF P_SRCE = X'70004'; ! Sema was forced free
GOT:
RESULT = 0
END ; ! PP
!
!-----------------------------------------------------------------------
!
EXTERNALROUTINE VV(INTEGER SEMADDR, SEMANO)
INTEGER SEM
RECORD (PARMF)P
IF GOTSEMA=0 START
!
DOPER2("VV ERROR")
WRS("TRY TO FREE: ".HTOS(SEMANO,8)."@". HTOS(SEMADDR, 8))
! PRINTMP(0, 0)
DIRMON = -1
RETURN
FINISH
!
IF SEMANO # SEMANOHELD START
DOPER2("VV ERROR")
WRS(DIROWN_SEMA HOLDER." HAS: ".HTOS(SEMANOHELD,8)."@". HTOS(SEMADDRHELD,8))
WRS(" VRIJ: ".HTOS(SEMANO,8)."@". HTOS(SEMADDR,8))
RETURN
FINISH
!
*LXN_SEMADDR
*TDEC_(XNB +0)
*JCC_8,<NOQ>; ! NO-ONE QUEUED ON THIS SEMA
*JCC_4,<SOME WAITING>
*ST_SEM
INTEGER(SEMADDR) = -1
DOPER2("VV ERROR")
WRS( DIROWN_SEMA HOLDER . " frees " . HTOS(SEMANOHELD,8)."=".HTOS(SEM,8)); ! bad error, sema was -1 or less
DIRMON = -1
-> NOQ
SOME WAITING:
P = 0
P_DEST = X'70002'
P_P1 = SEMANOHELD
DPONI(P)
NOQ:
IF SEMANOHELD >= 0 AND AEXPRESS # 0 C
THEN INTEGER(AEXPRESS) = 0
GOTSEMA=0
END ; ! VV
!
!-----------------------------------------------------------------------
!
EXTERNALROUTINE GET AV FSYS2(INTEGER TYPE, C
INTEGERNAME N,INTEGERARRAYNAME A)
! ARRAY A IS FILLED WITH N FSYS NUMBERS (AS MANY AS ARE ON-LINE)
! TYPE 0 only discs which are consistency-checked and not closing
! 1 all on-line discs, checked or not, closing or not
! 2 only checked discs, but may be closing.
INTEGER J, NDISCS, DITADDR, SLOAD FSYS, FS
RECORD (DDTF)NAME DDT
SLOAD FSYS = COM_SUPLVN
A(0) = SLOAD FSYS
DITADDR = COM_DITADDR
NDISCS = COM_NDISCS
N = 1
CYCLE J = 0, 1, NDISCS-1
DDT == RECORD(INTEGER(DITADDR + J<<2))
IF (1 << DDT_STATE) & DDTSTATES > 0 AND C
(TYPE=1 OR (TYPE=0 AND DDT_DLVN>>30=0) C
OR (TYPE=2 AND DDT_DLVN>=0)) C
START
FS = DDT_DLVN<<2>>2
UNLESS FS = SLOAD FSYS START
A(N)=FS
N=N+1
FINISH
FINISH
REPEAT
END ; ! GET AV FSYS2
!
!-----------------------------------------------------------------------
!
EXTERNALINTEGERFN AV(INTEGER FSYS, TYPE)
! TYPE = 0 Only discs for which CCK has been done
! TYPE = 1 All on-line EMAS discs, whether consistency-checked or not and
! whether closing or not.
! 2 Only consistency-checked discs, but they may be closing
! RESULT 1 IF FSYS AVAILABLE
! 0 IF NOT
INTEGER DLVN,J
BYTEINTEGERARRAYNAME DLVNA
INTEGERARRAYNAME DIT
RECORD (DDTF)NAME DDT
INTEGERARRAYFORMAT DITF(0:COM_NDISCS-1)
DLVNA==ARRAY(COM_DLVNADDR,DLVNAF)
DIT==ARRAY(COM_DITADDR,DITF)
RESULT =0 UNLESS 0<=FSYS<=99
J=DLVNA(FSYS); ! pick up DIT entry number for FSYS
IF J>250 THEN RESULT =0; ! off-line
DDT == RECORD(DIT(J))
DLVN=DDT_DLVN
IF FSYS = DLVN<<2>>2 START
IF (1 << DDT_STATE) & DDTSTATES > 0 START
IF TYPE=1 OR C
(TYPE = 0 AND DLVN >> 30 = 0) OR C
(TYPE = 2 AND DLVN>=0) THEN RESULT = 1
FINISH
FINISH
RESULT = 0
END ; ! AV
!
!-----------------------------------------------------------------------
!
EXTERNALINTEGERFN SCONNECT(INTEGER SEG,STARTP,LEN,CALLAPF, C
NEWCOPY,NOTDRUM,NOTSLAV,FLAGS)
! (DISC) SECTION CONNECT.
!
! This function adds either a block to the specified segment or
! allocates 1 or 2 blocks to a new segment. It can add an arbitrary
! number of epages (up to the segment max). The only proviso is that
! the current last block (if any) should be full.
!
! We assume that the disc section size is greater than or equal to and
! a multiple of the CBT block size.
!
! Param LEN is the number of epages being added.
!
! Param STARTP is the start page of the first block being added and
! must have FSYS no. in LH byte.
!
! FLAGS
! 2**5 32 advisory 'multiple use'
! set for the following
! file use count > 1
! an index/bitmap segment
! subsys basefile
! 2**6 64 advisory sequential
! 7 128 continuation
!
! Possible error results :
! 2 invalid params ("should not occur")
! 28 CBT freelist empty
!
! TAGS field in CBT (8 bits) as follows
! LH 3 BITS BLOCK IS "NEW-COPY" /DISC ONLY / ABTX=ABT INDEX
! RH 5 BITS BLOCK LIMIT (EPAGES)
!
!
INTEGER NEWBLKS, W, C1, C, J
UNLESS 0 < SEG <= HISEG C
ANDC
0 < LEN <= 256 C
ANDC
0 < CALLAPF <= X'1FF' C
THEN RESULT = 2; ! FAULTY PARAMS
!
NEWBLKS = (LEN+BLKSI-1)//BLKSI
!
*LSS_(1); ! PICK UP PSR
*AND_X'FF0FFFFF'; ! REMOVE ACR BITS
*OR_X'00100000'; ! AND SET TO 1
*ST_(1); ! PUT BACK
!
NOTDRUM = B'01000000' UNLESS NOTDRUM = 0
NEWCOPY = B'10000000' UNLESS NEWCOPY = 0
IF NOTSLAV # 0 # COM_OCPPORT1 C
THEN NOTSLAV = X'20000000' C
ELSE NOTSLAV = 0
!
W = ST(SEG)_APFLIM
C1 = SST(SEG)
!
J = 28
IF C1 = ENDSST START
! NEW SEGMENT
IF LEN <= BLKSI START
! ONE BLOCK
C = GET1
-> RES IF C < 0
CBTA(C)_DA = STARTP
CBTA(C)_AMTX = 0
CBTA(C)_TAGS = (LEN-1) ! NOTDRUM ! NEWCOPY
CBTA(C)_LINK = FLAGS
FINISH ELSE START
! TWO BLOCKS
C = GET2
-> RES IF C < 0
CBTA(C)_DA = STARTP
CBTA(C)_AMTX = 0
CBTA(C)_TAGS = (BLKSI-1) ! NOTDRUM ! NEWCOPY
CBTA(C)_LINK = FLAGS
CBTA(C+1)_DA = STARTP + BLKSI
CBTA(C+1)_AMTX = 0
CBTA(C+1)_TAGS = (LEN-BLKSI-1) ! NOTDRUM ! NEWCOPY
CBTA(C+1)_LINK = FLAGS ! 128
FINISH
ST(SEG)_APFLIM = (W & X'800C007F') ! C
NOTSLAV ! CALLAPF<<20 ! X'40000380' ! C
(((LEN * EPAGESIZE - 1) & X'FF') << 10)
SETSST(SEG, C)
FINISH ELSE START
! ADD A BLOCK
C = GET2
-> RES IF C < 0
CBTA(C) = CBTA(C1)
CBTA(C+1)_DA = STARTP
CBTA(C+1)_AMTX = 0
CBTA(C+1)_TAGS = (LEN-1) ! NOTDRUM ! NEWCOPY
CBTA(C+1)_LINK = CBTA(C)_LINK ! 128
ST(SEG)_APFLIM = (W & X'FFFC03FF') ! C
((((W >>10) + LEN*EPAGESIZE) & X'FF') << 10)
SETSST(SEG, C)
RECOVER CBT(C1); ! RECOVER OLD SINGLE ENTRY
FINISH
J = 0
RES:
RESULT =J
END ; ! SCONNECT
!
!-----------------------------------------------------------------------
!
INTEGERFN ALLOC DSEG(INTEGER PGNO,INTEGERNAME DSEG)
! THE PARAM PGNO SHOULD BE "SEGMENT-ALIGNED" ON THE DISC, IE.
! (PGNO*EPAGE SIZE)<<10 SHOULD BE A SEGMENT-START ADDRESS.
! FOR REPLACEMENT OF DIRECTOR INDEX SEGMENTS, SEE NOTE IN FN CINDA
INTEGER SEG,ENT,MIN,PT,SU, J, N
OWNINTEGER STAMP
RESULT =8 IF (((PGNO<<8>>8)*EPAGE SIZE)<<10)&X'3FFFF'#0
!
STAMP = STAMP + 1
MIN = STAMP
J = 0
N = 0; ! COUNT SEGS STILL AVAILABLE FOR USE
SEG = LODSEG
WHILE SEG<=HIDSEG CYCLE
ENT = SST(SEG)
-> ALREADY CONN IF ENT # ENDSST AND CBTA(ENT)_DA = PGNO
!
SU = SEGUSE(SEG)
!
-> GOT HOLE IF SU = -2
!
IF SU >= 0 START
N = N + 1
MIN = SU AND PT = SEG IF SU < MIN
FINISH
SEG = SEG + 1
REPEAT
!
DOPER2("ALLOC DSEG: <3") IF N < 3; ! ON THE VERGE OF DISASTER
!
DOPER2("ALLOC DSEG: OUT") AND RESULT = 3 IF MIN = STAMP
SEG = PT
DCHAIN(SEG, 0); ! DROP EXISTING SEGMENT DISC ADDRESSES
GOT HOLE:
J = SCONNECT(SEG,PGNO,64,DIRAPF&255,0,0,NOTSLAVED,32); ! anticipate multiple use
J = DISC USE COUNT(PGNO>>24,+1) IF J = 0
ALREADY CONN:
SEGUSE(SEG) = STAMP IF SEGUSE(SEG) # -1; ! unless fixed
DSEG = SEG
RESULT = J
END ; ! ALLOC DSEG
!
!-----------------------------------------------------------------------
!
EXTERNALINTEGERFN SYSAD(INTEGER KEY, FSYS)
!
! Use of first few words of bitmap (at least 40 bytes available)
!
! adr use semano
! 0 bitmap sema fsys<<16
! 8 fsys
! 16 time of CCK
! 20 date
! 24 nnt sema 2-----4 (one day)
! On the IPL disc, the next 248 bytes are also available - see
! record format DIRCOMF above.
! Note: the semanos used for DIRLOG and FEP are X8-----1 and x4-----2
!
! KEY = 0 BIT MAP
! 1 NNT
! 3 NNT SEMA
! 4 DATE WORD
! 5 DIRCOM
! 6 BAD PAGES BIT MAP
!
INTEGER J, SEG, BB, BIT
RECORD (DISCDATAF)DATA
FSYS = COM_SUPLVN IF FSYS < 0 OR KEY = 5
!
J = FBASE2(FSYS, ADDR(DATA))
-> OUT UNLESS J = 0
!
BIT = -1
BIT = 0 IF KEY = 0
BIT = DATA_NNTSTART IF KEY = 1
BIT = 4 IF KEY = 3
BIT = 16 IF KEY = 4
BIT = 40 IF KEY = 5
BIT = X'5000' IF KEY = 6
J = -1 AND -> OUT IF BIT < 0
!
BB = FSYS << 24 ! DATA_START
J = ALLOC DSEG(BB, SEG)
RESULT = SEG << 18 + BIT IF J = 0
OUT:
WRSNT("SYSAD fails", J, 5)
WRSNT(" KEY", KEY, 5)
WRSN(" FSYS", FSYS)
RESULT = -1
END ; ! SYSAD
!
!-----------------------------------------------------------------------
!
EXTERNALINTEGERFN BAD PAGE(INTEGER TYPE, FSYS, BITNO)
! TYPE = 0 CLEAR BAD PAGES LIST FOR FSYS
! 1 NEW BAD PAGE, BITNO IN FSYS
! 2 GOOD PAGE, BITNO IN FSYS
! 3 IS BITNO IN FSYS A BAD PAGE? (RESULT 1 IF SO, 0 IF NOT)
! 4 LIKE 2 BUT CALLED FROM A PROGRAM
! When a new bad page is recorded, we want the bitmap bit to be set. But
! not in this routine, because it may be executed on the signal stack
! and we need totake the bitmap semaphore. (Still, when it's executed
! on the signal stack (progerr 18) the page belongs to a file anyway).
! The bit is set in fn MOVE SECTION on getting a flag from the bulk mover.
INTEGER J, B, BITSINBITMAP
RECORD (DISCDATAF)DATA
IF 0 < TYPE < 3 START
IF FSYS < 0 THEN FSYS = BITNO >> 24
BIT NO = (BIT NO << 8) >> 8
FINISH
!
RESULT = 93 IF TYPE & 1 = 0 ANDC
0 <= DTRYING << 11; ! ie types 1 and 3 not priv
!
J = AV(FSYS, 1)
RESULT = 2 IF J = 0
!
J = FBASE2(FSYS, ADDR(DATA))
RESULT = 2 UNLESS J = 0
!
B = SYSAD(BADKEY, FSYS)
!
IF TYPE = 0 START
! CLEAR BAD PAGES LIST
FILL(DATA_BITSIZE, B, 0)
RESULT = 0
FINISH
!
BITS IN BITMAP = DATA_BITSIZE << 3
*LDTB_BITS IN BITMAP; ! SET UP DR AND B
*LDA_B; ! TO ADDR THE BIT
*LB_BIT NO; ! WE WANT
!
IF TYPE = 1 START
! NEW BAD PAGE
*LSS_(DR +B ); ! PICK UP BIT
*JAT_5,<SET>; ! J IF > 0, ALREADY SET
*LSS_1
*ST_(DR +B )
DOPER2( "BAD PAGE ".HTOS(FSYS<<24!BITNO,8)." RECORDED")
RESULT = 0
FINISH
!
IF TYPE = 2 START
! MAKE A BAD PAGE GOOD
*LSS_(DR +B )
*JAT_4,<NOT SET>; ! J IF = 0, ALREADY GOOD
*LSS_0
*ST_(DR +B )
DOPER2("CLEARED")
RESULT = 0
FINISH
!
IF TYPE = 3 START
! TEST BIT
*LSS_(DR +B ); ! RESULT NOW IN ACC
*EXIT_-64; ! RETURN
FINISH
!
IF TYPE = 4 START
! EXTERNAL CALL TO CLEAR BIT
*LSS_(DR +B )
*JAT_4,<ALREADY CLEAR>
*LSS_0
*ST_(DR +B )
RESULT = 1
ALREADY CLEAR:
RESULT = 0
FINISH
!
RESULT = 2; ! INVALID CALL
!
SET:
DOPER2("ALREADY SET"); RESULT = 0
NOT SET:
DOPER2("ALREADY CLEAR"); RESULT = 0
END ; ! OF BAD PAGE
!
!-----------------------------------------------------------------------
!
INTEGERFN DEAL(INTEGER FSYS,STARTP,PAGE,PAGES)
! Can de-allocate up to 32 epages comprising the whole or the
! last part of the section.
INTEGER J, MASK, WORD, WITHIN, BITS, BADS
RECORD (PARMF)NAME P
STARTP = PAGE IF STARTP = 0; ! same most of the time
WITHIN = PAGE & 31
!
J = 8; ! BAD PARAM
-> OUT UNLESS PAGES > 0
-> OUT UNLESS PAGE >= STARTP
-> OUT UNLESS (STARTP >> 5) = (PAGE >> 5)
-> OUT UNLESS WITHIN + PAGES <= 32
!
BITS = SYSAD(BITKEY, FSYS)
BADS = SYSAD(BADKEY, FSYS); ! BAD PAGES BIT LIST
WORD = (PAGE>>3) & (¬3)
!
MASK = ((-1) << (32 - PAGES)) >> (PAGE & 31)
!
J = 22; ! bits already clear flag
IF INTEGER(BITS+WORD) & MASK # MASK START
WRSNT("DEAL: B+W", BITS+WORD, 2)
WRSNT("INTG(B+W)", INTEGER(BITS+WORD), 2)
WRSNT("MASK ", MASK, 2)
-> OUT
FINISH
! OUT to local controller to check that the block whose start page is
! STARTP is not still active. This is because an ordinary disconnect does
! not wait until all page-outs are complete.
J = 91
P==RECORD(OUTPAD)
P=0
P_DEST=(FSYS<<24) ! STARTP
*OUT_17
-> OUT IF P_DEST = -1;! P_DEST=-1 IS ERROR RESULT
!
IF INTEGER(BITS+8) # FSYS START
WRS("BITMAP/FSYS2")
DIRMON = -1
FINISH
!
! Clear the bits
J = PP(BITS, FSYS << 16, "DEAL")
IF J = 0 START
INTEGER(BITS+WORD) = (INTEGER(BITS+WORD) & (¬MASK)) C
! INTEGER(BADS + WORD); ! ENSURE THAT ANY BAD PAGES JUST DETECTED ARE PUT INTO BITLIST
VV(BITS, FSYS << 16)
FINISH
OUT:
RESULT = J
END ; ! DEAL
!
!-----------------------------------------------------------------------
!
EXTERNALINTEGERFN NINDA(INTEGER FSYS,INDNO,INTEGERNAME INDAD)
! TO BE USED ONLY BY
! CINDA
! NEWUSER
! CLEAR FSYS
! CCK
! POSSIBLE ERROR RESULTS :
! 28 CBT FREELIST EMPTY
! 26 SCONNECT - INVALID PARAMS ("SHOULD NOT OCCUR")
!
INTEGER J,DSEG,PGNO
RECORD (DISCDATAF)DATA
J = FBASE2(FSYS, ADDR(DATA))
-> OUT UNLESS J = 0
!
PGNO = INDNO >> 2; ! index numbers are 1K's
J = ALLOC DSEG((FSYS<<24) ! (DATA_START + (PGNO>>6<<6)), DSEG)
-> OUT UNLESS J = 0
!
INDAD = DSEG<<18 + (INDNO&255)<<10
!
J = 97
-> OUT IF BADPAGE(3, FSYS, DATA_START+PGNO)=YES
!
J = 0
OUT:
RESULT =J
END ; ! NINDA
!
!-----------------------------------------------------------------------
!
EXTERNALINTEGERFN FIND NNT ENTRY(STRING (31)INDEX,
INTEGERNAME FSYS, NNAD, INTEGER TYPE)
! SEARCHES NNT OF ONE OR MORE FSYS'S FOR AN ENTRY
! HOLDING USER. IF FOUND, RETURNS FSYS AND ADDR OF NNT ENTRY
! POSSIBLE ERRORS
! 23 FSYS NOT AVAILABLE
! 37 USER NOT FOUND
! THE SEARCH IS SPEEDED UP (USUALLY) BY MAINTAINING A
! COLLECTION OF UP TO 16 USER+FSYS+NNTI COMBINATIONS
! TYPE is set 0 or 2, in calls of this function.
! 0 when only consistency-checked and not-closing discs are to be
! searched,
! 2 when only consistency-checked discs are to be searched and we
! don't mind if they are closing (calls originating from
! DDISCONNECT, DDESTROY and PROCESS STOPS(call of DINDA)
!
INTEGER HTI, FSYS GIVEN, FINDAD
INTEGER PT,N,I,J,FLAG,NNA,STOP
INTEGERARRAY A(0:99)
STRING (6)UNAME
STRING (11)INAME
STRING (18)IND
RECORD (FF)NAME F
RECORD (NNF)ARRAYFORMAT NNTF(0:16384)
RECORD (NNF)ARRAYNAME NNT
RECORD (NNF)NAME NN
RECORD (HOTTOPF)NAME HT
OWNINTEGER TIMES,SAVES
RECORD (DISCDATAF)DATA
!
J = UIO(INDEX, UNAME, INAME, IND)
RESULT = J UNLESS J = 0
!
FSYS GIVEN = FSYS
TIMES = TIMES + 1
IF (UNAME="FTRANS" OR UNAME="SPOOLR" OR UNAME="MAILER" OR UNAME="VOLUMS") C
AND FSYS=-1 C
THEN FSYS = COM_SUPLVN
!
!
-> INVALID IF HOTTOPN = 0; ! hot top not yet initialised
!
UNLESS HOTTOPADR = HOTTOPA START ; ! new address specified, remap
TIMES = 1
SAVES = 0
HOTTOPADR = HOTTOPA
HOTTOP == ARRAY(HOTTOPADR, HOTTOPFS)
CYCLE I = 0,1,HOTTOPN; HOTTOP(I)=0; REPEAT
FINISH
!
CYCLE I = 0, 1, HOTTOPN
HTI = I
HT == HOTTOP(I)
-> INVALID IF HT_INDEX = ""; ! Examined all used entries
IF EQUAL(IND, HT_INDEX) = YES ANDC
(FSYS=-1 OR FSYS=HT_FSYS) START
! FOUND, BUT CHECK JUST IN CASE
NNA = SYSAD(NNTKEY,HT_FSYS)
NNT == ARRAY(NNA, NNTF)
PT = HT_PT
NN == NNT(PT)
-> INVALID UNLESS NN_NAME = UNAME; ! reuse this entry
FSYS = HT_FSYS
! give 'not found' for TYPE=0 when the FSYS is closing
RESULT = 85 IF TYPE = 0 = AV(FSYS, 0)
NNAD = ADDR(NN)
RESULT = 0
FINISH
REPEAT
!
! Hot top is full and didnt find reqd entry, pick
! one at random to re-use
HTI = DRANDOM(HOTTOPN)
HT == HOTTOP(HTI)
INVALID:
! either now HOTTOPN = 0 or HT is mapped to record in which
! to save user/fsys/pt
!
FLAG=23; ! DISC N/A
IF FSYS=-1 START ; ! LOOK IN ALL AVAILABLE FILE SYSTEMS
GET AV FSYS2(TYPE,N,A)
N = N - 1
FINISH ELSE START ; ! LOOK ONLY IN "FSYS"
IF AV(FSYS, TYPE)=0 THEN -> NOT FOUND
A(0)=FSYS
N=0
FINISH
!
FOR J = 0, 1, N CYCLE
FSYS = A(J)
FLAG = FBASE2(FSYS, ADDR(DATA))
-> NOT FOUND UNLESS FLAG = 0
!
NNA=SYSAD(NNTKEY,FSYS)
NNT==ARRAY(NNA,NNTF)
PT=HASH(UNAME, DATA_NNTHASH)
STOP=PT
UNTIL PT=STOP CYCLE
NN == NNT(PT)
IF NN_NAME=UNAME START
IF INAME = "" START ; ! looking for a process index
-> FOUND IF NN_TAG = 0
FINISH ELSE START ; ! looking for a file index
IF NN_TAG > 0 START
I = NN_INDNO
J = NINDA(FSYS, I, FINDAD)
RESULT = J UNLESS J = 0
F == RECORD(FINDAD)
RESULT = 87 UNLESS F_OWNER = UNAME
-> FOUND IF EQUAL(F_NAME, INAME) = YES
FINISH
FINISH
FINISH
EXIT IF NN_NAME = ""
PT = PT + 1
PT = 0 IF PT > DATA_NNTTOP
REPEAT
REPEAT
!
FLAG = 37
NOT FOUND:
FSYS = FSYS GIVEN
RESULT = FLAG
FOUND:
NNAD = ADDR(NN)
UNLESS HOTTOPN = 0 START
SAVES = SAVES + 1
HT_INDEX = IND
HT_FSYS = FSYS
HT_PT = PT
UNLESS DIRMON = 0 START
WRS3N("HOTTOP", IND, ITOS((SAVES*100)//TIMES)."%", HTI)
FINISH
FINISH
RESULT = 0
END ; ! FIND NNT ENTRY
!
!-----------------------------------------------------------------------
!
EXTERNALROUTINE EMPTY DVM
! Used to disconnect the index area of the VM and to empty the HOTTOP
INTEGER SEG,I
CYCLE SEG=HIDSEG,-1,LODSEG
IF SEGUSE(SEG)#-1 START
DCHAIN(SEG,0)
SEGUSE(SEG)=-2
FINISH
REPEAT
!
IF HOTTOPN > 0 {in use} ANDC
HOTTOPA = HOTTOPADR {and mapped} C
START
CYCLE I=HOTTOPN,-1,0
HOTTOP(I)_INDEX=""
REPEAT
FINISH
END ; ! EMPTY DVM
!
!-----------------------------------------------------------------------
!
INTEGERFN CLOSING BIT(INTEGER FSYS)
INTEGER ENTAD, J
RECORD (DDTF)NAME DDT
J = DDT ENTRY(ENTAD,FSYS)
RESULT = 0 UNLESS J = 0
DDT==RECORD(ENTAD)
RESULT =(DDT_DLVN>>30)&1; ! pass back bit 1 of DLVN
END ; ! CLOSING BIT
!
!-----------------------------------------------------------------------
!
EXTERNALINTEGERFN SET CLOSING BIT(INTEGER FSYS)
INTEGER ENTAD
RECORD (DDTF)NAME DDT
! Give "not available if SLOAD disc specified.
RESULT = 23 IF DDTENTRY(ENTAD,FSYS)#0 OR AV(FSYS, 0)=0 ORC
FSYS=COM_SUPLVN
DDT==RECORD(ENTAD)
DDT_DLVN=DDT_DLVN ! (1<<30)
RESULT =0
END ; ! SET CLOSING BIT
!
!-----------------------------------------------------------------------
!
EXTERNALINTEGERFN CONSEG(STRING (30)FULL,
INTEGER FSYS, INTEGERNAME GAP)
! RESULT IS SEG NO WHICH FILE IS CONNECTED AT.
! If the file is connected but is not to be disconnected, have its size or access
! changed then the top bit is set in the result value.
! GAP is equal to the gap reserved for the file at CONNECT, or the
! default gap which was used if GAP was specified zero.
! Result is zero if the file is not connected.
INTEGER SEG, LSEG, LGAP, EQ
RECORD (CTF)NAME C
LSEG = 0
LGAP = 1
CYCLE SEG = 4, 1, HISEG
C == DIROWN_CONLIST(DIROWN_CPOINT(SEG))
EQ = 0
EQ = 1 IF EQUAL(C_FULL, FULL) = YES ANDC
{ C_PREFIX = PREFIX %ANDC }
C_FSYS = FSYS
IF LSEG # 0 START
IF EQ # 0 OR C_FULL = "RESERVED" C
THEN LGAP = LGAP + 1 C
ELSE EXIT
FINISH
! Pass "no disconnect" bit over into result seg number.
LSEG = SEG ! (C_NODISCO << 31) IF EQ # 0 = LSEG
REPEAT
GAP = LGAP
RESULT = LSEG
END ; ! CONSEG
!
!-----------------------------------------------------------------------
!
EXTERNALINTEGERFN DNINDA(INTEGER FSYS, INDNO, INTEGERNAME INDAD)
INTEGER J
J = IN2(51)
-> OUT UNLESS J = 0
!
J = 45
-> OUT IF VAL(ADDR(INDAD), 4, 1, DCALLERSPSR) = NO
!
J = NINDA(FSYS, INDNO, INDAD)
OUT:
RESULT = OUT(J, "II")
END
!
!-----------------------------------------------------------------------
!
EXTERNALINTEGERFN HINDA(STRING (6)UNAME, INTEGERNAME FSYS,INDAD, INTEGER TYPE)
! Called to get the address of a 'process index' NOT a file index
! UNAME must be a 6 ch name
! FSYS may be specific or -1 (-1 means IPL disc for executives else first found)
! TYPE 0: flag 85 is returned if fsys found is closing and procuser himself
! is on a closing disc
! 2: disc may be closing
!
INTEGER J, NNAD, DSEG, SAVESEG
RECORD (HF)NAME H
RECORD (NNF)NAME NN
STRING (12) W
TYPE = 2 IF TYPE = 0 # CLOSING BIT(PROCFSYS)
!
J = 0
SAVESEG = 0
IF UNAME = PROCUSER AND (FSYS = PROCFSYS OR FSYS = -1) START
IF OWNIND # 0 START ; ! have already found (and locked) procuser
INDAD = OWNIND
FSYS = PROCFSYS
-> GOT OWN
FINISH
SAVESEG = 1
FINISH
!
J = FIND NNT ENTRY(UNAME, FSYS, NNAD, TYPE)
-> OUT UNLESS J = 0
!
NN == RECORD(NNAD)
J = NINDA(FSYS, NN_INDNO, INDAD)
-> OUT UNLESS J = 0
!
DSEG = INDAD>>18
UNLESS SAVESEG = 0 START
SEGUSE(DSEG) = -1
SEGUSE(SYSAD(BITKEY,FSYS)>>18) = -1
FINISH
GOT OWN:
H == RECORD(INDAD)
W <- H_OWNER
UNLESS H_OWNER = UNAME START
WRS3N("HINDA", UNAME, W, 87)
J = 87; ! wrong index found
FINISH
J = 99 IF H_MARK = 0
OUT:
RESULT = J
END ; ! HINDA
!
!-----------------------------------------------------------------------
!
EXTERNALINTEGERFN FINDA(STRING (31)INDEX, INTEGERNAME FSYS, FINDAD,
INTEGER TYPE)
INTEGER J, NNAD
STRING (6)WOWNER, UNAME
STRING (11)WNAME, INAME
STRING (18)WFULL, IND
RECORD (NNF)NAME NN
RECORD (FF)NAME F
J = UIO(INDEX, UNAME, INAME, IND)
-> OUT UNLESS J = 0
!
TYPE = 2 IF TYPE = 0 # CLOSING BIT(PROCFSYS)
!
J = 0
IF IND = PROCUSER ANDC
(FSYS = PROCFSYS OR FSYS = -1) ANDC
OWNIND # 0 C
START
FINDAD = OWNIND
FSYS = PROCFSYS
-> GOTOWN
FINISH
!
J = FIND NNT ENTRY(IND, FSYS, NNAD, TYPE)
-> OUT UNLESS J = 0
!
NN == RECORD(NNAD)
J = NINDA(FSYS, NN_INDNO, FINDAD)
-> OUT UNLESS J = 0
!
GOTOWN:
FINDAD = FINDAD + 512 IF INAME = ""
F == RECORD(FINDAD)
UNLESS UNAME = F_OWNER AND EQUAL(INAME, F_NAME) = YES START
J = 87
WOWNER <- F_OWNER
WNAME <- F_NAME
WFULL = WOWNER
WFULL = WOWNER . ISEP . WNAME UNLESS WNAME = ""
WRS3N("FINDA", IND, WFULL, 87)
FINISH
OUT:
RESULT = J
END ; ! FINDA
!
!-----------------------------------------------------------------------
!
EXTERNALINTEGERFN MAP FILE INDEX(STRINGNAME INDEX,
INTEGERNAME FSYS, FINDAD, STRING (31)TXT)
INTEGER J
RECORD (FF)NAME F
J = FINDA(INDEX, FSYS, FINDAD, 0)
RESULT = J UNLESS J = 0
!
F == RECORD(FINDAD)
RESULT = PP(ADDR(F_SEMA), F_SEMANO, TXT)
END ; ! MAP FILE INDEX
!
!-----------------------------------------------------------------------
!
INTEGERFN NEW FILE DEAL(INTEGER FINDAD, SD, PAGES)
INTEGER NSD, FSYS, NP, DA, LINK, J
RECORD (FF)NAME F
INTEGERARRAYNAME SDS
F == RECORD(FINDAD)
SDS == ARRAY(FINDAD + F_SDSTART, SDSF)
NSD = (F_FDSTART - F_SDSTART) >> 2
FSYS = F_FSYS
J = 0
WHILE PAGES > 0 CYCLE
NP = PAGES
NP = 32 IF NP > 32
PAGES = PAGES - NP
DA = SD << 13 >> 13
LINK = SD >> 19
J = J ! DEAL(FSYS, 0, DA, NP) UNLESS DA = X'7FFFF'
EXIT UNLESS 1 <= LINK <= NSD
SD = SDS(LINK)
SDS(LINK) = 0
REPEAT
J = 87 UNLESS PAGES = 0 = LINK
RESULT = J
END ; ! NEW FILE DEAL
!
!-----------------------------------------------------------------------
!
externalintegerfn NEWFIND(integer FINDAD, DA, stringname FILE)
! Searches the file index at the specified address for
! the file of the given name, ignoring old gens if DA=0 or
! ignoring any with the wrong disc address if DA # 0. If found,
! returns index (>0) into array of FDs else 0
INTEGER J, PREFIX
integer I, NFD
STRING (255)W
record (FDF)name FD
record (FF)name F
record (FDF)arrayname FDS
!
F == RECORD(FINDAD)
FDS == ARRAY(FINDAD+F_FDSTART, FDSF)
NFD = (F_SIZE<<9 - F_FDSTART) // FDSIZE; ! NO OF FDS IN INDEX
DA = DA << 13
!
cycle I = 1, 1, NFD
FD == FDS(I)
result = 0 if FD_NAME = ""; ! reached a never-used entry
if EQUAL(FD_NAME, FILE) = YES start
-> OUT IF (DA=0=FD_CODES2&OLDGE OR FD_SD<<13=DA)
FINISH
REPEAT
RESULT = 0
OUT:
LASTFD = FD
RESULT = I
end ; ! NEWFIND
!
!-----------------------------------------------------------------------
!
EXTERNALROUTINE FILL STACK ENTS(INTEGER INDAD, STRING (3)SUFF)
INTEGER FINDAD, NFD, J, CELL, SD, DA, PGS
STRING (11)FILE
RECORD (FF)NAME F
RECORD (FDF)ARRAYNAME FDS
RECORD (FDF)NAME FD
INTEGERARRAYNAME SDS
CELL = SST(4)
CBTA(CELL)_LINK = 0
!
FILE = "#STK" . SUFF
FINDAD = INDAD + 512
F == RECORD(FINDAD)
FDS == ARRAY(FINDAD + F_FDSTART, FDSF)
SDS == ARRAY(FINDAD + F_SDSTART, IFT)
NFD = (F_SIZE << 9 - F_SDSTART) // FDSIZE
!
CYCLE J = 1, 1, NFD
FD == FDS(J)
IF EQUAL(FD_NAME, FILE) = YES START
SD = FD_SD >> 19
IF SD > 0 START ; ! more than one block
DA = F_FSYS << 24 ! (SDS(SD) << 13 >> 13)
PGS = FD_PGS
J = SCONNECT(4, DA, PGS - 32, X'FF', 1, 0, 0, 128)
IF J = 0 START
*LSS_(1)
*AND_X'FF0FFFFF'
*OR_X'00100000'
*ST_(1)
ST(4)_APFLIM = (ST(4)_APFLIM & X'FFFC0FFF') ! ((PGS-1)<<12)
FINISH ELSE WRSN("Fill stack ents", J)
FINISH
RETURN
FINISH
REPEAT
WRS("Fill stack ents: No #STK !!")
END ; ! FILL STACK ENTS
!
!-----------------------------------------------------------------------
!
INTEGERFN NEWCONENT
! returns a free CONLIST entry number, or zero if CONLIST full.
INTEGER J
IF SEARCHENT=0 START
DIROWN_CONLIST(0)_FULL="RUBBISH"
DIROWN_CONLIST(RESERVED)_FULL="RESERVED"
SEARCHENT=2
FINISH
J=SEARCHENT
WHILE J<=TOPCONENT CYCLE
IF DIROWN_CONLIST(J)_FULL="" THEN DIROWN_CONLIST(J) = 0 AND RESULT =J
J=J+1
REPEAT
RESULT =0; ! no free entry found
END ; ! NEWCONENT
!
!-----------------------------------------------------------------------
!
EXTERNALINTEGERFN DISCSEG CONNECT(INTEGER FSYS,SITE,SEG,APF,EPAGES,
FLAGS)
! Used to connect the System Call Table and basefiles
! Epages must be in the range 1 to 64 (for EPAGE SIZE=4)
! The segment is connect as "slaved".
! WE ARE NOT CONNECTING MORE THAN ONE SEGMENT ALTOGETHER.
INTEGER J,ENT
J = 29
ENT=NEWCONENT
UNLESS ENT = 0 START
J = SCONNECT(SEG,SITE!(FSYS<<24),EPAGES,APF,0,0,0,FLAGS)
IF J = 0 START
SEARCHENT=ENT+1
DIROWN_CPOINT(SEG)=ENT
DIROWN_CONLIST(ENT)_FULL="DISCSITE"
FINISH
FINISH
RESULT = J
END ; ! DISCSEG CONNECT
!
!-----------------------------------------------------------------------
!
externalintegerfn NEWFILEPERM(integer FINDAD, record (FDF)name FD,
string (6)USER)
INTEGER ARCHIVE
record (FF)name F
record (PDF)arrayname PDS
record (PDF)name PD
integer LINK, J, CH, NPD, N, P
!
! gives USER's permitted access modes to FILE
!
RESULT = 7 IF USER = "DIRECT" OR USER = "FCHECK"
!
F == RECORD(FINDAD)
IF F_NAME = "#ARCH" START
ARCHIVE = 1
FINISH ELSE START
P = FD_OWNP
-> OUT if USER = F_OWNER
ARCHIVE = 0
FINISH
!
PDS == ARRAY(FINDAD+F_PDSTART, PDSF)
NPD = (F_SDSTART - F_PDSTART) // PDSIZE
LINK = FD_PHEAD
N = 0
while NPD >= LINK > 0 cycle ; ! explicit permission to file
PD == PDS(LINK)
P = PD_PERM
-> OUT IF USER = PD_NAME
LINK = PD_LINK
N = N + 1
exit if N > 15
repeat
!
LINK = FD_PHEAD
N = 0
while NPD >= LINK > 0 cycle ; ! implicit permission to file
PD == PDS(LINK)
cycle J = 1, 1, 6
CH = CHARNO(PD_NAME, J)
-> NO1 unless CH='?' or CH = CHARNO(USER, J)
repeat
P = PD_PERM
-> OUT
NO1:
LINK = PD_LINK
N = N + 1
exit if N > 15
repeat
!
P = FD_EEP
-> OUT IF P > 0
RESULT = -1 IF ARCHIVE = 1
!
LINK = F_FIPHEAD
N = 0
while NPD >= LINK > 0 cycle ; ! explicit permission to index
PD == PDS(LINK)
P = PD_PERM
-> OUT IF USER = PD_NAME
LINK = PD_LINK
N = N + 1
exit if N > 15
repeat
!
LINK = F_FIPHEAD
N = 0
while NPD >= LINK > 0 cycle ; ! implicit permission to index
PD == PDS(LINK)
cycle J = 1, 1, 6
CH = CHARNO(PD_NAME, J)
-> NO2 unless CH='?' or CH = CHARNO(USER, J)
repeat
P = PD_PERM
-> OUT
NO2:
LINK = PD_LINK
N = N + 1
exit if N > 15
repeat
!
RESULT = -1
OUT:
P = P & 7
P = P ! 1 IF P & 6 > 0
RESULT = P
end ; ! NEWFILEPERM
!
!-----------------------------------------------------------------------
!
INTEGERFN NOM(INTEGER SEG)
! NOMINATE (DE-NOMINATE IF SEG=0) SEGMENT SEG.
INTEGER J
RECORD (PARMF)NAME P
P==RECORD(OUTPAD)
P=0
P_P1=3; ! STACKNO
P_P2=SEG
IF SEG=0 START ; *OUT_13; FINISH ELSE START ; *OUT_12; FINISH
J=P_DEST
J=36 IF J<0; ! NOM/DE-NOM FAILS
RESULT =J
END ; ! NOM
!
!-----------------------------------------------------------------------
!
externalintegerfn DCONNECTI(string (255)FILE,
integer FSYS, MODE, APF, integername SEG, GAP)
! ORDER OF MODE BITS: EXECUTE WRITE READ
! BITS IN MODE MAY BE SET AS FOLLOWS:
! 2**0 READ
! 1 WRITE
! 2 EXECUTE
! 3 WRITE-SHARED ALLOW
! 4 NEW-COPY
! 5 COMMS MODE
! 6 DISC-ONLY
! 7 NEW STACK SEGMENT
! 8 DISCONNECT, CHANGE ACCESS, CHANGE SIZE NOT ALLOWED
! 9 (advisory) sequential file
! 31 NON-SLAVED SEGMENT
constintegerarray MG(0:7) = c
B'01111101011100000011000000000000',
B'01110000000000000000000000000000',
B'01111100011100000011000000000000',
B'01110000000000000000000000000000',
B'00010000000000000001000000000000',
B'00000000000000000000000000000000',
B'00010000000000000001000000000000',
B'00000000000000000000000000000000'
integer FINDAD, FI
integer J,CONENT,NODISCO
integer SECTLEN,RELSEG, NSD, S, DA, NSECTS, N
integer K,PRM,NEWCOPY,WSA,NEWSTACK,A,MODEGOOD,NONSLAVED
integer TOPSEG,FSEGS,TOPFSEG,XSEG,XGAP,IS ROOM,TOTSEGS
integer PAGS,CODES,CODES2,NOTDRUM
integer FLAGS
STRING (31)UNAME, INAME, FNAME, INDEX, FULL
record (CTF)name CT
record (FF)name F
record (FDF)arrayname FDS
integerarrayname SDS
integername SD
record (FDF)name FL
conststring (8)FN = "DCONNECT"
J = IN2(11)
-> OUT UNLESS J = 0
!
APF=X'100' ! (D CALLERS ACR<<4) ! D CALLERS ACR if APF = 0
!
J=8; ! BAD PARAM
NODISCO = (MODE&X'100') >> 8
FLAGS = (MODE&X'200')>>3; ! ie set FLAGS to 64 for 'adv seq'
MODE=MODE&(¬(X'300'))
NONSLAVED=MODE>>31
MODE=MODE<<1>>1; ! Drop LH bit
unless 0<=MODE<=255 then -> OUT
!
! TYPE 0, VECTOR
! SIZE=0, BIT
! A=0, USC=0, BCI=0
A=ADDR(MG(0))
*LDTB_256
*LDA_A
*LB_MODE
*LSS_(dr +b )
*ST_MODEGOOD
if MODEGOOD=0 then -> OUT
!
J = UFO("", FILE, UNAME, INAME, FNAME, INDEX, FULL)
-> OUT UNLESS J = 0
!
J = MAP FILE INDEX(INDEX, FSYS, FINDAD, FN); ! to get fsys
-> OUT UNLESS J = 0
!
F == RECORD(FINDAD)
!
J = 32; ! NOT EXIST
FI = NEW FIND(FINDAD, 0, FNAME)
-> VOUT if FI=0
!
J = CONSEG(FULL,FSYS, K); ! check if file already connected
UNLESS J = 0 START
SEG = J & 255
GAP = K
J = 34
-> VOUT
finish
!
FDS == ARRAY(FINDAD+F_FDSTART, FDSF)
SDS == ARRAY(FINDAD+F_SDSTART, SDSF)
NSD = (F_FDSTART - F_SDSTART) >> 2
FL == FDS(FI)
!
J = 32; ! NO ACCESS
PRM = NEW FILE PERM(FINDAD, FL, PROCUSER)
IF PRM = -1 START
PRM = F_EEP & 7
PRM = PRM ! 1 IF PRM & 6 > 0
FINISH
-> VOUT if MODE&PRM < MODE&7; ! what you can have < what wanted
!
PAGS=FL_PGS
J = 87
-> VOUT IF PAGS <= 0
!
NSECTS = (PAGS + 31) >> 5
CODES = FL_CODES; ! make local copies
CODES2 = FL_CODES2
!
J=5; ! NOT READY
if CODES&UNAVA#0 then -> VOUT
!
J=20; ! ON OFFER
if CODES&OFFER#0 then -> VOUT
!
NEWCOPY=CODES & VIOLAT
! Reject WS-ALLOW for VIOLAT file
J=33; ! conflicting mode
if MODE&B'00001000'#0 and NEWCOPY#0 then -> VOUT
!
NOTDRUM=MODE & B'01000000'
NEWSTACK=MODE&B'10000000'
GAP=2 if NEWSTACK#0 and GAP<2
NEWCOPY=NEWCOPY ! (MODE&B'00010000'); ! INCLUDE SPECIFIC RQ FOR NEWCOPY
if FL_USE#0 start
! Does requested mode conflict with existing mode?
! Reject WRITE connection or WS-ALLOW connection if Ws-allow not set
if MODE&B'0001010'#0 and CODES2&WSALLOW=0 then -> VOUT
!
! If already connected WS-ALLOW, this request must also have it
if MODE&B'1000'=0 and CODES2&WSALLOW#0 then -> VOUT
!
! Reject any further connection if already conected W-mode and WS-ALLOW not set
if CODES2&WRCONN#0 and CODES2&WSALLOW=0 then -> VOUT
!
! Reject any further connection if already connected in COMMS mode or STACK mode
if CODES2&(COMMS!STACK)#0 then -> VOUT
!
! Reject NEW-COPY connection if already connected at all
! and reject any further connection for a VIOLAT file.
-> VOUT IF NEWCOPY # 0
finish
WSA=MODE&B'1000'
MODE=MODE & 7
if MODE&6#0 then MODE=MODE ! 1; ! add R if X or W set
!
! %if MODE&4=0 %then APF=APF & (¬X'100'); ! trim APF, not X
if MODE&2=0 then APF=APF & (¬X'F0'); ! not W
if MODE&1=0 then APF=APF & (¬X'0F'); ! not R
!
J=29; ! no free CONLIST entry
CONENT=NEWCONENT
if CONENT=0 then -> VOUT; ! no free CONLIST entry
!
FSEGS = (PAGS*4+255) >> 8; ! set SEG and GAP if req
J = 35
XGAP = GAP
if XGAP < FSEGS start
! -> VOUT %IF XGAP > 0; ! too small a GAP specified - BUT SS CAN'T COPE !!!!!
XGAP = FSEGS
GAP = FSEGS
finish
TOTSEGS = XGAP
!
XSEG=SEG
if NEWSTACK#0 and XSEG&1#0 then -> VOUT; ! MUST BE EVEN FOR STACK MODE
if XSEG=0 start
XSEG=LOUSEG
while XSEG<=HISEG cycle
IS ROOM=1
cycle K=0,1,GAP-1
! First condition below checks that we're not going beyond
! the VM limit.
if XSEG+K>HISEG or c
DIROWN_CPOINT(XSEG+K)#0 then IS ROOM=0 c
and exit
repeat
if IS ROOM#0 then exit ; ! FOUND HOLE
XSEG=XSEG+1
if NEWSTACK#0 then XSEG=XSEG+1; ! TO GO UP IN TWO'S
repeat
if IS ROOM=0 then -> VOUT
SEG=XSEG
finish
TOPFSEG=XSEG+FSEGS-1
TOPSEG=XSEG+TOTSEGS-1
!------ SEG & GAP SELECTED AND SET UP ---------------------------
! VALID SEG NOS, START AND FINISH ?
unless 0<=XSEG and TOPSEG<=HISEG then -> VOUT
! CHECK THESE SEGMENTS ARE FREE
cycle K=XSEG,1,TOPSEG
unless DIROWN_CPOINT(K)=0 then -> VOUT; ! VM GAP TOO SMALL
repeat
! CHECK ENOUGH CBT FREE LIST CELLS
K=1; ! binary switch for segment count
RELSEG=XSEG
SECTLEN = 32
N = 0
SD == FL_SD
while N < NSECTS cycle
N = N + 1
SECTLEN = PAGS - (NSECTS - 1) << 5 if N = NSECTS
DA = (SD << 13) >> 13
J = 87 and -> VOUT if DA = (-1) >> 13; ! space never allocated
J = SCONNECT(RELSEG, DA ! (FSYS << 24), SECTLEN, C
APF, NEWCOPY, NOTDRUM, NONSLAVED, FLAGS); ! called for each section
-> VOUT unless J = 0
FLAGS = FLAGS ! 128
K = K + 1
RELSEG = RELSEG + K & 1
S = SD >> 19
exit unless 1 <= S <= NSD
SD == SDS(S)
repeat
J = 87 and -> VOUT unless N = NSECTS and S = 0
!
!------------- UPDATE USECOUNT IN DISC TABLE ------------------------
J = DISC USE COUNT(FSYS,+1)
-> VOUT UNLESS J = 0
!
!------------ UPDATE CON TABLE ----------------------------
! mark not-to-be-disconnected in FSYS if required.
CT == DIROWN_CONLIST(CONENT)
CT_FULL = FULL
CT_FSYS=FSYS
CT_NODISCO = NODISCO
!
DMONW(X'F0', SEG, FULL) IF PAGE MON # 0 AND INTEGER(PAGE MON) > 32
!
SEARCHENT=CONENT+1
J=XSEG
while J<=TOPSEG cycle
if J<=TOPFSEG then DIROWN_CPOINT(J)=CONENT c
else DIROWN_CPOINT(J)=RESERVED
J=J+1
repeat
!----------------------------- UPDATE FILE DESCRIPTOR -----------------
if MODE&2#0 start ; ! WRITE MODE
FL_ARCH=(FL_ARCH&(¬2)) ! 1; ! SET BITS 2**0 AND CLEAR 2**1
FL_CODES2=FL_CODES2 ! WRCONN
finish
if WSA#0 then FL_CODES2=FL_CODES2 ! WSALLOW
FL_ARCH=FL_ARCH ! 4; ! HAS-BEEN-CONNECTED BIT
FL_CCT=FL_CCT + 1 unless FL_CCT=255
FL_USE=FL_USE+1
J = DDAYNUMBER & 255
J = 1 IF J = 0
FL_DAYNO = J
if NEWSTACK#0 start
J=NOM(0); ! IGNORE FLAG
J=NOM(SEG)
if J#0 then -> VOUT
FL_CODES2=FL_CODES2 ! STACK
finish
J=0
VOUT:
VV(ADDR(F_SEMA), F_SEMANO)
OUT:
RESULT = OUT(J, "SIIIJJ")
end ; ! DCONNECTI
!
!-----------------------------------------------------------------------
!
ROUTINE REF NEW BLOCKS(INTEGER SEG)
! This routine arranges to reference a page in each block of segment SEG for which
! the new-copy bit is set in the CBT entry.
INTEGER ENT,DUMMY,VADDR,BLOCK BYTES
BLOCK BYTES=(BLKSI*EPAGE SIZE)<<10; ! BLOCK SIZE IN BYTES
VADDR=SEG<<18
ENT = SST(SEG)
DUMMY = 0
UNLESS ENT = ENDSST START
UNLESS CBTA(ENT)_TAGS & X'80' = 0 START
DUMMY = INTEGER(VADDR)
FINISH
IF ENT > CBT1 START
! DOUBLE ENTRY
UNLESS CBTA(ENT+1)_TAGS & X'80' = 0 START
DUMMY = DUMMY ! INTEGER(VADDR+BLOCK BYTES)
FINISH
FINISH
FINISH
WRSN("REF NEW BLOCKS SEG", SEG) UNLESS DUMMY=0
END ; ! REF NEW BLOCKS
!
!-----------------------------------------------------------------------
!
externalintegerfn DDISCONNECTI(string (31)FILE, integer FSYS, LO)
! Bits in parameter LO are as follows:
!
!
! 2**0 = 0 User call, disconnect only from user segments
! 1 from DSTOP, allow all disconnects and destroy
! temp and vtemp files
!
! 2**1 = 1 disconnect and destroy, but only if this is the
! only connection, flag 42 otherwise
!
integer J,DESTROY,DDD,PRIV VIOL
integer FINDAD, SD, PI, NPD
integer SEG,CODES,CODES2,CPT
integer LOSEG,FLAG,PAGES,NKB
string (31)UNAME, INAME, FNAME, INDEX, FULL
record (CTF)name CT
record (PDF)arrayname PDS
record (PDF)name PD
record (FF)name F
record (FDF)arrayname FDS
record (FDF)name FL
conststring (10)FN = "DISCONNECT"
FLAG = IN2(18)
-> OUT UNLESS FLAG = 0
!
FLAG = UFO("", FILE, UNAME, INAME, FNAME, INDEX, FULL)
-> OUT UNLESS FLAG = 0
!
FLAG = FINDA(INDEX, FSYS, FINDAD, 2)
-> OUT UNLESS FLAG = 0
!
F == RECORD(FINDAD)
!
FLAG = PP(ADDR(F_SEMA),F_SEMANO,FN)
-> OUT unless FLAG = 0
!
LOSEG=LOUSEG
LOSEG=4 if LO&1#0
cycle SEG=LOSEG,1,HISEG
CPT = DIROWN_CPOINT(SEG)
CT == DIROWN_CONLIST(CPT)
-> GOTFI if EQUAL(CT_FULL, FULL) = YES and CT_FSYS=FSYS
repeat
FLAG=39; ! NOT IN CONLIST
-> VOUT
GOTFI:
! top bit set in FSYS field means do not disconnect (except at
! DSTOP).
FLAG=84; ! restricted connect
-> VOUT UNLESS CT_NODISCO = 0 OR LO & 1 > 0; ! restricted connect
! Check that segment being disconnected does not contain the PC from
! which fn DDISCONNECT was called, else flag 21. (If this fn DDISCONNECTI
! was not called from DDISCONNECT butfrom somewhere in Director, this
! test is equally valid. A possibility not catered for at present
! is that the PC of the call of DDISCONNECT could be in the second
! segment of a PD file. This case would escape the test which follows).
FLAG=21; ! not allowed to disconnect calling file
*STLN_J
J=INTEGER(INTEGER(J)+8)>>18; ! PC from link DR 1 display down.
if J=SEG and LO&1=0 then -> VOUT; ! and OK from DSTOP
!
FDS == ARRAY(FINDAD+F_FDSTART, FDSF)
PDS == ARRAY(FINDAD+F_PDSTART, PDSF)
NPD = (F_SDSTART - F_PDSTART) // 9
FLAG = 78
J=NEW FIND(FINDAD,CBTA(SST(SEG))_DA<<8>>8,FNAME); ! FIND SPECIFIC GEN OF A FILE
-> VOUT if J=0
!
FL==FDS(J)
CODES = FL_CODES
CODES2 = FL_CODES2
if FL_USE=0 then monitor else FL_USE=FL_USE-1
FLAG = 0; ! ANTICIPATE SUCCESS
DESTROY=0
if FL_USE=0 start
if CODES2&STACK#0 then J=NOM(0); ! DE-NOMINATE
! Clear STACK, DISC ONLY, COMMS, WSALLOW, and WRCONN bits
FL_CODES2 = CODES2&B'10000110'
! Set DESTROY non-zero for destroy:
! 1 for TEMPFI and VTEMPFI, and 2 for OLDGEN.
! We destroy vtempfiles anyway, and tempfiles if this is the
! closedown call of DISCONNECT (LO&1=1). AlsO we destroy if 2**1 is set in param LO.
if CODES&VTEMPF#0 or (LO&1#0 and CODES&TEMPFI#0) c
or LO&2#0 then DESTROY=1
!
! IF 'NO ACCESS' OR 'DONT DESTROY'
! THEN DONT DESTROY !!
if CODES2 & OLD GE > 0 c
then DESTROY = 2 c
else start
if DESTROY = 1 c
and c
(FL_OWNP = 0 c
or c
FL_OWNP & 8 > 0) c
then DESTROY = 0 and FLAG = 51
finish
!
finish
! now either destroy the file or reference blocks in the file for which
! the new-copy bit is set in the corresponding CBT entry, to ensure that
! zero pages go back to the disc.
! we want to release the semaphore as soon as possible, as disconnection
! may involve disc transfers.
SD = 0
PRIV VIOL=CODES & VIOLAT
if DESTROY=0 start
FL_CODES=FL_CODES & (¬VIOLAT)
finish else start
PAGES=FL_PGS
!
if DESTROY = 1 start
! in the case of 'generation destroy', all adjustments to
! counts etc have already been done in NEWGEN
NKB = PAGES * 4
F_FILES = F_FILES - 1
F_TOTKB = F_TOTKB - NKB
!
unless FL_CODES & TEMPFS = NO start
F_TEMPFILES = F_TEMPFILES - 1
F_TEMPKB = F_TEMPKB - NKB
finish
!
unless FL_CODES & CHERSH = NO start
F_CHERFILES = F_CHERFILES - 1
F_CHERKB = F_CHERKB - NKB
finish
finish
!
SD = FL_SD
PI = FL_PHEAD
FL = 0
FL_NAME = ".NULL"
while 0 < PI <= NPD cycle
PD == PDS(PI)
PI = PD_LINK
PD = 0
repeat
finish
VOUT:
VV(ADDR(F_SEMA), F_SEMANO)
-> OUT UNLESS FLAG = 0 OR FLAG = 51
!
! Clear conlist entries
DMONW(X'E0', SEG, FULL) IF PAGE MON # 0 AND INTEGER(PAGE MON) > 32
!
DDD=0; ! "DESTROY" FLAG TO DCHAIN
DDD=1 if DESTROY#0
SEARCHENT=CPT if CPT<SEARCHENT; ! new search-start point
while DIROWN_CPOINT(SEG)=CPT cycle
REF NEW BLOCKS(SEG) if DESTROY=0 and PRIV VIOL#0
DCHAIN(SEG,DDD)
DIROWN_CPOINT(SEG)=0
SEG=SEG + 1
repeat
CT=0
while DIROWN_CPOINT(SEG)=RESERVED cycle
DIROWN_CPOINT(SEG)=0
SEG=SEG+1
repeat
if SD>0 start
J = NEW FILE DEAL(FINDAD,SD,PAGES)
ACTIVE BLOCK("DISCONNECT", FULL, FSYS) if J = 91
finish
J = DISC USE COUNT(FSYS,-1); ! decrement FSYS use_count in disc table.
UNLESS FSYSWARN = 0 START
CYCLE J = 99, -1, 0
EMPTYDVM AND EXIT IF FSYSUSECOUNT(J)#0=AV(J, 0)
REPEAT
FINISH
OUT:
FLAG = 42 IF LO & 2 > 0 = DESTROY AND FLAG = 0
RESULT = OUT(FLAG, "SII")
end ; ! DDISCONNECTI
!
!-----------------------------------------------------------------------
!
ROUTINE RECOVER2(INTEGER STARTSEG,ENDSEG,NEW LAST BLK, C
NEW LAST BLKLEN)
! Recovers CBT entries for blocks beyond NEWLAST BLK in segment SEG.
! NEW LAST BLK is a blockno counting from 0 in STARTSEG.
! NEW LAST BLKLEN is no of epages to be left in new last block.
! The routine also deals with more then one segment if necessary (ie. if
! ENDSEG#STARTSEG) and provided ENDSEG>STARTSEG, NEW LAST BLK may be
! greater than the number of blocks per segment.
INTEGER R,CUR,BLKS PER SEG,NEW ENDSEG
INTEGER CELL, C
BLKS PER SEG=256//(BLKSI*EPAGE SIZE)
MONITOR UNLESS NEW LAST BLK//BLKS PER SEG<=ENDSEG-STARTSEG
! First deal with whole segments (if any) beyond the new last segment
NEW ENDSEG=STARTSEG + NEW LAST BLK//BLKS PER SEG
CUR=ENDSEG
WHILE CUR>NEW ENDSEG CYCLE
DCHAIN(CUR,1); ! destroy option - pages are going to be de-allocated
CUR=CUR - 1
REPEAT
! Now set NEW LAST BLK to be new last block number within new last
! segment
NEW LAST BLK=NEW LAST BLK - (NEW ENDSEG-STARTSEG)*BLKS PER SEG
R = DSEGMENT(NEWENDSEG,0)
CELL=SST(NEW ENDSEG)
IF R = -1 START
WRSN("RECOVER2", NEW END SEG)
FINISH
!
C = CELL + NEW LAST BLK
CBTA(C)_TAGS = (CBTA(CELL)_TAGS & X'E0') ! NEW LAST BLK LEN - 1
!
IF NEW LAST BLK = 0 AND CELL > CBT1 START
! HAVE TO SHRINK FROM TWO BLOCKS TO ONE
C = GET1
MONITOR AND DSTOP(24) IF C < 0
CBTA(C) = CBTA(CELL)
IF STARTSEG = NEW END SEG START
CBTA(C)_LINK = CBTA(C)_LINK&127; ! Remove cont block bit
FINISH
SETSST(NEW END SEG, C)
RECOVER CBT(CELL)
FINISH
!
! reduce the seg table limit field for the new last segment
*LSS_(1); ! pick up PSR
*AND_X'FF0FFFFF'; ! remove ACR bits
*OR_X'00100000'; ! set ACR to one
*ST_(1); ! and put it back
ST(NEW ENDSEG)_APFLIM=(ST(NEW ENDSEG)_APFLIM&X'FFFC0FFF') ! C
((((NEW LAST BLK<<5) + NEW LAST BLK LEN)<<2 -1)<<10)
END ; ! RECOVER2
!
!-----------------------------------------------------------------------
!
ROUTINE BLOCK EXTEND(INTEGER SEG,BLKNO,NEWDA,ADDPAGES)
! Call supplies new disc address and new (and not smaller!) number of pages
! for the block. A call with ADDPAGES zero is used to replace the disc address for the
! block: required in the case where SECTSI>BLKSI, as the section has been moved.
! ADDPAGES can be non-zero only when BLONK specifies the last block of SEG.
INTEGER TAGS,ENT,DA
*LSS_(1); ! pick up PSR
*AND_X'FF0FFFFF'; ! remove ACR bits
*OR_X'00100000'; ! set ACR to one
*ST_(1); ! and put it back
ENT=SST(SEG) + BLKNO
! Replace the disc address. Tag bits to remain the same.
! Limit to be increased.
DA=CBTA(ENT)_DA
CBTA(ENT)_DA=(DA>>24<<24) ! NEWDA; ! PRESERVE FSYS NO
TAGS=CBTA(ENT)_TAGS
CBTA(ENT)_TAGS=(TAGS&X'E0') ! ((TAGS&31)+ADDPAGES)
! Increase segment limit in segment table
ST(SEG)_APFLIM=(ST(SEG)_APFLIM&X'FFFC03FF') ! C
((ST(SEG)_APFLIM>>10)&255 + ADD PAGES*EPAGE SIZE)<<10
END ; ! BLOCK EXTEND
!
!-----------------------------------------------------------------------
!
ENDOFLIST
!
!
!
!
!
!
! Here are the routines to create EXAC7
!
! TCH
! The descriptor in ACC points to a table of check bits. Successive
! bytes in the DR string are checked against the table as follows
! - pick up the bit addressed by the byte
! - proceed along the DR string until get
! a byte with a check bit of 1
! - DR is left at that byte
!
!
!
!%EXTERNALROUTINE EXAC7(%STRING(255)S)
!!
!%EXTERNALROUTINESPEC DEFINE(%STRING(255)S)
!%EXTERNALROUTINESPEC CLEAR(%STRING(255)S)
!%EXTERNALROUTINESPEC PROMPT(%STRING(255)S)
!%EXTERNALROUTINESPEC RSTRG(%STRINGNAME S)
!!
!%SYSTEMROUTINESPEC PHEX(%INTEGER N)
!!
!%INTEGERARRAY T(0:55); ! 7*8-1
!%INTEGER BD, AD, BYTE, W, CON, I, INDEX
!%STRING(31)FILE
!!
! BD = 7*256
! AD = ADDR(T(0))
! FILL(56*4, AD, 0)
!!
! %CYCLE BYTE = 1, 1, 254
! W = BYTE << 24
! CON = 0
! %CYCLE I = 0, 1, 7
! CON = CON + 1 %IF W >= 0
! %IF W<0 %OR I=7 %START
! %IF CON>0 %START; ! GOT FROM 1 TO 7 CONSECUTIVE ZERO BITS
! INDEX = 256*(CON-1)+BYTE
! *LDTB_BD
! *LDA_AD
! *LB_INDEX
! *LSS_1
! *ST_(%DR+%B)
! CON = 0
! %FINISH
! %FINISH
! W = W << 1
! %REPEAT
! %REPEAT
!!
! PROMPT("FILE: ")
! RSTRG(FILE)
! DEFINE("1,".FILE)
! SELECTOUTPUT(1)
! PRINTSTRING("%CONSTINTEGERARRAY EXAC7(0:55) = %C
!")
!!
! I = 0
! %CYCLE W = 0, 1, 55
! I = I + 1
! PRINTSTRING("X'")
! PHEX(T(W))
! %IF W = 55 %C
! %THEN PRINTSTRING("'") %C
! %ELSE PRINTSTRING("',")
! NEWLINE %AND I = 0 %IF I = 4
! %REPEAT
!!
! SELECT OUTPUT(0)
! CLOSESTREAM(1)
! CLEAR("")
!%END
!%ENDOFFILE
!
!
! Here follow the routines (commented out) which were used to create the
! array in fn FIND SMALL HOLE
!%INTEGERFN CONSEC HOLES(%INTEGER BYTE,HOLESIZE)
!! Result is 0 ("No") if there are not HOLESIZE consecutive zero bits in BYTE
!! 1 ("Yes") if the is a group of HOLESIZE zero bits in BYTE
!%INTEGER N,CONSEC
! BYTE=(¬BYTE)<<24; ! TO LH BYTE OF WORD
! N=0
! CONSEC=0
! %WHILE N<=7 %CYCLE
! %IF BYTE<0 %START
! ! Top bit set
! CONSEC=CONSEC+1
! %IF CONSEC=HOLESIZE %THEN %RESULT=1
! %FINISH %ELSE CONSEC=0
! BYTE=BYTE<<1
! N=N+1
! %REPEAT
! %RESULT=0
!%END; ! CONSEC HOLES
!
!-----------------------------------------------------------------------
!
!%ROUTINE SETBIT(%INTEGER TABAD,TABNO,BITNO,BITVAL)
!%INTEGER I,BD,INDEX
! BD=7*256
! INDEX=256*TABNO + BITNO
!!-----------------------------------------------------
! ! TYPE 0, VECTOR
! ! SIZE=0, BIT
! ! A=0, USC=0, BCI=0
! *LDTB_BD
! *LDA_TABAD
! *LB_INDEX
! *LSS_BITVAL
! *ST_(%DR+%B)
!%END; ! SETBIT
!
!-----------------------------------------------------------------------
!
!%EXTERNALROUTINE MAKE 7 TABLES(%STRING(255) S)
!%INTEGERARRAY TABLES(0:7*8-1)
!%INTEGER HOLESIZE,TABNO,N,YES OR NO,J,TABAD
!%STRING(31) FILE
! TABAD=ADDR(TABLES(0))
! %CYCLE HOLESIZE=1,1,7
! TABNO=HOLESIZE-1
! %CYCLE N=0,1,255
! YES OR NO=CONSEC HOLES(N,HOLESIZE)
! SETBIT(TABAD,TABNO,N,YES OR NO)
! %REPEAT
! %REPEAT
! PROMPT("FILE: ")
! RSTRG(FILE)
! DEFINE("1,".FILE)
! SELECT OUTPUT(1)
! PRINTSTRING(%C
!"%CONSTINTEGERARRAY TAB7(0:7*8-1)= %C
!")
! N=0
! %CYCLE J=0,1,7*8-1
! N=N+1
! PRINTSTRING("X'")
! PRHEX(TABLES(J))
! %UNLESS J=7*8-1 %THEN PRINTSTRING("',") %ELSE PRINTSTRING("'")
! %IF N=6 %THEN NEWLINE
! %IF N=8 %THEN NEWLINE %AND N=0
! %REPEAT
! NEWLINE
! SELECT OUTPUT(0)
! CLOSE STREAM(1)
! CLEAR("")
!%END; ! MAKE 7 TABLES
!
!-----------------------------------------------------------------------
!
LIST
INTEGERFN SMALL HOLE(INTEGER LO, HI, EPAGES, INTEGERNAME MASK)
!
! This function is used to find space for sections of 1 to 7 EPAGES within
! a byte. It tries first to find an 'exact' hole and, if that fails,
! to find a sufficiently large hole. If a hole is found, it constructs
! a MASK which is to be OR'd into a word in the bitmap. The result is
! the address of the byte containing the hole or zero.
!
CONSTINTEGERARRAY TABLE(0:111) = C
X'26362F36',X'26FF2F36',X'FFFFFFFF',X'FFFFFFFF',
X'26362F36',X'FFFFFFFF',X'2636FFFF',X'26FF2F36',
X'08483848',X'FFFFFFFF',X'08FF3848',X'0F483848',
X'0848FFFF',X'0F483848',X'08FF3848',X'0F483848',
X'0080FFFF',X'30804080',X'0F804080',X'30804080',
X'00FF4080',X'30804080',X'0F804080',X'30804080',
X'00FF8000',X'40008000',X'30008000',X'40008000',
X'0F008000',X'40008000',X'30008000',X'40008000',
X'0F000000',X'80000000',X'40000000',X'80000000',
X'30000000',X'80000000',X'40000000',X'80000000',
X'30000000',X'00000000',X'80000000',X'00000000',
X'40000000',X'00000000',X'80000000',X'00000000',
X'40000000',X'00000000',X'00000000',X'00000000',
X'80000000',X'00000000',X'00000000',X'00000000',
X'FFFFFFFF',X'FFFFFFFF',X'FFFFFFFF',X'FFFFFFFF',X'FFFFFFFF',X'FFFFFFFF',
X'FFFFFFFF',X'FFFFFFFE',
X'FFFFFFFF',X'FFFFFFFF',X'FFFFF8C8',X'FFC8F8C8',X'FFFFFFFF',X'FFC8F8C8',
X'FFFFF8C8',X'FFC8F8C8',
X'FFFFFFFF',X'F080C080',X'FF80C080',X'F080C080',X'FFFFC080',X'F080C080',
X'FF80C080',X'F080C080',
X'FFFF8000',X'C0008000',X'F0008000',X'C0008000',X'FF008000',X'C0008000',
X'F0008000',X'C0008000',
X'FF000000',X'80000000',X'C0000000',X'80000000',X'F0000000',X'80000000',
X'C0000000',X'80000000',
X'F0000000',X'00000000',X'80000000',X'00000000',X'C0000000',X'00000000',
X'80000000',X'00000000',
X'C0000000',X'00000000',X'00000000',X'00000000',X'80000000',X'00000000',
X'00000000',X'00000000'
INTEGER DR0, DR1, ADR0, ADR1, W0, W1, L, B, CON, T, M, J
L = HI - LO
DR0 = X'58000000' ! L
DR1 = LO
ADR0 = X'00000100'
ADR1 = ADDR(TABLE(0)) + ((EPAGES - 1) << 5)
!
CYCLE T = 0, 1, 1
*LD_DR0
*LSD_ADR0
*TCH_L =DR
*JCC_8,<NOTFOUND>
*STD_W0
!
B = BYTEINTEGER(W1) << 24
CON = 0
M = (-1) << (32 - EPAGES) >> ((W1 & 3) << 3)
MASK = M; ! save this mask
CYCLE J = 0, 1, 7
CON = CON + 1 IF B >= 0; ! count consecutive zero bits
M = M >> 1
IF B < 0 OR J = 7 START ; ! see how many we've got
RESULT = W1 IF CON = EPAGES OR (T = 1 AND CON >= EPAGES)
CON = 0
MASK = M
FINISH
B = B << 1
REPEAT
NOT FOUND:
ADR1 = ADR1 + 224; ! second part of table
REPEAT
RESULT = 0
END ; ! SMALL HOLE
!
!-----------------------------------------------------------------------
!
INTEGERFN FINDHOLE(INTEGER STARTAD, ENDAD)
! This function finds a zero byte in
! the interval STARTAD to ENDAD.
! Result is 0 if no hole is found
! #0 = address of byte containing the (start of the) hole
INTEGER DR0,DR1,LEN
LEN=ENDAD-STARTAD
DR0=X'58000000' ! LEN
DR1=STARTAD
*LD_DR0
*LB_0; ! test char = 0 (to find holes)
*SWNE_L =DR
! condition code now set as follows
! 0 reference byte not found
! 1 reference byte found, address in bottom half of DR
*JCC_8,<NOTFD>
*STD_DR0
RESULT =DR1
NOTFD:
RESULT =0
END ; ! FINDHOLE
!
!-----------------------------------------------------------------------
!
EXTERNALINTEGERFN SMALLOC(INTEGERNAME STARTPG, INTEGER FSYS, EPAGES, ZEROPAGS)
! For allocations up to 7 epages the alignment is arbitrary.
! For other allocations, align on a byte boundary.
! Search from bottom each time.
!
! Possible improvements:
!
! 1. Do not restrict small holes to lie within bytes
!
! 2. Do not restrict large holes to start on byte boundary
!
! 3. Do not restrict holes to lie within words
!
! 4. Compact 'old last sections' {Dchsize}
!
INTEGER B, TIMES, LOB, HIB, CAT, M, AD, AD3
INTEGER LOAD, HIAD
INTEGER MASK
INTEGER J
INTEGER OFFSET, WDAD
RECORD (DISCDATAF)DATA
CONSTINTEGERARRAY SIZE(1:5) = 32, 24, 16, 8, 7
J = FBASE2(FSYS, ADDR(DATA))
RESULT = J UNLESS J = 0
!
LOB = ((DATA_START + DATA_FILESTART + 31) & (-32))
HIB = DATA_END & (-32)
TIMES = 0
B = SYSAD(BITKEY, FSYS)
LOAD = B + LOB >> 3
HIAD = B + HIB >> 3
!
CAT = 5; ! compute 'category' of required hole
CYCLE
EXIT IF EPAGES <= SIZE(CAT)
CAT = CAT - 1
REPEAT
SMOVER:
TIMES = TIMES + 1
!
IF CAT = 5 START ; ! find a hole and the corresponding word mask
AD = SMALL HOLE(LOAD, HIAD, EPAGES, M)
FINISH ELSE START
MASK = (-1) << (32 - EPAGES)
AD = LOAD - 1
CYCLE
AD = FINDHOLE(AD+1, HIAD)
EXIT IF AD = 0; ! no zero byte found
AD3 = AD & 3
M = MASK >> (AD3 << 3)
EXIT IF CAT = 4; ! only wanted a zero byte
EXIT IF AD3 < CAT AND M & (INTEGER(AD &(-3))) = 0
REPEAT
FINISH
!
IF AD = 0 START ; ! No hole found
DOPER2("FSYS ".ITOS(FSYS)." FULL")
RESULT = 10; ! FULL
FINISH
!
J = PP(B,FSYS << 16, "SMALLOC"); ! Take the semaphore
-> SMOVER UNLESS J = 0
!
WDAD = AD & (¬3); ! Set bits if all clear
IF INTEGER(WDAD)&M = 0 C
THEN INTEGER(WDAD)=INTEGER(WDAD) ! M C
ELSE M = 0
!
VV(B, FSYS << 16)
-> SMOVER IF M = 0; ! Some bits were already set, try again
!
*LSS_M; ! we know mask is non-zero
*SHZ_OFFSET; ! count zero bits at top
STARTPG = (WDAD-B)<<3 + OFFSET
!
UNLESS ZEROPAGS = 0 START ; ! Clear the new pages
J = MOVESECTION(-1, 0, FSYS,STARTPG,EPAGES)
IF J#0 START
-> SMOVER IF TIMES<10
RESULT = J; ! 10 disc zero-writes failed
FINISH
FINISH
!
RESULT = 0
END ; ! SMALLOC
!
!-----------------------------------------------------------------------
!
!
externalintegerfn DCREATEF(string (255)FILE,
integer FSYS, NKB, ALLOC, LEAVE, INTEGERNAME DA)
! IF ALLOC 2**0 = 0 THEN MAKE THE INDEX ENTRY BUT DO NOT ALLOCATE
! THE PAGES
! 1 NORMAL FILE CREATE
! AND IF 2**1 = 0 MAKE FD AVAIABLE ON COMPLETION
! 1 LEAVE FD UNAVAILABLE
! AND IF 2**2 SET THEN TEMPFI
! AND IF 2**3 SET THEN VTEMPF
! AND IF 2**4 SET THEN ZERO PAGES
! AND IF 2**5 SET THEN CREATE 'CHERISHED'
! AND IF 2**6 SET THEN SET EEP TO TOP BYTE OF 'ALLOC'
! POSSIBLE ERROR RESULTS
! 16 ALREADY EXISTS
! 17 INSUFFICIENT FREE CELSS
! 18 INVALID NAME
! 26 SCONNECT ERROR
! 28 INSUFFICIENT FREE CBT CELLS
! 37 USER NOT KNOWN
! 41 INVALID SIZE
!
integer NSD, NFD, S, NS, LINK
integer J, STARTPG,MAXKB,MAXFILE,FINDAD,FI
integer NUM,EP,R1,NP,EPAGES
STRING (31)UNAME, INAME, FNAME, INDEX, FULL
record (FF)name F
record (FDF)arrayname FDS
integerarrayname SDS
record (FDF)name FL
integername SD
conststring (9)FN = "DCREATEF "
DA = -1
J=IN2(13)
-> OUT unless J = 0
!
J=8
-> OUT UNLESS 0 < NKB <= (64 << 10); ! ie a max of 64Mbytes
EPAGES=(NKB+3) >> 2
NKB=EPAGES << 2
!
J = UFO("", FILE, UNAME, INAME, FNAME, INDEX, FULL)
-> OUT UNLESS J = 0
!
J=MAP FILE INDEX(INDEX, FSYS, FINDAD, FN)
-> OUT UNLESS J = 0
!
F == RECORD(FINDAD)
FDS == ARRAY(FINDAD + F_FDSTART, FDSF)
SDS == ARRAY(FINDAD + F_SDSTART, SDSF)
!
J=41; ! single file limit exceeded
MAXFILE=F_MAXFILE
MAXFILE=DEFAULT MAXFILE if MAXFILE=0
unless EPAGES<=MAXFILE>>2 then -> VOUT; ! single file limit exceeded
!
J=83; ! total (non-temp) filespace limit exceeded
MAXKB=F_MAXKB
if MAXKB=0 then MAXKB=DEFAULT MAXKB
if ALLOC & (TEMPFI ! VTEMPF) = 0 c
andc
F_TOTKB-F_TEMPKB+NKB>MAXKB c
then -> VOUT
!
NUM=(EPAGES+31) >> 5
J = 0
NFD = (F_SIZE << 9 - F_FDSTART) >> 5
for FI = LEAVE, 1, NFD cycle
FL == FDS(FI)
if FL_NAME = "" or FL_NAME = ".NULL" start
J = FI IF J = 0; ! save first free entry
EXIT IF FL_NAME = ""; ! reached end of used entries
FINISH
!
IF EQUAL(FL_NAME, FNAME) = YES AND FL_CODES2 & OLDGE = 0 START
DA = (FSYS<<24) ! (FL_SD<<13>>13)
J = 16; ! file already exists
-> SAVE FD
FINISH
REPEAT
!
J = 15 AND -> VOUT IF J = 0; ! no free FDs
!
FL == FDS(J)
FL = 0; ! for safety
FL_NAME = FNAME
FL_USE = 1 IF LEAVE < 3; ! #STK, #LCSTK and #DGLA do not get connected
FL_SD = (-1) >> 13
FL_PGS = EPAGES
FL_CODES = UNAVA
!
if NUM > 1 start ; ! more than 1 section, so need some SDs
J = 43; ! in case there are no free SDs
NS = NUM - 1
NSD = (F_FDSTART - F_SDSTART) >> 2; ! number of SDs
SD == FL_SD
cycle S = 1, 1, NSD
if SDS(S) = 0 start ; ! found a free SD
SD = SD ! (S << 19)
SD == SDS(S)
SD = (-1) >> 13
NS = NS - 1
exit if NS = 0
finish
repeat
!
UNLESS NS = 0 START ; ! could not get enough
S = FL_SD
CYCLE
LINK = S >> 19
EXIT UNLESS 1 <= LINK <= NSD
S = SDS(LINK)
SDS(LINK) = 0
REPEAT
FL = 0
FL_NAME = ".NULL"
-> VOUT
FINISH
!
finish
SD == FL_SD
VV(ADDR(F_SEMA), F_SEMANO)
if ALLOC&1#0 start
EP=EPAGES
while EP>0 cycle
NP=EP
NP=32 if NP>32
R1=SMALLOC(STARTPG,FSYS,NP,ALLOC&16)
!
if R1 # 0 start ; ! allocate fails
J = NEW FILE DEAL(FINDAD, FL_SD, EPAGES)
ACTIVE BLOCK(FN, FULL, FSYS) if J = 91
J = PP(ADDR(F_SEMA), F_SEMANO, FN)
-> OUT unless J = 0
FL = 0
FL_NAME = ".NULL"
J = R1
-> VOUT
finish
!
DA = (FSYS<<24) ! STARTPG IF DA = -1
SD = ((SD >> 19) << 19) ! STARTPG
LINK = SD >> 19
SD == SDS(LINK) if LINK > 0
EP=EP - NP
repeat
finish ; ! ALLOC # 0
J = PP(ADDR(F_SEMA), F_SEMANO,FN)
-> OUT unless J = 0
F_TOTKB=F_TOTKB + NKB
!
unless ALLOC & TEMPFS = NO start
! temporary
F_TEMPKB = F_TEMPKB + NKB
F_TEMPFILES = F_TEMPFILES + 1
finish
!
unless ALLOC & 32 = NO start
! cherished
F_CHERKB = F_CHERKB + NKB
F_CHERFILES = F_CHERFILES + 1
finish
!
F_FILES=F_FILES+1
! Clear UNAVA unless 2**1 set in ALLOC
FL_CODES=0 if ALLOC&2=0
if ALLOC&4#0 then FL_CODES=FL_CODES ! TEMPFI
if ALLOC&8#0 then FL_CODES=FL_CODES ! VTEMPF
if ALLOC&16=0 then FL_CODES=FL_CODES ! VIOLAT
if ALLOC&32#0 then FL_CODES=FL_CODES ! CHERSH
if ALLOC&64#0 then FL_EEP=ALLOC>>24
IF ALLOC & 128 # 0 THEN FL_CODES = FL_CODES ! NOARCH
FL_OWNP = 7
J = DDAYNUMBER & 255
J = 1 IF J = 0
FL_DAYNO = J
J=0
SAVE FD:
LAST FD = FL
VOUT:
VV(ADDR(F_SEMA), F_SEMANO)
OUT:
RESULT = OUT(J, "SIIX")
end ; ! DCREATEF
!
!-----------------------------------------------------------------------
!
EXTERNALINTEGERFN DMON(STRING (255)S)
EXTERNALINTEGERFNSPEC DLOCK(INTEGER A,L, LONGINTEGERNAME LI)
EXTERNALINTEGERFNSPEC DUNLOCK(INTEGER A)
INTEGER J, SEG, GAP, DA, ENT
LONGINTEGER LI
CONSTSTRING (17)FULL = "VOLUMS.PAGEFAULTS"
STRING (63)FILE
CONSTINTEGER NKB = 128 {16}
CONSTINTEGER WR = 3
RECORDFORMAT HF(INTEGER NEXT, RELST, MAX, A, B, C, CYCLIC, C
READ)
RECORD (HF)NAME H
RECORD (PARMF)NAME P
P == RECORD(OUTPAD)
P = 0
J = 99; ! silly fail flag
!
IF S = "" START ; ! monitor OFF
UNLESS PAGE MON = 0 START ; ! not already off
J = 0
*OUT_20; ! inform Supervisor
! %RESULT = 98 %IF P_DEST < 0; ! ignore failures
J = DUNLOCK(PAGE MON)
PAGE MON = 0
J = DDISCONNECTI(FULL, -1, 0)
WRSS(FULL, " OFF")
FINISH
RESULT = J
FINISH
!
IF S = "SWITCHON" START
CYCLE J = 4, 4, NKB-4
ENT = INTEGER(PAGEMON + J<<10)
REPEAT
J = 0
-> SWITCH ON
FINISH
!
! *** turn monitor ON ***
!
RESULT = J UNLESS PAGE MON = 0
!
SEG = 0
GAP = 0
J = DCREATEF(FULL, -1, NKB, (3<<24)+64+1, LEAVE, DA)
RESULT = J IF 0 # J # 16
J = DCONNECTI(FULL, -1, WR, DIRAPF, SEG, GAP)
RESULT = J IF 0 # J # 34
!
PAGE MON = SEG << 18
WRSS(FULL, " ON")
H == RECORD(PAGE MON)
H = 0
H_NEXT = 32
H_RELST = 32
H_CYCLIC = 32
H_MAX = NKB << 10
H_READ = 32
!
J = DLOCK(PAGE MON, NKB << 10, LI); ! lock down
!
IF S = "LATER" START
PAGE MON = 0 UNLESS J = 0
RESULT = J
FINISH
SWITCH ON:
CYCLE SEG = 35, 1, HISEG; ! list current segments
ENT = SST(SEG)
UNLESS ENT = ENDSST START
FILE = DIROWN_CONLIST(DIROWN_CPOINT(SEG))_FULL
DMONW(X'F0', SEG, FILE); ! 'F0' = connect
FINISH
REPEAT
!
IF J = 0 START
P_P1 = PAGE MON
*OUT_20; ! inform Supervisor
J = 98 IF P_DEST < 0
FINISH
RESULT = J
END
!
!-----------------------------------------------------------------------
!
externalintegerfn DDESTROYF(string (31)FILE, integer FSYS, DEALLOC)
! BITS IN DEALLOC :
! 2**0 DEALLOCATE PGS IF SET, always do this
! 2**1 DESTROY EVEN IF "UNAVA" OR "OFFER" SET (FOR FN DTRANSFER)
! 2**2 DESTROY EVEN IF USE IS NON--ZERO OR UNAVA SET (FOR PROCESS
! 1 TO DESTROY SIGSTK"S - NEVER DISCONNECTED)
integer FINDAD, FI, SD, PI, NPD
integer J,PAGES, NKB, K
STRING (31)UNAME, INAME, FNAME, INDEX, FULL
record (FDF)name FL
record (FF)name F
record (FDF)arrayname FDS
record (PDF)arrayname PDS
record (PDF)name PD
conststring (10)FN = "DDESTROYF "
!
J = IN2(16)
-> OUT UNLESS J = 0
!
J = UFO("", FILE, UNAME, INAME, FNAME, INDEX, FULL)
-> OUT UNLESS J = 0
!
J = FINDA(INDEX, FSYS, FINDAD, 2)
-> OUT UNLESS J = 0
!
F == RECORD(FINDAD)
J = PP(ADDR(F_SEMA),F_SEMANO,FN.FULL)
-> OUT unless J = 0
!
FDS == ARRAY(FINDAD + F_FDSTART, FDSF)
PDS == ARRAY(FINDAD + F_PDSTART, PDSF)
NPD = (F_SDSTART - F_PDSTART) // 9
!
J=32; ! FILE DOES NOT EXIST
FI=NEW FIND(FINDAD,0,FNAME)
if FI=0 then -> VOUT; ! FILE DOES NOT EXIST
!
FL==FDS(FI)
if DEALLOC&4=0 start ; ! SET ONLY BY PROCESS 1 ON DESTROYING SIGSTKS
J = 40; ! FILE CONNECTED
if FL_USE#0 then -> VOUT
if DEALLOC&2=0 start ; ! set only by DTRANSFER
! BOB THINKS 'UNLESS CALLER PRIVI'
if (FL_OWNP = 0 or FL_OWNP & 8 > 0) and DTRYING >= 0 c
then J = 51 and -> VOUT; ! NO ACCESS OR DONT DESTROY
J=20; ! file is on offer
if FL_CODES&OFFER#0 then -> VOUT
J=5; ! FILE NOT READY
if FL_CODES&UNAVA#0 then -> VOUT
finish
finish
PAGES=FL_PGS
!
NKB = PAGES * 4
!
F_TOTKB = F_TOTKB - NKB
!
unless FL_CODES & TEMPFS = NO start
! temporary
F_TEMPKB = F_TEMPKB - NKB
F_TEMPFILES = F_TEMPFILES - 1
finish
!
unless FL_CODES & CHERSH = NO start
! cherished
F_CHERKB = F_CHERKB - NKB
F_CHERFILES = F_CHERFILES - 1
finish
!
F_FILES = F_FILES-1
!
PI = FL_PHEAD
while 0 < PI <= NPD cycle
PD == PDS(PI)
PI = PD_LINK
PD = 0
repeat
!
SD = FL_SD
FL = 0
FL_NAME = ".NULL"
!
VV(ADDR(F_SEMA), F_SEMANO)
J = NEW FILE DEAL(FINDAD,SD,PAGES)
ACTIVE BLOCK("DESTROY", FULL, FSYS) if J = 91
J = 0
-> OUT
VOUT:
VV(ADDR(F_SEMA), F_SEMANO)
OUT:
UNLESS FSYSWARN = 0 START
CYCLE K = 99, -1, 0
IF FSYSUSECOUNT(K) # 0 = AV(K, 0) C
THEN EMPTYDVM AND EXIT
REPEAT
FINISH
!
RESULT = OUT(J, "SII")
end ; ! DDESTROYF
!
!-----------------------------------------------------------------------
!
EXTERNALROUTINE OUTPUT MESSAGE TO FEP(RECORD (FEPF)ARRAYNAME FEPS,
INTEGER FE, TYPE, MESSAGE ADDR, MESSAGE LENGTH, STRM ID, PROTOCOL)
INTEGER CURSOR, ADD, TOTAL LEN, BUFF LEN, FLAG, ZERO, J
INTEGER SEMADR, SEMANO
RECORD (PARMF)P
RECORD (DIRCOMF)NAME DIRCOM
!
!
!
ROUTINE PUT(INTEGER ADR, LEN)
INTEGER L
L = BUFF LEN - CURSOR; ! space remaining in buffer, >0
IF LEN > L START ; ! have to split
MOVE(L, ADR, ADD + CURSOR)
MOVE(LEN - L, ADR + L, ADD)
CURSOR = LEN - L
FINISH ELSE START
MOVE(LEN, ADR, ADD + CURSOR)
CURSOR = CURSOR + LEN
CURSOR = 0 IF CURSOR >= BUFF LEN
FINISH
END ; ! PUT
!
!
!
ZERO = 0
TOTAL LEN = 1+1+2+MESSAGE LENGTH+1
IF FEPS(FE)_AVAILABLE # YES THEN RETURN
!
! This routine is called by DIRECT and in user processes by DSETMODE.
! The fep buffers are in the same segment as the record format FEPS and
! the field OUT BUFF CONN ADDR gives the offset into it.
!
ADD = ADDR(FEPS(0))>>18<<18 + FEPS(FE)_FEP DETAILS(PROTOCOL)_OUT BUFF CON ADDR<<14>>14
J = INTEGER(ADD); ! page fault on buffer before claiming semaphore
!
DIRCOM == RECORD(SYSAD(DIRCOMKEY, -1))
SEMADR = ADDR(DIRCOM_FEPSEMA)
SEMANO = X'40000002'
FLAG = PP(SEMADR, SEMANO, "FEPoutmsg")
!
CURSOR = FEPS(FE)_FEP DETAILS(PROTOCOL)_OUTPUT CURSOR
BUFF LEN = FEPS(FE)_FEP DETAILS(PROTOCOL)_OUT BUFF LENGTH
PUT(ADDR(TOTAL LEN)+3,1)
PUT(ADDR(TYPE)+3,1)
PUT(ADDR(STRM ID)+2,2)
PUT(ADDR(ZERO),1)
PUT(MESSAGE ADDR, MESSAGE LENGTH)
P = 0
P_DEST = STREAM CONTROL MESSAGE
P_SRCE = FE<<8!FEP OUTPUT REPLY MESS
P_P1 = FEPS(FE)_FEP DETAILS(PROTOCOL)_OUTPUT STREAM
P_P2 = CURSOR
J = DPON3I("",P,0,0,7)
FEPS(FE)_FEP DETAILS(PROTOCOL)_OUTPUT CURSOR = CURSOR
IF FLAG = 0 THEN VV(SEMADR, SEMANO)
END ; ! OUTPUT MESSAGE TO FEP
!
!-----------------------------------------------------------------------
!
!<DCHACCESS
externalintegerfn DCHACCESS(string (31)FILE INDEX, FILE,
integer FSYS, NEWMODE)
!
! This procedure is used to change the access mode (Segment table access
! permission field, APF) for connected file FILE belonging to file index
! FILE INDEX on disc-pack FSYS (0-99). Bits in NEWMODE have the following
! meanings (as in the MODE parameter to procedure DCONNECT):
! 2**0 set - read access to be allowed
! 2**1 set - write access to be allowed
! 2**2 set - execute access to be allowed
! 2**9 set - advisory sequential(not set, then clear)
! The bottom 3 bits of NEWMODE must have one of the values 1, 3
! or 5. The file must be permitted to the caller in the appropriate
! mode.
!>
integer J, I, PRM, AS, C, FINDAD, W
integer SEG, READAPF, EXECBIT, WRITEAPF, OLDWRITEAPF
STRING (31)UNAME, INAME, FNAME, INDEX, FULL
RECORD (CTF)NAME CT
record (FF)name F
record (FDF)arrayname FDS
record (FDF)name FL
conststring (10)FN = "DCHACCESS "
J = IN2(7)
-> OUT unless J = 0
!
J = 8
W = NEWMODE & 7
-> OUT unless (W=1 or W=3 or W=5)
-> OUT unless NEWMODE & X'FFFFFDF8' = 0
-> OUT if FSYS<0
AS = (NEWMODE & X'200') >> 3; ! 2**6 for advisory-sequential
!
J = UFO(FILE INDEX, FILE, UNAME, INAME, FNAME, INDEX, FULL)
-> OUT UNLESS J = 0
!
J = MAP FILE INDEX(INDEX, FSYS, FINDAD, FN)
-> OUT UNLESS J = 0
!
F == RECORD(FINDAD)
FDS == ARRAY(FINDAD + F_FDSTART, FDSF)
!
J = 32; ! not exist/no access
I = NEW FIND(FINDAD, 0, FNAME)
-> VOUT if I = 0
FL == FDS(I)
!
PRM = NEW FILE PERM(FINDAD, FL, PROCUSER)
IF PRM = -1 START
PRM = F_EEP & 7
PRM = PRM ! 1 IF PRM & 6 > 0
FINISH
-> VOUT if W & PRM < W
!
J = 33
-> VOUT if NEWMODE&2#0 and FL_USE>1 and FL_CODES2&WSALLOW=0
!
*LSS_(1); ! pick up PSR
*AND_X'FF0FFFFF'; ! remove ACR bits
*OR_X'00100000'; ! set ACR to one
*ST_(1); ! and put it back
!
J=39; ! file not connected
cycle SEG=LOUSEG,1,HISEG
CT == DIROWN_CONLIST(DIROWN_CPOINT(SEG))
if EQUAL(CT_FULL, FULL) = YES and CT_FSYS=FSYS start
J = 84
-> VOUT unless CT_NODISCO = 0; ! not allowed to change access
READAPF=ST(SEG)_APFLIM & X'00F00000'
EXECBIT=0
EXECBIT=X'10000000' if NEWMODE&4#0
WRITEAPF=0
WRITEAPF=READAPF<<4 if NEWMODE&2#0
OLDWRITEAPF=ST(SEG)_APFLIM & X'0F000000'
ST(SEG)_APFLIM = (ST(SEG)_APFLIM & X'E0FFFFFF') ! EXECBIT ! WRITE APF
C = SST(SEG); ! CBT index
CBTA(C)_LINK = CBTA(C)_LINK & X'BF' ! AS
if C > CBT1 c
then CBTA(C+1)_LINK = CBTA(C+1)_LINK & X'BF' ! AS
finish else start
if J = 84 start ; ! file has been found
! Remove WR-CONNected bit if new mode doesn't contain write
! and usecount is one.
if NEWMODE&2=0 and FL_USE=1 c
then FL_CODES2= FL_CODES2&(¬WRCONN)
! do a null
! do an OUT to get an activate to clear the slaves.
*OUT_4
J=0
exit
finish
finish
repeat
VOUT:
VV(ADDR(F_SEMA), F_SEMANO)
OUT:
RESULT = OUT(J, "SSII")
end ; ! DCHACCESS
!
!-----------------------------------------------------------------------
!
!<DCHSIZE
externalintegerfn DCHSIZE(string (31)FILE INDEX, FILE,
integer FSYS, NEWKB)
!
! The physical size of file FILE belonging to file index FILE INDEX on
! disc-pack FSYS (or -1) is altered (if necessary) so that its new size
! is NEWKB Kbytes. The size may not be reduced to zero. The file may
! be connected in the caller's virtual memory (only). If the caller is
! not the file owner, he must either have W access to the file index or
! be privileged.
!>
!
!
!
integer OLDPGS; !number of pages to start with
integer NEWPGS; ! number of pages required
integer XPGS; ! number of pages to be added or removed
integer XKB; ! number of Kbytes to be added or removed
integer MAXKB; ! file space limit from file index
integer MAXFILE; ! also from file index
integer PGS IN OLD LAST SECT
integer PGS IN NEW LAST SECT
integer OLDSEGS; ! number of segments to start with
integer NEWSEGS; ! number of segments required
integer OLDSECTS; ! number of sections to start with
integer NEWSECTS; ! number of sections required
integer XSECTS; ! number of sections to be added or removed
integer B, W; ! used in relocating last section when no change in size
!
integer J,K,L,N,LASTSEG,CON,GAP
integer RELSEG,APF,NOTDRUM
integer ADD TO LAST SECT
integer SLAVEBIT,ZERALLOC
integer STARTP
integer CELL, FLAGS
integer S, FINDAD, DA, LINK, NSD
STRING (31)UNAME, INAME, FNAME, INDEX, FULL
record (FDF)name FL
integerarrayname SDS
record (FF)name F
record (FDF)arrayname FDS
integername SD0, SD, SDX
conststring (8)FN = "DCHSIZE "
K=IN2(9)
-> OUT UNLESS K = 0
!
K = UFO(FILE INDEX, FILE, UNAME, INAME, FNAME, INDEX, FULL)
-> OUT UNLESS K = 0
!
K=93
-> POK IF UNAME = PROCUSER
-> POK IF DTRYING < 0
-> POK IF FILE INDEX PERM(INDEX, FSYS) & 2 > 0
-> OUT
POK:
K=8; ! BAD PARAM - SILLY SIZE
NEWPGS=(NEWKB + 3) >> 2
NEWKB = NEWPGS << 2; ! ie rounded up to next page
NEWSEGS = (NEWPGS + 63) >> 6
-> OUT UNLESS NEWPGS > 0
!
K=MAP FILE INDEX(INDEX, FSYS, FINDAD, FN)
-> OUT UNLESS K = 0
!
F == RECORD(FINDAD)
FDS == ARRAY(FINDAD + F_FDSTART, FDSF)
SDS == ARRAY(FINDAD + F_SDSTART, SDSF)
NSD = (F_FDSTART - F_SDSTART) >> 2
MAXFILE=F_MAXFILE
MAXFILE=DEFAULT MAXFILE if MAXFILE=0
MAXKB = F_MAXKB
MAXKB = DEFAULT MAXKB if MAXKB = 0
!
K = 32; ! file does not exist
J = NEWFIND(FINDAD, 0, FNAME)
-> VOUT if J = 0
!
FL == FDS(J)
OLDPGS = FL_PGS
K = 87
-> VOUT IF OLDPGS = 0
OLDSEGS = (OLDPGS + 63) >> 6
OLDSECTS = (OLDPGS + 31) >> 5
NEWSECTS = (NEWPGS + 31) >> 5
XSECTS = NEWSECTS - OLDSECTS
PGS IN OLD LAST SECT = OLDPGS - (OLDSECTS - 1) << 5
PGS IN NEW LAST SECT = NEWPGS - (NEWSECTS - 1) << 5
!
K = 41; ! single file limit exceeded
-> VOUT if NEWKB > MAXFILE
!
XPGS = NEWPGS - OLDPGS; ! number to increase by (-, +, or 0)
XKB = XPGS << 2
!
K = 83; ! total file space limit exceeded
-> VOUT if XPGS > 0 andc {increasing size of file}
FL_CODES & TEMPFS = 0 andc {and its not temporary}
F_TOTKB - F_TEMPKB + XKB > MAXKB andc {and limit exceeded}
FNAME # "#ARCH" {but its not #ARCH}
!
CON = CONSEG(FULL, FSYS, GAP); ! is file connected in this VM?
!
IF FL_USE > 0 START ; ! file is in use somewhere
K = 0
-> VOUT IF XPGS = 0; ! if we are just fiddling, exit
K = 84
-> VOUT IF CON < 0; ! restricted connect
K = 42
-> VOUT IF CON = 0; ! connected in another VM
-> VOUT IF FL_USE > 1; ! ditto
FINISH
!
if CON > 0 start ; ! file is connected in this VM
CELL = SST(CON)
FLAGS = CBTA(CELL)_LINK ! 128; ! any subs blocks will be conts
LASTSEG = CON + OLDSEGS - 1
if XPGS > 0 start ; ! connected and extending
K = 28; ! insufficient CBT cells
-> VOUT if XSECTS > (CBT2 - CBT1 - 1)
K = 35; ! gap too small
-> VOUT if NEWSEGS > GAP
finish
finish
!
SD0 == FL_SD
SD == SD0; ! Now find last SD in chain
J = 0
while J < OLDSECTS cycle
J = J + 1
S = SD >> 19
exit unless 1 <= S <= NSD
SD == SDS(S)
repeat
K = 87
-> VOUT unless J = OLDSECTS and S = 0
!
if XSECTS>0 start ; ! extend the chain of SDs
J = XSECTS
SDX == SD
!
cycle S = 1, 1, NSD
if SDS(S) = 0 start ; ! a free SD
SDX = SDX ! (S << 19); ! link to new SD
SDX == SDS(S)
SDX = (-1) >> 13; ! set DA to '-1' in case allocate fails
J = J - 1
-> ENOUGH if J = 0
finish
repeat
!
LINK = SD >> 19; ! failed to get enough new SDs
SD = SD << 13 >> 13; ! so tidy up
while LINK > 0 cycle
SDX == SDS(LINK)
LINK = SDX >> 19
SDX = 0
repeat
K = 43; ! not enough SDs
-> VOUT
!
finish
ENOUGH:
FL_CODES = FL_CODES ! UNAVA; ! mark file UNAVAILABLE while we 'adjust' it
VV(ADDR(F_SEMA), F_SEMANO)
-> INCREASE if XPGS > 0
!
if CON > 0 > XPGS start ; ! file is connected and we are shrinking
RECOVER2(CON, LASTSEG, NEWSECTS-1, PGS IN NEW LAST SECT); ! recover blocks
J = LASTSEG; ! and amend conlist
while J >= CON + NEWSEGS cycle
DIROWN_CPOINT(J) = RESERVED
J = J - 1
repeat
finish
!
SD == FL_SD; ! de-allocate surplus pages
N = 0
while N < OLDSECTS cycle
N = N + 1
LINK = SD >> 19
if N >= NEWSECTS start
STARTP = (SD << 13) >> 13
K = STARTP
L = 32
L = PGS IN OLD LAST SECT if N = OLDSECTS
if N = NEWSECTS start
SDX == SD; ! leave SDX pointing at new last SD and
! discard any beyond
SD = STARTP; ! clear link in new last sect
L = L - PGS IN NEW LAST SECT
STARTP = STARTP + PGS IN NEW LAST SECT
finish
J = 0
J = DEAL(FSYS, K, STARTP, L) if L > 0
ACTIVE BLOCK("CHSIZE1", FULL, FSYS) if J = 91
SD = 0 if N > NEWSECTS
finish
exit unless 0 < LINK <= NSD
SD == SDS(LINK)
repeat
K = 87 and -> OUT unless LINK = 0 and N = OLDSECTS
!
IF XPGS < 0 START ; ! we are reducing size of file
-> RELOCATE IF PGS IN NEW LAST SECT < 9
-> UPDATE INDEX
FINISH
!
B = SYSAD(BITKEY, FSYS); ! size remaining same, get addr of bitmap
K = SDX; ! first page of last sect
W = INTEGER(B + (K>>5<<2)); ! word in bitmap containing sect
!
J = K & 31; ! start page within word
-> RELOCATE IF J > 0 ANDC {sect not at start of word}
W << (J-1) >= 0 {previous page is free}
!
J = (K + PGS IN NEW LAST SECT) & 31; ! page after this sect
-> RELOCATE IF J > 0 ANDC { sect not at end of word}
W << J >= 0 { following page free}
!
K = 0; ! release file and exit
FL_CODES = FL_CODES & (¬UNAVA)
-> OUT
RELOCATE:
! WRSN("Dchsize RELOCATES " . FULL, PGS IN NEW LAST SECT) %IF XPGS = 0
!
if CON > 0 start
LASTSEG = CON + NEWSEGS - 1
J = DSEGMENT(LASTSEG, 0)
if J = -1 start
WRSN("DCHSIZE RELOCATE SEG", LASTSEG)
finish
finish
!
cycle N = 1, 1, 10; ! have 10 attempts to move
J = SMALLOC(STARTP, FSYS, PGS IN NEW LAST SECT, NO); ! NO = DONT CLEAR
exit unless J = 0; ! give up
!
J = MOVESECTION(FSYS, SDX, FSYS, STARTP, PGS IN NEW LAST SECT)
if J = 0 start
J = DEAL(FSYS, 0, SDX, PGS IN NEW LAST SECT)
ACTIVE BLOCK("CHSIZE3", FULL, FSYS) if J = 91
SDX = STARTP
if CON > 0 c
then BLOCK EXTEND(LASTSEG, (NEWSECTS - 1) & 1, c
STARTP, 0); ! adjust DA field in CBT entry
exit ; ! success
finish
J = DEAL(FSYS, 0, STARTP, PGS IN NEW LAST SECT)
ACTIVE BLOCK("CHSIZE4", FULL, FSYS) if J = 91
repeat
-> UPDATE INDEX
!
INCREASE: !-------------------------- INCREASE-----------------------
!
!Get here with :
! - SD mapped to old last SD, with
! (possibly) more new SD's
! hanging on
if CON>0 start
if OLDPGS & 63 > 0 start ; ! last segment not full
REF NEW BLOCKS(LAST SEG)
J = DSEGMENT(LAST SEG,0)
if J = -1 start
PRINTSTRING("DCHSIZE")
WRITE(LASTSEG, 1)
WRITE(SST(LASTSEG), 1)
NEWLINE
finish
finish
GIVE APF(APF,NOTDRUM,SLAVEBIT,CON)
finish
!
if OLDPGS & 31 > 0 start ; ! last section not full, so pages
! will be allocated to it.
! Re-allocate the space and move
ADD TO LAST SECT = XPGS; ! if no new sections reqd
ADD TO LAST SECT = 32 - (OLDPGS & 31) if XSECTS > 0; ! just fill up old....
K=SMALLOC(STARTP,FSYS,PGS IN OLD LAST SECT+ADD TO LAST SECT,0); ! don't zero the pages
if K#0 then -> INC RECOVER; ! FSYS full
LINK = SD >> 19
DA = (SD << 13) >> 13
K=MOVE SECTION(FSYS,DA,FSYS,STARTP,PGS IN OLD LAST SECT)
-> INC RECOVER unless K = 0
K = MOVESECTION(-1, 0, FSYS, STARTP+PGS IN OLD LAST SECT, c
ADDTO LAST SECT)
-> INC RECOVER unless K = 0
!
J=DEAL(FSYS, 0,DA,PGS IN OLD LAST SECT)
ACTIVE BLOCK("CHSIZE5", FULL, FSYS) if J = 91
SD = (LINK << 19) ! STARTP
!
if CON>0 start
! Replace disc address for last block
BLOCK EXTEND(LASTSEG, (OLDSECTS-1)&1, STARTP, c
ADD TO LAST SECT)
finish ; ! CON > 0
finish
!
if XSECTS > 0 start ; ! new sections are being added,
! allocate them and then make and
! fill in new cells
SDX == SD; ! point to old last
ZERALLOC = NO
ZERALLOC = YES if CON = 0; ! clear new bits only if file not connected
cycle J = 1, 1, XSECTS
L=32
if J=XSECTS then L=PGS IN NEW LAST SECT
K=SMALLOC(STARTP,FSYS,L,ZERALLOC); ! Zero pgs if not connected else newcopy
if K#0 then -> INC RECOVER; ! FSYS full
SDX == SDS(SDX >> 19); ! move to next
SDX = ((SDX >> 19) << 19) ! STARTP; ! and insert DA
if CON>0 start ; ! file is connected, connect new sections
RELSEG=(OLDSECTS+J-1) >> 1
K=SCONNECT(CON+RELSEG,(FSYS<<24)!STARTP,L,APF,1, c
NOTDRUM, SLAVEBIT, FLAGS)
if K#0 then WRSN("DCHSIZE", K)
finish
repeat
finish
!
if CON>0 start ; ! update con table
J=LASTSEG + 1
while J<CON + NEWSEGS cycle
DIROWN_CPOINT(J)=DIROWN_CPOINT(CON)
J=J+1
repeat
finish
-> UPDATE INDEX
!
INC RECOVER:
if CON > 0 c
then RECOVER2(CON,CON+NEWSEGS-1,OLD SECTS-1,PGS IN OLD LAST SECT)
LINK = SD >> 19
SD = (SD << 13) >> 13; ! mark old last SD as end of list
while LINK > 0 cycle
SD == SDS(LINK)
LINK = SD >> 19
SD = 0
repeat
FL_CODES = FL_CODES & (¬UNAVA)
-> OUT
!
!
!
UPDATE INDEX:
K = PP(ADDR(F_SEMA),F_SEMANO,FN)
-> OUT unless K = 0
FL_PGS=NEWPGS
F_TOTKB=F_TOTKB + XKB
!
unless FL_CODES & TEMPFS = NO start
! temporary
F_TEMPKB = F_TEMPKB + XKB
finish
!
unless FL_CODES & CHERSH = NO start
! cherished
F_CHERKB = F_CHERKB + XKB
finish
!
FL_CODES=FL_CODES ! VIOLAT if XSECTS>0 and CON>0
FL_CODES=FL_CODES & (¬UNAVA)
VOUT:
VV(ADDR(F_SEMA), F_SEMANO)
OUT:
RESULT = OUT(K, "SSII")
END ; ! DCHSIZE
!
!-----------------------------------------------------------------------
!
!<DCONNECT
externalintegerfn DCONNECT(string (31)FILE INDEX, FILE,
integer FSYS, MODE, APF, integername SEG, GAP)
!
! Provided that the file is suitably permitted to the caller, the file of
! name FILE belonging to file index FILE INDEX on disc-pack FSYS (or -1)
! is connected into the caller's virtual memory.
!
! The bits in the parameter MODE have the following meanings (when set):
! 2**0 Read access required
! 1 Write access required
! 2 Execute access required
! 3 Write access by other processes to be allowed
! 4 New copy of file to be written
! 5 Communications mode
! 6 Not to be allocated space on the drum
! 7 Segment to be used as a process stack
!
! The purpose of bit 2**3 is to allow (read and) write access by more
! than one process to be achieved only when each user specifically allows
! the situation (by setting the bit in his request).
!
! Bits 2**1 or 2**3 may not be set in the request if bit 2**2 (execute
! access) is also set.
!
! SEG either specifies the segment number at which the file is to be
! connected (in the range 34 to 127), or is zero, indicating that the
! choice of segment number is to be left to Director. If the result of
! the function is 0 or 34 (file already connected), SEG is set to the
! chosen segment number.
!
! GAP specifies the number of segments which are to be reserved for the
! file, even though the current size of the file may be less than that
! number of segments. Attempts to specify a value of SEG which conflicts
! with this GAP, in subsequent connect requests before this file is
! disconnected, will be rejected.
!
! If GAP is set to zero then no segments of virtual memory, other than
! those required by the current file size, are reserved for the file.
! If the result of the function is 0 or 34 (file already connected), GAP
! is set to the number of segments reserved for the file.
!
! APF may be used to specify the access permission field in the
! segment(s) being connected. The bottom 9 bits are significant:
!
! 1 4 4
! EXE- WRITE READ
! CUTE ACR ACR
!
! The read and write ACR values supplied must be greater than or equal to
! the ACR at which the calling program (subsystem) is running. If the APF
! parameter is set to zero, a value of X'1nn' is used, where n is the ACR
! at which the caller is executing.
!>
INTEGER J,WAP,RAP
STRING (31)UNAME, INAME, FNAME, INDEX, FULL
J = IN2(11)
-> OUT UNLESS J = 0
!
J = UFO(FILE INDEX, FILE, UNAME, INAME, FNAME, INDEX, FULL)
-> OUT UNLESS J = 0
!
J = 93
! MODE<0 means segment to be non-slaved
IF DTRYING<<7>=0 AND C
(CHARNO(FNAME, 1)='#' OR MODE<0) C
THEN -> OUT
!
J = 45
-> OUT UNLESS VAL(ADDR(SEG), 4, 1, DCALLERS PSR) = YES
-> OUT UNLESS VAL(ADDR(GAP), 4, 1, DCALLERS PSR) = YES
!
RAP=APF&15
WAP=(APF>>4)&15
IF RAP=0 THEN RAP=DCALLERS ACR
IF WAP=0 THEN WAP=DCALLERS ACR
J = 8
UNLESS WAP>=DCALLERS ACR AND RAP>=DCALLERS ACR THEN -> OUT
APF=X'100' ! (WAP<<4) ! RAP
J=DCONNECTI(FULL,FSYS,MODE,APF,SEG,GAP)
RESULT = OUT(J, "NIL")
OUT:
RESULT = OUT(J, "SSIIIJJ")
END ; ! DCONNECT
!
!-----------------------------------------------------------------------
!
!<DCPUTIME
externalintegerfn DCPUTIME
!>
RESULT =(ACCTS_MUSECS - GETIT)//1000
END ; ! DCPUTIME
!
!-----------------------------------------------------------------------
!
!<DCREATE2
externalintegerfn DCREATE2(string (31)FILE INDEX, FILE,
integer FSYS, NKB, TYPE, integername DA)
!
! A file of name FILE is created, in file index FILE INDEX on disc-pack
! FSYS, of E Epages, where E is the smallest number of Epages containing
! NKB Kbytes. The maximum size of file allowed is 16 Mbytes. Subsystems
! requiring larger files should arrange that they be made up of subfiles
! comprising files created by this procedure.
!
! Bits in TYPE may be set:
!
! 2**0 For a temporary file (destroyed when the creating process
! stops if the file was connected, or at System start-up).
!
! 2**1 For a very temporary file (destroyed when the file is
! disconnected).
!
! 2**2 For a file which is to be zeroed when created.
!
! 2**3 To set "CHERISHed" status for the file.
!
!
! Temporary files are made into ordinary files (that is, the "temporary"
! attribute is removed) on being RENAMEd, OFFERed, TRANSFERred or
! PERMITted, and also explicitly by an appropriate call on procedure
! DFSTATUS.
!
! The disc address of the first section of the file is returned in DA.
!>
INTEGER J
STRING (31)UNAME, INAME, FNAME, INDEX, FULL
J = IN2(13)
-> OUT UNLESS J = 0
!
J = UFO(FILE INDEX, FILE, UNAME, INAME, FNAME, INDEX, FULL)
-> OUT UNLESS J = 0
!
J = 18
-> OUT IF CHARNO(FNAME, 1) = '#' C
AND D CALLERS ACR >= DEFAULT SS ACR
!
J = 93
-> POK IF UNAME = PROCUSER
-> POK IF DTRYING < 0
-> POK IF FILE INDEX PERM(INDEX, FSYS) & 2 > 0
-> OUT
POK:
J=8
-> OUT UNLESS 0<=TYPE<=15 AND TYPE&3#3
!
J=DCREATEF(FULL,FSYS,NKB,(TYPE<<2) ! 1, LEAVE, DA)
RESULT = OUT(J, "NIL")
OUT:
RESULT = OUT(J, "SSIII")
END ; ! DCREATE2
!
!-----------------------------------------------------------------------
!
!<DCREATE
externalintegerfn DCREATE(string (31)FILE INDEX, FILE,
integer FSYS, NKB, TYPE)
INTEGER DA
RESULT = DCREATE2(FILE INDEX, FILE, FSYS, NKB, TYPE, DA)
END ; ! DCREATE
!
! This is simply a call on DCREATE2
!>
!
!-----------------------------------------------------------------------
!
!<DDESTROY
externalintegerfn DDESTROY(string (31)FILE INDEX, FILE, string (8)DATE,
integer FSYS, TYPE)
!
! File FILE belonging to file index FILE INDEX on disc-pack FSYS, is
! destroyed. TYPE should be set to 1 to destroy a file from archive
! storage, otherwise it should be set to zero. When TYPE=1, DATE should
! be set to the archive date. DATE is ignored if TYPE=0.
!
! The procedure fails if 'OWNP' for the file is either zero (no access)
! or 8 (do not destroy).
!>
! TYPE = 0 destroy on-line file
! 1 destroy archive file
!
INTEGER J
STRING (31)UNAME, INAME, FNAME, INDEX, FULL
J = IN2(16)
-> OUT UNLESS J = 0
!
J = UFO(FILE INDEX, FILE, UNAME, INAME, FNAME, INDEX, FULL)
-> OUT UNLESS J = 0
!
-> POK IF UNAME = PROCUSER
-> POK IF DTRYING < 0
-> POK IF FILE INDEX PERM(INDEX, FSYS) &2 > 0
J = 93
-> OUT
POK:
IF TYPE=0 C
THEN J=DDESTROYF(FULL,FSYS,1) C
ELSE J=ADESTROY(FULL,DATE,FSYS,TYPE-1)
RESULT = OUT(J, "NIL"); ! monitoring done in support proc
OUT:
RESULT = OUT(J, "SS")
END ; ! DDESTROY
!
!-----------------------------------------------------------------------
!
!<DDISCONNECT
externalintegerfn DDISCONNECT(string (31)FILE INDEX, FILE,
integer FSYS, DSTRY)
!
! The file of name FILE belonging to file index FILE INDEX on disc-pack
! FSYS is disconnected from the caller's virtual memory. Parameter
! DESTROY should be set either to 0 or 1. If set to 1 the file will be
! destroyed, provided that it belongs to the process owner (not necessary
! if the process is privileged) and the "use-count" for the file is zero
! after disconnection. Otherwise the parameter is ignored.
!>
INTEGER J
STRING (31)UNAME, INAME, FNAME, INDEX, FULL
J=IN2(18)
-> RES UNLESS J = 0
!
J=8
-> RES UNLESS 0<=DSTRY<=1
!
J = UFO(FILE INDEX, FILE, UNAME, INAME, FNAME, INDEX, FULL)
-> RES UNLESS J = 0
!
J = 93
IF DTRYING << 7 >= 0 START ; ! not a privileged user
-> RES IF CHARNO(FNAME, 1) = '#'; ! can't disconnect #... files
IF UNAME # PROCUSER AND DSTRY # 0 START
-> RES UNLESS FILE INDEX PERM(INDEX, FSYS) & 2 > 0
FINISH
FINISH
!
DSTRY=2 IF DSTRY#0
J = DDISCONNECTI(FULL, FSYS, DSTRY)
RESULT = OUT(J, "NIL")
RES:
!
RESULT = OUT(J, "SSII")
END ; ! DDISCONNECT
!
!-----------------------------------------------------------------------
!
!<DGETDA
externalintegerfn DGETDA(string (31)FILE INDEX, FILE,
integer FSYS, ADR)
!
! This procedure provides the disc addresses of the sections of file FILE
! belonging to file index FILE INDEX on disc-pack FSYS. Data is written
! from address ADR in the format
!
! (%integer SECTSI, NSECTS, LASTSECT, SPARE, %integerarray DA(0:255))
!
! where SECTSI is the size (in epages) of the sections (except
! possibly the final section)
!
! NSECTS is the number of sections, and hence the number
! of entries returned in array DA
!
! LASTSECT is the size (in epages) of the final section
!
! In each entry in the DA array, the top byte contains the FSYS number.
!>
integer J,N,S,NSD,NSECTS
integer FINDAD, FI
integer PGS IN LAST SECT
integer PAGS
STRING (31)UNAME, INAME, FNAME, INDEX, FULL
record (FF)name F
record (FDF)name FD
record (FDF)arrayname FDS
integername SD
integerarrayname SDS
integerarrayname UA
conststring (7)FN = "DGETDA "
J = IN2(30)
-> OUT unless J = 0
!
J = UFO(FILE INDEX, FILE, UNAME, INAME, FNAME, INDEX, FULL)
-> OUT UNLESS J = 0
!
J = MAP FILE INDEX(INDEX, FSYS, FINDAD, FN)
-> OUT UNLESS J = 0
!
F == RECORD(FINDAD)
FDS == ARRAY(FINDAD+F_FDSTART, FDSF)
SDS == ARRAY(FINDAD+F_SDSTART, SDSF)
NSD = (F_FDSTART - F_SDSTART) >> 2
J=32; ! FILE DOES NOT EXIST
FI=NEW FIND(FINDAD, 0, FNAME)
if FI=0 then -> VOUT; ! NOT EXIST
!
FD == FDS(FI)
!
J=5; ! FILE NOT READY
if FD_CODES&UNAVA#0 then -> VOUT
!
PAGS=FD_PGS
J = 87
-> VOUT IF PAGS <= 0
NSECTS = (PAGS + 31) >> 5
PGS IN LAST SECT = PAGS - (NSECTS - 1) << 5
!
J=45; ! USER AREA NOT AVAILABLE
-> VOUT if VAL(ADR,NSECTS<<2+16,1,DCALLERS PSR) = NO
!
UA==ARRAY(ADR+16,IFT)
INTEGER(ADR)=32
INTEGER(ADR+4)=NSECTS
INTEGER(ADR+8)=PGS IN LAST SECT
INTEGER(ADR+12)=32; ! SPARE
!
SD ==FD_SD; ! proceed down sections chain
J = 87
N=0
while N < NSECTS cycle
UA(N) = (FSYS<<24) ! ((SD<<13)>>13)
N=N+1
S = SD >> 19
exit unless 1 <= S <= NSD
SD == SDS(S)
repeat
J = 0 if N = NSECTS and S = 0
VOUT:
VV(ADDR(F_SEMA), F_SEMANO)
OUT:
RESULT = OUT(J, "SSI")
end ; ! DGETDA
!
!-----------------------------------------------------------------------
!
!<DMDC
externalroutine DMDC
!>
INTEGER SEG, J, CELL
CYCLE SEG = LODSEG, 1, HISEG
CELL = SST(SEG)
IF CELL # ENDSST START
J = DSEGMENT(SEG, 0)
WRS("DMDC") IF J = -1
FINISH
REPEAT
END ; ! MDC
!
!-----------------------------------------------------------------------
!
!<DMODE
externalintegerfunction dmode(integer set,adr,command)
!
! ****** Kent version of DMODE ******
!
! If 'set' = 1, then 'adr' specifies the address of N bytes (N<65) of
! TCP command data, the first being a length byte containing N-1, which
! are to be dispatched (via the buffers and control streams attached to
! the executive process DIRECT) to the TCP. A copy of the current TCP
! mode settings is retained, and is used to return current mode settings
! to the user if requested. The GETMODE action (function code 4) is not
! required, since the local copy of the mode settings is always correct
! (as long as no other mechanism but DMODE is used to set TCP modes).
! For compatibility with ERCC, GETMODE is accepted, but treated as a
! no-op.
!
! If 'set' = 0, then 'command' specifies a TCP command byte for which
! the corresponding mode data are required. 'adr' specifies an
! eight-byte area into which the relevant mode settings are to be
! placed. This interface routine, which accesses the local copy of the
! mode settings, is provided to enable changes to be made to the
! internal representation of the data without requiring user programs to
! be modified.
!
! Possible error results: 8, 45, 61
!>
!
! Format of the record used to hold the local copy of the current TCP
! mode settings. This record is 40 bytes long (8 bytes longer than the
! ERCC one), so it cannot be held in the UINF record (nor does it need
! to be, since no other process requires access to it). Instead, an own
! copy of the record is maintained.
!
constantinteger tmodelen = 40; ! Length of TCP bulk setmode transfer
! (there are two extra bytes as well)
recordformat tmodef(byteinteger len,function,flags1,flags2,pads,dummy,
linelimit,pageleng,byteintegerarray tabvec(0:15),byteinteger del,can,
byteintegerarray rawmask(0:15))
!
integer pt,step,flag,seg,gap,j,len,v,rawset,i
record (logf hdf)name logh
record (fepf)arrayname feps
record (procdatf)arrayname proclist
constantrecord (uinff)name uinf = 9<<18
!
! Bits in TCP mode byte 'flags1' (this is two bytes at ERCC)
! Bits not mentioned here are not used
!
constantbyteinteger echo = b'00000010' { bit 1 }
constantbyteinteger graph = b'00000100' { bit 2 }
constantbyteinteger bin in = b'00010000' { bit 4 }
!
! Bits in TCP mode byte 'flags2' (this is two bytes at ERCC)
! Bits not mentioned here are not used
!
constantbyteinteger flow = b'00000001' { bit 0 }
constantbyteinteger video = b'00001000' { bit 3 }
constantbyteinteger xtab = b'00100000' { bit 5 }
constantbyteinteger raw = b'01000000' { bit 6 }
!
! Default settings for TCP modes. These are used to initialise the
! local copy of the current settings.
!
constantbyteintegerarray defmodes(1:tmodelen) = c
0,video,0,0,80,24,1,6,9,12,15,18,40,80,160(8),127,24,0(16)
!
constantinteger topg = 23, tops = 34
switch dg(1:topg),ds(1:tops)
ownrecord (tmodef) t
owninteger prev = 0; ! Time of previous call, or zero
owninteger n = 0; ! Number of calls in rapid succession
owninteger firstcall = 1; ! Used to initialise local copy of modes
!
flag = in2(43)
-> out if flag # 0
!
flag = 8
-> out unless 0 <= set <= 1
!
flag = 45
len = 1
len = 16 if set = 0
-> out if val(adr,len,1-set,0) = 0
!
if firstcall = 1 then start ; ! Set up local copy of TCP modes
firstcall = 0
t_len = 35; ! Red tape header
t_function = 22; ! Bulk setmode function code
move(tmodelen,addr(defmodes(1)),addr(t_flags1))
finish
!
-> set if set = 1
!
! Code to return a current mode setting
! -------------------------------------
!
flag = 0
unless 0 < command <= topg then command = 0
-> dg(command)
!
dg(*):
flag = 8
-> out
dg(1): v=(¬(t_flags1)) & echo; -> nonz; ! Echo mode (0=off, 1=on)
dg(2): v=t_pageleng; -> setv; ! Page size
dg(3): v=t_linelimit; -> setv; ! Max line size
dg(7): v=t_del; -> setv; ! Delete char
dg(8): v=t_can; -> setv; ! Cancel char
dg(9): v=t_flags1 & bin in; -> nonz; ! Binary input (0=off, 1=on)
dg(10): move(16,addr(t_tabvec(0)),adr); -> out; ! Tab settings
dg(11): v=t_flags1 & graph; -> nonz; ! Graph mode (0=off, 1=on)
dg(14): v=t_pads; -> setv; ! Number of pad chars
dg(15): v=t_flags2 & video; -> nonz; ! Video mode (0=off, 1=on)
dg(17): v=t_flags2 & flow; -> nonz; ! Flow control (0=off, 1=on)
dg(21): v=t_flags2 & xtab; -> nonz; ! Hard tabs mode (0=off, 1=on)
dg(23): v=t_flags2 & raw; -> nonz; ! Raw (Screed) mode (0=off, 1=on)
!
nonz: v = 1 if v # 0
setv: byteinteger(adr) = v
-> out
!
! Code to change TCP mode settings
! --------------------------------
!
set:
flag = 8
len = byteinteger(adr)
-> out unless 0 < len < 64
flag = 45
-> out if val(adr,len+1,0,0) = 0
flag = 8
rawset = 0
pt = 1
!
cycle
command = byteinteger(adr+pt)
-> out unless 0 < command <= tops
step = 1
if command = 10 then start ; ! Set tabs
-> out if pt + 16 > len; ! Must be last command
step = len - pt
finish else c
if command = 22 then step = tmodelen else c
{ Bulk setting of all modes
if command = 34 then step = 16
! Bulk setting of raw mask
-> out if pt + step > len; ! Not enough data
!
v = byteinteger(adr+pt+1); ! First qualifier byte
-> ds(command)
!
ds(*): -> out
ds(1): if v = 0 then t_flags1 = t_flags1!echo else c
t_flags1 = t_flags1 & (¬echo); -> next
ds(2): t_pageleng = v; -> next
ds(3): t_linelimit = v; -> next
ds(4): -> next; ! Getmode - null at Kent
ds(7): t_del = v; -> next
ds(8): t_can = v; -> next
ds(9): if v = 0 then t_flags1 = t_flags1 & (¬bin in) else c
t_flags1 = t_flags1!bin in; -> next
ds(10): move(16,adr+pt+1,addr(t_tabvec(0))); -> next
ds(11): if v = 0 then t_flags1 = t_flags1 & (¬graph) else c
t_flags1 = t_flags1!graph; -> next
ds(14): t_pads = v; -> next
ds(15): if v = 0 then t_flags2 = t_flags2 & (¬video) else c
t_flags2 = t_flags2!video; -> next
ds(17): if v = 0 then t_flags2 = t_flags2 & (¬flow) else c
t_flags2 = t_flags2!flow; -> next
ds(21): if v = 0 then t_flags2 = t_flags2 & (¬xtab) else c
t_flags2 = t_flags2!xtab; -> next
ds(22): move(tmodelen,adr+pt+1,addr(t_flags1)); -> next
ds(23): if v = 0 then t_flags2 = t_flags2 & (¬raw) else c
t_flags2 = t_flags2!raw; -> next
ds(24):
ds(25):
ds(26):
ds(27): t_rawmask(command-24) = v; rawset = 1; -> next
ds(28): move(tmodelen,addr(defmodes(1)),addr(t_flags1)); -> next
ds(30): v = x'ff' unless v = 0
t_rawmask(i) = v for i = 0,1,15
if v = 0 then t_flags2 = t_flags2 & (¬raw) else c
t_flags2 = t_flags2!raw; -> next
ds(34): move(16,adr+pt+1,addr(t_rawmask(0))); -> next
!
next: pt = pt + step + 1
repeat until pt >= len
!
! If the user altered the raw mask, clear the bits he may not know about.
!
if rawset # 0 then start
t_rawmask(j) = 0 for j = 4,1,15
finish
!
if uinf_streamid>>24 # x'0e' then start
! Ignore if not a front end
flag = 0
-> out
finish
!
j = com_secsfrmn - prev; ! Time since last call (or time of day)
j = j + 24*60*60 if j < 0; ! Adjust for new day
if j < 15 then n = n + 1 else n = 0
! j = ddelay(60-j) %if n > 20; ! Wait until it's at least a min since last call
prev = com_secsfrmn; ! Remember time of this call
!
! Now dispatch the data
!
seg = 0; gap = 0
flag = dconnecti("VOLUMS.#LOGMAP",-1,11,0,seg,gap)
-> out if flag # 0
logh == record(seg<<18+x'10000')
proclist == logh_proclist
feps == logh_feps
output message to fep(feps,uinf_streamid<<8>>24,2,addr(t),tmodelen+2,c
uinf_streamid<<16>>16, proclist(uinf_pslot)_protocol)
!
flag = ddisconnecti("VOLUMS.#LOGMAP",-1,0)
out:
result = out(flag,"I")
end ; ! of DMODE
!-----------------------------------------------------------------------
!
!<DNEWGEN
externalintegerfn DNEWGEN(string (31)FILE INDEX, FILE, NEWGEN OF FILE,
integer FSYS)
!
! This procedure provides a means of introducing an updated version
! (i.e. a new generation) of file FILE belonging to file index FILE INDEX
! even though it may be connected in other users' virtual memories.
!
! If FILE is not connected in any virtual memory, a call on DNEWGEN is
! equivalent to destroying FILE and then renaming NEWGEN OF FILE to FILE,
! except that the new version of FILE retains the former FILE's access
! permissions.
!
! If FILE is connected in some virtual memory, then the filename
! NEWGEN OF FILE "disappears", and any subsequent connection of FILE into
! a virtual memory yields the contents of the new generation formerly
! held in NEWGEN OF FILE.
!
! When the number of users of a former copy of FILE becomes zero
! (i.e. when it is not connected in any virtual memory), that copy is
! destroyed.
!>
!
!
!
integer FINDAD,J
integer SD, PI, NPD
integer OLDPGS, NEWPGS, OLDA, NEWA, OLDKB, NEWKB
STRING (31)UNAME, INAME, FNAME, INDEX, FULL
record (FF)name F
record (FDF)arrayname FDS
record (PDF)arrayname PDS
record (PDF)name PD
record (FDF)name NEWFL,OLDFL
conststring (8)FN = "DNEWGEN "
J=IN2(47)
-> OUT UNLESS J = 0
!
J = UFO(FILE INDEX, FILE, UNAME, INAME, FNAME, INDEX, FULL)
-> OUT UNLESS J = 0
!
J = 18
-> OUT IF S11OK(NEWGEN OF FILE)#0
-> OUT IF EQUAL(FNAME, NEWGEN OF FILE) = YES; ! INVALID NAME
!
-> POK IF UNAME = PROCUSER
-> POK IF DTRYING < 0
-> POK IF FILE INDEX PERM(INDEX, FSYS) &2 > 0
J = 93
-> OUT
POK:
J=MAP FILE INDEX(INDEX,FSYS,FINDAD,FN)
-> OUT UNLESS J = 0
!
F == RECORD(FINDAD)
FDS == ARRAY(FINDAD + F_FDSTART, FDSF)
PDS == ARRAY(FINDAD + F_PDSTART, PDSF)
NPD = (F_SDSTART - F_PDSTART) // PDSIZE
!
J=32; ! OLDNAME DOES NOT EXIST
OLDA=NEWFIND(FINDAD,0,FNAME)
if OLDA=0 then -> VOUT; ! DOES NOT EXIST
OLDFL==FDS(OLDA)
!
NEWA=NEWFIND(FINDAD,0,NEWGEN OF FILE)
if NEWA=0 then -> VOUT
NEWFL==FDS(NEWA)
!
J=40; ! FILE IS CONNECTED
if NEWFL_USE#0 then -> VOUT; ! NEW FILE IS CONNECTED
J=5
if NEWFL_CODES&VIOLAT#0 or OLDFL_CODES&VIOLAT#0 then -> VOUT
J=6
if NEWFL_CODES&OFFER#0 or OLDFL_CODES&OFFER#0 then -> VOUT
!
! There are now no more potential failures so do the
! common actions before splitting on file in use or no
!
!
OLDPGS = OLDFL_PGS
NEWPGS = NEWFL_PGS
!
OLDKB = OLDPGS * 4
NEWKB = NEWPGS * 4
!
F_FILES = F_FILES - 1
F_TOTKB = F_TOTKB - OLDKB
!
unless OLDFL_CODES & TEMPFS = NO start
! old file temp
F_TEMPFILES = F_TEMPFILES - 1
F_TEMPKB = F_TEMPKB - OLDKB
finish
!
unless NEWFL_CODES & TEMPFS = NO start
F_TEMPFILES = F_TEMPFILES - 1
F_TEMPKB = F_TEMPKB - NEWKB
finish
!
unless NEWFL_CODES & CHERSH = NO start
! new file is cherished and its attributes are about to be lost
F_CHERFILES = F_CHERFILES - 1
F_CHERKB = F_CHERKB - NEWKB
finish
!
unless OLDFL_CODES & CHERSH = NO start
F_CHERKB = F_CHERKB - OLDKB + NEWKB
finish
!
PI = NEWFL_PHEAD; ! discard any permissions on NEWFL
while 0 < PI <= NPD cycle
PD == PDS(PI)
PI = PD_LINK
PD = 0
repeat
!
if OLDFL_USE=0 start
OLDFL_PGS = NEWPGS
SD=OLDFL_SD
OLDFL_SD=NEWFL_SD
OLDFL_CODES=OLDFL_CODES & (¬TEMPFS)
OLDFL_ARCH=OLDFL_ARCH ! 1; ! WRITTEN TO
NEWFL = 0
NEWFL_NAME = ".NULL"
VV(ADDR(F_SEMA), F_SEMANO)
J = NEWFILE DEAL(FINDAD,SD,OLDPGS)
ACTIVE BLOCK(FN, FULL, FSYS) if J = 91
-> OUT
finish
!
!
! Then old file was connected. OLDFL is newest gen of the file (currently
! not marked OLDGE). Change that to OLDGE.
! Rename NEWGEN OF FILE to be FILE.
! Attributes to be same as previous newest generation.
! Move contents (excl name pointer) of old FD to new FD
!
SD = NEWFL_SD; ! save it
NEWFL = OLDFL; ! copy across all attributes
NEWFL_SD = SD; ! but then reset SD (the disc addresses)
NEWFL_PGS = NEWPGS; ! and its size
NEWFL_USE = 0
NEWFL_CODES = NEWFL_CODES & (¬TEMPFS)
NEWFL_CODES2 = NEWFL_CODES2 & (¬(OLDGE!WRCONN!WSALLOW))
NEWFL_ARCH = NEWFL_ARCH ! 1; ! written to
!
OLDFL_CODES2 = OLDFL_CODES2 ! OLDGE
OLDFL_PHEAD = 0; ! any permissions have been transferred to NEWFL
J = 0
VOUT:
VV(ADDR(F_SEMA), F_SEMANO)
OUT:
RESULT = OUT(J, "SSSI")
END ; ! DNEWGEN
!
!-----------------------------------------------------------------------
!
!<DRENAME
externalintegerfn DRENAME(string (31)FILE INDEX, OLDNAME, NEWNAME,
integer FSYS)
!
! File OLDNAME belonging to file index FILE INDEX on disc-pack FSYS is
! renamed NEWNAME.
!
! A file may not be renamed while it is connected in any virtual memory.
!>
!
!
!
integer FI, FINDAD, J
STRING (31)UNAME, INAME, FNAME, INDEX, FULL
record (FF)name F
record (FDF)name FL
record (FDF)arrayname FDS
conststring (8)FN = "DRENAME "
J=IN2(70)
-> OUT UNLESS J = 0
!
J = UFO(FILE INDEX, OLDNAME, UNAME, INAME, FNAME, INDEX, FULL)
-> OUT UNLESS J = 0
!
J = S11OK(NEWNAME)
-> OUT UNLESS J = 0
!
IF D CALLERS ACR >= DEFAULT SS ACR AND C
BYTEINTEGER(ADDR(NEWNAME)+1)='#' THEN -> OUT; ! INVALID NAME
!
-> POK IF UNAME = PROCUSER
-> POK IF DTRYING < 0
-> POK IF FILE INDEX PERM(INDEX, FSYS) &2 > 0
J = 93
-> OUT
POK:
J = MAP FILE INDEX(INDEX, FSYS, FINDAD, FN)
-> OUT UNLESS J = 0
!
F == RECORD(FINDAD)
FDS == ARRAY(FINDAD + F_FDSTART, FDSF)
!
J =16; ! NEWNAME ALREADY EXISTS
if NEWFIND(FINDAD,0,NEWNAME)>0 then -> VOUT; ! ALREADY EXISTS
FI=NEWFIND(FINDAD,0,FNAME)
J=32; ! OLDNAME DOES NOT EXIST
if FI=0 then -> VOUT; ! DOES NOT EXIST
FL==FDS(FI)
!
J=5; ! FILE NOT READY
if FL_CODES&UNAVA#0 then -> VOUT
!
J=40; ! FILE IS CONNECTED
if FL_USE#0 then -> VOUT; ! FILE IS CONNECTED
!
FL_NAME = NEWNAME; ! No more failures, so can rename
unless FL_CODES&TEMPFS = NO start
! renaming a temporary file has the curious effect
! effect of making it permanent !!
F_TEMPKB=F_TEMPKB - FL_PGS*4
F_TEMPFILES = F_TEMPFILES - 1
finish
!
FL_CODES<-FL_CODES &(¬(UNAVA!TEMPFS))
FL_ARCH=FL_ARCH ! 1; ! WRITTEN TO
J=0
VOUT:
VV(ADDR(F_SEMA), F_SEMANO)
OUT:
RESULT = OUT(J, "SSSI")
END ; ! DRENAME
!
!-----------------------------------------------------------------------
!
!<DSETIC
externalintegerfn DSETIC(integer KINSTRUCTIONS)
!
! This procedure is used to set a number of K instructions (1K=1024)
! which may be executed before an instruction-counter program error
! contingency is generated. The value of the parameter is subject to the
! following constraints:
!
! it must lie between the nominal values for the number of K
! instructions which the machine will execute in 1 second and
! two hours. The field KINSTRS in the public segment 48
! communications record format (see Ref. 11) is required for
! this calculation.
!
! it must not, when added to the number of K instructions so far
! executed this session, exceed the session K instruction limit
! (value available in the UINF record of the process, as
! described in this manual).
!>
! ALLOW RANGE APPROX 1 SEC TO TWO HOURS
! RESULT = 0 OK
! 8 PARAM OUT OF RANGE
INTEGER FLAG
FLAG = IN2(256 + 77)
-> OUT UNLESS FLAG = 0
!
*LSS_(3); ! SSR
*OR_INH IC INTS
*ST_(3)
!
ASYNC INHIB = ASYNC INHIB + 1
!
FLAG=8
-> OUT UNLESS COM_KINSTRS <= KINSTRUCTIONS <= 7200*COM_KINSTRS
!
FLAG=0
IF SESSINSTRS + KINSTRUCTIONS >= SESSKIC + GRACE KIC START
KINSTRUCTIONS = SESSKIC + GRACE KIC - SESSINSTRS
FLAG = 57 AND -> OUT IF KINSTRUCTIONS <= 0; ! END OF SESSION
FINISH
!
IUPDATE(0,KINSTRUCTIONS)
OUT:
ASYNC INHIB = ASYNC INHIB - 1
*LSS_(3); ! SSR
*AND_ALLOW IC INTS; ! UNINHIBIT IC INTERRUPTS
*ST_(3)
!
RESULT = OUT(FLAG, "")
END ; ! DSETIC
!
!-----------------------------------------------------------------------
!
!<DSTOP
externalroutine DSTOP(integer REASON)
!
! This is the means by which a subsystem terminates its process.
! Director disconnects all files, disconnects interactive terminal
! streams, unlocks locked-down areas and destroys temporary files. The
! integer REASON, which conventionally should be 100 for a normal stop or
! greater than 100 for an abnormal stop, is printed in a stopping message
! in the log file. Values less than 100 are generated by Director itself
! in abnormal circumstances:
!
! REASON Meaning
!
! 0 Error condition noted in monitor printing (Dirlog).
!
! 1 A contingency occurred, but the Director procedure PRIME
! CONTINGENCY (used to specify a subsystem contingency
! procedure to be executed)had not previously been called.
!
! 2 A program error has occurred during execution of the
! subsystem's contingency handling procedure and before
! a call of Director procedure DRESUME. (A call of DRESUME
! indicates that diagnostic actions are complete, and more
! specifically that the contingency procedure itself is
! again ready to handle further contingencies.)
!
! 3 The number of program error and virtual store
! contingencies for the process has exceeded a certain
! fixed number, currently 32. The purpose of this limit is
! to terminate the contingency loop which will occur if the
! subsystem contingency procedure executes satisfactorily
! but the computation repeatedly "resumed to" immediately
! fails.
!
! 4 The number of instructions executed by the process
! exceeds the limit specified for the session. In the case
! of an interactive session this is currently a very large
! number, but may be subject to the System Manager's
! control. In the case of a batch session, it is the
! number specified when the batch job was submitted to the
! SPOOLR process. A subsystem should normally arrange,
! through use of Director procedures DSETIC and DSFI
! (TYPE=21), that this session limit is not violated, in
! order to initiate the termination under its own control.
!
! 5 Not used.
!
! 6 A program error has occurred during execution of a
! Director procedure. Currently this may be caused by
! supplying the wrong number of parameter words to a
! procedure, later machine modification levels will enable
! this condition to generate a "subsystem program error"
! contingency.
!
! 7 Illegal call of Director procedure DRESUME: the value of
! the LNB parameter is >0 but is not at least 5 words
! below the machine register LNB contents at the time of
! the call of DRESUME.
!
! 8 Illegal call of Director procedure DRESUME: the parameter
! LNB specifies Director's contingency stack segment, which
! is reserved.
!
! 9 Illegal call of Director procedure DRESUME, specifying
! resumption of a computation in which a virtual store
! error (address error) has just occurred.
!
! 10 Illegal call of Director procedure DRESUME, specifying
! resumption of a computation when a contingency has not in
! fact occurred.
!
! 11 A processor stack-switch has failed to occur, perhaps
! when a call of Director procedure DRESUME has specified
! (through parameter LNB) a segment which is not the normal
! or other nominated stack segment.
!
! 12 Illegal call of Director procedure DASYNC INH to despatch
! (accept) a queued asynchronous contingency, either when
! no contingency is queued, or before the subsystem
! contingency-handling procedure has indicated, through a
! suitable call of Director procedure DRESUME, that it is
! able to accept further contingency notifications.
!
! 13 An "emergency stop" command has been sent to the process
! Director from the machine Operator console. This REASON
! for stopping may be printed in addition to one of the
! above-specified stopping messages when certain of the
! above failures occur during processing using the
! subsystem-nominated processor stack segment. In this
! case the message printed previously specifies the true
! reason for stopping.
!
! 14 A "stop" command has been sent from the Operator console
! or from DIRECT as part of the System automatic close-down
! sequence, or from the interactive communications system
! following line or network-processor failure.
!>
INTEGER SEG,J,STAKAD
STRING (31)FULL, FNAME, INDEX
RECORD (PARMF)P, Q
RECORD (PARMF)NAME PP
RECORD (DIRCOMF)NAME DIRCOM
RECORD (CTF)NAME CT
OWNINTEGER TIMES=0
OWNINTEGER USECOUNTS = 1
SWITCH ENTRY(0:3)
RECORD (HF)NAME NH
INTEGER GPINDAD
INTEGER K, L
OWNSTRING (14)LOGMAP = "VOLUMS.#LOGMAP"
INTEGERFN DRAT(INTEGER A,C,B)
RESULT = 0
END
!
!
!
IF SESSION PENCE > 0 C
ANDC
OWNIND # 0 C
START
J = FUNDS(GPINDAD, OWNIND)
J = J - SESSION PENCE
J = 0 IF J < 0
NH == RECORD(GPINDAD)
NH_INUTS = J
FINISH
!
UNLESS PAGE MON = 0 START
PP == RECORD(OUTPAD)
PP = 0
*OUT_20
PAGE MON = 0
WRS("PAGEFAULTS DSTOP")
FINISH
!
CYCLE J=0,1,2
IF DRS LOCKED(J)_DR0#0 THEN K=DUNLOCK(DRS LOCKED(J)_DR1)
REPEAT
!
J = DMAGCLAIM("", J, 1, 0) IF TAPES CLAIMED > 0
J = DDAP(DRAT, 0, 0) IF DAP STATE > 0
J = NEWAINDA("", -1, J) UNLESS SAINDAD = 0
!
-> ENTRY(TIMES)
ENTRY(0):
UNLESS GOTSEMA = 0 START
VV(SEMADDRHELD, SEMANOHELD)
WRSS( DIROWN_SEMA HOLDER, " had sema at DSTOP")
FINISH
!
! IF CURRENT STACK IS NOT THE NORMAL STACK THEN PON AN XST, TO GET THE DISCONNECTS
! ETC DONE ON THE NORMAL STACK
! THIS TO BE REPLACED BY AN OUT TO STACK SWITCH TO LOCAL 4 SOMETIME
*STSF_STAKAD
IF STAKAD>>18#NORMAL STACK SEG START
Q=0
Q_DEST=((COM_ASYNC DEST + PROCESS)<<16) ! DIRDACT
Q_S="XSTOP"
Q_P6 = REASON
DOUTI(Q)
-> ENTRY(3); ! (BUT SHOULD NOT RETURN FROM THE PON)
FINISH
TIMES=TIMES + 1 IF TIMES < 3
ASYNC INHIB=100; ! we can't treat async events when files have been disconnected
! INHIBIT IC INTERRUPTS
*LSS_(3); ! SSR
*OR_INH IC INTS
*ST_(3)
!
HOTTOPN = 0; ! prevents any further accesses to HOTTOP
! which may be a file
OWNIND = 0; ! switch off IUPDATE
FACILITYA = 0; ! ...and procedure counting
!
COMMS CLOSEDOWN
!
! DIVERT ANY FURTHER MSGS TO
! MAINLOG AS WE ARE ABOUT TO
! DISCONNECT DIRLOG
IF PROCESS = 1 START
WRS("DSTOP DISCONNECTING")
STOP FEPS
FINISH
LOG ACTION = DT ! LOG
DIRLOG AD = 0
!
IF "FCHECK"#PROCUSER#"DIRECT" AND UINF_REASON = BATCH START
REASON = (UINF_PRIORITY<<24) ! (REASON<<8>>8)
DAP INTERFACE(3) IF UINF_DAPSECS > 0; ! its a DAP batch job
FINISH
ENTRY(1):
IF USECOUNTS = 1 START
CYCLE SEG = 7, 1, HISEG
CT == DIROWN_CONLIST(DIROWN_CPOINT(SEG))
FULL = CT_FULL
IF FULL->INDEX.(".").FNAME AND C
(PROCESS # 1 OR EQUAL(FULL, LOGMAP) = NO) C
START
! We want the logmap file to be (disconnected and) destroyed
! only by a consistency check.
J=DDISCONNECTI(FULL,CT_FSYS,1)
IF J#0 THEN DERR2(FULL, 6, J)
FINISH
REPEAT
FINISH
ENTRY(2):
CYCLE SEG = 7, 1, HISEG
DCHAIN(SEG, 0)
REPEAT
ENTRY(3):
IF PROCUSER # "DIRECT" AND USECOUNTS = 1 START
USECOUNTS = 0
IF PROCUSER # "FCHECK" C
THEN J = DISC USE COUNT(PROCFSYS,-1); ! for #SIGSTK. All other files have been
! dealt with.
CYCLE J=99,-1,0
K = FSYS USECOUNT(J)
IF K # 0 C
THEN DOPER2("Fsys ".ITOS(J)." usecount".ITOS(K))
WHILE K > 0 CYCLE
L = DISC USE COUNT(J, -1)
K = K - 1
REPEAT
REPEAT
FINISH
!
P=0
P_DEST=X'FFFF0000' ! USER STOPS DACT
P_P1=PROCESS
J=DPON3I("VOLUMS",P,0,1,PONANDCONTINUE) UNLESS PROCUSER="VOLUMS"
! SEND PROCESS-STOPPING NOTIFICATION TO PROCESS 1
PP==RECORD(OUTPAD)
PP=0
! DEST is set up by the local controller, which PONs the message
PP_P1=SESSINSTRS; ! Kinstructions
PP_P2=INVOC
STRING(ADDR(PP_P3))=PROCUSER
PP_P5=REASON
PP_P6=ACCTS_PTRNS
!
IF PROCESS = 1 START
WRS("PROCESS 1 CLOSING DOWN")
CYCLE L = 0, 1, 63; ! 4096 CHS TO MAINLOG TO FLUSH IT OUT
SYMBOLS(64, '*')
NEWLINE
REPEAT
FINISH
!
*OUT_0
END ; ! DSTOP
!
!-----------------------------------------------------------------------
!
!<FBASE
externalintegerfn FBASE(integername LO, HI, integer FSYS)
!
! This procedure returns the characteristics of an on-line disc.
!
! LO is set to X40 for an ordinary disc and X800 for an IPL disc
!
! HI is set as follows:
! EDS 80 X3F1F
! EDS 100 X59F3
! EDS 160 X8F6F
! EDS 200 XB3E7
! EDS 640 X24797
!>
RECORD (DDTF)NAME DDT
RECORD (PROPF)NAME PROP
INTEGER ENTAD, J
J = DDT ENTRY(ENTAD, FSYS)
IF J = 0 START
DDT == RECORD(ENTAD)
LO = DDT_BASE; ! bitmap+indexes+filespace
PROP == RECORD(DDT_PROPADDR)
HI = PROP_TOTPAGES - 1
FINISH
RESULT = J
END ; ! FBASE
!
!-----------------------------------------------------------------------
!
!<FBASE2
externalintegerfn FBASE2(integer FSYS, ADR)
!
! This returns the characteristics of an on-line disc in a record
! of format DISCDATAF at address ADR
!>
RECORD (DDTF)NAME DDT
RECORD (PROPF)NAME PROP
INTEGER J, ENTAD, HIBIT, TYPE, K
RECORD (DISCDATAF)NAME DATA
CONSTINTEGER TOPTYPE = 5
CONSTINTEGERARRAY BITSIZE(1:TOP TYPE) = X'1000'(2), X'2000'(2), X'5000'
CONSTINTEGERARRAY NNTSTART(1:TOP TYPE) = X'7000'(4), X'A000'
CONSTINTEGERARRAY NNTSIZE(1:TOP TYPE) = X'4000'(4), X'1FF8'
CONSTINTEGERARRAY NNTTOP (1:TOP TYPE) = 1364(4), 681
CONSTINTEGERARRAY NNTHASH(1:TOP TYPE) = 1361(4), 667
CONSTBYTEARRAY INDEXSTART(1:TOP TYPE) = 12(5)
CONSTINTEGERARRAY FILESTART(1:TOP TYPE) = 1024(5)
CONSTINTEGERARRAY HI(1:TOP TYPE) = X'3F1F', X'59F3', X'8F6F',
X'B3E7', X'24797'
J = DDT ENTRY(ENTAD, FSYS)
-> OUT UNLESS J = 0
!
DDT == RECORD(ENTAD)
PROP == RECORD(DDT_PROPADDR)
HIBIT = PROP_TOT PAGES - 1
TYPE = -1
CYCLE K = 1, 1, TOP TYPE
TYPE = K AND EXIT IF HIBIT = HI(K)
REPEAT
J = 8 AND -> OUT IF TYPE < 0
!
DATA == RECORD(ADR)
!
DATA_START = DDT_BASE
DATA_BITSIZE = BITSIZE(TYPE)
DATA_NNTSTART = NNTSTART(TYPE)
DATA_NNTSIZE = NNTSIZE(TYPE)
DATA_NNTTOP = NNTTOP(TYPE)
DATA_NNTHASH = NNTHASH(TYPE)
DATA_INDEXSTART = INDEX START(TYPE)
DATA_FILESTART = FILE START(TYPE)
DATA_END = HIBIT
OUT:
RESULT = J
END ; ! FBASE2
!
!-----------------------------------------------------------------------
!
!<GETAVFSYS
externalroutine GET AV FSYS(integername N, integerarrayname A)
!
! This procedure supplies the numbers of the disc-packs currently
! on-line. Array A, which should be declared (0:99), is filled from
! A(0), A(1), ..... with as many numbers as there are on-line EMAS
! disc-packs, and N is set to the number of entries returned.
! By on-line we mean that the disk must be
! - mounted
! - consistency checked (CCK'd)
! - not closing
! The IPL disc is always placed first in the list.
!>
INTEGER J
INTEGERARRAY LA(0:99)
!
J = IN2(88)
-> OUT UNLESS J = 0
!
-> OUT UNLESS VAL(ADDR(N), 4, 1, DCALLERS PSR) = YES
!
GET AV FSYS2(0,N,LA)
!
-> OUT UNLESS N > 0
-> OUT UNLESS VAL(ADDR(A(0)), 4*N, 1, DCALLERS PSR) = YES
!
MOVE(N<<2, ADDR(LA(0)), ADDR(A(0)))
OUT:
J = OUT(J, "")
END ; ! GET AV FSYS
!
!-----------------------------------------------------------------------
!
!<PRINTMP
externalroutine PRINTMP(integer SEG1, SEG2)
!
! PRINTMP stands for PRINT Master Page tables. The procedure lists
! details of the segments SEG1 to SEG2 to DIRLOG. If SEG2 is zero,
! then HISEG is used, a value supplied by Supervisor.
!>
INTEGER SEG,ENT
INTEGER J, SAVEDT
!
!
!
ROUTINE PSECTION
INTEGER DA, J
RECORD (DISCDATAF)DATA
WRITE(SEG, 3)
PRINTSTRING(" X")
PRINTSTRING(HTOS(SEG, 2))
DA = CBTA(ENT)_DA
PRX(DA,8)
PRX(CBTA(ENT)_AMTX, 4)
SPACE
PRX(CBTA(ENT)_TAGS, 2)
SPACES(2)
PRX(CBTA(ENT)_LINK, 2)
SPACE
PRX(ST(SEG)_APFLIM, 8)
!
IF SEG >= LODSEG AND 32#SEG#33 START
J = FBASE2(DA>>24, ADDR(DATA))
!
UNLESS DATA_FILESTART <= DA<<8>>8 <= DATA_END C
THEN PRINTSTRING("*** OUT OF RANGE ***")
FINISH
END
!
!
!
J = IN2(92)
-> OUT UNLESS J = 0
!
SEG2=HISEG IF SEG2=0
WRS("-------------- MASTER PAGE TABLES -------------------")
!
SAVE DT = LOG ACTION & DT
LOG ACTION = LOG ACTION - SAVE DT
!
WRS(" SEGMENT CBTENTRY")
WRS(" DEC HEX DISCADDR AMTX TAGS LINK APFLIM USER.FILE")
!
CYCLE SEG = SEG1,1,SEG2
ENT=SST(SEG)
IF ENT#ENDSST START
PSECTION
SPACES(2)
WRS(DIROWN_CONLIST(DIROWN_CPOINT(SEG))_FULL)
IF ENT > CBT1 THEN ENT = ENT+1 AND PSECTION; ! DOUBLE SECTION
NEWLINE
FINISH
REPEAT
!
LOG ACTION = LOG ACTION ! SAVE DT
OUT:
J = OUT(J, "")
END ; ! PRINTMP
!
!-----------------------------------------------------------------------
!
INCLUDE "PD22S_B05PROCS"
ENDOFFILE