%BEGIN
         %TRUSTEDPROGRAM
         %INTEGER I,J,K
         !*DELSTART
         %CONSTBYTEINTEGERARRAY OPC(0:120)=0,
             8,9,X'10',X'11',X'12',
               X'13',X'20',X'21',X'22',X'23',
               X'30',X'31',X'32',X'33',X'24',
               X'34',0,X'45',X'46',X'47',
               X'54',X'55',X'56',X'57',X'58',X'59',X'5A',X'5B',X'5C',
               X'5D',X'5E',X'5F',X'68',X'69',X'6A',
               X'6B',X'6C',X'6D',X'6E',X'6F',
               X'78',X'79',X'7A',X'7B',X'7C',
               X'7D',X'7E',X'7F',0,X'70',
               X'60',X'50',X'4E',X'4F',X'4C',
               X'4B',X'4A',X'49',X'48',X'44',
               X'43',X'42',X'41',X'40',0,
               X'90',X'98',X'86',X'87',0,
               X'91',X'92',X'94',X'95',X'96',
               X'97',X'9C',X'9E',X'9D',X'9F',
               X'82',X'84',X'85',0,X'88',
               X'89',X'8A',X'8B',X'8C',X'8D',
               X'8E',X'8F',0,X'D0',X'D1',
               X'D2',X'D4',X'D5',X'D6',X'D7',
               X'D8',X'DC',X'DD',X'DE',X'DF',
               X'D3',0,X'F1',X'F2',X'F3',
               X'F8',X'F9',X'FA',X'FB',X'FC',
               X'FD',0,10,4,X'80';
         %CONSTINTEGERARRAY NEM(0:120)=M'CNOP',
                M'SSK',M'ISK',M'LP',M'LN',M'LT',
               M'LC',M'LPD',M'LND',M'LTD',M'LCD',
               M'LPE',M'LNE',M'LTE',M'LCE',M'HD',
               M'HE',0,M'BAL',M'BCT',M'BC',
               'N',M'CL','O','X','L','C','A','S','M','D',
               M'AL',M'SL',M'LD',M'CD',M'AD',
               M'SD',M'MD',M'DD',M'AW',M'SW',
               M'LE',M'CE',M'AE',M'SE',M'ME',
               M'DE',M'AU',M'SU',0,M'STE',
               M'STD',M'ST',M'CVD',M'CVB',M'MH',
               M'SH',M'AH',M'CH',M'LH',M'EX',
               M'IC',M'STC',M'LA',M'STH',0,
               M'STM',M'LM',M'BXH',M'BXLE',0,
               M'TM',M'MVI',M'NI',M'CLI',M'OI',
               M'XI',M'SDV',M'HDV',M'TDV',M'CKC',
               M'PC',M'WRD',M'RDD',0,M'SRL',
               M'SLL',M'SRA',M'SLA',M'SRDL',M'SLDL',
               M'SRDA',M'SLDA',0,M'SSP',M'MVN',
               M'MVC',M'NC',M'CLC',M'OC',M'XC',
               M'LSP',M'TR',M'TRT',M'ED',M'EDMK',
               M'MVZ',0,M'MVO',M'PACK',M'UNPK',
               M'ZAP',M'CP',M'AP',M'SP',M'MP',
               M'DP',0,M'SVC',M'SPM',M'IDL';
         %CONSTBYTEINTEGERARRAY HASHALT(0:218)=20(33),6,
         20(11),1,20(2),4(10),20(7),1(26),20(102),
         20,7,2,9,1,13,20,20,5,20,20,7,1,20,17,1(4),20,5,20,6,20(3);
         !*DELEND
         %OWNINTEGERARRAY FIXED GLA(0:28)=0,
               X'30000000',0(2),-1,0,255,0(5),
              X'41100000',0,X'80000000',X'FFFFFF',0(2),
         X'4E000000',0,-4,-8,0(4),X'80000000',X'6492350',M'ERMA';
         %CONSTSHORTINTEGERARRAY TSNAME (0:53)=10000(8),
               10001,10000(5),10001,10032,10001(2),10032,
               10000(2),2,1,32,10032(7),10000,11,21,10032(2),11,10000,
               1,32,10000(2),5,10000,10005,11,5,10005,3,0,10000,1,2,
               10001;
         %CONSTBYTEINTEGERARRAY BYTES(0:7)=4,1,2,8,4,1,2,8;
         %CONSTBYTEINTEGERARRAY GRMAP(0:14)=0,1,2,3,15,16,18,20,22,
                                       4,5,6,7,8,14;
       %CONSTBYTEINTEGERARRAY PRECEDENCE (1:12)=0,3,3,3,3,4,4,4,4,5,5,5;
         %OWNBYTEINTEGERARRAY TRTABS (0:1283)=128(39),
         1,255(8),0(10),255(7),0(26),255(6),255(26),255(133),
         28(34),8,28,8,28(2),12,28(6),4,28,0(10),
         28(8),24,28(8),32,28,20,28(4),36,28(5),16,28(167),
         0(9),1,0(49),2,0(196),
         0(10),12,0(21),8,20(4),16,20,4,
        20(25),24(26),20(32),0,20,0,28,0,0,
        0(10),12,0(21),0,20(4),16,20,4 ,
         20(25),24(26),20(32),0,20,0,28,0,0,
         128(10),12,128(21),8,20(4),16,20,4,
         20(25),0(26),20(32),20,20,20,28,128(2),
         128(32),8,0,4,0,0,16,0,4,
         0(25),0(26),0(32),0,0,0,28,128,128
         %COMMENT TABLE 1 FOR NAMES --2 FOR CONSTS -- 3 FOR TEXT
         %COMMENT LAST 129 =TABLE FOR READ LINE KEY AS FOLLOWS.
         %COMMENT  0=ILLEGAL,4='''',8=SP,12=NL,16=%,20=NONALPHA,24=ALPHA
         %OWNBYTEINTEGERARRAY TYPEFLAG(1:6)=1,2,
               B'1001',B'10001',B'11010',5;
         %OWNSHORTINTEGERARRAY WARNINGS(0:30)
         %OWNINTEGER MASK1=X'0F0F0F0F'
         %OWNINTEGER MASK2=X'0F0F0F0F'
         %OWNINTEGER PI1=X'413243F6', PI2=X'A8885A31'
         %CONSTINTEGER RELEASE=9,VERSION=18
         %CONSTSHORTINTEGER MAXLEVELS=11
         %CONSTSHORTINTEGER PTBASE=256
         %CONSTSHORTINTEGER SNPT=10006;        ! SPECIALNAME PTYPE
         %CONSTINTEGER CODER=12
         %CONSTINTEGER  WSPR =11
         %CONSTINTEGER  GLA =13
         %OWNINTEGER HH1=X'0047002F',HH2=X'00610035'
!
! THE FOLLOWING FUNNY WORDS ARE CYCLE CONTROL WORDS FOR SEARCHING THE
! LIST OF FREE REGISTERS. THE TOP HALF IS INC(SIGNED) AND THE BOTTOM
! TWO BYTES ARE START AND FINISH RESPECTIVELY
!
         %CONSTINTEGER GR0   =X'10F1E';   !   15,1,14
         %CONSTINTEGER GR1   =X'1010F';   !   1,1,15
         %CONSTINTEGER FR0   =X'FFFE1610';!   6,-2,0
         %CONSTINTEGER ADDREG=X'FFFF0E01';!  14,-1,1
         %CONSTINTEGER SAFE  =X'FFFF0E04';!  14,-1,4
         %CONSTINTEGER CLMABL=X'1050E';   !  5,1,14
         %SHORTINTEGER CCSIZE,ARSIZE,DSIZE,DUMMY FORMAT
         %INTEGER ASL,NNAMES,FLAG,GLAFLAG
         %INTEGER CABUF,PPCURR,LCA,OLDLINE,LINE,LENGTH,LENGTHP, %C
               N0,NUM,SNUM,RLEVEL,NMAX,LOPCODE,CONSTPTR, %C
               PLABEL,LEVEL,CA,MARKER1,MARKER2,LABSET,CCSTATE, %C
               CYCLE NUM,CSAVED,CUR CYC VAR,CYC REGS,CYC BITS,CYC ASS
!
         %BYTEINTEGER FFLAG,CHECKS,SBFLAG,LAST INST,FAULTY,MONE, %C
               HIT,LET,DIAGS2,LIST,ALLLONG,INHCODE,LINENOS, %C
               DIAGS1,IMPS,CHECKSP,CTYPE,DCOMP,COMPILER,CPRMODE, %C
               UNASS,PRINTMAP,BFFLAG,NMDECS
!
         %LONGREAL CVALUE,IMAX
         %INTEGER MASK,RBASE,SFLABEL,NEXT,N,MAX ULAB,GSAVED,CODEBASE, %C
               P,Q,R,S,TTOPUT,U,V,NEST,FNAME,NOT USED,FILEPTR, %C
               FILE END,SSTL,QMAX,STMTS,MAINEP1,MAINEP2,MAINEP3, %C
               GLACA,GLACURR,GLACABUF,CYC BASE,CYC ADDR
!
         %SHORTINTEGER RELHEAD,EPLINK,LEVELINF,DVHEAD,GLAHOLES, %C
               CONSTL2,CONSTL4,CONSTL6,CONSTL8,RNEXT
!
! THIS IS THE LIMIT OF INITIALISATION OF SCALARS TO ZERO
!
         %INTEGER QUICK,MARGIN,IOCP1,IOCP2,IOCP3,XLABEL,IMPMON1, %C
               IMPMON2,IMPMON3,STMTSHELD,STOPSTM,TOPPTR,PREV3CL,FILEADDR
         %SHORTINTEGERARRAY STPTRS (1:15)
         %ROUTINESPEC FETCH AR
         %ROUTINESPEC STORE AR(%INTEGERNAME I)
         %INTEGERARRAY REGISTER,GRUSE,GRINF,GRAT(0:22)
         %SHORTINTEGERARRAY A(-7:800)
         %INTEGERARRAY SET(0:11)
         %SHORTINTEGERARRAY CYCLE,LABEL,SBR,L,M,NAMES(0:11)
         %SHORTINTEGERARRAY AVLWSP(0:7,0:MAXLEVELS)
         %INTEGERARRAY UVARREG(5:14)
         %RECORDFORMAT OPTFORM(%BYTEINTEGER COUNT,TYPE,%INTEGER BITS,%C
                  PTYPE,XTRA)
         %RECORDARRAY OPTINF(0:25)(OPTFORM)
         %INTEGER OPTPTR
         %BYTEINTEGERARRAY GLABUF,CODE(0:268)
         %SYSTEMINTEGERMAPSPEC COMREG(%INTEGER N)
         !*INSERT
         %BEGIN
         %SHORTROUTINE
         %INTEGER FREE,TOTAL
! BLOCK TO ALLOCATE AVAILABLE STACK SPACE TO THE MAIN ARRAYS
         FILE ADDR=COMREG(46)
         %IF FILE ADDR#0 %THEN %START;  ! ON EMAS
            TOTAL=INTEGER(FILEADDR); NNAMES=255
            %IF TOTAL>8000 %THEN NNAMES=511
            %IF TOTAL>32000 %THEN NNAMES=1023
            %IF TOTAL>409600 %OR COMREG(27)&8#0 %THEN NNAMES=2047
            DSIZE=7*NNAMES; ASL=DSIZE<<2
            CCSIZE=100+NNAMES; ->2
         %FINISH
         FREE=COMREG(1)-ADDR(TOTAL)-6000; ! ON IBM 370
         %CYCLE I=2,1,4;   ! ALLOWS 255,511,1023 OR 2047 NAMES
            NNAMES=128*2**I-1
            DSIZE=7*NNAMES
            ASL=DSIZE<<2
            CCSIZE=250+100*I
            TOTAL=CCSIZE+ASL+DSIZE<<1
            ->1 %IF TOTAL>FREE
         %REPEAT
         ->2
1:       CCSIZE=CCSIZE-100
         NNAMES=NNAMES>>1
         ASL=(ASL>>1+(FREE-CCSIZE-DSIZE))//2;! HALF 'EXTRA' SPACE TO ASL
         DSIZE=DSIZE>>1
2:       ASL=32760%IF ASL>32760
         ASL=ASL&X'FFFFFFF0'
         %END
        %BYTEINTEGERARRAY CC(0:CCSIZE+10), %C
            ASLIST(0:ASL+32),LETT(0:DSIZE+20)
         %SHORTINTEGERARRAY WORD,TAGS(0:NNAMES)
         %SYSTEMROUTINESPEC IOCP(%INTEGER A,B)
         %ROUTINESPEC CODE OUT
         %ROUTINESPEC CNOP(%INTEGER I,J)
         %ROUTINESPEC PCONST(%INTEGER X)
         %ROUTINESPEC PSI(%INTEGER OPCODE,J,BASE,DISP)
         %ROUTINESPEC PSS(%INTEGER OPCODE,N,BASE,DISP,P,Q)
         %ROUTINESPEC PRX(%INTEGER OPCODE,R1,R2,BASE,DISP)
         %ROUTINESPEC PLANT(%INTEGER VALUE)
         %ROUTINESPEC PRR (%INTEGER OPCODE,R1,R2)
         %ROUTINESPEC PGLA(%INTEGER I,J,K)
         %SYSTEMROUTINESPEC LPUT(%INTEGER A,B,C,D)
         %ROUTINESPEC SET PERMBASE
         %ROUTINESPEC PLUG(%INTEGER AREA,J,K)
         %ROUTINESPEC PRHEX(%INTEGER VALUE,PLACES)
         %ROUTINESPEC RESTORE(%SHORTINTEGER HEAD)
         %ROUTINESPEC GET ENV(%SHORTINTEGERNAME HEAD)
!         %INTEGERFNSPEC NEWCELL
         %ROUTINESPEC INSERTAFTER(%SHORTINTEGERNAME STAD,%INTEGER S1,S2)
!         %ROUTINESPEC INSERTATEND(%SHORTINTEGERNAME S,%INTEGER A,B)
         %ROUTINESPEC FROM12(%INTEGER CELL,%INTEGERNAME S1,S2)
         %ROUTINESPEC FROM123(%INTEGER CELL,%INTEGERNAME S1,S2,S3)
         %ROUTINESPEC POP(%SHORTINTEGERNAME CELL,%INTEGERNAME S1,S2)
         %ROUTINESPEC POP123(%SHORTINTEGERNAME C,%INTEGERNAME P,Q,R)
         %ROUTINESPEC PUSH(%SHORTINTEGERNAME CELL,%INTEGER S1,S2)
         %ROUTINESPEC PUSH123(%SHORTINTEGERNAME C,%INTEGER S1,S2,S3)
         %INTEGERFNSPEC FIND(%INTEGER LAB,LIST)
         %INTEGERFNSPEC FIND3(%INTEGER LAB,LIST)
         %ROUTINESPEC MLINK(%INTEGERNAME CELL)
         %ROUTINESPEC REPLACE2(%INTEGER CELL,S2)
         %ROUTINESPEC REPLACE1(%INTEGER CELL,S1)
         %ROUTINESPEC REPLACE123(%INTEGER CELL,S1,S2,S3)
         %INTEGERFNSPEC FROM2(%INTEGER CELL)
         %INTEGERFNSPEC FROM1(%INTEGER CELL)
         %INTEGERFNSPEC FROM3(%INTEGER CELL)
!         %ROUTINESPEC CHECK ASL
         !*DELSTART
         %ROUTINESPEC COMPARE
         %ROUTINESPEC PNAME
         %ROUTINESPEC CONST(%INTEGER MODE)
         %ROUTINESPEC CONSTLIST
         %ROUTINESPEC TEXTTEXT
         %ROUTINESPEC READ LINE(%BYTEINTEGER N,CHAR)
         !*DELEND
         %ROUTINESPEC FROMAR8(%INTEGER PTR,%LONGREALNAME VALUE)
         %ROUTINESPEC FROMAR4(%INTEGER PTR,%INTEGERNAME VALUE)
         %ROUTINESPEC TOAR8(%INTEGER PTR,%LONGREAL VALUE)
         %ROUTINESPEC TOAR4(%INTEGER PTR,VALUE)
         %ROUTINESPEC CSS(%INTEGER P,MODE)
         %ROUTINESPEC FAULT(%INTEGER N,FNAME)
          %ROUTINESPEC ABORT
         %ROUTINESPEC PRINT USE
         %ROUTINESPEC PRINTNAME (%INTEGER N)
%SYSTEM %C
         %ROUTINESPEC RECODE (%INTEGER START,FINISH,CA)
         %ROUTINESPEC MESSAGE(%INTEGER N)
         %FAULT 1,2->OFL,9->INEND,18->SUBSCHAR
 ! START OF COMPILATION
         %BEGIN
!***********************************************************************
!*       THIS BLOCK INITIALISE THE COMPILER SCALARS AND ARRAYS         *
!*       WAS ORIGINALLY ROUTINE 'INITIALISE'.                          *
!*       THE INITIALISATION OF THE CONSTANT LISTS WITH THE VALUES      *
!*       IN PERM MAY BE OMITTED IN BATCH OR CUT-DOWN VERSIONS.         *
!***********************************************************************
         %SHORTROUTINE
         !*DELSTART
         %CONSTBYTEINTEGERARRAY ILETT(0: 410)= 11,
    'S','E','L','E','C','T','I','N','P','U','T', 12,'S','E','L','E',
    'C','T','O','U','T','P','U','T',  7,'N','E','W','L','I','N','E',
      5,'S','P','A','C','E', 10,'S','K','I','P','S','Y','M','B','O',
    'L', 10,'R','E','A','D','S','T','R','I','N','G',  8,'N','E','W',
    'L','I','N','E','S',  6,'S','P','A','C','E','S', 10,'N','E','X',
    'T','S','Y','M','B','O','L', 11,'P','R','I','N','T','S','Y','M',
    'B','O','L', 10,'R','E','A','D','S','Y','M','B','O','L',  4,'R',
    'E','A','D',  5,'W','R','I','T','E',  7,'N','E','W','P','A','G',
    'E',  4,'A','D','D','R',  6,'A','R','C','S','I','N',  3,'I','N',
    'T',  5,'I','N','T','P','T',  6,'F','R','A','C','P','T',  5,'P',
    'R','I','N','T',  7,'P','R','I','N','T','F','L',  4,'R','E','A',
    'L',  7,'I','N','T','E','G','E','R',  3,'M','O','D',  6,'A','R',
    'C','C','O','S',  4,'S','Q','R','T',  3,'L','O','G',  3,'S','I',
    'N',  3,'C','O','S',  3,'T','A','N',  3,'E','X','P', 11,'C','L',
    'O','S','E','S','T','R','E','A','M', 11,'B','Y','T','E','I','N',
    'T','E','G','E','R', 12,'S','H','O','R','T','I','N','T','E','G',
    'E','R',  6,'R','A','D','I','U','S',  6,'A','R','C','T','A','N',
      6,'L','E','N','G','T','H', 11,'P','R','I','N','T','S','T','R',
    'I','N','G',  2,'N','L',  8,'L','O','N','G','R','E','A','L',  7,
    'P','R','I','N','T','C','H',  6,'R','E','A','D','C','H',  6,'S',
    'T','R','I','N','G',  8,'R','E','A','D','I','T','E','M',  8,'N',
    'E','X','T','I','T','E','M',  6,'C','H','A','R','N','O',  8,'T',
    'O','S','T','R','I','N','G', 10,'F','R','O','M','S','T','R','I',
    'N','G',  6,'R','E','C','O','R','D',  5,'A','R','R','A','Y', 10,
    'S','E','T','M','A','R','G','I','N','S',4,'I','M','O','D',
     2,'P','I',6,'N','E','X','T','C','H',255;
         !*DELEND
         *XC_CABUF(108),CABUF ;!CLEAR INTEGER
         *XC_FFLAG(24),FFLAG;          !CLEAR BYTE FLAG VARIABLES
         *XC_MASK(144),MASK;           ! CLEAR WORK VARIABLES
         STMTSHELD=0; TOPPTR=500
         IMAX=(-1)>>1;PLABEL=26999
         LABSET=3<<30;LETT(0)=0
         N0=27; N=12; MARGIN=1024
         MAX ULAB=NNAMES+16384;   ! LARGEST VALID USER LABEL
         GLACA=N0<<2; GLACABUF=GLACA
         CHECKSP=1 ;  CHECKS=1
         LINENOS=1; DIAGS1=1;  MONE=1
         LIST=1; SFLABEL=21999; UNASS=1
         LET=1; XLABEL=19999;      ! FOR EXIT STATEMENTS
         ARSIZE=480
          QUICK=11009
         MAINEP1=4; MAINEP2=M'S#GO';  ! DEFAULT ENTRY POINT
         IOCP1=6; IOCP2=M'S#IO'; IOCP3=M'CPXX'
         IMPMON1=8; IMPMON2=M'S#IM'; IMPMON3=M'PMON'
         !*INSERT
         %IF FILE ADDR#0 %THEN %START
           FILE PTR=FILE ADDR+INTEGER(FILE ADDR+4)
           FILE END=FILE ADDR+INTEGER(FILE ADDR)
         %FINISH
         I=COMREG(27)
         %IF I&2=2 %THEN LIST=0
         %IF I&4=4 %THEN LINENOS=0
         %IF I&16=16 %THEN UNASS=0
         %IF I&32=32  %THEN CHECKS=0
         %IF I&(128<<8)#0 %THEN PRINTMAP=1
         %IF I&(32<<8)#0 %THEN LET=0
         %IF I&64=64 %THEN DIAGS1=0
         DIAGS2=I>>18&1
         TTOPUT=I>>21&1
         %IF I&(1<<16)#0 %THEN %START
            CHECKS=0; CHECKSP=0
            LINENOS=0; UNASS=0
         %FINISH
         GLAFLAG=CHECKSP;           ! GLAFLAG SHOULD BE SET TO 0 IF
!                                     IMPS IS COMPILED NON OPTIMISED.
         WARNINGS(0)=0
         IMPS=I>>23&1;              ! BIT SET IF IMPS REQUESTED
!
! OPEN OBJECT FILE HERE BEFORE MORE PAGES OF COMPILER CODE
! ARE PAGED IN AND SUB-SYSTEM PAGES MOVE OUT
!
         LPUT(0,IMPS<<1+1,RELEASE,VERSION)
         NEWLINES(3); SPACES(20)
         %PRINTTEXT'E.R.C.C. IMP'
         %IF IMPS#0 %THEN %PRINTTEXT'S'
         %PRINTTEXT' COMPILER RELEASE'
         WRITE(RELEASE,1)
         %PRINTTEXT' VERSION'
         WRITE(VERSION,2)
         NEWLINES(3)
         WRITE(NNAMES,5); WRITE(ASL,5)
         *L_1,SET; *XC_0(48,1),0(1)
         *L_1,CYCLE;  *XC_0(24,1),0(1)
         *L_1,NAMES; *XC_0(24,1),0(1)
         *L_1,LABEL;  *XC_0(24,1),0(1)
         *L_1,SBR;    *XC_0(24,1),0(1)
         *L_1,AVL WSP; *XC_0(192,1),0(1)
         *L_1,REGISTER;  *XC_0(92,1),0(1)
         *L_1,GRUSE;     *XC_0(92,1),0(1)
         *L_1,GRINF;     *XC_0(92,1),0(1)
         *L_1,GRAT; *XC_0(92,1),0(1)
         REGISTER(10)=-1; GRUSE(10)=12
         REGISTER(11)=-1; REGISTER(13)=-1
         *L_1,UVARREG+4; *XC_0(40,1),0(1);!NO USER DEFINED REGS
         %CYCLE I=0,16,ASL-16
             SHORT INTEGER(ADDR(ASLIST(I))+30)=I
         %REPEAT
         INTEGER(ADDR(ASLIST(0)))=-1
         INTEGER(ADDR(ASLIST(4)))=-1
         INTEGER(ADDR(ASLIST(8)))=-1
         INTEGER(ADDR(ASLIST(12)))=X'FFFF0000'
         SET PERMBASE
         PCONST(X'50FB003C');          ! ST 15,60(11)
         PCONST(X'45FC004C');          ! BAL 15,RTI1
         %CYCLE I=0,1,NNAMES
             WORD(I)=0; TAGS(I)=0
         %REPEAT
!
! NOW DECLARE THE SPECIAL NAMES WHICH ARE IN ARRAY ILETT. A SPECIAL
! ALTERNATIVE (19) OF PHRASE <SS> IS PROVIDED FOR THIS PURPOSE
!
         !*DELSTART
         A(1)=19; K=0; NEXT=1
         I=ILETT(0)
         %WHILE I<255 %CYCLE
            %CYCLE J=1,1,I
                CC(J)=ILETT(K+J)
            %REPEAT; CC(J+1)=';'
            R=2; Q=ADDR(CC(1)); PNAME
            CSS(1,1); K=K+I+1; I=ILETT(K)
         %REPEAT
         !*DELEND
!
                  A(-7)=2; TOAR4(-6,PI1); TOAR4(-4,PI2)
         A(0)=0; A(1)=12; CSS(1,1);      ! COMPILE A BEGIN @ LINE 0
         COMREG(24)=16;                ! RETURN CODE
         %CYCLE I=1,1,3
             PUSH123(CONSTL4,I,0,X'800000E0'+I<<2)
             PUSH123(CONSTL4,I<<12,0,X'80000100'+I<<2)
         %REPEAT
         PUSH123(CONSTL4,-1,0,16)
         PUSH123(CONSTL4,255,0,24)
         PUSH123(CONSTL4,-4,0,X'800000F8')
         PUSH123(CONSTL4,-8,0,X'800000FC')
         PUSH123(CONSTL8,X'41100000',0,X'800000C8');! FLOATNG =D'1'
         DUMMY FORMAT=0;        ! DUMMY RECORD FORMAT
         PUSH(CONSTL6,0,0)
         PUSH123(DUMMY FORMAT,0,0,CONSTL6); ! FOR BETTER ERROR RECOVERY
         CONSTL6=0
         %END
!
        ->8
         %ROUTINE LOAD DATA
         %SHORTROUTINE
!***********************************************************************
!*       PASS INFORMATION TO LPUT TO ENABLE IT TO GENERATE THE         *
!*       LOADER DATA AND COMPLETE THE PROGRAM FILE.                    *
!***********************************************************************
         %INTEGER JJ,KK,FLAG,XTRA,ID1,ID2,ID3
         %SHORTINTEGER HEAD
         GLACA=(GLACA+7)&(-8)
         CONSTPTR=(CONSTPTR+7)&(-8)
!
! DEFINE ANY DATA EPS FOR DATA IN THE GLA SYMBOL TABLES. THESE CAN NOT
! BE DEFINED BEFORE THE SIZE OF THE GLA IS KNOWN
!
         %WHILE EPLINK#0 %CYCLE
            POP123(EPLINK,JJ,XTRA,KK)
            HEAD=KK; FLAG=JJ>>24; JJ=JJ&X'FFFFFF'
            JJ=JJ+GLACA
            POP123(HEAD,ID1,ID2,ID3)
            ID3=ID3<<16
            LPUT(14,XTRA,JJ,ADDR(ID1))
         %REPEAT
         CNOP(0,8)
         FIXED GLA(2)=GLACA;        ! GLA SYMTABS FROM HEAD OF GLA
         FIXED GLA(3)=CA;           ! CODE SYMTABS FROM HEAD OF CODE
         FIXED GLA(0)=CA;           ! WILL BE RELOCATED
         CODE OUT
         I=GLACA-GLACABUF
         %IF INHCODE=0 %THEN %START
            LPUT(2,I,GLACABUF,ADDR(GLABUF(0))) %UNLESS I=0;! BACK OF GLAP
!
! NOW SET THE LANGUAGE FLAG(BYTE 4 OF GLA) 1=IMP,3=IMPS
!
            BYTE INTEGER(ADDR(FIXED GLA(1)))=16+IMPS<<5;! LANGUAGE FLAG
            LPUT(2,N0<<2,0,ADDR(FIXED GLA(0)));     ! FRONT OF GLAP
            I=X'E2E2E2E2'
            LPUT(4,4,SSTL,ADDR(I))
!
! NOW PLANT ANY RELOCATION INFO THAT HAS BEEN HELD UP AS IT IS RELATIVE
! TO THE SYMBOL TABLES. LPUT DEALS ONLY IN CODE & GLA SO THE COMPILER
! HAS TO ADJUST ST REFEFERNCES TO ALLOW FOR FRONT OF CODE OR GLA
!
!            %WHILE RELHEAD#0 %CYCLE
!               POP123(RELHEAD,JJ,KK,XTRA)
!               %IF XTRA=4 %THEN %START;    ! CODE ST
!                  KK=KK+CA
!               %FINISH %ELSE %START;       ! GLA ST
!                  KK=KK+GLACA
!               %FINISH
!               LPUT(2,4,JJ,ADDR(KK));      ! OUTPUT ADJUSTED POINTER
!               LPUT(XTRA+16,0,JJ,0);       ! AND RELOCATION INFO
!            %REPEAT
!
            LPUT(20,0,0,0);                ! RELOCATE POINTER TO CST
            LPUT(20,0,28,0);               ! RELOCATE GLA  HDOFCODE WORD
            LPUT(12,0,23<<2,ADDR(FIXEDGLA(27)));! O-P PERM REFERENCE
            LPUT(16,0,64,0);               ! DEFINE TOPOFSTORE WORD
         %FINISH
         SSTL=(SSTL+11)&(-8)
         %PRINTTEXT'
CODE'
         WRITE(CA,6); %PRINTTEXT ' BYTES      GLAP'
         WRITE(GLACA,3); %PRINTTEXT'+'
         WRITE(CONSTPTR,1); %PRINTTEXT' BYTES      DIAG TABLES'
         WRITE(SSTL,3); %PRINTTEXT' BYTES
TOTAL'
         REGISTER(0)=CA; REGISTER(1)=GLACA
         REGISTER(2)=0
         REGISTER(3)=SSTL
         REGISTER(4)=CONSTPTR
         K=CA+GLACA+SSTL+CONSTPTR;REGISTER(5)=K
         WRITE(K,5); %PRINTTEXT' BYTES'
         %IF IMPS=0 %AND WARNINGS(0)>0 %START
            J=WARNINGS(0)
            PRINTSTRING("
THE FOLLOWING LINES ARE NOT ACCEPTABLE TO 2900 IMP:-")
            NEWLINE
            %CYCLE I=1,1,J
               WRITE(WARNINGS(I),3)
               %EXIT %IF I>=30
            %REPEAT
            NEWLINE
            %IF J>30 %THEN PRINTSTRING("PLUS ") %AND WRITE(J-30,3) %C
               %AND PRINTSTRING(" MORE
")
         %FINISH
         NEWLINE; PRINT CH(13);    ! MARKER FOR COMP TO PRINT SUMMARY
         %IF FAULTY=0 %THEN %START
            WRITE(STMTS,7); %PRINTTEXT' STATEMENTS COMPILED'
            %IF GLACA>4096 %THEN %PRINTTEXT'
WARNING:- GLAP ROOT IS GREATER THAN 4096 BYTES!
********
          OBJECT PROGRAM IS LIABLE TO BE VERY INEFFICIENT
'
           COMREG(47) = STMTS
         %FINISH %ELSE %START
            %PRINTTEXT'PROGRAM CONTAINS'; WRITE(FAULTY,2)
            %PRINTTEXT' FAULT';  PRINTSYMBOL('S') %IF FAULTY>1
            COMREG(47)=FAULTY;             ! FOR COMPER
         %FINISH
         NEWLINES(2)
         I=0; I=8 %IF FAULTY#0
         COMREG(24)=I
         %IF INHCODE=0 %THEN %C
         LPUT(7,24,0,ADDR(REGISTER(0)));! SUMMARY INFO..REGISTER AS BUF
         %STOP
         %END
         %ROUTINE     FAULT(%INTEGER N,FNAME)
         %SHORTROUTINE
         %INTEGER I,J,QP,FLINE
         %IF N=100 %THEN FLINE=LINE %ELSE FLINE=A(STPTRS(1)-1)
         QP=Q
         %PRINTTEXT'
*';      WRITE(FLINE,4)
         I=3; I=3*LEVEL %IF LIST=0; SPACES(I)
         CHECKSP=1; FAULTY=FAULTY+1
         INHCODE=1 %UNLESS LET=0;    ! STOP GENERATING CODE
         %IF N#100 %THEN %START;     ! ALL EXCEPT SYNTAX
            %PRINTTEXT'FAULT'; WRITE(N,2)
            MESSAGE(N)
            %IF N>100 %THEN %START
               %PRINTTEXT' DISASTER '
               ABORT %UNLESS N<=108; %STOP
            %FINISH
            PRINTNAME(FNAME) %UNLESS FNAME=0
         %FINISH %ELSE %START;       ! SYMTAX FAULTS
            %PRINTTEXT'  SYNTAX   '
            %IF LINE#OLDLINE %THEN %START
               %PRINTTEXT'
 TEXT MODE FAILURE '
               WRITE(LINE-OLDLINE,1)
               %PRINTTEXT' LINES LOST 
'
               Q=QMAX
            %FINISH %ELSE %START
               %UNTIL J=';' %OR Q=LENGTH %CYCLE
                  J=BYTE INTEGER(Q)
                  PRINT SYMBOL(J)
                  Q=Q+1
               %REPEAT
                %IF I+20+Q-QP<=120 %THEN %START
                  NEWLINE; SPACES(I+QMAX-QP+17)
                  %PRINTTEXT'!
'
               %FINISH
            %FINISH
         %FINISH
         %IF TTOPUT#0 %THEN %START
            Q=QP; TTOPUT=0
            SELECT OUTPUT(87)
            FAULT(N,FNAME)
            FAULTY=FAULTY-1
            NEWLINE
            SELECT OUTPUT(82)
            TTOPUT=1
         %FINISH
         %END

%ROUTINE WARN(%INTEGER LINE)
!***********************************************************************
!*       STORE A WARNING IF STMNT NOT 2900 IMP COMPATIBLE              *
!***********************************************************************
%INTEGER I,J
         I=WARNINGS(0); J=I+1
         %IF J>30 %THEN WARNINGS(0)=J %AND %RETURN
         %IF LINE>WARNINGS(I) %THEN WARNINGS(J)=LINE %AND %C
            WARNINGS(0)=J
%END
         %ROUTINE ABORT
         %PRINTTEXT'
****************      ABORT********************    ABORT    *******'
         RECODE(ADDR(CODE(0)),ADDR(CODE(PPCURR)),CABUF) %UNLESS CA=CABUF
         PRINT USE
         %MONITORSTOP; %END
%ROUTINE PRINT USE
%INTEGER I, J, K
%ROUTINESPEC USES(%INTEGER I)
%OWNSTRING (10) %ARRAY STATUS(-1:2)='  LOCKED  ',
         '   FREE   ',' CLAIMED  ',' RESERVED '
%INTEGER NNAMES
         *L_1,TAGS+8;  *MVC_NNAMES(4),8(1)
         NEWLINES(2)
         %CYCLE I=0, 1, 15
            ->9 %IF 10<=I<=13
            ->9 %IF REGISTER(I)=0 %AND GRUSE(I)=0 %AND (I>6 %C
               %OR (REGISTER(I+16)=0 %AND GRUSE(I+16)=0))
            WRITE(I, 2)
            PRINT STRING(STATUS(REGISTER(I)))
            USES(I)
            ->4 %IF I>6 %OR (REGISTER(I+16)=0=GRUSE(I+16))
            SPACES(13-K)
            PRINT STRING(STATUS(REGISTER(I+16)))
            USES(I+16)
4:          NEWLINE
9:       %REPEAT
         I=CCSTATE>>16
         %IF 1<=I<=2 %THEN %START
            %IF I=1 %THEN PRINTSTRING('ARITHMETIC CC ON REG') %C
               %ELSE PRINT STRING('LOGICAL CC ON REG')
            WRITE(CCSTATE&255, 5)
            NEWLINE
         %FINISH
         %RETURN
%ROUTINE PN(%INTEGER N)
%INTEGER J, P, Q, R
         %CYCLE J=0, 1, NNAMES
            ->FOUND %IF N=TAGS(J)
         %REPEAT;  %PRINTTEXT ' ??'
         K=K+3;  ->99
FOUND:   P=WORD(J);  R=LETT(P)
         %IF R#0 %THEN %START
            %CYCLE Q=1, 1, R
               PRINT SYMBOL(LETT(P+Q))
            %REPEAT
         %FINISH %ELSE %PRINTTEXT '?'
         K=K+1+R
99: %END
%ROUTINE USES(%INTEGER I)
%SWITCH SW(0:18)
%INTEGER INF, J
         %PRINTTEXT ' USE = '
         K=0;  J=GRUSE(I);  INF=GRINF(I)
         ->SW(J)
SW(0):   %PRINTTEXT ' NOT KNOWN';  ->99
SW(1):   %PRINTTEXT ' I/RESULT '
1:       K=7;  WRITE(INF, 6);  ->99
SW(2):   %PRINTTEXT ' CONST = ';  ->1
SW(3):   %PRINTTEXT '  LOCAL   '
2:       PN(INF);  ->99
SW(4):
SW(5):
SW(6):   %PRINTTEXT ' ERROR  ';  ->1
SW(7):   %PRINTTEXT ' ADDR OF  ';  ->2
SW(8):   %PRINTTEXT ' BASE OF  ';  ->2
SW(9):   PN(INF&X'FFFF')
         %PRINTTEXT ' TIMES ';  WRITE(INF>>24, 2);  ->99
SW(10):  %PRINTTEXT 'DOPE V OF ';  ->2
SW(11):  %IF INF>0 %THEN ->111
         %PRINTTEXT ' 4K FOR LAB '
         K=8;  WRITE(\INF, 6);  ->99
111:     %PRINTTEXT ' 4096 * ';  K=8;  WRITE(INF, 6);  ->99
SW(12):  %PRINTTEXT ' BASE AT  ';  ->1
SW(13):  %PRINTTEXT ' STR LEN  ';  ->1
SW(14):  %PRINTTEXT ' CYCLE VAR ';  ->99
SW(15):  %PRINTTEXT ' RT PARAM ';  ->99
SW(16):  %PRINTTEXT ' RSLN PARM ';  ->1
SW(17):  %PRINTTEXT ' ADDR SST ';  ->1
SW(18):  %PRINTTEXT ' PERMBASE ';  ->99
99: %END
%END


         %ROUTINE MESSAGE(%INTEGER N)
!***********************************************************************
!*       OUTPUTS AN ERROR MESSAGE STORED IN A COMPRESSED FORMAT        *
!***********************************************************************
         %CONSTBYTEINTEGERARRAY WORD(0: 330)=0,%C
            1,   1,   2,   3,   0,   2,   4,   5,
            7,   8,   4,   9,  10,  11,   7,   5,
            9,   4,  12,   0,   6,   9,   4,   7,
            8,   7,  10,   7,   8,   0,   8,  13,
           14,  11,  16,   9,  13,  14,  11,  16,
           10,  13,  14,  11,  16,  11,   4,  11,
            7,   0,  13,   1,  18,   0,   0,  14,
            2,   3,  20,   0,  15,  18,  20,   0,
            0,  16,  10,  11,   7,   0,  17,  11,
           21,  10,   0,  18,   9,  23,  12,   0,
           19,  24,  25,  26,  14,  20,   9,  10,
           27,  28,  22,  30,  14,  11,  16,  23,
           21,  10,  27,  28,  24,  31,  27,  32,
           28,  25,  34,  35,  11,  32,  26,  37,
           38,  24,  39,  28,  21,  40,  18,   0,
           29,  41,  11,  42,   0,  30,  44,  45,
           26,  46,  31,  48,  45,  26,  46,  34,
            2,   3,  49,   0,  35,   2,   3,  21,
           49,  36,  50,  37,  25,   0,  39,  31,
           52,   0,   0,  40,  23,  53,   0,   0,
           42,  55,  35,  27,  28,  43,  56,  57,
           45,   0,  44,  50,  58,   0,   0,  45,
           24,  25,  26,  58,  47,  50,  59,   0,
            0,  48,  60,  61,  27,  38,  51,  62,
            2,   3,   0,  52,   1,  18,  63,  62,
           53,  62,  18,   0,   0,  54,  64,  45,
           26,  46,  57,  65,  18,   0,   0,  62,
           11,  66,  10,   0,  64,  67,  18,   0,
            0,  65,  67,  11,  27,  66,  66,  50,
           69,  70,   0,  67,  11,  69,  10,   0,
           69,  67,  45,  26,  46,  70,  50,  55,
           23,   0,  71,  35,  27,  55,  28,  72,
           50,  55,  72,   0,  73,  74,  45,  26,
           46,  74,  74,  24,  66,   0,  81,  50,
           76,   0,   0,  82,  41,  11,  78,  10,
           83,  80,  76,   0,   0,  84,  50,  69,
           70,   0,  85,  81,   0,   0,   0,  98,
           84,   0,   0,   0,  99,  84,   0,   0,
            0, 103,  87,   2,  88,   0, 104,   2,
            3,  87,   0, 106,  55,  58,   2,  88,
          108,  89,  61,  27,  38, 127,  90,   0,
            0,   0
          %CONSTINTEGERARRAY LETT(0: 92)=0,%C
        X'48B02868',X'51EF0000',X'342EC800',X'30222B00',
        X'25D60B13',X'13EF9000',X'4CB40000',X'52E91940',
        X'4EE9A0D0',X'382D2800',X'39F40000',X'16527C80',
        X'19F26858',X'40320B4B',X'50B29800',X'067F9C0B',
        X'0C000000',X'35339A5D',X'1C000000',X'15C49800',
        X'49F5A25D',X'14000000',X'10A36380',X'5E4F71C0',
        X'39E00000',X'3CC00000',X'25C00000',X'171094E7',
        X'38000000',X'0474A858',X'48A16000',X'25D429CB',
        X'48000000',X'0F236140',X'58324845',X'30A00000',
        X'18356500',X'4E8D7500',X'30B62B00',X'09E4C800',
        X'31130000',X'10B3A3A9',X'38000000',X'48B4AC9C',
        X'3EB40000',X'0DEEA171',X'50000000',X'48B3AB28',
        X'30B62B26',X'258C29C3',X'30000000',X'17107500',
        X'35338303',X'0CA40000',X'4E924B8E',X'06520E40',
        X'25D3490A',X'0DEE9D00',X'15932800',X'4EA20000',
        X'0D019000',X'192E4CD0',X'06800000',X'1709A000',
        X'08A74B80',X'19F26868',X'4EA2705B',X'14000000',
        X'48A37C88',X'3E059069',X'38000000',X'3E059069',
        X'3E400000',X'48B37B2B',X'512F7000',X'16354D83',
        X'30AE1940',X'41E9750B',X'48000000',X'39EE0000',
        X'112D2BA7',X'25EE0B13',X'53200000',X'04849167',
        X'4C224B13',X'53200000',X'382D2CC0',X'31EE3800',
        X'15A00000',X'4CA5FA5B',X'43ED0BAB',X'05800000'
        
         %INTEGER I,J,K,M,Q,S
         %PRINTTEXT' ('
         I=-4
         %UNTIL N=WORD(I) %OR I= 326 %THEN I=I+5
         %CYCLE J=1,1,4
            K=WORD(I+J)
            %IF K=0 %THEN %EXIT
            SPACE %UNLESS J=1
            %UNTIL M&1=0 %CYCLE
               M=LETT(K); S=26
               %UNTIL S<0 %CYCLE
                  Q=M>>S&31; 
                  %IF Q=31 %THEN Q=-32
                  %IF Q\=0 %THEN PRINT SYMBOL(Q+64)
                  S=S-5
               %REPEAT
               K=K+1
            %REPEAT
         %REPEAT
         %PRINTTEXT') '
         %END
INEND:   FAULT(108,0)
OFL:     FAULT(38,0); ->8
SUBSCHAR:LINE=LINE+1;FAULT(48,0)
         SPACES(5)
15:      READSYMBOL(I); ->8 %IF I=10
         PRINTSYMBOL(I); ->15
         %ROUTINE PRINTNAME (%INTEGER N)
         %IF N<0 %THEN %START
            N=-N
            %IF 16384<=N<=MAX ULAB %THEN N=N-16384 %ELSE %START
               WRITE(N,5); ->99
            %FINISH
       %FINISH
         %PRINTTEXT' '
         **1,WORD(N)
         *A_1,LETT; *->P5;             ! USE PRINTSTRING IN PERM
99:      %END
!
!***********************************************************************
!*       IMP CODE PLANTING ROUTINES                                    *
!*       CODE AND GLAP ARE PUT INTO THE BUFFERS 'CODE,GLABUF(0:268)'   *
!*       BY A NUMBER OF TRIVIAL ROUTINES.LPUT IS CALLED TO ADD THE     *
!*       BUFFER TO THE OUTPUT FILE. THE BUFFERS ARE BASICALLY 0:255    *
!*       WITH A 12-BYTE MARGIN TO MINIMISE THE NUMBER OF TESTS FOR     *
!*       THE BUFFER FULL CONDITION                                     *
!*                                                                     *
!*       PPCURR(GLACURR) IS THE BUFFER POINTER                         *
!*       CA(GLACA)  IS THE RELATIVE ADDRESS OF THE NEXT BYTE           *
!*       CABUF(GLACABUF) IS CA(GLACA) FOR START OF BUFFER              *
!***********************************************************************
         %ROUTINE CODEOUT
         %IF PPCURR>0 %THEN %START
            %IF DCOMP#0 %THEN %C
               RECODE(ADDR(CODE(0)),ADDR(CODE(PPCURR)),CABUF)
            LPUT(1,PPCURR,CABUF,ADDR(CODE(0))) %IF INHCODE=0
            PPCURR=0; CABUF=CA
         %FINISH
         %END
         %ROUTINE PLANT(%INTEGER HALFWORD)
!        ADD A HALF WORD OF BINARY TO THE BUFFER
         SHORT INTEGER(ADDR(CODE(PPCURR)))<-HALFWORD
         PPCURR=PPCURR+2
         CA=CA+2
         CODEOUT %IF PPCURR>=256
         %END
         %ROUTINE PCONST(%INTEGER WORD)
!        ADD A WORD OF BINARY TO THE BUFFER
         **1,ADDR(CODE(PPCURR))
         *MVC_0(4,1),WORD
         PPCURR=PPCURR+4
         CA=CA+4
         CODEOUT %IF PPCURR>=256
         %END
         %ROUTINE PRR(%INTEGER OPCODE,R1,R2)
         CODE(PPCURR)=OPCODE
         CODE(PPCURR+1)=R1<<4!R2
         PPCURR=PPCURR+2
         CA=CA+2
         CODEOUT %IF PPCURR>=256
         %END
         %ROUTINE MOVE BACK PC
         %IF LCA<CABUF %THEN CABUF=LCA %AND PPCURR=0 %ELSE %C
            PPCURR=PPCURR-CA+LCA
         CA=LCA
         %END
         %ROUTINE PRX(%INTEGER OPCODE,R1,R2,B,D)
         %SHORTROUTINE
         %OWNINTEGER LR1,LR2,LB,LD
         %IF CHECKSP=0 %THEN %START
            %IF OPCODE=X'58' %OR OPCODE=X'50' %THEN %START
               %IF LCA+4=CA %AND LB=B %AND R2=0 %AND %C
                  ((LOPCODE=OPCODE %AND (LR1+1)&15=R1 %AND LR2=0 %AND %C
                  D=LD+4) %OR (LOPCODE=OPCODE+X'40' %AND %C
                  (LR2+1)&15=R1 %AND D=LD+((R1-LR1)&15)*4)) %START
                  %IF DCOMP#0 %THEN %PRINTTEXT'** LOADS COMBINED **'
                  MOVE BACK PC
                  CSAVED=CSAVED+4
                  PRX(X'90'+OPCODE&15,LR1,R1,LB,LD)
                  %RETURN
               %FINISH
            %FINISH
            LCA=CA; LR1=R1; LR2=R2
            LB=B; LD=D; LOPCODE=OPCODE
         %FINISH
         CODE(PPCURR)=OPCODE
         CODE(PPCURR+1)=R1<<4!R2
         SHORT INTEGER(ADDR(CODE(PPCURR+2)))<- B<<12!D
         PPCURR=PPCURR+4
         CA=CA+4
         CODEOUT %IF PPCURR>=256
         %END
         %ROUTINE PSI(%INTEGER OPCODE,J,B,D)
         CODE(PPCURR)=OPCODE
         CODE(PPCURR+1)=J
         SHORT INTEGER(ADDR(CODE(PPCURR+2)))<- B<<12!D
         PPCURR=PPCURR+4
         CA=CA+4
         CODEOUT %IF PPCURR>=256
         %END
         %ROUTINE PSS(%INTEGER OPCODE,N,B1,D1,B2,D2)
         CODE(PPCURR)=OPCODE
         N=N-1 %UNLESS N=0
         CODE(PPCURR+1)=N
         SHORT INTEGER(ADDR(CODE(PPCURR+2)))<- B1<<12!D1
         SHORT INTEGER(ADDR(CODE(PPCURR+4)))<- B2<<12!D2
         PPCURR=PPCURR+6
         CA=CA+6
         CODEOUT %IF PPCURR>=256
         %END
         %ROUTINE PMVC(%INTEGER L,B1,D1,B2,D2)
         %SHORTROUTINE
!***********************************************************************
!*         PLANTS AN MVC INSTRN. IN OPTIMISING MODE TRIES TO GLUE IT   *
!*         ON TO THE LAST ONE PLANTED                                  *
!***********************************************************************
         %OWNINTEGER LL,LB1,LD1,LB2,LD2
         %IF CHECKSP#1 %THEN %START
            %IF LCA+6=CA %AND B1=LB1 %AND B2=LB2 %AND LOPCODE=X'D2' %C
                %AND D1=LD1+LL %AND D2=LD2+LL %AND LL+L<=256 %START
               MOVE BACK PC
               CA=LCA; L=L+LL
               D1=LD1; D2=LD2
            %FINISH
            LCA=CA; LL=L; LB1=B1; LD1=D1
            LB2=B2; LD2=D2; LOPCODE=X'D2'
         %FINISH
         PSS(X'D2',L,B1,D1,B2,D2)
         %END
         %ROUTINE     CNOP(%INTEGER I,J)
         PLANT(X'0700') %WHILE CA&(J-1)#I
         %END
         %ROUTINE PGLA(%INTEGER BDRY,L,INF ADR)
         %SHORTROUTINE
         %INTEGER I,J
         J=GLACA; GLACA=(J+BDRY-1)&(-BDRY)
         GLACURR=GLACURR+GLACA-J;      ! COMPLETE THE ROUNDING
!
! RECORD HOLES IN THE GLA FOR FUTURE USE
!
         %IF J&1#0 %THEN J=J+1
         %WHILE J+2<=GLACA %CYCLE
            PUSH(GLAHOLES,J,0)
            J=J+2
         %REPEAT
         %IF L+GLACURR>256 %THEN %START
            %IF INHCODE=0 %THEN LPUT(2,GLACURR,GLACABUF,ADDR(GLABUF(0)))
            GLACA=(GLACA+1)&(-2)
            GLACURR=0; GLACABUF=GLACA
         %FINISH
         *LM_1,2,L; *L_3,GLABUF
         *A_3,GLACURR; *BCTR_1,0
         *EX_1,<MOVE>
         GLACA=GLACA+L; GLACURR=GLACURR+L
         %RETURN
MOVE:    *MVC_0(1,3),0(2)
         %END
         %ROUTINE     PLUG(%INTEGER AREA,AT,VALUE)
         %SHORTROUTINE
!***********************************************************************
!*       WRITE ONE HALFWORD INTO OBJECT FILE OUT OF SEQUENCE           *
!***********************************************************************
         %INTEGERNAME WCABUF
         %INTEGER RELAD,BUFAD
         WCABUF==CABUF; BUFAD=ADDR(CODE(0))
         %IF AREA=2 %THEN WCABUF==GLACABUF %AND BUFAD=ADDR(GLABUF(0))
         RELAD=AT-WCABUF
         %IF RELAD>=0 %THEN SHORTINTEGER(RELAD+BUFAD)<-VALUE %ELSESTART
            %IF INHCODE=0 %THEN LPUT(AREA,2,AT,ADDR(VALUE)+2)
         %FINISH
         %END
         %ROUTINE SET PERMBASE
         PCONST(X'58CD005C')
         REGISTER(12)=-1
         GRUSE(12)=18
         GRINF(12)=0
         %END
         %ROUTINE     PRHEX(%INTEGER VALUE,PLACES)
         %OWNINTEGER HT1=M'0123'
         %OWNINTEGER HT2=M'4567'
         %OWNINTEGER HT3=M'89AB'
         %OWNINTEGER HT4=M'CDEF'
         %INTEGER W1,W2,W3
         *UNPK_W1+1(9),VALUE(5)
         *NC_W1+1(8),MASK1
         *TR_W1+1(8),HT1
         *LA_1,W1+8; *S_1,PLACES
         *MVC_ 0(1,1),PLACES+3
         *-> P5;                       ! PRINT STRING IN PERM
         %END
         %ROUTINE GET ENV(%SHORTINTEGERNAME HEAD)
         %SHORTROUTINE
!***********************************************************************
!*       SAVE A COPY OF THE REGISTER STATE FOR FUTURE REFERENCE        *
!***********************************************************************
         %INTEGER I,J
         %CYCLE J=0,1,14; I=GRMAP(J)
            PUSH123(HEAD,GRINF(I),GRAT(I),I<<8!GRUSE(I)) %IF GRUSE(I)>1
         %REPEAT
         %END
         %ROUTINE RESTORE(%SHORTINTEGER HEAD)
         %SHORTROUTINE
!***********************************************************************
!*       RESET THE REGISTERS TO ENVIRONMENT IN LIST HEADED BY 'HEAD'   *
!***********************************************************************
         %INTEGER I,J,R,USE,INF,AT
         CCSTATE=-1
         %CYCLE J=0,1,14; I=GRMAP(J)
            %IF REGISTER(I)>=0 %THEN GRUSE(I)=0 %AND GRINF(I)=0
         %REPEAT
         %WHILE HEAD#0 %CYCLE
            POP123(HEAD,INF,AT,I)
            R=I>>8
            %IF REGISTER(R)>=0 %THEN GRUSE(R)=I&255 %AND GRINF(R)=INF
            GRAT(R)=AT
         %REPEAT
         %END
!         %ROUTINE PRINT LIST(%INTEGER HEAD)
!         %SHORTROUTINE
!         %INTEGER I,J,K
!1:       %IF HEAD=0 %THEN %RETURN
!         FROM123(HEAD,I,J,K)
!         NEWLINE
!         PRHEX(I,8)
!         SPACES(3)
!         PRHEX(J,8)
!         SPACES(3)
!         PRHEX(K,8)
!         NEWLINE
!         MLINK(HEAD)
!         ->1
!         %END
!
! ******* LIST***PROCESSING***ROUTINES
! NEW VERSIONS BASED ON A 96BIT(12 BYTE) UNIT
! S1=S2=32 BIT STREAM, S3=16 BIT STREAM
!
!         %ROUTINE CHECK ASL
!! CHECK ASL FOR CONSISTENCY AND PRINT OUT FREE CELLS
!! FOR DEBUGGING OBSCURE LIST PROCESSING FAULTS ONLY
!         %SHORTROUTINE
!         %INTEGER N,Q
!         N=0
!          Q=ASL
!1:       ->2 %IF Q=0
!         ABORT %UNLESS Q&3=0
!          MLINK(Q)
!          N=N+1
!          ->1
!2:         %PRINTTEXT' FREE CELLS='
!          WRITE(N,3)
!         NEWLINE
!           %END
!
!         %INTEGERFN NEW CELL
!         %INTEGER I
!         *L_1,ASL
!         *LTR_2,1
!         *BC_7,<1>
!         FAULT(107,0)
!1:       *A_2,ASLIST
!         *MVC_ASL+2(2),14(2);         !ASL TO NEXT FREE CELL
!         *XC_0(16,2),0(2);                  ! NEWCELL TO ZERO
!         *LM_4,15,16(8)
!         *BCR_15,15
!         %END
         %ROUTINE PUSH(%SHORTINTEGERNAME CELL,%INTEGER S1,S2)
         *L_4,ASL; *LTR_5,4; *BC_7,<1>
         FAULT(107,0)
1:       *A_5,ASLIST; *MVC_ASL+2(2),14(5)
         *LM_15,1,CELL; *LH_3,0(15); *SR_2,2
         *STH_4,0(15); *STM_0,3,0(5)
         %END
         %ROUTINE PUSH123(%SHORTINTEGERNAME CELL,%INTEGER S1,S2,S3)
         *L_4,ASL; *LTR_5,4; *BC_7,<1>
         FAULT(107,0)
1:       *A_5,ASLIST; *MVC_ASL+2(2),14(5)
         *LM_15,2,CELL; *LH_3,0(15)
         *STH_4,0(15); *STM_0,3,0(5)
         %END
         %ROUTINE POP(%SHORTINTEGERNAME CELL,%INTEGERNAME S1,S2)
         *LM_1,3,CELL; *LH_4,0(1); *L_15,ASLIST
         *L_0,0(4,15); *ST_0,0(2);       ! SET S1
         *L_0,4(4,15); *ST_0,0(3);       ! SET S2
         *LTR_4,4; *BC_8,<1>;             ! HEAD =0 FOR NULL LIST
         *LH_0,14(4,15); *STH_0,0(1);    ! HEADCELL TO OLD 2ND CELL
         *L_3,ASL; *STH_3,14(4,15); *ST_4,ASL
1:       %END
         %ROUTINE POP123(%SHORTINTEGERNAME CELL,%C
         %INTEGERNAME S1,S2,S3)

         *LM_1,3,CELL; *LH_4,0(1); *L_15,ASLIST
         *L_0,0(4,15); *ST_0,0(2);       ! SET S1
         *L_0,4(4,15); *ST_0,0(3);       ! SET S2
         *L_0,8(4,15); *L_3,S3; *ST_0,0(3); ! SET S3
         *LTR_4,4; *BC_8,<1>;             ! HEAD =0 FOR NULL LIST
         *LH_0,14(4,15); *STH_0,0(1);    ! HEADCELL TO OLD 2ND CELL
         *L_3,ASL; *STH_3,14(4,15); *ST_4,ASL
1:       %END
         %ROUTINE INSERT AFTER(%SHORTINTEGERNAME CELL,%INTEGER S1,S2)
         *L_1,ASL; *LTR_2,1; *BC_7,<2>
         FAULT(107,0)
2:       *A_2,ASLIST; *MVC_ASL+2(2),14(2)
         *SR_0,0; *ST_0,12(2); *ST_0,8(2)
         *L_2,ASLIST;*LM_3,4,S1;*ST_3,0(1,2);*ST_4,4(1,2)
         *L_4,CELL; *LH_3,0(4); *STH_1,0(4)
         *LTR_3,3;*BC_8,<1>;*LH_4,14(3,2)
         *STH_4,14(1,2); *STH_1,14(3,2)
1:       %END

%ROUTINE BINSERT(%SHORTINTEGERNAME TOP,BOT,%INTEGER S1,S2,S3)
!***********************************************************************
!*       ADD A NEWCELL AT THE BOTTOM OF A LIST                         *
!***********************************************************************
         *LM_14,2,TOP; *L_3,ASL
         *LTR_4,3; *BC_7,<1>
         FAULT(107,0)
1:       *L_5,ASLIST; *LH_6,14(3,5); *ST_6,ASL
         *LH_6,0(15); *LTR_6,6; *BC_7,<2>; ! IS BOT 0 ?
         *STH_3,0(14); *BC_15,<3>;      ! YES SET TOP =NEWCELL
2:       *STH_3,14(6,5);                ! LINK NEWCELL TO PREV BOT
3:       *STH_3,0(15);                  ! BOT =NEWCELL
         *SR_3,3; *AR_4,5
         *STM_0,3,0(4)
%END
         %ROUTINE     REPLACE123(%INTEGER CELL,S1,S2,S3)
         *LM_15,2,CELL;*A_15,ASLIST
         *STM_0,2,0(15)
         *LM_8,15,32(8); *BCR_15,15
         %END
         %ROUTINE     REPLACE1(%INTEGER CELL,S1)
         INTEGER(ADDR(ASLIST(CELL)))=S1
         %END
         %ROUTINE     REPLACE2(%INTEGER CELL,S2)
         INTEGER(ADDR(ASLIST(CELL+4)))=S2
         %END
         %ROUTINE     REPLACE3(%INTEGER CELL,S3)
         INTEGER(ADDR(ASLIST(CELL+8)))=S3
         %END
         %ROUTINE     MLINK(%INTEGERNAME CELL)
         CELL=SHORTINTEGER(ADDR(ASLIST(CELL+14)))
         %END
         %INTEGERFN     FIND(%INTEGER LAB,LIST)
! THIS FUNCTION SEARCHES LIST 'LIST' FOR LAB IN STREAM2 AND
! RETURNS THE CORRESPONDING CELL NO.IT USED FOR MORE THAN
! SCANNING LABEL LISTS.
         %MCODE
         *LM_0,1,LAB; *L_2,ASLIST
         *LTR_15,1; *BC_8,<FAIL>
AGAIN:   *C_0,4(1,2);
         *BC_8,<FOUND>
         *LH_1,14(1,2)
         *LTR_15,1
         *BC_7,<AGAIN>
FAIL:    *L_1,0(15,2);                  ! IF FAIL LOADS-1 ELSE RESULT
FOUND:   *LM_8,15,32(8); *BCR_15,15
         %ENDOFMCODE
         %END
         %INTEGERFN FIND3(%INTEGER S3,LIST)
!***********************************************************************
!*       SEARCHES LIST FOR S3 IN STREAM 3                              *
!*       RETURNS CELL NO AS RESULT                                     *
!***********************************************************************
         *LM_0,1,S3; *L_2,ASLIST; *SR_3,3
         *LTR_1,1; *BC_8,<FAIL>
AGAIN:   *C_0,8(1,2)
         *BC_8,<FOUND>
         *LR_3,1;                       ! SAVE PREVIOUS CELL
         *LH_1,14(1,2)
         *LTR_1,1
         *BC_7,<AGAIN>
FAIL:    *BCTR_1,0
FOUND:   *ST_3,PREV3CL;
         *LM_8,15,32(8); *BCR_15,15
         %END
         %ROUTINE FROM123(%INTEGER CELL,%INTEGERNAME S1,S2,S3)
        *LM_1,4,CELL; *A_1,ASLIST;
         *LM_15,1,0(1); * ST_15,0(2)
         *ST_ 0,0(3); *ST_1,0(4)
         *LM_8,15,32(8); *BCR_15,15
         %END
         %ROUTINE FROM12(%INTEGER CELL,%INTEGERNAME S1,S2)
         *LM_1,3,CELL ;*A_1,ASLIST ;
         *LM_0,1,0(1); *ST_0,0(2); *ST_1,0(3)
         %END
         %INTEGERFN     FROM1(%INTEGER CELL)
         %RESULT=INTEGER(ADDR(ASLIST(CELL)))
         %END
         %INTEGERFN     FROM2(%INTEGER CELL)
         %RESULT=INTEGER(ADDR(ASLIST(CELL))+4)
         %END
         %INTEGERFN FROM3(%INTEGER CELL)
         %RESULT=INTEGER(ADDR(ASLIST(CELL))+8)
        %END
         %ROUTINE CLEAR LIST (%SHORTINTEGERNAME OPHEAD)
         **1,OPHEAD; *LTR_1,1; *BC_8,<EMPTY>
         *L_2,ASLIST; *L_0,ASL; *ST_1,ASL
AGAIN:  *LR_3,1; *LH_1,14(1,2);         ! NEXT LINK
         *LTR_1,1; *BC_7,<AGAIN>;       ! IS IT ZERO?
         *STH_0,14(3,2);                ! LAST LINK TO OLD VALUE OF ASL
EMPTY:   OPHEAD=0;
         %END
!         %ROUTINE CONCAT(%SHORTINTEGERNAME LIST1,LIST2)
!         %COMMENT ADDS LIST2 TO BOTTOM OF LIST1
!         *L_4,LIST1
!         *L_15,LIST2
!         *LH_0,0(15)
!         *L_2,ASLIST
!         *LH_1,0(4)
!         *LTR_3,1
!         *BC_7,<ON>
!         *STH_0,0(4)
!         *BC_15,<COMM>
!ON:      *LR_3,1
!         *LH_1,14(3,2);                 ! NEXT LINK
!         *LTR_1,1
!         *BC_7,<ON>
!         *STH_0,14(3,2);                ! LAST LINK TO NEW LIST
!COMM:    *STH_1,0(15);                  ! ZERO HEAD OF LIST2 IN CASE
!         %END;                          ! AN ERROR PUTS CELL TWICE ONTO
                                       ! FREE LIST - CATASTROPHIC!
!         %ROUTINE INSERT AT END(%SHORTINTEGERNAME CELL,%INTEGER S1,S2)
!         %SHORTROUTINE
!!***********************************************************************
!!*       ADD A CELL TO THE BOTTOM OF THE LIST HEADED BY 'CELL'         *
!!***********************************************************************
!         *L_1,ASL
!         *LTR_2,1
!         *BC_7,<1>
!         FAULT(107,0)
!1:       *A_2,ASLIST
!         *MVC_ASL+2(2),14(2)
!         *SR_0,0
!         *ST_0,12(2)
!         *L_2,ASLIST
!         *L_4,CELL
!         *LH_3,0(4);                 ! GET HEAD CELL
!         *LTR_3,3
!         *BC_7,<ON>;                 ! LIST NOT EMPTY
!         *STH_1,0(4)
!         *BC_15,<LOAD>;               ! EMPTY LIST -- CELL TO TOP
!ON:      *LR_4,3
!         *LH_3,14(2,4);               ! IS NEXT CELL THE BOTTOM??
!         *LTR_3,3
!         *BC_7,<ON>
!         *STH_1,14(2,4)
!LOAD:    *AR_1,2
!         *MVC_0(8,1),S1
!         %END
! ************END****OF****LIST****PROCESSING ROUTINES
         %ROUTINE CSS(%INTEGER PIN,CSSMODE)
         %ROUTINESPEC CIOCP(%INTEGER N)
         %ROUTINESPEC DEFINE EP(%INTEGER A,B,C,D)
         %ROUTINESPEC LAB LOOK(%INTEGERNAME A,%INTEGER B)
         %ROUTINESPEC SET LOCAL BASE
         %ROUTINESPEC STRINGOP(%INTEGER Z,L,BTO,DTO,BFRM,DFRM,BML,DML,X)
         %ROUTINESPEC CEND(%INTEGER KKK)
         %ROUTINESPEC CBPAIR(%INTEGERNAME LB,UB)
         %ROUTINESPEC CCOND(%INTEGER IU,FARLAB)
         %ROUTINESPEC SET LINE
         %ROUTINESPEC CUI(%INTEGER CODE)
         %ROUTINESPEC CSTART(%INTEGER CODE)
         %ROUTINESPEC BULKM(%INTEGER A,B,C,D,E,F)
         %ROUTINESPEC TORP(%SHORTINTEGERNAME H,B,NOPS,%INTEGER MODE)
         %ROUTINESPEC SET USE(%INTEGER R,U,I)
         %ROUTINESPEC CSEXP(%INTEGER REG,MODE)
         %ROUTINESPEC DSEXP(%INTEGER REG,MODE)
         %ROUTINESPEC FREE AND FORGET(%INTEGER REG)
         %ROUTINESPEC SAVE IRS(%INTEGER MODE)
         %ROUTINESPEC BOOT OUT(%INTEGER MODE)
         %ROUTINESPEC EXPOP(%INTEGER A,B,C,D)
         %ROUTINESPEC CSTREXP(%INTEGER MODE,REG)
         %ROUTINESPEC ASSIGN (%INTEGER P1,P2)
         %INTEGERFNSPEC COPY RECORD TAG(%INTEGERNAME SUBS)
         %ROUTINESPEC  TEST APP(%INTEGERNAME NUM)
         %INTEGERFNSPEC DISPLACEMENT(%INTEGER LINK)
          %ROUTINESPEC SKIP APP
         %ROUTINESPEC CRFORMAT(%SHORTINTEGERNAME HEAD)
         %INTEGERFNSPEC DOPE VECTOR(%INTEGER A,B,C)
         %ROUTINESPEC DECLARE ARRAYS(%INTEGER MODE,XTRA)
         %ROUTINESPEC DECLARE SCALARS(%INTEGER A,B)
         %ROUTINESPEC CQN(%INTEGER P)
         %ROUTINESPEC CLT
         %ROUTINESPEC MOVE R(%INTEGER R,N)
         %ROUTINESPEC GET WSP(%INTEGERNAME PLACE,%INTEGER SIZE)
         %ROUTINESPEC RETURN WSP(%INTEGER PLACE,SIZE)
         %ROUTINESPEC CRCALL(%INTEGER A)
         %ROUTINESPEC CNAME(%INTEGER Z,REG)
         %ROUTINESPEC CRNAME(%INTEGER Z,REG,MODE,CLINK,BS,IX,DP)
         %ROUTINESPEC CANAME(%INTEGER Z,BS,DP,LINK)
         %ROUTINESPEC ADJUST INDEX(%INTEGER M,%INTEGERNAME I,D)
         %ROUTINESPEC CREATE AH(%INTEGER M,R,B,D)
         %ROUTINESPEC CRES(%INTEGER LAB)
         %ROUTINESPEC CSNAME(%INTEGER Z,REG)
         %ROUTINESPEC COPY TAG(%INTEGER KK)
         %ROUTINESPEC REDUCE TAG(%INTEGER MODE)
         %ROUTINESPEC REPLACE TAG (%INTEGER KK)
         %ROUTINESPEC RT EXIT
         %ROUTINESPEC RT JUMP(%INTEGER CODE,R1,RT,WKREG)
         %ROUTINESPEC MERGE INFO
         %ROUTINESPEC REDUCE ENV(%SHORTINTEGERNAME HEAD)
         %ROUTINESPEC RELOCATE(%INTEGER A,B,C)
         %ROUTINESPEC GXREF(%INTEGER A,B,C,D)
         %ROUTINESPEC CXREF(%INTEGER A,B,C,%INTEGERNAME D)
         %ROUTINESPEC STORE TAG(%INTEGER KK,SLINK)
         %ROUTINESPEC TESTNST
         %ROUTINESPEC CUCI
         %ROUTINESPEC SKIP EXP
         %ROUTINESPEC UNPACK
         %ROUTINESPEC PACK(%INTEGERNAME PTYPE)
         %ROUTINESPEC CRSPEC (%INTEGER M)
         %ROUTINESPEC LOAD DV(%INTEGERNAME REG,%INTEGER B,D,T)
         %ROUTINESPEC DUMP(%INTEGER CODE,REG,DIS,X,LEVEL)
         %ROUTINESPEC DUMPM(%INTEGER OPCODE,R1,R2,B,D)
         %ROUTINESPEC DUMPSI(%INTEGER OPCODE,L,B,D)
         %ROUTINESPEC DUMPSS(%INTEGER OP,L,B,D,B,D)
         %ROUTINESPEC RHEAD(%INTEGER KK)
         %ROUTINESPEC ENTER JUMP(%INTEGER MASK,STAD,FLAG)
         %ROUTINESPEC CFPDEL
         %ROUTINESPEC PPJ(%INTEGER N)
         %ROUTINESPEC ENTER LAB(%INTEGER M,FLAG)
         %ROUTINESPEC CHECK CAPACITY(%INTEGER REG,DIS,X,LEVEL)
         %INTEGERFNSPEC TSEXP(%INTEGERNAME CODE,%INTEGER I)
         %ROUTINESPEC FIND USE(%INTEGERNAME REG,%INTEGER TYPE,USE,INF)
         %ROUTINESPEC CLAIM THIS REG(%INTEGER A)
         %ROUTINESPEC CLAIM(%INTEGER A,%INTEGERNAME REG)
         %ROUTINESPEC FIND REG (%INTEGER A,%INTEGERNAME REG)
         %ROUTINESPEC FORGET(%INTEGER REG)
         %ROUTINESPEC FORGETM(%INTEGER UPPER)
         %ROUTINESPEC FIND SEQ(%INTEGERNAME ONE,TWO)
         %ROUTINESPEC REMEMBER
         %INTEGERFNSPEC CONST FIND (%INTEGER L,AD)
         %ROUTINESPEC STORE CONST(%INTEGERNAME B,D,%INTEGER L,AD)
         %ROUTINESPEC NOTE ASSMENT(%INTEGER REG,ASSOP,VAR)
         %ROUTINESPEC TEXTOUT(%INTEGER REG)
         %ROUTINESPEC VALLOC(%INTEGER A,B)
         %ROUTINESPEC VDALLOC(%INTEGER A,B)
         %ROUTINESPEC CYCOPT(%INTEGERNAME FLAG,%INTEGER WU)
         %ROUTINESPEC EXTRA PASS(%INTEGER I,J,K)
         %ROUTINESPEC CYC RESTORE
         %SWITCH SW(1:30)
         %RECORDFORMAT RD(%SHORTINTEGER PTYPE,%BYTEINTEGER XB,FLAG,%C
         %INTEGER D,%SHORTINTEGER XTRA)
         %SHORTINTEGER OPHEAD,SFHEAD,TWSPHEAD,DUMHEAD,SNDISP,ACC,K,KFORM
         %INTEGER BXLE,TCELL,CURRINST,ADISP,BIMSTR,JJ,JJJ,KK,KKK, %C
               Q,QQ,EXTRN,STARTCOND,MARKIU,MARKUI,MARKC,MARKE,MARKR, %C
               BASE,INDEX,DISP,VALUE,BML,DML,LOCAL BASE, LOCAL ADDR, %C
               PTYPE,I,J,OLDI,USEBITS,SENOPS,SEFOP,PTYPEP,STRINGL,LINE
         %BYTEINTEGER ROUT,NAM,ARR,PREC,TYPE,REPORTUI
         %REGISTER P(14); P=PIN
         %INTEGERARRAY SGRUSE,SGRINF(0:22)
         %CONSTINTEGER WSPTRTAB1=X'00010204',WSPTRTAB2= X'04060607'
         LINE=A(P-1)
         LOCAL BASE=0; TWSPHEAD=0
         STARTCOND=0; CURRINST=0
         CYC BITS=0; BIMSTR=0
         SENOPS=0; SEFOP=0
!
! CHECK THERE ARE SOME CELLS LEFT ON THE AVAILABLE SPACE LIST
!
         %IF ASL<200 %AND CSSMODE#0 %THEN %START;! GARBAGE COLLECT NEEDED
            %IF PRINTMAP=1 %THEN %PRINTTEXT'
?      LIST SPACE'
            %IF ASL<200 %THEN %START; ! STILL SHORT OF SPACE
               %PRINTTEXT'?'
               CLEAR LIST(DVHEAD);    ! REMOVE LIST OF SHAREABLE D-VS
               CLEAR LIST(CONSTL8);   ! AND SHAREABLE LONG CONSTANTS
               CLEAR LIST(CONSTL6)
               %IF ASL<200 %THEN %START
                  %PRINTTEXT'?'
                  CLEAR LIST(CONSTL4);! & INTEGER CONSTANTS
                  CLEAR LIST(CONSTL2);! & SHORT INT CONSTANTS
               %FINISH
            %FINISH
         %FINISH
         OLDI=0; ->SW(A(P))
SW(23):
         WARN(LINE)
         SBFLAG=1 %IF CHECKSP=0;       ! '%SHORTROUTINE'
!
1:       LAST INST=CURR INST
         %WHILE TWSPHEAD#0 %CYCLE
            POP(TWSPHEAD,JJ,KK)
            RETURN WSP(JJ,KK)
        %REPEAT
SW(29):                               ! REDUNDANT SEP
SW(10):                               ! <CMARK> <COMMENT TEXT>
!         %CYCLE I=10,1,13
!              ABORT %UNLESS REGISTER(I)=-1
!         %REPEAT
         %RETURN
SW(1):   MARKER2=P+1+A(P+1); P=P+2
         ->LABFND %IF A(MARKER2)=1
         SET LINE %IF LINENOS#0
         -> 101 %IF A(MARKER2)<=3
         MASK=15; CUI(0); ->1
LABFND:  ->SWITCH %UNLESS A(P)<2 %AND A(P+3)=2;! 1ST ALT UI & NO APP
         ->SWITCH %UNLESS A(P+4)=2 %AND A(P+5)=2;! NO ENAME OR ASSOP
         K=16384+A(P+2); ->401
101:     MARKE=0; MARKR=0
         MARKUI=P; MARKIU=MARKER2+1;MARKC=MARKIU+1
         -> CONEXP %IF A(MARKER2)=2; ->WHILE
!
SW(2):                                 ! %CYCLE
!***********************************************************************
!*       THE LAYOUT OF AN ENTRY ON THE CYCLE LIST IS:-                 *
!*        S1= CNAME<<16!LABEL N0                                       *
!*        S2= EL<<16!BXLE<<15! CYCLE WORK AREA DISPLACEMENT FROM RBASE *
!*        S3= BREG    (THE REGISTER USED FOR INCREMENT AND FINAL VALUE)*
!*        WHERE :-                                                     *
!*        CNAME= CYCLE CONTROL NAME(IF SIMPLE SCALAR) OR               *
!*                      X'3000'!CYCLE NUM FOR CHECKED OR COMPLEX CYCLES*
!*        LABEL= NO OF INTERNAL LABEL FOR REPEAT TO JUMP TO            *
!*        BXLE=1 IF 'BXLE' CAN BE USED (IE INCREMENT +VE) ,=0 OTHERWISE*
!*          EL=LABEL NO FOR EXIT STATEMENT (TOP BIT SET WHEN USED)     *
!***********************************************************************
         %BEGIN
         %SHORTROUTINE
         %INTEGER PP,Q,INC,NAME,TNAME,PASS,WSPL,CFLAG,BREG,OPEN,CREG
         SET LINE
         CUR CYC VAR=0; CYC REGS=0
         BXLE=0; INC=0; BREG=2; CREG=1;    ! DEFAULTS
         OPEN=A(P+1)-1; P=P+2; PP=P
         %IF OPEN #0 %THEN %START
            CYCOPT(CFLAG,2) %IF CHECKSP=0
            PASS=X'10000000'
         %FINISH %ELSE %START
            NAME=A(P); TNAME = TAGS(NAME)
            COPY TAG (NAME)
            FAULT(25,NAME) %UNLESS TYPE=1 %AND PREC=0
            %IF A(P+1)=2=A(P+2)%AND UNASS=0%AND CHECKSP=0 %AND %C
                 NAM=0 %AND K<4095 %THEN %START;! CONTROL A LOCAL SCALAR
               WSPL=2; P=P+3; PASS= NAME<<16
               CUR CYC VAR=NAME
               Q=P; FFLAG=0;
               SKIP EXP; SKIP EXP; SKIP EXP
               P=Q;                        ! CHECK FNS IN CNTRL EXPRSNS
               CYCOPT(CFLAG,0)
               P=Q
               %IF CFLAG=0 %THEN CUR CYC VAR=0
               %IF CFLAG>0 %THEN BREG=CFLAG&15
               COPYTAG(NAME)
               %IF PTYPE=8 %THEN CREG=K
            %FINISH %ELSE %START;    ! CONTROL NAMETYPE OR ARRAY ELEMENT
               CYCLE NUM=CYCLE NUM+1
               PASS=X'30000000'!CYCLE NUM<<16
               WSPL=3; CNAME(3,4)
               REGISTER(4)=1
            %FINISH
            %IF BREG=2 %THEN %START;    ! REGISTER PAIR NOT AVAILABLE
               GET WSP(INC,WSPL);       ! WORKAREA TO INC
               POP(TWSPHEAD,JJ,KK);     ! MUST NOT BE FREED BEFORE REPEAT
            %FINISH
            Q=P; SKIP EXP; JJ=P;        ! Q TO 1ST EXP, JJ TO SECOND
            BXLE=1 %IF (3900>CA-CODEBASE %OR CYC BASE#0) %C
                        %AND 1<=TSEXP (JJJ,0)<=2 %AND TYPE=1
            P=JJ
!
! LOAD INCREMENT AND FINAL TO BREG & BREG+1 UNLESS THIS HAS BEEN
! DONE BY THE LOOP OPTIMISING
!
            DSEXP(BREG,0) %UNLESS BREG>2 %AND GRUSE(BREG)=14
            %IF BREG=2 %THEN DUMPM(X'90',2,WSPL+1,RBASE,INC);! STORE PARAMS
            DUMPSI(X'92',CYCLE NUM&255,RBASE,INC+8) %IF UNASS=1
            %CYCLE KK=BREG,1,BREG+WSPL-1
                %IF KK<4 %AND REGISTER(KK)>0 %THEN REGISTER(KK)=0
                %IF CFLAG=0 %THEN FORGET(KK) %ELSE SET USE(KK,14,TNAME)
            %REPEAT
            P=Q; CSEXP(CREG,1)
            FORGET(CREG);                 ! BEFORE PPJ TO AVOID A BOOTOUT
            REGISTER(CREG)=1
            %IF CHECKSP=1 %THEN  DUMP(0,2,INC,0,RBASE);! LA 2, CYCLE PARAMS
            REGISTER(CREG)=0; MONE=1
            %IF CHECKSP=1 %THEN PPJ(17);! CHECK VALIDITY
         %FINISH
         PLABEL=PLABEL-1; PASS=PASS!PLABEL
         PUSH123(LABEL(LEVEL),CA,0,PLABEL);! STORE LABEL
         CCSTATE=-1; LCA=0
         %IF OPEN#0 %THEN %START
            PLABEL=PLABEL-1
            FORGETM(14)
         %FINISH %ELSE %START
            %CYCLE JJ=0,1,22
               FORGET(JJ) %IF REGISTER(JJ)=0 %AND GRUSE(JJ)#14
            %REPEAT
            %IF WSPL=3 %THEN %START
               DUMP(1,1,0,0,4)
               REGISTER(4)=0
            %FINISH %ELSE %START
               %IF CREG=1 %THEN %START
                  P=PP; CNAME(1,1)
                  DUMP(1,1,DISP,INDEX,BASE)
               %FINISH
               NOTE ASSMENT(CREG,2,NAME)
               %IF CREG#1 %THEN REGISTER(CREG)=-1
            %FINISH
            INC=INC!BXLE<<15
         %FINISH
         XLABEL=XLABEL-1
         PUSH123(CYCLE(LEVEL),PASS,XLABEL<<16!INC,CREG<<16!BREG)
         %END; ->1
!
 SW(3):        !REPEAT
         %BEGIN
         %SHORTROUTINE
%INTEGER NAME,TOPREG,CNUM,DSP,WSPL,LAB,KK,BREG,ELABEL,EUSED,CREG
%SHORTINTEGER HEAD
%SWITCH CTYPE(0:3)
         SET LINE
         %IF -1<=FROM1(CYCLE(LEVEL))<=0 %THEN FAULT(1,0) %AND -> 1
         CUR CYC VAR=0
         POP123(CYCLE(LEVEL),J,DSP,BREG)
         ELABEL=DSP>>16&X'7FFF'
         EUSED=DSP>>31
         BXLE=DSP>>15&1; DSP=DSP&X'7FFF'; LAB=J&X'FFFF'
         CREG=BREG>>16; BREG=BREG&X'FFFF'
         ->CTYPE(J>>28)
CTYPE(3):                              ! STEP CYCLE WITH PTR TO CONTROL
       CNUM=J>>16&255; TOPREG=4; WSPL=3; NAME=-1; ->COM
CTYPE(0):                              ! STEP CYCLE LOCAL SCALAR CONTROL
        TOPREG=3; WSPL=2; NAME=J>>16
COM:                                   ! ALL STEPWISE CYCLES
         %IF UNASS=1 %THEN %START;     ! CHECK CYCLE ENTERD OK
            DUMPSI(X'95',CNUM,RBASE,DSP+8);! CLI CYCLE WK AREA,CODE NO
            PCONST(X'477C0028');       ! BNE UNASSIGNED VARIABLE USED
         %FINISH
!
! LOAD UP CYCLE PARAMETERS FROM WKAREA UNLESS THEY ARE LOADED ALREADY
!
         %UNLESS BREG>2 %OR (GRUSE(2)=14=GRUSE(3) %AND %C
                      (GRUSE(4)=14 %OR NAME>=0)) %THEN %START
            DUMPM(X'98',2,TOPREG,RBASE,DSP);! LM CYCLE PARAMS
            %CYCLE I=1,1,TOPREG
               FORGET(I);                   ! FORGET REGISTER USED
            %REPEAT
         %FINISH
!
! NOW GET CONTROL TO REG 1 VIA POINTER OR DIRECTLY AS RELEVANT
!
         %IF NAME<0 %THEN %START;     ! VIA POINTER (REGS NOT ALLOCATED)
            PRX(X'58',1,0,4,0)
            REGISTER(4)=1
         %FINISH %ELSE %START;        ! LOCAL SCALAR USE CNAME
            P=R; A(P)=NAME
            A(P+1)=2; A(P+2)=2;       ! SET NO APP OR ENAME
            CNAME(2,CREG);            ! CONTROL -> R1 OPTIMUM METHOD
         %FINISH
!
! NOW PLANT CODE TO DO THE TEST AND BRANCH.AGAIN 2 WAYS POSSIBLE
!
         %IF BXLE=0 %THEN %START;    ! THE TEDIOUS BUT VALID ROUTE
            PRR(X'18',0,CREG);                 ! LR 0,1
            PRR(X'1A',CREG,BREG);              ! AR 1,INC
            PRR(X'19',0,BREG+1);            ! CR 0,FINAL
            FORGET(0)
            REGISTER(CREG)=1;          ! JUMP MAY LOAD 4K MULTIPLE
            REGISTER(BREG)=1;       ! SO PROTECT REGISTER IN USE
            REGISTER(BREG+1)=1
            ENTER JUMP(7,LAB,0);    ! BNE <BEGIN ANOTHER TRAVERSE>
         %FINISH %ELSE %START;      ! THE BXLE INSTRUCTION CAN BE USED
            KK=FIND3(LAB,LABEL(LEVEL))
            KK=FROM1(KK);           ! EXTRACT LABEL ADDRESS
            %IF CYC BASE=0 %THEN I=10 %AND KK=KK-CODEBASE %ELSE %C
                                 I=CYC BASE %AND KK=KK-CYC ADDR
            PRX(X'87',CREG,BREG,I,KK); ! BXLE 1,2,<NEXT TRAVERSE>
         %FINISH
         %IF CREG#1 %THEN CYC REGS=CYCREGS!!(1<<CREG)
         CYC RESTORE;               ! DEALLOCATE PRELOADED REGISTERS
                                        ! EXCEPT CYCLE CONTROL VARIABLE
         %CYCLE I=BREG,1,BREG+1
            FREE AND FORGET(I)
         %REPEAT
         %IF CREG#1 %THEN %START; ! CONTROL ALLOCATED A REG
            VDALLOC(CREG,(BREG+1)*(1-COMPILER))
            NOTE ASSMENT(BREG+1,2,NAME);! SET CONTROL TO FINAL VALUE
         %FINISH %ELSE FREE AND FORGET(CREG)
         %IF NAME<0 %THEN FREE AND FORGET(4)
         %IF DSP#0 %THEN RETURN WSP(DSP,WSPL);!WORKAREA TO FREE LIST
         %IF UNASS=1 %THEN DUMPSI(X'92',0,RBASE,DSP+8)
         CYC REGS=0; CYC BASE=0
         CCSTATE=-1; ->1
CTYPE(1):                               ! '%WHILE' '%CYCLE'
         ENTER JUMP(15,LAB,0);          ! UNCONDITIONALLY TO WHILE CLAUS
         ENTER LAB(LAB-1,B'111');       ! CONDITIONAL/REPLACE ENV
        ->2
CTYPE(2):                               ! '%UNTIL' ... '%CYCLE'
         %IF 500-R>799-TOPPTR %THEN %START
            P=R+1; WSPL=499-P
         %FINISH %ELSE %START
            P=TOPPTR+1; WSPL=799-P
         %FINISH
         %IF WSPL<DSP %THEN FAULT(102,0);  ! NO ROOM FOR A.R.
         WSPL=P; P=P+DSP; HEAD=BREG
         %UNTIL HEAD=0 %CYCLE;           ! RETRIEVE AR FROM LIST
            POP123(HEAD,JJJ,KKK,KK)
            P=P-5
            TOAR4(P,JJJ)
            TOAR4(P+2,KKK)
            A(P+4)=KK
         %REPEAT
         A(PIN-1)=A(P);                  ! SET UP LINE NO OF CONDITION
         P=P+1
         R=R+DSP
         CCOND(1,LAB)
         R=R-DSP
2:       CYC RESTORE
         CYC REGS=0; CYC BASE=0
1:       %IF EUSED#0 %THEN ENTER LAB(ELABEL,B'11')
         %END; ->1
!
SW(4):                                 ! (LABEL)':'
         K=A(P+1)
         FAULT(2,0) %IF K=0 %OR K>16383
401:     NMDECS=NMDECS!1
         ENTER LAB(K,0)
         CYC BITS=CYC BITS!1;            ! SET 'LABEL' BIT
         ->1
!
SW(5):                                 ! (%IU)(COND)%THEN(UI)(ELSE')
         MARKIU=P+1; MARKC=MARKIU+2
         MARKR=P+2+A(P+2); MARKE=0
         %IF A(MARKR)=3 %THEN %START
         MARKE=MARKR+1+A(MARKR+1); MARKUI=MARKR+2
         %FINISH
         SET LINE %IF LINENOS#0
CONEXP:  %BEGIN
!***********************************************************************
!*       THIS BLOCK COMPILES CONDITIONAL EXPRESSIONS.IT REQUIRES THE   *
!*       FOLLOWING GLOBAL POINTERS TO BE SET TO THEIR A .R. ENTRY.     *
!*       MARKIU TO THE ENTRY FOR P(%IU)                                *
!*       MARKC  TO THE ENTRY FOR P(COND)                               *
!*       MARKUI TO THE ENTRY FOR (FIRST OCCURRENCE OF)  P(UI)          *
!*       MARKE  TO THE ENTRY FOR P(ELSE')  - =0 FOR BACKWARDS CONDITION*
!*       MARKR  TO ENTRY FOR P(RESTOFIU)                               *
!***********************************************************************
         %SHORTROUTINE
         MARKIU=A(MARKIU);              ! ALT OF IU 1=%IF,2=%UNLESS
         KKK=-1
         %IF MARKR>0 %AND A(MARKR)<=2 %START;! '%START' OR '%THENSTART'
            KKK=SFLABEL-1
            P=MARKC; CCOND(MARKIU,KKK)
            CSTART(1)
            -> 1
         %FINISH
         %IF A(MARKUI)=2 %AND (A(MARKUI+1)<2 %OR A(MARKUI+3)=2) %THEN %C
            KKK=A(MARKUI+2)+(A(MARKUI+1)-1)<<14;! UI = SIMPLE LABEL
!
         %IF A(MARKUI)=8 %AND CYCLE(LEVEL)#0 %START; ! VALID EXIT
            KKK=FROM2(CYCLE(LEVEL))
            REPLACE2(CYCLE(LEVEL),KKK!X'80000000')
            KKK=KKK>>16&X'7FFF'
         %FINISH
!
         %IF KKK>=0 %THEN %START;  ! FIRST UI IS'->'<LABEL>
            NMDECS=NMDECS!1
            CYC BITS=CYC BITS!2;        ! SET 'JUMP' BIT
            P=MARKC; CCOND(3-MARKIU,KKK)
            %IF MARKE>0 %AND A(MARKE)<=2 %START; ! THERE IS AN ELSE CLAUSE
               %IF A(MARKE)=1 %THEN CSTART(0) %ELSE %START
                  P=MARKE+1; MASK=15
                  CUI(0)
               %FINISH
            %FINISH
            ->1
         %FINISH
!
         PLABEL=PLABEL-1; KKK=PLABEL
         P=MARKC; CCOND(MARKIU,KKK)
         P=MARKUI; MASK=15; CUI(1)
         %UNLESS MARKE>0 %AND A(MARKE)<=2 %START;   ! UNLESS %ELSE FOLLOWS
            ENTER LAB(KKK,B'11'!REPORTUI<<2); ->1;  ! CONDITIONAL&MERGE
         %FINISH
!
         %IF A(MARKE)=1 %THEN %START;      ! '%ELSESTART'
            %IF REPORTUI=0 %THEN %C
               ENTER JUMP(15,SFLABEL-1,B'10');! LONG JUMP BUT SAVE ENV
            CSTART(2)
            ENTER LAB(KKK,B'111');         ! CONDITIONAL & REPLACE ENV
         %FINISH %ELSE %START;             ! '%ELSE<UI>'
            P=MARKE+1
            PLABEL=PLABEL-1; JJJ=PLABEL
            %IF REPORTUI=0 %THEN %C
               ENTER JUMP(15,JJJ,B'11');   ! SHORT JUMP AND SAVE ENV
            ENTER LAB(KKK,B'111');         ! CONDITIONAL REPLACE ENV
            MASK=15; CUI(2)
            ENTER LAB(JJJ,B'11'!REPORTUI<<2);! CONDITIONAL MERGE
         %FINISH
1:       %END; ->1
SW(14):
         %BEGIN;                       ! '%FINISH(ELSE')(S)
         %SHORTROUTINE

         %INTEGER J,K,CODE,CYC,FLAB
         POP123(SBR(LEVEL),CODE,FLAB,CYC)
         %IF CODE<0 %THEN FAULT(51,0) %AND ->1
         %IF CYC#CYCLE(LEVEL) %THEN FAULT(52,0)
!
         %IF A(P+1)<=2 %THEN %START;    ! %ELSE CLAUSE PRESENT
            FAULT(47,0) %UNLESS CODE=1;   ! DANGLING ELSE
            %IF A(P+1)=1 %THEN %START;  ! %ELSE %START
!
! PLANT A ROUND NEXT START-FINISH %UNLESS PREVIOUS INSTRUCTION WAS ->
!
               ENTER JUMP(15,SFLABEL-1,B'10') %IF LAST INST=0
               CSTART(2)
            %FINISH %ELSE %START;       ! %ELSE (UI)
               %IF LAST INST=0 %THEN %START
                  PLABEL=PLABEL-1; J=PLABEL
                  ENTER JUMP(15,J,B'11')
               %FINISH
               P=P+2;! K=A(P);           ! K= ALT OF P(UI)
!
! PLANT THE LABEL FOR THE JUMP ROUND THE START FINISH BLOCK JUST ENDED
! THE LABEL IS CONDITIONAL ON THERE HAVING BEEN A JUMP. ENVIRONMENTS ARE
! MERGED UNLESS THE PREVIOUS INSTN IS A -> ETC WHEN ENV IS REPLACED
!
               ENTER LAB(FLAB,B'011'!LAST INST<<2)
               MONE=1; SET LINE; MASK=15
               %IF LAST INST#0 %THEN CUI(0) %AND ->1
               CUI(2); FLAB=J
               LAST INST=REPORT UI
            %FINISH
!
         %FINISH %ELSE %START
            ->1 %IF CODE=0
         %FINISH
!
         ENTER LAB(FLAB,B'011'!LAST INST<<2)
         MONE=1
1:       %END; ->1
SWITCH:  %BEGIN;                       ! SWITCH LABEL
         %SHORTROUTINE
         %INTEGER HEAD,BASEPT,BP,FNAME
         MONE=1; LCA=0; FORGETM(14)
         CYC BITS=CYC BITS!1;                  ! SET 'LABEL' BIT
         FNAME=A(P+2)
         ->1411 %UNLESS A(P)=1 %AND A(P+3)=1;  ! 1ST OF UI + APP
         ->1411 %UNLESS A(P+6)#3 %AND A(P+7)=2 %AND A(P+8)&7=1
         ->1411 %UNLESS A(P+11)=2=A(P+12);     !NO R.OF.EXP. OR R.OF.APP
         ->1411 %UNLESS A(P+13)=2=A(P+14);     ! NO ENAME OR R.OF.UI
         COPY TAG(FNAME)
         HEAD=K
         %IF OLDI#LEVEL %OR TYPE#6 %THEN FAULT(4,FNAME) %AND ->1
         FROM123(HEAD,BASEPT,KKK,KK);      ! EXTRACT TABLE ADDR,LB & UB
         MLINK(HEAD);                      ! K POINTS TO BIT LIST
         FROM AR4(P+9,JJ)
         JJ=-JJ %IF A(P+6)=2
         ->1402 %IF KKK<=JJ<=KK
1411:    FAULT(5,FNAME); ->1
1402:    Q=JJ-KKK
         %WHILE Q>=96 %THEN MLINK(HEAD) %AND Q=Q-96
!
! ASLIST(HEAD) IS THE START OF 96 BIT ENTRY IN THE BIT LIST
! CHECK BIT NO Q TO SEE IF LABEL ALREADY SET AND THEN SET BIT Q
!
         QQ=Q>>3+HEAD;                 ! RIGHT BYTE
         Q=Q&7; JJJ=1<<Q;              ! BIT IN BYTE
         FAULT(6,FNAME) %UNLESS ASLIST(QQ)&JJJ=0
         ASLIST(QQ)=ASLIST(QQ)!JJJ %UNLESS CSSMODE=0
         Q=CA-CODEBASE
         BP=BYTES(PREC)
         QQ=BASEPT+8+(JJ-KKK)*BP; ! REL POSITION OF LABEL IN SST
         %IF INHCODE=0 %THEN LPUT(4,BP,QQ,ADDR(Q)+4-BP)
         FAULT(99,0) %IF Q>X'7FFF' %AND PREC#0
1:       %END;   ->1
SW(6):                                 ! (%WU)(SC)(COND)(RESTOFWU)
         MARKIU=P+1;                   ! TO WHILE/UNTIL
         MARKC=MARKIU+2;               ! TO (SC)(COND)
         MARKR=P+2+A(P+2);             ! TO RESTOF WU
         MARKUI=MARKR+1;               ! TO P(UI) IF ANY
         SET LINE
WHILE:   %BEGIN
         %SHORTROUTINE
         %INTEGER L1,L2,FLAG,XTRA
         %SHORTINTEGER HEAD
         HEAD=0; XTRA=0
         MARKIU=A(MARKIU);             ! =1 FOR'WHILE' =2 FOR'UNTIL'
         SFLABEL=SFLABEL-1
         L1=SFLABEL
         PLABEL=PLABEL-1;              ! RESERVE 2 LABELS
         L2=PLABEL
         ->WCYCLE %IF MARKR>0 %AND A(MARKR)<=2
         %IF CSSMODE#0 %AND STMTSHELD>1 %AND CYCREGS=CYCBASE=0 %C
            %THEN EXTRA PASS(1,1,100) %AND XTRA=1
         ENTER LAB(L1,0);             ! UNCONDITIONAL LAB FOR REPEAT
         %IF MARKIU=1 %THEN %START
            P=MARKC
            CCOND(1,L2)
         %FINISH
!
         MASK=15; P=MARKUI
         CUI(1)
!
         %IF MARKIU=1 %THEN %START
            ENTER JUMP(15,L1,0);        ! UNCODITIONALLY TO WHILE COND
            ENTER LAB(L2,B'111')
         %FINISH %ELSE %START
            P=MARKC; CCOND(1,L1);       ! UNTIL CONDITION AT END
         %FINISH
         %IF XTRA#0 %THEN CYC RESTORE %AND CYCREGS=0 %AND CYCBASE=0
         ->1
WCYCLE:
!***********************************************************************
!*       WHILE CYCLES JUST LIKE %WHILE...%THEN<UI> BUT %UNTIL CYCLES   *
!*       STORE AWWAY AN A.R. TO BE RESET AND COMPILED TO PUT THE       *
!*       CONDITION AT THE END. IF IT WAS PUT AT THE BEGINING 2 EXTRA   *
!*       JUMPS ARE NEEDED TO OBTAIN THE CORRECT EFFECT.                *
!***********************************************************************
         P=MARKC; FLAG=0
         %IF CSSMODE=0 %THEN CCOND(1,SFLABEL-1) %ELSE %START
            CUR CYC VAR=-1
            CYCOPT(FLAG,1);                  ! NOT A PRELIMINARY LOOK
            XLABEL=XLABEL-1
            ENTER LAB(L1,0);                 ! UNCONDITIONAL FOR REPEAT
            %IF MARKIU=2 %THEN %START;       ! '%UNTIL....%CYCLE'
               L2=MARKR-MARKC+6
               P=P-1; A(P)=A(PIN-1);         ! GET LINE NO
               %UNTIL P>=MARKR %CYCLE;       ! DOWN AR FOR <COND>
                 FROMAR4(P,JJJ)
                 FROMAR4(P+2,KKK)
                 PUSH123(HEAD,JJJ,KKK,A(P+4))
                 P=P+5
               %REPEAT
            %FINISH %ELSE %START;            ! '%WHILE...%CYCLE
               CCOND(1,L1-1)
               SFLABEL=SFLABEL-1
            %FINISH
            PUSH123(CYCLE(LEVEL),L1!MARKIU<<28,XLABEL<<16!L2,HEAD)
        %FINISH
1:         %END; ->1
!
SW(7):                                 ! SIMPLE DECLN
         FAULT(57,0) %UNLESS LEVEL>=2
         FAULT(40,0) %IF NMDECS&1#0
         SET LINE
         P=P+1;CLT;ROUT=0
         %IF A(P)=1 %THEN %START;      ! SCALAR DECLARATIONS
            CQN(P+1);P=P+2
            DECLARE SCALARS(1,0)
         %FINISH %ELSE %START;         ! ARRAY DECLARATIONS
            FAULT(70,0) %IF TYPE=5 %AND ACC=0
            NAM=0
            QQ=2-A(P+1); P=P+2;        ! QQ=1 FOR ARRAYFORMATS
            DECLARE ARRAYS(QQ,0)
           %FINISH
         ->1
!
         %ROUTINE DECLARE SCALARS(%INTEGER PERMIT,XTRA)
         %SHORTROUTINE
!***********************************************************************
!*       THIS ROUTINE DECLARES A LIST OF SCALARS FROM INFORMATION      *
!*       IN THE GLOBAL VARIABLES ROUT,NAM,ARR,PREC,TYPE & ACC.IT WORKS *
!*       OUT ROUNDING FACTORS FOR ITSELF. IF PERMIT#0 STRINGS AND      *
!*       RECORDS ARE ALLOCATED AT RUN TIME(ALLOC=1) WHEN SPACE IS      *
!*       TIGHT. P POINTS TO THE NAMELIST ON ENTRY AND IS UPDATED.      *
!***********************************************************************
         %INTEGER REP,ALLOC,INC,ROUND,Q,SCHAIN,NIN
         %CONSTBYTEINTEGERARRAY RACC (1:32)=               %C
                                X'44' (2),X'80',0,X'10',0(5),
                                       X'11',0(9),
                                       X'22',0(9),
                                       0,X'88'
         PACK(PTYPE); J=0; NIN=N
         %IF PTYPE<=32 %THEN ROUND=RACC(PTYPE) %ELSE %START
             %IF NAM=1 %AND TYPE=0 %AND ROUT=0 %THEN ROUND=X'48' %C
                                               %ELSE ROUND=X'44'
         %FINISH
         %IF ARR=1 %AND ROUT=0 %THEN INC=16 %ELSE INC=ROUND&15
                                       ! BEWARE MAPS
         %IF INC=0 %THEN INC=ACC
         ROUND=ROUND>>4;               ! ITEM LENGTH AND BOUNDARY O.K.
         %IF PTYPE=5 %AND ACC=0 %THEN FAULT(70,0)
         ALLOC=0; REP=A(P)
         %IF PERMIT#0 %AND(PTYPE=3 %OR PTYPE=5) %AND %C
            ACC*REP+N>4096-MARGIN %THEN %START
            NAM=1;  PACK(PTYPE)
            ROUND=4; INC=4
            ALLOC=1
         %FINISH
         N=(N+ROUND-1)&(-ROUND)
         %CYCLE Q=1,1,REP;         ! DOWN THE NAMELIST
            K=A(P+Q); TEST NST
            SCHAIN=N
            %IF ROUT=1 %THEN %START
               SCHAIN=0; J=13; SNDISP=N>>2
               KFORM=1000
            %FINISH
            %IF TYPE=3 %THEN KFORM=XTRA
            STORE TAG(K,SCHAIN)
            %IF ALLOC=1 %THEN %START
               %IF UNASS=1 %THEN PSS(X'D2',8,WSPR,0,CODER,216)
               DUMP(X'50',WSPR,N,0,RBASE)
               %IF TYPE=5 %THEN DUMPSI(X'92',ACC-1,RBASE,N)
               MOVER(WSPR,(ACC+7)&(-8))
            %FINISH
            N=N+INC
         %REPEAT
         P=P+REP+1
         N=(N+3)&(-4) %IF PERMIT#0;! NO ROUNDING AMONG PARAMS
         BULKM(0,N-NIN,RBASE,NIN,0,X'80') %IF UNASS=1 %AND %C
         ALLOC=0 %AND PERMIT\=0
         %END
         %ROUTINE DECLARE ARRAYS(%INTEGER FORMAT,FINF)
         %SHORTROUTINE
!***********************************************************************
!*       FORMAT=1 FOR 'ARRAYFORMAT'   =0 OTHERWISE                     *
!*       FINF>0 FOR RECORD FORMAT INFORMATION =0 OTHERWISE             *
!*       P IS AT P<ADECLN>   IN                                        *
!*                                                                     *
!*       P<ADECLN>=<NAMELIST> <BPAIR> <RESTOFDECLN>                    *
!*       P<BPAIR> = <CBPAIR>,'('<EXPR>':'<EXRR><RESTOFBP>*')'          *
!*                                                                     *
!*       ARRAYS OF ONE DIMENSION WITH CONSTANT BOUNDS HAVE THEIR       *
!*       DOPE-VECTOR IN THE CONSTANT AREA AND MAY HAVE THEIR SPACE     *
!*       ALLOCATED AT COMPILE TIME AMONG THE SCALARS                   *
!*       ALL OTHER ARRAYS HAVE A DOPE VECTOR AMONG THE LOCALS AND GET  *
!*       THEIR SPACE OFF THE STACK AT RUN TIME                         *
!*       BOTH SORTS OF ARRAYS HAVE A FOUR WORD HEAD AND D-V TO EMAS    *
!*       SYSTEM STANDARDS                                              *
!***********************************************************************
         %INTEGER DVDISP,PP,DVF,ELSIZE,TOTSIZE,L,U,D1,D0
         %INTEGER PTYPEP,ARRP,NN,ND,II,JJ,QQ,R,CDV
         ARRP=2*FORMAT+1; ARR=ARRP; PACK(PTYPEP)
         ELSIZE=ACC
START:   NN=A(P+1);                    ! NO OF NAMES IN NAMELIST
         PP=P; CDV=0
         P=P+2+NN;
         %IF A(P)=1 %THEN -> CONSTDV;  ! P<BPAIR> =<CBPAIR>
!
! NORMAL CASE - PLANT CODE TO SET UP DOPE-VECTOR AT RUN TIME
!
         ND=0; JJ=P; DVF=0;TOTSIZE=X'FFFF'
         %UNTIL A(P)=2 %CYCLE;         ! TILL NO MORE BPAIRS
            P=P+1; ND=ND+1;            ! COUNT NO OF DIMENSIONS
            SKIP EXP; SKIP EXP
         %REPEAT
         P=JJ; DVDISP=N;               ! DVDISP IS D-V POSITION
         N=N+12*ND+4;                  ! CLAIM SPACE FOR THE D-V
         FAULT(37,0) %IF ND>7;           ! TOO MANY DIMENSIONS
!
         DUMP(0,-2,ELSIZE,0,0)
         REGISTER(NEST)=1
         DUMP(X'50',NEST,DVDISP,0,RBASE)
         FREE AND FORGET(NEST)
         DUMPSI(X'92',ND,RBASE,DVDISP+1);  ! FIRST ND=ND<<16!ELSIZE
!
         %CYCLE II=0,1,ND-1
            P=P+1
            %CYCLE JJ=0,1,1
               QQ=12*II+4*JJ+4+DVDISP
               TYPE=1; PREC=0; PTYPE=1
               ASSIGN(2,RBASE<<16!QQ); ! ASSIGN EXPR TO DVITEM
            %REPEAT
         %REPEAT
         P=P+1
         DUMP(0,2,DVDISP,0,RBASE)
RUN TIME:                              ! ALLOCATE SPACE AT RUN TIME
                                       ! R2 POINTS TO D-V
         DVF=0;                        ! NOT VECTORS
         PRX(X'50',2,0,GLA,36);        ! PUT POINTER INTO GLA
         JJ=FORMAT<<7!UNASS
         PSI(X'92',JJ,GLA,36) %IF JJ#0;! AND ADD FLAGS
         -> DECL
CONSTDV:                               ! ONE DIMENSION - CONSTANT BOUNDS
         DVF=1; ND=1; P=P+1; CDV=1
         CBPAIR(L,U);                  ! GET BOUNDS
         DVDISP=DOPE VECTOR(ELSIZE,L,U); ! AND GENERATE A D-V
         R=U-L+1;                      ! RANGE=SPACES AS ELEMENTS
         TOTSIZE=R*ELSIZE
!
         II=DVDISP-GRINF(2)
         %UNLESS GRUSE(2)=17 %AND II>=0 %THEN %START
            PCONST(X'5820D000');       ! LOAD R2,POINTER TO SST
            FORGET(2)
            II=DVDISP
         %FINISH
!
         REGISTER(2)=1
         DUMP(0,2,II,0,2) %UNLESS II=0
         REGISTER(2)=0
         JJ=4096-N-MARGIN;             ! SPACE AVAILABLE
         JJ=JJ-MARGIN//2 %IF RBASE=9;  ! LEAVE LARGER MARGIN AT TOP
                                       ! LEVEL SINCE DECLNS THERE ARE
                                       ! ONLY EXECUTED ONCE
         -> RUNTIME %UNLESS FORMAT=0 %AND UNASS=0
         -> RUNTIME %IF NN*TOTSIZE>JJ %OR L>U
         II=N-L*ELSIZE
         -> RUNTIME %UNLESS II>0 %AND II+(NN-1)*(TOTSIZE+16)<4000
!
! CAN ALLOCATE ARRAYS AS STRINGS OF LOCALS. THIS SAVES TIME AT DECLARATION
! BUT ALSO ALLOWS THE LEVEL POINTER TO BE USED TO ADDRESS
! THE ARRAY SAVING A REGISTER ON EACH ACCESS.
!
         DUMP(0,3,ELSIZE,0,0) %UNLESS COMPILER=1
DECL:                                  ! MAKE DECLN - BOTH WAYS
         PTYPE=PTYPEP+100*DVF;         ! ARR=2 FOR VECTORS =3 FOR FORMAT
         J=ND
         %CYCLE JJJ=1,1,A(PP+1);       ! DOWN NAMELIST
            %IF DVF#0 %THEN %START;     ! ARRAY IS STRING OF LOCALS
               N=(N+7)&(-8);           ! ARRAYS START ON D-W BNDARY
               D1=N+16
               D0=D1-L*ELSIZE; SNDISP=D0
               PRX(X'41',0,0,RBASE,D0);! LA 0,ADDR(A(0))
               PRX(X'41',1,0,RBASE,D1);! LA 1,ADDR(A(L.B))
               JJ=16+TOTSIZE
               FORGETM(3)
            %FINISH %ELSE %START;     ! LONGWAY PERM MUST DECLARE
               PPJ(13); FORGET(4)
               JJ=16
               SNDISP=0
            %FINISH
!
            ACC=ELSIZE;                ! RESET ACC AFTER DV CMPLD
            KFORM=FINF;                 ! FORMAT INFORMATION
            K=A(JJJ+PP+1); TEST NST
            STORE TAG(K,N)
            REGISTER(1)=1;             ! MUST LOCK REGISTERS CONTAINING
            REGISTER(2)=1;             ! ARRAYHEAD IN CASE 4K MULTIPLE
            REGISTER(3)=1;             ! NEEDED TO STORE ARRAYHEAD
            DUMPM(X'90',0,3,RBASE,N)
            %CYCLE II=0,1,3
               FREE AND FORGET(II);    ! NOW FORGET REGISTERS
            %REPEAT
            N=N+JJ
         %REPEAT
         %IF CDV#0 %THEN SET USE(2,17,DVDISP)
         P=P+1;                        ! PAST REST OF ARRAYLIST
         N=(N+3)&(-4)
         %IF A(P-1)=1 %THEN -> START
         %END
SW(8):                                 ! %END
         %BEGIN
         %SHORTROUTINE
         %SWITCH S(1:5)
         -> S(A(P+1))
S(1):                                  ! ENDOFPROGRAM
S(2):                                  ! ENDOFFILE
         %IF CPRMODE=0 %THEN CPRMODE=2
         FAULT(15,0) %UNLESS LEVEL+CPRMODE=3
         FAULT(56,0) %UNLESS A(P+1)=CPRMODE
         CEND(CPRMODE)
         LOAD DATA; %STOP
S(3):                                  ! ENDOFLIST
         LIST=0;
S(4):                                  ! ENDOFMCODE
         ->1
S(5):                                  ! END
         CEND(FLAG)
1:       %END; ->1
!
SW(9):   P=P+1; MARKER1=A(P)+P;        ! (SEX)(RT)(SPEC')(NAME)(FPP)
900:     Q=P; KKK=A(MARKER1+1);        ! KKK ON NAME
         EXTRN=A(P+1)
         %IF A(MARKER1)=1 %THEN %START;! P<%SPEC'>='%SPEC'
            P=P+1;  CRSPEC(1-EXTRN>>2);! 0 FOR ROUTINESPEC
                                       ! 1 FOR EXTERNAL (ETC) SPEC
            ->1
         %FINISH
         KK=KKK;                       ! ROUTINE HEADING NOT SPEC
         CNOP(0,4)
         COPY TAG(KKK)
         ->939 %IF OLDI#LEVEL;        ! NAME DECLARED AT OUTER LEVEL
         %IF CPRMODE=0 %THEN %START;  ! NO BEGIN OR ROUTINE STMNT YET?
            CA=0; CABUF=0
            PPCURR=0;  CPRMODE=2;     ! FLAG AS FILE OF ROUTINES
         %FINISH
!
         %IF EXTRN#4 %THEN %START;   ! SYSTEM EXTERNAL DYNAMIC
            %IF (CPRMODE=2 %AND LEVEL=1) %OR COMPILER=1=RLEVEL %START
               %IF EXTRN=3 %THEN EXTRN=2
               DEFINE EP(EXTRN,KKK,CA,0)
               SET PERMBASE
            %FINISH %ELSE %START;    ! EXTERNALS IN PRGM OR WRNG LEVEL
               FAULT(55,0); EXTRN=4
            %FINISH
         %FINISH
         %IF A(P+2)=1 %THEN KKK=10000 %ELSE %START
            ROUT=1; P=P+3;           ! FIGURE OUT PTYPE FOR FNS&MAPS
            CLT; ARR=0
            NAM=(A(P)-1)<<1;         ! SET NAME ARRAY BIT FOR MAPS
            PACK(KKK);              ! AND STORE PTYPE IN KKK
         %FINISH
         ->940 %IF J=15 %AND PTYPE=KKK
939:     P=Q+1; CRSPEC(0); P=Q; ->900
940:     %BEGIN
         %SHORTROUTINE
         %INTEGER PTR,PTYPEP
         J=0; REPLACE TAG(KK);!  BODY GIVEN SO UPDATE TAGS INFO
         JJ=K; PLABEL=PLABEL-1
         ENTER JUMP(15,PLABEL,0) %UNLESS COMPILER=1 %OR %C
                                (CPRMODE=2 %AND LEVEL=1)
         PTYPEP=PTYPE
         RHEAD(KK)
         FLAG=PTYPEP
         P=MARKER1+1
         %IF A(P+1)=1 %THEN %START;   ! FORMAL PARAMETERS TO DEAL WITH
            %UNTIL A(P)=2 %CYCLE;     ! UNTIL NO MORE FP-PART
               P=P+2
               CFPDEL
               %CYCLE PTR=1,1,A(P);   ! CYCLE DOWN NAMELIST
                  %IF JJ#0 %THEN %START
                     FROM12(JJ,J,JJJ);! EXTRACT PTYPE XTRA INFO
                     %UNLESS J=PTYPE %AND (PTYPE#5 %OR JJJ>>16=ACC) %C
                        %THEN FAULT(9,A(P+PTR))
                  %FINISH %ELSE FAULT(8,0);! MORE FPS THAN IN SPEC
                  MLINK(JJ)
               %REPEAT
               DECLARE SCALARS(0,0)
            %REPEAT;              ! UNTIL NO MORE FP-PART
            N=(N+3)&(-4);         ! TO WORD BOUNDARY AFTER ALL SYSTEM
                                  ! STANDARD PARAMETERS HAVE BEEN DECLARED
         %FINISH
         FAULT(10,0) %UNLESS JJ=0
         %END; ->1202
!
SW(11):                                !REALS(LN)
         ALL LONG=A(P+1)&1;->1
!
SW(12):                                !%BEGIN
         PTYPE=0; RHEAD(-1)
         ->1 %IF LEVEL=1=RLEVEL
         ->1202 %UNLESS LEVEL=2
         CPRMODE=1 %IF CPRMODE=0
         DEFINE EP(0,0,0,0)
         FAULT(55,0) %UNLESS CPRMODE=1
1202:    %IF SBFLAG=0 %THEN %START
            PLANT(X'05A0'); CODEBASE=CA;
            GRINF(10)=CA; CUR CYC VAR=0
         %FINISH
         %IF CHECKSP#0 %THEN %START
            PCONST(X'41000004');          ! LA 0,4 --- FAULT 4=EXCESS BLKS
            PCONST(X'9812D040');          ! LM 1,2 TOPSTREF
            PLANT(X'1211');               ! LTR 1,1
            PRX(X'47',10,0,10,CA-CODEBASE+8);! BHE *+8
            PCONST(X'58202000');          ! L 2,0(2)
            PLANT(X'19B2');               ! CR 11,2
            PCONST(X'4720C054');          !  BH  RUN TIME FAULT ROUTINE
            CCSTATE=-1
            FORGET(1); FORGET(2)
         %FINISH
        ->1
!
SW(13):
                                       ! '%FAULT'(FLIST)(S)
         WARN(LINE)
         FAULT(26,0) %UNLESS LEVEL=2 %AND CPRMODE#2
         NMDECS=NMDECS!1
         %UNTIL A(P)=2 %CYCLE;         ! UNTIL RESTOFFAULTLIST IS NULL
            P=P+2; Q=P+1
            %WHILE A(Q)#2 %THEN Q=Q+2
            %UNTIL A(P-1)=2 %CYCLE;    ! UNTIL RESTOFNLIST IS NULL
               K=A(Q+2)+(A(Q+1)-1)<<14
               KKK=A(P);PCONST(X'41100000'!KKK)
               FAULT(36,0) %IF KKK>32 %OR KKK=0 %OR KKK=29 %OR 11<KKK<14
               PPJ(20); QQ=CA
               ENTER JUMP(15,K,0);           ! JUMP TO LABEL
               PCONST(X'07000700') %UNLESS CA=QQ+8;! JUMP MUST BE 8 BYTES
               P=P+2
            %REPEAT
            P=P+2
         %REPEAT; ->1
!
SW(15):  %BEGIN;                       !SWITCH (SWITCH LIST)
         %SHORTROUTINE
         %INTEGER Q,RANGE,KKK,KK,LB
         Q=P
         FAULT(56,0) %UNLESS LEVEL>=2
         %IF SBFLAG=1 %OR COMPILER=1 %THEN PREC=2 %ELSE PREC=0
         PTYPE=106+10*PREC;            !(SHORT?) LABEL ARRAY
         %UNTIL A(Q)=2 %CYCLE;         ! UNTIL NO'REST OF SW LIST'
            P=A(Q+1)+Q+2;              ! PAST 'NAMELIST' TO 'BPAIR'
            CBPAIR(KKK,KK);            ! LOWER BOUND TO KKK UPPER TO KK
            %UNLESS !KKK! <X'7FFF'>!KK! %THEN %START
               FAULT(18,0); KK=0; KKK=0
            %FINISH
            RANGE=(KK-KKK+1)*BYTES(PREC)
            LB=KKK; KKK=KKK&X'FFFFFF'!PREC<<24
            %CYCLE QQ=1,1,A(Q+1);      !  DOWN NAMELIST
               K=A(Q+QQ+1)
               TEST NST
               SSTL=(SSTL+3)&(-4);     !  CONST TABLES TO WORD BNDRY
               OPHEAD=0; R=LB
!
! SET UP A BIT LIST (96 BITS PER CELL) TO CHECK FOR SWITCH LABELS
! SET TWICE
!
               %UNTIL R>KK %CYCLE
                  PUSH123(OPHEAD,0,0,0)
                  R=R+96
               %REPEAT
!
! OUTPUT ARRAYBOUNDS (CHECKING MODE) AND CLEAR THE TABLE SPACE
!
              %IF (COMPILER=0 %OR CHECKSP=1) %AND (INHCODE=0)%C
              %THEN %START
                  LPUT(4,8,SSTL,ADDR(KKK))
                  SSTL=SSTL+8
               %FINISH
               PUSH123(OPHEAD,SSTL-8,LB,KK)
               J=1; STORE TAG(K,OPHEAD)
               %IF INHCODE=0 %THEN %C
                  LPUT(4,RANGE,SSTL,COMPILER)
               SSTL=(SSTL+RANGE+3)&(-4)
            %REPEAT;                   ! FOR ANY MORE NAMES IN NAMELIST
            Q=P
         %REPEAT;                      ! UNTIL A(Q)=2
         %END;->1
!
SW(16):  LIST=1; ->1;                  ! %LIST
!
!
SW(17):                                ! '%OWN' (TYPE)(OWNDEC)
         %BEGIN
         %SHORTROUTINE
!***********************************************************************
!*       INITIALISED DECLARATION GO INTO THE GLA OR GLA SYMBOL TABLES  *
!*       EXCEPT FOR CONST ARRAYS WHICH GO INTO THE CODE SYMBOL TABLES  *
!*       STRINGS AND ARRAYS HAVE A HEADER IN THE GLA. LPUT ARRANGES    *
!*       FOR THE LOADER TO RELOCATE THE HEADERS.                       *
!*      EXTERNALS ARE IDENTICAL WITH OWN BUT ALSO HAVE A DATA EP DEFN  *
!*       IN THE LOAD DATA SO THEY CAN BE FOUND AT LOAD TIME            *
!*      EXTRINSICS HAVE A DATA REFERENCE AND A DUMMY HEADER IN THE GLA *
!*      THE LOADER USES THE FORMER TO RELOCATE THE LATTER.             *
!***********************************************************************
         %ROUTINESPEC CLEAR(%INTEGER L)
         %ROUTINESPEC STAG(%INTEGER J,DATALEN)
         %INTEGER LENGTH,BP,PP,SIGN,CBASE,MODE
         %INTEGER ICONST,CTYPE,TAGDISP,EPTYPE,EPDISP
         %LONGREAL RCONST
         %STRING(255) SCONST
         %INTEGER AH1,AH2,AH3,AH4,AD,FNAM,FINF
         %INTEGER SPOINT,CONSTSFOUND,EXTRN,NNAMES,MARK,LPUTP
         %INTEGERNAME STPTR
         LPUTP=5; STPTR==CONSTPTR;     ! NORMAL CASE GLA SYMBOLTABLES
!         FAULT(40,0) %IF NMDECS&1#0
         EXTRN=A(P+1)&3
         %IF EXTRN=0 %THEN LPUTP=4 %AND STPTR==SSTL
         P=P+3; CBASE=GLA
         MODE=A(P-1);                ! MODE =1 FOR NORMAL OWNS
         ->RECORD %IF MODE>1;        ! MODE =2 FOR OWN RECORDS
         CLT;                        ! MODE =3 FOR OWN RECORD ARRAYS
         %IF TYPE=5 %AND ACC=0 %THEN FAULT(70,0) %AND ACC=2
         %IF EXTRN=0 %THEN PREC=PREC!4
         NAM=TYPE>>2; ROUT=0; ARR=A(P)-1; PACK(PTYPE)
         -> NON SCALAR  %UNLESS ARR=0
         %UNTIL A(MARK)=2 %CYCLE;    ! UNTIL <RESTOFOWNDEC> NULL
         MARK= P+1+A(P+1); NNAMES=A(P+2)
         PP=P+3; P=PP+NNAMES;        ! P ON CONST'
!
! OBTAIN THE INITIAL CONSTANT,ITS TYPE(CTYPE) AND SIGN(SIGN)
! CONVERT TO ALL LEGAL FORMS AND STORE THE INTEGER IN ICONST
! THE REAL IN RCONST AND THE STRING IN SCONST.
! NB 65 IS A VALID INTEGER OR REAL AND ALSO A STRING ('A')
!
         ICONST=0; RCONST=0; SCONST=''
         SIGN=4; CTYPE=TYPE; CONSTSFOUND=0
!
         %IF A(P)=1 %THEN %START;     ! CONSTANT GIVEN
            SIGN=A(P+1); CTYPE=A(P+2)&7
            CONSTSFOUND=1
            %IF CTYPE=2 %THEN %START; ! REAL CONSTANT
               FROMAR8(P+3,RCONST)
               %IF SIGN=2 %THEN RCONST=-RCONST
            %FINISH
!
            %IF CTYPE=5 %THEN SCONST=STRING(ADDR(A(P+3))+1)
!
            %IF CTYPE=1 %THEN %START; ! INTEGER CONSTANT
               FROMAR4(P+3,ICONST)
               %IF SIGN=2 %THEN ICONST=-ICONST
               %IF SIGN=3 %THEN ICONST=\ICONST
               %IF TYPE=2 %THEN %C
               RCONST=ICONST;         ! INTEGER A SPECIAL CASE OF REAL
               %IF 1<=ICONST<=127 %THEN SCONST=TOSTRING(ICONST)
            %FINISH
         %FINISH
         LENGTH=BYTEINTEGER(ADDR(SCONST))
!
!
! FAULT ANY OBVIOUS ERRORS IE:-
! CONSTANT FOR EXTRINSIC OR INCOMPATIBLE TYPE OR STRING TOO LONG
!
         %IF (EXTRN=3 %AND CONSTSFOUND#0 ) %OR %C
            (CTYPE=2 %AND TYPE#2) %OR %C
            (CTYPE=5 %AND (TYPE#5 %OR SIGN#4 %OR LENGTH>=ACC)) %C
            %OR (SIGN=3 %AND CTYPE#1) %THEN FAULT(44,0)
!
         %UNTIL NNAMES=0 %CYCLE;         ! DOWN <NAMELIST>
            J=0; K=A(PP)
            %IF TYPE=5 %THEN %START;         ! STRING
               QQ=STPTR; AD=ADDR(SCONST)
               %IF EXTRN<=1 %AND ACC<=8 %THEN %START
                  NAM=0; PACK(PTYPE)
                  TAGDISP=GLACA;    ! SHORT STRING INTO GLA NO POINTER
                  PGLA(1,ACC,AD)
               %FINISH %ELSE %START
                  %IF EXTRN=3 %THEN %START;  ! EXTRINSIC STRINGS
                     AH3=0;                  ! DUMMY STRING HEADER
                  %FINISH %ELSE %START
                     LPUT(LPUTP,ACC,QQ,AD) %IF INHCODE=0;! O/P STRING
                     STPTR=(STPTR+ACC+3)&(-4)
                     AH3=QQ
                  %FINISH
                  AH3=AH3!(ACC-1)<<24
                  PGLA(4,4,ADDR(AH3))
                  TAGDISP=GLACA-4
                  %IF EXTRN=3 %THEN GXREF(2,K,ACC,TAGDISP) %C
                     %ELSE RELOCATE(TAGDISP,AH3,LPUTP)
                  EPTYPE=4; EPDISP=QQ;       ! DATA IN GLA SYMBOL TABLES
               %FINISH
            %FINISH %ELSE %START;           ! INTEGER & REAL
               %IF EXTRN=3 %THEN %START;    ! EXTRINSICS
                  NAM=1; PACK(PTYPE);       ! EXTRINSICS VIA PTR
                  CXREF(2,K,ACC,TAGDISP)
               %FINISH %ELSE %START;        ! OWN,EXTERNAL&CONST
                  %IF TYPE=2 %THEN %START
                     AD=ADDR(RCONST)
                  %FINISH %ELSE %START;     ! INTEGER VARIABLES
                     FAULT(44,0) %IF (PREC&3=1 %AND ICONST>255) %C
                               %OR (PREC&3=2 %AND !ICONST!>>16#0)
                     AD=ADDR(ICONST)+4-ACC
                  %FINISH
                  %IF TYPE=1 %AND EXTRN=0 %AND 0<=ICONST<4096 %C
                     %THEN KFORM=ICONST %ELSE KFORM=-1
                  %IF EXTRN=0 %AND ACC>1 %START;  !CONST VAR==CONST SO SHARE IT
                     STORE CONST(CBASE,TAGDISP,ACC,AD)
                  %FINISH %ELSE %START
                     PGLA(ACC,ACC,AD);      ! PUT CONSTANT INTO GLA
                     CBASE=GLA
                     TAGDISP=GLACA-ACC;     ! OFFSET OF VAR FOR TAGS
                     EPDISP=TAGDISP;        ! AND FOR ENTRY DEFN
                     EPTYPE=3;              ! DATA IN ADRESSABLE GLA
                  %FINISH
               %FINISH
            %FINISH
            STAG(TAGDISP,ACC)
            PP=PP+1
         %REPEAT
         P=MARK
         %REPEAT
         ->99
RECORD:                                ! <XOWN>'%RECORD'<NAMELIST>
!***********************************************************************
!*       NO INITIALISATION OF OWN RECORDS ALLOWED SO THEY ARE ALL      *
!*       CLEARED TO ZERO.                                              *
!***********************************************************************
         MARKER1=P+A(P)+3-MODE;     ! TO FORMAT NAME
         FNAM=A(MARKER1)
         COPYTAG(FNAM)
         FINF=TCELL
         %IF PTYPE#4 %THEN FAULT(62,FNAM) %AND ->99
         %IF EXTRN=0 %THEN PTYPE=143 %ELSE PTYPE=103
         KFORM=FINF;! UNPACK
            *L_1,PTYPE; *CVD_1,0(11)
            *UNPK_ROUT(5),5(3,11)
            *NC_ROUT(5),MASK1
         ->NONSCALAR %IF MODE=3
         NNAMES=A(P); PTYPE=1003; J=0
         %UNTIL NNAMES=0 %CYCLE
            P=P+1; K=A(P)
            %IF EXTRN=3 %THEN %START;     ! EXTRINISIC
               CXREF(2,K,ACC,TAGDISP); ! RELOCATE BY EXTERNAL
            %FINISH %ELSE %START
               CLEAR(ACC)
               EPDISP=STPTR-ACC
               AH3=EPDISP
               RELOCATE(-1,AH3,LPUTP);! PUT DISP INTO GLA
               TAGDISP=GLACA-4;        ! AND RELOCATE REL APPROPIATE AREA
               EPTYPE=4;              ! DATA IN GLA SYMBOL TABLES
            %FINISH
            STAG(TAGDISP,ACC)
         %REPEAT
         ->99
NONSCALAR:                             ! OWN AND OWNRECORD ARRAYS
!***********************************************************************
!*       OWN ARRAYS CAN BE INITIALISED BUT ONLY ONE ARRAY CAN BE       *
!*       DECLARED IN A STATEMENT.(THANK HEAVENS!)                      *
!*       OWN RECORD ARRAYS ARE CLEARED TO ZERO                         *
!***********************************************************************
         PP=P+1; P=P+2; J=1; NNAMES=1
         K=A(PP)
         CBPAIR(KK,KKK)
         %IF TYPE>=3 %THEN BP=ACC %ELSE BP=BYTES(PREC)
         LENGTH=KKK-KK+1; QQ=LENGTH*BP
         CONSTS FOUND=0
         %IF MODE#3 %THEN %START;   ! NOT A RECORD ARRAY
            FROM AR4(P+1,CONSTS FOUND)
            FROM AR4(P+3,SPOINT);    ! DISPLACEMENT OF CONSTANTS
         %FINISH
         !*INSERT
         %IF CONSTS FOUND=0 %THEN %START;! NO CONSTANTS GIVEN
                                         ! SO CLEAR AN AREA TO ZERO
            CONSTS FOUND=LENGTH
            CLEAR(QQ) %UNLESS LENGTH<1 %OR EXTRN=3
            SPOINT=STPTR-QQ
         %FINISH %ELSE %START
         !*INSERT
            FAULT(46,K) %IF EXTRN=3
         %FINISH
         FAULT(45,K) %UNLESS KKK>=KK %AND LENGTH=CONSTS FOUND
!
! NOW OUTPUT A DOPE VECTOR FOR STRING ARRAYS OR IF CHECKS ARE ON
!
         %UNLESS COMPILER=1 %AND CHECKS=0 %AND TYPE#5 %THEN %START
            AH3=DOPE VECTOR(BP,KK,KKK)
         %FINISH %ELSE AH3=SSTL
         %IF EXTRN=3 %THEN EPDISP=0 %ELSE EPDISP=SPOINT
!
! OUTPUT AN ARRAYHEAD INTO THE GLA RELATIVE TO THE START OF THE SYMBOL-
! TABLES IN WHICH THE ARRAY RESIDES. PERM INITIALISATION WILL RELOCATE
! BY ADDING INTO AH1-3 THE VIRTUAL ADDRESS OF THE START OF THE
! APPROPIATE AREA.
!
         AH1=EPDISP-KK*BP
         AH2=EPDISP
         AH4=BP; JJ=16-COMPILER<<2
         PGLA(4,JJ,ADDR(AH1))
         TAGDISP=GLACA-JJ
         %IF EXTRN=3 %THEN %START;     ! EXTRINSIC ARRAYS
            GXREF(2,K,QQ,TAGDISP);     ! RELOCATE ADDR(A(0))
            GXREF(2,K,QQ,TAGDISP+4);   ! RELOCATE ADDR(A(FIRST))
         %FINISH %ELSE %START
            RELOCATE(TAGDISP,AH1,LPUTP);! RELOCATE ADDR(A(0))
            RELOCATE(TAGDISP+4,AH2,LPUTP);! RELOCATE ADDR(A(FIRST))
         %FINISH
         RELOCATE(TAGDISP+8,AH3,4);    ! RELOCATE DV POINTER
         EPTYPE=4;                     ! DATA IN GLA SYMBOL TABLES
         STAG(TAGDISP,QQ)
         -> 99
         %ROUTINE CLEAR(%INTEGER LENGTH)
               STPTR=(STPTR+7)&(-8)
         LENGTH=(LENGTH+3)&(-4)
         LPUT(LPUTP,LENGTH,STPTR,0)%IF INHCODE=0
         STPTR=STPTR+LENGTH
         %END
         %ROUTINE STAG(%INTEGER J,DATALEN)
         TEST NST
         %IF EXTRN=2 %THEN DEFINE EP(EPTYPE,K,EPDISP,DATALEN)
         RBASE=CBASE
         STORE TAG(K,J)
         RBASE=10-RLEVEL
         NNAMES=NNAMES-1
         %END
99:      %END; ->1
SW(18):
         P=P+1
         CRSPEC(2); -> 1
SW(19):
                                        ! '%NAME' SPECIAL NAME
         PUSH123(TAGS(A(P+1)),SNPT<<16!X'8090',0,SNUM<<16)
         SNUM=SNUM+1;->1
SW(20):                          ! TRUSTED PROGRAM
!
! TRUSTED PROGRAMS HAVE:-
!     1) NO JUMPS ROUND ROUTINE BODIES
!     2) NO ERROR EXITS FROM FNS & MAPS
!     3) NO CYCLES OF THE FORM I:=1,1,I
!     4) NO RELIANCE ON THE VALUE OF CYCLE VARIABLES AT TERMINATION
!
         MARGIN=512
         COMPILER=1 %IF CHECKSP=0;     ! ONLY WORKS ON PARM OPT
         ->1
SW(21):
                                       ! '%REGISTER'(NAME)(S)
         WARN(LINE)
         %IF A(P+2)=1 %THEN KK=A(P+3) %ELSE FINDREG(CLMABL,KK)
         %IF 4<KK<15 %AND REGISTER(KK)=0 %THEN %START
            UVARREG(KK)=LEVEL
            PTYPE=8; J=0
            K=A(P+1); TESTNST
            KFORM=M'RG'
            STORE TAG(K,KK)
            SET USE(KK,3,TAGS(K))
            REGISTER(KK)=-1
         %FINISH %ELSE FAULT(58,0)
SW(22):
         -> 1;                         ! '%MCODE'
SW(24):
         P=P+1; LCA=0; CUCI; -> 1;            ! '*'(UCI)(S)
SW(26):
         %BEGIN;                       ! %COMMENT %DEFINE (SOMETHING)
         %SHORTROUTINE
         %SWITCH S(1:3)
         %INTEGER I,J,K
         -> S(A(P+1))
S(1):    I=ADDR(FIXED GLA(27)); ->1
S(2):    I=ADDR(IOCP1)+3; ->1
S(3):    I=ADDR(MAIN EP1)+3
1:       K=A(P+2)
         FAULT(50,0) %UNLESS CPRMODE=0 %AND K<=7
         J=ADDR(A(P+2))+1
         *L_1,I;*L_2,J
         *MVC_0(8,1),0(2)
         %END; ->1
SW(25):
                                       ! %CONTROL (CONST)
!         FAULT(33,0) %UNLESS IMPS=1
         FROM AR4(P+2,J)
         K=J&15; LINENOS=K %UNLESS K=15
         K=J>>4&15; DIAGS1=K&1 %AND DIAGS2=K&2 %UNLESS K=15
         K=J>>8&15
         CHECKS=K %UNLESS K=15
         CHECKSP=K&14 %UNLESS K=15
         GLAFLAG=CHECKSP
         K=J>>12&15
         UNASS=K %UNLESS K=15
         K=J>>24&15
         %IF K=1 %THEN %START;         ! PERMIT LOWER CASE NAMES
            %CYCLE I=1,1,26
               TRTABS(I+96)=0
            %REPEAT
         %FINISH
         K=J>>28
         %IF K=1 %THEN CODEOUT
         DCOMP=K %UNLESS K=15
         ->1
SW(27):
         %BEGIN;                       ! %RECORD (RDECLN)
!***********************************************************************
!*       RECORDS ARE ALLOCATED AT COMPILE TIME WHEN POSSIBLE           *
!*       SEE CRFORMAT FOR ACTION ON RECORD FORMAT DECLARATIONS         *
!***********************************************************************
         %SHORTROUTINE
         %INTEGER MODE,RECL,ALLOC,FNAM,FINF,NAME
         P=P+1; MODE=A(P)
         %IF MODE=1 %THEN %START;      ! DEAL WITH FORMAT
            NAME=A(P+1); P=P+2
            CRFORMAT(OPHEAD); K=NAME
            PTYPE=4; J=0
            KFORM=OPHEAD
            TEST NST; STORE TAG(K,OPHEAD)
            ->99
         %FINISH
         P=P+1; MARKER1=P+A(P)
         FNAM=A(MARKER1);              ! FORMAT NAME
         COPY TAG(FNAM)
         FINF=TCELL
         %IF TYPE#4 %THEN %START
            FINF=DUMMY FORMAT
            ACC=4; FAULT(62,FNAM)
         %FINISH
         RECL=ACC
         %IF MODE=2%THEN %START;       ! '%RECORDSPEC'
            COPY TAG(A(P+1))
            %IF A(P+2)=1 %AND TYPE=4 %START;! SPEC FOR FORMAT ELEMENT
               P=P+3
               Q=DISPLACEMENT(TCELL)
              ! UNPACK
            *L_1,PTYPE; *CVD_1,0(11)
            *UNPK_ROUT(5),5(3,11)
            *NC_ROUT(5),MASK1
            %FINISH
            %IF TYPE=3 %AND NAM=1 %AND FROM3(TCELL)&X'FFFF'=0 %START
               REPLACE3(TCELL,FINF!K<<16)
               REPLACE2(TCELL,SNDISP<<16!RECL)
            %FINISH %ELSE FAULT(63,0)
         %FINISH %ELSE %START;         ! RECORD DECLARATION
            FAULT(57,0) %UNLESS LEVEL>=2
            FAULT(40,0) %IF NMDECS&1#0
            TYPE=3; PREC=0; ROUT=0
           %IF A(P+1)=1 %THEN %START;  ! SIMPLE RECORD AND RECORDNAMES
               ALLOC=ACC; CQN(P+2)
               ACC=ALLOC; P=P+3
               DECLARE SCALARS(1,FINF)
            %FINISH %ELSE %START;      ! ARRAYS OF RECORDS
               NAM=0
               Q=2-A(P+2); P=P+3;      ! Q=1 FOR ARRAY FORMAT
               DECLARE ARRAYS(Q,FINF)
            %FINISH
         %FINISH
99:      %END;->1
!

SW(28):                                 ! '%ON'(EVENT')(N)(RESTOFNLIST)
%BEGIN
%SHORTROUTINE
%INTEGER EL,KK,EF
%CONSTINTEGERARRAY EFMAP(1:14)=X'04E10003',8,X'20000',X'2000',
                  X'08100074',X'A0000000',X'2000000',X'40000000',
                  X'100',X'01000000',X'40000',0(3);
      FAULT(40,0) %IF NMDECS&1#0
      NMDECS=NMDECS!1
      FAULT(26,0) %UNLESS LEVEL=2 %AND CPRMODE#2
      P=P+2; SFLABEL=SFLABEL-1; EL=SFLABEL
      %UNTIL A(P-1)=2 %CYCLE;           ! UNTIL NO MORE RESTOFNLIST
         KK=A(P)
         %IF 1<=KK<=14 %START
            EF=EFMAP(KK)
            %CYCLE I=0,1,31
               %IF 1<<I&EF#0 %START
                  PCONST(X'41100001'+I)
                  PPJ(20); QQ=CA
                  ENTER JUMP(15,EL,0)
                  PCONST(X'07000700') %UNLESS CA=QQ+8
               %FINISH
            %REPEAT
         %FINISH %ELSE FAULT(36,0)
         P=P+2
      %REPEAT
      ENTER JUMP(15,SFLABEL-1,0);       ! ROUND ON START-FINISH
      CSTART(2)
      ENTER LAB(EL,0); MONE=1
%END; ->1
         %ROUTINE CRFORMAT(%SHORTINTEGERNAME OPHEAD)
         %SHORTROUTINE
!***********************************************************************
!*       CONVERTS A RECORDFORMAT STATEMENT TO A LIST HEADED BY OPHEAD  *
!*       FORMAT OF AN ENTRY.                                           *
!*       S1=SUBNAME<<20!PTYPE<<4!J                                     *
!*       S2,S3=4  16 BIT DISPLACEMENTS  D2,ACC,D1,KFORM                *
!*       NORMALLY D1=RECORD RELATIVE DISPLACEMENT AND ACC=LMAX(STRINGS)*
!*       FOR ARRAYS D2=ZERO ELEMENT DISPLACEMENT AND D1=DISPLACEMENT   *
!*       OF RECORD RELATIVE ARRAYHEAD IN THE GLA                       *
!*       KFORM IS ONLY USED FOR RECORDS AND POINTS TO THE FORMAT       *
!*       ON EXIT ACC HAS THE RECORD SIZE ROUNDED UP TO THE BOUNDARY    *
!*       REQUIRED BY ITS LARGEST COMPONENT                             *
!***********************************************************************
         %SHORTINTEGER D1,D2,NLIST,SLIST,FORM
         %INTEGER RL,MRL;               ! ROUNDING LENGTH & MAX
         %INTEGER REP,INC,Q,LB,UB,R,A0,A1,DV,L,RFD
         %SWITCH RFEL(1:5)
         %ROUTINESPEC SN(%INTEGER Q)
         %ROUTINESPEC ROUND
         NLIST=0; OPHEAD=0; FORM=0; ACC=0
         MRL=0; INC=0;                 ! INC COUNTS DOWN RECORD
NEXT:    ROUT=0; NAM=0; RFD=A(P)
         %IF RFD<=2 %THEN P=P+1 %AND CLT
         ->RFEL(RFD)
RFEL(1):                               ! (TYPE) (QNAME')(NAMELIST)
         CQN(P); P=P+1
         PACK(PTYPE); D2=0
         %IF ACC>8 %THEN RL=3 %ELSE RL=ACC-1
         %IF PTYPE=5 %THEN RL=0;       ! STRINGS NOT ALIGNED
 1:      ROUND ; J=0
         %CYCLE REP=1,1,A(P)
            P=P+1; D1=INC
            SN(P); INC=INC+ACC
         %REPEAT
         P=P+1+RFD>>2;       ! EXTRA  ONE FOR RECORDS TO SKIP FORMAT
TRY END: -> END %IF A(P)=2
         P=P+1; -> NEXT
RFEL(2):2:                             ! (TYPE)%ARRAY(NAMELIST)(CBPAIR)
         Q=P; ARR=1; PACK(PTYPE)
         %UNTIL A(P-1)=2 %CYCLE;       ! UNTIL <RESTOFARRAYLIST> NULL
            P=A(P)+P+1; CBPAIR(LB,UB)
            R=UB-LB+1
            DV=DOPE VECTOR(ACC,LB,UB); ! DOPE VECTOR INTO SHAREABLE S.T.
            %IF TYPE=5 %THEN RL=0 %ELSE RL=ACC-1
            %IF TYPE=3 %THEN RL=7
            ROUND; J=1
            %CYCLE REP=1,1,A(Q);       ! ARRAYHEAD  INTO GLA FOR EACH AR
               A1=INC; A0=A1-ACC*LB
               L=ACC
               PGLA(4,16,ADDR(A0))
               D1=GLACA-16
               RELOCATE(D1+8,DV,4);    ! RELOCATE DV POINTER
               D2=A0
               SN(Q+REP); INC=INC+R*ACC
            %REPEAT
            P=P+1; Q=P
         %REPEAT
         P=P+1 %IF RFD=5
         -> TRY END
RFEL(3):                               ! %RECORD (%ARRAY) %NAME
         TYPE=3; PREC=0; NAM=1
         ARR=2-A(P+1); P=P+2
         PACK(PTYPE); D2=0
         RL=3; ACC=4+12*ARR
         FORM=0
         ->1
RFEL(4):                               ! RECORDS IN RECORDS
RFEL(5):                                ! RECORDARRAYS IN RECORDS
         Q=P+A(P+1)+6-RFD
         COPY TAG(A(Q));               ! COPY FORMAT TAG & SET ACC
         FAULT(62,A(Q)) %UNLESS PTYPE=4
         TYPE=3; FORM=TCELL
         %IF RFD=4 %THEN %START
            PTYPE=3; P=P+1; D2=0
            RL=7; ->1
         %FINISH
         P=P+2; ->2
END:                                   ! FINISH OFF
         RL=MRL; ROUND
         ACC=INC;                      ! SIZE ROUNDED APPROPRIATELY
         FAULT(98,0) %UNLESS INC<=X'7FFF'
         OPHEAD=SLIST
         CLEAR LIST(NLIST)
         %RETURN
         %ROUTINE SN(%INTEGER Q)
!***********************************************************************
!*       CHECK THE SUBNAME HAS NOT BEEN USED BEFORE IN THIS FORMAT     *
!*       AND ENTER IT WITH ITS DESCRIPTORS INTO THE LIST.              *
!***********************************************************************
         FNAME=A(Q)
         FAULT(7,FNAME) %UNLESS FIND(FNAME,NLIST)=-1
         INSERT AFTER(OPHEAD,FNAME<<20!PTYPE<<4!J,D2<<16!ACC)
         REPLACE3(OPHEAD,D1<<16!FORM)
         %IF NLIST=0 %THEN SLIST=OPHEAD
         PUSH(NLIST,0,FNAME)
         %END
         %ROUTINE ROUND
         MRL=RL %IF RL>MRL
         INC=INC+1 %WHILE INC&RL#0
         %END
         %END;                         ! OF ROUTINE CRFORMAT
         %ROUTINE CRNAME(%INTEGER Z,REG,MODE,CLINK,BS,IX,DP)
         %SHORTROUTINE
!***********************************************************************
!*       DEAL WITH RECORD ELEMENT NAMES.Z AS FOR CNAME.CLINK=TAGS(RN)  *
!*       MODE=0 IF RECORD AT BS,IX&DP                                  *
!*       MODE=1 IF POINTER IN CORE AT BS,IX&DP                         *
!*       ON EXIT BASE,INDEX & DISP POINT TO REQUIRED ELEMENT           *
!*       RECURSIVE CALL IS NEEDED TO DEAL WITH RECORDS IN RECORDS      *
!*       DEPTH SHEWS  RECURSIVE LEVELS- NEEDED TO AVOID MIS SETTING    *
!*       REGISTER IN USE IF RECORDNAME IN RECORD HAS THE SAME NAME AS  *
!*       A GENUINE RECORD NAME.                                        *
!***********************************************************************
         %INTEGER DEPTH,FNAME,ACCP
         %ROUTINESPEC CENAME(%INTEGER MODE,FNAME,BS,IX,DP)
         %ROUTINESPEC NOAPP
         DEPTH=0
         FNAME=KFORM;                  ! POINTER TO FORMAT
         %IF ARR\=0 %THEN %START;      ! RECORDARRAY(ARRAYNAME)
            FAULT(217,0) %IF IX\=0
            CANAME(ARR,BS,DP,SNDISP)
            NAM=0; ARR=0;                 ! ARR & NAM AS FOR SCALAR RECORD
            CENAME(0,FNAME,BASE,INDEX,DISP)
         %FINISH %ELSE %START
            %IF A(P+1)=2 %THEN P=P+2 %ELSE NO APP
            CENAME(MODE,FNAME,BS,IX,DP)
         %FINISH; ->99
!
         %ROUTINE NOAPP
            P=P+1
            %IF A(P)=1 %THEN %START;    ! <APP> PRESENT
               FAULT(19,A(P-1))
               SKIP APP
            %FINISH %ELSE P=P+1;         ! P NOW POINTS TO ENAME
         %END
         %ROUTINE CENAME(%INTEGER MODE,FNAME,BS,IX,DP)
!***********************************************************************
!*       FINDS OUT ABOUT SUBNAME AND ACTS ACCORDINGLY.MOSTLY ACTION    *
!*       CONSISTS OF UPPING DP BY OFFSET OF THE SUBNAME BUT IS VERY    *
!*       HAIRY FOR RECORDS IN RECORDS ETC                              *
!***********************************************************************
         %ROUTINESPEC CHANGE MODE
         %ROUTINESPEC COMBINE(%INTEGER HOW)
         %INTEGER Q,QQ,D,C
         DEPTH=DEPTH+1
         %IF A(P)=2 %THEN %START;      ! ENAME MISSING
            BASE=BS; DISP=DP;INDEX=IX; ! FOR POINTER
            %IF Z<14 %THEN %START;     ! NOT A RECORD OPERATION
               P=P-2
               %UNLESS 3<=Z<=4 %OR (Z=1 %AND REG=99) %START;! ADDR(RECORD)
                  FAULT(64,0); BASE=RBASE
                  DISP=0; INDEX=0; PTYPE=1;! UNPACK
            *L_1,PTYPE; *CVD_1,0(11)
            *UNPK_ROUT(5),5(3,11)
            *NC_ROUT(5),MASK1
               %FINISH
            %FINISH
            %RETURN
         %FINISH
         P=P+1;                        ! FIND OUT ABOUT SUBNAME
         Q=DISPLACEMENT(FNAME);        ! TCELL POINTS TO CELL HOLDING
        ! UNPACK;                       ! INFO ABOUT THE SUBNAME
            *L_1,PTYPE; *CVD_1,0(11)
            *UNPK_ROUT(5),5(3,11)
            *NC_ROUT(5),MASK1
         %IF Q=-1=ACC %OR PTYPE=7 %START;! WRONG SUBNAME(HAS BEEN FAULTED)
            P=P+1; SKIP APP; P=P-2
            INDEX=0; BASE=0; DISP=0
            %RETURN
         %FINISH
         ->20 %IF ARR=1
         %IF MODE=1 %THEN CHANGE MODE
         %IF TYPE<=2 %OR TYPE=5 %THEN %START
            BASE=BS;  INDEX=IX;  DISP=DP+Q
         ->99; %FINISH
!
! NOW CODING BECOMES HAIRY:- STILL LEFT ARE
! A) RECORDS IN RECORDS   Q POINTS TO SECONDARY RECORD
! B) RECORDNAMES IN RECORDS   Q HAS OFF-SET OF A POINTER
! C) RECORDARRAYNAMES IN RECORDS   Q HAS OFF-SET A HEADER IN RECORD
! D) RECORDARRAYS IN RECORDS   NOT YET ALLOWED
!    Q WOULD HAVE OFF-SET OF A RECORD RELATIVE HEADER IN THE GLA
!
         %IF A(P+1)=2 %THEN P=P+2 %ELSE NOAPP
         CENAME(NAM,KFORM,BS,IX,DP+Q)
         ->99
20:                                    ! ARRAYS AND ARRAYNAMES AS ELEMEN
         FROM123(TCELL,Q,INTEGER(ADDR(SNDISP)),INTEGER(ADDR(K)))
         C=ACC; D=SNDISP; Q=K; QQ=KFORM
         %IF Z=12 %AND A(P+1)=2 %START;! 'GET ARRAYHEAD' CALL
            %IF MODE=1 %THEN CHANGE MODE
            %IF NAM=1 %THEN %START
               COMBINE(0)
               INDEX=0; BASE=BS; DISP=DP+Q
               %RETURN
            %FINISH
!
! PASSING AN ARRAY IN A RECORD BY NAME MUST CONSTRUCT PROPER ARRAYHEAD
! FROM THE RECORD RELATIVE ONE AT Q(GLA)
!
            COMBINE(1);                ! REDUCE TO A SINGLE POINTER
            CREATE AH(1,BS,GLA,Q)
            REGISTER(BS)=0 %IF REGISTER(BS)=2
         %FINISH %ELSE %START;         ! ARRAY ELEMENTS IN RECORDS
            %IF NAM=1 %THEN %START;    ! ARRAYNAMES-FULLHEAD IN RECORD
               %IF MODE=1 %THEN CHANGE MODE
               COMBINE(0);             ! IN CASE ARRAYNAME IN RECDARRAY
               CANAME(17,BS,DP+Q,0);   ! ARRAY MODE SETS DISP,INDEX&BASE
               REGISTER(BS)=0 %IF REGISTER(BS)=2
               BML=BS; DML=DP; NAM=0;  ! HEAD POSN STRINGS NEED
                                       ! LMAX FROM DOPEVECTOR
            %FINISH %ELSE %START;      ! ARRAY RELATIVE HEAD IN GLA
               COMBINE(0); J=1;        ! REDUCE TWO POINTERS TO ONE
               CANAME(3,GLA,Q,D);      ! VECTOR MODE D= BASIC DISP
                                       ! SETS INDEX AND DISP ONLY
               %IF INDEX>0 %THEN REGISTER(INDEX)=REGISTER(INDEX)!1
               %IF MODE=1 %THEN CHANGE MODE
               %IF INDEX>0<=REGISTER(INDEX) %THEN REGISTER(INDEX)=0
               BASE=BS; DISP=DISP+DP
               BML=-1; DML=C&X'FFFF'-1;! FOR STRING ARRAYS
               ADJUST INDEX(REGISTER(INDEX)+1,INDEX,DISP) %IF DISP<0
            %FINISH
            %IF TYPE=3 %THEN CENAME(0,QQ,BASE,INDEX,DISP)
         %FINISH
         ->99
         %ROUTINE CHANGE MODE
!***********************************************************************
!*       CHANGES MODE=1 RECORDS TO MODE=0 RECORDS BY PICKING UP THE    *
!*       POINTER TO SAFE REGISTER AND RESETTING BS,DP AND IX           *
!***********************************************************************
         %INTEGER REG
         REG=-1
         %IF DEPTH=1 %THEN FIND USE(REG,1,7,CLINK)
         %UNLESS REG>0 %AND REGISTER(REG)#1 %START
            FIND REG(ADDREG,REG)
            DUMP(X'58',REG,DP,IX,BS);     !  L   REG POINTER
            %IF DEPTH=1 %AND CLINK>0 %THEN SET USE(REG,7,CLINK) %C
                                     %ELSE FORGET(REG)
            %IF REGISTER(BS)=2 %THEN REGISTER(BS)=0
         %FINISH
         REGISTER(REG)=2 %IF REGISTER(REG)=0
         GRAT(REG)=CA
         BS=REG;IX=0; MODE=0; DP=0
         %END;                         ! OF CHANGE MODE
         %ROUTINE COMBINE(%INTEGER HOW)
!***********************************************************************
!*       COMBINES IX&BS INTO ONE SAFE REGISTER - IF HOW=1 THEN DP IS   *
!*       INCLUDED ALSO. IF HOW=0 THEN DP IS LEFT ALONE                 *
!***********************************************************************
         %INTEGER REG
         %IF IX=0 %AND (HOW=0 %OR DP=0) %THEN %RETURN
         %IF 4<=BS<=14 %AND REGISTER(BS)>=0 %THEN REG=BS %ELSE %C
         FIND REG(ADDREG,REG)
         DUMP(X'41',REG,DP*HOW,IX,BS)
         %IF REGISTER(BS)=2 %THEN REGISTER(BS)=0
         FORGET(REG); IX=0
         BS=REG;  REGISTER(BS)=2
         %IF HOW=1 %THEN DP=0
         %END;                         ! OF ROUTINE COMBINE
99:      %END;                         ! OF ROUTINE CENAME
99:      REGISTER(BASE)=0 %IF REGISTER(BASE)=2
         %END;                         ! OF ROUTINE CRNAME
         %INTEGERFN     DISPLACEMENT(%INTEGER LINK)
         %SHORTROUTINE
!***********************************************************************
!*         SEARCH A FORMAT LIST FOR A SUBNAME                          *
!*      A(P) HAS ENAME--LINK IS HEAD OF RFORMAT LIST. RESULT IS DISP   *
!*      FROM START OF RECORD                                           *
!***********************************************************************
         %INTEGER RR,II,ENAME,CELL
         ENAME=A(P); CELL=0
         %IF LINK#0 %THEN %START;    ! CHK RECORDSPEC NOT OMITTED
            LINK=FROM3(LINK)&X'7FFF';   ! LINK TO SIDE CHAIN
            CELL=LINK; II=-1; ACC=-1
!            %WHILE LINK>0 %CYCLE
!               FROM123(LINK,RR,INTEGER(ADDR(SNDISP)),INTEGER(ADDR(K)))
!               TCELL=LINK
!               MLINK(LINK)
!               %IF RR>>20=ENAME %THEN %START;      ! RIGHT SUBNAME LOCATED
!                  J=RR&15; PTYPE=RR>>4&X'FFFF'
!                  %RESULT=K
!               %FINISH
!            %REPEAT
            *L_0,ENAME; *L_1,LINK; *L_2,ASLIST
AGN:        *LTR_1,1; *BC_12,<END>
            *L_3,0(1,2); *SRL_3,20; *CR_3,0
            *BC_8,<HIT>; *LH_1,14(1,2); *BC_15,<AGN>
HIT:        *ST_1,TCELL
         *A_1,ASLIST; *LM_2,4,0(1)
         *ST_2,RR; *ST_3,SNDISP; *ST_4,K
            J=RR&15; PTYPE=RR>>4&X'FFFF'
            %RESULT=K
END:
         %FINISH
         FAULT(65,ENAME)
         %IF CELL>0 %THEN %C
         PUSH(SHORT INTEGER(ADDR(ASLIST(CELL+14))),ENAME<<20!7<<4,0)
         PTYPE=7; TCELL=0
         %RESULT=-1
         %END
         %INTEGERFN     COPY RECORD TAG(%INTEGERNAME SUBS)
         %SHORTROUTINE
!***********************************************************************
!*       PRODUCE PTYPE ETC FOR A COMPOUND NAME BY CHAINING DOWN ONE    *
!*       ONE OR MORE RECORD FORMAT LISTS. ON EXIT RESULT =0 IF NO      *
!*       SUBNAME FOUND OR SUBNAME IS OF TYPE RECORD WITH NO FURTHER    *
!*       SUBNAME ATTACHED. RESULT#0 IF BONE-FIDE SUBNAME LOCATED       *
!*       ON ENTRY KFORM HAS POINTER TO THE (FIRST ) FORMAT LIST AND    *
!*       P POINTS TO THE A.R. ENTRY FOR (FIRST) ENAME                  *
!***********************************************************************
         %INTEGER Q,FNAME
         SUBS=0
         %UNTIL TYPE#3 %CYCLE
            FNAME=KFORM
            P=P+1; %IF A(P)=2 %THEN P=P+1 %ELSE SKIP APP
            %RESULT=0 %IF A(P)=2 %OR FNAME<=0;! NO (FURTHER) ENAME
            SUBS=SUBS+1
            P=P+1; Q=DISPLACEMENT (FNAME)
           ! UNPACK
            *L_1,PTYPE; *CVD_1,0(11)
            *UNPK_ROUT(5),5(3,11)
            *NC_ROUT(5),MASK1
         %REPEAT
         %RESULT=Q+1;       ! GIVES 0 IF SUBNAME NOT KNOWN
         %END
         %ROUTINE STRINGOP(%INTEGER Z,L,BTO,DTO,BFRM,DFRM,BML,DML,XREG)
!***********************************************************************
!*       PERFORM ANY STRING OPERATION WHICH INVOLVES EXECUTING SS      *
!*       INSTRUCTIONS                                                  *
!*       Z=0 FOR CLC                                                   *
!*       Z=1 FOR STORE(=)                                              *
!*       Z=2 FOR CONCATENATE                                           *
!*       Z=4 FOR STORE(<-)                                             *
!*       Z=5 FOR LEXIOGRAPHIC STRING ORDERING                          *
!*       STRINGL>0 %IF LENGTH OF STRING KNOWN =0 NOT KNOWN             *
!*       BML & DML DEFINE POSITION OF MAX LENGTH BYTE                  *
!*       BML=0  DML=MAX LENGTH IF THIS KNOWN AT COMPILE TIME           *
!***********************************************************************
         %SHORTROUTINE
         %INTEGER RSTATE1,RSTATE2,RSTATE3,W,FIXL,CCREG,SCA
         %IF Z=4 %AND BML<=0 %AND DML=255 %THEN Z=1
         RSTATE1=REGISTER(BTO); REGISTER(BTO)=1
         RSTATE2=REGISTER(BFRM); REGISTER(BFRM)=1
         %IF BML>0 %THEN RSTATE3=REGISTER(BML) %AND REGISTER(BML)=1
         BML=0 %IF BML<0
         PLABEL=PLABEL-1
         %IF Z=5 %THEN %START;        ! LEXIOGRAPHIC ORDERING
!
! THE CAREFULLY OPTIMISED BUT OBSCURE CODE PLANTED IS:-
!       SR XREG,XREG. IC XREG, D2(B2)
! (OR   LA XREG,STRLENGTH2           WHEN 2ND OPERAND LENGTH KNOWN)
!       CLC D1(1,B1),D2(B2)          COMPARE THE LENGTHS
!       BALR CCREG,0                 SAVE CC FOR LATER & SET BASEREG
!       BNH L3                       SHORTEST LENGTH IN XREG
!LEX    CLC D1+1(1,B1),D2+1(B1)      FOR EXECUTING BUT QUICKER TO
!                                    OBEY THIS LINE THAN JUMP ROUND IT
!       IC XREG,D1(B1)               SHORTEST LENGTH TO XREG
!L3     LTR  XREG,XREG
!       BZ    L4
!       BCTR XREG,0                   XREG = LEASTCHARS-1
!       EX   XREG,LEX
!       BC   7,LEND
!L4     SPM CCREG                     RESTORE SAVED CONDITION COD
!LEND   EQU   *
!
            %IF XREG<=0 %THEN CLAIM(GR1,XREG)
            CLAIM(GR1,CCREG)
            %IF L<=0 %THEN DUMP(4,XREG,DTO,0,BTO) %ELSE %C
                           DUMP(0,XREG,L,0,0)
            SET USE(XREG,2,-2);       ! REMEMBER TO 24 BITS ZERO
            DUMPSS(X'D5',1,BFRM,DFRM,BTO,DTO); ! CLC LENGTHS
            PRR(5,CCREG,0)
            %IF CA-CODEBASE>4095-MARGIN %THEN SETUSE(CCREG,12,CA) %C
                                        %ELSE FORGET(CCREG)
            SCA=CA
            PRX(X'47',11,CCREG,0,0)
            DUMPSS(X'D5',1,BFRM,DFRM+1,BTO,DTO+1)
            PRX(X'43',XREG,BFRM,0,DFRM)
            PLUG(1,SCA+2,CA-SCA);       ! FILL JUMP
            PRR(X'12',XREG,XREG)
            PRX(X'47',8,CCREG,0,CA+14-SCA)
            PRR(6,XREG,0)
            PRX(X'44',XREG,CCREG,0,CA-18-SCA)
            PRX(X'47',7,CCREG,0,CA-SCA+6)
            PRR(4,CCREG,0);         ! SPM CCREG
            REGISTER(CCREG)=0
         %FINISH %ELSE %START
            %IF Z=4 %THEN %START;         ! JAM TRANSFER NEEDS LMAX
               %IF BML=0 %THEN W=X'41' %ELSE W=X'43'
               DUMP(W,XREG,DML,0,BML);    ! IC %OR LA TO GET LMAX TO XREG
               XREG=NEST; REGISTER(XREG)=1;! CLAIM REGISTER FOR LMAX
               SET USE(XREG,2,-2)
            %FINISH
!
! FOR JAM TRANSFER OR ASSIGN WITH CHECKS A LENGTH COMPARISION IS NEEDED
! THIS CAN BE AVOIDED IF RESULT IS KNOWN AT COMPILE TIME
!
            %IF (Z=4 %OR Z=1=CHECKS)%AND(BML#0 %OR L<=0 %OR L>DML)%START
               %IF BML#0 %THEN %START;           ! MAX LENGTH NOT KNOWN
                  DUMPSS(X'D5',1,BFRM,DFRM,BML,DML);! CLC (LENGTHS)
               %FINISH %ELSE PSI(X'95',DML,BFRM,DFRM)
               %IF Z=4 %THEN ENTER JUMP(10,PLABEL,B'11') %ELSE %C
               PRX(X'47',2,0,CODER,88);      ! BH CAP. EXCEEDED
            %FINISH
!
            %IF Z=0 %THEN W=X'D5' %ELSE W=X'D2'
!
! LENGTHS UP TO 15 IT IS QUICKER TO MOVE XTRA CHARS.
!
            %IF Z=1 %AND BML=0 %AND DML<=15 %AND L<=0 %THEN L=DML
!
! IF THE LENGTH IS KNOWN AT COMPILE TIME THEN CODE CAN BE PLANTED TO
! PERFORM THE OPERATION. IF LENGTH NOT KNOWN UNTIL RUN TIME THEN AN
! INSTRUCTION WITH ZERO LENGTH HAS TO BE SET AND CODE PLANTED
! TO EXECUTE THE INSTRUCTION AT RUN TIME. EXECUTE ORS THE LENGTH INTO
! THE INSTRUCTION BEFORE OBEYING IT.
!
            %IF L>0 %AND Z#4 %THEN FIXL=L+1 %ELSE %START;! EXECUTE NEEDED
               FIXL=0
               %UNLESS DFRM<0 %OR DFRM>4095 %OR Z=2 %THEN %START
                  %IF XREG<0 %THEN FINDREG(GR1,XREG) %AND FORGET(XREG)
                  PRX(X'43',XREG,0,BFRM,DFRM) %UNLESS GRUSE(XREG)=13
               %FINISH %ELSE %START
                  DUMP(X'43',XREG,DFRM,0,BFRM) 
                  XREG=NEST %IF XREG<0
                  SET USE(XREG,2,-2)
               %FINISH
               REGISTER(XREG)=1
               ENTER LAB(PLABEL,B'11') %IF Z=4
               SET LOCAL BASE
            %FINISH
            %IF Z=2 %THEN DFRM=DFRM+1
            DUMPSS(W,FIXL,BTO,DTO,BFRM,DFRM)
            %IF FIXL=0 %THEN %START
               DUMP(X'44',XREG,CA-LOCALADDR-6,0,LOCALBASE);! EXECUTE IT
               DUMP(X'42',XREG,DTO,0,BTO) %IF Z=4;! STC LENGTH BYTE IF <-
            %FINISH
         %FINISH
         %IF XREG>0 %THEN REGISTER(XREG)=0
         NEST=XREG
         %IF BML>0 %THEN REGISTER(BML)=RSTATE3
         REGISTER(BFRM)=RSTATE2;         ! ORDER OF THESE 3 LINES
         REGISTER(BTO)=RSTATE1;          ! IMPORTANT IF BTO=BFRM!
         CCSTATE=-1
         %END
         %ROUTINE CSTREXP(%INTEGER MODE,REG)
         %SHORTROUTINE
!***********************************************************************
!*       PLANT IN-LINE CODE FOR CONCATENATION. A WORK AREA UNDER       *
!*       BASE REGISTER COVER IS USUALLY REQUIRED. THE CURRENT LENGTH   *
!*       OF STRING IN THE WORK AREA IS KEPT IN A REGISTER (LENREG)     *
!*       WHICH IS PROTECTED THROUGH THE NORMAL INTERMEDIATE-RESULT     *
!*       MECHANISMS.                                                   *
!*       ON ENTRY:-                                                    *
!*       REG > 0 %IF A REGISTER IS TO BE LEFT POINTING AT THE RESULT   *
!*       MODE=0    NORMAL. REG IF GIVEN ONLY USED IF NO WK AREA NEEDED *
!*       MODE=1    AS MODE =0 BUT REG MUST BE SET AS POINTER           *
!*       (AND TO COME)                                                 *
!*       MODE=3    CONCATENATE INTO LHS OF =ASSNMNT (E.G. A=B.C)       *
!*       MODE=4    OPTIMISE  S=S.T   BY NOT COPYING S                  *
!*       2**4 BIT OF MODE IS SET IF WK-AREA NOT TO BE FREED ON EXIT    *
!*       ON EXIT:-                                                     *
!*       BASE,DISP & INDEX DEFINE RESULT                               *
!*       VALUE=1 %IF RESULT IN A WORK AREA(CCOND MUST KNOW)            *
!*       STRINGL SET IF STRING LENGTH KNOWN. NEST DEFINES LENREG       *
!***********************************************************************
         %INTEGER PP,WKBASE,WKAREA,LENREG,REXP,ERR,CLEN,KEEPWA
         %SHORTINTEGER SHEAD
         %RECORDNAME OP(RD)
         %INTEGERFNSPEC STROP(%INTEGER REG)
         LENREG=0; SHEAD=0
         KEEPWA=MODE&16; MODE=MODE&15
         PP=P; STRINGL=0
         REXP=2-A(P+1+A(P+1));         ! =0 %IF ONE OPERAND EXP
         -> NORMAL %UNLESS A(P+2)=4 %AND REXP=0 %AND MODE<=1
         -> SIMPLE %IF A(P+3)=2
         -> NORMAL %UNLESS A(P+3)=1
         COPY TAG(A(P+4))
         %IF PTYPE=SNPT %THEN PTYPE=TSNAME(K) %AND UNPACK
         -> NORMAL %IF ROUT#0 ; ! BEWARE OF MAP=FN
         -> NORMAL %IF CHECKS=1 %AND(ARR#0 %OR A(P+5)=1)
SIMPLE:  P=P+3
         %IF MODE=0 %THEN REG=-2
         ERR=STROP(REG)
         -> ERROR %UNLESS ERR=0
         VALUE=0
         P=P+1; NEST=0; -> 99
ERROR:   FAULT(ERR,0)
         REGISTER(LENREG)=0
         BASE=11; DISP=0
         VALUE=0
         P=PP; SKIP EXP
         -> 99
NORMAL:  PUSH(SHEAD,1<<16!9,-2)
         OP==RECORD(ADDR(ASLIST(SHEAD)));!RESULT DESCRIPTOR FOR LENREG
         CLEN=0; P=P+3;                ! LENGTH OF CONSTANT PART
         WKBASE=RBASE
         GET WSP(WKAREA,256);          ! GET NEXT OPERAND
NEXT:    STRINGL=0
         ERR=STROP(-2);                ! GET NEXT OPERAND
         -> ERROR %UNLESS ERR=0
         REGISTER(BASE)=2 %IF REGISTER(BASE)=0
         %IF LENREG>0 %THEN %START
            %IF OP_D>0 %THEN %START;   ! LENREG STORED BY RT CALL
               DUMP(2,-2,OP_D,0,OP_XB);! SO RELOAD IT
               LENREG=NEST
               OP_XB=LENREG;OP_D=-2;   ! AND RESET DESCRIPTOR
               REGISTER(LENREG)=1
               SET USE(LENREG,1,ADDR(ASLIST(SHEAD)))
            %FINISH
            DUMP(0,-2,0,RBASE,LENREG); ! LA   O(RBASE,LENREG)
            WKBASE=NEST; FORGET(WKBASE)
         %FINISH
         REGISTER(BASE)=0 %IF REGISTER(BASE)=2
         STRINGOP(2,STRINGL,WKBASE,WKAREA+CLEN+1,BASE,DISP,-1,255,-2)
!
! STRINGOP MOVES STRING INTO WORK AREA. IF LENGTH UNKNOWN THEN NEST
! IS SET TO THE REGISTER CONTAINING THE LENGTH OF THE STRING
!
         %IF LENREG>0 %THEN %START;    ! REGISTER SET UP
            %IF STRINGL>0 %THEN %START;! DESCRIPTOR WAS A CONSTANT
               PRX(X'41',LENREG,LENREG,0,STRINGL);! LA LENREG,STRING(LENREG)
            %FINISH %ELSE %START
               PRR(X'1A',LENREG,NEST); ! AR LENREG,NEST
            %FINISH
         %FINISH %ELSE %START;         ! NOW SET LENREG
            %IF STRINGL=0 %THEN %START
               LENREG=NEST;            ! USE ONE SET BY STRINGOP
               REGISTER(LENREG)=1;     ! CLAIM IT
               SET USE(LENREG,1,ADDR(ASLIST(SHEAD)));! PROTECT IT
               OP_XB=LENREG;           ! AND UPDATE RESULT DESCRIPTOR
               PRX(X'41',LENREG,LENREG,0,CLEN) %UNLESS CLEN=0
               CLEN=0
            %FINISH %ELSE CLEN=CLEN+STRINGL
         %FINISH
         %IF A(P)=2 %THEN -> TIDY;     ! NO MORE OPERATIONS
         ERR=72; -> ERROR %UNLESS A(P+1)=12; ! CONCATENATE
         P=P+2; -> NEXT
TIDY:                                  ! FINISH OFF
         VALUE=WKAREA
         %IF LENREG=0 %THEN %START
            DUMPSI(X'92',CLEN,RBASE,WKAREA); ! MAX LENGTH KNOWN
            STRINGL=CLEN; NEST=0
         %FINISH %ELSE %START
            DUMP(X'42',LENREG,WKAREA,0,RBASE); ! MAX LENGTH NOT KNOWN
            PREC=1; TYPE=1;            ! FOR CHECK CAPACITY
            %IF CHECKSP=1 %THEN CHECK CAPACITY(LENREG,WKAREA,0,RBASE)
            REGISTER(LENREG)=0;        ! FREE THE REGISTER
            STRINGL=0;                 ! LENGTH UNKNOWN
         %FINISH
         P=P+1;                        ! PAST REST OF EXPRN
         RETURN WSP(WKAREA,256) %IF KEEPWA=0
         %IF MODE=0 %THEN %START
            BASE=RBASE; DISP=WKAREA
         %FINISH %ELSE %START
            DUMP(0,REG,WKAREA,0,RBASE)
            BASE=REG; DISP=0
         %FINISH
         INDEX=0
         CLEAR LIST(SHEAD)
         CCSTATE=-1
         NEST=LENREG; -> 99
         %INTEGERFN STROP(%INTEGER REG)
!***********************************************************************
!*       DEALS WITH OPERAND FOR CONCATENATION. RETURN RESULT=0 FOR     *
!*       VALID OPERAND OTHERWISE AN ERROR NUMBER.                      *
!***********************************************************************
         %BYTEINTEGER CTYPE
         %INTEGER VAL,MODE,REGMODE
         %IF CHECKSP#0 %THEN REGMODE=SAFE %ELSE REGMODE=ADDREG
         MODE=A(P);                    ! ALTERNATIVE OF OPERAND
         %RESULT=75 %IF MODE>2
         %IF MODE#1 %THEN %START
            CTYPE=A(P+1)&7;           ! GET CONST TYPE & LOSE AMCK FLAGS
            %IF CTYPE=5 %THEN %START
               STRINGL=A(P+2); P=P+2
               %IF REG<0 %THEN FINDREG(REGMODE,BASE) %ELSE BASE=REG
               TEXTOUT(BASE)
               %IF A(P)=1 %THEN %RESULT=72
               P=P+1; DISP=0
            %FINISH %ELSE %START
               FROM AR4(P+2,VAL)
               %RESULT=72 %UNLESS CTYPE=1 %AND 0<=VAL<127 %AND A(P+4)=2
               P=P+5
               %IF VAL=0 %THEN %START
                  BASE=CODER; DISP=X'C0'
               %FINISH %ELSE %START
                  VAL=VAL+256; STRINGL=1
                  STORE CONST(BASE,DISP,2,ADDR(VAL)+2)
               %FINISH
            %FINISH
            INDEX=0
         %FINISH %ELSE %START
            P=P+1; CNAME(5,REG)
            STRINGL=0
            %RESULT=71 %IF TYPE#5
         %FINISH
         %IF REG>0 %OR INDEX>0 %OR BASE>4095 %THEN %START
            DUMP(0,REG,DISP,INDEX,BASE)
            REG=NEST %IF REG<0
            FORGET(REG)
            BASE=REG; INDEX=0;DISP=0
         %FINISH
         %IF MODE=1 %AND UNASS=1 %THEN %START
            DUMPSS(X'D5',2,BASE,DISP,CODER,216);! CLC =X'8080'
            PCONST(X'4780C028');                ! BE UNASS USED
         %FINISH
         %RESULT=0
         %END;                         ! OF INTEGERFN STROP
99:      %END;                         ! OF ROUTINE CSTREXP
         %ROUTINE CRES (%INTEGER LAB)
         %SHORTROUTINE
!**********************************************************************
!*       COMPILES A RESOLUTION E.G A->B.(C).D.(E).F AND JUMPS TO LAB   *
!*       ON FAILURE. (LAB=0 FOR UNCONDITIONAL RESOLUTION TO PERM ON    *
!*       FAILURE ).                                                    *
!*       THE  METHOD IS TO SET UP A 4 WORD WORK AREA AS FOLLOWS:-      *
!*       W1  POINTS TO LHS(A)                                          *
!*       W2  HAS COUNT OF BYTES OF A USED IN PREVIOUS RESOLUTIONS      *
!*       W3  PRIVATE SPACE FOR PERM                                    *
!*       W4    STRING TO CONTAIN FRAGMENT (PASSED BY NAME)             *
!*       PERM IS ENTERED WITH R1 POINTING TO C AND R2 TO W1 AND THE    *
!*       SUBROUTINE TRIES TO PERFORM THE RESOLUYION AND SETS THE       *
!*       CONDITION CODE =8 IF IT SUCCEEDS.                             *
!*                                                                     *
!*       ON ENTRY LHS IS DEFINED BY DISP,INDEX AND BASE.               *
!*       P POINTS TO P(+') OF RHS DEFINED AS (+')(OPERAND)(RESTOFEXP)  *
!*                                                                     *
!$       THE ROUTINE IS COMPACT BUT DIFFICULT TO FOLLOW (OR ALTER)     *
!*       THE TIME IN PERM IS LARGE SO IT IS NOT WORTHWHILE TO PERSUE   *
!*       CODE EFFICIENCY TOO INDUSTRIOUSLY .                           *
!**********************************************************************
         %INTEGER P1,P2,R1,R2,SEXPRN,W,LAST
         LAST=0;                       ! =1 WHEN END OF EXPRNSN FOUND
         SEXPRN=0;                     ! RESOLUTION(BRKTD) EXPRESSNS
         GET WSP(W,4);                 ! 4 WORD WORK AREA FOR W1-W4
         P1=P; P=P+2
         ->1 %IF A(P)=4 %AND TYPE=5;   ! LHS MUST BE A STRING
ERROR:   P=P1; SKIP EXP
         FAULT(74,0); ->99
1:       FIND SEQ(R1,R2);              ! 2 ADJACENT REGISTERS
         DUMP(0,R1,DISP,INDEX,BASE);   ! ADDR LHS
         REGISTER(R1)=1
         PRR(X'1B',R2,R2);             ! ZERO R2
         REGISTER(R2)=1
         DUMPM(X'90',R1,R2,RBASE,W);   ! SET W1 & W2
         FREE AND FORGET(R1)
         FREE AND FORGET(R2)
RES:     P=P+1;                        ! TO P(OPERAND)
         P2=-1;                        ! B OMITTED (>0 IF B GIVEN)
!
! THE CODING HERAFTER IS OBSCURE. NOTE HOWEVER:-
!        1)  IF B OMITTED THEN 0(WSPR) IS PASSED AS ADDR(B)
!        2)  THE LAST STRING F IS TREATED AS B OR D BUT PERM29 IS
!              USED INSTEAD OF PERM 28
!
         %IF A(P)=3 %THEN NEST=WSPR %ELSE %START;! B OMITTED
            ->ERROR %UNLESS A(P)=1;       ! P(OPERAND)=NAME
            P=P+1; P2=P
!
!        NORMALLY CNAME(3,REG) USED TO PASS B BY NAME TO PERM
!        IN OPTIMISING DONT WASTE TIME SETTING FLAGS BYTE INTO ADDRESS
!        SO USE CNAME(4,REG). PERM SKIPS CHECK IF FLAGS MISSING
!
            CNAME(4-CHECKSP,-2)
            ->ERROR %UNLESS TYPE=5
            %IF A(P)=2 %AND SEXPRN>0 %THEN LAST=1 %ELSE %START
               ->ERROR %UNLESS A(P+1)=12;! DOT OPERATOR
               P=P+2
            %FINISH
         %FINISH
         REGISTER(NEST)=1 %IF REGISTER(NEST)=0;! IN CASE 4K MULTIPLE REQD
         DUMP(X'50',NEST,W+12,0,RBASE);! B (OR DUMMY) TO W4
         REGISTER(NEST)=0 %IF REGISTER(NEST)>0; ! NB NEST CAN BE R11 HERE!
         %IF LAST=0 %THEN %START
            ->ERROR %UNLESS A(P)=3;    ! P(OPERAND)='('(EXPR)')'
            SEXPRN=SEXPRN+1; P=P+1
            CSTREXP(1,1);              ! TO REGISTER 1
         %FINISH
!
         REGISTER(1)=1
         DUMP(0,2,W,0,RBASE) %UNLESS GRUSE(2)=16 %AND GRINF(2)=W
         REGISTER(1)=0
         PPJ(LAST+28);                 ! 28 TO RESOLVE 29 TO FINISH OFF
         SET USE(2,16,W);              ! USE 16='HOLDS RESLN PARAM'
         -> END %IF LAST#0
FTEST:                                 ! DEAL WITH CC#8 IE RESLN FAILED
         %IF LAB#0 %THEN ENTER JUMP(7,LAB,B'11') %ELSE %START
            PCONST(X'4770C098')
            CYC BITS=CYC BITS!4;       ! JUMP TO PERM BIT
         %FINISH
!
         %IF P2<0 %THEN %START;        ! B WAS OMIITED SO CHECK THAT
         PSI(X'95',0,WSPR,0);          ! B WOULD HAVE BEEN NULL
         P2=1; ->FTEST; %FINISH
!
         -> END %IF A(P)=2
         ->ERROR %UNLESS A(P+1)=12
         P=P+1; ->RES
END:
         P=P+1
99:      %END
         %ROUTINE CUCI
         %SHORTROUTINE
!***********************************************************************
!*       COMPILE USERCODE INSTRUCTION. MOST WORK IS DONE BY HAIRY      *
!*       BUILT-IN PHRASE IN COMPARE. SINCE ALMOST ANYTHING IS LEGAL    *
!*       IN USERCODE THIS ROUTINE HAS ONLT TO ASSEMBLE AND PLANT THE   *
!*       THE INSTRUCTION.                                              *
!***********************************************************************
         %ROUTINESPEC DXB
         %ROUTINESPEC DLB
         %ROUTINESPEC DB
         %ROUTINESPEC CUCS
         %OWNINTEGER USING,AT
         %INTEGER Z,KK,X,OPCODE,REG,OPNUM
         %SWITCH UCITYPE(1:6),OPTYPE(1:8)
         CCSTATE=-1
         FORGETM(8);                  ! ALL UC INSTRNS DANGEROUS
         -> UCITYPE(A(P))
UCITYPE(1):                           ! **(N),(@')(NAME)(APP)
         NEST=A(P+1); Z=A(P+2); P=P+3
         Z=4 %IF Z=1; CNAME(Z,NEST)
         ->99
UCITYPE(2):                           ! *-> P<N> =JUMP TO PERM
         PPJ(A(P+1)); ->99
UCITYPE(4):                           ! *PUT_<CONST>
         PLANT(A(P+3));               ! LEAST SIGNIFICANT 16 BITS ONLY
         P=P+4; ->99
UCITYPE(3):                           ! '*'<SETUCN>'_' <UCOP>
         OPCODE=A(P+2); OPNUM=A(P+1)
         P=P+3; ->OPTYPE(OPNUM)
UCITYPE(5):                           ! 'USING' '*,'<N>
         Z=A(P+1)
         %IF 1<=Z<=15 %THEN %START
            USING=Z; AT=CA
         %FINISH %ELSE FAULT(33,0); ->99
UCITYPE(6):                           ! 'DROP' <N>
         Z=A(P+1)
         %IF Z=USING %THEN %START
            USING=0; AT=0
         %FINISH %ELSE FAULT(33,0); ->99
OPTYPE(1):                            ! RR FORMAT INSTRUCTION
         %IF OPCODE=0 %THEN CNOP(A(P),A(P+1)) %ELSE %C
                            PRR(OPCODE,A(P),A(P+1))
         P=P+2; ->99
OPTYPE(2):                            ! RX FORMAT INSTRUCTION
OPTYPE(3):                            ! RS FORMAT INSTRUCION
OPTYPE(5):                            ! SHIFT INSTRUCTION
         REG=A(P)
         %IF OPNUM=2 %THEN P=P+1 %AND DXB %ELSE %START
            %IF OPNUM=5 %THEN X=0 %AND P=P+1 %ELSE X=A(P+1) %AND P=P+2
            DB
         %FINISH
         PRX(OPCODE,REG,X,I,K);->99
OPTYPE(4):                            ! STORE-IMMEDIATE FORMAT
         DB
         %IF A(P)=2 %THEN Z=0 %ELSE %START
            FROM AR4(P+2,Z)
            FAULT(32,0) %UNLESS 0<=Z<=255
            P=P+4
         %FINISH
         PSI(OPCODE,Z,I,K);P=P+1; ->99
OPTYPE(6):                            ! SS FORMAT
OPTYPE(7):                            ! PACKED DECIMAL FORMAT
         DLB; KK=K; Z=X
         REG=I; Z=1 %IF Z=0
         %IF OPNUM=6 %THEN DB %ELSE %START
            DLB; X=1 %IF X=0
            Z=(Z-1)<<4!X
         %FINISH
         PSS(OPCODE,Z,REG,KK,I,K); ->99
OPTYPE(8):                            ! FUNNIES
         REG=A(P); P=P+1
         %IF OPCODE=X'80' %THEN PSI(OPCODE,REG,0,0) %ELSE %START
           %IF OPCODE=10 %THEN PLANT(X'A00'!REG) %ELSE PRR(OPCODE,REG,0)
         %FINISH
         ->99
         %ROUTINE DB
!***********************************************************************
!*       DEAL WITH OPERANDS FOR A DB INSTRUCTION. P ON ALT OF P<DB>    *
!*       P<DB>=<UCS>,<N><RESTOFDB>                                     *
!*       P<RESTOFDB>='('<N>')',%NULL                                   *
!***********************************************************************
         %IF A(P)=1 %THEN CUCS %ELSE %START
            K=A(P+1); I=A(P+2); P=P+3; ! I IS ALT OF P<RESTOFDB>
            %IF I=2 %THEN I=0 %ELSE I=A(P) %AND P=P+1
         %FINISH
         FAULT(99,0) %UNLESS 0<=K<=4095
         %END
         %ROUTINE DXB
!***********************************************************************
!*       DEAL WITH OPERANDS FOR A DXB INSTRN. P ON ALT OF P<DXB>       *
!*       P<DXB>=<UCS><RESTOFDB>,<N><RESTOFDXB>                         *
!*       P<RESTOFDXB>='('<N>','<N>')','('<N>')',%NULL                  *
!***********************************************************************
         %INTEGER ALT
         X=0
         %IF A(P)=1 %THEN %START
            CUCS
            %IF A(P)=1 %THEN X=A(P+1) %AND P=P+1
         %FINISH %ELSE %START
            K=A(P+1); I=0
            ALT=A(P+2); P=P+2
            %IF ALT=1 %THEN X=A(P+1) %AND P=P+1
            %IF ALT<=2 %THEN I=A(P+1) %AND P=P+1
         %FINISH
         P=P+1
         FAULT(99,0) %UNLESS 0<=K<=4095
         %END
         %ROUTINE DLB
!***********************************************************************
!*       DEAL WITH OPERAND FOR A DB INSTRUCTION. P ON ALT OF P<DB>     *
!*       P<DB>=<N>'('<N>','<N>')',<UCS>'('<N>')'                       *
!***********************************************************************
         %IF A(P)=1 %THEN %START;   ! EXPLICT FORM
            K=A(P+1); X=A(P+2)
            I=A(P+3); P=P+4
         %FINISH %ELSE %START
            CUCS; X=A(P); P=P+1
         %FINISH
         FAULT(99,0) %UNLESS 0<=K<=4095
         %END
         %ROUTINE     CUCS
!***********************************************************************
!*       DEAL WITH SYMBOLIC REFERENCES IN USERCODE STATEMENTS          *
!*       P<UCS>=<NAME><DISPP>,'<'<LABEL>'>','*'<DISPP>                 *
!*       P<DISPP>='+'<N>,'-'<N>,%NULL                                  *
!***********************************************************************
         %INTEGER X,Y,AD,ALT
         X=USING; Y=AT
         %IF X=0 %THEN X=10 %AND Y=CODEBASE
         ALT=A(P+1);                     ! ALT OF P<UCS>
         %IF ALT=2 %THEN %START
!
! OPERAND IS AN IMP LABEL WHICH MAY OR MAY NOT BE SET BUT MUST BE WITHIN
! 4095 OF THE BASE REGISTER WHETHER IMPLIED OR SET BY 'USING'
!
            K=A(P+3)+(A(P+2)-1)<<14
            P=P+4
            J=FIND3(K,LABEL(LEVEL))
            %IF J<0 %THEN PUSH123(LABEL(LEVEL),0,0,K) %AND %C
                          J=LABEL(LEVEL)
            AD=FROM1(J)
            REPLACE1(J,AD!X'01000000')
            %IF AD&X'FFFFFF'#0 %THEN K<-AD-Y %AND I=X %ELSE %START
               K=0; I=0
               PUSH(SHORT INTEGER(ADDR(ASLIST(J+6))),CA,X<<24!Y)
            %FINISH
         %FINISH %ELSE %START
            %IF ALT=1 %THEN %START
               FNAME=A(P+2)
               COPY TAG(FNAME)
               P=P+3
               FAULT(33,FNAME) %IF ROUT=1 %OR TYPE=4 %OR TYPE>=6
            %FINISH %ELSE %START
               I=X; K=CA-Y
               P=P+2
            %FINISH
            ALT=A(P); P=P+1
            %IF ALT#3 %THEN %START
               %IF ALT=1 %THEN K=K+A(P) %ELSE K=K-A(P)
               P=P+1
            %FINISH
         %FINISH
         %END
99:      %END
         %ROUTINE LAB LOOK(%INTEGERNAME FLAG,%INTEGER LAB)
! THIS ROUTINE LOOKS THRO THE STATEMENTS HELD IN THE CYCLIC BUFFER
! TO TRY TO FIND LABEL 'LAB'.

         %SHORTROUTINE
         %INTEGER I,J,K,F,MUI,ME
         FLAG=0
         %RETURN %UNLESS STMTSHELD>1
         %IF !LAB-SFLABEL!<=1 %THEN F=1 %ELSE F=0
         %CYCLE I=2,1,STMTSHELD;       ! CYCLE THROUGH STATEMENTS
         J=STPTRS(I)
         %IF F>0 %THEN %START
         -> FIN %IF A(J)=14
         -> AGN %UNLESS A(J)=5
         MUI=J+2+A(J+2); ME=MUI+1+A(MUI+1)
         F=F+1 %IF A(MUI)<=2 %OR A(ME)=1
         -> AGN
FIN:     %IF F=1 %THEN %START
         FLAG=1; %RETURN; %FINISH
         F=F-1
         F=F+1 %IF A(J+1)=1
         -> AGN; %FINISH
         -> LAB %IF A(J)=4;            ! NUMERIC LAB
         -> AGN %UNLESS A(J)=1 %AND A(J+2)=1 %AND A(J+5)=2
         K=J+1+A(J+1); -> AGN %UNLESS A(K)=1
         K=16384+A(J+4)
SUCC:    -> AGN %UNLESS K=LAB
         FLAG=1; %RETURN
LAB:     K=A(J+1); -> SUCC
AGN:     %REPEAT
         %END
%ROUTINE QSORT(%RECORDARRAYNAME A,%INTEGER I,J)
%RECORDFORMAT F(%INTEGER VAL,S1,S2,S3)
%RECORDSPEC A(F)
%RECORD D(F)
%INTEGER L,U
         %IF I>=J %THEN %RETURN
         L=I; U=J; D=A(J); ->FIND
UP:
         L=L+1
         %IF L=U %THEN ->FOUND
FIND:
         %UNLESS A(L)_VAL>D_VAL %THEN ->UP
         A(U)=A(L)
DOWN:
         U=U-1
         %IF L=U %THEN ->FOUND
         %UNLESS A(U)_VAL<D_VAL %THEN ->DOWN
         A(L)=A(U); ->UP
FOUND:
         A(U)=D
         QSORT(A,I,L-1)
         QSORT(A,U+1,J)
%END
%ROUTINE OPTSAVE(%INTEGER TYPE,Z,PTYPE,XTRA)
%RECORDNAME OPTE(OPTFORM)
%INTEGER I
         %IF OPTPTR>=24 %THEN %RETURN
         I=1
         %WHILE I<=OPTPTR %CYCLE
            OPTE==OPTINF(I)
            %IF TYPE=OPTE_TYPE %AND XTRA=OPTE_XTRA %START
               OPTE_COUNT=OPTE_COUNT+1
               OPTE_BITS=OPTE_BITS!1<<Z
               %RETURN
            %FINISH
            I=I+1
         %REPEAT
         OPTPTR=OPTPTR+1
         OPTE==OPTINF(OPTPTR)
         OPTE_COUNT=1
         OPTE_TYPE=TYPE
         OPTE_BITS=1<<Z
         OPTE_PTYPE=PTYPE
         OPTE_XTRA=XTRA
%END
         %ROUTINE VALLOC(%INTEGER REG,TN)
         %SHORTROUTINE
!***********************************************************************
!*       ALLOCATE A VARIABLE (TAGS=TN) TO REGISTER REG BY LOADING      *
!*       THE REGISTER AND FRIGGING THE TAGS. ONLY SIMPLE INTEGERS      *
!*       (PTYPE=1) CAN BE ALLOCATED TO REGISTERS.                      *
!*       BYTES AND SHORTS ARE TRUNCATED BY <- ASSIGNMENTS.             *
!*       NAME-TYPES MAY HAVE AN ALTER EGO                              *
!*       THE ALLOCATION CAN ONLY BE MADE FOR SECTIONS OF CODE THAT     *
!*       HAVE NO RT-CALLS OR LABELS/JUMPS                              *
!********-**************************************************************
         %INTEGER S1,S2,S3,I,Q
         FROM123(TN,S1,S2,S3)
         %IF CUR CYC VAR>=0 %AND TN=TAGS(CUR CYC VAR) %START
            P=STPTRS(1)+5;              ! CHECK INITIAL EXPRSN
            Q=TSEXP(I,0)
         %FINISH %ELSE Q=0
         %IF Q=0 %OR Q>=100 %OR (Q=10 %AND I=CUR CYC VAR)%START
            FIND USE(I,1,3,TN)
            %IF I>=0 %THEN %START
               PRR(X'18',REG,I) %UNLESS REG=I
            %FINISH %ELSE DUMP(X'58',REG,S3>>16,0,S1>>4&15)
         %FINISH
         SET USE(REG,3,TN)
         REGISTER(REG)=-1;             ! LOCK THE REG
         S1=S1+7<<16;                  ! PTYPE FROM1 TO 8
         S2=S2&X'FFFF'!S3&X'FFFF0000' ; ! K TO SNDISP
         REPLACE123(TN,S1,S2,REG<<16)
         %END
         %ROUTINE VDALLOC(%INTEGER REG,REGP)
         %SHORTROUTINE
!***********************************************************************
!*       DE-ALLOCATE REG WHICH WAS ALLOCATED BY VALLOC(Q.V.). STORE REG*
!*       INTO CORE AND RESTORE CORE COPY FROM REGP. REGP<=0 NO RESTORE *
!*       OFTEN REG=REGP                                                *
!***********************************************************************
         %INTEGER TN,S1,S2,S3
         TN=GRINF(REG)
         FROM123(TN,S1,S2,S3)
         S3=S2>>16<<16
         S1=S1-7<<16;                  ! BACK TO INTEGER
         %IF REGP#0 %THEN DUMP(X'50',REGP,S3>>16,0,S1>>4&15)
         REGISTER(REG)=0
         REPLACE123(TN,S1,S2,S3)
         %END
         %ROUTINE LOADUP(%INTEGER REGINFO)
         %SHORTROUTINE
!***********************************************************************
!*       REGINFO IS BIT MASK OF AVAILABLE REGS                         *
!*       CYC BITS HAS INFORMATION ON OPERATIONS IN THE CYCLE           *
!*       THIS ROUTINE PRELOADS ANY FREE REGISTERS FROM THE INFORMATION *
!*       IN THE LIST HEADED BY 'SFHEAD' WHICH WAS ORDERED BY ROUTINE   *
!*       'ORDER' SO THAT THE TOP HAS THE MOST USED ITEMS               *
!***********************************************************************
         %SHORTROUTINE
         %RECORDNAME OPTE(OPTFORM)
         %INTEGER I,USE,NEXTREG,INF,X,Y,Z,PTR
         PTR=OPTPTR+1
AGN:     PTR=PTR-1
         ->99 %IF PTR=0
         OPTE==OPTINF(PTR)
         %IF REGINFO=0 %THEN ->99
         %CYCLE I=4,1,15
         ->1 %IF REGINFO&(1<<I)#0
         %REPEAT
         %MONITORSTOP
1:       REGINFO=REGINFO!!(1<<I)
2:       NEXTREG=I
3:       %IF OPTE_TYPE=12 %THEN ->CODEB
         %IF OPTE_TYPE=0 %THEN ->CONST
         %IF OPTE_TYPE=2 %THEN %START
            INF=TAGS(OPTE_XTRA)
            PTYPE=OPTE_PTYPE; UNPACK
            %IF PTYPE=1 %AND CYCBITS&X'40F'=0 %AND OPTE_BITS&3<<3=0 %C
               %AND(CYC BITS&X'20'=0 %OR OPTE_XTRA#CUR CYC VAR) %THEN %C
               VALLOC(NEXTREG,INF) %AND USE=3 %AND ->RSET
!
            %IF TYPE=3 %AND NAM=1 %AND ARR=0 %AND OPTE_BITS&5<<14=0 %C
               %AND(CYCBITS&8=0 %OR ((-1<<20)<<FROM1(INF)>>8&15) %C
               &CYCBITS=0) %THEN ->LOAD RBASE
!
            %IF ARR=1 %AND(NAM=0 %OR (CYCBITS&8=0 %AND OPTE_BITS %C
               &(1<<12)=0)) %THEN -> LOAD ABASE
         %FINISH
         PTR=PTR-1
         ->99 %IF PTR<=0
         OPTE==OPTINF(PTR); ->3
LOADRBASE:USE=7
LOADANY: X=FROM1(INF)>>4&15
         Z=FROM3(INF)>>16
         I=X'58'
         ->COM
LOADABASE:USE=8; ->LOADANY
CODEB:                          ! BASE REGISTER FOR REPEATING NEEDED
         PRR(5,NEXTREG,0);                 ! BALR NEXTREG,0
         CYC BASE=NEXT REG; CYC ADDR=CA
         USE=12
         INF=CYC ADDR; ->SETU
COM:     DUMP(I,NEXTREG,Z,0,X)
SETU:    SET USE(NEXTREG,USE,INF)
         REGISTER(NEXTREG)=-1
RSET:    CYC REGS=CYC REGS!1<<NEXTREG
!         %IF DCOMP=1 %THEN %START
!            %PRINTTEXT'
!LOADS REGISTER'
!            WRITE(NEXTREG,3)
!            WRITE(USE,3)
!            WRITE(INF,5)
!        %FINISH
         -> AGN
CONST:   I=0; Z=OPTE_XTRA
         INF=Z
         USE=2; X=0; -> COM
99:       %END
         %ROUTINE CYCOPT(%INTEGERNAME FLAG,%INTEGER WU)
         %SHORTROUTINE
! EXAMINE THE STATEMENTS IN THE CYCLIC BUFFER FOR A '%REPEAT' AND
! COMPUTE IF REGISTERS CAN BE ALLOCATED FOR INCREMENT AND FINAL VALUE.
! WU=0 FOR OLD TYPE CYCLE =1 FOR WHILE OR UNTIL =2 FOR OPEN CYCLE
         %INTEGER I,J,K,CREGS,SCCSTATE
         FLAG=0; CREGS=0; CYC ASS=0; CYC REGS=0; CYC BASE=0
         %RETURN %UNLESS STMTSHELD>1;   ! NO STATEMENTS IN BUFFER
         %RETURN %IF WU=0 %AND FFLAG#0;! FNS IN P,Q,R
         %CYCLE I=2,1,STMTSHELD
         J=STPTRS(I)
         ->NESTED %IF A(J)=2;    ! CONTAINS NESTED CYCLE DONT OPTIMISE
         ->NESTED %IF A(J)=6 %AND A(J+2+A(J+2))<=2;! WU CYCLE
         -> CR %IF A(J)=3;       ! CORRESPONDING REPEAT FOUND!
         %REPEAT
NESTED:  %RETURN
CR:      K=16; ->REGS %IF WU#0
         K=6; ->REGS %IF REGISTER(6)=0 %AND REGISTER(7)=0
         K=4; ->REGS %IF REGISTER(4)=REGISTER(5)=0
         FLAG=-1;     ! WORTH TRYING TO USE GRS2&3
         %RETURN
REGS:    FLAG=K
!         %IF DCOMP=1 %THEN %START
!            %PRINTTEXT'
!CYCLE OPTIMISABLE'
!            WRITE(FLAG,2)
!         %FINISH
         EXTRA PASS(2-WU&1,I-1,FLAG)
         %END
         %ROUTINE EXTRA PASS(%INTEGER FST,LST,FLAG)
         %SHORTROUTINE
         %INTEGER SAVECA,USE,INF,BITS,J,CREGS,SCCSTATE
         %SHORTINTEGER HEAD
         CREGS=0
         %CYCLE J=4,1,14
            %IF REGISTER(J)=0 %THEN %START
               CREGS=CREGS!1<<J %UNLESS FLAG<=J<=FLAG+1
            %FINISH
         %REPEAT
         %RETURN %UNLESS LST>=FST
         CODE OUT;                  ! EMPTY CODE BUFFER
         SAVECA=CA;                 ! AND PRESERVE CURRENT ADDRESS
         INF=0; OPTPTR=0
         SCCSTATE=CCSTATE
         HEAD=0; GET ENV(HEAD);     ! AND THE REGISTER CONTENTS
         FORGETM(14)
         %IF 4<=FLAG<=14 %THEN OPTSAVE(2,2,1,CURCYCVAR)
! CYCLE BITS SIGNIFY AS FOLLOWS:-
! 2**0 = STATEMENT CONTAINS USER LABEL
! 2**1 = STATEMENT CONTAINS JUMP INSTRUCTION
! 2**2 = STATEMENT CONTAINS PERM SUBROUTINE CALL
! 2**3 = STATEMENT CONTAINS NORMAL ROUTINE/FN CALL
! 2**4 = STATEMENT USES PERMS CONSTANT LIST
! 2**5 = STATEMENT CONTAINS ASSIGNMENT TO CONTROL VARIABLE
! 2**6 = STATEMENT REQUIRES EVEN/ODD PAIR
! 2**7 = STATEMENT REQUIRES A SAFE REGISTER
! 2**8 = STATEMENT CONTAINS == TO RECORD OR SCALAR NAME
! 2**9 = STATEMENT CONTAINS == TO ARRAY NAME
! 2**10= STATEMENT CONTAINS A STORE VIA A BUILT-IN MAP
! 2**20->2**31 GIVE TEXTUAL LEVELS OF ANY RTS CALLED
         SFHEAD=0; BITS=0
         %IF SAVECA-CODEBASE>4000 %THEN BITS=X'10';! LONG BRANCH BACK
         %CYCLE J=FST,1,LST;          ! CYCLE THRO' ENCLOSED STMNTS
            CSS(STPTRS(J),0);          ! COMPILE THEM
                                       ! AND DISCARD ANY BINARY
            BITS=BITS!CYC BITS;        ! REMEMBER SALIENT FEATURES
            FORGETM(14)
         %REPEAT
         %IF CA-CODEBASE<4000 %THEN CYC BASE=10 %AND CYC ADDR=CODEBASE
         CYC BITS=BITS
         -> NO PRELOAD %UNLESS CYC BITS&1=0;   ! LABEL IN CYCLE
         %IF CYC BITS&X'80'=0 %THEN -> 5; ! IS A SAFE REG REQD?
         %CYCLE J=14,-1,4
            %IF CREGS&1<<J#0 %THEN CREGS=CREGS!!1<<J %AND ->5
                                        ! REMOVE 1 SAFE REGISTER
         %REPEAT
5:       %IF CYCBITS&X'C'=0 %THEN CREGS=CREGS!(1<<15)
         QSORT(OPTINF,1,OPTPTR)
         %IF DCOMP=1 %THEN %START
            %CYCLE J=1,1,OPTPTR
               NEWLINE
               WRITE(OPTINF(J)_COUNT,5)
               WRITE(OPTINF(J)_TYPE,5)
               WRITE(OPTINF(J)_BITS,5)
               WRITE(OPTINF(J)_PTYPE,5)
               WRITE(OPTINF(J)_XTRA,5)
            %REPEAT
         %FINISH
         %IF CYCBASE=0 %THEN OPTPTR=OPTPTR+1 %AND OPTINF(OPTPTR)_TYPE=12
         -> RELOAD;             ! REARRANGE INFO GLEANED
NO PRELOAD:  CREGS=0
RELOAD:  RESTORE(HEAD);                ! RESET REGISTERS
         CCSTATE=SCCSTATE
         CA=SAVECA; CABUF=CA; PP CURR=0
         %IF CREGS=0 %THEN %RETURN
!
! LOAD BASE AND INCREMENT HERE WHEN RELEVANT IN CASE OF CYCLE I=1,1,I
!
         %IF 4<=FLAG<=14 %START
            P=STPTRS(1)+5
            SKIP EXP
            DSEXP(FLAG,0)
            SET USE(FLAG,14,0)
            SET USE(FLAG+1,14,0)
         %FINISH
         LOAD UP (CREGS)
         %END
         %ROUTINE CYC RESTORE
         %SHORTROUTINE
         %INTEGER I
         %CYCLE I=4,1,15
            %IF CYC REGS&1<<I#0 %THEN %START
               %IF GRUSE(I)=3 %THEN VDALLOC(I,I*(CYCASS>>I&1)) %C
                  %ELSE REGISTER(I)=0
            %FINISH
         %REPEAT
         %END
         %ROUTINE CREATE AH(%INTEGER MODE,REG,BS,DP)
         %SHORTROUTINE
!***********************************************************************
!*       CREATES AN ARRAYHEAD IN TEMPORARY SPACE BY MODIFYING THE HEAD *
!*       AT BS&DP BY THE REGISTER REG,AS FOLLOWS:-                     *
!*       MODE=0 (ARRAYMAPPING)  REG HAS ADDR OF FIRST ELEMENT          *
!*       MODE=1 (ARRAYS IN RECORDS)-REG HAS RELOCATION FACTOR          *
!*       REG IS SET AND PROTECTED BY THE CALLING ROUTINE. ON EXIT DISP *
!*       INDEX & BASE POINT TO THE NEW ARRAYHEAD                       *
!***********************************************************************
         %INTEGER I,R1,R2,R3,R4,R5,WK,J
         GET WSP(WK,4);                ! GET FOUR WORDS FOR NEW HEAD
         FIND SEQ(R1,R2);              ! 2 WORK REGISTERS
         R3=(R2+1)&15; R4=(R3+1)&15;   ! TRY FOR 2 MORE
         %UNLESS REGISTER(R3)=0=REGISTER(R4) %THEN R4=R2
         %IF R1>R4 %THEN R5=R4+16 %ELSE R5=R4
         %CYCLE J=R1,1,R5
            I=J&15
            REGISTER(I)=1;             ! CLAIM WORKING REGISTERS
            FORGET(I)
         %REPEAT
         DUMPM(X'98',R1,R4,BS,DP);     ! PICK UP 2 OR 4 ELEMENTS
         %IF MODE=0 %THEN PRR(X'1B',R1,R2); ! SR R1,R2
         PRR(X'18'+2*MODE,R2,REG);     ! LR R2,REG (MODE=0) OR AR R2,REG
         PRR(X'1A',R1,REG);            ! AR R1,REG
         DUMPM(X'90',R1,R4,RBASE,WK);  ! STUFF OFF MODIFIED ELEMENTS
         %IF R2=R4 %THEN %START;       ! ONLY 2 WORK REGISTERS
            DUMPM(X'98',R1,R2,BS,DP+8);! SO REPEAT ON LAST ELEMENTS
            DUMPM(X'90',R1,R2,RBASE,WK+8)
         %FINISH
!
         %CYCLE J=R1,1,R5
            REGISTER(J&15)=0;          ! FREE WORK REGISTERS
         %REPEAT
         INDEX=0; BASE=RBASE
         DISP=WK;                      ! WK RETURNED ON EXIT FROM CSS
         CCSTATE=-1
         %END;                         ! OF ROUTINE CREATE AH
         %INTEGERFN DOPE VECTOR(%INTEGER ELSIZE,LB,UB)
         %SHORTROUTINE
!***********************************************************************
!*        CONSTRUCTS THE DOPE-VECTOR FOR A 1-DIMENSIONAL ARRAY IN THE  *
!*       SHAREABLE SYMBOL TABLES AND RETURNS ITS DISPLACEMENT AS RESULT*
!*       EVENTUALLY ALL NON DYNAMIC DOPE VECTORS SHOULD GO VIA HERE    *
!*       AND AS MUCH SHARING AS POSSIBLE SHOULD GO ON.                 *
!*       THE LIST OF DOPE VECTORS LOOKS LIKE:-                         *
!*       STREAM1(32 BITS) = LOWER BOUND<<16 ! UPPER BOUND              *
!*       STREAM2(32 BITS) = DISPLACEMENT OF DOPEVECTOR IN SHAREABLE ST *
!*       STREAM3(16 BITS) = THE ELEMENT SIZE IN BYTES                  *
!*       A CHECK IS REQUIRED THAT EACH BOUND FITS INTO 16 BITS         *
!***********************************************************************
         %INTEGER RANGE,I,J,K,W1,HEAD
         W1=LB<<16!UB&X'FFFF'
         %IF SHORTINTEGER(ADDR(W1))=LB %AND %C
             SHORTINTEGER(ADDR(W1)+2)=UB %START
            HEAD=DVHEAD
            %WHILE HEAD#0 %CYCLE;       ! SEARCH THE PREVIOUS DVS
               FROM123(HEAD,I,J,K);     ! FOR ONE THAT IS IDENTICAL
               MLINK(HEAD)
               %IF I=W1 %AND K=ELSIZE %THEN %RESULT=J
            %REPEAT
            PUSH123(DVHEAD,W1,SSTL,ELSIZE);! INSERT NEW DOPE VECR INTO LIST
         %FINISH
         RANGE=UB-LB+1
         I=SSTL; ELSIZE=ELSIZE!1<<16
         LPUT(4,16,SSTL,ADDR(ELSIZE))%IF INHCODE=0
         SSTL=SSTL+16
         %RESULT=I
         %END
%ROUTINE CLAIM ST FRAME(%INTEGER AT,VALUE)
%SHORTROUTINE
!***********************************************************************
!*       FILL THE LA INSTN IT RT ENTRY SEQUENCE TO CLAIM THE STACKFRAME*
!*       DIFFICULT WHEN THE FRAME IS>4095                              *
!***********************************************************************
%INTEGER PLUG2
         %IF 4096>VALUE %THEN PLUG(1,AT,VALUE) %AND %RETURN
!
! IF THE FRAME IS >4096 THE WHOLE INSTRN IS OVERWRITTEN WITH AN ADD
!
         %IF GLACA<4092 %THEN %START
            PGLA(2,2,ADDR(VALUE)+2)
            PLUG2=X'D000'!(GLACA-2)
         %FINISH %ELSE PLUG2=X'C000'!(PTBASE+6+VALUE>>12<<2)
         PLUG(1,AT-2,X'4AB0')
         PLUG(1,AT,PLUG2)
%END
         %ROUTINE CEND (%INTEGER KKK)
!***********************************************************************
!*       DEAL WITH ALL OCCURENCES OF '%END'                            *
!*       KKK=PTYPE(>=10000) FOR ROUTINES,FNS AND MAPS                  *
!*       KKK=0 FOR ENDS OF '%BEGIN' BLOCKS                             *
!*       KKK=1 FOR '%ENDOFPROGRAM'                                     *
!*       %ENDOFPROGRAM IS REALLY TWO ENDS. THE FIRST IS THE USERS      *
!*       AND THE SECOND IS PERMS. KKK=2 FOR A RECURSIVE CALL OF CEND   *
!*       ON END OF PROGRAM TO DEAL WITH THE %END CORRESPONDING TO      *
!*       THE %BEGIN COMPILED IN THE INITIALISATION SEQUENCE            *
!***********************************************************************
         %SHORT %ROUTINE
         %INTEGER KP
         %SHORTINTEGERNAME THEAD
         %ROUTINESPEC DTABLE(%INTEGER LEVEL,GLOBAL)
         SET LINE; MONE=1; FORGETM(14)
         CUR CYC VAR=0; CCSTATE=-1
!
! FIRST CHECK FOR ANY '%STARTS' WITHOUT FINISHES
!
         %WHILE SBR(LEVEL)#0 %CYCLE
            FROM12 (SBR(LEVEL),J,KP)
            FAULT(53,0);               ! FINISH MISSING
            A(2)=14; A(3)=3; CSS(2,0); ! SO COMPILE IT IN
         %REPEAT
!
! NOW PLANT AN ERROR EXIT FOR FNS AND MAPS - CONTROL SHOULD BE RETURNED
! VIA %RESULT= AN SHOULD NEVVER REACH THE %END INSTRUCTION
!
         %IF KKK>10000 %AND COMPILER=0 %AND LAST INST=0 %THEN %START
            PCONST(X'4100000B');       ! LA 0,11
            PPJ(21);                   ! RUN FAULT 11
         %FINISH
         NMAX=N %IF N>NMAX;            ! WORK SPACE POINTER
!
! CLEAR OUT THE LABEL LIST FAULTING LABELS WITH JUMPS OUTSTANDING
! AS NOT SET AND COMMENTING ON LABELS NOT USED
!
         %WHILE LABEL(LEVEL)#0 %CYCLE
            POP123(LABEL(LEVEL),I,J,KP)
            I=I>>24
            %IF J&X'FFFF'#0 %THEN %START
               CLEAR LIST(SHORT INTEGER(ADDR(J)+2))
               %IF 0<KP<=MAX ULAB %THEN FAULT(11,-KP)
            %FINISH %ELSE %START
               %IF I=0 %AND KP<MAX ULAB %THEN %PRINTTEXT'
?  UNUSED LABEL' %AND PRINTNAME(-KP)
            %FINISH
         %REPEAT
!
         %CYCLE J=0,1,6
            THEAD==AVL WSP(J,LEVEL);     ! RELEASE TEMPORARY LOCATIONS
            %IF THEAD#0 %THEN CLEAR LIST(THEAD)
         %REPEAT
!
         DTABLE(LEVEL,0);              ! OUTPUT DIAGNOSTIC TABLES
!
! CLEAR DECLARATIONS - POP UP ANY GLOBAL NAMES THAT WERE REDECLARED
! DESTROY SIDE CHAINS FOR ROUTINES,FORMATS AND SWITCHES
!
         JJ=NAMES(LEVEL)
         %WHILE JJ>=0 %CYCLE
                                    ! FIND A LOCAL NAME
            I=SHORTINTEGER(ADDR(ASLIST(TAGS(JJ)))+12)
            POP123(TAGS(JJ),KK,INTEGER(ADDR(SNDISP)),INTEGER(ADDR(K)))
            PTYPE=KK>>16
            %IF PTYPE =8 %THEN REGISTER(K)=0 %AND UVARREG(K)=0
            %IF KK&15=15 %THEN FAULT(28,JJ);! SPEC BUT NO BODY GIVEN
            %IF PTYPE>=10000 %OR PTYPE=4 %OR PTYPE=106 %OR %C
               PTYPE=126 %THEN CLEAR LIST(K)
            JJ=I
         %REPEAT
         NAMES(LEVEL)=-1
         %IF LEVEL=2 %THEN DTABLE(1,1); ! DO GLOBALS TO EXTERNALRTS
!
! CHECK FOR MISSING REPEATS
!
       %WHILE CYCLE(LEVEL)#0 %THEN FAULT(13,0)%AND POP(CYCLE(LEVEL),I,I)
!
! REMOVE TEXT OF ANY LOCAL NAMES FROM WORD AND LETT
!
         %IF NEXT#RNEXT %THEN %START
            NEXT=RNEXT
!            %CYCLE I=0,1,NNAMES
!               WORD(I)=0 %IF WORD(I)>=NEXT
!            %REPEAT
            *L_0,NEXT; *SR_15,15; *SR_1,1; *LA_2,2
            *L_3,NNAMES; *AR_3,3; *L_4,WORD
AGN:        *CH_0,0(1,4); *BC_2,*+8
            *STH_15,0(1,4); *BXLE_1,2,<AGN>
         %FINISH
!
! NOW CLAIM THE STACK FRAME BY FILING THE LA 11,0(11) IN THE BLOCK ENTRY
! CODING. IF MORE THAN 4095 BYTES OF LOCAL VARIABLES ARE NEEDED THEN
! THE WHOLE INSTRUCTION MUST BE OVERWRITTEN
!
         NMAX=(NMAX+7)&(-8)
         %IF KKK=2 %THEN %RETURN
         %IF KKK>=10000 %OR KKK=1 %THEN CLAIM ST FRAME(SET(RLEVEL),NMAX)
!
! NOW PLANT THE BLOCK EXIT SEQUENCE
!
         %IF KKK=10000 %AND LAST INST=0 %THEN RT EXIT
         PPJ(6) %IF KKK=1 %AND LAST INST=0;! %STOP AT %ENDOFPROGRAM
         %IF KKK=0 %THEN %START;         ! BEGIN BLOCK EXIT
            JJ=FROM2(LEVELINF)&X'FFF';    ! DISP OF SAVE AREA
            DUMPM(X'98',10,11,RBASE,JJ);  ! RESTORE R11 & R10
            %IF DIAGS1=1 %THEN %START;    ! RESTORE DIAGS POINTERS
               DUMP(X'58',0,JJ+8,0,RBASE)
               PRX(X'50',0,0,GLA,20)
               %FINISH
         %FINISH
!
! OUTPUT ANYTHING RELEVANT ONTO THE PROGRAM LISTING
!
         NEWLINE
         %IF PRINTMAP=1 %AND  KKK#0 %THEN %START
            %PRINTTEXT' LOCALS EXTEND TO '
            WRITE(NMAX,2)
            NEWLINE
!            CHECK ASL
         %FINISH
         %IF LIST=0 %THEN %START;    ! SHORT LISTING REQD
            WRITE(LINE,5)
            %IF PRINTMAP=1 %THEN SPACES(3) %AND PRHEX(CA,5)
            SPACES(3*LEVEL-3)
            %PRINTTEXT 'END'
         %FINISH
!
! RETURN TO PREVIOUS LEVEL PROVIDED THERE IS A VALID ONE !
!
         %UNLESS LEVEL>2 %OR (LEVEL=2 %AND CPRMODE=2) %THEN %START
            %IF KKK=1 %AND LEVEL=2 %THEN KKK=2 %ELSE %C
                                   FAULT(14,0) %AND %STOP
         %FINISH
         LEVEL=LEVEL-1
         %IF KKK>=10000 %THEN %START
            RLEVEL=RLEVEL-1
            RBASE=10-RLEVEL
            REGISTER(9-RLEVEL)=0
         %FINISH
!
! RESTORE INFORMATION ABOUT THE (NEW) CURRENT LEVEL
!
         POP123(LEVELINF,CODEBASE,N,FLAG)
         NMDECS=CODEBASE>>24
         CODEBASE=CODEBASE&X'FFFFFF'
         GRINF(10)=CODEBASE
         SBFLAG=N>>15&1
         RNEXT=FLAG>>16
         FLAG=FLAG&X'FFFF'
         NMAX=N>>16 %IF KKK>=10000
         N=N&X'7FFF'
         %IF KKK=2 %THEN CEND(KKK);    ! ROUND AGAIN FOR 'ENDOFPROGRAM'
!
! COMPLETE THE JUMP AROUND ALL NON-EXTERNAL ROUTINES EXCEPT WHEN
! %TRUSTEDPROGRAM IS IN OPERATION.
!
         %IF KKK>=10000 %AND COMPILER=0 %AND (RLEVEL#1 %OR CPRMODE#2)%C
            %THEN ENTER LAB(FROM3(LABEL(LEVEL)),0)
         ->99
         %ROUTINE DTABLE(%INTEGER LEVEL,GLOBAL)
!***********************************************************************
!*      THIS ROUTINE LOOKS AT THE DECLARATIONS FOR THE CURRENT LEVEL & *
!*      SETS UP THE SEGMENT OF SHARABLE SYMBOL TABLES TO DESCRIBE THEM.*
!*      FOR MAIN PROGRAMS OR EXTERNAL ROUTINES THE 'GLOBAL' VARIABLES  *
!*      (IF ANY) ARE ALSO INCLUDED.                                    *
!***********************************************************************
         %STRING(32) RT NAME
         %STRING(8) LOCAL NAME
         %INTEGER DPTR,LNUM,ML,KK,JJ,Q,DEND,OL,LC
         %INTEGERARRAY DD(0:300);       ! BUFFER FOR SEGMENT OF SST
         %IF GLOBAL#0 %THEN DPTR=0 %AND ->START
         DD(0)=X'C2C2C2C2';             ! MARKER ==M'BBBB' IN EBCDIC
         ML=M(LEVEL);                   ! ROUTINE NAME(=0 FOR %BEGIN)
         LNUM=LETT(ML);                 ! LENGTH OF THE NAME
         DD(1)=L(LEVEL)<<16!RBASE<<8;   ! RT WORD TO TABLE
         OL=L(LEVEL-1)
         DPTR=3; DEND=0
         %IF LNUM=0 %THEN DD(2)=L(LEVEL-1) %ELSE %START
         Q=ADDR(LETT(ML))
            RT NAME<-STRING(Q);         ! FOR RTS MOVE IN 1ST 32 CHARS
            STRING(ADDR(DD(1))+3)=RTNAME;! AND UPDATE POINTER PAST
            DPTR=DPTR+(LNUM-1)>>2;      ! ACTUAL NO OF CHARS
         %FINISH
START:
         JJ=NAMES(LEVEL)
         %CYCLE LC=0,1,NNAMES
            %EXIT %IF JJ<0
               %IF GLOBAL=0 %THEN %START
                  KK=INTEGER(ADDR(ASLIST(TAGS(JJ))))
                  %IF KK&X'F000'=0 %THEN %START
                     %PRINTTEXT'
?  UNUSED NAME '
                     PRINTNAME(JJ)
                  %FINISH
               %FINISH
               ->REP %IF DIAGS1=0 %OR LINENOS=0
               COPY TAG(JJ);               ! GET DETAILS
               %IF ARR=0 %AND ROUT=0 %AND DPTR<297 %ANDC
                  PREC<4 %AND (TYPE=1 %OR TYPE=2 %OR TYPE=5) %C
                  %AND (GLOBAL=0 %OR OLDI=1) %THEN %START
                  Q=ADDR(LETT(WORD(JJ)));  ! ADDRESS OF NAME
                  DD(DPTR)=NAM<<30!PREC<<27!TYPE<<24!I<<20!K<<8
                  LOCAL NAME<-STRING(Q);   ! TEXT OF NAME FROM DICTIONARY
                  LNUM=BYTE INTEGER(ADDR(LOCAL NAME))
                  STRING(ADDR(DD(DPTR))+3)=LOCAL NAME;! MOVE IN NAME 
                  DPTR=DPTR+(LNUM+7)>>2
               %FINISH
REP:           JJ=SHORTINTEGER(ADDR(ASLIST(TAGS(JJ)))+12)
         %REPEAT
         %IF LEVEL=2 %THEN %START;      ! GLOBALS TO FOLLOW
            DD(DPTR)=-2;                ! GLOBAL TO COME MARKER
            DPTR=DPTR+1
         %FINISH %ELSE %START
            DD(DPTR)=-1;                   ! 'END OF SEGMENT' MARK
            DD(DPTR+1)=OL;                 ! SO DEBUG CAN FIND GLOBALS
            DPTR=DPTR+2
         %FINISH
         DPTR=DPTR<<2
         %IF DIAGS1=1 %THEN %START
            %IF GLOBAL=1 %AND DPTR=8 %THEN SSTL=SSTL-4;! PUT -1 ONTOP OF -2
            LPUT(4,DPTR,SSTL,ADDR(DD(0)));! ADD TO SHARABLE SYM TABS
            SSTL=SSTL+DPTR
         %FINISH
         %END;                          ! OF ROUTINE DTABLE
99:      %END
!***********************************************************************
!*       VARIOUS ROUTINE THAT ARE REQUIRED ONLY AT BLOCK START         *
!*       AND BLOCK END ARE GATHERED HERE. HOPEFULLY THEY WILL BE PAGED *
!*       OUT EXCEPT WHEN NEEDED.                                       *
!***********************************************************************
!
         %ROUTINE TEST NST
!***********************************************************************
!*       SEE IF NAME 'K' HAS BEEN DECLARED BEFORE AT THIS LEVEL        *
!***********************************************************************
         FNAME=K
         FAULT(7,FNAME) %IF FROM1(TAGS(FNAME))>>8&15=LEVEL
         %END
         %ROUTINE RELOCATE(%INTEGER GLARAD,VALUE,AREA)
         %SHORTROUTINE
!***********************************************************************
!*      PLANTS A WORD IN THE GLA (IF GLARAD<0) AND ARRANGES TO         *
!*       RELOCATE IT RELATIVE TO AN AREA(CODE=1,GLA=2,CST=4,GST=5      *
!*       RELOCATION RELATIVE TO SYMBOL TABLES CAN NOW BE DONE HERE     *
!***********************************************************************
         %IF GLARAD<0 %THEN PGLA(4,4,ADDR(VALUE)) %AND GLARAD=GLACA-4
         %IF AREA<3 %THEN LPUT(AREA+19,0,GLARAD,0) %ELSE %C
            LPUT(AREA+14,0,GLARAD,0)
!            PUSH123(RELHEAD,GLARAD,VALUE,AREA)
         %END
         %ROUTINE GXREF(%INTEGER MODE,NAME,XTRA,AT)
         %SHORTROUTINE
!***********************************************************************
!*       ASK LPUT TO ARRANGE TO RELOCATE 1 OR MORE WORDS AT 'AT'       *
!*       IN THE GLA BY EXTERNAL NAME 'NAME'.                           *
!*       MODE DEFINES ENTITY:-                                         *
!*       MODE=0 FOR STATIC XREFS (XTRA='S' OR 'I' FOR #IDENS)          *
!*       MODE=1 FOR DYNAMIC XREFS                                      *
!*       MODE=2 FOR DATA REFS XTRA=LMIN                                *
!*       NAME=0 FOR IOCP REFERENCES                                    *
!***********************************************************************
         %INTEGER J,LPUTNO
         %STRING(8) ID
         %IF NAME<0 %THEN %START
            %IF NAME=-1 %THEN J=ADDR(IOCP1)+3 %ELSE J=ADDR(IMPMON1)+3
         %FINISH %ELSE J=ADDR(LETT(WORD(NAME)));! J TO NAME TEXT
         ID<-STRING(J);                ! MOVE IN NAME
         %IF MODE<=1 %AND XTRA>0 %THEN %C
            ID<-TOSTRING(XTRA).'#'.ID
         %IF MODE=2 %THEN LPUTNO=15 %ELSE LPUTNO=MODE+12
         LPUT(LPUTNO,XTRA,AT,ADDR(ID))
         %END

         %ROUTINE CXREF(%INTEGER MODE,NAME,XTRA,%INTEGERNAME AT)
         %SHORTROUTINE
!***********************************************************************
!*       CREATE A ZEROED AREA IN THE GLA AND CALL GXREF TO GET         *
!*       IT FILLED AT LOAD TIME WITH INFORMATION ON AN EXTERNAL OBJECT *
!*       PARAMETERS ARE AS FOR GXREF.                                  *
!***********************************************************************
         %INTEGER L
         %IF MODE=2 %THEN L=4 %ELSE L=16;    ! DATA OR ROUTINE
         PGLA(4,L,ADDR(FIXED GLA(7)));       ! 1 OR 4 ZERO WORDS
         AT=GLACA-L
         GXREF(MODE,NAME,XTRA,AT)
         %END
         %ROUTINE CLT
         %SHORTROUTINE
!***********************************************************************
!*       DEAL WITH PHRASE TYPE AND SET PREC,TYPE & ACC                 *
!*       ONLY PROBLEM IS STRING WHICH HAS OPTIONAL MAX LENGTH ALSO     *
!*       P ON PHRASE TYPE AT ENTRY - TO NEXT PHRASE AT EXIT.           *
!***********************************************************************
         TYPE=TYPEFLAG(A(P));       ! TYPEFLAG HOLDS PREC & TYPE
         PREC=TYPE>>3
         TYPE=TYPE&7
         %IF PREC=2 %THEN WARN(LINE);   ! WARNING FOR SHORTS
         PREC=3 %IF TYPE=2 %AND ALL LONG#0;! DEAL WITH '%REALSLONG'
         ACC=BYTES(PREC)
         %IF TYPE=5 %THEN %START;    ! P<TYPE>='%STRING'
            %IF A(P+1)=1 %THEN %START;! MAX LENGTH GIVEN
               P=P+2
               ACC=A(P)+1
               FAULT(70,0) %UNLESS 2<=ACC<=256
            %FINISH %ELSE ACC=0 %AND P=P+1
         %FINISH
         P=P+1
         %END
         %ROUTINE CQN(%INTEGER P)
         %SHORTROUTINE
!***********************************************************************
!*       SET NAM,ARR & ACC FROM ALTERNATIVE OF PHRASE <QNAME'>         *
!*       P<QNAME'>='%ARRAYNAME','%NAME',<%NULL>                        *
!*       P POINTS TO THE ANALYSIS RECORD ENTRY AS IS NOT UPDATED       *
!***********************************************************************
         %BYTEINTEGER I
         I=A(P);NAM=0;ARR=0
         %IF I=1 %THEN ARR=1 %AND ACC=16; ! ARRAYNAMES
         %IF I<=2 %THEN NAM=1;           ! ARRAYNAMES & NAMES
         %IF I=2 %THEN ACC=4;            ! NAMES USE 4-BYTE POINTER
         %END
         %ROUTINE     RHEAD(%INTEGER KK)
         %SHORTROUTINE
!***********************************************************************
!*       COMPILES CODE FOR BLOCK AND ROUTINE ENTRY                     *
!*       KK IS THE RT/FN/MAP NAME (=-1 FOR %BEGIN BLOCKS)              *
!*       FLAGP IS AS KK EXCEPT FLAGP=10000 IS USED TO DISTINGUISH      *
!*       THE FIRST (PERM) BEGIN WHICH HAS TO BE TREATED AS A ROUTINE   *
!*       ROUTINE TAGS ARE AS FOLLOWS:-                                 *
!*       SNDISP = WORD(!) DISPLACEMENT OF EP(REF)FROM HEAD OF CODE(GLA)*
!*        (OR)  = LISTHEAD OF OUTSTANDING FORWARD REFS                 *
!*       KFORM  = PSIMPLE<<12 ! NO OF PARAMS                           *
!*       K      = LIST OF FORMAL PARAMETER DESCRIPTIONS                *
!***********************************************************************
         %INTEGER FLAGP,W1,W2,W3,BASED,AT,WK
         PUSH123(LEVELINF,NMDECS<<24!CODEBASE,NMAX<<16!SBFLAG<<15!N,%C
             RNEXT<<16!FLAG)
         FLAGP=KK;FLAGP=10000 %IF RLEVEL=0
         %IF LIST=0 %AND RLEVEL#0 %THEN %START;  ! OUTPUT HEADER
            NEWLINE;WRITE(LINE,5)
            %IF PRINTMAP=1 %THEN SPACES(3) %AND PRHEX(CA,5)
            SPACES(3*LEVEL)
            %IF KK<0 %THEN %PRINTTEXT'BEGIN' %ELSE %START
               %IF PTYPE=10000 %THEN %PRINTTEXT'RT ' %ELSE %C
                  %PRINTTEXT'FN/MAP '
               PRINTNAME(KK)
           %FINISH
         %FINISH
         LEVEL=LEVEL+1
         NAMES(LEVEL)=-1
         %IF FLAGP>=0 %THEN %START
            RLEVEL=RLEVEL+1; RBASE=10-RLEVEL
            FAULT(35,0) %IF RBASE=4 %OR REGISTER(RBASE)#0
            FORGET(RBASE); REGISTER(RBASE)=-1
         %FINISH
         FAULT(34,0) %IF LEVEL=10
         FAULT(105,0) %IF LEVEL>MAX LEVELS
         NMDECS=0
         %IF FLAGP<0 %THEN %START;       ! BEGIN BLOCKS
            PRX(X'90',10,11,RBASE,N);    ! STM 10,11,?
            N=N+12; W2=N-4
         %FINISH
         %IF KK>=0 %THEN %START;      ! ROUTINE ENTRY
            %IF SNDISP=0 %AND EXTRN=4 %START; ! REPLACE 'NOT USED' BIT
               REPLACE1(TAGS(KK),FROM1(TAGS(KK))&X'FFFF0FFF')
            %FINISH
!
! NOW FILL ANY JUMPS TO THIS ROUTINE PLANTED SINCE
! THE ROUTINESPEC WAS COMPILED. SEE ALSO 'RT JUMP'
!
            %WHILE SNDISP#0 %CYCLE
               POP123(SNDISP,BASED,AT,W1)
               W2=CA-BASED
               %IF W1=0 %THEN %START
                  WK=PTBASE+W2>>12<<2
                  %IF W2<=4095 %THEN %START
                     PLUG(1,AT,X'41DD');      ! OVERWRITE THE ADD
                     WK=0;                  ! WITH LA 13,0(13) AS NO-OP
                  %FINISH
                  PLUG(1,AT+2,WK)
                  AT=AT+4
            
               %FINISH %ELSE %START
                  FAULT(99,0) %IF W2>4095
               %FINISH
               PLUG(1,AT+2,W2&4095)
            %REPEAT
            SNDISP<-CA>>2
            REPLACE2(TCELL,INTEGER(ADDR(SNDISP)));! NOTE ADDR FOR FUTURE CALLS
            PCONST(X'50FB003C');          ! SAVE LINK -- ST 15,60(11)
            W2=0
         %FINISH
         PRR(X'18',RBASE,WSPR) %UNLESS FLAGP<0
         %IF KK<0 %THEN W3=0 %ELSE W3=WORD(KK)
         L(LEVEL)=LINE;M(LEVEL)=W3
         RNEXT=NEXT
         FLAG=PTYPE;                ! CURRENT BLOCK TYPE MARKER
         %IF FLAGP>=0 %THEN %START
            SET(RLEVEL)=CA+2
            PCONST(X'41BB0000');       ! LA WSP, ?(WSP)
            N=64; NMAX=N;
            FORGETM(14);               ! START NEW RT W CLEAN SLATE
            CCSTATE=-1
         %FINISH
!
! IF IN DIAGNOSTIC MODE PLANT CODE TO SAVE THE LINE & ROUTINE NO OF
! THE CALLING ROUTINE AND SET UP THE NEW BLOCK/ROUTINE IDENT NO.
!
         %IF DIAGS1#0 %AND LINE>0 %THEN %START
            PRX(X'58',0,GLA,0,20);     ! L  0,OLD DIAGS INF
            DUMP(X'50',0,W2,0,RBASE);  ! ST 0,SAFE PLACE
            DUMP(X'41',0,LINE,0,0);    ! LA   0,LINE NO
            PCONST(X'4000D014');       ! STH 0,20(GLA)
            FORGET(0);                 ! NEEDED FOR %BEGIN BLOCKS
         %FINISH
         MONE=1; SET LINE;             ! NOW UPDATE LINE NUMBER
         %END;                         ! OF ROUTINE RHEAD
         %ROUTINE  DEFINE EP(%INTEGER MODE,NAME,ADR,XTRA)
         %SHORTROUTINE
!***********************************************************************
!*        ENTER AN ENTRY POINT ON THE ENTRY POINT LIST                 *
!*       AN ENTRY POINT LOOKS LIKE:-                                   *
!*       S1 = FLAG<<24 ! ENTRY POINT ADDRESS RELATIVE TO START OF AREA *
!*       S2 = XTRA INFO (PRIMARILY LENGTH OF DATA 'COMMON' AREAS)      *
!*       S3 = LINK TO SINGLE CELL SIDECHAIN CONTAINING NAME AS STRING  *
!*       FLAG = 0 FOR PROGRAM ENTRY POINT                              *
!*            = 1 FOR DATA IN GLA (%EXTERNAL)                          *
!*            = 2 FOR DATA IN GLA SYMBOL TABLE (%EXTERNAL %ARRAY)      *
!*       MODE=0 FOR S#GO, =1 SYSTEM ROUTINES,=2 EXTERNAL ROUTINES      *
!*       MODE=3 FOR DATA IN ADDRESSABLE GLA,=4 BACK OF GLA             *
!***********************************************************************
         %SHORTINTEGER HEAD
         %INTEGER JJ,FLAG,ID1,ID2,ID3
         %STRING(8) ID
         ID=''; FLAG=0
         HEAD=0
         %IF MODE=0 %THEN JJ=ADDR(MAINEP1)+3 %ELSE %C
                         JJ=ADDR(LETT(WORD(NAME)))
         %IF MODE>=3 %THEN FLAG=MODE-2
         %IF MODE=1 %THEN ID='S#'
         ID<-ID.STRING(JJ)
         STRING(ADDR(ID1))=ID
         %IF FLAG=0 %THEN JJ=11 %ELSE JJ=14
         %IF FLAG<=1 %THEN LPUT(JJ,XTRA,ADR,ADDR(ID)) %ELSE %START
            PUSH123(HEAD,ID1,ID2,ID3>>16)
            PUSH123(EPLINK,FLAG<<24!ADR,XTRA,HEAD)
         %FINISH
         %END
         %ROUTINE     CRSPEC (%INTEGER M)
         %SHORTROUTINE
!***********************************************************************
!*        MODE=0  FOR NORMAL ROUTINE SPEC                              *
!*        MODE=1 FOR EXTERNAL(ETC) ROUTINE SPECS XREF NEEDED           *
!*        MODE=2 FOR %SPEC FOR RT PARAMS                               *
!*       ROUTINE TAGS ARE AS FOLLOWS:-                                 *
!*       SNDISP = WORD(!) DISPLACEMENT OF EP(REF)FROM HEAD OF CODE(GLA)*
!*        (OR)  = LISTHEAD OF OUTSTANDING FORWARD REFS                 *
!*       KFORM  = PSIMPLE<<12 ! NO OF PARAMS                           *
!*       K      = LIST OF FORMAL PARAMETER DESCRIPTIONS                *
!***********************************************************************
         %INTEGER PP,KK,JJ,JJJ,Q,TYPEP,PREFIX,INC,PSIMPLE,PPOSN
         %SHORTINTEGER OPHEAD,OPBOT
         Q=0
         %IF M#2 %THEN %START
!
! WORK OUT TYPEP IE TYPE OF ENTITITY BY INSPECTING AR FOR P<RT>
!
            %IF A(P+1)=1 %THEN %START;  ! P<RT>=%ROUTINE
               TYPEP=10000; P=P+3
            %FINISH %ELSE %START;       ! P<RT>=<TYPE><FNORMAP>
               ROUT=1; ARR=0; P=P+2
               CLT; NAM=(A(P)-1)<<1
               PACK(TYPEP)
               P=P+2
            %FINISH
         %FINISH
         KK=A(P); COPYTAG(KK)
!
! IF KK IS A VALID RT TYPE PARAM IT MUST BE DECLARED AT THE CURRENT
! LEVEL AND HAVE 1000 PARAMS. IF KK IS A NEW DECLARATION '%SPEC' CANNOT
! BE USED AND THE NAME MUST NOT BE SET AT THE CURRENT LEVEL.
!
         %IF SNPT#PTYPE>=10000 %THEN Q=KFORM&4095 %AND %C
                                      JJ=(SNDISP&X'FFFF')<<2
         %UNLESS OLDI=LEVEL %AND Q=1000 %AND %C
                 (M=2 %OR PTYPE-1000=TYPEP) %THEN %START
!
! KK IS NOT A VALID RT TYPE PARAM
!
            %UNLESS OLDI#LEVEL %AND M<=1 %THEN %START;! KK VALID DECLN
               FAULT(7-M>>1<<2,KK);     ! FAULT 3(SPEC?)OR 7(SET TWICE)
               %RETURN %UNLESS M=0
            %FINISH
            JJ=0;                       ! SO MAKE DECLARATION
            J=15-M; PTYPE=TYPEP
            KFORM=0
            %IF OLDI = LEVEL %THEN %START
              USEBITS = INTEGER(ADDR(ASLIST(TAGS(KK)))) >> 12 & X'F'
              I = RBASE
              REPLACE TAG (KK)
            %FINISH %ELSE STORE TAG(KK,0)
         %FINISH
         OPHEAD=0; OPBOT=0
         PPOSN=64;                      ! DISPLCMENT OF EACH PARAM
         INC=1; JJJ=OPHEAD; PSIMPLE=1
         P=P+1; Q=0;                    ! Q COUNTS NO OF FORMAL PARAMS
         %WHILE A(P)=1 %CYCLE;          ! WHILE SOME(MORE) FPS
            P=P+INC;                    ! P<COMMA'> BETWEEN FPDELS
            CFPDEL;                     ! GET TYPE & ACC FOR NEXT GROUP
            PPOSN=(PPOSN+KFORM-1)&(-KFORM)
            PSIMPLE=0 %UNLESS PTYPE=1 %OR %C
                 (ROUT=0 %AND ARR=0 %AND NAM=1 %AND TYPE#0)
            %CYCLE PP=1,1,A(P);         ! DOWN <NAMELIST> FOR EACH DEL
               BINSERT(OPHEAD,OPBOT,PTYPE,ACC<<16!PPOSN,0)
               Q=Q+1
               PPOSN=PPOSN+ACC
            %REPEAT
            P=P+PP+1;                   ! ASSUMES PP SET TO A(P) BY REPE
            INC=2;                      ! TO IGNORE ALT OF P<COMMA'>
         %REPEAT
         %IF EXTRN=1 %THEN PREFIX='S' %ELSE PREFIX=0
         %IF M=1 %THEN CXREF((EXTRN-1)>>1,KK,PREFIX,JJ)
         TCELL=TAGS(KK)
         INTEGER(ADDR(SNDISP))=FROM2(TCELL)
         KFORM=PSIMPLE<<12!Q
         K=OPHEAD; SNDISP<-(JJ>>2)
         REPLACE2(TCELL,INTEGER(ADDR(SNDISP)))
         REPLACE3(TCELL,INTEGER(ADDR(K)))
         %END
         %ROUTINE CFPDEL
         %SHORTROUTINE
!***********************************************************************
!*       SET UP PTYPE & ACC FOR A LIST OF FORMAL PARAMETERS            *
!*       P<FPDEL>=<RT><%NAME'>,<TYPE><%QNAME'>,'%NAME',                *
!*                '%RECORD'<%ARRAY'>'%NAME'.                           *
!***********************************************************************
         %BYTEINTEGER FPALT
         FPALT=A(P); P=P+1; KFORM=4
         %IF FPALT<=2 %THEN %START
            %IF FPALT=1 %THEN %START
               ACC=4; ROUT=1; ARR=0
               %IF A(P)=2 %THEN %START;   ! P<RT>=<TYPE><FNORMAP>
                  P=P+1; CLT
                  NAM=(A(P)-1)<<1+1;      ! 1 FOR FN 3 FOR MAP
                  ACC=4
               %FINISH %ELSE %START;      ! P<RT>='%ROUTINE'
                  NAM=1; PREC=0; TYPE=0
               %FINISH
               P=P+2
            %FINISH %ELSE %START;         ! FPALT=2
               ROUT=0
               CLT; CQN(P)
               FAULT(70,0) %IF TYPE=5 %AND ACC=0
               %IF NAM=0 %THEN %START
                  %IF TYPE=5 %THEN KFORM=1 %ELSE KFORM=ACC
               %FINISH
               P=P+1
            %FINISH
         %FINISH %ELSE %START
            ROUT=0; PREC=0; NAM=1
            %IF FPALT=3 %THEN %START;     ! P<FPDEL>='%NAME'
               ACC=8; ARR=0; TYPE=0
            %FINISH %ELSE %START
               ARR=2-A(P)
               ACC=4+12*ARR
               TYPE=3; P=P+1
            %FINISH
         %FINISH
         PACK(PTYPE)
         %END
         %ROUTINE ASSIGN(%INTEGER ASSOP,P1)
         %SHORTROUTINE
!***********************************************************************
!*       HANDLES ARITHMETIC,STRING & ADDRESS ASSIGNMENTS TO VARIABLES  *
!*       FORMAL PARAMETERS AND DOPEVECTORS                             *
!*       ASSOP:-                                                       *
!*        1 IS FOR '=='                                                *
!*        2 IS FOR '='                                                 *
!*        3 IS FOR '<-' (JAM TRANSFER)                                 *
!*        4 IS FOR '->' (UNCONDITIONAL RESOLUTION)                     *
!*       >4 IS A SPECIAL FOR RESOLUTION                                *
!*               STORE BASE&DISP INTO NAME INDEXED BY P1 (RESLN)       *
!*                                                                     *
!*       P POINTS TO THE EXPRESSION. P1 TO THE NAME ON LHS OR          *
!*       P1=BASE<<16!OFFSET AND TYPE+PREC SET UP FOR FORMAL PARAMETERS *
!***********************************************************************
         %SHORTINTEGER HEAD1,NOPS,TPCELL,BOT1
         %INTEGER Q,QQ,KK,REG,Z,ZP,TYPEP,PRECP,PTYPEP,JJJ,P2,JJ, %C
            BASEP,DISPP,RHTYPE,ACCP,II
         %SWITCH SW(0:3);              ! TO SWITCH ON ASSOP
!
         %IF ASSOP>4 %THEN %START
            BASEP=BASE; DISPP=DISP; RHTYPE=TYPE
         %FINISH
         P2=P
         %IF P1< X'FFFF' %THEN %START
            P=P1; REDUCE TAG(1);       ! LOOK AT LH SIDE
         %FINISH
         PTYPEP=PTYPE; JJ=J
         KK=K; II=I
         TPCELL=TCELL; ACCP=ACC
         P=P2; TYPEP=TYPE; PRECP=PREC; ! SAVE USEFUL INFO FOR LATER
         -> SW(ASSOP&3)
!
SW(2):SW(3):                           ! ARITHMETIC ASSIGNMENTS
         ->REGVAR %IF TYPE=8;          ! LHS A REGISTER VARIABLE
         %IF TYPE=3 %THEN %START;      ! RECORD SO EXAMINE SUBNAME
         P=P1; Q=COPY RECORD TAG(QQ)
         P=P2; %IF TYPE=3 %THEN ->RECOP; %FINISH
         TYPE=1 %UNLESS TYPE=2 %OR TYPE=5;! IN CASE OF RUBBISHY SUBNAMES
         ->50 %IF TYPE=5;              ! LHS IS A STRING
!
! THE CODING BETWEEN HERE AND 'BACK' EXAMINES FOR DEGENERATE ASSIGNMENT
! CASES SUCH AS 'I=I!2' OR BYTE=BYTE&7. THESE CAN BE HANDLED IN ONE SI
! M/C INSTRUCTION. THE CODING COULD BE EXTENDED TO FIND'I=I!J'
! THIS WHOLE SECTION IS OMITTED FROM SERVICE IMP(AA)
!
         %IF ASSOP<=3 %AND CHECKSP=0 %AND TYPEP=1 %AND ARR=0 %AND %C
            NAM=0 %AND P1<X'FFFF' %AND ROUT=0 %AND A(P1+1)=2 %START;! NO APP
            TYPEP=PTYPE; PRECP=PREC
            Q=TSEXP(JJJ,0);            ! EXAMINE RHS
!
! CHECK FORM OF RHS AND THAT THE SAME NAME IS ON BOTH SIDES
!
            %IF (Q=300 %OR Q=400 %OR (Q=800 %AND PRECP=1)) %AND %C
               KK=K %AND II=I %AND KK<=4095 %START
               KK=KK+BYTES(PRECP)-1
               %IF Q=300 %THEN ZP=X'97' %ELSE ZP=X'96'
               %IF Q=800 %THEN ZP=X'94'
               PSI(ZP,JJJ,II,KK)
               CCSTATE=-1
               ->NA
            %FINISH %ELSE PTYPE=TYPEP %AND UNPACK
         %FINISH
BACK:    HEAD1=0;                      ! CLEAR TEMPORAYRY LIST HEADS
         TYPE=1 %UNLESS TYPE=2;        ! DEAL WITH UNSET NAMES
         ZP=TYPE; NOPS=1; P=P2+2
         %IF TYPE=2 %THEN ZP=ZP+PREC&1
         PUSH(HEAD1,ASSOP&3+28,0);       ! ASSIGNMENT OPERATOR
         BOT1=HEAD1
         %IF P1>X'FFFF' %THEN Z=P1>>16<<8!9 %ELSE Z=2
         PUSH(HEAD1,PTYPEP<<16!Z,P1&X'7FFF');! LHS
         %IF ASSOP>4 %THEN %START
            FAULT(24,0) %UNLESS TYPE=RHTYPE
            PUSH(HEAD1,RHTYPE<<16!BASEP<<8!9,DISPP)
            SET USE((RHTYPE&2)<<3+BASEP,1,HEAD1) %IF DISPP<0
         %FINISH %ELSE TORP(HEAD1,BOT1,NOPS,ZP);! RHS TO REVERSE POLISH
         Q=P; EXPOP(HEAD1,-1,NOPS,16); ! PLANT CODE
         P=Q
!         CLEARLIST(HEAD1)
         SHORTINTEGER(ADDR(ASLIST(BOT1))+14)=ASL
         ASL=HEAD1; ->1
NA:      NOTE ASSMENT(-1,ASSOP&3,A(P1)); ->1
50:      Z=0;                          ! STRINGS
         %IF ASSOP<4 %THEN %START;     ! SORT RHS
            FIND REG(SAFE,REG)
            CSTREXP(0,REG); Z=NEST
            %IF Z>0 %THEN SET USE(Z,13,0)
            DISPP=DISP; BASEP=BASE
            %UNLESS CHECKSP=0 %OR 4<=BASEP<=14 %START
               PRR(X'18',REG,BASEP)
               SET USE(REG,GRUSE(BASEP),GRINF(BASEP))
               BASEP=REG
            %FINISH
         %FINISH
         REGISTER(BASEP)=1 %IF REGISTER(BASEP)=0
         QQ=STRINGL; Q=P
         %IF P1>X'FFFF' %THEN %START
            BASE=P1>>16; DISP=P1&X'FFFF'
            BML=0; DML=ACCP
         %FINISH %ELSE %START
            P=P1; CNAME(1,0)
            %IF INDEX>0 %THEN %START
               PRR(X'1A',INDEX,BASE)
               FORGET(INDEX)
               BASE=INDEX; INDEX=0
            %FINISH
         %FINISH
!

         %IF DISPP=X'C0' %AND BASEP=CODER %THEN %START
            DUMPSI(X'92',0,BASE,DISP);         ! MVI IF RHS NULL
         %FINISH %ELSE %START
            REG=(ASSOP&3-1)**2
            %IF REG#1 %OR Z<=0 %OR GRUSE(Z)#13 %THEN Z=-2
            STRINGOP(REG,QQ,BASE,DISP,BASEP,DISPP,BML,DML,Z)
            %IF Z>0 %AND GRUSE(Z)=13 %THEN SET USE(Z,2,-2)
            REGISTER(BASEP)=0 %IF REGISTER(BASEP)>0
         %FINISH
         P=Q; ->1
REGVAR:  FAULT(59,0) %UNLESS A(P1+1)=2=A(P1+2)
         KK=1<<K
         %IF REGISTER(K)>=0 %THEN ABORT
        %IF CYC REGS&KK#0 %THEN CYC ASS=CYC ASS!KK %ELSE NMDECS=NMDECS!4
         CSEXP(K,1); ->NA

! THIS SECTION DEALS WITH OPERATIONS ON COMPLETE RECORDS
RECOP:                                   ! LHS IS RECORD WITHOUT SUBNAME
         Q=TSEXP(JJJ,0)
         -> RZ %IF Q=1=TYPE %AND JJJ=0;  ! CLEAR ENTIRE RECORD TO ZERO
         -> BACK %UNLESS Q=30;           ! ASSIGN RECORD TO RECORD
         P=P2+4; CNAME(16,-2);           ! SET BASE &DISP FOR RHS
         BASEP=BASE; DISPP=DISP
         ZP=ACC
         CYC BITS=CYC BITS!128 %IF COMPILER=0; ! SAFE REG NEEDED
         %UNLESS COMPILER=1 %OR 4<=BASE<=14 %START
            FINDREG(SAFE,NEST)
            PRR(X'18',NEST,BASE)
            SET USE(NEST,GRUSE(BASE),GRINF(BASE))
            BASEP=NEST
         %FINISH
         REG=BASEP
         REGISTER(BASEP)=1 %IF REGISTER(BASEP)=0
RZ:      P=P1; CNAME(16,-2);             ! BASE & DISP FOR LHS
         KK=DISP; JJ=BASE; ACCP=ACC
!
         %IF Q=1 %THEN %START
         BASEP=0; DISPP=0
         %FINISH %ELSE %START
         ->F66 %IF ASSOP=2 %AND ACCP#ZP;  ! '=' OPRN BOTH RECORD MUST
                                          ! HAVE THE SAME LENGTH
         %IF ZP<ACCP %THEN ACCP=ZP;       ! ON'<-' MOVE SMALLER
         %FINISH
         REGISTER(JJ)=1 %IF REGISTER(JJ)=0
!
         BULKM(Q-1,ACCP,JJ,KK,BASEP,DISPP)
         %IF REGISTER(JJ)>0 %THEN REGISTER(JJ)=0
         %IF Q=30 %AND REGISTER(BASEP)>0 %THEN REGISTER(BASEP)=0
         P=P2; SKIP EXP; ->1
SW(0):                                 ! RESOLUTION
         P=P1; CNAME(5,1);             ! LOAD UP LHS
         P=P2; CRES(0); ->1;           ! PERFORM UNCONDITIONAL RESOLUTIO
SW(1):                                 ! '==' AND %NAME PARAMETERS
         ->F2 %UNLESS A(P2+2)=4 %AND A(P2+3)=1;! DISALLOW EXPRESSIONS
         REG=-2
          %UNLESS ROUT=0 %AND ARR=0 %AND (P1>X'FFFF' %OR %C
         A(P1+1)=2=A(P1+2)) %THEN  CLAIM(SAFE,REG) %AND FORGET(REG)
         %IF TYPE=3 %THEN %START
            ->RECNAME %IF P1>X'FFFF';     ! RECORD NAME PARAMETERS
            P=P1; Q=COPY RECORD TAG(QQ)
            TYPEP=TYPE; PRECP=PREC; JJ=J
            -> RECNAME %IF Q=0 %AND NAM=1
         %FINISH
         -> F1 %UNLESS NAM=1;          ! LHS MUST BE A POINTER
         P=P2+4
         ->ARRNAME %IF ARR=1
         CNAME(3,REG)
         Z=I; ZP=K
         REG=NEST %IF REG<0
         %IF A(P2+5)=2=A(P2+6) %THEN %C
         NOTE ASSMENT(-1,1,A(P2+4));   ! RHS VARIAVBLE MAY BE CHANGED
                                       ! BY ASSIGNING TO LHS
         KK=6
COMM:    ->F3 %UNLESS TYPEP=0 %OR TYPE=0 %OR %C
            (TYPE=TYPEP %AND (PREC&3)=PRECP)
         ->F2 %UNLESS A(P)=2;          ! NO REST OF EXPRSSN
         Q=P+1; P=P1
         %IF P<X'FFFF' %THEN %START
            CNAME(KK,REG)
            %IF A(P1+1)=2=A(P1+2) %THEN NOTE ASSMENT(REG,1,A(P1))
         %FINISH %ELSE %START
            BASE=P>>16; DISP=P&X'7FFF'
            DUMP(1,REG,DISP,0,BASE) %UNLESS KK=12
            %IF TYPEP=0 %THEN %START; ! TO A %NAME PARAM
               %IF TYPE=0 %THEN %START; ! %NAME TO %NAME
                  JJJ=X'58'; ZP=ZP+4;   ! LOAD INFO WORD
               %FINISH %ELSE %START;    ! NORMAL VARIABLE TO %NAME
                  PSI(X'92',PREC<<3!TYPE,BASE,DISP);  ! FLAGS BYTE
                  %IF TYPE=5 %THEN JJJ=X'88' %AND ZP=24 %ELSE %START
                     JJJ=X'41'
                     %IF TYPE>=3 %THEN ZP=ACC %ELSE ZP=BYTES(PREC)
                     ZP=ZP-1
                  %FINISH
               Z=0
               %FINISH
               DUMP(JJJ,REG,ZP,0,Z)
               FORGET(REG)
               DUMP(X'50',REG,DISP+4,0,BASE);!    STORE XTRA WORD
            %FINISH
         %FINISH
         REGISTER(REG)=0 %IF REGISTER(REG)>=0; P=Q
         %IF KK=12 %THEN %START;       ! == TO ARRAY NAME
            FORGET(REG)
            CYC BITS=CYC BITS!512;     ! ARRAYNAME == BIT
            PMVC(16,BASE,DISP,Z,ZP);   ! MOVE IN ARRAYHEAD
                                       ! DISP>4095 SORTED IN CNAME
            REGISTER(Z)=0 %IF REGISTER(Z)=2
            ->F3 %UNLESS P1>X'FFFF' %OR ARR=1 %OR ARR=2
                                        ! ALLOW ARRAYS&VECTORS \FORMATS
         %FINISH %ELSE CYC BITS=CYC BITS!256;! REC/SCALAR == BIT
         ->1
ARRNAME: CNAME(12,REG);                ! SET BASE & DISP
         Z=BASE; ZP=DISP;              ! AND SAVE THEM
         ->F3 %UNLESS 1<=ARR<=2
         %IF JJ=0 %THEN %START
         JJ=J; %IF P1<X'FFFF' %THEN %START
         KK=FROM1(TPCELL);              ! DEDUDCE NO OF DIMENS
         REPLACE1(TPCELL,KK!JJ); %FINISH; %FINISH
         FAULT(85,0) %UNLESS J=JJ %OR J=0
         REGISTER(Z)=2 %IF REGISTER(Z)=0
         KK=12; ->COMM
RECNAME: P=P2+4
         ->ARRNAME %IF ARR=1 %AND (P1>X'FFFF' %OR A(P1+1)=2);
         CNAME(15,REG);                ! FETCH/SET POINTER
         REG=NEST %IF REG<0
         KK=14; ->COMM
F66:      Q=66; ->F00
F1:      Q=82; ->F00;                  ! LHS NOT A POINTER VARIABLE
F0:      P=P2; SKIP EXP;               ! SKIP RHS
         %IF 0<=REG<=15 %AND REGISTER(REG)>0 %THEN REGISTER(REG)=0
         ->1
F2:      Q=81;                         ! RHS AN EXPRSSN
F00:     %IF P1>X'FFFF' %THEN Q=22;    ! IF PARAM GIVE 'ACTUAL PARAM FLT
         %IF Q=82 %THEN JJ=A(P1) %ELSE JJ=0
         FAULT(Q,JJ)
         ->F0
F3:      Q=83; ->F00;                  ! NON-EQUIVALENCE'
1:       %END
         %ROUTINE     CUI(%INTEGER CODE)
         %SHORTROUTINE
         %INTEGER KK,JJ,QQ
         %BYTEINTEGER TYPEP,PRECP
         %SWITCH SW(1:8)
         REPORTUI=0;                  ! =0 CONTINUE,=1 UNCOND JUMP
         ->SW(A(P))
SW(1):   P=P+1; MARKER1=P+A(P);      !(NAME)(APP)(RESTOFUI)
         ->3 %IF A(MARKER 1)=1
         P=P+1; CNAME(0,0); P=P+1; -> AUI
3:       KK=P+1; P=MARKER1+2
         ASSIGN(A(MARKER1+1),KK)
AUI:     P=P+1
         %IF A(P-1)=1 %THEN CUI(CODE); ->1
SW(2):   !-><NAME><EXRN>
         CURR INST=1 %IF CODE=0
         NMDECS=NMDECS!1
         CYC BITS=CYC BITS!2;     ! SET 'JUMP' BIT
         ->NLAB %IF A(P+1)=1;          ! NUMERIC
         ->SLAB %IF A(P+3)=2;          ! SIMPLE NAME
         COPYTAG(A(P+2))
         KK=K; P=P+2
         PTYPEP=PTYPE
         %UNLESS OLDI=LEVEL %AND TYPE=6 %THEN %START
            FAULT(4,0); P=P+1; SKIP APP; ->1
         %FINISH
         FROM12(KK,QQ,JJ)
         JJ=QQ+8-JJ*BYTES(PREC);      ! DISP OF SW(0)
         CANAME(1,GLA,0,QQ)
         %IF CHECKS=0 %THEN %START; ! OPTIMISING PUT JUMP INLINE
            DUMP(2*PREC+2,-2,DISP+JJ,BASE,INDEX)
            PRX(X'47',15,NEST,10,0)
            FORGET(NEST)
         %FINISH; REPORTUI=1; ->1
NLAB:    K=A(P+2); P=P+3
LCOM:    ENTER JUMP(MASK,K,0)
         REPORTUI=1 %IF MASK=15; ->1
SLAB:    K=16384+A(P+2); P=P+4; ->LCOM
SW(3):                                 ! %PRINTTEXT'TEXTTEXT'
         WARN(LINE)
         P=P+1; TEXTOUT(0); ->AUI
SW(4):                                 ! %RETURN
         FAULT(30,0) %UNLESS FLAG=10000 %OR COMPILER=1
         P=P+1
6:       RT EXIT
         CYC BITS=CYC BITS!2;         ! SET 'JUMP OUT' BIT
         REPORTUI=1
         CURR INST=1 %IF CODE=0; ->1
SW(5):                                 ! %RESULT(ASSOP)(EXPR)
         PTYPE=FLAG;! UNPACK
            *L_1,PTYPE; *CVD_1,0(11)
            *UNPK_ROUT(5),5(3,11)
            *NC_ROUT(5),MASK1
         %IF PTYPE>10000 %AND A(P+1)#3 %THEN %START;! ASSOP #'->'
            %IF A(P+1)=1 %AND NAM#0 %AND A(P+4)=4 %AND A(P+5)=1 %START
               P=P+6; TYPEP=TYPE; PRECP=PREC
               CNAME(3,1)
               FAULT(81,0) %UNLESS A(P)=2; P=P+1
               FAULT(83,0) %UNLESS TYPEP=TYPE %AND PRECP=PREC
               ->6
            %FINISH
            %IF A(P+1)=2 %THEN %START;    ! ASSOP='='
               P=P+2
               %IF NAM#0 %THEN TYPE=1;    ! MAPS HAVE INTEGER RESULTS
               %IF TYPE=5 %THEN CSTREXP(1,1) %ELSE %START
                  PREC=TYPE %UNLESS PREC=3 %AND NAM=0
                  CSEXP(TYPE,PREC)
               %FINISH; ->6
            %FINISH
         %FINISH
         FAULT(31,0)
         P=P+2; SKIP EXP; ->1;            ! IGNORE SPURIOUS RESULT
SW(6):   ->601 %IF A(P+1)=2;           ! %MONITOR (SOMETHING)
         %IF DIAGS1=1 %THEN PPJ(31); P=P+1
         -> 701 %IF A(P)=1; P=P+1; ->1
601:     PRX(X'41',0,0,0,A(P+2))
         WARN(LINE)
         PPJ(21); P=P+3; ->1
701:     WARN(LINE)
SW(7):                                 ! %STOP
         PPJ(6); P=P+1; CURR INST=1 %IF CODE=0
         REPORTUI=1; ->1
SW(8):                             ! %EXIT
         CYC BITS=CYCBITS!2;          ! SET JUMP BIT
         KK=FROM2(CYCLE(LEVEL))
         %IF KK=-1 %THEN %START
         FAULT(54,0) %UNLESS CSSMODE=0; ->1; %FINISH
         REPLACE2(CYCLE(LEVEL),KK!X'80000000')
         ENTER JUMP(MASK,KK>>16&X'7FFF',B'10')
         REPORTUI=1 %IF MASK=15
1:       %END
         %ROUTINE RT EXIT
         %SHORTROUTINE
!***********************************************************************
!*       THIS ROUTINE COMPILES CODE FOR ROUTINE EXIT(IE '%RETURN')     *
!*       THE ONLY PROBLEM IS REGISTER VARIABLES WHICH ARE GLOBAL       *
!*       THE SAVE AREA MUST BE UPDATED TO PREVENT THE RETURN RESTORING *
!*       THE REGISTER VARIABLE TO ITS VALUE AT THE TIME OF THE CALL    *
!***********************************************************************
         %INTEGER KK
         PSS(X'D2',4,GLA,20,RBASE,0) %IF DIAGS1=1;! RESET DIAGS PTRS
         %CYCLE KK=5,1,14;            ! CHECK FOR REGISTER VAR
           %IF 0#UVARREG(KK)<LEVEL %AND(COMPILER=0 %OR NMDECS&X'FE'#0)%C
            %THEN PRX(X'50',KK,0,RBASE,KK<<2);  ! UPDATE CORE COPY
         %REPEAT
         PRX(X'98',4,15,RBASE,16);     ! LM OLD REGISTERS
         PLANT(X'7FF')
         %END
         %ROUTINE CSTART(%INTEGER CODE)
         %SHORTROUTINE
         %INTEGER KK
         SFLABEL=SFLABEL-1
         FIND USE(KK,1,11,\SFLABEL)
         %IF KK>0 %THEN FORGET(KK)  ;! FORGET MULT OF 4K FOR SFLAB
         PUSH123(SBR(LEVEL),CODE,SFLABEL,CYCLE(LEVEL))
         %END
         %ROUTINE     TEXTOUT(%INTEGER REG)
         %SHORTROUTINE
!***********************************************************************
!*      PLANT A JUMP ROUND THE TEXT WHICH IS PUT IN THE CODE.          *
!*       REG IS LEFT POINTING AT THE TEXT.                             *
!*        REG=0 IS SPECIAL CASE PRINTTEXT                              *
!***********************************************************************
         %INTEGER KK,Q,L
         L=A(P);                       ! NO OF CHARS IN TEXT
         %IF REG=0 %THEN PPJ(30) %ELSE %START
            SET LOCAL BASE
            KK=(CA+6+L-LOCAL ADDR)&(-2)
            PRX(X'45',REG,LOCAL BASE,0,KK);! BAL ROUND TEXT
            FORGET(REG)
         %FINISH
         Q=ADDR(A(P))+1;                ! ADDR OF LENGTH BYTE
         P=P+(L+3)>>1;                 ! P ON ROUND TEXT
         %CYCLE KK=Q,2,Q+L>>1<<1
            BYTE INTEGER(ADDR(J)+2)=BYTE INTEGER (KK)
            BYTE INTEGER(ADDR(J)+3)=BYTE INTEGER (KK+1)
            PLANT(J)
         %REPEAT
         %IF SBFLAG#0 %AND CA-CODEBASE>4096 %THEN FAULT(99,0)
         %IF REG=0 %AND SBFLAG=0 %AND CA-CODEBASE>4095-MARGIN %C
                  %THEN SET USE(15,12,CA)
         %END

         %ROUTINE     CSEXP(%INTEGER REG,MODE)
         %SHORTROUTINE
!***********************************************************************
!*       COMPILE A SIGNED EXPRESSION TO REGISTER 'REG' IN MODE 'MODE'  *
!*       MODE=1 FOR %INTEGER, =2 REAL, =3 LONG,=0 INTEGER %IF POSSIBLE *
!*       MODE=5 FOR ADDRESS EXPRESSNS(IE LEAVE ANY CONSTANT IN 'ADISP')*
!***********************************************************************
         %SHORTINTEGER EXPHEAD,NOPS,EXPBOT
         %BYTEINTEGER ADDREXP
         %INTEGER PP,BDISP,PPP
         EXPHEAD=0; ADDREXP=0
         NOPS=0; EXPBOT=0
         ADDREXP=MODE>>2&1
         P=P+2
         TORP(EXPHEAD,EXPBOT,NOPS,MODE)
         %IF EXPHEAD=0 %THEN NEST=0 %AND %RETURN;! EXPR  CONSTANT ONLY
!
! MODE=13 IS A SPECIAL FOR THE BUILT IN MAPS. TO ALLOW INTEGER (ADDR(J)) 
! TO BE COMPILE AS QUICKLY AS POSSIBLE IT LOOKS FOR 'ADDR'
! AND USES CNAME TO OBTAIN 'BASE' & 'DISP' OF THE NAME AND RETURNS THESE
! AS THE RESULT OMITTING THE 'LA' THAT ADDR USES INVOKES
!
         %IF MODE=13 %AND NOPS=0 %AND CHECKSP=0 %THEN %START
            FROM12(EXPHEAD,PP,BDISP)
            %IF PP&255=2 %THEN %START;  ! ONLY OPERAND IS A NAME
               COPY TAG (A(BDISP))
!
! CHECK THE NAME TO SEE IF IT IS OF THE FORM 'ADDR(<NAME><APP>)'
!
               %IF PTYPE=SNPT %AND K=14 %AND A(BDISP+1)=1 %AND %C
                  A(BDISP+4)=4 %AND A(BDISP+5)=1 %THEN %START
                  PP=P; P=BDISP+6
                  BDISP=ADISP; PPP=P
                  CNAME(1,99);     ! SPECIAL SET 'BASE'&'DISP'
                  FAULT(22,0) %UNLESS A(P)=2
                  %IF BIMSTR#0 %THEN NOTE ASSMENT(-1,2,A(PPP))
                  P=PP; DISP=DISP+BDISP
                  CLEAR LIST(EXPHEAD)
                  ADISP=0; NEST=-1
                  %RETURN
               %FINISH
            %FINISH
         %FINISH
!
         BDISP=ADISP
         PP=P
         EXPOP(EXPHEAD,REG,NOPS,MODE&7)
         P=PP
         ADISP=BDISP
!         CLEARLIST(EXPHEAD)
         SHORTINTEGER(ADDR(ASLIST(EXPBOT))+14)=ASL
         ASL=EXPHEAD
         %END
         %ROUTINE DSEXP(%INTEGER REG,MODE)
         %SHORTROUTINE
         %COMMENT COMPILES TWO INTEGER EXPRESSIONS TO REG & REG+1
         %COMMENT REGISTERS LEFT CLAIMED
         %SHORTINTEGER SRD
         SRD=0
         CSEXP(REG,1)
         REGISTER(REG)=1
         PUSH(SRD,1<<16!9!REG<<8,-2)
         SET USE(REG,1,ADDR(ASLIST(SRD)))
         P=P+MODE
         CSEXP(REG+1,1)
         REGISTER(REG+1)=1
         EXPOP(SRD,REG,0,100)
         REGISTER(REG)=1
         GRINF(REG)=0
         CLEAR LIST(SRD)
         %END
         %ROUTINE TORP(%SHORTINTEGERNAME HEAD,BOT,NOPS,%INTEGER MODE)
!***********************************************************************
!*       CONVERT THE SIGNED EXPRESSION INDEXED BY P INTO REVERSE       *
!*      POLISH NOTATION. THE REVERSE POLISH LIST IS ADDED TO 'HEAD'    *
!*      WHICH MAY CONTAIN ANOTHER EXPRESSION. THE NUMBER OF OPERATORS  *
!*      IS ADDED TO NOPS. MODE SIGNIFIES :-                            *
!*      MODE=1   INTEGER EXPRESSION                                    *
!*      MODE=2   SHORTREAL EXPRESSION                                  *
!*      MODE=3   LONGREAL EXPRESSION                                   *
!*      MODE=0   INTEGER IF POSIIBLE OTHERWISE REAL                    *
!*      N.B. AN INTEGER EXPRESSION IS A SPECIAL CASE OF A REAL EXPRSN  *
!***********************************************************************
         %SHORTROUTINE
         %SWITCH OPERAND(1:4)
         %SHORTINTEGER ORHEAD,RPHEAD,PASSHEAD,SAVEHEAD,OPBOT, %C
            RPBOT,PASSBOT,SAVEBOT
         %BYTEINTEGER REAL,LONGREAL,REALOP,COMPLEX
         %INTEGER OPERATOR,LASTOP,OPPREC,OPND,C,D,E,RPTYPE,RPINF,RPXTRA
         %BYTEINTEGER ADDREXP
         %INTEGER BDISP,OPSTK,OPPSTK,RPNAM
         %SHORTINTEGERNAME DUPHEAD,NEXTHEAD
         *XC_ORHEAD(76),ORHEAD
         LONGREAL=ALL LONG ;           ! IN CASE INTEGER SUBXPRS
         ADDREXP=MODE>>2&1
         C=A(P)
         %IF 2<=C<=3 %THEN %START;     ! INITIAL '-' OR '\'
            NOPS=NOPS+1
            OPSTK=13-C;               ! '-' =(11,3)   '\' =(10,5)
            OPPSTK=C<<1-1
         %FINISH
1:       OPND=A(P+1); P=P+2
         COMPLEX=0
         -> OPERAND(OPND);             ! SWITCH ON OPERAND
OPERAND(1):                            ! NAME
         RPNAM=TAGS(A(P))
         %IF RPNAM=0 %THEN PTYPE=7 %ELSE %C
            PTYPE=INTEGER(ADDR(ASLIST(RPNAM)))>>16
         *L_1,PTYPE; *CVD_1,0(11);      ! UNPACK
         *UNPK_ROUT(5),5(3,11)
         *NC_ROUT(5),MASK1
         %IF TYPE=8 %THEN COMPLEX=FROM3(RPNAM)>>16
         %IF PTYPE=SNPT %THEN %START
            K=FROM3(RPNAM)>>16
             %IF K=38 %AND A(P+1)=2 %THEN %START;    ! PICK OFF NL
                RPTYPE=0; RPINF=10; PTYPE=1; P=P+1; ->SKNAM
             %FINISH
            %IF K=52 %AND A(P+1)=2 %START;! PICK OFF PI
               RPTYPE=1; PTYPE=2; RPINF=-7
               P=P+1; REAL=1; ->SKNAM
            %FINISH
            COMPLEX=1;                  ! FOR INTEGER(ADDR(A(I)))
             PTYPE=TSNAME(K);! UNPACK
            *L_1,PTYPE; *CVD_1,0(11)
            *UNPK_ROUT(5),5(3,11)
            *NC_ROUT(5),MASK1
         %FINISH
         %IF ROUT=1 %THEN COMPLEX=1
         %IF ARR>=1 %AND CHECKS=1 %THEN COMPLEX=1
         %IF TYPE=3 %THEN %START
            KFORM=FROM3(RPNAM)&X'FFFF'
            D=P; C=COPY RECORD TAG(E); P=D;
            %IF (ARR>=1 %OR E>1) %AND CHECKS=1 %THEN COMPLEX=1
         %FINISH
         %IF TYPE=5 %THEN FAULT(42,0)
         %IF TYPE=2 %THEN %START
            REAL=1; LONGREAL=1 %IF PREC=3
         %FINISH
         RPTYPE=2; RPINF=P; PTYPE=1 %IF PTYPE=7
         RPTYPE=0 %AND PTYPE=1 %IF TYPE=5;   ! CHANGE TO SHORT CONST
         P=P+1
SKNAM:   FFLAG=0
         %UNTIL C=2 %CYCLE
            %IF A(P)=2 %THEN P=P+1 %ELSE SKIP APP
            C=A(P); P=P+2
         %REPEAT
         %IF FFLAG#0 %THEN COMPLEX=1
INS:     BINSERT(RPHEAD,RPBOT,PTYPE<<16!COMPLEX<<8!RPTYPE,RPINF,0)
         -> 50 %UNLESS OPND=2
         %IF A(P-1)=2 %THEN P=P+1 %AND -> 50
         WARN(LINE)
         P=P-2; OPERATOR=6; -> 49
OPERAND(2):                            ! CONSTANT
         C=A(P)&7; RPINF=P
         %IF C=2 %THEN %START;         ! REAL CONSTANT
            PTYPE=2; P=P+6
            REAL=1; RPTYPE=1
         %FINISH %ELSE %START
            %IF C=5 %THEN %START;      ! STRING CONSTANT
               FAULT(42,0); D=1
               P=P+(A(P+1)-1)>>1
            %FINISH %ELSE %START
               **1,P; *AR_1,1
               *LA_1,A+32(1); *MVC_D(4),0(1)
            %FINISH
            %IF D>>12=0 %THEN RPTYPE=0 %AND RPINF=D %ELSE RPTYPE=1
            P=P+4; PTYPE=1
         %FINISH; -> INS
OPERAND(4):                            ! MODULUS SIGNS
         WARN(LINE)
OPERAND(3):                            ! SUB EXPRESSION
         D=0; PASSHEAD=0; PASSBOT=0
         D=1 %IF MODE&3=1 %OR LASTOP=12
         P=P+2
         TORP(PASSHEAD,PASSBOT,NOPS,D)
         REAL=1 %IF TYPE=2
         LONGREAL=1 %IF PREC=3
         BINSERT(RPHEAD,RPBOT,PTYPE<<16!3,PASSHEAD,PASSBOT)
         %IF OPND=4 %THEN BINSERT(RPHEAD,RPBOT,13,0,0) %AND NOPS=NOPS+1
         P=P+1
50:      %COMMENT DEAL WITH OPERATOR
         -> 60 %IF A(P-1)=2;           ! EXPR FINISHED
         OPERATOR=A(P)
!
! THE STRING OPERATOR '.' CAUSES CHAOS IN AN ARITHMETIC EXPRSN
! SO FAULT IT AND CHANGE IT TO THE INNOCUOUS '+'
!
         %IF OPERATOR=12 %THEN FAULT(42,0) %AND OPERATOR=2
         REALOP=1 %IF OPERATOR=1 %OR OPERATOR=8
         OPERATOR=12 %IF OPERATOR=1
49:      LASTOP=OPERATOR
         OPPREC=PRECEDENCE(OPERATOR)
         OPERATOR=OPERATOR+13
         NOPS=NOPS+1
!
! UNLOAD THE OPERATOR STACK OF ALL OPERATORS WHOSE PRECEDENCE IS
! NOT LOWER THAN THE CURRENT OPERATOR. AN EMPTY STACK GIVES'-1'
! AS PRECEDENCE.
!
         %WHILE OPPREC<=OPPSTK&31 %CYCLE
            BINSERT(RPHEAD,RPBOT,OPSTK&31,0,0)
            OPSTK=OPSTK>>5; OPPSTK=OPPSTK>>5
         %REPEAT
!
! THE CURRENT OPERATOR CAN NOW BE STORED
!
         OPSTK=OPSTK<<5!OPERATOR
         OPPSTK=OPPSTK<<5!OPPREC
         -> 1
60:                                    ! END OF EXPRESSION
         %WHILE OPSTK#0 %CYCLE
            BINSERT(RPHEAD,RPBOT,OPSTK&31,0,0)
            OPSTK=OPSTK>>5
         %REPEAT
         REAL=1 %IF MODE&3#1 %AND REALOP=1
         LONGREAL=1 %IF MODE=3
         FAULT(24,0) %IF REAL=1 %AND MODE&3=1
!
! NOW THE TYPE OF THE EXPRESSION IS KNOWN WE CAN ADD FLOAT &STRETCH
! OPERATORS AS NECESSARY. ALSO TAKE THE OPPORTUNITY TO REMOVE
! CONSTANTS FROM ADDRESS EXPRESSIONS.
!
         DUPHEAD==RPHEAD
         %WHILE DUPHEAD#0 %CYCLE
            C=INTEGER(ADDR(ASLIST(DUPHEAD)))
            NEXTHEAD==SHORTINTEGER(ADDR(ASLIST(DUPHEAD))+14)
            RPTYPE=C&255
            %IF ADDREXP=1 %AND RPTYPE=0 %AND FROM2(DUPHEAD)+BDISP<256%C
                %AND (NOPS=0 %OR FROM1(NEXTHEAD)&255=15) %START;! CHECK FOR +CONST
               POP(DUPHEAD,D,RPINF)
               BDISP=BDISP+RPINF
               %IF NOPS#0 %THEN POP(DUPHEAD,D,D) %AND NOPS=NOPS-1
               NEXTHEAD==DUPHEAD
               %IF DUPHEAD=0 %START
                  RPBOT=RPHEAD
                  %WHILE SHORTINTEGER(ADDR(ASLIST(RPBOT))+14)#0 %THENC
                     RPBOT=SHORTINTEGER(ADDR(ASLIST(RPBOT))+14)
               %FINISH
            %FINISH %ELSE %START
              %IF RPTYPE=1 %AND C>>16=2 %AND LONGREAL=1 %THEN %C
               C=32<<16!1 %AND REPLACE1(DUPHEAD,C)
               %IF RPTYPE=3 %THEN %START
                  POP123(DUPHEAD,C,RPINF,RPXTRA);! CHUCK AWAY HEADCELL
                  D=DUPHEAD;            ! REPLACE BY SUBEXPRESSION
                  DUPHEAD=RPINF
                  NEXTHEAD==SHORTINTEGER(ADDR(ASLIST(RPXTRA))+14)
                  NEXTHEAD=D
                  %IF D=0 %THEN RPBOT=RPXTRA
               %FINISH
               %IF RPTYPE<10 %AND REAL#0 %THEN %START
                  D=0; PTYPE=C>>16;! UNPACK
                  *L_1,PTYPE; *CVD_1,0(11)
                  *UNPK_ROUT(5),5(3,11)
                  *NC_ROUT(5),MASK1
                  %IF (TYPE=1 %OR TYPE=8) %AND FROM1(NEXTHEAD)&255#25%C
                      %THEN D=12
                  %IF TYPE=2 %AND PREC=0 %AND LONGREAL=1 %THEN D=14
                  %IF D#0 %THEN %START;      ! FLOAT OR STRETCH REQD
                     NOPS=NOPS+1
                     PUSH(NEXTHEAD,D,LONGREAL)
                     NEXTHEAD==SHORTINTEGER(ADDR(ASLIST(NEXTHEAD))+14)
                  %FINISH
               %FINISH
            %FINISH
            DUPHEAD==NEXTHEAD
         %REPEAT
         %IF MODE&3>=2 %AND REAL=0 %THEN %START
            REAL=1; NOPS=NOPS+1
            BINSERT(RPHEAD,RPBOT,12,LONGREAL,0);! FLT RESULT(IF REQD)
         %FINISH
         PTYPE=1+REAL+30*LONGREAL
         %IF HEAD=0 %THEN BOT=RPBOT %ELSE %C
            SHORTINTEGER(ADDR(ASLIST(RPBOT))+14)=HEAD
         HEAD=RPHEAD;               ! HEAD BACK TO TOP OF LIST
        ! UNPACK
            *L_1,PTYPE; *CVD_1,0(11)
            *UNPK_ROUT(5),5(3,11)
            *NC_ROUT(5),MASK1
         ADISP=BDISP
         %END
         %ROUTINE EXPOP(%INTEGER INHEAD,REG,NOPS,MODE)
         %INTEGERARRAY OPERAND(1:2),STK(0:24)
         %BYTEINTEGER ADDREXP,RDFORM
         %RECORDNAME OPND1,OPND2 (RD)
         %INTEGER C,D,E,KK,JJ,OPCODE,COMM,XTRA,STPTR
         %INTEGER NEWCC,PP,PT,JJJ
         %INTEGER SPECREG; SPECREG=REG
         %ROUTINESPEC FLOAT
         %ROUTINESPEC CTOP(%INTEGERNAME A)
         %ROUTINESPEC CHOOSE(%INTEGERNAME I)
         %INTEGERFNSPEC FINDR
         %ROUTINESPEC CLAIM PAIR(%INTEGERNAME REG)
         %ROUTINESPEC PUT
         %ROUTINESPEC STARSTAR
         %ROUTINESPEC UNRESERVE(%INTEGER XB)
         %ROUTINESPEC LOAD PAIR(%INTEGER I)
         %ROUTINESPEC LOAD(%RECORDNAME OP,%INTEGER REG,MODE)
         %CONSTSHORTINTEGERARRAY MCINST(10:31)=X'297',X'193',
               X'80',X'190',X'81',X'11A',X'19B',X'217',
               X'216',X'1C',X'9D',X'9D',X'214',X'88',X'89',
               X'84',X'19',X'19',X'9C',X'89',X'90',X'90'
         %SHORTINTEGER TEMPHEAD
         %SWITCH SW(10:31)
         %IF INHEAD=0 %THEN %START
            NEST=0; %RETURN
         %FINISH
         RDFORM= MODE&16
         NEWCC=0; STPTR=0
         ADDREXP=MODE>>2&1
1:       C=INTEGER(ADDR(ASLIST(INHEAD)))
         JJ=C&255; D=INHEAD
         INHEAD=SHORTINTEGER(ADDR(ASLIST(D))+14)
         %IF JJ>=10 %THEN XTRA=INTEGER(ADDR(ASLIST(D))+4) %AND %C
            ->OPERATOR
         STK(STPTR)=D
         STPTR=STPTR+1
2:
         ->1 %UNLESS INHEAD=0 %OR MODE=100
         -> FINISH
OPERATOR:
         %IF JJ<15 %THEN KK=1 %ELSE KK=2; ! UNARY OR BINARY
         %CYCLE KK=KK,-1,1
            STPTR=STPTR-1
            C=STK(STPTR)
            OPERAND(KK)=C
         %REPEAT
!         PTYPE=FROM1(C)>>16
        ! UNPACK;                       ! SET PREC ETC.
            *L_1,C; *A_1,ASLIST
            *LH_1,0(1)
            *ST_1,PTYPE; *CVD_1,0(11)
            *UNPK_ROUT(5),5(3,11)
            *NC_ROUT(5),MASK1
         OPCODE=MCINST(JJ)
         COMM=OPCODE>>7&1;              ! BIT SET IF OPERATOR UNCOMMUTVE
         NEWCC=OPCODE>>8;               ! 0=CC UNKNOWN- 1= CC SRITHMETIC
                                        ! 2= CC LOGICAL AFTER OPERATION
         OPCODE=OPCODE&63;             ! OPCODE FOR INTEGER RR INST
         %IF COMM=0 %THEN CHOOSE(COMM)
         OPND1 == RECORD(ADDR(ASLIST(OPERAND(COMM))))
         OPND2== OPND1
         %IF JJ>=15 %THEN OPND2==RECORD(ADDR(ASLIST(OPERAND(3-COMM))))
         %IF OPND1_FLAG<2> OPND2_FLAG %THEN CTOP(JJ)
         -> 101 %IF JJ=0;              ! CTOP CARRIED OUT
         TYPE=1 %IF TYPE=8
         -> SW(JJ)
SW(10):                                !  \
         LOAD(OPND1,-1,2)
         FAULT(24,0) %UNLESS TYPE=1
         PRX(X'57',OPND1_XB,0,GLA,16)
100:     SET USE((TYPE&2)<<3+OPND1_XB,1,ADDR(ASLIST(OPERAND(COMM))))
101:     STK(STPTR)=OPERAND(COMM)
         STPTR=STPTR+1
         %IF NEWCC#0 %THEN CCSTATE=NEWCC<<16!(TYPE&2)<<3!OPND1_XB
         ->2;                            ! SAVE CONDITION CODE STATE
SW(11): SW(13):                        ! NEGATE: ABS
         LOAD(OPND1,-1,2)
         TEMPHEAD=0
         %IF NOPS=1 %AND REG>=0 %THEN %START
            PUSH(TEMPHEAD,INTEGER(ADDR(OPND1)),OPND1_D)
            OPND2== RECORD(ADDR(ASLIST(TEMPHEAD)))
            OPND1_XB=REG
         %FINISH
         PUT
         CLEAR LIST(TEMPHEAD) %IF TEMPHEAD#0
         -> 101
SW(12):                                ! FLOAT
         LOAD(OPND1,-1,0);                 ! LEAVE IN CORE
         FLOAT
         TYPE=2; OPND1_FLAG=9
         OPND1_XB=D; OPND1_D=-2
         OPND1_PTYPE=30*XTRA+2;  -> 100
SW(14):                                ! STRETCH
         LOAD(OPND1,-1,1)
         CLAIM (FR0,D); PRR(X'2B',D,D)
         CCSTATE=-1
         FORGET(D+16)
         LOAD(OPND1,D,2)
         OPND1_PTYPE=32; -> 100
SW(15):                                ! ADD
151:     LOAD(OPND1,-1,0) %UNLESS OPND1_FLAG<=2 %C
                  %AND OPND1_XB=0 %AND OPND1_PTYPE<100
         LOAD(OPND2,-1,1)
         LOAD(OPND1,-1,2)%UNLESS OPND1_FLAG=9 %AND OPND1_D<0;! IN CASE RT CALL
         PUT; -> 101
SW(16):                                ! SUBTRACT
         ->151%UNLESS(TYPE=1 %OR TYPE=8)%AND OPND2_FLAG=0 %AND OPND2_D=1
         LOAD(OPND1,-1,2)
         PRR(6,OPND1_XB,0);            ! BCTR
         NEWCC=0; -> 100;               ! BCTR DOES NOT SET CC
SW(17):                                ! EXCLUSIVE OR
SW(18):                                ! OR
SW(22):                                ! AND
         ->151 %IF TYPE=1
F24:         FAULT(24,0)
         JJ=15; OPCODE=X'1A'; ->151; ! CHANGE OPN TO +
SW(23):                                ! SRL
SW(24):                                ! SLL
         ->F24 %UNLESS TYPE=1
          D=0; D=1 %IF OPND2_FLAG=0
         LOAD(OPND1,-1,D<<1);              ! MUST LOAD %IF CONST
         %IF D=0 %THEN %START
! DIFFICULT AS MAY SHIFT BY A FN AND CANNOT SHIFT BY GR0
         LOAD(OPND2,-2,0)          ;! INSPECT SHIFTER
         LOAD(OPND1,-1,2);     ! LOAD UP SHIFTED TO ANY REGISTER
         LOAD(OPND2,-2,1)
         %UNLESS OPND2_FLAG=9 %AND OPND2_D<0 %AND OPND2_XB>0 %THENSTART
         FIND REG(GR1,C);       ! REG TO SHIFT BY (NOT GR0 !)
         LOAD(OPND2,C,2); %FINISH;  ! LOAD SHIFTER ( OR MOVE OUT OF GR0)
         %FINISH;               ! CA NOW PLANT THE OPERATION
         PRX(X'80'+OPCODE,OPND1_XB,0,OPND2_XB,D*OPND2_D)
         REGISTER(OPND2_XB)=0 %IF D=0 %AND REGISTER(OPND2_XB)>=0
         -> 100
SW(19):                                ! MULT
         -> 151 %IF TYPE=2
         LOAD PAIR(1);                 ! 1ST OPERAND TO ODD MEMBER
                                       ! 2ND OPERAND TESTED ALSO
         PUT
         D=OPND1_XB+CHECKSP
         REGISTER(D)=0; FORGET(D)
         %IF CHECKSP#0 %THEN %START
         PRX(X'8F',OPND1_XB,0,0,32)
         %FINISH %ELSE OPND1_XB=OPND1_XB+1
         -> 100
SW(20):                                ! INTEGER DIVISION
         ->F24 %UNLESS TYPE=1
         -> 211
SW(21):                                ! NORMAL DIVISION
         -> 151 %IF TYPE=2
         WARN(LINE)
211:     LOAD PAIR(0);                 ! 1ST OPERAND TO EVEN REG
         PRX(X'8E',OPND1_XB,0,0,32);   ! SRDA
         CCSTATE=-1
         PUT; D=OPND1_XB
         %IF CHECKSP=1 %AND JJ=21 %THEN %START
         PRR(X'12',D,D)
         PCONST(X'4770C040'); %FINISH
         REGISTER(D)=0; FORGET(D)
         OPND1_XB=D+1; -> 100
SW(25):                                ! EXP
         STARSTAR; -> 100
SW(26):                                ! COMPARISONS
SW(27):                                ! LOGICAL COMPARISONS (IE=&7=)
         PTYPE=OPND1_PTYPE;! UNPACK
            *L_1,PTYPE; *CVD_1,0(11)
            *UNPK_ROUT(5),5(3,11)
            *NC_ROUT(5),MASK1
         -> BC %IF PREC=1 %AND OPND2_FLAG=0
         LOAD(OPND1,-1,0) %UNLESS OPND1_FLAG<=2 %AND ARR=0=OPND1_XB
CNORM:
         ->Z1 %IF OPND1_FLAG=0=OPND1_D %ORC
         (OPND1_FLAG=9 %AND OPND1_XB=CODER %AND OPND1_D=X'C0')
         -> Z2 %IF OPND2_FLAG=0=OPND2_D %ORC
         (OPND2_FLAG=9 %AND OPND2_XB=CODER %AND OPND2_D=X'C0')
         -> RX %UNLESS JJ=27 %OR PREC=1
         LOAD(OPND2,-1,3) %IF OPND2_FLAG<7;! IN CASE BOTH OPERANDS ARE FNS
         LOAD(OPND1,-1,3) %IF OPND1_FLAG<7
         -> RX %UNLESS OPND1_PTYPE=OPND2_PTYPE %AND 0<=OPND1_D<=4095 %C
         %AND 0<=OPND2_D<=4095 %AND OPND1_XB<16>OPND2_XB
         CCSTATE=-1
         PSS(X'D5',BYTES(PREC),OPND1_XB,OPND1_D,OPND2_XB,OPND2_D)
         UNRESERVE(OPND2_XB)
Z5:      UNRESERVE(OPND1_XB); ->Z4
RX:      LOAD(OPND2,-1,1)
         LOAD(OPND1,-1,2)
         CCSTATE=-1
         PUT
Z4:
         BFFLAG=COMM-1;                ! NOTE BACKWARDS OR FORWARDS
         COMM=2; -> 101;               ! 2ND OPERAND MAY BE NEEDED IN
                                       ! DOUBLE SIDED AND IS THEREFORE
                                       ! TAKEN AS THE 'RESULT'
Z1:      COMM=3-COMM;                  ! SWITCH AROUND OPERANDS
         OPND1==OPND2
         OPND2==RECORD(ADDR(ASLIST(OPERAND(3-COMM))))
Z2:
         LOAD(OPND1,-1,2)
         D=FROM1(OPERAND(COMM))>>8&15
         C=(TYPE&2)<<3+D
         REGISTER(C)=0 %IF REGISTER(C)>0
         -> Z4 %IF 1<<16!C=CCSTATE;      ! CONDITION CODE ALREADY SET
         ->Z4 %IF JJ=27 %AND 2<<16!C=CCSTATE;! CC WILL DO
         PRR((TYPE-1)*(2-PREC>>1)*16+X'12',D,D)
         CCSTATE=1<<16!C; ->Z4
BC:                                    ! BYTE/CONSTANT COMPARISONS
         LOAD(OPND1,-1,3)
         -> CNORM %UNLESS OPND1_PTYPE=11 %AND %C
         0<=OPND1_D<=4095 %AND OPND2_D<=255
         NEST=OPND1_XB; D=NEST>>4; NEST=NEST&15
         %IF D>0 %THEN %START
         %IF 1#REGISTER(D)>=0 %AND GRUSE(D)<=1 %THENC
         NEST=D %ELSE NEST=-2; UNRESERVE(OPND1_XB)
         DUMP(0,NEST,0,D,OPND1_XB&15); OPND1_XB=NEST;
         FORGET(NEST); %FINISH
         PSI(X'95',OPND2_D,NEST,OPND1_D)
         CCSTATE=-1; -> Z5
SW(28):                                ! SPECIAL MH FOR ARRAY ACCESS
         %IF OPND1_FLAG=2 %AND OPND2_FLAG=0 %AND OPND2_D<=255%THENSTART
            E=OPND1_D; D=TAGS(A(E))
            FIND USE(C,1,9,OPND2_D<<24!D)
            %IF C>0 %AND A(E+1)=2=A(E+2) %START
               OPND1_FLAG=9; OPND1_XB=C; OPND1_D=-2; ->101
            %FINISH
         %FINISH
         LOAD(OPND1,-1,2);                 ! LOAD TO ANY REGISTER
         ->2801 %IF OPND2_FLAG=0;      ! CONSTANT SO OPTIMISE
         LOAD(OPND2,-1,3);                 ! LOAD DV POINTER
         LOAD(OPND1,-1,2);                  ! LOAD OF DVBASE MAY DUMP OPND!
         PUT; -> 100
2801:    D=OPND2_D; C=OPND1_XB
         %IF D=2 %THEN PRR(X'1A',C,C)  %AND CCSTATE=-1 %ELSE %START
         %IF D=4 %OR D=8 %THEN PRX(X'89',C,0,0,2!D>>3) %ELSESTART
         STORE CONST(KK,JJ,2,ADDR(D)+2)
         DUMP(X'4C',C,JJ,0,KK)
         %FINISH; %FINISH
         REGISTER(C)=0
         %IF GRUSE(C)#3 %OR D>255 %THEN ->100
         SET USE(C,9,D<<24!GRINF(C)); ->101

SW(29):                                   ! ->LAB MASKS AND LAB AS OPND2
                                          ! OPND1 MIDDLE OF D-SIDED
         LOAD(OPND1,-1,0) %IF INHEAD#0;       ! PROTECT MIDDLE OPND IN DSIDED
         C=OPND2_XB>>(4*BFFLAG)
         ENTER JUMP(C&15,OPND2_D,B'11')
         ->101;                           ! RETURN MIDDLE OPND AS RESULT
SW(30):                                   ! ASSIGN(=)
SW(31):                                   ! ASSIGN(<-)
         PP=OPND2_D;                      ! SAVE POINTER TO NAME
         PT=OPND2_PTYPE;                  ! AND ITS ORIGINAL PTYPE
         D=OPND2_FLAG;                    ! SAVE NAME OR R-DESCRPTOR
         LOAD(OPND1,-1,0) %UNLESS OPND1_FLAG<=2 %AND OPND1_XB=0 %C
               %AND OPND1_PTYPE<100;   ! DEAL WITH NASTY RH SIDES
         LOAD(OPND2,-1,4);                    ! GET ADDRESS FOR LHS
         ->MVI %IF TYPE=1 %AND PREC=1 %AND OPND1_FLAG=0 %AND %C
            OPND1_D<=255 %AND OPND2_XB<16 %AND OPND2_D<=4095
         %IF OPND1_FLAG#0 %AND OPND2_XB<16 %AND 0<=OPND2_D<=4095 %C
            %AND OPND2_PTYPE=OPND1_PTYPE-100*(OPND1_PTYPE//100) %START
            LOAD(OPND1,-1,3) %IF OPND1_FLAG<7;! STILL TRYING TO LEAVE RHS
         ->MVC %IF OPND2_PTYPE=OPND1_PTYPE %AND  %C
          0<=OPND1_D<=4095 %AND 16>OPND1_XB
         %FINISH
! ALL ATTEMPTS AT SHORT CUTTING HAVE FAILED SO ASSIGN NORMALLY
! IF LHS ALREADY IN A REGISTER IT IS BEST TO USE THAT REGISTER
! FOR ASSIGNMENT(UNLESS RHS ALREADY IN A DIFFERENT REGISTER).
! THIS SAVES A REGISTER WHEN COMPILING 'K=0 %IF K<0' ETC.
! IT IS RATHER A TEDIOUS SEARCH SO IT IS OMITTED IN NON OPTIMISING MODE
         JJJ=-1
         %IF CHECKSP=0 %AND OPND1_D>=0 %AND PT<3 %AND D=2 %THENSTART
            C=TAGS(A(PP));                   ! TAGS OF LHS
            FIND USE(KK,PT,3,C)
            %IF KK>=0 %AND REGISTER(KK)=0 %THEN JJJ=KK&15
         %FINISH
         LOAD(OPND1,JJJ,2);                   ! RHS TO REGISTER
         PTYPE=OPND2_PTYPE;! UNPACK;       ! SET TYPE & PREC FOR LHS
            *L_1,PTYPE; *CVD_1,0(11)
            *UNPK_ROUT(5),5(3,11)
            *NC_ROUT(5),MASK1
         JJJ=8*TYPE+2*(PREC&3)-7;         ! CODE FOR DUMP
         DUMP(JJJ,OPND1_XB,OPND2_D,OPND2_XB>>4,OPND2_XB&15)
         %IF JJ=30 %AND CHECKS=1 %THEN %C
         CHECK CAPACITY(OPND1_XB,OPND2_D,OPND2_XB>>4,OPND2_XB&15)
         JJJ=OPND1_XB
NASS1:   UNRESERVE(OPND2_XB)
         PTYPE=PT;! UNPACK;                ! ORIGINAL PTYPE
            *L_1,PTYPE; *CVD_1,0(11)
            *UNPK_ROUT(5),5(3,11)
            *NC_ROUT(5),MASK1
         COMM=1; ->101 %UNLESS D=2;       ! ASSGN TO NAME ONLY
         %IF 1<=TYPE<=2 %AND ARR=0 %AND A(PP+1)=2=A(PP+2) %THEN %C
         NOTE ASSMENT(JJJ,JJ-28,A(PP))
         ->101;                           ! NORMAL EXIT FREES REG USED

MVI:                                      ! ASSIGN CNST(<256) TO BYTE
         PSI(X'92',OPND1_D,OPND2_XB,OPND2_D)
NASS2:   JJJ=-1; ->NASS1;                 ! ->NOTE ASSMENT(CAPACITY OK)
MVC:     PMVC(BYTES(PREC),OPND2_XB,OPND2_D,OPND1_XB,OPND1_D)
         UNRESERVE(OPND1_XB)
         ->NASS2
FINISH:  C=STK(STPTR-1)
         OPERAND(1)=C
         OPND1==RECORD(ADDR(ASLIST(C)))
         LOAD(OPND1,REG,2) %UNLESS RDFORM#0 %OR (OPND1_FLAG=9 %AND %C
            OPND1_D<0 %AND (REG<0 %OR REG=OPND1_XB))
         PTYPE=OPND1_PTYPE
         NEST=-1
        ! UNPACK
            *L_1,PTYPE; *CVD_1,0(11)
            *UNPK_ROUT(5),5(3,11)
            *NC_ROUT(5),MASK1
         %IF OPND1_FLAG=9 %AND OPND1_D<0 %THEN %START
            NEST=OPND1_XB
            %IF TYPE=2 %THEN NEST=NEST+16
            %IF GRUSE(NEST)=1 %THEN GRINF(NEST)=0;! DONT POINT AT DEAD LIST
            NEST=OPND1_XB
            %IF NEST=0 %AND ADDREXP=1 %THEN %START
               LOAD(OPND1,FINDR,2)
               FORGET(0)
               NEST=OPND1_XB
            %FINISH
            D=NEST+(TYPE&2)<<3
            REGISTER(D)=0 %IF REGISTER(D)>0
         %FINISH
         %RETURN
!
         %INTEGERFN FINDR
         %INTEGER I,J
         %SHORTROUTINE
         %IF REG>=0 %THEN %START
         I=REG; -> 1 %IF REGISTER(REG)=0; %FINISH
         %IF ADDREXP=1 %THEN J=GR1 %ELSE J=GR0
         FIND REG(J,I)
1:       REGISTER(I)=1;
         %RESULT=I
         %END
         %ROUTINE CHOOSE(%INTEGERNAME CHOICE)
         %SHORTROUTINE
        %BYTEINTEGER X1,X2,F1,F2
         %RECORDNAME OPND1,OPND2(RD)
         OPND1==RECORD(ADDR(ASLIST(OPERAND(1))))
         OPND2==RECORD(ADDR(ASLIST(OPERAND(2))))
         F1=OPND1_FLAG; F2=OPND2_FLAG
         X1=OPND1_XB; X2=OPND2_XB
         -> CHOS1 %IF F1=2 %AND (X1=1 %OR 1<X1=SPECREG)
         -> CHOS2 %IF F2=2 %AND (X2=1 %OR 1<X2=SPECREG)
         -> CHOS0 %IF F1>=7 %AND OPND1_D<0
         -> CHOS2 %IF F2>=7 %AND OPND2_D<0
         PTYPE=OPND1_PTYPE;! UNPACK
            *L_1,PTYPE; *CVD_1,0(11)
            *UNPK_ROUT(5),5(3,11)
            *NC_ROUT(5),MASK1
         -> CHOS1 %IF PREC=1
         PTYPE=OPND2_PTYPE;! UNPACK
            *L_1,PTYPE; *CVD_1,0(11)
            *UNPK_ROUT(5),5(3,11)
            *NC_ROUT(5),MASK1
         -> CHOS2 %IF PREC=1
         -> CHOS1 %IF F1=0 %AND OPND1_D>3 %AND OPCODE#X'19'
         -> CHOS2 %IF F2=0 %AND OPND2_D>3 %AND OPCODE#X'19'
         -> CHOS2 %IF OPND2_PTYPE>OPND1_PTYPE
         -> CHOS2 %IF F2>F1
CHOS1:   CHOICE=1; -> 99
CHOS0:   ->CHOS1 %UNLESS F2>7 %AND OPND2_D<0 %AND X2=REG
CHOS2:   CHOICE=2
99:      %END
         %ROUTINE LOAD(%RECORDNAME OPND,%INTEGER REG,MODE)
!***********************************************************************
!*        MODE=0   LEAVE IN STORE IF POSSIBLE                          *
!*        MODE=1 LEAVE IN STORE IF SUITABLE FOR RX INSTRUCTIONS        *
!*        MODE=2 LOAD TO REGISTER REGARDLESS                           *
!*        MODE=3 LEAVE IN STORE IF SUITABLE FOR CLC  INSTRUCTIONS      *
!***********************************************************************
         %SHORTROUTINE
         %INTEGER I,J,K,VALUE,B
         %RECORDSPEC OPND(RD)
         %SWITCH SW(0:9)
         PTYPE=OPND_PTYPE;! UNPACK
            *L_1,PTYPE; *CVD_1,0(11)
            *UNPK_ROUT(5),5(3,11)
            *NC_ROUT(5),MASK1
         PREC=PREC&3
         %IF REG<0 %THEN REG=REG-ADDREXP
         -> SW(OPND_FLAG)
SW(0):                                 ! CONSTANT < 4096
         -> 99 %UNLESS MODE>0
         VALUE=OPND_D
         %IF CSSMODE=0 %THEN OPTSAVE(0,2,1,VALUE)
         FIND USE(I,1,2,VALUE)
         -> NOT FOUND %IF I<0
         %IF REG<0 %THEN %START
         ->RF %IF REGISTER(I)=0
         ->RF2 %IF REGISTER(I)<0 %AND(26<=JJ<=27 %OR 30<=JJ<=31)
         ->RF2 %IF MODE=1
         %FINISH
         REG=FINDR %IF REG<0
         PRR(X'18',REG,I) %UNLESS REG=I
         REGISTER(REG)=1 %IF REGISTER(REG)=0
SG:      SET USE(REG,2,VALUE) %UNLESS REGISTER(REG)<0
1:       OPND_PTYPE=1
2:       OPND_FLAG=9
         OPND_XB=REG
         OPND_D=-2
         -> 99
RF:      REGISTER(I)=1
RF2:     REG=I; -> 1
NOT FOUND: -> GLA COPY %IF MODE&1#0 %AND VALUE#0 %AND CSSMODE#0
         REG=FINDR %IF REG<0
         DUMP(0,REG,VALUE,0,0); -> SG
GLA COPY:TYPE=1; K=4; PREC=0
         -> FULL L %UNLESS X'19'<=OPCODE<=X'1B'
         J=CONST FIND(4,ADDR(VALUE))
         %UNLESS J=-1 %START
            %IF J<0 %THEN BASE=CODER %ELSE BASE=GLA
            DISP=J&X'7FFF'; INDEX=0; ->RESET RD
         %FINISH
         PREC=2; K=2
FULL L:  STORE CONST(BASE,DISP,K,ADDR(VALUE)+4-K)
         INDEX=0; ->RESET RD
SW(1):                                 ! LONG CONSTANT
         STORE CONST(BASE,DISP,BYTES(PREC),ADDR(A(OPND_D+1)))
         -> PICK UP %IF MODE=2
         INDEX=0; ->RESET RD
PICKUP:  DUMP(8*(TYPE-1)+2*(PREC&3)+2,REG,DISP,0,BASE)
         MODE=0; -> 21;        ! ENSURE THAT USE IS CHANGED
SW(2):                                 ! NAME
         -> LOAD %IF MODE=2
         ->STORE %IF MODE=4
         -> LOAD %IF OPND_XB&127#0 %AND PTYPE#8
         -> LOAD %IF MODE=0 %AND ARR>0
         -> DONT LOAD %IF MODE=3
         ->99 %IF MODE=0
         %IF MODE=1 %THEN %START
         -> LOAD %IF PREC=1
         -> DONT LOAD %IF PREC=2 %AND X'19'<=OPCODE<=X'1B'
         -> LOAD %IF PREC=2
         %FINISH
DONT LOAD: P=OPND_D
         CNAME(5,REG)
         ->21 %IF NEST>=0
RESETRD: REGISTER(BASE)=2 %IF BASE>0 %AND REGISTER(BASE)=0
         REGISTER(INDEX)=2 %IF INDEX>0 %AND REGISTER(INDEX)=0
         OPND_PTYPE=10*(PREC&3)+TYPE
         OPND_FLAG=9
         OPND_XB=INDEX<<4!BASE
         OPND_D=DISP; -> 99
STORE:   P=OPND_D
         CNAME(1,0); ->RESET RD
LOAD:    P=OPND_D
         -> REGVAR %IF PTYPE=8
         CNAME(2,REG)
21:      REG=NEST %IF REG<0
         TYPE=1 %IF TYPE=8
         PTYPE=TYPE; K=(PTYPE&2)<<3+REG
         REGISTER(K)=1 %IF REGISTER(K)>=0;   ! CLAIM THE REGISTER
         PTYPE=32 %IF PREC=3
         ->24 %IF MODE>=1 %AND GRUSE(K)>1;    ! DONT CHANGE GRUSE
         SET USE(K,1,ADDR(OPND))
24:      OPND_PTYPE=PTYPE; -> 2
REGVAR:  %IF OPCODE=X'19' %OR 30<=JJ<=31 %OR %C
            (NOPS=1 %AND OPND_XB=SPECREG %AND REG<0) %OR %C
            (NOPS=0 %AND REG<0) %THEN REG=OPND_XB %AND ->1
         REG=FINDR %IF REG<0
         %IF REGISTER(REG)>=0 %THEN %START; ! N.B. REGVAR1=REGVAR2
            FORGET(REG); GRUSE(REG)=3; GRINF(REG)=TAGS(A(P))
         %FINISH
         CNAME(2,REG); TYPE=1; ->21
SW(3):                                 ! DOPE VECTOR ITEM
! XB HAS BASE OF ARRAYHEAD  D  IS HEADDISP<<16!ITEM DISP. XTRA HAS TAGS
         -> 99 %IF MODE=0
         LOAD DV(BASE,OPND_XB,OPND_D>>16,OPND_XTRA)
         INDEX=0; DISP=OPND_D&X'FFFF'
         -> RESET RD;                  ! NOT CALLED WITH MODE=2
SW(7):SW(8):SW(9):
         -> 99 %IF  MODE=3 %OR MODE=4
         ->PROTECT %IF MODE=0
         ->99 %IF MODE=1 %AND(PREC=0 %OR PREC=3 %OR(PREC=2 %AND %C
         X'19'<=OPCODE<=X'1B'))
         B=OPND_XB
         -> RDR %IF OPND_D<0
         %IF REG<0 %AND TYPE=1 %THEN REG=FINDR;! IN CASE OF SPECREG
         DUMP(TYPE<<3!2*(PREC&3)-6,REG,OPND_D,B>>4,B&15)
         MODE=0;                       ! ENSURE USE IS CHANGED
         UNRESERVE(B); ->21
PROTECT: BASE=OPND_XB; INDEX=BASE>>4
         BASE=BASE&15; DISP=OPND_D;      ! SAFEGUARD FROM OVERWRITING
         ->RESET RD %IF OPND_D>=0
         K=(TYPE&2)<<3+BASE
         REGISTER(K)=1 %IF REGISTER(K)>=0;   ! CLAIM THE REGISTER
         %IF GRUSE(K)=1 %THEN GRINF(K)=ADDR(OPND) %ELSE %C
         SET USE(K,1,ADDR(OPND)); ->99
RDR:     -> 99 %IF REG<0 %OR REG=B
         K=B; J=X'18'
         %IF TYPE=2 %THEN %START
         K=K+16; J=X'38'-16*(PREC&1); %FINISH
         PRR(J,REG,B)
         SET USE((TYPE&2)<<3+REG,GRUSE(K),GRINF(K))
         REGISTER((TYPE&2)<<3+B)=0; OPND_XB=REG
99:      TYPE=1 %IF TYPE=8             ;%END
         %ROUTINE     UNRESERVE(%INTEGER XB)
         %SHORTROUTINE
         %INTEGER B
         B=XB&15
         REGISTER(B)=0 %IF REGISTER(B)=2
         XB=XB>>4
         REGISTER(XB)=0 %IF REGISTER(XB)=2
         %END
         %ROUTINE PUT
         %SHORTROUTINE
         %COMMENT THIS ROUTINE PLANTS CODE TO PERFORM THE BASIC
         ! OPERATION DEFINED BY OPND1,OPND2 & OPCODE
         ! OPCODE IS IN INTEGER RR FORM
         %INTEGER I,J,K,CODE,X,B,D
         PTYPE=OPND2_PTYPE;! UNPACK
            *L_1,PTYPE; *CVD_1,0(11)
            *UNPK_ROUT(5),5(3,11)
            *NC_ROUT(5),MASK1
         CODE=OPCODE
         %IF TYPE=2 %THEN %START
         CODE=CODE+32; CODE=CODE-16 %IF PREC&3=3
         %FINISH %ELSE %START
         CODE=CODE-16 %IF PREC=2; %FINISH
         ->RROP %IF OPND2_D<0
         X=OPND2_XB>>4; B=OPND2_XB&15
         D=OPND2_D; CODE=CODE+64
         DUMP(CODE,OPND1_XB,D,X,B)
         UNRESERVE(OPND2_XB)
         ->99
RROP:    PRR(CODE,OPND1_XB,OPND2_XB)
         K=(TYPE&2)<<3+OPND2_XB
         REGISTER(K)=0 %UNLESS REGISTER(K)<0 %OR OPND1_XB=OPND2_XB
99:      K=(TYPE&2)<<3+OPND1_XB
         %IF OPCODE=X'19' %THEN %START
         REGISTER(K)=0 %IF REGISTER(K)>0
         %FINISH %ELSE SET USE(K,1,ADDR(OPND1))
         %END
         %ROUTINE LOAD PAIR(%INTEGER ODDEVEN)
         %SHORTROUTINE
         ! THIS ROUTINE LOADS OPERAND 1 INTO AN EVEN0ODDPAIR
         ! THE PAIR IS CLAIMED AS LATE AS POSSIBLE
         %INTEGER PAIR,TOTHER
         CYC BITS=CYC BITS!64;         ! SET EVENODD PAIR BIT
         LOAD(OPND1,-1,0);              ! IN STORE UNLESS RT ETC
         LOAD(OPND2,-1,0)
         -> IN STORE %UNLESS OPND1_FLAG=9 %AND OPND1_D<0
         TOTHER=OPND1_XB!!1
         -> INSTORE %UNLESS REGISTER(TOTHER)=0
         REGISTER(TOTHER)=1; PAIR=TOTHER&14
         -> FIN %IF ODDEVEN+PAIR#TOTHER
         LOAD(OPND1,TOTHER,2); REGISTER(TOTHER!!1)=1; ->FIN
INSTORE: CLAIM PAIR(PAIR)
         LOAD(OPND1,PAIR+ODDEVEN,2)
FIN:     OPND1_XB=PAIR;                ! ALWAYS LH MEMBER
         REGISTER(PAIR)=2
         REGISTER(PAIR+1)=2
         LOAD(OPND2,-1,1)
         REGISTER(PAIR)=1
         REGISTER(PAIR+1)=1
         %END
         %ROUTINE CLAIM PAIR(%INTEGERNAME REG)
         %SHORTROUTINE
         %INTEGER I,J,K
         %CYCLE I=0,1,2
         %CYCLE K=6,-2,-2
         J=K&15
         -> FOUND %IF REGISTER(J)=REGISTER(J+1)=0 %AND (I>0 %OR  %C
         GRUSE(J)=0=GRUSE(J+1))
         %REPEAT
         SAVE IRS(4) %IF I=1
         %REPEAT
         ABORT
FOUND:   REGISTER(J)=1
         REGISTER(J+1)=1
         REG=J
         %END
         %ROUTINE CTOP(%INTEGERNAME FLAG)
         %SHORTROUTINE
         %COMMENT ON EXIT FLAG=0 %IF OPERATION CARRIED OUT
         %INTEGER K,VAL1,VAL2,TYPEP,PRECP,OP
         %LONGREAL RVAL1,RVAL2
         %SWITCH SW(10:41)
         NEWCC=0;                       !COMPILE TIME OPS CAN NOT SET CC
         TYPEP=TYPE; PRECP=PREC; OP=FLAG
         ->99 %IF OP>25
         %IF TYPEP=2 %THEN %START
         FROM AR8(OPND1_D+1,RVAL1)
         FROMAR8(OPND2_D+1,RVAL2)
         %FINISH %ELSE %START
         %IF OPND1_FLAG=0 %THEN VAL1=OPND1_D %ELSE %C
         FROMAR4(OPND1_D+1,VAL1)
         %IF OPND2_FLAG=0 %THEN VAL2=OPND2_D %ELSE  %C
         FROMAR4(OPND2_D+1,VAL2)
         %FINISH
         -> SW(16*(TYPEP-1)+OP)
SW(10):                                ! \
         VAL1=\VAL1
INTEND:  A(R)=1; TOAR4(R+1,VAL1)
         FLAG=0; OPND1_PTYPE=1
         OPND1_FLAG=1; OPND1_D=R;
         R=R+3; -> 99
SW(11):                                ! INTEGER NEGATE
         VAL1=-VAL1; -> INT END
SW(13):                                ! INTEGER ABS
         VAL1=!VAL1!; -> INT END
SW(12):                                ! INTEGER FLOAT
         RVAL1=VAL1; PRECP=3*XTRA
         ->REAL END %UNLESS VAL1=0
         CYC BITS=CYC BITS!16;          ! USES PERMS CONST TABLE
         OPND1_FLAG=9; OPND1_XB=CODER; ! TREAT ZERO SPECIALLY
         OPND1_D=X'C0'; ->98;          ! TO ALLOW LTDR ETC
SW(30):                                ! STRETCH REAL
REAL END:A(R)=2; TOAR8(R+1,RVAL1)
         OPND1_FLAG=1; OPND1_D=R; R=R+5
98:      FLAG=0; OPND1_PTYPE=10*PRECP+2
         ->99
SW(14):                                ! STRETCH INTEGER
SW(28):                                ! FLOAT REAL
         ABORT
SW(15):                                ! ADD
         VAL1=VAL1+VAL2; -> INT END
SW(16):                                ! MINUS
         VAL1=VAL1-VAL2; -> INT END
SW(17):                                ! EXCLUSIVE OR
         VAL1=VAL1!!VAL2; -> INT END
SW(18):                                ! OR
         VAL1=VAL1!VAL2; -> INT END
SW(19):                                ! MULT
         VAL1=VAL1*VAL2; -> INT END
SW(21):  ->99;                           ! / DIVISION
SW(20):  ->99 %IF VAL2=0;              ! // DIVISION
         VAL1=VAL1//VAL2; -> INT END
SW(22):                                ! AND
         VAL1=VAL1&VAL2; -> INT END
SW(24):                                ! SLL
         VAL1=VAL1<<VAL2; -> INT END
SW(23):                                ! SRL
         VAL1=VAL1>>VAL2; -> INT END
SW(27):                                ! NEGATE
         RVAL1=-RVAL1; -> REAL END
SW(29):                                ! ABS
         RVAL1=!RVAL1!; -> REAL END
SW(31):                                ! ADD
         RVAL1=RVAL1+RVAL2; -> REAL END
SW(32):                                ! SUBTRACT
         RVAL1=RVAL1-RVAL2; -> REAL END
SW(35):                                ! MULT
         RVAL1=RVAL1*RVAL2; -> REAL END
SW(37):                                ! DIVISION
         ->99 %IF RVAL2=0;             ! AVOID DIV BY ZERO
         RVAL1=RVAL1/RVAL2; -> REAL END
SW(41):                                ! EXP
         %IF OPND2_FLAG#0 %THEN  ->99
         RVAL1=RVAL1**OPND2_D; -> REAL END
SW(25):SW(26):SW(33):SW(34):
SW(36):SW(38):SW(39):SW(40):
99:      %END
         %ROUTINE FLOAT
         %SHORTROUTINE
!***********************************************************************
!*       PLANT CODE TO CONERT OPERAND1 FROM FIXED TO FLOATING          *
!***********************************************************************
         %INTEGER P1,P2,K
         P1=OPND1_XB; ; P2=(P1+1)&15
         %UNLESS OPND1_FLAG=9 %AND OPND1_D<0 %AND %C
            REGISTER(P1)>=0=REGISTER(P2) %AND GRUSE(P2)>1 %START
            FIND SEQ(P1,P2)
            LOAD(OPND1,P1,2)
         %FINISH
         PRR(X'10',P2,P1);             ! LPR P2,P1
         PRX(X'54',P1,CODER,0,X'E0');  ! N P1,=X'80000000'
         PRX(X'56',P1,CODER,0,X'D0');  ! O P1,=X'4E000000'
         PRX(X'90',P1,P2,WSPR,0);      ! STM P1,P2,0(11)
         CLAIM (FR0,K); D=K
         PRR(X'2B',K,K);               ! SDR K,K
         PRX(X'6A',K,0,11,0);          ! AD K,0(11)
         FREE AND FORGET(P1)
         FORGET(P2)
         CYC BITS=CYC BITS!16;         ! USES PERMS CONSTANTS
         CCSTATE=-1
         %END
         %ROUTINE STARSTAR
         %SHORTROUTINE
!***********************************************************************
!*       PLANT IN-LINE CODE FOR EXPONENTIATION                         *

!*       IMP ALLOWS EXPONENTS IN INTEGER EXPRESSIONS FROM 0-63 AND     *
!*       IN REAL EXPRESSIONS FROM-255 TO +255                          *
!***********************************************************************
         %INTEGER TYPEP,PRECP,COUNT,WORK,C,RREG,INTREG
         %BYTEINTEGER VALUE
         PTYPE=OPND1_PTYPE;            ! INSPECT THE OPERAND
        ! UNPACK
            *L_1,PTYPE; *CVD_1,0(11)
            *UNPK_ROUT(5),5(3,11)
            *NC_ROUT(5),MASK1
         %IF TYPE=1 %THEN WARN(LINE)
         TYPEP=TYPE
         %IF PREC&3=3 %THEN PRECP=16 %ELSE PRECP=0
         VALUE=0
         %IF OPND2_FLAG=0 %AND 1<=OPND2_D<=63*TYPE %THEN %START
            VALUE=OPND2_D;             ! EXPONENT IS #0 AND CONSTANT
         %FINISH
!
! MUST TEST BOTH OPERANDS BEFORE CLAIMING WORK REGS IN CASE EITHER OR
! BOTH ARE FNS AND WE ARE SHORT OF REGS SO THAT THE WORK REGS WILL
! NOT SURVIVE A FN CALL
!
         LOAD(OPND1,-1,0);                 ! INSPECT OPERAND CALL FNS
         LOAD(OPND2,-1,0);                 ! INSPECT EXPNT & CALL IF FN
         %IF TYPEP=1 %THEN CLAIM PAIR(WORK) %ELSE CLAIM (FR0,WORK)
         %IF VALUE#2 %THEN %START;         ! TREAT **2 SPECIALLY
            LOAD(OPND1,-1,2);              ! LOAD OPERAND TO ANY REGISTER
         %FINISH
!
! IF EITHER OPERAND IS A FN IT HAS BEEN FETCHED TO A REGISTER
! SO NOW REGISTERS CAN BE OBTAINED FOR THE IN-LINE SUBROUTINE
!     WORK HOLDS INITIALLY 1 PRIOR TO MULTIPLICATION
!     INTREG  HOLDS THE EXPONENT AS CALCULATED
!     COUNT HOLDS A +VE VERSION OF INTREG FOR COUNTING THE MULTIPLIES
!     RREG HOLD THE OPERAND.
!     COUNT & INTREG CAN BE THE SAME REGISTER IF EXPONENT IS +VE
!
         PLABEL=PLABEL-1;              ! LABEL FOR REPITITION
         %IF VALUE=2 %THEN %START;     ! TRANSPOSE X**2 TO X*X
            RREG= WORK+2-TYPEP
            LOAD(OPND1,RREG,2);
         %FINISH %ELSE %START
            LOAD(OPND2,-1,2);              ! EXPONENT TO ANY REGISTER
            INTREG=OPND2_XB
            RREG=OPND1_XB
            %IF TYPE=2 %THEN %START;   ! EXPONENT IS REAL **NOT ALLOWED
               FAULT(39,0)
               FREE AND FORGET(INTREG+16)
            %FINISH
            COUNT=INTREG
!
! GET '1' INTO WORK IN APPROPIATE FORM
!
            %IF TYPEP=1 %THEN PRX(X'41',WORK+1,0,0,1) %ELSE %C
               PRX(X'78'-PRECP,WORK,0,CODER,X'C8'); ! LD(E) WORK,=D'1'
!
! IF EXPONENT NOT KNOWN AT COMPILE TIME TO BE +VE CONSTANT MUST
! ALLOW FOR ZERO  :- XX**0=1 FOR ALL XX
! ALSO ALLOW FOR X**(-N) WHICH IS 1/(X**N) FOR ALL X & N
!
            %IF VALUE=0 %THEN %START;          ! NOT +VE CONSTANT
               CLAIM (GR1,COUNT) %IF TYPEP=2;  ! NEGATIVE REAL EXPONENTS
               PRR(X'14'-2*TYPEP,COUNT,INTREG);!  LPR OR LTR
               ENTER JUMP(8,PLABEL,B'11');     ! BZ END OF EXP ROUTINE
!
! IN CHECKING MODE PLANT CODE TO CHECK RANGE OF EXPONENT
!
               %IF CHECKSP=1 %THEN %START
                  %IF TYPEP=2 %THEN PRX(X'59',COUNT,0,GLA,24) %ELSESTART
                     DUMP(X'41',-1,63,0,0);  ! LA NEST,63
                     PRR(X'15',COUNT,NEST);  ! CLR COUNT,NEST
                  %FINISH
                  PCONST(X'4720C048');       !  BH ILLEGAL EXPONENT
               %FINISH
            %FINISH
            SET LOCAL BASE
            C=CA-LOCAL ADDR;                 ! ADDR OF NEXT INST FOR LOOP
         %FINISH
         PRR(32*TYPEP-4-PRECP,WORK,RREG);  ! MR OR MER OR MDR
         %IF TYPEP=1 %AND CHECKSP=1 %THEN %START
            PRX(X'8F',WORK,0,0,32);    ! SRDA TO CAUSE INTEGER OFLOW
            PRR(X'18',WORK+1,WORK);    ! LR WORK+1,WORK TO RESTORE
         %FINISH
         PRX(X'46',COUNT,LOCAL BASE,0,C) %IF VALUE#2;! BCT COUNT,AGAIN
!
! FOR REAL EXPONENTS CHECK IF NEGATIVE AND EVALUATE INVERSE
!
         %IF VALUE=0 %AND TYPEP=2 %THEN %START
            PRR(X'12',INTREG,INTREG);  ! LTR ON ORIGINAL EXPONENT
            ENTER JUMP(2,PLABEL,B'11');! BP END OF EXP ROUTINE
            PRX(X'78'-PRECP,RREG,0,CODER,X'C8');! LD(E) RREG,=D'1'
            CYC BITS=CYC BITS!16;      ! USES PERMS CONSTANTS
            PRR(X'3D'-PRECP,RREG,WORK);! DDR  RREG,WORK
            PRR(X'38'-PRECP,WORK,RREG);! LDR  WORK,RREG
         %FINISH
!
! ALL OVER. REAL RESULTS ARE IN FR WORK. INT RESULTS IN GR WORK+1
! FREE AND FORGET ANY OTHER REGISTERS
!
         TYPE=TYPEP; PREC=3*PRECP>>4
         %IF VALUE #2 %THEN %START
            FREE AND FORGET((TYPEP&2)<<3+RREG)
            REGISTER(INTREG)=0
            FREE AND FORGET(COUNT)
         %FINISH
         %IF TYPE=1 %THEN FREE AND FORGET(WORK)
         OPND1_PTYPE=10*PREC+TYPE
         OPND1_XB=WORK+2-TYPEP
         ENTER LAB(PLABEL,B'11');      ! LABEL AT END OF EXP ROUTINE
         %END
         %END
         %INTEGERFN CONST FIND(%INTEGER L,AD)
!***********************************************************************
!*       FIND IF THE CONSTANT OF LENGTH 'L' STORED AT ADDRESS 'AD'     *
!*       HAS ALREADY BEEN INSERTED IN THE GLA                          *
!***********************************************************************
         %SHORTROUTINE
         %INTEGER I,J,K,LIST,C1,C2
         LIST=SHORTINTEGER(ADDR(GLAHOLES)+L)
         C1=0; C2=0
!         %CYCLE I=0,1,L-1
!            BYTEINTEGER(ADDR(C1)+I)=BYTEINTEGER(AD)
!            AD=AD+1
!         %REPEAT
         *LM_1,2,L; *BCTR_1,0
         *MVC_C1(1),0(2)
         *EX_1,*-6
!         %WHILE LIST>0 %CYCLE
!            I=ADDR(ASLIST(LIST))
!            %IF C1=INTEGER(I) %AND C2=INTEGER(I+4) %C
!               %THEN %RESULT=INTEGER(I+8)
!            LIST=SHORT INTEGER(I+14)
!         %REPEAT
         *L_1,LIST; *L_2,ASLIST
NEXT:    *LTR_1,1; *BC_12,<MISS>
         *LA_3,0(1,2); *CLC_C1(8),0(3)
         *BC_8,<HIT>
AGN:     *LH_1,14(1,2); *BC_15,<NEXT>
HIT:     *L_1,8(1,2); *LM_4,15,16(7); *BCR_15,15
MISS:
         %RESULT=-1
         %END
         %ROUTINE STORE CONST(%INTEGERNAME B,D,%INTEGER L,AD)
!***********************************************************************
!*       PUT THE CONSTANT OF LENGTH 'L' AT ADDRESS 'AD' INTO THE GLA   *
!*       AND RECORD ITS POSITION IN CASE THIS CONSTANT IS REUSED       *
!*       A CHECK IS MADE USING 'CONST FIND' TO SEE IF THE CONSTANT HAS *
!*       BEEN INSERTED IN WHICH CASE THE OLD COPY IS REUSED            *
!***********************************************************************
         %SHORTROUTINE
         %INTEGER I,J,K
         %SHORTINTEGERNAME LIST
         D=-1
         D=CONST FIND(L,AD) %IF GLAFLAG = 0
         %IF D=-1  %START;! FIRST USE OF CNST
            I=0; J=0
            %CYCLE K=0,1,L-1
               BYTEINTEGER(ADDR(I)+K)=BYTEINTEGER(AD+K)
            %REPEAT
            %IF L=2 %AND GLAHOLES#0 %START
               POP(GLAHOLES,D,B)
               B=13; PLUG(2,D,I>>16)
               GSAVED=GSAVED+2
            %FINISH %ELSE %START
               PGLA(L,L,AD)
               D=GLACA-L; B=GLA
            %FINISH
            LIST==SHORT INTEGER(ADDR(GLAHOLES)+L)
            PUSH123(LIST,I,J,D) %IF GLAFLAG=0
         %FINISH %ELSE %START;            ! CONST ALREADY IN
            %IF D<0 %THEN %START
               CYC BITS=CYC BITS!16;      ! SET USES PERMS CONSTS BIT
               B=CODER; D=D&X'FFF'
            %FINISH %ELSE B=GLA
         %FINISH
         %END
         %ROUTINE CCOND(%INTEGER IU,FARLAB)
         %SHORTROUTINE
!***********************************************************************
!*       COMPILES <IU><SC><RESTOFCOND>%THEN<UI1>%ELSE<UI2>             *
!*       IU=1 FOR %IF   =2 FOR UNLESS. FARLAB TO GO ON UI2             *
!*       THE ROUTINE MAKES FOUR PASSES THROUGH THE CONDITION           *
!*       PASS 1 ANALYSES THE STRUCTURE AND DECIDES TO BRANCH ON TRUE   *
!*       (TF=2)   OR ON FALSE (TF=1) FOR EACH COMPARISON               *
!*       PASS 2 WORKS OUT WHERE THE BRANCHES OF PASS 1 SHOULD GO TO    *
!*       PASS 3 ASSIGNS LABEL NUMBERS                                  *
!*       PASS 4 EVALUATES COMPARISIONS AND PLANTS THE CODE             *
!*                                                                     *
!*       ON ENTRY P POINTS TO <SC> IN<HOLE><SC><RESTOFCOND>            *
!***********************************************************************
!         %ROUTINESPEC WRITE CONDLIST
         %ROUTINESPEC SKIP SC
         %ROUTINESPEC SKIP COND
         %ROUTINESPEC CCOMP
!
! FCOMP HAS BC MASKS FOR EACH COMPARATOR.
! THE FIRST 7 ARE TO BRANCH IF TRUE WITH NORMAL COMPARISON
! THE SECOND SEVEN ARE TO BRANCH IF TRUE WITH BACKWARDS COMPARISON
! THE THIRD SEVEN ARE FOR THE TEST UNDER MASK INSTRUCTION
!
         %CONSTBYTEINTEGERARRAY FCOMP(1:21)=8,10,2,7,12,4,7,
                                            8,12,4,7,10,2,7,
                                            8,15,7,7,8,0,7;
!
         %INTEGER PIN,PP,II,L,CPTR,CMAX,LL
         %RECORDFORMAT CF(%BYTEINTEGER TF,CMP1,CMP2,LABU,LVL,JMP, %C
                          %SHORTINTEGER LABNO,SP1,SP2)
         %RECORDARRAY CLIST(1:30)(CF)
         %RECORDNAME C1,C2(CF)
!
! PASS 1.   ANALYSES THE CONDITION
!
         PIN=P;                        ! SAVE INITIAL AR POINTER
         CPTR=1; L=3;                  ! LEVEL=3 TO ALLOW 2 LOWER
         C1==CLIST(CPTR);              ! SET UP RECORD FOR FIRST CMPARSN
         C1=0
         SKIP SC;                      ! SKIP THE 1ST CMPARSN
         SKIP COND;                    ! AND ANY %AND/%OR CLAUSES
         C1_LVL=2;                     ! LEVEL =-1 FOR %IF/%THEN ENTRY
         C1_TF=IU
         CMAX=CPTR+1
         C1==CLIST(CMAX); C1=0
         C1_LVL=1;                     ! LEVEL =-2 FOR ELSE ENTRY
         C1_TF=3-IU; C1_LABNO=FARLAB
         PP=P;                         ! SAVE FINAL AR POINTER
         FAULT(209,0) %IF CMAX>29;     ! TOO COMPLICATED
!
! PASS 2 WORKS OUT WHERE TO JUMP TO
! THE JUMP IS FORWARD TO THE START OF THE CLAUSE WITH A DIFFERENT
! CONNECTOR (AND/OR) PROVIDED THIS IS AT A LOWER LEVEL THAN THE BRANCH
! AND ALSO AT A LOWER LEVEL THAN THE LOWEST POINT REACHED ENROUTE
!
! ALSO CONTAINS PASS 3 (TRIVIAL)
! ASSIGN LABELS WHERE LABU SHOWS THEY ARE REQUIRED
!
         %CYCLE CPTR=1,1,CMAX-1
            C1==CLIST(CPTR)
            L=C1_LVL; LL=L;            ! LL FOR LOWEST LEVEL ENROUTE
            %CYCLE II=CPTR+1,1,CMAX+1
              C2==CLIST(II)
              %EXIT %IF C1_TF#C2_TF %AND C2_LVL<LL
              %IF C2_LVL<LL %THEN LL=C2_LVL
            %REPEAT
            C1_JMP=II;                 ! CLAUSE TO JUMP TO
            C2_LABU=C2_LABU+1
             %IF C1_CMP2#0 %OR C1_CMP1=8 %START; ! D-SIDED OR RESLN
                                       ! REQIUIRES A LABEL ON THE
               C1_LABU=C1_LABU+1;      ! THE NEXT SIMPLE CONDITION
            %FINISH
            %IF C1_LABU#0 %AND C1_LABNO<=0 %THEN PLABEL=PLABEL-1 %C
                                           %AND C1_LABNO=PLABEL
         %REPEAT
!
! PASS 4 GENERATE THE CODE
!
!         WRITE CONDLIST %IF DCOMP=1
         %CYCLE CPTR=1,1,CMAX-1
            C1==CLIST(CPTR)
            CCOMP
            %IF C1_LABNO>0 %THEN ENTER LAB(C1_LABNO,B'11')
         %REPEAT
!
         P=PP; %RETURN
         %ROUTINE SKIP SC
!***********************************************************************
!*       SKIPS OVER A SIMPLE CONDITION. P ON ALT OF<SC>                *
!***********************************************************************
         %INTEGER ALT
         ALT=A(P); P=P+1
         %IF ALT=1 %THEN %START;      ! <EXP><COMP><EXP><SECONDSIDE>
            C1_SP1=P-PIN
            SKIP EXP
            C1_CMP1=A(P)
            P=P+1; C1_SP2=P-PIN
            SKIP EXP
            %IF A(P)=2 %THEN P=P+1 %ELSE %START
               C1_CMP2=A(P+1);        ! DEAL WITH 2ND HALF OF D-SIDED
               P=P+2; SKIP EXP
            %FINISH
         %FINISH %ELSE %START;        ! '('<SC><RESTOFCOND>')'
             L=L+1
             SKIP SC
             SKIP COND
             L=L-1
         %FINISH
         %END;                        ! OF ROUTINE SKIP SC
         %ROUTINE SKIP COND
!***********************************************************************
!*       SKIPS OVER <RESTOFCOND>                                       *
!***********************************************************************
         %INTEGER ALT,ALTP
         ALT=A(P);                      ! 1=%AND<ANDC>,2=%OR<ORC>,3=NULL
         P=P+1
         %IF ALT\=3 %THEN %START;       ! NULL ALTERNATIVE NOTHING TO DO
            %UNTIL ALTP=2 %CYCLE;       ! UNTIL NO MORE <SC>S
               C1_LVL=L; C1_TF=ALT
               CPTR=CPTR+1
               C1==CLIST(CPTR); C1=0
               SKIP SC
               ALTP=A(P); P=P+1
            %REPEAT
         %FINISH
         %END
!         %ROUTINE WRITE CONDLIST
!         %CONSTSTRING(5) %ARRAY CM(0:8)='     ','    =','   >=','    >',
!                                '    #','   <=','    <','   \=','   ->'
!         PRINTSTRING('
! NO   TF   C1   C2   LABU   LVL  JMP  LABNO
!')
!         %CYCLE CPTR=1,1,CMAX
!            C1==CLIST(CPTR)
!            WRITE(CPTR,2)
!            WRITE(C1_TF,4)
!            PRINTSTRING(CM(C1_CMP1))
!            PRINTSTRING(CM(C1_CMP2))
!            WRITE(C1_LABU,6)
!            WRITE(C1_LVL,5)
!            WRITE(C1_JMP,4)
!            WRITE(C1_LABNO,7)
!            NEWLINE
!         %REPEAT
!         %END
         %ROUTINE CCOMP
!***********************************************************************
!*       COMPILES A COMPARISION: THREE DIFFERENT CASES                 *
!*       1) ARITHMETIC EXPRESSIONS EXPOP IS USED                       *
!*       2) STRING EXPRESSION AD-HOC CODE PLANTED BY THIS ROUTINE      *
!*       3) RESOLUTIONS - CRES CAN BE USED                             *
!***********************************************************************
         %ROUTINESPEC ACOMP(%INTEGER TF,LAB)
         %ROUTINESPEC SCOMP(%INTEGER TF,LAB,%INTEGERNAME WA)
         %SHORTINTEGER HEAD1,HEAD2,NOPS,BOT1,BOT2
         %INTEGER TE1,TE2,TEX1,TEX2,MASK,P1,P2
         %INTEGER FEXIT,IEXIT,CMP,WA1,WA2,WA3,DISPP,BASEP,LL
!
         HEAD1=0; HEAD2=0; NOPS=0; BOT1=0; BOT2=0
         FEXIT=CLIST(C1_JMP)_LABNO;    ! FINAL EXIT
         IEXIT=FEXIT;                  ! INTERMEDIATE EXIT (D-SIDED ETC)
         %IF C1_TF=2 %AND (C1_CMP1=8 %OR C1_CMP2#0) %THEN %C
                      IEXIT=C1_LABNO
!
         P=PIN+C1_SP2
         P2=P; P1=PIN+C1_SP1
         %IF C1_CMP1=8 %OR C1_CMP2=8 %THEN %START
                                       ! CONDITIONAL RESOLUTION
                                       ! NB CRES BRANCHES ON FALSE!!
            P=P1
            %IF C1_CMP2=0 %AND A(P+2)=4 %AND A(P+3)=1 %START
               P=P+4; CNAME(5,1);      ! LH STRING TO REGISTER 1
               %IF A(P)=2 %AND TYPE=5 %THEN %START
                  P=P2
                  CRES(IEXIT);         ! FAILURES -> IEXIT
                  %IF C1_TF=2 %THEN MASK=15 %AND ->TBRANCH
                  %RETURN
               %FINISH
            %FINISH
            FAULT(73,0)
            %RETURN
         %FINISH
         MASK=FCOMP(C1_CMP1)
         TE2=TSEXP(TEX2,0)
         ->STR %IF TYPE=5
         ->ARITH %UNLESS TE2=1
         P=P1; TE1=TSEXP(TEX1,1)
         ->STR %IF TYPE=5
         %IF TE1=800 %AND K<=4095 %AND C1_CMP2=0=CHECKSP %START;! X&N1=N2
            DISPP=K+BYTES(PREC)-1; BASEP=I
            %IF TEX2=0 %THEN %START
               MASK=FCOMP(C1_CMP1+14)
               -> T UNDER M;           ! CAN USE TM FOR X&N1=0 IF N1<256
            %FINISH
            %IF TEX1=TEX2 %AND 7<=MASK<=8 %START;  ! X&N1<=/#>N1
               %IF MASK=8 %THEN MASK=1 %ELSE MASK=14
               -> T UNDER M
            %FINISH
         %FINISH
ARITH:                                 ! ARITHMETIC COMPARISIONS
         P=P1+2
         TORP(HEAD1,BOT1,NOPS,0);      ! FIRST EXPRESSION TO REVERSE POL
         CMP=C1_CMP1
         P=P2+2
         %IF C1_CMP2#0 %THEN %START;   ! IF D-SIDED DEAL WITH MIDDLE
            ACOMP(1,IEXIT);            ! BRANCH IEXIT %IF FALSE
            P=P+4;                     ! TO THE THIRD EXPRSN
            CMP=C1_CMP2;               ! COMPARATOR NO 2
         %FINISH
!
         ACOMP(C1_TF,FEXIT);           ! SECOND OR ONLY COMPARISION
!
         EXPOP(HEAD1,-1,NOPS,16);      ! PLANT THE CODE
!         CLEAR LIST(HEAD1)
         SHORTINTEGER(ADDR(ASLIST(BOT1))+14)=ASL
         ASL=HEAD1
         %RETURN
T UNDER M:                             ! CAN USE TM FOR COMPARISON
         DUMPSI(X'91',TEX1,BASEP,DISPP)
         CCSTATE=-1
TBRANCH: MASK=MASK!!15 %IF C1_TF=1
         ENTER JUMP(MASK,FEXIT,B'11')
         %RETURN
STR:                                   ! STRING COMPARISIONS
                                       ! SOME CARE IS NEEDED IN FREEING
                                       ! STRING WK-AREAS SET BY CSTREXP
         P=P1
         WA1=0; WA2=0; WA3=0
         %IF TE2=1 %AND TEX2=0 %AND C1_CMP2=0 %AND 7<=MASK<=8 %START
            CSTREXP(0,-2);            ! USE TM FOR IF S='' ETC
            DISPP=DISP; BASEP=BASE
            TEX1=255
            ->T UNDER M
         %FINISH
         CSTREXP(16,-2);              ! DO NOT FREE WK-AREA
         WA1=VALUE;                   ! SAVE ADDRESS OF WK-AREA
         CMP=C1_CMP1
         P=P2
!
         %IF C1_CMP2#0 %THEN %START;  ! D-SIDED DEAL WITH MIDDLE
            SCOMP(1,IEXIT,WA2)
            P=P+2; CMP=C1_CMP2
            %IF WA1#0 %THEN RETURN WSP(WA1,256) %AND WA1=0
         %FINISH
!
         SCOMP(C1_TF,FEXIT,WA3)
         %CYCLE CMP=ADDR(WA1),4,ADDR(WA3)
            %IF INTEGER(CMP)#0 %THEN RETURN WSP(INTEGER(CMP),256)
         %REPEAT
         %RETURN
         %ROUTINE ACOMP(%INTEGER TF,LAB)
!***********************************************************************
!*       TYPE & PREC DEFINE THE EXPRSN IN REVERSE POLISH IN HEAD1      *
!*       THIS ROUTINE CONVERTS THE NEXT EXPRSN TO REVERSE POLISH AND   *
!*       ADDS OPERATORS FOR TYPE CHANGING(IF REQ) CMPRSN AND JUMP      *
!***********************************************************************
         %BYTEINTEGER PRECP,TYPEP
         %INTEGER BMASKS,TORPMODE,CMODE,COP
         PRECP=PREC; TYPEP=TYPE
         BMASKS=FCOMP(CMP+7)<<4!FCOMP(CMP)
         %IF TF=1 %THEN BMASKS=BMASKS!!255;! REVERSE MASKS IF FALSE
!
! ADD OPERATORS IN THE REVERSE ORDER TO EXECUTION. IE JUMP(29) THEN
! COMPARE(26) OR LOGICAL (IE = & # ONLY) COMPARE(27)
!
         PUSH(HEAD2,29,0)
         BOT2=HEAD2
         PUSH(HEAD2,1<<16!BMASKS<<8,LAB)
         %IF 7<=BMASKS&15<=8 %THEN CMODE=27 %ELSE CMODE=26
         PUSH(HEAD2,CMODE,0)
!
! CONVERT NEXT EXPRSN TO REVERSE POLISH AND TO THE SAME TYPE AS THE
! FIRST IF POSSIBLE. MODE=0 INTEGER IF POSSIBLE,=2 REAL, =3 LONGREAL
!
         %IF TYPEP=1 %THEN TORPMODE =0 %ELSE TORPMODE=PRECP!2
         TORP(HEAD2,BOT2,NOPS,TORPMODE)
!
! IF THE 2ND EXPRSN IS REAL OR LONGREAL AND THE FIRST IS INTEGER OR
! REAL A CONVERSION OPERN (FLOAT=12,STRETCH=14) IS ALSO NEEDED
!
         COP=0
         %IF TYPE=2 %THEN %START
            %IF TYPEP=1 %THEN COP=12 %ELSE %START
               %IF PREC#PRECP %THEN COP=14
            %FINISH
         %FINISH
         PUSH(HEAD2,COP,PREC>>1) %IF COP#0
         SHORTINTEGER(ADDR(ASLIST(BOT1))+14)=HEAD2
         BOT1=BOT2; BOT2=0; HEAD2=0
         %END
         %ROUTINE SCOMP(%INTEGER TF,LAB,%INTEGERNAME WA)
!***********************************************************************
!*       1ST STRING IS DEFINED BY BASE,DISP & STRINGL(IF KNOWN)        *
!*       THIS ROUTINE EVALUATES THE NEXT STRING EXPRS AND PERFORMS     *
!*       THE COMPARISON & BRANCH. = & # CAN BE DONE IN LINE BUT < & >  *
!*       ARE COMPLICATED BY THE LENGTH BYTE AND ARE PERFORMEDIN PERM   *
!***********************************************************************
         %INTEGER MASK,CODE,L
!
! A SAFE REGISTER MAY BE NEEDED HERE ON OPTIMUM CODE EVEN IF IT IS NOT
! REQUIRED ON THE PRELIMINARY PASS
!
         CYC BITS=CYC BITS!128;        ! SAFE REGISTER REQD
         %IF REGISTER(BASE)=0 %AND (BASE<4 %OR BASE=15) %START
            CLAIM(SAFE,BASEP); PRR(X'18',BASEP,BASE)
            FORGET(BASEP); BASE=BASEP
         %FINISH
!
         BASEP=BASE; DISPP=DISP; LL=STRINGL
         MASK=FCOMP(CMP)
         %IF 7<=MASK<=8 %THEN CODE=0 %ELSE CODE=5
         %IF TF=1 %THEN MASK=MASK!!15; ! REVERSE MASK TO JMP IF FALS
         REGISTER(BASEP)=1 %IF REGISTER(BASEP)=0
!
         CSTREXP(16,0);                ! SAVE WK-AREA
         WA=VALUE
         L=STRINGL
         %IF CODE=0 %THEN L=L!LL
         STRINGOP(CODE,L,BASE,DISP,BASEP,DISPP,0,255,-2)
         REGISTER(BASEP)=0 %IF REGISTER(BASEP)=1
         REGISTER(BASE)=1 %IF REGISTER(BASE)=0;! MAY BE FURTHER CMPRSN!
         ENTER JUMP(MASK,LAB,B'11')
         REGISTER(BASE)=0 %IF REGISTER(BASE)>0
         %END
         %END
         %END
         %ROUTINE REDUCE ENV(%SHORTINTEGERNAME HEAD)
         %SHORTROUTINE
!***********************************************************************
!*       HEAD HAS AN ENVIRONMENT  - THIS ROUTINE REMOVES ANYTHING      *
!*       INCOMPATIBLE WITH THE CURRENT REGISTER STATE                  *
!***********************************************************************
         %SHORTINTEGER NEWHEAD; %INTEGER I,J,K,REG,USE
         NEWHEAD=0
         %WHILE HEAD#0 %CYCLE
            POP123(HEAD,I,J,K)
            REG=K>>8; USE=K&255
            %IF USE=GRUSE(REG) %AND I=GRINF(REG) %THEN %C
               PUSH123(NEWHEAD,I,J,K)
         %REPEAT
         HEAD=NEWHEAD
         %END
         %ROUTINE ENTER LAB(%INTEGER LAB,FLAGS)
         %SHORTROUTINE
!***********************************************************************
!*       ENTER A NEW LABEL ON THE LABEL LIST FOR THE CURRENT LEVEL     *
!*       2**0  OF FLAGS  = 1  CONDITIONAL ENTRY                        *
!*       2**1  OF FLAGS  = 1  UPDATE ENVIRONMENT                       *
!*       2**2  OF FLAGS  = 1  REPLACE ENV     =0  MERGE ENV            *
!*       THE LABEL LIST                                                *
!*       S1 =   USE BITS<<8 ! LABEL ADDR                               *
!*       S2 =   ENVIRONMENT LIST << 16 ! UNFILLED JUMPS LIST           *
!*       S3 = LAB NO - RESET TO ZERO WHEN USED FOR INTERNAL LABELS     *
!***********************************************************************
         %INTEGER CELL,AT,BBASE,BREG,KREG,DIS,KDIS
         %SHORTINTEGERNAME ENVHEAD,JUMPHEAD
         %RETURN %IF CSSMODE=0
         FLAGS=FLAGS&1 %IF CHECKSP#0
         MONE=1 %IF LAB<MAX ULAB
         %IF 1<=LAB<=16381 %THEN WARN(LINE)
         CELL=FIND3( LAB,LABEL(LEVEL))
         %IF CELL<0 %THEN %START;      ! LABEL NOT KNOWN
            %IF FLAGS&1=0 %THEN %START;! UNCONDITIONAL ENTRY
               PUSH123(LABEL(LEVEL),CA,0,LAB)
               FORGETM(14)
               CCSTATE=-1; LCA=0
            %FINISH
            %RETURN
         %FINISH
!
! LABEL HAS BEEN REFERENCED - FILL IN ITS ADDRESS
!
         ENVHEAD== SHORT INTEGER(ADDR(ASLIST(CELL+4)))
         JUMPHEAD== SHORT INTEGER(ADDR(ASLIST(CELL+6)))
         %IF FROM1(CELL)&X'FFFFFF'# 0 %THEN %START
            FAULT(2,-LAB);             ! LABEL SET TWICE
         %FINISH %ELSE %START
            CCSTATE=-1; LCA=0
            REPLACE1(CELL,X'1000000'!CA)
         %FINISH
!
! SORT OUT ENVIRONMENTS  -  AS DIRECTED BY FLAGS
!
         %IF FLAGS&2=0 %THEN %START
            FORGETM(14)
            CLEAR LIST(ENVHEAD) %IF ENVHEAD#0
         %FINISH %ELSE %START
            REMEMBER %IF FLAGS&4=0
            RESTORE (ENVHEAD)
            ENVHEAD=0
            MERGE INFO %IF FLAGS&4=0
         %FINISH
!
! NOW FILL JUMPS TO THIS LABEL - JUMP LIST FORMAT GIVEN IN 'ENTER JMP'
!
         %WHILE  JUMPHEAD#0  %CYCLE
            POP(JUMPHEAD,AT,BBASE)
            KREG=AT>>24
            BREG=BBASE>>24
            AT=AT&X'FFFFFF'
            DIS=CA-BBASE&X'FFFFFF'
!
! KREG=0 %IF NO INDEX REGISTER REQUIRED
! KREG=KREG!16 %IF INDEX REGISTER HAS BEEN SET UP BY EARLIER JUMP
! IF INDEX REGISTER SET BUT NOT REQUIRED  OVERWRITE 'L' WITH 'LA'
!
         %IF 0<KREG<16 %THEN %START
            KDIS= PTBASE+ DIS>>12<<2;! ADDR OF CORRECT 4K MULTIPLE
            %IF KDIS=PTBASE %THEN %START
               PLUG(1,AT,X'4100'! KREG<<4);!   LOAD ADDRESS
               KDIS=0
            %FINISH
            PLUG(1,AT+2,KDIS)
            AT=AT+4
         %FINISH
         %IF DIS>4095 %AND KREG=0 %THEN FAULT(99,0)
         PLUG(1,AT+2, (BREG&15)<<12!DIS&4095); ! FILL THE JUMP
         %REPEAT
         %IF LAB> MAX ULAB  %THEN %START
            %IF PREV3CL=0 %THEN JUMPHEAD==LABEL(LEVEL) %C
               %ELSE JUMPHEAD==SHORT INTEGER(ADDR(ASLIST(PREV3CL+14)))
            POP(JUMPHEAD,AT,AT);        ! REMOVE OLD LABEL
         %FINISH
         %END
         %ROUTINE ENTER JUMP(%INTEGER MASK,LAB,FLAGS)
         %SHORTROUTINE
!***********************************************************************
!*       IF LAB HAS BEEN ENCOUNTERED THEN PLANT A *BC OTHERWISE ENTER  *
!*       THE LABEL IN THE LABEL LIST AND ATTACH THE JUMP TO IT SO IT   *
!*       CAN BE PLANTED WHEN THE LABEL IS FOUND                        *
!*       THE LABEL LIST IS DESCRIBED UNDER 'ENTER LAB'                 *
!*       THE JUMP SUB-LIST HAS THE FORM                                *
!*       S1=KREG<<24! ADDR OF JUMP                                     *
!*       S2=BREG<<24! (ADDRESS IN BASE(BREG) REGISTER)                 *
!*                                                                     *
!*       FLAGS BITS SIGNIFY AS FOLLOWS                                 *
!*       2**0 =1  JUMP IS KNOWN TO BE SHORT                            *
!*       2**1 =1  ENVIRONMENT MERGEING REQUIRED                        *
!***********************************************************************
         %INTEGER AT,CELL,BREG,BBASE,KREG,LABADDR,I
         %SHORTINTEGER ENVHEAD
         %SHORTINTEGERNAME OLDENV
         ENVHEAD=0; AT=CA; KREG=0
         BREG=10; BBASE=CODEBASE; ENVHEAD=0
         %IF LAB=0 %THEN FAULT(2,0) %AND %RETURN
         FLAGS=FLAGS&1 %IF CHECKSP#0
         %IF 1<=LAB<=16381 %THEN WARN(LINE)
         %IF LAB<MAX ULAB %THEN FLAGS=FLAGS&X'FD';! NO MERGE
         %IF LAB<22000 %THEN FLAGS=FLAGS&X'FE'
                                          ! SF OR USER LAB=LONG
         CELL=FIND3(LAB,LABEL(LEVEL))
         -> FIRSTREF %IF CELL<0
         LABADDR=FROM1(CELL)&X'FFFFFF'
         -> NOT YET SET %IF LABADDR=0
         REPLACE1(CELL,LABADDR!X'1000000');! FLAG LABEL AS USED
         %IF CYC BASE#0 %AND CYC ADDR<=LABADDR %THEN %C
                        BREG=CYC BASE %AND BBASE=CYC ADDR
         I=LABADDR-BBASE
         %IF I=0 %THEN PRR(7,MASK,BREG) %ELSE DUMP(X'47',MASK,I,0,BREG)
         %RETURN
FIRSTREF:                              ! FIRST REFERENCE TO A NEW LABEL
         %IF CSSMODE#0 %THEN %START
            %IF LAB>MAX ULAB %AND FLAGS&2#0 %THEN GET ENV(ENV HEAD)
            PUSH123(LABEL(LEVEL),X'1000000',ENVHEAD<<16,LAB)
            CELL=LABEL(LEVEL)
         %FINISH
         -> CODE
NOT YET SET:                           ! LABEL REFERENCED BEFORE
         %IF CSSMODE#0 %THEN %START
            %IF LAB>MAX ULAB %AND FLAGS&2#0 %THEN %START
            OLDENV==SHORT INTEGER(ADDR(ASLIST(CELL+4)))
               REDUCE ENV(OLD ENV)
            %FINISH
         %FINISH
CODE:                                  ! ACTUALLY PLANT THE JUMP
         %IF SBFLAG #0 %THEN FLAGS=FLAGS!1
         %IF CYC BASE #0 %AND LAB> MAX ULAB %THEN %START
            BREG=CYC BASE;             ! SOMETHING INSIDE AN OPTIMISED
            BBASE=CYC ADDR;            ! CYCLE. BASE REGISTER COVER
            FLAGS=FLAGS!1;             ! IS PROVIDED BY CYC BASE
         %FINISH
!
! IF THE SHORT JUMP FLAG NOT SET THEN WE CAN TRY :-
! A)     TO LOCATE A SUITABLE 4K MULTIPLE ALREADY IN A REGISTER
! B)     TO FIND THE LABEL LURKING IN THE CYCLIC BUFFER.
! IF THESE FAIL THEN AN 8 BYTE JUMP MUST BE PLANTED
!
         %IF FLAGS&1=0 %THEN %START
            FIND USE(I,1,11,\LAB)
            %IF I>0 %THEN KREG=I+16 %ELSE %START
               LABLOOK(I,LAB) %IF CHECKSP=0 %AND CSSMODE#0
               FLAGS=FLAGS!1 %IF I=1
            %FINISH
         %FINISH
         %IF FLAGS&1#0 %THEN %START
            SET LOCAL BASE
            BREG=  LOCAL BASE
            BBASE= LOCAL ADDR
            AT=CA;                     ! IN CASE BASE HAS BEEN SET
         %FINISH %ELSE %START
            %IF KREG=0 %THEN %START
               FIND REG(GR1,KREG)
               SET USE(KREG,11,\LAB)
               PRX(X'58',KREG,CODER,0,0)
               CYC BITS=CYC BITS!16;   ! 'USES MULTIPLE OF 4096' BIT SET
            %FINISH
         %FINISH
!
! ENTER JUMP IN SUBLIST
!
         %IF CSSMODE#0 %THEN %C
PUSH(SHORT INTEGER(ADDR(ASLIST(CELL+6))),KREG<<24!AT,BREG<<24!BBASE)
         PRX(X'47',MASK,KREG&15,0,0)
         %END
         %ROUTINE MERGE INFO
!***********************************************************************
!*       MERGE THE CURRENT STATUS OF GENERAL AND FLOATING REGISTERS    *
!*       WITH THOSE AT THE START OF THE CONDITIONAL CLAUSE. THUS       *
!*       THE COMPILER CAN REMEMBER UNCHANGED REGISTERS BUT NOT THOSE   *
!*       WHICH DEPEND ON A PARTICULAR RUN TIME ROUTE BEING TAKEN       *
!***********************************************************************
%SHORTROUTINE
%INTEGER I,J
         %IF CSSMODE#0 %THEN %START; ! OMIT MERGE ON PRELIM PASS
            %CYCLE J=0,1,14; I=GRMAP(J)
            FORGET(I) %UNLESS SGRUSE(I)=GRUSE(I) %AND SGRINF(I)=GRINF(I)
            %REPEAT
         %FINISH
         LCA=0;            ! NOTE LABEL
         %END
         %ROUTINE     REMEMBER
         %SHORTROUTINE
         *L_1,SGRUSE; *L_2,GRUSE; *MVC_0(92,1),0(2)
         *L_1,SGRINF; *L_2,GRINF; *MVC_0(92,1),0(2)
         %END
         %ROUTINE SET LOCAL BASE
         %SHORTROUTINE
! FIND OR SET UP A REGISTER FOR BRANCHING A SMALL DISTANCE FORWARD
         %INTEGER I,J
         LOCAL BASE=10; LOCAL ADDR=CODEBASE
         ->2 %IF SBFLAG=1 %OR 4095-MARGIN>CA-CODEBASE
         %IF CYC BASE#0 %THEN %START
            LOCAL BASE=CYC BASE; LOCAL ADDR=CYC ADDR
            ->2; %FINISH
         %CYCLE J=14,1,24
            I=J&15
            -> SET %IF I>0 %AND GRUSE(I)=12
         %REPEAT
         FIND REG(ADDREG,LOCAL BASE)
         PRR(5,LOCAL BASE,0)
         LOCAL ADDR=CA
         SET USE(LOCAL BASE,12,CA); ->2
SET:
         LOCAL ADDR=GRINF(I)
         LOCAL BASE=I
         %IF 4095-MARGIN<CA-LOCAL ADDR %THEN %START
               FORGET(I)
               SET LOCAL BASE
         %FINISH
2:       %END;                      ! OF ROUTINE SET LOCAL BASE
         %ROUTINE CSNAME(%INTEGER Z,REG)
         %SHORTROUTINE
!***********************************************************************
!*       COMPILE A SPECIAL NAME - PTYPE=10006 (=%ROUTINE %LABEL)       *
!*       THEIR TRUE PTYPE IS IN GLOBAL ARRAY TSNAME.                   *
!*       SNINFO HAS A FOUR BYTE RECORD FOR EACH NAME (%BI FLAG,PTR,    *
!*       %SI XTRA). THE TOP BITS OF FLAG CATEGORISE AS FOLLOWS:-       *
!*       2**7 SET FOR IMPLICITLY SPECIFIED CONSTRUCT A %SPEC           *
!*       2**6 SET FOR IOCP CALL                                        *
!*       2**5 SET FOR BUILT IN MAPPING FUNCTIONS                       *
!*       2**4 SET IF AD-HOC CODE PLANTED BY THIS ROUTINE               *
!*       2**3 SET IF FIRST PARAMETER IS OF %NAME TYPE                  *
!*       2**2-2**0 HOLD NUMBER OF PARAMS                               *
!*                                                                     *
!*       THE FULL SPECS ARE AS FOLLOWS:-                               *
!*       0=%ROUTINE SELECT INPUT(%INTEGER STREAM)                      *
!*       1=%ROUTINE SELECT OUTPUT(%INTEGER STREAM)                     *
!*       2=%ROUTINE NEWLINE                                            *
!*       3=%ROUTINE SPACE                                              *
!*       4=%ROUTINE SKIP SYMBOL                                        *
!*       5=%ROUTINE READ STRINWG(%STRINGNAME S)                        *
!*       6=%ROUTINE NEWLINES(%INTEGER N)                               *
!*       7=%ROUTINE SPACES(%INTEGER N)                                 *
!*       8=%INTEGERFN NEXT SYMBOL                                      *
!*       9=%ROUTINE PRINT SYMBOL(%INTEGER SYMBOL)                      *
!*       10=%ROUTINE READ SYMBOL(%NAME SYMBOL)                         *
!*       11=%ROUTINE READ(%NAME NUMBER)                                *
!*       12=%ROUTINE WRITE(%INTEGER VALUE,PLACES)                      *
!*       13=%ROUTINE NEWPAGE                                           *
!*       14=%INTEGERFN ADDR(%NAME VARIABLE)                            *
!*       15=%LONGREALFN ARCSIN(%LONGREAL X)                            *
!*       16=%INTEGERFN INT(%LONGREAL X)                               *
!*       17=%INTEGERFN INTPT(%LONRGREAL X)                             *
!*       18=%LONGREALFN FRACPT(%LONGREAL X)                            *
!*       19=%ROUTINE PRINT(%LONGREAL NUMBER,%INTEGER BEFORE,AFTER)     *
!*       20=%ROUTINE PRINTFL(%LONGREAL NUMBER,%INTEGER PLACES)         *
!*       21=%REALMAP REAL(%INTEGER VAR ADDR)                           *
!*       22=%INTEGERMAP INTEGER(%INTEGER VAR ADDR)                     *
!*       23=%LONGREALFN MOD(%LONGREAL X)                               *
!*       24=%LONGREALFN ARCCOS(%LONGREAL X)                            *
!*       25=%LONGREALFN SQRT(%LONGREAL X)                              *
!*       26=%LONGREALFN LOG(%LONGREAL X)                               *
!*       27=%LONGREALFN SIN(%LONGREAL X)                               *
!*       28=%LONGREALFN COS(%LONGREAL X)                               *
!*       29=%LONGREALFN TAN(%LONGREAL X)                               *
!*       30=%LONGREALFN EXP(%LONGREAL X)                               *
!*       31=%ROUTINE CLOSE STREAM(%INTEGER STREAM)                     *
!*       32=%BYTEINTEGERMAP BYTE INTEGER(%INTEGER VAR ADDR)            *
!*       33=%SHORTINTEGERMAP SHORTINTEGER(%INTEGER VARADDR)            *
!*       34=%LONGREALFN RADIUS(%LONGREAL X,Y)                          *
!*       35=%LONGREALFN ARCTAN(%LONGREAL X,Y)                          *
!*       36=%BYTEINTEGERMAP LENGTH(%STRINGNAME  S)                     *
!*       37=%ROUTINE PRINT STRING(%STRING(255) MESSAGE)                *
!*       38=%INTEGERFN NL                                              *
!*       39=%LONGREALMAP LONG REAL(%INTEGER VAR ADDR)                  *
!*       40=%ROUTINE PRINT CH(%INTEGER CHARACTER)                      *
!*       41=%ROUTINE READ CH(%NAME CHARACTER)                          *
!*       42=%STRINGMAP STRING(%INTEGER VAR ADDR)                       *
!*       43=%ROUTINE READ ITEM(%STRINGNAME ITEM)                       *
!*       44=%STRING(1)%FN NEXT ITEM                                    *
!*       45=%BYTEINTEGERMAP CHARNO(%STRINGNAME STR,%INTEGER CHARREQD)  *
!*       46=%STRING(1)%FN TOSTRING(%INTEGER SYMBOL)                    *
!*       47=%STRING(255)%FN FROMSTRING(%STRING(255)S,%INTEGER BEG,END) *
!*       48=%RECORDMAP RECORD(%INTEGER REC ADDR)                       *
!*       49=%ARRAYMAP ARRAY(%INTEGER A1ADDR,%ARRAYNAME FORMAT)         *
!*       50=%ROUTINE SETMARGINS(%INTEGER INOUT,LHM,RHM)                *
!*       51=%INTEGERFN IMOD(%INTEGER VALUE)                            *
!*       52=%LONGREALFN PI                                             *
!*       53=%INTEGERFN NEXTCH                                          *
!***********************************************************************
         %SWITCH ADHOC(1:12)
         %CONSTINTEGERARRAY SNINFO(0:53)=%C
                    X'41080001',X'41090001',X'408A0001',X'40A00001',
                    X'40010001',X'800D0000',X'11010001',X'11010001',
                    X'10020024',X'41030001',X'19030001',X'80130053',
                    X'12040001',X'408C0001',X'19050024',X'80010049',
                    X'80010053',X'80010053',X'80010053',X'80090053',
                    X'80060053',X'2100003E',X'2100003E',X'11060024',
                    X'80010049'(4),
                    X'80010049'(3),X'80150000',
                    X'2100003E'(2),X'80030049'(2),
                    X'1907003E',X'41070001',X'10080024',X'2100003E',
                    X'41050001',X'19030001',X'2100003E',X'19030001',
                    X'10020024',X'1A07003E',X'11090024',X'800F0000',
                    X'110A8018',X'120B1000',X'80170000',X'11060024',
                    X'100C0024',X'10020024';
!
! SNPARAMS HOLDS NUMBER AND PTYPE OF FORMAL PARAMETER FOR IMPLICITLY
! SPECIFIED EXTERNAL ROUTINES. A POINTER IN SNINFO MEANS THAT NO
! DUPLICATES NEED TO BE RECORDED.
!
         %CONSTSHORTINTEGERARRAY SNPARAMS(0:26)=0,
                    1,32,       2,32,32,  2,32,1,
                    3,32,1,1,   1,1005,   3,1005,1,1,
                    1,1000,     1,1,      3,1,1,1;
!
         %ROUTINESPEC RTOS(%INTEGER REG)
         %BYTEINTEGER ERRNO,FLAG,POINTER
         %SHORTINTEGER OPHEAD,OPBOT
         %INTEGER PIN,SNNO,SNNAME,NAPS,SNPTYPE,JJ,%C
                  XTRA,IOCPEP,B,D,SNINF,P0
!
         SNNAME=A(P)
         SNNO=K;                       ! INDEX INTO SNINFO
         TESTAPP(NAPS);                ! COUNT ACTUAL PARAMETERS
         PIN=P; P=P+1
         SNPTYPE=TSNAME(SNNO)
         SNINF=SNINFO(SNNO)
         XTRA=SNINF&X'FFFF'
         POINTER<-SNINF>>16
         FLAG=SNINF>>24
!
! THE IMPLICITLY SPECIFIED ROUTINE ARE THE EASIEST OF ALL TO DEAL WITH.
! JUST SET UP THE EXTERNAL SPEC & PARAMETERS. THEN A RECURSIVE CALL
! OF CNAME THEN FINDS THE ROUTINE UNDER ITS TRUE COLOURS AND COMPILES
! THE CALL. ALL CALLS EXCEPT THE FIRST ARE DEALT WITH DIRECTLY BY CNAME.
! ALL NONTRIVIAL ROUTINES SHOULD BE DEALT WITH IN THIS MANNER
!
         %IF FLAG&X'80'#0 %THEN %START
            CXREF(0,A(PIN),XTRA,JJ);    ! JJ SET WITH REF DISPLACEMENT
            OPHEAD=0; OPBOT=0; P0=SNPARAMS(POINTER)
            SNDISP=JJ>>2; KFORM=P0
            JJ=1; D=64
            %WHILE JJ<=P0 %CYCLE
               PTYPE=SNPARAMS(POINTER+JJ)
              ! UNPACK
            *L_1,PTYPE; *CVD_1,0(11)
            *UNPK_ROUT(5),5(3,11)
            *NC_ROUT(5),MASK1
               %IF NAM=0 %THEN ACC=BYTES(PREC) %ELSE ACC=4
               BINSERT(OPHEAD,OPBOT,PTYPE,ACC<<16!D,0)
               D=D+ACC
               JJ=JJ+1
            %REPEAT
            I=9; J=14
            OLDI=0; PTYPE=SNPTYPE
            K=OPHEAD
            REPLACETAG(A(PIN))
            P=PIN; CNAME(Z,REG);        ! RECURSIVE CALL
            P=P-2; %RETURN;             ! DUPLICATES CHECK OF <ENAME>
         %FINISH
!
! ALL ROUTINES EXCEPT THE IMPLICITS REQUIRE A CHECH THAT THE USE OF THE
! NAME IS LEGAL AND THAT THE CORRECT NO OF PARAMETERS(BOTTOM 2 BITS OF
! FLAG) HAS BEEN SUPPLIED. THE CHECK IS TRIVIAL - THE PROBLEM
! IS TO GET THE RIGHT ERROR NUMBER.
! XTRA HAS A BITMASK OF ALLOWED USES(IE ALLOWED Z VALUES)
!
         NEST=0
         %IF NAPS#FLAG&3 %THEN ERRNO=19 %AND ->ERREXIT
         JJ=1<<Z
         %IF JJ&XTRA=0 %THEN %START;    ! ILLEGAL USE
            ERRNO=23
            %IF Z=0 %THEN ERRNO=17
            %IF Z=1 %OR 3<=Z<=4 %THEN ERRNO=29
            %IF XTRA&X'F000'#0 %THEN ERRNO=84
            ->ERR EXIT
         %FINISH
!
! A NUMBER OF INPUT-OUTPUT ROUTINES ARE MAPPED ONTO CALLS OF IOCP.
! THIS ARRANGEMENT HAS THE ADVANTAGE OF REQUIRING ONL 1 EXTERNAL REF
! IN THE GLA BUT HAS THE DISADVANTAGE THAT THE I-O ROUTINES CAN NOT
! BE PASSED AS RT-TYPE PARAMETERS AS WELL AS REQUIRING MESSY CODE
! HEREABOUTS.  SNINF_PTR HOLD EITHER:-
!       1) THE IOCP ENTRY POINT NO
!   OR  2) THE SYMBOL TO BE OUTPUT WITH 2**7 BIT SET
!
! THIS SECTION DEALS WITH SELECT INPUT,SELECT OUTPUT,NEWLINE,NEWPAGE
!                         SPACE,SKIP SYMBOL,PRINT SYMBOL,PRINT STRING
!                         AND PRINT CH
!
         %IF FLAG&X'40'#0 %THEN %START
            IOCPEP=POINTER
            %IF FLAG&3#0 %THEN %START;  ! RT HAS PARAMS
               P=P+1
               %IF SNNO=37 %THEN CSTREXP(1,1) %ELSE CSEXP(1,1)
            %FINISH
            %IF IOCPEP>127 %THEN %START
               DUMP(0,1,IOCPEP&127,0,0)
               %IF SNNO=3 %THEN IOCPEP=3 %ELSE IOCPEP=5
            %FINISH
            CIOCP(IOCPEP);              ! PLANT CALL OF IOCP
            ->OKEXIT
         %FINISH
!
! THE BUILT-IN MAPS (INTEGER ETC BUT NOT RECORD OR ARRAY)
! A SPECIAL MODE(13) IN CSEXP ALLOWS ADDR(I) TO BE EVALUATED TO
! A BASE,INDEX &DISP RATHER THAN EVALUATED(IE THE FINAL LA IS OMITTED)
! THIS ENABLES INTEGER(ADDR(I)) TO BE COMPLIED EXTREMELY EFFICIENTLY
!
         %IF FLAG&X'20'#0 %THEN %START
            %IF Z=1 %THEN CYC BITS=CYC BITS!1024 %C
               %AND BIMSTR=1;           ! SPECIAL FLAG FOR STORE VIA MAP
            P=P+1; CSEXP(-1,13); P=P+1
            %IF Z=1 %THEN BIMSTR=0
            %IF NEST>=0 %THEN BASE=NEST %AND INDEX=0 %AND DISP=ADISP
            SNPTYPE=11000+SNPTYPE;      ! ADD MAP BITS
            ->OKEXIT
         %FINISH
!
! ADHOC CODING IS REQUIRED FOR THE REMAINING ROUTINES APART FROM
! A CHECK FOR NAMETYPE PARAMETERS. THE SWITCH NO IS KEPT IN POINTER
!
         %IF FLAG&3#0 %THEN P=P+1
         %IF FLAG&8#0 %AND(A(P+2)#4 %OR A(P+3)#1 %OR %C
            A(P+A(P+1)+1)#2) %THEN ERRNO=22 %AND ->ERREXIT
         ->ADHOC(POINTER)
ADHOC(1):                               ! NEWLINES(=6) & SPACES(=7)
         CSEXP(2,1);                    ! REPITITION NO TO GR2
         %IF SNNO=6 %THEN JJ=10 %ELSE JJ=32
         PRX(X'41',1,0,0,JJ);           ! LA 1,SYMBOL
         PPJ(14);                       ! PERM OPUTS R1 R2 TIMES
         ->OKEXIT
ADHOC(2):                               ! NEXTSYMBOL(=8) & NEXTITEM(=44)
                                        ! AND NEXTCH=53
         SAVE IRS(4);                   ! PRESERVE ANY INTERMEDIATES
         CLAIM THIS REG(0);             ! FORCE PRESERVATION OF GR0
         FREE AND FORGET(0);            ! SINCE THESE FNS CAN BE IN EXPN
         %IF SNNO=53 %THEN JJ=18 %ELSE JJ=2
         CIOCP(JJ);                     ! LEAVES THE SYMBOL IN GR1
         %IF SNNO#44 %THEN %START;       ! NEXT SYMBOL
            %IF 1#REG>=0 %THEN PRR(X'18',REG,1) %ELSE NEST=1
         %FINISH %ELSE RTOS(1);         ! CONVERT R1 TO STRING
         ->OKEXIT
ADHOC(3):                               ! READSYMBOL(=10),CH(=41)&ITEM(=43)
         %IF SNNO=41 %THEN JJ=4 %ELSE JJ=1
         CIOCP(JJ);                     ! SYMBOL OR CH TO GR1
         P=P+4
         %IF SNNO=43 %THEN TYPE=5 %AND RTOS(1) %ELSE %START
            REGISTER(1)=1; TYPE=1
            BASE=1; DISP=-2
         %FINISH
         JJ=TYPE
         COPYTAG(A(P));                  !PARAMETER NAME
         %IF TYPE # JJ %THEN %START
           ERRNO = 22
           -> ERREXIT
         %FINISH
         ASSIGN(6,P);                   ! BY '=' TO PARAMETER
         P=PIN+4+A(PIN+3)
         ->OKEXIT
ADHOC(4):                               ! WRITE(=12). SHOULD BE EXTERNAL
         DSEXP(1,1)
         REGISTER(1)=0; REGISTER(2)=0
         PPJ(4)
         ->OKEXIT
ADHOC(5):                               ! ADDR(=14)
         P=P+4; CNAME(4,REG);           ! FETCH ADDRESS MODE
         P=P+1; ->OKEXIT
ADHOC(6):                               ! MOD(=23), IMOD(=51)
         %IF SNNO=51 %THEN JJ=1 %ELSE JJ=3
         CSEXP(REG,JJ);                 ! INTEGER OR LONGREAL MODE
         %IF SNNO=51 %THEN JJ=0 %ELSE JJ=16
         REG=NEST
         PRR(X'10'+JJ,REG,REG);         ! LP(D)R REG,REG
         FORGET(REG+JJ)
         ->OKEXIT
ADHOC(7):                               ! CHARNO(=45) & LENGTH(=36)
         P=P+4; COPY TAG(A(P))
         %IF ROUT=0=NAM %AND ARR=0 %AND A(P+1)=2=A(P+2) %START
            P=P+3; BASE=I; DISP=K
         %FINISH %ELSE %START
            FINDREG(SAFE,JJ)
            CNAME(4,JJ)
            BASE=JJ; DISP=0
         %FINISH
         P=P+2
         ERRNO=22; ->ERREXIT %UNLESS TYPE=5
         %IF SNNO=36 %THEN INDEX=0 %ELSE %START
            D=DISP; B=BASE
            REGISTER(B)=1 %IF REGISTER(B)=0
            CSEXP(-1,5)
            P=P+1
            REGISTER(B)=0 %IF REGISTER(B)=1
            DISP=D+ADISP; BASE=B
            INDEX=NEST
         %FINISH
         SNPTYPE=SNPTYPE+11000
         ->OKEXIT
ADHOC(12):                              ! PI(=52)
ADHOC(8):                               ! NL(=38). THIS FN IS PICKED OFF
         NEST=0;                        ! IN CSEXP.ONLY COMES HERE IN
         PTYPE=SNPTYPE;! UNPACK
            *L_1,PTYPE; *CVD_1,0(11)
            *UNPK_ROUT(5),5(3,11)
            *NC_ROUT(5),MASK1
         NAM=2; ROUT=1
         ->OKEXIT;                      ! ERROR EG NL=A+B
ADHOC(9):                               ! TOSTRING(=46)
         CSEXP(-1,1);                   ! RET EXPSN
         RTOS(NEST)
         INDEX=0; ->OKEXIT
ADHOC(10):                              ! RECORD(=48)
         CSEXP(REG,1)
         REG=NEST %IF REG<0
         REGISTER(REG)=1 %IF REGISTER(REG)>=0
         ->OKEXIT
ADHOC(11):                              ! ARRAY(=49)
         %UNLESS 4<=REG<=14 %THEN FINDREG(SAFE,REG)
         CSEXP(REG,1);                  ! ADDR(A(0)) TO GR REG
         REGISTER(REG)=1
         ERRNO=22
         ->ERREXIT %UNLESS A(P+3)=4 %AND A(P+4)=1
         P=P+5; CNAME(12,0)
         ->ERREXIT %UNLESS A(P)=2 %AND ARR>0
         CREATE AH(0,REG,BASE,DISP)
         ARR=1;                              ! ERRORS REPORTED IF ARR=3
         REGISTER(REG)=0
         %RETURN
OKEXIT:                                 ! NORMAL EXIT
         PTYPE=SNPTYPE;! UNPACK
            *L_1,PTYPE; *CVD_1,0(11)
            *UNPK_ROUT(5),5(3,11)
            *NC_ROUT(5),MASK1
         %RETURN
ERREXIT:                                ! ERROR EXIT
         FAULT(ERRNO,SNNAME)
         BASE=0; DISP=0; INDEX=0
         P=PIN+1; SKIP APP
         PTYPE=SNPTYPE;! UNPACK
            *L_1,PTYPE; *CVD_1,0(11)
            *UNPK_ROUT(5),5(3,11)
            *NC_ROUT(5),MASK1
         P=P-1; %RETURN
         %ROUTINE RTOS(%INTEGER REGNO)
!***********************************************************************
!*       PLANTS CODE TO CONVERT A SYMBOL IN REGNO TO A ONE             *
!*       CHARACTER STRING IN A TEMPORARARY VARIABLE.                   *
!***********************************************************************
         %INTEGER KK
         GET WSP(KK,1);               ! GET 1 WORD WK AREA
         STRINGL=1; DISP=KK+2
         DUMP(X'50',REGNO,KK,0,RBASE)
         DUMPSI(X'92',1,RBASE,DISP);  ! MVI LENGTH BYTE
         BASE=RBASE; INDEX=0
         %END
         %END;                        ! OF ROUTINE CSNAME
         %ROUTINE     CIOCP(%INTEGER N)
         %INTEGER AT
         %IF IOCP1<10 %THEN %START
            CXREF(0,-1,0,AT);             ! INSERT IOCP XREF
            IOCP1=AT
         %FINISH
         PCONST(X'41000000'!N)
         CRCALL(-1)
         %END
         %ROUTINE LOAD DV(%INTEGER %NAME REG,%INTEGER B,D,TN)
         %SHORTROUTINE
!***********************************************************************
!*       FIND A REGISTER AND LOAD IT WITH POINTER TO D.V. B,D FOR      *
!*       ARRAYHEAD   TN=TAGS(NAME). NECESSARY TO PASS B&D ALSO IN CASE *
!*       OF ARRAYNAMES IN RECORDS WHEN TN<0. NO CHECK IS MADE THAT NAME*
!*       IS CORRECTLY DEFINED                                          *
!***********************************************************************
         %INTEGER R
         R=-1
         %IF TN>0 %THEN FIND USE(R,1,10,TN)
         %IF R<=0 %THEN %START;       ! REGISTER MUST BE SET
            FIND REG(ADDREG,R)
            DUMP(X'58',R,D+8,0,B)
            %IF TN>0 %THEN SET USE(R,10,TN) %ELSE FORGET(R)
         %FINISH
         REG=R
         %END
         %ROUTINE     CANAME(%INTEGER ARRP,BS,DP,BASIC DISP)
!***********************************************************************
!*       BS & DP DEFINE THE POSITION OF THE ARRAY HEAD                 * 
!*       ARRP=1 FOR ARRAYS,2 FOR VECTORS,3 FOR ARRAYS IN RECORDS       *
!*       BASIC DISP = DISPMNT OF A(0) FOR VECTORS OR ARRAYS IN RECORDS *
!*       IN-LINE CODE IS PLANTED IF PARM=NOARRAY IS REQUESTED          *
!*       OTHERWISE CALLS ARE MADE ON CHECKING SUBROUTINES IN PERM      *
!***********************************************************************
         %SHORTROUTINE
         %INTEGER DVREG,OPTYPE
         %SHORTINTEGER HEAD1,HEAD2,HEAD3,NOPS,BOT1,BOT2,BOT3
         %INTEGER PTYPEP,KK,RR,PP,JJ,JJJ,XTYPE,TYPEP,ARRNAME
         %INTEGER KKK,DIS,Q,PRECP,ELSIZE,BASEREG,NAMINF
         PP=P; TYPEP=TYPE
         JJ=J; PTYPEP=PTYPE; PRECP=PREC
         %IF TYPE<=2 %OR TYPE=6 %THEN ELSIZE=BYTES(PRECP) %C
                                %ELSE ELSIZE=ACC
         ARRNAME=A(P);                   ! NAME OF ENTITY
         NAMINF=TAGS(ARRNAME)
         FAULT(29,ARRNAME) %IF ARR=3;    ! ARRAYFORMAT USED AS ARRAY
         NAMINF=-2 %IF ARRP>2 %OR TYPE=6;! SWITCHES&ARRAYS IN RECORDS 
         ARRP=ARRP&X'F';                 ! NOT OPTIMISED
         TEST APP(Q);                    ! COUNT NO OF SUBSCRIPTS
!
! CHECK CORRECT NO OF SUBSCRIPTS PROVIDED. HOWEVER ENTITIES DECLARED
! AS %<TYPE>ARRAYNAME HAVE NO DIMENSION . THIS SECTION SETS THE
! DIMENSION FROM THE FIRST USE OF THE NAME.
!
         %IF JJ=0 %THEN %START;        ! 0 DIMENSIONS = NOT KNOWN
            REPLACE1(TCELL,FROM1(TCELL)!Q);! DIMSN IS BOTTOM 4 BITS OF TAG
            JJ=Q
         %FINISH
         %IF JJ>2 %THEN CYC BITS=CYCBITS!128; ! XTRA REG FOR DV BASE
         %IF JJ=Q#0 %AND CHECKS=0 %THEN %START;  ! IN LINE CODE
!
! FOR IN-LINE CODE WE SET UP A CHAIN OF REVERSE POLISH OPERATIONS TO
! EVALUATE THE VARIOUS SUBSCRIPTS,MULTIPLY BY THE MULTIPLIERS AND
! ADD THEM TOGETHER. THE FINAL OPERATION IS TO CONVERT FROM ELEMENTS
! TO BYTES. THIS LAST OPERATION IS DONE FIRST.
!
         *XC_DVREG(16),DVREG;          ! CLEAR LISTHEADS
         XTYPE=0; BOT3=0
         %IF PRECP#1 %THEN %START;     ! BYTE ARRAYS - NO FINAL MULTIPLY
            XTYPE=1;                   ! NOTE 1 XTRA OPERATION
            %IF TYPEP=5 %AND NAM#0 %THEN %START; ! ELSIZE NOT KNOWN
               OPTYPE=3; JJJ=BS
               KKK=DP<<16!2;           ! OPERAND 2ND HALFWORD OF DP
               ELSIZE=0
            %FINISH %ELSE %START;      ! ELSIZE KNOWN
                OPTYPE=0; JJJ=0
                KKK=ELSIZE;            ! OPERAND A CONSTANT
            %FINISH
            PUSH(HEAD3,28,0);          ! OPERATOR  (=MH)
            %IF BOT3=0 %THEN BOT3=HEAD3
           PUSH123(HEAD3,((OPTYPE&1)*20+1)<<16!JJJ<<8!OPTYPE,KKK,NAMINF)
         %FINISH
!
! NOW PROCESS THE SUBSCRIPTS CALLINR TORP TO CONVERT THE EXPRESSIONS
! TO REVERSE POLISH AND ADDING THE EXTRA OPERATIONS. IF THE FIRST
! SUBSCRIPT IS A CONSTANT AND THE ITEM LENGTH IS KNOWN AT COMPLIE TIME
! THE OPERATION CAN BE SUPPRESSED AND THE CONSTANT TRANSFERRED TO THE
! DISPLACEMENT FIELD OF THE FINAL INSTRUCTION. THIS SAVES 8 BYTES.
! A SPECIAL MODE (5) FOR TORP TRANSFERS ANY CONSTANT TO GLOBAL ADISP
!
         P=PP+2; JJJ=5;                ! MODE FOR TORP FOR 1ST EXPRSN
         %IF TYPEP=5 %AND ELSIZE=0 %THEN JJJ=1; ! ADDR OR NORMAL MODE
         %CYCLE KK=1,1,JJ;             ! THROUGH THE SUBSCRIPTS
            P=P+2; BOT2=0
            TORP(HEAD2,BOT2,NOPS,JJJ); ! SUBSCRIPT TO REVERSE POLISH
            P=P+1
!
! TWO DIMENSION ARRAYS HAVE THE MULTIPLIER IN WORD 4 OF HEAD
! ALL OTHER MULTIPLIERS ARE DOPE VECTOR ITEMS (OPTYPE=3)
!
            %IF JJ=2 %THEN OPTYPE=9 %AND RR=DP+14 %ELSE %START
               OPTYPE=3; RR=(12*KK-10)!(DP<<16)
            %FINISH
!
! N SUBSCRIPTS WILL REQUIRE (N-1) MULTIPLICATIONS AND ADDITIONS
!
            %IF KK>1 %THEN %START
               NOPS=NOPS+2
               PUSH(HEAD3,15,0) %IF HEAD1#0;! 15=ADD
               %IF BOT3=0 %THEN BOT3=HEAD3
!
! N.B. THE FIRST SUFFIX CAN BE OPTIMISED OUT OF EXISTENCE IF IT IS
! A SHORT CONSTANT AND THE CORRESPONDING ADDITION MUST THEN BE OMITTED
!
               PUSH(HEAD3,28,0);       ! MH
               %IF BOT3=0 %THEN BOT3=HEAD3
               PUSH123(HEAD3,21<<16!BS<<8!OPTYPE,RR,NAMINF);! MULTIPLIER
            %FINISH %ELSE DIS=ADISP*ELSIZE
            JJJ=1;                     ! SBSCRPTS XCEPT 1ST NORMAL MODE
!            CONCAT (HEAD1,HEAD2);      ! OPERANDS TO MAIN LIST
            %IF HEAD1=0 %THEN HEAD1=HEAD2 %ELSE %C
               SHORTINTEGER(ADDR(ASLIST(BOT1))+14)=HEAD2
            BOT1=BOT2; HEAD2=0
         %REPEAT
!
! ADD OPERATORS TO THE BACK OF OPERANDS AND EVALUATE
!
         CLEAR LIST(HEAD3) %IF HEAD1=0;! THROW AWAY OPERATORS IF NO OPND
!         CONCAT(HEAD1,HEAD3);          ! OPERATORS  LINKED ON
         %IF HEAD3#0 %START
            SHORTINTEGER(ADDR(ASLIST(BOT1))+14)=HEAD3
            BOT1=BOT3
         %FINISH
         PP=P; NOPS=NOPS+XTYPE
         EXPOP(HEAD1,-1,NOPS,5);       ! EVALUATE THE REVERSE POLISH LIST
         P=PP
         DISP=DIS; INDEX=NEST
!
! REGISTER INDEX AND DSIPLACEMENT NOW DEFINE THE ARRAY RELATIVE POSITION
! OF REQUIRED ELEMENT. ALL THAT REMAINS IS TO SET UP OR FIND A SUITABLE
! BASE REGISTER TO POINT TO A(0).
!
!         CLEAR LIST(HEAD1);            ! RETURN SPACE
         %IF HEAD1#0 %START
            SHORTINTEGER(ADDR(ASLIST(BOT1))+14)=ASL
            ASL=HEAD1
         %FINISH
         %IF ARRP>=2 %THEN %START;     ! VECTOR ACCESED VIA LEVEL POINTER
            DISP=DISP+BASIC DISP
            BASE=BS
         %FINISH %ELSE %START
            FIND USE(BASE,1,8,NAMINF)
            %IF BASE<=0 %START;        ! BASE REG NOT ALREADY SET
               REGISTER(INDEX)=1 %IF INDEX#0 %AND REGISTER(INDEX)=0
               FIND REG(ADDREG,BASE)
               DUMP(X'58',BASE,DP,0,BS);!  L  BASE,=A(A(0))
               REGISTER(INDEX)=0 %IF INDEX#0 %AND REGISTER(INDEX)>0
               %IF NAMINF <0 %THEN FORGET(BASE) %ELSE %C
                                  SET USE(BASE,8,NAMINF)
            %FINISH
         %FINISH
         %FINISH %ELSE %START
         %IF JJ#Q %OR Q=0 %THEN %START;! DIMENSIONALITY ERROR
            FAULT(19,ARRNAME)
            P=P+1; SKIP APP
            BASE=15
         %FINISH %ELSE %START
!
! THREE DIFFERENT SUBROUTINES ARE USED:-
! PERM7 CHECKS SWITCHES WITH GR1 HOLDING SUFFIX &GR2 POINTING AT VECTOR
! PERM23 CHECKS 1D ARRAYS. GR1 HAS SUFFIX & GR3 POINTS TO ARRAYHEAD
! PERM24 CHECKS MULTI-DIMENSION ARRAYS. GR1 POINT TO BACK OF LIST OF
!         SUFFICES AND GR2 POINT TO ARRAYHEAD
!
            DIS=0; P=PP+2
            CLAIM THIS REG(1);         ! FORCE PRESERVATION OF CONTENTS
            REGISTER(1)=0
            %IF JJ=1 %THEN %START;     ! 1D+SWITCHES
               CSEXP(1,1); P=P+1
            %FINISH %ELSE %START
                                       ! MULTI-DIMENSION 
               GET WSP(RR,JJ)
               %CYCLE PP=0,1,JJ-1;     ! THROUGH LIST OF SUFFICES
                  CSEXP(-1,1); P=P+1;  ! EVALUATE SUFFIX
                  DUMP(1,NEST,RR+PP<<2,0,RBASE);! AND PUT INTO WK-AREA
               %REPEAT
               DUMP(0,1,RR+PP<<2,0,RBASE);!LA  1,<BACK OF WORK AREA>
               FORGET(1)
            %FINISH
            %IF JJ=1 %AND TYPEP#6 %THEN JJJ=3 %ELSE JJJ=2
            REGISTER(1)=1;             ! PROTECT REG ALREADY SET
            CLAIM THIS REG(JJJ)
            REGISTER(JJJ)=0
            %IF TYPEP=6 %THEN BS=0 %AND DP=BASIC DISP;!SWITCHES SPECIAL
            DUMP(0,JJJ,DP,0,BS);       ! ADDR HEAD TO GR3(1D) OR GR2(MD)
            %IF TYPEP=6 %THEN PRX(X'5A',2,GLA,0,0) %AND JJJ=19
            REGISTER(1)=0
            PPJ(26-JJJ);               ! TO CHECKING SUBROUTINE
            BASE=15
            %IF ARRP=3 %THEN PRR(X'1A',1,15) %AND BASE=0
         %FINISH
         INDEX=1; DISP=0
         %FINISH
         ACC=ELSIZE
         PTYPE=PTYPEP;! UNPACK
            *L_1,PTYPE; *CVD_1,0(11)
            *UNPK_ROUT(5),5(3,11)
            *NC_ROUT(5),MASK1
         J=JJ
         %END;                         ! OF ROUTINE CANAME

%ROUTINE CNAME(%INTEGER Z, REG)
!***********************************************************************
!*       THIS IS THE MAIN ROUTINE FOR PROCESSING NAMES.CANAME,CSNAME   *
!*       AND CRNAME ARE ONLY CALLED FROM HERE,THE NAME (AND ANY PARAMS *
!*       OR SUBNAMES) ARE INDEXED BY P WHICH IS ADVANCED.              *
!*       Z SPECIFIES ACTION AS FOLLOWS:-                               *
!*       Z=0 COMPILE A ROUTINE CALL                                    *
!*       Z=1 SET BASE,INDEX AND DISP FOR A 'STORE' OPERATION           *
!*       Z=2 FETCH NAME TO 'REG'                                       *
!*       Z=3 SET ADDR(NAME) IN REG FOR PASSING BY NAME (TOP BYTE SET)  *
!*       Z=4 AS FOR Z=3 BUT TOP BYTE MUST BE CLEAR (USED FOR 'ADDR' FN)*
!*       Z=5 IF NAME IS IN A REGISTER THEN AS Z=2 ELSE SET BASE ETC    *
!*       Z=6 STORE 'REG' (CONTAINS POINTER) INTO POINTER VARIABLE      *
!*       Z=7->11  NOT NOW USED                                         *
!*       Z=12 SET BASE AND DISP TO POINT TO ARRAYHEAD                  *
!*       Z=13 SET REG TO POINT TO 4 WORD ROUTINE DISCRIPTOR            *
!*              (INTERNAL ROUTINES FIRST CREATE THE DISCRIPTOR)        *
!*       Z=14 STORE 'REG' INTO A RECORD NAME VARIABLE                  *
!*       Z=15 SET 'REG' TO POINT TO A RECORD                           *
!*       Z=16 SET BASE AND DISP (BUT NOT INDEX) FOR RECORD             *
!*                                                                     *
!*       REG (WHERE APPROPRIATE) IS SET AS FOLLOWS:-                   *
!*       >=0  A REGISTER                                               *
!*       -1   MEANS CHOOSE ANY REGISTER                                *
!*       -2   MEANS CHOOSE ANY REGISTER EXCEPT GR0                     *
!*       IF A REGISTER IS CHOSEN THEN NEST IS SET WITH CHOICE          *
!***********************************************************************
%INTEGER JJ, JJJ, KK, RR, LEVELP, DISPP, REGP, NAMEP, PP, SAVESL,  %C
            FNAME
%LONGREAL WORK
%SWITCH S, FUNNY(12:16), SW(0:8), MOD(0:7)
         FNAME=A(P)
2:       TCELL=TAGS(FNAME)
         *L_1,TCELL; *LTR_1,1; *BC_8,<4>
         *XC_PTYPE(20),PTYPE
         *A_1,ASLIST
         *UNPK_WORK(5),2(3,1)
         *LH_0,0(1,0)
         *ST_0,PTYPE
         *MVN_USEBITS+3(1),WORK
         *MVN_OLDI+3(1),WORK+1
         *MVN_I+3(1),WORK+2
         *MVN_J+3(1),WORK+3
         *OI_2(1),X'80';                ! SET USE BIT
         *MVC_SNDISP(8),4(1)
         *CVD_0,WORK
         *UNPK_ROUT(5),WORK+5(3)
         *NC_ROUT(5),MASK1
         SAVESL=ACC
         %IF CSSMODE=0 %AND ROUT=0 %THEN OPTSAVE(2,Z,PTYPE,FNAME)
         ->3
4:       FAULT(16, FNAME)
         I=LEVEL;  J=0;  K=FNAME
         PTYPE=7;  STORE TAG(K, N)
         K=N;  N=N+4;  ->2
3:       JJ=J;  JJ=0 %IF JJ=15
         NAMEP=TCELL
         LEVELP=I;  DISPP=K
         FAULT(29, FNAME) %IF PREC>3 %AND             %C
                    (Z=1 %OR ((Z=3 %OR Z=4) %AND ARR=0))    %AND REG#99
         PREC=PREC&3
         ->502 %IF TYPE=7
         ->500 %IF Z=0 %AND (ROUT#1 %OR 0#TYPE#6)
         ->FUNNY(Z) %IF Z>=10
         ->RTCALL %IF ROUT=1
         ->SW(TYPE)
500:
         FAULT(17, FNAME) %UNLESS TYPE=7;  ->502
SW(6):

SW(4):                                  !RECORD FORMAT NAME
         FAULT(20, FNAME)
SW(7):

502:     P=P+1;                         ! NAME NOT SET
         NEST=0;  BASE=I;  DISP=K;  INDEX=0
         PTYPE=1; ! UNPACK
            *L_1,PTYPE; *CVD_1,0(11)
            *UNPK_ROUT(5),5(3,11)
            *NC_ROUT(5),MASK1
         SKIP APP;  ->1
FUNNY(12):                              ! SET BASE & DISP FOR ARRAYHEAD
         ->SW(3) %IF TYPE=3 %AND (ARR=0 %OR A(P+1)=1)
         ->1202 %IF PTYPE=SNPT
         BASE=I;  INDEX=0;  DISP=K
S(12):                                  ! ARRAYS IN RECORDS BY NAME
         FAULT(219, FNAME) %UNLESS INDEX=0
         %UNLESS 0<=DISP<=4095 %THEN ADJUST INDEX(0, BASE, DISP)
         ->91
1202:    CSNAME(12, REG);  ->91
FUNNY(13):                              ! LOAD ADDR FOR RT-TYPE
         %IF PTYPE=SNPT %THEN ->1302
         ->500 %UNLESS ROUT=1
         DISP=4*(SNDISP&X'FFFF')
         %IF NAM&1#0 %THEN %START
            BASE=I; JJJ=X'58'
         %FINISH %ELSE %START
            %IF J=14 %THEN BASE=GLA %ELSE %START;! INTERNAL
               GET WSP(DISP, 4)
               JJJ=14;  %IF REGISTER(14)#0 %THEN FIND REG(GR1, JJJ)
               RT JUMP(X'41', JJJ, TCELL, JJJ)
               DUMPM(X'90', 12, 13, RBASE, DISP)
               PRX(X'50', JJJ, 0, RBASE, DISP+8)
               PRX(X'50', WSPR, 0, RBASE, DISP+12)
               BASE=RBASE
               FORGET(JJJ)
            %FINISH
            JJJ=X'41'
         %FINISH
         DUMP(JJJ, REG, DISP, 0, BASE)
         NEST=REG %IF REG>=0;  ->91
1302:    CSNAME(Z, REG);  ->6
S(14):   FAULT(67, FNAME) %UNLESS TYPE=3 %AND ARR=0
         P=P-2;  ->602
1401:    FAULT(67, FNAME) %UNLESS TYPE=7;  ->502
S(16):

S(15):   ->1401 %UNLESS TYPE=3
         P=P+1
         %IF Z=16 %AND INDEX=0 %AND DISP<=4095 %AND NAM=0 %THEN ->9005
         P=P-3;  KK=3;  ->605 %IF Z=15
         KK=1;  ->605 %IF NAM=1
         DUMP(0, REG, DISP, INDEX, BASE)
         REG=NEST %IF REG<0
         DISP=0;  INDEX=0;  BASE=REG
         FORGET(REG);  P=P+3;  ->9005
FUNNY(15):                              ! FETCH RECORD NAME
         ->1302 %IF PTYPE=SNPT
FUNNY(16):                              ! SET BASE & DISP
FUNNY(14):                              ! STORE INTO RECORD NAME
         PP=P;  ->1401 %UNLESS TYPE=3
SW(3):                                 ! RECORD
         %IF NAM=1 %AND ARR=0 %THEN JJJ=1 %ELSE JJJ=0
         CRNAME(Z, REG, JJJ, NAMEP, I, 0, K)
         ->S(Z) %IF Z>=10
         ->5020 %IF TYPE=5
         ->502 %IF TYPE=7
         ->601
SW(5):                                  ! TYPE =STRING
!        1) STRINGS ARE NEVER IN REGISTERS
!        2) BML &DML MUST BE SET ON Z=1
!        3) TOP BYTE MUST BE SET ON Z=3
!        4) TOP BYTE MUST BE CLEARED  ON Z=4
         ->STRARR %IF ARR>=1
         BASE=I;  INDEX=0;  DISP=K
5001:    %IF NAM=1 %THEN %START
            BML=BASE;  DML=DISP;        ! LMAX IN TOP BYTE OF POINTER
         %FINISH %ELSE %START
            BML=-1;  DML=SAVESL-1
         %FINISH
5002:    ->601 %UNLESS Z=3 %AND NAM=0
         DUMP(0, REG, DISP, INDEX, BASE)
         REG=NEST %IF REG<0
         FORGET(REG);  JJJ=DML<<24
         STORE CONST(JJ, KK, 4, ADDR(JJJ))
         REGP=REGISTER(REG); REGISTER(REG)=1
         DUMP(X'56', REG, KK, 0, JJ);   !  0  REG,=MAXL<<24
         REGISTER(REG)=REGP
         ->9
STRARR:                                 ! STRINGARRAYS & 
                                        !STRINGARRAYNAMES
         CANAME(ARR, I, K, SNDISP)
         BML=-1;  DML=SAVESL-1
5111:    %IF NAM=1 %AND (Z=1 %OR Z=3) %THEN %START
            %IF Z=1 %THEN %START
               REGISTER(BASE)=1 %IF REGISTER(BASE)=0
               REGISTER(INDEX)=1
            %FINISH %ELSE %START
               DUMP(0, REG, DISP, INDEX, BASE)
               REG=NEST %IF REG<0
               FORGET(REG)
               REGISTER(REG)=1
            %FINISH
            LOAD DV(RR, LEVELP, DISPP, NAMEP)
            FINDREG(GR0, JJ);  FORGET(JJ)
            DUMP(X'58', JJ, 0, 0, RR);  ! LOAD ITEM LENGTH
            PRR(6, JJ, 0);              ! BCTR  TO TAKE 1 OFF
            %IF Z=1 %THEN %START
               PRX(X'42', JJ, WSPR, 0, 0);   ! STC  LMAX,0(WSPR)
               BML=WSPR;  DML=0
               REGISTER(BASE)=0 %IF REGISTER(BASE)>0
               REGISTER(INDEX)=0
            %FINISH %ELSE %START
               PRX(X'89', JJ, 0, 0, 24);! SLL 24
               PRR(X'16', REG, JJ);     ! OR REG,JJ
               REGISTER(REG)=0
            %FINISH
            ->9
         %FINISH
         NAM=0;  ->5002;                ! ORDINARY ARRAYS ACC KNOWN
5020:                                   ! STRINGS IN RECORDS
         NAMEP=-1;  SAVESL=ACC
         LEVELP=BML;  DISPP=DML;        ! SET BY CRNAME TO ARRAYHEAD
         ->5111 %IF ARR=1;              ! NOW AS NORMAL STRINGARRAYS
         %IF NAM=1 %AND INDEX>0 %THEN %START
            PRR(X'1A', INDEX, BASE);    ! VERY MESSY  STRINGNAME IN A
            FORGET(INDEX);  BASE=INDEX; ! RECORDARRAY MUST MAKE LMAX
            CCSTATE=-1
            INDEX=0
         %FINISH;                       ! BYTE DIRECTLY ADDRESSABLE
         ->5001;                        ! NOW AS NORMAL STRINGS
SW(8):                                  ! REGISTER VARIABLE
         FAULT(29, FNAME) %UNLESS Z=2 %OR Z=5 %OR KFORM#M'RG'
                                        !ONLY FETCH MAKES SENSE
         ABORT %IF REGISTER(K)>=0
         %IF Z=1 %OR 3<=Z<=4 %THEN K=SNDISP %AND ->600
         %IF REG<0 %THEN NEST=K %ELSE %START
            PRR(X'18', REG, K) %UNLESS REG=K
         %FINISH
         ->9
! SECTION TO DEAL WITH ALL NAMES INVOLVING ROUTINE CALL
RTCALL:                                 ! FIRST CHECK
         %IF TYPE=0 %AND Z#0 %THEN FAULT(23, FNAME) %AND ->502
                                        ! RT NAME IN EXPRSN
         %IF PTYPE=SNPT %THEN %START
            CSNAME(Z, REG);             ! SPECIAL NAME
            ->202 %IF ROUT=1 %AND NAM>=1 %AND Z#0
            ->6
         %FINISH
         %IF KFORM&4095=1000 %THEN FAULT(21, FNAME) %AND ->502
                                        ! USE BEFORE %SPEC GIVEN
         CRCALL(TCELL);  P=P+1;        ! DEAL WITH PARAMS
         ->1 %IF PTYPE=10000 %OR PTYPE=11000
         ->201 %IF NAM>1;               ! MAPS
         %UNLESS Z=2 %OR Z=5 %THEN %START;   ! FUNCTIONS
            FAULT(29, FNAME);  BASE=0
            INDEX=0;  DISP=0
         %FINISH
         ->STRFUN %IF TYPE=5;  P=P-2
         %IF TYPE=2 %THEN REGP=2 %AND JJ=18 %ELSE REGP=1 %AND JJ=1
         NAMEP=0;  ->SWOP
STRFUN:  DISP=0;  INDEX=0;  BASE=1;  ->1
201:                                    ! USER DEFINED MAPS
         DISP=0;  INDEX=0;  BASE=1
202:                                    ! BUILT IN MAPS
         %IF PREC = 2 %THEN WARN(LINE)
         NAM=0;  NAMEP=0;  P=P-2
         %IF TYPE#5 %THEN ->601
         BML=-1;  DML=255;              ! STRING MAPS
         ->5002
SW(0):                                  ! %NAME PARAMETERS NO TYPE
                                        ! ALLOW FETCH ADDR OPERATIONS
                                        ! AND SPECIAL FOR BUILTIN MAPS
         %UNLESS 3<=Z<=4 %OR (Z=1 %AND REG=99) %THEN %START
            FAULT(12, FNAME);  TYPE=1
         %FINISH
SW(1):                                  ! TYPE =INTEGER
SW(2):                                  ! TYPE=REAL
         ->600 %IF ARR=0
         CANAME(ARR, I, K, SNDISP)
         NAM=0;  ->601
!
                                        ! GENERAL FETCHING & STORING 
                                        !SECTION
600:     BASE=I;  INDEX=0;  DISP=K
601:     ->602 %IF Z=6
         JJJ=Z;  JJJ=JJJ-3 %IF JJJ>3
         JJJ=TYPE<<3+2*(PREC&3)+JJJ-8
         KK=Z;  KK=2 %IF Z=5
605:     NAMEP=0 %UNLESS INDEX=0 %AND DISP=DISPP %AND BASE=LEVELP
         ->MOD(NAM<<2!KK&3)
602:     FAULT(17, FNAME) %IF NAM=0
         DUMP(1, REG, DISP, INDEX, BASE);  ->9
MOD(1):                                 ! SCALAR STORE
         ->9
MOD(2):                                 ! SCALAR FETCH
MOD(6):                                 ! SCALARNAME FETCH
         ->610 %IF NAMEP=0 %OR CHECKSP#0
! HAVE A SIMPLE NAME SO LOOK AT REGISTER POINTED AT BY REGP TO SEE
! IF THE LOAD (&UNASSIGNED CHECK) CAN BE AVOIDED
         FIND USE(JJ, TYPE&3, 3, NAMEP)
         ->610 %IF JJ<0;  REGP=JJ&15
! HAVE FOUND VARIABLE IN REGISTER. MANOEVRE IT TO REQUIRED REGISTER
SWOP:
         %IF REG<0 %THEN %START
            %IF REGISTER(JJ)=0 %THEN %START
               NEST=REGP;  ->9
            %FINISH;                    ! CAN USE IT AS FOUND
            %IF JJ>=16 %THEN FIND REG(FR0, REG) %C
               %ELSE FINDREG(GR0, REG)
         %FINISH
! MOVE TO NEW REGISTER ALLOWING FOR STRINGS AND ALL TYPES OF ADDRESSES
         %IF REG#REGP %THEN %START
            PRR((JJ>>4+1)<<4+8, REG, REGP);  ! LR OR LDR
            KK=GRUSE(JJ)
            JJ=JJ&16!REG
            FORGET(JJ);                 ! REMEMBER ORIGINAL REGISTER
            %IF NAMEP>0 %AND REGISTER(JJ)>=0 %C
               %THEN SET USE(JJ, KK, NAMEP)
         %FINISH
         NEST=REG;  ->9
610:     ->NAMETYPE %IF NAM=1
GENFETCH:->DELAY %IF Z=5 %AND (UNASS=0 %OR 1<=PREC<=2)
         ->DELAY %IF TYPE=5
         DUMP(JJJ, REG, DISP, INDEX, BASE)
         REG=NEST %IF REG<0
         %IF UNASS=1 %AND Z#3 %AND BASE#GLA %AND 1<=TYPE<=2 %C
            %AND (PREC=0 %OR PREC=3) %THEN %START
            PRX((TYPE-1)*(2-PREC>>1)*16+X'59', REG, 0, CODER, 216)
            CCSTATE=-1
            PCONST(X'4780C028')
         %FINISH;                       ! BE UNASS VAR USED
         %IF NAMEP=0 %THEN JJJ=1 %ELSE JJJ=3
         %IF JJJ=1 %AND PREC=1 %THEN JJJ=2 %AND NAMEP=-2
!         SET USE((TYPE&2)<<3+REG, JJJ, NAMEP)
         KK=(TYPE&2)<<3+REG
         CCSTATE=-1 %IF CCSTATE&255=KK
         %IF REGISTER(KK)>=0 %THEN GRUSE(KK)=JJJ %AND GRINF(KK)=NAMEP
         GRAT(KK)=CA
         ->9
DELAY:   NEST=-1;  ->9
MOD(4):                                 ! SCALAR NAME FETCH ADDR
MOD(7):                                 ! SACALR NAME FETCH POINTER
         JJJ=2;  ->621
MOD(0):                                 ! SCALAR FETCH POINTER
MOD(3):                                 ! SCALAR FETCH ADDR
         JJJ=0
621:     ->GENADDR %IF NAMEP=0
! MUST BEWARE OF STMNTS LIKE BYTEINTEGER(ADDR(I)+2)=...
! WHICH CAN CHANGE LOCAL VARIABLES (I) IN CORE. BIMSTR IS SET FOR ANY
! STATEMENT CONTAINING A STORE INTO A BUILTIN MAP. WHEN THIS FLAG IS
! SET ANY 'FETCH ADDRESS' OPERATION MUST BE TREATED AS A STORE
         %IF BIMSTR#0 %THEN NOTE ASSMENT(-1, 2, FNAME)
         FIND USE(REGP, 1, 7, NAMEP)
         ->GENADDR %UNLESS REGP>=0
         JJ=REGP;  ->SWOP
GENADDR: DUMP(JJJ, REG, DISP, INDEX, BASE)
         REG=NEST %IF REG<0
         %IF Z=4 %AND JJJ=2 %AND TYPE&3=0 %THEN %START
            PRX(X'54', REG, GLA, 0, 60);! N REG,=X'00FFFFFF'
            NAMEP=0
         %FINISH
         %IF NAMEP=0 %THEN JJJ=0 %ELSE JJJ=7
         SET USE(REG, JJJ, NAMEP);  ->9
MOD(5):                                 ! SCALAR NAME STORE
NAMETYPE:->630 %UNLESS NAMEP#0
         FIND USE(REGP, 1, 7, NAMEP)
         ->631 %IF REGP>0
630:     FIND REG(ADDREG, REGP)
         DUMP(X'58', REGP, DISP, INDEX, BASE);    ! ADDR TO REGP
         %IF NAMEP=0 %THEN RR=0 %ELSE RR=7
         SET USE(REGP, RR, NAMEP)
631:     INDEX=0;  BASE=REGP;  DISP=0
         ->GENFETCH %UNLESS Z=1 %OR Z>10
9:       ->1 %UNLESS ARR=0
91:      P=P+1
         ->6 %IF A(P)=2
         FAULT(19, FNAME)
         SKIP APP;  ->1
6:       P=P+1
1:       P=P+1;  ->9005 %IF A(P-1)=2
         FAULT(69, FNAME);  ->91
9005: %END
         %ROUTINE CRCALL(%INTEGER TCELLP)
         %SHORTROUTINE
!***********************************************************************
!*       COMPILE A ROUTINE OR FN CALL                                  *
!*       THE PROCEDURE CONSIST OF THREE PARTS:-                        *
!*       A) PLANT THE PARAMETER (IF ANY)                               *
!*       B) ENTER THE ROUTINE OR FN                                    *
!*       C) FORGET ANY REGISTERS WHICH HOLD ENTITIES THAT CAN BE       *
!*          ALTERED BY THE CALLED PROCEDURE.                           *
!*       ALSO CONTAINS A SPECIAL FOR CALLS OF IOCP & MONITOR           *
!*       ROUTINE TAGS ARE AS FOLLOWS:-                                 *
!*       SNDISP = WORD(!) DISPLACEMENT OF EP(REF)FROM HEAD OF CODE(GLA)*
!*        (OR)  = LISTHEAD OF OUTSTANDING FORWARD REFS                 *
!*       KFORM  = PSIMPLE<<12 ! NO OF PARAMS                           *
!*       K      = LIST OF FORMAL PARAMETER DESCRIPTIONS                *
!***********************************************************************
         %INTEGER KK,II,III,QQQ,SCA,JJ,JJJ,NPARMS,PT,LP,KKK,PSIZE, %C
                  SAVEFPTR,PSIMPLE,RTNAME,R1,R2,TL,MOVEPTR,RDISP,CLINK
         %OWNSHORTINTEGER FPTR
         SAVE IRS(RBASE+4)
!
! IF ANY ROUTINE HAS FUNCTIONS IN ITS PARAMETER LIST THIS ROUTINE
! WILL BE CALLED RECURSIVELY. FPTR KEEPS TRACK OF PARAMETERS AHEAD OF
! THE STACK TOP WHICH MUST BE PROTECTED
!
         SAVEFPTR=FPTR; R1=4; R2=14
         LP=I;JJJ=J; CLINK=K; KKK=CLINK; TL=OLDI
         RDISP=4*(SNDISP&X'FFFF'); PSIMPLE=KFORM>>12
         MOVEPTR=(FPTR+7)&(-8)
         %IF FPTR>64 %THEN MOVER(WSPR,MOVEPTR)
                                       ! ADVANCE WSP IF ALREADY IN THE
         FPTR=0;RTNAME=A(P);PT=PTYPE;  ! MIDDLE OF A RT CALL
         %IF TCELLP<0 %THEN %START;   ! CALL OF IOCP
            PT=10000;JJJ=14; PSIMPLE=0
            %IF TCELLP=-1 %THEN %START
               RDISP=IOCP1; NPARMS=2; R2=1
            %FINISH %ELSE %START
                RDISP=IMPMON1; NPARMS=0
            %FINISH
            -> ENTRY SEQ
         %FINISH
!
! NOW CHECK THAT THE RIGHT NUMBER OF PARAMETERS HAVE BEEN PROVIDED
!
         P=P+1
         NPARMS=KFORM&4095
         %IF NPARMS=0 %START
            ->ENTRY SEQ %IF A(P)=2
            FAULT(19,RTNAME);          ! WRONG NO OF PARAMETERS GIVEN
            SKIP APP; P=P-1
            %RETURN
         %FINISH
!
! A ROUTINE IS DEEMED TO HAVE SIMPLE PARAMETERS IF THEY CAN BE LOADED
! INTO GRS 0 UP AND PLANTED IN THE SAME 'STM' THAT STORES THE REGISTERS
! THIS IS CHECKED AT ROUTINESPEC TIME. ONLY THE REGISTERS NEED BE
! LOOKED AT HERE.
!
         II=0
         %WHILE PSIMPLE=1 %AND II<NPARMS %CYCLE
            PSIMPLE=0 %UNLESS REGISTER(II)=0
            II=II+1
         %REPEAT
         %IF PSIMPLE#0 %THEN %START
            R2=-1
            R1=NPARMS %IF NPARMS>4
         %FINISH
         ->FIRSTP
!
NEXT PARM:CLINK=SHORTINTEGER(ADDR(ASLIST(CLINK))+14)
         %IF CLINK=0 %THEN %START
            %IF A(P)=2 %THEN ->ENTRY SEQ
            FAULT(19,RTNAME)
            SKIP APP; P=P-1
            %RETURN
         %FINISH
FIRSTP:
!         FROM12(CLINK,PTYPE,II)
         *L_1,CLINK; *A_1,ASLIST
         *LM_2,3,0(1); *ST_2,PTYPE; *ST_3,II
         FPTR=II&X'FFFF'
         PSIZE=II>>16
         %IF A(P)=2 %THEN FAULT(19,RTNAME) %AND ->ENTRY SEQ
         P=P+1;! UNPACK
            *L_1,PTYPE; *CVD_1,0(11)
            *UNPK_ROUT(5),5(3,11)
            *NC_ROUT(5),MASK1
         II=TYPE;III=PREC
         JJ=(NAM<<1!ARR)&3
         %UNLESS (JJ=0 %AND ROUT=0) %OR %C
           (A(P+2)=4 %AND A(P+3)=1 %AND A(P+A(P+1)+1)=2) %START
            SKIP EXP; FAULT(22,0)
            ->NEXT PARM
         %FINISH
         %IF PSIMPLE#0 %THEN %START
            R2=R2+1
            %IF JJ=0 %THEN CSEXP(R2,1) %ELSE %START
               P=P+4; CNAME(3,R2)
               FAULT(22,0) %UNLESS II=TYPE %AND III=PREC
               P=P+1
            %FINISH
            GRUSE(R2)=15
            REGISTER(R2)=1
            -> NEXT PARM
         %FINISH
!
! FOR RT TYPE PARAMS, PASS 1 WORD POINTING TO 4 WORDS SET
! UP AS CODE,GLA,EP ADDR & ENVIRONMENT
!
         %IF ROUT=1 %THEN %START
            II=PTYPE; P=P+4
            CNAME(13,-1);              ! SET UP 4 WDS & SET PTR
            FAULT(22,0) %IF 1000#II-PTYPE#0;! PREC&TYPE SIMILAR
            P=P+1
            PRX(X'50',NEST,0,WSPR,FPTR);! STUFF OFF POINTER
         %FINISH %ELSE %START;         ! NAME & VALUE PARAMETERS
!
! FOR ARRAYNAME PARAMETERS THE NO OF DIMENSIONS OF THE ARRAY IS
! DEDUCED FROM THE FIRST CALL AND STORED IN STREAM3 OF THE PARAMETER
! LIST. ON ANY SUBSEQUENT CALL ONLY ARRAYS OF THE SAME DIMENSION CAN
! BE PASSED
!
            %IF JJ=0 %THEN KK=2 %AND ACC=PSIZE %ELSE KK=1
            %IF PTYPE=5 %THEN ACC=ACC-1
            QQQ=FROM3(CLINK); J=QQQ;   ! GET NO OF DIMENSIONS
            ASSIGN(KK,WSPR<<16!FPTR);  ! ASSIGN 1='==', 2='='
            %IF JJ=3 %AND QQQ=0 %THEN REPLACE3(CLINK,J)
         %FINISH
         -> NEXT PARM
ENTRY SEQ:                             ! CODE FOR RT ENTRY
         %IF R2=14 %AND REGISTER(14)!GRUSE(14)=0 %THEN R2=13
!
! SIMPLE PARAMETERS SHOULD BE IN GRS 0 UP AWAITING STORAGE. IF HOWEVER
! THERE WAS A FUNCTION CALL AMONG THE ACTUAL PARAMETERS SOME MAY HAVE
! BEEN STORED ALREADY. THIS CASE MUST BE CHECKED FOR, AND IF FOUND,
! ROUTINE SAVE IRS CALLED TO STORE ANY REMAINING PARAMETERS.
!
         JJ=0
         %WHILE PSIMPLE#0 %AND JJ<NPARMS %CYCLE
            %IF GRUSE(JJ)=15 %THEN REGISTER(JJ)=0 %ELSE %START
               KK=JJ-1;                 ! RESET REGISTER FOR REGS FREED
               REGISTER(KK)=1 %AND KK=KK-1 %WHILE KK>=0
               R2=14; PSIMPLE=0
               SAVE IRS(RBASE+4)
            %FINISH
            JJ=JJ+1
         %REPEAT
!
         SCA=CA; PCONST(0);            ! WILL CONTAIN THE 'STM'
         PTYPE=PT;! UNPACK
            *L_1,PTYPE; *CVD_1,0(11)
            *UNPK_ROUT(5),5(3,11)
            *NC_ROUT(5),MASK1
         %UNLESS JJJ=14 %OR NAM&1=1 %START
            NMDECS=NMDECS!2
            J=JJJ; OLDI=TL
            RT JUMP(X'45',15,TCELLP,10)
         %FINISH %ELSE %START
            %IF NAM&1=0 %THEN %START;        ! EXTERNAL CALL
               JJ=RDISP; TL=0;             ! NOTHING GLOBAL TO XTRN
               DUMPM(X'98',12,14,GLA,JJ);    ! LM 12,14,EP
            %FINISH %ELSE %START;            ! RT PARAM CALLED
                                             ! ENVIRONMENT MUST BE LOADED
               DUMP(X'58',15,RDISP,0,LP);  ! LOAD PTR TO RT HEAD
               PRX(X'98',12,15,15,0);        ! LOAD HEAD
               PRX(X'98',5,10,15,20);        ! LOAD UP ENVIRONMENT
            %FINISH
            PLANT(X'5FE');                   ! BALR 15,14
         %FINISH
!
! NOW UPDATE REGISTERS AND GLOBAL FLAGS
!
         MONE=1; CYC BITS=CYC BITS!8;  ! 'RT CALL' BIT
         CYC BITS=CYC BITS!(1<<20)<<TL
         FAULT(201,0) %UNLESS REGISTER(15)=0
         CCSTATE=-1
         FORGETM(8)
         SET USE(15,12,CA) %IF SBFLAG=0 %AND CA-CODEBASE>4095-MARGIN
         %IF R2<R1 %THEN JJJ=14 %ELSE JJJ=R2
         %CYCLE JJ=R1,1,JJJ
            %IF REGISTER(JJ)=0 %THEN %START
               KK=GRUSE(JJ)
               %UNLESS 1<=KK<=2 %OR KK=8 %OR 10<=KK<=12 %THEN %START
                  II=0
                  %IF KK=7 %THEN II=FROM1(GRINF(JJ))>>8&15;! LEVEL OF DECLN
                  GRUSE(JJ)=0 %UNLESS II>TL;!  NAME CAN NOT BE ALTERED
               %FINISH
            %FINISH
         %REPEAT
         R1=R1+1 %WHILE REGISTER(R1)=0 %AND GRUSE(R1)<=1
         PLUG(1,SCA,X'9000'!R1<<4!R2)
         PLUG(1,SCA+2,WSPR<<12!R1<<2)
         FPTR=SAVEFPTR
         %IF FPTR>64 %THEN %START
           REGISTER(1)=1;          !PROTECT PROGS WITH GLA>4096
           MOVER(WSPR,-MOVEPTR);!STEP BACK STACK PTR
           REGISTER(1)=0
           %FINISH
         %END
         %ROUTINE RT JUMP(%INTEGER CODE,R1,LINK,WKREG)
!***********************************************************************
!*       PLANTS A 'BAL' TO THE APPROPIATE ENTRY ADDRESS IN ASL(LINK)   *
!*       DIFFERENT FROM NORMAL JUMPS AS ADDRESS CAN BE BEFORE ((GR10)).*
!*       IF ROUTINE HAS BEEN SPECIFIED BUT NOT DESCRIBED THE JUMP CAN  *
!*       NOT BE PLANTED AND IS LINKED INTO A LIST HEADED BY ASL(LINK)  *
!*       TO AWAIT FILLING (BY ' RHEAD ') WHEN THE BODY IS GIVEN.       *
!*       THE FORMAT OF AN ENTRY IS :-                                  *
!*       S1(32 BITS) = VALUE IN BASE REGISTER( GR10)                   *
!*       S2(32 BITS) = ADDRESS OF JUMP TO BE FILLED                    *
!*       S3(16 BITS) = FLAG (0 FOR LONG JUMP,#0 SHORT JUMP)            *
!*       THE CODING ASSUMES I,J&OLDI ARE SET UP FOR THE CALLED ROUTINE *
!***********************************************************************
         %SHORTROUTINE
         %INTEGER DP,AD,XD
         XD=0; AD=ADDR(ASLIST(LINK))+4;!  TO SNDISP FIELD OF TAGS
         DP=4*(SHORTINTEGER(AD)&X'FFFF')-CODEBASE
         PRR(X'18',WKREG,10) %UNLESS WKREG=10 %OR(J#15 %AND 0<DP<4095)
         %IF J=15 %THEN %START;        ! RT BODY NOT GIVEN YET
            %IF SBFLAG=1 %AND OLDI=LEVEL %THEN XD=1 %AND WKREG=10
            DP=0
            PUSH123(SHORT INTEGER(AD),CODEBASE,CA,XD) %IF CSSMODE#0
            PRX(X'5A',WKREG,CODER,0,0) %IF XD=0
         %FINISH %ELSE %START;          ! BODY GIVEN AND ADDRESS KNOWN
            %IF 0<DP<4095 %THEN WKREG=10 %ELSE ADJUST INDEX(1,WKREG,DP)
         %FINISH
         PRX(CODE,R1,WKREG,0,DP&4095)
         %END
         %ROUTINE SKIP EXP
         %SHORTROUTINE
!***********************************************************************
!*       SKIPS OVER THE EXPRESSION POINTED AT BY P. USED FOR ERROR     *
!*       RECOVERY AND TO EXTRACT INFORMATION ABOUT THE EXPRESSION.     *
!*       FFLAG IS SET IF THERE ARE ANY FUNCTIONS IN THE EXPRESSION     *
!*        SENOPS COUNTS THE OPERATORS IN THE EXPRESSION                *
!*        SEFOP HOLD THE FIRST OPERATOR.                               *
!***********************************************************************
         %BYTEINTEGER OPTYPE
         %INTEGER J
         P=P+2;                         ! TO P<+'>
         %CYCLE;                        ! DOWN THE LIST OF OPERATORS
           OPTYPE=A(P+1);               ! ALT OF P<OPERAND>
           P=P+2
            %IF OPTYPE=0 %OR OPTYPE>4 %THEN ABORT
           %IF OPTYPE>=3 %THEN SKIP EXP;! SUB EXPRESSIONS
!
           %IF OPTYPE=2 %THEN %START;   ! OPERAND IS A CONSTANT
              J=A(P)&7;                 ! CONSTANT TYPE
              %IF J=1 %THEN P=P+3;      ! INTEGER CONSTANT
              %IF J=2 %THEN P=P+5;      ! REAL CONSTANT
              %IF J=5 %THEN P=P+(A(P+1)+1)>>1+2
              %IF A(P)=1 %THEN %START;  ! IMPLIED MULTIPLICATION
                 OPTYPE=1;              ! TO PROCESS THE NAME
              %FINISH
              P=P+1
           %FINISH
!
           %IF OPTYPE=1 %THEN %START;   ! NAME
              J=ADDR(ASLIST(TAGS(A(P))))
              FFLAG=1 %IF SNPT#SHORT INTEGER(J)>=10000;! ROUT IN PTYPE
              P=P-1
              %UNTIL A(P)=2 %CYCLE
                 P=P+2
                 %IF A(P)=2 %THEN P=P+1 %ELSE SKIP APP
              %REPEAT                     ;! TILL NO ENAME
              P=P+1
           %FINISH
!
           P=P+1
           %IF A(P-1)=2 %THEN %EXIT;    ! NO MORE REST OF EXP
         %REPEAT
         %END;                        ! OF ROUTINE SKIP EXP
          %ROUTINE SKIP APP;           ! SKIPS ACTUAL PARAMETER PART
         %WHILE A(P)=1 %THEN P=P+1 %AND SKIP EXP
         P=P+1
          %END
               %INTEGERFN TSEXP(%INTEGERNAME CODE,%INTEGER RTMODE)
         %SHORTROUTINE
         %INTEGER KK,PP,QQ,REXP
         %SWITCH SW(1:4)
         TYPE=1; PP=P; REXP=2-A(P+1+A(P+1)); P=P+2
         ->9 %IF 1#A(P)#4; ->SW(A(P+1))
SW(1):   P=P+2; CODE=A(P); REDUCE TAG(RTMODE)
         ->30 %IF TYPE=3
         -> 9 %IF K>4095
         ->9 %UNLESS A(P+1)=2 =A(P+2); ! NO APP OR ENAME
         ->9 %UNLESS ROUT=0
         ->20 %IF TYPE=5
         ->9 %UNLESS TYPE=1
         ->11 %IF A(P+3)=2;            ! NO RST OF EXPS
         -> 9 %UNLESS NAM=0 %AND ARR=0 %AND A(P+5)=2
         QQ=A(P+4); ->9 %UNLESS 1<QQ<=5 %OR QQ=9;! OPERATOR
         ->9 %UNLESS A(P+6)&7=1 %AND A(P+7)=0 %AND A(P+8)>>8=0 %C
         %AND A(P+9)=2=A(P+10)
         CODE=A(P+8); P=P+11; %RESULT=100*(QQ-1)
11:
         P=P+4; %RESULT=10+PREC+100*NAM
20:      ->9 %UNLESS A(P+3)=2
         P=P+4; %RESULT=20
30:      QQ=COPY RECORD TAG(KK)
         %IF QQ=0 %AND A(P+1)=2 %THEN %RESULT=30
         ->9
SW(2):   TYPE=A(P+2)&7
         %IF TYPE=5 %AND REXP=0 %AND A(P+3)=0 %AND A(P+4)=2 %C
            %THEN CODE=0 %AND P=P+6 %AND %RESULT=1;! """"
         -> 9 %UNLESS TYPE=1 %AND A(P+5)=2; ! NO IMPLIED MULT
         -> 21 %IF REXP=1
         **1,P; *AR_1,1; *LA_1,A+36(1)
         *MVC_KK(4),0(1)
         CODE=KK
         P=P+7
         -> 9 %UNLESS KK>>12=0
         %RESULT=1 %IF 256>CODE
         %RESULT=2
21:      %IF A(P+7)=12 %THEN TYPE=5
SW(3):SW(4):9:P=PP; %RESULT=0
               %END
         %ROUTINE     MOVE R(%INTEGER R,N)
         %SHORTROUTINE
!***********************************************************************
!*       ADVANCE OR RETARD ADDRESS IN REGISTER 'R' BY N BYTES          *
!***********************************************************************
         %INTEGER CODE,BASE,D
         CODE=0; BASE=R; D=N
         %IF N<0 %THEN %START;            ! STORE CONST & USE SH
            CODE=X'4B'; N=!N!
            CCSTATE=-1
            STORE CONST(BASE,D,2,ADDR(N)+2)
         %FINISH
            DUMP(CODE,R,D,0,BASE);        ! LA OR SH -ZERO SORTED
         %END
         %ROUTINE BULK M(%INTEGER MODE,L,B1,D1,B2,D2)
         %SHORTROUTINE
!***********************************************************************
!*       PLANT CODE TO MOVE L BYTES (L KNOWN AT COMPILE TIME) FROM     *
!*       D1(B1)  TO D2(B2)                                             *
!*       IF MODE =0 SET L BYTES TO D2(0 OR X'80')                      *
!*                                                                     *
!*       L MAY BE GREATER THAN 4095                                    *
!***********************************************************************
         %ROUTINESPEC UPDATE(%INTEGERNAME WI,DI)
         %INTEGER I,J,W1,W2,OPCODE,CONST
         W1=B1; W2=B2
         OPCODE=X'D2'
         %IF L+D1> 4092 %THEN UPDATE(W1,D1)
         %IF MODE#0 %AND L+D2>4092 %THEN UPDATE(W2,D2)
!
         %IF MODE=0 %THEN %START;      ! PROPAGATE CONSTANT
            J=L; W2=W1
            CONST=D2; D2=D1
         %IF CONST=0 %AND L<=32 %THEN %START
               CCSTATE=-1
               OPCODE=X'D7';           ! CAN USE XC
            %FINISH %ELSE %START;      ! USE MVI & MVC TO PROPOGATE
               PSI(X'92',CONST,W1,D1)
               L=L-1; D1=D1+1
            %FINISH
         %FINISH
!
!        END OF PREPARATION - CYCLE ROUND PLANTING MVC
!
         %WHILE L>0 %CYCLE
            %IF L>256 %THEN J=256 %ELSE J=L
            %IF D1>4092 %THEN %START
               I=D1; UPDATE(W1,D1)
               %IF W2=W1 %THEN D2=D2-I+D1;! OVERLAPPING PROPAGATION W1=W2
            %FINISH
            %IF D2>4092 %THEN UPDATE(W2,D2)
            PSS(OPCODE,J,W1,D1,W2,D2)
            D1=D1+J
            D2=D2+J
            L=L-J
         %REPEAT
!
         REGISTER(W1)=0 %IF REGISTER(W1)>0
         REGISTER(W2)=0 %IF REGISTER(W2)>0
         %RETURN
         %ROUTINE     UPDATE(%INTEGERNAME WI,DI)
         %INTEGER WK,J
         WK=WI
         %IF REGISTER(WK)<0 %THEN FIND REG(GR1,WK)
         %IF DI<4092 %THEN J=DI %ELSE J=4092
         DUMP(0,WK,J,0,WI)
         FORGET(WK)
         DI=DI-J; WI=WK
         %END
         %END;                         ! OF ROUTINE BULK M
         %ROUTINE     CBPAIR(%INTEGERNAME LB,UB)
         %SHORTROUTINE
!***********************************************************************
!*       EXTRACT UPPER AND LOWER BOUNDS FROM A CONSTANT BOUND PAIR     *
!***********************************************************************
         %INTEGER KK,KKK,JJ,BP
         P=P+1; KK=0
         %CYCLE JJ=1,1,2
           KKK=KK
           %IF A(P)=2 %THEN KK=-1 %ELSE KK=1;  ! EXTRACT SIGN
           FROM AR4(P+2,BP)
           KK=KK*BP
           P=P+4
         %REPEAT
         %IF KKK>KK %THEN FAULT(43,0) %AND KK=KKK
         LB=KKK; UB=KK
         %END
         %ROUTINE GET WSP(%INTEGERNAME PLACE,%INTEGER SIZE)
         %SHORTROUTINE
!***********************************************************************
!*       FIND OR CREATE A TEMPORARY VARIABLE OF 'SIZE' WORDS           *
!*       SIZE=0 FOR STRING TEMPORARIES (260 BYTES)                     *
!***********************************************************************
         %INTEGER J,K
         SIZE=0 %IF SIZE>7
         *TR_SIZE+3(1),WSPTRTAB1
         POP(AVL WSP(SIZE,LEVEL),J,K)
         %IF K<=0 %THEN %START;        ! MUST CREATE TEMPORARY
            %IF SIZE=2 %THEN N=(N+7)&(-8);    ! DBLE WRD BNDRY!
            K=N
            %IF SIZE=0 %THEN N=N+260 %ELSE N=N+SIZE<<2
         %FINISH
         PLACE=K
!
! NORMALLY TEMPORARIES ARE RETURN ON EXITING FROM CSS. WITH STRINGS
! THEY ARE RETURNED AS SOON AS POSSIBLE TO TRY AND SAVE SPACE
!
         PUSH(TWSPHEAD,K,SIZE) %UNLESS SIZE=0
         %END
         %ROUTINE RETURN WSP(%INTEGER PLACE,SIZE)
         %SHORTROUTINE
         SIZE=0 %IF SIZE>7
         *TR_SIZE+3(1),WSPTRTAB1
         PUSH(AVL WSP(SIZE,LEVEL),0,PLACE)
         %END
         %ROUTINE SETLINE
!***********************************************************************
!*       UPDATE THE LINE NO IF THIS STATEMENT HAS A DIFFERENT SOURCE   *
!*       LINE NO THAN THE LAST STATEMENT. IF IN DIAGNOSTIC MODE THE    *
!*       MONITOR IS CALLED ALSO TO KEEP IT INFORMED OF THE EXECUTION   *
!*       OF THE OBJECT PROGRAM.                                        *
!***********************************************************************
         %SHORTROUTINE
         %INTEGER K,AT
         %OWNINTEGER VALUE
         %IF LINENOS=1 %THEN %START
            K=LINE&255
            MONE=1 %IF K=0
            PSI(X'92',K,GLA,23) %UNLESS K=VALUE %AND MONE=0
            VALUE=K
            %IF MONE#0 %THEN PSI(X'92',LINE>>8,GLA,22);   ! MVI
            %IF DIAGS2#0 %THEN %START
               %IF IMPMON1<10 %THEN CXREF(0,-2,0,AT) %AND IMPMON1=AT
               CRCALL(-2);             ! CALL THE ONLINE MONITOR
            %FINISH
            MONE=0
          %FINISH
          %END
         %ROUTINE     CHECK CAPACITY(%INTEGER REG,DIS,X,LEVEL)
         %SHORTROUTINE
!***********************************************************************
!*       CHECK THAT THE ASSIGNMENT JUST MADE DID NOT EXCEED THE        *
!*       CAPACITY OF THE VARIABLE(BYTES  AND SHORTS ONLY)              *
!***********************************************************************
         %INTEGER MASK
         %IF 1<=PREC<=2 %THEN %START
            CCSTATE=-1
            %IF PREC=1 %THEN PRX(X'55',REG,0,GLA,24) %AND MASK=2 %C
                       %ELSE DUMP(X'49',REG,DIS,X,LEVEL) %AND MASK=7
            PRX(X'47',MASK,12,0,88);     ! BC MASK,CAPACITY EXCEEDED
         %FINISH
         %END
!
!***********************************************************************
!*       REGISTER ALLOCATING ROUTINES                                  *
!*       THE REGISTERS ARE HELD ON A LIST FROM 0->22 COVERING          *
!*       THE 16 GENERAL REGISTERS AND THE FOUR FLOATING REGISTERS.     *
!*       A FLOATING REGISTER MAY BE DEFINED BY (TYPE=2,REG=0,2,4,6) OR *
!*       (TYPE =1,REG=16,18,20,22). BOTH ARE  VALID. THE FREE LIST IS  *
!*       SEARCHED IN DIFFERENT WAYS SO THAT THE MORE VOLATILE REGISTERS*
!*       I.E. GRS 0-3 AND GR15 ARE USED FOR SHORT-TERM PURPOSES AND    *
!*       THE SAFE REGISTERS(GRS 4-14) ARE USED WHEN THE PURPOSE MAY    *
!*       HAVE SOME LONG TERM VALUE.                                    *
!***********************************************************************
!
         %ROUTINE FORGET(%INTEGER REG)
         CCSTATE=-1 %IF CCSTATE&255=REG
         %IF REGISTER(REG)>= 0 %THEN GRUSE(REG)=0 %AND GRINF(REG)=0
         %END
         %ROUTINE FREE AND FORGET(%INTEGER REG)
         CCSTATE=-1 %IF CCSTATE&255=REG
         %IF REGISTER(REG)>=0 %THEN  REGISTER(REG)=0 %AND %C
                GRUSE(REG)=0 %AND GRINF(REG)=0
         %END
         %ROUTINE FORGETM(%INTEGER UPPER)
         %SHORTROUTINE
!***********************************************************************
!*       FORGETS A BLOCK OF REGISTERS DEFINED BY UPPER AND THE         *
!*       GLOBAL ARRAY GRMAP                                            *
!*       UPPER= 3   FOR   GRS 0-3                                      *
!*       UPPER= 4   FOR   GRS  0-3  AND 15                             *
!*       UPPER= 8   FOR   GRS  0-3  AND 15  PLUS ALL FRS               *
!*       UPPER=14   FOR   GRS  0-8,14,15  AND ALL FRS                  *
!***********************************************************************
         %INTEGER I,J,REG,U
         %CYCLE I=0,1,UPPER
            REG=GRMAP(I)
            CCSTATE=-1 %IF CCSTATE&255=REG
            %IF REGISTER(REG)=0 %THEN GRUSE(REG)=0 %AND GRINF(REG)=0
         %REPEAT
         %END
         %ROUTINE SAVE IRS(%INTEGER UPPER)
         %SHORTROUTINE
!***********************************************************************
!*       INSPECTS THE REGISTERS DEFINED BY UPPER AND THE GLOBAL        *
!*       ARRAY 'GRMAP'. ANY INTERMEDIATE RESULTS IN THESE REGISTERS    *
!*       ARE TRANSFERED TO CORE BY 'BOOT OUT'                          *
!*       UPPER=4 FOR GRS 1-3 & 15   (CORRUPTED BY PERM)                *
!*       UPPER=8 FOR GRS 1-3 & 15 +FRS 0-6  (CORRUPTED BY FN CALL)     *
!***********************************************************************
         %INTEGER I,REG
         %CYCLE I=0,1,UPPER
           REG=GRMAP(I)
           BOOT OUT(REG) %IF REGISTER(REG)=1
         %REPEAT
         %END
         %ROUTINE SET USE(%INTEGER R,U,I)
!***********************************************************************
!*       NOTE THAT THE USE OF REGISTER 'R' IS NOW 'U' & 'I'            *
!***********************************************************************
         CCSTATE=-1 %IF CCSTATE&255=R
         %IF REGISTER(R)>=0 %THEN  GRUSE(R)=U %AND GRINF(R)=I%C
             %AND GRAT(R)=CA
         %END
         %ROUTINE BOOT OUT(%INTEGER REG)
         %SHORTROUTINE
!***********************************************************************
!*       IF THE SPECIFIED REGISTER CONTAINS AN INTERMEDIATE RESULT     *
!*       (USE=1) OR PARAMETER EN-ROUTE TO A ROUTINE (USE=15) THEN FREE *
!*       THE REGISTER BY TRANSFERRING ITS CONTENTS TO CORE             *
!***********************************************************************
         %INTEGER J,USE,BASE
         %RECORDNAME OPND(RD)
         USE=GRUSE(REG)
         %IF USE=1 %OR USE=15 %THEN %START
            %IF USE=15 %THEN BASE=WSPR %AND J=REG<<2+64 %ELSE %START
ABORT %UNLESS ADDR(ASLIST(0))<=GRINF(REG)<=ADDR(ASLIST(32752))
               OPND==RECORD(GRINF(REG))
               %RETURN %UNLESS OPND_FLAG=9 %AND OPND_D<0
               GET WSP(J,1+REG>>4)
               OPND_XB=RBASE; OPND_D=J; BASE=RBASE
            %FINISH
            DUMP(X'50'+REG&16,REG&15,J,0,BASE)
            FREE AND FORGET(REG)
         %FINISH
         %END
%ROUTINE FINDREG(%INTEGER CONTROL, %INTEGERNAME REG)
%SHORTROUTINE
%INTEGER I, J, K, LAST, LAT, AND, AD
         %IF CONTROL=FR0 %THEN AND=31 %ELSE AND=15
         AD=ADDR(CONTROL);  LAST=-1;  LAT=CA
         %CYCLE J=0, 1, 1
            %CYCLE K=BYTE INTEGER(AD+2), SHORT INTEGER(AD),  %C
               BYTE INTEGER(AD+3)
               I=K&AND
               BOOT OUT(I) %IF REGISTER(I)=1 %AND J>0
               %IF REGISTER(I)=0 %THEN %START
                  ->FOUND %IF GRUSE(I)<=1 %OR J>0
                  %IF GRAT(I)<LAT %THEN  LAST=I %AND LAT=GRAT(I)
               %FINISH
            %REPEAT
            I=LAST
            %IF J=0 %AND LAST>0 %THEN ->FOUND
         %REPEAT
         %IF CONTROL=CLMABL %THEN I=1 %ELSE ABORT
FOUND:   REG=I&15
         %IF CONTROL=SAFE %THEN CYC BITS=CYCBITS!128
                                        ! SAFE REG REQD
%END
%ROUTINE CLAIM(%INTEGER CONTROL, %INTEGERNAME REG)
%SHORTROUTINE
%INTEGER I
         FIND REG(CONTROL, I)
         %IF CONTROL=FR0 %THEN I=I+16
         REGISTER(I)=1
         REG=I&15
%END
%ROUTINE CLAIM THIS REG(%INTEGER REG)
%SHORTROUTINE
!***********************************************************************
!*       CLAIMS THE REGISTER AND PRESERVES CONTENTS IF                 *
!*       THE REGISTER IS ALREADY CLAIMED                               *
!***********************************************************************
         BOOT OUT(REG) %IF REGISTER(REG)=1
         %IF REGISTER(REG)#0 %THEN ABORT
         REGISTER(REG)=1
%END
%ROUTINE FIND USE(%INTEGERNAME REG, %INTEGER TYPE, USE, INF)
%INTEGER I, L, U, J
%CONSTINTEGERARRAY FMAP(1:16)=4,8,12,16,20,24,28,32,56,60,0,
                               48,64,72,80,88;
         %IF TYPE=2 %THEN L=52 %AND U=64 %ELSE L=4 %AND U=48
!         %CYCLE J=L,1,U
!            I=FMAP(J)
!            %IF GRUSE(I)=USE %AND(GRINF(I)=INF%OR INF=-1) %THEN ->HIT
!         %REPEAT
         *L_1,L; *LA_2,4;*L_3,U
         *L_15,FMAP; *SR_0,0; *BCTR_0,0
         *LM_4,5,USE
AGN:     *L_14,0(1,15);                 ! I=FMAP(J)*4
         *C_4,GRUSE+16(14); *BC_7,<REP>
         *C_5,GRINF+16(14); *BC_8,<HIT>
         *CR_0,5; *BC_8,<HIT>
REP:     *BXLE_1,2,<AGN>
         REG=-1
         %RETURN
HIT:
!         GRAT(I)=CA
!         REG=I
         *L_0,CA; *ST_0,GRAT+16(14)
         *SRL_14,2; *L_1,REG; *ST_14,0(1)
%END
%ROUTINE FIND SEQ(%INTEGERNAME ONE, TWO)
%SHORTROUTINE
!***********************************************************************
!*       FINDS TWO REGISTERS FOR LM OR STM THAT ARE ADJACENT           *
!*       ALLOWING FOR WRAP AROUND. NOT USED VERY MUCH SO IS FAIRLY     *
!*       PRIMITIVE COMPARED TO 'FIND REG'                              *
!***********************************************************************
%INTEGER J, P1, P2, K
         %CYCLE K=0, 1, 1
            %CYCLE J=14, 1, RBASE+31;   ! TWO PASSES THROUGH GRS
               P1=J&15;  P2=(J+1)&15
               ->FOUND %IF REGISTER(P1)=0 %AND REGISTER(P2)=0 %C
                  %AND (J>=30 %OR GRUSE(P1)<=1>=GRUSE(P2))
            %REPEAT
            SAVEIRS(4)
         %REPEAT
         ABORT;                         ! ALMOST INCONCEIVABLE!
FOUND:   ONE=P1;  TWO=P2
%END
!******END OF REGISTER ALLOCATING ROUTINES*******
!
!
!***********************************************************************
!*           START OF TAG HANDLING ROUTINES                            *
!*       TAGS TAKE THE FORM                                            *
!*       S1=PTYPE<<16!USEBITS<<12!LEVEL<<8!BASEREG<<14!DIMENSN         *
!*       S2=SECONDARY DISP<<16!ITEM SIZE                               *
!*       S3=PRIMARY DISP<<16!FORM                                      *
!*       WHERE:-                                                       *
!*       PTYPE=ROUT,NAM,ARR,PREC & TYPE PACKED INTO 16 BITS            *
!*       USEBITS(L-R)= ANY USE,STORED,ADDRESSED,READ                   *
!*       LEVEL=TEXTUAL LEVEL OF DECLARATION                            *
!*       BASEREG & DIMENSN ARE OBVIOUS                                 *
!*                                                                     * 
!*       SNDARY DISP(SIGNED)= DISP OF A0 FROM LEVEL PTR                *
!*       PRMY DISP= POSITION OF ITEM OR ITS POINTER IN STACK FRAME     *
!*       FORM=POINTER TO FORMAT(RECORDS) OR VALUE (%CONSTS)            *
!***********************************************************************
!
%ROUTINE NOTE ASSMENT(%INTEGER REG, ASSOP, VAR)
%SHORTROUTINE
!***********************************************************************
!*       NOTES THE ASSIGNMENT TO SCALAR 'VAR'.  THIS INVOLVES REMOVING *
!*       OLD COPIES FROM REGISTERS TO AVOID CONFUSING OLD AND NEW VALUE*
!*       ASSOP =1 FOR'==',=2 FOR '=',=3 FOR '<-'                       *
!***********************************************************************
%INTEGER I, J, K, L, U, AND, STEP, CCS
         %IF VAR=CUR CYC VAR %THEN CYC BITS=CYC BITS!32
         K=TAGS(VAR);  L=14;  U=RBASE+15;  AND=15;  STEP=1
         %IF TYPE=2 %AND ASSOP#1 %THEN %START
            L=16;  U=22;  AND=31;  STEP=2;  REG=REG!16
         %FINISH
         %IF CCSTATE&255=REG %THEN CCS=CCSTATE %ELSE CCS=0
         %CYCLE I=L, STEP, U;  J=I&AND
            FORGET(J) %C
               %IF K=GRINF(J)&X'FFFF' %AND REGISTER(J)=0 %AND (GRUSE( %C
               J)=3 %OR GRUSE(J)=9 %OR (GRUSE(J)=7 %AND ASSOP=1))
         %REPEAT
         ->99 %IF REG<0 %OR (GRUSE(REG)=2 %AND 0<=GRINF(REG)<=2)
         ->99 %IF ASSOP=3 %OR REGISTER(REG)<0
         %IF ASSOP=1 %THEN J=7 %ELSE J=3
!         SET USE(REG, J, K)
         GRUSE(REG)=J; GRINF(REG)=K; GRAT(REG)=CA
         CCSTATE=CCS %UNLESS CCS=0
99: %END
%ROUTINE STORE TAG(%INTEGER KK, SLINK)
%INTEGER Q
         Q=PTYPE<<16!LEVEL<<8!RBASE<<4!J
         SLINK=SLINK<<16!KFORM&X'FFFF'
         PUSH123(TAGS(KK), Q, INTEGER(ADDR(SNDISP)), SLINK)
         SHORTINTEGER(ADDR(ASLIST(TAGS(KK)))+12)=NAMES(LEVEL)
         NAMES(LEVEL)=KK
%END
%ROUTINE TEST APP(%INTEGERNAME NUM)
%SHORTROUTINE
!***********************************************************************
!*       THIS ROUTINE COUNTS THE NUMBER OF ACTUAL PARAMETERS           *
!*       WHICH IT RETURNS IN NUM.                                      *
!***********************************************************************
%INTEGER PP, Q
         Q=0;  PP=P;  P=P+1;            ! P ON NAME AT ENTRY
         %WHILE A(P)=1 %CYCLE;          ! NO (MORE) PARAMETERS
            P=P+1;  Q=Q+1
            SKIP EXP
         %REPEAT
         P=PP;  NUM=Q
%END
%ROUTINE COPY TAG(%INTEGER KK)
%LONGREAL WORK
         TCELL=TAGS(KK)
         *XC_PTYPE(20),PTYPE
         *L_1,TCELL
         *LTR_1,1;  *BC_8,<NOTSET>
         *A_1,ASLIST
         *UNPK_WORK(5),2(3,1)
         *LH_0,0(1,0)
         *ST_0,PTYPE
         *MVN_USEBITS+3(1),WORK
         *MVN_OLDI+3(1),WORK+1
         *MVN_I+3(1),WORK+2
         *MVN_J+3(1),WORK+3
         *OI_2(1),X'80';                ! SET USE BIT
         *MVC_SNDISP(8),4(1)
         *CVD_0,WORK
         *UNPK_ROUT(5),WORK+5(3)
         *NC_ROUT(5),MASK1
         %RETURN
NOTSET:  *MVI_PTYPE+3,7
         *MVI_I,255
         *MVC_I+1(11),I
         *XC_ROUT(4),ROUT
         TYPE=7
%END
%ROUTINE REDUCE TAG(%INTEGER MODE)
%SHORTROUTINE
!***********************************************************************
!*       AS COPY TAG FOR NAME AT A(P) EXCEPT:-                         *
!*       1) SPECIAL NAMES HAVE THEIR CORRECT PREC & TYPE SUBSTITUTED   *
!*       2) RECORD ELEMENTS OF SIMPLE RECORDS ARE REDUCED TO A         *
!*              SIMPLE BASE/OFFSET SITUATION.                          *
!***********************************************************************
%INTEGER PTYPEP, QQ, PP, NAMP, JJ, RDISP, SUBS
         PP=P;  COPY TAG(A(P))
         %IF PTYPE=SNPT %THEN %START
            PTYPE=TSNAME(K); ! UNPACK
            *L_1,PTYPE; *CVD_1,0(11)
            *UNPK_ROUT(5),5(3,11)
            *NC_ROUT(5),MASK1
            ROUT=1
         %FINISH;                       ! TO AVOID CHECKING PARAMS
         %UNLESS TYPE=3 %AND A(P+1)=2 %AND A(P+2)=1 %C
            %AND A(P+4)=2=A(P+5) %THEN ->OUT
! NO APP &SINGLE SIMPLE ENAME
         NAMP=NAM
         RDISP=K
         PTYPEP=PTYPE;  QQ=COPY RECORD TAG(SUBS)
         %UNLESS QQ>0 %AND ARR=0 %AND TYPE#3  %AND SUBS=1 %THEN ->RESET
         %IF NAMP=0 %THEN K=K+RDISP %ELSE %START
            FIND USE(JJ, 1, 7, TAGS(A(PP)))
            %IF JJ>0 %THEN I=JJ %ELSE %START
               ->RESET %UNLESS MODE#0
               %CYCLE JJ=14,-1,4
                  %IF REGISTER(JJ)=0 %AND GRUSE(JJ)<=1 %START
                     DUMP(X'58',JJ,RDISP,0,I)
                     SET USE(JJ,7,TAGS(A(PP)))
                     P=PP+3; I=JJ; %RETURN
                  %FINISH
               %REPEAT
               ->RESET
            %FINISH
         %FINISH;  P=PP+3;  %RETURN
RESET:   P=PP;  COPY TAG(A(P))
OUT: %END
%ROUTINE REPLACE TAG(%INTEGER KK)
%SHORTROUTINE
%INTEGER P, Q
         P=TAGS(KK)
         Q=PTYPE<<16!USEBITS<<12!OLDI<<8!I<<4!J
         REPLACE123(P, Q, INTEGER(ADDR(SNDISP)), INTEGER(ADDR(K)))
%END
%ROUTINE UNPACK
%LONGREAL WORK
         *L_1,PTYPE;  *CVD_1,WORK
         *UNPK_ROUT(5),WORK+5(3)
         *NC_ROUT(5),MASK1
%END
%ROUTINE PACK(%INTEGERNAME PTYPE)
%LONGREAL WORK
         %MCODE
         *PACK_WORK(8),ROUT(5)
         *OI_WORK+7,X'0C'     ;         !VALID SIGN
         *CVB_1,WORK
         *L_2,PTYPE;  *ST_1,0(2)
%END
%ROUTINE PPJ(%INTEGER N)
! PLANT A 'BAL' TO PERM SUBROUTINE N0 'N'
%INTEGER I
         CCSTATE=-1
         CYC BITS=CYC BITS!4;           ! SET 'PERM' BIT
         %IF 20<=N<=24 %THEN I=4 %ELSE I=8
         SAVE IRS(I)
         FAULT(202, 0) %UNLESS REGISTER(15)=0
         PCONST(X'45F0C000'!N<<2);      ! BAL 15,PN
         FORGETM(I)
         SET USE(15, 12, CA) %C
            %IF SBFLAG=0 %AND I#4 %AND CA-CODEBASE>4095-MARGIN
%END
%ROUTINE ADJUST INDEX(%INTEGER MODE, %INTEGERNAME INDEX, DISP)
%SHORTROUTINE
!***********************************************************************
!*       THIS IS THE GENERAL SOLUTION TO LACK OF ADDRESSABILITY. IT IS *
!*       CALLED WHEN DISP IS OUTSIDE THE RANGE 0->4095 AND MANIPULATES *
!*       INDEX ACCORDINGLY. FREQUENTLY INDEX=0 (NO INDEXING) WHEN THE  *
!*       SOLUTION IS TRIVIAL. MODE=0 IF INDEX MUST BE COPIED BEFORE    *
!*       BEING ADJUSTED.                                               *
!***********************************************************************
%INTEGER J, K, D, PN
         FIND REG(GR1, J);              ! MAY NOT BE NEEDED
         CYC BITS=CYC BITS!16;          ! USES MULTIPLE OF 4K
         %IF DISP>0 %THEN %START
            K=X'5A';  D=DISP
         %FINISH %ELSE %START
            K=X'5B';  D=4095-DISP
         %FINISH
         PN=D>>12;  FAULT(98, 0) %IF PN>63
         %IF INDEX=0 %AND DISP>0 %THEN %START
            FIND USE(INDEX, 1, 11, PN); ! LOOK FOR 4K MULTIPLE
            ->98 %IF INDEX>0
            SET USE(J, 11, PN)
            INDEX=J;  K=X'58'
         %FINISH %ELSE %START
            %IF MODE=0 %OR INDEX=0 %THEN %START
               %IF MODE=0 %THEN PRR(X'18', J, INDEX) %ELSE %START
                  PRR(X'1F', J, J)
                  CCSTATE=-1
               %FINISH
               INDEX=J
            %FINISH
            FORGET(INDEX) %UNLESS GRUSE(INDEX)<=1
         %FINISH
         PRX(K, INDEX, CODER, 0, PN<<2+PTBASE)
98:      DISP=DISP&4095
%END
%ROUTINE DUMP(%INTEGER CODE, REG, DIS, X, LEVEL)
%SHORTROUTINE
                                        ! CODE=8*(TYPE-1)+2*(PREC&3)+Z
%INTEGER K
%BYTEINTEGER ANDR;  ANDR=0
%CONSTBYTEINTEGERARRAY OPCODE(0:16)=X'41',
         X'50',X'58',X'42',X'43',X'40',X'48',X'59',X'49',
         X'70',X'78',0(4),X'60',X'68'
         CODE=OPCODE(CODE) %IF CODE<=16
         FAULT(216,0) %IF CODE<X'40';        ! IN 'RR' RANGE
         %UNLESS 0<=DIS<=4095 %C
            %THEN ADJUST INDEX(REGISTER(X)+1, X, DIS)
         ->REG KNOWN %IF REG>=0
         %IF CODE=X'43' %START;         ! TRY TO AVOID CLEARING A REG
            K=-1-REG;                   ! 0 OR 1 IF ADDR MODE
            %WHILE REG<0 %AND K<=15 %CYCLE
               %IF REGISTER(K)=0 %AND GRUSE(K)=2 %AND GRINF(K)<=255 %C
                   %THEN NEST=K %AND REG=NEST
               K=K+1
            %REPEAT
         %FINISH
         %IF REG=-1 %THEN K=GR0 %ELSE K=GR1
         %IF 96<=CODE<=127 %THEN K=FR0
         %IF REG<0 %THEN FIND REG(K, REG) %AND NEST=REG
REGKNOWN:->IC %IF CODE=X'43';           ! BYTES NEED SPECIAL CARE
         ->NORMAL %UNLESS CODE=X'41' %AND DIS=0;  ! OPTIMISE LA
         ->ZERO %IF X=0=LEVEL
         ->SWOP %IF LEVEL=0 %OR X=0
         ->NORMAL %IF X#REG#LEVEL
         PRR(X'1A', REG, X+LEVEL-REG);  CCSTATE=1<<16!REG;  ->99
ZERO:    PRR(X'1F', REG, REG);  CCSTATE=1<<16!REG;  ->99
SWOP:    PRR(X'18', REG, X+LEVEL) %UNLESS REG=X+LEVEL;  ->99
IC:      ->NORMAL %IF GRUSE(REG)=2 %AND GRINF(REG)<=255
         CCSTATE=-1
         %IF REG=0 %OR X#REG#LEVEL %THEN PRR(X'1F', REG, REG) %C
            %ELSE ANDR=1
NORMAL:  PRX(CODE, REG, X, LEVEL, DIS)
         %IF ANDR#0 %THEN %START
            PRX(X'54', REG, 0, GLA, 24)
            CCSTATE=2<<16!REG
         %FINISH
99: %END
%ROUTINE DUMPSI(%INTEGER OPCODE, L, B, D)
%SHORTROUTINE
         %IF D>4095 %THEN ADJUST INDEX(REGISTER(B)+1, B, D)
         PSI(OPCODE, L, B, D)
%END
%ROUTINE DUMPM(%INTEGER OPCODE, R1, R2, B, D)
%SHORTROUTINE
         %IF D>4095 %THEN %START
            ADJUST INDEX(REGISTER(B)+1, B, D)
         %FINISH
         PRX(OPCODE, R1, R2, B, D)
%END
%ROUTINE DUMPSS(%INTEGER OP,L,B1,D1,B2,D2)
%SHORTROUTINE
         %IF D1>4095 %THEN %C
            ADJUST INDEX(0,B1,D1)
         %IF D2>4095 %THEN %C
            ADJUST INDEX(0,B2,D2)
         PSS(OP,L,B1,D1,B2,D2)
%END
         %END;                      ! OF ROUTINE CSS
         !*DELSTART
%ROUTINE CONSTLIST
%SHORTROUTINE
%INTEGER PRECP, NCONST, RF, J, K, LPUTP, KK, SIGN, RQ, BPTR,  %C
            TYPEP, ACC, RP, SHR
%INTEGERNAME CONSTP
%BYTEINTEGER CHAR
%LONGREAL C
%BYTEINTEGERARRAY BUFFER(0:264)
%ROUTINESPEC OUT(%INTEGER L, IA)
         NCONST=0;  BPTR=0
         SHR=A(2)&3;                    ! 0='%CONST'
         %IF SHR=0 %THEN CONSTP==SSTL %AND LPUTP=4 %ELSE%C
                         CONSTP==CONSTPTR %AND LPUTP=5
         CONSTP=(CONSTP+7)&(-8);        ! RELEVANT PTR TO D.W. BOUNDRY
         TOAR4(R+2, CONSTP)
         RP=R;  R=R+4
         TYPEP=TYPEFLAG(A(4));  PRECP=TYPEP>>3
         TYPEP=TYPEP&7
         PRECP=3 %IF TYPEP=2 %AND ALL LONG=1
         %IF TYPEP=5 %THEN  ACC=A(6) %ELSE ACC=BYTES(PRECP)
6:       RQ=Q;  CHAR=BYTE INTEGER(Q)
         SIGN=1
         %IF CHAR='-' %THEN SIGN=-1
         %IF CHAR='+' %OR CHAR='-' %THEN Q=Q+1
         CONST(0);  RF=1
         ->98 %IF HIT=0
         ->1 %UNLESS BYTE INTEGER(Q)='('
         J=S;  Q=Q+1;  C=CVALUE;  K=CTYPE
         CONST(2)
         ->98 %UNLESS HIT=1 %AND S>0 %AND BYTE INTEGER(Q)=')'
         Q=Q+1
         CVALUE=C;  RF=S;  S=J;  CTYPE=K
1:       %IF TYPEP=5 %THEN %START
            %IF CTYPE#5 %THEN %START
               ->98 %UNLESS CTYPE=1 %AND S<127
               A(RP+6)=S<<8;  S=1 %UNLESS S=0;  A(RP+5)=S
            %FINISH
            ->98 %UNLESS SIGN=1 %AND ACC>=A(RP+5)
         %FINISH %ELSE %START
            %IF CTYPE=5 %THEN ->98
            %IF TYPEP=2 %THEN %START
               %IF CTYPE=1 %THEN CVALUE=S
               %IF SIGN<0 %THEN CVALUE=-CVALUE
               J=ADDR(CVALUE)
            %FINISH %ELSE %START
               S=S*SIGN
               %IF (PRECP=1 %AND S&X'FFFFFF00'#0) %OR %C
                   (PRECP=2 %AND (!S!)&X'FFFF0000'#0) %THEN ->98
               J=ADDR(S)+4-ACC
            %FINISH
         %FINISH
         %CYCLE KK=1, 1, RF
            %IF TYPEP=5 %THEN OUT(ACC+1, ADDR(A(RP+5))+1) %ELSE %START
               **1,@BUFFER(BPTR);  *L_2,J
               *MVC_0(8,1),0(2);        ! MOVE IN CONSTANT RUBBISH
               BPTR=BPTR+ACC
               %IF BPTR=256 %THEN OUT(256, ADDR(BUFFER(0)))
            %FINISH;  NCONST=NCONST+1
         %REPEAT;  R=RP+4
         ->99 %UNLESS BYTE INTEGER(Q)=',';  Q=Q+1
         ->6 %UNLESS BYTE INTEGER(Q)=10
         READ LINE(0,0);  Q=ADDR(CC(1));  ->6
98:      Q=RQ
99:      R=RP+4;  TOAR4(RP, NCONST)
         %IF TYPEP#5 %AND BPTR>0 %THEN OUT(BPTR, ADDR(BUFFER(0)))
         CONSTP=(CONSTP+3)&(-4)
         ->999
%ROUTINE OUT(%INTEGER L, IA)
         LPUT(LPUTP, L, CONSTP, IA) %IF INHCODE=0
         CONSTP=CONSTP+L
         BPTR=0
%END
999: %END
%ROUTINE TEXTTEXT
%INTEGER J, QU, ARAD
         S=R; HIT=0
         J=0; ARAD=ADDR(A(R+1))
         %RETURN %UNLESS I=M'''' %OR I=34;! FAIL UNLESS  INITIAL QUOTE
         QU=I; Q=Q+1
         %CYCLE
            I=BYTE INTEGER(Q)
            %IF I=QU %THEN %START
               Q=Q+1
               %IF BYTE INTEGER(Q)#QU %THEN %EXIT
            %FINISH
            BYTEINTEGER(ARAD)=I
            ARAD=ARAD+1; J=J+1
            %IF I=10 %THEN READ LINE(1,QU) %ELSE Q=Q+1
            FAULT(106,0) %IF J>=256
         %REPEAT
         A(S)=J;   HIT=1
         R=R+(J+1)>>1
%END
         !*DELEND
         %ROUTINE     TOAR4(%INTEGER PTR,VALUE)
         **1,@A(PTR)
         *MVC_0(4,1),VALUE
         %END
         %ROUTINE     TOAR8(%INTEGER PTR,%LONGREAL VALUE)

         **1,@A(PTR)
         *MVC_0(8,1),VALUE
         %END
         %ROUTINE     FROMAR4(%INTEGER PTR,%INTEGERNAME VALUE)
         **1,@A(PTR)
         *L_2,VALUE
         *MVC_0(4,2),0(1)
         %END
         %ROUTINE     FROMAR8(%INTEGER PTR,%LONGREALNAME VALUE)

         **1,@A(PTR)
         *L_2,VALUE
         *MVC_0(8,2),0(1)
         %END
         !*DELSTART
%ROUTINE CONST(%INTEGER MODE)
!***********************************************************************
!*       SYNTAX CHECK AND EVALUATE ALL THE FORMS OF IMP CONSTANT       *
!*       MODE#0 FOR INTEGER CONSTANTS =0 FOR ANY SORT OF CONSTANT      *
!***********************************************************************
%INTEGER Z,T;%LONGREAL X
         HIT=0
         CVALUE=0;  I=BYTE INTEGER(Q)
         S=0;  ->N %IF M'0'<=I<=M'9'
         ->DOT %IF I='.' %AND MODE=0 %AND '0'<=BYTE INTEGER(Q+1)<='9'
                                        ! 1 DIDT MIN
         CTYPE=1
         ->PI %IF I='$'
         ->STR %IF I=M''''
         ->STR2 %IF I=34
         %RETURN %UNLESS BYTE INTEGER(Q+1)=M'''';  Q=Q+2
         ->HEX %IF I='X'
         ->MULT %IF I='M'
         ->BIN %IF I=M'B'
         ->RHEX %IF I='R' %AND MODE=0
         ->OCT %IF I='K'
         Q=Q-2;  %RETURN
PI:      Q=Q+1;                         ! '$'=3.14159ETC
         *MVC_CVALUE(8),PI1
         %IF MODE=0 %THEN CTYPE=2 %AND HIT=1
         WARN(LINE)
         %RETURN
STR:     A(R)=5;  R=R+1
         TEXTTEXT
         %IF A(S)>1 %THEN CTYPE=5 %AND %RETURN
         R=S-1
         %IF A(S)=0 %THEN S=0 %ELSE S=A(S+1)>>8
         HIT=1; %RETURN
STR2:                                   ! DOUBLE QUOTED STRING
         A(R)=5; R=R+1; TEXTTEXT
         CTYPE=5; %RETURN
HEX:     T=0;                           ! HEX CONSTANTS
         %CYCLE
            I=BYTE INTEGER(Q); Q=Q+1; T=T+1
            %EXIT %IF I=M''''
            %RETURN %UNLESS ('0'<=I<='9' %OR 'A'<=I<='F') %AND T<9
            S=S<<4+I&15+9*I>>6
         %REPEAT
         HIT=1; %RETURN
RHEX:                                   ! REAL HEX CONSTANTS
         T=0
         %CYCLE
            I=BYTE INTEGER(Q); Q=Q+1
            %IF T=8 %THEN INTEGER(ADDR(CVALUE))=S %AND S=0
            %EXIT %IF I=M''''; T=T+1
            %RETURN %UNLESS '0'<=I<='9' %OR 'A'<=I<='F'
            S=S<<4+I&15+9*I>>6
         %REPEAT
         %RETURN %UNLESS T=8 %OR T=16
         INTEGER(ADDR(CVALUE)+4)=S
         HIT=1; CTYPE=2; %RETURN
OCT:                                    ! OCTAL CONSTANTS
         T=0
         %CYCLE
            I=BYTE INTEGER(Q); Q=Q+1; T=T+1
            %EXIT %IF I=M''''
            %RETURN %UNLESS '0'<=I<='7' %AND T<12
            S=S<<3!(I&7)
         %REPEAT
         HIT=1; %RETURN
MULT:    T=0;                           ! MULTIPLE CONSTANTS
         %CYCLE
            I=BYTE INTEGER(Q); Q=Q+1; T=T+1
            %IF I=M'''' %THEN %START
               %IF BYTE INTEGER(Q)#M'''' %THEN %EXIT %ELSE Q=Q+1
            %FINISH
            %RETURN %IF T>=5
            S=S<<8!I
         %REPEAT
         HIT=1; %RETURN
BIN:     T=0;                           ! BINARY CONST
         %CYCLE
            I=BYTE INTEGER(Q); Q=Q+1; T=T+1
            %EXIT %IF I=M''''
            %RETURN %UNLESS '0'<=I<='1' %AND T<33
            S=S<<1!I&1
         %REPEAT
         HIT=1; %RETURN
N:                                      ! CONSTANT STARTS WITH DIGIT
         %UNTIL I<M'0' %OR I>M'9' %CYCLE
            %IF S>X'7FFFFFF' %THEN ->BIGN
            S=10*S+I&15
            Q=Q+1; I=BYTEINTEGER(Q)
         %REPEAT
         %IF I='.' %OR I='@' %THEN CVALUE=S %AND ->FTEST
         CTYPE=1; HIT=1; %RETURN
BIGN:    CVALUE=S;                      ! NUMERIC CONSTANTS TOO BIG
                                        ! FOR EVALUATION IN INTEGERS
         %UNTIL I<M'0' %OR I>M'9' %CYCLE
            CVALUE=10*CVALUE+(I&15)
            Q=Q+1; I=BYTE INTEGER(Q);             ! ONTO NEXT CHAR
         %REPEAT
FTEST:   ->ALPHA %UNLESS MODE=0 %AND I='.'
DOT:     Q=Q+1;  X=10; I=BYTE INTEGER(Q)
         %WHILE M'0'<=I<=M'9' %CYCLE
            CVALUE=CVALUE+(I&15)/X
            X=10.0*X; Q=Q+1; I=BYTE INTEGER(Q)
         %REPEAT
ALPHA:                                  ! TEST FOR EXPONENT
         %IF MODE=0 %AND BYTE INTEGER(Q)='@' %THEN %START
            Q=Q+1;  X=CVALUE
            Z=1; I=BYTE INTEGER(Q)
            %IF I='-' %THEN Z=-1
            %IF I='+' %OR I='-' %THEN Q=Q+1
            CONST(2)
            %IF HIT=0 %THEN %RETURN
             S=S*Z
            %IF S=-99 %THEN CVALUE=0 %ELSE CVALUE=X*10**S
         %FINISH
                                        ! SEE IF IT IS INTEGER
FIX:     %COMMENT SEE IF IT IS INTEGER
         -> TOO BIG %IF CVALUE>IMAX
!
! THE NEXT LINE IS HAND CODED TO AVOID CALLING IN FRACPT ETC ON 370
!
!         ->41 %IF FRACPT(CVALUE)=0
!
         *LD_0,CVALUE
         *LDR_2,0
         *AW_0,208(12);                 ! -X'4E000000000000000'
         *AD_0,192(12);                 ! =D'0'
         *SDR_2,0
         *BC_8,<41>
TOO BIG: -> 150 %UNLESS MODE=0
40:      CTYPE=2; HIT=1; %RETURN
41:      *LD_0,CVALUE
         *AD_0,192(12);          ! AD_0,=D'0.5'
         *AW_0,208(12)
         *STD_0,0(11)
         *MVC_S(4),4(11);        ! S=INT(CVALUE)
99:      CTYPE=1; HIT=1; %RETURN
150:     HIT=0;                        ! FAILURE
         %END
         %ROUTINE PNAME
         %SHORTROUTINE; HIT=0; NUM=0
         *L_6,Q
         *L_3,TRTABS
         *SR_1,1; *LR_2,1; *ST_1,NUM
         *STM_1,2,0(11)
         *TRT_0(255,6),0(3)
         *LR_0,1; *SR_1,6;              ! LENGTH IN GR1

         *BC_8,<3>;                     ! ZERO LENGTH = NOT A NAME
         *BCT_2,*+8
         *BC_15,<3>;                    ! NAME END IN QUOTE =FAIL
         *L_14,LETT; *L_3,NEXT; *AR_3,14
         *STC_1,0(3);                   ! MOVE IN LENGTH
         *EX_1,<NAMMOVE>;               ! MOVE IN CHARS (+1 XTRA)
         *EX_1,<MOVEP>
         *LR_6,0; *ST_6,Q;              ! UPDATE TEXT POINTER
         *LH_2,0(11); *MH_2,HH1
         *LH_0,2(11); *MH_0,HH1+2; *ALR_2,0
         *LH_0,4(11); *MH_0,HH2; *ALR_2,0
         *LH_0,6(11); *MH_0,HH2+2; *ALR_2,0
         *LR_4,2;                       ! INITIAL HASH VALUE
         *SRL_2,9; *STC_2,NUM+3
         *OI_NUM+3,2; *NI_NUM+3,62
         *L_15,WORD; *L_5,NNAMES
         *LA_0,0(5,5)
         *ALR_4,4
LOOKL:   *NR_4,0;                       ! TO KEEP WITHIN WORD
         *LH_2,0(4,15);                 ! GET WORD(I)
         *LTR_2,2; *BC_8,<NEWNAME>;     ! EMPTY HOLE FOR NEW NAME
         *AR_2,14; *EX_1,<NAMCOMP>;     ! COMPARE
         *BC_8,<FOUND>
         *A_4,NUM
         *BCT_5,<LOOKL>
         FAULT(104,0)
NAMCOMP: *CLC_0(1,2),0(3)
NAMMOVE: *MVC_1(1,3),0(6)
MOVEP:   *MVC_0(1,11),0(3)
DFULL:   FAULT(103,0)
NEWNAME: *SR_3,14; *STH_3,0(4,15)
         *LA_3,1(1,3); *ST_3,NEXT;      ! UPDATE NEXT TO INCLUDE NEWNAME
         *CH_3,DSIZE; *BC_2,<DFULL>
FOUND:   *SRL_4,1; *L_2,R; *AR_2,2
         *STH_4,A+30(2)
         HIT=1
3:       %END
         !*DELEND
8:        %BEGIN
         %SHORTROUTINE
         %INTEGER I,J,K
1:       FETCH AR
         STMTSHELD=STMTSHELD+1
         STPTRS(STMTSHELD)=1
         STOPSTM=1 %UNLESS A(1)<=6 %OR A(1)=14
20:      %IF STOPSTM#0 %OR CHECKSP#0 %THEN ->10
         STORE AR(I); -> 10 %IF I=0
         STPTRS(STMTSHELD)=TOPPTR-R
         -> 1
10:      CSS(STPTRS(1),1)
!         CHECK ASL %IF PRINTMAP#0
         %IF DCOMP#0 %AND CA>CABUF %THEN %START
            CODE OUT
            PRINT USE
         %FINISH
         STMTSHELD=STMTSHELD-1
         %IF STMTSHELD=0 %THEN %START
         STOPSTM=0
         TOPPTR=500; -> 1; %FINISH
         %IF STMTSHELD=1 %THEN %START
          STPTRS(1)=1
         TOPPTR=500; -> 20; %FINISH
         J=STPTRS(2)-STPTRS(1)
!         %CYCLE I=500,1,TOPPTR-J
!         A(I)=A(I+J)
!         %REPEAT
         TOPPTR=TOPPTR-J
         *L_3,A; *LA_3,1000(3)
         *L_2,J; *AR_2,2; *AR_2,3
         *L_1,TOPPTR; *AR_1,1; *LA_0,998; *SR_1,0
         *LA_0,256
M2:      *SR_1,0; *BC_4,<M3>
         *MVC_0(256,3),0(2); *BC_8,<M4>
         *AR_3,0; *AR_2,0; *BC_15,<M2>
M5:      *MVC_0(1,3),0(2)
M3:      *BCTR_1,0; *EX_1,<M5>
M4:      %CYCLE I=1,1,STMTSHELD-1
         STPTRS(I)=STPTRS(I+1)-J
         %REPEAT; STPTRS(STMTSHELD)=1; -> 20
         %END
         %ROUTINE FETCH AR
         %SHORTROUTINE
         !*DELSTART
1:       %IF Q>=LENGTH %THEN READ LINE(0,0) %AND Q=ADDR(CC(1))
         R=1; OLDLINE=LINE; A(0)=LINE; QMAX=Q
         COMPARE
         %IF R>ARSIZE %AND R>ARSIZE+300*CHECKSP %THEN FAULT(102,0)
         %IF HIT=0 %THEN %START
         FAULT(100,0); -> 1
         %FINISH
         -> 1 %IF  A(1)=10 %OR A(1)=29
         !*DELEND
         STMTS=STMTS+1
         %END
         %ROUTINE STORE AR(%INTEGERNAME SUCCESS)
         %SHORTROUTINE
         %INTEGER I
         SUCCESS=0
         %RETURN %IF STMTSHELD>=14 %OR R+TOPPTR>=799
!         %CYCLE I=0,1,R
!         A(TOPPTR+I)=A(I)
!         %REPEAT
         *L_2,A; *L_3,TOPPTR
         *AR_3,3; *AR_3,2
         *LA_1,1; *A_1,R; *AR_1,1
         *LA_0,256
M2:      *SR_1,0; *BC_4,<M3>
         *MVC_0(256,3),0(2); *BC_8,<M4>
         *AR_3,0; *AR_2,0; *BC_15,<M2>
M5:      *MVC_0(1,3),0(2)
M3:      *BCTR_1,0; *EX_1,<M5>
M4:      TOPPTR=TOPPTR+R+1
         SUCCESS=1
         %END
         !*DELSTART
         %ROUTINE     READ LINE(%BYTEINTEGER N,CHAR)
         %SHORTROUTINE
         %ROUTINESPEC GET LINE
         %OWNINTEGER LAST=-1
         %BYTEINTEGER NP
         %REGISTER ATRTABS
         %OWNINTEGER M127=127
         %REGISTER DEL
         %INTEGER LL,L73,PAD
         %CONSTBYTEINTEGERARRAY TR(0:127)=1,0(9),1,0(117)
         %BYTEINTEGERARRAY TLINE(0:255)
         ATRTABS=ADDR(TRTABS(0))
         NP=N; LENGTH=1; LENGTHP=1
         DEL=0; QMAX=ADDR(CC(1))
1:       LENGTH=LENGTH-1
2:                                     ! READ IN A LINE
         %IF FILE ADDR=0 %THEN GET LINE %ELSE %START
            LL=FILE END-FILE PTR-1
            %MONITOR 9 %IF LL<0
            *L_14,LL; *LA_15,255
            *L_3,FILEPTR; *L_4,TR; *SR_1,1
            *CR_14,15; *BC_10,*+6; *LR_15,14
            *EX_15,<TRTP>
            *BC_7,*+8; *LA_1,0(15,3)
            *LA_15,1(1); *SR_1,3
            *L_4,TLINE; *EX_1,<MOVEP>
            *LA_1,1(1); *ST_1,LL
            *ST_15,FILEPTR; *IC_1,73(4); *ST_1,L73
            *ST_4,PAD; *MVI_73(4),10
         %FINISH
         *L_4,CC; *A_4,LENGTH;      ! SET POINTER TO CC FORRCL
         *L_1,TLINE;                ! POINTER TO RAW LINE
         *L_0,LL; *AR_0,1;          !ADDR OF LAST CHAR
         *SR_2,2;                   ! TO RECEIVE CHAR TYPE FROM TRT
         *CLI_NP,0; *BC_8,<NEXT>;      ! TEXT MODE SEPARATE
         *MVI_1187(5),0; *MVI_1192(5),0; *BC_15,<TNEXT>
UNFIN:   *S_4,CC; *ST_4,LENGTH; *BC_15,<2>
NEXT:    *LA_1,1(0,1)
SAME:    *TRT_0(255,1),768(5);         ! EXTRACT NEXT VALID CHAR
         *CR_1,0; *BC_12,<TAB>(2);     ! SWITCH ON CHAR
TAB:     *BC_15,<UNFIN>;               ! UNLESS ENDOFLINE WITHOUT NL
         *BC_15,<QUOTE>
         *BC_15,<SP>
         *BC_15,<NL>
         *BC_15,<PERCENT>
         *BC_15,<NONALPHA>
         *BC_15,<ALPHA>
         *BC_15,<MAP>
QUOTE:   *XI_NP,1
         *MVC_CHAR(1),0(1);             ! SAVE STRING OPENING CHAR
         *MVC_1(1,4),CHAR
         *LA_1,1(0,1); *LA_4,1(0,4)
         *MVI_1281(5),0;               ! TRTAB TO SKIP 7
         *MVI_1192(5),0;               ! TRTAB TO SKIP PERCENT
         *MVI_1187(5),0; *BC_15,<TCOM>;! TRTAB TO SKIP SPACE
SP:      *SR_6,6
         *TRT_0(255,1),897(5);         ! NEXT VALID NON SPACE
         *CR_1,0; *BC_12,<TAB>(2);     ! SWITCH ON CHAR
         *BC_15,<UNFIN>
NL:      *SR_6,6                       ;! DEL=0
         *MVI_1(4),10;                 ! MOVE IN NEWLINE
         *LA_4,1(0,4); *BC_15,<ENDLINE>
PERCENT: *LA_6,128;                    ! DEL=128
         *LA_1,1(0,1)
         *LNR_3,1
         *LR_15,1
         *TRT_0(39,1),1026(5)
         *BC_8,<SAME>
         *AR_3,1
         *BC_8,<SAME>
         *EX_3,<MOVE>
         *EX_3,<ULINE>
         *LA_4,0(3,4)
         *N_2,M127
         *BC_7,<TAB>(2)
         *BC_15,<SAME>
TRTP:    *TRT_0(1,3),0(4)
MOVEP:   *MVC_1(1,4),0(3)
MOVE:    *MVC_1(0,4),0(15)
ULINE:   *OC_1(0,4),0(5);              ! OR WITH X'80'
NONALPHA:*SR_6,6;                      ! DEL=0
ENBLOCK: *LNR_3,1;*LR_15,1
         *TRT_0(255,1),1155(5);        !TEST FOR ALPHANUMERICS
         *AR_3,1
         *EX_3,<MOVE>;                 ! QUICKER TO MOVE 1 TOO MANY
         *LA_4,0(3,4)
         *N_2,M127
         *BC_7,<TAB>(2)
         *BC_15,<SAME>
ALPHA:   *LTR_6,6;                     ! -> ENBLOCK %IF DEL=0
         *BC_8,<ENBLOCK>
         *MVC_1(1,4),0(1)
         *OI_1(4),128
         *LA_4,1(0,4);*BC_15,<NEXT>
MAP:     *SR_6,6;                      ! DEL=0
         *MVI_1(4),92;                 ! MAP TWIDDLES INTO '\'
         *LA_4,1(0,4); *BC_15,<NEXT>
TUNFIN:  *S_4,CC; *ST_4,LENGTH; *BC_15,<2>
TNEXT:   *LA_1,1(0,1)
TSAME:
         *TRT_0(255,1),768(5);         ! EXTRACT NEXT VALID CHAR
         *CR_1,0; *BC_12,<TTAB>(2);    ! SWITCH ON CHAR
TTAB:    *BC_15,<TUNFIN>
         *BC_15,<TQUOTE>
         *BC_15,<TCOM>
         *BC_15,<TNL>
         *BC_15,<TCOM>
         *BC_15,<TCOM>
         *BC_15,<TCOM>
         *BC_15,<TCOM>
TQUOTE:
         *MVC_1(1,4),0(1)
         *LA_4,1(0,4)
         *CLC_CHAR(1),0(1)
         *BC_7,<TNEXT>;                 ! NOT THE CLOSING CHAR
         *XI_NP,1
         *MVI_1281(5),28;              ! TRTAB AS INITIALISED FOR \
         *MVI_1187(5),8;               ! TRTAB AS INITIALISED
         *MVI_1192(5),16;              ! TRTAB AS INITIALISED
         *SR_6,6;
         *BC_15,<NEXT>
TCOM:    *LNR_3,1; *LR_15,1
         *TRT_0(255,1),1155(5)
         *AR_3,1; *EX_3,<MOVE>;        ! MOVES ONE MORE THAN NEEDED
         *LA_4,0(3,4); *N_2,M127
         *BC_7,<TTAB>(2); *BC_15,<TSAME>
TNL:     *CLI_0(4),32;                 ! CHECK FOR TRAILING SPACES
         *BC_7,<TNL2>
         *BCT_4,<TNL>
TNL2:    *MVI_1(4),10;                 ! MOVE IN NEWLINE
         *MVI_1281(5),28;              ! TRTAB AS INITIALISED FOR \
         *MVI_1192(5),16; *MVI_1187(5),8;! TRTAB AS INITIALISED
         *LA_4,1(0,4)
ENDLINE: *S_4,CC; *ST_4,LENGTH
         ->1 %IF LENGTH=LENGTHP %AND N=0;! IGNORE NL IN PRGRMODE
         -> NOLIST %IF LIST=0
         NEWLINE; %IF LINE=LAST %THEN %START
         SPACES(5);PRINT SYMBOL('C')
         %IF PRINTMAP=1 %THEN SPACES(3*LEVEL+5) %ELSE SPACES(4*LEVEL)
         %FINISH %ELSE %START
         WRITE(LINE+1,5)
         LAST=LINE
         PRINTSYMBOL(M'''') %IF N=1
         SPACES(2-N)
         %IF PRINTMAP=1 %THEN PRHEX(CA,5)
         SPACES((4-PRINTMAP)*LEVEL-2)
         %FINISH
         TLINE(73)=L73; BYTE INTEGER(PAD)=LL-1
         IOCP(15,PAD);       ! PRINTSTRING EXCEPT FINAL NL
NOLIST:
         ->5 %UNLESS LENGTH>=2 %AND CC(LENGTH-1)=195;!%C   AT LINE EDN
         LENGTH=LENGTH-2; LENGTHP=LENGTHP+1
20:      %COMMENT ALL THE FOLLOWING IS TO SKIP NLS AFTER '%C'
         GET LINE
         *L_4,CC; *A_4,LENGTH;      ! SET POINTER TO CC FORRCL
         *L_1,TLINE;                 ! POINTER TO RAW LINE
         *L_0,LL; *AR_0,1;          ! ADDR OF LAST CHAR
         *SR_2,2;                   ! TO RECEIVE CHAR TYPE FROM TRT
NEXTP:   *LA_1,1(0,1); *TM_0(1),128
         *BC_1,<NEXTP>; *CLI_0(1),10
         *BC_8,<20>; *BC_15,<SAME>
5:       LINE=LINE+1
         FAULT(101,0) %IF LENGTH>=CCSIZE
         *L_4,LENGTH; *A_4,CC
         *ST_4,LENGTH
         *XC_1(3,4),1(4);              !CLEAR BEYOND NL
         Q=ADDR(CC(1))
         %RETURN
         %ROUTINE GET LINE
         %INTEGER J,K
         %IF FILE ADDR=0 %THEN %START;  ! SOURCE NOT A 'CLEAN' FILE
            IOCP(6,0);                  ! RECONSTRUCT A SOURCE LINE
            *L_2,TLINE;                  ! TO RECEIVE A COPY
            *SR_3,3; *IC_3,0(1);        ! LENGTH
            *EX_3,<MOVE>;               ! MAKE COPY OF LINE
            *ST_3,LL;                   ! LL=LENGTH+1
            L73=TLINE(73)
           IOCP(14,0); *ST_1,PAD
         %FINISH %ELSE %START
            LL=FILE END-FILE PTR-1
            %IF LL<0 %THEN %MONITOR 99
!            LL=0
!            %UNTIL K=NL %OR K=0 %CYCLE
!               K=BYTE INTEGER(FILEPTR); ! NEXT CHAR FROM SORCE FILE
!               FILE PTR=FILE PTR+1
!               TLINE(LL+1)=K
!               LL=LL+1 %IF LL<250
!            %REPEAT
!            L73=TLINE(73);              ! SAVE 73 CHARACTER
!            TLINE(73)=10
!            PAD=ADDR(TLINE(0))
            *L_14,LL; *LA_15,255
            *L_3,FILEPTR; *L_4,TR; *SR_1,1;! TRT DOES NOT CLEAR R1!
            *CR_14,15; *BC_10,*+6; *LR_15,14
            *EX_15,<TRTP>
            *BC_7,*+8; *LA_1,0(15,3)
            *LA_15,1(1); *SR_1,3;       ! LL-1 IN R1
            *L_4,TLINE; *EX_1,<MOVEP>
            *LA_1,1(1); *ST_1,LL
            *ST_15,FILEPTR
            *IC_1,73(4); *ST_1,L73
         *ST_4,PAD; *MVI_73(4),10
         %FINISH
         %RETURN
MOVE:    *MVC_0(1,2),0(1)
TRTP:    *TRT_0(1,3),0(4)
MOVEP:   *MVC_1(1,4),0(3)
         %END
         %END
               %ROUTINE COMPARE
         %SHORTROUTINE
         %INTEGER RA,RQ,RR,RS
         %SHORTINTEGER RP,PP,ALT,MARKER
         %OWNINTEGER THIRTYTWO=32






! GENERATED ON 27/04/77
%CONSTSHORTINTEGERARRAY SYMBOL( 1059: 2900)= 299,   301,   296,   297,     1062
   289,   300,   713, 50694, 54734, 52421, 54227,  1495, 51401, 52421,     1072
  1493, 52948, 51660,  1987, 53197, 52677, 52948,  1993, 52948, 50631,     1082
 50642,  1234, 50625, 52228, 49881, 54469,  1491, 51407, 53972,  1228,     1092
 53198, 50950, 54228, 53961, 52935,  2002, 53205, 54473, 52933,   710,     1102
 52739, 52673, 53252, 52929, 52677,  1746, 50627, 53202, 50181, 49618,     1112
 53953, 55561, 49618, 53953, 55758, 49613, 50441, 53190, 53458, 53191,     1122
 53953, 52486, 53190, 50889, 52421,  1743, 50892, 51667, 54279, 53190,     1132
 52675, 53188, 50438, 50895, 53965, 49620,  1235, 53445, 49923, 49614,     1142
 50178, 53202,  1742, 53202, 52673, 52225, 14852, 53445, 53965,  1225,     1152
 53187, 53254, 52673, 51662, 50640,   975, 55246,  2245, 55508, 50642,     1162
 52929, 52233, 50648, 54482, 51662, 54217, 49925, 50127, 52947, 54274,     1172
 11582,  1235, 54479, 53253, 54228, 49618, 54281, 54472, 50638, 54228,     1182
 49618, 54276, 54472, 50638,  1475, 55747, 52421,  2516, 51397, 52931,     1192
 55747, 52421,  2501, 52435, 50643, 54465, 53972,  1221, 52435, 50433,     1202
 24325, 50646, 50638, 54273, 15622, 54233, 54228, 50637,  1988, 55758,     1212
 49613, 51651,   316,   318,   298,   336,  1104, 21844, 24327, 21843,     1222
 18766, 18218, 11268, 17490, 20304,   320,  2512, 53961, 52948, 54469,     1232
 55508,  1746, 50644, 54738, 52742, 53957, 54229, 52436,  1997, 53198,     1242
 51668, 53202,  1221, 55497, 54278, 53957, 53445, 49620,   965, 52932,     1252
  1490, 50625, 52435,  1474, 50631, 51662,  1478, 49621, 52436,  1734,     1262
 51662, 51667, 51206, 54231, 51668, 50120,  1228, 51667, 54279, 54224,     1272
 50627, 51649, 52231, 54482, 54739, 54469, 50183, 53458, 53191, 53953,     1282
 52488, 53957, 51145, 54228, 50642,  1485, 50127, 50373,  1987, 53198,     1292
 54482, 53196,  1732, 50630, 51662, 50434, 53198,  2624,  2610,-11008,     1302
 24576, 30791,  2618,-11008, 24576, 30793,  2624, 18416, 12296,  2686,     1312
  2640, 18416, 12300,  2035,  2754,  2035,  4152,  2650, 18416, 12308,     1322
  2035,  2686,  2668,-11008, 24576, 30795,  2035,  2708,-11008, 24576,     1332
 30797,  2686,-11008, 24576, 30799,  2035,  2708,-11008, 24576, 30799,     1342
  2708,  2702, 18416, 12300,  2035,  2754,  2035,  4152,  2708, 18416,     1352
 12296,  2732,  2732, 18416, 12336, 18416, 12384,  2035,  2624, 18416,     1362
 12340,  2035,  2732,  2754,  2748, 18416, 12388,  2035,  2624, 18416,     1372
 12292,  2754, 18416, 12296,  2784,  2778,-11008, 24576, 30795,  2035,     1382
  2708,  2035,  2784,-11008, 24576, 30797,  2784, 18416, 12296,  2808,     1392
  2802,-11008, 24576, 30801,  2035,  2708, 18416, 12292,  2808, 18416,     1402
 12296,  2824,  2818,-11008, 24576, 30801,  2824, 18416, 12296,  2842,     1412
  2834,-11007, 24576, 30803,  2842,-11003, 24576, 30806,  2860,  2852,     1422
-11004, 24576, 30813,  2860,-11004, 24576, 30819,  2878,  2870,-11008,     1432
 24576, 30799,  2878,-11002, 24576, 30825,  2950,  2888,-11002, 24576,     1442
 30833,  2896,-11005, 24576, 30841,  2910,-11005, 24576, 30846,-11002,     1452
 24576, 30833,  2924,-11004, 24576, 30851,-11002, 24576, 30833,  2938,     1462
-11005, 24576, 30857,-11005, 24576, 30841,  2950,-11003, 24576, 30862,     1472
  2035,  5106,  2970,  2960,-11002, 24576, 30869,  2970,  2035,  2878,     1482
  2035,  2970,  2988,  2980,-11007, 24576, 30877,  2988,-11006, 24576,     1492
 30880,  3036,  3000,  2035,  2950,  2035,  3084,  3010,  2035,  2878,     1502
  2035,  3100,  3018,-11005, 24576, 30884,  3036,-11003, 24576, 30889,     1512
  2035,  3068,-11005, 24576, 30884,  3050,  3044, 18416, 12316,  3050,     1522
 18416, 12300,  3068,  3058, 18416, 12316,  3068, 18416, 12300,  2035,     1532
  2754,  3084,  3078,-11004, 24576, 30896,  3084, 18416, 12296,  3100,     1542
  3094,-11005, 24576, 30884,  3100, 18416, 12296,  3124,  3110,-11000,     1552
 24576, 30902,  3118,-11005, 24576, 30884,  3124, 18416, 12296,  3158,     1562
  3152,-11008, 24576, 30795,  2035,  2988, 18416, 12332,  2035,  3158,     1572
-11008, 24576, 30797,  3158, 18416, 12296,  3184,  3178,  2035,  2808,     1582
  2035,  2988, 18416, 12332, 18416, 12292,  3184, 18416, 12296,  3224,     1592
  3194,-11000, 24576, 30912,  3202,-11003, 24576, 30922,  3210,-11003,     1602
 24576, 30929,  3218,-11002, 24576, 30936,  3224, 18416, 12296,  3240,     1612
  3234,-11003, 24576, 30944,  3240, 18416, 12296,  3344,  3274,-11003,     1622
 24576, 30944, 18416, 12300,-11008, 24576, 30795,  2035,  4466,  2035,     1632
  4442,-11008, 24576, 30797,  3314,-11005, 24576, 30951, 18416, 12336,     1642
 18416, 12300,  2035,  4132, 18416, 12340,-11008, 24576, 30795, 18416,     1652
 12300,-11008, 24576, 30797,  3344, 18416, 12336,  2035,  3616, 18416,     1662
 12340,-11008, 24576, 30795, 18416, 12300,-11008, 24576, 30797,  3386,     1672
  3364,  2035,  2708, 18416, 12396,  2035,  2708,  2035,  3386,  3386,     1682
-11008, 24576, 30795,  2035,  3344,  2035,  3404,-11008, 24576, 30797,     1692
  3404,  3398, 18416, 12396,  2035,  2708,  3404, 18416, 12296,  3444,     1702
  3422,-11006, 24576, 30956,  2035,  3344,  2035,  3444,  3438,-11007,     1712
 24576, 30960,  2035,  3344,  2035,  3468,  3444, 18416, 12296,  3468,     1722
  3462,-11006, 24576, 30956,  2035,  3344, 18416, 12292,  3468, 18416,     1732
 12296,  3492,  3486,-11007, 24576, 30960,  2035,  3344, 18416, 12292,     1742
  3492, 18416, 12296,  3510,  3504, 18416, 12392,  2035,  2708,  3510,     1752
 18416, 12296,  3526,  3520,-11005, 24576, 30951,  3526, 18416, 12296,     1762
  3544,  3536,-11005, 24576, 30857,  3544,-11003, 24576, 30963,  3578,     1772
  3572,-11008, 24576, 30801,  2035,  2708,-11008, 24576, 30970,  2035,     1782
  2708, 18416, 12292,  3578, 18416, 12296,  3616,  3592,-11005, 24576,     1792
 30972, 18416, 12328,  3604,-11005, 24576, 30977, 18416, 12328,  3616,     1802
-11003, 24576, 30982, 18416, 12328,  3644,  3628,  2035,  3100, 18416,     1812
 12332,  3644,-11004, 24576, 30896,  2035,  3224,  2035,  3644,  3660,     1822
  3660, 18416, 12332,  2035,  4196,  2035,  3660,  3680,  3674,-11008,     1832
 24576, 30801,  2035,  3644,  3680, 18416, 12296,  3732,  3708, 18416,     1842
 12336, 18416, 12332,  2035,  4236, 18416, 12340,  2035,  3732, 18416,     1852
 12320,  3732,-11004, 24576, 30896, 18416, 12300,  2035,  3802,  2035,     1862
  5132, 18416, 12312,  3768,  3762,-11008, 24576, 30801, 18416, 12336,     1872
 18416, 12332,  2035,  4236, 18416, 12340, 18416, 12292,  3768, 18416,     1882
 12296,  3802,  3778,-11006, 24576, 30989,  3786,-11001, 24576, 30993,     1892
  3794,-11000, 24576, 31002,  3802,-11004, 24576, 31012,  3840,  3840,     1902
-11008, 24576, 30795,  2035,  2600, 18416, 12304,-11008, 24576, 30970,     1912
  2035,  2600, 18416, 12304,-11008, 24576, 30797,  3864,  3858,-11008,     1922
 24576, 30801, 18416, 12316, 18416, 12292,  3864, 18416, 12296,  3890,     1932
  3890, 18416, 12316,  2035,  3840,-11007, 24576, 31018,  2035,  3036,     1942
  2035,  3890,  3910,  3904,-11008, 24576, 30801,  2035,  3864,  3910,     1952
 18416, 12296,  3932,  3920,-11005, 24576, 31021,  3926, 18416, 12316,     1962
  3932, 18416, 12296,  3960,  3954,-11008, 24576, 30801, 18416, 12332,     1972
  2035,  3802, 18416, 12292,  3960, 18416, 12296,  4012,  3970,-11008,     1982
 24576, 30970,  3988,  2035,  2824,  2035,  3344,  2035,  3404, 18416,     1992
 12320,  4006,  2035,  2842,  2035,  3344,  2035,  3404, 18416, 12320,     2002
  4012, 18416, 12320,  4054,  4022,-11004, 24576, 31026,  4030,-11000,     2012
 24576, 31032,  4054,-11005, 24576, 31042, 18416, 12336,  2035,  5164,     2022
 18416, 12340,  2035,  4104,  4084,  4064,-11004, 24576, 31047,  4072,     2032
-11000, 24576, 31053,  4084,-11005, 24576, 31042,  2035,  5164,  4104,     2042
  4098,-11006, 24576, 30956,  2035,  5164,  4104, 18416, 12296,  4132,     2052
  4114,-11000, 24576, 31063,  4126,-11005, 24576, 31073,  2035,  5164,     2062
  4132, 18416, 12296,  4152,  4146,-11008, 24576, 31078, 18416, 12300,     2072
  4152, 18416, 12296,  4180,  4174,-11008, 24576, 31078, 18416, 12300,     2082
  2035,  2754,  2035,  4152,  4180, 18416, 12296,  4196,  4190,-11004,     2092
 24576, 31080,  4196, 18416, 12296,  4236,  4204,  2035,  3802,  4236,     2102
-11008, 24576, 30795,  2035,  2708,-11008, 24576, 30970,  2035,  2708,     2112
  2035,  3544,-11008, 24576, 30797,  4260,  4254,-11008, 24576, 31086,     2122
 18416, 12384, 18416, 12308,  4260, 18416, 12296,  4296,  4274,-11003,     2132
 24576, 31088, 18416, 12380,  4282,-11001, 24576, 30993,  4290,-11002,     2142
 24576, 31095,  4296, 18416, 12296,  4348,  4342, 18416, 12300,  2035,     2152
  2754,  2035,  4152,-11008, 24576, 31086,  2035,  2708,-11008, 24576,     2162
 30801,  2035,  2708,-11008, 24576, 30801,  2035,  2708,  4348, 18416,     2172
 12296,  4442,  4360,  2035,  2878,  2035,  3680,  4392,-11003, 24576,     2182
 30889, 18416, 12332,-11008, 24576, 30795, 18416, 12300,-11008, 24576,     2192
 30797, 18416, 12320,  4442,-11003, 24576, 30889,-11004, 24576, 30896,     2202
 18416, 12336, 18416, 12300,  2035,  3802, 18416, 12340,-11008, 24576,     2212
 30795, 18416, 12300,-11008, 24576, 30797, 18416, 12320,  4466,  4460,     2222
-11008, 24576, 30801,  2035,  4466, 18416, 12292,  4466, 18416, 12296,     2232
  4606,  4482,  2035,  2878,  2035,  3100, 18416, 12332,  4506,  2035,     2242
  2878,-11004, 24576, 30896, 18416, 12332,  2035,  3802,  2035,  3932,     2252
  4528,-11003, 24576, 30889,  2035,  3068,-11005, 24576, 30884, 18416,     2262
 12332,  4556,-11003, 24576, 30889, 18416, 12332,-11008, 24576, 30795,     2272
 18416, 12300,-11008, 24576, 30797,  4606,-11003, 24576, 30889,-11004,     2282
 24576, 30896, 18416, 12336, 18416, 12332,  2035,  3802,  2035,  3932,     2292
 18416, 12340,-11008, 24576, 30795, 18416, 12300,-11008, 24576, 30797,     2302
  4648,  4618, 18416, 12300,  2035,  4974,  4636,-11008, 24576, 31103,     2312
  2035,  3036,-11008, 24576, 31105,  4648,-11008, 24576, 31107,  2035,     2322
  4974,  4704,  4682, 18416, 12316,-11008, 24576, 30795, 18416, 12316,     2332
-11008, 24576, 30801, 18416, 12316,-11008, 24576, 30797,  4704,  2035,     2342
  4606,-11008, 24576, 30795, 18416, 12316,-11008, 24576, 30797,  4726,     2352
  4716,  2035,  4606,  2035,  5106,  4726, 18416, 12316,  2035,  4726,     2362
  4780,  4756,-11008, 24576, 30795, 18416, 12316,-11008, 24576, 30801,     2372
 18416, 12316,-11008, 24576, 30797,  4774,-11008, 24576, 30795, 18416,     2382
 12316,-11008, 24576, 30797,  4780, 18416, 12296,  4800,  4794,-11008,     2392
 24576, 30801, 18416, 12304,  4800, 18416, 12296,  4818,  4808,  2035,     2402
  4606,  4818, 18416, 12316,  2035,  5106,  4974,  4840, 18416, 12344,     2412
 18416, 12316,-11008, 24576, 30801, 18416, 12316,  4860, 18416, 12348,     2422
 18416, 12316,-11008, 24576, 30801,  2035,  4704,  4890, 18416, 12352,     2432
 18416, 12316,-11008, 24576, 30801, 18416, 12316,-11008, 24576, 30801,     2442
  2035,  4800,  4904, 18416, 12356,  2035,  4800,  2035,  4780,  4924,     2452
 18416, 12360, 18416, 12316,-11008, 24576, 30801,  2035,  4800,  4944,     2462
 18416, 12364,  2035,  4648,-11008, 24576, 30801,  2035,  4800,  4964,     2472
 18416, 12368,  2035,  4648,-11008, 24576, 30801,  2035,  4648,  4974,     2482
 18416, 12372, 18416, 12316,  5006,  4988,-11008, 24576, 30791, 18416,     2492
 12316,  5000,-11008, 24576, 30793, 18416, 12316,  5006, 18416, 12296,     2502
  5106,  5042,-11008, 24576, 31107, 18416, 12316,-11008, 24576, 30801,     2512
  2035,  5148, 18416, 12300,  2035,  2754,  2035,  4152,  5060,-11007,     2522
 24576, 31018,-11008, 24576, 31109, 18416, 12316,  5070, 18416, 12376,     2532
  2035,  4818,  5082,-11005, 24576, 31111, 18416, 12304,  5094,-11002,     2542
 24576, 31116, 18416, 12316,  5106,-11005, 24576, 31124, 18416, 12316,     2552
  5132,  5126,-11008, 24576, 30795, 18416, 12316,-11008, 24576, 30797,     2562
  5132, 18416, 12296,  5148,  5142,-11008, 24576, 31086,  5148, 18416,     2572
 12296,  5164,  5158,-11008, 24576, 31129,  5164, 18416, 12296,  5276,     2582
  5196, 18416, 12336, 18416, 12300,  2035,  2754,  2035,  4152, 18416,     2592
 12340,  2035,  3492,  2035,  4084,  5208,-11007, 24576, 31018,  2035,     2602
  3050,  5224,-11000, 24576, 31131, 18416, 12328,  2035,  4084,  5232,     2612
-11003, 24576, 31141,  5248,-11003, 24576, 31148, 18416, 12392,  2035,     2622
  2708,  5260,-11002, 24576, 31155,  2035,  3910,  5268,-11005, 24576,     2632
 31021,  5276,-11005, 24576, 31163,  5802,  5296, 18416, 12336,  2035,     2642
  5164, 18416, 12340,  2035,  3960,  5312,-11004, 24576, 31047,  2035,     2652
  4296, 18416, 12320,  5324,-11003, 24576, 31168, 18416, 12320,  5336,     2662
 18416, 12316,-11008, 24576, 30970,  5366,  2035,  2824, 18416, 12336,     2672
  2035,  3344,  2035,  3404, 18416, 12340,  2035,  4012, 18416, 12320,     2682
  5396,  2035,  2842, 18416, 12336,  2035,  3344,  2035,  3404, 18416,     2692
 12340,  2035,  4054, 18416, 12320,  5410,  2035,  2878,  2035,  3616,     2702
 18416, 12320,  5426,-11006, 24576, 31175,  2035,  3184, 18416, 12320,     2712
  5460, 18416, 12336,  2035,  4260,  2035,  2950, 18416, 12340,  2035,     2722
  3510, 18416, 12300,  2035,  3124, 18416, 12320,  5470,  2035,  2860,     2732
 18416, 12324,  5486,-11004, 24576, 31179,  2035,  3526, 18416, 12320,     2742
  5498,-11004, 24576, 31185, 18416, 12320,  5514,-11004, 24576, 31191,     2752
  2035,  3864, 18416, 12320,  5530,-11003, 24576, 31197,  2035,  4104,     2762
 18416, 12320,  5554,-11003, 24576, 31204, 18416, 12332,  2035,  3802,     2772
  2035,  3932, 18416, 12320,  5566,-11005, 24576, 31211, 18416, 12320,     2782
  5576,  2035,  3768,  2035,  4348,  5596,-11005, 24576, 30951, 18416,     2792
 12300,  2035,  3124, 18416, 12320,  5618,-11002, 24576, 31216,-11005,     2802
 24576, 30884, 18416, 12300, 18416, 12320,  5640,-11002, 24576, 31224,     2812
-11002, 24576, 31232, 18416, 12380, 18416, 12320,  5664,-11001, 24576,     2822
 31240, 18416, 12380, 18416, 12300,  2035,  5106, 18416, 12320,  5676,     2832
-11004, 24576, 31249, 18416, 12320,  5694,-11004, 24576, 30851,-11002,     2842
 24576, 30869, 18416, 12320,  5714,-11008, 24576, 31107, 18416, 12380,     2852
  2035,  5006, 18416, 12320,  5730,-11002, 24576, 31255, 18416, 12308,     2862
 18416, 12320,  5750,-11003, 24576, 31263, 18416, 12380,  2035,  3578,     2872
 18416, 12320,  5766,-11003, 24576, 30889,  2035,  3240, 18416, 12320,     2882
  5796,-11007, 24576, 31270,  2035,  4180, 18416, 12316,  2035,  3840,     2892
-11004, 24576, 31026, 18416, 12320,  5802, 18416, 12320;
%CONSTSHORTINTEGERARRAY SALT(0: 29)= 5802,
 5278, 5296, 5312, 5324, 5336, 5366, 5396, 5410, 5426, 5460,
 5470, 5486, 5498, 5514, 5530, 5554, 5566, 5576, 5596, 5618,
 5640, 5664, 5676, 5694, 5714, 5730, 5750, 5766, 5796;
%REGISTER SYMAD(7)
%REGISTER QP(6)
         *L_7,SYMBOL; *L_6,Q
         *BAL_1,<HASHSTART>
         Q=QP
         %RETURN
HASHSTART:                             ! USE 1ST CHAR TO INDEX PHRASE SS
         *ST_1,0(0,11);                ! SAVE RETURN ADDR BUT NOT LOCALS
         *LA_11,32(0,11);              ! CLAIM SPACE TO CONFORM W.START
         *L_2,R; *ST_2,RR; *ST_6,RQ;   ! RQ=Q;!RR=R
         *LA_3,1(0,2); *ST_3,R;        ! R=R+1
         *SR_1,1; *IC_1,0(6);          ! R1=CC(Q)=1ST CHAR OF STMNT
         *L_3,HASHALT; *IC_1,0(3,1);   ! R1=A(R)=1ST ALT WORTH TRYING
         *STH_1,ALT;                   ! ALT    =ALTNO
         *L_3,SALT
         *LH_0,0(0,3); *STH_0,RP
         *AR_1,1; *LH_2,0(3,1);        ! P=SALT(ALT)
         *LA_1,2(0,2);                 ! RS=1ST ALT IS 2 BYTES ON
         *LH_0,0(2,7); *ST_0,RA;       ! RA=PTR TO NEXT ALT OF SS
         *BC_15,<12>
START:   *LM_15,4,RA;                  ! CURRENT LOCALS
         *STM_14,4,0(11);              ! SAVE RETURN ADDR+LOCALS
         *LA_11,32(0,11);              ! CLAIM WORKSPACE
         *L_0,P; *STH_0,PP
         *BC_15,<COMM>
999:                                    ! REPEATEING PHRASES
         *L_1,RR; *AR_1,1
         *LH_0,ALT; *STH_0,A+30(1)
         *LH_0,PP; *ST_0,P
COMM:
         %COMMENT  ROUTINE REALLY STARTS HERE
         *L_1,R; *ST_1,RR; *ST_6,RQ;   !RQ=Q  RR=R
         *LA_2,1(0,1); *ST_2,R;        ! R=R+1
         *LA_0,1; *STH_0,ALT;          ! ALT=1
         *L_1,P
         *LH_0,0(1,7); *STH_0,RP;       ! RP=SYMBOL(P)
         *LH_0,2(1,7); *ST_0,RA;       ! RA=SYMBOL(P+1)
         *LA_1,4(0,1); *BC_15,<12>;    ! RS=1ST ALTRNTIVE IS 4 BYTES ON
1:       *LA_1,1; *A_1,R
         *ST_1,R;                      ! R=R+1
2:                                     !RETURN HERE AFTER SUCCESS
         *C_6,QMAX
        *BC_12,<NOUPD>; *ST_6,QMAX
NOUPD:
         *L_1,RS; *LA_1,4(0,1);        ! ! UPDATE RS TO NEXT PHRASE%C
WHICH IN GENERAL WILL BE 4 BYTES ON DOWN THE TABLE.ONLY LITERALS DIFFER
12:      *C_1,RA; *BC_8,<8>;           !  ->SUCCESS %IF RA=RS
         *ST_1,RS;                     !  RS=RS+1
         *LA_3,<TABLE>
TESTP:                                 ! THE BASIC COMPARISON SEQUENCE
                                       ! EXECUTE THE NEXT INSTRUCTION IN
                                       ! THE TABLE FOR P-TYPE THIS BR3
                                       ! FOR A RECURSIVE CALL.BIP-TYPE
                                       ! BRANCHES VIA TABLE.LITERAL IS
                                       ! THE APPROPRIATE CLC
         *EX_0,0(1,7);                 ! CLC IN SYMBOL
         *BC_7,<3>;                    ! LITERAL NOT FOUND
         *AH_6,0(1,7);                 ! ADD 1ST HALFWORD OF CLC
         *A_6,QUICK;                   ! AND A CORRECTING FACTOR TO
        *C_6,QMAX; *BC_12,<NOUPD1>; *ST_6,QMAX
NOUPD1:
         *LA_1,6(0,1);                 !  LITERALS NEXT PHRASE 6BYTES ON
         *C_1,RA; *BC_8,<8>;           !  ->SUCCESS %IF RA=RS
         *ST_1,RS
         ->TESTP;                      ! ON TO NEXT PHRASE
4:       *LH_2,2(1,7);                ! POINTER TO PHRASE
         *ST_2,P;                      ! P=ITEM
         *BAL_14,<START>;              ! PSEUDO RECURSIVE CALL
         *CLI_HIT,0; *BC_8,<3>;         ! BIP NOT FOUND
                                        ! IF BIP FOUND CAN USE REGS
                                        ! LEFT SET UP AT LAST RTRN:
         *LA_1,4(2);                    ! UPDATE RS
         *CR_1,15; *BC_8,<8>;           ! ->SUCCESS IF RA=RS
         *ST_1,RS; *LA_3,<TABLE>; *BC_15,<TESTP>
U3:      *C_6,QMAX; *BC_12,<3>; *ST_6,QMAX
3:                                    !FAILURE TRY NEXT ALTERNATIVE
         *L_2,RA; *CH_2,RP;            ! -> 7 %IF RA=RP (UTTER FAILURE
         *BC_8,<7>;                    ! AS NO MORE ALTS LEFT TO TRY)
         *L_15,RR; *L_6,RQ;            ! Q=RQ--R=RR
         *LA_0,1(0,15); *ST_0,R;       ! R=R+1--
         *LH_3,ALT
         *LA_3,1(0,3); *STH_3,ALT;     ! ALT=ALT+1  = NEXT ALT
         *LA_1,2(0,2);                 ! NEW RS 2 ON FROM OLD RS(=RA)
         *LH_0,0(2,7); *ST_0,RA;       ! NEW RA=SYMBOL(OLD RA)
         *ST_1,RS
         *LA_3,<TABLE>; ->TESTP
NULL:                                  ! PHRASE NULL-CAN BE MADE FAST.AS
                                       ! ALWAYS LAST & ALWAYS SUCCESSFUL
8:       HIT=1                         ;!SUCCESS
RTRN:                                  ! PSEUDO RECURSIVE RETURN
         *L_1,RR; *AR_1,1
         *LH_0,ALT; *STH_0,A+30(1);    ! A(RR)=ALT MATCHED
         *S_11,THIRTYTWO;              ! RESET THE STACK POINTER
         *LM_14,4,0(11);               ! RETURN ADDR ETC
         *STM_15,4,RA;                 ! RESTORE OLD LOCALS
         *BCR_15,14    ;               ! AND EXIT
7:       HIT=0;->RTRN                  ;!COMPLETE AND UTTER FAILURE
TABLE:   *BC_15,<4>
         *BC_15,<999>
         *BC_15,<NULL>;                ! THE BIP %NULL
         *BC_15,<1001>  ;              !TREE FOR BIPS
         *BC_15,<1002>
         *BC_15,<1003>
         *BC_15,<1004>
         *BC_15,<1005>
         *BC_15,<1006>
         *BC_15,<1007>
         *BC_15,<1008>
         *BC_15,<1009>
         *BC_15,<1010>
         *BC_15,<1011>
         *BC_15,<1012>
         *BC_15,<1013>
         *BC_15,<1014>
         *BC_15,<1015>
         *BC_15,<1016>
         *BC_15,<1017>
         *BC_15,<1018>
         *BC_15,<1019>
         *BC_15,<1020>
         *BC_15,<1021>
         *BC_15,<1022>
         *BC_15,<1023>
         *BC_15,<1024>
         *BC_15,<1025>
1001:                                  !BIP NAME
         ->3 %UNLESS 'A'<=BYTEINTEGER(QP)
         *L_3,TRTABS
         *SR_1,1; *LR_2,1; *ST_1,NUM
         *STM_1,2,0(11)
         *TRT_0(255,6),0(3)
         *LR_0,1; *SR_1,6;              ! LENGTH IN GR1
         *BC_8,<3>;                     ! ZERO LENGTH = NOT A NAME
         *BCT_2,*+8
         *BC_15,<U3>;                   ! NAME END IN QUOTE =FAIL
         *L_14,LETT; *L_3,NEXT; *AR_3,14
         *STC_1,0(3);                   ! MOVE IN LENGTH
         *EX_1,<NAMMOVE>;               ! MOVE IN CHARS (+1 XTRA)
         *EX_1,<MOVEP>
         *LR_6,0;                       ! UPDATE TEXT POINTER
         *LH_2,0(11); *MH_2,HH1
         *LH_0,2(11); *MH_0,HH1+2; *ALR_2,0
         *LH_0,4(11); *MH_0,HH2; *ALR_2,0
         *LH_0,6(11); *MH_0,HH2+2; *ALR_2,0
         *LR_4,2;                       ! INITIAL HASH VALUE
         *SRL_2,9; *STC_2,NUM+3
         *OI_NUM+3,2; *NI_NUM+3,62
         *L_15,WORD; *L_5,NNAMES
         *LA_0,0(5,5)
         *ALR_4,4
LOOKL:   *NR_4,0;                       ! TO KEEP WITHIN WORD
         *LH_2,0(4,15);                 ! GET WORD(I)
         *LTR_2,2; *BC_8,<NEWNAME>;     ! EMPTY HOLE FOR NEW NAME
         *AR_2,14; *EX_1,<NAMCOMP>;     ! COMPARE
         *BC_8,<FOUND>
         *A_4,NUM
         *BCT_5,<LOOKL>
         FAULT(104,0)
NAMCOMP: *CLC_0(1,2),0(3)
NAMMOVE: *MVC_1(1,3),0(6)
MOVEP:   *MVC_0(1,11),0(3)
DFULL:   FAULT(103,0)
NEWNAME: *SR_3,14; *STH_3,0(4,15)
         *LA_3,1(1,3); *ST_3,NEXT;      ! UPDATE NEXT TO INCLUDE NEWNAME
         *CH_3,DSIZE; *BC_2,<DFULL>
FOUND:   *SRL_4,1; *L_2,R; *AR_2,2
         *STH_4,A+30(2)
         HIT=1; ->1
1020:                                  ! SET UP UC FOR LOOK UP &CHECK'_'
         I=BYTE INTEGER(QP)
         ->3 %UNLESS 'A'<=I<='Z'
         S=I; J=1
200:     QP=QP+1; I=BYTE INTEGER(QP)
         ->201 %UNLESS 'A'<=I<='Z'
         S=S<<8!I;J=J+1; ->200
201:     ->3 %UNLESS I='_' %AND J<=4
         QP=QP+1; ->2
1002:                                  ! INTEGER CONSTANT
         *MVI_CTYPE,2; -> 301
1003:                                  !BIP CONST
         *MVI_CTYPE,0
301:     *SR_1,1
        *IC_1,0(0,6);                   ! PICK UP NEXT CHAR
         *A_1,TRTABS;                  ! CHECK A CONST IS POSSIBLE
         *CLI_256(1),28;*BC_8,<3>;     !QUICK TEST FOR CONST.
         Q=QP; CONST(CTYPE); QP=Q
         %IF HIT=0 %THEN ->U3
         ->1 %IF CTYPE=5
         ->26 %IF CTYPE=2;             ! %REAL
         A(R)=1
         A(R+1)<-S>>16; A(R+2)<-S; R=R+3; ->2
26:      A(R)=2; TOAR8(R+1,CVALUE); R=R+5; ->2
1005:                                  !BIP N
         *L_3,TRTABS
         *TRT_0(10,6),256(3)
         *BC_8,<3>;                    ! TOO LONG
         *LR_0,1;                       ! UPDATE Q
         *SR_1,6; *BC_8,<3>;           ! ZERO LENGTH->FAILURE
         *BCTR_1,0;  *EX_1,<PK>;       !PACK
         *OI_7(11),15;                 !POSITIVE SIGN
         *CVB_2,0(0,11);               ! BINARY IN R2
         *L_1,R;  *AR_1,1
         *LR_6,0;                      ! FINISH UPDATING Q
         *STH_2,A+30(1);                  ! A(R)=N
         *SRA_2,15;  *BC_8,<1>
         ->3
PK:      *PACK_0(8,11),0(0,6)
1004:                                  !BIP CONSTLIST
         Q=QP; CONSTLIST; QP=Q; ->1
1006:                                  !BIP S
         *CLI_0(6),10; *BC_8,<2>;      ! -> 2 %IF I='NL'
         *CLI_0(6),59; *BC_7,<3>;      ! -> 3 %UNLESS I=;
         *LA_6,1(0,6)
         *LA_1,4(0,1); *BC_15,<12>
1007:                                  !BIP TEXT (=COMMENT TEXT)
         *L_3,TRTABS
31:      *TRT_0(255,6),512(3)
         *BC_8,<30>;                   ! TEXT LONGER THAN 255 CHARS
         *LR_6,1; ->2
30:      *LA_6,256(0,6); ->31
1008:                                  !BIP TEXTTEXT
         I=BYTE INTEGER(QP)
         Q=QP; TEXTTEXT; QP=Q
         ->3 %IF HIT=0;->1
1009:                                  !BIP NAMELIST
         ! GIVES AR IN FORM NNAMES,NAME1,....NAMEN
         ->3 %IF BYTEINTEGER(QP)<'A'
         U=R; V=1; R=R+1
         Q=QP; PNAME; QP=Q; ->3 %IF HIT=0
90:      ->91 %UNLESS BYTE INTEGER(QP)=','
         QP=QP+1; R=R+1
         ->U3 %IF BYTEINTEGER(QP)<'A'
         Q=QP; PNAME; QP=Q
         ->92 %IF HIT=0; V=V+1; ->90
92:      R=R-1; QP=QP-1
91:      A(U)=V; ->1
1010:                        ! BIP HOLE
         *L_15,R
         *STH_15,MARKER;               ! MARKER=R
         *LA_15,1(0,15);*ST_15,R;      ! R=R+1
         *LA_1,4(0,1);                 ! ADVANCE POINTER TO SYMBOL
         *C_1,RA; *BC_8,<8>;           ! AS FOR SUCCESS
         *ST_1,RS; ->TESTP;            ! BACK INTO NORMAL PAT
1011:                        !BIP MARK
         *LH_15,MARKER
         *L_14,R; *SR_14,15;           !  R-MARKER
         *AR_15,15
         *STH_14,A+30(15);                !  A(MARKER)=R-MARKER
         *LA_1,4(0,1);                 !  ADVANCE POINTER
         *C_1,RA; *BC_8,<8>;           !  ?END OF PHRASE
         *ST_1,RS; ->TESTP;            !  TO NORMAL PATH
1012:                                  !BIP UCRR - RR FORMAT
         *CLI_S+3,'R';*BC_8,<124>
         %CYCLE I=0,1,2
         ->120 %IF S=NEM(I)
         %REPEAT; ->3
120:     A(R)=OPC(I)&63; ->1
124:       J=S>>8; %CYCLE I=2,1,48
         ->120 %IF J=NEM(I)
         %REPEAT; ->3
1013:                                  !BIP UCRX - RX FORMAT
         J=18; K=64
131:
         %CYCLE I=J,1,K
         ->130 %IF S=NEM(I)
         %REPEAT; ->3
130:     A(R)=OPC(I); ->1
1014:                                  !BIP UCRS    RRS FORMAT
         J=66; K=69; ->131
1015:                                  !PHRASE UCSI STORE IMMEDIATE
         J=71; K=83; ->131
1016:                                  !PHRASE UCSHIFT
         *CLI_S+3,'A';*BC_8,<161>
         *CLI_S+3,'L';*BC_7,<3>
161:     J=85;K=92; ->131
1017:                                  !PHRASE UCSS - STORE-TO-STORE
         J=94; K=106; ->131
1018:                                  !PHRASE UCPD PACKED DECIMAL
         J=108; K=116; ->131
1019:                                  !UCSPEC - THE FUNNIES.
         J=118; K=120; ->131
1021:                                     ! P<CHKIMPS>
         ->3 %UNLESS IMPS=1; ->2
              
1022:                                   ! P(+')=+,-,\,0;
!         I=BYTEINTEGER(QP)
!         %IF I='+' %THEN A(R)=1 %AND QP=QP+1 %AND ->1
!         %IF I='-' %THEN A(R)=2 %AND QP=QP+1 %AND ->1
!         %IF I='\' %THEN QP=QP+1 %AND A(R)=3 %AND ->1
!         A(R)=4
!         ->1
         *CLI_0(6),'+'; *BC_8,<10221>
         *CLI_0(6),'-'; *BC_8,<10222>
         *CLI_0(6),'\'; *BC_8,<10223>
         *LA_3,4; *L_2,R; *LA_2,1(2); *ST_2,R
         *AR_2,2; *STH_3,A+28(2)
         *LA_1,4(1); *BC_15,<12>
10221:   A(R)=1; QP=QP+1; ->1
10222:   A(R)=2; QP=QP+1; ->1
10223:   A(R)=3; QP=QP+1; ->1
1023:                                   ! P(OP)=**,+,-,!!,!,*,//,/,
                                        ! &,>>,<<,.;
         I=BYTEINTEGER(QP)
         ->3 %UNLESS X'80000000'>>(I-32)&X'4237000A'#0
         QP=QP+1
         %IF I='+' %THEN A(R)=2 %AND ->1
         %IF I='-' %THEN A(R)=3 %AND ->1
         J=BYTEINTEGER(QP)
         %IF I='*' %THEN %START
            %IF J#I %THEN A(R)=6 %AND ->1
            A(R)=1; QP=QP+1; ->1
         %FINISH
         %IF I='/' %THEN %START
            %IF J#I %THEN A(R)=8 %AND ->1
            A(R)=7; QP=QP+1; ->1
         %FINISH
         %IF I='!' %THEN %START
            %IF J#I %THEN A(R)=5 %AND ->1
            A(R)=4; QP=QP+1; ->1
         %FINISH
         %IF I='&' %THEN A(R)=9 %AND ->1
         %IF I='.' %THEN A(R)=12 %AND ->1
         %IF I=J='<' %THEN A(R)=11 %AND QP=QP+1 %AND ->1
         %IF I=J='>' %THEN A(R)=10 %AND QP=QP+1 %AND ->1
         ->3
1024:                                   ! P(ASSOP)='==','=','<-','->'
         I=BYTEINTEGER(QP)
         ->3 %UNLESS X'80000000'>>(I-32)&X'4000C'#0
         QP=QP+1; J=BYTEINTEGER(QP)
         %IF I='=' %THEN %START
            %IF J=I %THEN QP=QP+1 %AND  A(R)=1 %AND ->1
            A(R)=2; ->1
         %FINISH
         %IF I='<' %AND J='-' %THEN A(R)=3 %AND QP=QP+1 %AND ->1
         %IF I='-' %AND J='>' %THEN A(R)=4 %AND QP=QP+1 %AND ->1
         ->3

1025:                                   ! P(COMP)= =,>=,>,#,<=,<,\=,->
         I=BYTEINTEGER(QP)
         ->3 %UNLESS I=92 %OR %C
            X'80000000'>>(I-32)&X'1004000E'#0
         QP=QP+1
         %IF I='=' %THEN A(R)=1 %AND ->1
         %IF I='#' %THEN A(R)=4 %AND ->1
         J=BYTEINTEGER(QP)
         %IF I='>' %THEN %START
            %IF J='=' %THEN QP=QP+1 %AND A(R)=2 %AND ->1
            A(R)=3; ->1
         %FINISH
         %IF I='<' %THEN %START
            %IF J='=' %THEN QP=QP+1 %AND A(R)=5 %AND ->1
            A(R)=6; ->1
         %FINISH
         %IF I=92 %AND J='=' %THEN QP=QP+1 %AND A(R)=7 %AND ->1
         %IF I='-' %AND J='>' %THEN QP=QP+1 %AND A(R)=8 %AND ->1
         ->3
%END                    ;! OF ROUTINE 'COMPARE'
         !*DELEND
         %ENDOFPROGRAM
E'
         %ENDOFPROGRAM
    ;! OF ROUTINE 'COMPARE'
         %ENDOFPROGRAM
TINE 'COMPARE'
         %ENDOFPROGRAM