!***********
!* SUP009  *
!*03.NOV.80*
!***********

CONTROL  K'111011';       ! MUL+TRUSTED

PERMROUTINESPEC  SVC
PERMINTEGERMAPSPEC  INTEGER(INTEGER  X); ! USED IN INIT
RECORDFORMAT  DUMMY(INTEGER  X)
CONSTRECORD  (DUMMY) NAME  NULL=0


BEGIN 
     CONSTINTEGER  TASK LOW LIMIT=30
     CONSTINTEGER  TASK LIMIT=70
     CONSTINTEGER  FREE CELLS=80
     CONSTINTEGER  NO OF SERVICES=TASK LIMIT
     CONSTINTEGER  FRAG NO=15
     CONSTINTEGER  PSECT LENGTH=48
     CONSTINTEGER  SVC LIMIT=23
     CONSTINTEGER  INT LIMIT=-50
     CONSTINTEGER  K SEG LIMIT=110

     CONSTINTEGER  HIGHEST PRIORITY = 3

     CONSTINTEGER  TTID=30;           ! TASK LO LIMIT
     CONSTINTEGER  DKID=31;           !   "   "    " +1
     CONSTINTEGER  DIRID=32;          !   "   "    " +2
     CONSTINTEGER  LOADID=33;         !   "   "    " +2
     CONSTINTEGER  MOTHER=35;         !   "   "    " +4

     CONSTINTEGERNAME  PS=K'177776'; ! STATUS WORD
     CONSTINTEGERNAME  STACK LIMIT=K'177774'

     RECORDFORMAT  EF(RECORD  (EF) NAME  LINK, INTEGER  ID, A1)
     RECORDFORMAT  QF(RECORD  (EF) NAME  E)
     RECORDFORMAT  TF(RECORD  (TF) NAME  LINK, INTEGER  ID, T)

     RECORDFORMAT  KSEGF(INTEGER  USE, DADD, PAR, PDR)
     RECORDFORMAT  KSEGLF(RECORD  (KSEGLF) NAME  L, INTEGER  B, C, D)

     RECORDFORMAT  UREGSF(INTEGER  R0, R1, R2, R3, R4, R5, PC, C 
                                   PS, SP)
     RECORDFORMAT  SEGF(INTEGER  PAR, PDR, RECORD  (KSEGF) NAME  KSL, C 
       INTEGER  USE)
     RECORDFORMAT  PSECTF(RECORD  (QF) NAME  E,BYTEINTEGER  ID, STATE, C 
       BYTEINTEGERARRAY  NAME(0:3), C 
       INTEGER  PRIO, RECORD  (QF) POFFQ, C 
       RECORD  (UREGSF) URS, INTEGER  TRAPV, C 
       RECORD  (SEGF) ARRAY  SEG(0:7))
     RECORDFORMAT  PSTF(RECORD  (PSECTF) NAME  P)

     RECORDFORMAT  PF(BYTEINTEGER  SERVICE, REPLY, C 
       INTEGER  A1, A2, A3)
     RECORDFORMAT  P2F(INTEGER  D, A1, A2, A3)
     RECORDFORMAT  MAINPF(RECORD  (MAINPF) NAME  L, RECORD  (P2F) P)

     RECORDFORMAT  STOREF(INTEGER  LEN, BLOCK NO)
     RECORDFORMAT  ADDRFN(RECORD  (ADDRFN) NAME  PSECTA, LAST32, COREA)
     CONSTRECORD  (ADDRFN) NAME  ADDS=K'120'

     RECORDFORMAT  D1F(INTEGER  X)
     RECORDFORMAT  D2F(RECORD  (QF) NAME  X)
     RECORDFORMAT  D3F(INTEGERNAME  X)




     RECORD  (EF) NAME  E
     RECORD  (TF) NAME  T, T2, TN, TB
     RECORD  (PSECTF) NAME  PSECT, PSECT2, PSECTN, PSECT3
     RECORD  (SEGF) NAME  SEG1, SEG2
     RECORD  (KSEGF) NAME  KS1, KS2
     RECORD  (KSEGLF) NAME  KL
     EXTERNALRECORD  (KSEGLF) NAME  FREE SEGL
     OWNINTEGER  IPL TICKS = 0

     EXTERNALRECORD  (QF) ARRAY  CPUQ(0:HIGHEST PRIORITY)
     !*

     RECORD  (PF) PX
     RECORD  (PF) NAME  P, Q
     RECORD  (P2F) NAME  P2, Q2, PXP
     RECORD  (MAINPF) NAME  MAINP, MP2
     EXTERNALRECORD  (QF) NAME  FREE PARAM
     RECORD  (QF) TIME Q;             ! HEAD OF TIMER LIST

     INTEGER  QU, SERVICE, TICKS, LEN, I, PT, L2, BLOCK, S, ID, CALL SEG
     INTEGER  PAR, PDR

     RECORD  (D1F) NAME  D1
     RECORD  (D2F) D2
     RECORD  (D3F) NAME  D3


     EXTERNALRECORD  (PSTF) ARRAY  PSECTA(TASK LOW LIMIT:TASK LIMIT)
     EXTERNALRECORD  (TF) ARRAY  ONTMQ(TASK LOW LIMIT:TASK LIMIT)

     EXTERNALRECORD  (MAINPF) ARRAY  PARAMS(0:FREE CELLS)

     EXTERNALRECORD  (STOREF) ARRAY  STORE(0:FRAG NO)
     RECORD  (STOREF) NAME  ST1, ST2

     EXTERNALRECORD  (KSEGLF) ARRAY  KSEGL(1:K SEG LIMIT)

