%RECORDFORMAT PARMF(%INTEGER DEST, SRCE, P1, P2, P3, P4, P5, P6)
%EXTRINSICLONGINTEGER KMON
%ROUTINESPEC PRHEX(%INTEGER H)
%ROUTINESPEC PRINTER(%RECORD(PARMF)%NAME P)
%EXTERNALROUTINESPEC PON(%RECORD(PARMF)%NAME P)
%EXTERNALROUTINESPEC GDC(%RECORD(PARMF)%NAME P)
%EXTERNALROUTINESPEC OPMESS(%STRING (23) MESS)
%SYSTEMROUTINESPEC ITOE(%INTEGER A, L)
%IF MULTIOCP=YES %THEN %START
%EXTERNALROUTINESPEC SEMALOOP(%INTEGERNAME SEMA,%INTEGER PARM)
%ROUTINESPEC RESERVE LOG
%ROUTINESPEC RELEASE LOG
%ROUTINESPEC AWAIT LOG ROUTE
%FINISH
!------------------------------------------------------------------------
!*
!* Communications record format - extant from CHOPSUPE 22A onwards *
!*
%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,SACPORT1,SACPORT0, %C
NOCPS,RESV2,OCPPORT1,OCPPORT0,%INTEGER ITINT,CONTYPEA, %C
(%INTEGER GPCCONFA %OR %INTEGER DCUCONFA), %C
%INTEGER FPCCONFA,SFCCONFA,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,SP1,SP2,SP3,SP4,SP5,SP6, %C
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)
!*
%CONSTRECORD(COMF)%NAME COM=X'80C00000'
%SYSTEMROUTINE MOVE(%INTEGER LENGTH, FROM, TO)
*LB_LENGTH; *JAT_14,<L99>
*LDTB_X'18000000'; *LDB_%B; *LDA_FROM
*CYD_0; *LDA_TO; *MV_%L=%DR
L99:
%END; ! of MOVE
%CONSTBYTEINTEGERARRAY H(0 : 15) = %C
'0','1','2','3','4','5','6','7','8','9',
'A','B','C','D','E','F'
%EXTERNALSTRING (8) %FN STRHEX(%INTEGER VALUE)
%STRING (8) S
*LD_S; *LSS_8; *ST_(%DR)
*INCA_1; *STD_%TOS; *STD_%TOS
*LSS_0; *LUH_VALUE
*MPSR_X'24'; ! SET CC=1
*SUPK_%L=8
*LD_%TOS; *ANDS_%L=8,0,15; ! THROW AWAY ZONE CODES
*LSS_H+4; *LUH_X'18000010'
*LD_%TOS; *TTR_%L=8
%RESULT =S
%END
%EXTERNALSTRING (8) %FN HTOS(%INTEGER VALUE, PLACES)
%STRING (8) S
%INTEGER I
%IF PLACES>8 %THEN PLACES=8
I=64-4*PLACES
*LD_S; *LSS_PLACES; *ST_(%DR)
*INCA_1; *STD_%TOS; *STD_%TOS
*LSS_VALUE; *LUH_0; *USH_I
*MPSR_X'24'; ! SET CC=1
*SUPK_%L=8
*LD_%TOS; *ANDS_%L=8,0,15; ! THROW AWAY ZONE CODES
*LSS_H+4; *LUH_X'18000010'
*LD_%TOS; *TTR_%L=8
%RESULT =S
%END
!-----------------------------------------------------------------------
%EXTERNALSTRING (15) %FN STRINT(%INTEGER N)
%STRING (16) S
%INTEGER D0, D1, D2, D3
*LSS_N; *CDEC_0
*LD_S; *INCA_1; ! PAST LENGTH BYTE
*CPB_%B; ! SET CC=0
*SUPK_%L=15,0,32; ! UNPACK 15 DIGITS SPACE FILL
*STD_D2; ! FINAL DR FOR LENGTH CALCS
*JCC_8,<WASZERO>; ! N=0 CASE
*LSD_%TOS; *ST_D0; ! SIGN DESCRIPTOR STKED BY SUPK
*LD_S; *INCA_1
*MVL_%L=15,15,48; ! FORCE IN ISO ZONE CODES
%IF N<0 %THEN BYTEINTEGER(D1)='-' %AND D1=D1-1
BYTEINTEGER(D1)=D3-D1-1
%RESULT =STRING(D1)
WASZERO:
%RESULT ="0"
%END
%EXTERNALROUTINE PKMONREC(%STRING(20)TEXT,%RECORD(PARMF)%NAME P)
%INTEGER I, J, SPTR, VAL
%STRING (131) S
S=TEXT
SPTR=LENGTH(S)+1
CHARNO(S,SPTR)=' '; SPTR=SPTR+1
%CYCLE I=ADDR(P),4,ADDR(P)+28
VAL=INTEGER(I)
%CYCLE J=28,-4,0
CHARNO(S,SPTR)=H((VAL>>J)&15)
SPTR=SPTR+1
%REPEAT
CHARNO(S,SPTR)=' '
SPTR=SPTR+1
%REPEAT
%CYCLE I=ADDR(P)+8,1,ADDR(P)+31
J=BYTEINTEGER(I)
%IF J<32 %OR J>95 %THEN J='_'
CHARNO(S,SPTR)=J
SPTR=SPTR+1
%REPEAT
CHARNO(S,SPTR)=NL
LENGTH(S)=SPTR
PRINTSTRING(S)
%END
%EXTERNALINTEGERFN REALISE(%INTEGER AD)
!***********************************************************************
!* THIS FUNCTION TAKES A VIRTUAL ADDRESS AND VIA SEGMENT AND PAGE *
!* TABLES RETURNS THE CORRESPONDING REAL ADDRESS. *
!* NOTE: NO FACILITY FOR SHARED SEGMENTS CURRENTLY REQD. *
!***********************************************************************
%CONSTINTEGER RA128=X'0FFFFF80'; ! 128 BYTE ALIGNED MASK FOR NON-PAGED SEGMENT ENTRY
%CONSTINTEGER RA8=X'0FFFFFF8'; ! 8 BYTE ALIGNED MASK FOR PAGED SEGMENT ENTRY
%CONSTINTEGER RA1024=X'0FFFFC00'; ! PAGE ALIGNED MASK FOR PAGE TABLE ENTRY
%CONSTINTEGER PUBLIC=X'80000000'; ! THESE TWO MAKE UP REAL CORE BASE ADDRESS
%CONSTINTEGER SEG64=X'01000000'; ! WHICH IS AT PSEG 64
%CONSTINTEGER PAGEDBIT=X'40000000'
%INTEGER VASE; ! VIRTUAL ADDRESS OF SEGMENT TABLE ENTRY
%INTEGER VAPE; ! VIRTUAL ADDRESS OF PAGE TABLE ENTRY
VASE=PST VA+(AD>>15)&X'FFF8'
%IF INTEGER(VASE)&PAGEDBIT#0 %START; ! PAGED SEGMENT
VAPE=((INTEGER(VASE+4)&RA8)+SEG64+(AD<<14>>24)<<2)! PUBLIC
!
! IF WE HAVE TRUTHFUL SEGMENT TABLES
! (CURRENTLY WE DO NOT - SEE CHOPSUPE ROUTINE 'CONFIG')
! THEN LEST STORE BE DISCONTIGUOUS :-
! VAPE=VAPE-(INTEGER(PST VA+((VAPE>>15)&X'FFF8')+4)&X'20000')
!
%RESULT =INTEGER(VAPE)&RA1024+(AD&X'3FF')
%FINISH
! UN-PAGED SEGMENT
%RESULT =(AD&X'3FFFF')+(INTEGER(VASE+4))&RA128
%END
!!
%CONSTSTRING(8) %NAME DATE=X'80C0003F'
%CONSTSTRING(8) %NAME TIME=X'80C0004B'
!!
!***********************************************************************
!* *
!* THESE FUNCTIONS ALL USE A PACKED FORMAT OF DATE AND TIME OF ONE OF *
!* THE FOLLOWING FORMS.BITS ARE NUMBERED FROM 31 (MOST SIGNIFICANT) TO *
!* 0 (LEAST SIGNIFICANT) *
!* OLD FORMAT *
!* BITS USE *
!* 31 ZERO FOR OLD FORMAT *
!* 30-26 YEAR-70 (VALID FOR 1970-2033) *
!* 25-22 MONTH *
!* 21-17 DAY *
!* 16-12 HOUR *
!* 11- 6 MINUTE *
!* 5- 0 SECOND *
!* *
!* NEW FORMAT *
!* BIT31 1 FOR NEW FORMAT *
!* ALL OTHER BITS HOLD DT AS SECS SINCE 0000HRS ON 1/1/70 *
!* CALCULATED AS PER CACM COLLECTER ALGORITHMS NO 199Z *
!* NB TO KEEP LEAP YEARS CORRECT ONE MUST USE THIS ALGORITH FROM *
!* 1ST JAN 1900 AND THEN CORRECT. THIS INVOLVES 64BIT ARITHMETIC *
!***********************************************************************
%INTEGERFN CURRENT PACKED DT
!***********************************************************************
!* GIVES CURRENT DT IN NEW PACKED FORM *
!***********************************************************************
%CONSTLONGINTEGER MILL=1000000
%CONSTLONGINTEGER SECS70=X'0000000083AA7E80';! SECS DITTOM
*RRTC_0; *USH_-1
*SHS_1; *USH_1
*IMDV_MILL
*ISB_SECS70; *STUH_%B
*OR_X'80000000'
*EXIT_-64
%END
%EXTERNALROUTINE DUMPTABLE(%INTEGER TABLE, ADD, LENGTH)
%OWNINTEGER NEXT
%INTEGER I, K, END, SPTR, VAL
%STRING (132) S
ADD=ADD&(-4)
%IF MULTIOCP=YES %THEN RESERVE LOG
NEWLINE
%IF TABLE>0 %THEN %START
NEXT=NEXT+1
PRINTSTRING("DT: ".DATE." ".TIME."
**** SUPERVISOR DUMP TABLE: ". %C
STRINT(TABLE)." ADDR ".STRHEX(ADD)." LENGTH: " %C
.STRINT(LENGTH)." DUMP NO: ".STRINT(NEXT)."****
")
%FINISH
END=ADD+LENGTH; I=1
S=" "
%UNTIL ADD>=END %CYCLE
->INVL %IF ADD>=0; ! DUMP PUBLIC ADDRESSES ONLY
*LDTB_X'18000020'; *LDA_ADD
*VAL_(%LNB+1); *JCC_3,<INVL>
%IF I=0 %AND ADD+32<END %THEN %START
%CYCLE K=ADD,4,ADD+28
->ON %IF INTEGER(K)#INTEGER(K-32)
%REPEAT
S="O"; ->UP
%FINISH
ON:
CHARNO(S,2)='('; SPTR=3
%CYCLE I=28,-4,0
CHARNO(S,SPTR)=H((ADD>>I)&15)
SPTR=SPTR+1
%REPEAT
CHARNO(S,SPTR)=')'
CHARNO(S,SPTR+1)=' '
SPTR=SPTR+2
%CYCLE K=ADD,4,ADD+28
VAL=INTEGER(K)
%CYCLE I=28,-4,0
CHARNO(S,SPTR)=H((VAL>>I)&15)
SPTR=SPTR+1
%REPEAT
CHARNO(S,SPTR)=' '
SPTR=SPTR+1
%REPEAT
%IF TABLE>=0 %THEN %START
CHARNO(S,SPTR)=' '
SPTR=SPTR+1
%CYCLE K=ADD,1,ADD+31
I=BYTEINTEGER(K)&X'7F'
%UNLESS 32<=I<127 %THEN I=' '
CHARNO(S,SPTR)=I
SPTR=SPTR+1
%REPEAT
%FINISH
CHARNO(S,SPTR)=NL
BYTEINTEGER(ADDR(S))=SPTR
PRINTSTRING(S)
S=" "
UP: ADD=ADD+32
I=0
%REPEAT
->WAYOUT
INVL:
PRINTSTRING("ADDRESS VALIDATION FAILS
")
WAYOUT: ! EXIT FREEING PATH
%IF MULTIOCP=YES %THEN RELEASE LOG
%END; !ROUTINE DUMP
! OWN VARIABLES FOR JOINT USE BY 'IOCP' AND 'PRINTER'
%CONSTINTEGER MASK=X'80FC3FFF', BUFFBASE=X'80FC0000', PAGEMASK= %C
X'80FC3000'
%EXTERNALINTEGER INPTR=X'80FC0000'
%EXTERNALINTEGER OUTPTR=X'80FC0000'
%OWNINTEGER BUSY, DINTPEND=0, INTPEND, TESTPEND=0, INIT=0
%OWNINTEGER MODE=-1
%CONSTINTEGER SPOOLING=1, PRINTING=0
%IF MULTIOCP=YES %THEN %START
%OWNINTEGER LOGSEMA=-1 ; ! SEMAPHORE FOR IOCP AND PRINTER
%OWNINTEGER LOGROUTE=0; ! BOTTOM HALF HAS COUNT
! IF COUNT>0 TOPHALF HAS OCP PORT
%EXTERNALROUTINE RESERVE LOG
!***********************************************************************
!* CLAIMS THE LOG FOR CALLING ROUTINE. WAITS IF NEEDED. THIS ROUTINE*
!* IS USED IN DUALS TO PREVENT TABLES BEING MIXED UP *
!* NESTED CLAIMS AND RELEASE BY SAME OCP ARE PERMITTED *
!***********************************************************************
%INTEGER MYPORT
*LSS_(3); *USH_-26
*AND_3; *ST_MYPORT; ! PORT OF OCP EXECUTING THIS
*INCT_LOGSEMA
*JCC_8,<LSEMAGOT>
SEMALOOP(LOGSEMA,0)
LSEMAGOT:
%IF LOGROUTE&X'FFFF'=0 %THEN ->WAYOUT
%IF LOGROUTE>>16=MYPORT %THEN ->WAYOUT
*TDEC_LOGSEMA
AWAIT LOG ROUTE
WAYOUT:
LOGROUTE=(LOGROUTE&X'FFFF'+1)!MYPORT<<16
*TDEC_LOGSEMA
%END
%EXTERNALROUTINE RELEASE LOG
!***********************************************************************
!* RELEASE THE LOG PATH *
!***********************************************************************
%INTEGER MYPORT
*LSS_(3); *USH_-26
*AND_3; *ST_MYPORT; ! PORT OF OCP EXECUTING THIS
*INCT_LOGSEMA
*JCC_8,<LSEMAGOT>
SEMALOOP(LOGSEMA,0)
LSEMAGOT:
%IF LOGROUTE&X'FFFF'=0 %OR LOGROUTE>>16#MYPORT %THEN %C
OPMESS("LOGROUTE PATHS ? ".STRHEX(LOGROUTE)) %C
%ELSE LOGROUTE=LOGROUTE-1
*TDEC_LOGSEMA
%END
%ROUTINE AWAIT LOG ROUTE
!***********************************************************************
!* AWAITS LOGROUTE COMING FREE AND RETURNS WITH LOGSEMA HELD *
!* TIMES OUT AFTER ABOUT 5 SECS ON 2970 *
!***********************************************************************
%INTEGER MYPORT,I,J
%IF MONLEVEL&4#0 %START
%EXTRINSICLONGINTEGER SEMATIME
%INTEGER IT
*LSS_(5); *ST_IT
%FINISH
*LSS_(3); *USH_-26
*AND_3; *ST_MYPORT; ! PORT OF OCP EXECUTING THIS
%CYCLE J=1,1,2000
%CYCLE I=1,1,COM_INSPERSEC; ! WAIT ABOUT 1 MILLESEC
%REPEAT; ! DONT USE RTC IN CASE OTHER
! OCP HAS CLOCK&HAS DIED
*INCT_LOGSEMA
*JCC_8,<LSEMAGOT>
SEMALOOP(LOGSEMA,0)
LSEMAGOT:
%IF LOGROUTE&X'FFFF'=0 %THEN ->WAYOUT
*TDEC_LOGSEMA
%REPEAT
OPMESS("LOGROUTE TIMEOUT")
LOGROUTE=0; ! HAVE TIMED OUT
WAYOUT:
%IF MONLEVEL&4#0 %START; ! RECORD WASTED TIME
*LSS_(5); *IRSB_IT; *IMYD_1
*IAD_(SEMATIME); *ST_(%DR)
%FINISH
%END
%FINISH
%SYSTEMROUTINE IOCP(%INTEGER EP, N)
!***********************************************************************
!* THIS ROUTINE RECEIVES ALL THE OUTPUT FROM MAIN VIA IMP STMTS *
!* SUCH AS PRINTSTRING, AND SENDS IT TO THE MAIN PRINT FILE. *
!* SEGMENT P63 IS USED AS THE BUFFER. IF OUTPUT ARRIVES FASTER *
!* THAN THE PRINTER CAN COPE IT IS DISCARDED. *
!* A SIMILAR ROUTINE IN SLOWFILE IS USED WITH A VIRTUAL PRINTER *
!***********************************************************************
%RECORD(PARMF) Q
%INTEGER I, J, ADR, L, OLDINPTR, SYM, NLSEEN, MYPORT, MYMASK
%STRING (63) S
%RETURN %UNLESS X'280A8'&1<<EP\=0;!CHECK FOR VALID ENTRY
NLSEEN=0
%IF EP=17 %THEN %START; ! REPEATED SYMBOLS
L=N>>8&63
ADR=ADDR(S)+1
! J = L
! %WHILE J > 0 %CYCLE
! CHARNO(S,J) = N&127
! J = J-1
! %REPEAT
!
! EQUIVELANT OF ABOVE 5 LINES IS
!
J=N&127
I=X'18000000'!L
*LDTB_I
*LDA_ADR
*LB_J
*MVL_%L=%DR
%FINISH %ELSE %START
%IF EP>=7 %THEN %START; ! PRINT STRING
L=BYTE INTEGER(N); ADR=N+1
%FINISH %ELSE %START; ! PRINT SYMBOL & PRINT CH
L=1; ADR=ADDR(N)+3
%FINISH
%FINISH
!
! NOW PUT MESSAGE INTO BUFFER IF THERE IS ROOM
!
I=1
%IF MULTIOCP=YES %THEN %START
*INCT_LOGSEMA
*JCC_8,<SEMAGOT>
SEMALOOP(LOGSEMA,0)
SEMAGOT:
%FINISH
!
! CHECK AND AWAIT THE LOGROUTE IN DUALS EXCEPT FOR SYSTEM ERRORS
! THE OTHER OCP IS HALTED HERE, SO NO POINT IN WAITING
! ALSO SYSTEM ERROR IN SINGLES CAN BREAK INTO DEVICE ERROR
! SO JOURNAL SYSTEM HAS TO BE ABLE TO COPE WITH THIS.
!
%IF MULTIOCP=YES %AND LOGROUTE&X'FFFF'>0 %START
*LSS_(3); *ST_MYMASK; *USH_-26; *AND_3; *ST_MYPORT
%IF MYPORT#LOGROUTE>>16 %AND MYMASK&1=0 %START
*TDEC_LOGSEMA
AWAIT LOG ROUTE
%FINISH
%FINISH
OLDINPTR=INPTR
%WHILE I<=L %CYCLE
->END %IF BUSY=1; ! BUFFERS BUSY DISCARD OUTPUT
J=(INPTR+1)&MASK
%IF J&X'FFF'<=63 %THEN INPTR=J!63 %AND J=INPTR+1
%IF J#OUTPTR %THEN %START; ! ROOM FOR CURRENT CHAR
SYM=BYTE INTEGER(ADR)
BYTE INTEGER(J)=SYM
%IF SYM=133 %THEN SYM=NL
%IF SYM=NL %THEN NLSEEN=1
ADR=ADR+1; I=I+1
INPTR=J
%FINISH %ELSE BUSY=1 %AND ->END
%REPEAT
!
! PON A KICK TO PRINTER IF A LINE (OR PAGE IN DISC MODE) HAS BEEN COMPLETED
! AND PRINTER IS IDLE. HOWEVER IF REPORTING A RECOVERED ERROR (IE SYSERR
! INT IS MASKED OUT) REFRAIN FROM PONNING. RECOVERED ERROR MIGHT BE
! A SINGLE BIT OR RETRY FROM PON OR POFF
!
*LSS_(3); *AND_1; *JAF_4,<END>;! JUMP IF SYSERR MASKED
%IF (OLDINPTR=OUTPTR %AND NLSEEN#0) %C
%OR (MODE=SPOOLING %AND INPTR&PAGEMASK#OLDINPTR& %C
PAGEMASK) %THEN Q_DEST=X'360000' %AND PON(Q)
END:
%IF MULTIOCP=YES %START; *TDEC_LOGSEMA; %FINISH
%END; ! OF ROUTINE IOCP
!!
%EXTERNALROUTINE PRINTER(%RECORD(PARMF)%NAME P)
!***********************************************************************
!* This (over elaborate) version of printer supports both a real *
!* printer and a virtual (disc) printer allowing switching between *
!* the two at any time. This was useful in development but in a *
!* service situation a disc only version would be samller and easier*
!* to maintain. *
!***********************************************************************
%ROUTINESPEC INITIALISE FILE
%ROUTINESPEC CHANGE FILE
%ROUTINESPEC DISCWRITE(%INTEGER AD)
%ROUTINESPEC PREPORT(%INTEGER VALUE)
%ROUTINESPEC DEALLOCATE MAIN PRINTER(%INTEGER REPLY ACT)
%ROUTINESPEC ALLOCATE MAIN PRINTER(%INTEGER REPLY ACT)
%INTEGER I, J, ACT, DMON, PAGE, PREVMODE
%OWNINTEGER BUFFERAD=-1
%IF SSERIES=YES %START
%OWNBYTEINTEGERARRAY BUFFER(0:133)=0(*); ! protem - put this into dev area
%RECORDFORMAT TCBF(%INTEGER COMMAND,STE,LEN,DATAD,NTCB,RESP, %C
%INTEGERARRAY PREAMBLE,POSTAMBLE(0:3))
%OWNRECORD(TCBF)%NAME TCB
%CONSTINTEGER TCBM=X'2F004000'
%INTEGER LEN,DATAD
%FINISH %ELSE %START
%RECORDFORMAT RCBF(%INTEGER LFLAG, LSTBA, LBL, LBA, ALL, ALA, INIT,SPARE)
%OWNRECORD(RCBF)%NAME RCB
%OWNINTEGER LBE=X'80700300',ALE1,ALE2
%FINISH
%OWNINTEGER PAGESTATE=0; ! bitmask of pages with trnsfers
%CONSTINTEGER PONSRC=X'360000'
%CONSTINTEGER GPCSNO=X'300000'
%CONSTINTEGER AUTO=X'8000'
%OWNINTEGER MNEM=M'LP', ACTSIZE=0
%OWNINTEGER DPAGE=0; ! disc address
%OWNINTEGER CFILE=0, SECTSIZE=0
%OWNINTEGERARRAY DPAGES(0 : 1) = -1(2)
%OWNINTEGER DISCDEST,TRANSTABAD=0
! file header block
%RECORDFORMAT HDRF(%INTEGER HDR1,HDR2,HDR3,HDR4,HDR5,HDR6,HDR7,HDR8)
%IF SSERIES=YES %START
%RECORDFORMAT ENTFORM(%INTEGER %C
SER, PTSM, PROPADDR, SECS SINCE, CAA, GRCB AD, %C
%BYTE %INTEGER LAST ATTN, DACTAD, %HALF %INTEGER HALFSPARE, %C
%INTEGER LAST TCB ADDR, %C
STATE, PAW, RESP1, SENSE1, SENSE2, SENSE3, SENSE4, %C
REPSNO, BASE, ID, DLVN, MNEMONIC, %C
%STRING (6) LABEL, %BYTE %INTEGER HWCODE, %C
%INTEGER ENTSIZE, URCB AD, SENSDAT AD, LOGMASK, TRTAB AD, %C
UA SIZE, UA AD, TIMEOUT,PROPS0,PROPS1)
%FINISH %ELSE %START
%RECORDFORMAT ENTFORM(%INTEGER SER, PTSM, PROPADDR, %C
TICKS SINCE, CAA, GRCB AD, LBA, ALA, STATE, RESP0, %C
RESP1, SENSE1, SENSE2, SENSE3, SENSE4, REPSNO, BASE, %C
ID, DLVN, MNEMONIC, ENTSIZE, PAW, USAW0, URCB AD, %C
SENSDAT AD, LOGMASK, TRTAB AD, UA SIZE, UA AD, %C
TIMEOUT, PROPS0, PROPS1)
%FINISH
%RECORD(ENTFORM)%NAME D
%OWNSTRING (8) OLDDATE, OLDTIME
%OWNINTEGER OLDPDT
%OWNINTEGER SOURCE8
%CONSTINTEGER MAXACT=10
%SWITCH DACT(0:MAXACT)
!!
!!
!!
%IF INIT=0 %THEN %START; ! first time in - initialise
ALLOCATE MAIN PRINTER(10)
INIT=-1
%FINISH
!!
!!
!!
ACT=P_DEST&255
%IF ACT>MAXACT %THEN ACT=0; ! dont report for fear of starting loop
%IF MONLEVEL&2#0 %THEN DMON=KMON>>54&1
%IF MONLEVEL&2#0 %AND DMON#0 %AND ACT#0 %AND %C
(ACT#2 %OR P_P1&X'800000'=0) %THEN PKMONREC("PRINT( IN):",P)
! dont monitor clock or normal terms
->DACT(ACT)
!!
!****************************************
!!
NEXTLINE:
%IF MODE=PRINTING %THEN BYTEINTEGER(BUFFERAD)=0
!!
!!------------------------------------------------
DACT(0): ! alarm clock tick or equivalent
%IF MULTIOCP=YES %THEN %START
*INCT_LOGSEMA
*JCC_8,<SEMAGOT1>
SEMALOOP(LOGSEMA,0)
SEMAGOT1:
%FINISH
%IF MODE=SPOOLING %START
I=OUTPTR
%CYCLE J=1,1,4
%IF (I-1)<=INPTR<(I+4096)&X'FFFFFFC0' %C
%AND BUSY=0 %THEN %START
%IF MULTIOCP=YES %START; *TDEC_LOGSEMA; %FINISH
%RETURN
%FINISH
PAGE=(I-BUFFBASE)//(EPAGESIZE*1024)
%IF PAGESTATE&(1<<PAGE)=0 %THEN DISCWRITE(I)
I=(I+4096)&MASK
%REPEAT
%FINISH
%IF MODE!INTPEND!TESTPEND!DINTPEND#0 %START
%IF MULTIOCP=YES %START; *TDEC_LOGSEMA; %FINISH
%RETURN; ! unless printing & no ints pending
%FINISH
%IF INPTR=OUTPTR %THEN ->UNBUSY; ! nothing to print
! check we were not inhibited
I=BYTEINTEGER(BUFFERAD)
%CYCLE
J=BYTE INTEGER(OUTPTR)
BYTE INTEGER(OUTPTR)=0
%IF J=10 %THEN J=133
%IF J=133 %OR J=12 %OR I=132 %START
%IF I=132 %THEN BYTEINTEGER(OUTPTR)=J %C
%AND J=133 %ELSE %START
OUTPTR=(OUTPTR+1)&MASK
%IF OUTPTR&X'FFF'<=63 %THEN OUTPTR=OUTPTR+64
%FINISH
I=I+1; BYTEINTEGER(BUFFERAD+I)=J
BYTEINTEGER(BUFFERAD)=I
%IF SSERIES=YES %START
TCB_LEN=I
DATAD=TCB_DATAD
ITOE(DATAD,I)
%FINISH %ELSE %START
ALE1=X'58000000'+I
ITOE(ALE2,I)
%FINISH
%IF TRANSTABAD#0 %START
%IF SSERIES=YES %START
LEN=X'58000000'+I
*LDTB_LEN; *LDA_DATAD
%FINISH %ELSE %START
*LD_ALE1
%FINISH
*LSS_TRANSTABAD
*LUH_X'18000100'
*TTR_%L=%DR; ! non-printables to null
%FINISH
%EXIT
%FINISH
OUTPTR=(OUTPTR+1)&MASK
%IF OUTPTR&X'FFF'<=63 %THEN OUTPTR=OUTPTR+64
%IF J#13 %THEN I=I+1 %AND BYTEINTEGER(BUFFERAD+I)=J
%IF INPTR=OUTPTR %THEN BYTEINTEGER(BUFFERAD)=I %AND ->UNBUSY
! incomplete line
%REPEAT
%IF MULTIOCP=YES %START; *TDEC_LOGSEMA; %FINISH
PRINT: ! print line in array buffer(again)
P=0
%IF SSERIES=YES %START
P_P1=ADDR(TCB)
%FINISH %ELSE %START
P_P1=ADDR(RCB)
P_P3=X'11'; ! PAW - do stream request, SAW - clear abnormal
%FINISH
P_DEST=GPCSNO!12
P_SRCE=PONSRC!5
P_P2=INIT
PON(P)
INTPEND=1
%RETURN
!!
!!-----------------------------------------------
! execute request rejected
DACT(5):
!!
PREPORT(P_P1)
INTPEND=0
%RETURN
!!
!!-----------------------------------------------
DACT(1): ! new log file
! P_P1=no of epages (16)
! P_P2=disc addr
%IF MONLEVEL&2#0 %AND DMON=1 %THEN %C
OPMESS("New log file ".HTOS(P_P2,8))
SECTSIZE=P_P1<<12
%IF DPAGES(0)>0 %AND DPAGES(1)>0 %START
PRINTSTRING("Spurious log file")
%RETURN
%FINISH
%IF DPAGES(CFILE)=0 %THEN DPAGES(CFILE)=P_P2 %C
%ELSE DPAGES((CFILE+1)&1)=P_P2
%IF DPAGE=0 %THEN INITIALISE FILE
->NEXTLINE
!!
!!------------------------------------------------
!! Printer interrupts terms&attns, come here
DACT(2):
J=(P_P1>>20)&15
%IF J=1 %START; ! attention
%IF TESTPEND#0 %AND P_P1&AUTO#0 %C
%THEN TESTPEND=0 %AND ->PRINT
%RETURN; ! ignore all other attentions
%FINISH
INTPEND=0
!!
!! May be waiting for LP term before deallocating to avoid
!! a spurious term going to the next owner
!!
%IF MODE=SPOOLING %THEN %START
DEALLOCATE MAIN PRINTER(9)
%RETURN
%FINISH
!!
%IF J=8 %THEN ->NEXTLINE; ! normal term
! abnormal term.
OPMESS("Attend main LP")
TESTPEND=1; %RETURN
!!
!!------------------------------------------------
!! Reset to printer - after D/MAINLP (obeying allocation rules)
!!
DACT(8):
SOURCE8=P_SRCE
%IF MODE#PRINTING %START
ALLOCATE MAIN PRINTER(3)
%RETURN
%FINISH
P_P1=81; ! DIR error "already main lp"
DACT(3): ! reply from above allocat
P_DEST=SOURCE8
P_SRCE=PONSRC!8
%IF 0#P_P1#81 %THEN P_P1=95; ! DIR err "main lp fails"
PON(P)
%RETURN %IF P_P1\=0; ! no allocate done
DACT(10): ! reply from initial allocate
EXIT6:
%IF P_P1#0 %THEN PREPORT(P_P1) %AND %RETURN
D==RECORD(P_P3)
TRANSTABAD=D_TRTABAD
INIT=P_P2
MNEM=P_P6
MODE=PRINTING
%IF SSERIES=YES %START
BUFFERAD=ADDR(BUFFER(0)); ! protem
!BUFFERAD=D_UA AD+14*4
TCB==RECORD(D_UA AD)
TCB=0
TCB_COMMAND=TCBM!X'83'; ! write
TCB_STE=REALISE(BUFFERAD&X'FFFC0000')!1
TCB_DATAD=BUFFERAD+1
%FINISH %ELSE %START
BUFFERAD=D_UA AD+32
ALE2=BUFFERAD+1
RCB==RECORD(D_UA AD)
RCB=0
RCB_LBL=4
RCB_LBA=ADDR(LBE)
RCB_ALL=8
RCB_ALA=ADDR(ALE1)
%FINISH
%IF MULTIOCP=YES %THEN %START
*INCT_LOGSEMA
*JCC_8,<SEMAGOT4>
SEMALOOP(LOGSEMA,0)
SEMAGOT4:
%FINISH
CHANGE FILE %IF DPAGE>0
%IF MULTIOCP=YES %START; *TDEC_LOGSEMA; %FINISH
INTPEND=0
->NEXTLINE
!!
!!----------------------------------
!!
DACT(6): ! emergency reset by hairy PON
! no reply. Use emergency allocate
P_DEST=GPCSNO!8; ! emergency allocate
P_P1=M'LP'; ! any LP will do
P_P2=PONSRC!2
GDC(P); ! direct call for emergency allocate
->EXIT6;
!!----------------------------------------------------
DACT(7): ! close current output
%IF MONLEVEL&2#0 %AND DMON = 1 %THEN %C
OPMESS("NLF ".HTOS(INPTR,8)." ".HTOS(OUTPTR,8))
PREVMODE=MODE
DISCDEST=P_SRCE
%IF MULTIOCP=YES %THEN %START
*INCT_LOGSEMA
*JCC_8,<SEMAGOT5>
SEMALOOP(LOGSEMA,0)
SEMAGOT5:
%FINISH
%IF MODE=SPOOLING %START
BYTEINTEGER((INPTR+1)&MASK)=4; ! EOM character
DISCWRITE(OUTPTR)
! Subtract unused space
ACTSIZE=ACTSIZE-(X'1000'-((INPTR&X'FFF')+1))
INPTR=((INPTR+4096)&PAGEMASK)!63; ! move onto next page
CHANGE FILE
%FINISH %ELSE %START; ! zero front of first page
%IF INPTR<OUTPTR %AND INPTR>>12=OUTPTR>>12 %START
BUSY=1
I=(INPTR&PAGEMASK)!64
%WHILE I<=OUTPTR %CYCLE
BYTEINTEGER(I)=0
I=I+1
%REPEAT
%FINISH
MODE=SPOOLING
%IF DPAGES(0)=-1=DPAGES(1) %THEN CHANGE FILE %C
%ELSE INITIALISE FILE
! ACT to acquire new files if neccesary
%FINISH
%IF MULTIOCP=YES %START; *TDEC_LOGSEMA; %FINISH
%IF PREVMODE=PRINTING %THEN DEALLOCATE MAIN PRINTER(9)
->NEXTLINE
!!
!!------------------------------------------------
DACT(4): ! disc termination
%IF DINTPEND=0 %START
PRINTSTRING("
Spurious log disc int ")
%RETURN
%FINISH
DINTPEND=DINTPEND-1
PAGESTATE=PAGESTATE&(X'FFFFFFFF'!!(1<<P_P1));! clear transfer bit
J=BUFFBASE+(P_P1<<12)
!
! Zero block - null character
!
*LDTB_X'18001000'
*LDA_J
*MVL_%L=%DR,0,0
%IF MULTIOCP=YES %THEN %START
*INCT_LOGSEMA
*JCC_8,<SEMAGOT6>
SEMALOOP(LOGSEMA,0)
SEMAGOT6:
%FINISH
%IF P_P2#0 %START; ! abnormal termination
OPMESS(" Log file abterm ".HTOS(P_P2,2))
DINTPEND=0; ! forget other transfers outstanding on faulty file
PAGESTATE=0
CHANGE FILE
%FINISH
%CYCLE
PAGE=(OUTPTR-BUFFBASE)//(EPAGESIZE*1024)
%EXIT %IF PAGESTATE&(1<<PAGE)#0
OUTPTR=((OUTPTR+4096)&PAGEMASK)!64
->UNBUSY %IF OUTPTR-1<=INPTR<(OUTPTR+4096)
%REPEAT
%IF MULTIOCP=YES %START; *TDEC_LOGSEMA; %FINISH
%RETURN
!!------------------------------
!!
DACT(9): ! reply from dellocate
! after switch to spooling
%IF P_P1#0 %THEN PREPORT(P_P1)
TESTPEND=0
BUFFERAD=-1
%RETURN
!!
!!-------------------------------------------------
!!
UNBUSY: ! restart if buffer oflow occurred
! LOGSEMA is claimed
%IF BUSY=1 %THEN %START
%IF MODE=SPOOLING %THEN INPTR=OUTPTR
%IF MONLEVEL&2#0 %AND DMON = 1 %THEN OPMESS("Unbusy")
BUSY=0
I=-1
%FINISH %ELSE I=0
%IF MULTIOCP=YES %START; *TDEC_LOGSEMA; %FINISH
%IF I=-1 %THEN PRINTSTRING("
*** output lost ***
")
%RETURN
%ROUTINE INITIALISE FILE
!***********************************************************************
!* SEMA must be claimed before calling this *
!***********************************************************************
%RETURN %UNLESS MODE=SPOOLING
ACTSIZE=0
OUTPTR=(OUTPTR&PAGEMASK)!64
%IF BUSY=1 %THEN INPTR=OUTPTR-1
! pack date and time
OLDPDT=CURRENT PACKED DT
OLDTIME=TIME
OLDDATE=DATE
DPAGE=DPAGES(CFILE)
%END
%ROUTINE CHANGEFILE
!***********************************************************************
!* SEMA must be held before calling this. Can not let other OCP in *
!* while changing files *
!* close current spool file and request another one *
!* if both files closed , requests have already been sent, so return*
!***********************************************************************
%RETURN %IF DPAGES(0)=0 %AND DPAGES(1)=0
%RETURN %IF ACTSIZE=0 %AND DPAGE#0; ! no empty files
AGN:
%IF MONLEVEL&2#0 %AND DMON=1 %THEN %C
OPMESS("Change file ".HTOS(DPAGE,8)." ".HTOS(ACTSIZE,6))
P=0
P_DEST=DISCDEST
P_SRCE=PONSRC!1
P_P1=DPAGE
P_P2=ACTSIZE
PON(P)
ACTSIZE=0
DPAGES(CFILE)=0; ! mark file closed
CFILE=(CFILE+1)&1; ! change to alternate file
DPAGE=DPAGES(CFILE)
%IF DPAGE>0 %THEN INITIALISE FILE %ELSE %START
%IF DPAGE=-1 %THEN DPAGE=0 %AND ->AGN
%FINISH
%END
%ROUTINE DISCWRITE(%INTEGER AD)
!***********************************************************************
!* SEMA must be held for call of change file *
!***********************************************************************
%RECORD(HDRF)%NAME HDR
%CONSTBYTEINTEGERARRAY SYSTYPE(0:2)=M'P',M'S',M'S'
%STRING (32) SHEAD
%INTEGER STYPE
AD=AD&PAGEMASK
P=0
P_P1=(AD>>12)&3; ! block 0:3
! Return unless no file available or page already sent
%RETURN %IF DPAGE<=0 %OR PAGESTATE&(1<<P_P1)#0
%IF MONLEVEL&2#0 %AND DMON=1 %THEN %C
OPMESS("DISCW ".HTOS(AD,8)." ".HTOS(DPAGE,8))
%IF DPAGE&15=0 %START; ! header page
HDR==RECORD(AD)
HDR_HDR1=SECTSIZE
HDR_HDR2=32
HDR_HDR3=HDR_HDR1
HDR_HDR4=3
HDR_HDR5=0
HDR_HDR6=OLDPDT
HDR_HDR7=-256
HDR_HDR8=0
*LSS_(16); *USH_-16; *AND_255; *ST_STYPE
SHEAD="DT: ".OLDDATE." ".OLDTIME." OCP n t "."
"
BYTEINTEGER(ADDR(SHEAD)+28)=COM_OCPTYPE+48
BYTEINTEGER(ADDR(SHEAD)+30)=SYSTYPE(STYPE)
MOVE(32,ADDR(SHEAD)+1,AD+32)
%FINISH
P_DEST=X'210002'
P_SRCE=PONSRC!4
P_P2=DPAGE
P_P3=AD
PON(P)
DINTPEND=DINTPEND+1; ! remember disc term. pending
PAGESTATE=PAGESTATE!(1<<P_P1); ! lock page until disc write complete
ACTSIZE=ACTSIZE+4096
%IF ACTSIZE>=SECTSIZE %THEN CHANGE FILE %C
%ELSE DPAGE=DPAGE+1
%END
%ROUTINE PREPORT(%INTEGER VALUE)
OPMESS("MLP activity ".STRINT(ACT)." fails ".STRINT(VALUE))
%END
%ROUTINE DEALLOCATE MAIN PRINTER(%INTEGER REPLY ACT)
%RECORD(PARMF) Q
%IF INTPEND#0 %THEN %RETURN
Q=0; Q_DEST=GPCSNO!5
Q_SRCE=PONSRC!REPLYACT
Q_P1=MNEM
PON(Q)
%END
%ROUTINE ALLOCATE MAIN PRINTER(%INTEGER REPLYACT)
%RECORD(PARMF) Q
Q=0
Q_DEST=GPCSNO!11
Q_P2=PONSRC!2
Q_SRCE=PONSRC!REPLYACT
Q_P1=MNEM
PON(Q)
%END
%END; ! OF ROUTINE PRINTER
!!
!--------------------------------------------------------------
%SYSTEMROUTINE WRITE(%INTEGER VALUE, PLACES)
%STRING (16) S
%INTEGER D0, D1, D2, D3, L
*LSS_VALUE; *CDEC_0
*LD_S; *INCA_1; *STD_%TOS
*CPB_%B; ! SET CC=0
*SUPK_%L=15,0,32; ! UNPACK & SPACE FILL
*STD_D2; *JCC_8,<WASZERO>
*LD_%TOS; *STD_D0; ! FOR SIGN INSERTION
*LD_%TOS
*MVL_%L=15,63,0; ! FORCE ISO ZONE CODES
%IF VALUE<0 %THEN BYTEINTEGER(D1)='-'
L=D3-D1
OUT: %IF PLACES>=L %THEN L=PLACES+1
D3=D3-L-1
BYTEINTEGER(D3)=L
PRINTSTRING(STRING(D3))
%RETURN
WASZERO:
BYTEINTEGER(D3-1)='0'
L=2; ->OUT
%END
%EXTERNALROUTINE PRHEX(%INTEGER I)
! 8-DIGIT HEX PRINT
PRINTSTRING(STRHEX(I))
%END; ! PRHEX
%ENDOFFILE