!TITLE User Indexes
!<DBITMAP2
! %externalintegerfn DBITMAP2(%integername LO, HI, %integer FSYS)
!>
!<DDELUSER
! %externalintegerfn DDELUSER(%string(18)FILE INDEX, %integer FSYS)
!>
!
CONSTINTEGER ERCC = 1
CONSTINTEGER KENT = 0
CONSTINTEGER SITE = KENT
CONSTINTEGER BITKEY = 0
CONSTINTEGER DIRLOG KB = 128
CONSTINTEGER DLOG = 8; ! route PRINTSTRING to DIRLOG
CONSTINTEGER ENDLIST = 255
CONSTINTEGER LOGKB=64; ! Kbytes for logfiles
CONSTINTEGER NNTKEY = 1; ! SYSAD
CONSTINTEGER NO = 0
CONSTINTEGER UNAVA = 1; ! CODES
CONSTINTEGER VIOLAT = 64; ! CODES
CONSTINTEGER WRSH = 11
CONSTINTEGER YES = 1
CONSTINTEGER BADKEY = 6; ! SYSAD
CONSTINTEGER CHERSH = 16; ! CODES
CONSTINTEGER DATKEY = 4; ! SYSAD
CONSTINTEGER LEAVE = 8
CONSTINTEGER LOSTFLEN = 48
CONSTINTEGER OLDGE = 4; !CODES2
CONSTINTEGER PON AND CONTINUE = 6
CONSTINTEGER SYNC1 TYPE = 1
CONSTINTEGER TEMPFS = 12
CONSTINTEGER TOPLOST = 80
CONSTINTEGER W = B'00000010'; !Write permission
CONSTINTEGER COM36=X'00100004'
CONSTINTEGER WRTOF=4, LOG=2, DT=1
CONSTINTEGER SIG STACK SEG=6
CONSTINTEGER CLEAR=255,NULL=0,SCREEN2=2,SCREEN SWITCH=1
CONSTINTEGER LINES PER PAGE=24
CONSTINTEGER GROUPFULLFLAG=5,SYSFULLFLAG=101,ADDEDFLAG=100
CONSTINTEGER AMBIFLAG=31,NOFREEFLAG=70,NOTINLISTFLAG=50
CONSTINTEGER TOPUG=7,ENDL=-1
CONSTINTEGER PROCRESET=1,ADDTO=2,INCRE=4,RESETN=8,OLDSCREEN=16
CONSTINTEGER REMOVE=32,DISPLAY=64,CHECKN=128,SIDECHAIN=512
CONSTSTRINGNAME DATE = X'80C0003F'
CONSTINTEGER NEXECPROCS = 4
CONSTSTRING (6)ARRAY EXECPROCS(1:NEXECPROCS) = "FTRANS", "SPOOLR", "VOLUMS",
"MAILER"
!
!
!
CONSTSTRINGNAME TIME = X'80C0004B'
CONSTSTRING (5)ARRAY LM(0:2)="FREE", "READY", "MAIN"
!
!
!
RECORDFORMAT C
KYFF(STRING (11)NAME, INTEGER A,B,C,D,E)
RECORDFORMAT C
FHDRF(INTEGER NEXTFREEBYTE,TXTRELST,MAXBYTES,THREE, C
SEMA,DATE,NEXTCYCLIC,READ TO)
!
INCLUDE "PD22S_C03FORMATS"
!
!
EXTERNALROUTINESPEC C
ATTU(STRINGNAME S)
EXTERNALINTEGERFNSPEC C
AV(INTEGER FSYS, TYPE)
EXTERNALINTEGERFNSPEC C
BAD PAGE(INTEGER TYPE, FSYS, BITNO)
EXTERNALINTEGERFNSPEC C
HINDA(STRING (6) USER,INTEGERNAME FSYS,INDAD, INTEGER TYPE)
EXTERNALINTEGERFNSPEC C
COUNT PROCS IN(STRING (6)USERGROUP, INTEGERNAME IPROCS)
EXTERNALINTEGERFNSPEC C
CREATE AND CONNECT(STRING (31)FILE,
INTEGER FSYS, NKB, ALLOC, MODE, APF,
INTEGERNAME SEG, GAP)
EXTERNALROUTINESPEC C
CYCINIT(INTEGER ADR, MAXBYTES)
EXTERNALROUTINESPEC C
DAPINTERFACE(INTEGER ACT)
EXTERNALINTEGERFNSPEC C
DCHSIZE(STRING (31)USER, FILE, INTEGER FSYS, NKB)
EXTERNALINTEGERFNSPEC C
DCONNECTI(STRING (31)FILE,INTEGER FSYS,MODE,APF,
INTEGERNAME SEG,GAP)
EXTERNALINTEGERFNSPEC C
DCREATEF(STRING (31)FILE,INTEGER FSYS,NKB,ALLOC,LEAVE,
INTEGERNAME DA)
EXTERNALINTEGERFNSPEC C
DDAYNUMBER
EXTERNALINTEGERFNSPEC C
DDESTROYF(STRING (31)FILE, INTEGER FSYS, TYPE)
EXTERNALINTEGERFNSPEC C
DDISCONNECTI(STRING (31) FILE,INTEGER FSYS,LO)
ROUTINESPEC C
DDUMP(INTEGER A,B,C,D)
EXTERNALSTRINGFNSPEC C
DERRS(INTEGER N)
EXTERNALINTEGERFNSPEC C
DFILENAMES(STRING (18)INDEX, RECORD (KYFF)ARRAYNAME F,
INTEGERNAME JUNK, MAX, N, INTEGER FSYS, TYPE)
EXTERNALINTEGERFNSPEC C
DFSTATUS(STRING (31)USER, FILE, INTEGER FSYS, ACT, VALUE)
EXTERNALROUTINESPEC C
DOUTI(RECORD (PARMF)NAME P)
EXTERNALINTEGERFNSPEC C
DPERMISSIONI(STRING (18) OWNER,USER,DATE,FILE,
INTEGER FSYS,TYPE,ADRPRM)
EXTERNALROUTINESPEC C
DPONI(RECORD (PARMF)NAME P)
EXTERNALINTEGERFNSPEC C
DPON3I(STRING (6)USER, RECORD (PARMF)NAME P, INTEGER INVOC, TYPE, OUT)
INTEGERFNSPEC C
DPRGP(STRING (18)INDEX, STRING (11)FNAME, STRING (6)LABEL,
INTEGER FSYS, SITE, DIRECTION)
EXTERNALINTEGERFNSPEC C
DRENAME(STRING (18)USER, OLD, NEW, INTEGER FSYS)
EXTERNALINTEGERFNSPEC C
DSETPASSWORD(STRING (6)USER, INTEGER FSYS, WHICH, STRING (63)OLD, NEW)
EXTERNALROUTINESPEC C
EMPTY DVM
EXTERNALINTEGERFNSPEC C
FBASE2(INTEGER FSYS, ADR)
EXTERNALROUTINESPEC C
FILL(INTEGER LENGTH, FROM, FILLER)
EXTERNALINTEGERFNSPEC C
FINDA(STRING (31)INDEX, INTEGERNAME FSYS, FINDAD, INTEGER TYPE)
EXTERNALINTEGERFNSPEC C
FIND NNT ENTRY(STRING (18)INDEX, INTEGERNAME FSYS, NNAD,INTEGER TYPE)
EXTERNALROUTINESPEC C
GETAVFSYS2(INTEGER TYPE, INTEGERNAME N, INTEGERARRAYNAME A)
EXTERNALINTEGERFNSPEC C
HASH(STRING (6)USER, INTEGER NNTHASH)
EXTERNALSTRINGFNSPEC C
HTOS(INTEGER I, PL)
EXTERNALINTEGERFNSPEC C
IN2(INTEGER FN)
EXTERNALSTRINGFNSPEC C
ITOS(INTEGER I)
EXTERNALINTEGERFNSPEC C
MAP FILE INDEX(STRINGNAME INDEX, INTEGERNAME FSYS, FINDAD, STRING (31)TXT)
EXTERNALINTEGERFNSPEC C
MOVESECTION(INTEGER FSYS1, STARTP1, FSYS2, STARTP2, EPGS)
EXTERNALROUTINESPEC C
MOVE(INTEGER LENGTH, FROM, TO)
EXTERNALINTEGERFNSPEC C
NEWAINDA(STRING (18)INDEX, INTEGER FSYS, INTEGERNAME AFINDAD)
EXTERNALINTEGERFNSPEC C
NEWFIND(INTEGER FINDAD, DA, STRINGNAME FILE)
EXTERNALINTEGERFNSPEC C
NINDA(INTEGER FSYS, INDNO, INTEGERNAME INDAD)
ROUTINESPEC C
OPER(INTEGER CONSOLE, STRING (255)S)
EXTERNALINTEGERFNSPEC C
OUT(INTEGER FLAG, STRING (63)TEMPLATE)
EXTERNALINTEGERFNSPEC C
PACKDT
EXTERNALINTEGERFNSPEC C
PP(INTEGER SEMADDR,SEMANO,STRING (63)S)
ROUTINESPEC C
PREC(STRING (255)S, RECORD (PARMF)NAME P, INTEGER N)
ROUTINESPEC C
PRHEX(INTEGER I)
EXTERNALINTEGERFNSPEC C
PRIME CONTINGENCY(ROUTINE R)
EXTERNALROUTINESPEC C
PROCESS1(INTEGER A, B)
EXTERNALINTEGERFNSPEC C
S11OK(STRINGNAME S11)
EXTERNALINTEGERFNSPEC C
STARTP(STRING (6)USER, STRINGNAME FILE, STRING (63)ITADDR,
INTEGERNAME INVOC, INTEGER FSYS, STARTCNSL, REASON, STREAM ID,
DIRVSN, PROTOCOL)
EXTERNALINTEGERFNSPEC C
STOI2(STRING (255)S, INTEGERNAME I2)
EXTERNALROUTINESPEC C
STOP ONE(INTEGER A, B)
EXTERNALINTEGERFNSPEC C
SYSAD(INTEGER KEY, FSYS)
EXTERNALINTEGERFNSPEC C
SYSBASE(INTEGERNAME SYS START, INTEGER FSYS)
EXTERNALINTEGERFNSPEC C
TXTMESS(STRING (6) USER,RECORD (PARMF)NAME RP,
INTEGER SYNC,INVOC,TXTLEN,TXTAD,FSYS,SACT)
EXTERNALINTEGERFNSPEC C
UFO(STRING (31)USER, FILE, STRINGNAME UNA, INA, FNA, INDEX, FULL)
EXTERNALINTEGERFNSPEC C
UIO(STRING (31)USER, STRINGNAME UNA, INA, INDEX)
EXTERNALINTEGERFNSPEC C
UNOK(STRINGNAME USER)
EXTERNALINTEGERFNSPEC C
VAL(INTEGER ADR, LEN, RW, PSR)
EXTERNALROUTINESPEC C
VV(INTEGER SEMADDR, SEMANO)
EXTERNALROUTINESPEC C
WRS(STRING (255)S)
EXTERNALROUTINESPEC C
WRSS(STRING (255)S1, S2)
EXTERNALROUTINESPEC C
WRSN(STRING (255)S, INTEGER N)
EXTERNALROUTINESPEC C
WRSNT(STRING (255)S, INTEGER N, T)
EXTERNALROUTINESPEC C
WRS3N(STRING (255)S1, S2, S3, INTEGER N)
!
!
!-----------------------------------------------------------------------
EXTRINSICINTEGER D CALLERS PSR
EXTRINSICINTEGER DIRLOGAD
EXTRINSICINTEGER DIRMON
EXTRINSICINTEGER D TRYING
EXTRINSICINTEGER FILE1AD
EXTRINSICINTEGER GOT SEMA
EXTRINSICINTEGER LOG ACTION
EXTRINSICINTEGER OUTPAD
EXTRINSICINTEGER PROCESS
EXTRINSICINTEGER SELECTED FSYS
EXTRINSICSTRING (6)PROCUSER
EXTRINSICSTRING (18)SELECTED INDEX
EXTRINSICSTRING (127)SELECTED NODE
EXTRINSICSTRING (15)VSN
EXTERNALINTEGER MONITORAD
!
!
!
!
OWNSTRING (31) DELIV="Machine Room"
OWNINTEGER GMON=0
! This variable below is set non-zero when JOURNL requests the current logfile
! be spooled. The SPOOLR reply is passed on to the DEST specified.
OWNINTEGER JOURNL DEST=0
OWNINTEGER MAIN LP=1
OWNINTEGER PRINT ON=0
OWNINTEGER READY FILES=0
OWNRECORD (LF)ARRAYNAME LOGS
!
!
!
!
OWNINTEGER LOSTARAD
RECORDFORMAT LOSTF(STRING (8) DATE,TIME, C
STRING (6) USER,STRING (11) FILE, C
BYTEINTEGER CODES2,CODES,CHERISHED)
!
!
!
!-----------------------------------------------------------------------
!
!
!
!
!
!
!
CONSTSTRING (1) SNL = "
"
OWNINTEGER HEAD=ENDL,ASL=-2,CURIUSERS=0,MAXIUSERS=10
!
!
!
!
!
!
RECORDFORMAT C
POPERF(INTEGER DEST,SRCE,BYTEINTEGER LINE,POS,ZERO,STRING (20)TEXT)
RECORDFORMAT C
UGF(STRING (6)U, INTEGER SUBLINK, LINK, MAX, N)
!
!
!
OWNRECORD (UGF)ARRAY UG(0:TOPUG)
OWNINTEGER LINE NO = 0
!
!
!
!-----------------------------------------------------------------------
!
EXTERNALSTRINGFN FROMSTRING(STRING (255) S,INTEGER I,J)
UNLESS 0<I<=J AND J<=LENGTH(S) THEN RESULT =""
I=I-1
CHARNO(S, I) =J-I
RESULT =STRING(ADDR(S)+I)
END ; ! FROMSTRING
!
!-----------------------------------------------------------------------
!
INTEGERFN DBITS(INTEGER N)
*LB_0; ! BIT COUNT
*LSS_N
*JAT_4,<OUT>; ! J IF ZERO
LOOP:
*ST_TOS
*USB_1
*AND_TOS ; ! N = N & (N-1)
*ADB_1
*JAF_4,<LOOP>; ! J IF NOT ZERO
OUT:
*LSS_B ; ! RESULT TO ACC
*EXIT_-64; ! %RETURN
END ; ! DBITS
!
!-----------------------------------------------------------------------
!
INTEGERFN SIZEOF(NAME X)
INTEGER I
*LSS_(LNB +5)
*ST_I
RESULT = (I<<8)>>8 UNLESS I & X'C2000000' = 0
I = (I >> 27) & 7
RESULT = 1 + ((X'F0') << I) >> 11
END ; ! SIZEOF
!
!-----------------------------------------------------------------------
!
INCLUDE "PD22S_B13GENERAL"
INCLUDE "PD22S_B11OPER"
externalintegerfn SET FILE INDEX(string (6)USER, string (11)NAME,
integer FSYS, SIZE, NPD, NFD, FINDAD, INDNO)
!
! SIZE given in half K's
!
integer FLAG, N, SDBYTES, J
record (FF)name F
constinteger PDSTART = 128
RECORD (FDF)ARRAYNAME FDS
constinteger TOPN = 19
constbyteintegerarray V(0:TOPN) = 0, 1, 3, 4, 7, 8, c
15, 16, 23, 24, 31, 32, 39,40,47,48,55,56,63, 64
constbyteintegerarray PDV(1:TOPN) = 8, 12, 32, 32, 48, 48, 48, 48, 48(11)
{ SDs 29 48 180 1204 628 }
constintegerarray FDV(1:TOPN) = 8, 37, 50, 93,100,200,200,200,200, 400(6),
800(4)
FLAG = 8
cycle J = TOPN, -1, 0
N = J
exit if V(N) = SIZE
repeat
-> OUT if N = 0; ! an invalid size
!
NPD = PDV(N) if NPD = 0
NFD = FDV(N) if NFD = 0
!
-> OUT unless 8 <= NPD <= 128
-> OUT unless 8 <= NFD <= 1024
NPD = (NPD + 3) & (-4); ! make NPD a multiple of 4
SDBYTES = SIZE << 9 - PDSTART - PDSIZE*NPD - FDSIZE*NFD
-> OUT unless 0 <= SDBYTES <= 32768
!
FLAG = 0
F == RECORD(FINDAD)
FILL(SIZE<<9, FINDAD, 0); ! clear the whole record
F_OWNER = USER
F_NAME = NAME
F_FSYS = FSYS
F_SEMA = -1
F_SEMANO = FSYS << 16 ! INDNO
F_ASEMA = -1
F_PDSTART = PDSTART
F_SDSTART = PDSTART + PDSIZE*NPD
F_FDSTART = F_SDSTART + SDBYTES
F_DAY42 = DDAYNUMBER & 255
!
IF NAME = "#ARCH" START
F_MAXFILE = SIZE << 9
FINISH ELSE START
F_SIZE = SIZE
FDS == ARRAY(FINDAD + F_FDSTART, FDSF)
CYCLE J = 1, 1, 7
FDS(J)_NAME = ".NULL"
REPEAT
FINISH
OUT:
result = FLAG
end ; ! OF SET FILE INDEX
!
!-----------------------------------------------------------------------
!
integerfn SET USER RECORD(string (6)USER, integer FSYS,
SIZE, NPD, NFD, INDAD, INDNO)
!
! SIZE in half K's
!
integer FLAG, N, J
LONGINTEGER L
string (4)U4
record (FF)name F
record (HF)name H
!
!
!
constinteger TOPU = 8
conststring (4)array U(0:TOPU) = c
"DUMM", "MANA", "VOLU", "JOBR", "ENGI", "SPOO", "JOUR", "MAIL", "FTRA"
constintegerarray MAXFILE(0:TOPU) = c
0, 50000(8)
constbyteintegerarray ACR(0:TOPU) = c
0, 4, 9, 9, 2, 9, 9, 9, 9
constbyteintegerarray STKKB(0:TOPU) = c
0, 0, 252, 0, 0, 0, 0, 0, 0
constintegerarray TRYING(0:TOPU) = c
0, X'F7F7F7F7'(6), X'7141710', X'F7F7F7F7'
!
!
!
U4 <- USER; ! look for special users
cycle J = TOPU, -1, 0
N = J
exit if U(N) = U4
repeat
!
H == RECORD(INDAD)
FILL(512, INDAD, 0); ! clear first 512, file part cleared separately
H_OWNER = USER
H_MARK = 1
H_MSGSEMA = -1
H_ACR = ACR(N)
H_DIRVSN = 255
H_IMAX = 255
H_BMAX = 255
H_TMAX = 255
H_STKKB = STKKB(N)
H_FSYS = FSYS
H_TOP = SIZE << 9
L = 0
J = M'....' !! (-1)
*LSS_J
*ST_L+4
H_DWSP = L
H_BWSP = L
!
J = DSETPASSWORD(USER, FSYS, 1, "....", "....")
J = DSETPASSWORD(USER, FSYS, 0, "....", "....")
!
IF SITE = ERCC AND N = 0 { unprivileged } START
H_TRYING = 1 << 16 { allow use of real money devices } C
UNLESS CHARNO(USER, 4) = 'U'
FINISH ELSE H_TRYING = TRYING(N)
!
H_LAST LOG ON = PACKDT
INDAD = INDAD + 512
FLAG = SET FILE INDEX(USER, "", FSYS, SIZE-1, NPD, NFD, INDAD, INDNO)
F == RECORD(INDAD)
F_MAXFILE = MAXFILE(N)
result = FLAG
end ; ! SET USER RECORD
!
!-----------------------------------------------------------------------
!
INTEGERFN NEW NNT ENTRY(STRING (18)INDEX, INTEGER FSYS, INTEGERNAME NNAD)
INTEGER J, STOP, N, FINDAD, K
STRING (18)UNA, INA
RECORD (NNF)ARRAYFORMAT NNTF(0 : 16384)
RECORD (NNF)ARRAYNAME NNT
RECORD (NNF)NAME NN
RECORD (FF)NAME F
RECORD (DISCDATAF)DATA
RESULT = 23 IF AV(FSYS, 0) = 0; ! FSYS N/A
J = FBASE2(FSYS, ADDR(DATA))
RESULT = J UNLESS J = 0
!
NNT == ARRAY(SYSAD(NNTKEY, FSYS), NNTF)
UNA = INDEX AND INA = "" UNLESS INDEX -> UNA . (ISEP) . INA
STOP = HASH(UNA, DATA_NNTHASH)
K = -1; ! to remember first empty entry
N = STOP
!
UNTIL N = STOP CYCLE ; ! cycle through, starting at optimum place
! checking if already in and getting a free entry
NN == NNT(N)
IF NN_NAME = UNA START
IF INA = "" START ; ! main index entry reqd
RESULT = 14 IF NN_TAG = 0; ! already has a main index
FINISH ELSE START
IF NN_TAG > 0 START ; ! this entry is for a file index
J = NINDA(FSYS, NN_INDNO, FINDAD)
RESULT = J UNLESS J = 0; ! should not occur
F == RECORD(FINDAD)
RESULT = 87 UNLESS F_OWNER = UNA
RESULT = 14 IF F_NAME = INA
FINISH
FINISH
FINISH ELSE START
K = N IF K < 0 AND LENGTH(NN_NAME) < 6; ! first free
FINISH
IF N = DATA_NNTTOP THEN N = 0 ELSE N = N + 1
REPEAT
!
RESULT = 13 IF K < 0; ! no free entries found
NNAD = ADDR(NNT(K))
RESULT = 0
END ; ! NEW NNT ENTRY
!
!-----------------------------------------------------------------------
!
EXTERNALINTEGERFN DINDNO(STRING (18)NAME, INTEGER FSYS,
INTEGERNAME INDNO)
INTEGER J, NNAD
STRING (31)UNA, INA, INDEX
RECORD (NNF)NAME NN
J = IN2(33)
-> OUT UNLESS J = 0
!
J = 8
-> OUT IF FSYS < 0
!
J = UIO(NAME, UNA, INA, INDEX)
-> OUT UNLESS J = 0
!
J = FIND NNT ENTRY(INDEX, FSYS, NNAD, 0)
-> OUT UNLESS J = 0
!
NN == RECORD(NNAD)
INDNO = NN_INDNO
OUT:
RESULT = OUT(J, "SI")
END
!
!-----------------------------------------------------------------------
!
INCLUDE "PD22S_B08DPRG"
externalintegerfn STRING TO FILE(integer TXTL,TXTA,FA)
integer I0, MAX, FREE
record (FHDRF)name H
H == RECORD(FA)
CYCINIT(FA, 4096) if H_MAXBYTES = 0
I0 = H_NEXTCYCLIC
MAX = H_MAXBYTES
FREE = MAX - I0; ! >= 1
!
if TXTL <= FREE start ; ! no wrapround
MOVE(TXTL, TXTA, FA + I0)
if H_NEXT FREE BYTE < MAX c
then H_NEXT FREE BYTE = I0 + TXTL
!
if I0 + TXTL < MAX start
H_NEXT CYCLIC = I0 + TXTL
if I0 < H_READ TO <= I0 + TXTL start
if I0 + TXTL = MAX + 1 c
then H_READ TO = H_TXT REL ST c
else H_READ TO = I0 + TXTL + 1
finish
finish else start
H_NEXT CYCLIC = H_TXT REL ST
if I0 < H_READ TO c
then H_READ TO = H_TXT REL ST + 1
finish
finish else start
MOVE(FREE, TXTA, FA + I0); ! it does wrap round, move two bits
MOVE(TXTL - FREE, TXTA + FREE, FA + H_TXT REL ST)
H_NEXT FREE BYTE = MAX
H_NEXT CYCLIC = H_TXT REL ST + TXTL - FREE
if H_READ TO > I0 or H_READ TO <= H_NEXT CYCLIC c
then H_READ TO = H_NEXT CYCLIC + 1
finish
result =(I0<<16) ! H_NEXT CYCLIC
end ; ! STRING TO FILE
!
!-----------------------------------------------------------------------
!
EXTERNALROUTINE COPY TO FILE(INTEGER FA1, FA2)
INTEGER J, RT, NC, TRS
RECORD (FHDRF)NAME H
H == RECORD(FA1)
RT = H_READTO
NC = H_NEXTCYCLIC
TRS= H_TXT REL ST
RETURN IF RT = NC; ! nothing to copy
!
IF RT < NC START ; ! simple chunk to dispose of
J = STRING TO FILE(NC-RT, FA1+RT, FA2)
FINISH ELSE START ; ! two chunks, although second may be null !!
J = STRING TO FILE(H_MAXBYTES-RT, FA1+RT, FA2)
IF NC > TRS START ; ! there is another bit
J = STRING TO FILE(NC-TRS, FA1+TRS, FA2)
FINISH
FINISH
H_READTO = NC
END ; ! COPY TO FILE
!
!-----------------------------------------------------------------------
!
INTEGERFN SPOOL(STRING (31)FULL, DEST, DELIV,
INTEGER FSYS, START, END, COPIES, PROC1 DACT)
INTEGER LEN
STRING (255)S
STRING (31)USER, FILE
RECORD (PARMF)P
FULL -> USER . (".") . FILE
S = "DOCUMENT DEST=" . DEST . C
",SRCE=" . FILE . C
",LENGTH=" . ITOS(END - START) . C
",PRTY=VHIGH" . C
",COPIES=" . ITOS(COPIES) . C
",USER=" . USER . C
",START=" . ITOS(START) . C
",FSYS=" . ITOS(FSYS)
S = S . ",DELIV=" . DELIV UNLESS DELIV = ""
ATTU(S)
LEN = LENGTH(S)
P_DEST = X'FFFF0016'
RESULT = TXTMESS("SPOOLR", P, 1, 0, LEN, ADDR(S)+1, -1, PROC1 DACT)
END ; ! SPOOL
!
!-----------------------------------------------------------------------
!
!
!
! Process1 DACTs for replies:
! 38 reply from SPOOLR for JOURNAL file
! 39 LP
!
!
!---------------------------------------------------------------------------------
STRINGFN NEWNAME
OWNINTEGER INC=0
STRING (10) S,HH,MM,SS
S=TIME
S->HH.(".").MM.(".").SS
INC=INC+1
INC=0 IF INC>9999; ! restricting final name to 10 characters
RESULT ="M".ITOS(INC)."#".HH.MM
END ; ! NEWNAME
!
!-----------------------------------------------------------------------
!
INTEGERFN MAKE LOGFILE(RECORD (LF)NAME LOGRECORD)
! This routine creates a uniquely-named file of LOGKB kbytes(currently 16 epages)
! in VOLUMS index on the SLOAD file system, fills it with EM characters
! and puts an Edinburgh Subsystem standard header on it (character file)
! In addition the file is permitted to the DIRECT process, is made
! temporary and is connected into the caller's VM (to prevent it's being
! accidentally destroyed (e.g. by erroneous software!).
INTEGER J, GAP, FAD, BYTES, SEG, FN, DA
STRING (11)VOLSFILE
STRING (31)FULL
RECORD (FHDRF)NAME FH
CONSTSTRING (12)PROC = "MAKE LOGFILE"
VOLSFILE = LOGRECORD_NAME
FULL = "VOLUMS." . VOLSFILE
LOGRECORD_FSYS = COM_SUPLVN
!
FN = 1; ! CREATE
J = DCREATEF(FULL, -1, LOGKB, 1, LEAVE, DA); ! ALLOCATE
-> ERR UNLESS J = 0
!
GAP = 0
SEG = 0
FN = 2; ! CONNECT
J = DCONNECTI(FULL, -1, 2, 0, SEG, GAP)
-> ERR UNLESS J = 0
!
FAD = SEG << 18
FH == RECORD(FAD)
BYTES = 64 << 10
FILL(BYTES, FAD, X'19')
FH_NEXTFREEBYTE = 32
FH_TXTRELST = 32
FH_MAXBYTES = BYTES
FH_THREE = 3; ! CHARACTER FILE
! We now want to remove the PRIVacy VIOLated state. We used to do this
! by creating the file with the "zero" option, but this was too slow
! (psychologically, at IPL). So we'll just disconnect and the transfers
! occur "on the fly", i.e. we don't go to sleep awaiting
! completion of the transfers.
J = DDISCONNECTI(FULL, -1, 0)
!
GAP = 0
SEG = 0
J = DCONNECTI(FULL, -1, 11, 0, SEG, GAP)
DOPERR(PROC, 2, J) UNLESS J = 0
! Now make it a temporary file, so that unused files are destroyed at
! consistency check (temporary attribute disappears on RENAME,
! TRANSFER or PERMIT, and that's why we can't create it "temporary").
J = DFSTATUS("VOLUMS", VOLSFILE, -1, 5, 0)
DOPERR(PROC, 8, J) UNLESS J = 0
!
LOGRECORD_DISC ADDR = DA
LOGRECORD_STATE = 1; ! READY
READY FILES = READY FILES + 1
RESULT = 0
ERR:
DOPERR(PROC, FN, J)
RESULT = J
END ; ! MAKE LOGFILE
!
!-----------------------------------------------------------------------
!
ROUTINE LOG DISCONNECT(RECORD (LF)NAME LOG)
!
! The point of this routine is to get the LOG file "disconnected" even if it
! isn't connected in this VM (becase a previous invocation of DIRECT died in
! an unfortunate manner. This will be done as follows. If the DDISCONNECT
! fails 39, we get a new (ready) file to copy the contents into, and replace
! the data in the LOG parameter record accordingly.
!
INTEGER J, INSEG, OUTSEG, N, GAP, ONCE, INAD, OUTAD
RECORD (FHDRF)NAME H
CONSTSTRING (15)PROC = "LOG DSCN"
ONCE = 0
REDISC:
J = DDISCONNECTI("VOLUMS." . LOG_NAME, LOG_FSYS, 0)
RETURN IF J = 0 OR ONCE > 0
!
ONCE = 1
IF J = 39 START
! not connected, we presume because previous invocation of DIRECT had
! it connected.
INSEG = 0
GAP = 0
J = DCONNECTI("VOLUMS." . LOG_NAME, LOG_FSYS, 11, 0, INSEG, GAP)
DOPERR(PROC." ".LOG_NAME, 2, J) UNLESS J = 0
INAD = INSEG << 18
!
! Find a ready file to copy the data into
CYCLE N = 0, 1, TOP LOG
IF LOGS(N)_STATE = 1 START ; ! ready
OUTSEG = 0
GAP = 0
! (we actually expect it to be connected, but this way we get the
! connect address)
J = DCONNECTI("VOLUMS." . LOGS(N)_NAME, LOGS(N)_FSYS,
11, 0, OUTSEG, GAP)
DOPERR(PROC." ".LOGS(N)_NAME,2,J) AND RETURN IF 0 # J # 34
OUTAD = OUTSEG << 18
!
! Move the necessary amout of data
H == RECORD(INAD)
J = H_TXTRELST
J = J + 1 WHILE J < H_MAXBYTES AND BYTEINTEGER(INAD+J) # X'19'
H_NEXTFREEBYTE = J
MOVE(J, INAD, OUTAD)
!
! The OUTSEG file now replaces the original
LOG = LOGS(N)
LOGS(N)_STATE = 0; ! just forget about the original
-> REDISC
FINISH
REPEAT
DOPER2(PROC." no free files")
FINISH
DOPERR(PROC,5,J)
END ; ! LOG DISCONNECT
!
!-------------------------------------------------------------------------------
!
ROUTINE SPOOL LOGFILE(RECORD (LF)NAME LOG TO BE SPOOLED,
INTEGER BYTES, CHAR1)
! This routine scans the file to be spooled backwards to get the last
! non-EM character. But if BYTES is >0 then this is the
! required data length.
! If PRINT ON = 0, then to JOURNAL queue
! >0, then to LP queue in addition.
RECORD (FHDRF)NAME H
STRING (31)COPFILE, UP TO TIME FILE, FULL
INTEGER J, A, SEG, GAP, LOGFILE SEG, CURF, DA, FN, PROC1 DACT
INTEGER START, END
STRING (11)CURLOG
CONSTSTRING (13)PROC = "SPLOGFILE"
PROC1 DACT = 39
LOG DISCONNECT(LOG TO BE SPOOLED)
CURLOG = LOG TO BE SPOOLED_NAME
CURF = LOG TO BE SPOOLED_FSYS
DA = LOG TO BE SPOOLED_DISC ADDR
! Rename the file to make it's identifier reflect the current time-
! of-day.
UP TO TIME FILE = NEWNAME
CHARNO(UP TO TIME FILE, 1) = CHAR1; ! make first char M for mainlog, D for Director log
J = DRENAME("VOLUMS", CURLOG, UP TO TIME FILE, CURF)
!
IF J = 0 C
THEN CURLOG = UP TO TIME FILE C
ELSE DOPERR(PROC." ".CURLOG, 9, J)
!
LOG TO BE SPOOLED = 0
RETURN IF CURLOG = ""
!
FULL = "VOLUMS." . CURLOG
LOGFILE SEG = 0
GAP = 0
FN = 2
J = DCONNECTI(FULL, CURF, 11, 0, LOGFILE SEG, GAP)
-> ERR UNLESS J = 0
!
A = LOGFILE SEG <<18
H==RECORD(A)
UNLESS 0<H_TXTRELST<=64 AND 0<H_MAXBYTES<=X'10000' START
DOPER2("HDR ? .".CURLOG." ".HTOS(DA,4))
H_NEXTFREEBYTE=X'10000'
H_TXTRELST=32
H_MAXBYTES=X'10000'
H_THREE=3
FINISH
IF H_TXTRELST<BYTES<=H_MAXBYTES THEN H_NEXTFREEBYTE=BYTES C
ELSE START
J=A + H_TXTRELST
J=J+1 WHILE J<A + H_MAXBYTES AND BYTEINTEGER(J)#X'19'
H_NEXTFREEBYTE=J - A
FINISH
!
START = H_TXTRELST
END = H_NEXTFREEBYTE
!
IF PRINT ON>0 START
PRINT ON=PRINT ON - 1
! make a copy of the file in VOLUMS to send to LP.
COPFILE=FULL
BYTEINTEGER(ADDR(COPFILE)+8)='L'
FN = 1
J=DCREATEF(COPFILE,CURF, C
(END+X'3FF')>>10, 16 + 1,LEAVE,DA)
IF J = 0 START
SEG = 0
GAP = 0
FN = 2
J=DCONNECTI(COPFILE,CURF,3,0,SEG,GAP)
IF J=0 START
MOVE(END, A, SEG << 18)
J=DDISCONNECTI(COPFILE,CURF,0)
FN = 10
J=SPOOL(COPFILE, "LP", DELIV,CURF,START, END,1,PROC1 DACT)
FINISH
FINISH
DOPERR(PROC."/C", FN, J) UNLESS J = 0
FINISH ; ! PRINT ON > 0
FN = 5
J=DDISCONNECTI(FULL,CURF,1)
DOPERR(PROC, FN, J) UNLESS J = 0
FN = 10
IF CHAR1='M' THEN PROC1 DACT=38
J=SPOOL(FULL, "JOURNAL", "",CURF,START, END,1,PROC1 DACT)
!
RETURN IF J = 0
ERR:
DOPERR(PROC, FN, J)
END ; ! SPOOL LOGFILE
!
!-----------------------------------------------------------------------
!
ROUTINE PRINT LOGSPACE
INTEGER J
CYCLE J=0,1,TOPLOG
DOPER2(LOGS(J)_NAME." ".HTOS(LOGS(J)_DISC ADDR,8)." ".LM(LOGS(J)_STATE))
REPEAT
END ; ! PRINT LOGSPACE
!
!-----------------------------------------------------------------------
!
ROUTINE FILL LOGSPACE(INTEGER RESTART)
! If RESTART is non-zero (restart of DIRECT) then the logfiles are possibly
! marked connected (in the previous DIRECT's VM). This is the case only if
! DIRECT has failed on the signal stack.
! Anyway, what we are going to do on restart is to forget the "ready" files,
! keep the files which PRINTER has got and re-fill the logspace with new files.
! Then when PRINTER gives up its existing files they will get copied into fresh
! files in rt SPOOL LOGFILE.
!
INTEGER J,K
K=0
CYCLE J=0,1,TOPLOG
! (If restart and state=ready then state=free)
IF RESTART#0 AND LOGS(J)_STATE=1 THEN LOGS(J)_STATE=0
IF LOGS(J)_STATE=0 START ; ! FREE
LOGS(J)_NAME=NEWNAME
K=K!MAKE LOGFILE(LOGS(J))
FINISH
REPEAT
!
IF K#0 START
DOPERR("FILL LOGSPACE", 0, K)
PRINT LOGSPACE
FINISH
END ; ! FILL LOGSPACE
!
!-----------------------------------------------------------------------
!
ROUTINE GIVE NEW SECTION(INTEGER DEST)
! This routine serves the following two functions:
! 1. selects a "ready" file and gives its disc address to the
! resident PRINTER routine (DEST#-1), and
! 2. selects a "ready" file to copy the Director logfile into,
! and spools it (DEST=-1)
INTEGER AD,J,LX,FSYS,SEG,GAP
INTEGER SEMADR, SEMANO
STRING (11) NAME
RECORD (PARMF)P
RECORD (FHDRF)NAME H, HH
RECORD (DIRCOMF)NAME DIRCOM
CONSTSTRING (13)PROC = "GIVE NEW SCTN"
RETURN IF DEST=0
CYCLE LX=0,1,TOPLOG
IF LOGS(LX)_STATE=1 START ; ! READY
UNLESS DEST = -1 START
! SEND IT OFF TO PRINTER
P=0
P_DEST=DEST
P_P1=16; ! EPGS
P_P2=LOGS(LX)_DISC ADDR
IF GMON#0 THEN DOPER2("NEWSECT ".HTOS(P_P2,8))
DPONI(P)
FINISH
NAME=LOGS(LX)_NAME
FSYS=LOGS(LX)_FSYS
! Also RENAME it, to add a "#" to the RH end of the name (which is max 10
! characters at this point) to indicate that this is one of the files
! This also removes TEMPORARY status, so that this log will survive IPL.
J=DDISCONNECTI("VOLUMS." . NAME,FSYS,0)
DOPERR(PROC, 5, J) UNLESS J = 0
J=DRENAME("VOLUMS",NAME,NAME."#",FSYS)
DOPERR(PROC, 9, J) UNLESS J = 0
NAME=NAME."#"
LOGS(LX)_NAME=NAME
SEG=0; GAP=0
J=DCONNECTI("VOLUMS." . NAME,FSYS,11,0,SEG,GAP)
DOPERR(PROC, 2, J) UNLESS J = 0
IF DEST=-1 START
IF J=0 START
! Copy and spool the Director logfile
AD=SEG<<18
H==RECORD(AD)
! Set up the header first for the copy of the circular file
H_NEXTFREEBYTE=32
H_TXTRELST=32
H_MAXBYTES=LOGKB<<10
H_NEXTCYCLIC=32
DIRCOM == RECORD(SYSAD(DIRCOM KEY, -1))
SEMADR = ADDR(DIRCOM_DIRLOGSEMA)
SEMANO = (1<<31)!1
J = PP(SEMADR, SEMANO,PROC); ! DIRLOG sema
IF J = 0 START
COPY TO FILE(DIRLOGAD,AD)
! Clear word4 "SPARE" in #DIRLOG header to indicate to
! other processes that data has been spooled.
HH==RECORD(DIRLOGAD)
HH_SEMA=0
VV(SEMADR, SEMANO)
FINISH
! Now fix the header into the format required by JOURNAL
! (Word numbers counting from zero)
H_THREE=3; ! Word 3
H_DATE=PACKDT; ! Word 5
H_NEXTCYCLIC=X'FFFFFF04'; ! Word 6, DIRLOG code
! Spool if not empty else destroy
IF H_NEXTFREEBYTE>H_TXTRELST THEN C
SPOOL LOGFILE(LOGS(LX),H_NEXTFREEBYTE,'D') C
ELSE J=DDISCONNECTI("VOLUMS." . NAME,FSYS,2); ! and destroy
LOGS(LX)_STATE=0; ! FREE
FINISH
FINISH ELSE START
! Giving (having given) a file section to PRINTER
LOGS(LX)_STATE=2; ! MAIN
READY FILES=READY FILES - 1
FINISH
!
RETURN
FINISH
REPEAT
PRINT LOGSPACE
END ; ! GIVE NEW SECTION
!
!-----------------------------------------------------------------------
!
ROUTINE LSPOOL(INTEGER DA,BYTES)
INTEGER J
! DISC ADDRESS IS ALLOWED TO REPRESENT ANY PAGE IN THE 16 EPAGE
! SECTION, AND SECTIONS ARE 16 EPAGE-ALIGNED. SO DROP THE BOOTTOM
! 4 BITS
DA=DA&(¬15)
CYCLE J=0,1,TOPLOG
IF LOGS(J)_DISC ADDR=DA AND LOGS(J)_STATE=2 START ; ! MAIN
UNLESS 32<=BYTES<=X'10000' START
DOPER2("DA BYTES ")
DOPER2(HTOS(DA,8)." ".HTOS(BYTES,8))
FINISH
! OK TO SPOOL
IF GMON#0 START
DOPER2("LSPOOL ".LOGS(J)_NAME)
DOPER2(HTOS(DA,8)." ".HTOS(BYTES,8))
FINISH
SPOOL LOGFILE(LOGS(J),BYTES,'M')
LOGS(J)_STATE=0; ! FREE
!
RETURN
FINISH
REPEAT
DOPERR("LSPOOL", 0, DA)
PRINT LOGSPACE
END ; ! LSPOOL
!
!-----------------------------------------------------------------------
!
ROUTINE PROCEED TO NEW FILE
RECORD (PARMF)P
P=0
P_DEST=X'00360007'
P_SRCE=21; ! TO BE USED FOR FUTURE NEW FILE REQUESTS FROM MAIN
DPONI(P)
MAIN LP=0
END ; ! PROCEED TO NEW FILE
!
!-----------------------------------------------------------------------
!
EXTERNALINTEGERFN LOGLINK(RECORD (PARMF)NAME P, INTEGER ACT)
OWNINTEGER DPRINT NEWSECT DEST=0
OWNINTEGER LINIT=0
OWNINTEGER MAPAD
INTEGER N1,SEG,SEGAD,GAP,FSYS,I,J,DISCAD,SIZE, RES, PROTOCOL
INTEGER NKB, ALLOC, MODE, APF, RESTART, INOFF, OUTOFF, DA
RECORD (FHDRF)NAME HH
RECORD (LOGF HDF)NAME H
RECORD (FEPF)ARRAYNAME FEPS
RECORD (FEP DETAILF)NAME FEP
RECORD (DIRCOMF)NAME DIRCOM
CONSTINTEGER TOPLA=12
SWITCH NEWLA(0:TOPLA)
CONSTSTRING (7)PROC = "LOGLINK"
STRINGNAME SITEF
RES = 8
IF LINIT = 0 START ; ! need to initialise
FSYS = -1
! NKB = (ADDR(TESTH_LEND) - ADDR(TESTH) + X'FFF')>>10
NKB = 128; ! one block. The FEP buffers go in the last 16 pages.
! The amount required for the LOGF HDR record is only
! four pages.
ALLOC = X'03000055'; ! EEP=3, ZERO, TEMPFI
MODE = WRSH
APF = 0
SEG = 0
GAP = 0
J = DCREATEF("VOLUMS.#LOGMAP", FSYS, NKB, ALLOC, LEAVE, DA)
DOPERR(PROC, 1, J) UNLESS J=0 OR J=23 OR J=37 OR J=16
-> OUT UNLESS J = 0 OR J = 16
!
J = DCONNECTI("VOLUMS.#LOGMAP", FSYS, MODE, APF, SEG, GAP)
DOPERR(PROC, 2, J) AND -> OUT UNLESS J = 0 OR J = 34
!
SEGAD = SEG <<18
MAPAD = SEGAD + X'10000'
H == RECORD(MAPAD)
!
IF H_LOGMAPST = 0 START ; ! just done an IPL
DIRCOM == RECORD(SYSAD(DIRCOM KEY, -1)); ! preserve DEFAULT SUBSYS and STUDENT
DIRCOM_DIRLOGSEMA = -1
DIRCOM_FEPSEMA = -1
DAP INTERFACE(1); ! Set DAP fields
DIRCOM_SUBSYS SITE COUNT = 0
DIRCOM_STUDENT SITE COUNT = 0
!
CYCLE J = 0, 1, 253
H_PROCLIST(J) = 0;
H_PROCLIST(J)_LINK = J + 1
REPEAT
H_PROCLIST(254)_LINK = ENDLIST
H_LOGMAPST = ADDR(H_PROCLIST(0)) - MAPAD
H_FREEHD = 0
H_LIVEHD = ENDLIST
H_BACKHD = ENDLIST
!
FEPS == H_FEPS
INOFF = - 2*FEP IO BUFF SIZE
CYCLE I = 0, 1, TOP FE NO
FEPS(I)_AVAILABLE = NO
CYCLE PROTOCOL = ITP, 1, X29
FEP == FEPS(I)_FEP DETAILS(PROTOCOL)
FEP_INPUT STREAM = 0;!STREAM TYPE
FEP_OUTPUT STREAM = 1; !DITTO
FEP_IN BUFF DISC ADDR = DA
FEP_OUT BUFF DISC ADDR = DA
FEP_IN BUFF DISC BLK LIM = 31
FEP_OUT BUFF DISC BLK LIM = 31
INOFF = INOFF + 2*FEP IO BUFF SIZE
OUTOFF = INOFF + FEP IO BUFF SIZE
FEP_IN BUFF CON ADDR = SEGAD + INOFF
FEP_OUT BUFF CON ADDR = SEGAD + OUTOFF
FEP_IN BUFF OFFSET = INOFF
FEP_OUT BUFF OFFSET = OUTOFF
FEP_IN BUFF LENGTH = FEP IO BUFF SIZE
FEP_OUT BUFF LENGTH = FEP IO BUFF SIZE
REPEAT
REPEAT
RESTART = 0
FINISH ELSE RESTART = 1
!
LOGS == H_LOGS
FILL LOGSPACE(RESTART)
!
!
ALLOC = X'03000051'; ! Create a 'monitor' file, zeroed, EEP = 3
MODE = WRSH
APF = 0
SEG = 15
GAP = 0
J = CREATE AND CONNECT("VOLUMS.#MONITOR", FSYS, 8 {kb},
ALLOC, MODE, APF, SEG, GAP)
IF J = 0 C
THEN MONITORAD = SEG << 18 C
ELSE DOPERR(PROC, 1, J)
!
! Also create and connect a 1/2-segment file for a Director log
ALLOC = X'03000051'; ! EEP=3, ZERO
MODE = WRSH
APF = 0
SEG = 14
GAP = 0
J = CREATE AND CONNECT("VOLUMS.#DIRLOG", FSYS, C
DIRLOG KB, ALLOC, MODE, APF, SEG, GAP)
IF J = 0 START
DIRLOGAD = SEG << 18
HH == RECORD(DIRLOGAD)
HH_SEMA = 0; ! clear it at IPL (yes 0=clear!) in case left held
! at end of last session
CYCINIT(DIRLOGAD, DIRLOG KB<<10) IF HH_MAXBYTES = 0
LOG ACTION = DT ! DLOG
FINISH ELSE DOPERR(PROC, 1, J)
!
SITEF == DIRCOM_DEFAULT SUBSYS
IF DIRCOM_SUBSYS SITE COUNT = 0 AND SITEF # "" START
DOPER2("IPLPRG " . SITEF)
J = DPRG("", SITEF, -1, "DEV".ITOS(100+COM_SUPLVN), X'380')
DOPER2("Flag=" . ITOS(J))
SITEF = "" IF J = 0
FINISH
!
SITEF == DIRCOM_DEFAULT STUDENT
IF DIRCOM_STUDENT SITE COUNT = 0 AND SITEF # "" START
DOPER2("IPLPRG " . SITEF)
J = DPRG("", SITEF, -1, "DEV".ITOS(100+COM_SUPLVN), X'400')
DOPER2("Flag=" . ITOS(J))
SITEF = "" IF J = 0
FINISH
!
LINIT=1; ! LOGLINK INITIALISED
FINISH
UNLESS 0<ACT<=TOPLA THEN ACT=0
-> NEWLA(ACT)
!---------------------------- NEW ------------------------------------
NEWLA(0): ! INVALID ACT
-> OUT
NEWLA(1): ! FROM PR(21) IN RT PROCESS1
! P_P1 = DISC ADDRESS WITHIN FILE TO BE SPOOLED
! P_P2 = FINAL SIZE IN BYTES
DPRINT NEWSECT DEST=P_SRCE
DISCAD=P_P1
SIZE=P_P2
GIVE NEW SECTION(DPRINT NEWSECT DEST)
IF DISCAD#0#SIZE THEN LSPOOL(DISCAD,SIZE)
FILL LOGSPACE(0)
-> OUT0
!
NEWLA(2): ! AFTER IPL, BEFORE STARTING VOLUMS & SPOOLR
PROCEED TO NEW FILE
NEWLA(8): ! give address in LOGMAP file for DIRECT's process list
P_DEST=MAPAD
-> OUT0
!
NEWLA(3): ! D/PRINT(25)
! Param specifies number of files to be printed, where
! D/PRINT (no param) means print current file
! D/PRINT 0 means go to new file without printing current file
! and otherwise
! D/PRINT n means print current and n-1 subsequent
! files.
! Note that the number PRINT ON is also set by D/DIRPRINT
N1=P_DEST
IF N1=1 THEN GMON=1
IF N1=2 THEN GMON=0
IF N1=-1 THEN N1=1; ! default value
PRINT ON=N1
IF READY FILES=0 START
FILL LOGSPACE(0)
GIVE NEW SECTION(DPRINT NEWSECT DEST)
FINISH
PROCEED TO NEW FILE
-> OUT0
!
NEWLA(4): ! from JOURNL, requesting current logfile be spooled
! This entry is reached by sending a DACT 27 message to DIRECT. A reply is
! (eventually) given to SRCE. P_P1 is a FLAG, 0 if operation successful,
! otherwise -1,-2 or -3, or SPOOLR's flag as described below.
! Effects are as follows:
! 1. If MAIN has printer then FLAG -3, else
! PRINTER is poked to close current file.
! 2. SRCE of request is remembered, FLAG -2 given immediately if one
! already remembered.
! 3. Each time a file is spooled to JOURNAL, if a SRCE is remembered, a reply
! is given to the SRCE (and SRCE forgotten). If the spool request
! failed, FLAG is -1 if Director flag non-zero, else SPOOLR's flag.
! P_P2 of the reply to SRCE is SPOOLR's Id for the file spooled if spool successful, else -1.
IF JOURNL DEST#0 OR MAIN LP#0 START
P_DEST=P_SRCE
P_P1=-2
IF MAIN LP#0 THEN P_P1=-3
DPONI(P)
FINISH ELSE JOURNL DEST=P_SRCE
PROCEED TO NEW FILE
-> NEWLA(11); ! GIVE DIRLOG TO JOURNL AS WELL
!
NEWLA(5): ! D/MAINLP(32)
!
RES = 81
-> OUT UNLESS MAINLP = 0
P = 0
P_DEST = X'00360008'
DOUTI(P)
RES = P_P1
MAINLP = 1 IF RES = 0
-> OUT
NEWLA(6):
PRINT LOGSPACE
-> OUT0
NEWLA(7): ! D/DELIVER
DELIV<-STRING(ADDR(P))
IF DELIV="" THEN DELIV="Machine Room"
-> OUT0
!
NEWLA(9): ! Dact 38 in process1. JOURNAL reply fROM SPOOLR
IF JOURNL DEST#0 START
! only if spooled to JOURNAL queue
P_DEST=JOURNL DEST
DPONI(P)
JOURNL DEST=0
FINISH
!
NEWLA(10): ! Dact 39 in process1. LP reply from SPOOLR
-> OUT0
NEWLA(12): ! D/DIRPRINT
! Param specifies number of files to be printed, where
! D/PRINT (no param) mans print current file
! D/PRINT 0 means go to new file without printing current file
! and otherwise D/PRINT n means print current and n-1 subsequent
! files.
N1=P_DEST
IF N1=-1 THEN N1=1; ! default value
PRINT ON=N1
NEWLA(11): ! Dact 40 in process1. Trigger DIRPRINT from user process
IF DIRLOGAD=0 THEN RES=90 AND -> OUT; ! no #DIRLOG file, or not connected
GIVE NEW SECTION(-1)
FILL LOGSPACE(0)
-> OUT0
OUT0:
RES=0
!
OUT:
RESULT = RES
END ; ! LOGLINK
!
!-----------------------------------------------------------------------
!
ROUTINE RECORD LOST FILE(STRING (6) USER,STRING (11) FILE, C
BYTEINTEGER FSYS,CODES2,CODES)
OWNINTEGER N=0
INTEGER J,SEG,GAP,FAD,KB
INTEGER ALLOC, MODE, APF
RECORD (FHDRF)NAME FILEH
RECORD (LOSTF)NAME LARDEST
RECORD (LOSTF)ARRAYNAME LARY
RECORD (LOSTF)ARRAYFORMAT LARYF(0:TOPLOST)
LARY==ARRAY(LOSTARAD,LARYF)
IF LENGTH(USER)=6 START ; ! call with l(USER)=6 records entry in LARY
IF N>=TOPLOST START
DOPER2("Too many files lost!")
RETURN
FINISH
LARY(N)_DATE=DATE
LARY(N)_TIME=TIME
LARY(N)_USER=USER
LARY(N)_FILE=FILE
LARY(N)_CODES2=CODES2
LARY(N)_CODES=CODES
LARY(N)_CHERISHED=(CODES&CHERSH)>>4
N=N+1
RETURN
FINISH
! copy the contents of the array into file VOLUMS.LOSTFILES
RETURN IF N=0; ! No lost files
DOPER2("FSYS ".ITOS(FSYS).": ".ITOS(N)." files lost")
KB=4; ! Kbytes
ALLOC = X'00000011'; ! ZERO
MODE = WRSH
APF = 0
SEG = 0
GAP = 0
J = CREATE AND CONNECT("VOLUMS.LOSTFILES", FSYS, KB, C
ALLOC, MODE, APF, SEG, GAP)
DOPERR("CCK LOSTFILE", 1, J) AND RETURN UNLESS J = 0
FAD=SEG<<18
FILEH==RECORD(FAD)
J=FILEH_NEXTFREEBYTE-FILEH_TXTRELST
UNLESS FILEH_TXTRELST#0#FILEH_NEXTFREEBYTE AND C
J-(J//LOSTFLEN)*LOSTFLEN=0 START
FILEH=0
FILEH_TXTRELST=32
FILEH_NEXTFREEBYTE=32
FILEH_MAXBYTES=KB<<10
FINISH
J=0
WHILE J<N CYCLE
LARDEST==RECORD(FAD+FILEH_NEXTFREEBYTE)
LARDEST=LARY(J)
J=J+1
FILEH_NEXTFREEBYTE=FILEH_NEXTFREEBYTE+LOSTFLEN
IF FILEH_NEXTFREEBYTE>FILEH_MAXBYTES - LOSTFLEN C
THEN FILEH_NEXTFREEBYTE=32
REPEAT
N=0
!
J = DDISCONNECTI("VOLUMS.LOSTFILES",FSYS,0)
DOPERR("CCK LOSTFILE", 5, J) UNLESS J = 0
END ; ! RECORD LOST FILE
!
!-----------------------------------------------------------------------
!
integerfn DOINDEX2(integer ITYPE, INDAD, INDNO, FSYS, CROSSEDA,
COPYA, string (6)USER, integername CLOSE USERS FLAG)
!
! Parameters
! ITYPE = 0 process index
! 1 file index
!
! INDAD address of index
!
! FSYS
!
! CROSSEDA address of 'crossed pages' bitlist
!
! COPYA address of 'bit map copy'
!
! USER index owner
!
! Result flag
!
! 2**0 TEMP/VTEMP
! 1 PRIV VIOL/UNAVA
! 2 filename corrupt
! 3 PD list corrupt
! 4 SD list corrupt
! 5 PGS not consistent with SDs
! 6 bit map bits set twice
! 7 DA out of range
! 8 index corrupt
!
! Local procedures
!
CONSTSTRING (15)ARRAY MSG(0:8) = C
"temp",
"priv viol",
"fname bad",
"PD list bad",
"SD list bad",
"PGS bad",
"bits twice",
"DA bad",
"index bad"
!
ROUTINE WRITE FLAG(INTEGER FLAG)
INTEGER J
CYCLE J = 0, 1, 8
IF FLAG & 1 > 0 START
SPACE
PRINTSTRING(MSG(J))
FINISH
FLAG = FLAG >> 1
REPEAT
NEWLINE
END
!
routine SETB(byteintegername B, integer N)
B <- N unless B = N
end
!
!
!
routine SETI(integername I, integer N)
I = N unless I = N
end
!
!
!
!
!
!
integerfn SETBIT(integer ADR, N); ! used to set bits in SDBITS and PDBITS
integer X
*LDTB_8192
*LDA_ADR
*LB_N
*LSS_(dr +b )
*ST_X
*LSS_1
*ST_(dr +b )
result = X
end
!
!
!
integer J, B, LOBIT, HIBIT, USEDPGS, CHERPGS, CHERFILES, W, c
NPD, NSD, NFD, NF, FI, FLAG, CODES, CODES2, PAGS, TEMP, CHER, c
LINK, DA, LEN, IFLAG, MASK, SDX, PDX, L, NSECTS, c
SDBITSA, PDBITSA
!
record (FF)name F
record (HF)name H
RECORD (PARMF)NAME P
record (FDF)name FD
record (PDF)name PD
integername SD
record (PDF)arrayname PDS
record (FDF)arrayname FDS
integerarrayname SDS
byteintegerarray SDBITS(0:1023)
byteintegerarray PDBITS(0:31)
RECORD (DISCDATAF)DATA
!
string (11)NAME
STRING (255)TEXT
!
constinteger TOPSIZE = 19
constbyteintegerarray FSIZES(1:TOPSIZE) = 1, 3, 4, 7, 8, c
15, 16,23,24, 31, 32,39,40,47,48,55,56, 63, 64
constinteger PDSTART = 128
!
constinteger B0=1, B1=2, B2=4, B3=8, B4=16, B5=32, B6=64, B7=128, c
B8=256
!
CONSTSTRING (31)ARRAY CORRUPTION(1:9) = C
"Badname",
"H_MARK not 1",
"PDSTART overwritten",
"PD not< SD not< FD(START)",
"PD bytes not n * PDSIZE",
">255 PDs",
"SD bytes not n * SDSIZE",
">8191 SDs",
"FD bytes not n * FDSIZE"
!
!
FLAG = 1; ! various tests for 'index corrupt'. Flag is
! set to give specific reason then reset to B8
-> OUTA UNLESS UNOK(USER) = 0
-> DOFILEINDEX if ITYPE = 1
!
H == RECORD(INDAD)
FLAG = 2
-> OUTA unless H_MARK = 1
SETI(H_MSGSEMA, -1)
SETI(H_DIRMON, 0)
!
SETB(H_IUSE, 0)
SETB(H_BUSE, 0)
SETB(H_SB0, 0)
SETB(H_SB1, 0)
SETB(H_PASSFAILS, 0)
SETB(H_SIGMON, 0)
SETB(H_FSYS, FSYS)
SETB(H_DIRVSN, 255); ! check various fields
H_GPHOLDR = "" unless LENGTH(H_GPHOLDR) = 6
H_SURNAME = "Initials.Surname" unless 2<LENGTH(H_SURNAME)<32
H_DELIVERY = "Please set delivery" c
unless 2 < LENGTH(H_DELIVERY) < 32
! BASEFILE etc
! LOGFILE, MAIN, DATA
!
result = DOINDEX2(1,INDAD+512,INDNO,FSYS,CROSSEDA,COPYA,USER,
CLOSE USERS FLAG)
!
!
!
DO FILE INDEX:
J = FBASE2(FSYS, ADDR(DATA))
unless J = 0 START
TEXT = "FBASE gives " . ITOS(J)
-> OUT
FINISH
!
LOBIT = DATA_FILESTART
HIBIT = DATA_END
!
B = SYSAD(BITKEY, FSYS)
SDBITSA = ADDR(SDBITS(0))
PDBITSA = ADDR(PDBITS(0))
FILL(1024, SDBITSA, 0); ! to check for multiple use
FILL(32, PDBITSA, 0)
SDX = 0
PDX = 0
F == RECORD(INDAD)
!
LEN = F_SIZE
cycle J = 1, 1, TOPSIZE
-> FSIZEOK if LEN = FSIZES(J)
repeat
TEXT = "BAD Size " . ITOS(LEN)
-> OUT; ! bad size
FSIZEOK:
!now check essential structure
FLAG = 3
-> OUTA unless F_PDSTART = PDSTART
FLAG = 4
-> OUTA unless F_PDSTART < F_SDSTART < F_FDSTART
!
W = F_SDSTART - F_PDSTART
NPD = W // PDSIZE
FLAG = 5
-> OUTA unless W = NPD * PDSIZE
FLAG = 6
-> OUTA if NPD > 255
!
W = F_FDSTART - F_SDSTART
NSD = W >> 2
FLAG = 7
-> OUTA unless W & 3 = 0
FLAG = 8
-> OUTA if NSD > 8191
!
W = F_SIZE << 9 - F_FDSTART
NFD = W // FDSIZE
FLAG = 9
-> OUTA unless W = NFD * FDSIZE
!
PDS == ARRAY(INDAD+F_PDSTART, PDSF)
SDS == ARRAY(INDAD+F_SDSTART, SDSF)
FDS == ARRAY(INDAD+F_FDSTART, FDSF)
!
SETB(F_TEMPFILES, 0)
SETI(F_TEMPKB, 0)
SETI(F_SEMA, -1)
SETI(F_SEMANO, FSYS << 16 ! INDNO)
SETI(F_ASEMA, -1)
!
USED PGS = 0
CHER PGS = 0
CHER FILES = 0
!
SETB(F_FSYS, FSYS)
F_OWNER = USER unless F_OWNER = USER
! NAME
!
NF = 7; ! number of files surviving CCK
IFLAG = 0; ! file flags or'd together
!
cycle FI = 1, 1, NFD
FD == FDS(FI)
FLAG = 0
-> BAD FD if LENGTH(FD_NAME) > 11
NAME = FD_NAME
!
if NAME = ".NULL" START
-> NEXTF IF FI < LEAVE
-> CLEAR FD
FINISH
!
if NAME = "" START
-> CLEAR FD IF FI < LEAVE
-> NEXTF
FINISH
!
-> BAD FD unless S11OK(NAME) = 0
CODES = FD_CODES
CODES2 = FD_CODES2
PAGS = FD_PGS
TEMP = CODES & (TEMPFS ! VIOLAT)
CHER = CODES & CHERSH
!
SD == FD_SD; ! preliminary scan
L = 32
NSECTS = (PAGS + 31) >> 5; ! alleged
cycle
LINK = SD >> 19
DA = SD << 13 >> 13
L = (PAGS - 1)&31 + 1 if LINK = 0; ! last section
FLAG = FLAG ! B7 unless LOBIT <= DA <= HIBIT-L; ! DA out of range
NSECTS = NSECTS - 1
exit if NSECTS < 0
exit unless 0 < LINK <= NSD
SDX = SDX ! SETBIT(SDBITSA, LINK)
SD == SDS(LINK)
repeat
FLAG = FLAG ! B4 unless LINK = 0; ! bad link
FLAG = FLAG ! B5 unless NSECTS = 0; ! pags not consistent with number of sections
!
if FLAG = 0 and CODES & UNAVA = 0 start ; ! section list appears OK
! look for crossed pages
SD == FD_SD
L = 32
MASK = -1
cycle ; ! through sections
LINK = SD >> 19
DA = SD << 13 >> 13
if LINK = 0 start ; ! last section
L = (PAGS - 1)&31 + 1
MASK = ((-1) << (32-L)) >> (DA & 31)
finish
W = (DA>>3)&(¬3); ! word offset
if INTEGER(B+W) & MASK # 0 orc
INTEGER(CROSSEDA+W) & MASK # 0 c
start
INTEGER(CROSSEDA+W) = INTEGER(CROSSEDA+W) ! MASK
FLAG = FLAG ! B6; ! crossed pages
finish
INTEGER(B+W) = INTEGER(B+W) ! MASK
INTEGER(COPYA+W) = INTEGER(COPYA+W) ! MASK unless TEMP=NO
exit if LINK = 0
SD == SDS(LINK)
repeat
finish
!
LINK = FD_PHEAD; ! check file permissions
FD_PHEAD = 0 if LINK > NPD
J = 16; ! max number of permissions
while 0 < LINK <= NPD cycle
J = J - 1
exit if J < 0
PDX = PDX ! SETBIT(PDBITSA, LINK)
LINK = PDS(LINK)_LINK
repeat
FLAG = FLAG ! B3 unless LINK = 0 and J >= 0
!
FLAG = FLAG ! B1 unless CODES & (VIOLAT ! UNAVA) = 0
FLAG = FLAG ! B0 unless CODES & TEMPFS = 0
!
if FI < LEAVE OR FLAG > 0 or CODES2 & OLDGE > 0 start ; ! dispose of file
if FLAG & B3 = 0 start ; ! pd chain ok
LINK = FD_PHEAD
while LINK > 0 cycle
PD == PDS(LINK)
LINK = PD_LINK
PD = 0
repeat
finish
!
if FLAG & B4 = 0 start ; ! sd chain ok
LINK = FD_SD >> 19
while LINK > 0 cycle
SD == SDS(LINK)
LINK = SD >> 19
SD = 0
repeat
finish
-> CLEAR FD
finish
!
SETB(FD_USE, 0)
SETB(FD_CODES2, 0)
!
NF = NF + 1
IF FI > NF START
FDS(NF) = FD
FD = 0
FINISH
!
USED PGS = USED PGS + PAGS
unless CHER = NO start
CHER FILES = CHER FILES + 1
CHER PGS = CHER PGS + PAGS
finish
-> NEXTF
BADFD:
FLAG = FLAG ! B2
P == RECORD(ADDR(FD))
PREC("Bad FD: ", P, 0)
CLEAR FD:
FD = 0
FD_NAME = ".NULL" IF FI < 8
NEXTF:
unless FLAG = 0 start
PRINTSTRING("...".NAME)
SPACES(15 - LENGTH(NAME))
WRITEFLAG(FLAG)
RECORD LOST FILE(USER, NAME, FSYS, CODES2, CODES) ifc
FLAG & B0 = 0
IFLAG = IFLAG ! FLAG
finish
repeat ; ! through all files
!
LINK = F_FIPHEAD; ! scan file index permissions
F_FIPHEAD = 0 if LINK > NPD
J = 16
while 0 < LINK <= NPD cycle
J = J - 1
EXIT IF J < 0
PDX = PDX ! SETBIT(PDBITSA, LINK)
LINK = PDS(LINK)_LINK
repeat
IFLAG = IFLAG ! B3 unless LINK = 0 and PDX = 0 AND J >= 0
IFLAG = IFLAG ! B4 unless SDX = 0
!
SETI(F_FILES, NF - 7)
SETI(F_TOTKB, USED PGS << 2)
SETI(F_CHER FILES, CHERFILES)
SETI(F_CHER KB, CHER PGS << 2)
!
unless IFLAG & (B2!B3!B4!B5!B7) = 0 start ; ! bad filename, pd or sd
-> DONT REMOVE IF USER = "MANAGR"
CYCLE J = 1, 1, NEXECPROCS
-> DONT REMOVE IF USER = EXECPROCS(J)
REPEAT
IFLAG = IFLAG & (¬(B2!B3!B4!B5!B7)); ! remove b2,b3,b4,b5 and b7
finish
DONT REMOVE:
result = IFLAG & B6 if IFLAG & (¬(B0!B1!B6)) = 0; ! anything apart from temp/viol/bits twice files
!
TEXT = ""
FLAG = IFLAG
CYCLE J = 0, 1, 7
TEXT = TEXT . " " . MSG(J) IF FLAG & 1 > 0
FLAG = FLAG >> 1
REPEAT
!
DOPER2(USER." corrupt fsys".ITOS(FSYS) . TEXT)
CLOSE USERS FLAG = 1
RESULT = IFLAG
OUTA:
TEXT = CORRUPTION(FLAG)
OUT:
DOPER2(USER." corrupt fsys".ITOS(FSYS) . " " . TEXT)
RESULT = B8; ! index corrupt flag
end ; ! DO INDEX2
!
!-----------------------------------------------------------------------
!
EXTERNALINTEGERFN DDUMPINDNO(INTEGER FSYS,INDNO)
INTEGER J,INDAD,TOP
RECORD (HF)NAME H
RECORD (FF)NAME F
J=NINDA(FSYS,INDNO,INDAD)
-> OUT UNLESS J = 0
!
H == RECORD(INDAD)
J = 99
-> OUT IF H_MARK = 0
!
F == RECORD(INDAD + 512)
TOP = F_SIZE << 9 + 512
!
TOP=X'1000' UNLESS TOP=X'800' ORC
(X'1000'<=TOP<=X'8000' AND TOP<<21=0)
DDUMP(INDAD,INDAD+TOP,-1,-1)
J = 0
OUT:
RESULT =J
END ; ! DDUMPINDNO
!
!-----------------------------------------------------------------------
!
EXTERNALROUTINE ADJUST DLVN BIT(INTEGER FSYS, SET)
! SET = 0 to clear bit and make disc available, else 1
INTEGER J
BYTEINTEGERARRAYNAME DLVNA
INTEGERARRAYFORMAT DITF(0:COM_NDISCS-1)
INTEGERARRAYNAME DIT
RECORD (DDTF)NAME DDT
RETURN UNLESS 0 <= FSYS <= 99
!
DLVNA == ARRAY(COM_DLVNADDR, DLVNAF)
DIT == ARRAY(COM_DITADDR, DITF)
J = DLVNA(FSYS)
RETURN IF J > 250
DDT == RECORD(DIT(J))
!
IF SET = 0 START
DDT_DLVN = DDT_DLVN & 255
EMPTY DVM
DDT_CONCOUNT = 0
FINISH ELSE START
DDT_DLVN = DDT_DLVN ! (1 << 31)
FINISH
END ; ! ADJUST DLVN BIT
!
!-----------------------------------------------------------------------
!
ROUTINE CHECK BADS(INTEGER FSYS)
INTEGER P, J, K, BITMAP SIZE
RECORD (DISCDATAF)DATA
J = FBASE2(FSYS, ADDR(DATA))
BITMAPSIZE = DATA_BITSIZE
!
P = SYSAD(BADKEY, FSYS)
J = 0
CYCLE K = 0, 4, BITMAP SIZE - 4
EXIT IF J > 256
J = J + DBITS(INTEGER(P + K))
REPEAT
FILL(BITMAP SIZE, P, 0) IF J > 256
END ; ! OF CHECK BADS
!
!-----------------------------------------------------------------------
!
EXTERNALROUTINE CLEAR FSYS(INTEGER FSYS)
INTEGER P, J, K, INDAD, B
RECORD (DISCDATAF)DATA
ADJUST DLVN BIT(FSYS, 0)
J = FBASE2(FSYS, ADDR(DATA))
! IF THIS IS A NEW DISC AND OPS
! HAVE OMITTED TO DO A
! 'CLEAR BAD PAGES'
! WE DO ONE IF THERE ARE > 256
CHECK BADS(FSYS)
!
CYCLE P = DATA_INDEXSTART, 1, DATA_FILESTART-1
J = MOVESECTION(-1, 0, FSYS, DATA_START+P, 1); ! sets badpage bit if transfer fails
!
IF J = 0 START
CYCLE K = 0, 1, 3
J = NINDA(FSYS, P<<2+K, INDAD)
WRSN("Clear fsys/NINDA", J) AND RETURN UNLESS J = 0
STRING(INDAD) = "NEVER"; ! MARK EACH 'K' OF PAGE 'NEVER'
REPEAT
FINISH
!
REPEAT
!
B = SYSAD(BITKEY, FSYS)
MOVE(DATA_BITSIZE, SYSAD(BADKEY,FSYS), B); ! init bitmap with badpages
INTEGER(B) = -1
INTEGER(B+8) = FSYS
!
FILL(DATA_NNTSIZE, SYSAD(NNTKEY,FSYS), 0); ! clear NNT
!
DOPER2("FSYS ".ITOS(FSYS)." cleared OK")
END ; ! CLEAR FSYS
!
!-----------------------------------------------------------------------
!
INTEGERFN HOW FULL(INTEGER FSYS)
INTEGER I, N, B, PC, LO, HI
RECORD (DISCDATAF)DATA
I = FBASE2(FSYS, ADDR(DATA))
RESULT = -1 UNLESS I = 0
!
B = SYSAD(BITKEY, FSYS)
LO = (B+(DATA_START + DATA_FILESTART) >> 3) & (-4)
HI = (B+DATA_END >> 3) & (-4)
N = 0
!
CYCLE I = LO, 4, HI-4
N = N + DBITS(INTEGER(I))
REPEAT
!
RESULT = (100*N) // ((HI-LO) << 3)
END ; ! HOW FULL
!
!-----------------------------------------------------------------------
!
ROUTINE NEQS(INTEGER LENGTH, FROM, TO)
*LB_LENGTH
*JAF_13,<L99>; ! J IF NOT > ZERO
*LDTB_X'18000000'
*LDB_B
*LDA_FROM
*CYD_0
*LDA_TO
*NEQS_L =DR
L99:
END ; ! OF NEQS
!
!-----------------------------------------------------------------------
!
ROUTINE ADVISE EXECUTIVES(INTEGER FSYS)
INTEGER I,J
RECORD (PARMF)P
P=0
CYCLE I=1,1,NEXECPROCS
P_DEST=X'FFFF0000' ! X'15'; ! CCK DONE DACT
P_P1=FSYS
J=DPON3I(EXECPROCS(I),P,0,SYNC1 TYPE,PON AND CONTINUE)
REPEAT
END ; ! ADVISE EXECUTIVES
!
!-----------------------------------------------------------------------
!
EXTERNALINTEGERFN CCK(INTEGER FSYS, CHECK, INTEGERNAME PERCENT)
! CHECK = 0 ordinary CCK
! not 0 do CCK but dont make disc available or tell executives
INTEGER X, K, NNTTOP, PAGE, CLOSE USERS FLAG
INTEGER PT, STOP, NNTA
INTEGER B, J, L, INDNO, HI, ADD, DONE, PASS
INTEGER BIT MAP COPY A
INTEGER GOOD, CH, INDAD, FLAG, TYPE
STRING (6)OWNER
STRING (12)NAME
STRING (18)INDEX
STRING (31)S
RECORD (NNF)NAME NN
RECORD (NNF)ARRAYFORMAT NNTF(0 : 16384)
RECORD (NNF)ARRAYNAME NNT
RECORD (HF)NAME H
RECORD (FF)NAME F
BYTEINTEGERARRAY BITMAPCOPY(0:X'4FFF')
BYTEINTEGERARRAY CROSSEDPAGES(0:X'4FFF')
RECORD (LOSTF)ARRAY LOSTARRAY(0:TOPLOST)
BYTEINTEGERARRAY NNC(0:1364); ! for a 4-page NNT
RECORD (DISCDATAF)DATA
!
!
ROUTINE OPMESS(STRING (255)S)
INTEGER OCP
*LSS_(3)
*USH_-26
*AND_3
*ST_OCP
!
DOPER2("OCP".ITOS(OCP)." ".S)
END
!
WRS3N("CCK ", VSN, "FSYS", FSYS)
PERCENT = -1; ! just in case of failure
CLOSE USERS FLAG = 0; ! initialise
!
RESULT = 23 UNLESS FBASE2(FSYS, ADDR(DATA)) = 0; ! not on-line
RESULT = 69 UNLESS AV(FSYS, 0) = 0; ! CCK already done
!
LOSTARAD=ADDR(LOSTARRAY(0))
!
LOG ACTION = LOG ACTION & (¬DT); ! knock out date
!
X = 40; ! 'free' bytes at start of bitmap
X = 288 IF FSYS = COM_SUPLVN
!
NNTA = SYSAD(NNTKEY, FSYS)
NNTTOP = DATA_NNTTOP
!
NNT == ARRAY(NNTA, NNTF)
!
CYCLE PT = 0, 1, NNTTOP; ! set marker bits for in-use entries
IF LENGTH(NNT(PT)_NAME) = 6 C
THEN NNC(PT) = 1 C
ELSE NNC(PT) = 0
REPEAT
!
FILL(DATA_BITSIZE, ADDR(CROSSEDPAGES(0)), 0)
B = SYSAD(BITKEY,FSYS)
PASS = 0
PASS2:
DONE = 0
PAGE = 0; ! last page checked by BADPAGE
BIT MAP COPY A = ADDR(BITMAPCOPY(0))
FILL(DATA_BITSIZE, BIT MAP COPY A, 0); ! CLEAR BIT MAP COPY
CHECK BADS(FSYS)
MOVE(DATA_BITSIZE-X, SYSAD(BADKEY,FSYS)+X, B+X); ! INIT BIT MAP WITH BAD PAGES ONLY
! but do not clear the 'DIRCOM' area, it may hold filenames
INTEGER(B) = -1; ! BIT MAP SEMAPHORE
INTEGER(B+8) = FSYS
J = PACKDT
INTEGER(B+16) = J << 15 >> 15; ! Time
INTEGER(B+20) = J >> 17; ! Date
!
INDNO = DATA_INDEX START << 2
HI = DATA_FILE START << 2 - 1
WHILE INDNO<=HI CYCLE
!
ADD = X'800'; ! just examine even numbered K's
J = INDNO >> 2
UNLESS PAGE = J START
PAGE = J
IF BAD PAGE(3, FSYS, DATA_START+J) = YES START
WRSN("BAD PAGE AT", J)
INDNO = (J<<2) + 2; ! SO THAT WE GO TO NEXT PAGE !!!!
-> NEXTI
FINISH
FINISH
!
!
J = SYSAD(NNTKEY, FSYS)
UNLESS J = NNTA START
OPMESS("NNT Remapped on fsys".itos(fsys))
NNTA = J
NNT == ARRAY(NNTA, NNTF)
B = SYSAD(BITKEY, FSYS)
FINISH
!
J=NINDA(FSYS,INDNO,INDAD)
OPMESS("CCK/NINDA".ITOS(J)) UNLESS J = 0
!
L = BYTEINTEGER(INDAD); ! length of name of main or empty index
! top byte of 'sdstart' of file index
IF L > 6 START ; ! reject outright
S = "1st byte > 6"
-> BAD INDEX
FINISH
!
H == RECORD(INDAD); ! now decide if EMPTY, MAIN or FILE index
OWNER = H_OWNER
IF OWNER = "NEVER" START
WRSN("CCK exits on NEVER at", INDNO)
EXIT
FINISH
-> NEXTI IF OWNER = "EMPTY"
!
IF L = 6 START ; ! looks like a main index
TYPE = 0
NAME = ""
ADD = H_TOP
-> CHECK
FINISH
!
-> BAD INDEX; ! no file indexes for now
F == RECORD(INDAD); ! see if FILE index
UNLESS LENGTH(F_OWNER) = 6 START
S = "L(F_OWNER) not 6"
-> BAD INDEX
FINISH
!
UNLESS 0 < LENGTH(F_NAME) < 12 START
S = "L(F_NAME) not 1-11"
-> BAD INDEX
FINISH
!
TYPE = 1
OWNER = F_OWNER
NAME = F_NAME
ADD = F_SIZE << 9
!
IF NAME = "#ARCH" START
S = NAME
-> BAD INDEX
FINISH
CHECK:
GOOD = 0
!
CYCLE J = 1, 1, 6; ! check owner
CH = CHARNO(OWNER, J)
GOOD = 1 UNLESS 'A'<=CH<='Z' OR '0'<=CH<='9'
REPEAT
!
GOOD = 2 UNLESS ADD=X'800' OR (X'1000'<=ADD<=X'8000' ANDC
(ADD & X'FFF' = 0))
! report
WRSNT(OWNER, INDNO, X'36'); ! index no 3 hex digits
IF GOOD = 2 C
THEN WRSNT(" Bad size", ADD, 4) C {dec if small else hex}
ELSE WRSNT("", ADD>>10, X'25') {2 dec digits}
PRINTSTRING("K")
!
PRINTSTRING(" file index: " . NAME) IF TYPE = 1
!
UNLESS GOOD = 0 START
-> bad index
WRS(" BAD index")
ADD = X'800'
-> NEXTI
FINISH
NEWLINE
!
!
! Now check that there is an NNT entry for this owner. If name is not null,
! it signifies a file index for owner. If the entry is found, the
! corresponding entry in the NNT copy is deleted. If the NNT entry is
! found, but it points to a different index (only applicable to main
! indexes) 'duplicate index' is reported. If no NNT entry is found, an attempt
! is made to create one. If this fails, 'NNT full' is reported.
!
K = -1; ! remember first free entry, in case reqd
PT = HASH(OWNER, DATA_NNTHASH)
STOP = PT
UNTIL PT = STOP CYCLE
NN == NNT(PT)
IF OWNER = NN_NAME START ; ! possible
IF NAME = "" START ; ! looking for a main index
IF NN_TAG = 0 START ; ! it is an entry for a main index
IF INDNO = NN_INDNO C {correct INDNO}
THEN NNC(PT) = 0 AND -> DOINDEX C
ELSE START ; ! already present with different index
DOPER2(OWNER . " Duplicate") IF PASS = 0
-> DOINDEX
FINISH
FINISH
FINISH ELSE START
IF NN_TAG > 0 START ; ! this NNT entry is for a file index
IF INDNO = NN_INDNO C
THEN NNC(PT) = 0 AND -> DO INDEX
FINISH
FINISH
FINISH ELSE START
K = PT IF K < 0 AND LENGTH(NN_NAME) < 6; ! first free
FINISH
IF PT = NNTTOP THEN PT = 0 ELSE PT = PT + 1
REPEAT
!
! appropriate entry not found, so make one
INDEX = OWNER
INDEX = OWNER . ISEP . NAME UNLESS NAME = ""
!
DOPER2("New Index ".INDEX." on Fsys" . ITOS(FSYS))
!
IF K < 0 THEN DOPER2("NNT FULL") ELSE START
NN == NNT(K)
NN = 0
NN_NAME = OWNER
NN_KB = ADD >> 10
NN_INDNO = INDNO
NN_TAG = 1 UNLESS NAME = ""
FINISH
DOINDEX:
FLAG = DOINDEX2(TYPE, INDAD, INDNO, FSYS, ADDR(CROSSEDPAGES(0)),
BITMAPCOPYA, OWNER, CLOSE USERS FLAG)
!
DONE=DONE ! FLAG
-> NEXTI
BAD INDEX:
opmess("BAD INDEX at " . HTOS(INDNO, 3) . " Fsys" . ITOS(FSYS) . " " . S)
CLOSE USERS FLAG = 120
-> OUT
NEXTI:
ADD=ADD>>10
INDNO=INDNO + ADD
REPEAT
!
IF DONE&(1<<6)#0 AND PASS=0 START ; ! Crossed pages
PASS=1
DOPER2("FSYS ".ITOS(FSYS)." PASS2")
-> PASS2
FINISH
!
DONE = DONE & (¬(1<<6)); ! remove 'bits twice' bit
!
LOG ACTION = LOG ACTION ! DT; ! put date back in
NEQS(DATA_BITSIZE-X, BITMAPCOPY A+X, B+X); ! clear tempfile bits in bitmap
! avoiding 'free' bytes at front
!
PERCENT = HOW FULL(FSYS)
!
CYCLE PT = 0, 1, NNTTOP
IF NNC(PT) = 1 START
NN == NNT(PT)
CLOSE USERS FLAG = 1
DOPER2(NN_NAME . " MISSED, FSYS" . ITOS(FSYS))
DOPER2("(file index)") IF NN_TAG > 0
FINISH
REPEAT
OUT:
ADJUST DLVN BIT(FSYS, 0)
!
! Place records of files lost in file VOLUMS.LOSTFILES
RECORD LOST FILE("","",FSYS,0,0)
!
FLAG = DONE ! CLOSE USERS FLAG
!
IF CHECK = 0 START
IF FLAG = 0 ORC {it worked}
FSYS = COM_SUPLVN ORC {didn't work, but is IPL disc}
COM_IPLDEV >= 0 C {... but not in 'auto' mode}
THEN ADVISE EXECUTIVES(FSYS)
FINISH ELSE ADJUST DLVN BIT(FSYS, 1)
!
RESULT = FLAG
END ; ! CCK
!
!-----------------------------------------------------------------------
!
ROUTINE SORT STRINGS(STRINGARRAYNAME U, INTEGER N)
INTEGER I, J, K, M
STRING (255)W
RETURN IF N < 1
!
M = 1
M = M << 1 WHILE M <= N
M = M - 1
!
CYCLE
M = M >> 1
EXIT IF M = 0
CYCLE I = 1, 1, N-M
K = I
WHILE K > 0 CYCLE
J = K + M
!
EXIT IF U(K) <= U(J)
W = U(J)
U(J) = U(K)
U(K) = W
!
K = K - M
REPEAT
REPEAT
REPEAT
END ; ! SORT STRINGS
!
!-----------------------------------------------------------------------
!
INCLUDE "PD22S_A03TEST"
EXTERNALROUTINE SET STOP
INTEGER J
IF PROCUSER = "DIRECT" C
THEN J = PRIME CONTINGENCY(PROCESS1) C
ELSE J = PRIME CONTINGENCY(STOP ONE)
END ; ! SET STOP
!
!-----------------------------------------------------------------------
!
EXTERNALROUTINE DERR2(STRING (31)S,INTEGER FN,ERR)
STRING (15) LOC
CONSTINTEGER TOP = 8
CONSTSTRING (15)ARRAY NAME(1:TOP) = C
" 1 DCREATE",
" 2 DCONNECT",
" 3 DPERMISSION",
" 4 DSFI",
" 5 DDISCONNECT",
" 6 DSTOP",
" 7 DGETDA",
" 8 STARTP"
LOC = NAME(FN)
PRINTSTRING(S)
IF 1 <= FN <= TOP C
THEN PRINTSTRING(FROMSTRING(LOC, 3, LENGTH(LOC))) C
ELSE WRITE(FN, 6)
SPACE
WRS(DERRS(ERR))
END ; ! DERR2
!
!-----------------------------------------------------------------------
!
externalroutine NCODE(integer PC)
!
!
conststring (4) array OPS(0 : 127) = c
" ","JCC ","JAT ","JAF ","TEST"," ","CLR*","SET*",
"VAL ","CYD ","INCA","MODD","PRCL","J ","JLK ","CALL",
"ADB ","SBB ","DEBJ","CPB ","SIG ","MYB ","VMY ","CPIB",
"LCT ","MPSR","CPSR","STCT","EXIT","ESEX","OUT ","ACT ",
"SL ","SLSS","SLSD","SLSQ","ST ","STUH","STXN","IDLE",
"SLD ","SLB ","TDEC","INCT","STD ","STB ","STLN","STSF",
"L ","LSS ","LSD ","LSQ ","RRTC","LUH ","RALN","ASF ",
"LDRL","LDA ","LDTB","LDB ","LD ","LB ","LLN ","LXN ",
"TCH ","ANDS","ORS ","NEQS","EXPA","AND ","OR ","NEQ ",
"PK ","INS ","SUPK"," ","COMA","DDV ","DRDV","DMDV",
"SWEQ","SWNE","CPS ","TTR ","FLT ","IDV ","IRDV","IMDV",
"MVL ","MV ","CHOV"," ","FIX ","RDV ","RRDV","RDVD",
"UAD ","USB ","URSB","UCP ","USH ","ROT ","SHS ","SHZ ",
"DAD ","DSB ","DRSB","DCP ","DSH ","DMY ","DMYD","CBIN",
"IAD ","ISB ","IRSB","ICP ","ISH ","IMY ","IMYD","CDEC",
"RAD ","RSB ","RRSB","RCP ","RSC ","RMY ","RMYD"," "
!
!
ROUTINE MASK(INTEGER N)
! prints bottom 4 bits in binary
INTEGER J
PRINTSTRING(" MASK=B'")
CYCLE J = 3, -1, 0
PRINTSYMBOL('0' + ((N >> J) & 1))
REPEAT
END
!
!
routine PHX(integer N, PLACES, SIGN)
PRINTSYMBOL(SIGN)
!
N = N & X'7F' IF PLACES = 2
N = N & X'3FFFF' IF PLACES = 5
!
if 0<=N<=9 C
then PRINTSTRING(ITOS(N)) C
else PRINTSTRING("X'" . HTOS(N, PLACES) . "'")
end ; ! PHX
!
!
!
integer I, K, KP, KPP, N, N1, OPCODE
integer INSL, DEC,LITERAL,JUMP,N7,N18
integer H, Q, INS, KPPP
integer START, FINISH
integer SIGN,ILLEGAL
integer ALL
STRING (7)W
SWITCH DECSW(1:3)
!
!
!
conststring (12) array PREFPOP(0 : 31) = c
"","*** ","(LNB","(XNB",
"(PC","(CTB","TOS ","B ",
"(DR","*** ","(DR+(LNB","(DR+(XNB",
"(DR+(PC","(DR+(CTB","(DR+TOS) ","(B",
"IS LOC N ","*** ","((LNB","((XNB",
"((PC","((CTB","(TOS) ","(DR) ",
"IS LOC B ","*** ","((LNB","((XNB",
"((PC","((CTB","(TOS+B) ","(DR+B) "
conststring (8) array SUFPOP(0:31) = c
"","",") ",") ",
") ",") ","","",
") ","",")) ",")) ",
")) ",")) ","",")* ",
"","",")) ",")) ",
")) ",")) ","","",
"","",")+B) ",")+B) ",
")+B) ",")+B) ","",""
conststring (8) array TOP(0 : 7) = c
"","(DR+","(LNB+","(XNB+","(PC+","(CTB+","(DR) ","(DR+B) "
conststring (7) array JAS(0:15)= c
"FACC=0","FACC>0","FACC<0"," ? ","ACC=0","ACC>0","ACC<0",
" ? ","DACC=0","DACC>0","DACC<0","DRLEN=0",
" B=0 "," B>0 "," B<0 ","OV SET"
!
!
!
!
START = PC - 128
FINISH = PC + 128
!
START = FINISH >> 18 << 18 unless START>>18 = FINISH>>18
ALL = FINISH-START
PRINTSTRING("Code around")
PHX(PC, 5, ' ')
NEWLINE
PC = 0
I = X'18000000'!ALL
*LDTB_I
*LDA_START
*VAL_(lnb +1)
*JCC_3,<BADADDR>
!!
while PC < ALL cycle
H = 0
LITERAL=0
JUMP=0
INSL = 32
MOVE(4,START+PC,ADDR(INS))
N1 = INS & X'3FFFF'
N = INS << 9 >> 25
KP = N >> 5
KPP = INS << 11 >> 29
KPPP = KPP
!
OPCODE = INS>>25<<1
if OPCODE = 0 or OPCODE = 254 or 8 <= OPCODE <= 14 start
INSL = 16
ILLEGAL = 1
DEC = 0
finish else start
ILLEGAL = 0
IF 2 <= OPCODE < 8 START
DEC = 3; ! tertiary
N = N1
IF KPPP > 5 START
INSL = 16
ILLEGAL = 1 UNLESS (INS >> 16) & 3 = 0
FINISH
FINISH ELSE START
IF 8 <= OPCODE >> 4 <= X'B' AND OPCODE & 15 < 8 START
DEC = 2; ! secondary
H = INS << 7 >> 31
Q = INS << 8 >> 31
INSL = 16 UNLESS Q = 1
FINISH ELSE START
DEC = 1; ! primary
K = INS << 7 >> 30
IF K = 3 START
LITERAL = 1 IF KP = 0 = KPP
IF KPP < 6 C
THEN N = N1 C
ELSE START
INSL = 16
ILLEGAL = 1 UNLESS INS & X'30000' = 0
FINISH
FINISH ELSE START
LITERAL = 1 IF K = 0
INSL = 16
FINISH
FINISH
FINISH
FINISH
JUMP=1 if X'1A'<=OPCODE<=X'1E' or OPCODE=X'24'
!
WRSNT("", (START+PC) & X'3FFFF', X'56'); ! address
if INSL = 16 c
then SPACES(6) and PRINTSTRING(HTOS(INS >> 16, 4)) c
else SPACES(2) and PRINTSTRING(HTOS(INS, 8)); ! instruction in hex
!
W = OPS(OPCODE >> 1)
->END if ILLEGAL=1 or W=" " or INS=X'81818181'
SPACES(2)
PRINTSTRING(W); ! opcode
SPACE
!
SIGN = '+'
N7 = -(N ! X'FFFFFF80')
N18 = -(N ! X'FFFC0000')
-> DECSW(DEC)
!
DECSW(1): ! PRIMARY FORMAT
-> END if OPCODE=X'3A' or OPCODE=X'4E' or OPCODE=X'12' orc
OPCODE=X'EE' or OPCODE=X'DE'
SPACE IF LITERAL = 0
if K < 3 start
PRINTSYMBOL('(') IF K = 2
PRINTSTRING("(LNB") IF K > 0
SIGN = '-' AND N = N7 IF N>>6 # 0 = K
PHX(N, 2, SIGN) UNLESS JUMP = 1 = LITERAL
PRINTSYMBOL(')') IF K = 2
PRINTSTRING(") ") IF K > 0
FINISH ELSE START
PRINTSTRING(PREFPOP(KP*8+KPP))
if INSL = 32 start
if (KP = 0 = KPP) or KPP = 4 start
N = N18 and SIGN = '-' if (N>>17) > 0
PRINTSYMBOL(SIGN) if KPP = 4
finish else PRINTSYMBOL(SIGN)
PHX(N, 5, ' ') unless LITERAL # 0 # JUMP
PRINTSTRING(SUFPOP(KP*8+KPP))
finish
N = -N if SIGN = '-'
WRSNT("ie ", (PC+START+(N*2)),X'56') if KP=0 and KPP=4
finish
if LITERAL # 0 = JUMP and IMOD(N)>9 start
PRINTSYMBOL('[')
PRINTSYMBOL('-') if SIGN = '-'
PRINTSTRING(ITOS(N)."]")
finish
if LITERAL # 0 # JUMP start
PRINTSTRING(" TO")
N = -N if SIGN = '-'
PHX((PC+START+(N*2)), 5, ' ')
finish
-> END
DECSW(2): ! SECONDARY FORMAT
PHX((INS>>16),2,0) if H=0
if INSL = 32 start
MASK(INS >> 8)
PRINTSTRING(" LITERAL")
PHX(INS, 2, '=')
finish
-> END
DECSW(3): ! TERTIARY FORMAT
PRINTSTRING(TOP(KPPP))
if INSL = 32 start
SIGN = ' '
if KPPP = 0 or KPPP = 4 start
if (N>>16) > 1 c
then N = N18 and SIGN = '-'
finish
if KPPP = 0 start
N = -N if SIGN = '-'
PRINTSTRING(" TO")
PHX((PC+START+(N*2)), 5, ' ')
finish else PHX(N, 5, SIGN)
PRINTSYMBOL(')') if 1 <= KPPP <= 5
if 4<=OPCODE<=6 c
then PRINTSTRING(" ON ".JAS((INS>>21)&15)) c
else MASK(INS >> 21)
finish
END:
NEWLINE
PC = PC+(INSL>>3)
repeat
RETURN
!
!
!
BADADDR:
WRSNT("NCODE: validation fails ", START, 6)
WRSNT(" : ", FINISH, 2)
end ; ! NCODE
!
!-----------------------------------------------------------------------
!
SYSTEMROUTINE NDIAG(INTEGER PC, OLD, FAULT, I)
INTEGER NEW, GLA, LANG, T, N
STRING (255)S
L1:
NEW = INTEGER(OLD)
GLA = INTEGER(OLD + 16)
*LDTB_X'18000020'
*LDA_GLA
*VAL_(LNB + 1)
*JCC_3,<L3>
!
LANG = BYTEINTEGER(GLA + 16)
RETURN IF LANG > 5 OR LANG = 4 OR LANG = 0
-> L2 UNLESS LANG & 1 > 0; ! IMP
T = INTEGER(OLD + 12) & X'FFFFFF'
CYCLE
RETURN IF T = 0
T = T + INTEGER(GLA + 12)
EXIT UNLESS INTEGER(T + 12) = 0
T = INTEGER(T + 4) & X'FFFF'
REPEAT
S = STRING(T + 12) . " " . ITOS(INTEGER(T) >> 16)
IF PROCUSER = "DIRECT" C
THEN DOPER2(S) C
ELSE WRS(S)
L2:
N = OLD + 20
N = (N + 267) & (-32) IF PC >> 18 = 2
DDUMP(OLD, N, -1, -1)
L3:
RETURN IF NEW = OLD
PC = INTEGER(OLD + 8)
OLD = NEW
-> L1 UNLESS NEW < COM36
END ; ! NDIAG
!
!-----------------------------------------------------------------------
!
! LAYOUT OF DIAGNOSIC TABLES
!+**********************
! THE BOUND FIELD OF PLT DESCRIPTOR STORED AT (LNB+3 & LNB+4) IF
! USED TO CONTAIN A DISPLACEMENT RELATIVE TO THE START OF SST OF THE
! DIAGNOSTIC TABLES FOR THE BLOCK OR ROUTINE BEING EXECUTED.
! A ZERO BOUND MEANS NO DIAGNOSTIC REQUESTED.(NB THIS MAY MEAN A DUMMY
! FIRST WORD IN THE SST).
! THE ABSOLUTE ADDRESS OF THE SST FOR THE CURRENT CODE SEGMENT WILL
! ALWAYS BE FOUND IN THE STANDARD 10 WORDS OF THE GLA/PLT
! FORM OF THE TABLES:-
! WORD 0 = LINE OF RT IN SOURCE PROG <<16 ! LINE NO POSN(FROM LNB)
! WORD 1 = (12 LANG DEPENDENT BITS)<<20 ! ENVIRONMENT
! WORD 2 = DISPLAY POSN (FROM LNB)<<16 ! RT TYPE INFO
! WORD 3 = ZERO FOR BLKS OR STRING(<=11BYTES) BEING THE
! RT NAME. THIS WILL TAKE WORDS 4 AND 5 IF NEEDED
! WORD 6 = LANGUAGE DEPENDENT INFO . IMP ON CONDITIONS ETC
! THE REST IS MADE UP OF VARIABLE ENTRIES AND THE SECTION IS TERMINATED BY
! A WORD OF X'FFFFFFFF'
! EACH VARIABLE ENTRY CONSISTS OF THE VARIABLE WORD FOLLOWED BY
! THE VARIABLE NAME AS A STRING. THE WORD CONSISTS OF
! BITS 2**31 TO 2**20 TYPE INFORMATION (MAY BE LANGUAGE DEPENDENT
! BIT 2**19 =0 UNDER LNB =1 IN GLA
! BITS 2**18 TO 2**0 DISPLACEMENT FROM LNB(GLA) IN BYTES
! THE ENVIRONMENT IS A POINTER (RELATIVE TO SST) OF THE NEXT OUTERMOST
! BLOCK OR A POINTER TO GLOBAL OWNS, EXTERNAL OR COMMON AREAS
! A ZERO MEANS NO ENCLOSING BLOCK. WORD1=WORD3=0 IS AN
! IMP MAIN PROGRAM AND WILL TERMINATE THE DIAGNOSTICS.
STRINGFN JUST(STRING (255)S)
INTEGER A, J, K
J = 1
K = LENGTH(S)
J = J + 1 WHILE J < K AND CHARNO(S, J) = ' '
K = K - 1 WHILE J < K AND CHARNO(S, K) = ' '
J = J - 1
A = ADDR(S) + J
BYTEINTEGER(A) = K - J
RESULT = STRING(A)
END
!
!-----------------------------------------------------------------------
!
EXTERNALINTEGERFN DBITMAP2(INTEGERNAME LO, HI, INTEGER FSYS)
! IF LO < 0, L := ADDR(BAD PAGES LIST)
! ELSE LO := ADDR(FIRST WORD OF BITMAP)
! AND HI := ADDR(LAST)-4
INTEGER B
RECORD (DISCDATAF)DATA
RESULT = 23 IF AV(FSYS, 0) = 0; ! NOT AVAILABLE
!
IF LO < 0 C
THEN LO = SYSAD(BADKEY, FSYS) AND RESULT = 0
!
B = FBASE2(FSYS, ADDR(DATA))
B = SYSAD(BITKEY, FSYS)
LO = (B + (DATA_START + DATA_FILE START)>>3) & (-4)
HI = (B + DATA_END>>3) & (-4)
RESULT = 0
END ; ! DBITMAP2
!
!-----------------------------------------------------------------------
!
EXTERNALINTEGERFN DDELUSER(STRING (18)FILE INDEX, INTEGER FSYS)
INTEGER G0, FSYSW, K, NNAD
INTEGER JUNK, J,INDAD,CYCLE TO, I, N, MAX
STRING (31)UNA, INA, INDEX
RECORDFORMAT KYFF(STRING (11)NAME, INTEGER A,B,C,D,E)
RECORD (KYFF)ARRAY FILE(0:31)
RECORD (FF)NAME F
RECORD (HF)NAME H
RECORD (NNF)NAME NN
J = IN2(15)
-> OUT UNLESS J = 0
!
J = 93
-> OUT UNLESS DTRYING << 5 < 0
!
J = UIO(FILE INDEX, UNA, INA, INDEX)
-> OUT UNLESS J = 0
!
G0 = -1
AGAIN:
FSYSW = FSYS; ! FSYS specified may be specific or -1
J = FIND NNT ENTRY(INDEX, FSYSW, NNAD, 0)
G0 = J IF G0 = -1; ! remember first result
J = G0 AND -> OUT UNLESS J = 0
!
J = DPERMISSIONI(INDEX, PROCUSER, "", "", FSYSW, 7, 0); ! REMOVE
J = DPERMISSIONI(INDEX, PROCUSER, "", "", FSYSW, 6, 7); ! FULL INDEX PERM
-> XIND UNLESS J = 0
!
NAMES:
MAX = 32
J = DFILENAMES(INDEX, FILE, JUNK, MAX, N, FSYSW, 0)
-> XIND UNLESS J = 0
!
IF N > 0 = MAX START ; ! very curious, does it happen?
WRSN("Dfilenames N", N)
FINISH
!
I = 0
WHILE I < MAX CYCLE
K = DDESTROYF(INDEX . "." . FILE(I)_NAME, FSYSW, 1)
DOPERR("DDELUSER", 15, K) UNLESS K = 0
J = J ! K
I = I + 1
REPEAT
-> NAMES IF MAX > 0 AND J = 0
XIND:
J = FIND NNT ENTRY(INDEX, FSYSW, NNAD, 0)
-> OUT UNLESS J = 0
!
NN == RECORD(NNAD)
J = NINDA(FSYSW, NN_INDNO, INDAD)
-> OUT UNLESS J = 0
NN_NAME = ".NULL"
!
! Write "EMPTY" at the start of each 1K, but first make sure
! that the index we are deleting (in particular the index size field) is
! reasonable.
CYCLE TO=0
J = 87
IF INA = "" START ; ! main index
H == RECORD(INDAD)
-> OUT UNLESS UNA = H_OWNER
J = H_TOP >> 10
IF J = 2 OR (4 <= J <= 32 AND H_TOP & X'FFF' = 0) C
THEN CYCLE TO = H_TOP - X'400'
FINISH ELSE START ; ! file index
F == RECORD(INDAD)
-> OUT UNLESS UNA = F_OWNER
-> OUT UNLESS INA = F_NAME
CYCLE TO = (F_SIZE << 9) - X'400'
FINISH
!
CYCLE J=0,X'400',CYCLE TO
H==RECORD(INDAD+J)
H_OWNER="EMPTY"
REPEAT
-> AGAIN; ! round again in case there are more
OUT:
EMPTY DVM
RESULT = OUT(J, "SI")
END ; ! DDELUSER
!
!-----------------------------------------------------------------------
!
!<DEMPTYI
externalintegerfn DEMPTYI(integer FSYS, INDNO)
!
! This privileged procedure writes 'EMPTY' at the start of the 1K block
! INDNO on FSYS.
!>
INTEGER INDAD,J
RECORD (HF)NAME H
RECORD (DISCDATAF)DATA
J = IN2(21)
-> OUT UNLESS J = 0
!
J = 93
-> OUT UNLESS DTRYING << 5 < 0
!
J = 23
-> OUT IF AV(FSYS, 0)=0
!
J = FBASE2(FSYS, ADDR(DATA))
-> OUT UNLESS J = 0
!
J = 8
-> OUT UNLESS DATA_INDEX START <= INDNO >> 2 < DATA_FILE START
!
J=NINDA(FSYS,INDNO,INDAD)
-> OUT UNLESS J = 0
!
H==RECORD(INDAD)
H_OWNER="EMPTY"
OUT:
RESULT = OUT(J, "II")
END ; ! DEMPTYI
!
!-----------------------------------------------------------------------
!
!<DGETINDEXES
externalintegerfn DGETINDEXES(integername N, integer ADR, FSYS)
!
! This procedure supplies a sorted list of index names accredited on
! FSYS. The names are either listed (to DIRLOG) if ADR = -1 or written
! as a series of 18 byte strings to ADR onwards. N is set to the number
! of names returned. The array at ADR must be able to hold as many index
! names as there are on the disc. The current max is 1365,
! i.e. 19 * 1365 (=25935) bytes.
!>
INTEGER PT,NNA,J, LN, I, L, W, FINDAD
STRING (255) USER
STRING (18)ARRAY U(1:1365)
RECORD (NNF)ARRAYFORMAT NNTF(0:16384)
RECORD (NNF)ARRAYNAME NN
RECORD (FF)NAME F
RECORD (DISCDATAF)DATA
J = IN2(98)
-> OUT UNLESS J = 0
!
J = 23
-> OUT IF AV(FSYS, 0) = 0
!
J = FBASE2(FSYS, ADDR(DATA))
-> OUT UNLESS J = 0
!
NNA = SYSAD(NNTKEY, FSYS)
NN == ARRAY(NNA, NNTF)
LN = 0
!
CYCLE PT = 0, 1, DATA_NNTTOP
USER = NN(PT)_NAME
IF LENGTH(USER) = 6 START
IF NN(PT)_TAG > 0 START ; ! a file index
J = NINDA(FSYS, NN(PT)_INDNO, FINDAD)
IF J = 0 START
F == RECORD(FINDAD)
USER = USER . ISEP . F_NAME
FINISH
FINISH
LN = LN + 1
U(LN) = USER
FINISH
REPEAT
!
N = LN
IF LN = 0 START
WRSN("No indexes on FSYS", FSYS) IF ADR = -1
FINISH ELSE START
!
IF ADR # -1 START
J = 45
-> OUT IF VAL(ADR, 19 * LN, 1, D CALLERS PSR) = 0
-> OUT IF VAL(ADDR(N), 4, 1, D CALLERS PSR) = 0
FINISH
!
SORT STRINGS(U, LN)
IF ADR = -1 START
WRSN("Indexes on FSYS", FSYS)
PT = 0
CYCLE I = 1, 1, LN
L = LENGTH(U(I))
W = 1
IF L > 6 START
W = 2
W = 3 IF L > 13
FINISH
PT = 0 AND NEWLINE IF PT + W > 9
PRINTSTRING(U(I))
SPACES(6*W + 1 - L)
PT = PT + W
REPEAT
NEWLINE
FINISH ELSE START
MOVE(LN*19, ADDR(U(1)), ADR)
FINISH
FINISH
J = 0
OUT:
RESULT = OUT(J, "")
END ; ! DGETINDEXES
!
!-----------------------------------------------------------------------
!
!<DGETINDEXES2
externalintegerfn DGETINDEXES2(integername N, integer ADR, FSYS)
!
! This procedure supplies a list of the indexes accreditted on FSYS,
! sorted into INDEX NO order. A series of records of format
!
! (string(18)NAME, byteinteger KB, integer INDNO)
!
! is returned to ADR onwards, a maximum of 24 * 1365 bytes. N is set to
! the number of records supplied.
!>
INTEGER PT, NNA, J, I, K, MM, FINDAD, NUSERS
STRING (255)USER
RECORD (NNF)ARRAYFORMAT NNTF(0:16384)
RECORD (NNF)ARRAYNAME NN
RECORDFORMAT UF(STRING (18)NAME, BYTEINTEGER KB, INTEGER INDNO)
RECORD (UF)ARRAYNAME UNN
RECORD (UF)ARRAYFORMAT UNNF(0:1364)
RECORD (UF)NNW
RECORD (FF)NAME F
RECORD (DISCDATAF)DATA
J = IN2(99)
-> OUT UNLESS J = 0
!
J = 23
-> OUT IF AV(FSYS, 0) = 0
!
J = FBASE2(FSYS, ADDR(DATA))
-> OUT UNLESS J = 0
!
NNA = SYSAD(NNTKEY, FSYS)
NN == ARRAY(NNA, NNTF)
!
NUSERS = 0
CYCLE PT = 0, 1, DATA_NNTTOP
NUSERS = NUSERS + 1 IF LENGTH(NN(PT)_NAME) = 6
REPEAT
J = 45
-> OUT IF VAL(ADR, 24*NUSERS, 1, D CALLERS PSR) = 0
-> OUT IF VAL(ADDR(N), 4, 1, D CALLERS PSR) = 0
!
N = 0
UNN == ARRAY(ADR, UNNF)
CYCLE PT = 0, 1, DATA_NNTTOP
USER = NN(PT)_NAME
IF LENGTH(USER) = 6 START
UNN(N)_KB = NN(PT)_KB
UNN(N)_INDNO = NN(PT)_INDNO
IF NN(PT)_TAG > 0 START ; ! a file index
J = NINDA(FSYS, NN(PT)_INDNO, FINDAD)
IF J = 0 START
F == RECORD(FINDAD)
USER = USER . ISEP . F_NAME
FINISH
FINISH
UNN(N)_NAME = USER
N = N + 1
FINISH
REPEAT
!
IF N > 0 START
MM = 1
MM = MM << 1 WHILE MM <= N
MM = MM - 1
!
CYCLE
MM = MM >> 1
EXIT IF MM = 0
CYCLE I = 1, 1, N-MM
K = I
WHILE K > 0 CYCLE
J = K + MM
!
EXIT IF UNN(K-1)_INDNO <= UNN(J-1)_INDNO
NNW = UNN(J-1)
UNN(J-1) = UNN(K-1)
UNN(K-1) = NNW
!
K = K - MM
REPEAT
REPEAT
REPEAT
FINISH
J = 0
OUT:
RESULT = OUT(J, "")
END ; ! DGETINDEXES2
!
!-----------------------------------------------------------------------
!
!<DINDEX2
externalintegerfn DINDEX2(string (18)NAME, integer FSYS, ADR)
!
! This procedure returns the index NAME on fsys FSYS into ADR
! onwards, with sensitive fields blanked off.
!>
INTEGER J, TOP, INDAD, FINDAD, A
STRING (31)UNA, INA, INDEX
RECORD (FF)NAME F
RECORD (HF)NAME H, NH
CONSTSTRING (7)FN = "DINDEX "
J = IN2(32)
-> OUT UNLESS J = 0
!
J = 93
-> OUT UNLESS DTRYING << 5 < 0
!
J = UIO(NAME, UNA, INA, INDEX)
-> OUT UNLESS J = 0
!
IF INA = "" START
J = HINDA(UNA, FSYS, INDAD, 0)
-> OUT UNLESS J = 0
H == RECORD(INDAD)
A = INDAD
TOP = H_TOP
FINDAD = INDAD + 512
F == RECORD(FINDAD)
FINISH ELSE START
J = FINDA(INDEX, FSYS, FINDAD, 0)
-> OUT UNLESS J = 0
F == RECORD(FINDAD)
A = FINDAD
TOP = F_SIZE << 9
FINISH
!
J = 45
-> OUT UNLESS VAL(ADR, TOP, 1, DCALLERSPSR) = YES
!
J = PP(ADDR(F_SEMA), F_SEMANO, FN)
-> OUT UNLESS J = 0
!
MOVE(TOP, INDAD, ADR)
!
IF INA = "" START
NH == RECORD(ADR)
NH_DWSP = 0
NH_BWSP = 0
NH_TRYING = 0
FINISH
VV(ADDR(F_SEMA), F_SEMANO)
OUT:
RESULT = OUT(J, "SIX")
END ; ! DINDEX2
!
!-----------------------------------------------------------------------
!
!<DNEWUSER
externalintegerfn DNEWUSER(string (18)FILE INDEX, integer FSYS, NKB)
!
! This privileged procedure creates either a user record+main file index
! (if FILE INDEX is simply a username) or a file index (if FILE INDEX
! is supplied as username@fileindexname). The index is created on disc
! pack FSYS with NKB Kbytes. NKB must either be 2 or a multiple of 4
! between 4 and 32.
!>
INTEGER NNAD, INDNO, N, HI, PAGE, NPD, NFD
INTEGER INDAD, TESTAD, J, AMINUS1
STRING (18)UNA, INA, INDEX
RECORD (FF)NAME F
RECORD (HF)NAME H
RECORD (NNF)NAME NN
RECORD (DISCDATAF)DATA
J = IN2(50)
-> OUT UNLESS J = 0
!
J = 93
-> OUT UNLESS DTRYING << 5 < 0
!
J = UIO(FILE INDEX, UNA, INA, INDEX)
-> OUT UNLESS J = 0
!
J = 12
NPD = NKB >> 24
NFD = (NKB >> 8 ) & 2047
NKB = NKB & 255
! restrict to 2K or multiples of 4K
-> OUT UNLESS (4<=NKB<=32 AND NKB&3=0) OR NKB=2
!
J = NEW NNT ENTRY(INDEX, FSYS, NNAD)
-> OUT UNLESS J = 0
!
J = FBASE2(FSYS, ADDR(DATA))
-> OUT UNLESS J = 0
!
AMINUS1 = 3; ! indexes are aligned on page boundaries, except 2K ones
AMINUS1 = 1 IF NKB = 2
INDNO = DATA_INDEX START << 2
!
INDNO = INDNO + 8 IF DATA_END > X'10000'; ! space for 4 page NNT on 640
!
HI = DATA_FILE START << 2 - 1
PAGE = 0; ! last page to be checked by BADPAGE
!
WHILE INDNO < HI CYCLE
J = INDNO >> 2
UNLESS PAGE = J START
PAGE = J
UNLESS BADPAGE(3, FSYS, DATA_START+PAGE) = 0 START ; ! skip over bad page
INDNO = (PAGE+1) << 2
-> NO GO
FINISH
FINISH
!
J = NINDA(FSYS, INDNO, INDAD)
-> OUT UNLESS J = 0
!
H == RECORD(INDAD)
IF H_OWNER = "EMPTY" OR H_OWNER = "NEVER" START ; ! potential hole
J = (INDNO+AMINUS1) & (¬AMINUS1); ! align
J = (J+NKB)>>8<<8 IF (J+NKB-1)>>8 > (J>>8); ! crosses segment
!
IF J > INDNO START ; ! can't start here
H_OWNER = "EMPTY" IF H_OWNER = "NEVER"; ! mustn't leave any NEVER holes
INDNO = INDNO + 2
-> NOGO
FINISH
!
-> ENTER IF NKB = 2; ! no need to check further
!
CYCLE N = INDNO+2, 2, INDNO+NKB-2; ! check availability of rest
J = N >> 2
UNLESS PAGE = J START
PAGE = J
UNLESS BADPAGE(3, FSYS, DATA_START+PAGE) = 0 START
INDNO = (PAGE+1) << 2
-> NO GO
FINISH
FINISH
!
J = NINDA(FSYS, N, TESTAD)
-> OUT UNLESS J = 0
!
H == RECORD(TESTAD)
UNLESS H_OWNER = "EMPTY" OR H_OWNER = "NEVER" START ; ! won't do
INDNO = N
-> CHECK
FINISH
!
H_OWNER = "EMPTY" IF H_OWNER = "NEVER"; ! just in case
REPEAT
-> ENTER; ! successfully found a hole
FINISH
CHECK:
J = 2
IF LENGTH(H_OWNER) = 6 START ; ! main index
J = H_TOP >> 10
J = 2 UNLESS (4<=J<=32 AND H_TOP & X'FFF' = 0)
FINISH
INDNO = INDNO + J
NO GO:
REPEAT ; ! INDNO <= HI
J =7; ! NO SPACE FOR INDEX
-> OUT
ENTER:
NN == RECORD(NNAD)
NN_NAME=UNA
NN_KB=NKB
NN_INDNO=INDNO
NN_TAG=0
!
IF INA = "" C
THEN J = SET USER RECORD(UNA, FSYS, NKB<<1, NPD, NFD, INDAD, INDNO) C
ELSE START
NN_TAG = 1
J = SET FILE INDEX(UNA, INA, FSYS, NKB<<1, NPD, NFD, INDAD, INDNO)
FINISH
OUT:
RESULT = OUT(J, "SII")
END ; ! DNEWUSER
!
!-----------------------------------------------------------------------
!
!<DPROCS
externalintegerfn DPROCS(integername MAXPROCS, integer ADR)
!
! This procedure copies Supervisor's list of current processes to ADR
! onwards. Each entry is 32 bytes long and the number of entries is
! returned in MAXPROCS.
!>
INTEGER J, LEN
CONSTINTEGER ENTRYLEN = 32
!MON M(10) = M(10) + 1
J = IN2(68)
-> OUT UNLESS J = 0
!
J = 45
-> OUT IF VAL(ADDR(MAXPROCS), 4, 1, DCALLERS PSR) = 0
MAXPROCS = COM_MAXPROCS
!
LEN = MAXPROCS * ENTRYLEN
-> OUT IF VAL(ADR, LEN, 1, DCALLERS PSR) = 0
!
MOVE(LEN, COM_PROCAAD, ADR)
J = 0
OUT:
RESULT = OUT(J, "")
END ; ! DPROCS
!
!-----------------------------------------------------------------------
!
!<DRENAMEINDEX
externalintegerfn DRENAME INDEX(string (18)OLDNAME, NEWNAME,
integer FSYS)
!
! This privileged procedure renames index OLDNAME to NEWNAME. Both
! OLDNAME and NEWNAME must either be of the form:
! username or username:indexname
! ie not one of each. Note that only the specified index is renamed.
! If the user has other fileindexes, these are not renamed.
!>
INTEGER J,INDAD, AINDAD
STRING (31)OLDU, OLDI, OLDINDEX
STRING (31)NEWU, NEWI, NEWINDEX
RECORD (HF)NAME H
INTEGER NNAD, NEWNNAD
RECORD (NNF)NAME NN, NEWNN
RECORD (FF)NAME F, AF
J = IN2(71)
-> OUT UNLESS J = 0
!
J = 93
-> OUT UNLESS DTRYING << 5 < 0
!
J = UIO(OLDNAME, OLDU, OLDI, OLDINDEX)
-> OUT UNLESS J = 0
!
J = UIO(NEWNAME, NEWU, NEWI, NEWINDEX)
-> OUT UNLESS J = 0
!
J = 8
-> OUT IF OLDI = "" # NEWI OR OLDI # "" = NEWI
!
J = FIND NNT ENTRY(OLDINDEX, FSYS, NNAD, 0)
-> OUT UNLESS J = 0; ! OLDNAME DOES NOT EXIST
!
NN == RECORD(NNAD)
!
J = NINDA(FSYS, NN_INDNO, INDAD)
-> OUT UNLESS J = 0
!
J = NEW NNT ENTRY(NEWNAME, FSYS, NEWNNAD)
-> OUT UNLESS J = 0
!
NEWNN == RECORD(NEWNNAD)
NEWNN = NN
NEWNN_NAME = NEWU
NN_NAME = ".NULL"
!
IF OLDI = "" START ; ! process index + main file index
H == RECORD(INDAD)
H_OWNER = NEWU
INDAD = INDAD + 512
FINISH
!
F == RECORD(INDAD)
F_OWNER = NEWU; ! file index
F_NAME = NEWI
J = NEWAINDA(NEWINDEX, FSYS, AINDAD)
IF J = 0 START
AF == RECORD(AINDAD)
AF_OWNER = NEWU
J = NEWAINDA("", 0, J)
FINISH
OUT:
EMPTY DVM
RESULT = OUT(J, "SSI")
END ; ! DRENAME INDEX
!
!-----------------------------------------------------------------------
!
!<DREPLACEINDEX
externalintegerfn DREPLACE INDEX(integer FSYS, INDNO, ADR)
!
! Allows 1024 bytes in the index area of a disc to be overwritten by a
! privileged process.
!>
INTEGER J, INDAD
J = IN2(73)
-> OUT UNLESS J = 0
!
J = 93
-> OUT UNLESS DTRYING << 7 < 0
!
J = 45
-> OUT UNLESS VAL(ADR, 1024, 0, 0) = YES
!
J = NINDA(FSYS, INDNO, INDAD)
-> OUT UNLESS J = 0
!
MOVE(1024, ADR, INDAD)
OUT:
RESULT = OUT(J, "II")
END ; ! DREPLACE INDEX
!
!-----------------------------------------------------------------------
!
!<DSYSAD
externalintegerfn DSYSAD(integer TYPE, ADR, FSYS)
!
! This privileged procedure returns
! the bitmap (TYPE=0)
! the name-number table (TYPE=1)
! the DIRCOM record (TYPE=5)
! or the bad pages bitmap (TYPE=6)
! in ADR onwards for FSYS.
!>
INTEGER J, L, SEMA, SEMANO
RECORD (DISCDATAF)DATA
J = IN2(81)
-> RES UNLESS J = 0
!
J = 93
-> RES UNLESS DTRYING << 11 < 0
!
J = 23
-> RES IF AV(FSYS, 1) = 0
!
J = FBASE2(FSYS, ADDR(DATA))
-> RES UNLESS J = 0
!
J = 8
L = 0
L = DATA_BITSIZE IF TYPE = 0 OR TYPE = 6
L = DATA_NNTSIZE IF TYPE = 1
L = DIRCOMSIZE IF TYPE = 5
-> RES UNLESS L > 0
!
J = 45
-> RES UNLESS VAL(ADR, L, 1, DCALLERSPSR) = YES
!
SEMA = SYSAD(BITKEY, FSYS)
SEMANO = FSYS << 16
J = PP(SEMA, SEMANO,"DSYSAD")
-> RES UNLESS J = 0
MOVE(L, SYSAD(TYPE, FSYS), ADR)
VV(SEMA, SEMANO)
RES:
RESULT = OUT(J, "IXI")
END ; ! DSYSAD
!
!-----------------------------------------------------------------------
!
!<DUSERINDEXES
externalintegerfn DUSERINDEXES(string (6)USER, integer FSYS, ADR,
integername N)
!
! Searches FSYS (or all fsys's if FSYS is -1) for indexes belonging to
! USER. Returns N records to ADR onwards of the form:
!
! %string(11)index, %integer fsys
!>
!
!
INTEGER NDISCS, J, I, NNA, PT, STOP, FINDAD
STRING (11)INAME
INTEGERARRAY FS(0:99)
RECORD (NNF)ARRAYFORMAT NNTF(0:16384)
RECORD (NNF)ARRAYNAME NNT
RECORD (NNF)NAME NN
RECORD (FF)NAME F
RECORD (DISCDATAF)DATA
J = IN2(100)
-> OUT UNLESS J = 0
!
J = UNOK(USER)
-> OUT UNLESS J = 0
!
J = 45
-> OUT IF VAL(ADDR(N), 4, 1, D CALLERS PSR) = 0
N = 0
!
IF FSYS = -1 START
GET AV FSYS2(0, NDISCS, FS)
NDISCS = NDISCS - 1
FINISH ELSE START
J = 23 AND -> OUT IF AV(FSYS, 0) = 0
FS(0) = FSYS
NDISCS = 0
FINISH
!
FOR I = 0, 1, NDISCS CYCLE
FSYS = FS(I)
NNA = SYSAD(NNTKEY, FSYS)
NNT == ARRAY(NNA, NNTF)
J = FBASE2(FSYS, ADDR(DATA))
PT = HASH(USER, DATA_NNTHASH)
STOP = PT
UNTIL PT = STOP CYCLE
NN == NNT(PT)
IF NN_NAME = USER START
INAME = ""
IF NN_TAG > 0 START
J = NINDA(FSYS, NN_INDNO, FINDAD)
-> OUT UNLESS J = 0
F == RECORD(FINDAD)
INAME = F_NAME
FINISH
!
J = 45
-> OUT IF VAL(ADR, 16, 1, D CALLERS PSR) = 0
STRING(ADR) = INAME
INTEGER(ADR+12) = FSYS
ADR = ADR + 16
N = N + 1
FINISH {%ELSE %IF NN_NAME = "" %THEN %EXIT}
PT = PT + 1
PT = 0 IF PT > DATA_NNTTOP
REPEAT
REPEAT
J = 0
OUT:
RESULT = OUT(J, "SI")
END ; ! DUSERINDEXES
!
!-----------------------------------------------------------------------
!
!<GETUSNAMES
externalintegerfn GET USNAMES(integername N, integer ADR, FSYS)
!
! This procedure supplies a sorted list of users who have user records
! on disc pack FSYS. The names are either listed (to DIRLOG) if ADR = -1
! or written as a series of 6 byte strings to ADR onwards. N is set to
! the number of names returned. The array at ADR must be able to hold 1365
! names, i.e. 9555 bytes.
!>
RECORD (NNF)ARRAYFORMAT NNTF(0:16384)
RECORD (NNF)ARRAYNAME NN
INTEGER PT,NNA,J, LN, I
STRING (255) USER
STRING (6)ARRAY U(1:1365)
RECORD (DISCDATAF)DATA
J = IN2(89)
-> OUT UNLESS J = 0
!
J = 23
-> OUT IF AV(FSYS, 0) = 0
!
J = FBASE2(FSYS, ADDR(DATA))
-> OUT UNLESS J = 0
!
NNA = SYSAD(NNTKEY, FSYS)
NN == ARRAY(NNA, NNTF)
LN = 0
!
CYCLE PT = 0, 1, DATA_NNTTOP
USER=NN(PT)_NAME
IF LENGTH(USER)=6 AND NN(PT)_TAG = 0 START ; ! a process index
LN=LN+1
U(LN) = USER
FINISH
REPEAT
!
N = LN
IF LN = 0 START
IF ADR = -1 START
WRSN("No users on FSYS", FSYS)
FINISH
FINISH ELSE START
IF ADR # -1 START
J = 45
-> OUT IF VAL(ADR, LN*7, 1, D CALLERS PSR) = 0
-> OUT IF VAL(ADDR(N), 4, 1, D CALLERS PSR) = 0
FINISH
!
SORT STRINGS(U, LN)
IF ADR = -1 START
WRSN("Users on FSYS", FSYS)
PT = 0
CYCLE I = 1, 1, LN
PRINTSTRING(U(I))
SPACES(2)
PT = PT + 1
IF PT > 9 THEN PT = 0 AND NEWLINE
REPEAT
NEWLINE
FINISH ELSE START
MOVE(LN*7, ADDR(U(1)), ADR)
FINISH
FINISH
J = 0
OUT:
RESULT = OUT(J, "")
END ; ! GET USNAMES
!
!-----------------------------------------------------------------------
!
!<GETUSNAMES2
externalintegerfn GET USNAMES2(record (NNF)arrayname UNN,
integername N, integer FSYS)
!
! This procedure supplies the list of users who have user records on
! disc-pack FSYS, sorted into INDEX NO order. A series of records of
! format
!
! (string(6)NAME, byteinteger KB, integer INDNO)
!
! is returned in the array UNN, which should be declared (0:1364). N is
! set to the number of names supplied.
!>
RECORD (NNF)ARRAYFORMAT NNTF(0:16384)
RECORD (NNF)ARRAYNAME NN
RECORD (NNF)NNW
INTEGER PT,NNA, J, I, K, MM, NUSERS
STRING (255) USER
RECORD (DISCDATAF)DATA
J = IN2(90)
-> OUT UNLESS J = 0
!
J = 23
-> OUT IF AV(FSYS, 0) = 0
!
J = FBASE2(FSYS, ADDR(DATA))
-> OUT UNLESS J = 0
!
NNA = SYSAD(NNTKEY, FSYS)
NN == ARRAY(NNA, NNTF)
!
NUSERS = 0
CYCLE PT = 0, 1, DATA_NNTTOP
NUSERS = NUSERS + 1 IF LENGTH(NN(PT)_NAME) = 6 AND NN(PT)_TAG = 0
REPEAT
!
J = 45
K = 12 * NUSERS + 1
K = K ! X'18000000'
*LDA_UNN+4
*LDTB_K
*VAL_(LNB +1)
*JCC_3,<OUT>; ! jump if no read access to descriptor
*LD_UNN+8
*VAL_(LNB +1)
*JCC_3,<OUT>
-> OUT IF VAL(ADDR(UNN(0)), 12 * NUSERS, 1, D CALLERS PSR) = 0
-> OUT IF VAL(ADDR(N), 4, 1, D CALLERS PSR) = 0
!
N = 0
CYCLE PT = 0, 1, DATA_NNTTOP
USER=NN(PT)_NAME
IF LENGTH(USER)=6 AND NN(PT)_TAG = 0 START ; ! a process index
UNN(N)=NN(PT)
N=N+1
FINISH
REPEAT
!
IF N > 0 START
MM = 1
MM = MM << 1 WHILE MM <= N
MM = MM - 1
!
CYCLE
MM = MM >> 1
EXIT IF MM = 0
CYCLE I = 1, 1, N-MM
K = I
WHILE K > 0 CYCLE
J = K + MM
!
EXIT IF UNN(K-1)_INDNO <= UNN(J-1)_INDNO
NNW = UNN(J-1)
UNN(J-1) = UNN(K-1)
UNN(K-1) = NNW
!
K = K - MM
REPEAT
REPEAT
REPEAT
FINISH
J = 0
OUT:
RESULT = OUT(J, "")
END ; ! GET USNAMES2
!
!-----------------------------------------------------------------------
!
EXTERNALROUTINE SETDIRMON(STRING (255)S)
IF S = "" OR S = "0" THEN DIRMON = 0 ELSE DIRMON = 1
END ; ! SETDIRMON
!
!-----------------------------------------------------------------------
!
EXTERNALROUTINE PLACE(STRING (39)TEXT,INTEGER SCREEN,LINE,COL,ACTION)
RECORD (POPERF)P
WHILE LENGTH(TEXT)>20 CYCLE
PLACE(FROMSTRING(TEXT,1,20),SCREEN,LINE,COL,ACTION)
TEXT=FROMSTRING(TEXT,21,LENGTH(TEXT))
COL=COL+20
ACTION=NULL IF ACTION#NULL
REPEAT
P=0
P_DEST=X'320006'
P_LINE=SCREEN*LINES PER PAGE + LINE
P_POS=COL
P_ZERO=ACTION
P_TEXT=TEXT
DPONI(P)
END ; ! PLACE
!
!-----------------------------------------------------------------------
!
ROUTINE WRITE TO COL(INTEGER I,LINE,COL)
STRING (31) S
S=ITOS(I)
PLACE(S,SCREEN2,LINE,COL-LENGTH(S),NULL)
END ; ! WRITE TO COL
!
!-----------------------------------------------------------------------
!
!
!
EXTERNALROUTINE INIT DISPLAY
INTEGER J
STRING (31) S
J=COUNT PROCS IN(" ",CURIUSERS)
PLACE("Interactive Use - Status",SCREEN2,0,6,CLEAR)
WRITE TO COL(MAXIUSERS,5,31)
WRITE TO COL(CURIUSERS,5,38)
LINENO=9
PLACE("Current Current",SCREEN2,2,25,NULL)
PLACE("limit number",SCREEN2,3,25,NULL)
PLACE("Interactive users:",SCREEN2,5,0,NULL)
S=TIME
LENGTH(S)=5
PLACE("Screen written at ".S."hrs",SCREEN2, C
LINES PER PAGE - 1,13,NULL)
END ; ! INIT DISPLAY
!
!-----------------------------------------------------------------------
!
INTEGERFN HASQS(STRING (6) U)
INTEGER J
CYCLE J=1,1,6
IF CHARNO(U,J)='?' THEN RESULT =1
REPEAT
RESULT =0
END ; ! HASQS
!
!-----------------------------------------------------------------------
!
INTEGERFN EQUSER(STRING (6) USER,PASSU)
! RESULT 1 IF USER IS IN THE CLASS "PASSU", ELSE RESULT 0
INTEGER J,CHP,CHU
RESULT =0 UNLESS LENGTH(USER)=6=LENGTH(PASSU); ! does not belong
CYCLE J=1,1,6
CHU=CHARNO(USER,J)
CHP=CHARNO(PASSU,J)
UNLESS CHU=CHP OR CHP='?' THEN RESULT =0; ! does not belong
REPEAT
RESULT =1
END ; ! EQUSER
!
!-----------------------------------------------------------------------
!
INTEGERFN AMBIGUOUS(STRING (6) USER,PASSU)
! result is 1 if there exists a 6-char name which belongs to the group
! USER and to the group PASSU, otherwise result 0.
INTEGER J,CHP,CHU
RESULT =1 UNLESS LENGTH(USER)=6=LENGTH(PASSU); ! not unambiguous
CYCLE J=1,1,6
CHU=CHARNO(USER,J)
CHP=CHARNO(PASSU,J)
IF CHU#CHP AND CHU#'?' AND CHP#'?' THEN RESULT =0; ! unambiguous
REPEAT
RESULT =1; ! ambiguous
END ; ! AMBIGUOUS
!
!-----------------------------------------------------------------------
!
ROUTINE UGRETLIST(INTEGER PT)
INTEGER K
RETURN IF PT=ENDL
K=ASL
ASL=PT
PT=UG(PT)_LINK WHILE UG(PT)_LINK#ENDL
UG(PT)_LINK=K
END ; ! UGRETLIST
!
!-----------------------------------------------------------------------
!
INTEGERFN ONLIST(STRING (6) USER,INTEGERNAME HEAD,INTEGER ACT,MAX)
! FOR ADDTOMAINLIST WE ADD TO THE END OF THE LIST. FOR
! ADDTOSUBLIST, WE GO DOWN TO THE FIRST ENTRY TO WHICH THE USER IS NON-EQUIVALENT,
! AND ADD IN FRONT OF THAT.
INTEGER CUR,J,K,INSET
INTEGERNAME PREVLINK
RECORD (UGF)NAME R
STRING (6) WU
CUR=HEAD
PREVLINK==HEAD
WHILE CUR#ENDL CYCLE
R==UG(CUR)
IF ACT&DISPLAY#0 START
IF ACT&OLDSCREEN=0 THEN ACT=ACT!OLDSCREEN
INSET=5
IF ACT&SIDECHAIN#0 THEN INSET=10
PLACE(R_U,SCREEN2,LINENO,INSET,NULL)
WRITE TO COL(R_MAX,LINENO,31)
WRITE TO COL(R_N,LINENO,38)
LINENO=LINENO+1
J=ONLIST(USER,R_SUBLINK,DISPLAY!SIDECHAIN,0)
FINISH
IF ACT&PROCRESET#0 START
R_N = COUNT PROCS IN(R_U, J)
IF USER=R_U THEN MAX=R_MAX ELSE START
IF EQUSER(R_U,USER)#0 AND R_MAX>MAX THEN R_MAX=MAX
FINISH
J=ONLIST(USER,R_SUBLINK,ACT!SIDECHAIN,MAX)
FINISH
IF EQUSER(USER,R_U)#0 START ; !
!
! Found equivalent or identical
IF ACT&(CHECKN!RESETN!INCRE)#0 START
IF ACT&INCRE#0 THEN R_N=R_N+MAX
IF ACT&RESETN#0 THEN R_N=MAX
IF ACT&CHECKN#0 START
IF R_N>=R_MAX THEN RESULT =GROUPFULLFLAG
FINISH
RESULT =ONLIST(USER,R_SUBLINK,ACT!SIDECHAIN,MAX)
FINISH ; ! CHECKN PROCRESET INCRE
!
IF USER#R_U START
!
! Found equivalent, but not identical
IF ACT&(ADDTO!SIDECHAIN)=ADDTO!SIDECHAIN START
IF MAX>R_MAX THEN MAX=R_MAX
FINISH
IF ACT&PROCRESET=0 THEN C
RESULT =ONLIST(USER,R_SUBLINK,ACT!SIDECHAIN,MAX)
!
FINISH ELSE START
!
! Then found identical
IF ACT&ADDTO#0 THEN R_MAX=MAX AND RESULT =0
IF ACT&REMOVE#0 START
UGRETLIST(R_SUBLINK)
R_SUBLINK=ENDL
J=PREVLINK
PREVLINK=R_LINK
R_LINK=ENDL
UGRETLIST(J)
RESULT =0
FINISH ; ! ACT REMOVE
FINISH ; ! FOUND IDENT
FINISH ELSE START ; ! FINISH FOUND EQUIV
! Neither identical nor equivalent
! PREVLINK IS MAPPED ONTO LINK POINTING TO CURRENT
! CELL. GET NEW CELL AND PUT IN FRONT OF CURRENT CELL
IF ACT&SIDECHAIN=0 START
IF EQUSER(R_U,USER)#0 AND ACT&ADDTO#0 START
PREVLINK==R_SUBLINK
WU=R_U
R_U=USER
USER=WU
J=R_MAX
R_MAX=MAX
MAX=J
EXIT
FINISH
IF AMBIGUOUS(USER,R_U)#0 THEN RESULT =AMBIFLAG
FINISH
IF HASQS(R_U)#0 AND C
ACT&(ADDTO!SIDECHAIN)=ADDTO!SIDECHAIN THEN EXIT
FINISH ; ! Neither identical nor equivalent
PREVLINK==UG(CUR)_LINK
CUR=UG(CUR)_LINK
REPEAT
IF ACT&ADDTO#0 START
IF ASL=ENDL THEN RESULT =NOFREEFLAG
K=PREVLINK
J=ASL
PREVLINK=J
ASL=UG(ASL)_LINK; ! TAKE OFF FREELIST
UG(J)_LINK=K
UG(J)_U=USER
UG(J)_MAX=MAX
UG(J)_N=0
RESULT =ADDEDFLAG; ! OK
FINISH
RESULT =NOTINLISTFLAG
END ; ! ONLIST
!
!-----------------------------------------------------------------------
!
EXTERNALINTEGERFN LISTMOD(STRING (6) USERGROUP,INTEGER N1,N2)
! There are 4 calls on this all from XOP
! process start LM(user, 0, 1)
! process stops LM(user, 0, -1)
! D/USERS LM(S1, N1, N2)
! checkstart LM(user, 0, 0)
!
!
! ADDTO 2 add or reset MAXusers for usergroup to value N
! REMOVE 32 remove USERGROUP from list
! CHECKN 128 check whether USERgroup may log on
! INCRE 4 add N to counts for usergroups including USERGROUP
! PROCRESET 1 reset N-values for all usergroups from process-list
! DISPLAY 64 display the lists on the screen.
INTEGER N,ACT,J,K
!MON M(22) = M(22) + 1
N=0
IF ASL=-2 START
! FREELIST NOT INITIALISED
CYCLE J=0,1,TOPUG
UG(J)_LINK=J+1
UG(J)_SUBLINK=ENDL
REPEAT
UG(TOPUG)_LINK=ENDL
ASL=0
MAXIUSERS=COM_MAXPROCS - NEXECPROCS - 1
FINISH
IF LENGTH(USERGROUP)=6 START
IF N1=0 START ; ! NOT A D/USERS
IF N2=0 START
IF CURIUSERS>=MAXIUSERS THEN RESULT =SYSFULLFLAG
ACT=CHECKN
FINISH ELSE ACT=INCRE AND N=N2 AND CURIUSERS=CURIUSERS+N
FINISH ELSE START
! THEN D/USERS <USERGROUP> PAR
IF N2<0 THEN ACT=REMOVE ELSE START
ACT=ADDTO
N=N2
IF N>MAXIUSERS THEN N=MAXIUSERS
FINISH
FINISH
FINISH ELSE START
IF N1>=0 START
MAXIUSERS=N1
MAXIUSERS=COM_MAXPROCS-NEXECPROCS - 1 C
IF MAXIUSERS>COM_MAXPROCS-NEXECPROCS - 1
RESULT =0
FINISH
ACT=DISPLAY
INIT DISPLAY
USERGROUP=" "
FINISH
J=ONLIST(USERGROUP,HEAD,ACT,N)
! If we have just successfully added a new item to the list,
! then reset all counts from process list.
IF ACT#CHECKN AND ACT#INCRE AND ACT#REMOVE C
AND ACT#DISPLAY C
THEN K=ONLIST(USERGROUP,HEAD,PROCRESET,N)
IF ACT=DISPLAY C
THEN PLACE("Sub groups:", SCREEN2, 7, 0, SCREEN SWITCH)
IF ACT=CHECKN AND SYSFULLFLAG#J#GROUPFULLFLAG THEN J=0
RESULT =J
END ; ! LISTMOD
!
!-----------------------------------------------------------------------
!
EXTERNALINTEGERFN NEWPAGE CHAR(RECORD (PARMF)NAME P)
OWNINTEGER STATE=-1
SWITCH NP(0:2)
OWNINTEGER CDEX,IMNEM
!
RECORDFORMAT RCBF(INTEGER LIMFLAGS,LSTBA,LB BYTES,LBA,AL BYTES, C
ALA,INITWORD,SLOTNO)
RECORD (RCBF)NAME RCB
!
CONSTSTRING (19)ARRAY ALLMS(0:2)=C
"SUCCESSFUL", "BAD PARAM(?)", "ALREADY ALLOCATED"
!
CONSTINTEGER PROCESS1=1
!
RECORDFORMAT ALEF(INTEGER BYTES,ADDR)
INTEGERNAME INIT0 LB,LOAD REP LB,INIT LB,WRITE CONTROL LB,NEWPAGE LB
INTEGERNAME READ PROPS LB
RECORD (ALEF)NAME AL0,AL2,AL4
INTEGER FAD,REP ADDR,SNO,DEV ENT AD,INIT ADDR
INTEGER PROP DAT ADDR,RESP0,RESP1, J
!
RECORDFORMAT PROPF(BYTEINTEGER SIX,DEVNO,SPEED REP,FORM STYLE, C
FINAL LINE, OPTION CART)
RECORD (PROPF)NAME PROPS
!MON M(23) = M(23) + 1
!
IF STATE<0 START
!Reject everything until init call from routine AUTO CLOSE
IF P_DEST#0 THEN RESULT =0
STATE=0
FINISH
-> NP(STATE)
NP(0):
! ALLOCATE THE DEVICE
IMNEM=M'LP0'
P=0
P_DEST=X'30000B'; ! GPC ALLOCATE
P_SRCE=36; ! IN "PROCESS1"
P_P1=IMNEM
P_P2=((COM_SYNC1 DEST + PROCESS1)<<16) ! 36; ! to DACT 36 in rt PROCESS1
DPONI(P)
STATE=1
RESULT =0
NP(1):
IF P_P1 # 0 START
J = P_P1
J = 1 UNLESS J = 2
WRS3N("ALLOC REPLY", ALLMS(J), "", P_P1)
RESULT = 1
FINISH
SNO=P_P2
DEV ENT AD=P_P3
!
!NOW GET A PAGE
P=0
P_DEST=X'50000'; ! GET EPAGE DEST
DOUTI(P)
CDEX=P_P2
FAD=P_P4
REPADDR=FAD+128
!
! If the device has been powered off, initialisation data is lost, so we need
! to re-initialise. Setting "no auto-throw" is not enough to eliminate
! auto-throw - you have to do a write-control to set "lines-per-page"
! as well. EXTRAORDINARY !!
!
! Layout of the (public) page
! OFFSET(BYTES) LENGTH(BYTES)
! 0 RCB 32
! 52 INIT0 LB 4
! 56 READ PROP DATA LB 4
! 60 NEWPAGE LB 4
! 64 LOAD REP LB 4
! 68 INIT LB 4
! 72 WRITE-CONTROL LB 4
! 76 AL0-1 8
! 84 AL2-3 8
! 92 AL4-5 8
! 100 INIT DATA 4
! 104 PROPERTIES DATA 8
! 128 LP 384
!
! INITIALISE RCB ETC.
INIT0 LB==INTEGER(FAD+52)
READ PROPS LB==INTEGER(FAD+56)
NEWPAGE LB==INTEGER(FAD+60)
LOAD REP LB==INTEGER(FAD+64)
INIT LB==INTEGER(FAD+68)
WRITE CONTROL LB==INTEGER(FAD+72)
AL0==RECORD(FAD+76)
AL2==RECORD(FAD+84)
AL4==RECORD(FAD+92)
!
INIT ADDR=FAD+100
PROP DAT ADDR=FAD+104
PROPS==RECORD(PROP DAT ADDR)
!
RCB==RECORD(FAD+0)
RCB=0
RCB_LIMFLAGS=X'00004000'; ! trusted RCB - to do the initialise
RCB_LB BYTES=4
RCB_LBA=ADDR(INIT0 LB)
RCB_AL BYTES=24
RCB_ALA=ADDR(AL0)
!
INIT0 LB= X'80F00002'
READ PROPS LB=X'00F00E04'; ! short-block, long block, X & Y conditions suppressed
NEWPAGE LB= X'82F0030C'; ! write literal data X'C'=form feed
LOAD REP LB= X'80F02500'; ! Load repertoire, command chain
INIT LB= X'80F00102'; ! initialise
!
AL0_BYTES=384
AL0_ADDR=REPADDR
AL2_BYTES=4
AL2_ADDR=INIT ADDR
AL4_BYTES=8
AL4_ADDR=PROP DAT ADDR
!
INTEGER(INIT ADDR)=0; ! suppress all secondary bits from setting primary
!
!---------------- Fire NEWPAGE command -------------------
RCB_LB BYTES=4
RCB_LBA=ADDR(NEWPAGE LB)
P=0
P_DEST=X'30000C'; ! GPC EXECUTE
P_SRCE=36
P_P1=ADDR(RCB)
P_P2=SNO
P_P3=1<<4 ! 3; ! PAWFN<<4 ! SAWFLAGS
DPONI(P)
STATE=2
RESULT =0
NP(2):
RESP0=P_P1
RESP1=P_P2
WRSNT("RESP0=", RESP0, 2)
IF (RESP0>>16)&255=X'10' THEN RESULT =0; ! Attention response
STATE=-1
!
! Now return page
P=0
P_DEST=X'60000'; ! RETURN EPAGE
P_P2=CDEX
DPONI(P)
! De=-allocate
P=0
P_DEST=X'300005'; ! GPC DE ALLOCATE
P_P1=IMNEM
DOUTI(P)
IF P_P1 # 0 START
WRSN("De-allocate reply =", P_P1)
FINISH
RESULT =1
END ; ! NEWPAGE CHAR
!
!-----------------------------------------------------------------------
!
routine SEND(string (255)TEXT, STRING (4)TYPE)
record (PARMF)P
return if LENGTH(TEXT) > 2 and FROMSTRING(TEXT, 1, 3) = "IPL"
!
P = 0
P_DEST = X'32000E'; ! GOES TO 'PARSE COM' VIA OPER
P_SRCE = 26; ! DISCARD REPLIES
LENGTH(TEXT) = 23 if LENGTH(TEXT) > 23
STRING(ADDR(P_P1)) = TEXT
DPONI(P)
!
OPER(0, TYPE . " command:")
OPER(0, TEXT)
PRINTSTRING(TYPE)
WRSS(": ", TEXT)
end ; ! SEND
!
!-----------------------------------------------------------------------
!
INTEGERFN OBEYFILE(STRING (31)FULL)
! result = 0 for success
! All lines in file, except blank ones, must be at least 3 characs long
! and have '/' as the second ch. This stops garbage files filling up
! the param table. NOTE that Supervisor commands can start '0/'.
INTEGER SEG, GAP, FAD, J, K, DATASTART, DATAEND, RES
STRING (255)S, A, B
RECORD (FHDRF)NAME H
SEG = 0
GAP = 0
J = DCONNECTI(FULL, -1, 1, 0, SEG, GAP)
RESULT = J UNLESS J = 0
!
FAD = SEG << 18
H == RECORD(FAD)
RES = 89; ! invalid file
-> OUT UNLESS 0 < H_TXTRELST < H_NEXTFREEBYTE ANDC
H_NEXTFREEBYTE <= H_MAXBYTES ANDC
H_THREE = 3
!
DATA START = FAD + H_TXTRELST
DATA END = FAD + H_NEXTFREEBYTE
J = DATA START
CYCLE
K = J
EXIT IF J >= DATA END
WHILE BYTEINTEGER(J) # NL CYCLE
EXIT IF J >= DATA END
J = J + 1
REPEAT
!
S = ""
WHILE K < J CYCLE
S = S . TOSTRING(BYTEINTEGER(K)) IF LENGTH(S) < 255
K = K + 1
REPEAT
!
J = J + 1
S = A . " " . B WHILE S -> A . (" ") . B
S = JUST(S)
CONTINUE IF S = ""
-> OUT IF LENGTH(S) < 3 OR CHARNO(S, 2) # '/'
SEND(S, "Obey")
REPEAT
RES = 0
OUT:
J = DDISCONNECTI(FULL, -1, 0)
RESULT = RES
END ; ! OBEYFILE
!
!-----------------------------------------------------------------------
!
integerfn VALID LINE(stringname LINE,integer LOBYTE,HIBYTE)
! Result=0 not an OK line
! 1 valid: ie line looks like 'ddddddd hh.mm command'
integer J,CH,MINS
string (255) A,B,S
constintegerarray FAC(1:5)=600,60,0,10,1
constintegerarray HHMM(1:5)='2','9',0,'5','9'
if LOBYTE>HIBYTE start
J=LOBYTE
LOBYTE=HIBYTE
HIBYTE=J
finish
!
S=""
J=LOBYTE
while J<=HIBYTE cycle
S=S.TOSTRING(BYTEINTEGER(J)) if LENGTH(S)<255
J=J+1
repeat
!
! Remove NLs and multiple spaces
S = A . " " . B while S->A.(" ").B
S = A . B while S->A.(TOSTRING(NL)).B
! Remove leading spaces
S = JUST(S)
if LENGTH(S)<=14 then result =0
if CHARNO(S,11)#'.' then result =0
MINS=0
cycle J=1,1,7
CH=CHARNO(S,J)
unless 'A'<=CH<='Z' or CH='-' then result =0
repeat
cycle J=1,1,5
if J#3 start
CH=CHARNO(S,J+8)
result = 0 unless '0' <= CH <= HHMM(J)
MINS=MINS + FAC(J)*(CH-'0')
finish
repeat
if MINS>=24*60 then result =0
LINE=S
result =1
end ; ! VALID LINE
!
!-----------------------------------------------------------------------
!
integerfn NEXTLINE(stringname LINEDAYS,LINETIME,integername c
LINEPTR,stringname TEXT,integer DIRECTION,LIMIT)
! Result = 0 if LIMIT reached and no valid line
! 1 if valid line found
!
! LINEPTR is set before entry to point where search is to start from
! and is set after call to where search may continue from.
!
! For result=1, LINEDAYS is set to string(7) day letters,
! LINETIME is set to string(5) hh.mm, and TEXT to rest of line.
integer J,K,V
string (255) S
J=LINEPTR
V=0; ! becomes 1 on finding valid line
cycle
if J=LIMIT then exit
K=J
until BYTEINTEGER(J)=NL cycle
exit if J=LIMIT
J=J+DIRECTION
repeat
V=VALIDLINE(S,J,K)
exit if V#0
repeat
LINEPTR=J
if V=0 then result =0
LINEDAYS=FROMSTRING(S,1,7)
LINETIME=FROMSTRING(S,9,13)
S=FROMSTRING(S,14,LENGTH(S))
S = JUST(S)
TEXT=S
result =1
end ; ! NEXTLINE
!
!-----------------------------------------------------------------------
!
externalintegerfn AUTOCOMM(string (31)NEWFILE,integer ACT)
! ACT = 0 clock tick (1 per minute)
! 1 disconnect file, re-connect file NEWFILE (D/AUTOFILE)
! 2 disconnect file (D/AUTOFILE 0)
! 3 connect file (system start-up)
! 4 say 'no autofile'
! 5 obey NEWFILE
ownstring (18)FILE="MANAGR.AUTOFILE"
owninteger PROCEED FROM=-1
owninteger DAY
string (7) LINEDAYS
owninteger NORMAL STARTUP ACHIEVED=0,INHIBIT NORMAL STARTUP=0
owninteger PREVSECSFRMN,DATA START,DATA END,FAD
string (255) TEXT
string (6)user
string (11)filename
string (8) NOW,LINETIME,PREV TIM
integer J,K,SEG,GAP,LINEPTR,FLAG
record (FHDRF)name H
constinteger DOWN=-1, UP=1
switch AA(0:5)
NOW=TIME
LENGTH(NOW)=5
-> AA(ACT)
AA(3): ! System start-up
if INHIBIT NORMAL STARTUP#0 then result =0
NORMAL STARTUP ACHIEVED=1
AA(2): ! Disconnect file or inhibit normal startup
! (D/AUTOFILE 0)
if NORMAL STARTUP ACHIEVED=0 then INHIBIT NORMAL STARTUP=1
AA(4): ! say 'no autofile'
AA(1): ! D/AUTOFILE <file> (or null)
TEXT = "no autofile"
PLACE(TEXT, 0, 4, 0, 0)
result = 0 if ACT = 4
!
J = DDISCONNECTI(FILE, -1, 0)
J = 0 IF J = 39
FILE = "MANAGR.AUTOFILE"
PROCEED FROM = -1
RESULT = J IF ACT = 2; ! disconnect the autofile
DAY = DDAYNUMBER + 1
DAY = 1 + DAY - 7*(DAY//7); ! Sun = 1 etc
!
IF NEWFILE = "" THEN TEXT = FILE ELSE TEXT = NEWFILE
!
SEG = 0
GAP = 0
J = DCONNECTI(TEXT, -1, 1, 0, SEG, GAP)
RESULT = J UNLESS J = 0
FILE = TEXT
!
file -> user . (".") . filename
filename = filename . " " while length(filename) < 11
PLACE(filename, 0, 4, 0, 0)
!
FAD=SEG<<18
H==RECORD(FAD)
unless 0<H_TXTRELST<H_NEXTFREEBYTE and c
H_NEXTFREEBYTE<=H_MAXBYTES and H_THREE=3 then result =89; ! invalid autofile
DATA START=FAD+H_TXTRELST
DATA END=FAD+H_NEXTFREEBYTE
! Check that valid lines have monotonically increasing times
PREV TIM="25.00"
LINEPTR=DATA END
until LINEPTR=DATA START cycle
FLAG=NEXTLINE(LINEDAYS,LINETIME,LINEPTR,TEXT,DOWN,DATASTART)
if FLAG#0 start
result =89 if LINE TIME > PREV TIM; ! INVALID AUTOFILE
PREV TIM=LINE TIME
finish
repeat
!
! Find most recent IPL point (if any)
LINEPTR = DATA END
until LINEPTR = DATA START cycle
FLAG = NEXTLINE(LINEDAYS,LINETIME,LINEPTR,TEXT,DOWN,DATASTART)
if FLAG#0 and LENGTH(TEXT)>3 and FROMSTRING(TEXT,1,3)="IPL" start
if CHARNO(LINEDAYS,DAY)#'-' and LINETIME<=NOW start
PROCEED FROM = LINEPTR
exit
finish
finish
repeat
PROCEED FROM = DATA START if PROCEED FROM < 0
AA(0): ! regular tick (1-minute)
result =0 if PROCEED FROM < 0; ! no file
! Set up J and K to see whether we have passed midnight recently
J = PREVSECSFRMN
K = COM_SECSFRMN
PREVSECSFRMN = K
if PROCEED FROM = 0 start
! Nothing more in file. Has midnight passed recently?
RESULT = 0 UNLESS J > K
!
J = SYSAD(DATKEY, -1); ! reset last IPL date&time
INTEGER(J + 4) = PACKDT >> 17; ! DATE
INTEGER(J) = 0; ! TIME
!
DAY = DDAYNUMBER + 1
DAY = 1 + DAY - 7*(DAY//7); ! Sun = 1 etc
PROCEED FROM=DATA START
finish
! Proceed up file, activating msgs prior to NOW and finishing at
! DATA END or msg-line timed for later than NOW
LINEPTR = PROCEED FROM
until LINEPTR = DATA END cycle
FLAG = NEXTLINE(LINEDAYS,LINE TIME,LINEPTR,TEXT,UP,DATA END)
if FLAG # 0 start
exit if LINE TIME > NOW
SEND(TEXT, "Auto") UNLESS CHARNO(LINEDAYS,DAY) = '-'
PROCEED FROM = LINEPTR
finish
repeat
PROCEED FROM = 0 if FLAG = 0; ! no more data
result = 0
AA(5):
RESULT = OBEYFILE(NEWFILE)
end ; ! AUTOCOMM
!
!-----------------------------------------------------------------------
!
endoffile