%EXTERNALINTEGERFNSPEC HANDKEYS
%EXTERNALROUTINESPEC WAIT(%INTEGER MSECS)
%EXTERNALROUTINESPEC SUP29
%ROUTINESPEC PRHEX(%INTEGER H)
%ROUTINESPEC PRINTER(%RECORDNAME P)
%EXTERNALROUTINESPEC DCU(%RECORDNAME P)
%EXTERNALROUTINESPEC PON(%RECORDNAME P)
%EXTERNALROUTINESPEC SLAVESONOFF(%INTEGER J)
%EXTERNALROUTINESPEC OPMESS(%STRING (23) MESS)
%RECORDFORMAT PARMF(%INTEGER DEST, SRCE, P1, P2, P3, P4, P5,  %C
         P6)
!* COMMUNICATIONS RECORD FORMAT - EXTANT FROM CHOPSUPE 18D ONWARDS *
!* COMMUNICATIONS RECORD FORMAT - EXTANT FROM CHOPSUPE 18D ONWARDS *
! Alterations from above-mentioned record format, for the S-series, are
! as follows:
!     GPCTABSIZE  ->   DCUTABSIZE
!     GPCA        ->   DCUA
!     SMACS       ->   SCUS
!     GPCCONFA    ->   DCUCONFA
%RECORDFORMAT COMF(%INTEGER OCPTYPE,IPLDEV,SBLKS,SEPGS,NDISCS,  %C
         DDTADDR,DCUTABSIZE,DCUA,SFCTABSIZE,SFCA,SFCK,DIRSITE,  %C
         DCODEDA,SUPLVN,KLOKCORRECT,DATE0,DATE1,DATE2,  %C
         TIME0,TIME1,TIME2,EPAGESIZE,USERS,PROCMON,DQADDR,  %C
         SACPORT,OCPPORT,ITINT,CONTYPEA,DCUCONFA,FPCCONFA,SFCCONFA, %C
         BLKADDR,DPTADDR,SCUS,TRANS,%LONGINTEGER KMON,  %C
         %INTEGER SPDRQ,SMACPOS,SUPVSN,PSTVA,SECSFRMN,SECSTOCD, %C
         SYNC1DEST,SYNC2DEST,ASYNCDEST,MAXPROCS,INSPERSEC,ELAPHEAD, %C
         COMMSRECA,STOREAAD,PROCAAD,SFCCTAD,DRUMTAD,SP0,SP1,SP2,SP3, %C
            SP4,SP5,SP6,SP7,SP8,SP9,  %C
         LSTL,LSTB,PSTL,PSTB,HKEYS,HOOT,SIM,CLKX,CLKY,CLKZ,  %C
         HBIT,SLAVEOFF,INHSSR,SDR1,SDR2,SDR3,  %C
         SDR4,SESR,HOFFBIT,S2,S3,S4,END)
%OWNRECORDNAME COM(COMF)
!------------------------------------------------------------------------
%RECORDFORMAT ENTFORM(%INTEGER SER, PTSM, PROPADDR,  %C
         TICKS SINCE, CAA, GRCB AD, LBA, ALA, STATE, RESP0,  %C
         RESP1, SENSE1, SENSE2, SENSE3, SENSE4, REPSNO, BASE,  %C
         ID, DLVN, MNEMONIC, PAW, USAW0, ENTSIZE, URCB AD,  %C
         SENSDAT AD, LOGMASK, TRTAB AD, UA SIZE, UA AD,  %C
         TIMEOUT, PROPS0, PROPS1)
!------------------------------------------------------------------------
%OWNINTEGERARRAYFORMAT BF(0:63)

! MASTER RESIDENT TRANSLATE TABLES FOR EMAS2900

%SYSTEMROUTINE MOVE(%INTEGER LENGTH, FROM, TO)
      *LB_LENGTH;  *JAT_14,<L99>
      *LDTB_X'18000000';  *LDB_%B;  *LDA_FROM
      *CYD_0;  *LDA_TO;  *MV_%L=%DR
L99:
%END;                                   ! OF MOVE
%SYSTEMROUTINE ITOE(%INTEGER AD, L)
%INTEGER J
      J=COM_TRANS
      *LB_L;  *JAT_14,<L99>
      *LDTB_X'18000000';  *LDB_%B;  *LDA_AD
      *LSS_J;  *LUH_X'18000100'
      *TTR_%L=%DR
L99:
%END;                                   ! ITOE
%SYSTEMROUTINE ETOI(%INTEGER AD, L)
%INTEGER J
      J=COM_TRANS+256
      *LB_L;  *JAT_14,<L99>
      *LDTB_X'18000000';  *LDB_%B;  *LDA_AD
      *LSS_J;  *LUH_X'18000100'
      *TTR_%L=%DR
L99:
%END;                                   ! ETOI
%OWNINTEGER TRANSTABAD=0
%SYSTEMROUTINE ETOE(%INTEGER AD, L)
%INTEGER J
      %RETURN %IF TRANSTABAD=0
      J=TRANSTABAD
      *LB_L
      *JAT_14,<L99>
      *LDTB_X'18000000'
      *LDB_%B
      *LDA_AD
      *LSS_J
      *LUH_X'18000100'
      *TTR_%L=%DR
L99:
%END
%EXTERNALROUTINE HOOT(%INTEGER NUM)
%INTEGER J, HOOTISA, HOOTBIT
      HOOTBIT=COM_HBIT
      HOOTISA=COM_HOOT
      %IF HOOTISA#0 %START;             ! P2 HAS NO HOOTER
         %CYCLE J=1,1,NUM
            *LB_HOOTISA
            *LSS_(0+%B)
            *OR_HOOTBIT
            *ST_(0+%B)
            WAIT(40)
            *LB_HOOTISA
            *LSS_(0+%B)
            *SLSS_-1
            *NEQ_HOOTBIT
            *AND_%TOS
            *ST_(0+%B)
            WAIT(40)
         %REPEAT
      %FINISH
      WAIT(300)
%END
%CONSTBYTEINTEGERARRAY H(0 : 15) =           %C
'0','1','2','3','4','5','6','7','8','9',
  'A','B','C','D','E','F'
%EXTERNALSTRING (8) %FN STRHEX(%INTEGER VALUE)
%STRING (8) S
      *LD_S;  *LSS_8;  *ST_(%DR)
      *INCA_1;  *STD_%TOS;  *STD_%TOS
      *LSS_0;  *LUH_VALUE
      *MPSR_X'24';                      ! SET CC=1
      *SUPK_%L=8
      *LD_%TOS;  *ANDS_%L=8,0,15;       ! THROW AWAY ZONE CODES
      *LSS_H+4;  *LUH_X'18000010'
      *LD_%TOS;  *TTR_%L=8
      %RESULT =S