!     %EXTERNALRECORD (P2F) %ARRAY LAST THIRTY2(0:15);  %OWNINTEGER LAST=0

     EXTERNALBYTEINTEGERARRAY  SER MAP(INT LIMIT:NO OF SERVICES)= C 
        0(40), 0, 0, 0, 0, 0, 0, MOTHER, DKID, TTID, TTID, 0,
         TTID, 0, DKID, DIRID, LOADID, 0, MOTHER, 0(63)

     CONSTINTEGER  FAULT SER=-4
     !!   TU 16 INT = -5
     !!   DQS11 TX INT = -6
     !!   DQS11 RX INT = -7




     SYSTEMINTEGERFNSPEC  RUN
     EXTERNALROUTINESPEC  INITIALISE

     !! %PERMROUTINESPEC PUSH(%RECORD (QF) %NAME Q, %RECORD (EF) %NAME E)
     !! %PERMRECORD (QF) %MAPSPEC POP(%RECORD (QF) %NAME Q)

     !*
     ROUTINESPEC  SCHEDULE
     ROUTINESPEC  DEALLOCATE(RECORD  (KSEGF) NAME  KS)
     ROUTINESPEC  FAULT(INTEGER  I)

     !***********************************************
     !*          SUPERVISOR STATES                  *
     !***********************************************
     CONSTINTEGER  IDLE ST=-1
     CONSTINTEGER  TASK ST=0

     !**********************************************
     !*                TASK STATES                 *
     !**********************************************
     CONSTINTEGER  T WAIT=1
     CONSTINTEGER  T POFF=2
     CONSTBYTEINTEGER  T CPUQ=8
     CONSTBYTEINTEGER  T RUN=16
     CONSTBYTEINTEGER  T SUSP=K'200'


     !***********************************************
     !*         SVC SERVICES (BY EMT VALUE)         *
     !***********************************************
     CONSTINTEGER  INTERRUPT=-1
     CONSTINTEGER  WAIT=1
     CONSTINTEGER  PON R=2
     CONSTINTEGER  POFF R=3
     CONSTINTEGER  INSERT=4
     CONSTINTEGER  DELETE=5
     CONSTINTEGER  ALLOCATE CORE=6
     CONSTINTEGER  FREESP=7
     CONSTINTEGER  SET TIME=8
     CONSTINTEGER  SCHEDULE T=9
     CONSTINTEGER  MAP VIRT=10
     CONSTINTEGER  GET ABS=11
     CONSTINTEGER  GET ID=12
     CONSTINTEGER  LINKIN=13
     CONSTINTEGER  MAP SHARED=14
     CONSTINTEGER  MAP HREGS=15
     CONSTINTEGER  MAP PSECT=16
     CONSTINTEGER  PONPOFF=17
     CONSTINTEGER  SET PRIO=18
     CONSTINTEGER  SET T BIT = 19
     CONSTINTEGER  TOFF = 20
     CONSTINTEGER  DPTAB = 22
     CONSTINTEGER  TIME SER = 23


     !************************************************
     !*          STATIC CORE LOCATIONS               *
     !************************************************
     CONSTINTEGERNAME  INT VALUE=K'40'
     CONSTINTEGERNAME  ALARM F=K'44'
     CONSTRECORD  (PSTF) NAME  PSECTX = K'46'
     CONSTINTEGERNAME  PSECT AREA=K'50'
     CONSTINTEGERNAME  FAULT TYPE=K'52'
     CONSTRECORD  (PSTF) NAME  LAST PSECT = K'54'
     CONSTINTEGERNAME  EXTRA INT INFO = K'56'

     CONSTINTEGERNAME  SVCADDRESS = K'30'
     !*************************************************
     SWITCH  SER(-1:SVC LIMIT)

     CONSTINTEGERARRAYNAME  U PAR = K'177640'
     CONSTINTEGERARRAYNAME  U PDR = K'177600'


     !***************************************************
     !*            START OF CODE PROPER                 *
     !***************************************************

     INITIALISE;                ! HELD IN DE-ALLOCATABLE SPACE


     !*****************************************************
     !*            BASIC LOOP IS CPU SCHEDULER            *
     !*****************************************************

     *K'013700'; *K'30';  ! MOV SVC, R0
     *K'010540';          ! MOV R5, -(R0)
     *K'010440';          ! MOV R4, -(R0)
     D1 == D2; D3 == D1; PXP == PX;  PX_REPLY = 0
     CYCLE 
      IF  NOT  CPUQ(3)_E == NULL START 
         PSECT == POP(CPUQ(3))
      ELSE 
         IF  NOT  CPUQ(2)_E == NULL START 
            PSECT == POP(CPUQ(2))
         ELSE 
            IF  NOT  CPUQ(1)_E == NULL START 
               PSECT == POP(CPUQ(1))
            ELSE 
               IF  NOT  CPUQ(0)_E == NULL START 
                  PSECT == POP(CPUQ(0))
               ELSE 
                  !! NOTHING TO DO
                  PSECT == NULL;  PSECTX_P == NULL
                  ->GO2
               FINISH 
            FINISH 
         FINISH 
      FINISH 
