!***********
!* SUP011  *
!*14 OCT 85*
!***********

%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=75
     %CONSTINTEGER FREE CELLS=80
     %CONSTINTEGER NO OF SERVICES=TASK LIMIT
     %CONSTINTEGER FRAG NO=15
     %CONSTINTEGER PSECT LENGTH=52
     %CONSTINTEGER SVC LIMIT=23
     %CONSTINTEGER INT LIMIT=-90
     %CONSTINTEGER K SEG LIMIT=125

     %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:8))
     %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
     %OWNINTEGER BUFF ONCE ONLY = 0;   ! ALLOCATE BUFFER AREA BUT ONLY ONCE

     %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)

      ! STORE FOR PARAMS IS NOW ABOVE THE PSECT AREA (FREE STORE)

     %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(80), 0, 0, 0, 0, 0, 0, MOTHER, DKID, TTID, TTID, 0,
         TTID, 0, DKID, DIRID, LOADID, 0, MOTHER, 0(68)

     %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 ALLOC BUFF=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 GPSPEC = 21
     %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'
      %CONSTRECORD (QF) %NAME PXP PT = K'56';  ! POINTS TO PX&PXP

     %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; PXP PT_E == PXP; 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
     %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+1 %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=8, -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 %OR FREE SEGL == 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) - NO FREE SEGMENT CELLS, NOW PASSED AS NO CORE
     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(ALLOC BUFF):                  ! ALLOCATE AN AREA FOR BUFFERS
      %IF BUFF ONCE ONLY = 0 %START; ! ONCE ONLY !
         ST2 == STORE(0);    ! PICKUP LARGEST FRAGMENT
         %IF ST2_LEN >= PSECT_URS_R0 %START; ! R0=SIZE REQUIRED
            ST2_LEN = ST2_LEN-PSECT_URS_R0
            BUFF ONCE ONLY = ST2_BLOCK NO
            ST2_BLOCK NO = ST2_BLOCK NO+PSECT_URS_R0; ! ALLOCATE AT 
                 ! BEGINNING OF BLOCK, NOT THE END OF IT
         %FINISH
      %FINISH
      PSECT_URS_R0 = BUFF ONCE ONLY
      -> GO

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
     PSECT_URS_R2=8
     !! 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
         I = SER MAP(PSECT_URS_R0)
         -> MV FAIL %UNLESS TASK LOW LIMIT <= I <= TASK LIMIT
        PSECT2==PSECTA(I)_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
     -> GO %IF SERVICE = GET ABS;     ! CANT SET REAL SEG 8 !

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
        -> GOT FREE %IF PSECTA(ID)_P==NULL
     %REPEAT

      PSECT_URS_R0 = 0;      ! PASS BACK FAILED
      -> GO

GOT FREE:
     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'777600';  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(GPSPEC):         ! PASS A CHAR TO APP TOWER PLOTTER
!      D1_X = SVCADDRESS-6;   ! PICKUP POINTER TO GPCHAR
!      D1_X = D3_X;         ! D1_X SHOULD NOW POINT TO GPCHAR ITSELF
!      D3_X = PSECT_URS_R0;  ! PUT CHARINTO LOCATION
      -> 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
         *K'010046';    ! MOV R0,-(SP)
         *K'004737'; *K'140';  ! JSR PC,@#140 - IE JUMP TO DUMP
     %END

%ENDOFPROGRAM