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'
EXTERNALROUTINE MOVE ALIAS "S#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
INTEGER I
I=ADDR(S)
*LDTB_X'18000008'; *LDA_I; *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,J
J=ADDR(S)
IF PLACES>8 THEN PLACES=8
I=64-4*PLACES
*LDTB_X'18000008'; *LDA_J; *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 I,D0, D1, D2, D3
I=ADDR(S)
*LSS_N; *CDEC_0
*LDTB_X'18000010'; *LDA_I; *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
*LDTB_X'18000010'; *LDA_I; *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
EXTERNALROUTINE IOCP ALIAS "S#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
OWNBYTEINTEGERARRAY BUFFER(0:133)=0(*)
OWNINTEGER BUFFERAD=-1
IF SSERIES=YES START
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) 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)
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
BUFFERAD=ADDR(BUFFER(0))
! use private areas where possible (but DCU1 TCBs must be in COM area)
! 'lest LP in use when 'grabbed' by PON X36 6
IF SSERIES=YES START
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
ALE2=BUFFERAD+1
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
!!
!--------------------------------------------------------------
EXTERNALROUTINE WRITE ALIAS "S#WRITE" (INTEGER VALUE, PLACES)
STRING (16) S
INTEGER I,D0, D1, D2, D3, L
I=ADDR(S)
*LSS_VALUE; *CDEC_0
*LDTB_X'18000010'; *LDA_I; *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