GO:  IF  PSECT_STATE&T SUSP#0 THENCONTINUE ;  ! DON'T RUN IT
     PSECT_STATE=T RUN
     PSECTX_P == PSECT
GO2: SERVICE=RUN;                   ! EXTERNAL ROUTINE
     ->SER(SERVICE) IF  SERVICE<=SVC LIMIT
     FAULT TYPE=5
ERROR:
     INT VALUE=FAULT SER

SER(INTERRUPT):             ; ! DEVICE INTERRUPT
     IF  INT VALUE#FAULT SER START 
        SCHEDULE UNLESS  PSECT == NULL
        PX_A3 = EXTRA INT INFO;      ! PASS STUFF THROUGH
     ELSE 
        PX_A2=PSECT_ID
        PX_A3=FAULT TYPE
     FINISH 
     -> CLOCKINT IF  INT VALUE = 0
     ID=SER MAP(INT VALUE)
     PX_SERVICE=INT VALUE
     P2==PXP;  P==P2
     !* AND SEND IT
     !! SEND MESS TO RELEVANT TASK
     ->DO PON

SER(WAIT):
     PSECT_STATE=T WAIT
     CONTINUE ;                   ! FIND SOMETHING ELSE

SER(PON R):
SER(PONPOFF):;                ! PON-POFF FROM USER
     P2==PSECT_URS;           ! MAP PARAM AREA TO HIS REGS
     P==P2
     !* NOW PLANT ON Q
     !* AND SCHEDULE PROCESS IF NECESSARY
     ID=SER MAP(P_SERVICE);           ! AND FIND THE OWNING PROCESS
DO PON:
     PSECT3==PSECTA(ID)_P;        ! PSECT OF RECEIVING MESSAGE
     IF  PSECT3==NULL OR  ID=0 START 
        FAULT TYPE=6;  PX_A1 = P_SERVICE
        -> ERROR
     FINISH 
     Q==PSECT3_URS
     IF  PSECT3_STATE&T POFF#0 AND  C 
        (Q_SERVICE=0 OR  PSECT3_URS_R0=P2_D) START 

        !! IS WAITING FOR POFF, AND IS THE CORRECT MESSAGE

         PSECT3_STATE = (PSECT3_STATE&T SUSP)!T CPUQ; ! CODE OF SCHEDULE
         PUSH(CPUQ(PSECT3_PRIO), PSECT3)