%END
%EXTERNALSTRING (8) %FN HTOS(%INTEGER VALUE, PLACES)
%STRING (8) S
%INTEGER I
      I=64-4*PLACES
      *LD_S;  *LSS_PLACES;  *ST_(%DR)
      *INCA_1;  *STD_%TOS;  *STD_%TOS
      *LSS_VALUE;  *LUH_0;  *USH_I
      *MPSR_X'24';                      ! SET CC=1
      *SUPK_%L=8
      *LD_%TOS;  *ANDS_%L=8,0,15;       ! THROW AWAY ZONE CODES
      *LSS_H+4;  *LUH_X'18000010'
      *LD_%TOS;  *TTR_%L=8
      %RESULT =S
%END
!-----------------------------------------------------------------------
%EXTERNALSTRING (15) %FN STRINT(%INTEGER N)
%STRING (16) S
%INTEGER D0, D1, D2, D3
      *LSS_N;  *CDEC_0
      *LD_S;  *INCA_1;                  ! PAST LENGTH BYTE
      *CPB_%B;                          ! SET CC=0
      *SUPK_%L=15,0,32;                 ! UNPACK 15 DIGITS SPACE FILL
      *STD_D2;                          ! FINAL DR FOR LENGTH CALCS
      *JCC_8,<WASZERO>;                 ! N=0 CASE
      *LSD_%TOS;  *ST_D0;               ! SIGN DESCRIPTOR STKED BY SUPK
      *LD_S;  *INCA_1
      *MVL_%L=15,15,48;                 ! FORCE IN ISO ZONE CODES
      %IF N<0 %THEN BYTEINTEGER(D1)='-' %AND D1=D1-1
      BYTEINTEGER(D1)=D3-D1-1
      %RESULT =STRING(D1)
WASZERO:
      %RESULT ="0"
%END
%EXTERNALROUTINE PTREC(%RECORDNAME P)
%RECORDFORMAT PARMAF(%INTEGER DEST, SRCE, %INTEGERARRAY P(1:6))
%RECORDSPEC P(PARMAF)
%INTEGER I, J, SPTR, VAL
%STRING (120) S
      SPTR=1
      %CYCLE I=ADDR(P),4,ADDR(P)+28
         VAL=INTEGER(I)
         %CYCLE J=28,-4,0
            CHARNO(S,SPTR)=H((VAL>>J)&15)
            SPTR=SPTR+1
         %REPEAT
         CHARNO(S,SPTR)=' '
         SPTR=SPTR+1
      %REPEAT
      %CYCLE I=ADDR(P)+8,1,ADDR(P)+31
         J=BYTEINTEGER(I)
         %IF J<32 %OR J>95 %THEN J='_'
         CHARNO(S,SPTR)=J
         SPTR=SPTR+1
      %REPEAT
      CHARNO(S,SPTR)=NL
      LENGTH(S)=SPTR
      PRINTSTRING(S)
%END
!!
!! THIS FUNCTION TAKES A VIRTUAL ADDRESS AND VIA SEGMENT AND PAGE TABLES
!! RETURNS THE CORRESPONDING REAL ADDRESS.
!! NOTE: NO FACILITY FOR SHARED SEGMENTS CURRENTLY REQD.
!!
%EXTERNALINTEGERFN REALISE(%INTEGER AD)
%CONSTINTEGER RA128=X'0FFFFF80';        ! 128 BYTE ALIGNED MASK FOR NON-PAGED SEGMENT ENTRY
%CONSTINTEGER RA8=X'0FFFFFF8';          ! 8 BYTE ALIGNED MASK FOR PAGED SEGMENT ENTRY
%CONSTINTEGER RA1024=X'0FFFFC00';       ! PAGE ALIGNED MASK FOR PAGE TABLE ENTRY
%CONSTINTEGER PST VA=X'80040000';       ! SEGMENT TABLE BASE ADDRESS
%CONSTINTEGER PUBLIC=X'80000000';       ! THESE TWO MAKE UP REAL CORE BASE ADDRESS,
%CONSTINTEGER SEG64=X'01000000';        ! WHICH IS AT PSEG 64
%CONSTINTEGER PAGEDBIT=X'40000000'
%INTEGER VASE;                          ! VIRTUAL ADDRESS OF SEGMENT TABLE ENTRY
%INTEGER VAPE;                          ! VIRTUAL ADDRESS OF PAGE TABLE ENTRY
!!
      VASE=PST VA+(AD>>15)&X'FFF8'
!!
      %IF INTEGER(VASE)&PAGEDBIT#0 %START;   ! PAGED SEGMENT
!!
         VAPE=((INTEGER(VASE+4)&RA8)+SEG64+(AD<<14>>24)<<2)! %C
            PUBLIC
!** IF WE HAVE TRUTHFUL SEGMENT TABLES
!** (CURRENTLY WE DO NOT - SEE CHOPSUPE ROUTINE 'CONFIG')
!**  THEN LEST STORE BE DISCONTIGUOUS :-
!     VAPE=VAPE-(INTEGER(PST VA+((VAPE>>15)&X'FFF8')+4)&X'20000')
         %RESULT =INTEGER(VAPE)&RA1024+(AD&X'3FF')
!!
      %FINISH
!!
!  UN-PAGED SEGMENT
!!
      %RESULT =(AD&X'3FFFF')+(INTEGER(VASE+4))&RA128
!!
%END
%INTEGERFN I2(%INTEGER AD)
!AD POINTS TO THE FIRST OF A PAIR OF DECIMAL CHARACTERS. THE RESULT
!IS THE NUMERIC VALUE OF THE CHAS
      %RESULT =10*(BYTEINTEGER(AD)&X'F')+(BYTEINTEGER(AD+1)& %C
         X'F')
%END;                                   !OF I2
!*
!*
%EXTERNALINTEGERFN PACK DATE(%STRING (8) DATE)
%INTEGER AD
      AD=ADDR(DATE)
      %RESULT =((I2(AD+7)-70)<<26)!(I2(AD+4)<<22)!(I2(AD+1)<<17)
%END;                                   !OF PACK DATE
!*
!*
%EXTERNALINTEGERFN PACK DATE AND TIME(%STRING (8) DATE, TIME)
%INTEGER AT
      AT=ADDR(TIME)
      %RESULT =PACK DATE(DATE)!(I2(AT+1)<<12)!(I2(AT+4)<<6)!( %C
         I2(AT+7))
%END;                                   !OF PACK DATE AND TIME
!!
%CONSTSTRING(8) %NAME DATE= X'80C0003F'
%CONSTSTRING(8) %NAME TIME = X'80C0004B'
!!
%EXTERNALROUTINE DUMPTABLE(%INTEGER TABLE, ADD, LENGTH)
%OWNINTEGER NEXT
%INTEGER I, K, END, SPTR, VAL
%STRING (132) S
      NEXT=NEXT+1;  ADD=ADD&(-4)
! SOME SORT OF VALIDATION IS REQUIRED HERE
      PRINTSTRING("
DT: ".DATE." ".TIME."
****    SUPERVISOR  DUMP    TABLE: " %C
         .STRINT(TABLE)."    ADDR ")
      PRINTSTRING(STRHEX(ADD).'    LENGTH: '.STRINT(LENGTH))
      PRINTSTRING('    DUMP NO: '.STRINT(NEXT).'****')
      NEWLINE
      END=ADD+LENGTH;  I=1
      S=" "
      %UNTIL ADD>=END %CYCLE
         *LDTB_X'18000020';  *LDA_ADD
         *VAL_(%LNB+1);  *JCC_3,<INVL>
         %IF I=0 %THEN %START
            %CYCLE K=ADD,4,ADD+28
               ->ON %IF INTEGER(K)#INTEGER(K-32)
            %REPEAT
            S="O";  ->UP
         %FINISH
