%include "ercc08.comf370"
%include "ercc08.page0f"
%recordformat PARMF(%integer DEST,SRCE,(%integer P1,P2,P3,P4,P5,
   P6 %orstring (23) TEXT))
%constinteger PCELLSIZE=36,MARGIN=48
%recordformat PDOPEF(%integer CURRMAX,MAXMAX,FIRST UNALLOC,LAST UNALLOC,
   NEXTPAGE,S1,S2,S3,S4)
%recordformat PARMXF(%integer DEST,SRCE,P1,P2,P3,P4,P5,P6,LINK)
%constrecord (PARMXF) %arrayname PARM=PARM0AD
%constrecord (PDOPEF) %name PARMDOPE=PARM0AD
%recordformat STOREF(%shortinteger FLAGS,USERS,LINK,BLINK,FLINK)
%constrecord (STOREF) %arrayname STORE=STORE0AD
!
%externallonginteger SEMATIME=0
%owninteger PARMASL=0
%externalinteger MAINQSEMA=-1
%externalintegerspec STORESEMA
%ownintegerarray GET NEW PAGE(0:14);    ! parms for call of new epage
!
%constinteger LOCSN1=LOCSN0+MAXPROCS
%recordformat SERVF(%integer P,L)
                                        ! L is link in circular chain of
                                        ! services which constitute a queue
                                        ! P is pointer to circular list
                                        ! of parameters for this service
                                        ! 2**31 bit of P is inhibit
                                        ! 2**30 of P is inter OCP lockout
%constrecord (SERVF) %arrayname SERVA=SERVAAD
! Local controllers & user services inhibited initially
%externalinteger KERNELQ=0, RUNQ1=0, RUNQ2=0
%recordformat PROCF(%string (6) USER, %byteinteger INCAR,CATEGORY,WSN,RUNQ,
   ACTIVE, %integer ACTW0,LSTAD,LAMTX,STACK,STATUS)
%ownrecord (PROCF) %arrayformat PROCAF(0:MAXPROCS)
%ownrecord (PROCF) %arrayname PROCA
      %if MONLEVEL&2#0 %thenstart
      %externallongintegerspec KMON
      %finish
!
!
!
%externalstringfnspec STRHEX(%integer N)
%externalstringfnspec STRINT(%integer N)
%externalstringfnspec HTOS(%integer VAL,PL)
!
%externalroutinespec OPMESS(%string (63) S)
%externalroutinespec ETOI(%integer A,L)
%externalroutinespec DUMPTABLE(%integer T,A,L)
%externalroutinespec PKMONREC(%string (23) TEXT, %record (PARMF) %name P)
%externalintegerfnspec REALISE(%integer VAD)
!
%constlonginteger DISAWAIT=x'2000000000000'
%ownlonginteger PSW
!
!
!------------------------------------------------------------------------
!
!------------------------------------------------------------------------
!
%externalintegerfn TIO(%integer CUU)
%integer CC
      CC=0
      *basr_15,0; *using_15
      *l_1,cuu; *tio_0(1)
      *bc_8,<res>; *bc_2,<cc2>; *bc_4,<cc1>
      *drop_15
      CC=3; ->RES
CC2:  CC=2; ->RES
CC1:  CC=1
RES:  %result=CC
%end
!
!------------------------------------------------------------------------
!
%externalintegerfn SIO(%integer CUU)
%integer CC
      CC=0
      *basr_15,0; *using_15
      *l_1,cuu; *sio_0(1)
      *bc_8,<res>; *bc_2,<cc2>; *bc_4,<cc1>
      *drop_15
      CC=3; ->RES
CC2:  CC=2; ->RES
CC1:  CC=1
RES:  %result=CC
%end
!
!------------------------------------------------------------------------
!
%externalintegerfn HIO(%integer CUU)
%integer CC
      CC=0
      *basr_15,0; *using_15
      *l_1,cuu; *hio_0(1)
      *bc_8,<res>; *bc_2,<cc2>; *bc_4,<cc1>
      *drop_15
      CC=3; ->RES
CC2:  CC=2; ->RES
CC1:  CC=1
RES:  %result=CC
%end
!
      %if MULTI OCP=YES %start
      %externalroutine SEMALOOP(%integername SEMA)