PON EXECUTE:
           Q = P2
           ! LAST THIRTY2(LAST)=P2;  ! LAST=(LAST+1)&15
     ELSE 
        MAINP==FREE PARAM;          ! PICK UP NEW PARAM CELL
        FAULT(9) IF  MAINP == NULL
        FREE PARAM==MAINP_L;        ! RELINK FREE LIST
        MAINP_P = P2
        PUSH(PSECT3_POFFQ, MAINP);    ! PUT ON TASK POFF Q
      FINISH 
      IF  SERVICE < 0 THEN  CONTINUE ;  ! (=INTERRUPT)DO A PRIO SCAN
      IF  SERVICE#PONPOFF THEN  ->GO2;  ! PON OR POFF, SO JUST REENTER
      
      !**************************************************************
      !  THIS SECTION IS DEPENDENT ON THE FORMAT OF PSECTF
      *K'013700';  *K'54';  ! MOV LAST PSECT, R0
      *K'000360';  *K'14';    ! SWAB(LAST PSECT_URS_R0)
      ! WOULD BE PREFERABLE IN IMP, BUT WOULD COST AT LEAST 10 WORDS
      !**************************************************************

SER(POFF R):;             ! USER POFF
     UNLESS  PSECT_POFFQ_E==NULL START ; ! Q NON ZERO
        MP2==PSECT_POFFQ_E;    ! GET LAST ENTRY
        Q==PSECT_URS;  Q2==Q
        UNTIL  MP2==MAINP CYCLE ;       ! CYCLE WHOLE Q
           MAINP==POP(PSECT_POFFQ)
           P==MAINP_P;  P2==P
           IF  Q_SERVICE=0 OR  Q2_D=P2_D START 
              MAINP_L==FREE PARAM;  FREE PARAM==MAINP; ! RELINK ON Q
              ->PON EXECUTE
           FINISH 
           PUSH(PSECT_POFFQ, MAINP)
        REPEAT 
     FINISH 
     PSECT_STATE=T POFF
     CONTINUE 


SER(SCHEDULE T):                ! R0 IS ID OF TASK TO BE SCHEDULED
     I = PSECT_URS_R1; ! 0 = SCH, 1 = HOLD, X = ADDR
     SCHEDULE;     ! RE-SCHEDULE CALLER
     PSECT==PSECTA(PSECT_URS_R0)_P
     FAULT(7) IF  PSECT==NULL
     IF  I&1 = 0 START 
        PSECT_STATE = PSECT_STATE&(¬T SUSP); ! ENSURE NOT SUSPENDED
        IF  I # 0 START ;            ! FORCE NEWW ADDRESS AND START UP
           PSECT_URS_PC = I
        ELSE 
           IF  PSECT_STATE&T POFF # 0 THEN  CONTINUE 
        FINISH 
        SCHEDULE
     ELSE 
        PSECT_STATE = PSECT_STATE!T SUSP;  ! SUSP IT
     FINISH 
        CONTINUE 

SER(DELETE):                      ! DELETE THE RUNNING TASK
        I = PSECT_URS_R0
        IF  PSECT_ID=LOADID OR  I#0 START 
           SCHEDULE;     ! RE-SCHEDULE LOADER
           PSECT==PSECTA(I)_P
        FINISH 
        CYCLE ;                  ! CLEAR OUT THE POFF Q
           MAINP==POP(PSECT_POFFQ)
           EXITIF  MAINP==NULL
           MAINP_L==FREE PARAM;  FREE PARAM==MAINP
        REPEAT 
       CYCLE  I=7, -1, 0;         ! GO DOWN THE SEGS
           KS1==PSECT_SEG(I)_KSL
           UNLESS  KS1 == NULL START 
              KS1_USE=KS1_USE-1
              DEALLOCATE(KS1) IF  KS1_USE=0
           FINISH 
        REPEAT 
        PSECTA(PSECT_ID)_P==NULL