ON:
         CHARNO(S,2)='(';  SPTR=3
         %CYCLE I=28,-4,0
            CHARNO(S,SPTR)=H((ADD>>I)&15)
            SPTR=SPTR+1
         %REPEAT
         CHARNO(S,SPTR)=')'
         CHARNO(S,SPTR+1)=' '
         SPTR=SPTR+2
         %CYCLE K=ADD,4,ADD+28
            VAL=INTEGER(K)
            %CYCLE I=28,-4,0
               CHARNO(S,SPTR)=H((VAL>>I)&15)
               SPTR=SPTR+1
            %REPEAT
            CHARNO(S,SPTR)=' '
            SPTR=SPTR+1
         %REPEAT
         CHARNO(S,SPTR)=' '
         SPTR=SPTR+1
         %CYCLE K=ADD,1,ADD+31
            I=BYTEINTEGER(K)&X'7F'
            %UNLESS 32<=I<=127 %THEN I=' '
            CHARNO(S,SPTR)=I
            SPTR=SPTR+1
         %REPEAT
         CHARNO(S,SPTR)=' '
         SPTR=SPTR+1
         CHARNO(S,SPTR)=NL
         BYTEINTEGER(ADDR(S))=SPTR
         PRINTSTRING(S)
         S=" "
UP:      ADD=ADD+32
         I=0
      %REPEAT
      %RETURN
