?%EXTRINSICLONGINTEGER KMON
%EXTERNALINTEGERFNSPEC HANDKEYS
%EXTERNALROUTINESPEC WAIT(%INTEGER MSECS)
%EXTERNALROUTINESPEC SUP29
%ROUTINESPEC PRHEX(%INTEGER H)
%ROUTINESPEC PRINTER(%RECORDNAME P)
%EXTERNALROUTINESPEC GPC(%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, P6)
!* COMMUNICATIONS RECORD FORMAT - EXTANT FROM CHOPSUPE 18D ONWARDS *
%RECORDFORMAT COMF(%INTEGER OCPTYPE,IPLDEV,SBLKS,SEPGS,NDISCS,  %C
         DDTADDR,GPCTABSIZE,GPCA,SFCTABSIZE,SFCA,SFCK,DIRSITE,  %C
         DCODEDA,SUPLVN,KLOKCORRECT,DATE0,DATE1,DATE2,  %C
         TIME0,TIME1,TIME2,EPAGESIZE,USERS,PROCMON,DQADDR,  %C
         SACPORT,OCPPORT,ITINT,CONTYPEA,GPCCONFA,FPCCONFA,SFCCONFA, %C
         BLKADDR,DPTADDR,SMACS,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, TICKS SINCE,  %C
   CAA, GRCB AD, LBA, ALA, STATE, RESP0, RESP1, SENSE1, SENSE2,  %C
   SENSE3, SENSE4, REPSNO, BASE, ID, DLVN, MNEMONIC, ENTSIZE,  %C
   PAW, USAW0, URCB AD, SENSDAT AD, LOGMASK, TRTAB AD, UA SIZE,  %C
   UA AD, 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
   %IF PLACES>8 %THEN PLACES=8
   I = 64-4*PLACES
   *LD_S;  *LSS_PLACES;  *ST_(%DR)
   *INCA_1;  *STD_%TOS;  *STD_%TOS
   *LSS_VALUE;  *LUH_0;  *USH_I
   *MPSR_X'24';                         ! SET CC=1
   *SUPK_%L=8
   *LD_%TOS;  *ANDS_%L=8,0,15;          ! THROW AWAY ZONE CODES
   *LSS_H+4;  *LUH_X'18000010'
   *LD_%TOS;  *TTR_%L=8
   %RESULT = S
%END
!-----------------------------------------------------------------------

%EXTERNALSTRING (15) %FN STRINT(%INTEGER N)
%STRING (16) S
%INTEGER D0, D1, D2, D3
   *LSS_N;  *CDEC_0
   *LD_S;  *INCA_1;                     ! PAST LENGTH BYTE
   *CPB_%B;                             ! SET CC=0
   *SUPK_%L=15,0,32;                    ! UNPACK 15 DIGITS SPACE FILL
   *STD_D2;                             ! FINAL DR FOR LENGTH CALCS
   *JCC_8,<WASZERO>;                    ! N=0 CASE
   *LSD_%TOS;  *ST_D0;                  ! SIGN DESCRIPTOR STKED BY SUPK
   *LD_S;  *INCA_1
   *MVL_%L=15,15,48;                    ! FORCE IN ISO ZONE CODES
   %IF N < 0 %THEN BYTEINTEGER(D1) = '-' %AND D1 = D1-1
   BYTEINTEGER(D1) = D3-D1-1
   %RESULT = STRING(D1)
WASZERO:

   %RESULT = "0"
%END

%EXTERNALROUTINE 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)!PUBLIC
!** IF WE HAVE TRUTHFUL SEGMENT TABLES
!** (CURRENTLY WE DO NOT - SEE CHOPSUPE ROUTINE 'CONFIG')
!**  THEN LEST STORE BE DISCONTIGUOUS :-
!     VAPE=VAPE-(INTEGER(PST VA+((VAPE>>15)&X'FFF8')+4)&X'20000')
      %RESULT = INTEGER(VAPE)&RA1024+(AD&X'3FF')