SEARCH CPU Q:
     CONTINUE 

CLOCKINT:                        ! CLOCK HAS TICKED
     IPL TICKS = IPL TICKS+1
     IF  ALARMF # 0 START 
        ALARMF = ALARMF-1
        IF  ALARMF = 0 START 
           !* SEND MESSAGE TO FIRST TASK ON Q
           !* SET CLOCK TO NEXT TIME
           TN==POP(TIME Q)
           UNLESS  TIMEQ_E==NULL START 
              ALARM F=TIMEQ_E_LINK_A1
              IF  ALARMF=0 THEN  ALARMF=1
           FINISH 
           ID=TN_ID
           PX_SERVICE=ID;  PX_REPLY=0
           P2==PX;  TN_T=0
           ->DO PON
        FINISH 
     FINISH 

     REPEAT ;                    ! OF MAIN LOOP

SER(SET TIME):                         ! SET TIMER FOR URS_R0 TICKS
     ID=PSECT_ID
     TN==ONTMQ(ID)
     TICKS=PSECT_URS_R0;          ! NO OF TICKS
     IF  TICKS=0 OR  ONTMQ(ID)_T#0 THEN  FAULT TYPE=7 AND  ->ERROR
     TB==TIMEQ_E;                     ! LAST ENTRY
     ->BOT IF  TB==NULL
     T==TB_LINK;  ! POINT TO FIRST ENTRY, IF ONLY ONE IT IS A LOOPED POINTER
     T_T=ALARM F;       ! ADJUST FOR TIME PAST
     T2==TB
     CYCLE ;                          ! CHECK THE LIST
        IF  TICKS<T_T START ;        ! PUT ON Q HERE
           TN_LINK==T2_LINK;  T2_LINK==TN
           T_T=T_T-TICKS
           EXIT 
        FINISH 
        TICKS=TICKS-T_T
        IF  T==TB START ;             ! AT BOTTOM
BOT:       PUSH(TIMEQ, TN);           ! PLANT ON END
           EXIT 
        FINISH 
        T2==T
        T==T2_LINK
     REPEAT 
     TN_T=TICKS
     ALARM F = TIMEQ_E_LINK_A1
     ->GO;                            ! IMMEDIATE RESCHEDULE

SER(TIME SER):
        PSECT_URS_R0 = IPL TICKS
        ->GO;                         ! IMMEDIATE RESCHEDULE

SER(ALLOCATE CORE):
     LAST PSECT_P == NULL;    ! MUST RELOAD SEG REGS ON EXIT
     ST1 == NULL
     IF  PSECT_ID <= LOADID START 
        LEN=PSECT_URS_R0;                ! CORE REQUIRED IN BLOCKS
        PSECT_URS_R0=0;                  ! URS_R1 IS THE NEW SEG
        L2=K'77777'
        CYCLE  I=FRAG NO, -1, 0
           ST2 == STORE(I)
           IF  ST2_LEN>=LEN AND  ST2_LEN<L2 THEN  C 
             ST1 == ST2 AND  L2=ST2_LEN
        REPEAT 
     FINISH 
     IF  ST1 == NULL THEN  ->GO;              ! NO CORE
        PAR=ST1_BLOCK NO;           ! ADDRESS OF BLOCK (IN BLOCKS)
        IF  L2>LEN START ;            ! EXCESS, SO TRIM
           ST1_BLOCKNO=ST1_BLOCK NO+LEN
           ST1_LEN=ST1_LEN-LEN
        ELSE  ST1 = 0
     KL==FREE SEGL
     FAULT(12) IF  KL==NULL;           ! NO FREE SEGMENT CELLS
     FREE SEGL==KL_L
     KS1==KL;                           ! MAP THE 'REAL' TYPE ON
     KS1_USE=0;                         ! 'SHARED' WILL MAKE IT '1'
     S = 6
     PDR=(LEN-1)<<8!6
     KS1_PAR=PAR;  KS1_PDR=PDR
     CALL SEG = PSECT_URS_R1
     SEG1==PSECTN_SEG(CALL SEG)
     PSECT_URS_R0=BLOCK
     ->DO SHARED;                    ! FILL HIS SEG ENTRY