!***********************************************************************
!*    Loop till a sema comes free. MAXCOUNT is large enough so that    *
!*    it is only invoked when another OCP has gone down holding a sema *
!***********************************************************************
      %constinteger MAX COUNT=6
      %ownlonginteger CPT1,CPT2
      %integer I,J
         %for J=1,1,4 %cycle
            *stpt_cpt1
            %for I=1,1,COM_INSPERSEC*(500//MAXCOUNT) %cycle
               *slr_1,1; *lr_0,1; *bctr_0,0
               *l_2,sema
               *cs_0,1,0(2)
               *bc_7,<rep>
               %if MONLEVEL&4#0 %start
                  *stpt_cpt2
                  SEMATIME=SEMATIME+(CPT1-CPT2)>>12
               %finish
               %return
REP:        %repeat
            SEMA=-1;                    ! free sema before msg lest IOCP sema
            PRINTSTRING("Sema forced free at ".STRHEX(ADDR(SEMA))."
")
         %repeat
      %end
      %finish
!
%externalroutine SYSERR(%integer STK,IP)
%end
!
!------------------------------------------------------------------------
!
%externalroutine STOP %alias "S#STOP"
      PSW=PSW0!DISAWAIT!x'd1ed'
      *lpsw_psw
%end
!
%externalroutine MONITOR(%string (63) S)
      PRINTSTRING(S)
      NEWLINE
      %monitor
      %stop
%end
!
!-----------------------------------------------------------------------
%routine PUTONQ(%integer SERVICE)
%record (PROCF) %name PROC
%record (SERVF) %name SERV,SERVQ
%integername RUNQ
      SERV==SERVA(SERVICE)
      %if LOCSN0<SERVICE<=LOCSN1 %thenstart
         PROC==PROCA(SERVICE-LOCSN0)
         %if PROC_RUNQ=1 %then RUNQ==RUNQ1 %else RUNQ==RUNQ2
         %if RUNQ=0 %then SERV_L=SERVICE %elsestart
            SERVQ==SERVA(RUNQ)
            SERV_L=SERVQ_L
            SERVQ_L=SERVICE
         %finish
         RUNQ=SERVICE %unless PROC_STATUS&3#0 %and RUNQ#0
                                        ! priority procs on front
      %finishelsestart
         %if KERNELQ=0 %then SERV_L=SERVICE %elsestart
            SERVQ==SERVA(KERNELQ)
            SERV_L=SERVQ_L
            SERVQ_L=SERVICE
         %finish
         KERNELQ=SERVICE
      %finish
%end
!
!-----------------------------------------------------------------------
!
%externalintegerfn RTV(%integer RAD)
!
! setup page to allow access to store at real address RAD
! or invalidate page if RAD = -1
!
%constinteger PAGENO=2
%constinteger RTV VAD=PAGE0 VA+PAGENO<<12; ! page 2 of seg 0
%integer I,J
      J=SEGTAB VA+INTEGER(SEGTAB VA+4*PAGE0 SEG)&x'fff'+PAGENO*PTE SIZE
      %if PTE SIZE=2 %start
         %if RAD=-1 %then RAD=0 %and I=8 %else I=0
         SHORTINTEGER(J)<-RAD>>12<<4!I
      %finishelsestart
         %if RAD=-1 %then RAD=0 %and I=x'400' %else I=0
         INTEGER(J)=RAD!I
      %finish
!
      %unless XA=YES %start
         *ptlb_0
      %finishelsestart
         I=INTEGER(SEGTAB VA+4*PAGE0 SEG); ! PTO
         *l_0,i; *l_1,rtvvad; *ipte_0,1
      %finish
!
      %result=RTV VAD
%end
!
!------------------------------------------------------------------------
!
%externalintegerfn PPINIT(%integerfn NEW EPAGE)
%constinteger INIT EPAGES=SERVASIZE//PAGESIZE+1
%integerarray REALADS(0:INIT EPAGES)
%integer I,J,K,CELLS
%longinteger L
      I=ADDR(GET NEW PAGE(0));          ! save FN parms
      *l_1,i; *l_15,64(10)
      *mvc_0(16,1),0(15)
      *l_15,12(1); *mvc_16(40,1),20(15)
      PROCA==ARRAY(COM_PROCAAD,PROCAF)
      %for J=INIT EPAGES,-1,0 %cycle
         I=NEW EPAGE
         REALADS(J)=I
      %repeat
      %if MAXPROCS#COM_MAXPROCS %or PAGESIZE#COM_PAGESIZE %or %c
         STORE0AD#COM_STOREAAD %then PRINTSTRING("Incompatable components!!!
")
                                        ! page table at beginning of PPSEG
      %if XA=NO %then J=INIT EPAGES<<28 %else J=0
      INTEGER(SEG TAB VA+4*PPSEG)=I!J
      I=RTV(I)
      %for J=0,1,INIT EPAGES %cycle
         K=REALADS(J)
         %if PTE SIZE=2 %then SHORTINTEGER(I+J*PTE SIZE)<-K>>8 %else %c
            INTEGER(I+J*PTE SIZE)=K
      %repeat
      I=RTV(-1)
      PARMDOPE_CURRMAX=PAGESIZE*(INITEPAGES+1)-PARMPTSIZE*PTE SIZE-SERVASIZE
      PARMDOPE_MAXMAX=PAGESIZE*PARMPTSIZE-PARMPTSIZE*PTE SIZE-SERVASIZE
      CELLS=PARMDOPE_CURRMAX//PCELLSIZE-1; ! no of cells now avaiable
      PARMDOPE_FIRSTUNALLOC=CELLS-MARGIN+1
      PARMDOPE_LAST UNALLOC=CELLS
      PARMDOPE_NEXTPAGE=INIT EPAGES+1
      CELLS=CELLS-MARGIN;               ! margin of "MARGIN" cells for trying
                                        ! to obtain further epage
      %for I=1,1,CELLS-1 %cycle
         PARM(I)_LINK=I+1
      %repeat
      PARM(CELLS)_LINK=1
      PARMASL=CELLS
      COM_PARMASLA=ADDR(PARMASL)
      COM_KERNELQA=ADDR(KERNELQ)
      COM_RUNQ1A=ADDR(RUNQ1)
      COM_RUNQ2A=ADDR(RUNQ2)
      %result=PARM0AD
%end
!
!------------------------------------------------------------------------
!
%routine MORE PPSPACE
!***********************************************************************
!*    Called when PARM ASL is empty and attemps to grab a free epage   *
!*    and use to extend the (paged) parameter passing area             *
!*    if no page available it tries to use one of the small no of cells*
!*    not formatted into the original list. This gives us a fair       *
!*    chance of finding a free epage before disaster strikes           *
!***********************************************************************
%integer I,J,REALAD,PTAD,CELLS,FIRST,CMAX
      CMAX=PARMDOPE_CURRMAX
      %if CMAX>=PARMDOPE_MAXMAX %then ->FAIL
      I=ADDR(GET NEW PAGE(0))
      *l_2,i
      *stm_4,14,16(11)
      *lm_12,15,0(2)
      *lm_5,10,16(2)
      *lr_1,14
      *l_14,52(2)
      *basr_15,1
      *st_1,realad
      %if REALAD=-1 %then ->TRY MARGIN
      %if XA=NO %start
         I=INTEGER(SEGTAB VA+4*PPSEG)>>28
         I=I+1
         INTEGER(SEGTAB VA+4*PPSEG)=INTEGER(SEGTAB VA+4*PPSEG) %c
            &x'0fffffff'!I<<28
      %finish
      PTAD=PPSEG<<SSHIFT+PTE SIZE*PARMDOPE_NEXTPAGE
!
! Extend PARM area by 1 epage by adding entry into page table
!
      %if PTE SIZE=2 %then SHORTINTEGER(PTAD)<-REALAD>>8 %else %c
         INTEGER(PTAD)=REALAD
!
! Adjust param area descriptor and format up new bit of parmlist
!
      CMAX=CMAX+PAGESIZE
      PARMDOPE_CURRMAX=CMAX
      CELLS=CMAX//PCELLSIZE-1
      FIRST=PARMDOPE_FIRST UNALLOC
      PARMDOPE_FIRST UNALLOC=CELLS-MARGIN+1
      PARMDOPE_LAST UNALLOC=CELLS
      PARMDOPE_NEXTPAGE=PARMDOPE_NEXTPAGE+1
      CELLS=CELLS-MARGIN
      %for I=FIRST,1,CELLS-1 %cycle
         PARM(I)_LINK=I+1
      %repeat
      PARM(CELLS)_LINK=FIRST
      PARMASL=CELLS
      %return
TRY MARGIN:
!
! No epage available just now, use one of margin cells
!
      I=PARMDOPE_FIRST UNALLOC
      %if I>PARMDOPE_LAST UNALLOC %then ->FAIL
      PARMDOPE_FIRST UNALLOC=I+1
      PARM(I)_LINK=I
      PARMASL=I
      %return
FAIL:
      MONITOR("PARM ASL empty")
%end
!
!------------------------------------------------------------------------
!
%externalroutine PON(%record (PARMF) %name P)
%record (SERVF) %name SERV,SERVQ
%record (PARMXF) %name ACELL,SCELL,NCELL
%integer SERVICE,NEWCELL,SERVP,I
      SERVICE=P_DEST>>16
      %if MONLEVEL&2#0 %and (SERVICE>MAXSERV %or SERVICE=0) %then %c
         PKMONREC("Invalid PON:",P) %andreturn
      %if MULTIOCP=YES %thenstart
         *inct_MAINQSEMA
         *jcc_8,<PSEMAGOT>
         SEMALOOP(MAINQSEMA,0)
PSEMAGOT:
      %finish
      %if PARMASL=0 %then MORE PPSPACE
      ACELL==PARM(PARMASL);             ! ACELL =ASL HEADCELL
      NEWCELL=ACELL_LINK
      NCELL==PARM(NEWCELL);             ! NCELL mapped onto NEWCELL
      %if NEWCELL=PARMASL %then PARMASL=0 %else ACELL_LINK=NCELL_LINK
      NCELL<-P;                         ! copy parameters in
      SERV==SERVA(SERVICE)
      SERVP=SERV_P&X'3FFFFFFF'
      %if SERVP=0 %then NCELL_LINK=NEWCELL %elsestart
         SCELL==PARM(SERVP)
         NCELL_LINK=SCELL_LINK
         SCELL_LINK=NEWCELL
      %finish
      I=SERV_P&X'C0000000'
      SERV_P=I!NEWCELL
      %if I=0 %and SERV_L=0 %start;     ! q if not xecuting or inhbtd
         %if SERVICE>=LOCSN0 %then PUTONQ(SERVICE) %elsestart
            %if KERNELQ=0 %then SERV_L=SERVICE %elsestart
               SERVQ==SERVA(KERNELQ)
               SERV_L=SERVQ_L
               SERVQ_L=SERVICE
            %finish
            KERNELQ=SERVICE
         %finish
      %finish
      %if MULTIOCP=YES %start; *tdec_MAINQSEMA; %finish
%end
!
!------------------------------------------------------------------------
!
%externalroutine FASTPON(%integer CELL)
!***********************************************************************
!*    Can be used when record already in param table to avoid copy     *
!*    cell is no of entry in PARM holding the record                   *
!***********************************************************************
%integer SERVICE,SERVP,I
%record (SERVF) %name SERV,SERVQ
%record (PARMXF) %name CCELL,SCELL
      CCELL==PARM(CELL)
      SERVICE=CCELL_DEST>>16
      SERV==SERVA(SERVICE)
      %if MULTIOCP=YES %thenstart
         SEMALOOP(MAINQSEMA,0)
      %finish
      SERVP=SERV_P&x'3fffffff'
      %if SERVP=0 %then CCELL_LINK=CELL %elsestart
         SCELL==PARM(SERVP)
         CCELL_LINK=SCELL_LINK
         SCELL_LINK=CELL
      %finish
      I=SERV_P&x'c0000000'
      SERV_P=I!CELL
      %if I=0 %and SERV_L=0 %thenstart
         %if SERVICE>=LOCSN0 %then PUTONQ(SERVICE) %elsestart
            %if KERNELQ=0 %then SERV_L=SERVICE %elsestart
               SERVQ==SERVA(KERNELQ)
               SERV_L=SERVQ_L
               SERVQ_L=SERVICE
            %finish
            KERNELQ=SERVICE
         %finish
      %finish
      %if MULTIOCP=YES %start; { release sema} %finish
%end
!-----------------------------------------------------------------------
%externalroutine DPON(%record (PARMF) %name P, %integer DELAY)
!***********************************************************************
!*    As for PON except for a delay of "DELAY" seconds. Zero delays    *
!*    are allowed. ELAPSED INT is used to kick DPONPUTONQ              *
!***********************************************************************
%record (PARMF) POUT
%record (PARMXF) %name ACELL,NCELL
%integer SERVICE,NEWCELL
      SERVICE=P_DEST>>16
      %if MONLEVEL&2#0 %and SERVICE>MAXSERV %then %c
         PKMONREC("Invalid DPON:",P) %and WRITE(DELAY,4) %andreturn
      %if DELAY<=0 %then PON(P) %andreturn
      %if MULTIOCP=YES %thenstart
         SEMALOOP(MAINQSEMA,0)
      %finish
      %if PARMASL=0 %then MORE PPSPACE
      ACELL==PARM(PARMASL)
      NEWCELL=ACELL_LINK
      NCELL==PARM(NEWCELL);             ! onto cell in freelist
      %if NEWCELL=PARMASL %then PARMASL=0 %else ACELL_LINK=NCELL_LINK
      NCELL<-P
      %if MULTIOCP=YES %then MAINQSEMA=-1
      POUT_DEST=x'a0002'
      POUT_SRCE=0
      POUT_P1=x'c0000'!NEWCELL
      POUT_P2=DELAY
      PON(POUT)
%end
!-----------------------------------------------------------------------
%externalroutine DPONPUTONQ(%record (PARMF) %name P)
!***********************************************************************
!*    Scond part of DPON. The delay has elapsed and P_DACT has the    *
!*    number of a PPCELL set up ready for fastponning                  *
!***********************************************************************
      %if MONLEVEL&2#0 %and KMON&1<<12#0 %then PKMONREC("DPONPUTONQ:",P)
      FASTPON(P_DEST&x'ffff')
%end
!
!------------------------------------------------------------------------
!
%externalintegerfn NEWPPCELL
%integer NEWCELL
%record (PARMXF) %name ACELL
      %if PARMASL=0 %then MORE PPSPACE
      ACELL==PARM(PARMASL)
      NEWCELL=ACELL_LINK
      %if NEWCELL=PARMASL %then PARMASL=0 %else ACELL_LINK=PARM(NEWCELL)_LINK
      %result=NEWCELL
%end
!
!------------------------------------------------------------------------
!
!%externalroutine poff(%record(parmf)%name p)
!%record(servf)%name serv
!%record(parmxf)%name acell,ccell,scell
!%integer service,cell,servp
!service=p_dest>>16
!%unless 0<service<=maxserv %start
!      pkmonrec("Invalid poff:",p)
!      p_dest=0
!      %return
!%finish
!serv==serva(service)
!servp=serv_p
!%if servp<=0 %then p_dest=0 %and %return
!scell==parm(servp)
!cell=scell_link
!ccell==parm(cell)
!p<-ccell
!%if cell=serv_p %then serv_p=0 %else scell_link=ccell_link
!%if parmasl=0 %then ccell_link=cell %else %start
!      acell==parm(parmasl)
!      ccell_link=acell_link
!      acell_link=cell
!%finish
!parmasl=cell
!%end
!!
!------------------------------------------------------------------------
!
%externalroutine RETURN PPCELL(%integer CELL)
%record (PARMXF) %name ACELL,CCELL
      CCELL==PARM(CELL)
      %if PARMASL=0 %then CCELL_LINK=CELL %elsestart
         ACELL==PARM(PARMASL)
         CCELL_LINK=ACELL_LINK
         ACELL_LINK=CELL
      %finish
      PARMASL=CELL
%end
!
!------------------------------------------------------------------------
!
%externalroutine INHIBIT(%integer SERVICE)
%record (SERVF) %name SERV
      %unless 0<=SERVICE<=MAXSERV %start
         PRINTSTRING("Invalid inhibit: ".STRINT(SERVICE))
         NEWLINE
         %return
      %finish
      SERV==SERVA(SERVICE)
      SERV_P=SERV_P!x'80000000'
%end
!
!------------------------------------------------------------------------
!
%externalroutine UNINHIBIT(%integer SERVICE)
%record (SERVF) %name SERV
      %unless 0<=SERVICE<=MAXSERV %start
         PRINTSTRING("Invalid uninhibit: ".STRINT(SERVICE))
         NEWLINE
         %return
      %finish
      SERV==SERVA(SERVICE)
      SERV_P=SERV_P&x'7fffffff'
      %if SERV_L=0 %and SERV_P#0 %then PUTONQ(SERVICE)
%end
!-----------------------------------------------------------------------
%externalroutine SUPPOFF(%record (SERVF) %name SERV, %record (PARMF) %name P)
!***********************************************************************
!*    A more efficient POFF for supervisor                             *
!*    assumes vital checks have been done                              *
!***********************************************************************
%record (PARMXF) %name ACELL,CCELL,SCELL
%integer CELL,SERVP
      %if MULTIOCP=YES %thenstart
         SEMALOOP(MAINQSEMA,0)
      %finish
      SERVP=SERV_P&X'3FFFFFFF'
      SCELL==PARM(SERVP)
      CELL=SCELL_LINK
      CCELL==PARM(CELL)
      P<-CCELL
      %if CELL=SERVP %then SERV_P=SERV_P&X'C0000000' %else %c
         SCELL_LINK=CCELL_LINK
      %if PARMASL=0 %then CCELL_LINK=CELL %elsestart
         ACELL==PARM(PARMASL)
         CCELL_LINK=ACELL_LINK
         ACELL_LINK=CELL
      %finish
      PARMASL=CELL
      %if MULTIOCP=YES %start; { release sema } %finish
%end
%externalroutine PINH(%integer PROCESS,MASK)
!***********************************************************************
!*    Inhibit a group of services for a process with one claiming      *
!*    of the relevant sema. Needed for duals.                          *
!*    Mask controls:-     2**0 set = inhibit processes LOCSN0          *
!*                        2**1 set = inhibit processes LOCSN1 etc      *
!***********************************************************************
%record (SERVF) %name SERV
%integer I,SERVICE
      %if MULTIOCP=YES %thenstart
         *inct_MAINQSEMA
         *jcc_8,<GOT>
         SEMALOOP(MAINQSEMA,0)
GOT:
      %finish
      %for I=0,1,3 %cycle
         %if MASK&(1<<I)#0 %start
            SERVICE=PROCESS+LOCSN0+I*MAXPROCS
            SERV==SERVA(SERVICE)
            SERV_P=SERV_P!X'80000000'
         %finish
      %repeat
      %if MULTIOCP=YES %start; *tdec_MAINQSEMA; %finish
%end
%externalroutine PUNINH(%integer PROCESS,MASK)
!***********************************************************************
!*    Uninhibit service for a process. The converse of PINH(q.v)       *
!***********************************************************************
%record (SERVF) %name SERV
%integer I,SERVICE
      %if MULTIOCP=YES %thenstart
         *inct_MAINQSEMA
         *jcc_8,<GOT>
         SEMALOOP(MAINQSEMA,0)
GOT:
      %finish
      %for I=0,1,3 %cycle
         %if MASK&(1<<I)#0 %start
            SERVICE=PROCESS+LOCSN0+I*MAXPROCS
            SERV==SERVA(SERVICE)
            SERV_P=SERV_P&X'7FFFFFFF'
            %if SERV_L=0 %and 0<SERV_P<X'FFFF' %then PUT ON Q(SERVICE)
         %finish
      %repeat
      %if MULTIOCP=YES %start; *tdec_MAINQSEMA; %finish
%end
!-----------------------------------------------------------------------
%externalroutine CLEAR PARMS(%integer SERVICE)
!***********************************************************************
!*    Throw away all cells queuing for service en block                *
!*    also print discarded cells for information                       *
!***********************************************************************
%record (SERVF) %name SERV
%integer CELL,SERVP
      SERV==SERVA(SERVICE)
      %if MULTIOCP=YES %thenstart
         *inct_MAINQSEMA
         *jcc_8,<SSEMAGOT>
         SEMALOOP(MAINQSEMA,0)
SSEMAGOT:
      %finish
      SERVP=SERV_P&X'3FFFFFFF'
      %if SERVP=0 %start
         %if MULTI OCP=YES %start; *tdec_MAINQSEMA; %finish
         %return
      %finish
      %if MONLEVEL&2#0 %thenstart
         %if MULTIOCP=YES %start; *tdec_MAINQSEMA; %finish; ! dont hold during o-p
         CELL=SERVP
         %until CELL=SERVP %cycle
            CELL=PARM(CELL)_LINK
            PKMONREC("PARM cleared:",PARM(CELL))
         %repeat
         %if MULTIOCP=YES %thenstart
            *inct_MAINQSEMA
            *jcc_8,<SSEMAGOT2>
            SEMALOOP(MAINQSEMA,0)
SSEMAGOT2:
         %finish
      %finish
      SERV_P=SERV_P&X'C0000000'
      %if PARMASL#0 %then %c
         CELL=PARM(SERVP)_LINK %and PARM(SERVP)_LINK=PARM(PARMASL)_LINK %and %c
         PARM(PARMASL)_LINK=CELL
      PARMASL=SERVP
      %if MULTIOCP=YES %start; *tdec_MAINQSEMA; %finish
%end
!------------------------------------------------------------------------
%externalroutine ELAPSED INT(%record (PARMF) %name P)
!**********************************************************************
!*                                                                     *
!*   ELAPSED INTERVAL TIMER                                            *
!*                                                                     *
!* Act 0 = call from RTC interrupt handler (currently once per sec)    *
!* ACT 1 = Q/unQ nominee for kick every n seconds                      *
!* ACT 2 = Q nominee for once-off kick in n seconds                    *
!*                                                                     *
!* Where : P_P1 is routine to be kicked                                *
!*       : P_P2 is (a) seconds to elapse before kick (0<P_P2<X8000)    *
!*              or (b) unQ nominee (P_P2 = -1,act 1 only)              *
!*       : P_P3 is parameter returned to kicked routine in P_P1        *
!***********************************************************************
%routinespec QUEUE
%routinespec UNQUEUE(%integer N)
%integerfnspec SLOT(%integer N)
%recordformat QF(%integer DEST,KLOKTIKS,PARM,PROCNO, %string (7) USER,
   %integer P5,P6,LINK)
%record (QF) %name Q
%switch ACT(0:2)
%integer I,SRCE,PROCNO
%integername HEAD
      HEAD==COM_ELAP HEAD
      SRCE=P_SRCE
      I=P_DEST&X'FFFF'
      %if MONLEVEL&2#0 %and 1<<10&KMON#0 %then PKMONREC("ELAPSED INT:",P)
      ->ACT(I) %if 0<=I<=2
      %if MONLEVEL&2#0 %and I>2 %then PKMONREC("ELAPSED INT rejects:",P)
      %return
ACT(0):                                 ! RTC interrupt
      P_SRCE=P_DEST
      I=HEAD
      %while I>0 %cycle
         Q==PARM(I)
         I=Q_LINK
         %if Q_DEST#0 %start
            Q_KLOKTIKS=Q_KLOKTIKS-1
            %if Q_KLOKTIKS&X'FFFF'=0 %start
               P_DEST=Q_DEST
               P_P1=Q_PARM
!
! Check user process has not logged off and if so cancel request
!
               PROCNO=Q_PROCNO
               %if PROCNO=0 %or Q_USER=PROCA(PROCNO)_USER %then PON(P) %else %c
                  Q_KLOKTIKS=0
               %if Q_KLOKTIKS=0 %then UNQUEUE(Q_DEST) %else %c
                  Q_KLOKTIKS=Q_KLOKTIKS!Q_KLOKTIKS>>16
            %finish
         %finish
      %repeat
      %return
ACT(1):                                 ! request timer interrupt
      %if P_P2<0 %then UNQUEUE(P_P1) %andreturn
ACT(2):                                 ! one time only
      %returnif X'7FFF'<P_P2<1
      %if I=1 %then P_P2=P_P2<<16+P_P2
      QUEUE
      %return
%routine QUEUE
%integer CELL,PROCNO
      CELL=SLOT(P_P1)
      %unless CELL=0 %start;            ! already Q'd
         %if I=2 %start;                ! ok if once-off
            Q==PARM(CELL);              ! update parms
            Q_KLOKTIKS=P_P2
            Q_PARM=P_P3
         %finish
         %return
      %finish
      CELL=NEWPPCELL
      Q==PARM(CELL)
      Q_P6=0
      Q_LINK=HEAD
      PARM(HEAD)_P6=CELL
      HEAD=CELL
      Q_DEST=P_P1
      Q_KLOKTIKS=P_P2
      Q_PARM=P_P3
      PROCNO=P_P1>>16-LOCSN0
      %if PROCNO<0 %then PROCNO=0 %else PROCNO=PROCNO&(MAXPROCS-1)
      Q_PROCNO=PROCNO
      Q_USER=PROCA(PROCNO)_USER %if PROCNO>0
%end
%routine UNQUEUE(%integer N)
%integer I
%record (QF) %name Q
      I=SLOT(N)
      %returnif I=0;                    ! not Q'd
      Q==PARM(I)
      %if Q_P6=0 %then HEAD=Q_LINK %else PARM(Q_P6)_LINK=Q_LINK
      %if Q_LINK#0 %then PARM(Q_LINK)_P6=Q_P6
      RETURN PPCELL(I)
%end
%integerfn SLOT(%integer DEST)
%integer I,J
      I=HEAD
      %while I>0 %cycle
         Q==PARM(I)
         %result=I %if Q_DEST=DEST
         I=Q_LINK
      %repeat
      %result=0
%end
%end
!
%recordformat DTFORM(%integer SER,CUU,(%integer PROPADDR %orinteger FLAGS),
   %integer STICK,SP1,CCWA,CSW1,CSW2,STATE,SP2,
   (%integer CONCOUNT %orinteger SSP2), %integer SENSE1,SENSE2,SENSE3,SENSE4,
   (%integer REPSNO,BASE,ID,DLVN %orinteger SSP3,SSP4,SSP5,SSP6),
   %integer MNEMONIC,(%string (6) LAB, %byteinteger MECH, %integer PROPS,
   STATS1,STATS2, %byteinteger QSTATE,PRIO,DBSP1,DBSP2, %integer LQLINK,
   UQLINK,CURCYL,SEMA,TRLINK,DSP1 %orinteger SSP7,SSP8,SSP9,UCCWA,SENSEDATAD,
   LOGMASK,TRTAB AD,UA SIZE,UA AD,TIMEOUT,PROPS0,PROPS1))
%recordformat PROPFORM(%integer TRACKS,CYLS,PPERTRK,BLKSIZE,TOTPAGES,SP1,SP2,
   SP3,KEYLEN,SECTINDX)
%recordformat LABFORM(%byteintegerarray VOL(0:5), %byteinteger S1,S2,S3,S4,
   ACCESS, %byteintegerarray RES(1:20), %byteinteger C1,C2,AC1,AC2,TPC1,TPC2,
   BF1,BF2, %byteintegerarray POINTER(0:3),IDENT(1:14))
%recordformat CCWF(%integer CMDAD, %byteinteger FLAGS,SP, %shortinteger LEN)
%constinteger NORMALT=x'0c000000',ERRT=x'400000',ATTNT=x'80000000'
%constinteger DISCSNO=x'200000',PDISCSNO=x'210000'
%constinteger SCHEDSNO=x'30000'
%ownbyteintegerarrayformat LVNF(0:99)
%ownbyteintegerarrayname LVN
%owninteger DITADDR=0,NDISCS=0
!
%routinespec PDISC(%record (PARMF) %name P)
%externalroutine DISC(%record (PARMF) %name P)
%routinespec READ DLABEL(%record (DTFORM) %name DDT)
%routinespec LABREAD ENDS
%routinespec UNLOAD(%record (DTFORM) %name DDT)
%stringfnspec MTOS(%integer M)
%routinespec SENSE(%record (DTFORM) %name DDT, %integer VAL)
%routinespec DREPORT(%record (DTFORM) %name DDT, %record (PARMF) %name P)
%routinespec FIRE CHAIN(%integer CCWA)
%record (DTFORM) %name DDT
%record (PROPFORM) %name PROP
%record (LABFORM) %name LABEL
%record (CCWF) %name CCW
%constinteger DEAD=0,CONNIS=1,RLABIS=2,DCONNIS=3,AVAIL=4,PAGTIS=5
%constinteger PAGSIS=6,INOP=7,PAVAIL=10,PCLAIMD=11,PTRANIS=12
%constinteger PSENIS=13,SPTRANIS=14,RLABSIS=15
%constinteger RESPX=1<<CONNIS!1<<RLABIS!1<<DCONNIS!1<<PAGTIS! %c
      1<<PAGSIS!1<<PTRANIS!1<<PSENIS!1<<SPTRANIS!1<<RLABSIS
%constinteger PAGIO=1<<PAGTIS!1<<PAGSIS
%constinteger PRIVIO=1<<PTRANIS!1<<PSENIS!1<<SPTRANIS
%owninteger INITINH=0,LABREADS=0,CURRTICK=0
%integer ACT,I,J,SLOT,PTR,CSW1,CSW2,LRSTATE
%string (40) S
%string (6) PREVLAB
%switch INACT(0:12),AINT,FINT,NINT(0:15)
!
      ACT=P_DEST&x'ffff'
      %if KMON>>32&1#0 %then PKMONREC("DISC:",P)
      %if ACT>=64 %then ->ACT64
      ->INACT(ACT)
!
INACT(0):                               !initialisation
      %returnunless NDISCS=0
      NDISCS=COM_NDISCS
      DITADDR=COM_DITADDR
      LVN==ARRAY(COM_DLVNADDR,LVNF)
      %for I=0,1,99 %cycle
         LVN(I)=254
      %repeat
      INITINH=1
      %for J=0,1,NDISCS-1 %cycle
         DDT==RECORD(INTEGER(DITADDR+4*J))
         SENSE(DDT,0)
         DDT_STATE=CONNIS
      %repeat
      P_DEST=PDISCSNO
      PDISC(P)
      P_DEST=x'a0001'
      P_SRCE=0
      P_P1=DISCSNO!5
      P_P2=3
      PON(P)
      %return
!
INACT(1):                               ! claim for dedicated use
      PTR=P_P3; I=PTR
      %unless 0<=PTR<NDISCS %start
         %for I=0,1,NDISCS-1 %cycle
            DDT==RECORD(INTEGER(DITADDR+4*I))
            ->HIT %if PTR=DDT_MNEMONIC %or DDT_LAB=STRING(ADDR(P_P3))
         %repeat
         ->CLAIM FAILS
      %finishelse DDT==RECORD(INTEGER(DITADDR+4*I))
HIT:
      %if P_P2>0 %start
         %if DDT_STATE=PAVAIL %or (DDT_STATE=AVAIL %and DDT_DLVN<0) %start
            DDT_STATE=PCLAIMD
            DDT_REPSNO=P_P2
            ->REPLY
         %finishelse ->CLAIM FAILS
      %finishelsestart
         %if DDT_STATE#PCLAIMD %then OPMESS("Duff dev returned") %andreturn
         DDT_STATE=PAVAIL
         DDT_REPSNO=0
         DDT_CURCYL=0
         OPMESS(MTOS(DDT_MNEMONIC)." unused")
         %if P_P2<0 %then SENSE(DDT,0) %and DDT_STATE=CONNIS
         %return
      %finish
REPLY:
      P_P2=DISCSNO+64+I
      P_P3=I
      P_P4=DDT_MNEMONIC
      STRING(ADDR(P_P5))=DDT_LAB
SEND:
      P_DEST=P_SRCE
      P_SRCE=DISCSNO!1
      PON(P)
      %return
CLAIM FAILS:
      P_P2=0
      ->SEND
!
INACT(2):                               ! paged request
      DDT==RECORD(P_P1)
      %if DDT_STATE#AVAIL %or P_SRCE&x'ffff0000'#PDISCSNO %then ->REJECT
      DDT_STATE=PAGTIS
      DDT_ID=P_P1
      FIRE CHAIN(DDT_CCWA)
      %return
!
ACT64:                                  ! private chains
      SLOT=ACT&63
      DDT==RECORD(INTEGER(DITADDR+4*SLOT))
      %if DDT_STATE#PCLAIMD %then ->REJECT
      DDT_REPSNO=P_SRCE
      DDT_ID=P_P1
      %if P_P2<0 %then DDT_STATE=SPTRANIS %else DDT_STATE=PTRANIS
      FIRE CHAIN(DDT_CCWA)
      %return
REJECT:
      %if DDT_STATE=INOP %then ->REPLY INOP
      PKMONREC("DISC rejects:",P)
      P_DEST=P_SRCE
      P_P2=-1
      P_SRCE=DISCSNO+64+SLOT
      PON(P)
      %return
!
INACT(4):                               ! lvn p_p1 cck'd
      I=P_P1
      J=LVN(I)
      %if J>=NDISCS %thenreturn
      DDT==RECORD(INTEGER(DITADDR+4*J))
      DDT_DLVN=DDT_DLVN&255
      %return
!
INACT(5):                               ! clock tick
      CURRTICK=CURRTICK+1
      %return
!
INACT(9):                               ! for testing 'things'
      %if P_P1=1 %start;                ! display devs
         %for I=0,1,NDISCS-1 %cycle
            DDT==RECORD(INTEGER(DITADDR+4*I))
            OPMESS(MTOS(DDT_MNEMONIC)." (".HTOS(DDT_CUU,
               3).") ".DDT_LAB." ".STRINT(DDT_STATE)." ".STRINT(DDT_QSTATE))
         %repeat
      %finishelseif P_P1=2 %start;      ! crop properties
         %if 0<=P_P2<=99 %start
            SLOT=LVN(P_P2)
            %if 0<=SLOT<NDISCS %start
               DDT==RECORD(INTEGER(DITADDR+4*SLOT))
               PROP==RECORD(DDT_PROPADDR)
               %if 0<P_P3<960 %start
                  PROP_CYLS=P_P3
                  PROP_TOTPAGES=P_P3*PROP_TRACKS*PROP_PPERTRK
                  OPMESS("lvn ".STRINT(P_P2)." now has ".STRINT(P_P3)." cyls")
                  %return
               %finish
            %finish
         %finish
         OPMESS("DISC: crop parms??")
      %finishelsestart
         %monitor
      %finish
      %return
!
INACT(10):                              ! relocate tables for supervisor
      %if VA MODE=NO %start
         %for I=0,1,NDISCS-1 %cycle
            DDT==RECORD(INTEGER(DITADDR+4*I))
            INTEGER(DITADDR+4*I)=(INTEGER(DITADDR+4*I)-P_P1)!COM SEG<<SSHIFT
            DDT_PROPADDR=(DDT_PROPADDR-P_P1)!COM SEG<<SSHIFT
            DDT_CCWA=(DDT_CCWA-P_P1)!COM SEG<<SSHIFT
            DDT_SENSEDATAD=(DDT_SENSEDATAD-P_P1)!COM SEG<<SSHIFT
         %repeat
         %return
      %finish
!
!inact(*):                               ! sink
!pkmonrec("DISC act?:",p)
!%return
!
INACT(3):                               ! interrupt
      CSW1=P_P2
      CSW2=P_P3
      SLOT=P_P4
      DDT==RECORD(INTEGER(DITADDR+4*SLOT))
      %if CSW2&x'7fff0000'=NORMALT %then ->NINT(DDT_STATE)
      %if CSW2&ATTNT#0 %then ->AINT(DDT_STATE)
      ->FINT(DDT_STATE)
      %return
!
NINT(AVAIL):
FINT(AVAIL):
NINT(PAVAIL):
FINT(PAVAIL):
NINT(PCLAIMD):
FINT(PCLAIMD):
NINT(DEAD):
FINT(DEAD):
      PRINTSTRING("DISC int (".HTOS(P_P1,3).") state ".STRINT(DDT_STATE)." ???
")
      %return
NINT(CONNIS):                           ! sense terminates
      READ DLABEL(DDT)
      LABREADS=LABREADS+1
      DDT_STATE=RLABIS
      %return
!
NINT(RLABIS):                           ! label read
      LABREAD ENDS
      LABEL==RECORD(DDT_CCWA+40)
      ETOI(ADDR(LABEL),6)
      PREVLAB=DDT_LAB
      %for I=0,1,5 %cycle
         BYTEINTEGER(ADDR(DDT_LAB)+1+I)=LABEL_VOL(I)
      %repeat
      LENGTH(DDT_LAB)=6
!
!  check label but note that VM does not allow a full 80 byte write (it seems)
!
      J=COM_OCPTYPE>>24;                ! 255 if VM
      %if ((J#255 %and LABEL_ACCESS=x'c5') %or J=255) %and %c
         '0'<=LABEL_VOL(4)<='9' %and '0'<=LABEL_VOL(5)<='9' %start
         %for I=0,1,3 %cycle
            BYTEINTEGER(ADDR(DDT_BASE)+I)=LABEL_POINTER(I)
         %repeat
         %if J=255 %then DDT_BASE=x'800'
         S=" EMAS"
         I=(LABEL_VOL(4)&x'f')*10+LABEL_VOL(5)&x'f'
         %if SLOT#LVN(I)<254 %then ->DUPLICATE
         LVN(I)=SLOT
         DDT_DLVN=I!x'80000000'
         DDT_STATE=AVAIL
      %finishelsestart
         DDT_BASE=0
         DDT_STATE=PAVAIL
         DDT_DLVN=-1
         S=" frgn"
      %finish
      DDT_STATS1=0
      DDT_STATS2=0
LOAD MESS:
      OPMESS(MTOS(DDT_MNEMONIC)." loaded ".DDT_LAB.S)
      %return
DUPLICATE:
      OPMESS("Duplicate disc lvn")
      OPMESS("Re-label disc on ".MTOS(DDT_MNEMONIC))
      DDT_DLVN=-1
      DDT_STATE=PAVAIL
      %return
!
FINT(CONNIS):                           ! sense fails
      DDT_STATE=DEAD
      %return
!
FINT(RLABIS):                           ! label read fails
      LABREAD ENDS
      DDT_CSW1=CSW1
      DDT_CSW2=CSW2
      DDT_STATE=RLABSIS
      SENSE(DDT,2)
      %return
!
NINT(RLABSIS):
FINT(RLABSIS):                          ! sense after lab read
      DDT_LAB="nolabl"
      DDT_DLVN=-1
      DDT_STATE=PAVAIL
      OPMESS(MTOS(DDT_MNEMONIC)." loaded no label")
      DDT_BASE=0
      P_DEST=0
      ->COM1
!
NINT(DCONNIS):
FINT(DCONNIS):                          ! unload complete
      DDT_STATE=DEAD
UNLDED:
      OPMESS(MTOS(DDT_MNEMONIC)." unloaded")
      %if DDT_DLVN#-1 %then LVN(DDT_DLVN&255)=255
      %return
!
AINT(RLABIS):
      LABREAD ENDS
AINT(DEAD):
AINT(CONNIS):
AINT(RLABSIS):
      PRINTSTRING("attntn while initng ".HTOS(P_P1,
         3)." ".STRHEX(CSW1).STRHEX(CSW2)."
")
      DDT_STATE=CONNIS
      SENSE(DDT,1)
AINT(DCONNIS):
      %return
!
AINT(AVAIL):
AINT(PAVAIL):
AINT(PAGTIS):
AINT(PAGSIS):
      %return
!
AINT(INOP):
      %return
!
NINT(INOP):
FINT(INOP):
REPLY INOP:
      P_P3=ERRT
      P_P4=0
      P_P5=NORMALT
      P_DEST=PDISCSNO!10
      P_SRCE=DISCSNO
      DDT_ID=ADDR(DDT)
      DDT_SENSE2=x'80800000'
      ->COM2
!
FINT(SPTRANIS):
NINT(PTRANIS):
NINT(SPTRANIS):
      P_DEST=DDT_REPSNO
      P_SRCE=DISCSNO+64+SLOT
      P_P1=DDT_ID
      P_P2=0
      P_P3=CSW1
      P_P4=CSW2
      PON(P)
      DDT_STATE=PCLAIMD
      %return
!
FINT(PAGTIS):
FINT(PTRANIS):
      DDT_CSW1=CSW1
      DDT_CSW2=CSW2
      DDT_STATE=DDT_STATE+1
      SENSE(DDT,2)
      %return
!
NINT(PAGTIS):
      P_DEST=PDISCSNO!10
      P_SRCE=DISCSNO!2
      P_P1=DDT_ID
      P_P2=0
      DDT_STATE=AVAIL
      PDISC(P)
      %return
!
FINT(PAGSIS):
NINT(PAGSIS):
      P_DEST=PDISCSNO!10
      P_SRCE=DISCSNO!2
      DDT_STATE=AVAIL
      ->COM1
!
NINT(PSENIS):
FINT(PSENIS):
      P_DEST=DDT_REPSNO
      P_SRCE=DISCSNO+64+SLOT
      DDT_STATE=PCLAIMD
COM1:
      P_P3=DDT_CSW1
      P_P4=DDT_CSW2
      P_P5=CSW1
COM2:
      P_P1=DDT_ID
      P_P2=1
      P_P6=ADDR(DDT_SENSE1)
      DREPORT(DDT,P)
      PON(P) %unless P_DEST=0
      %return
!
AINT(*):                                ! private atts
      P_DEST=DDT_REPSNO
      P_SRCE=DDT_SER+64
      P_P1=0
      P_P2=0
      P_P3=CSW1
      P_P4=CSW2
      PON(P) %unless P_DEST=0
      %return
INACT(*):                               ! sink
      PKMONREC("DISC act?:",P)
      %return
!
%stringfn MTOS(%integer M)
%integer I,J
      I=4; J=M
      %result=STRING(ADDR(I)+3)
%end
!
%routine READ DLABEL(%record (DTFORM) %name DDT)
%integer I,RAD
      I=DDT_CCWA
      RAD=REALISE(I)
      INTEGER(I)=x'13000000';           ! recalibrate
      INTEGER(I+4)=x'60000001'
      INTEGER(I+8)=x'31000000'!(RAD+32); ! search id eq
      INTEGER(I+12)=x'60000005'
      INTEGER(I+16)=x'08000000'!(RAD+8); ! tic
      INTEGER(I+20)=0
      INTEGER(I+24)=x'06000000'!(RAD+40); ! read data
      INTEGER(I+28)=x'20000050'
      INTEGER(I+32)=0;                  ! cchh = 0
      INTEGER(I+36)=0;                  ! r0
      DDT_STICK=CURRTICK
      FIRE CHAIN(I)
%end
!
%routine LABREAD ENDS
      LABREADS=LABREADS-1
      %if INITINH=1 %and LABREADS=0 %then %c
         INITINH=0 %and UNINHIBIT(SCHEDSNO>>16)
%end
!
%routine SENSE(%record (DTFORM) %name DDT, %integer VALUE)
%integer I
      I=DDT_CCWA-8
      %if VA MODE=YES %start
         *l_1,i; *lra_0,0(1); *st_0,i
      %finish
      PAGE0_CAW=I
RESIO:I=SIO(DDT_CUU); ->RESIO %if I=2
      %unless I=0 %start
         P_DEST=DISCSNO!3;              ! pon abterm
         P_P1=DDT_CUU
         P_P2=PAGE0_CSW1
         P_P3=PAGE0_CSW2
         P_P4=BYTEINTEGER(COM_STEER INT+P_P1)
         PRINTSTRING("DISC sense fails ".STRINT(I)." on CUU ".HTOS(DDT_CUU,3))
         NEWLINE
         PON(P)
      %finish
      DDT_STICK=CURRTICK
%end
!
%routine FIRE CHAIN(%integer CCWA)
%integer I
      %if VA MODE=YES %start
         *l_1,ccwa; *lra_0,0(1); *st_0,ccwa
      %finish
      PAGE0_CAW=CCWA
RETIO:I=TIO(DDT_CUU)
      ->RETIO %if I=2
      %if I=0 %start
RESIO:   I=SIO(DDT_CUU)
         ->RESIO %if I=2
      %finish
      %unless I=0 %start
         DDT_CSW1=PAGE0_CSW1
         DDT_CSW2=PAGE0_CSW2
         OPMESS("DISC fire fails: ".STRINT(I))
         PRINTSTRING("DISC fire i/o fails:")
         DUMPTABLE(0,ADDR(DDT),512)
         P_DEST=DISCSNO!3;              ! pon abterm
         P_P1=DDT_CUU
         P_P2=DDT_CSW1
         P_P3=DDT_CSW2
         P_P4=BYTEINTEGER(COM_STEER INT+P_P1)
         PON(P)
      %finish
%end
!
%routine DREPORT(%record (DTFORM) %name DDT, %record (PARMF) %name P)
%integer I,J
      PRINTSTRING("&& disc transfer ".DDT_LAB." on ".MTOS(DDT_MNEMONIC)." (". %c
         HTOS(DDT_CUU,3).") fails ".STRING(ADDR(COM_DATE0)+3)." ".STRING %c
         (ADDR(COM_TIME0)+3))
      PRINTSTRING("
csw1 = ".STRHEX(P_P3)." csw2 = ".STRHEX(P_P4)."
ccws (@ ".STRHEX(DDT_CCWA).") : ")
      I=DDT_CCWA
      %cycle
         NEWLINE
         PRINTSTRING(STRHEX(INTEGER(I))." ".STRHEX(INTEGER(I+4)))
         J=INTEGER(I)
         %unless J>>24=8 %start
            %exitif INTEGER(I+4)&x'40000000'=0
         %finish
         I=I+8
      %repeat
      NEWLINE
      PRINTSTRING("sense data :")
      %for I=0,1,3 %cycle
         PRINTSTRING(" ".STRHEX(INTEGER(ADDR(DDT_SENSE1)+4*I)))
      %repeat
      NEWLINE
%end
!
%end
!
!------------------------------------------------------------------------
!
%externalroutine PDISC(%record (PARMF) %name P)
%constintegerarray CMD(1:6)=x'06000000',x'05000000'(2),x'06000000'(2),
x'05000000'
%recordformat REQFORM(%integer DEST, %byteinteger FAULTS,FLB,LLBP1,REQTYPE,
   %integer IDENT,CYLINK,COREADDR,CYL,TRKSECT,STOREX,REQLINK)
%record (DTFORM) %name DDT
%record (PROPFORM) %name PROP
%record (PARMXF) %name ACELL
%record (REQFORM) %name REQ,ENTRY
%constinteger TRANOK=0,TRANWITHERR=1,TRANREJECT=2,NOTTRANNED=3
%constinteger ABORTED=4,PTACT=5,POUTACT=6
%constinteger RETRIES=7,MAXTRANS=5
%routinespec QUEUE(%integername QHEAD, %integer REQ,CYL)
%routinespec PTREPLY(%record (REQFORM) %name REQ, %integer FAIL)
%switch PDA(0:11)
%owninteger INIT=0
%integername LINK
%integer SEMA
%integer I,J,K,ACT,UNIT,LUNIT,CYL,TRACK,SECT,CELL,SECSTAT
%integer CCWA,SEEKA,RSEEKA,SECTINDX,ERRCCW,UNRECOVERED,NEXTCELL,SRCE,FAIL,FLB
%integer STOREX,L,PRIO,NEXTSEEK
!
      ACT=P_DEST&x'ffff'
      %if KMON>>33&1#0 %then PKMONREC("pdisc:",P)
      ->PDA(ACT)
!
PDA(0):                                 ! initialise
      %returnif INIT#0
      %for I=0,1,NDISCS-1 %cycle
         DDT==RECORD(INTEGER(DITADDR+4*I))
         DDT_QSTATE=0
         DDT_LQLINK=0
         DDT_UQLINK=0
         DDT_TRLINK=0
         DDT_CURCYL=0
      %repeat
      INIT=1
      %return
!
PDA(6):                                 ! pageout request (write)
PDA(5):                                 ! pageturn request (read)
                                        ! P_P1 = amtx/epx
                                        ! P_P2 = discaddr
                                        ! P_P3 = storex
                                        ! P_P4 = priority (0=high,1=low)
      P_P6=P_P3;                        ! save storex
      P_P3=P_P3*PAGESIZE;               ! store addr
PDA(1):                                 ! read
PDA(2):                                 ! write
PDA(3):                                 ! write + check
PDA(4):                                 ! check read
                                        ! p_p3 now real store addr
      SRCE=P_SRCE&x'7fffffff'
      UNIT=P_P2>>24
      %if UNIT>99 %then ->REJECT
      J=P_P2&x'ffffff'
      LUNIT=LVN(UNIT)
      ->REJECT %if LUNIT>=NDISCS
      DDT==RECORD(INTEGER(DITADDR+4*LUNIT))
      PROP==RECORD(DDT_PROPADDR)
      I=J//PROP_PPERTRK
      SECT=J-I*PROP_PPERTRK+1
      CYL=I//PROP_TRACKS
      TRACK=I-CYL*PROP_TRACKS
      %if CYL>PROP_CYLS %then ->REJECT
      %if PARMASL=0 %then MORE PPSPACE
      ACELL==PARM(PARMASL)
      CELL=ACELL_LINK
      REQ==PARM(CELL)
      %if CELL=PARMASL %then PARMASL=0 %else ACELL_LINK=REQ_REQLINK
      P_SRCE=ACT
      REQ<-P
      REQ_DEST=SRCE
      REQ_CYLINK=0
      REQ_CYL=CYL
      REQ_TRKSECT=(TRACK<<8!SECT)<<8
      REQ_REQLINK=0
      %if DDT_QSTATE=0 %or CYL>=DDT_CURCYL %then %c
         QUEUE(DDT_UQLINK,CELL,CYL) %else QUEUE(DDT_LQLINK,CELL,CYL)
      ->INIT TRANSFER %if DDT_QSTATE=0
      %return
!
REJECT:
      PKMONREC("*** pdisc rejects",P)
      P_DEST=SRCE
      P_SRCE=PDISCSNO!ACT
      P_P2=TRANREJECT
      %if ACT=PTACT %then PTREPLY(P,2) %else PON(P)
      %return
!
INIT TRANSFER:
      CELL=DDT_UQLINK
      REQ==PARM(CELL)
      DDT_UQLINK=REQ_REQLINK
      CYL=REQ_CYL
      CCWA=DDT_CCWA
      SEEKA=CCWA+MAXTRANS*48-8
      RSEEKA=REALISE(SEEKA)
      PROP==RECORD(DDT_PROPADDR)
      SECTINDX=PROP_SECTINDX
      %if CYL=DDT_CURCYL#0 %then NEXTSEEK=x'1b000000' %else %c
         NEXT SEEK=x'07000000'
                                        ! '07' = seek cyl/head: '1b' = seek head
      FLB=0; I=0
      %cycle
         NEXTCELL=REQ_CYLINK
         INTEGER(CCWA)=NEXT SEEK!RSEEKA
         INTEGER(CCWA+4)=x'40000006'
         CCWA=CCWA+8
         INTEGER(CCWA)=x'23000000'!(RSEEKA+7)
         INTEGER(CCWA+4)=x'40000001'
         CCWA=CCWA+8
         INTEGER(CCWA)=x'31000000'!(RSEEKA+2)
         INTEGER(CCWA+4)=x'40000005'
         INTEGER(CCWA+8)=x'08000000'!REALISE(CCWA)
         INTEGER(CCWA+12)=0
         CCWA=CCWA+16
         INTEGER(CCWA)=CMD(REQ_REQTYPE&255)!REQ_COREADDR
         INTEGER(CCWA+4)=x'40000000'!PAGESIZE
         INTEGER(SEEKA)=CYL
         INTEGER(SEEKA+4)=REQ_TRKSECT!((REQ_TRKSECT>>8&255-1)*SECTINDX)
         CCWA=CCWA+8
         SEEKA=SEEKA-8
         RSEEKA=RSEEKA-8
         I=I+1
         REQ_REQLINK=DDT_TRLINK
         DDT_TRLINK=CELL
         FLB=(CCWA-DDT_CCWA)>>2
         REQ_LLBP1=FLB
         CELL=NEXT CELL
         %if CELL=0 %then ->DECHAIN
         REQ==PARM(CELL)
         %exitif I=MAXTRANS
      %repeat
      REQ_REQLINK=DDT_UQLINK
      DDT_UQLINK=CELL
!
DECHAIN:
      %if I=0 %then ->DOMORE
      INTEGER(CCWA-4)=INTEGER(CCWA-4)&x'bfffffff'
      DDT_STATS2=DDT_STATS2+1
      P_DEST=DISCSNO!2
      P_SRCE=PDISCSNO!10
      P_P1=ADDR(DDT)
      DDT_QSTATE=1
      DDT_CURCYL=CYL
      DISC(P)
      %return
!
PDA(10):
      DDT==RECORD(P_P1)
      CELL=DDT_TRLINK
      %if P_P2=0 %start
         %while CELL#0 %cycle
            REQ==PARM(CELL)
            J=REQ_REQLINK
            %if REQ_REQTYPE=PTACT %then PTREPLY(REQ,0) %elsestart
               INTEGER(ADDR(REQ)+4)=PDISCSNO
               REQ_CYLINK=0
               FASTPON(CELL)
            %finish
            CELL=J
         %repeat
         DDT_TRLINK=0
DOMORE:
         %if DDT_UQLINK=0 %then DDT_UQLINK=DDT_LQLINK %and DDT_LQLINK=0
         ->INIT TRANSFER %if DDT_UQLINK#0
         DDT_QSTATE=0
         %return
      %finish
      DDT_STATS1=DDT_STATS1+1
      ERRCCW=(P_P3-DDT_CCWA)>>2
      SEC STAT=INTEGER(P_P6)
      UNRECOVERED=1
      FAIL=NOT TRANNED
      CYL=DDT_CURCYL
      %while CELL#0 %cycle
         REQ==PARM(CELL)
         DDT_TRLINK=REQ_REQLINK
         %if REQ_LLBP1<=ERRCCW %or REQ_FAULTS>RETRIES %start
            %if REQ_LLBP1<=ERRCCW %then REQ_CYLINK=TRAN OK %else %c
               REQ_CYLINK=FAIL
            %if REQ_CYLINK#0 %start
               PKMONREC("pdisc transfer fails",P)
            %finish
            %if REQ_REQTYPE=PTACT %then PTREPLY(REQ,REQ_CYLINK) %else %c
               INTEGER(ADDR(REQ)+4)=PDISCSNO %and FASTPON(CELL)
         %finishelsestart
            REQ_CYLINK=0
            %if REQ_FLB<=ERRCCW<=REQ_LLBP1 %and UNRECOVERED#0 %then %c
               REQ_FAULTS=REQ_FAULTS+1
            QUEUE(DDT_UQLINK,CELL,CYL)
         %finish
         CELL=DDT_TRLINK
      %repeat
      %if SEC STAT<<1<0 %then DDT_QSTATE=2 %andreturn
      ->DOMORE
!
PDA(11):
      DDT==RECORD(INTEGER(DITADDR+4*P_P1))
      DDT_TRLINK=0
      DDT_CURCYL=0
      ->DOMORE
!
PDA(7):                                 ! special tests
      %return
!
!
PDA(*):
      PKMONREC("pdisc act??",P)
      %return
!
%routine QUEUE(%integername LINK, %integer CELL,CYL)
%record (REQFORM) %name REQ,ENTRY,NEXTREQ
%integer NEXTCELL,AD
      REQ==PARM(CELL)
      NEXTCELL=LINK
      ENTRY==PARM(NEXTCELL)
      %if NEXTCELL=0 %or CYL<ENTRY_CYL %start
         LINK=CELL
         REQ_REQLINK=NEXTCELL
         %return
      %finish
      %cycle
         ->QONCYL %if CYL=ENTRY_CYL
         NEXTCELL=ENTRY_REQLINK
         %exitif NEXTCELL=0
         NEXTREQ==PARM(NEXTCELL)
         %exitif NEXTREQ_CYL>CYL
         ENTRY==NEXTREQ
      %repeat
      REQ_REQLINK=NEXTCELL
      ENTRY_REQLINK=CELL
      %return
QONCYL:
      REQ_CYLINK=ENTRY_CYLINK
      ENTRY_CYLINK=CELL
%end
!
%routine PTREPLY(%record (REQFORM) %name REQ, %integer FAIL)
!***********************************************************************
!*    Replies to all local controllers waiting for a page transfer     *
!*    usually one only but possibly several. This code will go inline  *
!*    for the normal case when alltransfers in chain are errorfree     *
!***********************************************************************
%record (PARMXF) %name REP
%integer L,J,STOREX
      STOREX=REQ_STOREX
      %if FAIL>1 %thenstart;            ! clear the page
         J=RTV(REQ_COREADDR)
         *ipk_0; *st_2,l; *slr_2,2; *spka_0(2); ! key 0
         *l_0,j; *l_1,pagesize
         *lr_2,0; *slr_3,3; *mvcl_0,2
         *l_2,l; *spka_0(2);            ! restore key
         J=RTV(-1)
      %finish
      %if MULTIOCP=YES %thenstart
         SEMALOOP(STORESEMA,0)
      %finish
      L=STORE(STOREX)_LINK
      STORE(STOREX)_FLAGS=STORE(STOREX)_FLAGS&x'ff3f'; ! clear i/o flag
      STORE(STOREX)_LINK=0;             ! & link
      %if MULTI OCP=YES %then STORESEMA=-1
      %until L=0 %cycle
         REP==PARM(L)
         %if FAIL#0 %then REP_DEST=REP_DEST!1 %and REP_P3=FAIL
         J=REP_LINK
         FASTPON(L)
         L=J
      %repeat
      RETURN PPCELL(CELL) %if FAIL#2;   ! headcell back to freelist
%end
!
%end
!
%externalroutine SEMAPHORE(%record (PARMF) %name P)
%recordformat SEMAF(%integer DEST,SRCE,TOP,BTM,SEMA,TICK,P5,P6,LINK)
%record (SEMAF) %name SEMACELL
%record (PARMXF) %name WAITCELL
%ownintegerarray HASH(0:31)=0(32)
%owninteger TICKS=0
%integerfnspec NEWSCELL
%integerfnspec NEWWCELL
%integer SEMA,HASHP,NCELL,I,WCELL
%integername CELLP
%switch ACT(1:4)
      %if MONLEVEL&2#0 %and KMON&1<<7#0 %then PKMONREC("Semaphore:",P)
      SEMA=P_P1
      %if P_DEST&15<3 %then %c
         HASHP=IMOD(SEMA-SEMA//31*31) %and CELLP==HASH(HASHP)
      ->ACT(P_DEST&7)
!-----------------------------------------------------------------------
ACT(1):                                 ! p operation
      %while CELLP#0 %cycle
         SEMACELL==PARM(CELLP)
         %if SEMA=SEMACELL_SEMA %thenstart
            I=SEMACELL_BTM
            %if I=0 %thenstart;         ! already had v operation
               SEMACELL_DEST=P_SRCE
               SEMACELL_SRCE=x'70001'
               FASTPON(CELLP)
               CELLP=0
            %finishelsestart;           ! add to btm of queue
               WCELL=NEWWCELL
               PARM(I)_LINK=WCELL
               SEMACELL_BTM=WCELL
            %finish
            %return
         %finish
         CELLP==SEMACELL_LINK
      %repeat
!
! no queue yet
!
      NCELL=NEWSCELL
      CELLP=NCELL
      WCELL=NEWWCELL
      SEMACELL_TOP=WCELL
      SEMACELL_BTM=WCELL
      %return
!-----------------------------------------------------------------------
ACT(2):                                 ! v operation
      %while CELLP#0 %cycle
         SEMACELL==PARM(CELLP)
         %if SEMA=SEMACELL_SEMA %thenstart
            SEMACELL_TICK=TICKS;        ! record v operation
            I=SEMACELL_TOP
            %if I#0 %start;             ! in case 2 v operations
               SEMACELL_TOP=PARM(I)_LINK
               PARM(I)_SRCE=P_SRCE;     ! if a timeout P_SRCE = X'70004'
                                        ! this SRCE enables director to reset faulty SEMA
               FASTPON(I)
            %finish
            %if SEMACELL_TOP=0 %thenstart; ! return headcell
               I=SEMACELL_LINK
               RETURN PP CELL(CELLP)
               CELLP=I
            %finish
            %return
         %finish
         CELLP==SEMACELL_LINK
      %repeat
!
! p operation not here yet
!
      NCELL=NEWSCELL
      CELLP=NCELL
      %return
!-----------------------------------------------------------------------
ACT(3):                                 ! display semaphore queues
      %if MONLEVEL&2#0 %thenstart
         %for HASHP=0,1,31 %cycle
            CELLP==HASH(HASHP)
            %while CELLP#0 %cycle
               SEMACELL==PARM(CELLP)
               SEMA=SEMACELL_SEMA
               I=SEMACELL_TOP
               %while I#0 %cycle
                  OPMESS("Sema x".HTOS(SEMA,8)." q :x".HTOS(PARM(I)_DEST>>16,
                     3))
                  I=PARM(I)_LINK
               %repeat
               CELLP==SEMACELL_LINK
            %repeat
         %repeat
      %finish
      %return
!-----------------------------------------------------------------------
ACT(4):                                 ! ten second tick
      TICKS=TICKS+1
      %for HASHP=0,1,31 %cycle
         CELLP==HASH(HASHP)
         %while CELLP#0 %cycle
            SEMACELL==PARM(CELLP)
            %if TICKS-SEMACELL_TICK>=12 %start; ! 2 mins since v oper
               OPMESS("Fsema timeout ".HTOS(SEMACELL_SEMA,8))
               P_DEST=x'70002'
               P_SRCE=x'70004'
               P_P1=SEMACELL_SEMA
               PON(P)
            %finish
            CELLP==SEMACELL_LINK
         %repeat
      %repeat
      %return
%integerfn NEWWCELL
%integer I
      I=NEWPPCELL
      WAITCELL==PARM(I)
      WAITCELL_DEST=P_SRCE
      WAITCELL_SRCE=x'70001'
      WAITCELL_LINK=0
      %if MONLEVEL&2#0 %then WAITCELL_P5=m'SEMA'
      %if MONLEVEL&2#0 %then WAITCELL_P6=m'WAIT'
      %result=I
%end
!-----------------------------------------------------------------------
%integerfn NEWSCELL
%integer I
      I=NEWPPCELL
      SEMACELL==PARM(I)
      SEMACELL=0
      SEMACELL_SEMA=SEMA
      SEMACELL_TICK=TICKS
      %if MONLEVEL&2#0 %then SEMACELL_P5=m'SEMA'
      %if MONLEVEL&2#0 %then SEMACELL_P6=m'head'
      %result=I
%end
%end
%endoffile