INVL:
      PRINTSTRING("ADDRESS VALIDATION FAILS
")
%END;                                   !ROUTINE DUMP
!  OWN VARIABLES FOR JOINT USE BY 'IOCP' AND 'PRINTER'
%CONSTINTEGER MASK=X'80FC3FFF'
%OWNINTEGER INPTR, OUTPTR=X'80FC0000'
%OWNINTEGER PAVAIL=0
%OWNINTEGER BUSY, DINTPEND=0, INTPEND, TESTPEND=0, INIT=0
! %OWNINTEGER DUMPMODE=0
%SYSTEMROUTINE IOCP(%INTEGER EP, N)
!***********************************************************************
!*       THIS ROUTINE RECEIVES ALL THE OUTPUT FROM MAIN VIA IMP STMTS  *
!*       SUCH AS PRINTSTRING, AND SENDS IT TO THE MAIN PRINT FILE.     *
!*       A CYCLIC BUFFER IS MAINTAINED IN PAGE 2 AND ONE OTHER BUFFER  *
!*       IS USED IN SEGMENT PUBLIC 63.    IF OUTPUT ARRIVES FASTER     *
!*       THAN THE PRINTER CAN COPE IT IS DISCARDED.                    *
!*       A SIMILAR ROUTINE IN SLOWFILE IS USED WITH A VIRTUAL PRINTER  *
!***********************************************************************
%RECORD Q(PARMF)
%CONSTINTEGER SUP STACK=X'80100000', CHOP STACK=X'80B80000'
%INTEGER I, J, ADR, L, OLDINPTR, SYM, NLSEEN
%STRING (63) S
      ->END %UNLESS X'280A8'&1<<EP\=0;  !CHECK FOR VALID ENTRY
      OLDINPTR=INPTR;  NLSEEN=0
      %IF EP=17 %THEN %START;           ! REPEATED SYMBOLS
         L=N>>8&63;  J=L
         %WHILE J>0 %CYCLE
            CHARNO(S,J)=N&127;  J=J-1
         %REPEAT
         ADR=ADDR(S)+1
      %FINISH %ELSE %START
         %IF EP>=7 %THEN %START;        ! PRINT STRING
            L=BYTE INTEGER(N);  ADR=N+1
         %FINISH %ELSE %START;          ! PRINT SYMBOL & PRINT CH
            L=1;  ADR=ADDR(N)+3
         %FINISH
      %FINISH
!         %CYCLE I=1,1,L
                                        !  MESSAGE INTO CYCLIC BUFFER
!            BYTE INTEGER(CYCB)=BYTE INTEGER(ADR)
!            CYCB=CYCB+1
!            ADR=ADR+1
!            %IF CYCB&X'FFF'=0 %THEN CYCB=CYCA+16
!         %REPEAT
!         INTEGER(CYCA)=CYCB
                                        ! STORE POINTER FOR DUMPS
!         ADR=ADR-1
! NOW PUT MESSAGE INTO BUFFER IF THERE IS ROOM
      I=1
      %WHILE I<=L %CYCLE
         ->END %IF BUSY=1;              ! BUFFERS BUSY DISCARD OUTPUT
         J=(INPTR+1)&MASK
         %IF J#OUTPTR %THEN %START;     ! ROOM FOR CURRENT CHAR
            SYM=BYTE INTEGER(ADR)
            BYTE INTEGER(J)=SYM
            %IF SYM=133 %THEN SYM=NL
            %IF SYM<32 %AND SYM#NL %THEN SYM='?'
            %IF SYM=NL %THEN NLSEEN=1
            ADR=ADR+1;  INPTR=J;  I=I+1
         %FINISH %ELSE BUSY=1 %AND %RETURN
      %REPEAT
      %RETURN %IF PAVAIL=0
! A HORRIBLE FRIG IS HERE TO ALLOW DJR TO PRINT FROM THE LOCAL CONTROLLER
!  SINCE THE LOCAL CONTROLLER HAS A SMALL STACK MUST NOT CALL PRINTER
! OR STACK OVERFLOW IS LIKELY TO BE CAUSED BY GPC
      *STSF_I;  I=I>>18<<18
      %RETURN %UNLESS I=SUP STACK %OR I=CHOP STACK
! %ORC DUMPMODE#0
! END OF HORRIBLE FRIG TO BE DELETED AS SOON AS POSSIBLE
      %IF (OLDINPTR=OUTPTR %AND INIT#0) %AND NLSEEN#0 %C
         %THEN Q=0 %AND PRINTER(Q)
END:
%END;                                   ! OF ROUTINE IOCP
%EXTERNALROUTINE PRINTER(%RECORDNAME P)
!***********************************************************************
!*       VERSION FOR A REAL PRINTER.                                   *
!***********************************************************************
%ROUTINESPEC DISCWRITE
%ROUTINESPEC SHUFFLE
%ROUTINESPEC ALLOCATE
%ROUTINESPEC DEALLOCATE
%INTEGER I, J
%OWNBYTEINTEGERARRAY BUFFER(0:133)=0(2),X'FC',X'10',0(130)
                                        !  BUFFER HAS LP INIT DATA IN 1-4
%RECORDFORMAT TCBF(%INTEGER COMMAND,STE,LEN,DATAD,NTCB,RESP, %C
                        %INTEGERARRAY PREAMBLE,POSTAMBLE(0:3))
%OWNRECORDNAME TCB(TCBF)
%RECORDFORMAT ENTFORM(%INTEGER   %C
   SER, SPSSM, PROPADDR, SECS SINCE, CAA, SPARE0, TCBA, SPARE1,  %C
   STATE, RESP0, RESP1, SENSE1, SENSE2, SENSE3, SENSE4,  %C
   REPSNO, BASE, ID, DLVN, MNEMONIC,  %C
   ENTSIZE, SPARE2, SPARE3, UTCB AD, SENSDAT AD, LOGMASK, TRTAB AD,  %C
   UA SIZE, UA AD, TIMEOUT,PROPS0,PROPS1)
%OWNRECORDNAME D(ENTFORM)
%CONSTINTEGER TCBM=X'2C004000'
%OWNINTEGER LASTDEST,TCBA
%OWNINTEGER MNEM=M'LP0'
%OWNINTEGER LFS
%OWNINTEGER DPAGE=-2    ;               ! DISC ADDRESS COMPS. <0  NO FILE AVAILABLE
%OWNINTEGER FAILDEST;                   ! ACTIVATE DISC(7) GIVES DEST FOR FAILURES
%OWNINTEGER LSECT, SECTSIZE, PAGESSENT
%OWNINTEGER HDR1=0, HDR2=32, HDR3=0
%OWNINTEGER  HDR4=3,HDR5=0,HDR6=0,HDR7=-256,HDR8=0
%CONSTINTEGER SPOOLING=1, PRINTING=0, PST VA=X'80040000'
%OWNINTEGER MODE=-1   ;                 ! NEITHER PRINTING NOR SPOOLING
%OWNINTEGER DEALLPR=0;                  ! FLAG TO SAY PRINTER DEALL. PENDING
%RECORD Q(PARMF)
%SWITCH DACT(0:8)
%RECORDSPEC P(PARMF)
!!
!!
!!
      %IF INIT=0 %THEN %START;          ! FIRST TIME IN - INITIALISE
         ALLOCATE
!
!      %IF ALLOCATE FAILS SET INIT NON ZERO TO AVOID RETRY
!
         %IF INIT=0 %THEN INIT=-1 %AND %RETURN
         TCBA=D_UA AD
         TCB==RECORD(TCBA)
         TCB_COMMAND=TCBM!X'81';        ! INITIALISE
         I=PST VA+ADDR(BUFFER(0))<<1>>19<<3;! VA OF ST ENTRY
         TCB_STE=INTEGER(I+4)!(INTEGER(I)>>29&2)
         TCB_LEN=4
         TCB_LEN=4
         TCB_DATAD=ADDR(BUFFER(0))
         MODE=PRINTING
         LASTDEST=P_DEST
         INTPEND=2
         ->PRINTI
      %FINISH
      I=P_DEST&255
      %UNLESS 0<=I<=8 %THEN I=0;        ! DONT REPORT FOR FEAR OF STARTING LOOP
      %IF (2<=I<=3 %OR I=5) %AND MODE=SPOOLING %START
!!            MAY BE WAITING FOR LP TERM TO DE-ALLOCATE PRINTER
!!            TO AVOID SPURIOUS TERM GOING TO NEXT OWNER.
         %IF DEALLPR=1 %AND PAVAIL=1 %THEN DEALLOCATE
!! IF DEALLOCATE FAILS HEREAFTER ATTNS ETC FROM PRINTER ARE
                                        !IGNORED WHILE IN SPOOLING MODE ANYWAY.
         ->DACT(0)
      %FINISH
      ->DACT(I)
!!
NEXTLINE:

      BUFFER(0)=0
!!
DACT(0):                                ! ALARM CLOCK TICK OR EQUIVALENT
      %IF INPTR=OUTPTR %THEN ->UNBUSY
      %IF DINTPEND#0 %THEN %RETURN;     ! WAIT IN EITHER MODE
      %IF MODE=SPOOLING %START
         %UNLESS OUTPTR<INPTR<(OUTPTR+4096) %THEN DISCWRITE
         %RETURN
      %FINISH
      %IF MODE=PRINTING %START
         %IF INTPEND#0 %OR TESTPEND#0 %OR PAVAIL=0 %THEN ->END
         I=BUFFER(0)
         %CYCLE
            J=BYTE INTEGER(OUTPTR)
            BYTE INTEGER(OUTPTR)=0
            %IF J=10 %THEN J=133
            %IF J=133 %OR J=12 %OR I=132 %START
               %IF I=132 %THEN BYTEINTEGER(OUTPTR)=J %C
                  %AND J=133 %ELSE OUTPTR=(OUTPTR+1)&MASK
               I=I+1;  BUFFER(I)=J
               BUFFER(0)=I
               TCB_LEN=I
               ITOE(ADDR(BUFFER(1)),I)
               ETOE(ADDR(BUFFER(1)),I)
               ->PRINT
            %FINISH
            OUTPTR=(OUTPTR+1)&MASK
            %IF J#13 %THEN I=I+1 %AND BUFFER(I)=J
            %IF INPTR=OUTPTR %THEN BUFFER(0)=I %AND ->UNBUSY
                                        ! INCOMPLETE LINE
         %REPEAT
PRINT:                                  ! PRINT LINE IN ARRAY BUFFER(AGAIN)
         INTPEND=1
PRINTI:
         P_DEST=10
         TCB_RESP=0
         P_P1=ADDR(TCB)
         P_P2=INIT
         P_P3=X'11';                    ! PAW & SAW(DO STREAM REQ & CLEAR ABN.)
         P_P4=0
         P_SRCE=X'80000000'
         DCU(P)
         %IF P_P1#0 %THEN OPMESS('MAIN LP FAILS '.TOSTRING(P_ %C
            P1+48))
      %FINISH
      ->END
!!
DACT(1):                                ! CHANGE MODE FOR TESTING
      ->END
!!
DACT(2):                                ! PRINTER INTERUPT NORMAL TERMN
      %IF INTPEND=0 %THEN OPMESS('MAIN LP INT???') %AND %RETURN
      %IF INTPEND=2 %START
         INTPEND=0
         TCB_COMMAND=TCBM!X'83'
         TCB_DATAD=ADDR(BUFFER(1))
         ->DACT(LASTDEST&15)
      %FINISH
      INTPEND=0
      ->NEXT LINE
!!
DACT(5):                               ! ABNORMAL TERMINATION - LP ONLY
      %IF INTPEND=2 %START
         INTPEND=0
         TCB_COMMAND=TCBM!X'83'
         TCB_DATAD=ADDR(BUFFER(1))
         ->DACT(LASTDEST&15)
      %FINISH
      INTPEND=0
      %IF P_P2 = 0 %AND TCB_POSTAMBLE(0)>>24=X'20' %START
                                         ! ILLEGAL CHAR ONLY
         TCB_LEN=1
         BUFFER(1) = X'15'
                                        ! NEWLINE IN EBCDIC
         -> PRINT
                                        ! BLANK LINE FOR FAULTY LINE
      %FINISH
      PRINTSTRING("PRINTER ABTERMN: ")
      PTREC(P)
      D==RECORD(P_P3)
      DUMPTABLE(54,ADDR(TCB),4*18)
      NEWLINE
      OPMESS('ATTEND MAIN LP')
      TESTPEND=1;  ->END