!!
   %FINISH
!!
!  UN-PAGED SEGMENT
!!
   %RESULT = (AD&X'3FFFF')+(INTEGER(VASE+4))&RA128
!!
%END
!*
!*
!*
!!
%CONSTSTRING(8) %NAME DATE=X'80C0003F'
%CONSTSTRING(8) %NAME TIME=X'80C0004B'
!!

%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)&X'F')
%END;                                   !OF I2
!!

%EXTERNALROUTINE DUMPTABLE(%INTEGER TABLE, ADD, LENGTH)
%OWNINTEGER NEXT
%INTEGER I, K, END, SPTR, VAL
%STRING (132) S
   NEXT = NEXT+1;  ADD = ADD&(-4)
   PRINTSTRING("
DT: ".DATE." ".TIME."
****    SUPERVISOR  DUMP    TABLE: ". %C
      STRINT(TABLE)."    ADDR ".STRHEX(ADD).'    LENGTH: '. %C
      STRINT(LENGTH).'    DUMP NO: '.STRINT(NEXT).'****
')
   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', BUFFBASE = X'80FC0000',  %C
   PAGEMASK = X'80FC3000'
%OWNINTEGER INPTR, OUTPTR = X'80FC0000'
%OWNINTEGER BUSY, DINTPEND = 0, INTPEND, TESTPEND = 0, INIT = 0
%OWNINTEGER MODE=-1
%CONSTINTEGER SPOOLING=1,PRINTING=0,CLOSED=-1

%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
      ADR = ADDR(S)+1
   J = L
!       %WHILE J > 0 %CYCLE
!          CHARNO(S,J) = N&127
!       J = J-1
!       %REPEAT
! EQUIVELANT OF ABOVE 4 LINES IS
      J = N&127
      I = X'18000000'!L
      *LDTB_I
      *LDA_ADR
      *LB_J
      *MVL_%L=%DR
   %FINISH %ELSE %START
      %IF EP >= 7 %THEN %START;         ! PRINT STRING
         L = BYTE INTEGER(N);  ADR = N+1
      %FINISH %ELSE %START;             ! PRINT SYMBOL & PRINT CH
         L = 1;  ADR = ADDR(N)+3
      %FINISH
   %FINISH
!         %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&X'FFF' <= 63 %THEN INPTR = J!63 %AND J = INPTR+1
      %IF J # OUTPTR %THEN %START;      ! ROOM FOR CURRENT CHAR
         SYM = BYTE INTEGER(ADR)
         BYTE INTEGER(J) = SYM
         %IF SYM = 133 %THEN SYM = NL
         %IF SYM < 32 %AND SYM # NL %THEN SYM = '?'
         %IF SYM = NL %THEN NLSEEN = 1
         ADR = ADR+1;  I = I+1
      INPTR=J
      %FINISH %ELSE BUSY = 1 %AND %RETURN
   %REPEAT
   %RETURN %IF MODE # PRINTING
   %IF OLDINPTR = OUTPTR %AND NLSEEN # 0 %C
      %THEN Q_DEST=X'360000' %AND PON(Q)
END:

%END;                                   ! OF ROUTINE IOCP
!!
%OWNINTEGER WAITINIT,WAITBUSY
!!

%EXTERNALROUTINE PRINTER(%RECORDNAME P)
!***********************************************************************
!***********************************************************************
?%OWNINTEGER DMON
%INTEGER I, J
%OWNBYTEINTEGERARRAY BUFFER(0 : 133)
! RCB - REQUEST BLOCK TO PRINT LINES ON MAIN PRINTER
%OWNINTEGER LFLAG = X'40000', LSTBA = X'8080', LBL = 4, LBA = 0,  %C
      ALL = 8, ALA = 0, INITWRD = 0
%OWNBYTEINTEGERARRAY PAGESTATE(0 : 3) =     0(4)
%CONSTINTEGER PONSRC = X'360000', CALLSRC = X'80360000'
%CONSTHALFINTEGER AUTO=X'8000'
%CONSTINTEGER READONLY = 1, WRITEABLE = 0
%OWNINTEGER LBE = X'80700300', ALE1, ALE2
%OWNINTEGER MNEM = M'LP', ACTSIZE = 0
%OWNINTEGER DPAGE = 0;                  ! DISC ADDRESS
%OWNINTEGER CFILE = 0, SECTSIZE = 0
%OWNINTEGERARRAY DPAGES(0 : 1) =  -1(2)
%OWNINTEGER DISCDEST,GPCREJ
! FILE HEADER BLOCK
%OWNINTEGER HDR1 = 0, HDR2 = 32, HDR3 = 0, HDR4 = 3
%OWNINTEGER HDR5=0,HDR6=0,HDR7=-256,HDR8=0
%RECORDNAME D(ENTFORM)
%SWITCH DACT(0 : 9)
%RECORDSPEC P(PARMF)
!!
!!
!!

   %ROUTINE INITIALISE FILE
%STRING(32) SHEAD
      %RETURN %UNLESS MODE = SPOOLING
    %IF DINTPEND>0 %THEN WAITINIT=1 %AND %RETURN %ELSE WAITINIT=0
      ACTSIZE = 0
      OUTPTR = (OUTPTR&PAGEMASK)!64
      %IF BUSY = 1 %THEN INPTR = OUTPTR-1
! PACK DATE AND TIME
      HDR6 = ((I2(X'80C00046')-70)<<26)!(I2(X'80C00043')<<22) %C
         !(I2(X'80C00040')<<17)!(I2(X'80C0004C')<<12)!(I2( %C
         X'80C0004F')<<6)!I2(X'80C00052')
      HDR1 = SECTSIZE
      HDR3 = HDR1
      MOVE(32,ADDR(HDR1),OUTPTR&PAGEMASK);   ! FILL IN HEADER
SHEAD="DT: ".DATE." ".TIME." OCPTYPE= 
"
BYTEINTEGER(ADDR(SHEAD)+31)=COM_OCPTYPE +48
MOVE(32,ADDR(SHEAD)+1,(OUTPTR&PAGEMASK)+32)
      DPAGE = DPAGES(CFILE)
   %END
!!
!!

   %ROUTINE CHANGEFILE
! CLOSE CURRENT SPOOL FILE AND REQUEST ANOTHER ONE
! IF BOTH FILES CLOSED , REQUESTS HAVE ALREADY BEEN SENT, SO GET OUT
%RETURN %IF DPAGES(0)=0 %AND DPAGES(1)=0
     %RETURN %IF ACTSIZE=0 %AND DPAGE#0  ;! NO EMPTY FILES
AGN:
?   %IF DMON=1 %THEN OPMESS("CHANGE FILE ".HTOS(DPAGE,8))
      P = 0
      P_DEST = DISCDEST
      P_SRCE = PONSRC!1
      P_P1 = DPAGE
      P_P2 = ACTSIZE
      PON(P)
      ACTSIZE=0
      DPAGES(CFILE) = 0;                ! MARK FILE CLOSED
      CFILE = (CFILE+1)&1;              ! CHANGE TO ALTERNATE FILE
      DPAGE = DPAGES(CFILE)
      %IF DPAGE > 0 %THEN INITIALISE FILE %ELSE %START
         %IF DPAGE = -1 %THEN DPAGE = 0 %AND -> AGN
      %FINISH
   %END
!!

   %ROUTINE DISCWRITE(%INTEGER AD)
AD=AD&PAGEMASK
       P=0
      P_P1=(AD>>12)&3   ;! BLOCK 0:3
!  RETURN UNLESS NO FILE AVAILABLE OR PAGE ALREADY SENT
      %RETURN %IF DPAGE <= 0 %OR PAGESTATE(P_P1)#WRITEABLE
  %IF DPAGE&15=0 %AND INTEGER(AD+8)=0 %START   ;! BAD HEADER
     OPMESS(" BAD HEADER ! ")
     OPMESS(HTOS(AD,8)." ".HTOS(DPAGE,8))
     %FINISH
?      %IF DMON = 1 %THEN OPMESS("DISCW ".HTOS(AD,8)." ".HTOS( %C
         DPAGE,8))
      P_DEST = X'210002'
      P_SRCE = PONSRC!4
      P_P2 = DPAGE
      P_P3 = AD
      PON(P)
      DINTPEND = DINTPEND+1;            ! REMEMBER DISC TERM. PENDING
      PAGESTATE(P_P1) = READONLY;       ! LOCK PAGE UNTIL DISC WRITE COMPLETE
      ACTSIZE = ACTSIZE+4096
      %IF ACTSIZE >= SECTSIZE %THEN CHANGE FILE %C
         %ELSE DPAGE = DPAGE+1
   %END
!!
!!

   %ROUTINE PREPORT(%INTEGER TYPE, VALUE)
   %CONSTSTRING (8) %ARRAY M(1 : 3) =    %C
"DEALLOC.","ALLOC.","PRINT"
      OPMESS("MLP ".M(TYPE)." FAILS ".TOSTRING(VALUE+'0'))
   %END
!!

   %ROUTINE DEALLOCATE MAIN PRINTER
   %RECORD Q(PARMF)
!*
      %IF INTPEND # 0 %THEN %RETURN
      Q = 0;  Q_DEST = 5
      Q_SRCE = CALLSRC!2
      Q_P1 = MNEM
      GPC(Q)
      %IF Q_P1 # 0 %AND Q_P1 # 2 %THEN PREPORT(1,Q_P1) %C
         %ELSE MODE = MODE+(MODE-1)
      TESTPEND = 0
   %END
!!

   %ROUTINE ALLOCATE MAIN PRINTER
   %RECORD Q(PARMF)
      Q = 0;  Q_DEST = 4;               ! REQUEST PRINTER ALLOCATION
      Q_P1 = MNEM;  Q_SRCE = CALLSRC!2
      GPC(Q)
      %IF Q_P1 # 0 %THEN PREPORT(2,Q_P1) %AND %RETURN
      D == RECORD(Q_P3)
      TRANSTABAD = D_TRTABAD
      INIT = Q_P2;                      ! SNO
      MNEM = Q_P6;                      ! ACTUAL DEVICE RETURNED BY KY
      MODE = PRINTING
   %END
!!
   %IF INIT = 0 %THEN %START;           ! FIRST TIME IN - INITIALISE
      LBA = ADDR(LBE)
      ALA = ADDR(ALE1)
      ALE2 = ADDR(BUFFER(1))
      ALLOCATE MAIN PRINTER
%IF INIT=0 %THEN INIT=-1
   %FINISH
!!
!!
!!
   I = P_DEST&255
   %IF I > 9 %THEN I = 0;               ! DONT REPORT FOR FEAR OF STARTING LOOP
! MAY BE WAITING FOR LP TERM. BEFORE DEALLOCATING TO AVOID
! A SPURIOUS TERM. GOING TO THE NEW OWNER.
   %IF MODE = SPOOLING %AND INTPEND = 1 %AND (2 <= I <= 3 %C
      %OR I = 5) %THEN INTPEND = 0 %C
      %AND DEALLOCATE MAIN PRINTER %AND I = 0
   -> DACT(I)
!!
!****************************************
DACT(9):  ;! IDENTIFY VERSION
P_DEST=P_SRCE
P_SRCE=X'360009'
P_P1=M'NEW'
PON(P)
%RETURN
!!----------------------------------------------
DACT(2):

! PRINTER - NORMAL TERMINATION
   INTPEND = 0
!!
NEXTLINE:

   BUFFER(0) = 0
!!
!!------------------------------------------------
DACT(0):                                ! ALARM CLOCK TICK OR EQUIVALENT
   %IF INPTR = OUTPTR %THEN -> UNBUSY
   %IF MODE = SPOOLING %START
      %IF WAITINIT=1 %AND DINTPEND=0 %THEN INITIALISE FILE
SP:   I = OUTPTR
      %CYCLE J=1,1,4
%IF (I-1)<= INPTR < (I+4096)&X'FFFFFFC0'   %AND BUSY=0 %THEN %RETURN
         %IF PAGESTATE(I<<18>>30) = WRITEABLE %C
            %THEN DISCWRITE(I)
         I = (I+4096)&MASK
      %REPEAT
   %FINISH
   %RETURN %IF MODE!INTPEND!TESTPEND!DINTPEND # 0
   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 %START
            OUTPTR = (OUTPTR+1)&MASK
            %IF OUTPTR&X'FFF' <= 31 %THEN OUTPTR = OUTPTR+32
         %FINISH
         I = I+1;  BUFFER(I) = J
         BUFFER(0) = I
         ALE1 = X'58000000'+I
         ITOE(ALE2,I)
         ETOE(ALE2,I)
         -> PRINT
      %FINISH
      OUTPTR = (OUTPTR+1)&MASK
      %IF OUTPTR&X'FFF' <= 31 %THEN OUTPTR = OUTPTR+32
      %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)
   P = 0
   P_DEST = 10
   P_SRCE = CALLSRC
   P_P1 = ADDR(LFLAG);                  ! ADDR OF RCB
   P_P2 = INIT
   P_P3 = X'11';                        ! PAW = DO STREAM REQ,SAW - CLEAR ABNORMAL
   GPC(P)
   %IF P_P1 # 0 %THEN %START
