%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)
   %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 PST VA=X'80040000';       ! SEGMENT TABLE BASE ADDRESS
%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)
LSEMAGOT:
      %IF LOGROUTE&X'FFFF'=0 %THEN ->WAYOUT
      %IF LOGROUTE>>16=MYPORT %THEN ->WAYOUT
      LOGSEMA=-1
      AWAIT LOG ROUTE
WAYOUT:
      LOGROUTE=(LOGROUTE&X'FFFF'+1)!MYPORT<<16
      LOGSEMA=-1
%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)
LSEMAGOT:
      %IF LOGROUTE&X'FFFF'=0 %OR LOGROUTE>>16#MYPORT %THEN %C
         OPMESS("LOGROUTE PATHS ? ".STRHEX(LOGROUTE)) %C
         %ELSE LOGROUTE=LOGROUTE-1
      LOGSEMA=-1
%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)
LSEMAGOT:
         %IF LOGROUTE&X'FFFF'=0 %THEN ->WAYOUT
          LOGSEMA=-1
      %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)
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 %THEN %C
            LOGSEMA=-1 %AND AWAIT LOG ROUTE
      %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 %THEN LOGSEMA=-1
%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)
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 %THEN LOGSEMA=-1
               %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 %THEN LOGSEMA=-1
         %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 %THEN LOGSEMA=-1
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)
SEMAGOT4:
      %FINISH
      CHANGE FILE %IF DPAGE>0
      %IF MULTIOCP=YES %THEN LOGSEMA=-1
      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)
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)&MASK)!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 %THEN LOGSEMA=-1
      %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)
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 %THEN LOGSEMA=-1
      %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 %THEN LOGSEMA=-1
      %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
%STRING (32) SHEAD
      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
         SHEAD="DT: ".OLDDATE." ".OLDTIME." OCPTYPE ?
"
         BYTEINTEGER(ADDR(SHEAD)+31)=COM_OCPTYPE+48
         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