!!
DACT(3):                                ! ATTENTION
      %IF (TESTPEND#0 %AND P_P1&X'8000'#0) %C
         %THEN TESTPEND=0 %AND ->PRINT
      ->END
!!
DACT(8):                                ! RESET PRINTER - HOPEFULLY
DACT(6):                                ! RESET PRINTER - FORCEFULLY
      DEALLPR=0;                        ! CANCEL ANY DEALLOCATION REQUEST
      %IF PAVAIL=0 %START;              ! IF WE DONT HAVE THE PRINTER - GET  IT
         DEALLOCATE %UNLESS I=8;        ! FROM WHOEVER HAS IT
         ALLOCATE
      %FINISH
      %IF I=8 %START
         P_DEST=P_SRCE
         P_SRCE=X'360008'
         %IF PAVAIL=1 %THEN P_P1=0 %ELSE P_P1=101
         PON(P) %UNLESS P_DEST<0
      %FINISH
      %RETURN %IF PAVAIL=0
                                        ! GET RID OF FILE HEADER ON FIRST BLOCK IF STILL AROUND
      %IF MODE=SPOOLING %AND PAGESSENT=0 %C
         %THEN OUTPTR=(OUTPTR+32)&MASK
      MODE=PRINTING
      DPAGE=-2;                         ! FORGET CURRENT FILE -2 IN CASE OK TERM PENDS.
      INTPEND=0;                        ! DANGEROUS - MAY GET SLOT BUSY IF CALL REPEATED
      ->NEXTLINE
!!
DACT(7):                                ! CHANGE TO DISC
!!                                       OR NEW SPOOL FILE
      PAGESSENT=0
      FAILDEST=P_SRCE
      LSECT=P_P1;                       ! NO OF BLOCKS IN SECTION (1 EPAGE = 1 BLOCK)
      SECTSIZE=P_P1<<12;                ! FILESIZE IN BYTES
      HDR1=SECTSIZE;                    ! FILE HEADER FIELDS , ACTUAL AND MAX SIZE
      HDR3=SECTSIZE
      LFS=P_P2>>24;                     ! DISC - LOCAL FILE SYSTEM
      J=DPAGE
      DPAGE=P_P2&X'FFFFFF';             ! PAGE NUMBER ON DISC
      SHUFFLE;                          ! ALIGN DATA TO EPAGE BOUNDARY
      HDR6=PACK DATE AND TIME(DATE,TIME)
      MOVE(32,ADDR(HDR1),OUTPTR);       ! COPY IN HEADER BLOCK
      %IF J>=0 %START;                  !DPAGE=J

!
! FLUSH BUFFER TO NEW SPOOL FILE < K HAS ALREADY RELEASED OLD FILE>
! OUTPTR IS ALWAYS EPAGE ALIGNED WHILE SPOOLING
!PRETEND SECOND SPOOL FILE WILL BE FILLED BY REMAINING BUFFER
! CONTENTS TO GET AUTOMATIC PRINT.
! IF BUFFER IS FULL THEN 4 EPAGES TO GO.

!
         %IF (INPTR+1)&MASK=OUTPTR %THEN PAGESSENT=LSECT-4 %C
            %ELSE %START
            BYTEINTEGER((INPTR+1)&MASK)=4;   ! EOM CHARACTER
            INPTR=(INPTR+4095)&X'80FC3000';  ! ALIGN BY EPAGE
                                        ! FIND OUT HOW MANY EPAGES TO PRINT
            I=INPTR-OUTPTR
            %IF I<0 %THEN I=X'4000'+I
            PAGESSENT=LSECT-(I>>12)
         %FINISH
      %FINISH
      %IF PAVAIL=1 %START;              ! GET RID OF PRINTER - MAY BE DELAYED ACTION
         %IF INTPEND=0 %THEN DEALLOCATE %ELSE DEALLPR=1
      %FINISH
      MODE=SPOOLING
      ->NEXTLINE
!!
DACT(4):                                ! DISC TERMINATION
      %IF DINTPEND=0 %THEN OPMESS('DISC INT ???') %AND %RETURN
      DINTPEND=0
      %IF P_P2=0 %START;                ! TERM. SUCCESSFUL
         %CYCLE I=0,4,4092;             ! ZERO BLOCK
            INTEGER(OUTPTR+I)=0
         %REPEAT
         DPAGE=DPAGE+1;                 ! NEXT DISC PAGE
         OUTPTR=(OUTPTR+4095)&MASK
         %IF OUTPTR=INPTR %START
                                        ! INPTR=FFF IS TRICKY - HENCE
                                        ! INSERTING SPACE IS BEST WAY.  
            INPTR=(INPTR+1)&MASK
         %FINISH
         OUTPTR=(OUTPTR+1)&MASK
      %FINISH %ELSE %START;             ! FAILED - REPORT AND EXPECT NEW FILE
         OPMESS(' LOG FILE ABTERM '.HTOS(P_P2,2))
         Q=P
         Q_DEST=FAILDEST
         Q_SRCE=X'360007'
         PON(Q) %UNLESS DPAGE<0;        ! CHK NOT ALREADY SENT (BECAUSE FULL)
         DPAGE=-2;                      ! MARK FILE UN-USEABLE
         %IF PAGESSENT=1 %THEN OUTPTR=(OUTPTR+32)
                                        ! GET RID OF HEADER
      %FINISH
      ->NEXTLINE %IF MODE#SPOOLING;    ! INCASE MODE =PRINTING
!!
UNBUSY:                                 ! RESTART IF BUFFER OFLOW OCCURRED
      %IF BUSY=1 %START
         BUSY=0;  PRINTSTRING('
*** OUTPUT LOST ***
')
      %FINISH
      ->END
%ROUTINE DISCWRITE
%INTEGER I
      %RETURN %IF DPAGE<0;              ! NO FILE AVAILABLE
      OPMESS('DISC ADDR =0 ') %AND I=1//0 %IF DPAGE=0
      Q=0
      Q_DEST=X'210002'
      Q_SRCE=X'360004'
      Q_P1=(OUTPTR>>12)&3;              ! BLOCK 0-3
      Q_P2=(LFS<<24)!DPAGE
      Q_P3=OUTPTR
      PON(Q)
      DINTPEND=1
      PAGESSENT=PAGESSENT+1
      %IF PAGESSENT=LSECT %START;       ! HAVE FILLED CURRENT FILE
         DPAGE=-2
         Q=0
         Q_DEST=FAILDEST
         Q_SRCE=X'360007'
         PON(Q);                        ! ASK FOR A NEW FILE
      %FINISH
%END
!!
%ROUTINE SHUFFLE
!*
!* THIS ROUTINE ALIGNS THE OUTPUT BUFFER FROM BYTE
!* TO EPAGE BOUNDARY. THIS IS NECESSARY FOR    
!*  DISC WRITING.     
!!
%BYTEINTEGERARRAY A(0:4095);            ! ALL THAT'S AVAILABLE ON RESIDENT STACK
%INTEGER L, OLDPTR, NEWPTR, I
%CONSTINTEGER BLENMASK=X'FFF';          ! GIVES BLOCK LENGTH
%CONSTINTEGER BSTARTMASK=X'80FCF000';   ! GIVES BLOCK START
!!
!      %UNLESS OUTPTR = INPTR %START
                                        ! UNLESS BUFFER EMPTY
!!
! GET 32 BYTES FOR  FILE HEADER
!! GENERATE OUTPUT LOST IF NOT GOT 32 BYTES SPACE IN BUFFER
!!
      %CYCLE I=1,1,32
         OUTPTR=(((OUTPTR-1)+X'4000')&MASK)
         %IF OUTPTR=INPTR %THEN BUSY=1 %C
            %AND INPTR=(((INPTR-1)+X'4000')&MASK)
      %REPEAT
!       %FINISH
!!
      %RETURN %IF OUTPTR&X'FFF'=0;      ! GET OUT IF ALIGNED ALREADY
      L=OUTPTR&BLENMASK;                ! LENGTH  FROM BLOCK START  TO OUTPTR
      MOVE(L,OUTPTR&BSTARTMASK,ADDR(A(0)));  ! SAVE FIRST FRAGMENT
      OLDPTR=OUTPTR
      NEWPTR=OUTPTR&BSTARTMASK
      %CYCLE I=1,1,4
         MOVE(4096-L,OLDPTR,NEWPTR)
         NEWPTR=NEWPTR+(4096-L)
         OLDPTR=(((OLDPTR+4096)&MASK)&BSTARTMASK)
         %EXIT %IF I=4
         MOVE(L,OLDPTR,NEWPTR)
         NEWPTR=OLDPTR
         OLDPTR=OLDPTR+L
      %REPEAT
      MOVE(L,ADDR(A(0)),NEWPTR);        ! PUT BACK FRAGMENT
      OUTPTR=OUTPTR-L;                  ! IE. OUTPTR&X'000'
      INPTR=((INPTR-L)+X'4000')&MASK
%END
!!
%ROUTINE DEALLOCATE
!*
!* ROUTINE TO DEALLOCATE LINE PRINTER, FOR USE BY OTHERS,
!* SINCE LOG OUTPUT NOW TO DISC FILE.
!* MAY WAIT ON LP TERM BEFORE ENTERING HERE.
!*
      DEALLPR=0
      Q=0;  Q_DEST=5
      Q_SRCE=X'80360002'
      Q_P1=MNEM
      DCU(Q)
      %IF Q_P1#0 %THEN %START
                                        ! NOT SURPRISED IF DEALLOC FAILS UNLESS PRINTER IS
                                        ! SUPPOSED TO HAVE THE LP.
         %IF PAVAIL=1 %THEN OPMESS('MAIN LP DEALLOC FAILS '. %C
            TOSTRING(Q_P1+48))
      %FINISH %ELSE PAVAIL=0
      TESTPEND=0
%END
%ROUTINE ALLOCATE
      Q=0;  Q_DEST=4;                   ! REQUEST PRINTER ALLOCATION
      Q_P1=M'LP';  Q_SRCE=X'80360002'
      DCU(Q)
      %IF Q_P1#0 %THEN OPMESS(' NO MAIN LP FLAG='.STRINT(Q_P1)) %C
         %AND PAVAIL=0 %AND %RETURN
      D==RECORD(Q_P3)
      TRANSTABAD=D_TRTABAD
      INIT=Q_P2;                        ! SNO
      MNEM=Q_P6;                        ! ACTUAL DEVICE RETURNED BY KY
      PAVAIL=1
%END
END:
%END;                                   ! OF ROUTINE PRINTER
!!
!!
%EXTERNALROUTINE GET PSTB(%INTEGERNAME PSTB0, PSTB1)
!***********************************************************************
!*    MACHINE-INDEPENDENT VERSION                                      *
!*    PUBLIC SEGMENT 1 IS MAPPED TO THE PST ITSELF                     *
!*    E_LIM GIVES THE SIZE OF THE PST (BYTES)                          *
!*    FOR DOUBLE WORDS, >>3, AND THIS IS THE TOP PUBLIC SEG WHICH IS   *
!*    POTENTIALLY AVAILABLE. TO GET THE VA LIMIT THEREFORE WE <<18.    *
!*    WE ADD THE TOP BIT AND ALSO THE BOTTOM 7 BITS >>3 AND <<18, WHICH*
!*    IS THE '3C'.                                                     *
!***********************************************************************
%CONSTINTEGER PST VA=X'80040000';       ! VA OF PUBLIC SEG TABLE
%RECORDFORMAT EF(%INTEGER LIM, RA)
%RECORDNAME E(EF)
      E==RECORD(PST VA+8);              ! ONTO THE PST ENTRY FOR SEG 1
      PSTB0=((E_LIM&X'0003FF80')<<15)!X'803C0000'
      PSTB1=E_RA&X'0FFFFFC0'
%END;                                   ! GET PSTB
%SYSTEMROUTINE STOP
%INTEGER I, W0, W1, W2, W3, W4, W5
%CONSTINTEGER RESTACK=X'80180000'
%CONSTINTEGER SEG10=X'80280000';        ! FOR COMMCN WITH DUMP RT
      I=COM_LSTL
      *LB_I;  *LSS_(0+%B);  *ST_W2
      I=COM_LSTB
      *LB_I;  *LSS_(0+%B);  *ST_W3
      *STSF_I
      W1=I>>18<<18
      W0=-1;                            ! DUMMY SYSERR PARAM
      *LXN_SEG10;  *LSQ_W0;  *ST_(%XNB+0)

! NOW IF SUPERVISOR STOP SEG 10 IS SET UP AS IF WE HAVE HAD A DUMMY 
! SYSTEM ERROR. A TAPE DUMP WILL THEN LOOK OK TO THE DUMP ANALYSER

      HOOT(15)
      %IF HANDKEYS&X'FFFF'#0 %START
         W4=0;  W5=RESTACK
         *ACT_W2;                       ! DUMP TO TAPE VIA RESTART
      %FINISH
      *IDLE_X'3333'
%END;                                   ! STOP
%EXTERNALROUTINE RESTART(%INTEGER C, B)
%INTEGERFNSPEC PINT
%ROUTINESPEC DOWAIT(%INTEGER MASK)
%CONSTINTEGER PST VA=X'80040000';       ! VA OF PUBLIC SEG TABLE
%RECORDFORMAT  SEG10F(%INTEGER SYSERRP,STACK,LSTL,LSTB,PSTL,PSTB, %C
      HKEYS,INPTR,OUTPTR,BUFFLASTBYTE,S1,S2,S3,S4,SBLKS, %C
      %INTEGERARRAY BLOCKAD(0:63),%INTEGER PASL,KQ,RQ1,RQ2, %C
      %LONGINTEGER SA,PARM,PARML)
%RECORDNAME SEG10(SEG10F)
%RECORDFORMAT SEGENTF(%INTEGER LIM, RA)
%RECORDARRAYFORMAT SEGARRF(0:127)(SEGENTF)
%RECORDARRAYNAME PST(SEGENTF)
%OWNINTEGERARRAYFORMAT BF(0:63)
%INTEGERARRAYNAME BLOCKAD
%OWNINTEGERARRAY TCBA(0:14)
%OWNINTEGERARRAYFORMAT TCBF(0:13)
%OWNINTEGERARRAYNAME TCB
%CONSTINTEGER TCBM=X'2C404000'
%OWNINTEGER INIT=X'0000FC03';           !1600 BPI/PE
%OWNINTEGERARRAY ACTIVATE(0:1)=X'10001400',0
%LONGINTEGER A, TEMP
%INTEGER I, J
%INTEGER PSM, AWORDA, PCWORDA, TOPBYTE
%RECORDFORMAT SERVAF(%INTEGER P,C)
%EXTRINSICRECORDARRAY SERVA(0:576)(SERVAF)
%EXTRINSICLONGINTEGER PARMDES
%EXTRINSICINTEGER PARMASL,KERNELQ,RUNQ1,RUNQ2
      TCB==ARRAY(ADDR(TCBA(1))&X'FFFFFFF8',TCBF); !DOUBLE-WORD ALIGN
      SLAVESONOFF(0)
      PST==ARRAY(PST VA,SEGARRF)

! SEG 10 (WHICH MUST BE IN SMAC0-BLOCK0) IS USED AT FAILURE TO PASS
! INFO TO THE DUMP PROGRAM. FIRST 4 WORDS ARE SET UP BY SYSTEM
! ERROR ROUTINE (WHERE APPROPIATE)

      SEG10==RECORD(X'80280000')
      %CYCLE I=0,4,8
         J=INTEGER(ADDR(COM_PSTL)+I)
         *LB_J;  *LSS_(0+%B);  *ST_J
         INTEGER(X'81000000'+I)=J
         INTEGER(X'80280010'+I)=J
      %REPEAT
      SEG10_INPTR=INPTR;                ! FOR THE PRINTER BUFFER
      SEG10_OUTPTR=OUTPTR
      SEG10_BUFFLASTBYTE=MASK
      SEG10_SBLKS=COM_SBLKS
      BLOCKAD==ARRAY(COM_BLKADDR,BF)
      %CYCLE I=0,1,SEG10_SBLKS-1
         SEG10_BLOCKAD(I)=BLOCKAD(I)
      %REPEAT
      SEG10_PASL=PARMASL
      SEG10_KQ=KERNELQ
      SEG10_RQ1=RUNQ1
      SEG10_RQ2=RUNQ2
      *LSD_SERVA; *ST_TEMP
      SEG10_SA=TEMP
      SEG10_PARM=PARMDES
      SEG10_PARML=0
                                        !DUMP STORE TO TAPE
      PSM=HANDKEYS %UNTIL PSM#0;        !GET PORT,STREAM,MECH
      TOPBYTE=PSM>>24
      PSM=PSM&X'FFFFFF'
      AWORDA=X'60000000'!PSM>>16<<22;   !ACTIVATE WORD ADDRESS
      %IF TOPBYTE#0 %START
         A=X'0000000080000000'
         *LSD_A; *LB_AWORDA; *ST_(0+%B)
         %CYCLE I=1,1,5000; %REPEAT
      %FINISH
      PCWORDA=X'60000010'!COM_OCP PORT<<22;  !PROCESSOR COUPLER ADDRESS 
      ACTIVATE(1)=REALISE(ADDR(TCB(0))&X'FFFC0000')!X'80000001'
      J=0
      I=PINT %AND J=J+1 %UNTIL I=0 %OR J=100
      A=LONGINTEGER(ADDR(ACTIVATE(0)))
      *LSD_A;                           !SET EMERGENCY CCA (@ X'1400')
      *LB_AWORDA
      *ADB_X'20'
      *ST_(0+%B)
      ACTIVATE(0)=ADDR(TCB(0))
      ACTIVATE(1)=3<<24!PSM>>8&X'FF';   !CONNECT STREAM
      A=LONGINTEGER(ADDR(ACTIVATE(0)))
      *LSD_A
      *LB_AWORDA
      *ST_(0+%B)
CON:  *MPSR_X'12'
      *L_(0+%B)
      *MPSR_X'11'
      *JAF_4,<CON>
      J=0
      I=PINT %AND J=J+1 %UNTIL I#0 %OR J=100
      ACTIVATE(1)=ACTIVATE(1)&X'00FFFFFF'!1<<24;  !START STREAM
      TCB(0)=TCBM!X'81';                !INITIALISE
      TCB(1)=REALISE(ADDR(INIT)&X'FFFC0000')!1;   !GLA STE
      TCB(2)=4;                         !DATA LENGTH
      TCB(3)=ADDR(INIT);                !DATA ADDRESS
      INIT=INIT!(PSM&15)<<24;           !MECHANISM
      DOWAIT(X'C00000')
SKIPINIT:

      TCB(0)=TCBM!X'238';               !REWIND TO BT (& SKIP DATA)
      TCB(1)=1;                         !FIXED
      TCB(2)=0
      TCB(3)=0
      DOWAIT(X'C00000');                !WAIT FOR TERM
      J=0
      I=PINT %AND J=J+1 %UNTIL I#0 %OR J=100;!WAIT FOR BT SENSE
      WAIT(2000)
SKIPBT:

      TCB(0)=TCBM!X'202';               !READ OVER LABEL
      TCB(2)=4096
      DOWAIT(X'C00000')
      TCB(0)=TCBM!X'A3';                !WRITE TM
      DOWAIT(X'C00000')
      TCB(0)=TCBM!X'83';                !WRITE DATA
      %CYCLE I=0,1,SEG10_SBLKS-1;       !DUMP STORE IN 4K BLOCKS
         TCB(1)=BLOCKAD(I)!1
         %CYCLE J=0,4096,31*4096
            TCB(3)=J
            DOWAIT(X'C00000')
         %REPEAT
      %REPEAT
      TCB(0)=TCBM!X'A3';                !WRITE TM*2
      DOWAIT(X'C00000')
      DOWAIT(X'C00000')
      TCB(0)=TCBM!X'258';               !DISCONNECT & UNLOAD
      DOWAIT(X'C00000')
      HOOT(0)
      *IDLE_X'E00E'
      STOP
%INTEGERFN PINT
%RECORDFORMAT ISTF(%INTEGER LNB, PSR, PC, SSR, SF, IT, IC)
%RECORDNAME IST(ISTF)
%RECORD SAVE IST(ISTF)
%CONSTINTEGER IST VA=X'80080000'
%INTEGER LNB, PC, SF
%INTEGER I
%CONSTINTEGER PINTWT=4;                 !INTERRUPT WEIGHT
      I=0
      IST==RECORD(IST VA+(PINTWT-1)*32)
      SAVE IST=IST
      *STLN_LNB
      *STSF_SF
      *JLK_<INT>
      *LSS_%TOS
      *ST_PC
      IST_LNB=LNB
      IST_PSR=X'14FF01'
      IST_PC=PC
      IST_SSR=X'FFE'
      IST_SF=SF
      IST_IT=X'7FFFFF'
      IST_IC=X'7FFFFF'
      *LSS_X'826';                      !ALLOW PERIPHERAL INTS.
      *ST_(3)
      WAIT(10)
      ->FINI
INT:
      *JLK_%TOS
      *LSS_%TOS
      *LSS_%TOS
      *ST_I;                            !INTERRUPT PARAM
FINI:
      *LSS_X'FFE'
      *ST_(3)
      IST=SAVE IST
      %RESULT =I
%END
%ROUTINE DOWAIT(%INTEGER MASK)
%INTEGER TCBR
%INTEGER I
%LONGLONGREAL TCBP
      %UNLESS MASK<0 %START
         *LB_PCWORDA;                   !CLEAR UNWANTED INTS.
         *MPSR_X'12'
         *L_(0+%B)
         TCB(5)=0;                      !CLEAR RESPONSE WORD
         A=LONGINTEGER(ADDR(ACTIVATE(0)))
         *LSD_A
         *LB_AWORDA
         *ST_(0+%B)
CA:      *MPSR_X'12'
         *L_(0+%B)
         *MPSR_X'11'
         *JAF_4,<CA>
CR:      TCBR=TCB(5)
         *LSS_TCBR;                     !WAIT FOR RESPONSE
         *JAT_4,<CR>
         *USH_-30;                      !PROTEM
         *JAT_4,<FIREOK>
         ->SENSEF %IF TCB(0)&X'FF'=4;   !SENSE ALREADY FAILED
         %CYCLE I=0,1,3;                !SAVE OLD TCB INFO
            TCB(6+I)=TCB(I)
         %REPEAT
         TCB(0)=TCBM!4;                 !READ FOR SENSE
         TCB(1)=REALISE(ADDR(TCB(0))&X'FFFC0000')!1
         TCB(2)=13
         TCB(3)=ADDR(TCB(10));          !INTO POSTAMBLE
         DOWAIT(X'C00000')
SENSEF:
         %CYCLE I=0,1,3;                !RESTORE TCB
            TCB(I)=TCB(6+I)
         %REPEAT
         ->FIREOK %IF TCBR&X'FFFF'=0;   !NO RBC
         TCBP=LONGLONGREAL(ADDR(TCB(10)))
         *LB_TCBR
         *LSQ_TCBP
         *IDLE_X'EEEE'
FIREOK:
         %RETURN
      %FINISH
      *LB_PCWORDA;                      !WAIT FOR INTERRUPT
      *MPSR_X'12'
CI:   *L_(0+%B)
      *JAT_4,<CI>
      %RETURN
%END
%END;                                   ! RESTART
%EXTERNALROUTINE ENTER(%INTEGER A, B)
%RECORDFORMAT REGF(%INTEGER LNB, PSR, PC, SSR, SF, IT, IC, LTB)
%RECORDNAME R(REGF)
%INTEGER SSNP1ADDR, J, REACTAD, PB0, PB1, THIS LNB, THIS SF,  %C
         REACT PC, CURSTKAD
%CONSTINTEGER REAL0SEG=X'2040', RESSTKAD=X'80180000'
%INTEGERARRAYNAME BLOCKAD
! THIS CODE IS RUNNING IN LOCAL SEGMENT 2
! LOCAL SEGMENT 0 IS MAPPED ONTO RA 0
      *STLN_J
      THIS LNB=J
      COM==RECORD(X'80C00000');         ! FOR ALL RTS IN THIS FILE
      BLOCKAD==ARRAY(COM_BLKADDR,BF)

! COPY WORDS FROM ALTERNATE STACK SEGMENT TO RA WORD 32(DEC) IE. X80 BYTES
! WORK OUT ALT STACK SEG FROM CURRENT STACK FRONT
      *STSF_J
      CURSTKAD=J&X'FFFC0000'
      SSNP1ADDR=CURSTKAD!X'00040000'
      REACTAD=REAL0 SEG<<18+X'80'
!      MOVE(80,SSNP1ADDR + REACT OFFSET,REACTAD)
! COPY SUFFICIENT OF CURRENT STACK TO THE RESTART STACK (PUBLIC 6) TO
! ALLOW 'RESTART' TO BE CALLED ON IT.
      *STSF_THIS SF
      MOVE(THIS SF&X'3FFFF',CURSTKAD,RESSTKAD)
! NOW SET UP RE-ACTIVATION WORDS FOR RE-ENTRY BELOW
      *JLK_<ELAB>
      *LSS_%TOS
      *ST_REACT PC
      R==RECORD(REACTAD)
      R_LNB=RESSTKAD!(THIS LNB&X'3FFFF')
      R_PSR=X'0014FF01'
      R_PC=REACT PC
      R_SSR=X'FFE';                     ! VA MODE   ALL MASKED EXCEPT SYSTEM ERROR
      R_SF=RESSTKAD!(THIS SF&X'3FFFF')
      GET PSTB(PB0,PB1)
      INTEGER(REACTAD+X'48')=PB0
      INTEGER(REACTAD+X'4C')=PB1
      MOVE(80,REACTAD,RESSTKAD+X'40000');    ! SECOND COPY IN NEXT SEG.
! NEXT WORD AFTER THESE RE-ACTIVATION REGISTERS TO BE THE ADDRESS OF
! THE SSN+1 SEGMENT FOR RESTART TO GET THE REGISTERS FROM.
      INTEGER(REACTAD+80)=SSNP1ADDR
      SUP29
      *IDLE_X'F003'
ELAB:
      *JLK_%TOS
! RE-ENTRY HERE FOR POST MORTEM
      RESTART(0,0)
      *IDLE_X'F003'
                                        ! SHOULD NOT RETURN !
%END;                                   ! ENTER
%SYSTEMROUTINE WRITE(%INTEGER VALUE, PLACES)
%STRING (16) S
%INTEGER D0, D1, D2, D3, L
      PLACES=PLACES&15
      *LSS_VALUE;  *CDEC_0
      *LD_S;  *INCA_1;  *STD_%TOS
      *CPB_%B;                          ! SET CC=0
      *SUPK_%L=15,0,32;                 ! UNPACK & SPACE FILL
      *STD_D2;  *JCC_8,<WASZERO>
      *LD_%TOS;  *STD_D0;               ! FOR SIGN INSERTION
      *LD_%TOS
      *MVL_%L=15,63,0;                  ! FORCE ISO ZONE CODES
      %IF VALUE<0 %THEN BYTEINTEGER(D1)='-'
      L=D3-D1
OUT:  %IF PLACES>=L %THEN L=PLACES+1
      D3=D3-L-1
      BYTEINTEGER(D3)=L
      PRINTSTRING(STRING(D3))
      %RETURN
WASZERO:

      BYTEINTEGER(D3-1)='0'
      L=2;  ->OUT
%END
%EXTERNALROUTINE PRHEX(%INTEGER I)
! 8-DIGIT HEX PRINT
      PRINTSTRING(STRHEX(I))
%END;                                   ! PRHEX
%ENDOFFILE