%IF GPCREJ&X'FF'=0 %THEN PREPORT(3,P_P1)  %ELSE GPCREJ=GPCREJ+1
%FINISH %ELSE INTPEND = 1
   %RETURN
!!
!!-----------------------------------------------
DACT(1):

! NEW LOG FILE
? %IF DMON=1 %THEN OPMESS("NEW LOG FILE ".HTOS(P_P2,8))
   SECTSIZE = P_P1<<12
    %IF DPAGES(0) > 0 %AND DPAGES(1) > 0 %START  
?   PRINTSTRING("SPURIOUS LOG FILE")
     %RETURN
     %FINISH
   %IF DPAGES(CFILE) = 0 %THEN DPAGES(CFILE) = P_P2 %C
      %ELSE DPAGES((CFILE+1)&1)=P_P2
   %IF DPAGE=0 %THEN INITIALISE FILE
   -> NEXTLINE
!!
!!------------------------------------------------
DACT(5):

! ABNORMAL TERMINATION - LP ONLY
   INTPEND = 0
?   PRINTSTRING("
MLP ABTERMN: ")
?PTREC(P)
!     D==RECORD(Q_P3)
   OPMESS('ATTEND MAIN LP')
   TESTPEND = 1;  %RETURN
!!
!!------------------------------------------------
DACT(3):

! ATTENTION
   %IF TESTPEND # 0 %AND P_P1&AUTO # 0 %C
      %THEN TESTPEND = 0 %AND -> PRINT %ELSE %RETURN
!!
!!------------------------------------------------
DACT(8):

                                        ! RESET PRINTER - HOPEFULLY
DACT(6):                                ! RESET PRINTER - FORCEFULLY
   %IF MODE # PRINTING %START;          ! IF WE DONT HAVE THE PRINTER - GET  IT
      DEALLOCATE MAIN PRINTER %UNLESS I = 8; ! FROM WHOEVER HAS IT
      ALLOCATE MAIN PRINTER
   %FINISH
   %IF I = 8 %START
      P_DEST = P_SRCE
      P_SRCE = PONSRC!8
      %IF MODE = PRINTING %THEN P_P1 = 0 %ELSE P_P1 = 101
      PON(P) %UNLESS P_DEST < 0
   %FINISH
    GPCREJ=0
   %RETURN %IF MODE # PRINTING
   CHANGE FILE %IF DPAGE>0
   -> DACT(2);                          ! DANGEROUS - MAY GET SLOT BUSY IF CALL REPEATED
!!
!!----------------------------------------------------
DACT(7):                                ! CLOSE CURRENT OUTPUT
?     %IF KMON&(LENGTHENI(1)<<54)#0 %THEN DMON=1 %ELSEC
    DMON=0
?      %IF DMON = 1 %THEN OPMESS("NLF ".HTOS(INPTR,8)." ". %C
         HTOS(OUTPTR,8))
      I=MODE
    DISCDEST=P_SRCE
%IF MODE=SPOOLING %START
   BYTEINTEGER((INPTR+1)&MASK) = 4;     ! EOM CHARACTER
   DISCWRITE(OUTPTR)
!   SUBTRACT UNUSED SPACE
   ACTSIZE = ACTSIZE-(X'1000'-((INPTR&X'FFF')+1))
   INPTR=((INPTR+4096)&MASK)!32  ;! MOVE ONTO NEXT PAGE
    CHANGE FILE
%FINISH %ELSESTART   ;! ZERO FRONT OF FIRST PAGE
%IF INPTR<OUTPTR %AND INPTR>>12=OUTPTR>>12 %START
   BUSY=1
%CYCLE I=INPTR&PAGEMASK,1,OUTPTR
BYTEINTEGER(I)=0
%REPEAT
%FINISH
    MODE=SPOOLING
    %IF DPAGES(0)=-1=DPAGES(1) %THEN CHANGE FILE %ELSEC
   INITIALISE FILE  ;! ACT TO ACQUIRE NEW FILES IF NECCESARY
%FINISH
   %IF I = PRINTING %THEN DEALLOCATE MAIN PRINTER
   -> NEXTLINE
!!
!!------------------------------------------------
DACT(4):                                ! DISC TERMINATION
   %IF DINTPEND = 0 %START
? PRINTSTRING('
 SPURIOUS LOG DISC INT ') 
      %RETURN
   %FINISH
   DINTPEND = DINTPEND-1
   PAGESTATE(P_P1) = WRITEABLE
   J = BUFFBASE+(P_P1<<12)
! ZERO BLOCK - NULL CHARACTER
!BYTEINTEGER(J)=0
! MOVE(4095,J,J+1)
! M/C CODE EQUIVELANT OF ABOVE TWO LINES IS-
   *LDTB_X'18001000'
   *LDA_J
   *LB_0
   *MVL_%L=%DR
   %IF P_P2 # 0 %START;                 ! ABNORMAL TERMINATION
!       OPMESS(' LOG FILE ABTERM '.HTOS(P_P2,2))
     DINTPEND=0   ;! FORGET OTHER TRANSFERS OUTSTANDING ON FAULTY FILE
      %CYCLE I=0,1,3
      PAGESTATE(I)=WRITEABLE
      %REPEAT
      CHANGE FILE
   %FINISH

   %WHILE PAGESTATE((OUTPTR&X'3000')>>12) = WRITEABLE %THEN %CYCLE
      OUTPTR=((OUTPTR+4096)&PAGEMASK)!64
    ->UNBUSY %IF OUTPTR-1<=INPTR<(OUTPTR+4096)
   %REPEAT
   %RETURN
!!
!!-------------------------------------------------
UNBUSY:                                 ! RESTART IF BUFFER OFLOW OCCURRED
   %IF BUSY = 1 %THEN %START
   %IF MODE =SPOOLING %THEN INPTR=OUTPTR
?         %IF DMON = 1 %THEN OPMESS("UNBUSY")
      BUSY = 0
      PRINTSTRING('
*** OUTPUT LOST ***
')
   %FINISH
   %IF MODE = SPOOLING %THEN -> SP
%END;                                   ! OF ROUTINE PRINTER
!!

%EXTERNALROUTINE GET PSTB(%INTEGERNAME PSTB0, PSTB1)
%CONSTINTEGER PST VA = X'80040000';     ! VA OF PUBLIC SEG TABLE
! MACHINE-INDEPENDENT VERSION
! PUBLIC SEGMENT 1 IS MAPPED TO THE PST ITSELF
%RECORDFORMAT EF(%INTEGER LIM, RA)
%RECORDNAME E(EF)
   E == RECORD(PST VA+8);               ! ONTO THE PST ENTRY FOR SEG 1
! 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'.
   PSTB0 = ((E_LIM&X'0003FF80')<<15)!X'803C0000'
   PSTB1 = E_RA&X'0FFFFFC0'
!%INTEGER J,K
!*LSS_(X'6002')
!*ST_J
!      LIM=J
!*LSS_(X'6003')
!*ST_K
!      RA=K
%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 A, B)
!
%ROUTINESPEC DOWAIT(%INTEGER MASK)
%CONSTINTEGER PST VA=X'80040000';       ! VA OF PUBLIC SEG TABLE
%RECORD Q,P(PARMF)
%RECORDFORMAT RQBF(%INTEGER LFLAG,LSTBA,LBL,LBA,ALL,ALA,INIT)
%RECORDFORMAT STRMF(%INTEGER SAW0,SAW1,RESP0,RESP1)
%RECORDFORMAT CAF(%INTEGER MARK,PAW,PIW0,PIW1,CSAW0,CSAW1,CRESP0,%C
      CRESP1,%RECORDARRAY STRMS(0:15)(STRMF))
%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)
%RECORDNAME DEV(ENTFORM)
%RECORDNAME CA(CAF)
%RECORDNAME RQB(RQBF)
%INTEGERNAME LBE,ALE1,ALE2
%INTEGERARRAYNAME BLOCKAD
%RECORDFORMAT SEGENTF(%INTEGER LIM, RA)

%RECORDARRAYFORMAT SEGARRF(0:127)(SEGENTF)
%RECORDARRAYNAME PST(SEGENTF)
%EXTRINSICINTEGER PARMASL,KERNELQ,RUNQ1,RUNQ2
%RECORDFORMAT SERVAF(%INTEGERC
P,C)
%EXTRINSICRECORDARRAY SERVA(0:576)(SERVAF)
%EXTRINSICLONGINTEGER PARMDES
%LONGINTEGER TEMP
%INTEGER PTSM, I, J, STRM, RESP0, RESP1
%INTEGER SMARK,SENSE1,SENSE2,SENSE3,SENSE4,SRESP
      SLAVESONOFF(0)
      P=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
      PTSM=HANDKEYS&X'FFFF'
!
!     DEALLOCATE &REALLOCATE TAPE DECK
!
      Q=0; Q_DEST=5
      Q_P1=PTSM; Q_SRCE=X'80000000'
      GPC(Q);                           ! DEALLOCATE
      Q_DEST=4; Q_P1=PTSM
      Q_SRCE=X'80360000'
      GPC(Q)
      %IF Q_P1#0 %THEN %START
         PTREC(Q)
         NEWLINE
         HOOT(4)
         *IDLE_X'12121'
      %FINISH
       DEV==RECORD(Q_P3)
       CA==RECORD(DEV_CAA)
       RQB==RECORD(DEV_GRCB AD)
      CA_MARK=-1
      LBE==INTEGER(RQB_LBA)
      ALE1==INTEGER(RQB_ALA)
      ALE2==INTEGER(RQB_ALA+4)
      RQB_LFLAG=1<<18!X'C000';          ! LST 1 SEG,NOTE MECH NO,ACR=0
                                        ! AND TRUSTED CHAIN
      RQB_LSTBA=X'8080'
      RQB_LBL=4; RQB_ALL=8
      RQB_INIT=(PTSM&15)<<24!X'FC03';   ! STATUS MASK&1600BPI
      STRM=PTSM>>4&15
!
      ALE1=X'58001000'
      ALE2=X'81000000'
!
! RECONNECT THE STREAM IN CASE . KY SAYS THIS DOES NO HARM
!
      LBE=X'00F10800';                  ! CONNECT STREAM IF NEC
      DOWAIT(X'C00000')
      LBE=X'80F03800';                  ! REWIND
!
! SKIP BACK TO BT
!
      DOWAIT(X'C00000');                ! WAIT FOR TERM(=REWND STARTS)
! IF OK THEN WAIT FOR ATTN ELSE DO SENSE
%IF RESP0&X'800000'#0 %THENC
      DOWAIT(X'80100000') %ELSESTART
     SMARK=X'F1F1F1F1'   ;! JUST A DUMP MARKER
      SRESP=0
     ALE1=X'5800000D' 
       ALE2=ADDR(SENSE1)
     LBE=X'80F00400'
     DOWAIT(X'C00000')   ;! WAIT FOR SENSE TERM.
      SRESP=RESP0   ;! REMEMBER RESULT
       ALE1=X'58001000'   ;! RESET ALE
     ALE2=X'81000000'
     %FINISH
      WAIT(1000)
!
! NOW SKIP FORWARD 1 BLOCK
!
      LBE=X'80F04200'
      DOWAIT(X'C00000')
!
! NOW WRITE 1 TAPE MARK
!
      LBE=X'80F02300'
      DOWAIT(X'C00000')
!
! NOW DUMP STORE AS 4K BLOCKS
!
      LBE=X'80C00300'
!
      %CYCLE I=0,1,SEG10_SBLKS-1
         %CYCLE J=0,4096,31*4096
            ALE2=X'81000000'+SEG10_BLOCKAD(I)+J
            DOWAIT(X'C00000')
         %REPEAT
      %REPEAT
!
! WRITE 2 TAPE MARKS
!
      LBE=X'80F02300'
      DOWAIT(X'C00000')
      DOWAIT(X'C00000')
!
! DISCONNECT AND UNLOAD
!
LBE=X'00F05800'
DOWAIT(X'C00000')
!
! RE-CONNECT DECK
!
LBE=X'00000900'
DOWAIT(X'C00000')
HOOT(40)
*IDLE_X'E00E'
STOP
%ROUTINE DOWAIT(%INTEGER MASK)
!***********************************************************************
!*    FIRES AN I-O OPERATION AND WAITS FOR THE REPLY. ANY ATTENTIONS   *
!*    ARE THROWN AWAY. RESPONSE WORDS ARE LEFT IN GLOBALS              *
!***********************************************************************
%INTEGER CHISA
%RECORDNAME STRMS(STRMF)
       STRMS==CA_STRMS(STRM)
      %IF MASK<0 %THEN MASK=MASK&X'7FFFFFFF' %AND ->AGN
WAIT: *LXN_CA+4; *INCT_(%XNB+0)
     *JCC_8,<ON>
     %CYCLE CHISA=1,1,50
       %REPEAT
->WAIT
ON:   CA_PAW=1<<24!STRM;                ! DO STREAM REQUEST
      CA_PIW0=0
      STRMS_SAW0=1<<28!32;              ! CLEAR ABNORMAL TERMINATION
      STRMS_SAW1=ADDR(RQB)
      STRMS_RESP0=0
      STRMS_RESP1=0
      CA_MARK=-1
      CHISA=X'40000800'!(PTSM>>8<<16)
      *LB_CHISA; *LSS_1; *ST_(0+%B);    ! SEND CHANNEL FLAG
!
AGN:  %UNTIL STRMS_RESP0#0 %AND CA_MARK=-1 %CYCLE; %REPEAT
!
GET:  *LXN_CA+4; *INCT_(%XNB+0); *JCC_7,<GET>
      RESP0=STRMS_RESP0
      RESP1=STRMS_RESP1
      STRMS_RESP0=0
      STRMS_RESP1=0
      CA_PIW0=0
      CA_MARK=-1
      ->AGN %UNLESS RESP0&MASK#0;  ! NORMAL OR ABNORML SET
%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