SER(GET ABS):                      ! GET ABSOLUTE ADDRESS OF VIRT SEG
                                   ! R0=TARGET ID
                                   ! R1=TARGET SEGMENT
                                   ! R2=0 - DROP  =1 - GET
     IF  PSECT_URS_R2=0 THEN  PSECT_URS_R1=-1 ELSEC 
       PSECT_URS_R2=0
     !! THIS CHANGES IT TO THE FORMAT EXPECTED BY MAP VIRT
     !! IT IS ALWAYS MAPPED TO THE CALLERS SEGMENT ZERO


SER(MAP VIRT):                       ! MAP USER A TO B
                                      ! R0 = TARGET ID
                                      ! R1 = TARGET SEG
                                      ! R2 = CALLERS SEG
                                      ! R1 = -1 SIGNIFIES DROP SEG
     CALL SEG=PSECT_URS_R2;        ! GET CALLERS SEG NO
     SEG1==PSECT_SEG(CALL SEG)

MAP2:
     S=0; PAR=0; PDR=0
     IF  PSECT_ID=LOADID THEN  S=6
     IF  PSECT_URS_R1<0 START ;        ! DROP SEGMENT
        KS1==SEG1_KSL
        IF  KS1==NULL THEN  ->MV FAIL;  ! NO SEG
        KS1_USE=KS1_USE-1
        IF  KS1_USE=0 THEN  DEALLOCATE(KS1)
        SEG1=0;                        ! ZERO CALLERS ENTRY
     ELSE 
        !! MAP TO DESIRED SEG
        PSECT2==PSECTA(SER MAP(PSECT_URS_R0))_P
        -> MV FAIL IF  PSECT2==NULL
        KS1==PSECT2_SEG(PSECT_URS_R1)_KSL
DO SHARED:
        UNLESS  KS1==NULL START 
           PAR=KS1_PAR;  PDR=KS1_PDR!S
           SEG1_PAR=PAR;  SEG1_PDR=PDR
           SEG1_KSL==KS1
           KS1_USE=KS1_USE+1
        FINISH 
     FINISH 
MV FAIL:                    ! COMES HERE IF CALL FAILS OR IS OK
     PSECT_URS_R0=PAR;  PSECT_URS_R1=PDR;  ! PASS RESULT BACK

SET SEGREGS:
     UPAR(CALL SEG) = PAR
     UPDR(CALL SEG) = PDR
     ->GO


SER(GET ID):                      ! RETURN ID OF TASK IN R0
        PSECT_URS_R0=PSECT_ID
        ->GO
SER(LINKIN):                       ! R0 IS REQUIRED SERVICE
     SER MAP(PSECT_URS_R0)=PSECT_ID
     ->GO

SER(MAP SHARED):                  ! R0 IS ID, R1=SEG, R2=SHARED NO
     PSECT2==PSECTA(PSECT_URS_R0)_P
     FAULT(8) IF  PSECT2==NULL
     SEG1==PSECT2_SEG(PSECT_URS_R1)
      D1_X = PSECT_URS_R2
      KS1 == D2_X;           ! LOADER PASSES ADDRESS OF DESCRIPT
      LAST PSECT_P == NULL
     S=2;  CALL SEG = 1
     ->DO SHARED

SER(INSERT):                     ! ALLOCATE A NEW PSECT (AND MAP TO R0?)
     CYCLE  ID=TASK LOW LIMIT, 1, TASK LIMIT
        EXIT  IF  PSECTA(ID)_P==NULL
     REPEAT 

     D1_X=PSECT AREA+(ID-MOTHER-1)*(PSECT LENGTH*2)
     !! SHOULD BE *(PSECT LENGTH*2)
     PSECTA(ID)_P==D2_X
     PSECTN==D2_X;               ! MAP TO ARRAY AND PSECTN
     PSECTN_ID=ID
     SER MAP(ID)=ID
     ->MPS;                       ! RESTART LOADER

SER(MAP HREGS):                  ! MAP HARDWARE REGS TO SEG R0
     SEG1==PSECT_SEG(PSECT_URS_R0)
        SEG1_PAR=K'7600';  SEG1_PDR=K'77406';  SEG1_KSL==NULL
        LAST PSECT_P == NULL;    ! FORCE A RELOAD OF SEGMENT REGS
        ->GO

