!TITLE Manipulating User records and Indexes
!<DACCEPT
! %externalintegerfn DACCEPT(%string(31)FILE INDEX, FILE, NEWNAME,
! %integer FSYS)
!
! This procedure causes the transfer to the caller's main file index of
! file FILE belonging to file index FILE INDEX on disc-pack FSYS. The
! file must previously have been "offered to" the caller of this
! procedure, using procedure DOFFER. The file is named NEWNAME under its
! new ownership, but NEWNAME and FILE may be identical names.
!>
!
!
!
CONSTINTEGER ALLOW IC INTS = X'FFFFF7FF'
CONSTINTEGER BASEFILE SEG = 32
CONSTINTEGER BATCH = 2; ! reason for STARTP
CONSTINTEGER CHERSH = 16; ! CODES
CONSTINTEGER CLODACT=8
CONSTINTEGER CODE AD = X'00080000'; ! LOCAL 2
CONSTINTEGER DAPINSPERSEC = 3300000
CONSTINTEGER DEFAULT BMAX = 1
CONSTINTEGER DEFAULT IMAX = 1
CONSTINTEGER DEFAULT MAXFILE = 1024; ! 1megabyte
CONSTINTEGER DEFAULT MAXKB = X'8000'; ! 32 megabytes
CONSTINTEGER DEFAULT TMAX = 1
CONSTINTEGER DIRCODE SEG = 2
CONSTINTEGER DIRDACT = 5; ! special director async messages
CONSTINTEGER DLOG = 8; ! route PRINTSTRING to DIRLOG
CONSTINTEGER DT = 1; ! DATE and TIME required in PRINSTRING
CONSTINTEGER EPAGE SIZE = 4
CONSTINTEGER ERCC = 1
CONSTINTEGER EX = 5
CONSTINTEGER FORK = 5
CONSTINTEGER GLAD = X'000C0000'; ! LOCAL 3
CONSTINTEGER INTDACT = 1; ! INT: messages from supervisor
CONSTINTEGER INTER = 0; ! reason for STARTP
CONSTINTEGER INVI = X'80308030'
CONSTINTEGER KENT = 0
CONSTINTEGER LEAVE = 8
CONSTINTEGER LOG = 2; ! route PRINTSTRING to MAINLOG
CONSTINTEGER LOUAD = X'00800000' ! 32 << 18
CONSTINTEGER MAXM1 = 3
CONSTINTEGER NEWSTART = 4; ! reason from STARTP
CONSTINTEGER NO = 0
CONSTINTEGER NOARCH = 128; ! CODES
CONSTINTEGER NORMAL STACK SEG = 4
CONSTINTEGER NULDACT = 6; ! Null activity
CONSTINTEGER OFFER = 2; ! CODES
CONSTINTEGER OLDGE = 4; !CODES2
CONSTINTEGER PON AND CONTINUE = 6
CONSTINTEGER PON AND SUSPEND = 7
CONSTINTEGER PRIVAT = 32; ! CODES
CONSTINTEGER READ ACR = 5
CONSTINTEGER REC SEP = 30; !ISO record separator
CONSTINTEGER RESDACT = 2; ! resume messages from user process
CONSTINTEGER SCTAB SEG = 8
CONSTINTEGER SIG LOOP STOP = 31
CONSTINTEGER SITE = KENT
CONSTINTEGER SYNC1 TYPE = 1
CONSTINTEGER TEMPFI = 4; ! CODES
CONSTINTEGER TEMPFS = 12
CONSTINTEGER TOP AS ACT = 9
CONSTINTEGER TOPEI = 22
CONSTINTEGER TOP I VALUE = 2
CONSTINTEGER TXTDACT = 3; ! text messages in file, P1 = start/finish
CONSTINTEGER UHIDACT = 4; ! uninhibit async messages
CONSTINTEGER UNAVA = 1; ! CODES
CONSTINTEGER USEDACT = 7
CONSTINTEGER VEC128 = X'38000000'
CONSTINTEGER VIOLAT = 64; ! CODES
CONSTINTEGER VTEMPF = 8; ! CODES
CONSTINTEGER WR = 3
CONSTINTEGER WRCONN = 1; ! CODES2
CONSTINTEGER WRSH = 11; ! WRITE, READ AND SHARED
CONSTINTEGER WRTOF = 4; ! route PRINTSTRING to private log file
CONSTINTEGER YES = 1
!
!
CONSTSTRINGNAME DATE = X'80C0003F'
CONSTSTRINGNAME TIME = X'80C0004B'
!
CONSTSTRING (29)EXECP = "FTRANSDIRECTVOLUMSPOOLRMAILER"
!
!
EXTERNALINTEGER ACCTSA
EXTERNALINTEGER AEXPRESS = 0
EXTERNALINTEGER AIOSTAT
EXTERNALINTEGER AQD
EXTERNALINTEGER AREVS
EXTERNALINTEGER ASYNC INHIB = 100
EXTERNALINTEGER BLKSI
EXTERNALINTEGER CBTA0
EXTERNALINTEGER CBTASL0
EXTERNALINTEGER DAP STATE
EXTERNALINTEGER D CALLERS ACR; ! SET BY FN IN2
EXTERNALINTEGER D CALLERS PSR
EXTERNALINTEGER DDVSN; ! FORMAT IS FSYS<<18 ! DIRVSN
EXTERNALINTEGER DEFAULT SS ACR = 10
EXTERNALINTEGER DEPTH
EXTERNALINTEGER DINSTRS
EXTERNALINTEGER DIRFLAG
EXTERNALINTEGER DIRFN
EXTERNALINTEGER DIRLEVEL
EXTERNALINTEGER DIRLOGAD = 0; ! ADDR OF DIRLOG
EXTERNALINTEGER DIRMON
EXTERNALINTEGER DIROUTP0
EXTERNALINTEGER D TRYING = -1; ! SET FROM INDEX IN DIRECTOR AT START UP
EXTERNALINTEGER ENDSST
EXTERNALINTEGER FACILITYA; ! set to seg<<18+32 or 0
EXTERNALINTEGER FILE1AD = 0; ! ADDR OF USERS LOGFILE
EXTERNALINTEGER FSYS WARN = 0
EXTERNALINTEGER GOT SEMA = 0
EXTERNALINTEGER HISEG
EXTERNALINTEGER HOTTOPA = 0; ! address of Hot Top array
EXTERNALINTEGER HOTTOPN = 0; ! records 0:N, where n = 2**p - 1
EXTERNALINTEGER INVOC; ! >= 0
EXTERNALINTEGER LOG ACTION
EXTERNALINTEGER OUTPAD
EXTERNALINTEGER OWNIND
EXTERNALINTEGER PAGEMON
EXTERNALINTEGER PROCESS
EXTERNALINTEGER PROCFSYS = -1
EXTERNALINTEGER PROC1 LNB = 0; ! used in PROCESS1
EXTERNALINTEGER SAINDAD
EXTERNALINTEGER SCTIAD
EXTERNALINTEGER SELECTED FSYS
EXTERNALINTEGER SEMADDRHELD = 0
EXTERNALINTEGER SEMANOHELD = 0
EXTERNALINTEGER SESSINSTRS = 0
EXTERNALINTEGER SESSKIC = X'0FFFFFFF'
EXTERNALINTEGER SIGMO = 0
EXTERNALINTEGER SIGOUTP0
EXTERNALINTEGER SRCE ID = 5000; ! ARBITRARY NUMBER TO INCREMENT FOR SORCE IN EACH PON AND SUSPEND
EXTERNALINTEGER SST0
EXTERNALINTEGER SUPLVN S START
EXTERNALINTEGER TAPES CLAIMED
EXTERNALINTEGER WORKBASE
EXTERNALBYTEINTEGERARRAY FSYS USECOUNT(0:99)
!
!
!
EXTERNALSTRING (23)LOUTPSTATE
EXTERNALSTRING ( 6)PROCUSER = ""
EXTERNALSTRING (18)SELECTED INDEX
EXTERNALSTRING (127)SELECTED NODE
EXTERNALSTRING (15)VSN
!
!
RECORDFORMAT C
ACF(LONGINTEGER MUSECS, INTEGER PTRNS, KINSTRS)
RECORDFORMAT C
AINFF(STRING (11)NAME, INTEGER NKB, STRING (8)DATE, STRING (6)TAPE, C
INTEGER CHAP,FLAGS); ! 40 BYTES
RECORDFORMAT C
CBTF(INTEGER DA, HALFINTEGER AMTX, BYTEINTEGER TAGS, LINK)
RECORDFORMAT C
DRF(INTEGER DR0, DR1)
RECORDFORMAT C
FHDRF(INTEGER NEXTFREEBYTE,TXTRELST,MAXBYTES,ZERO, C
SEMA,DATE,NEXTCYCLIC,READ TO)
RECORDFORMAT C
IOSTATF(INTEGER IAD, STRING (15)INTMESS, C
INTEGER INBUFLEN, OUTBUFLEN, INSTREAM, OUTSTREAM)
RECORDFORMAT C
MAGF(STRING (6)TSN, INTEGER SNO)
RECORDFORMAT C
OBJF(INTEGER NEXTFREEBYTE, CODERELST, GLARELST, LDRELST)
RECORDFORMAT C
OINFF(STRING (11) NAME,INTEGER SP12,NKB, C
BYTEINTEGER ARCH,CODES, C
CCT,OWNP,EEP,USE,CODES2,SSBYTE,FLAGS,POOL,DAYNO,SP31)
RECORDFORMAT RF(INTEGER LNB,PSR,PC,SSR,SF,IT,IC,LTB, C
XNB,B,DR0,DR1,A0,A1,A2,A3,INSTRAD,PROCDEF)
RECORDFORMAT C
SCTHDRF(INTEGER HORIZ VECTOR BOUND, SCTRELST, IDENS ARRAY RELST, C
DT STAMP, STRING (15)FIXUP DATE, INTEGER ENDF)
RECORDFORMAT C
SCTIF(INTEGER DR0, DR1); ! horizontal, I-vector, format
RECORDFORMAT C
SCTJF(INTEGER TYPE, ACR, DRDR0, DRDR1); ! vertical, J-vector, format
RECORDFORMAT C
SPOOF(INTEGER VSN, FSYS, STRING (6)USER, SPARE1,
INTEGER IDENT,KINSTRS,STRING (31) JOB DOC FILE,
STRING (15)JOBNAME,
INTEGER PRIORITY, DECKS, DRIVES, OUTPUT LIMIT, DAPSECS,
INTEGER OUT, STRING (15)OUTNAME, INTEGER DAP NO)
!
! OUT: 0, 1 to a devcie
! 2, 3 to a file
! 4 to be destroyed
! OUTNAME name of queue or file
RECORDFORMAT C
STE(INTEGER APFLIM, USERA)
INCLUDE "PD22S_C03FORMATS"
ROUTINESPEC COMMS CLOSEDOWN
INTEGERFNSPEC NEWAFIND2(INTEGER AFINDAD, STRINGNAME FILE,
STRING (11)DATE, INTEGER TYPE)
INTEGERFNSPEC NEWAINDA(STRING (6)USER, INTEGER FSYS,
INTEGERNAME AFINDAD)
EXTERNALINTEGERFNSPEC NEWFILEPERM(INTEGER FINDAD,
RECORD (FDF)NAME FD, STRING (6)USER)
EXTERNALINTEGERFNSPEC NEWFIND(INTEGER FINDAD, DA,
STRINGNAME FILE)
EXTERNALINTEGERFNSPEC SETFILEINDEX(STRING (6)USER, STRING (11)NAME,
INTEGER FSYS, SIZE, NPD, NFD, FINDAD)
!
!
!
!
!
!
!
INTEGERFNSPEC C
APP(INTEGERNAME SEMA)
EXTERNALINTEGERFNSPEC C
AV(INTEGER FSYS, TYPE)
ROUTINESPEC C
AVV(INTEGERNAME SEMA)
EXTERNALINTEGERFNSPEC C
BAD PAGE(INTEGER TYPE, FSYS, BITNO)
EXTERNALINTEGERFNSPEC C
CONSEG(STRING (31)FILE, INTEGER FSYS, INTEGERNAME GAP)
EXTERNALROUTINESPEC C
DAP INTERFACE(INTEGER ACT)
EXTERNALROUTINESPEC C
DCHAIN(INTEGER SEG,DSTRY)
EXTERNALINTEGERFNSPEC C
DCHSIZE(STRING (6)USER, STRING (11)FILE, INTEGER FSYS, NEWKB)
EXTERNALINTEGERFNSPEC C
DCONNECTI(STRING (31)FULL, INTEGER FSYS, MODE, APF, C
INTEGERNAME SEG,GAP)
EXTERNALINTEGERFNSPEC C
DCREATEF(STRING (31)FULL, INTEGER FSYS, NKB, ALLOC, LEAVE, C
INTEGERNAME DA)
EXTERNALINTEGERFNSPEC C
DDAYNUMBER
INTEGERFNSPEC C
DDELAY(INTEGER N)
EXTERNALINTEGERFNSPEC C
DDESTROYF(STRING (31)FULL, INTEGER FSYS, DEALLOC)
EXTERNALINTEGERFNSPEC C
DDISCONNECTI(STRING (31)FULL, INTEGER FSYS, LO)
EXTERNALROUTINESPEC C
DDUMP(INTEGER A,B,C,D)
EXTERNALROUTINESPEC C
DERR2(STRING (31) S,INTEGER FN, ERR)
INTEGERFNSPEC C
DISABLE STREAM(INTEGERNAME CURSOR, INTEGER STREAM, REASON)
EXTERNALINTEGERFNSPEC C
DISCSEG CONNECT(INTEGER FSYS,SITE,SEG,APF,EPGS,FLAGS)
INTEGERFNSPEC C
DMESSAGE2(STRING (255)USER, INTEGERNAME LEN, INTEGER ACT, FSYS, INVOC, ADR)
EXTERNALINTEGERFNSPEC C
DMON(STRING (255)S)
EXTERNALROUTINESPEC C
DOPERR(STRING (15)TXT,INTEGER FN,RES)
EXTERNALROUTINESPEC C
DOPER2(STRING (255)S)
ROUTINESPEC C
DOUTI(RECORD (PARMF)NAME P)
INTEGERFNSPEC C
DPON3(STRING (6)USER, RECORD (PARMF)NAME P, INTEGER INVOC, MSGTYPE, OUTNO)
ROUTINESPEC C
DRESUME(INTEGER LNB, PC, ADR18)
INTEGERFNSPEC C
DSFI(STRING (6)USER, INTEGER FSYS, TYPE, SET, ADR)
EXTERNALROUTINESPEC C
DSTOP(INTEGER REASON)
INTEGERFNSPEC C
DTRANSFER(STRING (31)USER1, USER2, FILE1, FILE2, INTEGER FSYS1, FSYS2, TYPE)
EXTERNALROUTINESPEC C
EMPTY DVM
EXTERNALINTEGERFNSPEC C
EQUAL(STRINGNAME NAME1, NAME2)
INTEGERFNSPEC C
FILE INDEX PERM(STRING (31)INDEX, INTEGER FSYS)
EXTERNALROUTINESPEC C
FILL(INTEGER LENGTH, FROM, FILLER)
EXTERNALROUTINESPEC C
FILL STACK ENTS(INTEGER INDAD, STRING (3)SUFF)
EXTERNALINTEGERFNSPEC C
FINDA(STRING (31)INDEX, INTEGERNAME FSYS, FINDAD, INTEGER TYPE)
EXTERNALINTEGERFNSPEC C
FUNDS(INTEGERNAME GPINDAD,INTEGER INDAD)
EXTERNALINTEGERFNSPEC C
GETIC
EXTERNALROUTINESPEC C
GIVEAPF(INTEGERNAME SAPF, NOTDRUM, SLAVEBIT, INTEGER SEG)
EXTERNALINTEGERFNSPEC C
HINDA(STRING (6)USER, INTEGERNAME FSYS, INDAD, INTEGER TYPE)
EXTERNALSTRINGFNSPEC C
HTOS(INTEGER I, PL)
EXTERNALROUTINESPEC C
INIT CBT
EXTERNALINTEGERFNSPEC C
IN2(INTEGER FN)
EXTERNALSTRINGFNSPEC C
ITOS(INTEGER I)
EXTERNALROUTINESPEC C
IUPDATE(INTEGER MODE, NEWCOUNT)
EXTERNALINTEGERFNSPEC C
MAP FILE INDEX(STRINGNAME INDEX, INTEGERNAME FSYS, FINDAD, STRING (31)TXT)
EXTERNALROUTINESPEC C
MOVE(INTEGER LEN, FROM, TO)
EXTERNALROUTINESPEC C
NCODE(INTEGER PC)
EXTERNALINTEGERFNSPEC C
OUT(INTEGER FLAG, STRING (63)TEMPLATE)
EXTERNALINTEGERFNSPEC C
PACKDT
EXTERNALINTEGERFNSPEC C
PP(INTEGER SEMADDR,SEMANO,STRING (63)S)
EXTERNALROUTINESPEC C
PREC(STRING (255)S, RECORD (PARMF)NAME P, INTEGER N)
EXTERNALROUTINESPEC C
PRHEX(INTEGER I)
EXTERNALROUTINESPEC C
PRINTMP(INTEGER SEG1,SEG2)
EXTERNALROUTINESPEC C
PROCESS1(INTEGER A, B)
EXTERNALINTEGERFNSPEC C
SCONNECT(INTEGER SEG,STARTP,LEN,CALLAPF,NEWCOPY,NOTDRUM,NOTSLAVED,FS)
EXTERNALROUTINESPEC C
SETSTOP
EXTERNALINTEGERFNSPEC C
SHOW USECOUNT(INTEGER FSYS, SOURCE, CNSL)
EXTERNALINTEGERFNSPEC C
SST(INTEGER N)
EXTERNALINTEGERFNSPEC C
STOI(STRING (255)S)
EXTERNALINTEGERFNSPEC C
STRING TO FILE(INTEGER LEN, ADR, FAD)
EXTERNALINTEGERFNSPEC C
SYSAD(INTEGER KEY, FSYS)
EXTERNALINTEGERFNSPEC C
SYSBASE(INTEGERNAME SYSTEM START, INTEGER FSYS)
EXTERNALINTEGERFNSPEC C
VAL(INTEGER ADR,LEN,WR,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)
!
OWNSTRING (18)SINDEX
OWNINTEGER SFSYS, SRES, SFINDAD
OWNBYTEINTEGERARRAY DEFHOTTOP(0:383); ! 16*24
OWNINTEGER DIRSITE
OWNINTEGER UINHAD = -1
OWNINTEGER ACALLDR0 = -1
OWNINTEGER ACALLDR1 = -1
OWNINTEGER ACALLXNB = -1
OWNINTEGER ACALLPSR = -1
OWNINTEGER CALLDR0 = 0
OWNINTEGER CALLDR1 = 0
OWNINTEGER CALLXNB = 0
OWNINTEGER CALLPSR = X'00F00000'; ! DEFAULT UNTIL PRIME CONTINGENCY CALLED
OWNINTEGER ONTRAP = 0
OWNINTEGER VSERR = 0
OWNINTEGER RESUMEWAIT = 0
OWNINTEGER RESUMESTACK = 0
!
EXTERNALRECORD (FDF)LAST FD; ! LAST FD FOUND
EXTERNALRECORD (PARMF)LOUTP; ! LAST RECORD OUTD
!
CONSTRECORD (UINFF)NAME UINF = 9<<18
!
OWNRECORD (RF)RESUMEREGS
OWNRECORD (PARMF)SAVE DIROUTP
!
!
OWNRECORD (IOSTATF)NAME IOSTAT
!
!
OWNINTEGER INBUFA,INBUFLEN,OUTBUFA,OUTBUFLEN
OWNINTEGERARRAY ENABLED(0:1)
OWNRECORD (CBTF)ARRAYFORMAT CBTAF(0:512)
OWNRECORD (CBTF)ARRAYNAME CBTA
OWNRECORD (STE)ARRAYFORMAT STF(0:127)
OWNRECORD (STE)ARRAYNAME ST
!
CONSTINTEGER TOPENT = 3
OWNRECORD (MAGF)ARRAY CLAIMED(0:3)
EXTRINSICRECORD (DRF)ARRAY DRS LOCKED(0:2)
!
!
!-----------------------------------------------------------------------
!
EXTERNALROUTINE UCTRANSLATE(INTEGER ADR, LEN)
INTEGER A
A = INTEGER(X'80C0008F') + 512
*LDTB_X'18000100'
*LDA_A
*CYD_0
*LDA_ADR
*LDB_LEN
*TTR_L =DR
END ; ! OF UCTRANSLATE
!
!-----------------------------------------------------------------------
!
EXTERNALINTEGERFN S11OK(STRINGNAME FILE)
INTEGER J,CH, L
!
! RESULT = 0 GOOD
! 18 BAD
!
L = LENGTH(FILE)
RESULT = 18 UNLESS 0 < L < 12
! UCTRANSLATE(ADDR(FILE)+1, L); ! retain case of letters
CYCLE J=1,1,L
CH=BYTEINTEGER(ADDR(FILE)+J)
RESULT = 18 UNLESS C
CH = '#' ORC
'A' <= CH <= 'Z' ORC
'a' <= CH <= 'z' ORC
'0' <= CH <= '9'
REPEAT
RESULT = 0
END ; ! S11OK
!
!-----------------------------------------------------------------------
!
EXTERNALINTEGERFN UNOK(STRINGNAME USER)
INTEGER J, CH
RESULT = 11 UNLESS LENGTH(USER) = 6
UCTRANSLATE(ADDR(USER)+1, 6)
CYCLE J = 1, 1, 6
CH = CHARNO(USER, J)
RESULT = 11 UNLESS 'A' <= CH <= 'Z' OR '0' <= CH <= '9'
REPEAT
RESULT = 0
END ; ! UNOK
!
!-----------------------------------------------------------------------
!
EXTERNALINTEGERFN UIO(STRING (31)USER, STRINGNAME UNAME, INAME, INDEX)
!
! checks, UCTs and resolves USER, supplies PROCUSER as default
!
INTEGER J
J = 0
INAME = ""
UNAME = USER UNLESS USER -> UNAME . (ISEP) . INAME
!
IF UNAME = "" C
THEN UNAME = PROCUSER C
ELSE START
J = UNOK(UNAME)
-> OUT UNLESS J = 0
FINISH
INDEX = UNAME
!
UNLESS INAME = "" START
J = S11OK(INAME)
INDEX = INDEX . ISEP . INAME
FINISH
OUT:
RESULT = J
END ; ! UIO
!
!-----------------------------------------------------------------------
!
EXTERNALINTEGERFN UFO(STRING (31)USER, FILE, STRINGNAME UNAME, INAME, FNAME, INDEX, FULL)
!
! Combines and then resolves USER and FILE into
! user [:index] and file
! does UC translate and supplies PROCUSER as default user
!
INTEGER J
STRING (255)W
IF FILE -> W . (".") . FNAME C
THEN W = USER . W C
ELSE W = USER AND FNAME = FILE
!
J = UIO(W, UNAME, INAME, INDEX)
-> OUT UNLESS J = 0
!
J = S11OK(FNAME)
FULL = INDEX . "." . FNAME
OUT:
RESULT = J
END ; ! UFO
!
!-----------------------------------------------------------------------
!
EXTERNALINTEGERFN CREATE AND CONNECT(STRING (31)FULL,
INTEGER FSYS, NKB, ALLOC, MODE, APF, INTEGERNAME SEG, GAP)
INTEGER J, DA
J = DCREATEF(FULL, FSYS, NKB, ALLOC, LEAVE, DA)
RESULT = J IF 0 # J # 16
J = DCONNECTI(FULL, FSYS, MODE, APF, SEG, GAP)
J = 0 IF J = 34
RESULT = J
END ; ! CREATE AND CONNECT
!
!-----------------------------------------------------------------------
!
INCLUDE "PD22S_B06MESS"
INCLUDE "PD22S_B09IO"
EXTERNALINTEGERFN ASYNC MSG(STRING (6) USER,
INTEGER INVOC,DACT,P1,P3)
RECORD (PARMF)NAME P
LONGLONGREAL LONGLONGREAL
INTEGER LRAD,J,CH
LRAD=ADDR(LONGLONGREAL)
CYCLE J=0,1,15
IF J<=6 THEN CH=BYTEINTEGER(ADDR(USER)+J) ELSE CH=0
IF J=7 THEN CH=INVOC; ! incarnation number
! for sync1 msgs, RH end of ACC to be 1
! SYNC2 2
! ASYNC 3
CH=3 IF J=15; ! async msg
BYTEINTEGER(LRAD+J)<-CH
REPEAT
P==RECORD(OUTPAD)
P=0
P_DEST=X'FFFF0000' ! DACT
P_P1=P1
P_P3=P3
*LSQ_LONGLONGREAL
*OUT_6; ! pon and continue
IF P_DEST=0 THEN RESULT =61; ! process not present
RESULT =0
END ; ! ASYNC MSG
!
!-----------------------------------------------------------------------
!
EXTERNALROUTINE CYCINIT(INTEGER FAD, MAXBYTES)
RECORD (FHDRF)NAME H
H == RECORD(FAD)
H = 0
H_NEXTFREEBYTE = 32
H_TXTRELST = 32
H_NEXTCYCLIC = 32
H_MAXBYTES = MAXBYTES
H_READ TO = 32
END ; ! CYCINIT
!
!-----------------------------------------------------------------------
!
EXTERNALINTEGERFN TXTMESS(STRING (6)USER, RECORD (PARMF)NAME P,
INTEGER SYNC, INVOC, TXTLEN, TXTAD, FSYS, SACT)
!
!
! Used by :
! DMESSAGE
! DSPOOL
! BROADCAST and D/MSG
! SPOOL LOGFILE (D/PRINT)
!
!
! SYNC determines message type
! SACT = 0: do a "DOUT" (and wait)
! # 0: do a "DPON" (and continue). Used by SPOOL LOGFILE and CHECKSTART.
INTEGER SEG,FAD,GAP,I,J,INDAD,DIR ACR, PONTYPE
INTEGER NKB, ALLOC, MODE, APF
INTEGER SEMADR, SEMANO, TELLREJ
STRING (6)FROM
STRING (31)FULL
RECORD (FHDRF)NAME CYCH
RECORD (FF)NAME F
RECORD (HF)NAME H
*LSS_(1); ! PSR
*ST_J
DIR ACR=(J>>20)&15
!
FULL = USER . ".#MSG"
NKB = 4
ALLOC = X'0B000051'; ! EEP = 11, zero
MODE = WRSH
APF = DIRACR << 4 ! 15
SEG = 0
GAP = 0
J = CREATE AND CONNECT(FULL, FSYS, NKB, ALLOC, C
MODE, APF, SEG, GAP)
RESULT = J UNLESS J = 0
!
FAD = SEG << 18
CYCH == RECORD(FAD)
!
J = HINDA(USER, FSYS, INDAD, 0)
RESULT = J UNLESS J = 0
!
H == RECORD(INDAD)
F == RECORD(INDAD + 512)
TELLREJ = H_TELLREJ
SEMADR = ADDR(H_MSGSEMA)
SEMANO = (1<<31) ! F_SEMANO
!
IF TELLREJ & 1 > 0 AND DTRYING = 0 C
THEN RESULT =48; ! destination user requires TELL messages to be
! rejected (except from executive processes).
! Top bit in SEMANO is set:
! 1 to give a semano different from the index semano, to be used
! conventionally for the #MSG file, and
! 2 to indicate 'not-express' to the semaphore routine, PP.
! Arguably we could use (say) the disc address of the file page (i.e.
! the page containing the sema), but then we'd need a call of DGETDA.
J = PP(SEMADR, SEMANO,"TXTMESS: ".USER)
-> OUT UNLESS J = 0
!
CYCLE {double up any rec seps in text}
I = 0
WHILE I < TXTLEN CYCLE
EXIT IF BYTEINTEGER(TXTAD + I) = REC SEP
I = I + 1
REPEAT
!
J = STRING TO FILE(I, TXTAD, FAD) IF I > 0
EXIT UNLESS I < TXTLEN
!
J = (REC SEP << 8) ! REC SEP
J = STRING TO FILE(2, ADDR(J)+2, FAD)
TXTAD = TXTAD + I + 1
TXTLEN = TXTLEN - I - 1
REPEAT
!
J = REC SEP << 8
J = STRING TO FILE(2, ADDR(J)+2, FAD) {terminate with RS + null}
! now see how the message is to be signalled.
! Send an async (txt) msg if SYNC is zero, else a sync1-type message to P_DEST
SRCE ID = (SRCE ID + 1) & X'FFFF'
P_SRCE = SACT
!
FROM = PROCUSER
MOVE(6, TXTAD + 2, ADDR(FROM) + 1) IF SYNC = 2; ! from DSUBMIT
P_S = FROM
!
P_P3 = SYNC
P_P4 = SACT
STRING(ADDR(P_P5)) = USER; ! these 3 items for info only
!
!
!
! IF SACT=0 ITS FROM DSPOOL THE IDEA IS TO HOLD
! THE MSG SEMA FOR A SHORT A TIME AS POSSIBLE
! IT DOES NOT SEEM NECESSARY TO KEEP IT UNTIL
! A REPLY HAS BEEN RECEIVED
IF SYNC = 0 C
THEN J = ASYNC MSG(USER, INVOC, TXT DACT, 0, 0) C
ELSE START
PON TYPE = PON AND CONTINUE; ! ON SYNC1
PON TYPE = 8 AND P_SRCE=SRCE ID IF SACT = 0; ! PON AND CONTINUE ON SYNC2
J = DPON3I(USER, P, INVOC, SYNC1 TYPE, PON TYPE)
FINISH
VV(SEMADR, SEMANO)
IF J = 0 AND SACT = 0 # SYNC START ; ! J # 0 means 61 - process N/A, so doing a DPOFF causes a hang
DPOFF2(P, SRCE ID)
J = P_P1
FINISH
!
OUT:
I = DDISCONNECTI(FULL, FSYS, 1)
RESULT =J
END ; ! TXTMESS
!
!-----------------------------------------------------------------------
!
EXTERNALROUTINE ATTU(STRINGNAME S)
STRING (255) T
T="**".PROCUSER.TOSTRING(7)." ".DATE." ".TIME
LENGTH(T)=LENGTH(T)-3
S<-T.": ".S
END ; ! ATTU
!
!-----------------------------------------------------------------------
!
INTEGERFN RDCIRC(INTEGERNAME LEN,INTEGER FA1,ADR)
! reads from circular file FA1 from "read to" to
! next record separator or to "NEXTCYCLIC". resets
! "read to" according to what's taken.
! at DR, setting LEN to be N. of bytes moved
! places data (so far as possible) into file FA2, from "NEXTFREEBYTE"
! up to a max of "MAXBYTES".
!
INTEGER NEXT1,RELST1,MAXB1,ZER1,NEXTCYC,READTO,CH,TOP,LAST,ADR0
RECORD (FHDRF)NAME H1
H1 == RECORD(FA1)
CYCINIT(FA1, 4096) IF H1_MAXBYTES = 0
NEXT1 = H1_NEXTFREEBYTE
RELST1 = H1_TXTRELST
MAXB1 = H1_MAXBYTES
ZER1 = H1_ZERO
NEXTCYC = H1_NEXTCYCLIC
READTO = H1_READTO
!
RESULT = 1 UNLESS 16 <= RELST1 <= MAXB1 ANDC
RELST1 <= NEXT1 <= MAXB1 ANDC
(READTO=0 OR RELST1 <= READTO <= MAXB1) ANDC
RELST1 <= NEXTCYC <= MAXB1 ANDC
ZER1 = 0
!
H1_READTO = RELST1 IF READTO = 0 AND RELST1 # NEXT1
TOP = ADR + LEN
ADR0 = ADR
LAST = -1
WHILE H1_READTO # NEXTCYC AND ADR < TOP CYCLE
CH = BYTEINTEGER(FA1+H1_READTO)
H1_READTO = H1_READTO + 1
H1_READTO = RELST1 IF H1_READ TO >= MAXB1
!
IF LAST = REC SEP START
EXIT IF CH # REC SEP
LAST = -1
FINISH ELSE START
LAST = CH
FINISH
BYTEINTEGER(ADR) = CH
ADR = ADR + 1 UNLESS LAST = REC SEP
REPEAT
LEN = ADR - ADR0
RESULT = 0
END ; ! RDCIRC
!
!-----------------------------------------------------------------------
!
EXTERNALROUTINE NOT SO FAST
INTEGER J
OWNINTEGER INCREASING = 1
RETURN UNLESS DTRYING = 0
J = DDELAY(INCREASING)
INCREASING = INCREASING + 4
END ; ! NOT SO FAST
!
!-----------------------------------------------------------------------
!
INTEGERFN DSPOOLBODY(STRING (6)TO, RECORD (PARMF)NAME P, INTEGER LEN, ADR)
INTEGER L, FLAG
BYTEINTEGERARRAY MSG(0:2050)
FLAG = 45
- > OUT IF VAL(ADR,LEN,0,0) = 0
!
FLAG = 8
-> OUT IF LEN > 2000; ! relatively arb, but to keep it within an EPAGE (size of #MSG file)
!
MSG(0) = 0
ATTU(STRING(ADDR(MSG(0))))
L = MSG(0)
MOVE(LEN, ADR, ADDR(MSG(L+1)))
P_DEST = X'FFFF0016'
FLAG = TXTMESS(TO, P, 1, 0, L+LEN, ADDR(MSG(1)), -1, 0); ! 1=SYNC SIG,0=INVOC,-1=FSYS
OUT:
RESULT = FLAG
END ; ! DSPOOLBODY
!
!-----------------------------------------------------------------------
!
EXTERNALROUTINE FILE FOR HOTTOP(INTEGER INVOC)
INTEGER J, SEG, GAP, DIRWRITEAPF
STRING (31)FULL
*LSS_(LNB +1)
*ST_J
J = (J & X'00F00000') >> 16
DIRWRITEAPF = J ! 15
!
FULL = "#HOTTOP"
FULL = "VOLUMS.#DHOTTOP" IF PROCUSER = "DIRECT"
FULL = FULL . ITOS(INVOC)
!
SEG = 11
GAP = 0
J = CREATE AND CONNECT(FULL, -1, 4, (3<<24)+64+16+8+1, C
3, DIRWRITEAPF, SEG, GAP); ! EEP=3, ZERO, VTEMP & ALLOC
!
IF J = 0 START
HOTTOPA = SEG << 18 + 32
HOTTOPN = 127
WRS("HOTTOP FILE SETUP")
FINISH
END ; ! FILE FOR HOTTOP
!
!-----------------------------------------------------------------------
!
ROUTINE ENTER SUBSYSTEM(INTEGER CODEADR, SPACE, SSACR)
INTEGER DISPLAD, STAKAD
*STLN_DISPLAD; ! Now enter the Basefile
STAKAD = (DISPLAD & X'FFFC0000') + SPACE; ! 'space' bytes up from start of seg
INTEGER(STAKAD+20) = UINF_SCT DATE
INTEGER(STAKAD+24) = ADDR(UINF)
INTEGER(DISPLAD) = STAKAD
INTEGER(DISPLAD+4) = (INTEGER(DISPLAD+4)&X'FF0BFFFF') ! (SSACR << 20)
!
IF PROCUSER = "ENGINR" START
INTEGER(DISPLAD+4) = INTEGER(DISPLAD+4) ! X'00040000'; ! set priv bit
*LSS_(3); ! PICK UP SSR
*OR_X'01800000'; ! DGW AND ISR
*ST_(3); ! PUT BACK WITH DGW AND ISR BITS SET
FINISH
!
*LSS_(3)
*AND_X'FFBFFFFF'
*ST_(3); ! Temp, but has been there for many a yonk.
!
INTEGER(DISPLAD+8) = CODEADR
INTEGER(STAKAD) = STAKAD
*EXIT_0
END ; ! ENTER SUBSYSTEM
!
!-----------------------------------------------------------------------
!
ROUTINE PREPARE TO ENTER(INTEGER CODEADR, SSACR)
CONSTINTEGER SPACE = X'6000'
BYTEINTEGERARRAY DUMMY(1 : SPACE)
ENTER SUBSYSTEM(CODEADR, SPACE, SSACR)
END ; ! PREPARE TO ENTER
!
!-----------------------------------------------------------------------
!
EXTERNALROUTINE DIRECTOR(RECORD (PARMF)NAME P)
INTEGER J,K,BASEFAD,PFSYS,BGLASEG,SSACR,ACR HERE
INTEGER DIRDISC,GAP,WKSEG,SITE,SSAPF,DIR RW APF
INTEGER DIR WRITE APF
INTEGER SCT REL EPG,SCT BLOCKAD,TRIED BASEF, TRIED DEF SS
INTEGER CELL, DA
STRING (3)SSUFF
STRING (8) USER
STRING (255) S
STRING (31) BASEFILE,FILE
STRING (14)DIRLOG
!
RECORD (DIRCOMF)NAME DIRCOM
RECORD (SCTHDRF)NAME SCTHDR
RECORD (SCTIF)ARRAYFORMAT SCTIAF(0:TOP I VALUE)
RECORD (SCTIF)ARRAYNAME SCTI
!
! Mac wants an SSN+1 integer to contain session kistructions (this is of
! course different from AICREVS).
! USE LAST WORD OF ACCTS RECORD
!
!
INTEGER WKGAP, ACOUNT, BITS
RECORD (LOGFHDF)NAME LOGH
RECORD (PROCDATF)ARRAYNAME PROCLIST
CONSTSTRING (14)FULL = "VOLUMS.#LOGMAP"
CONSTSTRING (7)ARRAY SITEN(1:2) = "SUBSYS", "STUDENT"
!
RECORD (HF)NAME NIH
RECORD (OBJF)NAME H,HC
RECORD (PARMF)NAME SIGP
RECORD (ACF)NAME ACCTS
!
! Initial values in
! DIROUTP RECORD : SIGOUTP RECORD :
! DEST : S pare" LST LENGTH (NO. OF LOCAL SEGMENTS)
! SRCE : EPAGE SIZE<<16 ! MAX "CBT" BLKSI (EPAGES) ADDR(SST(0))
! P1 : PROC NO ADDR(CBTASL)
! P2 : USERNAME STRING ADDR(CBTA(0))
! P3 : - DITTO - ADDR(ACCT RECORD)
! P4 : ADDR(SIGOUTP) ADDR(IC REVOLUTIONS)
! P5 : ADDR(SCTI(0)) (THE HORIZONTAL VECTOR) ADDR(IOSTATUS)
! P6 : DACT ON ASYNC SNO ON WHICH FE HL CTL MSGS ARE TO ARRIVE
RECORD (SPOOF)NAME SPOOH
!
!
!-----------------------------------------------------------------------
!
ROUTINE FAIL(STRING (13)S, INTEGER RES)
!
! With the new FE software (Sept 81), this routine must not be called after
! the process' i/o comms streams have been connected. The FE can accept these
! messages for the terminal on DIRECT's output stream only while the process'
! i/o streams are not connected. Also, this routine must not be called before
! the UINF file has been connected!
!
RECORD (PARMF)P
INTEGER J
P = 0
P_P2 = UINF_STREAM ID
!
IF UINF_REASON = INTER START
P_DEST = X'FFFF0000' ! (UINF_PSLOT << 8) ! 18; ! PR(18) in process 1
STRING(ADDR(P_P3)) = S
P_P6 = RES
J = DPON3I("DIRECT", P, 0, SYNC1 TYPE, PON AND CONTINUE)
FINISH
DOPER2("LOGON " . S . ITOS(RES))
DSTOP(21)
END ; ! FAIL
!
!-----------------------------------------------------------------------
!
DIRLOG = "VOLUMS.#DIRLOG"
DIRLEVEL = 0
FACILITYA = 0
DIROUTP0=ADDR(P)
OUTPAD=DIROUTP0
! EPAGE SIZE=P_SRCE>>16
BLKSI=P_SRCE&X'FFFF'
PROCESS=P_P1
USER=STRING(ADDR(P_P2))
PROCUSER=USER
INVOC=P_P3&255
SIGOUTP0=P_P4
SCTIAD=P_P5
! ASYNC DACT=P_P6
SIGP==RECORD(SIGOUTP0)
HISEG=SIGP_DEST - 1
SST0=SIGP_SRCE
CBTASL0=SIGP_P1
CBTA0=SIGP_P2
ACCTSA=SIGP_P3
ACCTS==RECORD(ACCTSA)
AREVS=SIGP_P4
AIOSTAT=SIGP_P5
AEXPRESS = SIGP_P6; ! ADDR(EXPRESS)
!
*LSS_(LNB +1)
*ST_ACR HERE
ACR HERE = (ACR HERE & X'00F00000') >> 20
DIR RW APF = (ACR HERE << 4) ! ACR HERE
DIR WRITE APF = (ACR HERE << 4) ! X'F'
!
CBTA == ARRAY(CBTA0, CBTAF)
ST == ARRAY(0, STF)
INIT CBT
HOTTOPA = ADDR(DEFHOTTOP(0))
HOTTOPN = 15
!
PROCFSYS = CBTA(SST(3))_DA >> 24
J = CBTA(SST(2))_DA
DIRSITE = J << 8 >> 8
DDVSN = (J - X'200') >> 6
DIRDISC = DDVSN >> 18
HC == RECORD(DIRCODE SEG << 18)
LOG ACTION = DT ! LOG
!
J = SYSBASE(SUPLVN S START, COM_SUPLVN)
DOPER2("SYSBASE fails") UNLESS J = 0
!
!
!------------------------------ CONNECT SCTABLE -------------------------------
!
SCT REL EPG = HC_LDRELST >> 12
FILE = "SCT"
J = DISCSEGCONNECT(DIRDISC,DIRSITE+SCTRELEPG,SCTABSEG,X'00F',
(64 - SCT REL EPG),32)
-> STOP UNLESS J = 0
!
SCT BLOCK AD = (SCTABSEG << 18) + (HC_LDRELST & 4095)
SCT HDR == RECORD(SCT BLOCK AD)
SCTI == ARRAY(SCTIAD, SCTIAF)
SCTI(0) = 0
SCTI(2) = 0
SCTI(1)_DR0 = VEC128 ! SCT HDR_HORIZ VECTOR BOUND; ! TOP J VALUE, PLUS ONE
SCTI(1)_DR1 = SCT BLOCK AD + SCT HDR_SCT RELST
! THERE ARE TWO PAGES OF SCT + IDEN/I,J-VALUES PRECEDING GLAP (AND PG-ALIGNED)
!
! GET DATE AND TIME OF DIRECTOR FIXUP OUT OF SCTABLE HEADER
VSN = SCT HDR_FIXUP DATE
!
!----------------------------------------------------------------------
!
IF USER = "DIRECT" OR USER = "FCHECK" START
! LCSTK 4 DSTK 51 UINF 1 DGLA 4 SIGSTK 4
CELL = SST(4)
CBTA(CELL)_LINK = 0
SITE = CBTA(CELL)_DA; ! address of director stack
!
IF USER = "DIRECT" START
WORKBASE = (((SITE<<8)>>8) + 63) & (-64)
FINISH
!
J = SCONNECT(4, SITE+32, 19, DIR RW APF, 1, 0, 0, 128); ! newcopy,drum,slaved,continuation
DOPERR("DIRECTOR STK", 2, J) UNLESS J = 0
!
J = SCONNECT(9, SITE+51, 1, DIR RW APF, 1, 0, 0, 0)
DOPERR("DIR UINF", 2, J) UNLESS J = 0
!
J = SCONNECT(6, SITE+56, 4, DIR RW APF, 1, 1, 0, 0); ! newcopy,notdrum,slaved
DOPER2("SIG STK FLAG ".ITOS(J)) UNLESS J = 0
!
PROCESS1(0, 0)
FINISH
!
!-------------------------------------------------------------------------------
!
FILE = "HINDA"
PFSYS = PROCFSYS
J = HINDA(USER, PFSYS, OWNIND, 0)
-> STOP UNLESS J = 0
IUPDATE(-2, 0); ! init index accounting entries for session
!
SSUFF = ITOS(INVOC)
!
WKSEG = 14
GAP = 0
K = DCONNECTI(DIRLOG, -1, WRSH,
(DIR WRITE APF>>4<<4)!(DEFAULT SSACR-1), WKSEG, GAP)
IF K = 0 START
DIRLOGAD = WKSEG << 18
LOG ACTION = DT ! DLOG
FINISH ELSE DOPERR("DIRLOG", 2, K)
!
NIH == RECORD(OWNIND)
DTRYING = NIH_TRYING
DIRMON = NIH_DIRMON
NIH_DIRMON = 0
!
SSACR = NIH_ACR
SSACR = DEFAULT SSACR UNLESS 0 < SSACR <= 15
!
FILE FOR HOTTOP(INVOC) IF PROCUSER = "SPOOLR"
!
!
!-------------------- CONNECT UINF FILE -----------------------
!
FILE = "#UINFI".SSUFF
WKSEG = ADDR(UINF) >> 18
GAP = 0
J = DCONNECTI(FILE, PFSYS, WRSH, DIR WRITE APF, WKSEG, GAP)
-> STOP UNLESS J = 0
IUPDATE(-3, 0); ! allow entries to the iupdate file now UINF seg connected
! UINF now available
UINF_ASYNC DEST = (COM_ASYNC DEST + PROCESS) << 16
UINF_SYNC1 DEST = (COM_SYNC1 DEST + PROCESS) << 16
UINF_SYNC2 DEST = (COM_SYNC2 DEST + PROCESS) << 16
DIRCOM == RECORD(SYSAD(DIRCOMKEY, -1))
!
!--------------------------------- Batch --------------------------------
!
IF UINF_REASON = BATCH START
FILE = "SPOOLR." . UINF_SPOOLRFILE
WKSEG = 0
GAP = 0
J = DCONNECTI(FILE, PROCFSYS, 1, DIRWRITEAPF, WKSEG, GAP)
-> STOP UNLESS J = 0
SPOOH == RECORD(WKSEG << 18)
! Note that no-one is currently putting any limit on this value,
! i.e. the user can make it as large as he likes. Decision needed sometime.
SESSKIC = SPOOH_KINSTRS
WRSNT("Seconds=", SESSKIC//COM_KINSTRS, 5)
!
UINF_JOBDOCFILE = SPOOH_JOB DOC FILE
UINF_JOBNAME = SPOOH_JOBNAME
UINF_PRIORITY = SPOOH_PRIORITY
UINF_DECKS = SPOOH_DECKS
WRSNT(",Decks=", UINF_DECKS, 5) UNLESS UINF_DECKS = 0
UINF_DRIVES = SPOOH_DRIVES
WRSNT(",Drives=", UINF_DRIVES, 5) UNLESS UINF_DRIVES = 0
UINF_OUTPUT LIMIT = SPOOH_OUTPUT LIMIT
!
UINF_DAPSECS = SPOOH_DAPSECS
UINF_DAP NO = SPOOH_DAP NO
UINF_DAPINSTRS = 0
DAP INTERFACE(2) IF UINF_DAPSECS > 0; ! its a DAP job
!
UINF_OUT = SPOOH_OUT
UINF_OUTNAME = SPOOH_OUTNAME
NEWLINE
!
J = DDISCONNECTI(FILE, PROCFSYS, 3); ! DISCONNECT AND DESTROY
FINISH
!
!-----------------------------------------------------------------------
!
FILL STACK ENTS(OWNIND, SSUFF)
!
FAIL("BAD PRIV", 0) UNLESS DTRYING & X'08080808' = 0
!
!--------------------CREATE AND CONNECT CONTINGENCY STACK (LOCAL 6) ---
!
FILE = "#SIGSTK".SSUFF
J = DCREATEF(FILE,PFSYS,32,5,6,DA); ! TEMPFI, ALLOC
FAIL(FILE, J) UNLESS J = 0 OR J = 16
DCHAIN(6, 0); ! THROW AWAY TEMP SEG 6
GAP = 0
WKSEG = 6
J = DCONNECTI(FILE,PFSYS,WR,DIRWRITEAPF,WKSEG,GAP)
FAIL(FILE, J) UNLESS J = 0
PROCESS1(0, 0) IF USER->("DIREC").S; ! testing new version of DIRECT process
!
!--------- CONNECT BASEFILE ---------
!
SITE = X'380'; ! used in calculating UINF_BASEFILE
TRIED BASEF = NO
TRIED DEF SS = NO
BITS = 0
SSAPF = X'100' ! (SSACR <<4) ! SSACR
WKSEG = BASE FILE SEG
!
UNLESS UINF_REASON = BATCH START
BASEFILE <- NIH_TESTSS
-> TRY BASEF IF BASEFILE = ""
NIH_TESTSS = ""
-> TRY CONNECT
FINISH
!
BASEFILE <- NIH_BATCHSS
-> TRY CONNECT UNLESS BASEFILE = ""
TRY BASEF:
TRIED BASEF = YES
BASEFILE <- NIH_BASEFILE
-> DEFAULT BASE IF BASEFILE = ""
TRY CONNECT:
IF BASEFILE = "#STUDENT" START
BASEFILE = DIRCOM_DEFAULT STUDENT
SITE = X'400'
-> CONNECT SITE IF BASEFILE = ""
FINISH
!
GAP = 0
J = DCONNECTI(BASEFILE, -1, EX!X'100', SSAPF, WKSEG, GAP)
IF J = 0 START
IF EXECP -> (PROCUSER) START
DOPER2(PROCUSER . ": ". BASEFILE)
FINISH
-> BASEF CONNECTED
FINISH
DOPER2( BASEFILE)
DOPERR("BASEF", 2, J)
-> TRY BASEF IF TRIED BASEF = NO
!
IF PROCUSER = "VIEWER" ORC
PROCUSER = "HORTIH" ORC
PROCUSER = "LIBRAR" C
THEN FAIL("No Service", 0)
!
DEFAULT BASE:
BASEFILE = ""
SITE = X'300' IF USER = "VOLUMS"
SITE = X'340' IF USER = "MAILER"
SITE = X'480' IF USER = "SPOOLR"
SITE = X'4C0' IF USER = "FTRANS"
!
IF SITE = X'380' AND TRIED DEF SS = NO START
TRIED DEF SS = YES
BASEFILE = DIRCOM_DEFAULT SUBSYS
-> TRY CONNECT UNLESS BASEFILE = ""
FINISH
CONNECT SITE:
K = 0
S = USER
!
IF X'380' <= SITE <= X'400' START
BITS = SITE >> 9; ! ie 1 or 2
K = 32; ! anticipate multiple use of these sites
ACOUNT = ADDR(DIRCOM_SUBSYS SITE COUNT)
ACOUNT = ACOUNT + 24 IF BITS = 2
S = SITEN(BITS)
FINISH
!
SITE = SITE + SUPLVN S START
!
J = DISCSEG CONNECT(DIRDISC, SITE, WKSEG, X'100' ! SSACR, 64, K); ! exec and read
FAIL(S, J) UNLESS J = 0
!
BASEFAD = BASEFILE SEG << 18; ! now check if more than one segment
H == RECORD(BASEFAD)
GAP = 1
IF H_NEXTFREEBYTE > X'40000' START
WKSEG = WKSEG + 1
GAP = GAP + 1
J = DISCSEG CONNECT(DIRDISC, SITE + X'40', WKSEG, X'100' ! SSACR, 64, K); ! exec and read
FAIL(S, J) UNLESS J = 0
FINISH
!
IF K = 0 START
DOPER2(PROCUSER . " on site X'" . HTOS(SITE, 3))
FINISH ELSE START
*LXN_ACOUNT
*INCT_(XNB +0)
!
FINISH
BASEF CONNECTED:
UINF_PROCNO = PROCESS; ! set up various items in UINF
UINF_MARK = 1
UINF_SESS IC LIM = SESSKIC; ! thousands of instructions
UINF_SCT BLOCK AD = SCT BLOCK AD
UINF_SCIDENSAD = SCT BLOCK AD + SCT HDR_IDENS ARRAY RELST
UINF_SCIDENS = SCT HDR_HORIZ VECTOR BOUND - 1; ! number of system call ids
UINF_AIOSTAT = AIOSTAT
UINF_SCT DATE = SCT HDR_DT STAMP
UINF_AACCT REC = ACCTSA
UINF_AIC REVS = AREVS
!
IF BASEFILE = "" START
BASEFILE = "S#DISC.SITEX" . HTOS(SITE, 3)
FINISH
!
UINF_BASEFILE = BASEFILE
UINF_HISEG = HISEG
!
WKSEG = 0
WKGAP = 0
J = DCONNECTI(FULL, -1, 11, 0, WKSEG, WKGAP)
IF J = 0 START
LOGH == RECORD(WKSEG<<18 + X'10000')
PROCLIST == LOGH_PROCLIST
PROCLIST(UINF_PSLOT)_SITE = BITS
J = DDISCONNECTI(FULL, -1, 0)
FINISH
BASEFAD = BASEFILE SEG << 18
H == RECORD(BASEFAD)
BGLASEG = BASEFILESEG + GAP
!
!--------- CREATE AND CONNECT BGLA ---------
FILE = "#BGLA".SSUFF
!
J = DDESTROYF(FILE, PFSYS, 7)
!
J = DCREATEF(FILE, PFSYS, 256, 5, 7, DA); ! TEMPFILE
FAIL(FILE, J) UNLESS J = 0
WKSEG = BGLASEG
GAP = 0
J = DCONNECTI(FILE, PFSYS, WR, SSAPF, WKSEG, GAP)
FAIL(FILE, J) UNLESS J = 0
!
!--------------------Connect Directors' monitoring file-------------------------------
!
! IF THE USER HAS HIS OWN LOGFILE,
! THIS IS USED ELSE DIRLOG, IF
! NEITHER OF THESE IS AVAILABLE
! MAINLOG IS USED. NOTE THAT
! DIRLOG IS 2 SEGMENTS LONG AND
! SEGMENT 16 MUST NOT BE OVERWRITTEN!!!!!!!
!
! Connect local logfile if it exists
S = NIH_LOGFILE
UNLESS S = "" START
J = DDISCONNECTI(DIRLOG,-1,1)
DIRLOGAD = 0
LOGACTION = DT ! LOG
WKSEG = 14
GAP = 2; ! have only allowed TWO segments
J = DCONNECTI(S,PFSYS,WRSH,SSAPF,WKSEG,GAP)
IF J = 0 START
LOG ACTION = WRTOF ! DT
FILE1AD = WKSEG << 18
WRS("NEWSESSION")
FINISH ELSE START
DERR2(S, 2, J)
WKSEG = 14
GAP = 0
J = DCONNECTI(DIRLOG, -1, WRSH,
(DIR WRITE APF>>4<<4)!(DEFAULT SSACR-1), WKSEG, GAP)
IF J = 0 START
DIRLOGAD = WKSEG << 18
LOG ACTION = DT ! DLOG
FINISH ELSE DOPERR("DIRLOG", 2, J)
FINISH
FINISH
!
!
!
!
!----------------------------------------------------------------------
!
! K = 0
! GAP = 0
! J = CREATE AND CONNECT("VOLUMS.FCOUNT", -1, 4, %C
! (3<<24) + 64 + 16 + 1, WRSH, SSAPF, %C
! K, GAP)
! %IF J = 0 %START
! FACILITYA = K << 18 + 32
! %FINISH
!
!
!
UNLESS DDVSN&3 = 0 START
J = COM_SUPVSN
WRSS("Supervisor ", STRING(ADDR(J)))
PRINTSTRING("Director VSN "); WRSN(VSN, DDVSN&3)
WRSN("Sload disc ", DDVSN>>18)
FINISH
!------------------------------- Interactive --------------------------
J = UINF_REASON
IF J = INTER OR J = NEWSTART OR J = FORK START
! Interactive startup - connect console streams
FILE = "T#IT" . SSUFF; ! clear buffer, not done at create for speed
WKSEG = 0; ! (new-copy connect)
GAP = 0
J = DCONNECTI(FILE, PFSYS,16!WR, DIRWRITEAPF, WKSEG,GAP)
FAIL(FILE, J) UNLESS J = 0
J = DDISCONNECTI(FILE, PFSYS, 0)
FAIL(FILE, J) UNLESS J = 0
!
-> MAP IF UINF_REASON = FORK; ! can connect streams only once
!
!
! The FAIL routine must not be called after this point.
! (see note in the routine)
!
K = 0
AGAIN:
J=CONNECT STREAM(0,UINF_ASYNC DEST ! 1) C
! CONNECT STREAM(1,UINF_SYNC2 DEST)
IF J#0=K START
J=DISABLE STREAM(J,0,4); ! IGNORE FLAG
J=DISABLE STREAM(J,1,4); ! IGNORE FLAG
J=DISCONNECT STREAM(0); ! IGNORE FLAG
J=DISCONNECT STREAM(1); ! IGNORE FLAG
K=1
-> AGAIN
FINISH
DOPERR("TERMINAL I/O", 2,J) UNLESS J = 0
FINISH
MAP:
IOSTAT == RECORD(AIOSTAT)
IOSTAT_INSTREAM = UINF_INSTREAM
IOSTAT_OUTSTREAM = UINF_OUTSTREAM
!
PREPARE TO ENTER(BASEFAD + H_CODERELST, SSACR)
STOP:
DOPERR(FILE, 2, J); ! catastrophic failure
DSTOP(22)
END ; ! DIRECTOR
!
!-----------------------------------------------------------------------
!
integerfn NEWCHK PERM SPACE(record (FF)name F, record (FDF)name FD)
! To be called before changing a file from "TEMP" to "PERMANENT".
! Checks whether the effect is to exceed permanent filespace limit
! (result 83). If OK, result 0.
integer NKB,PERM SPACE,MAXKB
if FD_CODES&TEMPFS=0 then result =0; ! no problem
NKB=FD_PGS << 2
PERM SPACE=F_TOTKB-F_TEMPKB
MAXKB=F_MAXKB
MAXKB=DEFAULT MAXKB if MAXKB=0
if PERM SPACE+NKB>MAXKB then result =83; ! filespace limit exceeded.
result =0
end ; ! CHK PERM SPACE
!
!-----------------------------------------------------------------------
!
externalintegerfn DPERMISSIONI( c
string (18)OWNERINDEX, USER, c
string (8)DATE, c
string (11)FILE, c
integer FSYS, TYPE, ADRPRM)
integer ARCHIVE,SET CHKSUM, IP
integer I, N, A, NPD
integer J,MAXP,FINDAD,POK,NQS,PRM,CH,FLAG
STRING (18)UNAME, INAME, IND
byteintegername LINK
! 9876543210
constinteger SET USED=B'0000101111'
constinteger SET CSUM=B'1011101110'; ! WHETHER TO RESET CHECKSUMFOR ARCHIVE INDEX
record (FDF)name FL
record (FF)name F
record (PDF)name PD
record (FDF)arrayname FDS
record (PDF)arrayname PDS
integername ARCH SEMA
switch DP(0:11)
conststring (5)FN = "DPERM"
SET CHKSUM = 0
!
FLAG = UIO(OWNERINDEX, UNAME, INAME, IND)
-> OUT UNLESS FLAG = 0
!
IP = 0
IP = FILE INDEX PERM(IND, FSYS) IF TYPE = 26
!
FLAG = FINDA(IND, FSYS, FINDAD, 0)
-> OUT UNLESS FLAG = 0
!
F==RECORD(FINDAD)
!
if TYPE<16 start
ARCHIVE = 0
FLAG = PP(ADDR(F_SEMA),F_SEMANO,FN)
-> OUT unless FLAG = 0
finish else start
TYPE=TYPE - 16
ARCHIVE=1
ARCH SEMA==F_ASEMA; ! in the main index
FLAG=NEWAINDA(IND,FSYS,FINDAD); ! replace FINDAD with addr of arch file index
-> OUT UNLESS FLAG = 0
F == RECORD(FINDAD); ! remap to appropriate #ARCH
!
SET CHKSUM=(1<<TYPE) & SET CSUM
if SET CHKSUM#0 start
FLAG=APP(ARCH SEMA)
-> OUT UNLESS FLAG = 0
finish
finish
!
FLAG = 8
-> VOUT unless 0 <= TYPE <= 11
PDS == ARRAY(FINDAD+F_PDSTART, PDSF)
NPD = (F_SDSTART - F_PDSTART) // PDSIZE
!
unless 6<=TYPE<=9 or TYPE > 10 start ; ! file relevant
-> VOUT IF ARCHIVE # 0 = TYPE; ! OWNP NOT STORED FOR #ARCH FILES
FLAG = S11OK(FILE)
-> VOUT UNLESS FLAG = 0
!
if ARCHIVE=0 C
then J=NEWFIND(FINDAD,0,FILE) c
else J=NEWAFIND2(FINDAD,FILE,DATE,0)
!
FLAG=32
-> VOUT IF J = 0; ! NOT EXIST
!
FDS == ARRAY(FINDAD+F_FDSTART, FDSF)
FL==FDS(J)
!
FLAG=20; ! file on offer
! Not allowed to alter permission list for a file while the file
! is on offer, because DOFFER uses the permission list.
if archive = 0 and FL_CODES&OFFER#0 and (TYPE=2 or TYPE=3 or TYPE=5) c
then -> VOUT
!
finish
!
!
NQS = -1; ! error value
-> BAD unless LENGTH(USER) = 6
UCTRANSLATE(ADDR(USER)+1, 6)
N = 0
cycle J = 1, 1, 6
CH = BYTEINTEGER(ADDR(USER) + J)
N = N + 1 if CH = '?'
-> BAD unless '0'<=CH<='9' or 'A'<=CH<='Z' or CH='?'
repeat
NQS = N; ! number of queries
BAD:
POK=0
if 0<=ADRPRM<=7 or (0<=ADRPRM<=15 and TYPE<=1) start
POK = 1
ADRPRM = ADRPRM ! 1 IF ADRPRM & 6 > 0
FINISH
!
if (1<<TYPE)&SET USED#0 and ARCHIVE=0 start
! SET WRITTEN-TO BIT AND CLEAR TEMPFI BITS.
! (THIS CAN GET DONE EVEN THOUGH SOME FAILURE MIGHT OCCUR
! BELOW PREVENTING THE PERMISSION BEING SET OR WITHDRAWN)
! Check permanent filespace allocation, before making permanent.
FLAG=NEWCHK PERM SPACE(F, FL)
if FLAG#0 then -> VOUT
FL_ARCH=FL_ARCH ! 5
unless FL_CODES & TEMPFS = NO start
F_TEMPFILES = F_TEMPFILES - 1
F_TEMPKB = F_TEMPKB - FL_PGS << 2
FL_CODES = FL_CODES & (¬TEMPFS)
finish
finish
FLAG=46
-> DP(TYPE)
!
DP(0):
if POK=0 then -> VOUT; ! set OWNP
FL_OWNP=ADRPRM
-> DDONE
!
DP(1):
if POK=0 then -> VOUT; ! set EEP
FL_EEP=ADRPRM
-> DDONE
!
DP(2): ! PUT USER IN LIST FOR FILE
-> DP(1) if NQS = 6
LINK == FL_PHEAD
MAXP = 16; ! max no of perms in file list
-> DP6
DP(6): ! PUT USER IN LIST FOR INDEX
-> VOUT if ADRPRM&2 > 0 and DTRYING << 23 >= 0
-> DP(11) if NQS = 6
LINK == F_FIPHEAD
MAXP = 15; ! max for index list, leave one 'space' for F_EEP
DP6:
-> VOUT if POK = 0
-> VOUT if NQS < 0
!
N = 0
WHILE 0 < LINK <= NPD AND N < MAXP CYCLE
PD == PDS(LINK)
IF PD_NAME = USER START ; ! found
PD_PERM = ADRPRM; ! set new permission
-> DDONE
FINISH
LINK == PD_LINK
N = N + 1
REPEAT
!
FLAG = 49; ! permission list full
-> VOUT IF LINK > 0 OR N >= MAXP
!
FLAG = 17; ! insufficient pds
cycle I = 1, 1, NPD
PD == PDS(I)
if PD_NAME = "" start
PD_NAME = USER
PD_PERM = ADRPRM
PD_LINK = 0
LINK = I
FLAG = 0
exit
finish
repeat
-> VOUT
!
DP(3): ! REMOVE USER FROM LIST FOR FILE
LINK == FL_PHEAD
-> DP7
DP(7): ! REMOVE USER FROM LIST FOR INDEX
F_EEP = 0 AND -> DDONE IF NQS = 6
LINK == F_FIPHEAD
DP7:
-> VOUT if NQS < 0
!
FLAG = 50; ! user not in list
N = 0
WHILE 0 < LINK <= NPD AND N < 16 CYCLE
PD == PDS(LINK)
IF PD_NAME = USER START
LINK = PD_LINK
PD = 0
-> DDONE
FINISH
LINK == PD_LINK
N = N + 1
REPEAT
-> VOUT
!
DP(4): ! GIVE LIST FOR FILE
FLAG=45
if VAL(ADRPRM,16 + 16*8,1,DCALLERS PSR)=0 then -> VOUT
INTEGER(ADRPRM+4)=FL_OWNP
INTEGER(ADRPRM+8)=FL_EEP
J = FL_PHEAD
-> DP8
!
DP(8): ! GIVE LIST FOR INDEX
INTEGER(ADRPRM + 4) = 7
INTEGER(ADRPRM + 8) = F_EEP
J = F_FIPHEAD
DP8:
INTEGER(ADRPRM+12) = 0; ! spare
A = ADRPRM + 16
N = 0
while NPD >= J > 0 cycle
PD == PDS(J)
STRING(A) = PD_NAME
BYTEINTEGER(A+7) = PD_PERM
A = A + 8
J = PD_LINK
N = N + 1
exit if N > 15
repeat
!
IF TYPE = 8 AND F_EEP > 0 START ; ! TEMP ************
STRING(A) = "??????"
BYTEINTEGER(A+7) = F_EEP
A = A + 8
N = N + 1
FINISH
!
INTEGER(ADRPRM) = A - ADRPRM
-> DDONE
!
DP(5): ! DESTROY LIST FOR FILE
LINK == FL_PHEAD
-> DP9
DP(9): ! DESTROY LIST FOR INDEX
LINK == F_FIPHEAD
DP9:
while NPD >= LINK > 0 cycle
PD == PDS(LINK)
LINK = PD_LINK
PD = 0
repeat
LINK = 0 unless LINK = 0
-> DDONE
!
DP(10): ! GIVE PERMITTED ACCESS MODES OF USER TO FILE
if NQS#0 then -> VOUT; ! no ?'s allowed
if USER=UNAME start
PRM=FL_OWNP & 7; ! REMOVE "DESTROY-INHIBIT" BIT
if ARCHIVE#0 then PRM=7; ! OWNP NOT STORED FOR ARCHIVE FILES
-> GIVEP
finish
PRM = NEWFILEPERM(FINDAD, FL, USER)
GIVEP:
IF PRM = -1 START
IF ARCHIVE = 0 C
THEN PRM = F_EEP & 7 C
ELSE PRM = IP
FINISH
PRM = PRM ! 1 IF PRM & 6 > 0
FLAG=45
if VAL(ADRPRM,4,1,DCALLERS PSR)=0 then -> VOUT
INTEGER(ADRPRM)=PRM
-> DDONE
DP(11): ! set index EEP
-> VOUT IF POK = 0
-> VOUT IF ADRPRM & 2 > 0 AND DTRYING <<23 >= 0
F_EEP = ADRPRM
DDONE:
FLAG=0
VOUT:
if SET CHKSUM#0 start
FLAG=NEWAINDA("", J, J) if FLAG = 0
AVV(ARCH SEMA)
finish
VV(ADDR(F_SEMA), F_SEMANO) if ARCHIVE=0
OUT:
result =flag
end ; ! DPERMISSIONI
!
!-----------------------------------------------------------------------
!
EXTERNALINTEGERFN FILE INDEX PERM(STRING (31)INDEX, INTEGER FSYS)
! RESULT IS PROCUSERS WHOLE INDEX
! PERMISSION TO INDEX ON FSYS
INTEGER I, J, K, ADR, N, CH, AP
RECORDFORMAT RF(STRING (6)USER, BYTEINTEGER PRM)
RECORD (RF)NAME R
BYTEINTEGERARRAY A(0:143)
ADR = ADDR(A(0))
J = DPERMISSIONI(INDEX, PROCUSER, "", "", FSYS, 8, ADR)
RESULT = 0 UNLESS J = 0
!
N = INTEGER(ADR)
RESULT = 0 UNLESS N > 16
!
AP = ADDR(PROCUSER)
!
CYCLE I = 0, 1, 1
CYCLE J = ADR+16, 8, ADR+N-8
R == RECORD(J)
IF I = 0 START
RESULT = R_PRM IF R_USER = PROCUSER
FINISH ELSE START
CYCLE K = 1, 1, 6
CH = BYTEINTEGER(J+K)
-> NOT THIS ONE UNLESS CH = '?' OR C
CH = BYTEINTEGER(AP+K)
REPEAT
RESULT = R_PRM
FINISH
NOT THIS ONE:
REPEAT
REPEAT
RESULT = 0
END ; ! FILE INDEX PERM
!
!-----------------------------------------------------------------------
!
! Functions for password encryption on EMAS 2900 - Gordon Brebner, Feb 1982.
!
!
!
EXTERNALINTEGERFN ENCRYPT(INTEGER MODE, STRING (63)PASS, LONGINTEGERNAME E,
INTEGERNAME K, DT)
!
! MODE = 0 compare supplied PASS and K with E
! 1 return E, K and DT
!
! Computes the function f(key) = p(key) mod P, where P = 2^64-a.
! The function p is the following polynomial :
! x^n0 + x^n1*c1 + x^3*c2 + x^2*c3 + x*c4 + c5
! The parameter "key" is an unsigned 64 bit quantity.
! For more details about why this function is useful, see a paper by Purdy
! in CACM 17 (August 1974) 442 - 445.
!
constlonginteger a = 59
constlonginteger n0 = 1<<24-3, n1 = 1<<24-63
constlonginteger c1 = -83, c2 = -179, c3 = -257, c4 = -323, c5 = -363
INTEGER J, FLAG, W, OLD
LONGINTEGER L
STRING (255)S, S1
BYTEINTEGERNAME B
longintegerfn add(longinteger u, y)
! Adds two unsigned 64 bit integers together modulo 2^64-a.
integer flag
*lb_0
*lss_u+4
*uad_y+4
*st_y+4
*lss_u
*jcc_8, <nc>
*uad_1
*jcc_8, <nc>
*adb_1
nc:*uad_y
*st_y
*jcc_8,<on>
*adb_1
on:*stb_flag
y = y+a if flag # 0 or -a <= y <= -1
result = y
end
longintegerfn emul(integer w, z)
! Multiplies two unsigned 32 bit integers together.
longinteger r
*lss_w
*imyd_z
*st_r
if w < 0 start
*lss_r
*uad_z
*st_r
finish
if z < 0 start
*lss_r
*uad_w
*st_r
finish
result = r
end
longintegerfn mod(longinteger u)
! Returns a 64 bit unsigned integer modulo 2^64-a.
u = u+a if -a <= u <= -1
result = u
end
longintegerfn lsh(longinteger u)
! Multiplies a 64 bit unsigned integer by 2^32 modulo 2^64-a.
result = add(emul(a, integer(addr(u))), u<<32)
end
longintegerfn mul(longinteger u, y)
! Multiplies two unsigned 64 bit integers together modulo 2^64-a.
integername ul, uh, yl, yh
ul == integer(addr(u)+4); uh == integer(addr(u))
yl == integer(addr(y)+4); yh == integer(addr(y))
result = add(lsh(add(lsh(mod(emul(uh, yh))),
add(mod(emul(uh, yl)), mod(emul(ul, yh))))),
mod(emul(ul, yl)))
end
longintegerfn exp(longinteger p, integer n)
! Raises an unsigned 64 bit integer p to a 32 bit
! unsigned integer power n modulo 2^64-a.
longinteger r
result = 1 if n = 0
r = 0
while n # 0 cycle
if n & 1 > 0 start
if r = 0 c
then r = p c
else r = mul(r, p)
finish
p = mul(p, p)
n = n>>1
repeat
result = r
end
!
!
!
RESULT = 8 IF MODE = 0 AND E = 0; ! zero always fails to check
!
IF MODE = 0 AND E >> 31 = 1 START ; ! checking old pass
RESULT = 8 UNLESS LENGTH(PASS) = 4
UCTRANSLATE(ADDR(PASS)+1, 4)
!
L = E
*LSD_L
*STUH_B
*ST_OLD
OLD = OLD !! (-1)
W = 4
S = STRING(ADDR(W) + 3)
UCTRANSLATE(ADDR(S)+1, 4)
RESULT = 8 UNLESS PASS = S
RESULT = 0
FINISH
!
IF MODE = 1 START
*RRTC_0
*STUH_B
*ST_J
K = J
FINISH
!
S1 = " "
CHARNO(S1, 1) = K & 255
S = PASS . S1
UCTRANSLATE(ADDR(S)+1, LENGTH(S))
S = S . S WHILE LENGTH(S) < 32
W = K
*LSS_W
*LUH_0
*ST_L
B == BYTEINTEGER(ADDR(L) + 7)
!
CYCLE J = 1, 1, 32
*LSD_L
*ROT_5
*ST_L
B = (B + CHARNO(S, J)) & 255
REPEAT
!
L = MOD(L)
L = add(mul(exp(L, n1), add(exp(L, n0-n1), c1)),
add(mul(L, add(mul(L, add(mul(L, c2), c3)), c4)), c5))
!
FLAG = 0
IF MODE = 0 START ; ! checking
IF E >> 32 = 0 START ; ! single length
*LSD_L
*AND_X'000000007FFFFFFF'
*ST_L
FINISH
FLAG = 8 UNLESS E = L
FINISH ELSE E = L AND DT = PACKDT; ! return double length value
!
RESULT = FLAG
END ; ! ENCRYPT
!
!-----------------------------------------------------------------------
!
EXTERNALINTEGERFN D SET PASSWORD(STRING (6)USER, INTEGER FSYS, WHICH,
STRING (63)OLD, NEW)
INTEGER J, INDAD, DT, TRUNC
RECORD (HF)NAME H
J = IN2(8)
-> OUT UNLESS J = 0
!
J = UNOK(USER)
-> OUT UNLESS J = 0
!
J = 8
-> OUT IF OLD = ""
-> OUT IF NEW = ""
!
TRUNC = 0; ! give warning if password longer than 11 and will be trunc
TRUNC = 19 AND LENGTH(NEW) = 11 IF LENGTH(NEW) > 11
!
J = HINDA(USER, FSYS, INDAD, 0)
-> OUT UNLESS J = 0
!
H == RECORD(INDAD)
J = 93
-> OUT UNLESS PROCUSER = "DIRECT" OR UINF_REASON < 2
-> OK IF USER = PROCUSER
-> OK IF DTRYING << 21 < 0
-> OUT IF H_BASEFILE = ""
-> OUT UNLESS CHARNO(USER, 4) = 'U'
-> OUT UNLESS PROCUSER = H_SUPERVISOR
OK:
J = ENCRYPT(0, OLD, H_DWSP, H_DWSPK, DT)
IF J = 0 START
IF WHICH = 0 C
THEN J = ENCRYPT(1, NEW, H_DWSP, H_DWSPK, H_DWSPDT) C
ELSE J = ENCRYPT(1, NEW, H_BWSP, H_BWSPK, H_BWSPDT)
H_PASSFAILS = 0
FINISH
OUT:
J = TRUNC IF J = 0
RESULT = OUT(J, "SII")
END ; ! DSETPASSWORD
!
!-----------------------------------------------------------------------
!
EXTERNALINTEGERFN MOVE SECTION(INTEGER FSYS1, STARTP1, FSYS2, STARTP2, EPGS)
INTEGER FROMDEV, FSYS, BITNO, RELPAGE, MOVE FLAG, RW, FAIL
INTEGER J
INTEGERNAME F, PAGE
RECORD (PARMF)NAME Q
RECORD (PARMF)P
UNLESS STARTP1>>19 = 0 AND STARTP2>>19 = 0 START
WRSNT("MVSC P1", STARTP1, 6)
WRSNT(" P2", STARTP2, 2)
RESULT = 25
FINISH
!
FROM DEV = 2; ! disc
IF FSYS1 = -1 START
FROMDEV = 5; ! "LP"
STARTP1 = 0
FINISH
!
! OUT TO LOCAL CONTROLLER TO CHECK THAT THE BLOCK WHOSE START PAGE IS
! "PAGE" IS NOT STILL ACTIVE. THIS IS BECAUSE AN ORDINARY DISCONNECT DOES
! NOT WAIT UNTIL ALL PAGE-OUTS ARE COMPLETE.
! But we suppress this check for UNPRG, so that we can unprg active software
! without messages. This is indicated by the TOP BIT being set in FSYS1.
! (This feature is used only by function DPRGP).
!
J = 0
F == FSYS1
PAGE == STARTP1
L:
UNLESS F = -1 START
IF F < 0 C
THEN F = F & 255 C {remove top bit}
ELSE START
Q == RECORD(OUTPAD)
Q = 0
Q_DEST = (F << 24) ! PAGE
*OUT_17
UNLESS Q_DEST = 0 START
WRSN("MVSC BLOCK STILL ACTIVE", Q_DEST)
RESULT = 25
FINISH
FINISH
FINISH
!
IF J = 0 START
J = 1
F == FSYS2
PAGE == STARTP2
-> L
FINISH
!
P = 0
P_DEST = X'00240000'
P_P1 = X'00020000' ! (FROMDEV<<24) ! EPGS
P_P2 = FSYS1
P_P3 = STARTP1
P_P4 = FSYS2
P_P5 = STARTP2
P_P6 = M'MVSC'
IF EPGS < 5 C
THEN DOUT11I(P) C
ELSE DOUTI(P)
MOVE FLAG = P_P1
!***********************************************************************
! About the BULK MOVER:
! CALLED ON SERVICE 36 TO TRANSFERS GROUPS OF PAGES BETWEEN *
! FAST DEVICES. REPLIES ARE ON SERVICE 37. *
! FAST DEVICE TYPES ARE:- *
! DEV=1 DRUM (SPECIFIED AS SERVICE & PAGE IN AMEM ) *
! DEV=2 DISCFILE (SPECIFIED AS [MNEMONIC OR LVN] & PAGE) *
! DEV=3 ARCHTAPE (SPECIFIED AS SERVICE(PREPOSND BY VOLUMS)) *
! DEV=4 TAPE (SPECIFIED AS STRING(6)LAB,BYTE CHAP NO) *
! DEV=5 FUNNY (READS GIVE ZERO PAGE,WRITES IN HEX TO LP) *
! DEV=6 SINK (THROWS AWAY INPUT FOR TAPE CHECKING) *
! *
! CAN HANDLE UP TO FOUR MOVES AT A TIME. EACH MOVE USES *
! ONE BUFFER AND APART FROM CLEARS ONLY HAS ONE TRANSFER *
! OUTSTANDING AT ANY ONE TIME TIME. *
! ALL WRITES ARE CHECKED BY RE-READING *
! Failure flags (returned in P_P1) are as follows (at least *
! for moves to/from disc): *
! *
! P_P1 = RW<<24 ! FAIL<<16 ! RELPAGE *
! *
! where RW = 1 means a READ failed *
! 2 means a WRITE failed. *
! FAIL = flag from PDISC: *
! 1 = transferred with errors (i.e. cyclic *
! check fails) *
! 2 = request rejected *
! 3 = transfer not effected (e.g. flagged *
! track encountered) *
! and RELPAGE = relative page no of failing page, counting *
! first page of request as one. *
!**********************************************************************
RESULT = 0 IF MOVE FLAG = 0
!
RW=MOVE FLAG>>24
FAIL=(MOVE FLAG>>16) & 255
RELPAGE=MOVE FLAG&X'FFFF'
IF ((RW=1 AND FSYS1>=0) OR RW=2) AND (FAIL=1 OR FAIL=3) START
IF RW=1 START
FSYS=FSYS1
BITNO=STARTP1
FINISH ELSE START
FSYS=FSYS2
BITNO=STARTP2
FINISH
FAIL=BAD PAGE(1,FSYS,BITNO + RELPAGE - 1)
FINISH
RESULT = 25
END ; ! MOVE SECTION
!
!-----------------------------------------------------------------------
!
INCLUDE "PD22S_B04CONT"
ROUTINE REF LOCK(RECORD (PARMF)NAME Q, INTEGER ADR, LEN)
INTEGER K,DUM,EPAGE BYTES,TIMES
RECORD (PARMF)NAME P
TIMES=0
P==RECORD(OUTPAD)
UNTIL (TIMES>4 OR P_DEST#-1) CYCLE
! NOW REFERENCE ALL THE PAGES
EPAGE BYTES=EPAGE SIZE<<10
K=ADR & (¬(EPAGE BYTES - 1))
WHILE K<ADR+LEN CYCLE
DUM=BYTEINTEGER(K)
K=K+EPAGE BYTES
REPEAT
P=Q
*OUT_25; ! SPECIAL PON AND SUSPEND
TIMES=TIMES+1
REPEAT
Q=P
END ; ! REF LOCK
!
!-----------------------------------------------------------------------
!
INCLUDE "PD22S_B07ARCHIVE"
EXTERNALINTEGERFN DACCEPT(STRING (31)FILE INDEX, FILE, NEWNAME,
INTEGER FSYS)
RESULT =DTRANSFER(FILE INDEX,PROCUSER,FILE,NEWNAME,FSYS,PROCFSYS,0)
END ; ! DACCEPT
!
!-----------------------------------------------------------------------
!
!<DCHECKBPASS
externalintegerfn D CHECK BPASS(string (6)USER, string (63)BPASS,
integer FSYS)
!
! This procedure allows a privileged process to check that a supplied
! background password corresponds to the version in the index for USER
! on FSYS. Result is zero if password is correct.
!>
INTEGER INDAD, J, DT
RECORD (HF)NAME H
J = IN2(8)
-> OUT UNLESS J = 0
!
J = UNOK(USER)
-> OUT UNLESS J = 0
!
J = 93
-> OUT UNLESS DTRYING << 22 < 0
!
J = HINDA(USER, FSYS, INDAD, 0)
-> OUT UNLESS J = 0
!
H == RECORD(INDAD)
J = ENCRYPT(0, BPASS, H_BWSP, H_BWSPK, DT)
J = 96 UNLESS J = 0
OUT:
RESULT = OUT(J, "S")
END ; ! D CHECK BPASS
!
!-----------------------------------------------------------------------
!
!<DDELAY
externalintegerfn DDELAY(integer N)
!
! This procedure checks that 1 <= N <= 7200. If it is not, result 8 is
! returned. Otherwise, the process is suspended for N seconds and then
! returns with result 0
!>
INTEGER J
RECORD (PARMF)NAME P
REAL Z
J = IN2(14)
-> OUT UNLESS J = 0
!
J = 8
-> OUT UNLESS 1 <= N <= 7200
Z = N
Z = (Z*1000000) / (1024*1024) IF N > 20
N = INT(Z)
!
P == RECORD(OUTPAD)
!
UNTIL P_DEST = 0 CYCLE
P_DEST = 0
*OUT_6; ! accept and discard outstanding msgs
REPEAT
!
P = 0
P_DEST = X'A0002'; ! single kick
P_P1 = UINF_SYNC1DEST
P_P2 = N
*OUT_5
!
J = 0
OUT:
RESULT = OUT(J, "I")
END ; ! DDELAY
!
!-----------------------------------------------------------------------
!
!<DDONATE
externalintegerfn DDONATE(string (6)USER, integer FSYS, UNITS)
!
! Allows a process owner, who has no group holder, to transfer some of
! his funds to USER on FSYS or, if USER has a group holder, to the group
! holder.
!>
INTEGER J, INDAD
RECORD (HF)NAME NH, ONH
INTEGERNAME INUTS, ONUTS
STRING (6)GP
J = IN2(19)
-> OUT UNLESS J = 0
!
J = UNOK(USER)
-> OUT UNLESS J = 0
!
ONH == RECORD(OWNIND)
!
J = 60; ! this user not allowed, as he uses somebody else's units
-> OUT IF ONH_GPHOLDR # ""
ONUTS == ONH_INUTS
!
UNITS=0 IF UNITS<0
IF UNITS>ONUTS THEN UNITS=ONUTS
!
J = 8
-> OUT IF UNITS < 1
!
J = HINDA(USER, FSYS, INDAD, 0)
-> OUT UNLESS J = 0
!
GP = ""
NH == RECORD(INDAD)
INUTS == NH_INUTS
GP = NH_GPHOLDR
!
IF GP # "" START
FSYS = -1
J = HINDA(GP, FSYS, INDAD, 0)
-> OUT UNLESS J = 0
NH == RECORD(INDAD) AND INUTS == NH_INUTS
FINISH
!
ONUTS=ONUTS-UNITS
INUTS=INUTS+UNITS
!
WRS3N("DONATE", USER, GP, UNITS)
!
J=0
OUT:
RESULT = OUT(J, "SII")
END ; ! DDONATE
!
!-----------------------------------------------------------------------
!
!<DEXECMESS
externalintegerfn DEXECMESS(string (6)USER, integer SACT, LEN, ADR)
!
! Checks that the message held at ADR of length LEN is readable and
! not > 2000 characters. Adds a prefix of
! **user.bel.date.time
! to the message then sends it to USER on the SYNC1 service, act X16.
! Control returns to the sending process immediately, the result being
! 0 successful
! 8 LEN invalid
! 45 message not readable
! 61 no process belonging to user
!>
!
!
INTEGER J, L
BYTEINTEGERARRAY MSG(0:2050)
RECORD (PARMF)P
J = IN2(25)
-> OUT UNLESS J = 0
!
J = UNOK(USER)
-> OUT UNLESS J = 0
!
J = 8
-> OUT UNLESS 0 < LEN < 2000
!
J = 45
-> OUT IF VAL(ADR, LEN, 0, 0) = 0
!
MSG(0) = 0
ATTU(STRING(ADDR(MSG(0))))
L = MSG(0)
MOVE(LEN, ADR, ADDR(MSG(L+1)))
!
P_DEST = X'FFFF0016'
J = TXTMESS(USER, P, 1, 0, L+LEN, ADDR(MSG(1)), -1, SACT)
OUT:
RESULT = OUT(J, "S")
END ; ! DEXECMESS
!
!-----------------------------------------------------------------------
!
!<DFILENAMES
externalintegerfn DFILENAMES(string (18)FILE INDEX,
record (OINFF)arrayname INFS,
integername FILENO, MAXREC, NFILES,
integer FSYS, TYPE)
!
! This procedure delivers, in the record array INFS (which should be
! declared (0:n)), a sequence of records describing the on-line files
! (for TYPE=0), archived files (for TYPE=1) or backed-up files (for
! TYPE=2) belonging to file index FILE INDEX on fsys FSYS (or -1 if not
! known).
!
! MAXREC is set by the caller to specify the maximum number of records he
! is prepared to accept in the array INFS, and is set by Director to be
! the number of records actually returned.
!
! NFILES is set by Director to be the number of files actually held on
! on-line storage or on archive storage, depending on the value of TYPE.
!
! FILENO is used only for TYPE=1. Filenames are stored in chronological
! order (by archive date). FILENO is set by the caller to specify the
! "file-number" from which descriptions are to be returned, zero
! represents the most recently archived file. (The intention here is to
! allow the caller to receive subsets of descriptions of a possibly very
! large number of files.)
!
! The format of the records delivered in the array INF is as follows:
!
! For on-line files (32 bytes)
! %string(11)NAME, %integer SP12, KBYTES, %byteinteger ARCH, CODES,
! CCT, OWNP, EEP, USE, CODES2, SSBYTE, FLAGS, POOL, DAYNO, SP31)
!
! and for archived files (40 bytes)
! %string(11)NAME, %integer KBYTES, %string(8)DATE, %string(6)TAPE,
! %integer CHAPTER, FLAGS)
!
! TAPE and CHAPTER are returned null to unprivileged callers.
!>
!
!
!
constinteger A INF LEN = 40; ! BYTES
constinteger O INF LEN = 32
constinteger W = 1
record (OINFF)name INF
!
integer J, FINDAD, SWITCH, LFILENO, IP, FP
integer NFD, I
integer NGIVEN, TB, K, GLOBAL
STRING (18)UNA, INA, IND
record (FF)name F
record (FDF)arrayname FDS
RECORD (FDF)NAME FL
CONSTSTRING (11)FN = "Dfilenames "
J = IN2(26)
-> RES UNLESS J = 0
!
SWITCH = MAXREC >> 31
MAXREC = (MAXREC << 1) >> 1
!
J = 8
-> RES UNLESS 0 <= TYPE <= 2
-> RES UNLESS 0 < MAXREC <= X'10000'
!
J = UIO(FILE INDEX, UNA, INA, IND)
-> RES UNLESS J = 0
!
J = 45
K = AINFLEN
K = OINFLEN IF TYPE = 0
K = K * MAXREC
TB = X'18000000' + K
*LDA_INFS+4
*LDTB_TB
*VAL_(LNB +1)
*JCC_3,<RES>
*LD_INFS+8
*VAL_(LNB +1)
*JCC_3,<RES>
-> RES UNLESS VAL(ADDR(FILENO), 4, 1, D CALLERS PSR) = YES
-> RES UNLESS VAL(ADDR(MAXREC), 4, 1, D CALLERS PSR) = YES
-> RES UNLESS VAL(ADDR(NFILES), 4, 1, D CALLERS PSR) = YES
-> RES UNLESS VAL(ADDR(INFS(0)),K,W,DCALLERS PSR) = YES
!
GLOBAL = NO; ! checking now to see if caller has unqualified access
GLOBAL = YES IF UNA = PROCUSER OR DTRYING << 23 < 0
!
J = FINDA(IND, FSYS, FINDAD, 0)
-> RES UNLESS J = 0
!
NFILES = 0
!
UNLESS TYPE=0 start
J = AFILENAMES(IND, INFS, FILENO, MAXREC, NFILES,
FSYS, TYPE - 1, GLOBAL)
-> RES
FINISH
!
LFILENO = FILENO
LFILENO = 0 IF SWITCH = 0
!
NGIVEN = 0
F == RECORD(FINDAD)
J = PP(ADDR(F_SEMA),F_SEMANO,FN)
-> RES UNLESS J = 0
!
NFD = (F_SIZE << 9 - F_FDSTART) // FDSIZE
FDS == ARRAY(FINDAD + F_FDSTART, FDSF)
IP = F_EEP & 7
cycle I = 1, 1, NFD
FL == FDS(I)
exit if FL_NAME = ""; ! never used
FP = NEWFILEPERM(FINDAD, FL, PROCUSER)
IF FL_NAME # ".NULL" ANDC
FL_CODES2 & OLDGE = 0 ANDC
(GLOBAL = YES OR FP > 0 OR (FP < 0 AND IP > 0)) C
START
NFILES = NFILES + 1; ! count good and relevant names
if NFILES > LFILENO ANDC
NGIVEN < MAXREC C
start ; ! can supply another name
INF == INFS(NGIVEN)
INF = 0
INF_NAME = FL_NAME
INF_NKB = FL_PGS<<2
INF_ARCH = FL_ARCH
INF_CODES = FL_CODES
INF_CCT = FL_CCT
INF_OWNP = FL_OWNP
INF_EEP = FL_EEP
INF_USE = FL_USE
INF_CODES2 = FL_CODES2
INF_SSBYTE = FL_SSBYTE
INF_DAYNO = FL_DAYNO
NGIVEN = NGIVEN + 1
finish
finish
repeat
MAXREC = NGIVEN
VV(ADDR(F_SEMA), F_SEMANO)
RES:
RESULT = OUT(J, "S----JJJII")
END ; ! DFILENAMES
!
!-----------------------------------------------------------------------
!
!<DFINFO
externalintegerfn DFINFO(string (31)FILE INDEX, FILE,
integer FSYS, ADR)
!
! This procedure returns detailed information about the attributes of
! file FILE belonging to file index FILE INDEX on disc-pack FSYS, in a
! record written to address ADR.
!
! A caller of the procedure having no permitted access to the file will
! receive an error result of 32, as though the file did not exist.
!
! The format of the record returned is:
!
recordformat DFINFOF(integer NKB, RUP, EEP, APF,
USE, ARCH, FSYS, CONSEG, CCT, CODES,
byteinteger SP1, DAYNO, POOL, CODES2,
integer SSBYTE, string (6)OFFER)
!
! where
! NKB the number of Kbytes (physical file size)
! RUP the caller's permitted access modes
! EEP the general access permission
! APF 1-4-4 bits, right-justified, giving respectively the Execute,
! Write and Read fields of APF, if the file is connected in
! this VM
! USE the current number of users of the file
! ARCH the value of the archive byte for the file (see procedure
! DFSTATUS)
! FSYS disc-pack number on which the file resides
! CONSEG the segment number at which the file is connected in the
! caller's VM, zero if not connected
! CCT the number of times the file has been connected since this
! field was last zeroed (see procedure DFSTATUS)
! CODES information for privileged processes
! SP1 spare
! DAYNO Day number when file last connected
! POOL
! CODES2 information for internal use
! SSBYTE information for the subsystem's exclusive use
! OFFER the username to which the file has been offered, otherwise
! null
!>
RECORD (DFINFOF)NAME FIF
integer J,GAP,FLAG,PRM,NS, NPD, SEG
integer FINDAD
string (6) ON OFFER TO
STRING (31)UNAME, INAME, FNAME, INDEX, FULL
record (FF)name F
record (FDF)name FL
record (FDF)arrayname FDS
record (PDF)arrayname PDS
conststring (7)FN = "DFINFO "
FLAG=IN2(27)
-> OUT UNLESS FLAG = 0
!
FLAG = UFO(FILE INDEX, FILE, UNAME, INAME, FNAME, INDEX, FULL)
-> OUT UNLESS FLAG = 0
!
FLAG = MAP FILE INDEX(INDEX, FSYS, FINDAD, FN)
-> OUT IF FLAG > 0
!
F == RECORD(FINDAD)
FDS == ARRAY(FINDAD + F_FDSTART, FDSF)
PDS == ARRAY(FINDAD + F_PDSTART, PDSF)
NPD = (F_SDSTART - F_PDSTART) // PDSIZE
FLAG = 32; ! not exist or no access
J = NEWFIND(FINDAD, 0, FNAME)
-> VOUT if J = 0
FL == FDS(J)
PRM = NEWFILE PERM(FINDAD, FL, PROCUSER)
IF PRM = -1 START
PRM = F_EEP & 7
PRM = PRM ! 1 IF PRM & 6 > 0
FINISH
ON OFFER TO=""
if FL_CODES&OFFER#0 start
J = FL_PHEAD
ON OFFER TO = PDS(J)_NAME if NPD >= J > 0
finish
if PRM=0 and ON OFFER TO#PROCUSER start
-> VOUT unless DTRYING << 23 < 0
finish
!
FIF==RECORD(ADR)
FIF=0
FIF_NKB=FL_PGS << 2
FIF_RUP=PRM
FIF_EEP=FL_EEP
FIF_USE=FL_USE
FIF_ARCH=FL_ARCH
FIF_FSYS=FSYS
! Drop top bit from CONSEG, which if set indicates thast the file
! is not to be disconnected (except at DSTOP), nor changed in
! size or access.
SEG = CONSEG(FULL,FSYS,GAP)<<1>>1;
FIF_CONSEG = SEG
if SEG>0 then GIVE APF(FIF_APF,J,NS,SEG)
FIF_CCT=FL_CCT
FIF_CODES=FL_CODES
FIF_DAYNO=FL_DAYNO
FIF_CODES2=FL_CODES2
FIF_SSBYTE=FL_SSBYTE
FIF_OFFER=ON OFFER TO
FLAG=0
VOUT:
VV(ADDR(F_SEMA), F_SEMANO)
OUT:
RESULT = OUT(FLAG, "SSI")
END ; ! DFINFO
!
!-----------------------------------------------------------------------
!
!<DFSTATUS
externalintegerfn DFSTATUS(string (31)FILE INDEX, FILE,
integer FSYS, ACT, VALUE)
!
! This procedure is supplied to enable the attributes of file FILE
! belonging to file index FILE INDEX on disc-pack FSYS to be modified,
! as follows.
!
! Parameter VALUE is for use by the archive/backup program (ACT=13),
! and by the subsystem (ACT=18), otherwise it should be set to zero.
!
! ACT ACTION
!
! 0 HAZARD Remove CHERISHed attribute
!
! 1 CHERISH Make subject to automatic System back-up procedures
! Note: If the file is one of
! SS#DIR, SS#OPT or SS#PROFILE
! then the 'archive-inhibit' bit is also set.
! Similarly, the 'archive-inhibit' bit is
! cleared by HAZARD for these files.
!
! 2 UNARCHIVE Remove the "to-be-archived" attribute
!
! 3 ARCHIVE Mark the file for removal from on-line to archive
! storage.
!
! 4 NOT TEMP Remove the "temporary" attribute.
!
! 5 TEMPFI Mark the file as "temporary", that is, to be
! destroyed when the process belonging to the file
! owner stops (if the file is connected at that
! time), or at system start-up.
!
! 6 VTEMPFI Mark the file as "very temporary", that is, to be
! destroyed when it is disconnected from the owner's
! VM.
!
! 7 NOT PRIVATE May now be written to magnetic tape either for
! back-up or archive. May be called only by
! privileged programs.
!
! 8 PRIVATE Not to be written to magnetic tape either for
! back-up or archive. May be called only by
! privileged programs.
!
! 9 SET CCT Set the connect count for the file to VALUE.
!
! 10 ARCH Operation 0 (PRIVILEGED).
! Shift ARCH byte usage bits (2**3 to 2**6
! inclusive) left one place. If A is the resulting
! value of the ARCH byte, set bit 2**7 if
! (A>>2)&B'11111' = VALUE.
!
! 11 ARCH Operation 1 (PRIVILEGED).
! Set currently-being-backed-up bit (bit 2**1 in
! ARCH byte), unless the file is currently connected
! in write mode, when error result 52 is given.
!
! 12 ARCH Operation 2 (PRIVILEGED).
! Clear currently-being-backed-up bit (2**1) and
! has-been-connected-in-write-mode bit (2**0).
!
! 13 ARCH Operation 3 (PRIVILEGED).
! Set archive byte to be bottom 8 bits of VALUE and
! clear the UNAVAilable bit in CODES.
!
! 14 ARCH Operation 4 (PRIVILEGED).
! Clear the UNAVAilable and privacy VIOLATed bits in
! CODES. Used by the back-up and archive programs
! when the file has been read in from magnetic tape.
!
! 15 CLR USE Clear file use-count and WRITE-CONNECTED status
! (PRIVILEGED).
!
! 16 CLR NOARCH Clear archive-inhibit bit in CODES. PRIVILEGED -
! for System
!
! 17 SET NOARCH Set archive-inhibit bit in CODES. Library use
!
! 18 SSBYTE Set SSBYTE to be the bottom 8 bits of VALUE (byte
! for a subsystem's exclusive use).
!
! 19 ARCH Operation 5 (PRIVILEGED).
! Set the WRCONN bit in CODES2. Used to prevent any
! user connecting the file in write mode during
! back-up or archive.
!
! 20 ARCH Operation 6 (PRIVILEGED).
! Clear the WRCONN bit in CODES2. Used when back-up
! is complete.
!
! 21 DAYNO Set DAYNO to bottom 8 bits of VALUE
!>
!
! Structure of the 'ARCH' byte:
! 2**0 file has been connected W
! 1 file is being backed up
! 2 file has been connected
! 3 usage over last 4 'periods'
! 4 " " " "
! 5 " " " "
! 6 " " " "
! 7 file to be archived
!
integer J, K, FINDAD, FLAG, FKB, CODES
STRING (255)A, B
STRING (31)UNAME, INAME, FNAME, INDEX, FULL
switch DF(0:21)
record (FDF)name FL
record (FF)name F
record (FDF)arrayname FDS
!
! 3322222222221111111111
! 10987654321098765432109876543210
constinteger PRIVFLAGS=B'00000000001110111111110110000000'
constinteger SET USED =B'00000000000001000000001000000010'
!
CONSTSTRING (26)NOTTOBEARCHIVED = " SS#DIR SS#OPT SS#PROFILE "
conststring (9)FN = "DFSTATUS "
FLAG=IN2(28)
-> OUT UNLESS FLAG = 0
!
FLAG=8
-> OUT UNLESS 0<=ACT<=21
!
FLAG = UFO(FILE INDEX, FILE, UNAME, INAME, FNAME, INDEX, FULL)
-> OUT UNLESS FLAG = 0
!
FLAG = 93
J = DTRYING << 23
-> OUT IF (1<<ACT)&PRIVFLAGS#0 AND J >= 0
!
IF UNAME # PROCUSER START
-> OUT UNLESS J < 0 OR FILE INDEX PERM(INDEX, FSYS) & 2 > 0
FINISH
!
FLAG = MAP FILE INDEX(INDEX, FSYS, FINDAD, FN)
-> OUT IF FLAG > 0
F == RECORD(FINDAD)
!
FLAG = 32
J = NEWFIND(FINDAD, 0, FNAME)
-> VOUT if J = 0
FDS == ARRAY(FINDAD + F_FDSTART, FDSF)
FL == FDS(J)
!
UCTRANSLATE(ADDR(FNAME)+1, LENGTH(FNAME)); ! for the 'NOT TO BE ARCH' test
FKB=FL_PGS << 2
CODES = FL_CODES
FLAG = 0
-> DF(ACT)
!
!
!
DF(0): !HAZARD
unless CODES & CHERSH = NO start
! was cherished
CODES = CODES - CHERSH
F_CHERFILES = F_CHERFILES - 1
F_CHERKB = F_CHERKB - FKB
IF NOT TO BE ARCHIVED -> (" " . FNAME . " ") START
CODES = CODES & (¬NOARCH)
FINISH
finish
-> DFR
DF(1): ! CHERISH
if CODES & CHERSH = NO start
! not cherished
CODES = CODES ! CHERSH
F_CHERFILES = F_CHERFILES + 1
F_CHERKB = F_CHERKB + FKB
IF NOT TO BE ARCHIVED -> (" " . FNAME . " ") START
CODES = CODES ! NOARCH
FINISH
finish
-> DFR
DF(2): ! CLR ARCHIVE BIT
FL_ARCH=FL_ARCH & 127
-> DFR
DF(3): ! SET ARCHIVE BIT
FL_ARCH=FL_ARCH ! 128
-> DFR
DF(4): ! CLR TEMPFILE BITS
! Check first that permanent filespace allocation will not be exceeded.
unless CODES & TEMPFS = NO start
! temporary
FLAG = NEWCHKPERMSPACE(F, FL)
-> DFR unless FLAG = 0
F_TEMPFILES = F_TEMPFILES - 1
F_TEMPKB = F_TEMPKB - FKB
CODES = CODES & (¬TEMPFS)
finish
-> DFR
DF(5): ! SET TEMPFILE BIT
if FL_OWNP&8#0 then FLAG=51 and -> DFR; ! "INHIBIT-DESTROY" BIT
if CODES & TEMPFS = NO start
! not temp yet
F_TEMPFILES = F_TEMPFILES + 1
F_TEMPKB = F_TEMPKB + FKB
finish
CODES = CODES ! TEMPFI
-> DFR
DF(6): ! SET VTEMPFILE BIT
if FL_OWNP&8#0 then FLAG=51 and -> DFR; ! "INHIBIT-DESTROY" BIT
if CODES & TEMPFS = NO start
! not temp yet
F_TEMPFILES = F_TEMPFILES + 1
F_TEMPKB = F_TEMPKB + FKB
finish
CODES=CODES ! VTEMPF
-> DFR
DF(7): ! PRIVILEGED. CLEAR 'PRIVATE' BIT
CODES=CODES & (¬PRIVAT)
-> DFR
DF(8): ! PRIVILEGED. SET 'PRIVATE' BIT
CODES=CODES ! PRIVAT
-> DFR
DF(9): ! SET CONNECT COUNT BYTE
FL_CCT<-VALUE
-> DFR
DF(10): ! PRIVILEGED. ARCH 0. SHIFT BITS
! J to be new value of 4 periods' use-bits without the ARCHIVE bit.
! K to be the bits other than the 4 period bits & current bit, and bit
! 2**7 is set additionally if J>>2 matches VALUE.
J=((FL_ARCH & B'01111100') <<1) & B'01111111'
K=FL_ARCH & B'10000011'
if J>>2=VALUE then K=K ! X'80'
FL_ARCH=J ! K
-> DFR
DF(11): ! PRIVILEGED. ARCH 1. SET "CURRENTLY-BEING-BACKED-UP" BIT
if CODES&WRCONN#0 then FLAG=52 and -> DFR
FL_ARCH=FL_ARCH ! 2; ! FILE-IS-BEING-BACKED-UP
-> DFR
DF(12): ! PRIVILEGED. CLEAR "CURRENTLY-BEING-BACKED-UP' BIT
FL_ARCH=FL_ARCH & (¬3)
-> DFR
DF(13): ! PRIVILEGED. ARCH 3. SET WHOLE ARCHIVE BYTE.
FL_ARCH<-VALUE
CODES=CODES & (¬UNAVA)
-> DFR
DF(14): ! PRIVILEGED. ARCH 4. CLEAR UNAVAILABLE AND VIOLAT BITS
CODES=CODES & (¬(VIOLAT ! UNAVA))
-> DFR
DF(15): ! PRIVILEGED. CLEAR USE AND WRCONN (LOCAL EMERGENCIES)
FL_USE=0
FL_CODES2=(FL_CODES2&(¬WRCONN))
-> DFR
DF(16): ! PRIVILEGED. CLEAR 'NOARCHIVE' BIT
CODES=CODES & (¬NOARCH)
-> DFR
DF(17): ! PRIVILEGED. SET 'NOARCHIVE' BIT.
CODES=CODES ! NOARCH
-> DFR
DF(18): ! SET SSBYTE
FL_SSBYTE<-VALUE
-> DFR
DF(19): ! PRIVILEGED. ARCH 5. SET 'WRITE-CONNECTED' BIT
if FL_CODES2 & WRCONN#0 then FLAG=52 and -> DFR; ! ALREADY SET
FL_CODES2=FL_CODES2 ! WRCONN
-> DFR
DF(20): ! PRIVILEGED. ARCH 6. CLEAR 'WRITE-CONNECTED' BIT
FL_CODES2=FL_CODES2 & (¬WRCONN)
-> DFR
DF(21): ! PRIVILEGED, set DAYNO to bottom byte of VALUE
FL_DAYNO <- VALUE
DFR:
FL_CODES = CODES
FL_ARCH=FL_ARCH ! 5 if (1<<ACT)&SET USED#0
VOUT:
VV(ADDR(F_SEMA), F_SEMANO)
OUT:
RESULT = OUT(FLAG, "SSII")
END ; ! DFSTATUS
!
!-----------------------------------------------------------------------
!
!<DFSYS
externalintegerfn DFSYS(string (31)FILE INDEX, integername FSYS)
!
! This procedure is used to determine on which disc pack a user's FILE
! INDEX resides. If FSYS is set to -1 before the procedure is called,
! it is set with the first disc-pack number on which FILE INDEX is
! found. If FSYS is set non-negative, only that disc-pack number is
! searched. If FILE INDEX is not found, FSYS is unchanged.
!>
INTEGER FINDAD, FLAG, INFSYS, OUTFSYS, J
STRING (31)UNAME, INAME, IND
FLAG = IN2(29)
-> RES UNLESS FLAG = 0
!
FLAG = UIO(FILE INDEX, UNAME, INAME, IND)
-> RES UNLESS FLAG = 0
!
FLAG = 45
INFSYS = -2
OUTFSYS = -2
-> RES IF VAL(ADDR(FSYS), 4, 1, DCALLERS PSR) = 0
INFSYS = FSYS
OUTFSYS = INFSYS
!
FLAG = 8
-> RES IF INFSYS < -1 OR INFSYS > 99
FLAG = FINDA(IND, OUTFSYS, FINDAD, 0)
FSYS = OUTFSYS IF FLAG = 0
!
RES:
! If any FSYS is closing,
! see if any index segment on a closing FSYS is connected in this VM.
! If so, empty the Director (index area) VM (and empty the HOTTOP).
!
IF FSYS WARN#0 START
CYCLE J = 0, 1, 99
IF FSYS USECOUNT(J) # 0 = AV(J,0) C
THEN EMPTY DVM AND EXIT
REPEAT
FINISH
!
RESULT = OUT(FLAG, "SJ")
END ; ! DFSYS
!
!-----------------------------------------------------------------------
!
!<DLOCK
externalintegerfn DLOCK(integer ADR, LEN, longintegername STB)
!
! This privileged procedure is used exceptionally to lock down areas
! of virtual memory in main store for short durations. ADR and LEN
! determine the extent of virtual storage to be made resident.
!
! On successful return STB contains a word-pair which may be used as a
! local segment table base for specially created local segment and
! page tables describing the locked-down area. This word-pair may be
! passed, for example, to the GPC routine to achieve a "private" data
! transfer to or from the locked-down area.
!
! Up to 3 separate non-overlapping areas may be simultaneously locked
! by repeated calls of this procedure. Exceptionally it may not be
! possible for the locking to be effected, for example if the System
! is unusually busy or if little main store is available, in this
! case result 68 is given.
!>
INTEGER STB0,STB1
INTEGER J,FLAG
RECORD (DRF)NAME ENTRY
RECORD (PARMF)Q
FLAG = IN2(35)
-> OUT UNLESS FLAG = 0
!
FLAG = 93
-> OUT UNLESS DTRYING << 13 < 0
!
FLAG = 8
-> OUT UNLESS ADR>0 AND 0<LEN <=2<<18; ! arb limit of 2 segs length
!
CYCLE J=0,1,2
-> GOT E IF DRS LOCKED(J)_DR0=0
REPEAT
FLAG=82; ! MAX AREAS LOCKED
-> OUT
GOTE:
ENTRY==DRS LOCKED(J)
!
FLAG=45; ! AREA NOT AVAILABLE
IF VAL(ADR,LEN,1,DCALLERS PSR)=0 THEN -> OUT; ! AREA NOT AVAIABLE
-> OUT IF VAL(ADDR(STB), 8, 1, DCALLERS PSR) = 0
Q = 0
Q_P1=1; ! LOCK
Q_P5=X'18000000' ! LEN
Q_P6=ADR
! We reference all the pages in the data area, to get them into
! main store. If they are not still there at the time of the OUT 25, then
! P_DEST will be set to -1, and we try again, up to four times (say).
LOUTP=Q
LOUTP STATE="DLOCK"
REF LOCK(Q,ADR,LEN)
LOUTP STATE="DLOCK exit"
!
FLAG=68; ! LOCKDOWN FAILS
IF Q_DEST=-1 THEN -> OUT; ! LOCK-DOWN FAILS
!
STB0=Q_P5
STB1=Q_P6
STB=(LENGTHENI(STB0)<<32) ! STB1
ENTRY_DR0=X'18000000' ! LEN
ENTRY_DR1=ADR
FLAG=0
OUT:
RESULT = OUT(FLAG, "XI")
END ; ! DLOCK
!
!-----------------------------------------------------------------------
!
!<DLOWERACR
externalintegerfn DLOWER ACR(integer NEWACR)
!
! This privileged procedure (currently accessible from ACR 4) enables
! the calling procedure to acquire a lower ACR (>0) and optionally to
! acquire PRIV (bit 2**4 set in parameter NEWACR) and/or DGW and ISR
! in SSR (bit 2**5 set in NEWACR).
!>
INTEGER CALLERS ACR, LNBHERE, PRIV, DGW
INTEGERNAME CALLERS PSR WORD
CONSTINTEGER DGW AND ISR = X'1800000'; ! diagnostic write and image store read
DIRFN = 44
PRIV = NEWACR & 16 << 14; ! ie X'00040000'
DGW = NEWACR&32
NEWACR = (NEWACR&(¬(16+32))) << 20
*STLN_LNBHERE
CALLERS PSR WORD == INTEGER(LNBHERE+4)
CALLERS ACR = CALLERS PSR WORD<<8>>28<<20
RESULT = 8 UNLESS 0<NEWACR<=CALLERS ACR
!
CALLERS PSR WORD = (CALLERS PSR WORD&X'FF0FFFFF') ! NEWACR ! PRIV
!
IF DGW#0 START
*LSS_(3); ! PICK UP SSR
*OR_DGW AND ISR
*ST_(3); ! PUT BACK WITH DGW AND ISR BITS SET
FINISH
!
RESULT = 0
END ; ! DLOWER ACR
!
!-----------------------------------------------------------------------
!
INCLUDE "PD22S_B10TAPES"
!<DMAIL
externalintegerfn DMAIL(record (PARMF)name P, integer LEN, ADR)
!
! Like DSPOOL but for MAILER, see below
!>
INTEGER FLAG
FLAG = IN2(39)
-> OUT UNLESS FLAG = 0
!
FLAG = DSPOOLBODY("MAILER", P, LEN, ADR)
OUT:
RESULT = OUT(FLAG, "")
END ; ! DMAIL
!
!-----------------------------------------------------------------------
!
!<DMESSAGE
externalintegerfn DMESSAGE(string (255)USER,
integername LEN, integer ACT, FSYS, ADR)
!
! This is identical to a call of DMESSAGE2 with INVOC = 0
!>
INTEGER J
J = IN2(40)
-> OUT UNLESS J = 0
!
J = DMESSAGE2(USER,LEN,ACT,0,FSYS,ADR); ! INVOC ZERO
OUT:
RESULT = OUT(J, "")
END ; ! DMESSAGE
!
!-----------------------------------------------------------------------
!
!<DMESSAGE2
externalintegerfn DMESSAGE2(string (255)USER,
integername LEN, integer ACT, INVOC, FSYS, ADR)
!
! ACT=0 Delivers to ADR the next message sent to this user process.
! LEN should be previously set to the maximum length you are
! prepared to accept, it is set by the procedure to the
! number of bytes returned. LEN will be set to zero if no
! further messages are available.
!
! ACT=1 Sends message (ADR, LEN) to USER on FSYS. INVOC is the
! invocation number of the paged process to which the message
! is to be notified. Currently LEN is restricted to 2000 bytes.
! Result 61 from this call means that a process belonging to
! USER is not currently present (but the message goes into his
! file anyway).
!
! ACT=2 Determines whether USER on FSYS currently has a process of
! invocation number INVOC. Result 61 if not, else zero.
!>
!
! Used by TELL and shouldnt be used to send things to SPOOLR
!
! ACT = 0 deliver next message to ADR. LEN is limit of area
! result 45 if area invalid, and len is set to no o fbytes passed.
! act = 1 send message (ADR,LEN) to user on disc FSYS.
RECORD (PARMF) P; ! DUMMY, NOT REQ FOR ASYNC TXT MESS
SWITCH DM(0:2)
INTEGER L,J,SEG,GAP,FAD,FLAG,DIR ACR,TYPE
INTEGER NKB, ALLOC, MODE, APF
BYTEINTEGERARRAY MSG(0:2050)
STRINGNAME S
FLAG = IN2(41)
-> DMFLAG UNLESS FLAG = 0
!
FLAG=8
-> DMFLAG UNLESS 0 <= ACT <= 2
UNLESS PROCUSER = "VOLUMS" START ; ! reject tell's to exec procs
-> DMFLAG IF ACT > 0 AND EXECP -> (USER)
FINISH
!
FLAG = 11
-> DMFLAG IF ACT > 0 # UNOK(USER)
!
*LSS_(1); ! PSR
*ST_J
DIR ACR=(J>>20)&15
FLAG=45
-> DM(ACT)
DM(0): ! deliver next message
-> DMFLAG IF VAL(ADDR(LEN), 4, 1, D CALLERS PSR) = NO
-> DMFLAG IF VAL(ADR, LEN, 1, D CALLERS PSR) = NO
!
NKB = 4
ALLOC = X'0B000051'
MODE = WRSH
APF = DIRACR << 4 ! 15
SEG = 0
GAP = 0
FLAG = CREATE AND CONNECT("#MSG", FSYS, NKB, ALLOC, C
MODE, APF, SEG, GAP)
FLAG = 86 AND -> DMFLAG UNLESS FLAG = 0
!
FAD=SEG<<18
FLAG=RDCIRC(LEN,FAD,ADR)
-> DMFLAG
DM(1): ! send message (adr,len) to user
-> DMFLAG IF VAL(ADDR(LEN), 4, 0, 0) = 0
IF VAL(ADR,LEN,0,0)=0 THEN -> DMFLAG
FLAG=8
IF LEN>2000 THEN -> DMFLAG; ! relatively arb, but to keep it within an EPAGE (size of #MSG file)
S == STRING(ADDR(MSG(0)))
S = "
"
S = "" IF USER = "SPOOLR"
ATTU(S)
L = LENGTH(S)
MOVE(LEN, ADR, ADDR(S) + L + 1)
P = 0
P_DEST = X'FFFF0016'
TYPE = 0; ! ASYNC
TYPE = 1 IF USER = "SPOOLR"; ! SYNC - THESE STATEMENTS UNTIL "DSPOOL" IN USE
FLAG = TXTMESS(USER, P, TYPE, INVOC, L+LEN, ADDR(MSG(1)), FSYS, 0)
-> DM2 IF TYPE = 0
-> DMFLAG
DM(2): ! is user present ?
! WE RECKON TO TEST USER'S SFI HERE, TO CHECK WHETHER YOU'RE ALLOWED TO KNOW..
FLAG=ASYNC MSG(USER,INVOC,NULDACT,0,0)
DM2:
IF SITE = ERCC START
NOT SO FAST; ! my friend !
FINISH
DMFLAG:
RESULT = OUT(FLAG, "S--I")
END ; ! DMESSAGE2
!
!-----------------------------------------------------------------------
!
!<DOFFER
externalintegerfn DOFFER(string (31)FILE INDEX, OFFERTO, FILE,
integer FSYS)
!
! This procedure causes file FILE belonging to file index FILE INDEX on
! disc-pack FSYS to be marked as being "on offer" to user OFFERTO. The
! file may not be connected in any virtual memory either at the time of
! the call of this procedure or subsequently while the file is on offer.
! The procedure DACCEPT is used by user OFFERTO to accept the file. A
! file may be on offer to at most one user.
!
! An offer may be withdrawn by calling this procedure with OFFERTO set
! as a null string.
!>
integer NPD, FINDAD
integer J,FLAG
STRING (31)UNAME1, INAME1, FNAME1, INDEX1, FULL1
record (FDF)name FL
record (FF)name F
record (FDF)arrayname FDS
record (PDF)arrayname PDS
record (PDF)name PD
!
conststring (7)FN = "DOFFER "
FLAG=IN2(53)
-> OUT UNLESS FLAG = 0
!
FLAG = UFO(FILE INDEX, FILE, UNAME1, INAME1, FNAME1, INDEX1, FULL1)
-> OUT UNLESS FLAG = 0
!
-> POK IF UNAME1 = PROCUSER
-> POK IF DTRYING << 6 < 0
-> POK IF FILE INDEX PERM(INDEX1, FSYS) & 2 > 0
FLAG=93
-> OUT
POK:
FLAG = MAP FILE INDEX(INDEX1, FSYS, FINDAD, FN)
-> OUT IF FLAG > 0
F == RECORD(FINDAD)
!
FLAG = 32
J = NEWFIND(FINDAD, 0, FILE)
-> VOUT if J = 0
FDS == ARRAY(FINDAD + F_FDSTART, FDSF)
PDS == ARRAY(FINDAD+F_PDSTART, PDSF)
FL == FDS(J)
!
if OFFERTO="" start
FLAG=0
if FL_CODES&OFFER=0 then -> VOUT
PD == PDS(FL_PHEAD); ! remove first permission
FL_PHEAD = PD_LINK
PD = 0
FL_CODES=FL_CODES & (¬OFFER)
-> VOUT
finish
!
FLAG=20
if FL_CODES&OFFER#0 then -> VOUT; ! ALREADY ON OFFER
!
FLAG=5
if FL_CODES&VIOLAT#0 then -> VOUT
!
FLAG=42; ! FILE CONNECTED
unless FL_USE=0 then -> VOUT
!
FLAG = UNOK(OFFER TO)
-> VOUT UNLESS FLAG = 0
!
NPD = (F_SDSTART - F_PDSTART) // PDSIZE
cycle J = 1, 1, NPD; ! look for a free PD
PD == PDS(J)
if PD_NAME = "" start ; ! found a free one
PD_NAME = OFFER TO
PD_PERM = 1
PD_LINK = FL_PHEAD
FL_PHEAD = J; ! link in new PD
FL_CODES = FL_CODES ! OFFER
FLAG = 0
-> VOUT
finish
repeat
FLAG = 17; ! no free PD
VOUT:
VV(ADDR(F_SEMA), F_SEMANO)
OUT:
RESULT = OUT(FLAG, "SSSI")
END ; ! DOFFER
!
!-----------------------------------------------------------------------
!
!<DPERMISSION
externalintegerfn DPERMISSION(string (31)FILE INDEX, USER,
string (8)DATE, string (11)FILE, integer FSYS, TYPE, ADRPRM)
!
! This procedure allows the caller to set access permissions, or specific
! preventions, for file connection to individual users, groups of users
! or to all users to file FILE belonging to file index FILE INDEX. It
! also allows a caller to determine the modes (if any) in which he may
! access the file.
!
! TYPE determines the service required of the procedure:
!
! TYPE Action
!
! 0 set OWNP (not for files on archive storage)
! 1 set EEP
! 2 put USER into the file list (see "Use of file
! access permissions", below)
! 3 remove USER from file list
! 4 return the file list
! 5 destroy the file list
! 6 put USER into the index list (see "Use of file
! access permissions", below)
! 7 remove USER from the index list
! 8 return the index list
! 9 destroy the index list
! 10 give modes of access available to USER for FILE
! 11 set EEP for the file index as a whole
!
! TYPEs 0 to 9 and 11 are available only to the file owner and to
! privileged processes. For TYPE 10, ADRPRM (see below) should be the
! address of an integer into which the access permission of USER to the
! file is returned. If USER has no access to the file, error result 32
! will be returned from the function, as though the file did not exist.
! If the file is on archive storage, TYPE should be set to 16 plus the
! above values to obtain the equivalent effects.
!
! ADRPRM is either the permission being attached to the file, bit
! values interpreted as follows:
!
! all bits zero prevent access
! 2**0 allow READ access
! 2**1 allow WRITE access not allowed for files
! 2**2 allow EXECUTE access on archive storage
! 2**3 If TYPE = 0, prevent the file from being
! destroyed by e.g. DDESTROY, DDISCONNECT (and
! destroy).
! or, except for type 10, it is the address of an area into which access
! permission information is to be written
!
! %recordformat(%integer BYTES RETURNED, OWNP, EEP, SPARE,
! %record(EF)%array INDIV PRMS(0:15))
!
! and EF is
! %recordformat EF(%string(6)USER, %byteinteger PERMISSION)
!
! where:
!
! BYTES indicates the amount of data returned.
! RETURNED
!
! OWNP is the file owner's own permission to the file, or the
! requesting user's "net" permission if the caller of the
! procedure is not the file owner (see "Use of file access
! permissions", below).
!
! EEP is the general (all users) access permission to the file
! ("everyone else's permission").
!
! UPRM The PERMISSION values in the sub-records are those
! for the corresponding users or groups of users denoted by
! USER. Up to 16 such permissions may be attached to a
! file.
!
! Use of file access permissions
!
! The general scheme for permissions is as follows. With each file
! there are associated:
!
! OWNP the permission of the owner of the file to access it
!
! EEP everyone else's permission to access it (other than users
! whose names are explicitly or implicitly attached to the
! file)
!
! INDIV PRMS a list of up to 16 items describing permissions for
! individual users, e.g. ERCC00, or groups of users, e.g.
! ERCC?? (specifying all usernames of which the first four
! characters are "ERCC")
!
! In addition, a user may attach a similar list of up to 16 items to
! his file index as a whole and an EEP for the file index. These
! permissions apply to any file described in the index along with those
! attached to that particular file.
! In determining the mode or modes in which a particular user may access
! a file, the following rules apply:
!
! 1. If the user is the file owner then OWNP applies.
!
! 2. Otherwise, if the user's name appears explicitly in the list for
! the file, the corresponding permission applies.
!
! 3. Otherwise, if the user's name is a member of a group of users
! represented by a list item for the file, the corresponding
! permission applies.
!
! 4. Otherwise EEP applies if greater than zero.
!
! 5. Otherwise, if the user's name appears explicitly in the list for
! the index, the corresponding permission applies.
!
! 6. Otherwise, if the user's name is a member of a group of users
! represented by a list item for the index, the corresponding
! permission applies.
!
! 7. Otherwise, everybody else's permission to the file index applies.
!
! In the event of a user's name appearing more than once (implicitly)
! within groups specified in a single list, the actual list item to be
! selected to give the permission should be regarded as indeterminate.
!>
INTEGER FLAG, IP
STRING (31)UNAME, INAME, INDEX
FLAG = IN2(60)
->OUT UNLESS FLAG = 0
!
FLAG = UIO(FILE INDEX, UNAME, INAME, INDEX)
-> OUT UNLESS FLAG = 0
!
-> POK IF UNAME = PROCUSER
-> POK IF TYPE = 10
-> POK IF TYPE = 26
-> POK IF DTRYING << 23 < 0
IP = FILE INDEX PERM(INDEX, FSYS)
-> POK IF IP & 2 > 0
-> POK IF (TYPE=4 OR TYPE=8) AND IP & 1 > 0
!
FLAG = 93
-> OUT
POK:
FLAG = DPERMISSIONI(INDEX, USER, DATE, FILE, C
FSYS, TYPE, ADRPRM)
!
OUT:
RESULT = OUT(FLAG, "SSSSII")
END ; ! DPERMISSION
!
!-----------------------------------------------------------------------
!
!<DSFI
externalintegerfn DSFI(string (31)FILE INDEX,
integer FSYS, TYPE, SET, ADR)
!
! This procedure is used to set or read information in file index FILE
! INDEX (or user record in some cases) on disc-pack FSYS. TYPE specifies
! which data item is to be referenced (see list below). SET must be 1
! to write the data item into the index, or 0 to read the item from the
! index. ADR is the address of an area, which must be available in write
! or read mode, to or from which the data item is to be transferred.
!
! TYPE Data item Data type & size
!
! 0 BASEFILE name (the file to be connected
! and entered at process start-up) string(18)
!
! 1 DELIVERY information (to identify string(31)
! slow-device output requested by the
! index owner)
!
! 2 CONTROLFILE name (a file for use by the
! subsystem for retaining control information) string(18)
!
! 3 ADDRTELE address and telephone number of user string(63)
!
! 4 INDEX USE (may not be reset)
! Gives (in successive integers from ADR):
! a) number of files
! b) number of file descriptors currently in use
! c) number of free file descriptors
! d) index size (Kbytes)
! e) Number of section descriptors (SDs)
! f) Number of free section descriptors
! g) Number of permission descriptors (PDs)
! h) Number of free permission descriptors integer(x8)
!
! 5 Foreground and background passwords
! (reading is a privileged operation), a zero
! value means "do not change" integer(x2)
!
! 6 Date last logged-in: (Y-70)<<9 ! (M<<5) ! D and
! date last started (non-interactive) (same)
! (may not be reset) integer(x2)
!
! 7 ACR level at which the process owning this
! index is to run (may be set only by privileged
! processes) integer
!
! 8 Director Version (may be set only by privileged
! processes) integer(x2)
!
! 9 ARCHIVE INDEX USE (may not be reset)
! Gives (in successive integers from ADR):
! a) number of archived files
! b) number of archived Kbytes
! c) number of backed-up files
! d) number of backed-up Kbytes
! e) index size (Kbytes)
! f) number of file descriptors
! g) number of free file descriptors
! h) number of permission descriptors
! i) number of free permission descriptors integer(x9)
!
! 10 Stack size (Kbytes) integer
!
! 11 Limit for total size of all files in disc
! storage (Kbytes) (may be set only by privileged
! processes integer
!
! 12 Maximum file size (Kbytes) (may be set only by
! privileged processes) integer
!
! 13 Current numbers of interactive and batch
! processes, respectively, for the user (may
! not be reset) integer(x2)
!
! 14 Process concurrency limits (may be set only
! by privileged processes). The three words
! denote respectively the maximum number of
! interactive, batch and total processes which
! may be concurrently running for the user.
! (Setting the fields to -1 implies using
! the default values, currently 1, 1 and 1.) integer(x3)
!
! 15 When bit 2**0 is set, TELL messages to the
! index owner are rejected with flag 48. integer
!
! 16 Set Director monitor level (may be set only
! by privileged processes) integer(x2)
!
! 17 Set SIGNAL monitor level (may be set only
! by privileged processes) integer
!
! 18 Initials and surnames of user (may
! be set only by privileged processes) string(31)
!
! 19 Director monitor file string(11)
!
! 20 Thousands of instructions executed, interactive
! and batch modes (may be reset only by
! privileged processes) integer(x2)
!
! 21 Thousands of instructions executed (current
! session only) integer
!
! 22 Thousands of instructions executed in Director
! procedures (current process session only)
! (may not be reset) integer
!
! 23 Page-turns, interactive and batch modes
! (may be reset only by privileged processes) integer(x2)
!
! 24 Page-turns (current process session only) integer
!
! 25 Thousands of bytes output to slow-devices
! (local or remote) (may be reset only by
! privileged processes) integer
!
! 26 Thousands of bytes input from slow-devices
! (local or remote) (may be reset only by
! privileged processes) integer
!
! 27 Milliseconds of OCP time used, interactive
! and batch modes (may be reset only by
! privileged processes) integer(x2)
!
! 28 Milliseconds of OCP time used (current
! session only) integer
!
! 29 Seconds of interactive terminal connect time
! (may be reset only by privileged processes) integer
!
! 30 No. of disc files, total disc Kbytes, no. of
! cherished files, total cherished Kbytes, no.
! of temporary files, total temporary Kbytes
! (cannot be reset) integer(x6)
!
! 31 No. of archive files, total archive Kbytes integer(x2)
!
! 32 Interactive session length in minutes integer
! 0 or 5 <= x <= 240
!
! 33 Funds integer
!
! 34 The FSYS of the Group Holder of the index integer
! owners funds, if he has a GH
!
! 35 Test BASEFILE name string(18)
!
! 36 Batch BASEFILE name string(18)
!
! 37 Group Holder of funds for scarce resources string(6)
!
! 38 Privileges integer
!
! 39 Default LP string(15)
!
! 40 Dates passwords last changed integer(x2)
! (may not be reset)
!
! 41 Password data integer(x8)
!
! 42 Get accounting data integer(x16)
!
! 43 Mail count integer
! (may be reset only by privileged processes)
!
! 44 Supervisor string(6)
!
! 45 Secure record about 512 bytes
!
! 46 Gateway access id string(15)
!
! 47 File index attributes byte
!
! 48 User type byte
!>
! THIS FUNCTION SETS (SET=1) OR GIVES (SET=0) FILE INDEX HEADER
! INFORMATION. ADR POINTS TO ADDRESS OF OR FOR THE INFORMATION
! TO BE TRANSFERRED.
! TYPE SPECIFIES THE DATA ITEM REQUIRED TO BE REFERENCED.
!
! A BIT IS SET IN SETFLAGS IF THE CORRESPONDING 'TYPE' MAY BE 'SET'
! ONLY BY A PRIVILEGED CALLER.
! A bit is set in LENFLAGS if the first byte of a string parameter input
! under the "set" option is to be checked according to corresponding
! entry from array VLEN. VLEN also used to VAL user area.
CONSTLONGINTEGER SETFLAGS = X'1DA632E9B7D80'
CONSTLONGINTEGER LENFLAGS = X'050B8000C000F'
CONSTLONGINTEGER H ONLY = X'15BFF3FFFE5EF'
CONSTLONGINTEGER UCT = X'050B800080005'; ! input string to be UC translated
CONSTINTEGER TOP GET = 48
CONSTBYTEINTEGERARRAY VLEN(0:TOPGET)= C
19, 32, 19, 64, 48, 8, 8, 4, 8, 48, C
4, 4, 4, 8, 12, 4, 8, 4, 32, 12, C
8, 4, 4, 8, 4, 4, 4, 8, 4, 4, C
24, 8, 4, 4, 4, 19, 19, 7, 4, 16, C
8, 32, 68, 4, 7,255, 16, 4, 4
constbyteintegerarray NI(0:TOPGET) = c
0, 0, 0, 0,12, 2, 1, 1, 2,12, c
1, 1, 1, 2, 3, 1, 2, 1, 0, 0, c
2, 1, 1, 2, 1, 1, 1, 2, 1, 1, c
6, 2, 1, 1, 1, 0, 0, 0, 1, 0, C
2, 0,17, 1, 0, 1, 0, 1, 1
! 0 = string
! n = number of integers to be reported if 'dmonning'
CONSTLONGINTEGER JMS = X'141DD76000'
integer TOPA
integer J, FLAG, LEN, INDAD, FINDAD, IP
integer NFD, NSD, NPD, N, A, AKB, B, BKB
LONGINTEGER L
STRING (18)W
STRING (31)UNA, INA, IND
switch DGET,DSET(0:TOPGET)
RECORD (FF)NAME AF
RECORD (AFDF)ARRAYNAME AFDS
record (FDF)arrayname FDS
RECORD (PDF)ARRAYNAME PDS
integerarrayname SDS
integername I0, I1
stringname S0
record (HF)name H
record (FF)name F
record (ACF)name ACCTS
conststring (5)FN = "DSFI "
!
!
!
FLAG=IN2(78)
-> OUT UNLESS FLAG = 0
!
FLAG = UIO(FILE INDEX, UNA, INA, IND)
-> OUT UNLESS FLAG = 0
!
FLAG=8
-> OUT UNLESS 0<=SET<=1 AND 0<=TYPE<=TOPGET
!
FLAG = 45
LEN=VLEN(TYPE)
J=VAL(ADR,LEN,1-SET,DCALLERS PSR)
-> OUT IF J=0; ! user area not accessible
!
IP = FILE INDEX PERM(IND, FSYS); ! done here because of sema
FLAG = MAP FILE INDEX(IND, FSYS, FINDAD, FN)
-> OUT IF FLAG > 0
F == RECORD(FINDAD)
!
I0 == INTEGER(ADR)
I1 == INTEGER(ADR+4)
S0 == STRING(ADR)
!
IF (H ONLY >> TYPE) & 1 = 1 START
FLAG = 8
-> VOUT UNLESS INA = ""
INDAD = FINDAD - 512
H == RECORD(INDAD)
FINISH
!
ACCTS==RECORD(ACCTSA)
!
FLAG=93
-> POK IF DTRYING << 21 < 0; ! the gods can do anything
-> VOUT IF ((SET=YES AND (SETFLAGS >> TYPE) & 1 = YES) OR C
(SET=NO AND TYPE=41) OR C
(SET=NO AND TYPE=5))
-> SUPER IF SET = YES AND TYPE = 18; ! surnames are funny
-> POK IF UNA = PROCUSER
-> POK IF IP & 2 > 0
-> POK IF SET = NO AND IP & 1 > 0
SUPER:
-> VOUT UNLESS (H ONLY >> TYPE) & 1 = 1; ! because we don't have H mapped
-> VOUT UNLESS PROCUSER = H_SUPERVISOR; ! for course supervisors
-> VOUT IF H_BASEFILE = ""
-> VOUT UNLESS CHARNO(UNA, 4) = 'U'
POK:
FLAG = 8; ! invalid parameter
-> DGET(TYPE) IF SET = 0
-> VOUT IF (LENFLAGS >> TYPE) & 1 = 1 and LENGTH(S0) >= VLEN(TYPE)
UNLESS S0 = "" OR (UCT>>TYPE) & 1 = 0 START
W = S0 {need to UCT but must first copy the data to a writeable}
S0 == W { bit of store. Have already checked its length}
UCTRANSLATE(ADDR(S0)+1, LENGTH(S0))
FINISH
-> DSET(TYPE)
DONE:
FLAG=0
DSET(*):
DGET(*):
VOUT:
VV(ADDR(F_SEMA), F_SEMANO)
OUT:
unless DIRMON = NO start
PRINTSTRING(FN)
PRINTSTRING(IND)
WRITE(TYPE, 1)
!
if SET = 0 = FLAG start ; ! report values to be returned
if NI(TYPE) = 0 c
then PRINTSTRING(" ".S0) c
else start
TOPA = ADR + (NI(TYPE) - 1) * 4
cycle J = ADR, 4, TOPA
WRITE(INTEGER(J), 1)
repeat
finish
finish else start
WRITE(SET, 1)
finish
IF FLAG = 0 C
THEN WRS(" OK") C
ELSE WRSN(" RES =", FLAG)
finish
result = OUT(flag, "NIL")
!
!
!
integerfn EN(stringname S)
string (255)W, X, Y
W = S0
W = X . Y while W -> X . ("
") . Y; ! remove any newline characters
S <- W
RESULT = 0
end
!
!
!
DGET(0): S0 = H_BASEFILE; -> DONE
DSET(0): FLAG=EN(H_BASEFILE) if DTRYING << 19 < 0; -> VOUT
DGET(1): S0 = H_DELIVERY; -> DONE
DSET(1): FLAG=EN(H_DELIVERY); -> VOUT
DGET(2): S0 = H_STARTF; -> DONE
DSET(2): FLAG=EN(H_STARTF) if DTRYING << 19 < 0; -> VOUT
DGET(3): S0 = H_DATA; -> DONE
DSET(3): FLAG=EN(H_DATA); -> VOUT
DGET(4): ! INDEX USE
I0 = F_FILES
!
NFD = (F_SIZE << 9 - F_FDSTART) // FDSIZE
N = 0; ! to count FDs in use
FDS == ARRAY(FINDAD + F_FDSTART, FDSF)
cycle J = 1, 1, NFD
exit if FDS(J)_NAME = ""
N = N + 1 unless FDS(J)_NAME = ".NULL"
repeat
I1 = N; ! FDs in use
INTEGER(ADR+8) = NFD - N; ! FDs available
INTEGER(ADR+12) = (F_SIZE+1) >> 1; ! INDEX SIZE (KBYTES)
!
NSD = (F_FDSTART - F_SDSTART) >> 2
SDS == ARRAY(FINDAD + F_SDSTART, SDSF)
INTEGER(ADR+16) = NSD
N = 0
cycle J = 1, 1, NSD
N = N + 1 if SDS(J) = 0
repeat
INTEGER(ADR+20) = N; ! number of free SDs
!
NPD = (F_SDSTART - F_PDSTART)//PDSIZE
PDS == ARRAY(FINDAD + F_PDSTART, PDSF)
N = 0
CYCLE J = 1, 1, NPD
N = N + 1 IF PDS(J)_NAME = ""
REPEAT
INTEGER(ADR+24) = NPD
INTEGER(ADR+28) = N
INTEGER(ADR+32)=0
INTEGER(ADR+36)=0
INTEGER(ADR+40)=0
INTEGER(ADR+44)=0
-> DONE
DGET(5): ! PASSWORDS
L = H_DWSP
L = L & X'7FFFFFFF' UNLESS L >> 32 = 0
*LSS_L+4
*ST_J
I0 = J !! (-1)
!
L = H_BWSP
L = L & X'7FFFFFFF' UNLESS L >> 32 = 0
*LSS_L+4
*ST_J
I1 = J !! (-1)
-> DONE
DSET(5): ! PASSWORDS
!
J = NO; ! FORE PASS TO BE SET ONLY BY DIRECT & NON-BACK JOB
if PROCUSER = "DIRECT" c
then J = YES c
else start
J = YES if UINF_REASON < 2
finish
!
if J = YES start
H_PASSFAILS = 0
J = I0
unless J = 0 start
J = J !! (-1)
*LSS_J
*LUH_0
*ST_L
H_DWSP = L
H_DWSPDT = PACKDT
finish
finish
!
J = I1
unless J = 0 start
J = J !! (-1)
*LSS_J
*LUH_0
*ST_L
H_BWSP = L
H_BWSPDT = PACKDT
finish
-> DONE
DGET(6): ! LAST LOGON
I0=H_LAST LOG ON
I1 = H_LAST NON INT START
-> DONE
DGET(7): ! ACR
I0=H_ACR
I0=DEFAULT SSACR if I0=0
-> DONE
DSET(7): ! ACR
FLAG = 93
-> VOUT unless DTRYING << 24 < 0
H_ACR=I0
H_ACR=0 if H_ACR=DEFAULT SSACR
-> DONE
DGET(8): ! DIRVSN
I0=H_DIRVSN
I1=DDVSN
-> DONE
DSET(8): ! DIRVSN
unless 0<=I0<=7 or I0=255 then -> VOUT
H_DIRVSN=I0
-> DONE
DGET(9): ! ARCHIVE INDEX DATA
VV(ADDR(F_SEMA), F_SEMANO)
!
FLAG = NEWAINDA(IND, FSYS, INDAD)
-> OUT unless FLAG = 0
!
AF == RECORD(INDAD); ! #ARCH of course
NFD = (AF_MAXFILE - AF_FDSTART) // FDSIZE
AFDS == ARRAY(INDAD+AF_FDSTART, AFDSF)
NPD = (AF_SDSTART - AF_PDSTART) // PDSIZE
PDS == ARRAY(INDAD + AF_PDSTART, PDSF)
!
A = 0; ! count archived files
AKB = 0; ! and KB
B = 0; ! count backed up files
BKB = 0
CYCLE J = 1, 1, NFD
S0 == AFDS(J)_NAME
EXIT IF S0 = ""
UNLESS S0 = ".NULL" START
N = AFDS(J)_PGS << 2; ! NKB
IF AFDS(J)_TYPE = 0 START ; ! arch
A = A + 1
AKB = AKB + N
FINISH ELSE START
B = B + 1; ! backed up
BKB = BKB + N
FINISH
FINISH
REPEAT
! H_ATOTKB = AKB; ! this will get done when #ARCH disconnected
! H_AFILES = A
!
AF_FILES0 = A
AF_CHERKB = AKB
AF_FILES1 = B
AF_TEMPKB = BKB
!
I0 = A
I1 = AKB
INTEGER(ADR + 8) = B
INTEGER(ADR + 12) = BKB
INTEGER(ADR + 16) = (AF_MAXFILE) >> 10
INTEGER(ADR + 20) = NFD
INTEGER(ADR + 24) = NFD - (A + B)
!
N = 0
CYCLE J = 1, 1, NPD
N = N + 1 IF PDS(J)_NAME = ""
REPEAT
INTEGER(ADR + 28) = NPD
INTEGER(ADR + 32) = N
J = NEWAINDA("", 0, J); ! disconnect #ARCH
INTEGER(ADR+36)=0
INTEGER(ADR+40)=0
INTEGER(ADR+44)=0
-> OUT
DGET(10):
I0=H_STKKB
-> DONE
DSET(10):
-> VOUT unless I0=0 or 12<=I0<=255
H_STKKB=I0
-> DONE
DGET(11):
I0=F_MAXKB
if I0=0 then I0=DEFAULT MAXKB
-> DONE
DSET(11):
F_MAXKB=I0
-> DONE
DGET(12):
I0=F_MAXFILE
if I0=0 then I0=DEFAULT MAXFILE
-> DONE
DSET(12):
FLAG=8
if I0<64 then -> VOUT; ! MIN 64K
F_MAXFILE=I0
-> DONE
DGET(13): ! NOS. OF INTER, BATCH AND TOTAL PROCESSES
I0=H_IUSE
I1=H_BUSE
-> DONE
DSET(13): ! NOS OF INTER AND BATCH PROCS (EMERGENCY ONLY)
H_IUSE<-I0
H_BUSE<-I1
-> DONE
DGET(14): ! PROCESS CONCURRENCY LIMITS
I0=H_IMAX
I0=DEFAULT IMAX if I0=255
I1=H_BMAX
I1=DEFAULT BMAX if I1=255
J=H_TMAX
J=DEFAULT TMAX if J=255
INTEGER(ADR+8)=J
-> DONE
DSET(14): ! PROCESS CONCURRENCY LIMITS
H_IMAX<-I0
H_BMAX<-I1
H_TMAX<-INTEGER(ADR+8)
-> DONE
DGET(15):
I0 = H_TELLREJ
-> DONE
DSET(15):
H_TELLREJ = I0
-> DONE
DGET(16):
I0 = H_DIRMON
-> DONE
DSET(16): H_DIRMON=I0
-> DONE
DGET(17):
I0 = H_SIGMON
I1 = 0
-> DONE
DSET(17): H_SIGMON<-I0
-> DONE
DGET(18): ! INITIALS AND SURNAME
S0 = H_SURNAME
-> DONE
DSET(18): ! INITIALS AND SURNAME
FLAG=EN(H_SURNAME)
-> VOUT
DGET(19): ! LOGFILE NAME
S0 = H_LOGFILE
-> DONE
DSET(19): ! LOGFILE NAME
FLAG=EN(H_LOGFILE)
-> VOUT
!------------------------ PROCESS METERING ENTRIES ---------------
DGET(20):
I0=H_IINSTRS
I1=H_BINSTRS
-> DONE
DSET(20):
H_IINSTRS=I0
H_BINSTRS=I1
-> DONE
DGET(21):
I0=SESSINSTRS
-> DONE
DGET(22):
INTEGER(ADR)=DINSTRS
-> DONE
DGET(23):
I0=H_IPTRNS
I1=H_BPTRNS
-> DONE
DSET(23):
H_IPTRNS=I0
H_BPTRNS=I1
-> DONE
DGET(24):
I0=ACCTS_PTRNS
-> DONE
DGET(25):
I0=H_NKBOUT
-> DONE
DSET(25):
H_NKBOUT=I0
-> DONE
DGET(26):
I0=H_NKBIN
-> DONE
DSET(26):
H_NKBIN=I0
-> DONE
DGET(27):
I0=H_IMSECS
I1=H_BMSECS
-> DONE
DSET(27):
H_IMSECS=I0
H_BMSECS=I1
-> DONE
DGET(28):
I0=ACCTS_MUSECS//1000
-> DONE
DGET(29):
I0=H_CONNECTT
-> DONE
DSET(29):
H_CONNECTT=I0
-> DONE
DGET(30):
! these fields are set by
! CCK CHSIZE DPERM
! DFSTAT CREATE DESTROY
! RENAME NEWGEN DISCONNECT
I0=F_FILES
INTEGER(ADR+4)=F_TOTKB
INTEGER(ADR+8)=F_CHERFILES
INTEGER(ADR+12)=F_CHERKB
INTEGER(ADR+16)=F_TEMPFILES
INTEGER(ADR+20)=F_TEMPKB
-> DONE
DGET(31):
I0 = F_AFILES
I1 = F_ATOTKB
-> DONE
DGET(32): ! interactive session length (minutes)
I0=H_ISESSM
-> DONE
DSET(32): ! interactive session length (minutes)
unless I0=0 or 5<=I0<=240 then -> VOUT; ! up to 4 hours only
H_ISESSM=I0
-> DONE
DGET(33): ! scarcity ration
VV(ADDR(F_SEMA), F_SEMANO)
I0=FUNDS(J,INDAD)
FLAG = 0
-> OUT
DSET(33): ! scarcity ration
H_INUTS=I0
-> DONE
DGET(34): ! GPFSYS
I0 = H_GPFSYS
-> DONE
DSET(35): ! test subsystem
FLAG=EN(H_TESTSS) if DTRYING << 19 < 0
-> VOUT
DGET(35): ! test subsystem
S0 = H_TESTSS
-> DONE
DSET(36): ! batch subsystem
FLAG=EN(H_BATCHSS) if DTRYING << 19 < 0
-> VOUT
DGET(36): ! batch subsystem
S0 = H_BATCHSS
-> DONE
DGET(37): ! group holder of scarcity ration
S0 = H_GPHOLDR
-> DONE
DSET(37): ! group holder of scarcity ration
FLAG=EN(H_GPHOLDR)
-> VOUT
DGET(38):
I0 = H_TRYING
-> DONE
DSET(38):
FLAG = 93
-> VOUT unless DTRYING << 14 < 0
!
DOPER2(PROCUSER." sets PRIV for ".UNA." to ".HTOS(I0,8)) UNLESS I0 = 0
!
H_TRYING = I0
-> DONE
DGET(39):
S0 = H_DEFAULTLP
-> DONE
DSET(39):
FLAG = EN(H_DEFAULTLP)
-> VOUT
DGET(40):
I0 = H_DWSPDT
I1 = H_BWSPDT
-> DONE
DGET(41): ! password info
LONGINTEGER(ADR) = H_DWSP
LONGINTEGER(ADR+8) = H_BWSP
INTEGER(ADR+16) = H_DWSPK
INTEGER(ADR+20) = H_BWSPK
INTEGER(ADR+24) = H_DWSPDT
INTEGER(ADR+28) = H_BWSPDT
-> DONE
DSET(41):
H_DWSP = LONGINTEGER(ADR)
H_BWSP = LONGINTEGER(ADR+8)
H_DWSPK = INTEGER(ADR+16)
H_BWSPK = INTEGER(ADR+20)
H_DWSPDT = INTEGER(ADR+24)
H_BWSPDT = INTEGER(ADR+28)
-> DONE
DSET(42): ! Read, and possibly clear, ACCOUNTS data
DGET(42):
FILL(68, ADR, 0) UNLESS INA = ""
!
INTEGER(ADR+36) = F_AFILES
INTEGER(ADR+40) = F_ATOTKB
INTEGER(ADR+44) = F_FILES
INTEGER(ADR+48) = F_TOTKB
INTEGER(ADR+52) = F_CHERFILES
INTEGER(ADR+56) = F_CHERKB
INTEGER(ADR+64) = F_DAY42
-> DONE UNLESS INA = ""
!
INDAD = FINDAD - 512
H == RECORD(INDAD)
!
I0 = H_IINSTRS
I1 = H_BINSTRS
INTEGER(ADR+8) = H_IPTRNS
INTEGER(ADR+12) = H_BPTRNS
INTEGER(ADR+16) = H_NKBOUT
INTEGER(ADR+20) = H_NKBIN
INTEGER(ADR+24) = H_IMSECS
INTEGER(ADR+28) = H_BMSECS
INTEGER(ADR+32) = H_CONNECTT
INTEGER(ADR+60) = H_DAPSECS
!
-> DONE IF SET = 0
!
H_IINSTRS = 0
H_BINSTRS = 0
H_IPTRNS = 0
H_BPTRNS = 0
H_NKBOUT = 0
H_NKBIN = 0
H_IMSECS = 0
H_BMSECS = 0
H_CONNECTT = 0
H_DAPSECS = 0
!
F_DAY42 = DDAYNUMBER & 255
!
-> DONE
DSET(43):
H_MAIL COUNT = I0
-> DONE
DGET(43):
I0 = H_MAIL COUNT
-> DONE
DSET(44): ! Supervisor
FLAG = EN(H_SUPERVISOR)
-> VOUT
DGET(44):
S0 = H_SUPERVISOR
-> DONE
DSET(46):
FLAG = EN(H_GATEWAY ACCESS ID)
-> VOUT
DGET(46):
S0 = H_GATEWAY ACCESS ID
-> DONE
DSET(47):
F_ATTRIBUTES = I0
-> DONE
DGET(47):
I0 = F_ATTRIBUTES
-> DONE
DSET(48):
H_TYPE = I0
-> DONE
DGET(48):
I0 = H_TYPE
-> DONE
end ; ! DSFI
!
!-----------------------------------------------------------------------
!
!<DSPOOL
externalintegerfn DSPOOL(record (PARMF)name P, integer LEN, ADR)
!
! This procedure transmits a spool request message to the Spooler
! process. ADR and LEN describe the text to be transmitted.
!
! The result of the function is 61 if the Spooler process is not
! available, or 0 if the request was successful. If Spooler was
! available, the record P contains reply information from Spooler on
! return.
!
! P1 is zero for a successful request, and P2 gives the Spooler's unique
! identifier for the document. Error messages from Spooler, in P1, are in the
! range 201-236, as follows:
! 201 Bad Parameters
! 202 No Such Queue
! 203 Queue Full
! 204 All Queues Full
! 205 Not In Queue
! 206 User Not Known
! 207 No Files In Queue
! 208 File Not Valid
! 209 No Free Document Descriptors
! 210 Not Enough Privilege
! 211 Invalid Password
! 212 Invalid Filename
! 213 Invalid Descriptor
! 214 Command Not Known
! 215 Invalid Username
! 216 Username Not Specified
! 217 Not Available From A Process
! 218 Invalid Length
! 219 Document Destination Not Specified
! 220 Invalid Destination
! 221 Invalid Source
! 222 Invalid Name
! 223 Invalid Delivery
! 224 Invalid Time
! 225 Invalid Priority
! 226 Invalid Copies
! 227 Invalid Forms
! 228 Invalid Mode
! 229 Invalid Order
! 230 Invalid Start
! 231 Invalid Rerun
! 232 Invalid Tapes
! 233 Invalid Discs
! 234 Invalid Start After
! 235 Invalid Fsys
! 236 SPOOLR File Create Fails
! In the event of a syntax error in the message, P3 is the offset from
! ADR of the offending character.
!>
INTEGER FLAG, E
CONSTINTEGER TOPEXEC = 5
CONSTSTRING (6)ARRAY EXEC(2 : TOPEXEC) = C
"VOLUMS", "SPOOLR", "MAILER", "FTRANS"
FLAG = IN2(79)
-> OUT UNLESS FLAG = 0
!
FLAG = 8
E = LEN >> 24
E = 3 IF E = 0
-> OUT UNLESS 2 <= E <= TOPEXEC
!
FLAG = DSPOOLBODY(EXEC(E), P, LEN & X'FFFFFF', ADR)
OUT:
RESULT = OUT(FLAG, "")
END ; ! DSPOOL
!
!-----------------------------------------------------------------------
!
!<DSUBMIT
externalintegerfn DSUBMIT(record (PARMF)name P, integer LEN, ADR, SACT,
string (6)USER)
!
! Allows a privileged caller to submit a batch job for user USER.
!>
INTEGER J
BYTEINTEGERARRAY M(0:2050)
STRINGNAME S
BYTEINTEGERNAME L
J = IN2(79)
-> OUT UNLESS J = 0
!
J = 93
-> OUT UNLESS DTRYING << 6 < 0
!
J = 45
-> OUT IF VAL(ADR, LEN, 0, 0) = 0
!
J = 8
-> OUT IF LEN > 2000
!
J = UNOK(USER)
-> OUT UNLESS J = 0
!
S == STRING(ADDR(M(0)))
L == BYTEINTEGER(ADDR(M(0)))
!
S = "**".USER.TOSTRING(7)." ".DATE." ".TIME
L = L - 3
S = S . ": "
MOVE(LEN, ADR, ADDR(M(L+1)))
!
P_DEST = X'FFFF0016'
J = TXTMESS("SPOOLR", P, 2, 0, L+LEN, ADDR(M(1)), -1, SACT)
OUT:
WRS3N("DSUBMIT", USER, "RES", J)
RESULT = OUT(J, "")
END ; ! DSUBMIT
!
!-----------------------------------------------------------------------
!
!<DTRANSFER
externalintegerfn DTRANSFER(string (31)FILE INDEX1, FILE INDEX2,
FILE1, FILE2, integer FSYS1, FSYS2, TYPE)
!
! This procedure transfers FILE1 belonging to file index FILE INDEX1 on
! FSYS1 to the ownership of file index FILE INDEX2 on FSYS2 under name
! FILE2.
!
! TYPE = 0 'accepts' a file which has been 'offered'. This call
! is non-privileged.
! 1 a privileged call to transfer a file.
! 2 like 1, but, in addition, forces a re-allocation of the
! disc space.
! 3 a privileged call to copy the file.
! 4 as 3 but works even when file connected W (for test purposes)
!>
INTEGER FLAG, MOVEDATA, STATE
INTEGER NKB,J,CHERISH STATUS
INTEGER PAGS
INTEGER TRIED, DA
INTEGER EP, NP
INTEGER FINDAD1, FINDAD2, DA1, DA2, LINK1, LINK2
STRING (31)UNA1, INA1, FNA1, INDEX1, FULL1
STRING (31)UNA2, INA2, FNA2, INDEX2, FULL2
RECORD (FDF)NAME FD1, FD2
RECORD (FF)NAME F1, F2
RECORD (FDF)ARRAYNAME FDS1, FDS2
RECORD (PDF)ARRAYNAME PDS1
INTEGERARRAYNAME SDS1, SDS2
INTEGERNAME SD1, SD2
CONSTSTRING (10)FN = "DTRANSFER "
!
!
!
STATE = 0; ! 1 = PP1 done
! 2 = FD1 marked UNAVA
! 4 = FILE2 has been created
!
!
FLAG=IN2(83)
-> OUT UNLESS FLAG = 0
!
FLAG = UFO(FILE INDEX1, FILE1, UNA1, INA1, FNA1, INDEX1, FULL1)
-> OUT UNLESS FLAG = 0
!
FLAG = UFO(FILE INDEX2, FILE2, UNA2, INA2, FNA2, INDEX2, FULL2)
-> OUT UNLESS FLAG = 0
!
-> POK IF DTRYING << 6 < 0
IF TYPE = 0 START ; ! accept
-> POK IF UNA2 = PROCUSER
-> POK IF FILE INDEX PERM(INDEX2, FSYS2) & 2 > 0
FINISH
FLAG = 93
-> OUT
POK:
!
FLAG=8
-> OUT UNLESS 0 <= TYPE <= 4
UNLESS -1<=FSYS1 AND FSYS2>=0 THEN -> OUT
!
FLAG = MAP FILE INDEX(INDEX1, FSYS1, FINDAD1, FN); ! P1P1P1P1P1P1P1P1P1P1
-> OUT UNLESS FLAG = 0
F1 == RECORD(FINDAD1)
STATE = 1
!
FLAG = 32
J = NEWFIND(FINDAD1, 0, FNA1)
-> OUT IF J = 0
FDS1 == ARRAY(FINDAD1 + F1_FDSTART, FDSF)
PDS1 == ARRAY(FINDAD1 + F1_PDSTART, PDSF)
SDS1 == ARRAY(FINDAD1 + F1_SDSTART, SDSF)
FD1 == FDS1(J)
SD1 == FD1_SD
IF TYPE = 0 START
-> OUT UNLESS FD1_CODES&OFFER#0 ANDC
PDS1(FD1_PHEAD)_NAME = UNA2
FINISH
!
FLAG = 5
-> OUT UNLESS FD1_CODES & (UNAVA!VIOLAT) = 0
!
FLAG = 42
-> OUT UNLESS FD1_USE = 0 ORC
(TYPE = 3 AND FD1_CODES2 & WRCONN = 0) ORC
TYPE = 4
!
FD1_CODES = FD1_CODES ! UNAVA
CHERISH STATUS = FD1_CODES & CHERSH
PAGS = FD1_PGS
VV(ADDR(F1_SEMA), F1_SEMANO); ! V1V1V1V1V1V1V1V1V1V1
STATE = 2
NKB=PAGS << 2
!
MOVEDATA = 0
MOVEDATA = 1 IF FSYS1 # FSYS2 OR TYPE > 1
!
!
TRIED = 0
TRY AGAIN:
TRIED = TRIED + 1
-> OUT IF TRIED > 10; ! FLAG set to 25 by Move Section
!
FLAG=DCREATEF(FULL2,FSYS2,NKB,MOVEDATA!2,LEAVE,DA); ! FD2 left 'UNAVA'
-> OUT UNLESS FLAG = 0
STATE = STATE ! 4
!
FLAG = MAP FILE INDEX(INDEX2, FSYS2, FINDAD2, FN); ! P2P2P2P2P2P2P2P2P2P2
-> OUT UNLESS FLAG = 0
!
F2 == RECORD(FINDAD2)
FDS2 == ARRAY(FINDAD2 + F2_FDSTART, FDSF)
SDS2 == ARRAY(FINDAD2 + F2_SDSTART, SDSF)
!
FLAG = 32
J = NEWFIND(FINDAD2, 0, FNA2)
IF J = 0 START
WRS("Dtransfer can't find " . FNA2)
-> OUT
FINISH
FLAG = 0
!
FD2 == FDS2(J)
SD2 == FD2_SD
VV(ADDR(F2_SEMA), F2_SEMANO); ! V2V2V2V2V2V2V2V2V2V2
!
EP = PAGS
WHILE EP > 0 CYCLE
NP = EP
NP = 32 IF NP > 32
EP = EP - NP
!
DA1 = SD1 << 13 >> 13 AND LINK1 = SD1 >> 19
DA2 = SD2 << 13 >> 13 AND LINK2 = SD2 >> 19
!
IF MOVEDATA = 0 START
SD1 = (LINK1 << 19) ! ((-1) >> 13)
SD2 = LINK2 << 19 ! DA1
FINISH ELSE START
FLAG = MOVE SECTION((1<<31)!FSYS1, DA1, FSYS2, DA2, NP)
IF FLAG # 0 START
J = DDESTROYF(FULL2, FSYS2, 2)
STATE = STATE & (¬4)
-> TRY AGAIN
FINISH
FINISH
!
EXIT IF EP = 0; ! appear to have finished
!
SD1 == SDS1(LINK1)
SD2 == SDS2(LINK2)
REPEAT
!
FD2_ARCH = FD1_ARCH ! 5; ! file has been connected W
FD2_CODES = CHERISH STATUS
STATE = STATE & (¬4)
!
UNLESS TYPE = 3 OR TYPE = 4 START
J = DDESTROYF(FULL1, FSYS1, 2)
STATE = 0
FINISH
OUT:
VV(ADDR(F1_SEMA), F1_SEMANO) IF STATE & 1 > 0
FD1_CODES = FD1_CODES & (¬UNAVA) IF STATE & 2 > 0
J = DDESTROYF(FULL2, FSYS2, 2) IF STATE & 4 > 0
RESULT = OUT(FLAG, "SSSSIII")
END ; ! DTRANSFER
!
!-----------------------------------------------------------------------
!
!<DUNLOCK
externalintegerfn DUNLOCK(integer ADR)
!
! This privileged procedure unlocks an area of virtual memory, identified
! by its start virtual address ADR, previously locked by a call of
! procedure DLOCK.
!>
INTEGER J,FLAG
RECORD (DRF)NAME DR LOCKED
RECORD (PARMF)Q
FLAG = IN2(84)
-> OUT UNLESS FLAG = 0
!
FLAG=8
IF ADR<=0 THEN -> OUT
CYCLE J=0,1,2
IF DRS LOCKED(J)_DR1=ADR THEN -> GOTU
REPEAT
FLAG = 79; ! NOT LOCKED
-> OUT
GOTU:
DR LOCKED==DRS LOCKED(J)
Q=0
Q_P1=-1; ! UNLOCK
Q_P5=DR LOCKED_DR0
Q_P6=ADR
LOUTP=Q
LOUTP STATE="DUNLOCK"
REF LOCK(Q,ADR,DR LOCKED_DR0<<8>>8)
LOUTP STATE="DUNLOCK exit"
IF Q_DEST=0 THEN DR LOCKED=0; ! free to lock another
FLAG=Q_DEST
OUT:
RESULT = OUT(FLAG, "X")
END ; ! DUNLOCK
!
!-----------------------------------------------------------------------
!
ENDOFFILE