!*
!* Communications record format - extant from CHOPSUPE 22B onwards *
!*
RECORDFORMAT CDRF(BYTEINTEGER IPDAPNO,DAPBLKS,DAPUSER,DAPSTATE, C
INTEGER DAP1,DAPINT)
RECORDFORMAT COMF(INTEGER OCPTYPE,SLIPL,SBLKS,SEPGS,NDISCS,DLVNADDR, C
(INTEGER GPCTABSIZE,GPCA OR INTEGER DCUTABSIZE,DCUA), C
INTEGER SFCTABSIZE,SFCA,SFCK,DIRSITE, C
DCODEDA,SUPLVN,TOJDAY,DATE0,DATE1,DATE2, C
TIME0,TIME1,TIME2,EPAGESIZE,USERS,CATTAD,SERVAAD, C
BYTEINTEGER NSACS,RESV1, C
(BYTEINTEGER SACPORT1,SACPORT0 OR BYTEINTEGER C
OCP1 SCU PORT,OCP0 SCU PORT), BYTEINTEGER C
NOCPS,SYSTYPE,OCPPORT1,OCPPORT0,INTEGER ITINT, C
(INTEGER CONTYPEA,GPCCONFA,FPCCONFA,SFCCONFA OR C
INTEGER DCU2HWNA,DCUCONFA,MIBA,SP0), C
INTEGER BLKADDR,RATION, C
(INTEGER SMACS OR INTEGER SCUS), C
INTEGER TRANS,LONGINTEGER KMON, C
INTEGER DITADDR,SMACPOS,SUPVSN,PSTVA,SECSFRMN,SECSTOCD, C
SYNC1DEST,SYNC2DEST,ASYNCDEST,MAXPROCS,INSPERSEC,ELAPHEAD, C
COMMSRECA,STOREAAD,PROCAAD,SFCCTAD,DRUMTAD,TSLICE,FEPS, C
MAXCBT,PERFORMAD,RECORD (CDRF)ARRAY CDR(1:2), C
INTEGER LSTL,LSTB,PSTL,PSTB,HKEYS,HOOT,SIM,CLKX,CLKY,CLKZ, C
HBIT,SLAVEOFF,INHSSR,SDR1,SDR2,SDR3, C
SDR4,SESR,HOFFBIT,BLOCKZBIT,BLKSHIFT,BLKSIZE,END)
RECORDFORMAT PARMF(INTEGER DEST,SRCE,P1,P2,P3,P4,P5,P6)
! misc. routine specs
EXTERNALROUTINESPEC PKMONREC(STRING (20)TEXT,RECORD (PARMF)NAME P)
EXTERNALSTRING (8)FNSPEC STRHEX(INTEGER N)
EXTERNALROUTINESPEC OPMESS3(STRING (63)TXT)
EXTERNALROUTINESPEC PON(RECORD (PARMF)NAME P)
EXTERNALROUTINESPEC DPON(RECORD (PARMF)NAME P,INTEGER DELAY)
EXTERNALROUTINESPEC INHIBIT(INTEGER N)
EXTERNALROUTINESPEC UNINHIBIT(INTEGER N)
EXTERNALROUTINESPEC DISPLAYTEXT(INTEGER VID,L,POS,STRING (41)TX)
EXTERNALROUTINESPEC SEMALOOP(INTEGERNAME SEM,INTEGER PARM)
EXTERNALROUTINESPEC DUMPTABLE(INTEGER T,A,L)
IF MONLEVEL&2#0 THEN START
EXTRINSICLONGINTEGER KMON
FINISH
IF MONLEVEL&256#0 START
EXTERNALROUTINESPEC TRACER(STRING (63) S)
FINISH
OWNINTEGER DUMPID=M'COMS'
CONSTRECORD (COMF)NAME COM=X'80000000'!48<<18
EXTERNALSTRING (15)FNSPEC STRINT(INTEGER I)
EXTERNALSTRING (15)FNSPEC HTOS(INTEGER N,M)
CONSTINTEGER UNASSIGNED = X'80808080'
CONSTINTEGER RESIDENT = 64
CONSTINTEGER LAST PROC = MAXPROCS-1
!------------------------------------------------------------------------
EXTERNALLONGINTEGERFN CLOCK
LONGINTEGER L
*RRTC_0
*ST_L
RESULT =(L>>33<<32!L&X'0FFFFFFFF')<<1
END ; ! OF CLOCK
!
!
!
!------------------------------------------------------------------------
EXTERNALROUTINE WAIT(INTEGER MILLESECS)
INTEGER T0,T1,T2,T3,ISA
ISA=COM_CLKX
*RRTC_0; *ST_T0
IF T0&1#T1>>31 START ; ! guard bit set
*LSS_1; *IAD_T0; *LB_ISA
*ST_(0+B )
FINISH
T1=T1<<1
*LSS_MILLESECS; *IMY_2
*IAD_1; *IMYD_512; ! ACC=delay in microsecs
*IAD_T0; *ST_T0
L1: *RRTC_0; *ST_T2
IF T2&1#T3>>31 START ; ! guard bit set
*LSS_1; *IAD_T2
*LB_ISA; *ST_(0+B )
FINISH
T3=T3<<1
*LSD_T2
*UCP_T0; *JCC_4,<L1>
END ; ! OF WAIT
!
!
!
!------------------------------------------------------------------------
EXTERNALROUTINE HOOT(INTEGER NUM)
INTEGER J, HOOTISA, I, HOOTBIT
HOOTBIT = COM_HBIT
HOOTISA = COM_HOOT
IF HOOTISA # 0 START ; ! lest no hooter
CYCLE J = 1,1,NUM
*LB_HOOTISA
*LSS_(0+B )
*OR_HOOTBIT
*ST_(0+B )
CYCLE I=1,1,5*COM_INSPERSEC
REPEAT
*LB_HOOTISA
*LSS_(0+B )
*SLSS_-1
*NEQ_HOOTBIT
*AND_TOS
*ST_(0+B )
CYCLE I=1,1,5*COM_INSPERSEC
REPEAT
REPEAT
FINISH
CYCLE I=1,1,20*COM_INSPERSEC
REPEAT
END ; ! OF HOOT
!
!
!
!------------------------------------------------------------------------
EXTERNALROUTINE GET PSTB(INTEGERNAME PSTB0, PSTB1)
! Machine-independent version
! Public segment PST SEG is mapped to the PST itself
RECORDFORMAT EF(INTEGER LIM, RA)
RECORD (EF)NAME E
E == RECORD(PST VA+PST SEG*8)
! E_LIM gives the size of the PST (bytes)
! for double words, >>3, and this is the top public seg which is
! potentially available. To get the VA limit therefore we <<18.
! we add the top bit and also the bottom 7 bits >>3 and <<18, which
! is the '3C'.
PSTB0 = ((E_LIM&X'0003FF80')<<15)!X'803C0000'
PSTB1 = E_RA&X'0FFFFFC0'
END ; ! of GET PSTB
!
!
!
!
!------------------------------------------------------------------------
EXTERNALROUTINE ITOE ALIAS "S#ITOE" (INTEGER AD, L)
INTEGER J
J = COM_TRANS
*LB_L; *JAT_14,<L99>
*LDTB_X'18000000'; *LDB_B ; *LDA_AD
*LSS_J; *LUH_X'18000100'
*TTR_L =DR
L99:
END ; ! of ITOE
!
!
!
!------------------------------------------------------------------------
EXTERNALROUTINE ETOI ALIAS "S#ETOI" (INTEGER AD, L)
INTEGER J
J = COM_TRANS+256
*LB_L; *JAT_14,<L99>
*LDTB_X'18000000'; *LDB_B ; *LDA_AD
*LSS_J; *LUH_X'18000100'
*TTR_L =DR
L99:
END ; ! of ETOI
!
!
!
!------------------------------------------------------------------------
EXTERNALROUTINE OPMESS(STRING (63) MESS)
OPMESS3(" 0/ ".MESS)
END ; ! of OPMESS
!
!
!
!------------------------------------------------------------------------
! writes value as two decimal ISO digits
! into AD and AD+1
ROUTINE DECWRITE2(INTEGER VALUE,AD)
*LSS_VALUE; *IMDV_10
*USH_8; *IAD_TOS ; *IAD_X'3030'
*LDA_AD; *LDTB_X'58000002'
*ST_(DR )
END ; ! of DECWRITE2
!
!
!
!------------------------------------------------------------------------
! K is days since 1st JAN 1900
! returns d, m, y 2 digit y only
ROUTINE KDATE(INTEGERNAME D,M,Y,INTEGER K)
! %INTEGER W
! K=K+693902; ! days since CEASARS bday
! W=4*K-1
! Y=W//146097
! K=W-146097*Y
! D=K//4
! K=(4*D+3)//1461
! D=4*D+3-1461*K
! D=(D+4)//4
! M=(5*D-3)//153
! D=5*D-3-153*M
! D=(D+5)//5
! Y=K
*LSS_K; *IAD_693902
*IMY_4; *ISB_1; *IMDV_146097
*LSS_TOS ; *IDV_4; *IMY_4; *IAD_3
*IMDV_1461; *ST_(Y)
*LSS_TOS ; *IAD_4; *IDV_4
*IMY_5; *ISB_3; *IMDV_153
*ST_(M); *LSS_TOS
*IAD_5; *IDV_5; *ST_(D)
IF M<10 THEN M=M+3 ELSE M=M-9 AND Y=Y+1
END ; ! of KDATE
!
!
!
!------------------------------------------------------------------------
! get time of day from real time clock
EXTERNALROUTINE UPDATE TIME
INTEGER RTC1,RTC2,JDAY,DD,MM,YY,ISA
LONGINTEGER WORK
*RRTC_0; *ST_RTC1
IF RTC1&1#RTC2>>31 START ; ! int pending
ISA=COM_CLKX
*LSS_1; *IAD_RTC1; *ST_RTC1
*LB_ISA; *ST_(0+B ); ! update clock X reg by software
FINISH
RTC2=RTC2<<1; ! now in microsecs
WORK=LONGINTEGER(ADDR(RTC1))//1000000
JDAY=WORK//86400
WORK=WORK-86400*LENGTHENI(JDAY)
IF 0<COM_SECSTOCD<X'7FFFFFFF' THEN START
COM_SECSTOCD=COM_SECSTOCD+COM_SECSFRMN-WORK
IF COM_SECSTOCD<1 THEN COM_SECSTOCD=1
FINISH
COM_SECSFRMN=WORK
!
! Work has seconds from midnight
!
ISA = ADDR(COM_TIME1)
*LDTB_X'58000002'
*LDA_ISA
*LSS_WORK+4; ! secs from midnight
!
*IMDV_60; ! %TOS=SECS, ACC=MINS
*IMDV_60; ! %TOS=MINS, ACC=HRS
!
*IMDV_10; ! convert hrs to 2 digits and store
*USH_8
*IAD_TOS
*IAD_X'3030'
*ST_(DR )
!
*INCA_3; ! increment DR
*LSS_TOS ; ! mins
*IMDV_10
*USH_8
*IAD_TOS
*IAD_X'3030'
*ST_(DR )
!
*INCA_3
*LSS_TOS ; ! secs
*IMDV_10
*USH_8
*IAD_TOS
*IAD_X'3030'
*ST_(DR )
!
DISPLAY TEXT(0, 0, 32, STRING(ISA-1))
!
! Check for passing midnight
!
IF JDAY#COM_TOJDAY START ; ! passed midnight amend date
IF 1<COM_SECSTOCD<X'7FFFFFFF' THEN C
COM_SECSTOCD=COM_SECSTOCD-86400
KDATE(DD,MM,YY,JDAY)
COM_TOJDAY=JDAY
ISA=ADDR(COM_DATE1)
DECWRITE2(DD,ISA)
DECWRITE2(MM,ISA+3)
DECWRITE2(YY,ISA+6)
DISPLAYTEXT(0,0,22,STRING(ADDR(COM_DATE0)+3))
FINISH
END ; ! of UPDATE TIME
!
!
!
!------------------------------------------------------------------------
EXTERNALINTEGERFN STOI(STRINGNAME S);!external because used by harvest package
STRING (50) P
INTEGER SIGN,AD,I,J,HEX
LONGINTEGER TOTAL
HEX=0; TOTAL=0; SIGN=1
AD=ADDR(P)
L1: ->NULLS IF S=""
I=CHARNO(S,1); ! first char
IF I=' ' THEN S->(" ").S AND ->L1; ! chop leading spaces
IF I='-' THEN S->("-").S AND SIGN=-1 AND ->L1
IF I='X' THEN S->("X").S AND HEX=1 AND ->L1
P=S
UNLESS S->P.(" ").S THEN S=""
I=1
WHILE I<=BYTEINTEGER(AD) CYCLE
J=BYTE INTEGER(I+AD)
->FAULT UNLESS '0'<=J<='9' OR (HEX#0 AND 'A'<=J<='F')
IF HEX=0 THEN TOTAL=10*TOTAL ELSE TOTAL=TOTAL<<4+9*J>>6
TOTAL=TOTAL+J&15; I=I+1
REPEAT
IF HEX#0 AND I>9 THEN ->FAULT
J<-TOTAL
IF I>1 THEN RESULT =SIGN*J
FAULT: S=P." ".S
NULLS: RESULT =UNASSIGNED
END ; ! of STOI
!
!
!
!------------------------------------------------------------------------
EXTERNALROUTINE SLAVESONOFF(INTEGER ONOFF)
!***********************************************************************
!* Turn off all slaves if ONOFF=0 *
!* Turn on all slaves if ONOFF=-1 *
!* or turn off and on slectively if ONOFF == a bitmask *
!***********************************************************************
INTEGER I,J,K,PSTB
PSTB=COM_PSTB
I=COM_SLAVEOFF
J=I>>16; I=I&X'FFFF'
K=J!!(-1); J=J&(ONOFF!!(-1))
*LB_I; *LSS_(0+B )
*AND_K; *OR_J; *ST_(0+B )
*LB_PSTB; *LSS_(0+B ); *ST_(0+B ); ! clear slaves
END ; ! of SLAVES ON OFF
!
INTEGERFN SAFE IS OP(INTEGER READORWRITE,ISAD,INTEGERNAME VAL)
!************************************************************************
!* Performs an image store action and catches any system errors *
!* result is se parameter or 0 *
!************************************************************************
RECORDFORMAT ISTF(INTEGER LNB,PSR,PC,SSR,SF,IT,IC,CTB)
RECORD (ISTF) OLDIST
RECORD (ISTF)NAME IST
INTEGERARRAY SSSNP1(0:17); ! TO SAVE SSN+1
INTEGER MYPORT
INTEGER I,J,K,ISWORD1,ISWORD2,SSR,SNAD
*LSS_(3); *USH_-26; *AND_3; *ST_MYPORT
IST==RECORD(X'80000000'!MYPORT<<18)
OLDIST=IST; ! save syserr IST entry
*STLN_I; *STSF_J; *JLK_<ERROR>; *LSS_TOS ; *ST_K
IST_LNB=I
IST_PC=K; ! reset IST in case
IST_SF=J
*LSS_(3); *ST_SSR
IST_SSR=SSR
SNAD=J&X'FFFC0000'+1<<18
CYCLE J=0,1,17
SSSNP1(J)=INTEGER(SNAD+4*J)
REPEAT
! inihibit photos (not 2960s) & for duals turn off cross-reporting/BSE
! rather unfortunate if these are the target I.S registers!!
IF SSERIES=YES START
*LSS_(X'6011'); *AND_X'FFFF'; *ST_ISWORD1
*OR_2; *ST_(X'6011')
IF MULTI OCP=YES START
*LSS_(X'601D'); *ST_ISWORD2
*LSS_(16); *USH_-24; *USH_22; *ST_(X'601D')
FINISH
FINISH ELSE IF BASIC PTYPE=4 THEN START
*LSS_(X'4012'); *ST_ISWORD1
*OR_X'01000000'; *ST_(X'4012')
IF MULTI OCP=YES START
*LSS_(X'4013'); *ST_ISWORD2
*AND_X'FFFF7FFB'; *ST_(X'4013')
FINISH
FINISH ELSE START ; ! P2 * P3S
IF BASIC PTYPE=3 START
*LSS_(X'6011'); *AND_X'FFFF'; *ST_ISWORD1
*OR_1; *ST_(X'6011')
FINISH
IF MULTI OCP=YES START
*LSS_(X'6009'); *ST_ISWORD2
*LSS_0; *ST_(X'6009'); ! dont broadcast this se
FINISH
FINISH
*LSS_SSR; *AND_-2; *ST_(3); ! unmask system errors
IF READORWRITE=0 START ; ! image store read
*LB_ISAD; *LSS_(0+B ); *ST_(VAL)
FINISH ELSE START
*LB_ISAD; *LSS_(VAL); *ST_(0+B )
FINISH
! if control gets here it worked
*LSS_SSR; *ST_(3); ! restore SSR
I=0; ->WAYOUT
ERROR: ! comes here if fails
*JLK_TOS
*LSS_TOS ; ! discard old SSN
*LSS_TOS ; *ST_I; ! se i parameter
CYCLE J=0,1,17
INTEGER(SNAD+4*J)=SSSNP1(J)
REPEAT
WAYOUT:
IF SSERIES=YES START
*LSS_ISWORD1; *ST_(X'6011')
IF MULTI OCP=YES START
*LSS_ISWORD2
*ST_(X'601D')
FINISH
FINISH ELSE IF BASIC PTYPE=4 THEN START
*LSS_ISWORD1; *ST_(X'4012')
IF MULTI OCP=YES START
*LSS_ISWORD2
*ST_(X'4013')
FINISH
FINISH ELSE START
IF BASIC PTYPE=3 START
*LSS_ISWORD1; *ST_(X'6011')
FINISH
IF MULTI OCP=YES START
*LSS_ISWORD2
*ST_(X'6009')
FINISH
FINISH
IST=OLDIST
RESULT =I
END
EXTERNALINTEGERFN SAFE IS WRITE(INTEGER ISAD,VAL)
RESULT =SAFEISOP(1,ISAD,VAL)
END
EXTERNALINTEGERFN SAFE IS READ(INTEGER ISAD,INTEGERNAME VAL)
RESULT =SAFE IS OP(0,ISAD,VAL)
END
!
!
!------------------------------------------------------------------------
ROUTINE RESPOND(INTEGER SRCE,STRING (40)TXT)
RECORD (PARMF) PP
PP_SRCE = 0
PP_DEST = SRCE << 16 ! 7; ! 7 is a conventional dact
IF LENGTH(TXT)>23 THEN LENGTH(TXT)=23
STRING(ADDR(PP_P1)) = TXT
PON(PP)
END ; ! OF RESPOND
!
!
!
!------------------------------------------------------------------------
CONSTINTEGER DIRACT=X'10014',VOLACT=X'20014',SPLACT=X'30014', C
MAILACT=X'40014',FTAACT=X'50014',MESSACT=X'5'
EXTERNALROUTINE PARSE COM(INTEGER SRCE,STRINGNAME S)
!***********************************************************************
!* Transcribe a command to a PON message and PON it *
!***********************************************************************
INTEGERFNSPEC TAPEPLACE(INTEGERNAME A,B,STRINGNAME S,INTEGER F)
INTEGERFNSPEC DISCPLACE(INTEGERNAME A,B,STRINGNAME S,INTEGER F)
INTEGERFNSPEC ONOFF(STRING (63)S)
OWNINTEGER SRCESERV=0
CONSTINTEGER LIMIT=34
CONSTINTEGER BMREP = X'3D0000'
IF SSERIES=YES START
CONSTBYTEINTEGERARRAY PARAMS(1:LIMIT)=2,1,0,0,2,1,0,0,1,0,0,0,1,1(3),0,
2,2,0,1,1,2,2,2,0,0,0,0,0,0,0,0,1;
CONSTSTRING (7)ARRAY COMMAND(1:LIMIT)="PON ","SRCE ","PLOT ",
"PLOD ","DT ","OCP ","UNPLOT ","STARTD",
"FEPUP ","DUMP ","PRIME ","OPER ","CINIT ",
"INH ","UNINH ","DIRVSN ","P ","XDUMP ",
"REP ","DDUMP ","SLAVES ","ISR ","ISW ","KMON ",
"SHOW ","DCU ","B ","F ","TRACE ","RESTART","SOFON",
"SOFOFF","DCLEAR ","FEDOWN ";
FINISH ELSE START
CONSTBYTEINTEGERARRAY PARAMS(1:LIMIT)=2,1,0,0,2,1,0,0,1,0,0,0,1,1(3),0,
2,2,0,1,1,2,2,2,0,0,0,0,1,1,1,0,1;
CONSTSTRING (7)ARRAY COMMAND(1:LIMIT)="PON ","SRCE ","PLOT ",
"PLOD ","DT ","OCP ","UNPLOT ","STARTD",
"FEPUP ","DUMP ","PRIME ","OPER ","CINIT ",
"INH ","UNINH ","DIRVSN ","P ","XDUMP ",
"REP ","DDUMP ","SLAVES ","ISR ","ISW ","KMON ",
"SHOW ","GPC ","B ","F ","TRACE ","SAC ","SMAC ",
"DAP ","DCLEAR ","FEDOWN ";
FINISH
CONSTSTRING (3)ARRAY DOW(0:6)="MON","TUE","WED","THU","FRI","SAT","SUN";
CONSTSTRINGNAME TIME = X'80C0004B'
CONSTINTEGER SECSIN24HRS=86400
SWITCH SWT(1:LIMIT)
RECORDFORMAT PARMMF(INTEGER DEST,SRCE,(INTEGER P1,P2,P3,P4,P5,P6 C
OR STRING (23)MSG))
RECORD (PARMMF) PP
INTEGERARRAY DATA(1:6)
INTEGER I,J,K, OP, SSNO, MASK ,WORK, D, M, Y, HR, MIN
LONGINTEGER L
STRING (63)PRE
STRING (63)P,Q
IF LENGTH(S) = 0 THEN RETURN ; ! ignore null lines
PP=0
SSNO = SRCE >> 16
IF SSNO = X'32' START ; ! compute prefixed line for operlog
! called from an OPER
OP = 3<<24 ! M'OP0' ! SRCE>>8&7
PRE = STRING(ADDR(OP))." ".S
FINISH ELSE START ; ! called from process
I = (SSNO - RESIDENT) & LAST PROC
PRE = STRINT(I)
PRE = " ".PRE IF I < 10
PRE = PRE."/ ".S
FINISH
!
IF S->Q.("0/").P AND Q="" THEN S=P
CYCLE I=1,1,LIMIT
->FOUND IF S->Q.(COMMAND(I)).P AND Q=""
REPEAT
OPMESS3(PRE)
CYCLE I=2,1,5
IF LENGTH(S)>=I AND CHARNO(S,I)='/' THEN ->TEXTIN
REPEAT
ERR:
RESPOND(SSNO,"????".S); ! error response
RETURN
FOUND: ! command recognised
UNLESS I=17 OR I=27 OR I=28 THEN OPMESS3(PRE); ! dont log S, B or F
J=PARAMS(I); ! (minimum) no of parameters
K=1
WHILE K<=J CYCLE
DATA(K)=STOI(P)
->ERR IF DATA(K)=UNASSIGNED; ! required parameter not given
K=K+1
REPEAT
PP_DEST = X'240000'; ! bulk mover, nearly always right!
PP_SRCE = BMREP ! (srce >> 16); ! likewise
->SWT(I)
TEXTIN: ! operator to user process
S->P.("/").Q
IF LENGTH(Q)>23 THEN ->ERR
IF P="D" THEN PP_DEST=DIRACT+COM_SYNC1DEST<<16 AND ->ON
IF P="V" THEN PP_DEST=VOLACT+COM_SYNC1DEST<<16 AND ->ON
IF P="S" THEN PP_DEST=SPLACT+COM_SYNC1DEST<<16 AND ->ON
IF P="M" THEN PP_DEST=MAILACT+COM_SYNC1DEST<<16 AND ->ON
IF P="F" THEN PP_DEST=FTAACT+COM_SYNC1DEST<<16 AND ->ON
K=STOI(P); IF K<=0 THEN ->ERR
!
K = K << 16 ! MESSACT; ! DACT = 5 for opmess in
PP_DEST = K + COM_ASYNCDEST << 16
!
ON: PP_SRCE=SRCE
LENGTH(Q)=LENGTH(Q)-1 WHILE C
LENGTH(Q)>0 AND CHARNO(Q,LENGTH(Q))=' '
STRING(ADDR(PP_P1))=Q
->POUT
SWT(1): ! PON (variable params)
PP_DEST=DATA(1)<<16!DATA(2)
CYCLE K=0,1,5
I=STOI(P)
IF I=UNASSIGNED AND P#"" AND CHARNO(P,1)='"' AND C
P->("""").Q.("""").P START
STRING(ADDR(PP_P1)+4*K)=Q
K=K+LENGTH(Q)//4
FINISH ELSE INTEGER(ADDR(PP_P1)+4*K)=I
REPEAT
IF SRCESERV=0 THEN PP_SRCE=SRCE ELSE PP_SRCE=SRCESERV
POUT: PKMONREC(TIME." Command ",PP)
PON(PP)
RETURN
SWT(2): ! SRCE = SRCE serv no for PON
SRCESERV=DATA(1)
RETURN
SWT(3): ! PLOT T F D PGE NPAGES
->ERR UNLESS TAPEPLACE(PP_P2,PP_P3,P,1)=0
->ERR UNLESS DISCPLACE(PP_P4,PP_P5,P,1)=0
I=STOI(P)
->ERR UNLESS I>0
PP_P1=X'04020000'+I
PP_P6=M'PLOT'
->POUT
SWT(4): ! PLOD FD FP TD TP NP
->ERR UNLESS DISCPLACE(PP_P2,PP_P3,P,1)=0
->ERR UNLESS DISCPLACE(PP_P4,PP_P5,P,1)=0
I=STOI(P)
->ERR UNLESS I>0
PP_P1=X'02020000'+I
PP_P6=M'PLOD'
->POUT
SWT(5): ! DT date time
WORK=DATA(1); ! date
*LSS_WORK; *IMDV_100; *IMDV_100
*ST_D; ! days
*LSS_TOS ; *ST_M; ! months
*LSS_TOS ; *ST_Y; ! year
->ERR UNLESS 1<=D<=31 AND 1<=M<=12 AND Y>=77
IF M>2 THEN M=M-3 ELSE M=M+9 AND Y=Y-1
J=1461*Y//4+(153*M+2)//5+D+58
->ERR UNLESS P->(DOW(J-(J//7)*7)).Q
!
WORK=DATA(2); ! time
*LSS_WORK; *IMDV_100
*ST_HR; ! hours
*LSS_TOS ; *ST_MIN; ! mins
->ERR UNLESS 0<=HR<=23 AND 0<=MIN<60
*LSS_J; *IMYD_SECSIN24HRS; *ST_L
L=(L+60*(60*HR+MIN))*1000000; ! microsecs since Jan 1900
I=COM_CLKX
*LB_I; *LSS_L; *ST_(0+B ); ! set clock X register
I=COM_CLKY; L=L>>1
*LB_I; *LSS_L+4; *ST_(0+B )
RETURN
SWT(6): ! OCP n ONOFF
IF MULTIOCP=YES THEN START
PP_P1=1; ! for OCP
FINISH ELSE ->ERR
ONOFF:K=ONOFF(P)
->ERR IF K<0
PP_DEST=17<<16!K
PP_P1=PP_P1<<16!DATA(1)
->POUT
SWT(7): ! UNPLOT discaddr tapeaddr npages
->ERR UNLESS DISCPLACE(PP_P2,PP_P3,P,1)=0
->ERR UNLESS TAPEPLACE(PP_P4,PP_P5,P,1)=0
I=STOI(P)
->ERR UNLESS I>0
PP_P1=X'02040000'+I
PP_P6=M'PLOT'
->POUT
SWT(8): ! STARTD. restart "DIRECT" process
PP_DEST=X'30011'
PP_SRCE=0
->POUT
SWT(9): ! FEPUP n
I=DATA(1)
->ERR UNLESS 0<=I<=9 AND COM_FEPS&(X'10000'<<I)#0
Q=TOSTRING(I+'0')
PP_SRCE=SRCE
PP_DEST=X'300001'; ! DCU/GPC <text> DEST
PP_MSG="CDS FE".Q." OFF "
DPON(PP,1)
PP_MSG="CDS FE".Q." ON "
DPON(PP,6)
PP_DEST=X'390009'; ! allocate FEP in FE adaptr
PP_P1=I
DPON(PP,11)
PP_DEST=DIRACT+COM_SYNC1DEST<<16
PP_MSG="CONNECTFE ".Q
DPON(PP,16)
PP_DEST=PP_DEST+(SPLACT-DIRACT)
DPON(PP,17)
PP_DEST=PP_DEST+(FTAACT-SPLACT)
DPON(PP,17)
RETURN
SWT(10): ! DUMP T D NPAGES
->ERR UNLESS TAPEPLACE(PP_P4,PP_P5,P,0)=0
->ERR UNLESS DISCPLACE(PP_P2,PP_P3,P,0)=0
I=STOI(P)
->ERR UNLESS I>0
PP_P1=X'02040000'+I
PP_P6=M'DUMP'
->POUT
SWT(11): ! PRIME T D NPAGES
->ERR UNLESS TAPEPLACE(PP_P2,PP_P3,P,0)=0
->ERR UNLESS DISCPLACE(PP_P4,PP_P5,P,0)=0
I=STOI(P)
->ERR UNLESS I>0
PP_P1=X'04020000'+I
PP_P6=M'PRME'
->POUT
SWT(12): ! OPER <text>
PP_DEST=X'0032000C'!SRCE&X'FF00'
->DEVTEXT
SWT(13): ! CINIT NEWPT OLDPT
IF SSERIES=NO START
->ERR UNLESS 0<=DATA(1)<=31
J=STOI(P)
UNLESS J=UNASSIGNED START
->ERR UNLESS 0<=J<=31
K=J
FINISH ELSE K=DATA(1)
I=BYTEINTEGER(COM_CONTYPEA+K); ! type of controller
IF I=2 THEN PP_DEST=X'20000A' ELSE C { DFC }
IF I=3 THEN PP_DEST=X'30000A' ELSE C { GPC }
->ERR
PP_SRCE=SRCE
PP_P1=DATA(1)
PP_P2=J
->POUT
FINISH ELSE ->ERR
SWT(14): ! INH
INHIBIT(DATA(1)); RETURN
SWT(15): ! UNINH
UNINHIBIT(DATA(1)); RETURN
SWT(16): ! DIRVSN
COM_DIRSITE=X'200'+(DATA(1)&3)*64
COM_DCODEDA=COM_SUPLVN<<24!COM_DIRSITE
RETURN
SWT(17): ! S picture screen
I = STOI(P)
IF I = UNASSIGNED START
! Picture not given as numeric
SWT17A: IF P#"" AND CHARNO(P,1)=' ' THEN P -> (" ").P AND -> SWT17A
UNLESS P -> Q.(" ").P START
Q = P
P = ""
FINISH
PP_P1 = -1
STRING(ADDR(PP_P3)) = Q
FINISH ELSE START
PP_P1 = I
FINISH
I = STOI(P)
IF I = UNASSIGNED THEN I = 0
PP_P2 = I
PP_DEST = (SRCE >> 8) << 8 ! 19; ! show picture
PP_SRCE = 0
-> POUT
!
!
!
SWT(18): ! XDUMP
DUMPTABLE(32,DATA(1),DATA(2))
RETURN
SWT(19): ! REP AT WITH
I=DATA(1)
*LDTB_X'18000004'; *LDA_I; *VAL_(LNB +1)
*JCC_7,<ERR>
J=INTEGER(I); INTEGER(I)=DATA(2)
RESPOND(SSNO,STRHEX(DATA(2))." REPS ".STRHEX(J))
RETURN
SWT(20): ! DDUMP discaddr
PP_P1=X'02050001'
PP_P6=M'DDMP'
->ERR UNLESS DISCPLACE(PP_P2,PP_P3,P,1)=0
PP_P4=0; PP_P5=0
->POUT
SWT(33): ! DCLEAR discaddr
PP_P1=X'05020001'
PP_P6=M'DCLR'
->ERR UNLESS DISCPLACE(PP_P4,PP_P5,P,1)=0
PP_P2=0; PP_P3=0
->POUT
SWT(21): ! SLAVES ONOFF(0=off)
SLAVESONOFF(DATA(1))
RETURN
SWT(22): ! image store read&display
I=DATA(1)
IF SAFE IS READ(I,J)#0 THEN ->ERR
RESPOND(SSNO,"IS ".STRHEX(I)."=".STRHEX(J))
RETURN
SWT(23): ! image store write
I=DATA(1); J=DATA(2)
IF SAFE IS WRITE(I,J)#0 THEN ->ERR
RETURN
SWT(24): ! KMON serv onoff
IF MONLEVEL&2#0 THEN START
I=DATA(1)
J=DATA(2)
->ERR UNLESS 0<=J<=1
L=LENGTHENI(1)<<I
KMON=KMON&(L!!X'FFFFFFFFFFFFFFFF')
IF J=1 THEN KMON=KMON!L
FINISH
RETURN
SWT(25): ! SHOW virtaddr length
I=DATA(1); J=DATA(2)
IF J<=0 OR J>64 THEN J=64
*LDTB_X'18000000'
*LDB_J; *LDA_I
*VAL_(LNB +1)
*JCC_3,<ERR>
CYCLE
RESPOND(SSNO, C
HTOS(I,4)." ".HTOS(INTEGER(I),8)." ". C
HTOS(INTEGER(I+4),8))
I=I+8; J=J-8
EXIT IF J<=0
REPEAT
RETURN
SWT(26): ! GPC/DCU <text>
PP_DEST=X'300001'
DEVTEXT: ! OPER <text> joins here
->ERR IF LENGTH(P)>23
PP_SRCE = SRCE
STRING(ADDR(PP_P1))=P
->POUT
SWT(27): ! B (PGB)
PP_P1 = -1
-> SWT28A
SWT(28): ! F (PGF)
PP_P1 = 1
SWT28A:
I = STOI(P)
IF I = UNASSIGNED THEN I = 0
PP_P2 = I
PP_DEST = (SRCE >> 8) << 8 ! 18; ! PGB,F
PP_SRCE = 0
-> POUT
SWT(29): !trace events
IF MONLEVEL&256#0 START
TRACER(P)
RETURN
FINISH ELSE ->ERR
IF SSERIES=YES START
SWT(30): ! restart
UNLESS COM_USERS=0 START
RESPOND(SSNO,"Processes still active!")
RETURN
FINISH
UNLESS COM_SLIPL<0 THEN COM_SLIPL=COM_SLIPL&X'FFFF'!X'80000000'
! AUTOSLOAD if set
PRINTSTRING("RESTART requested
")
STOP ; ! activates into 'RESTART'
RETURN ; ! should not!!
SWT(31): ! SOFON mask
MASK=STOI(P)
IF MASK=UNASSIGNED THEN I=X'810' ELSE I=X'800'
*LSS_(X'6011'); *OR_I; *ST_(X'6011'); ! stop on fail on
UNLESS MASK=UNASSIGNED START
*LSS_MASK; *ST_(X'602A'); ! selective inh SSR
FINISH
IF MULTI OCP=YES AND COM_NOCPS>1 START
*LSS_(3); *USH_-26; *AND_3; *ST_K
IF K=COM_OCPPORT0 THEN K=COM_OCP1 SCU PORT ELSE K=COM_OCP0 SCU PORT
K=X'400C0000'!K<<22; ! other OCP
J=K!X'6011'
*LB_J; *LSS_(0+B ); *OR_I; *ST_(0+B )
UNLESS MASK=UNASSIGNED START
J=K!X'602A'; *LB_J; *LSS_MASK; *ST_(0+B )
FINISH
FINISH
OPMESS("Stop on fail set")
RETURN
SWT(32): ! SOFOFF
*LSS_(X'6011'); *AND_X'F7EF'; *ST_(X'6011'); ! stop on fail off
*LSS_0; *ST_(X'602A')
IF MULTI OCP=YES AND COM_NOCPS>1 START
*LSS_(3); *USH_-26; *AND_3; *ST_K
IF K=COM_OCPPORT0 THEN K=COM_OCP1 SCU PORT ELSE K=COM_OCP0 SCU PORT
K=X'400C0000'!K<<22; ! other OCP addr
J=K!X'6011'
*LB_J; *LSS_(0+B ); *AND_X'F7EF'; *ST_(0+B )
J=K!X'602A'
*LB_J; *LSS_0; *ST_(0+B )
FINISH
OPMESS("Stop on fail unset")
RETURN
FINISH ELSE START
SWT(30): ! SAC <N> ONOFF
SWT(31): ! SMAC <N> ONOFF
SWT(32): ! DAP <N> ONOFF
IF RECONFIGURE=YES THEN START
PP_P1=I-28; ! 3 for SMAC 2 for SAC
! 4 for DAP
->ONOFF
FINISH ELSE ->ERR
FINISH
!
SWT(34): ! FEDOWN n
I=DATA(1)
->ERR UNLESS 0<=I<=9 AND COM_FEPS&(X'10000'<<I)#0
Q=TOSTRING(I+'0')
PP_SRCE=SRCE
PP_DEST=X'39000B'; !FE ADAPTOR DEALLOCATE
PP_P1=I; !FEP i
PON(PP)
PP_DEST=X'300001'; ! DCU/GPC <text> DEST
PP_MSG="CDS FE".Q." OFF "
DPON(PP,5)
RETURN
!
INTEGERFN DISCPLACE(INTEGERNAME A,B,STRINGNAME S,INTEGER FLAG)
!***********************************************************************
!* Extract a disc no or label from S and set A&B in bulkmover format*
!* FLAG=0 if no page no expected(when page 0 assumed) *
!***********************************************************************
INTEGER I,J,K
STRING (63)P
I=STOI(S); B=0; K=0
IF I>=0 THEN A=I+M'ED00' AND ->PAGE
AGN: RESULT =1 UNLESS S->P.(" ").S
->AGN IF P=""
RESULT =1 UNLESS LENGTH(P)=6
CYCLE I=0,1,5
BYTEINTEGER(ADDR(J)+I)=CHARNO(P,I+1)
REPEAT
A=J; B=K; ! 6 char vol label
PAGE: IF FLAG#0 START
I=STOI(S)
IF I<0 THEN RESULT =1
B=B&X'FFFF0000'+I
FINISH
RESULT =0
END
INTEGERFN TAPEPLACE(INTEGERNAME A,B,STRINGNAME S,INTEGER FLAG)
!***********************************************************************
!* Extract a tape no or label from S and set A&B in bulkmover format*
!* FLAG=0 if no chap no expected (when 1 is assumed) *
!***********************************************************************
INTEGER I,J,K
STRING (63)P
I=STOI(S); B=1; K=1
IF I>=0 THEN A=X'0031006E'+I AND ->CHAP
AGN: RESULT =1 UNLESS S->P.(" ").S
->AGN IF P=""
RESULT =1 UNLESS LENGTH(P)=6
STRING(ADDR(J))=P
A=J; B=K
CHAP: IF FLAG#0 THEN START
I=STOI(S)
IF I<0 THEN RESULT =1
B=B&X'FFFFFF00'+I&255
FINISH
RESULT =0
END
INTEGERFN ONOFF(STRING (63)S)
STRING (63)A,B
S=A.B WHILE S->A.(" ").B
RESULT =0 IF S="OFF"
RESULT =1 IF S="ON"
RESULT =-1
END
END ; ! OF PARSE COM
!
!
!
EXTERNALROUTINE BMREP(RECORD (PARMF)NAME P)
!***********************************************************************
!* Translates responses from bulk mover into *
!* text form before passing them back to *
!* the original caller (on DACT 1) *
!***********************************************************************
STRING (23)TXT
IF P_P1 = 0 C
THEN TXT = "Load OK" C
ELSE TXT = "Load fails ".STRHEX(P_P1)
RESPOND(P_DEST,TXT)
END ; ! of BMREP
!------------------------------------------------------------------------
EXTERNALROUTINE COMREP(RECORD (PARMF)NAME P)
!***********************************************************************
!* Translates the error response from de allocate tape in bulk *
!* mover and logs it *
!***********************************************************************
! Reply from de-allocate tape in move
UNLESS P_P2 = 0 START
OPMESS3("Dealloc fails:".STRING(ADDR(P_P3)))
FINISH
END ; ! OF COMREP
!
!
!
!------------------------------------------------------------------------
EXTERNALINTEGERFN HANDKEYS
INTEGER ISA
ISA=COM_HKEYS
*LB_ISA
*LSS_(0+B ); *EXIT_-64
END ; ! OF HANDKEYS
!
!
!
!------------------------------------------------------------------------
EXTERNALSTRING (255)FN STRSP(INTEGER N)
STRING (255) S
UNLESS 0<N<=255 THEN RESULT =""
S=""
S=S." " AND N=N-1 UNTIL N=0
RESULT =S
END ; ! OF STRSP
!
!
!
!------------------------------------------------------------------------
EXTERNALINTEGERFN SYSTEMCALL
INTEGER PC
*JLK_<SYSCALLI>
*LSS_TOS
*ST_PC
INTEGER(X'800000E0')=0; ! zero software syscall count
RESULT =PC
SYSCALLI:*JLK_TOS
!
! This horrible piece of coding deals with system calls. We have a RT call
! with unknown no of parameters set up together with LNB+0-2.
! LNB +3,4 undefined and usable.Can corrupt XNB & DR (PLI says so).Must
! preserve the others (esp. ACC size!). The reason for doing this here
! is that we appear to the local controller to be the user so we can
! page fault of run out of time etc. If we switch stacks to local
! controller proper we can write in IMP but the value of this is offset
! by having to precheck addresses so as not to have any page or other
! faults. If this sequence fails we restore all regs and use OUT 15
! into the local controller to force a contingency
!
*ST_TOS ; ! save ACC whatever its size
*STB_TOS ; ! save B
*CPSR_B ; *ADB_16; *STB_TOS ; ! save ACC size in PSR
*STD_(LNB +3); ! save sys call descriptor
!
! Ready to go--- follow logic of routine sys call
! beware of inward returns. Originally indicated by I=J=0 but in later
! mod levels are indicated by link (E1) descriptor in DR rather than
! the normal system call (E3) descriptor. Code must allow for both
!
*LCT_X'800000E0'; ! CTB to IST entry for syscall
*LSS_(LNB +3); *USH_-24; ! check descriptor code byte
*ICP_X'E1'; *JCC_8,<INWARDRET>; ! take link as inward return
*LSS_(LNB +3); *AND_X'FFFF'; *ST_B ; ! I value to B
*LSS_(CTB +6); *AND_X'FFFF'; ! SCTI limit from IST
*ICP_B ; *JCC_12,<FAIL0>; ! limit violated by I
*MYB_8; *ADB_(CTB +7); *LXN_B ; ! XNB to SCTI entrty
*LSS_(XNB +0); *AND_X'FFFF'; ! SCT limit
*ICP_(LNB +4); *JCC_12,<FAIL1>; ! limit violated by J
*LB_(LNB +4); *JAT_12,<inwardret>;! j=0 inward return
*MYB_16; *ADB_(XNB +1); *LXN_B ; ! XNB to relevant SCT entry
*LSS_(XNB +0); *AND_X'F00000'; ! ACR access key
*SLSS_(LNB +1); *AND_X'F00000'; ! users ACR before syscall
*ICP_TOS ; *JCC_2,<FAIL2>; ! user not allowed this call
! *LB_(%XNB+0)
! *JAF_14,<OUTWARD>; ! jump for outward calls
!
! The following if frig to route task calls (top 2 bits 0) as software
! INWARD CALLS INSTEAD OF LAST 2 LINES. THIS ENABLES SOFT PARAMETER CHECKS
!
*SLSS_(XNB +0)
*AND_X'C0000000'
*ST_B
*LSS_TOS ; ! RESET ACC
*JAT_13,<OUTWARD>
!
! check that acr is not going to be increase
!
*SLSS_(XNB +1); *AND_X'F00000'; ! new ACR from SCTE entry
*ICP_TOS ; *JCC_2,<FAIL33>; ! new ACR less privileged
!
! Update count (kept in LNB posn in IST) of soft system calls
!
*LSS_1; *IAD_(CTB +0); *ST_(CTB +0)
!
!
! CHECK THAT THE RIGHT AMOUNT OF APARMS HAVE BEEN PROVIDE. THIS
! IS IN TOP BYTE OF SECOND WORD OF TABLE
!
*LSS_(XNB +1); *USH_-24; *JAT_4,<NOCH>;! 0= NO CHECKING
*IAD_2; *ST_B ; ! MUST ALLOW FOR VARIABLE ACC
! STORED ON STACK
*LSS_TOS ; *ST_TOS ; *AND_3; ! GET ACS FROM PSR
*ICP_3; *JCC_7,<NOTQUAD>
*LSS_4
NOTQUAD: ! ACC HAS ACCSIZE IN WORDS
*IAD_B ; *ST_B ; *MYB_4; ! B HAS SPACE IN BYTES
*STSF_TOS ; *LSS_TOS ; ! STF TO ACC
*STLN_TOS ; *ISB_TOS
*ICP_B ; *JCC_7,<FAIL6>; ! WRONG PARAMS
NOCH: ! PARAMETER CHECKS NOT NEEDED
! Check validity of SCTE descriptor
!
*LSS_(XNB +2); *USH_-25; *USH_1; ! type less BCI bit
*UCP_X'E0'; *JCC_8,<DESOK>; ! code descriptor
*UCP_X'B0'; *JCC_8,<DESOK>; ! descriptor descriptor
*UCP_X'30'; *JCC_8,<DESOK>; ! 64-bit vector descripotr
*UCP_X'28'; *JCC_7,<FAIL34>; ! 32-bit vector descriptor
DESOK: ! can make the call
*LD_(XNB +2); ! descriptor to DR
*LSS_TOS ; *AND_X'FF0F'; ! old PM CC &ACS
*OR_(XNB +1); *ST_(1); ! with new ACR & priv->new PSR
*LB_TOS ; ! reset B
*L_TOS ; ! reset ACC at old size
*J_(DR ); ! into user code
OUTWARD: ! outward call
!
! First check that ACR is not going to be decreased
!
*SLSS_(XNB +1); *AND_X'F00000'; ! new ACR
*ICP_TOS ; *JCC_4,<FAIL33>; ! outward call goes inward
!
! Check for and reject (pro tem) task calls
!
*LSS_B ; *USH_-30; *JAT_4,<FAIL4>
!
! Validate new stack and copy accross parameters etc
!
*LSS_(XNB +0); *USH_18; *ST_B ; ! address of free stack
*STSF_TOS ; *LSS_TOS ; *USH_-18
*USH_18; *UCP_B ; *JCC_8,<FAIL3>; ! outward call to same stack
*LSS_(XNB +0); *AND_X'10000'; ! test "EMAS" bit
*JAT_4,<ICLST>; ! ICL stacks start at word0
*LDTB_X'28000010'; *LDA_B ; ! EMAS stacks have stndrd headr
*VAL_(XNB +1); *JCC_7,<FAIL3>; ! no access
*LSS_(DR ); *IAD_3; *AND_-4; ! find first free word in stack
*IAD_B ; *ST_B ; ! amend B past preloaded stack
ICLST: ! B has new LNB Address
*STSF_TOS ; *LSS_TOS ; ! TOS to ACC
*STLN_TOS ; *ISB_TOS ; ! bytes of parameters in ACC
*ST_TOS
*LDTB_X'18000000'; *LDB_TOS ; ! set up byte vector descptr
*LDA_B ; *VAL_(XNB +1); ! check can write params
*JCC_7,<FAIL3>; ! stack invalid
*STLN_TOS ; *LSS_TOS
*LUH_X'1800FFFF'; *MV_L =DR ; ! copy parameters(+temporaries)
!
! Frig up link descriptor to force inward return
!
*LDTB_X'28000010'; *LDA_B ; ! 16 word descriptor to new frame
*LSS_(LNB +3); *ST_(DR +1); ! syscall 'I' word
*LSS_0; *ST_(DR +2); ! J=0 for inward return
!
! Validate SSN+1 must be only 128 bytes long ie known and locked down
! by the local contoller before system call starts
!
*LSS_B ; *USH_-18; *IAD_1
*USH_18; *ST_TOS ; *LDA_TOS ; ! DR to 16 words of new SSN+1
*VAL_X'00100000'; *JCC_7,<FAIL3>
*INCA_128; *VAL_X'00100000'
*JCC_14,<FAIL3>; ! more than 128 bytes long
*INCA_-128; ! back to first 16 word
!
! Set up SSN+1 using info from current context & SCTE. Also incorporate
! checks on SCTE descriptor while digging out the new PC
!
*STB_(DR ); ! new LNB
*ISB_X'40000'; *ST_(DR +7); ! SSN
*LSS_(XNB +3); *ST_(DR +11); ! new DR1
*LSS_(XNB +2); *ST_(DR +10); ! DR0
*USH_-25; *USH_1; ! type byte less BCI bit
*UCP_X'B0'; *JCC_8,<VDES>; ! descriptor= type 2 64 bit
*UCP_X'30'; *JCC_8,<VDES>; ! descriptor= type 0 64 bit
*UCP_X'28'; *JCC_8,<VDES>; ! descriptor= type 0 32 bit
*UCP_X'E0'; *JCC_7,<FAIL34>; ! not code descriptor
*LSS_(XNB +3); *J_<ALLDES>; ! PC from code desc
VDES: *STD_TOS ; *LSD_((XNB +2)); ! get PC from vector descptr
*MPSR_X'11'; *LD_TOS ; ! get PC lose top 32 bits
ALLDES: *ST_(DR +2); ! new PC
*LSS_(3); *ST_(DR +3); ! old SSR
*LSS_(5); *ST_(DR +5); ! transfer interval timer
*LSS_(6); *ST_(DR +6); ! transfer instrn counter
*LSS_TOS ; *ST_TOS ; *AND_X'FF0F';! get OLD PM CC & ACS
*OR_(XNB +1); *ST_(DR +1); ! new PSR
!
! The ACC is difficult. Pick up from TOS force to 128 bits change DR
! and store. New ACS in PSR will discard top portion if necessary
!
*MPSR_TOS ; *LB_TOS ; *STB_(DR +9);! tranfer old B reg
*L_TOS ; *MPSR_X'13'; ! ACC to 128 bits
*LDTB_X'38000004'; *ST_(DR +3); ! words 12-15
*LDTB_X'28000010'; *STSF_B
*STLN_TOS ; *SBB_TOS ; *ADB_(DR );! add in new LNB
*STB_(DR +4); ! to get new value of SF
!
! New SSN+1 ready for activate. Set up current SSN+1 for subsequent
! inward return. Must inhibit interrupts as a register dump into
! this SSN+1 would be very inconvenient!
!
*STSF_TOS ; *LSS_TOS ; *USH_-18
*IAD_1; *USH_18; ! current SSN+1 addr in ACC
*SLSS_X'3FFE'; *LXN_TOS ; ! XNB to current SSN+1
*ST_(3); ! mask out all int xcept se
*LSS_(DR +3); *ST_(XNB +3); ! SSR from new SSN+1 to old
*LSD_(LNB +1); *ST_(XNB +1); ! PC &PSR for return
*LSS_(7); *ST_(XNB +7); ! SSN(CTB)
*STLN_(XNB +4); ! new SF = current LNB
*LSS_(LNB +0); *ST_(XNB +0); ! new LNB= current(LNB+0)
!
! SSN+1 now ready for return except for ACC,ACS CC etc which are not yet
! known. Reactivate on new stack using activate words in process list
! word 4 of IST entry is address of X28000004/adrr descriptor for
! four activate words in process list entry of this (nb! this
! hence double indirection) process
!
ASSACT:
*LSS_(DR ); *USH_-18; *USH_18
*LXN_(CTB +4); ! points to descriptor
*LXN_(XNB +1); ! now points to act words
*ST_(XNB +3); ! update last word (=SSN addr)
*ACT_(XNB +0); ! and activate it
!
INWARDRET: ! inward return
*LSS_(LNB +0); *USH_-18; *UAD_1; ! find SSN+1 to return to
*USH_18; *ST_B ; *LXN_B ; ! XNB to SSN+1
*LDTB_X'28000010'; *LDA_B ; ! DR to SSN+1
*VAL_X'00100000'; *JCC_7,<FAIL5>; ! no such SSN+1
*LSS_(DR ); *UCP_(LNB +0); ! check LNBs
*JCC_7,<FAIL5>; ! LNBs dont agreee
*AND_-2; *ST_(DR ); ! remove bottom bit which can
! be left by precall before *ACT
!
! Copy B,ACC,CC &PM to new context
!
*LB_TOS ; ! MPSR word off stack
*LSS_TOS ; *ST_(XNB +9); ! transfer B
*MPSR_B ; *L_TOS ; ! restore ACC
*MPSR_X'13'; *ST_(XNB +12); ! ACC to new context
*LSS_B ; *AND_X'FF0F'; ! get PM,CC&ACS
*SLSS_(XNB +1); *AND_X'FF0000'; ! get ACC&PRIV before owrd call
*OR_TOS ; *ST_(XNB +1); ! & combine into new PSR
*LSS_(5); *ST_(XNB +5); ! transfer interval timer
*LSS_(6); *ST_(XNB +6); ! transfer instrn counter
*LSS_X'3FFE'; *ST_(3); ! mask out all int bar sys err
*J_<ASSACT>; ! and activate on former stack
NOCANDO: ! failure off to contingency
*MPSR_TOS ; ! reset ACC size
*LB_TOS ; ! reset B
*L_TOS ; ! reset ACC
*LD_(LNB +3); ! reset sytem call descriptor
*OUT_15; ! stack switch & exit
!
! Failure . Return failure subclass (SYSTEM B compatalble where possible)
! in XNB this being only register available.(nb XNB has only 30 bits!)
!
FAIL0: *LXN_0; *J_<NOCANDO>
FAIL1: *LXN_4; *J_<NOCANDO>
FAIL2: *LXN_8; *J_<NOCANDO>
FAIL3: *LXN_12; *J_<NOCANDO>
FAIL4: *LXN_16; *J_<NOCANDO>
FAIL5: *LXN_20; *J_<NOCANDO>
FAIL6: *LXN_24; *J_<NOCANDO>
FAIL33: *LXN_132; *J_<NOCANDO>
FAIL34: *LXN_136; *J_<NOCANDO>
!***Z
END ; ! of ROUTINE SYSTEMCALL!
!
!
!------------------------------------------------------------------------
EXTERNALROUTINE BMOVE(RECORD (PARMF)NAME P)
!***********************************************************************
!* 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. *
!* 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. *
!***********************************************************************
INTEGERFNSPEC CHECK(INTEGERNAME MNEM, PAGE, INTEGER RTYEP)
CONSTINTEGER MAXSTREAMS=8
RECORDFORMAT BME(INTEGER DEST, SRCE, STEP, COUNT, FDEV, C
TODEV, L, FDINF1, FDINF2, TODINF1, TODINF2, IDENT, CORE C
, READ, CDEX, UFAIL, WTRANS, FVL1, FVL2, TVL1, TVL2)
OWNRECORD (BME)ARRAY BMS(1:MAXSTREAMS)
RECORD (BME)NAME BM
OWNINTEGER MASK=0,BMSEMA=-1
CONSTINTEGER TRANSIZE=1024*EPAGESIZE; ! BM TRANSFER SIZE
CONSTINTEGER TAPE POSN=9, FILE POSN=8, WRITE=2, READ PAGE=1
CONSTINTEGER WRITETM=10, MAX TRANS=16, REWIND=17, BACK READ=6
CONSTINTEGER REQSNO=X'240000', PRIVSNO=X'250000', MAXMASK= C
(-2)!!X'FFFFFFFF'<<(MAXSTREAMS+1), C
GETPAGE=X'50000', RETURNPAGE=X'60000', C
CLAIM TAPE=X'31000C', RELEASE TAPE=X'310007', COMREP= C
X'3E0001', ZEROEPAGEAD=X'804C0000', PDISCSNO=X'210000'
INTEGER I, INDEX, PAGE, FILE, SNO, FAIL
SWITCH STEP(1:12)
!
IF MONLEVEL&2#0 AND KMON>>(P_DEST>>16)&1#0 THEN C
PKMONREC("MOVE: ",P)
IF P_DEST>>16=PRIVSNO>>16 START ; !NAME MNEM,PAGEREPLY
INDEX=P_DEST&255
IF 1<<INDEX&MASK=0 THEN START ; ! THIS SLOT NOT IN USE!
PKMONREC("MOVE REJECTS :",P)
RETURN
FINISH
BM==BMS(INDEX)
FAIL=P_P2
->STEP(BM_STEP)
FINISH
!
! THIS THE THE ENTRY FOR A NEW REQUEST
!
IF MULTIOCP=YES THEN START
*INCT_BMSEMA
*JCC_8,<SEMAGOT1>
SEMALOOP(BMSEMA,0)
SEMAGOT1:
FINISH
CYCLE INDEX=1,1,MAXSTREAMS
IF MASK&1<<INDEX=0 THEN EXIT
REPEAT
BM==BMS(INDEX)
MASK=MASK!1<<INDEX
IF MASK=MAXMASK THEN INHIBIT(REQSNO>>16);! ALL BUFFERS IN USE
IF MULTIOCP=YES START ; *TDEC_BMSEMA; FINISH
BM_DEST=P_DEST
BM_SRCE=P_SRCE
BM_FDEV=P_P1>>24
BM_TODEV=P_P1>>16&255
BM_READ=READ PAGE
IF P_P1&X'8000'#0 THEN BM_READ=BACK READ
BM_L=P_P1&X'7FFF'
BM_FDINF1=P_P2
BM_FDINF2=P_P3
BM_TODINF1=P_P4
BM_TODINF2=P_P5
BM_IDENT=P_P6
BM_COUNT=0; BM_STEP=0
BM_UFAIL=0; BM_FVL1=0; BM_FVL2=0
BM_WTRANS=0; BM_TVL1=0; BM_TVL2=0
IF BM_L=0 THEN ->REQFAIL; ! MOVE 0 PAGES DISALLOWED
IF BM_FDEV=2 AND CHECK(BM_FDINF1,BM_FDINF2,READPAGE)#0 C
THEN ->REQFAIL
IF BM_TODEV=2 AND CHECK(BM_TODINF1,BM_TODINF2,WRITE)#0C
THEN ->REQFAIL
IF BM_TODEV=3 AND (BM_TODINF2>2 OR BM_TODINF2<0) C
THEN ->REQFAIL; ! 0,1,OR 2 TMARKS ONLY ALLOWED
!
! PON A CHECK BLOCKS ACTIVE TO ACTIVEMEM. TEMPORARY TO FIND BUG
!
! %IF BM_TODEV=2 %START
! P_DEST=X'00080006'
! %CYCLE I=0,1,BM_L-1
! P_P1=BM_TODINF2+I
! PON(P)
! %REPEAT
! %FINISH
P_DEST=GETPAGE; ! REQUEST ONE (EXTENDED) PAGE
BM_STEP=0
IF BM_FDEV>=5 START
BM_CDEX=0
BM_CORE=ZEROEPAGEAD
->CORE GOT
FINISH
PONIT:P_SRCE=PRIVSNO!INDEX
BM_STEP=BM_STEP+1
PON(P)
RETURN
STEP(1): ! CORE PAGE FROM CORE ALLOT
BM_CDEX=P_P2; ! CORE INDEX NO(FOR RETURNING)
BM_CORE=P_P4
CORE GOT: ! BY HOOK OR BY CROOK
->FDEVPOSD UNLESS BM_FDEV=4; ! UNLESS A MAG TAPE
!
! CODE HERE TO CLAIM THE INPUT TAPE AND PUT ITS SERVICE NO IN INF1
!
IF BM_FDINF1>>24#0 START ; ! TAPE LABEL NOT SERVICE NO
P_DEST=CLAIM TAPE
P_P2=X'00040001'; ! TAPE FOR READING
P_P3=BM_FDINF1; P_P4=BM_FDINF2; P_P6=0
BM_FVL1=BM_FDINF1; BM_FVL2=BM_FDINF2;! REMEMBER FOR RELEASE
BM_STEP=1; ->PONIT
STEP(2): ! REPLY FROM CLAIM TAPE
IF P_P2#0 THEN ->POSFAIL
BM_FDINF1=P_P3; ! SERVICE NO FOR TAPE
BM_FDINF2=BM_FDINF2&255; ! CHAPTER NO OF FILE
FINISH
SNO=BM_FDINF1
BM_STEP=2
FILE=BM_FDINF2&255
TAPEPOS: ! TAPE POSITION TO 'FILE'
P_DEST=SNO
P_P1=FILE; ! IDENT FOR LATER
P_P2=REWIND
->PONIT; ! SKIP BACK TO BT
STEP(3): ! FROM TAPE AT BT
STEP(6): ! TO TAPE AT BT
->POSFAIL UNLESS FAIL=4 OR FAIL=0
P_DEST=P_SRCE
P_P2=P_P1<<16!1<<8!TAPE POSN
->PONIT; ! SKIP FORWARD N FILES
STEP(4): ! FROMTAPE AT RIGHT FILE
->POSFAIL UNLESS FAIL=0
!
! THIS BULK MOVER MOVES TAPE CHAPTERS ONLY
!
FDEVPOSD:
->POSCOMPLETE UNLESS BM_TODEV=4; ! OPUT TAPE NEEDS POSITIONING
!
! CODE HERE TO CLAIM THE OUTPUT TAPE
!
IF BM_TODINF1>>24#0 START ; ! TAPE GIVEN AS LABEL NOT SNO
P_DEST=CLAIM TAPE
P_P2=X'00040002'; ! TAPE FOR WRITING
P_P3=BM_TODINF1; P_P4=BM_TODINF2; P_P6=0
BM_TVL1=BM_TODINF1; BM_TVL2=BM_TODINF2
BM_STEP=4; ->PONIT
STEP(5): ! REPLY FROM CLAIM OUTPUT TAPE
IF P_P2#0 THEN ->POSFAIL
BM_TODINF1=P_P3
BM_TODINF2=BM_TODINF2&255; ! CHAPTER NO
FINISH
SNO=BM_TODINF1
FILE=BM_TODINF2&255
BM_STEP=5
->TAPEPOS
STEP(7): ! BOTH DEVICES POSITONED
->POSFAIL UNLESS FAIL=0
POSCOMPLETE:
READ PG:
BM_COUNT=BM_COUNT+1
IF BM_FDEV<5 THEN START ; ! NOT FROM A ZERO PAGE
P_DEST=BM_FDINF1
P_P3=BM_CORE
IF BM_FDEV=3 OR BM_FDEV=4 THEN START
P_P2=TRANSIZE<<16!BM_READ
FINISH ELSE START
P_P2=BM_FDINF2-1+BM_COUNT
FINISH
BM_STEP=7
P_P1=BM_COUNT
->PONIT
FINISH ELSE FAIL=0
STEP(8): ! PAGE READ
->READ FAIL UNLESS FAIL=0
IF BM_TODEV<5 THEN START
CYCLE
P_DEST=BM_TODINF1
P_SRCE=PRIVSNO!INDEX
BM_STEP=8
P_P3=BM_CORE
IF BM_TODEV=4 OR BM_TODEV=3 THEN START
P_P2=TRANSIZE<<16!WRITE
FINISH ELSE START
P_P2=BM_TODINF2-1+BM_COUNT
FINISH
P_P1=BM_COUNT
PON(P)
BM_STEP=9
BM_WTRANS=BM_WTRANS+1
RETURN IF BM_FDEV<5 OR BM_WTRANS>=MAX TRANS OR C
BM_COUNT>=BM_L
BM_COUNT=BM_COUNT+1
REPEAT
FINISH ELSE START
BM_WTRANS=BM_WTRANS+1
DUMPTABLE(34,BM_CORE,TRANSIZE)IF BM_TODEV=5
FINISH
STEP(9): ! PAGE WRITTEN
BM_WTRANS=BM_WTRANS-1
->WRITEFAIL UNLESS FAIL=0
->READ PG IF BM_COUNT<BM_L AND BM_UFAIL=0
RETURN UNLESS BM_WTRANS=0
!
STEP(10): !FIRST TM WRITE
->TMFAIL UNLESS FAIL=0
P_DEST=BM_TODINF1
P_P1=M'BMTM'
P_P2=WRITE TM
IF BM_TODEV=3 AND BM_TODINF2#0 START ;! ARCH TAPE NEEDS TM?
BM_STEP=BM_STEP+2-BM_TODINF2; ! ONE OR TWO TMS
->PONIT
FINISH
->PONIT IF BM_TODEV=4
STEP(11): !BOTH TMS WRITTEN
->TMFAIL UNLESS FAIL=0
WAYOUT: !DEALLOCATE CORE
RETURN UNLESS BM_WTRANS=0
P_DEST=RETURN PAGE
P_SRCE=0; ! REPLY NOT WANTED
P_P2=BM_CDEX
PON(P) UNLESS BM_FDEV>=5; ! RETURN CORE
P_DEST=RELEASE TAPE
P_SRCE=COMREP
IF BM_FDEV=4 AND BM_FVL1#0 START
P_P2=X'00040000'!BM_FDINF1&X'FFFF'
P_P3=BM_FVL1; P_P4=BM_FVL2; P_P5=1
PON(P); ! RELEASE FROM TAPE
FINISH
IF BM_TODEV=4 AND BM_TVL1#0 START
P_P2=X'00040000'!BM_TODINF1&X'FFFF'
P_P3=BM_TVL1; P_P4=BM_TVL2; P_P5=1
PON(P); ! RELEASE OUTPUT TAPE
FINISH
REPLY: !SET UP REPLY
P_DEST=BM_SRCE
P_SRCE=REQSNO
P_P1=BM_UFAIL
P_P2=BM_IDENT
PON(P); !REPLY TO REQUEST
IF MULTIOCP=YES THEN START
*INCT_BMSEMA
*JCC_8,<SEMAGOT2>
SEMALOOP(BMSEMA,0)
SEMAGOT2:
FINISH
IF MASK=MAXMASK THEN UNINHIBIT(REQSNO>>16)
MASK=MASK!!1<<INDEX
IF MULTIOCP=YES START ; *TDEC_BMSEMA; FINISH
RETURN
REQFAIL: ! FAULT WITH REQUEST
BM_UFAIL=-2
->REPLY
POSFAIL: ! UNABLE TO POS TAPE
BM_UFAIL=-3
->WAYOUT
TMFAIL: ! TAPE MARK DID NOT WRITE!
->ETWONTM IF FAIL=4
BM_UFAIL=-4 IF BM_UFAIL=0
->WAYOUT
ETWONTM: ! END OF TAPE WARNING
BM_UFAIL=-5
->WAYOUT
!
! The format of the failure flags given below is described in comment at
! the head of this routine.
!
READFAIL: ! UNABLE TO READ
IF BM_UFAIL=0 THEN C
BM_UFAIL=READPAGE<<24!P_P1!FAIL<<16
->WAYOUT
WRITEFAIL: ! UNABLE TO WRITE PAGE
IF BM_UFAIL=0 THEN C
BM_UFAIL=WRITE<<24!P_P1!FAIL<<16
->WAYOUT
!
INTEGERFN CHECK(INTEGERNAME MNEM,PAGE,INTEGER RTYPE)
!***********************************************************************
!* CHECKS A DISC ID VOR VALIDITY & AVAILABILITY *
!***********************************************************************
RECORDFORMAT DDTFORM(INTEGER SER, PTS, PROPADDR, STICK, STATS, C
RQA, LBA, ALA, STATE, IW1, IW2, SENSE1, SENSE2, SENSE3, C
SENSE4, REPSNO, BASE, ID, DLVN, MNEMONIC, C
STRING (6) LAB, BYTEINTEGER MECH)
RECORD (DDTFORM)NAME DDT
INTEGER I,L,V1,V2
L=6; V1=MNEM; V2=PAGE
CYCLE I=0,1,COM_NDISCS-1
DDT==RECORD(INTEGER(COM_DITADDR+4*I))
IF (DDT_MNEMONIC=MNEM OR STRING(ADDR(L)+3)=DDT_LABOR C
MNEM=DDT_DLVN&X'FFFF') AND 4<=DDT_STATE<=7 THEN START
MNEM=PDISCSNO!RTYPE
IF STRING(ADDR(L)+3)=DDT_LAB THEN PAGE=PAGE&X'FFFF'
PAGE=PAGE!DDT_DLVN<<24
RESULT =0
FINISH
REPEAT
RESULT =1
END ; ! OF CHECK
!
!
!
END ; ! OF MOVE
!
!
!
ENDOFFILE