SER(MAP PSECT):                 ! MAP PSECT 'R0' TO SEG IN R1
     ID = PSECT_URS_R0;        ! TARGET TASK ID
MPS: CALL SEG=PSECT_URS_R1
     SEG1==PSECT_SEG(CALL SEG)
     PT=0
     IF  PSECT_ID=LOADID THEN  PDR=2<<8!6 ELSE  PDR=2<<8!2
     D2_X==PSECTA(ID)_P
     UNLESS  D2_X==NULL START 
        PAR = D1_X>>6
        SEG1_PAR=PAR;      ! MAP TO THE START OF ITS BLOCK
        SEG1_PDR=PDR;    ! ACCESS DEPENDS ON TASK
        SEG1_KSL == NULL
        PT=CALL SEG<<13!(D1_X&K'77');  ! POINT R0 TO ITS BEGINNING
     FINISH 
     PSECT_URS_R0=PT
     ->SET SEGREGS

SER(SET PRIO):                 ! SET PRIO BETWEEN 0 AND 3
     PSECT_PRIO = PSECT_URS_R0&3
     SCHEDULE;                 ! CHECK A HIGHER ONE NOT RUNNING
     ->SEARCH CPU Q

SER(SET T BIT):                ! SET THE TRACE TRAP
     PSECT_URS_PS = PSECT_URS_PS!K'20'
      -> GO

SER(TOFF):                      ! TEST FOR MESSAGES
     PSECT_URS_R0 = 0
     IF  NOT  PSECT_POFFQ_E == NULL THEN  PSECT_URS_R0 = 1
     -> GO

SER(DPTAB):
     D1_X = SVCADDRESS-6
     I = D3_X;          !  = 0 IF NO DP CODE IN BRUN
     PT = PSECT_URS_R0;    ! TARGET SEGMENT
     PSECT_URS_R0 = I
     PSECT_SEG(PT)_PAR = I>>6; PSECT_SEG(PT)_PDR = K'406'
     PSECT_SEG(PT)_KSL == NULL;  LAST PSECT_P == NULL; ! FORCE RELOAD
     -> GO




     ROUTINE  SCHEDULE
        PSECT_STATE=(PSECT_STATE&T SUSP)!T CPUQ
        PUSH(CPUQ(PSECT_PRIO), PSECT)
     END 

     ROUTINE  DEALLOCATE(RECORD  (KSEGF) NAME  KS)
        RECORD  (STOREF) NAME  S, S2, S3
        RECORD  (KSEGLF) NAME  KSL
        INTEGER  I, BOT, BLOCK, LEN

        BLOCK=KS_PAR;  LEN=KS_PDR>>8+1
        BOT=BLOCK+LEN;  S2==NULL
        CYCLE  I=FRAG NO, -1, 0
           S==STORE(I)
           IF  S_BLOCK NO+S_LEN=BLOCK START 
              IF  S2==NULL START 
                 S_LEN=S_LEN+LEN;   ! ADD IT ON THE BOTTOM
                 S2==S;               ! REMEMBER IT
              ELSE 
                 S_LEN=S_LEN+S2_LEN
                 S2 = 0
                 EXIT 
              FINISH 
           ELSE 
              IF  S_BLOCK NO=BOT START 
                 IF  S2==NULL START ; ! NOT FOUND THE UPPER HALF
                    S_BLOCK NO=BLOCK;  S_LEN=S_LEN+LEN
                    S2==S;         ! MARK FOUND
                 ELSE 
                     S_BLOCK NO=S2_BLOCK NO
                     S_LEN=S_LEN+S2_LEN
                     S2_BLOCK NO=0;  S2_LEN=0
                    EXIT 
                 FINISH 
              FINISH 
           FINISH 
           IF  S_BLOCK NO=0 THEN  S3==S; ! REMEMBER EMPTY SLOT
        REPEAT 
        IF  S2==NULL START 
           S3_BLOCK NO=BLOCK;  S3_LEN=LEN
        FINISH 
        KSL==KS
        KSL_L==FREE SEGL
        FREE SEGL==KSL;               ! MAP SEG ENTRY BACK TO FREE LIST
     END 

     ROUTINE  FAULT(INTEGER  I)
        *K'016500'; *4; ! MOV 4(LNB),R0
        *0
     END 

ENDOFPROGRAM