
! rs6p206.1.i jly 94 Conversion to 32 bits before unary ops
!
! rs6p206.i Jun94 Longintegers re-introduced
! m88p205f.3.i Sep93 pds Change in CRNAME to return correct size
! when recordarrayelement in a record has a record as a subname
!
! m88p205f.i 3Mar 92 PDS
! changes to allow record alignment to go to pass4 on record assignment
%externalroutine ICL9CEZDRSIMP
%constinteger RELEASE=4
%include "hostcodes.inc"
!
%CONSTINTEGER HOST=DRS
%CONSTINTEGER TARGET=PENTIUM
%CONSTINTEGER STANDARDPT=X'51'
%CONSTINTEGER MINAPT=X'51';             ! MINIMUM PTYPE FOR WHICH ARITHMETIC
                                        ! OPERATORS ARE AVAILABLE
%CONSTINTEGER MINAPREC=MINAPT>>4
%if 1<<Target&LLREALAVAIL#0 %then %start
    %constinteger TYPELLRENTRY=x'72'
%else
    %constinteger TYPELLRENTRY=x'2062'       { Warn and treat as LONGreal}
%finish
%if 1<<Target&LINTAVAIL#0 %then %start
    %constinteger TYPELIENTRY=x'61'
%else
    %constinteger TYPELIENTRY=x'1051'        { fault long integers }
%finish
%CONSTHALFINTEGERARRAY TYPEFLAG(0:12)=0,
                                        X'51'{%INTEGER},
                                        X'52'{%REAL},
                                        X'8009'{%LONG SOMETHING},
                                        X'4031'{%BYTE},
                                        X'35'{%STRING},
                                        X'6051'{%HALF->%INTEGER+WARNING},
                                        X'4041'{%SHORT},
                                        X'33'{%RECORD},
                                        0,
                                        TYPELIENTRY,
                                        X'62'{%LONG REAL},
                                        TYPELLRENTRY;
!
! 2****15 SET FOR RELAY TO LOWER PART OF TYPEFLAGS
! 2****14 SET TO SKIP NEXT AR ENTRY FOR BYTE(INTEGER?) ETC
! 2****13 SET IF A DIFFERENT PRECISION USED GIVES WARNING
! 2****12 SET FOR COMBINATION WE CANT SUPPORT GIVES FAULT99
!
%CONSTBYTEINTEGERARRAY PTRSIZE(0:127)= %C
                                        8,0(15)                 {PREC=0},   
                                        0(16)                   {PREC=1},
                                        0(16)                   {PREC=2},
                                        8,4,0,4,0,8,0,4,0(8)    {PREC=3},
                                        8,4,0(14)               {PREC=4},
                                        8,4,4,0(13)             {PREC=5},
                                        8,4,4,0(13)             {PREC=6},
                                        8,0,4,0(13)             {PREC=7};
%CONSTBYTEINTEGERARRAY PTRROUNDING(0:3*128-1)=%C
                  3(128)                {ALL PTRS IN RECORDS},
                  3(128)                {ALL PTRS IN STACK FRAMES},
                  3(128)                {ALL PTRS IN PARAMETERS};
%CONSTINTEGER SFRAMEMISALIGN=0;         ! NEEDED ONLY FOR 2900 WHERE PRECALL
                                        ! MISALIGNS STACK FRAMES !
%CONSTINTEGER AHEADPT=X'61';            ! PTYPE OF ARRAYHEAD WHEN USED AS SCALAR
%CONSTINTEGER AHEADSIZE=8;              ! SIZE OF ARRAY HEAD(BYTES)
%CONSTINTEGER MINPARAMSIZE=4;           ! MINIMUM STACKABLE PARAMETER(BYTES)
%CONSTINTEGER RTPARAMPT=X'51';          ! PTYPER OF RTPARAM WHEN USED AS SCALAR
%CONSTINTEGER RTPARAMSIZE=4;            ! SIZE OF RT PARAMETER (BYTES)
%CONSTINTEGER ARRAYROUNDING=7;          ! ALL ARRAYS TO 4 BYTE BNDR
%CONSTINTEGER ARRAYINRECROUNDING=0;     ! ARRAYS IN RECORDS TO 4 BYTE BOUNDARY
%CONSTINTEGER STRVALINWA=NO;            ! STRING VALUE PARAMETERS STACKED
%CONSTINTEGER STRRESINWA=YES;           ! STRING&RECORD FN RESULTS STACKED
%CONSTINTEGER RECVALINWA=NO;            ! Record values passed via work area
!
%CONSTBYTEINTEGERARRAY RNDING(0:3*128-1)= %C
                  {VALUES FOR SCALARS PTYPES 0->X'7F' IN SITUATIONS}
                  {FIRST SITUATION IS IN RECORDS}
                  {SECOND SITUATION IS IN STACK FRAMES}
                  {THIRD SITUATION IS AS PARAMETERS}

         0(16)                          {PREC=0},
         0(16)                          {PREC=1},
         0(16)                          {PREC=2},
         0(3),3,0,0,0(10)               {PREC=3},
         0,1,0(14)                      {PREC=4},
         0,3,3,0(13)                    {PREC=5},
         0,3,3,0(13)                    {PREC=6},
         0,3,3,0(13)                    {PREC=7},


         0(16)                          {PREC=0},
         0(16)                          {PREC=1},
         0(16)                          {PREC=2},
         0(3),3,0,1,0(10)               {PREC=3},
         0,1,0(14)                      {PREC=4},
         0,3,3,0(13)                    {PREC=5},
         0,3,3,0(13)                    {PREC=6},
         0,3,3,0(13)                    {PREC=7},


         0(16)                          {PREC=0},
         0(16)                          {PREC=1},
         0(16)                          {PREC=2},
         0,3,0,3,0,3,0(10)              {PREC=3},
         0,3,0(14)                      {PREC=4},
         0,3,3,0(13)                    {PREC=5},
        {0,7,7,0(13)                     PREC=6,}   {for non-SPARC}
         0,3,3,0(13)                   {PREC=6},    {for SPARC and RS6000}
         0,3,3,0(13)                    {PREC=7};

%CONSTBYTEINTEGERARRAY BYTES(0:7)=0(3),1,2,4,8,16;
%CONSTBYTEINTEGERARRAY WORDS(0:7)=0(3),1,1,2,4,8;
%CONSTINTEGER DAREA=6;                  ! SPECIAL DIAGS AREA ON PERQ
%CONSTINTEGER DVAREA=4;                 ! CONST DOPE VECTORS IN sst
%CONSTINTEGER LHSADDRFIRST=NO;          ! EVALUATE LHS ADDR BEFORE RHS ON ASSNMNT
%CONSTINTEGER JRNDBODIES=NO;            ! NO NEED TO JUMP ROUNT RT BODIES
%CONSTINTEGER STACK DOWN=YES
%CONSTINTEGER PARAMSBWARDS=YES;         ! YES FOR REVERSED PARAMETERS
%CONSTINTEGER DISPLAY NEEDED=YES;       ! DISPLAY NEEDED IN LOCAL SPACE
%CONSTINTEGER DISPLAY ROUNDING=3;      ! Display on S-W bndry
%CONSTINTEGER DISPLAY C1=4;             ! 4 bytes per routine level on RS6000
%CONSTINTEGER DISPLAY C0=4;             ! 4 for globals
%CONSTINTEGER RTPARAM1OFFSET=0;         ! OFFSET FROM LNB TO PARAM1
%CONSTINTEGER ALPHA=0;                  ! post parmeter linkage
!
! END OF CONCATENATED DEFINITIONS
!
!
! Recent Source Changes
!**********************
!
!*                                                                p205e.i
!* 06/12/91 - Changes (pds) to base dictionary size directly on workfile
!*              and/or MAXDICT. Source file size is poor indicator in view
!*              of many large includes.
!*
! Oct 89   Version 5
! Chnages (mostly in CRCALL) to pass record values via work area & pointer
! for risc chips. Controlled by const integer in steering file
!
! DEc88 Version 3 produced
! Changes to note included procedures for Gould and others
! Also change to allow LINT &LINTPT to compile when lonlongs are treated as longs
!
! 8May87 Changes in FPlist so that RT Parameters are aligned according
!        the rules of array Rnding
!
!
! Warning this module has the revised triples spec.
!
! In first attempt at Triple Imp considerable use was made of constant operands
! to pass information from Pass2 to GEN. Although for specialised operations%c
like
! passing Labels this still applies, this adhocery has caused problems with%c
arrays
! and pointers particularly in mapped records. The operands for four triples
! have thus been redefined in a more standard way.
!
! GETPTR    X1 is now (ptype of passed)<<16! DIMENSION
!           Opnd2 is either a 32 bit const with the size (ACC) as value or
!           the ptr or arrayhead as normal operand.
!
! VMY       X1 is now dim<<28!maxdim<<24!array name(where known)
!           Opnd2 is either a 32 bit const with DV offset into const area or
!           the arrayhead as a standard operand
!
! AINDX     X1 is ELSIZE<<20 !spare
!           Opnd2 is arrayhead as standard operand
!           NOTE:- The Operands have been swopped for consistency with norm.
!
! BADJ      X1 is arrayptype<<16!no of Dimensions (latter in case of backward%c
dvs)
!           Opnd2 exactly as for VMY
!

%include "impcompdate.inc"
   %const %integer MAXRECSIZE=x'ffff'
   %const %integer NO OF SNS=67
   %const %integer LRLPT=X'62'
!
   %const %integer MAXLEVELS=31,CONCOP=13
!
!
! FIRST THE OPERAND FLAG CONSTANTS
!
%CONSTINTEGER SCONST=0;                 ! CONST UPTO 64 BITS value is carried
                                        ! in opnd_d and opnd_xtra
%CONSTINTEGER LCONST=1;                 ! CONST LONGER THAN SCONST const can be
                                        ! found elsewhere(at top of ar) by
                                        ! meanse of base&offset inf in_d and _xtra
%CONSTINTEGER DNAME=2;                  ! NAME BY DICTIONARY NO the base and disp in
                                        ! the dictionary after adjusting by
                                        ! possible offset for item in
                                        ! in records lead to the variable
%CONSTINTEGER ARNAME=3;                 ! NAME BY AR POINTER opnd_d the ar pointer
                                        ! this form local to pass2
                                        ! and used to identify functions
                                        ! with params before the call
                                        ! is planted
%CONSTINTEGER VIAPTR=4;                 ! VIA TRIPLE WITHOFFSET TO POINTER
                                        ! At an offset(_xtra) from address in
                                        ! referenced triple can be found a
                                        ! pointer to the required operand
%CONSTINTEGER INDNAME=5;                ! INDIRECT VIA DICTIONARY base&disp
                                        ! in dictionary identify a pointer
                                        ! variable at possible offset from
                                        ! this pointer
%CONSTINTEGER INDIRECT=6;               ! INDIRECT VIA TRIPLE WITH OFFSET
                                        ! the refenced triple has computed
                                        ! the (32bit) address of an item
                                        ! an offset may have to be applied
                                        ! before the fetch or store
%CONSTINTEGER LOCALIR=7;                ! BASE DISP REF IN CURRENT STACK FRAME
                                        ! opnd_b=base<<16!offset used only for
                                        ! compiler generated temporaries
%CONSTINTEGER REFTRIP=8;                ! REFERENCE TO A TRIPLE the operand is the result of 
                                        ! triple opnd_d
%CONSTINTEGER INAREG=9;                 ! REGISTER OPERAND this form is local to the
                                        ! code generating pass(es)
%CONSTINTEGER developped=10;            ! also local to generator
%CONSTINTEGER DEVADDR=11;               ! ALSO LOCAL TO GENERATOR
%CONSTINTEGER BTREFMASK=1<<REFTRIP!1<<INDIRECT!1<<VIAPTR
%CONSTINTEGER REFER NEEDED=1<<INDIRECT!1<<VIAPTR
!
! NOW THE DEFINITIONS OF ONE OPERAND TRIPLES <128
!
%CONSTINTEGER RTHD=1;                   ! ROUTINE-BLOCK HEADING
%CONSTINTEGER RDSPY=2;                  ! ROUTINE ENTRY SET DISPLAY
%CONSTINTEGER RDAREA=3;                 ! ROUTINE LEAVE DIAGNOSTIC SPACE
%CONSTINTEGER RDPTR=4;                  ! SET DIAGNOSTIC POINTER
%CONSTINTEGER RTBAD=5;                  ! ROUTINE-FN BAD EXIT
%CONSTINTEGER RTXIT=6;                  ! "%RETURN"
%CONSTINTEGER XSTOP=7;                  ! EXECUTE "%STO"
%CONSTINTEGER NOTL=10;                  ! LOGICAL NOT
%CONSTINTEGER LNEG=11;                  ! LOGICAL NEGATE
%CONSTINTEGER IFLOAT=12;                ! CONVERT INTEGER TO REAL
%CONSTINTEGER MODULUS=13;               ! AS USED BY IMOD&RMOD
%CONSTINTEGER SHRTN=14;                 ! SHORTEN TO LOWER PRECISION
%CONSTINTEGER LNGTHN=15;                ! LENGTHEN TO HIGHER PRECISION
%CONSTINTEGER JAMSHRTN=16;              ! SHORTEN FOR JAM TRANSFER
%CONSTINTEGER NULLT=18;                 ! FOR REDUNDANT TRIPLES
%CONSTINTEGER PRELOAD=19;               ! PREFETCH FOR OPTIMISATION REASONS
%CONSTINTEGER SSPTR=21;                 ! STORE STACK POINTER
%CONSTINTEGER RSPTR=22;                 ! RESTORE STACK POINTER
%CONSTINTEGER ASPTR=23;                 ! ADVANCE STACK PTR
%CONSTINTEGER DARRAY=24;                ! DECLARE ARRAY(IE STORE HD)
%CONSTINTEGER SLINE=25;                 ! UPDATE LINE NO
%CONSTINTEGER STPCK=26;                 ! CHECK FOR ZERO STEPS
%CONSTINTEGER FORPRE=27;                ! PREAMBLE FOR "FOR"
%CONSTINTEGER FORPOST=28;               ! POSTAMBLE FOR "FOR"
%CONSTINTEGER FORPR2=29;                ! FOR SECOND PREAMBLE
%CONSTINTEGER PRECL=30;                 ! PREPARATION FOR CALL
%CONSTINTEGER RCALL=31;                 ! THE CALL
%CONSTINTEGER RCRFR=32;                 ! RECOVER FN RESULT
%CONSTINTEGER RCRMR=33;                 ! RECOVER MAP RESULT
%CONSTINTEGER GETAD=35;                 ! GET ADDRESS OF NAME
%CONSTINTEGER RTOI1=36;                 ! REAL TO INTEGER AS INT
%CONSTINTEGER RTOI2=37;                 ! REAL TO INTEGER INTPT
%CONSTINTEGER ITOS1=38;                 ! INTEGER TO STRING AS TOSTRING
%CONSTINTEGER MNITR=39;                 ! %MONITOR
%CONSTINTEGER PPROF=40;                 ! PRINT PROFILE
%CONSTINTEGER RTFP=41;                  ! TURN RT INTO FORMAL PARAMETER
%CONSTINTEGER ONEV1=42;                 ! ON EVENT 1 PRIOR TO TRAP
%CONSTINTEGER ONEV2=43;                 ! ON EVENT 2 AFTER TRAP
%CONSTINTEGER DVSTT=44;                 ! START OF DOPE VECTOR
%CONSTINTEGER DVEND=45;                 ! END OF DV EVALUATE TOTSIZE ETC
%CONSTINTEGER FOREND=46;                ! END OF FOR LOOP
%CONSTINTEGER DMASS=47;                 ! assign via bim warning to opt only
%CONSTINTEGER RTOI3=48;                 ! real to integer as TRUNC
!
! CODES FOR USER WRITTEN ASSEMBLER. NATURALLY THESE ARE NOT
! MACHINE INDEPENDENT
!
%CONSTINTEGER UCNOP=50;                 ! FOR CNOPS
%CONSTINTEGER UCB1=51;                  ! ONE BYTE OPERATIONS
%CONSTINTEGER UCB2=52;                  ! FOR 2 BYTE OPERATIONE
%CONSTINTEGER UCB3=53;                  ! FOR 3 BYTE OPERATIONS
%CONSTINTEGER UCW=54;                   ! FOR WORD OPERATIONS
%CONSTINTEGER UCBW=55;                  ! FOR OPC,BYTEWORD OPERATIONE
%CONSTINTEGER UCWW=56;                  ! FOR OPC,WORD,WORD OPERAIONS
%CONSTINTEGER UCLW=57;                  ! FOR LONGWORD OPERATIONS
%CONSTINTEGER UCB2W=58;                 ! FOR OPC,B1,B2,WORD OPERATIONS
%CONSTINTEGER UCNAM=59;                 ! FOR ACESS TO NAMES FROM ASSEMBLER
!
! NOW THE BINARY OPERATIONS
!
%CONSTINTEGER ADD=128;                  ! ADDITION
%CONSTINTEGER SUB=129;                  ! SUBTRACTION
%CONSTINTEGER NONEQ=130;                ! INTEGER NONEQUIVALENCE
%CONSTINTEGER ORL=131;                  ! LOGICAL OR
%CONSTINTEGER MULT=132;                 ! MULTIPLICATION
%CONSTINTEGER INTDIV=133;               ! INTEGER DIVISION
%CONSTINTEGER REALDIV=134;              ! REAL DIVISION
%CONSTINTEGER ANDL=135;                 ! LOGICAL AND
%CONSTINTEGER RSHIFT=136;               ! LOGICAL RIGHT SHIFT
%CONSTINTEGER LSHIFT=137;               ! LOGICAL LEFT SHIFT
%CONSTINTEGER REXP=138;                 ! REAL EXPONENTIATION
%CONSTINTEGER COMP=139;                 ! COMPARISONS
%CONSTINTEGER DCOMP=140;                ! FIRST PART OF DSIDED(NEEDED?)
%CONSTINTEGER VMY=141;                  ! VECTOR MULTIPLY
%CONSTINTEGER COMB=142;                 ! COMBINE (IE ADD OF LA) ON VMY RESULTS
%CONSTINTEGER VASS=143;                 ! VARAIABLE ASSIGN WITH CHECKING
%CONSTINTEGER VJASS=144;                ! VARIABLE JAMMED ASSIGN
%CONSTINTEGER IEXP=145;                 ! INTEGER EXPONENTIAITION
%CONSTINTEGER BADJ=146;                 ! BASE ADJUST ARRAY INDEX
%CONSTINTEGER AINDX=147;                ! INDEX ARRAY(COMBINE BS&IX)
%CONSTINTEGER IFETCH=148;               ! NO LONGER USED
%CONSTINTEGER LASS=149;                 ! ASSIGN LOCAL TEMPORARY
%CONSTINTEGER FORCK=150;                ! VALIDATE FOR
%CONSTINTEGER PRECC=151;                ! PRELIMINARY CONNCATENATION
%CONSTINTEGER CONCAT=152;               ! CONCATENATION
%CONSTINTEGER IOCPC=153;                ! CALL IOCP
%CONSTINTEGER PASS1=154;                ! PRIMARY PARAMETER ASSIGNMENT
%CONSTINTEGER PASS2=155;                ! PARAMETER PASSING POINTER PARAMS
%CONSTINTEGER PASS3=156;                ! PARAMETERPASSING ARRAY PARAMETERS
%CONSTINTEGER PASS4=157;                ! PASS A FORMAL PROCEDURE
%CONSTINTEGER PASS5=158;                ! PASS AN UNTYPE(%NAME) PARAMETER
%CONSTINTEGER PASS6=159;                ! PASS STRFN OR RECFN RESULT AREA
%CONSTINTEGER BJUMP=160;                ! BACKWARDS JUMPS
%CONSTINTEGER FJUMP=161;                ! FORWARD JUMPS
%CONSTINTEGER REMLB=162;                ! REMOVE LAB FROM LABELIST
                                        ! NEEDS TO BE TRIPLE IF COMBINED
                                        ! LABEL LIST IS USED
%CONSTINTEGER TLAB=163;                 ! TO ENTER A LABEL
%CONSTINTEGER DCLSW=164;                ! DECLARE A SWITCH ARRAY
%CONSTINTEGER SETSW=165;                ! SET A SWITCH TO "CA"
%CONSTINTEGER GOTOSW=166;               ! GO TO A SWITCH LABEL
%CONSTINTEGER STRASS1=167;              ! STRING GENERAL ASSIGNMET
%CONSTINTEGER STRASS2=168;              ! STRING FIXED LENGTH ASSNMENT
%CONSTINTEGER STRJT=169;                ! STRING JAM TRANSFER
%CONSTINTEGER AHASS=170;                ! ASSIGNMENT OF ARRAYHEADS
%CONSTINTEGER PTRAS=171;                ! ASSIGNMENT OF POINTERS
%CONSTINTEGER MAPRES=172;               ! ASSIGN MAPPING FN RESULT
%CONSTINTEGER FNRES=173;                ! ASSIGN FN RESULT
%CONSTINTEGER SCOMP=174;                ! STRING COMPARISON
%CONSTINTEGER SDCMP=175;                ! FIRST PART OF STRING D-SIDED
%CONSTINTEGER PRES1=176;                ! PRE RESOLUTION 1
%CONSTINTEGER PRES2=177;                ! PRE RESOLUTION 2
%CONSTINTEGER RESLN=178;                ! STRING RESOLUTION
%CONSTINTEGER RESFN=179;                ! RESOLUTION FINALE
%CONSTINTEGER SIGEV=180;                ! SIGNAL EVENT
%CONSTINTEGER RECASS=181;               ! WHOLE RECORD ASSIGNMENT
%CONSTINTEGER AAINC=182;                ! ARRAY ADDRESS ADJUST FOR
                                        ! RECORD RELATIVE TO ABSOLUTE
%CONSTINTEGER AHADJ=183;                ! MODIFY HEAD FOR MAPPING
%CONSTINTEGER CTGEN=184;                ! CREATE TYPE GENERAL PARAMETER
%CONSTINTEGER GETPTR=185;               ! POINTER FOR PASSING BY NAME
%CONSTINTEGER SINDX=186;                ! INDEX STRING IE CHARNO
                                        ! SAME AS AINDX FOR ALL TARGETS
                                        ! BUT PNX !
%CONSTINTEGER ZCOMP=187;                ! COMPARISONS WITH ZERO
                                        ! GENERATED BY OPTIMISER
%CONSTINTEGER CLSHIFT=188;              ! CONSTANT LOGICAL SHIFT
                                        ! GENERATED BY OPTIMISER
%CONSTINTEGER CASHIFT=189;              ! CONSTANT ARITHMETIC SHIFT
                                        ! GENERATED BYOPTIMISER
%CONSTINTEGER DVBPR=190;                ! GENERATE DV ENTRY FOR BOUND PAIR
%CONSTINTEGER RSTORE=191;               ! REGISTER TO STORE OPERATION
%CONSTINTEGER MULTX=192;                ! MULTIPLY AND EXTEND PRECISION
!
! RECORDFORMAT FOR ALL THE OPTION AND FLAG VARAIBLES
!
! amended to remove non-alined longreal prior to bootstrapping to gould
!
%RECORDFORMAT PARMF(%INTEGER BITS1,BITS2,TTOPUT,
      %BYTEINTEGER LET,DYNAMIC,LINE,TRACE,ARR,DBUG,CHK,DIAG,OPT,FREE,
      LIST,CPRMODE,COMPILER,Z,Y,PROF,INHCODE,DCOMP,FAULTY,X,STACK,MAP,QUOTES,S2,
      %INTEGER LPOPUT,SP0)
%RECORDFORMAT LEVELF(%INTEGER RBASE, DIAGINF, RAL, FLAG, L, M, NMDECS, ONWORD, ONINF,
         LABEL, JROUND, UNATT FORMATS, PSIZE, ENTRYAD, DISPLAY, AUXSBASE, 
         NAMES, SNMAX,SN,RESSIZE,CLEVEL,SET, MAXPP, EXITLAB, CONTLAB, S3,
       %INTEGERARRAY AVL WSP(0:4))

%IF 1<<host&unsignedshorts=0 %START
%RECORDFORMAT RD((%INTEGER S1 %OR %SHORT PTYPE,%BYTE XB,FLAG),
      ((%INTEGER D %OR %REAL R),
      %INTEGER XTRA %OR %SHORT H0,H1,H2,H3 %OR %BYTE B0,B1,B2,B3,B4,B5,B6,B7))
%RECORDFORMAT TAGF((%SHORTINTEGER PTYPE,UIOJ,SNDISP,ACC,SLINK,KFORM %OR %C
      %INTEGER S1,S2,S3),%INTEGER LINK)
%RECORDFORMAT TRIPF(%BYTE OPERN,OPTYPE,CNT,DPTH,
      %SHORTINTEGER FLAGS,PUSE,FLINK,BLINK,%INTEGER X1,
      %RECORD(RD) OPND1,OPND2)
%RECORDFORMAT LISTF((%SHORTINTEGER PTYPE,(%SHORT UIOJ %OR %BYTE XB,FLAG),
      %SHORT SNDISP,ACC,SLINK,KFORM %OR  %INTEGER S1,S2,S3),%INTEGER LINK)
%FINISH %ELSE %START
%RECORDFORMAT RD((%INTEGER S1 %OR %HALF PTYPE,%BYTE XB,FLAG),
      ((%INTEGER D %OR %REAL R),
      %INTEGER XTRA %OR %HALF H0,H1,H2,H3 %OR %BYTE B0,B1,B2,B3,B4,B5,B6,B7))
%RECORDFORMAT TAGF((%HALFINTEGER PTYPE,UIOJ,SNDISP,ACC,SLINK,KFORM %OR %C
      %INTEGER S1,S2,S3),%INTEGER LINK)
%RECORDFORMAT TRIPF(%BYTE OPERN,OPTYPE,CNT,DPTH,
      %HALFINTEGER FLAGS,PUSE,FLINK,BLINK,%INTEGER X1,
      %RECORD(RD) OPND1,OPND2)
%RECORDFORMAT LISTF((%HALFINTEGER PTYPE,(%HALF UIOJ %OR %BYTE XB,FLAG),
      %HALF SNDISP,ACC,SLINK,KFORM %OR  %INTEGER S1,S2,S3),%INTEGER LINK)
%FINISH
%RECORDFORMAT WORKAF(%INTEGER NNAMES,CCSIZE,DSIZE,ASL MAX,ASL CUR BTM,CONST PTR,
      CONST BTM,LASTTRIP,WKFILEAD,WKFILEK,FILE ADDR,RELEASE,AASL0,CONST LIMIT,
      RTCOUNT,ARTOP,AMAINEP,DICTBASE,OPTCNT,INCLHEAD,S2,S3,S4,
      %INTEGERNAME LINE,N,S5,%STRING(9)LADATE,
      %BYTEINTEGERARRAYNAME CC,A,LETT,
      %INTEGERARRAYNAME WORD,TAGS,CTABLE,
      %RECORD(LEVELF)%ARRAYNAME LEVELINF,
      %INTEGERARRAY PLABS,PLINK(0:31),
      %RECORD(LISTF)%ARRAYNAME ASLIST)
!
! TRIPF_FLAGS SIGNIFY AS FOLLOWS
%CONSTINTEGER LEAVE STACKED=2****0;     ! SET LEAVE RESULT IN ESTACK
%CONSTINTEGER LOADOP1=2****1;           ! OPERAND 1 NEEDS LOADING
%CONSTINTEGER LOADOP2=2****2;           ! OPERAND 2 NEEDS LOADING
%CONSTINTEGER NOTINREG=2****3;          ! PREVENT REG OPTIMISNG
                                        ! OF TEMPS OVER LOOPS&JUMPS
%CONSTINTEGER USE ESTACK=2****4;        ! KEEP DUPLICATE IN ESTACK
%CONSTINTEGER USE MSTACK=2****5;        ! PUT DUPLICAT ON MSTACK
%CONSTINTEGER CONSTANTOP=2****6;        ! ONE OPERAND IS CONSTANT(FOR FOLDING)
%CONSTINTEGER COMMUTABLE=2****7;        ! OPERATION IS COMMUTABLE
%CONSTINTEGER BSTRUCT=2****12;          ! Proc contains inner blks or RTs
%CONSTINTEGER USED LATE=2****13;        ! I-RESULT USED AFTER LAB OR A LONG WAY AHEAD
%CONSTINTEGER ASS LEVEL=2****14;        ! ASSEMBLER LEVEL OPERATION
%CONSTINTEGER DONT OPT=2****15;         ! DONT DUPLICATE THIS RESULT
                                        ! USED FOR BYTE PTR & OTHER SODS!
!
%RECORDFORMAT EMASFHDRF(%INTEGER ENDRA,STARTRA,FBYTESIZE,W3,W4,W5,W6,W7)
                                        ! FORMAT FOR ARRAY HEADS
! %END %OF  %FILE "ERCC07.TRIMP_TFORM1S"
   %const %integer SNPT=X'1006';         ! SPECIALNAME PTYPE
   %const %integer UNASSPAT=X'80808080'
   %const %integer LABUSEDBIT=X'01000000'
   %const %integer LABSETBIT=X'02000000'
   %const %integer MAXDICT=X'100';       ! PARM MAXDICT BIT
!
   %integer I,K,DUMMYFORMAT,P1SIZE,STARSIZE,ASL,ARSIZE,OLDLINE,NEXTP,SNUM,
      RLEVEL,NMAX,PLABEL,LEVEL,PROFAAD,LAST INST,LINE,N,BFFLAG,RBASE,Q,R,
      FNAME,STMTS,FILE SIZE,BIMSTR,MAX ULAB,SFLABEL,NEXTTRIP
   %integer %name SSTL,USTPTR
   %string (31) MAINEP
!
   %external %integer %array CAS(0:12)
   %external %record (PARMF) PARM
   %external %record (WORKAF) WORKA
   %if HOST=IBM %or HOST=AMDAHL %or HOST=IBMXA %or HOST=Vax %start
      %external %integer %map %spec COMREG %alias "s#comregmap"(%integer N)
   %finish %else %if HOST=Gould%or Host=M88k %or Host=RS6 %or Host=MIPS %c
      %or HOST=DRS %or HOST=PENTIUM  %then %Start
      %externalintegermapspec COMREG  (%integer N)
   %else
      %external %integer %map %spec COMREG %alias "s#comreg"(%integer N)
   %finish
   %const %integer BYTESPERKFORSOURCE=256;  ! FRACTION OF KB IN WK FILE
                                         ! THATS IS ALLOCATE FOR SOURCE (&LPUT)
   %begin
      %record (EMASFHDRF) %name SHDR,WHDR
      worka = 0
      WORKA_FILE ADDR = COMREG(46);      ! SOURCE FILE IF CLEAN
      PARM = 0
      PARM_BITS1 = COMREG(27)
      PARM_BITS2 = COMREG(28)
      PARM_TTOPUT = COMREG(40)
      PARM_LPOPUT = COMREG(23)
      WORKA_WKFILEAD = COMREG(14)
      COMREG(24) = 16;                   ! failure as return code
      WHDR == RECORD(WORKA_WKFILEAD)
      WORKA_WKFILEK = WHDR_FBYTESIZE>>10
      %if WORKA_FILE ADDR<=0 %then %start
         %if WORKA_FILE ADDR<-1 %then FILESIZE = IMOD(WORKA_FILE ADDR) %else %c
            FILESIZE = 64000
         WORKA_FILE ADDR = 0
      %finish %else %start
         SHDR == RECORD(WORKA_FILE ADDR)
         FILE SIZE = SHDR_ENDRA
      %finish
!
! Derive nnames form workfile K ignoring source size because of includes
!
! Note if nnames goes over 4095 the linking of arrayname parameters
! in sw(11) goes wong as their are only 12 bits left intags_uioj
! this is an absolute limit unless pds in prepared to be very ingenious
!

      WORKA_NNAMES = 1023
      %if WORKA_WKFILEK>513 %then WORKA_NNAMES=2047
     %if WORKA_WKFILEK>1000 %or PARM_BITS2&MAXDICT#0  %then WORKA_NNAMES = 4095
      ASL = 3*WORKA_NNAMES
!      %if ASL>4095 %and (HOST#EMAS %or PARM_BITS2&MAXDICT=0) %then ASL = 4095
      WORKA_ASL MAX = ASL
      ARSIZE = WORKA_WKFILEK*(1024-BYTESPERKFORSOURCE)-300
   %end
   %byte %integer %array %format AF(0:ARSIZE)
   %byte %integer %array %name A
   %record (LISTF) %array ASLIST(0:ASL)
   %integer %array TAGS(0:WORKA_NNAMES)
   %integer %array WORD(0:WORKA_NNAMES)
   %integer %array DVHEADS(0:12)
   %record (LEVELF) %array LEVELINF(0:MAXLEVELS)
   %external %routine %spec INITASL(%record (LISTF) %array %name A,
      %integer %name B)
   %external %integer %fn %spec MORE SPACE
!%externalintegerfnspec NEWCELL
   %external %routine %spec INSERTATEND(%integer %name S, %integer A,B,C)
   %external %routine %spec INSERT AFTER(%integer %name S, %integer A,B,C)
   %external %routine %spec POP(%integer %name C,P,Q,R)
   %external %routine %spec PUSH(%integer %name C, %integer S1,S2,S3)
   %external %integer %fn %spec FIND(%integer LAB,LIST)
   %external %routine %spec BINSERT(%integer %name T,B, %integer S1,S2,S3)
   %external %routine %spec CLEARLIST(%integer %name HEAD)
   %external %routine %spec FILL DTABREFS(%integer %name HEAD)
   %external %routine %spec CXREF(%string (255) NAME, %integer MODE,XTRA,
      %integer %name AT)
   %external %routine %spec IMPABORT
   %external %routine %spec PROLOGUE(%record (LISTF) %array %name ALIST)
   %external %routine %spec EPILOGUE(%integer STMTS)
   %external %routine %spec PDATA(%integer AREA,BNDRY,L,AD)
   %external %routine %spec PRDATA(%integer AREA,BNDRY,L,REP,AD)
   %external %integer %fn %spec PINITOWN(%integer PTYPE,ACC,
      %record (RD) %name INIT, %string %name XNAME)
   %external %integer %fn %spec POWNARRAYHEAD(%integer PTYPE,J,LB,SIZE,
      AOFFSET,AAREA,DVOFFSET, %string (31) XNAME)
   %external %routine %spec FAULT(%integer A,B,C)
   %external %routine %spec WARN(%integer N,V)
   %external %routine %spec TRIP OPT(%record (TRIPF) %array %name T,
      %integer %name NEXT TRIP)
   %external %routine %spec MOVE BYTES(%integer LENGTH,FBASE,FOFF,TOBASE,TOOFF)
   %external %routine %spec CTOP(%integer %name OP,MASK, %integer XTRA,
      %record (RD) %name OPND1,OPND2)
   %if HOST#TARGET %start
      %external %routine %spec REFORMATC(%record (RD) %name OPND)
      %external %routine %spec CHANGE SEX(%integer BASEAD,OFFSET,L)
   %finish
   %external %routine %spec GENERATE(%record (TRIPF) %array %name T,
      %integer CURRLEVEL, %routine GETWSP(%integer %name PL, %integer SIZE))
   %external %routine %spec PRINTLIST(%integer HEAD)
                                         ! START OF COMPILATION
   K = host//10
      %if k=0 %then k=1
   K = BYTESPERKFORSOURCE//K;             ! DISTINGUISH BYTE&WORD ADDRESSED%c
                                         HOSTS
                                         ! ALLOW FOR BYTE & WORD ADDRESS M-CS
   A == ARRAY(WORKA_WKFILE AD+K*WORKA_WKFILEK,AF)
   %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.         *
!***********************************************************************
      %external %integer %fn %spec PASSONE
      WORKA_CCSIZE = BYTESPERKFORSOURCE*(WORKA_WKFILEK-1);  ! CCSIZE ALWAYS AS%c
                                                            BYTES
      %byte %integer %array %format CCF(0:WORKA_CCSIZE)
      %byte %integer %array %name CC
      CC == ARRAY(WORKA_WKFILEAD+32,CCF)
      WORKA_CC == CC
      WORKA_A == A
      WORKA_WORD == WORD
      WORKA_TAGS == TAGS
      WORKA_LINE == LINE
      WORKA_N == N
      WORKA_RELEASE = RELEASE
      WORKA_LADATE = LADATE
      WORKA_AASL0 = ADDR(ASLIST(0))
      WORKA_AMAINEP = ADDR(MAINEP)
      WORKA_LASTTRIP = WORKA_CCSIZE//40-2;  ! 40 IS SIZE OF THE TRIP ARRAY
      %if WORKA_LASTTRIP>699 %then WORKA_LASTTRIP = 699
      WORKA_OPTCNT = 0;                  ! ZERO COUNT OF OPTIMISATIONS
      WORKA_ASLIST == ASLIST
      PLABEL = 29999
      N = 12;
      MAX ULAB = WORKA_NNAMES+16384;     ! LARGEST VALID USER LABEL
      LAST INST = 0
      SFLABEL = 20999
      RLEVEL = 0; NMAX = 0; BFFLAG = 0
      RBASE = 1
      SSTL == CAS(4); USTPTR == CAS(5)
      STMTS = 1; SNUM = 0
      BIMSTR = 0
      WORKA_RTCOUNT = 1;                 ! ROUTINE 0 RESERVED FOR MAIN PROG
      MAINEP = "s#go";                   ! DEFAULT MAIN ENTRY
      INITASL(ASLIST,ASL)
      %cycle I = 0,1,12
         CAS(I) = 0; DVHEADS(I) = 0
      %repeat
!
      DUMMY FORMAT = 0;                  ! DUMMY RECORD FORMAT
      PUSH(DUMMY FORMAT,0,0,0);          ! FOR BETTER ERROR RECOVERY
      P1SIZE = PASSONE
      R = P1SIZE
      WORKA_ARTOP = P1SIZE
   %end;                                 ! OF BLOCK CONTAINING PASS 1
   %if PARM_FAULTY#0 %start
      COMREG(24) = 8
      COMREG(47) = PARM_FAULTY
      %return
   %finish
   %begin
!***********************************************************************
!*    SECOND OR TRIPLES GENERATING PASS                                *
!***********************************************************************
      %record (LEVELF) %name CURRINF
      %integer TWSPHEAD,FORCNT,FORDPTH,FORCECNT
      %if HOST=EMAS %or HOST=IBM %or HOST=AMDAHL %or HOST=IBMXA %start
                                         ! LPUT BASED WORKFILE USED FOR OBJECT
         %record (TRIPF) %array TRIPLES(0:WORKA_LASTTRIP)
      %finish %else %start
         %record (TRIPF) %array %format TRIPLESFORM(0:WORKA_LASTTRIP)
         %record (TRIPF) %array %name TRIPLES
         TRIPLES == ARRAY(WORKA_WKFILEAD+32,TRIPLESFORM)
      %finish
      %integer %array %format CF(0:12*WORKA_NNAMES)
      %integer %array %name CTABLE
!%routinespec NOTE CREF(%integer CA)
!%routinespec STORE CONST(%integername D,%integer L,AD)
!%integerfnspec WORD CONST(%integer VALUE)
      %routine %spec REUSE TEMPS
      %routine %spec GET WSP(%integer %name PLACE, %integer SIZE)
      %routine %spec RETURN WSP(%integer PLACE,SIZE)
      %routine %spec COMPILE A STMNT
      %integer %fn %spec NEW TRIP
      %integer %fn %spec FROMAR4(%integer PTR)
      %integer %fn %spec FROMAR2(%integer PTR)
      %integer %fn %spec UCONSTTRIP(%integer OPERN,OPTYPE,FLAGS,CONST)
      %integer %fn %spec ULCONSTTRIP(%integer OPERN,OPTYPE,FLAGS,CONST1,CONST2)
      %integer %fn %spec UNAMETRIP(%integer OPERN,OPTYPE,FLAGS,NAME)
      %integer %fn %spec UTEMPTRIP(%integer OPERN,OPTYPE,FLAGS,TEMP)
      %integer %fn %spec BRECTRIP(%integer OPERN,OPTYPE,FLAGS,
         %record (RD) %name OPND1,OPND2)
      %integer %fn %spec URECTRIP(%integer OPERN,OPTYPE,FLAG,
         %record (RD) %name OPND1)
      %routine %spec KEEPUSECOUNT(%record (RD) %name OPND)
      %routine %spec CSS(%integer P)
      %cycle I = 0,1,MAXLEVELS
         LEVELINF(I) = 0
         LEVELINF(I)_NAMES = -1
      %repeat
      CTABLE == ARRAY(ADDR(ASLIST(1)),CF)
      WORKA_CTABLE == CTABLE
      WORKA_LEVELINF == LEVELINF
      CTABLE(0) = M'CTAB'
      TWSPHEAD = 0
      FORCNT = 0;                        ! COUNTS FORS TO DETECT NESTING
      FORDPTH = 0;                       ! COUNTS DEPTH OF NESTED FORS
      FORCECNT = 0;                      ! UPDATED WHEN TRIPLES FORCED OUT
                                         ! KEPT SO THAT GLAENING IS POSSIBLE
      PROLOGUE(ASLIST)
      LINE = 0
      NEXTTRIP = 1
      TRIPLES(0) = 0
      NEXTP = 1; LEVEL = 1; STMTS = 0
      CURRINF == LEVELINF(LEVEL)
      RLEVEL = 0; RBASE = 0
      CURRINF = 0
      CURRINF_CLEVEL = LEVEL
      CURRINF_NAMES = -1
      %if target=gould %then currinf_maxpp = 8;  ! max parameters passed
      %while A(NEXTP+3)!A(NEXTP+4)#0 %cycle
         COMPILE A STMNT
      %repeat
      LINE = 99999
      EPILOGUE(STMTS)
{bugtrace}   printstring("plabel="); write(plabel,5);
printstring("   sflabel="); write(sflabel,5); newline

      %if PARM_FAULTY#0 %start
         COMREG(24) = 8
         STMTS = PARM_FAULTY
      %else
         COMREG(24) = 0
      %finish
      COMREG(47) = STMTS
      %if HOST=PERQ %start
         *RETURN;                        ! JUMP WONT REACH!
      %finish %else ->P2END
      %routine FORCE TRIPS
!***********************************************************************
!*    FORCE OUT THE TRIPLES TO CODE. NEEDED IN CEND ETC                *
!***********************************************************************
         %return %if NEXT TRIP=1
         FORCECNT = FORCECNT+1
         %if PARM_OPT=0 %then TRIP OPT(TRIPLES,NEXT TRIP)
         GENERATE(TRIPLES,LEVEL,GET WSP)
         TRIPLES(0) = 0
         NEXTTRIP = 1
         TRIPLES(0)_FLINK = 1;         !  NEXT TRIP
         %if TWSPHEAD#0 %then REUSE TEMPS
      %end
      %routine COMPILE A STMNT
         %integer I
         FORCE TRIPS %if NEXT TRIP>199 %or (NEXT TRIP>1 %and PARM_OPT#0)
         I = NEXTP
         STARSIZE = A(NEXTP)<<16+A(NEXTP+1)<<8+A(NEXTP+2)
         NEXTP = NEXTP+STARSIZE
         LINE = A(I+3)<<8+A(I+4)
         STMTS = STMTS+1
         CSS(I+5)
!      %cycle I=0,1,4
!      %repeat
!      CHECK ASL %if LINE&7=0
      %end
      %routine CSS(%integer Pinit)
         %routine %spec ENTER JUMP(%integer MASK,STAD,FLAG)
         %integer %fn %spec ENTER LAB(%integer M,FLAG)
         %routine %spec REMOVE LAB(%integer LAB)
         %routine %spec SAVE STACK PTR
         %routine %spec CEND(%integer KKK)
         %integer %fn %spec CCOND(%integer CTO,A,B,JFLAGS)
         %integer %fn %spec REVERSE(%integer MASK)
         %routine %spec SET LINE
         %routine %spec CUI(%integer CODE)
         %routine %spec ASSIGN(%integer A,B)
         %routine %spec CSTART(%integer CCRES,MODE)
         %integer %fn %spec CHECKBLOCK(%integer P,PIN)
         %routine %spec CCYCBODY(%integer UA,ELAB,CLAB)
         %routine %spec CLOOP(%integer ALT,MARKC,MARKUI)
         %routine %spec CIFTHEN(%integer MARKIU,MARKC,MARKUI,MARKE,MARKR,SKIP)
         %integer %fn %spec CREATE AH(%integer MODE,
            %record (RD) %name EOPND,NOPND)
         %routine %spec TORP(%integer %name HEAD,BOT,NOPS)
         %integer %fn %spec INTEXP(%integer %name VALUE, %integer PRECTYPE)
         %integer %fn %spec CONSTEXP(%integer PRECTYPE)
         %routine %spec CSEXP(%integer MODE)
         %routine %spec CSTREXP(%integer B)
         %routine %spec CRES(%integer LAB)
         %routine %spec EXPOP(%integer %name A,B, %integer C,D)
         %routine %spec TEST APP(%integer %name NUM)
         %routine %spec SKIP EXP
         %routine %spec SKIP APP
         %routine %spec NO APP
         %integer %fn %spec DOPE VECTOR(%integer A,B,C,MODE,ID,
            %integer %name C,D)
         %routine %spec DECLARE ARRAYS(%integer A,B)
         %routine %spec DECLARE SCALARS(%integer B)
         %routine %spec CRSPEC(%integer M)
         %integer %fn %spec SET SWITCHLAB(%integer HEAD,LAB,FNAME,BIT)
         %routine %spec CFPLIST(%integer %name A,B)
         %routine %spec CFPDEL
         %routine %spec CLT
         %integer %fn %spec ROUNDING LENGTH(%integer PTYPE,RULES)
         %routine %spec CQN(%integer P)
         %integer %fn %spec TSEXP(%integer %name VALUE)
         %routine %spec CRCALL(%integer RTNAME)
         %routine %spec NAMEOP(%integer Z,SIZE,NAMEP)
         %routine %spec CNAME(%integer Z)
         %routine %spec CANAME(%integer Z,ARRP, %record (RD) %name HDOPND)
         %routine %spec CSNAME(%integer Z)
         %routine %spec COPY TAG(%integer KK,DECLARE)
         %routine %spec REDUCE TAG(%integer DECLARE)
         %routine %spec STORE TAG(%integer KK,LEVEL,RBASE,J,SNDISP,ACC,SLINK,
            KFORM)
         %routine %spec UNPACK
         %routine %spec PACK(%integer %name PTYPE)
         %routine %spec RDISPLAY(%integer KK)
         %routine %spec RHEAD(%integer RTNAME,AXNAME,Xtra)
         %integer %fn %spec CFORMATREF
         %routine %spec CRFORMAT(%integer %name OPHEAD,OPBOT,NLIST,MRL,
            %integer INIT)
         %integer %fn %spec DISPLACEMENT(%integer LINK)
         %integer %fn %spec COPY RECORD TAG(%integer %name SUBS)
         %integer %fn %spec CHK REC ALIGN(%integer p1)
         %switch SW(1:24)
         %const %byte %integer %array FCOMP(0:14)=0,
                                   8,10,2,7,12,4,7,
                                   8,12,4,7,10,2,7

         %integer P,SNDISP,ACC,K,KFORM,STNAME,MIDCELL
         %integer TCELL,JJ,JJJ,KK,QQ,MARKER,REPORTUI,XDISP,MASK,BASE,AREA,
            ACCESS,DISP,EXTRN,CURR INST,VALUE,STRINGL,PTYPE,I,J,OLDI,USEBITS,
            STRFNRES,MARKIU,MARKUI,MARKC,MARKE,MARKR,INAFORMAT
         %integer LITL,ROUT,NAM,ARR,PREC,TYPE
         %record (RD) EXPOPND,NAMEOPND,MLOPND;  ! RESULT RECORD FOR EXPOP&CNAME
!
! on some machines global parameters are difficult to access hence
! copy pinit into local P which is frequently updated globally
!
         P = Pinit
         CURR INST = 0; INAFORMAT = 0
	type=7; prec=5; rout=0; nam=0; litl=0; arr=0; ptype=x'57'
         acc=4; i=0; j=0; k=0; base=0; disp=0
         EXPOPND=0; NAMEOPND=0; MLOPND=0
         ->SW(A(P))
SW(13):                                  ! INCLUDE SOMETHING
SW(24):                                  ! REDUNDANT SEP
SW(2):                                   ! <CMARK> <COMMENT TEXT>
CSSEXIT: LAST INST = CURR INST
         %return
SW(1):                                   !(UI)(S)
         FAULT(57,0,0) %unless LEVEL>=2
         MARKER = P+1+A(P+1)<<8+A(P+2)
         P = P+3
         ->LABFND %if A(MARKER)=1
         %if A(MARKER)=2 %then SET LINE %and CUI(0) %and ->CSSEXIT
         MARKE = 0; MARKR = 0
         MARKUI = P; MARKIU = MARKER+1
         MARKC = MARKIU+1
         %if A(MARKER)=3 %then %c
            CIFTHEN(MARKIU,MARKC,MARKUI,0,0,NO) %and ->CSSEXIT
         CLOOP(A(MARKIU),MARKC+2,MARKUI)
         ->CSSEXIT
LABFND:  OLDLINE = 0
         ->SWITCH %unless A(P)=1 %and A(P+5)=2;  ! 1ST OF UI AND NO APP
         ->SWITCH %unless A(P+6)=2 %and A(P+7)=2;  ! NO ENAMSE OR ASSNMNT
         JJ = ENTER LAB(FROM AR2(P+3),0)
         FORCE TRIPS %if PARM_OPT=0
         ->CSSEXIT
SW(5):                                   ! %cycle
         FAULT(57,0,0) %unless LEVEL>=2
         %if A(P+5)=2 %then %start;      ! OPEN CYCLE
            CLOOP(0,P+1,P+1)
         %finish %else %start
            SET LINE
            CLOOP(6,P+6,P+1)
         %finish
         ->CSSEXIT
!
SW(6):                                   ! REPEAT
         ->CSSEXIT
SW(22):                                  ! '%CONTROL' (CONST)
         FORCE TRIPS %if PARM_OPT=0
         J = FROM AR4(P+2)
         I = J>>28
         PARM_DCOMP = I %unless I=15
         I = J>>24&15
         PARM_Y = I %unless I=15

         I = J>>20&15
         PARM_Z = I %unless I=15
         I = J&15
         PARM_LINE = I %unless I=15
         I = J>>4&15
         PARM_DIAG = I %unless I=15
         ->CSSEXIT
!
SW(3):                                   ! (%iu)(COND)%then(UI)(ELSE')
         MARKIU = P+1; MARKC = MARKIU+3
         MARKR = P+2+A(P+2)<<8+A(P+3);   ! ! FROMAR2(P+2)
         MARKE = 0; MARKUI=0
         %if A(MARKR)=3 %then %start
            MARKE = MARKR+1+FROMAR2(MARKR+1)
            MARKUI = MARKR+3
         %finish
         CIFTHEN(MARKIU,MARKC,MARKUI,MARKE,MARKR,NO)
         ->CSSEXIT
SW(4):
                                         ! '%FINISH(ELSE')(S)
SW(18):
                                         ! '%ELSE' MEANING FINISH ELSE START
         ->CSSEXIT
SWITCH:  %begin;                         ! SWITCH LABEL
            %integer NAPS,FNAME
            FNAME = FROM AR2(P+3)
            %unless A(P)=1 %and A(P+5)=1 %then FAULT(5,0,FNAME) %and ->BEND
                                         ! 1ST OF UI + APP
            P = P+3; TEST APP(NAPS)
            P = P+6
            %unless INTEXP(JJ,MINAPT)=0 %then FAULT(41,0,0) %and ->BEND
                                         ! UNLESS EXPRESSION EVALUATES AND
            %unless NAPS=1 %then FAULT(21,NAPS-1,FNAME) %and ->BEND
                                         ! NO REST OF APP
            %unless A(P+1)=2=A(P+2) %then FAULT(5,0,FNAME) %and ->BEND
                                         ! NO ENAME OR REST OF ASSIGMENT
            COPY TAG(FNAME,NO)
            %if OLDI#LEVEL %or TYPE#6 %then FAULT(4,0,FNAME) %and ->BEND
            %if SET SWITCHLAB(K,JJ,FNAME,1)#0 %then FAULT(6,JJ,FNAME)
BEND:    %end
         FORCE TRIPS %if PARM_OPT=0
         ->CSSEXIT
SW(23):
                                         ! SWITCH(*):
         %begin
            %record (LISTF) %name LCELL
            %integer FNAME,JJ,RES
            FNAME = FROM AR2(P+1)
            COPY TAG(FNAME,NO)
            %if OLDI=LEVEL %and TYPE=6 %start
               LCELL == ASLIST(K)
               %cycle JJ = LCELL_S2,1,LCELL_S3
                  RES = SET SWITCHLAB(K,JJ,FNAME,0)
               %repeat
            %finish %else FAULT(4,0,FNAME)
         %end
         FORCE TRIPS %if PARM_OPT=0
         ->CSSEXIT
!
SW(7):                                   ! (%wu)(SC)(COND)(RESTOFWU)
         FAULT(57,0,0) %unless LEVEL>=2
         MARKIU = P+1;                   ! TO WHILE/UNTIL
         MARKC = MARKIU+3;               ! TO (SC)(COND)
         CLOOP(A(MARKIU)+3,MARKC,MARKIU+1+FROMAR2(MARKIU+1))
         ->CSSEXIT
!
SW(8):                                   ! SIMPLE DECLN
         FAULT(57,0,0) %unless LEVEL>=2
         FAULT(40,0,0) %if CURRINF_NMDECS&1#0
         P = P+1
         MARKER = P+FROMAR2(P);          ! TO ALT OF DECLN
         P = P+2; ROUT = 0; LITL = 0; J=0
         %if A(MARKER)#1 %then %start;   ! ARRAY DECLARATIONS
            CLT
            %if TYPE=5 %and (ACC<=0 %or ACC>256) %then %c
               FAULT(70,ACC-1,0) %and ACC = 255
            NAM = 0
            SET LINE
            QQ = 2-A(P+1); P = P+2;      ! QQ=1 FOR ARRAYFORMATS
            DECLARE ARRAYS(QQ,KFORM)
            FORCE TRIPS %if PARM_OPT=0
         %finish %else %start
            CLT
            CQN(P+1); P = P+2
            DECLARE SCALARS(KFORM)
         %finish
         ->CSSEXIT
!
SW(9):                                   ! %end
         %begin
            %switch S(1:5)
            ->S(A(P+1))
S(1):                                    ! ENDOFPROGRAM
S(2):                                    ! ENDOFFILE
            %if PARM_CPRMODE=0 %then PARM_CPRMODE = 2
            FAULT(15,LEVEL+PARM_CPRMODE-3,0) %unless LEVEL+PARM_CPRMODE=3
            CEND(PARM_CPRMODE)
            ->BEND
S(3):                                    ! ENDOFLIST
            ->BEND
S(4):                                    ! END
            %if PARM_CPRMODE=1 %and LEVEL=2 %then FAULT(14,0,0) %else %c
               CEND(CURRINF_FLAG)
BEND:    %end
         ->CSSEXIT
!
SW(11):
         %begin
            %integer MARKER1,RTNAME,KKK,PTR,PTYPEP,CNT,PP,PCHAIN,AXNAME,
               PNAME,NPARAMS,SCHAIN,PARMSPACE,D,PARAMPTYPE,PARAMACC
            %record (LISTF) %name LCELL,TCELL
            P = P+1; MARKER1 = FROM AR2(P)+P;  ! (SEX)(RT)(SPEC')(NAME)(FPP)
AGN:        Q = P; RTNAME = FROM AR2(MARKER1+3);  ! RTNAME ON NAME
            EXTRN = A(P+2);              ! 1=SYSTEM,2=EXTERNAL
                                         ! 3=DYNAMIC, 4=INTERNAL

            LITL = EXTRN&3
            %if A(MARKER1)=1 %then %start;  ! P<%spec'>='%spec'
               P = P+3; CRSPEC(1-EXTRN>>2);  ! 0 FOR ROUTINESPEC
                                         ! 1 FOR EXTERNAL (ETC) SPEC
               ->BEND
            %finish
            FORCE TRIPS;                 ! IN CASE OPTIMISING
            COPY TAG(RTNAME,NO)
            AXNAME = ADDR(WORKA_LETT(WORD(RTNAME)))
            %if EXTRN=3 %then EXTRN = 2
            %if TARGET=EMAS %and EXTRN=1 %then WARN(11,0)
            %if A(MARKER1+5)=1 %then %start;! extract alias name
               MOVE BYTES(A(MARKER1+6)+1,ADDR(A(0)),MARKER1+6,ADDR(A(0)),
                  WORKA_ARTOP)
               AXNAME = ADDR(A(WORKA_ARTOP))
               WORKA_ARTOP = (WORKA_ARTOP+4+A(MARKER1+6))&(-4)
            %finish
            %if EXTRN=4 %then AXNAME = 0
            %if OLDI#LEVEL %then %start;  ! NAME NOT KNOWN AT THIS LEVEL
               P = Q+3; CRSPEC(0); P = Q; ->AGN
            %finish %else %start;        ! NAME ALREADY KNOWN AT THIS LEVEL
               %if PARM_CPRMODE=0 %then PARM_CPRMODE = 2;  ! FLAG AS FILE OF%c
                                                           ROUTINES
               FAULT(56,0,RTNAME) %unless %c
                  EXTRN=4 %or (PARM_CPRMODE=2 %and LEVEL=1)
               %if A(P+3)=1 %then KKK = LITL<<14!X'1000' %else %start
                  ROUT = 1; P = P+4;     ! FIGURE OUT PTYPE FOR FNS&MAPS
                  CLT; ARR = 0; NAM = 0
                  %if A(P)=2 %then NAM = 2;  ! SET NAME ARRAY BIT FOR MAPS
                  PACK(KKK);             ! AND STORE PTYPE IN KKK
               %finish
            %finish
!
! UNLESS A MATCH WAS OBTAINED BETWEEN HEADING AND SPEC SOMETHING
! HAS GONE WRONG. COMPILE HEADING AGAIN AS SPEC. THIS WILL
! PREVENT ANY INCONSISTENCIED AND CAUSE A "NAME SET TWICE"
! FOR ANY ERROR
!
            %unless (J=15 %or J=7*EXTRN) %and PTYPE&X'FFFF'=KKK %start
               P = Q+3; CRSPEC(0); P = Q; ->AGN
            %finish
            PTYPE = PTYPE!(EXTRN&3)<<14;  ! DEAL WITH %routinespec FOLLOWED
                                         ! BY %externalroutine
!
! RESET THE TAGS TO BODY GIVEN AND ALLOWING FOR SPEC/EXTERNALROUTINE
! AND EXTERNALSPEC/EXTERNAL ROUTINE COMBINATIONS. RESTORE THE USE
! BITS WHICH WILL SHOW USED AS A RESULT OF THE COPY TAG IN THIS SEQUENCE
!
            TCELL == ASLIST(TAGS(RTNAME))
            TCELL_PTYPE <- PTYPE
            %if PTYPE&x'c000'=x'8000' %then USEBITS = 2;  ! externals presumed%c
                                                          'used'

            TCELL_UIOJ <- TCELL_UIOJ&X'3FF0'!USEBITS<<14
                                         ! NEWPTYPE & SET J=0
            %if (target=Perq %or Target=Accent) %and J=14 %then %c
              TCELL_S2 = WORKA_RTCOUNT %and WORKA_RTCOUNT = WORKA_RTCOUNT+1
                                         ! NO RT NO ALLOCATED TO EXTERNAL SPECS
            PTYPEP = PTYPE
            PCHAIN = TCELL_SLINK;        ! CHAIN OF PARAMETER DESCRIPTUONS
            RHEAD(RTNAME,AXNAME,fromar2(marker1+1));! FIRST PART OF ENTRY SEQUENCE
!
! NOW DECLARE THE FORMAL PARAMETERS. FOLLOW BY CLAIMING DISPLAY
! AND SETTING DIAGNOSTIC PTR IN ROUTINE RDISPLAY
!
            P = MARKER1+6
            %if A(P-1)=1 %then P = P+A(P)+1;  ! SKIP OVER ALIASNAME
            CNT = 0
            PTYPE = PTYPEP; UNPACK
            N = RTPARAM1OFFSET
            %if TARGET=PERQ %or TARGET=ACCENT %start
               %if TYPE#0 %then N = (BYTES(PREC)+1)&(-2)
               %if TYPE=5 %or TYPE=3 %then N = 4;  ! MAPS
               %if NAM#0 %then %start
                  %if TYPE=5 %then N = 4 %else N = PTRSIZE(PTYPE&127)
                                         ! BYTE MAPS RETURN BYTE PTR
               %finish
               CURRINF_RESSIZE = N
            %finish
            NPARAMS = 0; PARMSPACE = 0
            %if PCHAIN#0 %then NPARAMS = ASLIST(PCHAIN)_S3
            %if NPARAMS#0 %then %c
               PARMSPACE = NPARAMS>>16 %and NPARAMS = NPARAMS&X'FF'
                                         ! ALLOW ACTUAL PARAMETER SPACE
            %while A(P)=1 %cycle;        ! WHILE SOME (MORE) FP PART
               PP = P+1+FROMAR2(P+1)
               P = P+3
               CFPDEL
               PARAMPTYPE = PTYPE; PARAMACC = ACC;  ! may get cahnged for rt%c
                                                    types
               PTR = P
               %until A(PTR-1)=2 %cycle;  ! CYCLE DOWN NAMELIST
                  %if PARAMS BWARDS=YES %start;  ! MAP PCHAIN TO REVERSE ORDER%c
                                                 LIST
                     PCHAIN = TCELL_SLINK
                     PCHAIN = ASLIST(PCHAIN)_LINK %for KKK = 2,1,NPARAMS-CNT
                  %finish
                  LCELL == ASLIST(PCHAIN);  ! EXTRACT PTYPE XTRA INFO
                  %if PCHAIN#0 %then %start
                     %unless LCELL_PTYPE=PARAMPTYPE %and %c
                        LCELL_ACC&x'FFFF'=PARAMACC %then FAULT(9,CNT+1,RTNAME)
                  %finish
                  PNAME = FROM AR2(PTR);  ! NAME FOR PARAM INTERNALLY
                  LCELL_UIOJ <- LCELL_UIOJ!PNAME<<4;  ! SAVED IN LIST( max 12 bits!)
                  D = LCELL_SNDISP+N;    ! PARAMETER OFFSET
                  %if PARAMPTYPE&x'1000'#0 %start;  ! PROCEDURE PARAMETERS
                     P = PTR
                     P = P+3 %until A(P-1)=2
                     CFPLIST(SCHAIN,KKK);  ! PARAMETERLIST FOR PASSED PROC
                     PTYPE = PARAMPTYPE;  ! CHANGED BY CFPLIST
                     STORETAG(PNAME,LEVEL,RBASE,13,D,LCELL_ACC,SCHAIN,0)
                  %finish %else %start
                     %if TARGET=EMAS %and PTYPE=X'33' %then D = D+8
                                         ! FOR HISTORIC PARAMTER COMPATABILITY
                     %if STRVALINWA=YES %and PTYPE=X'35' %then PTYPE = X'435'
                      %if recvalinwa=yes %and ptype=X'33' %and acc#4 %then ptype=x'433'
                     STORE TAG(PNAME,LEVEL,RBASE,LCELL_UIOJ&15,0,ACC,D,KFORM)
                     PTYPE = PARAMPTYPE
                  %finish
                  PTR = PTR+3
                  CNT = CNT+1
                  PCHAIN = LCELL_LINK %if PARAMS BWARDS=NO
               %repeat
               P = PP
            %repeat;                     ! UNTIL NO MORE FP-PART
            N = N+PARMSPACE
            N = (N+MINPARAMSIZE-1)&(-MINPARAMSIZE);  ! TO WORD BOUNDARY AFTER%c
                                                     ALL SYSTEM
                                         ! STANDARD PARAMETERS HAVE BEEN%c
                                         DECLARED
            FAULT(8,0,RTNAME) %if CNT>NPARAMS
            FAULT(10,0,RTNAME) %if CNT<NPARAMS
            PTYPE = PTYPEP
            %if STRRESINWA=YES %start;   ! NEEDS FN RESULT DESC
               %unless 3#PTYPE&X'F0F'#5 %then N = N+PTRSIZE(X'35')
                                         ! STR FNS RESULT PARAM IS STACKED
               CURRINF_RESSIZE = N
            %finish
            N = N+ALPHA;                 ! allow for link bytes on unix(etc)
            %if TARGET=PNX %then %start
               IMPABORT %if N&7#0
            %finish
                                         ! AS XTRA PARM JUST BEFORE DISPLAY
            RDISPLAY(RTNAME)
BEND:    %end
      Force trips %if parm_opt=0;! Problems if procname redeclared
                                         ! as new proc before entry code planted
       ->CSSEXIT
!
SW(14):                                  ! %begin
         %begin
            FORCE TRIPS;                 ! IN CASE OPTIMISING
            PTYPE = 0
            %if LEVEL=1 %and RLEVEL=0 %start
               %if PARM_CPRMODE=0 %then %start
                  RLEVEL = 1; RBASE = 1
                  PARM_CPRMODE = 1
                  RHEAD(-1,ADDR(MAINEP),1)
                  N = RTPARAM1OFFSET+alpha
               %finish %else FAULT(58,0,0)
            %finish %else %start
               SET LINE;                 ! SO 'ENTERED FROM LINE' IS OK
               RHEAD(-1,0,1)
            %finish
            RDISPLAY(-1)
         %end
         ->CSSEXIT
!
SW(15):
                                         ! '%ON'(EVENT')(N)(NLIST)'%start'
         FAULT(57,0,0) %unless LEVEL>=2
         FAULT(40,0,0) %if CURRINF_NMDECS&1#0
         FORCE TRIPS;                    ! IN CASE OPTIMISING
         CURRINF_NMDECS = CURRINF_NMDECS!X'11';  ! NO MORE DECS AND IN ONCOND
         %if TARGET=EMAS %then SAVE STACK PTR;  ! NEEDED WITH AUXSTACKS ONLY
         JJ = UCONSTTRIP(ONEV1,X'51',DONTOPT,0);  ! SAVE PROGRAM MASK ETC
         PLABEL = PLABEL-1
         JJJ = PLABEL
         ENTER JUMP(15,JJJ,B'10');       ! JUMP ROUND ON BODY
!
         P = P+1; JJ = 0;                ! SET UP A BITMASK IN JJ
         %until A(P)=2 %cycle;           ! UNTIL NO MORE NLIST
            KK = -1; P = P+4
            FAULT(26,KK,0) %unless INTEXP(KK,MINAPT)=0 %and 1<=KK<=14
            JJ = JJ!1<<(KK-1)
         %repeat
         P = P+1
         CURRINF_ONWORD = JJ<<18
         LEVELINF(0)_ONWORD = LEVELINF(0)_ONWORD!JJ<<18
         N=(N+sframe misalign+7)&(-8)-sframe misalign;! double align
         CURRINF_ONINF = N; N = N+16
         JJ = UCONSTTRIP(ONEV2,X'51',DONTOPT,JJ)
         OLDLINE = 0
         CSTART(0,3)
         CURRINF_NMDECS = CURRINF_NMDECS!!X'10';  ! NOT IN ONCOND
         JJ = ENTER LAB(JJJ,B'011');     ! MERGE ENVIRONMENT
         ->CSSEXIT
SW(16):
         %begin;                         ! %switch (SWITCH LIST)
            %integer Q,RANGE,KKK,LB,UB,PP,OPHEAD,V,R
            %record (RD) OPND1,OPND2
            FAULT(57,0,0) %unless LEVEL>=2
            Q = P
            %unless TARGET=EMAS %then %c
               PLABEL = PLABEL-1 %and ENTER JUMP(15,PLABEL,0)
            %until A(Q)=2 %cycle;        ! UNTIL NO'REST OF SW LIST'
               P = P+3
               P = P+3 %while A(P)=1
               P = P+4;                  ! TO P(+')
               KKK = INTEXP(LB,MINAPT);  ! EXTRACT LOWER BOUND
               P = P+3
               KKK = KKK!INTEXP(UB,MINAPT);  ! EXTRACT UPPER BOUND
               RANGE = (UB-LB+1)
               %if RANGE<=0 %or KKK#0 %start
                  FAULT(38,1-RANGE,FROMAR2(Q+1))
                  LB = 0; UB = 10; RANGE = 11
               %finish
               PTYPE = X'56'+1<<8;       ! WORD LABEL ARRAY
               PP = P; P = Q+1
               %until A(P-1)=2 %cycle;   !  DOWN NAMELIST
                  K = FROM AR2(P)
                  P = P+3
                  OPHEAD = 0; R = LB
!
! SET UP A BIT LIST (96 BITS PER CELL) TO CHECK FOR SWITCH LABELS
! SET TWICE
!
                  %until R>UB %cycle
                     PUSH(OPHEAD,0,0,0)
                     R = R+96
                  %repeat
                  OPND1_PTYPE <- PTYPE
                  OPND1_XB = 0
                  OPND1_FLAG = DNAME
                  OPND1_D = K
                  OPND1_XTRA = 0
                  OPND2_PTYPE = X'61'
                  OPND2_XB = 0
                  OPND2_FLAG = DNAME
                  OPND2_D = LB
                  OPND2_XTRA = UB
                  V = BRECTRIP(DCLSW,PTYPE,0,OPND1,OPND2)
                  PUSH(OPHEAD,0,LB,UB)
                  STORE TAG(K,LEVEL,RBASE,1,0,4,OPHEAD,0)
!
!THE TABLE WILL CONSIST OF RELATIVE DISPLACEMENTS FROM EACH ENTRY
! TO THE LABEL POSN. SET ALL TO GO TO PLAB(6) INITIALLY
!
               %repeat;                  ! FOR ANY MORE NAMES IN NAMELIST
               Q = PP; P = Q
            %repeat;                     ! UNTIL A(Q)=2
            %unless TARGET=EMAS %then KKK = ENTER LAB(PLABEL,0)
                                         ! COMPLETE JUMP AROUND TABLE
         %end; ->CSSEXIT
!
SW(17):  ->CSSEXIT
!
SW(12):                                  ! '%OWN' (TYPE)(OWNDEC)
         %begin
!***********************************************************************
!*       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. QPUT 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.            *
!***********************************************************************
            %routine %spec CLEAR(%integer L)
            %routine %spec XTRACT CONST(%integer CONTYPE,CONPREC)
            %routine %spec INIT SPACE(%integer A,B)
            %integer SLENGTH,PP,SIGN,TAGDISP,DVO,K,STALLOC,SPOINT,
               CONSTSFOUND,CPREC,EXTRN,NNAMES,MARK,QPUTP,LB,CTYPE,CONSTP,
               FORMAT,DPTYPE,DIMEN,SACC,TYPEP,KK,orlevel,savesndisp
            %record (RD) COPND,FCOPND
            %own %long %real ZERO=0
            %string (255) SCONST,NAMTXT
            %record (LISTF) %name LCELL
            QPUTP = 5;                  ! NORMAL CASE GLA SYMBOLTABLES
!      FAULT(40,0,0) %if NMDECS&1#0
            EXTRN = A(P+1)
            P = P+2
            %if EXTRN>=4 %then EXTRN = 0;  ! CONST & CONSTANT->0
            SNDISP = 0
            CONSTS FOUND = 0
            %if EXTRN=0 %then QPUTP = 4
            CLT
!
! CHECK FOR %spec AND CHANGE EXTERNAL SPEC TO EXTRINSIC
!
            %if A(P+2)=1 %start
               %if EXTRN=2 %then EXTRN = 3 %else FAULT(46,0,0)
            %finish
            %if 2<=EXTRN<=3 %and ((A(P)=1 %and A(P+1)#3) %or (A(P)=2 %and %c
               A(P+1)#2)) %then FAULT(46,0,0)
            LITL = EXTRN
            %if LITL<=1 %then LITL = LITL!!1
            %if A(P)=1 %then CQN(P+1) %else ARR = 1 %and NAM = 0
            %if TYPE=5 %and NAM=0 %and (ACC<=0 %or ACC>256) %then %c
               FAULT(70,ACC-1,0) %and ACC = 2
            STALLOC = ACC;               ! ALLOCATION OF STORE FOR ITEM OR%c
                                         POINTER
            %if (TARGET=PERQ %or TARGET=ACCENT %or TARGET=PNX) %and %c
               TYPE=5 %then STALLOC = (STALLOC+1)&X'FFE'
            ROUT = 0; PACK(PTYPE); DPTYPE = PTYPE;  ! FOR DECLARATION
            %if NAM#0 %start;            ! OWN POINTERS
               %if ARR#0 %then STALLOC = 8 %else STALLOC = 4
            %finish %else %start;        ! OWN VARS & ARRAYS
               ->NON SCALAR %if ARR#0
            %finish
            P = P+2
            %until A(MARK)=2 %cycle;     ! UNTIL <RESTOFOWNDEC> NULL
               MARK = P+1+FROM AR2(P+1)
               PP = P+3; P = PP+2;       ! PP ON FIRST NAME'
               K = FROM AR2(PP);         ! FOR ERROR MESSAGES RE CONST
               NAMTXT = STRING(ADDR(WORKA_LETT(WORD(K))))
               %if A(P)=1 %then %start;  ! ALAIS GIVEN
                  %if LITL=0 %then WARN(10,0)
                  LENGTH(NAMTXT) = A(P+1)
                  CHARNO(NAMTXT,KK) = A(P+KK+1) %for KK = 1,1,A(P+1)
                  P = P+A(P+1)+1
               %finish
               P = P+1;                  ! P ON CONST'
!
! OBTAIN THE INITIAL CONSTANT,ITS TYPE(CTYPE) AND SIGN(SIGN)
!
               SCONST = ""
               PTYPE = DPTYPE; UNPACK;   ! MAY HAVE BEEN CONSTANT EVALUATIONS
                                         ! WHICH HAVE CHANGED PTYPE
               SIGN = 3; CTYPE = TYPE; CONSTSFOUND = 0; CPREC = PREC
               %if TYPE=3 %then CTYPE = 1;  ! RECS INITTED TO REPEATED BYTE
               %if NAM#0 %then CTYPE = 1 %and CPREC = 5
               P = P+1
               %if A(P-1)=1 %then %start;  ! CONSTANT GIVEN
                  XTRACT CONST(CTYPE,CPREC)
               %finish %else %start
                  WARN(7,K) %if EXTRN=0;  ! %const NOT INITIALISED
                  FCOPND = 0; COPND = 0
               %finish
               J = 0; orlevel = 0
               %if NAM#0 %then %start;   ! OWNNAMES AND ARRAYNAMES
                  %if ARR=0 %then %start
                     %if (target=ibm %or target=amdahl %or target=ibmxa) %and %c
                        extrn=0 %start
                        tagdisp = worka_constptr
                        %if type=5 %then ctable(tagdisp)=acc %and %c
                             worka_constptr=worka_constptr+1
                        ctable(worka_constptr) = fcopnd_d
                        worka_constptr = worka_constptr+1
                        %if worka_constptr>worka_const limit %then %c
                           fault(102,worka_wkfilek,0)
                        tagdisp = 4*tagdisp; orlevel = 14
                     %finish %else TAGDISP = PINITOWN(PTYPE,ACC,FCOPND,NAMTXT)
                  %finish %else %start;  ! ARRAYNAMES
                     DVO = DOPE VECTOR(NO,TYPE,ACC,-1,K,QQ,LB)
                     %if PARM_COMPILER#0 %and LB#0 %then FAULT(99,0,0)
                     %if EXTRN#0 %then SNDISP = 0 %and J = 0 %else %c
                        J = 1 %and SNDISP = (SNDISP&X'3FFFF')>>2
                     TAGDISP = POWNARRAYHEAD(PTYPE,J,LB,X'FFFFFF',COPND_D,0,
                        DVO,NAMTXT)
                  %finish
                  STORE TAG(K,LEVEL,orlevel,J,SNDISP,ACC,TAGDISP,KFORM)
                  P = MARK
                  %continue
               %finish
               %if EXTRN=3 %then %start;  ! EXTRINISIC
                  PTYPE = PTYPE!X'400';  ! FORCE NAM=1 (IE VIA POINTER)
                  FCOPND_D = 0
                  TAGDISP = PINITOWN(PTYPE,ACC,FCOPND,NAMTXT)
                  STORE TAG(K,LEVEL,0,J,SNDISP,ACC,TAGDISP,KFORM)
                  P = MARK
                  %continue
               %finish
               %if TYPE=3 %then %start;  ! RECORDS
                  TAGDISP = PINITOWN(PTYPE,ACC,FCOPND,NAMTXT)
               %finish
               %if 1<<TYPE&B'100110'#0 %start;  ! INTEGER & REAL & STRING
                  %if EXTRN#0 %then %start
                     TAGDISP = PINITOWN(PTYPE,ACC,FCOPND,NAMTXT)
                  %finish %else TAGDISP = 0
               %finish
               STORE TAG(K,LEVEL,0,J,SNDISP,ACC,TAGDISP,KFORM)
               %if EXTRN=0=NAM %and 1<<TYPE&B'100110'#0 %start
                                         ! CONST = LITERAL
                  LCELL == ASLIST(TAGS(K))
                  lcell_s1=lcell_S1!(copnd_ptype&8)<<16
                  LCELL_S2 = COPND_D
                  LCELL_S3 = COPND_XTRA
                  %if TYPE=5 %then %start
                     LCELL_S2 = WORKA_ARTOP
                     WORKA_ARTOP = (WORKA_ARTOP+COPND_XTRA+4)&(-4)
                  %finish
               %finish
               P = MARK
            %repeat
            ->BEND
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 INITIALISED AS BYTE ARRAYS              *
!***********************************************************************
            P = P+1
            FORMAT = 2-A(P)
            %if FORMAT#0 %then ARR = 3 %and PACK(PTYPE)
            PP = P+2; P = P+4; NNAMES = 1
            K = FROM AR2(PP)
            NAMTXT = STRING(ADDR(WORKA_LETT(WORD(K))))
            %if A(P)=1 %then %start;     ! ALAIS GIVEN
               %if LITL=0 %then WARN(10,0)
               LENGTH(NAMTXT) = A(P+1)
               CHARNO(NAMTXT,KK) = A(P+KK+1) %for KK = 1,1,A(P+1)
               P = P+A(P+1)+1
            %finish
            P = P+1;                     ! P ON CONSTLIST
            SACC = ACC; TYPEP = PTYPE
            DVO = DOPE VECTOR(NO,TYPE,STALLOC,0,K,QQ,LB)
            %if SNDISP=-1 %then SNDISP = 0;  ! BUM DOPE VECTOR
            SNDISP = (SNDISP&X'3FFFF')>>2;  ! AS WORD DISPLACEMENT
            savesndisp=sndisp           { Not proof against C-T concatenation !}
            DIMEN = J;                   ! SAVE NO OF DIMENESIONS
            ACC = SACC; PTYPE = TYPEP; UNPACK
            %if LB=0 %and FORMAT=0 %then ARR = 2 %and PACK(PTYPE)
            %if TYPE=3 %then SLENGTH = QQ %else SLENGTH = QQ//STALLOC
                                         ! NO OF ELEMENTS
            %if (target=IBM %or target=IBMXA %or target=Amdahl %or %c
               (1<<target)&EMACHINE # 0) %and QPUTP=5  %and %c
               A(p)#1 %and extrn=1{%owns only} %then QPUTP=9;          ! divert unitialised to zgst
            cas(qputp)=(cas(qputp)+arrayrounding)&(\arrayrounding)
            SPOINT = cas(qputp)
            %if FORMAT=0 %then %start
               %if A(P)=1 %then P = P+1 %and INIT SPACE(QQ,SLENGTH)
            %finish
            %if CONSTS FOUND=0 %then %start;  ! NO CONSTANTS GIVEN
                                         ! SO CLEAR AN AREA TO ZERO
               CONSTS FOUND = SLENGTH
               CLEAR(QQ) %unless SLENGTH<1 %or EXTRN=3 %or FORMAT#0
            %finish %else %start
               FAULT(49,0,K) %if EXTRN=3 %or FORMAT#0
            %finish
            %if EXTRN=3 %then SPOINT = 0
!
! OUTPUT AN ARRAYHEAD INTO THE GLA RELATIVE TO THE START OF THE SYMBOL-
! TABLES IN WHICH THE ARRAY RESIDES.
!
            %if Format#0 %then qputp=0     { avoid data fixup in pownarrayhead}
            TAGDISP = POWNARRAYHEAD(PTYPE,J,LB,QQ,SPOINT,QPUTP,DVO,NAMTXT)
            SNDISP=savesndisp
            STORE TAG(K,LEVEL,0,J,SNDISP,ACC,TAGDISP,KFORM)
            ->BEND
            %routine INIT SPACE(%integer SIZE,NELS)
!***********************************************************************
!*       P IS TO FIRST ENTRY FOR CONSTLIST                             *
!*    MAP SPACE ONTO WORKFILE END TO GIVE SANE ERROR MESSAGE IF        *
!*    THERE WAS NOT ENOUGH SPACE                                       *
!***********************************************************************
               %const %integer BUFSIZE=512
               %integer RF,I,II,ELSIZE,AD,SPP,SLENGTH,WRIT
               %byte %integer %array SP(0:BUFSIZE+256)
               AD = ADDR(FCOPND_B0)
               ELSIZE = SIZE//NELS
                                         ! fcopnd is in target format
                                         ! however must allow for half swopped%c
                                         targets
               %if 1<<host&halfswopped=0  %and ELSIZE=2 %then AD = ADDR(FCOPND_H1)
               %if TYPE=5 %then AD = ADDR(SCONST)
               SPP = 0; WRIT = 0
               %until A(P-1)=2 %cycle
                  XTRACT CONST(TYPE,PREC)
                  %if A(P)=1 %start;     ! REPITITION FACTOR
                     P = P+2
                     %if A(P-1)=2 %then RF = NELS-CONSTS FOUND %else %start
                        P = P+2
                        %if INTEXP(RF,MINAPT)#0 %then FAULT(41,0,0) %and RF = 1
                     %finish
                     P = P+1
                  %finish %else RF = 1 %and P = P+2
                  FAULT(42,RF,0) %if RF<=0
                  %cycle I = RF,-1,1
                     %if TYPE=1=ACC %or TYPE=3 %start
                        %cycle II = 0,1,ELSIZE-1
                           %if CONSTS FOUND<=NELS %then %c
                              SP(SPP) <- COPND_D %and SPP = SPP+1
                        %repeat
                     %finish %else %start
                        %if TYPE#5 %and ELSIZE=16 %then AD = ADDR(A(FCOPND_D))
                        %if CONSTS FOUND<=NELS %then %c
                           MOVE BYTES(ELSIZE,AD,0,ADDR(SP(0)),SPP) %and %c
                           SPP = SPP+ELSIZE
                     %finish
                     CONSTS FOUND = CONSTS FOUND+1
                     %if SPP>=BUFSIZE %start;  ! EMPTY BUFFER
                        %if HOST#TARGET %and (TYPE=5 %or (TYPE=1 %and %c
                           PREC=3)) %then CHANGE SEX(ADDR(SP(0)),0,SPP)
                        PDATA(QPUTP,1,SPP,ADDR(SP(0)))
                        WRIT = WRIT+SPP
                        SPP = 0
                     %finish
                  %repeat
               %repeat;                  ! UNTIL P<ROCL>=%null
               %if CONSTS FOUND#NELS %then FAULT(45,CONSTS FOUND,NELS)
               SLENGTH = (SIZE+3)&(-4)
               %if HOST#TARGET %and (TYPE=5 %or (TYPE=1 %and PREC=3)) %then %c
                  CHANGE SEX(ADDR(SP(0)),0,SLENGTH-WRIT)
               PDATA(QPUTP,1,SLENGTH-WRIT,ADDR(SP(0)))
            %end
            %routine CLEAR(%integer SLENGTH)
               SLENGTH = (SLENGTH+3)&(-4)
               PRDATA(QPUTP,4,4,SLENGTH>>2,ADDR(ZERO))
            %end
            %routine XTRACT CONST(%integer CONTYPE,CONPREC)
!***********************************************************************
!*       P POINTS TO P<+'> OF <+'><OPERNAD><RESTOFEXPR>  AND IS UPDATED*
!*       THE CONST IS CONVERTED TO REQUIRED FORM AND IF INTEGER        *
!*       IS LEFT IN ICONST, IF REAL IN RCONST AND IF STRING IN SCONST  *
!***********************************************************************
               %integer SLENGTH,STYPE,SACC,MODE,CH,WR,I
               STYPE = PTYPE; SACC = ACC;  ! MAY BE CHANGED IF CONST IS EXPR
               %if CONTYPE=5 %then %start
                  P = P-3; CSTREXP(0)
                  WR = WORKA_ARTOP
                  %if EXPOPND_FLAG=LCONST %and EXPOPND_PTYPE=X'35' %start
                     SLENGTH = EXPOPND_XTRA
                     LENGTH(SCONST) = SLENGTH
                     A(WR) = SLENGTH
                     %for I = 1,1,SLENGTH %cycle
                        CH = A(EXPOPND_D+I)
                        CHARNO(SCONST,I) = CH
                        A(WR+I) = CH
                     %repeat
                     COPND_PTYPE = X'35'; COPND_FLAG = LCONST
                     COPND_D = EXPOPND_D
                     COPND_XTRA = SLENGTH
                  %finish %else %start
                     FAULT(44,CONSTS FOUND,K); SCONST = ""
                     SLENGTH = 0
                  %finish
               %finish %else %start
                  MODE = CONPREC<<4!CONTYPE
                  %if CONPREC<5 %then MODE = CONTYPE!X'50'
                  CONSTP = CONSTEXP(MODE)
                  %if CONSTP=0 %then FAULT(41,0,0)
                                         ! CANT EVALUATE EXPT
                  COPND = EXPOPND;       ! GET RESULT OPND
                  COPND_PTYPE = MODE!(copnd_Ptype&8);! preserve R'' bit
               %finish
               PTYPE = STYPE; UNPACK; ACC = SACC

! FAULT ANY OBVIOUS ERRORS IE:-
! CONSTANT FOR EXTRINSIC OR INCOMPATIBLE TYPE OR STRING TOO LONG

               %if EXTRN=3 %then FAULT(49,0,K) %and %return
               %if (CONTYPE=5 %and SLENGTH>=ACC) %or (CONTYPE=1 %and %c
                  ((CONPREC=3 %and COPND_D>255) %or (CONPREC=4 %and %c
                  COPND_D>X'FFFF'))) %then FAULT(44,CONSTS FOUND,K)
!
! IF CROSS COMPILING THEN A CONSTANT FORMAT CHANGE IS NEED FROM
! IBM&ICL FORM TO PERQ FORM. IF ON PERQ FORMAT IS CORRECT
!
               FCOPND = COPND
               %if HOST#TARGET %then %start
               fcopnd_ptype=conprec<<4!contype!fcopnd_ptype&8;! correct precision before swopping
                  REFORMATC(FCOPND)
               %finish
            %end
BEND:    %end; ->CSSEXIT
SW(10):
         %begin;                         ! %recordformat (RDECLN)
            %integer NAME,OPHEAD,OPBOT,NLIST,MRL,CELLREF,FHEAD,SPEC
            %record (LISTF) %name LCELL,FRCELL
            SNDISP = 0
            SPEC = A(P+1);               ! 1 FOR SPEC 2 FOR FORMAT
            NAME = FROM AR2(P+2); P = P+4
            COPY TAG(NAME,NO)
            %if SPEC=1 %or %not (PTYPE=4 %and J=15 %and OLDI=LEVEL) %start
               KFORM = 0
               PUSH(KFORM,0,0,0)
               PTYPE = 4
               STORE TAG(NAME,LEVEL,RBASE,15,0,MAXRECSIZE,KFORM,KFORM)
                                         ! IN CASE OF REFS IN FORMAT
            %finish
            %if SPEC=2 %start
               OPHEAD = 0; OPBOT = 0
               NLIST = 0; MRL = 0
               INAFORMAT = 1
               CRFORMAT(OPHEAD,OPBOT,NLIST,MRL,X'80000000')
               INAFORMAT = 0
               CLEAR LIST(NLIST)
!
! IN CASE OF FORWARD REFS COPY TOP CELL OF FORMAT CHAIN INTO DUMMY
! SET UP BEFORE CALL OF CRFORMAT. ALSO RESET J&ACC TO CORRECT VALUE
!
               LCELL == ASLIST(TAGS(NAME))
               KFORM = LCELL_KFORM
               POP(KFORM,I,I,FHEAD);     ! THROW DUMMY CELL
                                         ! GET HEAD OF FORWARD REFS
               %while FHEAD>0 %cycle;    ! THROUGH FORWARD REFS
                  POP(FHEAD,CELLREF,I,I)
                  FRCELL == ASLIST(CELLREF)
                  FRCELL_UIOJ = FRCELL_UIOJ&X'FFFFFFF0';  ! SET J BACK TO 0
                  FRCELL_ACC <- ACC;     ! ACC TO CORRECT VALUE
                  FRCELL_KFORM = OPHEAD;  ! CORRECT KFORM
               %repeat
               LCELL_UIOJ = LCELL_UIOJ&X'FFFFFFF0';  ! J BACK TO ZERO
               LCELL_ACC <- ACC
               LCELL_SLINK = OPHEAD;     ! KFORM&SLINK(HISTORIC) TO SIDECHAIN
               LCELL_KFORM = OPHEAD
            %finish
         %end; ->CSSEXIT
!
SW(19):
                                         ! '*' (UCI) (S)
         FAULT(57,0,0) %unless LEVEL>=2
         %begin
!***********************************************************************
!*       COMPILE USERCODE INSTRUCTION. MOST WORK IS DONE BY HAIRY      *
!*       BUILT-IN PHRASE IN COMPARE. SINCE ALMOST ANYTHING IS LEGAL    *
!*       IN USERCODE THIS BLOCK HAS ONLT TO ASSEMBLE AND PLANT THE     *
!*       THE INSTRUCTION.                                              *
!***********************************************************************
            %switch UCITYPE(1:5),QINST(1:7)
            %record (RD) OPND
            %record (TAGF) %name TCELL
            %integer ALT,AALT,FNAME,OPTINC,OPC,KK,VAL1,VAL2,UCOP,TR,XTRA,H,Q
            %if TARGET=EMAS %or TARGET=IBM %or TARGET=IBMXA %or %c
               TARGET=AMDAHL %start
               %routine CUCS
!***********************************************************************
!*    SETS UP OPND FOR ASSEMBLER NAME(IE LOCAL OR CONST)               *
!***********************************************************************
                  %integer ALT,FN0,D
                  FN0 = FROM AR2(P); P = P+2
                  COPY TAG(FN0,NO)
                  %if (LITL=1 %and NAM=ARR=0) %start
                     TCELL == ASLIST(TAGS(FN0))
                     OPND_PTYPE = PTYPE&255
                     OPND_D = TCELL_S2
                     OPND_XTRA = TCELL_S3
                  %finish %else %start
                     %if TYPE>=6 %or TYPE=4 %or (ROUT=1 %and NAM=0) %then %c
                        FAULT(95,0,FN0) %and %return
                     %if ROUT=1 %then K = SNDISP;  ! FORMAL RT DESCPTR OFFSET
                     ALT = A(P); D = FROM AR2(P+1)
                     %if ALT=1 %then K = K+D
                     %if ALT=2 %then K = K-D
                     P = P+1; P = P+2 %if ALT<=2
                     OPND_FLAG = LOCALIR
                     OPND_D = I<<16!K
                  %finish
               %end
            %finish
            %if TARGET=EMAS %start
               %routine CIND
!***********************************************************************
!*       COMPILE A SYMBOLIC OPERAND BY SETTING ACCESS,AREA &DISP       *
!***********************************************************************
                  %integer ALT,FN0,JJ,D,CTYPE,CPREC,AREA
                  %switch SW(1:4)
                  ALT = A(P)
                  P = P+1; ->SW(ALT)
SW(1):                                   ! (PLUS')(ICONST)
                  D = A(P); CTYPE = A(P+1)
                  OPND_PTYPE = CTYPE
                  CPREC = CTYPE>>4; CTYPE = CTYPE&7
                  %if CPREC=4 %then OPND_D = FROM AR2(P+2) %else %if %c
                     CPREC=7 %then OPND_D = P+2 %else %c
                     MOVE BYTES(BYTES(CPREC),ADDR(A(0)),P+2,ADDR(OPND_D),0)
                  P = P+2+BYTES(CPREC)
                  %if D=2 %then %start
                     JJ = 11;            ! UNARY NEGATE
                     CTOP(JJ,D,0,OPND,OPND);  ! NEGATE CONSTANT
                  %finish
                  FAULT(96,FN0,0) %unless 1<=CTYPE<=2 %and 4<=CPREC<=7
                  %return
SW(2):                                   ! (NAME)(OPTINC)
                  CUCS
                  %return
SW(3):                                   ! '('(REG)(OPTINC)')'
                  AREA = A(P)+1; ALT = A(P+1); P = P+2
                  DISP = 0
                  D = FROM AR2(P)
                  %if ALT=1 %then DISP = D
                  %if ALT=2 %then FAULT(96,-D,0)
                  DISP = 4*DISP
                  P = P+2 %unless ALT=3
                  OPND_FLAG = 10
                  OPND_XB = AREA<<4
                  OPND_D = DISP
                  %return
SW(4):                                   ! '%TOS'
                  OPND_FLAG = 10; OPND_XB = X'60'
               %end
               %routine ULABREF
!***********************************************************************
!*    COMPILES USERCODE REF TO 2900 LABELS                             *
!*    LABELS MAY ONLY BE USED WITH JCC(2),JAT(4),JAF(6),J(1A),JLK(1C)  *
!*    AND ALSO DEBJ(24)                                                *
!*    FAULTED IN OTHER SITUATIONS.(IE MORE RESTRICTIVE THAN 2900IMP)   *
!***********************************************************************
                  %integer MASK,LAB
                  %if OPC<=6 %then %c
                     MASK = FROMAR2(P)+8*(OPC-2) %and P = P+3 %else %if %c
                     OPC=X'1A' %then MASK = 15 %else %if OPC=X'1C' %then %c
                     MASK = 0 %else %if OPC=X'24' %then MASK = 48 %else %c
                     FAULT(97,0,0)
                  LAB = FROMAR2(P)
                  ENTER JUMP(MASK,LAB,0)
               %end
            %finish
            %if TARGET=IBM %or TARGET=IBMXA %or TARGET=AMDAHL %start
               %routine DB
!***********************************************************************
!*    COMPILES AN IBM DB FORMAT SECOND OPERAND REFERENCE               *
!***********************************************************************
                  %integer ALT
                  ALT = A(P); P = P+1;   ! ALT OF DB
                  %if ALT=1 %start;      ! NAME LOCAL OR CONST
                     CUCS
                  %finish %else %start;  ! EXPLICIT NUMERICAL FORM
                     OPND_D = FROMAR2(P); P = P+2
                     OPND_FLAG = 10
                     ALT = A(P); P = P+1
                     %if ALT=1 %then OPND_XB = A(P) %and P = P+1
                  %finish
               %end
               %routine DXB
!***********************************************************************
!*    COMPILES AN IBM DXB (AND DLB) FORMAT SECOND OPERAND REFERENCE    *
!*    THE L IN DLB CAN BE UP TO 256 SO NEEDS 2 AR ENTRIES              *
!***********************************************************************
                  %integer ALT
                  ALT = A(P); P = P+1;   ! ALT OF DXB
                  %if ALT=1 %start;      ! NAME LOCAL OR CONST
                     CUCS
                     %if A(P)=1 %and OPND_FLAG=7 %then %c
                        XTRA = FROMAR2(P+1) %and P = P+2
                     P = P+1
                  %finish %else %start;  ! EXPLICIT NUMERICAL FORM
                     OPND_D = FROMAR2(P); P = P+2
                     OPND_FLAG = 10
                     ALT = A(P); P = P+1
                     %if ALT=1 %then %start
                        XTRA = FROMAR2(P); OPND_XB = A(P+2)
                        P = P+3
                     %finish
                     %if ALT=2 %then OPND_XB = A(P) %and P = P+1
                  %finish
               %end
            %finish
            OPC = 0; XTRA = 0
            OPND = 0
            OPND_PTYPE = X'51'
            OPND_FLAG = 1
            ALT = A(P+1); P = P+2
            ->UCITYPE(ALT)
UCITYPE(1):                              ! **@'(NAME)(OPTINC)
                                         ! INVALID ON IBM ARCHITECTURES
                                         ! AS THERE IS NO ACCUMULATOR
            AALT = A(P);                 ! ALT OF @'
            FNAME = A(P+1)<<8!A(P+2)
            P = P+3; OPTINC = 0
            %if A(P)#3 %start;           ! THERE IS AN OPTINC
               OPTINC = FROMAR2(P+1)
               %if A(P)=2 %then OPTINC = -OPTINC
            %finish
            COPY TAG(FNAME,NO)
            %if TARGET=IBM %or TARGET=IBMXA %or TARGET=AMDAHL %or TYPE>=6 %or %c
               ROUT#0 %then FAULT(97,FNAME,0)
            UCOP = UCNAM
            OPND_PTYPE = X'61'
            OPND_D = AALT<<16!FNAME
            OPND_XTRA = OPTINC
            ->OTRIP
UCITYPE(2):                              ! PUT (HEX HALFWORD)
            TYPE = A(P)
            PREC = TYPE>>4; TYPE = TYPE&7
            FAULT(97,0,0) %unless TYPE=1 %and PREC<6
            %if PREC=5 %then P = P+2
            OPND_D = FROM AR2(P+1); UCOP = UCB2
            %if TARGET=IBM %or TARGET=IBMXA %or TARGET=AMDAHL %then %c
               OPND_D = OPND_D>>8<<16!(OPND_D>>4&15)!((OPND_D&15)<<8)
            ->OTRIP
UCITYPE(4):                              ! CNOP
            UCOP = UCNOP; OPND_D = FROM AR2(P)
            ->OTRIP
UCITYPE(3):                              ! ASSEMBLER
            AALT = A(P); P = P+1
            OPC = FROMAR2(P); P = P+2
            %if TARGET=PNX %or TARGET=PERQ %or TARGET=ACCENT %or %c
               1<<target&emachine#0 %start
               P = P+3;                  ! TO START OF EXPR
               %if AALT>1 %then %start
                  KK = INTEXP(VAL1,MINAPT)
                  FAULT(96,0,1) %unless KK=0
               %finish
               %if AALT>=5 %start
                  P = P+3
                  KK = INTEXP(VAL2,MINAPT)
                  FAULT(96,0,2) %unless KK=0
               %finish
            %finish
            ->QINST(AALT)
UCITYPE(5):                              ! OTHER M-CS ASSEMBLER
            FAULT(97,0,0)
            ->BEND
QINST(1):                                ! ONE BYTE INSTRUCTION
                                         ! 2900 IS PRIMARY FORMAT INSTRUCTIONS
                                         ! IBM ONE REGISTER RR INSTRUCTIONS
            UCOP = UCB1
            %if TARGET=PNX %or TARGET=PERQ %or TARGET=ACCENT %or %c
               1<<target&emachine#0 %then OPND_D = OPC %else %if %c
               TARGET=EMAS %start
               ALT = A(P); P = P+1
               %if ALT=1 %then ULABREF %and ->BEND
               %if ALT=2 %then CIND %else %if ALT=3 %then %c
                  CIND %and XTRA = 4-A(P) %else %if ALT=4 %then %c
                  CIND %and XTRA = 1 %else %if ALT=5 %then %c
                  OPND_FLAG = 10 %and OPND_XB = X'74'-A(P) %else %if %c
                  ALT=6 %then OPND_FLAG = 10 %and OPND_XB = X'70'
            %finish %else %if %c
               TARGET=IBM %or TARGET=IBMXA %or TARGET=AMDAHL %start
               VAL1 = A(P); P = P+1
               %if OPC#10 %and VAL1>15 %then FAULT(97,0,0)
               OPND_D = OPC<<16!VAL1
            %finish
            ->OTRIP
QINST(2):                                ! UNSIGNED BYTE OPERAND
                                         ! EMAS 2NDARY (STORE TO STORE) FORMAT
                                         ! IBM RR AND RRE INSTRUCTIONS
            UCOP = UCB2
            %if TARGET=PNX %or TARGET=PERQ %or TARGET=ACCENT %or %c
               1<<target&emachine#0 %start
               FAULT(96,0,1) %unless 0<=VAL1<=255
               OPND_D = OPC<<8!VAL1
            %finish %else %if TARGET=EMAS %start
               VAL1 = 0; VAL2 = 0; Q = 0; JJ = 0
               H = 2-A(P)
               %if H=0 %then JJ = FROM AR2(P+1)-1 %and P = P+2
               FAULT(96,JJ+1,0) %unless 0<=JJ<=127
               ALT = A(P+1); P = P+2
               %if ALT=1 %then %start
                  Q = 1
                  VAL1 = FROM AR2(P)
                  VAL2 = FROM AR2(P+2)
                  P = P+4
                  %if VAL1>255 %then FAULT(96,VAL1,0)
                  %if VAL2>255 %then FAULT(96,VAL2,0)
               %finish
               OPND_D = H<<31!Q<<30!JJ<<16!VAL1<<8!VAL2
            %finish %else %if %c
               TARGET=IBM %or TARGET=IBMXA %or TARGET=AMDAHL %start
               VAL1 = A(P); VAL2 = A(P+1); P = P+2
               FAULT(97,0,0) %if VAL1>15 %or VAL2>15
               OPND_D = OPC<<16!VAL2<<8!VAL1
            %finish
            ->OTRIP
QINST(3):                                ! PERQ SIGNED BYTE OPERAND
                                         ! EMAS TERTIARY (JUMP) FORMAT
                                         ! IBM REGISTER STORE RX FORMAT
            %if TARGET=PNX %or TARGET=PERQ %or TARGET=ACCENT %or %c
               1<<target&emachine#0 %start
               UCOP = UCB2
               FAULT(96,0,1) %unless-128<=VAL1<=127
               OPND_D = OPC<<8!(VAL1&255)
            %finish %else %if TARGET=EMAS %start
               UCOP = UCB3;              ! DIFFERENT TRIPLE NEEDED FOR EMAS
               XTRA = FROMAR2(P)
               ALT = A(P+2)
               %if ALT=1 %then ULABREF %and ->BEND
               P = P+3
               %if ALT=2 %then %start
                  CIND
                  FAULT(97,0,0) %if OPND_XB=X'60'
               %finish %else %if ALT=3 %start
                  OPND_FLAG = 10
                  OPND_XB = 8-A(P)
               %finish %else OPND_XB = 1 %and OPND_D = FROMAR2(P)
            %finish %else %if %c
               TARGET=IBM %or TARGET=IBMXA %or TARGET=AMDAHL %start
               UCOP = UCB3
               VAL1 = A(P); P = P+1;     ! FIRST REGISTER OPERAND
               DXB
               FAULT(97,0,0) %if XTRA>15 %or VAL1>15 %or OPND_XB>15
               XTRA = XTRA<<8!VAL1
                                         ! OPCODE R1 & INDEX IN _X1
                                         ! DB VARIOUSLY IN OPND
            %finish
            ->OTRIP
QINST(4):                                ! SIGNED WORD OPERAND
                                         ! IBM RS (REGISTER TO STORE) FORMAT
            %if TARGET=PNX %or TARGET=PERQ %or TARGET=ACCENT %or %c
               1<<target&emachine#0 %start
               FAULT(96,0,1) %if %c
                  (TARGET=PERQ %or TARGET=ACCENT) %and IMOD(VAL1)>X'7FFF'
               UCOP = UCW; OPND_PTYPE = X'61'
               OPND_D = OPC
               OPND_XTRA = VAL1
            %finish %else %if %c
               TARGET=IBM %or TARGET=IBMXA %or TARGET=AMDAHL %start
               UCOP = UCB3;              ! GENERATORS TREATS AS DXB
               VAL1 = A(P); XTRA = A(P+1)
               P = P+2; DB
               FAULT(97,0,0) %if XTRA>15 %or VAL1>15 %or OPND_XB>15
               XTRA = XTRA<<8!VAL1
            %finish
            ->OTRIP
QINST(5):                                ! 2 UNSIGNED BYTE OPERANDS
                                         ! IBM STORE IMMEDIATE OR STORE FORMATS
            %if TARGET=PNX %or TARGET=PERQ %or TARGET=ACCENT %or %c
               1<<target&emachine#0 %start
               FAULT(96,0,1) %unless 0<=VAL1<=255
               FAULT(96,0,2) %unless 0<=VAL2<=255
               UCOP = UCB3; OPND_D = OPC<<16!VAL1<<8!VAL2
            %finish %else %if %c
               TARGET=IBM %or TARGET=IBMXA %or TARGET=AMDAHL %start
               UCOP = UCW; DB
               ALT = A(P); P = P+1
               %if ALT=1 %start;         ! IMMEDIATE OPERAND GIVEN
                  P = P+3
                  KK = INTEXP(XTRA,X'51')
                  FAULT(97,0,0) %unless KK=0 %and 0<=XTRA<=255 %and OPC<255
               %finish;                  ! NO OPERAND 0 ASSUMED
               ->OTRIP
            %finish
            ->OTRIP
QINST(6):                                ! BYTE & WORD OPERANDS
                                         ! IBM SS AND SSE FORMATS
            %if TARGET=PNX %or TARGET=PERQ %or TARGET=ACCENT %or %c
               1<<target&emachine#0 %start
               FAULT(96,0,1) %unless 0<=VAL1<=255
               FAULT(96,0,2) %unless IMOD(VAL2)<=X'7FFFF'
               I = UCBW; OPND_D = OPC<<24!VAL1<<16!(VAL2&X'FFFF')
            %finish %else %if %c
               TARGET=IBM %or TARGET=IBMXA %or TARGET=AMDAHL %start
               DXB
               TR = URECTRIP(UCNAM,0,DONT OPT!ASSLEVEL,OPND)
                                         ! PASS ON OPND FIRST DUE TO
                                         ! LIMITATIONS OF PORTABLE ASSEMBLER
               OPND = 0
               DB; UCOP = UCBW
               %if (OPC>255 %and XTRA#0) %or XTRA>256 %then FAULT(97,0,0)
            %finish
            ->OTRIP
QINST(7):                                ! JUMPS
            %if TARGET=IBM %or TARGET=IBMXA %or TARGET=AMDAHL %start
               VAL1 = A(P); P = P+1;     ! THE MASK OR EQIVALENT
               %if A(P)=1 %then XTRA = A(P+1) %and P = P+1;  ! THE INDEX
               P = P+1
               VAL2 = FROMAR2(P);        ! THE NAME
               ENTER JUMP(OPC<<8!VAL1<<4!XTRA,VAL2,X'40')
               FAULT(97,0,0) %if VAL1>15 %or XTRA>15
               ->BEND
            %finish
            ->OTRIP
OTRIP:
            TR = URECTRIP(UCOP,0,DONT OPT!ASS LEVEL,OPND)
            TRIPLES(TR)_X1 = OPC<<16!XTRA
BEND:
         %end
         ->CSSEXIT
SW(20):
                                         ! '%TRUSTEDPROGRAM'
         PARM_COMPILER = 1 %if PARM_ARR=0 %and PARM_CHK=0; ->CSSEXIT
SW(21):                                  ! '%MAINEP'(NAME)
         KK = FROM AR2(P+1)
         FAULT(97,0,0) %unless PARM_CPRMODE=0
         MAINEP <- STRING(ADDR(WORKA_LETT(WORD(KK))))
         ->CSSEXIT
         %integer %fn CFORMATREF
!***********************************************************************
!*    P IS TO ALT OF FORMAT REF                                        *
!*    P<FORMTAREF>::=(NAME),(RFDEC)(RESTOFRFDEC)(ALTRFDEC)             *
!*    RETURNS CELL NO OF TOP CELL OF THE FORMATLIST                    *
!***********************************************************************
            %integer FNAM,OPHEAD,OPBOT,NHEAD,MRL
            %record (LISTF) %name LCELL
            %if A(P)=1 %start;           ! A RECORD OF RECORDFORMAT NAME
               FNAM = FROM AR2(P+1)
               P = P+3
               COPY TAG(FNAM,NO)
               %if 3<=TYPE<=4 %then %result = KFORM
               %if INAFORMAT#0 %and OLDI#LEVEL %start
                  PTYPE = 4; ACC = MAXRECSIZE
                  PUSH(KFORM,0,0,0)
                  STORE TAG(FNAM,LEVEL,RBASE,15,0,MAXRECSIZE,KFORM,KFORM)
                  %result = KFORM
               %finish
               FAULT(62,0,FNAM);         ! NOT A RECORD OF FORMAT NAME
               ACC = 8;                  ! GUESS A RECORD SIZE
               %result = DUMMY FORMAT
            %finish
                                         ! FORMAT ACTUALLY SPECIFIED
            P = P+1
            OPHEAD = 0; OPBOT = 0
            NHEAD = 0; MRL = 0
            CRFORMAT(OPHEAD,OPBOT,NHEAD,MRL,X'80000000')
            CLEAR LIST(NHEAD)
            %if CURRINF_UNATT FORMATS#0 %start
               LCELL == ASLIST(CURRINF_UNATT FORMATS)
               %if LCELL_S2=0 %then LCELL_S2 = OPHEAD %and %result = OPHEAD
               %if LCELL_S3=0 %then LCELL_S3 = OPHEAD %and %result = OPHEAD
            %finish
            PUSH(CURRINF_UNATT FORMATS,OPHEAD,0,0)
            %result = OPHEAD
         %end

         %routine CRFORMAT(%integer %name OPHEAD,OPBOT,NLIST,MRL,
            %integer INIT)
!***********************************************************************
!*       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=FIRST 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                             *
!***********************************************************************
            %integer D1,D2,FORM,RL,STALLOC,INC,Q,R,RFD,LB,TYPEP,SACC,DVO
            %routine %spec SN(%integer Q)
            %routine %spec ROUND
            FORM = 0; ACC = 0
            INC = INIT&X'FFFF';          ! INC COUNTS DOWN RECORD
            %cycle
               ROUT = 0; LITL = 0; NAM = 0; RFD = A(P)
               P = P+1
               %if RFD=1 %then %start
                  CLT
                  FORM = KFORM
                  STALLOC = ACC
                  P = P+1
                  %if A(P-1)=1 %start
                                         ! (TYPE) (QNAME')(NAMELIST)
                     FORM = KFORM
                     CQN(P); P = P+1
                     PACK(PTYPE); D2 = 0
                     RL = ROUNDING LENGTH(PTYPE,0)
                     %if NAM=1 %then %start
                        STALLOC = PTRSIZE(PREC<<4!TYPE)
                         RL=PTRrounding(ptype&127)
                        %if ARR#0 %then STALLOC = AHEADSIZE %and RL=ROUNDINGLENGTH(AHEADPT,0)
                     %finish
                     fault(70,0,0) %if type=5 %and stalloc=0
                     ROUND; J = 0
                     %until A(P-1)=2 %cycle
                        D1 = INC; SN(P)
                        P = P+3; INC = INC+STALLOC
                     %repeat
                  %finish %else %start
                                         ! (TYPE)%array(NAMELIST)(BPAIR)
                     Q = P+1; ARR = 1; PACK(PTYPE)
                     %cycle
                        P = Q
                        P = P+3 %until A(P-1)=2
                        TYPEP = PTYPE; SACC = ACC
                        DVO = DOPE VECTOR(NO,TYPE,ACC,0,FROMAR2(Q)>>1,R,LB)
                                         ! DOPE VECTOR INTO SHAREABLE S.T.
                        ACC = SACC; PTYPE = TYPEP; UNPACK
                        %if DVO<0 %then DVO = 0;  ! ERROR HAS BEEN FAULTED
                        RL = ROUNDING LENGTH(PTYPE&255,0);  ! FOR ELEMENT AS%c
                                                            SCALAR
                        %if RL<ARRAYINREC ROUNDING %then %c
                           RL = ARRAYINREC ROUNDING
                        %cycle
                           ROUND
                           D1 = POWNARRAYHEAD(PTYPE,J,LB,R,INC,0,DVO,"")
                           D2 = INC
                           SN(Q); INC = INC+R
                           Q = Q+3
                        %repeat %until A(Q-1)=2;  ! TILL NAMELIST NULL
                        P = P+1; Q = P+1
                     %repeat %until A(P-1)=2;  ! UNTIL <RESTOFARRAYLIST> NULL
                  %finish
               %finish %else %start
                                         ! (FORMAT)
                  CRFORMAT(OPHEAD,OPBOT,NLIST,MRL,INC)
                  INC = ACC
               %finish
               P = P+1
            %repeat %until A(P-1)=2;     ! UNTIL <RESTOFRFDEC> NULL
                                         ! FINISH OFF
            %if A(P)=1 %start;           ! WHILE %or CLAUSES
               P = P+1
               CRFORMAT(OPHEAD,OPBOT,NLIST,MRL,INIT&X'FFFF')
               %if ACC>INC %then INC = ACC
            %finish %else P = P+1
            %if INIT<0 %then RL = MRL %and ROUND
            FAULT(63,MAXRECSIZE,0) %and INC = MAXRECSIZE %unless %c
               INC<=MAXRECSIZE
            ACC = INC;                   ! SIZE ROUNDED APPROPRIATELY
            %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.              *
!*       CARE IS NEEDED TO MATCH TAG LAYOUT ON BYTE SWOPPED HOSTS      *
!***********************************************************************
               %record (TAGF) CELL
               FNAME = FROM AR2(Q)
               FAULT(61,0,FNAME) %unless FIND(FNAME,NLIST)=-1
               CELL_PTYPE <- PTYPE; CELL_UIOJ <- FNAME<<4!J
               CELL_ACC <- ACC
               CELL_SNDISP <- D2&X'FFFF';  ! IN CASE OF BUM FORMATS
               CELL_SLINK <- D1&X'FFFF';  ! IN CASE OF BUM FORMATS
               CELL_KFORM = FORM
               BINSERT(OPHEAD,OPBOT,CELL_S1,CELL_S2,CELL_S3)
               PUSH(NLIST,0,FNAME,0)
               %if PTYPE=X'433' %and ACC=MAXRECSIZE %then %c
                  PUSH(ASLIST(FORM)_S3,OPBOT,0,0)
! NOTE FORWARD REFERENCE
            %end
            %routine ROUND
               MRL = RL %if RL>MRL
               INC = INC+1 %while INC&RL#0
            %end
         %end;                           ! OF ROUTINE CRFORMAT
         %integer %fn DISPLACEMENT(%integer LINK)
!***********************************************************************
!*         SEARCH A FORMAT LIST FOR A SUBNAME                          *
!*      A(P) HAS ENAME--LINK IS HEAD OF RFORMAT LIST. RESULT IS DISP   *
!*      FROM START OF RECORD                                           *
!***********************************************************************
            %record (LISTF) %name FCELL,PCELL,LCELL
            %record (TAGF) TOPND
            %integer RR,II,ENAME,CELL
            ENAME = A(P)<<8+A(P+1); CELL = 0
            %if LINK#0 %then %start;     ! CHK RECORDSPEC NOT OMITTED
               FCELL == ASLIST(LINK);    ! ONTO FIRST CELL
               CELL = LINK; II = -1; ACC = -1
               %while LINK>0 %cycle
                  LCELL == ASLIST(LINK)
                  %if LCELL_UIOJ<<16>>20=ENAME %start;  ! RIGHT SUBNAME LOCATED
                     TCELL = LINK
                     SNDISP = LCELL_SNDISP
                     K = LCELL_SLINK
                     J = LCELL_UIOJ&15; PTYPE = LCELL_PTYPE
                     ACC = LCELL_ACC&X'FFFF'
                     SNDISP = LCELL_SNDISP
                     KFORM = LCELL_KFORM
                     %if LINK#CELL %start;  ! NOT TOP CELL OF FORMAT
                        PCELL_LINK = LCELL_LINK
                        LCELL_LINK = FCELL_LINK
                        FCELL_LINK = LINK
                     %finish;            ! ARRANGING LIST WITH THIS SUBNAME
                                         ! NEXT TO THE TOP
                     %result = K
                  %finish
                  PCELL == LCELL
                  LINK = LCELL_LINK
               %repeat
            %finish
            FAULT(65,0,ENAME)
            %if CELL>0 %then %start
               TOPND_PTYPE = x'57'
               TOPND_UIOJ = ENAME<<4
               PUSH(ASLIST(CELL)_LINK,TOPND_S1,0,0)
            %finish
            PTYPE = X'57'; TCELL = 0
            %result = -1
         %end
         %integer %fn COPY RECORD TAG(%integer %name SUBS)
!***********************************************************************
!*       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+2; SKIP APP
               %result = 0 %if A(P)=2 %or FNAME<=0;  ! NO (FURTHER) ENAME
               SUBS = SUBS+1
               P = P+1; Q = DISPLACEMENT(FNAME)
               UNPACK
            %repeat
            %result = Q+1;               ! GIVES 0 IF SUBNAME NOT KNOWN
         %end
%integerfn chk rec align(%integer p1)
!***********************************************************************
!*      Tiddles down chain looking for an integer or larger            *
!*      returns 0 unless at least word aligned                         *
!***********************************************************************
%integer cell,i
%integerfnspec scan(%integer cell)
      p=p1; reduce tag(no);    ! leaves kform set for records
      cell=kform
!        printstring("chk align ".printname(a(p1)<<8!a(p1+1)))
!        write(kform,5); newline
!           printlist(cell)
      %result=scan(cell)
%integerfn scan(%integer cell)
%integer j
      %while cell #0 %cycle
         i=aslist(cell)_ptype>>4&7
         %if i>=5 %then %result=i
         %if aslist(cell)_ptype=x'33' %then %start
            i=scan(aslist(cell)_kform)
          %if i>=5 %then %result=i
         %finish
         cell=aslist(cell)_link
      %repeat
      %result=0
%end
%end { chk rec align }
         %routine CRNAME(%integer Z,MODE,BS,DP, %integer %name NAMEP)
!***********************************************************************
!*       DEAL WITH RECORD ELEMENT NAMES.Z AS FOR CNAME.CLINK=TAGS(RN)  *
!*       MODE=ACCESS FOR RECORD(NOT THE ELEMENT!)                      *
!*       ON EXIT BASE,AREA & 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,EMNAME
            %routine %spec CENAME(%integer MODE,FNAME,BS,DP,XD)
            %record (RD) HDOPND
            HDOPND = 0
            DEPTH = 0
            EMNAME = NAMEP&X'FFFF';      ! ORIGINAL RECORD NAME FOR ERROR%c
                                         MESSES
            FNAME = KFORM;               ! POINTER TO FORMAT
            %if ARR=0 %or (Z=6 %and A(P+2)=2) %start;  ! SIMPLE RECORD
               %if A(P+2)=2 %then P = P+3 %else NO APP
               CENAME(MODE,FNAME,BS,DP,0)
            %finish %else %start
               HDOPND_PTYPE = AHEADPT
               HDOPND_FLAG = LOCALIR
               HDOPND_D = BS<<16!DP
               CANAME(Z,ARR,HDOPND)
               NAMEP = -1
               CENAME(ACCESS,FNAME,BASE,DISP,0)
            %finish; %return
!
%routine CENAME(%integer MODE,FNAME,BS,DP,XD)
!***********************************************************************
!*       FINDS OUT ABOUT SUBNAME AND ACTS ACCORDINGLY.MOSTLY ACTION    *
!*       CONSISTS OF UPPING XD BY OFFSET OF THE SUBNAME BUT IS VERY    *
!*       HAIRY FOR RECORDS IN RECORDS ETC                              *
!*       MODE IS ACCESS FOR THE RECORD                                 *
!***********************************************************************
%routine %spec FETCH RAD
%integer Q,QQ,D,C,TR,ENAME,RPTYPE,EPTYPE
%record (RD) RADOPND,OPND1
%record (LISTF) %name LCELL
               DEPTH = DEPTH+1
              RPTYPE=PTYPE
               %if A(P)=2 %then %start;  ! ENAME MISSING
                  ACCESS = MODE; XDISP = XD
                  BASE = BS; DISP = DP;  ! FOR POINTER
                  %if Z<14 %then %start;  ! NOT A RECORD OPERATION
                     %unless 3<=Z<=4 %or Z=6 %start;  ! ADDR(RECORD)
                        FAULT(64,0,EMNAME); BASE = RBASE
                        DISP = 0; ACCESS = 0; PTYPE = X'51'
                        UNPACK
                     %finish
                  %finish
                  %return
               %finish
               P = P+1;                  ! FIND OUT ABOUT SUBNAME
               Q = DISPLACEMENT(FNAME);  ! TCELL POINTS TO CELL HOLDING
              EPTYPE=PTYPE;                ! Save ptype of ename
               UNPACK;                   ! INFO ABOUT THE SUBNAME
               %if Q=-1=ACC %or PTYPE=X'57' %start;  ! WRONG SUBNAME(HAS BEEN%c
                                                     FAULTED)
                  P = P+2; SKIP APP; P = P-3
                  ACCESS = 0; BASE = RBASE; DISP = 0
                  %return
               %finish
               ENAME = A(P)<<8!A(P+1)
               NAMEP = ENAME<<16!NAMEP;  ! NAMEP=-1 UNALTERED !
               ->AE %if ARR=1;           ! ARRAYS INCLUDING RECORDARRAYS
               %if A(P+2)=2 %then P = P+3 %else NO APP
               %if TYPE<=2 %or TYPE=5 %or (TYPE=3 %and A(P)=2 %and %c
                  (3<=Z<=4 %or Z=6)) %start
                  ACCESS = MODE+4+4*NAM; BASE = BS;
                  DISP = DP; XDISP = XD+Q
                  %return
               %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
!
               XD = XD+Q
               NAMEP = NAMEP!X'FFFF0000'
               %if NAM=1 %then %start
                  MODE = MODE+4;         ! SO ADDRESS OF POINTER FETCHED
                  FETCH RAD;             ! NEW METHOD IS AS FOR REC FNS
                  EXPOPND = RADOPND;     ! EXPOPND IS ADDRESS TO WHICH POINTER%c
                                         POINTED
                  MODE = 3
                  DP = 0; XD = 0; BS = 0
                  NAMEP = -1
               %finish
               CENAME(MODE,KFORM,BS,DP,XD)
               %return
AE:                                      ! ARRAYS AND ARRAYNAMES AS ELEMEN
               LCELL == ASLIST(TCELL)
               ACC = LCELL_ACC&X'FFFF'; SNDISP = LCELL_SNDISP&X'FFFF'
               KFORM = LCELL_KFORM; K = LCELL_SLINK&x'ffff'
               C = ACC; D = SNDISP; Q = K; QQ = KFORM
               %if (Z=6 %or Z>=11) %and A(P+2)=2 %start;  ! 'GET ARRAYHEAD'%c
                                                          CALL
                  P = P+3
                  %if NAM=1 %then %start
                     ACCESS = MODE+8; BASE = BS
                     DISP = DP; XDISP = XD+Q
                     PTYPE = AHEADPT
                     NAMEOP(6,8,NAMEP);  ! PTR TO HEAD
                     %return
                  %finish
!
! PASSING AN ARRAY IN A RECORD BY NAME MUST CONSTRUCT PROPER ARRAYHEAD
! FROM THE RECORD RELATIVE ONE AT Q(GLA)
!
                  FETCH RAD
                  NAMEP = -1
                  OPND1 = 0
                  OPND1_PTYPE = AHEADPT
                  OPND1_FLAG = LOCALIR
                  OPND1_D = Q
                  NAMEOPND_D = CREATE AH(1,RADOPND,OPND1)
                  NAMEOPND_PTYPE = AHEADPT; NAMEOPND_FLAG = REFTRIP
                  NAMEOPND_XTRA = 0
               %finish %else %start;     ! ARRAY ELEMENTS IN RECORDS
                  %if NAM=1 %then %start;  ! ARRAYNAMES-FULLHEAD IN RECORD
                     XD = XD+Q
                     ACCESS = MODE+8
                     BASE = BS; DISP = DP; XDISP = XD
                     NAMEOP(6,AHEADSIZE,NAMEP)
                     OPND1 = NAMEOPND
                     OPND1_PTYPE = AHEADPT
                     PTYPE = LCELL_PTYPE; UNPACK
                     CANAME(Z,3,OPND1);  ! ARRAY MODE SETS DISP,AREA&BASE
                     XD = 0
                  %finish %else %start;  ! ARRAY RELATIVE HEAD IN GLA
                     FETCH RAD;          ! 32 BIT ADDR TO ETOS
                     OPND1 = 0; OPND1_PTYPE = AHEADPT
                     OPND1_FLAG = LOCALIR
                     OPND1_D = Q
                     CANAME(Z,3,OPND1);  ! RECORD REL ARRAY ACCESS
                                         ! CAN RETURN ACCESS=1 OR 3 ONLY
                     TR = BRECTRIP(AAINC,X'51',0,RADOPND,EXPOPND)
                     EXPOPND_FLAG = REFTRIP
                     EXPOPND_D = TR
                     TRIPLES(TR)_X1 = PTYPE&255;  ! FRIG FOR PERQ&ACCENT 3%c
                                                  WORD BYTE PTRS!
                     XD = 0
                  %finish
                  NAMEP = -1
                  XDISP = XD
                  %if TYPE=3 %then%start
                     CENAME(ACCESS,QQ,BASE,DISP,XD)
                     c=acc;         ! to return element size
                  %else
                        %if Z>=11 %then FAULT(17,0,ENAME)
                  %finish
                                         ! AN ELEMENT IS NOT AN ARRAY FOR P-P
               %finish
               ACC = C;                  ! NEEDED FOR STRING ARRAYS
               %return
%routine FETCH RAD
!***********************************************************************
!*       SET ACC TO 32 BIT ADDRESS OF RECORD.                          *
!***********************************************************************
                  ACCESS = MODE+4
                  BASE = BS
                  DISP = DP; XDISP = XD
               ptype=rptype; unpack
                  NAMEOP(4,4,NAMEP)
                 ptype=eptype; unpack
                  RADOPND = NAMEOPND
               %end
            %end;                        ! OF ROUTINE CENAME
         %end;                           ! OF ROUTINE CRNAME
         %routine CSTREXP(%integer MODE)
!***********************************************************************
!*       PLANT IN-LINE CODE FOR CONCATENATION. A WORK AREA IN THE      *
!*       CURRENT STACK FRAME IS USUALLY REQUIRED.                      *
!*       ON ENTRY:-                                                    *
!*       MODE=0    NORMAL. WK AREA NOT USED FOR ONE OPERAND EXPSSNS    *
!*       MODE=1     STRING MUST GO TO WORK AREA                        *
!*       2**5 BIT OF MODE SET IF FULL VIRTUAL ADDRESS REQUIRED         *
!*       2**4 BIT OF MODE IS SET IF WK-AREA NOT TO BE FREED ON EXIT    *
!*       ON EXIT:-                                                     *
!*       VALUE#0 %if RESULT IN A WORK AREA(CCOND MUST KNOW)            *
!***********************************************************************
            %integer PP,WKAREA,DOTS,ERR,KEEPWA,FNAM,I,ENDFLAG
            %record (RD) OPND1,OPND2,OPND3
            %integer %fn %spec STROP(%record (RD) %name OPND)
            KEEPWA = MODE&16; MODE = MODE&15
            OPND1 = 0
            OPND1_PTYPE = X'35'
            OPND1_FLAG = LOCALIR
            OPND1_XTRA = 268;            ! THE WORK AREA SIZE NEEDED FOR
            PP = P; STRINGL = 0; FNAM = 0; WKAREA = 0
            P = P+3;                     ! LENGTH OF CONSTANT PART
            ERR = 72; ->ERROR %unless A(P)=4
            P = P+1
            DOTS = 0;                    ! NO OPERATORS YET
            ENDFLAG = 0
            STRINGL = 0
            ERR = STROP(OPND2);          ! GET FIRST OPERAND
            %if STRRESINWA=NO %and PTYPE&X'1000'#0 %then MODE = 1
                                         ! IF FN RESULT NOT IN A WORK AREA
                                         ! COPY IN FROM TOP OF STACK
                                         ! SOMETIMES NOT NECESSARY BUT FN=FN%c
                                         COMPARISONS
                                         ! WILL GO WRONG WITHOUT THIS
            ->ERROR %unless ERR=0
NEXT:       %if A(P)=2 %then ENDFLAG = 1 %else %start
               %if A(P+1)#CONCOP %then ERR = 72 %and ->ERROR
               P = P+2
!
! LEFT TO RIGHT EVALUATION IS DEFINED BUT IF FIRST OPERAND IS ACONST
! WE CAN EVALUATE THE SECOND. THIS ENABLES US TO FOLD "TOSTRING(NL)" ETC
!
               %if DOTS=0 %and OPND2_FLAG=LCONST %then %start
                  ERR = STROP(OPND3)
                  ->ERROR %unless ERR=0
               %finish %else OPND3_FLAG = 255
            %finish
            %if ENDFLAG=0 %and OPND2_FLAG=LCONST=OPND3_FLAG %start
!
! CAN FOLD OUT A CONCATENATION HERE
!
               I = CONCAT
               CTOP(I,ERR,0,OPND2,OPND3)
               %if I=0 %then ->NEXT;     ! FOLDED OUR
            %finish
            %if DOTS=0 %start
               %if MODE=0 %and ENDFLAG#0 %start;  ! NO RUN-TIME OPERATIONS
                  OPND1 = OPND2; ->TIDY
               %finish
               GET WSP(WKAREA,X'80000000'!268);  ! GET NEXT OPERAND
               OPND1_D = RBASE<<16!WKAREA
                                         ! BACKWARD STACKS
               I = BRECTRIP(PRECC,X'35',0,OPND1,OPND2)
               OPND1_FLAG = REFTRIP
               OPND1_D = I;              ! CHANGE TO TRIPLES REFERENCE
               DOTS = 1
            %finish
            %if ENDFLAG=0 %then %start
               %if OPND3_FLAG=255 %start;  ! 3 NEED EVALUATION
                  ERR = STROP(OPND3)
                  ->ERROR %unless ERR=0
               %finish
               OPND1_D = BRECTRIP(CONCAT,X'35',0,OPND1,OPND3)
               ->NEXT
            %finish
TIDY:                                    ! FINISH OFF
            EXPOPND = OPND1;             ! LEAVE REULT IN EXPOPND
            VALUE = WKAREA
            P = P+1;                     ! PAST REST OF EXPRN
            RETURN WSP(WKAREA,268) %if KEEPWA=0 %and WKAREA>0
            STRINGL = 0
            %return
ERROR:      FAULT(ERR,0,FNAM)
            EXPOPND = OPND1
            BASE = RBASE; DISP = 0
            VALUE = 0; ACCESS = 0
            P = PP; SKIP EXP
            %return
            %integer %fn STROP(%record (RD) %name OPND)
!***********************************************************************
!*       DEALS WITH OPERAND FOR CONCATENATION. RETURN RESULT=0 FOR     *
!*       VALID OPERAND OTHERWISE AN ERROR NUMBER.                      *
!***********************************************************************
               %integer CTYPE,MODE,I
               MODE = A(P);              ! ALTERNATIVE OF OPERAND
               OPND = 0
               %result = 75 %if MODE>2
               %if MODE#1 %then %start
                  CTYPE = A(P+1);        ! GET CONST TYPE & LOSE AMCK FLAGS
                  %if CTYPE=X'35' %then %start
                     PTYPE = CTYPE
                     STRINGL = A(P+2)
                     OPND_PTYPE = CTYPE
                     OPND_FLAG = LCONST
                     OPND_D = P+2
                     OPND_XTRA = STRINGL
                     P = P+STRINGL+3
                  %finish %else %result = 73
               %finish %else %start
                  P = P+1;               ! MUST CHECK FIRST
                  COPYTAG(FROMAR2(P),NO)
                  %if PTYPE=x'1006' %then TYPE = ACC&7;  ! special for "string"
                  %if TYPE=3 %then REDUCE TAG(NO)
                  %if 5#TYPE#7 %then FNAM = FROMAR2(P) %and %result = 71
                  %if PTYPE=X'4035' %and A(P+2)=2=A(P+3) %start
                     OPND_FLAG = LCONST;  ! CONST STRING
                     OPND_PTYPE = X'35'
                     OPND_D = MIDCELL
!
! The use of code for constintegers(etc) for const strings causes an unexpected
! problem on half swopped machines in that kform is not the ls end of _s2
!
                     %if 1<<host&halfswopped=0 %then OPND_XTRA = KFORM %else OPND_XTRA=K
                     STRINGL = OPND_XTRA
                     P = P+4
                     %result = 0
                  %finish
                  %if PTYPE=X'35' %and A(P+2)=2=A(P+3) %start
                     OPND_FLAG = DNAME
                     OPND_XTRA = 0
                     OPND_PTYPE <- PTYPE
                     OPND_D = FROMAR2(P)
                     P = P+4
                  %finish %else %start
                     CNAME(2)
                     OPND = NAMEOPND
                     %if opnd_flag<=1 %then ptype=opnd_ptype;! specially for csname
                                        ! when evaluates to a constant
                  %finish
                  STRINGL = 0
               %finish
               %result = 0
            %end;                        ! OF INTEGERFN STROP
         %end;                           ! OF ROUTINE CSTREXP
         %routine CRES(%integer LAB)
!**********************************************************************
!*       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 CALL A SUBROUTINE PASSING 5 PARAMS:-        *
!*       P1(32BITS)  POINTS TO LHS(A)                                  *
!*       P2(16BITS) ORIGINAL LENGTH OF A                               *
!*       P3(32BITS) FULL POINTER TO BYTES USED UP INITIALLY 0          *
!*       P4(48BITS) STRING TO CONTAIN FRAGMENT                         *
!*                (PASSED AS LMAX FOLLOWED BY 32BIT ADDRESS)           *
!*       P5(32BITS) THE EXPRESSION PASSED AS 32 BIT ADDRESS            *
!*       SUBROUTINE TRIES TO PERFORM THE RESOLUTION AND SETS THE       *
!*       RESULT TO TRUE IF IT SUCCEEDS.                                *
!*                                                                     *
!*       ON ENTRY LHS IS IN THE ESTACK(32BITS).                        *
!*       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,SEXPRN,W,LAST,ERR,FNAM,JJ
            %record (RD) OPND1,OPND2

            OPND1=0; OPND2=0
            LAST = 0; FNAM = 0;          ! =1 WHEN END OF EXPRNSN FOUND
            SEXPRN = 0;                  ! RESOLUTION(BRKTD) EXPRESSNS
            P1 = P
            ERR = 43
            %if NAMEOPND_PTYPE&X'C700'=X'4000' %then %c
               FNAM = NAMEOPND_D %and ->ERROR
                                         !  CANT RESOLVE A CONST STRING
            %if STRRESINWA=NO %and NAMEOPND_FLAG=REFTRIP %and %c
               TRIPLES(NAMEOPND_D)_OPERN=RCRFR %start
               GET WSP(W,268)
               OPND2_PTYPE = x'35'
               OPND2_FLAG = LOCAL IR
               OPND2_D = RBASE<<16!W
               OPND2_XTRA = 268
               JJ = BRECTRIP(PRECC,x'35',DONT OPT,OPND2,NAMEOPND)
               NAMEOPND_FLAG = REFTRIP
               NAMEOPND_D = JJ
               NAMEOPND_PTYPE = x'35'
            %finish
            ERR = 74;                    ! NORMAL CRES FAULT
            GET WSP(W,4);                ! TO HOLD P1,P2 AND VALUE OF P3
            OPND1_PTYPE = X'61'
            OPND1_FLAG = LOCALIR
            OPND1_D = RBASE<<16!W
            JJ = BRECTRIP(PRES1,X'35',DONT OPT,OPND1,NAMEOPND)
            P = P+3
            ->RES %if A(P)=4;            ! LHS MUST BE A STRING
                                         ! BUT THIS CHECKED BEFORE CALL
            ERR = 72
ERROR:      FAULT(ERR,0,FNAM)
            P = P1; SKIP EXP; %return
RES:        P = P+1;                     !    TO P(OPERAND)
            %if A(P)=3 %then %start;     ! B OMITTED
               OPND2_PTYPE = X'51'
               OPND2_FLAG = SCONST
               OPND2_D = 0;              ! ZERO CONST FOR NO DEST
            %finish %else %start
               ->ERROR %unless A(P)=1;   ! P(OPERAND)=NAME
               P = P+1; P2 = P
               CNAME(3)
               OPND2 = NAMEOPND
               %if TYPE#5 %then ERR = 71 %and FNAM = FROMAR2(P2) %and ->ERROR
               %if A(P+1)#CONCOP %then ERR = 72 %and ->ERROR
               P = P+2
            %finish
            JJ = BRECTRIP(PRES2,X'35',DONT OPT,OPND1,OPND2)
            ->ERROR %unless A(P)=3;      ! P(OPERAND)='('(EXPR)')'
            SEXPRN = SEXPRN+1; P = P+1
            CSTREXP(32);                 ! FULL 32 BIT ADDRESS
            OPND2_PTYPE = X'51'; OPND2_FLAG = SCONST
            OPND2_D = LAB
            JJ = BRECTRIP(RESLN,X'35',DONT OPT,EXPOPND,OPND2)
            %if LAB#0 %then %start
               %if LAB<=MAX ULAB %then JJ = 0 %else JJ = B'10'
                                         ! SET MERGE FOR FAIL JUMPS
                                         ! EXCEPT WHEN ROUTED TO USER LAB
               ENTER JUMP(X'87',LAB,JJ)
            %finish
!
            ->END %if A(P)=2
            %if A(P+1)#CONCOP %then ERR = 72 %and ->ERROR
            P2 = P+1; P = P2+1
            %if A(P)=3 %then P = P2 %and ->RES
            ->ERROR %unless A(P)=1
            P = P+3 %and SKIP APP %until A(P)=2
            %if A(P+1)=1 %then P = P2 %and ->RES
            P1 = P+1
            P = P2+2
            CNAME(3)
            JJ = BRECTRIP(RESFN,X'35',DONT OPT,OPND1,NAMEOPND)
            P = P1
END:
            P = P+1
         %end
         %routine SAVE STACK PTR
!***********************************************************************
!*    SAVE THE CURRENT STACK TOP AND POSSIBLY A DESCRIPTOR TO IT       *
!*    NEEDED ON AUX STACK IMPLEMENTATIONS AND ALSO IN BEGIN-END BLOCKS *
!*    SO ARRAYS CAN BE UNDECLARED ON BLOCK EXIT. ONLY ACTS ON THE FIRST*
!*    CALL IN ANY BLOCK OR ROUITNE                                     *
!***********************************************************************
            %integer JJJ
            %if CURRINF_AUXSBASE=0 %start
               JJJ = UTEMPTRIP(SSPTR,MINAPT,0,N);  ! SAVE THE STACK POINTER
               CURRINF_AUXSBASE = N
               %if TARGET=EMAS %and PARM_STACK=0 %then N = N+16 %else N = N+4
            %finish
         %end
         %routine CEND(%integer KKK)
!***********************************************************************
!*       DEAL WITH ALL OCCURENCES OF '%END'                            *
!*       KKK=PTYPE(>=X'1000') 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            *
!***********************************************************************
            %integer KP,JJ,BIT
            %record (TAGF) %name RCELL,TCELL,PCELL
            %routine %spec DTABLE(%integer LEVEL)
            SET LINE %unless KKK=2
            BIT = 1<<LEVEL
!
! NOW PLANT AN ERROR EXIT FOR FNS AND MAPS - CONTROL SHOULD BE RETURNED
! VIA %result= AN SHOULD NEVVER REACH THE %end INSTRUCTION
!
            %if KKK&X'3FFF'>X'1000' %and PARM_COMPILER=0 %and %c
               LAST INST=0 %then JJ = UCONSTTRIP(RTBAD,X'51',0,0)
                                         ! RUN FAULT 11
            %if KKK=0 %then %start;      ! BEGIN BLOCK EXIT
               %if PARM_TRACE=1 %then %start;  ! RESTORE DIAGS POINTERS
                  JJ = UCONSTTRIP(RDPTR,X'51',0,LEVEL-1)
               %finish
               JJ = CURRINF_AUXSBASE
               %if JJ#0 %then %start;    ! ARRAYS TO BE UNDECLARED
                  JJ = UCONSTTRIP(RSPTR,X'51',0,JJ)
               %finish
            %finish
            FORCE TRIPS;                 ! BEFOR LABEL LIST CLEARED IN OPT MODE
            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 CURRINF_LABEL#0 %cycle
               POP(CURRINF_LABEL,I,J,KP)
               %if J&X'FFFF'#0 %then %start
                  J = J&X'FFFF'
                  %if 0<KP<=MAX ULAB %then FAULT(11,ASLIST(J)_S3&X'FFFF',KP)
                  CLEAR LIST(J)
               %finish %else %start
                  %if I&LABUSEDBIT=0 %and KP<MAX ULAB %then WARN(3,KP)
               %finish
            %repeat
!
            NMAX = (NMAX+7)&(-8)
            CURRINF_SNMAX = NMAX
!
! FOR ROUITNE CHECK PARAMETER LIST FOR ARRAY PARAMETERS AND PASS
! BACK ANY INFORMATION ON DIMENSIONALAITY GLEANED DURING THE BODY
!
            JJ = CURRINF_M-1;            ! RT NALE
            %if JJ>=0 %start
               RCELL == ASLIST(TAGS(JJ))
               %if RCELL_PTYPE&X'1000'#0 %start;  ! NAME COULD BE REDECLARED%c
                                                  AS LOCAL
                                         ! IF THIS HAPPENS SKIP GLEANING
                  K = RCELL_SLINK
                  %while K>0 %cycle;     ! DOWN PARAM LIST
                     TCELL == ASLIST(K)
                     %if TCELL_PTYPE&X'F00'=X'500' %and TCELL_UIOJ&15=0 %start
                                         ! TCELL IS ARRAY OF UNKNOWN DIMENSION
                        PCELL == ASLIST(TAGS((TCELL_UIOJ>>4)&4095))
                                         ! ONTO LOCAL TAGS
                        TCELL_UIOJ = TCELL_UIOJ!PCELL_UIOJ&15
                                         ! COPY BACK DIMENSIO
                     %finish
                     K = TCELL_LINK
                  %repeat
               %finish
            %finish
!
! NOW PLANT THE BLOCK EXIT SEQUENCE
!
            %if KKK&X'1000'#0 %then JJ = UCONSTTRIP(RTXIT,X'51',0,KKK)
            JJ = UCONSTTRIP(XSTOP,X'51',0,KKK) %if KKK=1;  ! %stop AT%c
                                                           %endofprogram
            CLEAR LIST(TWSPHEAD);        ! CAN NOT CARRY FORWARD
            %cycle JJ = 0,1,4
               CLEAR LIST(CURRINF_AVL WSP(JJ));  ! RELEASE TEMPORARY LOCATIONS
            %repeat
            %if TARGET=PERQ %or TARGET=ACCENT %then FORCE TRIPS
                                         ! PERQ NEED THIS BEFORE DTABLE AS
                                         ! DTABLE OFFSET GOES IN RTDICT

                                         ! PNX MUST HAVE DATBLE FIRST OR
                                         ! FILLING OF DTABLE REFS FAILS
            DTABLE(LEVEL);               ! OUTPUT DIAGNOSTIC TABLES
            FORCE TRIPS
                                         ! ALL TRIPS MUST BE DEALT WITH
                                         ! BEFORE CURRENT LEVELS ARE CHANGED
            %while CURRINF_UNATT FORMATS#0 %cycle
               POP(CURRINF_UNATT FORMATS,I,J,JJ)
               CLEAR LIST(I)
               CLEAR LIST(J)
               CLEAR LIST(JJ)
            %repeat
!
! NOW CLAIM THE STACK FRAME BY FILING THE ASF IN THE BLOCK ENTRY CODING
!
            %if KKK=2 %then %return
!
! RETURN TO PREVIOUS LEVEL PROVIDED THERE IS A VALID ONE !
!
            %unless LEVEL>2 %or (LEVEL=2 %and PARM_CPRMODE=2) %then %start
               %if KKK=1 %and LEVEL=2 %then KKK = 2 %else FAULT(109,0,0)
                                         ! SHOULD BE CHKD IN PASS1
            %finish
            LEVEL = LEVEL-1
            CURRINF == LEVELINF(LEVEL)
            %if KKK&X'1000'#0 %then %start
               RLEVEL = CURRINF_RBASE
               RBASE = RLEVEL
            %finish
!
! RESTORE INFORMATION ABOUT THE (NEW) CURRENT LEVEL
!
            NMAX = CURRINF_SNMAX %if KKK&X'1000'#0
            N = CURRINF_SN
            %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&X'1000'#0 %and PARM_COMPILER=0 %and (RLEVEL>0 %or %c
               PARM_CPRMODE#2) %then %start
               JJ = NEXTP+6
               %unless A(NEXTP+5)=11 %and A(JJ+FROMAR2(JJ))=2 %start
                  JJ = ENTER LAB(CURRINF_JROUND,1)
                  CURRINF_JROUND = 0
               %finish
            %finish
            %return
!
! LAYOUT OF DIAGNOSIC TABLES
! ****** ** ********* ******
!
! THE BOUND FIELD OF PLT DESCRIPTOR STORED AT (LNB+3 & LNB+4) IF
! USED TO CONTAIN A DISPLACEMENT RELATIVE TO THE START OF SST OF THE
! DIAGNOSTIC TABLES FOR THE BLOCK OR ROUTINE BEING EXECUTED.
! A ZERO BOUND MEANS NO DIAGNOSTIC REQUESTED.(NB THIS MAY MEAN A DUMMY
! FIRST WORD IN THE SST).
! THE ABSOLUTE ADDRESS OF THE SST FOR THE CURRENT CODE SEGMENT WILL
! ALWAYS BE FOUND IN THE STANDARD 10 WORDS OF THE GLA/PLT
!
! FORM OF THE TABLES:-
!
! WORD 0    =   LINE OF RT IN SOURCE PROG <<16 ! LINE NO POSN(FROM LNB)
! WORD 1    =   (12 LANG DEPENDENT BITS)<<18 ! ENVIRONMENT
!                ( TOP 2 BITS OF LANG DEPENDENT HAS LITL FROM PTYPE)
!                 ( BOTTOM 4 BITS HAVE TEXTUAL LEVEL)
! WORD 2    =   DISPLAY POSN (FROM LNB)<<16 ! RT TYPE INFO
! WORD 3    =   ZERO FOR BLKS OR STRING(<=11BYTES) BEING THE
!               RT NAME. THIS WILL TAKE WORDS 4 AND 5 IF NEEDED
! WORD 6    =  LANGUAGE DEPENDENT INFO . IMP ON CONDITIONS ETC
!
! THE REST IS MADE UP OF VARIABLE ENTRIES AND THE SECTION IS TERMINATED BY
! A WORD OF X'FFFFFFFF'
!
!  EACH VARIABLE ENTRY CONSISTS OF THE VARIABLE WORD FOLLOWED BY
! THE VARIABLE NAME AS A STRING. THE WORD CONSISTS OF
! BITS 2**31 TO 2**20 TYPE INFORMATION (MAY BE LANGUAGE DEPENDENT
! BIT  2**19  =0 UNDER LNB =1 IN GLA
! BITS 2**18 TO 2**0 DISPLACEMENT FROM LNB(GLA) IN BYTES
!
!
! THE ENVIRONMENT IS A POINTER (RELATIVE TO SST) OF THE NEXT OUTERMOST
! BLOCK OR A POINTER TO GLOBAL OWNS, EXTERNAL OR COMMON AREAS
! A ZERO MEANS NO ENCLOSING BLOCK. WORD1=WORD3=0 IS AN
! IMP MAIN PROGRAM AND WILL TERMINATE THE DIAGNOSTICS.
!
            %routine DTABLE(%integer LEVEL)
!***********************************************************************
!*      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.                                    *
!***********************************************************************
%integerfnspec swopof(%integer ptype,value)
%string (11) RT NAME
%string (11) LOCAL NAME
%if 1<<host&unsignedshorts=0 %start
   %record %format HEADF(%short RTLINE,LINEOFF,OFLAGS,ENV,
      DISPLAY,RTFLAGS,(%integer IDHEAD %or %string (11) RTNAME))
   %record %format VARF(%short FLAGS,DISP, %string (11) VNAME)
%finish %else %start
   %record %format HEADF(%half %integer RTLINE,LINEOFF,OFLAGS,
      ENV,DISPLAY,RTFLAGS,
      (%integer IDHEAD %or %string (11) RTNAME))
   %record %format VARF(%half %integer FLAGS,DISP,
      %string (11) VNAME)
%finish
%record (HEADF) %name DHEAD
%record (VARF) %name VAR
%record (LISTF) %name LCELL
%const %integer LARRROUT=X'F300'
%record (TAGF) T
%integer DPTR,LNUM,ML,KK,JJ,Q,DEND,BIT,S4,LANGD,RULES,II
%const %integer DLIMIT=700
%integer %array DD(0:DLIMIT);  ! BUFFER FOR SEGMENT OF SST
!
! FILL ALL OUTSTANDING REFERENCES TO THIS DIAGS BLOCK
!
      BIT = 1<<LEVEL
      LANGD = KKK>>14<<30!LEVEL<<18;    ! GET LITL FROM PTYPE
      %if PARM_TRACE=1 %then PDATA(DAREA,4,0,ADDR(DD(0)));    ! TO WORD BOUNDARY
      FILL DTABREFS(CURRINF_RAL)
      PUSH(LEVELINF(LEVEL-1)_RAL,DAREA,CAS(DAREA)+4,LANGD) %if PARM_TRACE#0
      DHEAD == RECORD(ADDR(DD(0)))
      DHEAD_RTLINE <-swopof(X'41', CURRINF_L)
      DHEAD_LINEOFF <-Swop of(x'41', CURRINF_DIAGINF)
      DHEAD_OFLAGS <-Swop of(x'41', LANGD>>16)
      DHEAD_ENV = 0
      %if TARGET=IBM %or TARGET=IBMXA %or TARGET=AMDAHL %then %c
         DHEAD_DISPLAY = CURRINF_RBASE %else %c
         DHEAD_DISPLAY <-Swop of(x'41', CURRINF_DISPLAY)
      DHEAD_RTFLAGS <-Swop of(x'41', CURRINF_FLAG&X'3FFF')
      ML = CURRINF_M;                   ! ROUTINE NAME(=0 FOR %begin)
      %if ML#0 %then ML = WORD(ML-1);   ! IF NOT BLOCK GET DIRPTR
      LNUM = WORKA_LETT(ML);            ! LENGTH OF THE NAME
      DPTR = 4; DEND = 0
      %if LNUM=0 %then DHEAD_IDHEAD = 0 %else %start
         Q = ADDR(WORKA_LETT(ML))
         RT NAME <- STRING(Q);          ! FOR RTS MOVE IN 1ST 32 CHARS
         LNUM = LENGTH(RT NAME)
         DHEAD_RTNAME = RTNAME;         ! AND UPDATE POINTER PAST
!         %if HOST#TARGET %and PARM_TRACE#0 %then %c
!            CHANGE SEX(ADDR(DD(0)),12,LNUM+1)
         DPTR = DPTR+LNUM>>2;           ! ACTUAL NO OF CHARS
      %finish
      DD(DPTR) <-Swop of(X'51',CURRINF_ONWORD);! ON CONDITION WORD
      DPTR = DPTR+1
      JJ = CURRINF_NAMES
      %while 0<=JJ<X'3FFF' %cycle
         LCELL == ASLIST(TAGS(JJ))
         T = LCELL
                                         ! OBTAIN NEXT NAME FORM DECLNS
!
! GET ONLY THE MINIMUM OF DETALS NECESSARY
!
         S4 = LCELL_LINK
         LCELL_LINK = ASL; ASL = TAGS(JJ)
         TAGS(JJ) = S4&X'3FFFF'
         PTYPE = T_PTYPE; TYPE = PTYPE&15
!
! FAULT ALL UNUSED NAMES EXCEPT CONSTINTEGERS&REALS
!
         %if (TYPE>2 %or PTYPE&X'FF00'#X'4000' %or %c
            PARM_STACK#0) %and T_UIOJ&X'C000'=0 %then WARN(2,JJ)
         I = T_UIOJ>>4&15
         J = T_UIOJ&15
         K = T_SLINK
!
! ALLOW OWNS (LITL=0) AND EXTERNALS (=2) NOT CONSTS(=1) OR EXTRINSIC(=3)
!
         %if PARM_DIAG#0 %and PTYPE&X'7300'<=X'200' %and %c
            DPTR<DLIMIT-3 %and (1<=TYPE<=3 %or TYPE=5) %start
            Q = ADDR(WORKA_LETT(WORD(JJ)));  ! ADDRESS OF NAME
            %if I=0 %then II = 1 %else II = 0;! GLA OR LNB BIT
            VAR == RECORD(ADDR(DD(DPTR)))
            VAR_FLAGS <- swopof(X'41',PTYPE<<4!II<<2)
            %if ((PARAMS BWARDS=YES %and k<currinf_display) %or (STACK DOWN=YES %and k>Currinf_display))%c
                  %and PTYPE&X'C00'=0 %and II=0 %and %c
               (TYPE=3 %or TYPE=5) %start;! VALUE RECS&STRS
               %if K<Currinf_display %then rules=2 %else rules=1
                KK=rounding length(ptype,rules)
               K = (K+T_ACC+kk)&(\KK)
            %finish
            VAR_DISP <- swopof(X'41', K)
           %if target=eamd %and I#0 %Then var_disp=k+64;! frig so standard diags work
            LOCAL NAME <- STRING(Q);   ! TEXT OF NAME FROM DICTIONARY
            LNUM = LENGTH(LOCAL NAME)
            VAR_VNAME = LOCAL NAME;     ! MOVE IN NAME
            %if HOST#TARGET %and PARM_TRACE#0 %then %c
               CHANGE SEX(ADDR(DD(0)),4*DPTR+4,LNUM+1)
            DPTR = DPTR+(LNUM+8)>>2
         %finish
         %if J=15 %and PTYPE&X'3000'#0 %and T_UIOJ&X'C000'#0 %then %c
            FAULT(28,0,JJ)
                                         ! SPEC&USED BUT NO BODY GIVEN
         %if J=15 %and TYPE=4 %then FAULT(62,0,JJ)
         %if PTYPE&X'3000'#0 %or TYPE=4 %or TYPE=6 %then %c
            CLEAR LIST(K) %else %start
            %if I#0 %and K>4095 %and PTYPE&LARRROUT=0 %and %c
               TYPE#7 %then WARN(5,JJ)
         %finish
         JJ = S4>>18
      %repeat
      DD(DPTR) = -1;                    ! 'END OF SEGMENT' MARK (Not swopped!)
      DPTR = DPTR<<2+4
      %if PARM_TRACE=1 %then PDATA(DAREA,4,DPTR,ADDR(DD(0)))
                                         ! ADD TO SHARABLE SYM TABS
      %return
%integerfn Swopof(%integer ptype,value)
!***********************************************************************
!*      Does the byte swopping for cross compilers using rt in P4      *
!***********************************************************************
%record(rd)opnd
      %if host#target %then %start
         Opnd=0
         Opnd_d=value
        Opnd_ptype=ptype
         Reformatc(Opnd)
         value=Opnd_d
      %finish
      %result=Value
%end
%end;                        ! OF ROUTINE DTABLE
         %end
         %routine DECLARE SCALARS(%integer XTRA)
!***********************************************************************
!*       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.                              *
!*       P POINTS TO THE NAMELIST ON ENTRY AND IS UPDATED.             *
!***********************************************************************
            %integer INC,SCAL NAME,RL
            PACK(PTYPE)
            INC = ACC; SNDISP = 0
            RL = ROUNDING LENGTH(PTYPE,1)
            %if NAM#0 %and ARR=0 %then INC = PTRSIZE(PTYPE&127) %and RL=ptrrounding(ptype&127+128)
            %if NAM>0 %and ARR>0 %then INC = AHEADSIZE %and RL=rounding length(aheadpt,1)
            %if PTYPE=X'35' %and (ACC<=0 %or ACC>256) %then %c
               FAULT(70,ACC-1,0) %and ACC = 255
            %until A(P-1)=2 %cycle;      ! DOWN THE NAMELIST
               N = (N+RL+SFRAME MISALIGN)&(\RL)-SFRAME MISALIGN
               SCAL NAME = FROM AR2(P)
               P = P+3
               STORE TAG(SCAL NAME,LEVEL,RBASE,0,SNDISP,ACC,N,XTRA)
               N = N+INC
            %repeat
            N = (N+MIN PARAM SIZE-1)&(-MIN PARAM SIZE);  ! THIS IS NECESSARY !
%end
         %integer %fn DOPE VECTOR(%integer TAMPER,TYPEP,ELSIZE,MODE,IDEN,
            %integer %name ASIZE,LB)
!***********************************************************************
!*        CONSTRUCTS THE DOPE-VECTOR FOR A CONSTANT ARRAY IN THE       *
!*       SHAREABLE SYMBOL TABLES AND RETURNS ITS DISPLACEMENT AS RESULT*
!*       P IS TO ALT (MUST BE 1!) OF P<BPAIR>                          *
!*       PERQ,DRS,WWC&ACCENT DOPE VECTOR CONSISTS OF :-                *
!*       @0 DWORD CONTAINING THE BASE OFFSET                           *
!*       @4 WORD CONTAINING THE NO OF DIMENSIONS ND                    *
!*       @6 WORD HOLDING SIZE (IN BYTES) OF A SINGLE ELEMENT           *
!*       @8 DWORD OF ARRAYSIZE WORDS(DRS BYTES)  FOR STACK ADJUSTMENT  *
!*       AND ND DWORD TRIPLES EACH CONSISTING OF:-                     *
!*       UBI THE UPPER BOUND OF THE ITH DIMENSION                      *
!*       LBI - THE LOWER BOUND OF THE ITH DIMENSION                    *
!*       RI - THE STRIDE FOR THE ITH DIMENSION=(UBI-LBI+1)             *
!*       EMAS DOPE VECTOR CONSISTS OF:-                                *
!*       @0 BOUNDED WORD DESCRPTOR BOUND=3*ND                          *
!*       @8 THE ARRAY SIZE IN BYTES OF ENTIRE ARRAY                    *
!*       @12 ND TRIPLES OF LB,MULT AND UPPER CHK AS PER VMY INSTRN     *
!*       NOTE TRIPLES IN REVERSE ORDER FOR HISTORIC COMPATABILITY      *
!*       MODE=0 DV MUST BE CONST, MODE#0 CAN BE DYNAMIC                *
!*       MODE=-1 SPECIAL FOR CONSTARRAYNAMES 1D 0:INFINITY             *
!***********************************************************************
            %integer I,JJ,K,ND,D,M0,HEAD,NOPS,TYPEPP,PIN
            %record (RD) OPND
            %record (LISTF) %name LCELL
            %integer %array LBH,LBB,UBH,UBB(0:12)
            %integer %array DV(0:39);    ! ENOUGH FOR 12 DIMENSIONS
            ND = 0; NOPS = 0; TYPEPP = 0; PIN = P
            M0 = 1
            %if (TARGET=PERQ %or TARGET=ACCENT %or TARGET=PNX) %and %c
               ELSIZE>1 %then ELSIZE = (ELSIZE+1)&(-2)
            %if MODE=-1 %then %start
               ND = 1; LBB(1) = 0
               %if TARGET=PERQ %or TARGET=DRS %or TARGET=WWC %or %c
                  TARGET=ACCENT %then ASIZE = X'7FFF' %else ASIZE = X'FFFFFF'
               UBH(1) = ASIZE//ELSIZE
               UBB(1) = UBH(1)-ELSIZE
            %finish %else %start
               %until A(P)=2 %cycle
                  ND = ND+1; P = P+4
                  FAULT(37,0,IDEN) %and ND = 1 %if ND>12
                  LBH(ND) = 0; LBB(ND) = 0
                  UBB(ND) = 0; UBH(ND) = 0
                  TORP(LBH(ND),LBB(ND),NOPS)
                  P = P+3
                  TYPEPP = TYPEPP!TYPE
                  TORP(UBH(ND),UBB(ND),NOPS)
                  TYPEPP = TYPEPP!TYPE
               %repeat
               P = P+1
               ->NONCONST %unless TYPEPP=1 %and NOPS&X'40040000'=0
!
! NOW ONE CAN WORK OUT AND FILL IN THE TRIPLES
!
               ASIZE = 1
               %cycle D = 1,1,ND
                  K = 3*D
                  EXPOP(LBH(D),LBB(D),NOPS,X'251')
                  EXPOPND_D = 0 %and FAULT(41,0,0) %unless %c
                     EXPOPND_FLAG<=1 %and EXPOPND_PTYPE=X'51'
                  LBB(D) = EXPOPND_D
                  %if (TARGET=EMAS %or TARGET=PNX) %and TAMPER=YES %and %c
                     PARM_OPT=0 %and ND=1 %and LBB(D)=1 %then LBB(D) = 0
! READJUST BASE TO 0 FROM 1
                  EXPOP(UBH(D),UBB(D),NOPS,X'251')
                  EXPOPND_D = 10 %and FAULT(41,0,0) %unless %c
                     EXPOPND_FLAG<=1 %and EXPOPND_PTYPE=X'51'
                  JJ = EXPOPND_D
                  FAULT(38,LBB(D)-JJ,IDEN) %and JJ = LBB(D) %unless JJ>=LBB(D)
                  UBB(D) = JJ
                  UBH(D) = JJ-LBB(D)+1;  ! RANGE OF DTH DIMENSION
                  ASIZE = ASIZE*UBH(D)
               %repeat
               ASIZE = ASIZE*ELSIZE
            %finish
!
!      CALCULATE THE OFF SET OF A(FIRST,..) FROM A(0,..)
!
            LB = 0; I = ND
            %while I>=2 %cycle
               LB = (LB+LBB(I))*UBH(I-1)
               I = I-1
            %repeat
            LB = LB+LBB(1)
            FAULT(39,0,IDEN) %if ASIZE>X'FFFFFF'
!
! SET UP THE DOPEVECTOR ALLOWING EACH TARGET ITS ODDITIES
!
            %if 1<<target&emachine#0 %start
               DV(2) = ASIZE
               DV(0) = -LB
               DV(1) = ND<<16!ELSIZE
            %finish
            %if TARGET=PERQ %or TARGET=ACCENT %or TARGET=PNX %start
               DV(2) = (ASIZE+1)>>1
               DV(0) = -LB
               DV(1) = ND<<16!ELSIZE
            %finish
            %if TARGET=EMAS %start
               DV(0) = X'28000000'+3*ND
               DV(1) = 12;               ! SO LDRL POINTS TO TRIPLES
               DV(2) = ASIZE;            ! FOR ARRAYS BY VALUE
               %if TYPEP>=3 %or ELSIZE=2 %then M0 = ELSIZE
            %finish
            %if TARGET=IBM %or TARGET=IBMXA %or TARGET=AMDAHL %start
               DV(0) = ND
               DV(1) = (ASIZE+7)&(-8)
               DV(2) = ELSIZE
            %finish
            %cycle D = 1,1,ND
               %if TARGET=PERQ %or 1<<target&emachine#0 %or TARGET=ACCENT %or %c
                  TARGET=PNX %start
                  K = 3*D
                  DV(K) = UBB(D)
                  DV(K+1) = LBB(D);      ! LOWER BND OVER UPPER
                  M0 = M0*UBH(D)
                  DV(K+2) = M0;          ! RANGE
               %finish
               %if TARGET=EMAS %start
                  K = 3*(ND+1-D);        ! TRIPLES IN REVERSE ORDER
                  DV(K) = LBB(D)
                  DV(K+1) = M0;          ! RUNNING MULTIPLIER
                  M0 = M0*UBH(D);        ! UPPED BY RANGE
                  DV(K+2) = M0
               %finish
               %if TARGET=IBM %or TARGET=IBMXA %or TARGET=AMDAHL %start
                  K = 3*D
                  DV(K) = LBB(D)
                  DV(K+1) = UBB(D)
                  DV(K+2) = M0*ELSIZE
                  M0 = M0*UBH(D)
               %finish
            %repeat
            K = 3*ND+2
!
! REFORMAT THE ARRAY DOPE VECTOR FOR BYTE SWAPPED MACHINES. OPT AND GEN
! MUST ALLOW FOR POSSIBLY SWAPPED DOPE VECTORS IN COMPILE TIME OPERATIONS
!
            %if HOST#TARGET %start
               OPND_PTYPE = X'51'; OPND_FLAG = 0
               %for D = 0,1,K %cycle
                  OPND_D = DV(D)
                  REFORMATC(OPND)
                  DV(D) = OPND_D
               %repeat
            %finish
            J = ND;                      ! DIMENSIONALITY FOR DECLN
            HEAD = DVHEADS(ND)
            %while HEAD#0 %cycle
               LCELL == ASLIST(HEAD)
               %if LCELL_S2=ASIZE %start
                  %cycle D = 0,1,K
                     ->ON %unless DV(D)=CTABLE(D+LCELL_S1)
                  %repeat
                  SNDISP = 4*LCELL_S1
                  %result = LCELL_S3
               %finish
ON:
               HEAD = LCELL_LINK
            %repeat
            SNDISP = 4*WORKA_CONST PTR
            I = SNDISP
            %if DVAREA=4 %then SSTL = (SSTL+3)&(-4) %and I = SSTL
                                         ! PERQ DVS IN SST
            PUSH(DVHEADS(ND),WORKA_CONSTPTR,ASIZE,I)
            %cycle D = 0,1,K
               CTABLE(WORKA_CONST PTR) = DV(D)
               WORKA_CONST PTR = WORKA_CONST PTR+1
            %repeat
            %if WORKA_CONST PTR>WORKA_CONST LIMIT %then %c
               FAULT(102,WORKA_WKFILEK,0)
            %if DVAREA=4 %then %c
               PDATA(4,4,4*(K+1),ADDR(DV(0))) %and SSTL = SSTL+4*(K+1)
WAYOUT:
            %if MODE=-1 %then %result = I;  ! NO EXPRESSION CELLS TO RETURN
            %result = I
NONCONST:                                ! NOT A CONST DV
            J = ND; I = -1; SNDISP = -1
            LB = 0; ASIZE = ELSIZE
            %if MODE=0 %then %Start
            FAULT(41,0,0)
            I=dope vector(tamper,typep,elsize,-1,iden,asize,lb)
            %finish %else P = PIN
            %cycle D = 1,1,ND
               CLEAR LIST(LBH(D))
               CLEAR LIST(UBH(D))
            %repeat
            ->WAYOUT
         %end

         %routine DECLARE ARRAYS(%integer FORMAT,FINF)
!***********************************************************************
!*       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> = '('<EXPR>':'<EXRR><RESTOFBP>*')'                   *
!*                                                                     *
!*       ARRAYS WITH CONSTANT BOUNDS HAVE THEIR D-V IN THE SST         *
!*       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,PTYPEP,ARRP,NN,ND,II,CDV,
   LWB,PTYPEPP,JJJ,JJ,TRIP1,RL
            %record (RD) OPND1
            SAVE STACK PTR;              ! FOR LATER UNDECLARING
            ARRP = 2*FORMAT+1; ARR = ARRP; PACK(PTYPEP)
            ELSIZE = ACC
            %if (TARGET=PERQ %or TARGET=ACCENT %or TARGET=PNX) %and %c
               ELSIZE>1 %then ELSIZE = (ELSIZE+1)&(-2)
START:      NN = 1; P = P+1;             ! NO OF NAMES IN NAMELIST
            PP = P; CDV = 0; PTYPEPP = PTYPEP
            P = P+3 %and NN = NN+1 %while A(P+2)=1
            P = P+3
            %if ARRP=3 %then JJ = NO %else JJ = YES
            DVDISP = DOPE VECTOR(JJ,TYPE,ELSIZE,1,FROMAR2(PP),TOTSIZE,LWB)
            ND = J
            ->CONSTDV %unless DVDISP<0
!
! NORMAL CASE - PLANT CODE TO SET UP DOPE-VECTOR AT RUN TIME
!
            DVF = 0; TOTSIZE = X'FFFF'
            N = (N+3)&(-4)
            DVDISP = N;                  ! DVDISP IS D-V POSITION
            N = N+12*ND+12;              ! CLAIM SPACE FOR THE D-V
            %if STACK DOWN=YES %then DVDISP = N-4
                                         ! FOR DOWNWARD STACK MACHINES
            TRIP1 = ULCONSTTRIP(DVSTT,X'51',DONT OPT,ND<<16!ELSIZE,
               PTYPEP<<16!DVDISP)
                                         ! ASSN ND&DIMEN->DVDIPS+4
!
            %cycle II = 1,1,ND
               P = P+1
               CSEXP(X'51');             ! LOWER BOUND
               %if (TARGET=EMAS %or TARGET=PNX) %and PARM_OPT=0 %and %c
                  ND=1 %and EXPOPND_FLAG=0 %and EXPOPND_D=1 %then EXPOPND_D = 0
                                         ! ADD ONE ELEMENT ON TO FRONT
                                         ! OF OPTIMISED ARRAYS STARTING
                                         ! AT UNITY TO SAVE BASE ADJUST
               %if EXPOPND_FLAG>0 %or EXPOPND_D#0 %then DVF = DVF!(1<<II)
                                         !NON ZERO
                                         ! BASE OFFSET NOT ZERO
               OPND1 = EXPOPND
               CSEXP(X'51');             ! UPPER BOUND
               TRIP1 = BRECTRIP(DVBPR,X'51',DONT OPT,OPND1,EXPOPND)
               TRIPLES(TRIP1)_X1 = II<<24!ND<<16!DVDISP
            %repeat
            P = P+1
            SNDISP = 0;                  ! DV NOT AVAILABLE AT COMPILETIME
            %if DVF=0 %then %start
               LWB = 0
               %if FORMAT=0 %then PTYPEPP = PTYPEP+256
            %finish
!***********************************************************************
!*    FIND THE OFFSET OF A(0...) FROM A(FIRST...) BY COMPUTING         *
!*    THE OFFSET OF A(FIRST...) FROM A(0...) AND NEGATING              *
!***********************************************************************
            JJ = ULCONSTTRIP(DVEND,X'51',DONT OPT,DVF<<16!ELSIZE,PTYPEPP)
            TRIPLES(JJ)_X1 = ND<<16!DVDISP
            ->DECL
CONSTDV:                                 ! ONE DIMENSION - CONSTANT BOUNDS
            CDV = 1
            %if LWB=0 %and FORMAT=0 %then PTYPEPP = PTYPEP+256
            SNDISP = SNDISP>>2
                                         ! SET ARR=2 IF LWB=ZERO
            %if PARM_COMPILER#0 %and LWB#0 %then FAULT(99,0,0)
DECL:                                    ! MAKE DECLN - BOTH WAYS
            J = ND
            RL=ROUNDINGLENGTH(AHEADPT,1)
            N = (N+RL)&(\RL);              ! MAY BE BENEFITS IN WORD ALIGNMENT
            PTYPE = PTYPEPP; UNPACK
            %cycle JJJ = 0,1,NN-1;       ! DOWN NAMELIST
               K = FROM AR2(PP+3*JJJ)
               STORE TAG(K,LEVEL,RBASE,J,SNDISP,ELSIZE,N,FINF)
               JJ = ULCONSTTRIP(DARRAY,X'61',0,
                  CDV<<31!JJJ<<24!(NN-1)<<16!DVDISP,K)
               JJ = ULCONSTTRIP(ASPTR,X'61',0,CDV<<31!SNDISP<<16!DVDISP,
                  K) %if FORMAT=0
               N = N+AHEADSIZE
            %repeat
            P = P+1;                     ! PAST REST OF ARRAYLIST
            %if A(P-1)=1 %then ->START
            %return
         %end
         %integer %fn ROUNDING LENGTH(%integer PTYPE,RULES)
!***********************************************************************
!*    RULES=0 IN RECORDS(BEST DEFINED)                                 *
!*    RULES=1 IN STACK FRAME(MOST LATITUDE)                            *
!*    RULES=2 AS PARAMETERS(FUNNY HARDWARE CONSIDERATIONS)             *
!***********************************************************************
            %if PTYPE&X'1000'#0 %then %result = PTR ROUNDING(128*RULES)
                                         ! TREAT RT PARAMS AS %name
            %if PTYPE&X'C00'#0 %then %c
               %result = PTR ROUNDING(PTYPE&X'7F'+128*RULES)
!
! The rounding requirements for records are not stored so treat as long reals
! using the correct rules
!
          %if ptype=x'33' %and rules=1 %then %result=rnding(x'62'+128*rules)
            %result = RNDING(PTYPE&X'7F'+128*RULES)
         %end
         %routine CLT
!***********************************************************************
!*       DEAL WITH PHRASE TYPE AND SET PREC,TYPE & ACC                 *
!*       ONLY PROBLEM ARE STRINGS WHICH HAS OPTIONAL MAX LENGTH ALSO   *
!*       RECORD WHICH HAVE A FORMAT                                    *
!*       P ON PHRASE TYPE AT ENTRY - TO NEXT PHRASE AT EXIT.           *
!***********************************************************************
            %integer ALT,PTYPEP,I,FLAGS,SJ
            ALT = A(P)
            FLAGS = TYPEFLAG(ALT)
            %if FLAGS&X'8000'#0 %then %c
               P = P+1 %and FLAGS = TYPEFLAG(A(P)+FLAGS&15)
            %if FLAGS&X'4000'#0 %then P = P+1;  ! ALLOWS BYTE OR BYTEINTEGER%c
                                                ETC
            %if FLAGS&X'2000'#0 %then WARN(8,0);  ! SUBSTITUTION MADE
            %if FLAGS&X'1000'#0 %then FAULT(99,0,0)
            PREC = FLAGS>>4&15
            TYPE = FLAGS&7
            P = P+1
            ACC = BYTES(PREC)
            PACK(PTYPEP);                ! PRESERVE ALL COMPONENT
                                         ! BEFORE CALLINT INTEXP ETC
            %if TYPE=5 %then %start;     ! P<TYPE>='%STRING'
               %if A(P)=1 %then %start;  ! MAX LENGTH GIVEN
                  %if A(P+1)=1 %start;   ! EXPRESSION NOT STAR
                     P = P+4
                     %if INTEXP(I,MINAPT)#0 %then FAULT(41,0,0) %and i=255
                     FAULT(70,I,0) %unless 1<=I<=255
                     ACC = I+1
                     PTYPE = PTYPEP; UNPACK
                  %finish %else ACC = 0 %and P = P+2
               %finish %else ACC = 0 %and P = P+1
            %finish
            KFORM = 0
            %if TYPE=3 %then %start
               SJ = J
               KFORM = CFORMATREF
               PTYPE = PTYPEP
               UNPACK
               J = SJ
            %finish
         %end
         %routine CQN(%integer P)
!***********************************************************************
!*       SET NAM & ARR FROM ALTERNATIVE OF PHRASE <QNAME'>             *
!*       P<QNAME'>='%arrayname','%name',<%NULL>                        *
!*       P POINTS TO THE ANALYSIS RECORD ENTRY AS IS NOT UPDATED       *
!***********************************************************************
            %integer I
            I = A(P); NAM = 0; ARR = 0
            %if I=1 %then ARR = 1;       ! ARRAYNAMES
            %if I<=2 %then NAM = 1;      ! ARRAYNAMES & NAMES
         %end

         %integer %fn SET SWITCHLAB(%integer HEAD,LAB,FNAME,BIT)
!***********************************************************************
!*    SET A SWITCH LABEL AND RETURNS RESULT=0 %unless THE LABEL        *
!*    HAS BEEN ALREADY SET WHEN IT RETURNS RESULT#0                    *
!*    HEAD IS HEAD OF THE TAGS SIDECHAIN FOR THE SWITCH                *
!***********************************************************************
            %integer Q,QQ,JJJ,LB,UB
            %record %format BITFORM(%integer %array BITS(0:2), %integer LINK)
            %record (RD) OPND1,OPND2
            %record (BITFORM) %name BCELL
            %record (LISTF) %name LCELL
            OLDLINE = 0
            LCELL == ASLIST(HEAD)
            LB = LCELL_S2
            UB = LCELL_S3
            HEAD = LCELL_LINK
            BCELL == ASLIST(HEAD)
            %unless LB<=LAB<=UB %then FAULT(50,LAB,FNAME) %and %result = 0
            Q = LAB-LB
            %while Q>=96 %cycle
               HEAD = BCELL_LINK
               BCELL == ASLIST(HEAD)
               Q = Q-96
            %repeat
!
! 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>>5;                   ! RIGHT WORD
            Q = Q&31; JJJ = 1<<Q;        ! BIT IN WORD
            %result = 1 %unless BCELL_BITS(QQ)&JJJ=0
            BCELL_BITS(QQ) = BCELL_BITS(QQ)!BIT<<Q;  ! DONT SET BIT ON SW(*)%c
                                                     ENTRIES
            OPND1 = 0; OPND2 = 0
            OPND1_PTYPE = X'56'; OPND1_FLAG = DNAME
            OPND1_D = FNAME
            OPND2_PTYPE = X'51'; OPND2_FLAG = SCONST
            OPND2_D = LAB
            QQ = BRECTRIP(SETSW,X'56',0,OPND1,OPND2)
            %result = 0
         %end
         %routine CRSPEC(%integer M)
!***********************************************************************
!*    MODE=0  FOR NORMAL ROUTINE SPEC                                  *
!*    MODE=1 FOR EXTERNAL(ETC) ROUTINE SPECS XREF NEEDED               *
!*    P ON ENTRY TO P(RT) IN (RT)(MARK)(%spec')(NAME)(FPP)             *
!***********************************************************************
            %integer KK,JJ,TYPEP,OPHEAD,NPARMS,AXNAME,SACC,SKFORM,PCHKWORD
            LITL = EXTRN&3
            ACC = 0; KFORM = 0;          ! FOR NORMAL RTS-CLT WILL REVISE
            %if A(P)=1 %then %start;     ! P<RT>=%routine
               TYPEP = LITL<<14!X'1000'
               P = P+4;                  ! IGNORING ALT OF P(SPEC') and hole
            %finish %else %start;        ! P<RT>=<TYPE><FNORMAP>
               ROUT = 1; ARR = 0; P = P+1
               CLT; NAM = 0
               %if A(P)=2 %then NAM = 2;  ! 2 FOR MAP 0 FOR FN
               PACK(TYPEP)
               P = P+4;                  ! AGAIN IGNORING ALT OF P(SPEC') and hole
            %finish
            KK = FROM AR2(P)
            AXNAME = ADDR(WORKA_LETT(WORD(KK)))
            JJ = 0
            P = P+3
            SACC = ACC; SKFORM = KFORM;  ! FOR RECORD MAPS WITH PARAMS
            %if A(P-1)=1 %then %start
               %if LITL=0 %then WARN(10,0)
               MOVE BYTES(A(P)+1,ADDR(A(0)),P,ADDR(A(0)),WORKA_ARTOP)
               AXNAME = ADDR(A(WORKA_ARTOP))
               WORKA_ARTOP = (WORKA_ARTOP+4+A(P))&(-4)
               P = P+A(P)+1
            %finish
            CFPLIST(OPHEAD,NPARMS)
            PCHKWORD = 0
            %if NPARMS>0 %then PCHKWORD = NPARMS<<16!ASLIST(OPHEAD)_S3>>16
            %if M=1 %then %start
               %if TARGET=EMAS %or TARGET=PNX %or TARGET=IBM %or %c
                  TARGET=IBMXA %or target=amdahl %or %c
                  1<<target&emachine#0 %then %c
                  CXREF(STRING(AXNAME),3*PARM_DYNAMIC!EXTRN,PCHKWORD,JJ)
                                         ! %system & %external =STATIC
                                         ! UNLESS PARM DYNAMIC SET
                                         ! %dynamic = DYNAMIC
               %if TARGET=PERQ %or TARGET=ACCENT %then %c
                  JJ = AXNAME-ADDR(A(WORKA_DICTBASE))
            %finish %else %start
               %if TARGET=PERQ %or TARGET=ACCENT %then %c
                  JJ = WORKA_RTCOUNT %and WORKA_RTCOUNT = WORKA_RTCOUNT+1
            %finish
            %if M=0 %and RLEVEL=0 %start
               %if PARM_CPRMODE=0 %then PARM_CPRMODE = 2
               %if PARM_CPRMODE#2 %then FAULT(56,0,KK)
            %finish
            J = 15-M; PTYPE = TYPEP
            STORE TAG(KK,LEVEL,RBASE,15-M,JJ,SACC,OPHEAD,SKFORM)
         %end
         %routine CFPLIST(%integer %name OPHEAD,NPARMS)
!***********************************************************************
!*    COMPILE A FORMAL PARAMETER PART INTO A LIST OF PARAMETER TYPES   *
!*    P(FPP)='('{(HOLE)(FPDEL)(NAMELIST)(MARK)}*')',0.                 *
!*                                                                     *
!*    THE LIST OF PARAMETER LOOKS LIKE:-                               *
!*    S1 = PTYPE FOR PARAM<<16!LNAME<<12!DIMENSION(DIMEN DEDUCED LATER)*
!*                                      LNAME IS PARAMS LOCAL NAME     *
!*    S2 = PARAMETER OFFSET(SNDISP) <<16 ! ACC                         *
!*    S3 = 0                                 (RESERVED FOR FPP OF RTS) *
!*                                                                     *
!*    ON ENTRY P IS AT ALT OF FPP (WHICH MAY BE NULL)                  *
!***********************************************************************
            %integer OPBOT,PP,INC,RL,RSIZE,CELL,PSIMPLE
            %record (LISTF) %name LCELL
            OPHEAD = 0; OPBOT = 0
            NPARMS = 0;                  ! ZERO PARAMETERS AS YET
            PSIMPLE = 1;                 ! NO COMPLEX PARAMS YET
            %while A(P)=1 %cycle;        ! WHILE SOME(MORE) FPS
               PP = P+1+FROMAR2(P+1);    ! TO NEXT FPDEL
               P = P+3;                  ! TO ALT OF FPDEL
               CFPDEL;                   ! GET TYPE & ACC FOR NEXT GROUP
               PSIMPLE = 0 %unless %c
                  PTYPE=X'51' %or (ROUT=ARR=0 %and NAM=1 %and 0<TYPE<=3)
               %if rout#0 %Start
                  INC = RT PARAM SIZE
                  RL = ROUNDING LENGTH(RTPARAMPT,2)
               %finish %else %if ARR=1 %then %start
                  INC = AHEADSIZE;
                  RL = ROUNDING LENGTH(AHEADPT,2)
               %finish %else %if NAM=1 %then %start
                  INC = PTRSIZE(PTYPE&X'7F')
                  RL = PTRROUNDING(PTYPE&X'7F'+256)
               %finish %else %if STRVALINWA=YES %and PTYPE=X'35' %then %start
                  INC = PTRSIZE(X'35')
                  RL = PTRROUNDING(256+X'35')
               %finish %else %if RECVALINWA=YES %and PTYPE=X'33' %then %start
                  INC = PTRSIZE(X'33')
                  RL = PTRROUNDING(256+X'33')
              %finish %else %if TARGET=EMAS %and PTYPE=X'33' %then %start
                  INC = ACC+8;           ! ALLOW FOR DESCRPTR FOR IMP80%c
                                         COMPATABILITY
                  RL = 3;                ! STRICTLY ROUNDING LENGTH(X'33',2)
               %finish %else INC = ACC %and RL = ROUNDING LENGTH(PTYPE,2)
               %until A(P-1)=2 %cycle;   ! DOWN <NAMELIST> FOR EACH DEL
                  %if PARAMS BWARDS=YES %then %start
                     PUSH(OPHEAD,0,0,RL)
                     CELL = OPHEAD
                  %finish %else %start
                     BINSERT(OPHEAD,OPBOT,0,0,RL)
                     CELL = OPBOT
                  %finish
                  LCELL == ASLIST(CELL)
                  LCELL_PTYPE <- PTYPE;  ! DIRECT "PUSH" FAILS ON HALF SWOPPED%c
                                         MACHINES
                  LCELL_SNDISP = INC
                  LCELL_ACC <- ACC
                  NPARMS = NPARMS+1
                  P = P+3
               %repeat
               P = PP
            %repeat
            OPBOT = OPHEAD; INC = 0; RL=0;! FURTHER PASS TO ALLOCATE SPACE
            %while OPBOT>0 %cycle
               LCELL == ASLIST(OPBOT)
               RL = LCELL_S3; LCELL_S3 = 0;  ! EXTRACT ROUNDIMG LENGTH
               RSIZE = LCELL_SNDISP;     ! INC EXTRACTED
               INC = (INC+RL+SFRAME MISALIGN)&(\RL)-SFRAME MISALIGN
               %if PARAMSBWARDS=NO %and RSIZE<MINPARAMSIZE %and %c
                  LCELL_PTYPE&7<=2 %then INC = INC+MINPARAMSIZE-RSIZE
                                         ! MAINTAIN BYTES &SHORTS IN BTM
                                         ! OF WORDS FOR 2900&IBM ARCHITECTURE
               LCELL_SNDISP <- INC;      ! THE PARAMETER OFFSET
               INC = INC+RSIZE
               OPBOT = LCELL_LINK
            %repeat
            INC = (INC+RL+SFRAME MISALIGN)&(\RL)-SFRAME MISALIGN
            P = P+1
            PRINT LIST(OPHEAD) %if PARM_Z#0
            %if TARGET=PNX %and INC&7#0 %start;  ! FUNNY STACK RULES ON PNX
               INC = INC+4
               OPBOT = OPHEAD
               %while OPBOT#0 %cycle
                  LCELL == ASLIST(OPBOT)
                  LCELL_SNDISP = LCELL_SNDISP+4
                  OPBOT = LCELL_LINK
               %repeat
            %finish
            %if target=gould %and inc>currinf_maxpp %then currinf_maxpp = inc
            PP = INC<<16!NPARMS
            %if (TARGET=IBM %or TARGET=IBMXA %or TARGET=AMDAHL) %then %c
               PP = PP!PSIMPLE<<15
            %if NPARMS>0 %then ASLIST(OPHEAD)_S3 = PP
            PRINTLIST(OPHEAD) %if PARM_Z#0
         %end
         %routine CFPDEL
!***********************************************************************
!*    SET UP PTYPE & ACC FOR A FORMAL PARAMETER DEFINITION             *
!*    P<FPDEL>=<TYPE><%qname'>,                                        *
!*             (RT)(%name')(NAMELIST)(FPP),                            *
!*             '%NAME'.                                                *
!***********************************************************************
            %switch FP(1:3)
            %integer FPALT
            FPALT = A(P); P = P+1
            KFORM = 0; LITL = 0
            ->FP(FPALT)
FP(1):                                   ! (TYPE)(%qname')
            ROUT = 0; CLT
            CQN(P)
            %if TYPE=5 %and NAM=0 %and (ACC<=0 %or ACC>256) %then %c
               FAULT(70,ACC-1,0) %and ACC = 255
            P = P+1
            ->PK
FP(2):                                   ! (RT)(%name')(NAMELIST)(FPP)
            ROUT = 1; NAM = 1
            ARR = 0
            %if A(P)=1 %then %start;     ! RT=%rouitne
               TYPE = 0; PREC = 0
               P = P+2
            %finish %else %start
               P = P+1; CLT;             ! RT=(TYPE)(FM)
               NAM = 1
               %if A(P)=2 %then NAM = 3;  ! 1 FOR FN 3 FOR MAP
               P = P+2;                  ! PAST (%name') WHICH IS IGNORED
            %finish
            ACC = RT PARAM SIZE
            ->PK
FP(3):                                   ! %name
            ACC = PTRSIZE(0); NAM = 1
            ROUT = 0; TYPE = 0
            ARR = 0; PREC = 0
PK:         PACK(PTYPE)
         %end
         %routine RHEAD(%integer RTNAME,AXNAME,Xtra)
!***********************************************************************
!*       COMPILES CODE FOR BLOCK AND ROUTINE ENTRY                     *
!*       RTNAME IS THE RT/FN/MAP NAME (=-1 FOR %begin BLOCKS)          *
!*       XNAME IS THE EXTERNAL NAME (="" FOR INTERNALS&BLOCKS          *
!*       ACTIONS INCLUDE PLANTING JUMPS ROUND RT BODY AND              *
!*       DEFINING EXTERNAL ENTRIES AS WELL AS PLANTING ENTRY CODE      *
!***********************************************************************
            %integer W3,Flags
            %record (LISTF) %name LCELL
            Flags=0
            %if Xtra#0 %then flags=Bstruct
            CURRINF_SNMAX = NMAX; CURRINF_SN = N
            %if RTNAME>=0 %then %start;  ! SECTION FOR ROUTINES
               LCELL == ASLIST(TAGS(RTNAME))
!
! FIRST JUMP ROUND BODY UNLESS AT TOP LEVEL OR IN COMPILER
! OR A JUMP IS ALREADY OUTSTANDING AT THIS LEVEL
! MUST DO THIS HERE BEFORE LEVEL IS CHANGED OR LABEL LIST IS WRONG
!
               %if PARM_COMPILER=0 %and LEVEL>1 %and CURRINF_JROUND=0 %start
                  PLABEL = PLABEL-1
                  CURRINF_JROUND = PLABEL
                  %if JRNDBODIES=YES %then ENTER JUMP(15,PLABEL,0)
               %finish
               RLEVEL = RLEVEL+1; RBASE = RLEVEL
            %finish
            LEVEL = LEVEL+1
            CURRINF == LEVELINF(LEVEL)
            CURRINF = 0
            CURRINF_RBASE = RBASE
            CURRINF_CLEVEL = LEVEL;      ! SELF POINTER IS NEEDED IN GENERATE
            CURRINF_NAMES = -1
            CURRINF_DIAGINF = LEVELINF(LEVEL-1)_DIAGINF
            %if target=gould %then currinf_maxpp = levelinf(level-1)_maxpp
            CURRINF_DISPLAY = LEVELINF(LEVEL-1)_DISPLAY
            FAULT(34,0,0) %if LEVEL=MAX LEVELS
            FAULT(105,0,0) %if LEVEL>MAX LEVELS
!
! DEAL WITH EXTERNAL ENTRIES SO THAT THEY COME TO THIS POINT
! IN THE CODE. THE DESCRIPTORS SET UP ARE OF NO INTEREST TO THIS MODULE
! ONLY TO OTHER MODULES SO NO DETAILS OF THEN ARE RECORDED IN TAGS
!
            %if RTNAME<0 %then W3 = 0 %else W3 = RTNAME+1
            CURRINF_L = LINE; CURRINF_M = W3
            CURRINF_FLAG = PTYPE&X'FFFF';  ! CURRENT BLOCK TYPE MARKER
                                         ! SIGN MUST NOT PROPOGATE
!
! TILL LOADER COPIES GLAP TO GLA MUST CALL A FRIG ROUTINE TO DO
! THIS ESSENTIAL AS SOON AS POSSIBLE IN ANYTHING EXTERNAL
!
            W3 = ULCONSTTRIP(RTHD,X'61',Flags,RTNAME,AXNAME)
         %end
         %routine RDISPLAY(%integer KK)
!***********************************************************************
!*       SET UP OR COPY THE DISPLAY                                    *
!*       SINCE THIS IS IN REGISTERS ON 360 IT IS EASY                  *
!*       ALSO CLAIM STACK SPACE AND SET DIAGNOSTIC POINTERS            *
!***********************************************************************
            %integer TRIPNO
            %if KK>=0 %or LEVEL=2 %start;  ! DISPLAY NEEDED
                                         ! DONE BY THE QCODE CALL
               CURRINF_PSIZE = N-alpha;  ! REMEMBER PARAMETER SIZE FOR RTDICT
               %if 1<<target&riskmc#0 %then N=(N+display rounding)&(\display rounding)
               CURRINF_DISPLAY = N
               %if DISPLAY NEEDED=YES %start
                  N = N+DISPLAY C1*RLEVEL+DISPLAY C0;  ! RESERVE DISPLAY SPACE
               %finish
               TRIPNO = UCONSTTRIP(RDSPY,X'51',0,CURRINF_DISPLAY)
            %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 PARM_TRACE#0 %start
               %if KK>=0 %or LEVEL=2 %start;  ! ROUTINE NEW AREA NEEDED
                  %if target=vns %then %c
                     currinf_diaginf = currinf_psize+8 %else %start
                     TRIPNO = UCONSTTRIP(RDAREA,X'51',0,N)
                     N = N+4
                     N = N+4 %if 1<<Target & Riskmc#0;! extra word here on risks
                     CURRINF_DIAGINF = N
                     N = N+4
!
! For risk and some others it is better to use words for line & diag pointers
! if half word access is slow.
!
                     %if target=ORN %or 1<<target&riskmc#0 %then N=N+4
                  %finish
               %finish
               TRIPNO = UCONSTTRIP(RDPTR,X'51',0,LEVEL)
            %finish
            OLDLINE = 0
            SET LINE
!
! NORMALLY CODE IS PLANTED HERE TO CHECK PARAMETERS BUT I CANNOT
! SEE HOW TO DO THIS ON PERQ ARCHITECTURE. IT MAY BE IN THE QCODE ANYHOW
!
!
! CLAIM (THE REST OF) THE STACK FRAME
!
            %if KK>=0 %or LEVEL=2 %start
               NMAX = N
            %finish
         %end
         %routine CUI(%integer CODE)
!***********************************************************************
!*       COMPILE AN UNCONDITIONAL INSTRN WHEREEVER IT OCCURS           *
!*       CODE=0 UNCONDITIOALLY,=1 AFTER %then, =2 AFTER %else          *
!***********************************************************************
            %integer PT,MARKER,J,LNAME,TYPEP,PRECP,ALT,KK
            %record (RD) OPND1
            %integer HEAD1,BOT1,NOPS
            %record (RD) RPOP
            %switch SW(1:9)
            REPORTUI = 0
            ALT = A(P)
            ->SW(ALT)
SW(1):                                   ! (NAME)(APP)(ASSMNT?)
            P = P+1; MARKER = P+FROMAR2(P)
            %if A(MARKER)=1 %then %start
               J = P+2; P = MARKER+2
               ASSIGN(A(MARKER+1),J)
            %finish %else %start
               P = P+2
               CNAME(0)
               P = P+1
            %finish
AUI:        J = A(P); P = P+1
            %if J=1 %then CUI(CODE)
            %return
SW(2):                                   ! -> (NAME)(APP)
            CURRINF_NMDECS = CURRINF_NMDECS!1
            CURR INST = 1 %if CODE=0
            LNAME = FROM AR2(P+1)
            J = A(P+3); P = P+4
            %if J=2 %then %start;        ! SIMPLE LABEL
               ENTER JUMP(15,LNAME,0)
               REPORTUI = 1
            %finish %else %start;        ! SWITCH LABELS
               COPY TAG(LNAME,NO)
               %unless OLDI=LEVEL %and TYPE=6 %start
                  FAULT(4,0,LNAME); P = P-1; SKIP APP
                  %return
               %finish
               CSEXP(MINAPT)
               OPND1 = 0
               OPND1_PTYPE <- PTYPE; OPND1_FLAG = DNAME
               OPND1_D = LNAME
               KK = BRECTRIP(GOTOSW,PTYPE,0,OPND1,EXPOPND)
               REPORTUI = 1
            %finish
            %return
SW(3):                                   ! RETURN
            FAULT(30,0,0) %unless CURRINF_FLAG&X'3FFF'=X'1000'
            P = P+1
RET:        KK = UCONSTTRIP(RTXIT,X'51',0,0)
            REPORT UI = 1
            CURR INST = 1 %if CODE=0
            %return
SW(4):                                   ! %result(ASSOP)(EXPR)
            PTYPE = CURRINF_FLAG&X'3FFF'; UNPACK
            PT=ptype&255
            OPND1 = 0
            OPND1_PTYPE <- PTYPE; OPND1_FLAG = DNAME
            OPND1_D = CURRINF_M-1
            %if PTYPE>X'1000' %and A(P+1)#3 %then %start;  ! ASSOP #'->'
               %if A(P+1)=1 %and NAM#0 %and A(P+5)=4 %and A(P+6)=1 %start
                  P = P+7; TYPEP = TYPE; PRECP = PREC; J = P
                  CNAME(4)
                  KK = BRECTRIP(MAPRES,PTYPE&255,0,OPND1,NAMEOPND)
                  FAULT(81,0,0) %unless A(P)=2; P = P+1
                  FAULT(83,CURRINF_M-1,FROMAR2(J)) %unless %c
                     TYPEP=TYPE %and PRECP=PREC
                  ->RET
               %finish
               %if A(P+1)=2 %and NAM=0 %then %start;  ! ASSOP='='
                  P = P+2
                  %if TYPE=5 %then %start
                     CSTREXP(32);        ! FULL VIRTAD
                  %finish %else %if TYPE=3 %start
                     ->BAD RES %unless A(P+3)=4 %and A(P+4)=1
                     P = P+5
                     CNAME(3)
                     FAULT(66,0,OPND1_D) %unless TYPE=3
                     EXPOPND = NAMEOPND
                  %finish %else %start
                     %if PREC<4 %then PREC = 4
                     CSEXP(PREC<<4!TYPE)
                  %finish
                  %if PT=X'31' %or PT=X'41' %Start
                     kk=urectrip(SHRTN,PT,0,expopnd)
                     expopnd_flag=reftrip; expopnd_d=kk
                     expopnd_ptype=PT
                  %finish
                  KK = BRECTRIP(FNRES,PTYPE&255,0,OPND1,EXPOPND)
                  ->RET
               %finish
            %finish
            P = P+2
BAD RES:
            FAULT(31,0,0)
            SKIP EXP;                    ! IGNORE SPURIOUS RESULT
            %return
SW(5):                                   ! %monitor (AUI)
            KK = UCONSTTRIP(MNITR,X'51',0,0)
            P = P+1; ->AUI
SW(6):                                   ! %stop
            KK = UCONSTTRIP(XSTOP,X'51',0,0)
            P = P+1
            CURR INST = 1 %if CODE=0
            REPORTUI = 1
            %return
SW(7):                                   !'%SIGNAL'(EVENT')(N)(OPEXPR)
            P = P+5
            KK = INTEXP(J,MINAPT);       ! EVENT NO TO J
            FAULT(26,J,0) %unless KK=0 %and 1<=J<=15
            HEAD1 = 0; NOPS = 0
            RPOP = 0
            RPOP_PTYPE = X'51'
            RPOP_FLAG = 1
            RPOP_D = 256*J
            PUSH(HEAD1,RPOP_S1,RPOP_D,0);  ! EVENT<<8 AS CONST
            BOT1 = HEAD1
            %if A(P)=1 %start;           ! SUBEVENT SPECIFIED
               RPOP = 0; RPOP_FLAG = ANDL
               PUSH(HEAD1,RPOP_S1,0,0);  ! OPERATOR &
               RPOP_PTYPE = X'51'
               RPOP_FLAG = 1
               RPOP_D = 255
               PUSH(HEAD1,RPOP_S1,RPOP_D,0);  ! CONST=F'255'
               P = P+4; TORP(HEAD1,BOT1,NOPS)
               RPOP = 0; RPOP_FLAG = ORL
               BINSERT(HEAD1,BOT1,RPOP_S1,0,0);  ! OPERATOR !
               NOPS = NOPS+2
            %finish
            EXPOP(HEAD1,BOT1,NOPS,X'51')
            OPND1_PTYPE = X'51'; OPND1_FLAG = SCONST
            OPND1_D = LEVEL; OPND1_XTRA=0
            %if CURRINF_NMDECS&16#0 %start;  ! IN AN 'ON' GROUP
               OPND1_D = LEVEL-1;        ! SIGNAL 1 LEVEL UP
            %finish
            KK = BRECTRIP(SIGEV,X'51',DONTOPT,OPND1,EXPOPND)
            CURR INST = 1 %if CODE=0
            REPORTUI = 1; %return
SW(8):                                   ! %exit
SW(9):                                   ! %continue
            ALT = ALT&7;                 ! 0 FOR EXIT 1 FOR CONTINUE
            %if currinf_EXITLAB=0 %then FAULT(54+ALT,0,0) %and %return
            %if ALT=0 %then KK = currinf_EXITLAB %else KK = currinf_CONTLAB
            ENTER JUMP(15,KK,B'10')
            REPORTUI = 1
            CURR INST = 1 %if CODE=0
         %end
         %routine CIFTHEN(%integer MARKIU,MARKC,MARKUI,MARKE,MARKR,SKIP)
!***********************************************************************
!*    THIS ROUTINE COMPILES CONDITIONAL EXPRESSIONS.IT REQUIRES THE    *
!*    FOLLOWING PARAMETERS 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)   - =0 FOR BACKWARDS CONDITION   *
!***********************************************************************
            %integer ALTUI,CCRES,ELRES,THENLAB,ELSELAB,USERLAB,REPORT,START,
               ELSEALT,K,J,CS,LINETRIP
            %const %integer NULL ELSE=4
            %switch ESW(1:NULL ELSE)


            REPORT=0;
            LINETRIP = -1
            SET LINE %and LINETRIP = TRIPLES(0)_BLINK %unless SKIP=YES
            MARKIU = A(MARKIU);          ! ALT OF IU 1=%if,2=%unless
            PLABEL = PLABEL-1
            THENLAB = PLABEL
            START = 0; CS = 0;           ! NO START IN CONDITION YET
            CS = 1 %if STARSIZE>100;     ! LONG JUMPS FOR COMPLEX STMTS
            ELSELAB = 0;                 ! MEANS NO ELSE CLAUSE
            P = MARKC
            %if MARKR>0 %and A(MARKR)<=2 %then %c
               START = 1 %and CS = CHECK BLOCK(MARKR+1,MARKC)
! '%START' OR '%THENSTART'
            %if MARKE#0 %and LEVEL<2 %and START=0 %then FAULT(57,0,0)
            USERLAB = -1
            %if START#0 %then ALTUI = 0 %else ALTUI = A(MARKUI)
            %if ALTUI=2 %and A(MARKUI+3)=2 %then USERLAB = FROM AR2(MARKUI+1)
                                         ! UI = SIMPLE LABEL
            %if 8<=ALTUI<=9 %and currinf_EXITLAB#0 %start;  ! VALID EXIT
               %if ALTUI=8 %then USERLAB = currinf_EXITLAB %else %c
                  USERLAB = currinf_CONTLAB
            %finish
!
            %if SKIP=YES %then %start;   ! NO CODE NEEDED
               %if START#0 %start
                  P = MARKR+1
                  CSTART(2,1);           ! NO CODE
                  MARKE = P
               %finish
               CCRES = 1;                ! NO CODE FOR ELSE
               ->ELSE
            %finish
!
            %if USERLAB>=0 %then %start;  ! FIRST UI IS'->'<LABEL>
               CURRINF_NMDECS = CURRINF_NMDECS!1
               CCRES = CCOND(0,3-MARKIU,USERLAB,2);  ! merge not short for%c
                                                     exit & continue
                                         ! merge deleted for genuine gotos
               %if CCRES#0 %then CCRES = CCRES!!3;  ! CONDITION BACKWARDS!
               THENLAB = 0;              ! NO THENLAB IN THIS CASE
               REPORT = 1;               ! UI TRANSFERED CONTROL
            %finish %else %start
               CCRES = CCOND(1,MARKIU,THENLAB,B'11'!!START!!CS)
               %if START#0 %then %start;  ! %then %start
                  %if CCRES=0 %start;    ! CONDITIONAL
                     FAULT(57,0,0) %if LEVEL<2
                     CURRINF_NMDECS = CURRINF_NMDECS!1
                  %finish %else %start
                                         ! DELETE LINE NO UPDATE FOR%c
                                         CONDITIONAL STARTR
                                         ! (IT MIGHT CONTAIN M-C CODE!)
                     %if LINE TRIP>0 %then TRIPLES(LINETRIP)_OPERN = NULLT
                  %finish
                  P = MARKR+1
                  CSTART(CCRES,1)
                  %if A(P)<=2 %then PLABEL = PLABEL-1 %and ELSELAB = PLABEL
                  MARKE = P
                  REPORT = LAST INST
               %finish %else %start
                  %if CCRES#2 %start
                     P = MARKUI; CUI(1)
                     REPORT = REPORTUI
                  %finish %else %start;  ! FIRST UI NEVER EXECUTED
                     REPORT = 1
                  %finish
               %finish
            %finish
ELSE:                                    ! ELSE PART
            %if MARKE=0 %then ELSEALT = NULL ELSE %else ELSEALT = A(MARKE)
            %if ELSEALT<NULL ELSE %then PLABEL = PLABEL-1 %and ELSELAB = PLABEL
            P = MARKE+1
            %if REPORT=0=CCRES %and ELSEALT<NULL ELSE %then %start
               REPORT = 1
               K = B'10'
               %if (ELSEALT=3 %and STARSIZE<100) %or (ELSEALT=1 %and %c
                  CHECK BLOCK(P,P)#0) %then K = B'11'
               ENTER JUMP(15,ELSELAB,K);  ! LONG(?) JUMP BUT SAVE ENV
            %finish
            %if THENLAB>0 %then ELRES = ENTER LAB(THENLAB,B'11'!REPORT<<2)
                                         ! CONDITIONAL&MERGE OR REPLACE
            ->ESW(ELSEALT)
ESW(1):                                  ! '%ELSESTART'
            %if CCRES=0 %then CURRINF_NMDECS = CURRINF_NMDECS!1
            CSTART(CCRES,2)
            REPORT = LAST INST
            ->ENTER ELSELAB
ESW(2):                                  ! '%ELSE' (%iu) ETC
            MARKE = 0; MARKUI = 0
            MARKR = P+1+FROMAR2(P+1)
            %if A(MARKR)=3 %then %start
               MARKE = MARKR+1+FROM AR2(MARKR+1)
               MARKUI = MARKR+3
            %finish
            %if CCRES=1 %or SKIP=YES %then K = YES %else K = NO
            J = NEXT TRIP
            CIFTHEN(P,P+3,MARKUI,MARKE,MARKR,K)
            %if START=0 %and TRIPLES(J)_OPERN=SLINE %then %c
               TRIPLES(J)_OPERN = NULLT
                                         ! Delete unnecessary line update
            REPORT = 0;                  ! CANT TELL IN GENERAL
            ->ENTER ELSELAB
ESW(3):                                  ! '%ELSE'<UI>
            %if CCRES#1 %then %start
               %if START#0 %then SET LINE;  ! FOR CORRECT LINE IF FAILS IN UI
               %if THENLAB=0 %then K = 0 %else K = 2
               CUI(K)
               REPORT = REPORTUI
            %finish
ENTER ELSELAB:
            %if ELSELAB>0 %then ELRES = ENTER LAB(ELSELAB,B'11'!REPORT<<2)
                                         ! CONDITIONAL MERGE
ESW(NULL ELSE):                          ! NULL ELSE CLAUSE
         %end
         %integer %fn CHECKBLOCK(%integer P,PIN)
!***********************************************************************
!*    WORK OUT IF START-FINISH OR CYCLE REPEAT IS SHORT ENOUGH TO      *
!*    MANAGE WITH BYTE JUMP. PIN ALLOWS THE CONDITION TO BE INCLUDED   *
!*    IN THE TEST WHERE RELEVANT.                                      *
!***********************************************************************
            %integer SIZE
            SIZE = FROMAR4(P)-PIN
            %if SIZE<64 %or (PARM_OPT=0 %and SIZE<128) %then %result = 1
            %result = 0
         %end
         %routine CSTART(%integer CCRES,CODE)
!***********************************************************************
!*    COMPILE A COMPLETE START-FINISH BLOCK BY RECURSION               *
!*    IF START NEVER EXECUTED SKIP TO CORRESPONDING FINISH             *
!*    CODE=0 WAS UNCONDITIONAL NOW SHOULD BE UNUSED                    *
!*    CODE=1 AFTER THEN                                                *
!*    CODE=2 AFTER ELSE                                                *
!*    CODE=3 AFTER ONEVENT                                             *
!*    P ON ENTRY TO FORWARD POINTER TO THE RIGHT FINISH                *
!*    P ON EXIT TO THE ELSE CLAUSE AFTER THE RIGHT FINISH              *
!***********************************************************************
            %integer SKIPCODE,FINISHAR,OLDNEXTP,OLDLINE
            SKIPCODE = NO
            %if 1<=CODE<=2 %and CCRES!CODE=3 %then SKIPCODE = YES
                                         ! NEVER EXECUTED
            FINISHAR = FROMAR4(P);       ! TO START OF AR FOR FINISH
            %if FINISHAR<=P %then IMPABORT;  ! FOR TESTING
            OLDLINE = LINE;              ! FOR ERROR MESSAGES
            %cycle;                      ! THROUGH INTERVENING STATMNTS
               OLDNEXTP = NEXTP
               %if SKIP CODE=NO %then COMPILE A STMNT %else %start
                  LINE = A(NEXTP+3)<<8!A(NEXTP+4)
                  STARSIZE = A(NEXTP)<<16+A(NEXTP+1)<<8+A(NEXTP+2)
                  NEXTP = NEXTP+STARSIZE
               %finish
            %repeat %until OLDNEXTP>=FINISHAR;  ! HAVING COMPILED FINISH
            P = FINISHAR+6;              ! TO ELSE CLAUSE
!
            %if A(P)<=3 %and CODE#1 %then FAULT(45+CODE,OLDLINE,0)
            %if SKIPCODE=YES %then LAST INST = 1
         %end
         %routine CCYCBODY(%integer UA,ELAB,CLAB)
!***********************************************************************
!*    COMPILES A CYCLE REPEAT BODY BY RECURSION                        *
!*    ON ENTRY P IS TO FORWARD POINTER. ON EXIT TO ALT OF UNTIL        *
!*    UA = O IF UNTIL NOT ALLOWED                                      *
!*    ELAB&CLAB ARE LABELS FOR ELSE & CONTINUE                         *
!***********************************************************************
            %integer FINISHAR,OLDLINE,SAVEE,SAVEC
            FINISHAR = FROMAR4(P)
            %if FINISHAR<=P %then IMPABORT
            FORDPTH = FORDPTH+1
            OLDLINE = LINE; SAVEE = currinf_EXITLAB; SAVEC = currinf_CONTLAB
            currinf_EXITLAB = ELAB; currinf_CONTLAB = CLAB
            %while NEXTP<=FINISHAR %cycle
               COMPILE A STMNT
            %repeat
            currinf_EXITLAB = SAVEE; currinf_CONTLAB = SAVEC
            P = FINISHAR+6
            FORDPTH = FORDPTH-1
            %if A(P)=1 %and UA=0 %then FAULT(12,OLDLINE,0)
         %end

         %routine CLOOP(%integer ALT,MARKC,MARKUI)
!***********************************************************************
!*    ALT=1 FOR %while, =2 FOR %until, =3 FOR %for                     *
!*    MARKC IS TO THE CONDITION OR CONTROL CLAUSE                      *
!*    MARKUI IS TO THE UI, SPECIAL FOR %cycle                          *
!*    FORBITS DEFINES FOR LOOP AS FOLLOWS:-                            *
!*    2**2 TO 2**0 SET FOR CONSTANT INITIAL,INC &FINAL                 *
!*    CORRESPONDING UPPER BYTE SET DEFINES CONSTANT FURTHER            *
!*       2**7 NEGATIVE CONSTANT                                        *
!*       2**4 CONSTANT IS 2                                            *
!*       2**3 CONSTANT IS 1                                            *
!*       2**2 CONSTANT IS 0                                            *
!*       2**1 CONSTANT IS -1                                           *
!*       2**0 CONSTANT IS -2                                           *
!*    THESE BITS ARE PASSED ON TO GENERATOR FOR SPECIAL CASE           *
!***********************************************************************
            %integer L1,L2,L3,L4,CCRES,ELRES,FLINE,TRIP,FOT,PP,DEBJ,JJ,FSTRIP
            %integer FORNAME,INITP,STEPP,REPMASK,FORPT,FORWORDS,FORBITS
            %record (RD) INITOPND,STEPOPND,FINALOPND,DIFFOPND,ZOPND,OPND
            %record (TRIPF) %name CURRT
            %routine %spec FOREXP(%record (RD) %name EOPND, %integer TT,SH)
            %routine %spec VALIDATE FOR
            %switch SW(0:6)


            INITOPND=0; STEPOPND=0; FINALOPND=0;
            DIFFOPND=0; ZOPND=0; OPND=0;
            P = MARKC
            FORBITS = 0
            SFLABEL = SFLABEL-2
            L1 = SFLABEL; L2 = L1+1
!
! SET L3 FOR ALTS 0,5&6 ONLY
!
            L3 = 0
            %if B'1100001'&1<<ALT#0 %then L3 = SFLABEL-1 %and SFLABEL = L3
!
! UPDATE THE LINE NUMBER FOR ALTS 1 TO 3 ONLY
!
            %if 1<=ALT<=3 %then SET LINE
!
! ENTER THE FIRST LABEL FOR ALL ALTS EXCEPT 3 & 6
!
            %if B'0110111'&1<<ALT#0 %then ELRES = ENTER LAB(L1,0)
            ->SW(ALT)
SW(0):                                   ! %cycle
            PP = FROM AR4(P)+6;          ! TO UNTIL CLAUSE IF ANY
            %if A(PP)=1 %start;          ! %repeat %until <COND>
               C CYC BODY(1,L2,L3)
               L3 = L3*ENTER LAB(L3,B'011');  ! DELETE IF NOT NEEDED
               SET LINE
               P = PP+1; CCRES = CCOND(0,1,L1,0)
            %finish %else %start
               C CYC BODY(1,L2,L1);      ! CONTINUES DIRECT TO TOP
               ENTER JUMP(15,L1,0)
            %finish
            L2 = L2*ENTER LAB(L2,B'011');  ! DELETE IF NOT NEEDED
WAYOUT:                                  ! REMOVE LABELS NOT REQUIRED
            REMOVE LAB(L1)
            %return
SW(1):                                   ! UI WHILE COND
            CCRES = CCOND(0,1,L2,B'11')
            P = MARKUI
            CUI(1)
            ENTER JUMP(15,L1,0);         ! UNCONDITIONALLY BACK TO WHILE
            L2 = L2*ENTER LAB(L2,B'111');  ! CONDITIONAL(?) & REPLACE ENV
            ->WAYOUT
SW(2):                                   ! UI %until COND
            P = MARKUI
            CUI(1)
            P = MARKC
            CCRES = CCOND(0,1,L1,0)
            ->WAYOUT
SW(6):                                   ! %for ... %cycle
SW(3):                                   ! UI %for ....
            DEBJ = 0;                    ! CANT USE DEBJ BCT OR EQUIVALENT
            FORCNT = FORCNT+1;           ! TO DETCT FORS IN ENCLOSED STMTS
            L4 = SFLABEL-1; SFLABEL = L4
            FORNAME = FROMAR2(P)
            INITP = P+2
            COPY TAG(FORNAME,YES);       ! DECLARE IF UNKNOWN TO COMPILER
            FAULT(91,0,FORNAME) %and ptype=X'51'  %unless %c
               (TYPE=7 %or TYPE=1) %and 4<=PREC<=5 %and ROUT=0=ARR %and LITL#1
            FOT = DNAME;                 ! FOR OPERAND TYPE
            %if NAM#0 %then FOT = INDNAME
            FORPT = PTYPE&255;           ! SAVE TYPE&PREC OF CONTROL
            FORWORDS = WORDS(FORPT>>4);  ! NO OF WORDS FOR TEMPS
            WARN(4,FORNAME) %unless I=RBASE
!
            P = INITP
            SKIP EXP;                    ! P TO STEP EXPRSN
            STEPP = P; SKIP EXP;         ! P TO FINAL
            FOR EXP(FINALOPND,1,0);      ! EVALUATE FINAL
!
            P = STEPP
            FOR EXP(STEPOPND,1,1);       ! STEP TO REG AND TEMP
            %if STEPOPND_FLAG=0 %start
               FAULT(92,0,0) %if STEPOPND_D=0;  ! ZERO STEP
            %finish %else %start
               %if PARM_OPT#0 %then %start
                  TRIP = URECTRIP(STPCK,FORPT,0,STEPOPND);  ! VALIDATE STEP
               %finish
            %finish
!
            P = INITP
            FOR EXP(INITOPND,0,2);       ! INITIAL VALUE TO ETOS
            %if PARM_OPT#0 %then VALIDATE FOR
!
            %if (TARGET=EMAS %or TARGET=IBM %or TARGET=IBMXA %or %c
               TARGET=AMDAHL) %and FORBITS&X'FFFF03'=X'820803' %then %c
               DEBJ = 48 {=?,-1,1}
            %if DEBJ=0 %start
               DIFFOPND_D = BRECTRIP(SUB,FORPT,0,INITOPND,STEPOPND)
               DIFFOPND_PTYPE = FORPT; DIFFOPND_FLAG = REFTRIP
            %finish %else DIFFOPND = INITOPND;  ! TEST DIRECTLY ON INIT WITH%c
                                                DIFFERENT MASK
!
! HAVE DIFFOPND SET TO INIT-STEP.  FOR COMPUTED STEPS NOW MUST CHECK
! FOR NEGATIVE TRAVERSES. FOR FIXED STEPS THIS CAN BE SET
! IN MASK FOR REPEATING
!
            %if STEPOPND_FLAG>0 %then %start
               OPND_D = BRECTRIP(SUB,FORPT,0,FINALOPND,DIFFOPND)
               OPND_PTYPE = FORPT; OPND_FLAG = REFTRIP
               OPND_D = BRECTRIP(INTDIV,FORPT,0,OPND,STEPOPND)
               ZOPND_D = 0; ZOPND_PTYPE = FORPT; ZOPND_FLAG = SCONST
               CURRT == TRIPLES(BRECTRIP(COMP,FORPT,0,OPND,ZOPND))
               CURRT_X1 = 4;             ! MASK FOR <0
               ENTER JUMP(4,L4,B'10')
               REPMASK = 8
            %finish %else %start
               %if STEPOPND_D>0 %then REPMASK = 10 %else REPMASK = 12
            %finish
!
            FSTRIP = URECTRIP(FORPRE,FORPT,0,DIFFOPND)
            DIFFOPND_PTYPE = FORPT; DIFFOPND_FLAG = REFTRIP
            TRIPLES(FSTRIP)_X1 = FORBITS
            DIFFOPND_D = FSTRIP
!
! MUST PREVENT OPTIMISING OF UNUSED STEP&FINAL TEMPORAIES IN
! REGISTERS ACCROSS THIS LABEL FOR REPEATING. THE OPTIMISING CAN
! BE REINSTATED BY NEXT PASS AFTER CHECKS
!
            %if STEPOPND_FLAG>1 %start;  ! NOT A CONST
               CURRT == TRIPLES(STEPOPND_D)
               %if CURRT_PUSE=0 %then CURRT_FLAGS = CURRT_FLAGS!NOTINREG
            %finish

            %if FINALOPND_FLAG>1 %start;  ! NOT A CONST
               CURRT == TRIPLES(FINALOPND_D)
               %if CURRT_PUSE=0 %then CURRT_FLAGS = CURRT_FLAGS!NOTINREG
            %finish
            ELRES = ENTER LAB(L1,0) %if DEBJ=0;  ! LABEL FOR REPEATING
            DIFFOPND_D = URECTRIP(FORPR2,FORPT,USE ESTACK,DIFFOPND)
            TRIPLES(DIFFOPND_D)_X1 = FORBITS
!
            CURRT == TRIPLES(BRECTRIP(COMP,FORPT,0,DIFFOPND,FINALOPND))
            %if DEBJ#0 %then REPMASK = 4;  ! SPECIAL FOR TEST IN DEBJ
            CURRT_X1 = REPMASK
            ENTER JUMP(REPMASK,L4,B'10')
            %if DEBJ=0 %start
               OPND_D = BRECTRIP(ADD,FORPT,0,DIFFOPND,STEPOPND)
               OPND_PTYPE = FORPT; OPND_FLAG = REFTRIP
            %else
               OPND = DIFFOPND
               ELRES = ENTER LAB(L1,0)
            %finish
            ZOPND_PTYPE = FORPT; ZOPND_FLAG = FOT
            ZOPND_D = FORNAME
            ZOPND_XTRA = X'80000000'
            CURRT == TRIPLES(BRECTRIP(VASS,FORPT,0,ZOPND,OPND))
            CURRT_X1 = FORPT;            ! VASS USES THIS FIELD
!
            P = MARKUI;                  ! TO UI OR '%CYCLE'(HOLE)
            JJ = FORCNT<<20!FORCECNT
            %if ALT=3 %then %start;      ! DEAL WITH CONTROLLED STMNTS
               CUI(0)
            %finish %else %start
               CCYCBODY(0,L2,L3)
               L3 = L3*ENTER LAB(L3,B'011');  ! LABEL FOR CONTINUE
            %finish
            %unless JJ=FORCNT<<20!FORCECNT %then FSTRIP = -1
                                         ! SOMETHING NASTY IN LOOP
            TRIP = URECTRIP(FOREND,FORPT,0,ZOPND)
            TRIPLES(TRIP)_X1 = FORBITS
            %if DEBJ=0 %then JJ = 15 %else JJ = 48
            ENTER JUMP(JJ,L1,0)
            ELRES = ENTER LAB(L4,B'10')
            TRIP = UCONSTTRIP(FORPOST,FORPT,0,0)
            %if (TARGET=IBM %or TARGET=IBMXA %or TARGET=AMDAHL) %and %c
               FSTRIP>0 %then TRIPLES(FSTRIP)_PUSE = TRIP
                                         ! POINT FORPRE AT FORPOST FOR IBM ONLY
                                         ! THIS ENABLES LOOP OPTIMISING BY OPT
                                         ! PASS OR GENERATOR IF REQUIRED
            TRIPLES(TRIP)_X1 = FORBITS
            REMOVE LAB(L4)
            L2 = L2*ENTER LAB(L2,B'011');  ! exit lab MERGE ENV
            %if STEPOPND_FLAG>1 %then PUSH(TWSPHEAD,STEPOPND_XTRA,FORWORDS,0)
            %if FINALOPND_FLAG>1 %then PUSH(TWSPHEAD,FINALOPND_XTRA,FORWORDS,0)
                                         ! CAN NOT RETURN DIRECTLY
                                         ! AS THEY CAN BE USED IN OPTIMISING
            ->WAYOUT
SW(4):                                   ! %while COND %cycle
            SET LINE
            CCRES = CCOND(0,1,L2,2);     ! merge but not short
            C CYC BODY(0,L2,L1)
            ENTER JUMP(15,L1,0)
            L2 = L2*ENTER LAB(L2,B'111');  ! CONDITIONAL & REPLACE ENV
            ->WAYOUT
SW(5):                                   ! %until ... %cycle
                                         ! ALSO %cycle... %repeat %until
                                         ! MARKUI TO %cycle
            P = MARKUI
            FLINE = LINE
            C CYC BODY(0,L2,L3)
            P = MARKC; L3 = L3*ENTER LAB(L3,B'011');  ! CONTINUE LABEL IF%c
                                                      NEEDED
            LINE = FLINE; SET LINE
            CCRES = CCOND(0,1,L1,0)
            L2 = L2*ENTER LAB(L2,B'011')
            ->WAYOUT
            %routine FOR EXP(%record (RD) %name EOPND, %integer TOTEMP,SHIFT)
!***********************************************************************
!*    P INDEXES EXPRESSION.  IF CONST PUT INTO EVALUE OTHERWISE        *
!*    COMPILE TO ETOS AND STORE IN TEMP IF TOTEMP#0                    *
!***********************************************************************
               %integer INP,VAL,SUBBITS
               INP = P; P = P+3
               %if INTEXP(VAL,FORPT)=0 %and X'FFFF8000'<VAL<X'FFFF' %start
                  EOPND = EXPOPND;       ! EXPRESSION A LITERAL CONST
                  SUBBITS = 0
                  %if VAL<0 %then SUBBITS = X'80'
                  %if-2<=VAL<=2 %then SUBBITS = SUBBITS!(1<<(VAL+2))
                  SUBBITS = SUBBITS<<(8+8*SHIFT)
                  FORBITS = FORBITS!SUBBITS!1<<SHIFT
                  %return
               %finish
               EOPND = EXPOPND
               %if TOTEMP#0 %start
                  GET WSP(VAL,FORWORDS!X'80000000')
                  EOPND_PTYPE = FORPT; EOPND_FLAG = LOCALIR
                  EOPND_D = RBASE<<16!VAL; EOPND_XTRA = VAL
                  EOPND_D = BRECTRIP(LASS,FORPT,0,EOPND,EXPOPND)
                  EOPND_FLAG = REFTRIP
               %finish
            %end
            %routine VALIDATE FOR
!***********************************************************************
!*    INITIAL VALUE IN ETOS                                            *
!***********************************************************************
               %integer J
               %record (RD) OPND


               OPND=0
               %if INITOPND_FLAG!STEPOPND_FLAG!FINALOPND_FLAG=0 %start
                  J = FINALOPND_D-INITOPND_D;  ! ALL CONSTANT CAN CHECK NOW
                  %if STEPOPND_D=0 %or (J//STEPOPND_D)*STEPOPND_D#J %then %c
                     FAULT(93,0,0)
                  %return
               %finish
               %if STEPOPND_FLAG=0 %and IMOD(STEPOPND_D)=1 %then %return
!
! CHECK BY PLANTING CODE
!
               OPND_D = BRECTRIP(SUB,FORPT,0,FINALOPND,INITOPND)
               OPND_PTYPE = FORPT; OPND_FLAG = REFTRIP;
               J = BRECTRIP(FORCK,FORPT,0,OPND,STEPOPND)
            %end
         %end
         %routine ASSIGN(%integer ASSOP,P1)
!***********************************************************************
!*       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)                     *
!*                                                                     *
!*       P POINTS TO THE EXPRESSION. P1 TO THE NAME ON LHS             *
!***********************************************************************
            %integer Q,KK,TYPEP,PRECP,PTYPEP,JJJ,P2,JJ,B,HEAD2,BOT2,ACCP,
               II,HEAD1,NOPS,TPCELL,LVL,BOT1,LHNAME,RHNAME,a1,a2
            %record (LISTF) %name LHCELL
            %record (RD) OPND1,OPND2
            %switch SW(0:4);             ! TO SWITCH ON ASSOP
            P2 = P
            LHNAME = A(P1)<<8!A(P1+1)
            LHCELL == ASLIST(TAGS(LHNAME))
            P = P1; REDUCE TAG(NO);      ! LOOK AT LH SIDE
            PTYPEP = PTYPE; JJ = J
            KK = K; II = I; LVL = OLDI
            TPCELL = TCELL; ACCP = ACC
            P = P2; TYPEP = TYPE; PRECP = PREC;  ! SAVE USEFUL INFO FOR LATER
            ->SW(ASSOP)
SW(2):
SW(3):                                   ! ARITHMETIC ASSIGNMENTS
            %if TYPE=3 %then ->RECOP
            TYPE = 1 %unless TYPE=2 %or TYPE=5;  ! IN CASE OF RUBBISHY SUBNAMES
            ->ST %if TYPE=5;             ! LHS IS A STRING
BACK:       HEAD1 = 0; BOT1 = 0;         ! CLEAR TEMPORAYRY LIST HEADS
            HEAD2 = 0; BOT2 = 0
            TYPE = 1 %unless TYPE=2;     ! DEAL WITH UNSET NAMES
            TYPEP = TYPE
            NOPS = 1<<18+1
            PTYPE = PTYPEP; UNPACK
            %if LHSADDRFIRST=NO %or (NAM=0=ARR %and A(P1+2)=2=A(P1+3)) %start
                                         ! SCALAR
               OPND1 = 0
               OPND1_PTYPE <- PTYPE; OPND1_FLAG = ARNAME
               BINSERT(HEAD1,BOT1,OPND1_S1,P1,LHNAME)
            %finish %else %start
               P = P1; CNAME(3);         ! 32 BIT ADDR TO STACK
               BINSERT(HEAD1,BOT1,NAMEOPND_S1,NAMEOPND_D,NAMEOPND_XTRA)
            %finish
            P = P2+3
            TORP(HEAD2,BOT2,NOPS);       ! RHS TO REVERSE POLISH
            OPND2 = 0; OPND2_FLAG = VASS+ASSOP-2
            BINSERT(HEAD2,BOT2,OPND2_S1,LHNAME<<16!PTYPEP,0)
                                         ! = OR <-OPERATOR
            ASLIST(BOT1)_LINK = HEAD2
            HEAD2 = 0; BOT1 = BOT2
            PRINT LIST(HEAD1) %if PARM_Z#0
            EXPOP(HEAD1,BOT1,NOPS,256+PRECP<<4+TYPEP);  ! PLANT CODE
            %return
ST:                                      ! STRINGS
! two triples are provided for string assignment. Ths "SIMPLE" one is
! restricted to local scalars for backwards stack machines. On IBM and possble
! others later any string whose acc is known that does not involve a call is%c
simple
!
            %if assop=3 %and acc=256 %then warn(12,0) %and assop = 2
            p = p1
            %if (target=ibm %or target=ibmxa %or target=amdahl %or %c
               A(P1+2)=A(P1+3)=2) %and PTYPE=X'35' %and ASSOP=2 %then %c
               KK = STRASS2 %and CNAME(2) %else KK = STRASS1 %and CNAME(3)
            OPND1 = NAMEOPND
            P = P2; CSTREXP(32)
            %if ASSOP=3 %then KK = STRJT
            JJ = BRECTRIP(KK,X'35',0,OPND1,EXPOPND)
            %if kk=strass2 %then triples(jj)_x1 = accp
            %return
!
! THIS SECTION DEALS WITH OPERATIONS ON COMPLETE RECORDS
!
RECOP:                                   ! LHS IS RECORD WITHOUT SUBNAME
            Q = TSEXP(JJJ)
            %if Q=1 %and JJJ=0 %start;   ! CLEAR A RECORD TO ZERO
               P = P1; CNAME(3)
               OPND1 = NAMEOPND
               OPND2 = 0
               OPND2_PTYPE = X'51'; OPND2_FLAG = SCONST
              a1=0; a2=0;
            %finish %else %start
               ->BACK %unless TYPE=3 %and A(P2+3)=4 %and A(P2+4)=1
               P = P1; CNAME(3)
               OPND1 = NAMEOPND
               ACCP = ACC
               P = P2+5; CNAME(3)
               OPND2 = NAMEOPND
               %unless A(P)=2 %then FAULT(66,0,LHNAME) %and ->F00
               %if ASSOP=2 %and ACCP#ACC %then %c
                  FAULT(67,LHNAME,FROMAR2(P2+5)) %and ->F00
               %if ACCP>ACC %then ACCP = ACC
               a1=CHK REC ALIGN(p1)
               a2=CHK REC ALIGN(p2+5)
            %finish
            JJ = BRECTRIP(RECASS,X'33',0,OPND1,OPND2)
            %if accp=0 %then impabort
            %if a2<a1 %then a1=a2;          ! smallest
            TRIPLES(JJ)_X1 =a1<<24! ACCP
            P = P2; SKIP EXP
            %return
SW(4):                                   ! RESOLUTION
            P = P1; CNAME(2)
            P = P2;
            %if TYPE=5 %then CRES(0) %else %start
               SKIP EXP
               FAULT(71,0,LHNAME) %unless TYPE=7
            %finish
            %return
SW(1):                                   ! '==' AND %name PARAMETERS
            ->F81 %unless A(P2+3)=4 %and A(P2+4)=1
            FAULT(82,0,LHNAME) %and ->F00 %unless NAM=1 %and LITL#1
                                         ! ONLY NON-CONST POINTERS ON LHS OF==
            %if ARR=1 %then %start
               JJ = 11; KK = 12
               II = AHASS; B = AHEADPT
            %finish %else %start
               JJ = 6; KK = 3
               II = PTRAS; B = X'51'
               %if PTRSIZE(PTYPE&255)>4 %then B = X'61'
            %finish
            P = P1; CNAME(JJ)
            P = P2+5; OPND1 = NAMEOPND
            RHNAME = A(P)<<8!A(P+1)
            CNAME(KK);                   ! DESCRPTR FETCHED
            ->F81 %unless A(P)=2;        ! NO REST OF EXP ON RHS
            ->F83 %unless TYPE=TYPEP %and PREC=PRECP %and (ARR>0 %or II=PTRAS)
            ->F86 %unless OLDI<=LVL %or I=0 %or NAM#0
                                         ! GLOBAL == NONOWN LOCAL
            JJ = BRECTRIP(II,B,0,OPND1,NAMEOPND)
            P = P+1
            %return
F83:        FAULT(83,LHNAME,RHNAME); ->F00
F86:        FAULT(86,LHNAME,RHNAME); ->F00
F81:        FAULT(81,0,LHNAME)
F00:
            P = P2; SKIP EXP
         %end
         %routine CSEXP(%integer MODE)
!***********************************************************************
!*       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')*
!***********************************************************************
            %integer EXPHEAD,NOPS,EXPBOT
            EXPHEAD = 0; EXPBOT = 0
            NOPS = 0
            P = P+3
            TORP(EXPHEAD,EXPBOT,NOPS)
            EXPOP(EXPHEAD,EXPBOT,NOPS,MODE)
         %end
         %integer %fn CONSTEXP(%integer PRECTYPE)
!***********************************************************************
!*    COMPILES AN EXPRESSION WHICH SHOULD EVALUATE TO A CONSTANT OF    *
!*    TYPE 'PRECTYPE'. P AS FOR FN INTEXP.                             *
!***********************************************************************
            %integer EXPHEAD,EXPBOT,NOPS,RES
            EXPHEAD = 0; EXPBOT = 0; NOPS = 0; RES = 0
            TORP(EXPHEAD,EXPBOT,NOPS)
!      ->WAYOUT %unless NOPS&X'00040000'=0
            EXPOP(EXPHEAD,EXPBOT,NOPS,X'200'+PRECTYPE)
            ->WAYOUT %unless EXPOPND_FLAG<=1
            RES = ADDR(EXPOPND_D)
WAYOUT:
            %result = RES
         %end
         %integer %fn INTEXP(%integer %name VALUE, %integer PRECTYPE)
!***********************************************************************
!*    COMPILES AN EXPRESSION WHICH SHOULD EVALUATE TO A CONSTANT       *
!*    VALUE RETURNED IN VALUE. RESULT#0 IF FAILED TO EVALUATE          *
!*    IN THIS CASE RESULT IS IN ETOS. USED FOR BOUND CALCULATIONS      *
!*    P POINTS TO P(+') IN (+')(OPERNAD)(RESTOFEXPR)                   *
!***********************************************************************
            %integer EXPHEAD,EXPBOT,NOPS,CODE,SPTYPE,SACC
            EXPHEAD = 0; EXPBOT = 0; NOPS = 0; CODE = 0
            SPTYPE = PTYPE; SACC = ACC;  ! CALLED IN DECLARATIONS
            TORP(EXPHEAD,EXPBOT,NOPS)
            EXPOP(EXPHEAD,EXPBOT,NOPS,X'200'+PRECTYPE)
            CODE = 1 %unless EXPOPND_FLAG<=1 %and EXPOPND_PTYPE=PRECTYPE
            VALUE = EXPOPND_D
            ACC = SACC; PTYPE = SPTYPE
            UNPACK
            %result = CODE
         %end
         %routine TORP(%integer %name HEAD,BOT,NOPS)
!***********************************************************************
!*       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.                                              *
!*      N.B. AN INTEGER EXPRESSION IS A SPECIAL CASE OF A REAL EXPRSN  *
!*    THE TOP 20 BITS OF NOPS ARE USED TO RETURN DETAILS OF THE EXPR   *
!*    THESE BITS SIGNIFY AS FOLLOWS:-                                  *
!*    1<<17    CONTAINS VARIABLE OF MORE THAN 32 BITS                  *
!*    1<<18    NOT CONSTANT EXPRSSN IE CONTAINS AT LEAST 1 VARIABLE    *
!*    1<<19    COMPLEX IE CONTAINS FN CALL OR NEEDS DR TO EVALUATE     *
!***********************************************************************
            %switch OPERAND(1:3)
            %const %byte %integer %array PRECEDENCE(0:20)=0,3,3,4,5,5,4,3,3,4,4,5,5,3,5,5,
                                        0(3),3,5

            %const %byte %integer %array OPVAL(0:20)=0,ADD,SUB,ANDL,IEXP,REXP,MULT,NONEQ,
                  ORL,INTDIV,REALDIV,RSHIFT,LSHIFT,ADD,IEXP,REXP,0(3),LNEG,NOTL

            %integer RPHEAD,PASSHEAD,SAVEHEAD,REAL,REALOP,OPERATOR,OPPREC,
               OPND,C,D,E,BDISP,OPNAME,OPMASK,RPBOT,OPSTK,OPPSTK,PASSBOT
            %record (TAGF) %name LCELL
            %record (RD) RPOP
!
            RPOP=0
            PASSHEAD = 0; RPHEAD = 0; SAVEHEAD = 0
            REAL = 0; REALOP = 0; BDISP = 0
            RPBOT = 0; OPSTK = 0; OPPSTK = 0
!
            C = A(P)
            %if 2<=C<=3 %then %start;    ! INITIAL '-' OR '\'
               NOPS = NOPS+1
                                         ! '-' =(11,3)   '\' =(10,5)
               OPSTK = C+17
               OPPSTK = PRECEDENCE(OPSTK)
               OPMASK = 1<<(19+C);       ! - %or !!
            %finish %else OPMASK = 0
NEXTOPND:   OPND = A(P+1); P = P+2
            RPOP = 0
            ->OPERAND(OPND);             ! SWITCH ON OPERAND
OPERAND(1):                              ! NAME
            OPNAME = A(P)<<8+A(P+1)
            LCELL == ASLIST(TAGS(OPNAME))
            LCELL_UIOJ <- LCELL_UIOJ!X'8000';  ! SET USED BIT
            PTYPE = LCELL_PTYPE
            %if PTYPE=X'FFFF' %then PTYPE = X'57';  ! NAME NOT SET
            TYPE = PTYPE&7; PREC = PTYPE>>4&15
            %if PTYPE=SNPT %then PTYPE = LCELL_ACC %and UNPACK
            %if PTYPE&X'FF00'=X'4000' %and A(P+2)=2=A(P+3) %and %c
               1<=TYPE<=2 %then %start
                                         ! CONST VAR
               RPOP_D = LCELL_S2; RPOP_XTRA = LCELL_S3
               RPOP_FLAG = 1; PTYPE = PTYPE&255
               %if TYPE=1 %and PREC<=5 %and X'FFFF8000'<RPOP_D<=X'7FFF' %then %c
                  RPOP_FLAG = 0 %and PTYPE = MINAPT
               REAL = 1 %if TYPE=2
               P = P+2; ->SKNAM
            %finish
            RPOP_XTRA = OPNAME
            RPOP_FLAG = ARNAME; RPOP_D = P; PTYPE = X'51' %if PTYPE=X'57'
            %if TYPE=3 %then %start
               D = P; KFORM = LCELL_KFORM
               C = COPY RECORD TAG(E); P = D;
            %finish
            %if TYPE=5 %then FAULT(76,0,OPNAME) %and RPOP_FLAG = 0 %and %c
               PTYPE = X'51'
            %if PREC>=6 %then OPMASK = OPMASK!1<<17;  ! MORE THAN 32 BITS
            %if TYPE=2 %then REAL = 1
            P = P+2
SKNAM:      %if A(P)=2 %then P = P+1 %else SKIP APP
            %if A(P)=1 %then P = P+3 %and ->SKNAM
            P = P+2
INS:        %if RPOP_FLAG=ARNAME %then OPMASK = OPMASK!1<<18
            %if PTYPE>>4&15>5 %then OPMASK = OPMASK!1<<17;  ! CONTINS LONG
            %if 3<=PTYPE&7<=7 %then PTYPE = X'51';  ! NOT SET TO INTEGER
            RPOP_PTYPE <- PTYPE
            BINSERT(RPHEAD,RPBOT,RPOP_S1,RPOP_D,RPOP_XTRA)
            ->OP
OPERAND(2):                              ! CONSTANT
            PTYPE = A(P); D = PTYPE>>4
            C = PTYPE&7
            %if (PTYPE=x'61' %and 1<<TARGET&LINTAVAIL=0) %or %c
               (D=7 %and c=2 %and 1<<TARGET&LLREALAVAIL=0) %then FAULT(99,0,0)
            %if D>=6 %then OPMASK = OPMASK!1<<17;  ! MORE THAN 32 BIT OPERAND
            %if D=4 %then %start
               RPOP_D = FROM AR2(P+1)
               PTYPE = X'51'
            %finish %else RPOP_D = FROM AR4(P+1)
            REAL = 1 %if C=2; RPOP_FLAG = 1
            %if D=6 %then RPOP_XTRA = FROM AR4(P+5)
            %if C=5 %then %start;        ! STRING CONSTANT
               FAULT(77,0,0); RPOP_D = 1; RPOP_FLAG = 0
               P = P+A(P+1)+3; PTYPE = X'51'
            %finish %else %start
               %if D=7 %then RPOP_XTRA = RPOP_D %and RPOP_D = P+1
               %if PTYPE=X'51' %and X'FFFF8000'<=RPOP_D<=X'7FFF' %then %c
                  RPOP_FLAG = 0 %and PTYPE = MINAPT
               P = P+2+BYTES(D)
            %finish; ->INS
OPERAND(3):                              ! SUB EXPRESSION
            PASSHEAD = 0; PASSBOT = 0
            P = P+3
            TORP(PASSHEAD,PASSBOT,NOPS)
            REAL = 1 %if TYPE=2
!         CONCAT(RPHEAD,PASSHEAD)
            %if RPBOT=0 %then RPHEAD = PASSHEAD %else %c
               ASLIST(RPBOT)_LINK = PASSHEAD
            RPBOT = PASSBOT
            P = P+1
OP:                                      ! DEAL WITH OPERATOR
            RPOP = 0
            ->EOE %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=CONCOP %then FAULT(78,0,0)
            OPPREC = PRECEDENCE(OPERATOR)
            C = OPVAL(OPERATOR)
            %if C=REALDIV %or C=REXP %then REAL = 1
            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
               RPOP_FLAG = OPVAL(OPSTK&31)
               BINSERT(RPHEAD,RPBOT,RPOP_S1,0,0)
               OPSTK = OPSTK>>5; OPPSTK = OPPSTK>>5
            %repeat
!
! THE CURRENT OPERATOR CAN NOW BE STORED
!
            OPSTK = OPSTK<<5!OPERATOR
            OPPSTK = OPPSTK<<5!OPPREC
            ->NEXTOPND
EOE:                                     ! END OF EXPRESSION
                                         ! EMPTY REMAINING OPERATORS
            %while OPSTK#0 %cycle
               RPOP_FLAG = OPVAL(OPSTK&31)
               BINSERT(RPHEAD,RPBOT,RPOP_S1,0,0)
               OPSTK = OPSTK>>5
            %repeat
            PTYPE = REAL+1
            TYPE = PTYPE
!         CONCAT(RPHEAD,HEAD)
            %if HEAD=0 %then BOT = RPBOT %else ASLIST(RPBOT)_LINK = HEAD
            HEAD = RPHEAD;               ! HEAD BACK TO TOP OF LIST
            NOPS = NOPS!OPMASK
         %end
         %routine EXPOP(%integer %name HEAD,BOT, %integer NOPS,MODE)
!***********************************************************************
!*    EVALUATE A LIST OF OPERAND AND'NOPS' OPERATORS AND LEAVE         *
!*    THE RESULT IN REG                                                *
!*    INHEAD HOLDS THE LIST THE BOTTOM BYTE OF STREAM 1 DEFINES THE    *
!*    ENTRY AS FOLLOWS:-                                               *
!*       0 = SHORT (INTEGER) CONSTANT <18 BITS --S2=CONSTANT           *
!*       1 = OTHER CONSTANT    S2 (+S3 IF NEEDED) = CONSTANT           *
!*       2 = VARIABLE S2 POINT TO AR ENTRY FOR NAME&SUBSCRIPTS         *
!*      (3 = DOPE VECTOR ITEM IF NEEDED)                               *
!*      (4 = CONDITONAL EXPRESSION AS IN ALGOL)                        *
!*       7 = INTERMEDIATE RESULT UNDER LNB  S2=DISPLCMNT FROM LNB      *
!*       8 = INTERMEDIATE RESULT STACKED                               *
!*       9 = INTERMEDIATE RESULT IN A REGISTER S2 = REG                *
!*                                                                     *
!*       10-19 = UNARY OPERATOR S2=OP S3 =EXTRA                        *
!*       20 UP = BINARY OPERATOR                                       *
!*                                                                     *
!*       MODE HAS TYPE & PREC REQD +256 BIT IF NO RESULT REQD          *
!***********************************************************************
            %routine %spec PSEVAL
!
            %integer %array OPERAND(0:2),STK(0:99)
            %record (LISTF) %name LIST
            %record (RD) %name OPND1,OPND2,OPND
            %record (TRIPF) %name CURRT

!
            %integer C,D,KK,JJ,COMM,XTRA,INHEAD,CURR TRIP,STPTR,CONSTFORM,
               CONDFORM,SAVEP,INITTRIP
!
! CORULES GIVE INFORMATION ON OPERATORS.
!     BTM 4 BITS HAVE TYPE CONVERSION RULES(SEE COERCET)
!     NEXT 4 BITS HAVE PREC RULES (SEE COERCEP)
!     2**8 SET IF COMMUTATIVE
!
            %const %half %integer %array CORULES(0:20)= %c
                                        X'1FF'{+},X'FF'{-},
                                        X'1F1'{!!},X'1F1'{!},
                                        X'1FF'{*},X'F1'{//},
                                        X'F2'{/},X'1F1'{&},X'71'{>>},
                                        X'71'{<<},X'43'{**},
                                        X'1FF'{COMP},X'FF'{DCOMP},
                                        X'21'{VMY},X'1F1'{COMB},
                                        X'14'{ASSIGN=},
                                        X'54'{ASSIGN<-},X'71'{****},
                                        X'01'{ARR BADJ},
                                        X'001'{ARR INDEX},
                                        X'100'{INDEXED FETCH}

            %const %integer %array PTYPECH(0:19)=0(12),X'11',0,-X'10',X'10',-X'10',0(3)


!
            STPTR = 0; CONSTFORM = MODE&512
            INITTRIP = NEXTTRIP
            CONDFORM = MODE&256
            SAVEP = P
            INHEAD = HEAD
            PSEVAL
NEXT:       LIST == ASLIST(INHEAD)
            XTRA = LIST_S2
            JJ = LIST_FLAG; D = INHEAD
            INHEAD = LIST_LINK
            ->OPERATOR %if JJ>=10
!
! ANY OPERAND WHICH MAY NEED DR OR B OR ACC IN THEIR EVALUATION
! EG FUNCTIONS,ARRAY ELEMENTS ETC ARE FETCHED AND STACKKED FIRST
!
            OPND1 == ASLIST(D)
            STK(STPTR) = D
            STPTR = STPTR+1
            IMPABORT %if STPTR>99
ANYMORE:
            ->NEXT %unless INHEAD=0
            OPND1 == ASLIST(STK(STPTR-1))
            EXPOPND = OPND1
            ->FINISH
OPERATOR:
            %if JJ<128 %then KK = 1 %else KK = 2;  ! UNARY OR BINARY
            %cycle KK = KK,-1,1
               STPTR = STPTR-1
               OPERAND(KK) = STK(STPTR)
            %repeat
            COMM = 1
            OPND1 == ASLIST(OPERAND(1))
            %if JJ>=128 %then %start
               OPND2 == ASLIST(OPERAND(2))

            %finish %else OPND2 == RECORD(0)
! next line must be wrong 32 is not dsided
!            %if JJ=32 %then COMM = 2;    ! DSIDED RESULT=2ND OPERAND
                                         ! ALL OTHERS RESULT=1ST OPERAND
            %if JJ<128 %then C = 0 %else C = CORULES(JJ-128)
            %if JJ=VASS %or JJ=VJASS %then KK = 1 %else KK = 2
                                         ! CNAME FETCH-STORE
            %if OPND1_FLAG=ARNAME %and (LHSADDRFIRST=YES %or KK=2) %start
                                         ! EXPAND UP NAMES BUT NOT LHS
                                         ! ASSIGNMENT NAMES
               P = OPND1_D; CNAME(KK)
               OPND1 = NAMEOPND
            %finish
            %if JJ>=128 %and OPND2_FLAG=ARNAME %then %start
               P = OPND2_D
               CNAME(2)
               OPND2 = NAMEOPND
            %finish
            %if OPND1_FLAG=ARNAME %then %start
               P = OPND1_D
               CNAME(KK)
               OPND1 = NAMEOPND
            %finish
            %if OPND1_FLAG<2 %and (JJ<128 %or OPND2_FLAG<2) %then %c
               CTOP(JJ,MASK,XTRA,OPND1,OPND2)
            %if JJ#0 %then %start;       ! CODE REQUIRED OP TRIPLE
               CURR TRIP = NEW TRIP
               CURRT == TRIPLES(CURR TRIP)
               CURRT_DPTH = 0;           ! LEAVE DEPTHS TO BE WORKED OUT IN%c
                                         OPT PASS
               CURRT_CNT = 0
               CURRT_FLAGS = 1!(C>>1&128)
               CURRT_OPERN = JJ
               CURRT_OPTYPE <- OPND1_PTYPE
               %if 12<=JJ<=16 %start;    ! UNARY(TYPECHANGE)OPN
                  CURRT_OPTYPE <- XTRA; XTRA = 0
               %finish %else %if %c
                  OPND1_PTYPE&7=1 %and OPND1_PTYPE&255<MINAPT %then %c
                  CURRT_OPTYPE = MINAPT
                                         ! PREVENT OPTIMISING BYTE ARRAY SCALE
                                         ! AS THESE CREATE EXTRA WORD
                                         ! WHICH DEFEATS ALGORITHMS
               %if (TARGET=PERQ %or TARGET=ACCENT %or TARGET=PNX) %and %c
                  JJ=39 %and XTRA>>20=1 %then %c
                  CURRT_FLAGS <- CURRT_FLAGS!DONT OPT
               CURRT_X1 = XTRA
               CURRT_OPND1 = OPND1
               %if 1<<OPND1_FLAG&BTREFMASK#0 %then KEEP USE COUNT(OPND1)
               %if JJ>=128 %then %start
                  CURRT_OPND2 = OPND2
                  %if 1<<OPND2_FLAG&BTREFMASK#0 %then KEEP USE COUNT(OPND2)
               %finish
               OPND1_FLAG = 8
               OPND1_PTYPE = CURRT_OPTYPE
               OPND1_D = CURR TRIP
            %finish
            STK(STPTR) = OPERAND(COMM)
            STPTR = STPTR+1
            ->ANYMORE
FINISH:
            %if EXPOPND_FLAG=ARNAME %then %start
               P = EXPOPND_D
               CNAME(2)
               EXPOPND = NAMEOPND
            %finish
            PTYPE = EXPOPND_PTYPE
            TYPE = PTYPE&7; PREC = PTYPE>>4
            P = SAVEP
            ASLIST(BOT)_LINK = ASL
            ASL = HEAD
            HEAD = 0; BOT = 0
            %return
            %routine PSEVAL
!***********************************************************************
!*    PERFORMS A PSEUDO EVALUATION ON THE EXPRESSION TO DETERMINE      *
!*    THE POSITION OF ANY TYPE CHANGES AND THEN INSERTS                *
!*    THESE UNARY OPERATIONS                                           *
!***********************************************************************
               %routine %spec AMEND(%record (RD) %name OPND, %integer OP)
               %routine %spec COERCET(%integer RULES)
               %routine %spec COERCEP(%integer RULES)
               %integer TMPHEAD,INHEAD,C,JJ,NEXT
               %record (RD) %name OPND1
               %record (RD) OPND2,RPOP
               %record (LISTF) %name CELL
               PRINT LIST(HEAD) %and IMPABORT %unless ASLIST(BOT)_LINK=0
               RPOP = 0
               TMPHEAD = 0
               INHEAD = HEAD
!
               %while INHEAD#0 %cycle
                  CELL == ASLIST(INHEAD)
                  NEXT = CELL_LINK
                  RPOP <- CELL;          ! COPY BEFOR ADJUSTING PTYPE
                  JJ = RPOP_FLAG;        ! FLAG
                  %if JJ<10 %start;      ! AN OPERAND
!            %if RPOP_PTYPE>>4&15<MINAPREC %then RPOP_PTYPE%c
=RPOP_PTYPE&X'FF0F'!(MINAPREC<<4)
                     PUSH(TMPHEAD,RPOP_S1,RPOP_D,INHEAD)
                  %finish %else %start;  ! AN OPERATOR
                     %if JJ>=128 %start;  ! BINARY OPERATOR
                        POP(TMPHEAD,OPND2_S1,OPND2_D,OPND2_XTRA)
                        OPND1 == ASLIST(TMPHEAD);  ! MAPPING SAVES POP&PUSH
                        C = CORULES(JJ-128)
                        %if JJ=REXP %and OPND2_PTYPE&7=2 %then C = X'F2'
                                         ! REAL TO THE REAL
                        %if C&15#0 %then COERCET(C&15)
                        %if C>>4&15#0 %then COERCEP(C>>4&15)
                     %else
                        OPND1 == ASLIST(TMPHEAD)
                        %if JJ=MODULUS %start
                           %if OPND1_PTYPE&7=1 %and RPOP_D&7=2 %then COERCET(3)
                           %if OPND1_PTYPE>>4&15<RPOP_D>>4&15 %then %c
                              AMEND(OPND1,LNGTHN)
                           %if OPND1_PTYPE>>4&15>RPOP_D>>4&15 %then %c
                              AMEND(OPND1,SHRTN)
                         %else
                           amend(opnd1,lngthn) %while opnd1_ptype>>4&15<5 %and 10<=jj<=11
                            %if jj<19 %then opnd1_ptype=opnd1_ptype+ptypech(jj)
                        %finish
                     %finish
                     OPND1_XTRA = INHEAD;  ! IN CASE(FURTHER)TYPE CHANGE
                  %finish
                  INHEAD = NEXT
               %repeat
!
! FINAL COERCION ON RESULT
!
               POP(TMPHEAD,OPND2_S1,OPND2_D,OPND2_XTRA)
               PRINT LIST(HEAD) %and IMPABORT %unless TMPHEAD=0
               %if CONDFORM=0 %start
                  %if MODE&7=1 %and OPND2_PTYPE&7=2 %then FAULT(25,0,0)
                  %if OPND2_PTYPE&7=1 %and MODE&7=2 %then AMEND(OPND2,IFLOAT)
                  C = MODE>>4&15;        ! TARGET PREC
                  AMEND(OPND2,SHRTN) %while C<OPND2_PTYPE>>4&15
                  AMEND(OPND2,LNGTHN) %while C>OPND2_PTYPE>>4&15
               %finish
               PRINTLIST(HEAD) %if PARM_DCOMP#0 %and PARM_Z#0
               BOT = ASLIST(BOT)_LINK %while ASLIST(BOT)_LINK#0
               %return
               %routine AMEND(%record (RD) %name OPND, %integer OP)
!***********************************************************************
!*    ADDS IN AN OPERATION TO CHANGE THE TYPE OR PREC OF OPND          *
!*     On E machines we can not elide uneceesary changes               *
!***********************************************************************
                  %record (RD) RPOP
                  %if 1<<target&Emachine=0 %and OP=LNGTHN %and OPND_PTYPE&255<MINAPT %then %c
                     OPND_PTYPE <- OPND_PTYPE&X'FF00'!MINAPT %and %return
                  RPOP = 0
                  RPOP_FLAG = OP
                  %if OP=IFLOAT %and OPND_PTYPE&255<MINAPT %then %c
                     OPND_PTYPE = MINAPT
                  OPND_PTYPE = OPND_PTYPE+PTYPECH(OP)
                    %if 1<<target&Llrealavail=0 %and op=ifloat %c
                       %and Opnd_ptype&255=X'72' %then OPnd_ptype=opnd_ptype-x'10'
                                       ! float longinteger when longlongreal not available
                  INSERT AFTER(OPND_XTRA,RPOP_S1,OPND_PTYPE,0)
                  NOPS = NOPS+1
               %end
               %routine COERCET(%integer RULES)
!***********************************************************************
!*         RULES=1 BOTH OPERANDS INTEGER ELSE ERROR                    *
!*         RULES=2 FORCE BOTH OPERAND TO BE OF TYPE REAL               *
!*         RULES=3 OPND1 ONLY TO BE REAL(FOR **)                       *
!*         RULES=4 OPND2 TO BE OPND 1(ASSIGNMENT)                      *
!*         RULES=15  BOTH OPERANDS TO BE OF LARGEST TYPE               *
!***********************************************************************
                  %integer PT1,PT2
                  %record (RD) RPOP
                  RPOP = 0; RPOP_FLAG = 12;  ! FLOAT
                  PT1 = OPND1_PTYPE&7
                  PT2 = OPND2_PTYPE&7
                  %if RULES=4 %then PT1 = CELL_S2&7;  ! ORIGINAL PT FOR ARRAYS%c
                                                      ETC
                  %if (RULES=1 %or RULES=15 %or RULES=4) %and PT1=1=PT2 %then %c
                     %return
                  %if RULES=1 %or (RULES=4 %and PT1=1) %then %c
                     FAULT(24,0,0) %and %return
                  %if PT1=1 %then AMEND(OPND1,IFLOAT)
                  %if PT2=1 %and (RULES=2 %or RULES=4 %or RULES=15) %then %c
                     AMEND(OPND2,IFLOAT)
               %end
               %routine COERCEP(%integer RULES)
!***********************************************************************
!*       RULES DEFINE COERCION AS FOLLOWS:                             *
!*       RULES=1 FORCE OPND2 TO BE OPND1(ASSIGNMENT)                   *
!*       RULES=2 OPERAND 1 TO BE 'STANDARD' INTEGER                    *
!*       RULES=4 OPERAND 2 TO BE 'STANDARD' INTEGER                    *
!*       RULES=5 AS RULES=1 BUT FOR <- ASSIGNMENT                      *
!*       RULES=6 BOTH OPERANDS TO BE 'STANDARD' INTEGER                *
!*       RULES=7 OPND1>=32BITS, OPND2 TO BE 'STANDARD'                 *
!*       RULES=15 BOTH OPERANDS TO THE LARGEST PRECISION               *
!***********************************************************************
                  %integer PREC1,PREC2,TPREC,OPER
                  %record (RD) %name OPND
                  %record (RD) RPOP
                  RPOP = 0
                  %if RULES=6 %then COERCEP(4) %and RULES = 2
                  PREC1 = OPND1_PTYPE>>4&15
                  PREC2 = OPND2_PTYPE>>4&15
                  %if RULES=5 %or RULES=1 %start;  !  ASSIGN
                     PREC1 = CELL_S2>>4&15;  ! ORIGINAL PREC FOR ARRAY ASSIGN
                     %if PREC2>PREC1 %start
                        %cycle
                           %if RULES=1 %then OPER = SHRTN %else OPER = JAMSHRTN
                           AMEND(OPND2,OPER)
                           PREC2 = PREC2-1
                        %repeat %until PREC1=PREC2
                        %return
                     %finish %else RULES = 1;  ! IN CASE LENGTHEN NEEDED
                  %finish
                  %if PREC1<MINAPREC %then %c
                     PREC1 = MINAPREC %and %c
                     OPND1_PTYPE <- OPND1_PTYPE&X'FF0F'!(MINAPREC<<4)
                  %if PREC2<MINAPREC %then %c
                     PREC2 = MINAPREC %and %c
                     OPND2_PTYPE <- OPND2_PTYPE&X'FF0F'!(MINAPREC<<4)
                  %if RULES=7 %start;    ! FORCE SHIFT INTO 32 BIT MIN REG
                     RULES = 4
                     %if PREC1=4 %then AMEND(OPND1,LNGTHN) %and PREC1 = 5
                  %finish
                  %if 2<=RULES<=4 %start
                     %if RULES<=2 %then OPND == OPND1 %else OPND == OPND2
                     %if OPND_PTYPE&X'FF'>MINAPT %then AMEND(OPND,SHRTN)
                     %return
                  %finish
                  %if PREC1<PREC2 %then %c
                     TPREC = PREC2 %and OPND == OPND1 %else %c
                     TPREC = PREC1 %and OPND == OPND2
                  OPER = OPND_PTYPE
                  AMEND(OPND,LNGTHN) %while OPND_PTYPE>>4&15<TPREC
               %end
            %end
         %end;                           ! OF ROUTINE EXPOP
         %integer %fn CCOND(%integer CTO,IU,FARLAB,JFLAGS)
!***********************************************************************
!*       COMPILES <IU><SC><RESTOFCOND>%then<UI1>%else<UI2>             *
!*       CTO=0 JUMP TO FARLAB MUST BE PLANTED IF COND UNCONDITIONAL    *
!*       CTO#0 JUMP MAY BE OMITTED                                     *
!*       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>            *
!*       RESULT=0 CONDITION COMPILED                                   *
!*       RESULT=1 UNCONDITIONALLY TO 1ST ALTERNATIVE                   *
!*       RESULT=2 UNCONDITIONALLY TO 2ND ALTERNATIVE(FARLAB)           *
!***********************************************************************
!%routinespec WRITE CONDLIST
            %routine %spec SKIP SC(%integer REVERSED)
            %routine %spec SKIP COND(%integer REVERSED)
            %integer %fn %spec CCOMP
            %routine %spec JUMP(%integer MASK,LAB,FLAGS)
            %routine %spec NOTE JUMP(%integer LAB)
            %routine %spec LAB UNUSED(%integer LAB)
            %routine %spec OMIT TO(%integer LAB)
!
! FCOMP HAS BC MASKS FOR EACH STRING COMPARATOR.
! THE FIRST 7 ARE TO BRANCH IF TRUE WITH NORMAL COMPARISON
! THE SECOND SEVEN ARE TO BRANCH IF TRUE WITH BACKWARDS COMPARISON
!
!
            %integer PIN,PP,II,L,CPTR,CMAX,LL,BITMASK,LLA
            %record %format CF(%byte %integer TF,CMP1,CMP2,LABU,LVL,JMP,REV,
               JUMPED, %integer LABNO,SP1,SP2)
            %record (CF) %array CLIST(0:30)
            %record (CF) %name C1,C2
!
! 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(0);                  ! SKIP THE 1ST CMPARSN
            SKIP COND(0);                ! 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_REV NEVER SET HERE (PDS HOPES)
            C1_LABNO = FARLAB
            PP = P;                      ! SAVE FINAL AR POINTER
            FAULT(108,0,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 %c
                  PLABEL = PLABEL-1 %and C1_LABNO = PLABEL
            %repeat
!
! PASS 4 GENERATE THE CODE
! MAINTAIN BIT MASK TO HELP. 2**0 JUMP TO FAR LAB PLANTED
!                            2**1 JUMP TO INTERMEDIATE LAB PLANTED
!
!         WRITE CONDLIST %if PARM_DCOMP=1
            BITMASK = 0
            CPTR = 1
            %cycle
               C1 == CLIST(CPTR)
               LLA = CCOMP
               %if LLA#0 %start
                  OMIT TO(LLA)
                  %if CPTR>=CMAX %then %start
                     %if CTO=0 %then JUMP(15,LLA,B'11')
                     %result = 2
                  %finish
                  C1 == CLIST(CPTR)
               %finish
               %if C1_LABNO>0 %then II = ENTER LAB(C1_LABNO,B'11')
               CPTR = CPTR+1
               %exit %if CPTR>=CMAX
            %repeat
!
            P = PP;
            %result = 1 %if BITMASK&1=0
            %result = 0
            %routine LAB UNUSED(%integer LAB)
!***********************************************************************
!*       A LABEL IS NOT JUMPED TO AS CONDITION ALWAYS FALSE            *
!*       REMOVE IT FROM LIST                                           *
!***********************************************************************
               %integer I
               %record (CF) %name C1
               %cycle I = CPTR,1,CMAX-1
                  C1 == CLIST(I)
                  %if C1_LABNO=LAB %start
                     C1_LABU = C1_LABU-1;  ! COUNT DOWN USE COUNT
                     %if C1_LABU=0 %then C1_LABNO = 0
                     %return
                  %finish
               %repeat
            %end
            %routine OMIT TO(%integer LAB)
!***********************************************************************
!*    A JUMP TURNS OUT TO BE UNCONDITIONAL. OMIT CODE FOR SKIPPED BIT  *
!***********************************************************************
               %record (CF) %name C1
               %cycle
                  C1 == CLIST(CPTR)
                  %if C1_LABNO>0 %start
                     %if C1_LABNO=LAB %then %return
                     %if C1_JUMPED>0 %then JUMP(15,LAB,B'11') %and %return
                  %finish
                  CPTR = CPTR+1
                  %exit %if CPTR>=CMAX
               %repeat
            %end
            %routine SKIP SC(%integer REVERSED)
!***********************************************************************
!*       REVERSED=1 FOR RECURSIVE CALL IN %not(SC)                     *
!*       SKIPS OVER A SIMPLE CONDITION. P ON ALT OF<SC>                *
!***********************************************************************
               %switch SCALT(1:3)
               %integer ALT
               ALT = A(P); P = P+1
               ->SCALT(ALT)
SCALT(1):                                ! <EXP><COMP><EXP><SECONDSIDE>
               C1_SP1 = P-PIN
               SKIP EXP
               C1_CMP1 = A(P)
               C1_REV = 3*REVERSED
               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
               %return
SCALT(2):                                ! '('<SC><RESTOFCOND>')'
               L = L+1
               SKIP SC(REVERSED)
               SKIP COND(REVERSED)
               L = L-1
               %return
SCALT(3):                                ! %not(SC)
               SKIP SC(REVERSED!!1)
            %end;                        ! OF ROUTINE SKIP SC
            %routine SKIP COND(%integer REVERSED)
!***********************************************************************
!*       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
                     C1_TF = C1_TF!!(3*REVERSED)
                     CPTR = CPTR+1
                     C1 == CLIST(CPTR); C1 = 0
                     SKIP SC(REVERSED)
                     ALTP = A(P); P = P+1
                  %repeat
               %finish
            %end
!%routine WRITE CONDLIST
!%conststring(5) %array CM(0:10)="     ","    =","   >=","    >",
!                       "    #","   <=","    <","   \=","   ->",
!                       "   ==","  \=="
!      PRINTSTRING("
! NO   TF   C1   C2   LABU   LVL  JMP  REV   LABNO JUMPED
!")
!      %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_REV,4)
!         WRITE(C1_LABNO,7)
!         WRITE(C1_JUMPED,6)
!         NEWLINE
!      %repeat
!%end
            %integer %fn 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                             *
!*       4) EQUIVALENCES   INTEGER COMPARISONS ON ADDRESSES            *
!*       RESULT=0 CODE COMPILED                                        *
!*       RESULT#0 UNCODITIONAL JUMP TO LAB=RESULT                      *
!***********************************************************************
               %routine %spec ACOMP(%integer TF,DS)
               %routine %spec ADCOMP(%integer TF)
               %routine %spec STRCOMP(%integer DS,TF, %integer %name WA)
               %integer HEAD1,HEAD2,NOPS,TE2,TEX2,P1,P2,FEXIT,IEXIT,CMP,BOT1,
                  BOT2
               %integer %array WA(0:3)
!
               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_REV!!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 %then %start
                                         ! CONDITIONAL RESOLUTION
                                         ! NB CRES BRANCHES ON FALSE!!
                  P = P1
                  %if A(P+3)=4 %and A(P+4)=1 %start
                     P = P+5; CNAME(2);  ! LH STRING TO ANY REG
                     %if A(P)=2 %then %start
                        %if TYPE#5 %then %c
                           FAULT(71,0,FROMAR2(P1+5)) %and %result = 0
                        P = P2
                        CRES(IEXIT);     ! FAILURES -> IEXIT
                        NOTE JUMP(IEXIT)
                        %if IEXIT=FARLAB %then BITMASK = BITMASK!1 %else %c
                           BITMASK = BITMASK!2
                        %if C1_REV!!C1_TF=2 %then JUMP(15,FEXIT,B'11')
                        %result = 0
                     %finish
                  %finish
                  FAULT(74,0,0)
                  %result = 0
               %finish
               %if C1_CMP1>8 %then ->ADRCOMP
               MASK = FCOMP(C1_CMP1)
               TE2 = TSEXP(TEX2)
               ->STR %if TYPE=5
                                         ! ARITHMETIC COMPARISIONS
               P = P1+3
               TORP(HEAD1,BOT1,NOPS);    ! FIRST EXPRESSION TO REVERSE POL
               CMP = C1_CMP1
               P = P2+3
               %if C1_CMP2#0 %then %start;  ! IF D-SIDED DEAL WITH MIDDLE
                  ACOMP(1,1);            ! BRANCH IEXIT %if FALSE
                  %if MASK=15 %then %result = IEXIT
                  JUMP(MASK,IEXIT,B'11')
                  P = P+5;               ! TO THE THIRD EXPRSN
                  CMP = C1_CMP2;         ! COMPARATOR NO 2
               %finish
!
               ACOMP(C1_REV!!C1_TF,0);   ! SECOND OR ONLY COMPARISION
               %if MASK=15 %then %result = FEXIT
               JUMP(MASK,FEXIT,B'11')
               %result = 0
STR:                                     ! STRING COMPARISIONS
                                         ! SOME CARE IS NEEDED IN FREEING
                                         ! STRING WK-AREAS SET BY CSTREXP
               P = P1
               WA(1) = 0; WA(2) = 0; WA(3) = 0
               CSTREXP(48);              ! DO NOT FREE WK-AREA
               WA(1) = VALUE;            ! SAVE ADDRESS OF WK-AREA
               CMP = C1_CMP1
               P = P2
!
               %if C1_CMP2#0 %then %start;  ! D-SIDED DEAL WITH MIDDLE
                  STRCOMP(1,1,WA(2))
                  %if MASK=15 %then %result = IEXIT
                  JUMP(MASK,IEXIT,B'11')
                  P = P+2; CMP = C1_CMP2
                  %if WA(1)#0 %then RETURN WSP(WA(1),268) %and WA(1) = 0
               %finish
!
               STRCOMP(0,C1_REV!!C1_TF,WA(3))
               %if MASK=15 %then %result = FEXIT
               JUMP(MASK,FEXIT,B'11')
               %cycle CMP = 1,1,3
                  %if WA(CMP)#0 %then RETURN WSP(WA(CMP),268)
               %repeat
               %result = 0
ADRCOMP:                                 ! ADRESS COMPARISONS
               ADCOMP(C1_REV!!C1_TF)
               JUMP(MASK,FEXIT,B'11')
               %result = 0
               %routine ADCOMP(%integer TF)
!***********************************************************************
!*    COMPILES AN == OR ADDRESS COMPARISON WHICH CAN NOT BE            *
!*    DOUBLESIDED. BETTER CODE COULD BE GENERATED FOR THE              *
!*    MOST COMMON CASE IE POINTERNAME==VARIABLE                        *
!************************************************************************
                  %integer TYPEP,PRECP,LHNAME,RHNAME,FNAME,CMP
                  %record (RD) OPND1
                  %record (TRIPF) %name CURRT
                  LHNAME = A(P1+5)<<8!A(P1+6)
                  RHNAME = A(P2+5)<<8!A(P2+6)
                  FNAME = RHNAME
                  %if C1_CMP1=10 %then CMP = 7 %else CMP = 1
                  MASK = FCOMP(CMP)
                  P = P1+1
                  ->FLT %unless A(P1+3)=4 %and A(P1+4)=1 %and A(P+FROMAR2(P))=2
                  P = P1+5; CNAME(4)
                  TYPEP = TYPE; PRECP = PREC
                  OPND1 = NAMEOPND
                  OPND1_PTYPE = X'51'
!
                  FNAME = LHNAME
                  P = P2+1
                  ->FLT %unless A(P2+3)=4 %and A(P2+4)=1 %and A(P+FROMAR2(P))=2
                  P = P2+5; CNAME(4)
                  FAULT(83,LHNAME,RHNAME) %unless TYPEP=TYPE %and PRECP=PREC
                  CURRT == TRIPLES(BRECTRIP(COMP,X'51',0,OPND1,NAMEOPND))
                  CURRT_X1 = MASK
                  %if TF=1 %then MASK = REVERSE(MASK)
                  %return
FLT:
                  FAULT(80,0,FNAME)
                  MASK = 7
               %end
               %routine ACOMP(%integer TF,DS)
!***********************************************************************
!*       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      *
!***********************************************************************
                  %record (RD) OPERATOR
                  %integer PRECP,TYPEP
                  OPERATOR = 0
                  PRECP = PTYPE>>4&15; TYPEP = TYPE
                  MASK = FCOMP(CMP)
!
! ADD OPERATOR AT BOTTOM. EITHER COMPARE(COMP) OR DS COMPARE(DCOMP)
!
                  OPERATOR_FLAG = COMP+DS
                  PUSH(HEAD2,OPERATOR_S1,MASK,0)
                  BOT2 = HEAD2
                  NOPS = NOPS+1;         ! FLAG COMPARE
!
! 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
!
                  TORP(HEAD2,BOT2,NOPS)
                  %if TYPEP>TYPE %then TYPE = TYPEP
!         CONCAT(HEAD1,HEAD2)
                  ASLIST(BOT1)_LINK = HEAD2
                  BOT1 = BOT2; BOT2 = 0; HEAD2 = 0
                  EXPOP(HEAD1,BOT1,NOPS,256+16*PRECP+TYPE);  ! PLANT THE CODE
                  %if DS#0 %start
                     PUSH(HEAD1,EXPOPND_S1,EXPOPND_D,EXPOPND_XTRA)
                     BOT1 = HEAD1
                  %finish
                  %if TF=1 %then MASK = REVERSE(MASK)
               %end
               %routine STRCOMP(%integer DS,TF, %integer %name WA)
!***********************************************************************
!*       1ST STRING IS DEFINED BY (ACCR)                               *
!*       THIS ROUTINE EVALUATES THE NEXT STRING EXPRS AND PERFORMS     *
!*       THE COMPARISON & BRANCH.                                      *
!*       DS=0 UNLESS THIS COMPARISON IS THE FIRST HALF OF A DBLE-SIDED *
!***********************************************************************
                  %integer FLAG,D
                  %record (RD) OPND1
                  %record (TRIPF) %name CURRT
                  OPND1 = EXPOPND
                  CSTREXP(48);           ! SAVE WK-AREA
                  WA = VALUE
                  FLAG = SCOMP+DS
                  %if OPND1_FLAG=LCONST=EXPOPND_FLAG %then %c
                     CTOP(FLAG,MASK,FCOMP(CMP),OPND1,EXPOPND)
                  %if FLAG#0 %start
                     MASK = FCOMP(CMP)
                     CURRT == TRIPLES(BRECTRIP(FLAG,X'35',0,OPND1,EXPOPND))
                     CURRT_X1 = MASK
                  %finish
                  %if TF=1 %then MASK = REVERSE(MASK);  ! REVERSE MASK TO JMP%c
                                                        IF FALS
               %end
            %end
            %routine JUMP(%integer MASK,LAB,FLAGS)
!***********************************************************************
!*    CALLS ENTER JUMP WHILE MAINTAINING BITMASK                       *
!***********************************************************************
               %if MASK=0 %then LAB UNUSED(LAB) %and %return
               %if LAB=FARLAB %then FLAGS = JFLAGS
               ENTER JUMP(MASK,LAB,FLAGS)
               NOTE JUMP(LAB)
               %if LAB=FARLAB %then BITMASK = BITMASK!1 %else %c
                  BITMASK = BITMASK!2
            %end
            %routine NOTE JUMP(%integer LABEL)
!***********************************************************************
!*    RECORD LABEL JUMPED TO FOR SKIPPING COMPLEX CONDITIONS           *
!***********************************************************************
               %integer I
               %record (CF) %name C
               %cycle I = 1,1,CMAX
                  C == CLIST(I)
                  %if C_LABNO=LABEL %then C_JUMPED = C_JUMPED+1 %and %exit
               %repeat
            %end
         %end;                           ! OF CCOND
         %integer %fn REVERSE(%integer MASK)
!***********************************************************************
!*       REVERSE THE MASK FOR A JCC(MASK<=15),JAT(>15) OR JAF(>31)     *
!***********************************************************************
            %if MASK=0 %or MASK=15 %then %result = MASK!!15
            %result = MASK!!X'8F'
         %end

         %integer %fn ENTER LAB(%integer LAB,FLAGS)
!***********************************************************************
!*       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 =   UNFILLED JUMPS LIST & ENVIRONMENT LIST                 *
!*       S3 =   FOR DEPTH<<16!LAB NO                                   *
!*             LAB NO - RESET TO FFFF WHEN USED FOR INTERNAL LABELS    *
!*       RESULT = 1 LABEL ENTERED                                      *
!*       RESULT = 0 CONDITIONAL LABEL NOT REQUIRED                     *
!***********************************************************************
            %integer CELL,OLDCELL,TRIPNO,K
            %record (LISTF) %name LCELL,JCELL
            CELL = CURRINF_LABEL; OLDCELL = 0
            %while CELL>0 %cycle
               LCELL == ASLIST(CELL)
               %exit %if LCELL_S3&X'FFFF'=LAB
               OLDCELL = CELL; CELL = LCELL_LINK
            %repeat
!
            %if CELL<=0 %then %start;    ! LABEL NOT KNOWN
               %if FLAGS&1#0 %then %result = 0;  ! CONDITIONAL ENTRY
               PUSH(CURRINF_LABEL,0,0,FORDPTH<<16!LAB)
               CELL = CURRINF_LABEL
               LCELL == ASLIST(CELL)
            %finish
!
! LABEL HAS BEEN REFERENCED - FILL IN ITS ADDRESS
!
            %if LCELL_S1&LABSETBIT#0 %then %start
               FAULT(2,0,LAB);           ! LABEL SET TWICE
            %finish %else %start
               LCELL_S1 = LCELL_S1!LABSETBIT;  ! FLAG AS SET
            %finish
!
! NOW FILL JUMPS TO THIS LABEL - JUMP LIST FORMAT GIVEN IN 'ENTER JMP'
!
            %if LAB<=MAX ULAB %start;    ! CHECK FOR ILLEGAL JUMPS INTO LOOPS
               K = LCELL_S2&X'FFFF';     ! HD OF JUMP LIST
               %while K>0 %cycle
                  JCELL == ASLIST(K)
                  %if JCELL_S3>>16<FORDPTH %then FAULT(3,JCELL_S3&X'FFFF',LAB)
                  K = JCELL_LINK
               %repeat
            %finish
            TRIPNO = ULCONSTTRIP(TLAB,X'61',DONT OPT,FLAGS<<24!LAB,CELL)
            %if FLAGS&1#0 %and LAB>MAXULAB %then REMOVELAB(LAB)
            %result = 1
         %end
         %routine ENTER JUMP(%integer TFMASK,LAB,FLAGS)
!***********************************************************************
!*       IF LAB HAS BEEN ENCOUNTERED THEN PLANT A JCC 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= ADDR OF JUMP                                              *
!*       S2=SHORT OR LONG FLAG                                         *
!*       S3=FORDPTH OF JUMP<<16!LINE NO OF JUMP FOR DIAGNOSTICS        *
!*                                                                     *
!*       FLAGS BITS SIGNIFY AS FOLLOWS                                 *
!*       2**0 =1  JUMP IS KNOWN TO BE SHORT                            *
!*       2**1 =1  ENVIRONMENT MERGEING REQUIRED                        *
!*       2**6 =1 ASSEMBLER JUMP TFMASK =RELEVENT ASS INFO              *
!*       2**7 SET ON FIRST REF TO LABEL                                *
!***********************************************************************
            %integer CELL,I
            %record (TRIPF) %name CURRT
            %record (LISTF) %name LCELL
            %if LAB<MAX ULAB %then FLAGS = FLAGS&X'FD';  ! NO MERGE
            CELL = CURRINF_LABEL
            %while CELL>0 %cycle
               LCELL == ASLIST(CELL)
               %if LAB=LCELL_S3&X'FFFF' %then %exit
               CELL = LCELL_LINK
            %repeat
            ->FIRSTREF %if CELL<=0
            ->NOT YET SET %if LCELL_S1&LABSETBIT=0
            LCELL_S1 = LCELL_S1!X'1000000';  ! FLAG LABEL AS USED
            CURRT == TRIPLES(UCONSTTRIP(BJUMP,0,DONT OPT,FLAGS<<24!LAB))
            CURRT_OPND1_XTRA = CELL;     ! LAB CELL FOR BJUMPS
            CURRT_X1 = TFMASK
            %if LAB<MAX ULAB %and FORDPTH<LCELL_S3>>16 %then FAULT(3,LINE,LAB)
            %return
FIRSTREF:                                ! FIRST REFERENCE TO A NEW LABEL
            PUSH(CURRINF_LABEL,LABUSEDBIT,0,LAB)
            FLAGS = FLAGS!128;           ! MARK FIRST USE FOR PASS3
            CELL = CURRINF_LABEL
            LCELL == ASLIST(CELL)
NOT YET SET:                             ! LABEL REFERENCED BEFORE
            I = LCELL_S2&X'FFFF';        ! MAY BE ENVIRONMENT LIST ADDED
            PUSH(I,0,0,FORDPTH<<16!LINE)
            LCELL_S2 = LCELL_S2&X'FFFF0000'!I
            CURRT == TRIPLES(ULCONSTTRIP(FJUMP,0,DONT OPT,FLAGS<<24!LAB,
               CELL<<16!I))
            CURRT_X1 = TFMASK;           ! CONDITIONAL OR NOT ETC
         %end
         %routine REMOVE LAB(%integer LAB)
!***********************************************************************
!*    REMOVES A ALBEL FROM THE CURRENT LABEL LIST WHEN KNOWN TO        *
!*    BE REDUNDANT. MAINLY USED FOR CYCLE LABELS                       *
!***********************************************************************
            %integer T
            T = UCONSTTRIP(REMLB,X'51',DONT OPT,LAB)
         %end
         %integer %fn CREATE AH(%integer MODE, %record (RD) %name EOPND,NOPND)
!***********************************************************************
!*       CREATES AN ARRAYHEAD IN THE ESTACK BY MODIFYING THE           *
!*       HEAD ALREADY THERE AS FOLLOWS:-                               *
!*       MODE=0 (ARRAYMAPPING)  ETOS-4&5 HAS 32BIT ADDR OF FIRST ELEMNT*
!*       MODE=1 (ARRAYS IN RECORDS)ETOS-4&5 HAS 32BIT RELOCATION FACTOR*
!***********************************************************************
            %integer JJ
            JJ = BRECTRIP(AHADJ,AHEADPT,0,EOPND,NOPND)
            TRIPLES(JJ)_X1 = PTYPE<<4!MODE
            %result = JJ
         %end;                           ! OF ROUTINE CREATE AH
         %routine CSNAME(%integer Z)
!***********************************************************************
!*       COMPILE A SPECIAL NAME - PTYPE=10006 (=%routine %label)       *
!*       THEIR TRUE PTYPE IS IN GLOBAL ARRAY TAGS_S2.                  *
!*       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 STRING(%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=%integerfn EVENTINF                                        *
!*       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 SUBSTRING(%stringname S,%integer BEG,END)  *
!*       48=%recordmap RECORD(%integer REC ADDR)                       *
!*       49=%arraymap ARRAY(%integer A1ADDR,%arrayname FORMAT)         *
!*       50=%integerfn SIZEOF(%name X)                                 *
!*       51=%integerfn IMOD(%integer VALUE)                            *
!*       52=%longrealfn PI                                             *
!*       53=%integerfn EVENTLINE                                       *
!*       54=%longintegermap LONGINTEGER(%integer ADR)                  *
!*       55=%longlongrealmap LONGLONGREAL(%integer ADR)                *
!*       56=%longintgerefn LENGTHENI(%integer VAL)                     *
!*       57=%longlongrealfn LENGTHENR(%longreal VAL)                   *
!*       58=%integerfn SHORTENI(%longinteger VAL)                      *
!*       59=%longrealfn SHORTENR(%longlongreal VAL)                    *
!*       60=%integerfn NEXTCH                                          *
!*       61=%halfintegermap HALFINTEGER(%integer ADDR)                 *
!*       62=%routine PPROFILE                                          *
!*       63=%longrealfn FLOAT(%integer VALUE)                          *
!*       64=%longintegerfn LINT(%longlongreal X)                       *
!*       65=%longintegerfn LINTPT(%longlongreal X)                     *
!*       66=%shortintegermap SHORTINTEGER(%integer N)                  *
!*       65=%integerfn TRUNC(%longreal X)                              *
!***********************************************************************
            %integer %fn %spec OPTMAP
            %switch ADHOC(1:17)
            %const %integer %array SNINFO(0:NO OF SNS)= %c
                    X'41080001',X'41090001',X'408A0001',X'40A00001',
                    X'40010001',X'800D0000',X'11010001',X'11010001',
                    X'10020024',X'41030001',X'19030001',X'80130001',
                    X'80170014',X'408C0001',X'19050024',X'80010002',
                    X'11040024',X'11040024',X'80010005',X'80090006',
                    X'80060007',X'2100003E',X'2100003E',X'11060024',
                    X'80010008',X'80010009',X'8001000A',X'8001000B',
                    X'8001000C',X'8001000D',X'8001000E',X'8015000F',
                    X'2100003E',X'100D0024',X'80030010',X'80030011',
                    X'1907003E',X'41070001',X'10080024',X'2100003E',
                    X'41050001',X'19030001',X'2100003E',X'19030001',
                    X'10020024',X'1A07003E',X'11090024',X'800F0012',
                    X'110A0018',X'120B1000',X'80130013',X'11060024',
                    X'100C0024',X'100D0024',X'2100003E'(2),
                    X'110E0024'(4),
                    X'10020024',X'2100003E',X'100F0001',X'11100024',
                    X'11110024',X'11110024',X'2100003E',X'11040024'


            %const %string (13) %array SNXREFS(0:20)= %c
                  "s#readstring", "s#read",   "s#iarcsin", "s#int",
                  "s#intpt" , "s#fracpt", "s#print" , "s#printfl",
                  "s#iarccos","s#isqrt" , "s#ilog"  , "s#isin",
                  "s#icos"  , "s#itan"  , "s#iexp"  , "s#closestream",
                  "s#iradius","s#iarctan","s#substring","s#sizeof",
                  "s#write"

!
! 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.
!
            %if PARAMS BWARDS=YES %then %start
               %const %integer %array SNPARAMS(0:25)=0{NO PARAMS},
               8<<16!1,LRLPT{%LONGREAL X},
               16<<16!2,8<<16!LRLPT,LRLPT{%LONGREAL X,Y},
               12<<16!2,12<<16!LRLPT,4<<16!X'51'{%LONGREAL X,%INTEGER I},
               16<<16!3,8<<16!LRLPT,4<<16!X'51',X'51'{%LONGREAL X,%INTEGER I,J},
               8<<16!1,X'435'{%STRINGNAME S},
               16<<16!3,8<<16!X'435',4<<16!X'51',X'51'{%STRINGNAME S,%INTEGER I,J},
               8<<16!1,X'400'{%NAME X},
               4<<16!1,X'51'{%INTEGER I},
               8<<16!2,4<<16!X'51',X'51'{%INTEGER I,J}

            %finish %else %start
               %const %integer %array SNPARAMS(0:25)=0{NO PARAMS},
               8<<16!1,LRLPT{%LONGREAL X},
               16<<16!2,LRLPT,8<<16!LRLPT{%LONGREAL X,Y},
               12<<16!2,LRLPT,8<<16!X'51'{%LONGREAL X,%INTEGER I},
               16<<16!3,LRLPT,8<<16!X'51',12<<16!X'51'{%LONGREAL X,%INTEGER I,J},
               8<<16!1,X'435'{%STRINGNAME S},
               16<<16!3,X'435',8<<16!X'51',12<<16!X'51'{%STRINGNAME S,%INTEGER I,J},
               8<<16!1,X'400'{%NAME X},
               4<<16!1,X'51'{%INTEGER I},
               8<<16!2,X'51',4<<16!X'51'{%INTEGER I,J}

            %finish
!
            %const %byte %integer %array WRONGZ(0:15)=27,29,23,29,29,23,82,109(5),
                                        23,27,109(2)

            %routine %spec RTOS
            %integer %fn %spec CIOCP(%integer N, %record (RD) %name PARAM)
            %record (LISTF) %name LCELL
            %record (LISTF) PCELL
            %record (RD) OPND,OPERATOR
            %record (TRIPF) %name CURRT
            %string (31) SNXREF
            %integer ERRNO,FLAG,POINTER,PIN,SNNO,SNNAME,NAPS,SNPTYPE,JJ,XTRA,
               IOCPEP,B,D,SNINF,P0,OPHEAD,ERRVAL,EXPHEAD,EXPBOT,NOPS



            ERRVAL=0
            SNNAME = FROM AR2(P)
            SNNO = K;                    ! INDEX INTO SNINFO
            TESTAPP(NAPS);               ! COUNT ACTUAL PARAMETERS
            PIN = P; P = P+2
            SNPTYPE = ACC
            SNINF = SNINFO(SNNO)
            XTRA = SNINF&X'FFFF'
            POINTER = (SNINF>>16)&255
            FLAG = SNINF>>24
            %if snptype&255=x'61' %and 1<<Target&LINTAVAIL=0 %then %c
               errno=99 %and ->errexit
!
! 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
! XTRA HAS INDEX INTO ARRAY OF EXTERNAL NAMES SO THAT THESE
! CAN EASILY BE CHANGED.
!
            %if FLAG&X'80'#0 %then %start
               SNXREF = SNXREFS(XTRA)
               P0 = SNPARAMS(POINTER)
               %if TARGET=PERQ %or TARGET=ACCENT %then %start
                  JJ = ADDR(SNXREF)
                  D = LENGTH(SNXREF)
                  MOVE BYTES(D+1,JJ,0,ADDR(A(0)),WORKA_ARTOP)
                  JJ = ADDR(A(WORKA_ARTOP))-ADDR(A(WORKA_DICTBASE))
                  WORKA_ARTOP = (WORKA_ARTOP+D+4)&(-4)
               %finish %else CXREF(SNXREF,3*PARM_DYNAMIC,P0<<16!P0>>16,JJ)
                                         ! JJ SET WITH REF DISPLACEMENT
!         %if SNNO=26 %then LOGEPDISP=JJ
!         %if SNNO=30 %then EXPEPDISP=JJ
               OPHEAD = 0
               K = OPHEAD; D = 1
               %while D<=P0&15 %cycle
                  B = SNPARAMS(POINTER+D)
                  PTYPE = B&X'FFFF'
                  UNPACK
                  %if NAM=0 %then ACC = BYTES(PREC) %else ACC = 8
                  %if PTYPE=X'35' %then ACC = 256;  !STRING BY VALUE
                  PCELL = 0;             ! SET UP PARAMETER DESC VIA RECORD
                  PCELL_PTYPE <- PTYPE;  ! FOR CONSISTENCY ON BYTE SWOPPED%c
                                         HOSTS
                  PCELL_SNDISP = B>>16
                  PCELL_ACC <- ACC
                  %if PARAMS BWARDS=YES %then %c
                     PUSH(OPHEAD,PCELL_S1,PCELL_S2,0) %else %c
                     INSERTAT END(OPHEAD,PCELL_S1,PCELL_S2,0)
                  D = D+1
               %repeat
               %if P0>0 %then ASLIST(OPHEAD)_S3 = P0;  ! INSERT NO OF PARAMS
                                         ! UPPER PART OF P0(TOTAL PARAMSPACE)
                                         ! APPARENTLY NOT NEEDED AS NO BODIES
                                         ! ARE PROVIDED.
               LCELL == ASLIST(TAGS(SNNAME))
               LCELL_PTYPE = SNPTYPE
               LCELL_UIOJ = 1<<4!14;     ! I=1 & J=14
               LCELL_SNDISP <- JJ;       ! RT ENTRY DISPLACEMENT
               LCELL_ACC = BYTES(SNPTYPE>>4&15)
               LCELL_SLINK = OPHEAD
               LCELL_KFORM = 0;          ! KFORM(=FORMAT INFO)
               P = PIN; CNAME(Z);        ! RECURSIVE CALL
               P = P-1; %return;         ! DUPLICATES CHECK OF <ENAME>
            %finish
!
! ALL ROUTINES EXCEPT THE IMPLICITS REQUIRE A CHECK 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)
!
            ERRVAL = NAPS-FLAG&3
            %if ERRVAL>0 %then ERRNO = 19 %and ->ERREXIT
            %if ERRVAL<0 %then ERRNO = 18 %and ERRVAL = -ERRVAL %and ->ERREXIT
            JJ = 1<<Z
            %if JJ&XTRA=0 %then %start;  ! ILLEGAL USE
               ERRNO = WRONGZ(Z)
               ->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(32) %else CSEXP(X'51')
               %finish %else EXPOPND = 0 %and EXPOPND_PTYPE = X'51' %and expopnd_d=-1
!
! ep=1 is used for read symbol and skip symbol. 2nd param=-1 is to
! enable the result to be abandoned for skip symbol
!
               %if IOCPEP>127 %then %start
                  EXPOPND_FLAG = SCONST
                  EXPOPND_D = IOCPEP&127
                  IOCPEP = 5
               %finish
               JJ = CIOCP(IOCPEP,EXPOPND);  ! PLANT CALL OF IOCP
               P = P+1
               ->OKEXIT
            %finish
!
! THE BUILT-IN MAPS (INTEGER ETC BUT NOT RECORD OR ARRAY)
!
            %if FLAG&X'20'#0 %then %start
               SNPTYPE = X'1C00'+SNPTYPE;  ! ADD MAP BITS
               %if PARM_OPT=0 %and OPTMAP#0 %then ->OKEXIT
               %if Z=1 %then BIMSTR = 1;  ! SPECIAL FLAG FOR STORE VIA MAP
               P = P+1
               CSEXP(X'51'); P = P+1
               %if Z=1 %then BIMSTR = 0
               DISP = 0; ACCESS = 3; BASE = 0
               OLDI = 0;                 ! FOR CHECK IN == ASSGNMNT
               ->OKEXIT
            %finish
!
! ADHOC CODING IS REQUIRED FOR THE REMAINING ROUTINES APART FROM
! A CHECK FOR NAMETYPE PARAMETERS. THE SWITCH NO IS KEPT IN POINTER
!
            P = P+1
            %if FLAG&8#0 %and (A(P+3)#4 %or A(P+4)#1 %or %c
               A(P+FROM AR2(P+1)+1)#2) %then %c
               ERRNO = 22 %and ERRVAL = 1 %and ->ERREXIT
            ->ADHOC(POINTER)
ADHOC(1):                                ! NEWLINES(=6) & SPACES(=7)
            %if SNNO=6 %then JJ = 10 %else JJ = 32
            EXPHEAD = 0; NOPS = 2
            OPND = 0; OPND_PTYPE = MINAPT; OPND_FLAG = SCONST
            OPERATOR = 0; OPERATOR_FLAG = ORL
            PUSH(EXPHEAD,OPERATOR_S1,0,0);  ! OPERATOR '!'
            EXPBOT = EXPHEAD
            PUSH(EXPHEAD,OPND_S1,JJ,0);  ! CONST JJ
            OPERATOR_FLAG = LSHIFT
            PUSH(EXPHEAD,OPERATOR_S1,0,0);  ! OPERATOR '<<'
            PUSH(EXPHEAD,OPND_S1,8,0);   ! CONST 8
            P = P+3; TORP(EXPHEAD,EXPBOT,NOPS)
            EXPOP(EXPHEAD,EXPBOT,NOPS,X'51');  ! EVAL REPTN<<8!SYMBOL IN GR1
            JJ = CIOCP(17,EXPOPND)
            P = P+1
            ->OKEXIT
ADHOC(2):                                ! NEXTSYMBOL(=8) & NEXTITEM(=44)
                                         ! ALSO NEXTCH(=60)
            %if SNNO=60 %then JJ = 18 %else JJ = 2
            EXPOPND = 0; EXPOPND_PTYPE = X'51'
            JJ = CIOCP(JJ,EXPOPND);      ! LEAVES THE SYMBOL IN GR1
            %if SNNO=44 %then %start
               EXPOPND_FLAG = REFTRIP
               EXPOPND_D = JJ
               ->TOST;                   ! TREAT AS TOSTRING
            %finish
            NAMEOPND_PTYPE = MINAPT
            NAMEOPND_FLAG = REFTRIP
            NAMEOPND_D = JJ
            ->OKEXIT
ADHOC(3):                                ! READSYMBOL(=10),CH(=41)&ITEM(=43)
            %if SNNO=41 %then JJ = 4 %else JJ = 1
            EXPOPND = 0; EXPOPND_PTYPE = X'51'
            P = P+5
            %if SNNO=43 %then %start
               EXPOPND_D = CIOCP(JJ,EXPOPND)
               EXPOPND_PTYPE = X'41'; EXPOPND_FLAG = REFTRIP
               TYPE = 5; RTOS
               OPND = NAMEOPND
               CNAME(3)
               JJ = BRECTRIP(STRASS1,X'35',0,NAMEOPND,OPND)
            %finish %else %start
               EXPHEAD = 0; NOPS = 1
               FNAME = A(P)<<8!A(P+1)
               REDUCE TAG(NO)
               FAULT(25,0,0) %unless TYPE=1
               OPND = 0; OPND_FLAG = ARNAME; OPND_PTYPE <- PTYPE
               %if LHSADDRFIRST=NO %or (NAM=ARR=0 %and A(P+2)=2=A(P+3)) %then %c
                  PUSH(EXPHEAD,OPND_S1,P,FNAME) %else %c
                  CNAME(3) %and PUSH(EXPHEAD,NAMEOPND_S1,NAMEOPND_D,
                  NAMEOPND_XTRA)
               EXPBOT = EXPHEAD
               EXPOPND_PTYPE = X'51'; EXPOPND_FLAG = SCONST
               EXPOPND_D = 0
               JJ = CIOCP(JJ,EXPOPND)
               OPND = 0; OPND_PTYPE = MINAPT; OPND_FLAG = REFTRIP
               OPERATOR = 0; OPERATOR_FLAG = VASS
               BINSERT(EXPHEAD,EXPBOT,OPND_S1,JJ,0)
               BINSERT(EXPHEAD,EXPBOT,OPERATOR_S1,PTYPE,0)
               EXPOP(EXPHEAD,EXPBOT,NOPS,PTYPE&255!256)
            %finish
            P = PIN+6+FROM AR2(PIN+4)
            ->OKEXIT
ADHOC(17):                               ! LINT(=64) AND LINTPT(=65)
            %unless TYPEFLAG(10)&255=X'61' %and TYPEFLAG(12)&255>=X'62' %then %c
               ERRNO = 99 %and ->ERREXIT
! NEED LONGINTS&LLREALS
            CSEXP(typeflag(12)&255);    ! LONGLONGREAL MODE or longreal if defaulted
            %if SNNO=64 %then JJ = RTOI1 %else JJ = RTOI2
            P0 = X'61'; ->FIXIT
ADHOC(4):                                ! INT(=16) AND INTPT (=17)
            CSEXP(LRLPT)
            %if SNNO=16 %then JJ = RTOI1 %else %if SNNO=17 %then %c
               JJ = RTOI2 %else jj = rtoi3
            P0 = X'51';                  ! FIXES TO INTEGER
FIXIT:      JJ = URECTRIP(JJ,P0,0,EXPOPND)
            P = P+1
            NAMEOPND_PTYPE = P0; NAMEOPND_FLAG = REFTRIP
            NAMEOPND_D = JJ
            ->OKEXIT
ADHOC(5):                                ! ADDR(=14)
            P = P+5; CNAME(4);           ! FETCH ADDRESS MODE
            P = P+2; ->OKEXIT
ADHOC(6):                                ! MOD(=23), IMOD(=51)
            EXPHEAD = 0; NOPS = 1
            OPERATOR = 0; OPERATOR_FLAG = MODULUS
            PUSH(EXPHEAD,OPERATOR_S1,SNPTYPE&255,0)
            EXPBOT = EXPHEAD
            P = P+3
            TORP(EXPHEAD,EXPBOT,NOPS)
            EXPOP(EXPHEAD,EXPBOT,NOPS,SNPTYPE)
            NAMEOPND = EXPOPND
            P = P+1
            ->OKEXIT
ADHOC(7):                                ! CHARNO(=45) & LENGTH(=36)
            P = P+5
            COPY TAG(A(P)<<8!A(P+1),NO)
            B = -1
            %if NAM=ARR=0 %and TYPE=5 %and LITL=1 %and Z=2 %and %c
               A(P+2)=2=A(P+3) %then B = MIDCELL %and P = P+4 %else %start
               CNAME(4)
               OPND = NAMEOPND
               ERRNO = 22; ERRVAL = 1
               ->ERREXIT %unless TYPE=5 %and (ROUT=0 %or NAM>=2)
            %finish
            P = P+2
            %if SNNO#36 %then %start
               CSEXP(MINAPT)
               P = P+1
            %finish %else EXPOPND = 0 %and EXPOPND_PTYPE = X'41' %and %c
               EXPOPND_FLAG = SCONST
            %if B>0 %start;              ! LENGTH OR CHARNO AT COMPILE TIME
               %if EXPOPND_FLAG=SCONST %and EXPOPND_PTYPE&7=1 %and %c
                  EXPOPND_D<=A(B) %start
                  NAMEOPND = EXPOPND
                  NAMEOPND_D = A(B+EXPOPND_D)
                  NAMEOPND_XTRA = 0
                  ->OKEXIT
               %finish
               FAULT(43,0,FROMAR2(PIN+8))
               ->ERREXIT
            %finish
            JJ = BRECTRIP(SINDX,X'31',0,OPND,EXPOPND)
            CURRT == TRIPLES(JJ)
            CURRT_X1 = 1<<20;            ! ADJUSTMENT BASE ON 1 BYTE ELEMENTS
            EXPOPND_PTYPE = X'31'; EXPOPND_FLAG = REFTRIP
            EXPOPND_D = JJ
            EXPOPND_XTRA = 0
            DISP = 0; ACCESS = 3
            STNAME = -1 %if Z=1;         ! CANT REMEBER NAME
            SNPTYPE = SNPTYPE+X'1C00'
            ->OKEXIT
ADHOC(12):                               ! PI(=52)
ADHOC(8):                                ! NL(=38). THIS FN IS PICKED OFF
            P = P+1
            ->OKEXIT;                    ! ERROR EG NL=A+B
ADHOC(9):                                ! TOSTRING(=46)
            CSEXP(MINAPT);               ! RET EXPSN
            P = P+1
TOST:
            RTOS
            STRFNRES = 0
            SNPTYPE = X'1035';           ! TYPED AS STRING FN
            ->OKEXIT
ADHOC(10):                               ! RECORD(=48)
            CSEXP(X'51')
            P = P+1
            DISP = 0; BASE = 0; ACCESS = 3
            OLDI = 0; ACC = X'FFFF'
            SNPTYPE = SNPTYPE+X'1C00';   ! ADD MAP BITS
            PTYPE = SNPTYPE; UNPACK
            %return
ADHOC(11):                               ! ARRAY(=49)
            CSEXP(X'51');                ! ADDR(A(0)) TO NEST
            OPND = EXPOPND
            ERRNO = 22; ERRVAL = 2
            ->ERREXIT %unless A(P+4)=4 %and A(P+5)=1
            P = P+6; CNAME(12)
            ->ERREXIT %unless A(P)=2 %and ARR=3
            P = P+2
            NAMEOPND_D = CREATE AH(0,OPND,NAMEOPND)
            NAMEOPND_PTYPE = AHEADPT
            NAMEOPND_FLAG = REFTRIP
            NAMEOPND_XTRA = 0
            %return
ADHOC(13):                               ! EVENTINF(=33) & EVENTLINE
            D = CURRINF_ONINF
            FAULT(16,0,SNNAME) %if D=0
            D = D+4 %if SNNO#33
            BASE = RBASE; ACCESS = 0
            DISP = D; SNPTYPE = SNPTYPE+X'1C00';  ! ADD MAP BITS
            ->OKEXIT
ADHOC(14):                               ! LENGTHEN AND SHORTEN
            D = (SNNO&3)*8
            JJ = X'62517261'>>D&255
            %if 1<<TARGET&LLREALAVAIL=0 %and JJ=X'72' %then JJ = X'62'
            %if 1<<TARGET&LINTAVAIL=0 %and JJ=X'61' %then JJ = X'51'
            CSEXP(JJ)
            P = P+1
            NAMEOPND = EXPOPND
            ->OKEXIT
ADHOC(15):                               ! PPROFILE(IGNORED UNLESS PARM SET)
            JJ = UCONSTTRIP(PPROF,X'51',0,PROFAAD) %unless PARM_PROF=0
            ->OKEXIT
ADHOC(16):                               ! FLOAT
            CSEXP(LRLPT)
            NAMEOPND = EXPOPND
            P = P+1
OKEXIT:                                  ! NORMAL EXIT
            PTYPE = SNPTYPE; UNPACK
            ACC = BYTES(PREC)
            %return
ERREXIT:                                 ! ERROR EXIT
            FAULT(ERRNO,ERRVAL,SNNAME)
            NAMEOPND = 0; NAMEOPND_PTYPE = X'51'
            BASE = 0; DISP = 0; ACCESS = 0; AREA = 0
            PTYPE = SNPTYPE; UNPACK
            P = PIN+2; SKIP APP
            P = P-1; %return
            %integer %fn OPTMAP
!***********************************************************************
!*       LOOK FOR EXPRESSION LIKE INTEGER(ADDR(X)) AND AVOID USING DR  *
!***********************************************************************
               %integer VARNAME,REXP,PP,CVAL,OP
               %const %integer ADINCFACTOR=1+TARGET//20;  ! 16bit WORDS OR BYTES
               %if SNNO=42 %then %result = 0;  ! STRINGMAP STRING
               %if STACK DOWN=YES %then %result=0; !trick does not work
               PP = P+2; REXP = FROM AR2(PP)+PP;  ! TO REST OF EXP
               VARNAME = FROM AR2(PP+4);  ! SHOULD BE ADDR
               %result = 0 %unless A(PP+2)=4 %and A(PP+3)=1
               COPY TAG(VARNAME,NO);     ! CHECK IT WAS ADDR
               ->WASADR %if PTYPE=SNPT %and K=14 %and A(PP+6)=1
               %result = 0
WASADR:        PP = PP+10
               %result = 0 %unless %c
                  A(PP)=4 %and A(PP+1)=1 %and A(PP+4)=2=A(PP+5) %and %c
                  A(PP+6)=2=A(PP+7) %and A(PP+8)=2
               VARNAME = FROM AR2(PP+2); COPY TAG(VARNAME,NO)
               %result = 0 %unless PTYPE&X'FF0C'=0
               %if Z=1 %then OP = UNAMETRIP(DMASS,PTYPE,DONT OPT,VARNAME)
               %if A(REXP)=2 %then P = REXP+2 %else %start
                  OP = A(REXP+1)
                  %result = 0 %unless %c
                     1<=OP<=2 %and A(REXP+2)=2 %and A(REXP+3)=X'41' %and %c
                     A(REXP+6)=2
                  CVAL = FROM AR2(REXP+4)
                  %if OP=1 %then K = K+ADINCFACTOR*CVAL %else %c
                     K = K-ADINCFACTOR*CVAL
                  %result = 0 %if K<0
                  P = REXP+8
               %finish
               BASE = I
               DISP = K; ACCESS = 0
               %result = 1

            %end
            %integer %fn CIOCP(%integer EP, %record (RD) %name PARAM)
!***********************************************************************
!*    CALL IOCP PASSING A PARAMETER
!*    RETURNS THE TRIPLE NO OF THE CALL
!***********************************************************************
               %record (RD) OPND
               OPND_PTYPE = MINAPT; OPND_FLAG = SCONST
               OPND_D = EP; OPND_XTRA=0;
               %result = BRECTRIP(IOCPC,MINAPT,DONT OPT,OPND,PARAM)
            %end
            %routine RTOS
!***********************************************************************
!*       PLANTS CODE TO CONVERT A SYMBOL IN EXPOPND TO A ONE           *
!*       CHARACTER STRING IN A TEMPORARARY VARIABLE.                   *
!***********************************************************************
               %integer KK,JJ
               %if EXPOPND_FLAG<=1 %start
                  KK = ITOS1
                  CTOP(KK,JJ,0,EXPOPND,NAMEOPND)
                  %if KK=0 %then NAMEOPND = EXPOPND %and %return
               %finish
               JJ = URECTRIP(ITOS1,X'35',0,EXPOPND)
               NAMEOPND_PTYPE = X'35'; NAMEOPND_FLAG = REFTRIP
               NAMEOPND_D = JJ
            %end
         %end;                           ! OF ROUTINE CSNAME
         %routine CANAME(%integer Z,ARRP, %record (RD) %name HDOPND)
!***********************************************************************
!*       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 *
!***********************************************************************
            %integer HEAD1,BOT1,NOPS,ELSIZE,PTYPEP,JJ,SOLDI,KK,PP,TYPEP,
               ARRNAME,Q,PRECP,NAMINF,DVD,PRIVOPS
            %record (RD) VMYOP,RPOP
            %record (TAGF) %name LCELL
            %integer %array HEADS,BOTS(0:12)

            vmyop=0;
            NOPS = 0; HEAD1 = 0; BOT1 = 0
            PP = P; TYPEP = TYPE
            JJ = J; PTYPEP = PTYPE; PRECP = PREC; SOLDI = OLDI
            %if TYPE<=2 %then ELSIZE = BYTES(PRECP) %else ELSIZE = ACC
            %if ELSIZE>4095 %or (TYPE=5 %and NAM#0) %then ELSIZE = 0
            DVD = SNDISP;                ! LOCATION OF DV IF CONSTANT
            VMYOP_FLAG = 0; VMYOP_XB = 0
            ARRNAME = FROM AR2(P);       ! NAME OF ENTITY
            NAMINF = TAGS(ARRNAME)
            FAULT(87,0,ARRNAME) %if ARR=3;  ! ARRAYFORMAT USED AS ARRAY
            NAMINF = -2 %and DVD = 0 %if ARRP>2;  ! ARRAYS IN RECORDS
            %if DVD>0 %then VMYOP_PTYPE = X'51' %and VMYOP_D = DVD %else %c
               VMYOP = HDOPND
            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
               LCELL == ASLIST(TCELL)
               LCELL_UIOJ = LCELL_UIOJ!Q;  ! DIMSN IS BOTTOM 4 BITS OF TAG
               JJ = Q
            %finish
            %if JJ=Q#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.
!
!
! NOW PROCESS THE SUBSCRIPTS CALLING TORP TO CONVERT THE EXPRESSIONS
! TO REVERSE POLISH AND ADDING THE EXTRA OPERATIONS.
!
               P = PP+3
               %cycle KK = 1,1,JJ;       ! THROUGH THE SUBSCRIPTS
                  P = P+3
                  HEADS(KK) = 0; BOTS(KK) = 0; PRIVOPS = 0
                  TORP(HEADS(KK),BOTS(KK),PRIVOPS);  ! SUBSCRIPT TO REVERSE%c
                                                     POLISH
                  %if PTYPE=1 %and PRIVOPS&1<<17#0 %then %c
                     WARN(1,0) %and BINSERT(HEADS(KK),BOTS(KK),SHRTN,X'51',0)
                  P = P+1
                  NOPS = (NOPS+PRIVOPS&X'FFF')!PRIVOPS&X'FFFF0000'
                                         ! ADD OPERATORS AND OR FLAGS
!
! MULTIPLIERS ARE DOPE VECTOR ITEMS (OPTYPE=3)
!
! N SUBSCRIPTS WILL REQUIRE (N-1) MULTIPLICATIONS AND ADDITIONS
! ON EMAS HAVE TO ADD ALL OPERATORS AT END SINCE DV ARE BACKWARDS
!
                  NOPS = NOPS+1
                  BINSERT(HEADS(KK),BOTS(KK),VMYOP_S1,VMYOP_D,VMYOP_XTRA)
                                         ! MULTIPLIER
                  RPOP = 0
                  RPOP_FLAG = VMY
                  RPOP_D = KK<<28!JJ<<24
                  %if TARGET=EMAS %then RPOP_D = RPOP_D!(PTYPEP&255)<<16
                  %if NAMINF>=0 %then RPOP_D = RPOP_D!ARRNAME
                  BINSERT(HEADS(KK),BOTS(KK),RPOP_S1,RPOP_D,0)
                                         ! DOPE VECTOR MULTIPLY
                  %if (TARGET#EMAS %and KK>1) %or (TARGET=EMAS %and %c
                     KK<JJ) %start
                     RPOP = 0; RPOP_FLAG = COMB
                     BINSERT(HEADS(KK),BOTS(KK),RPOP_S1,0,0)
                                         ! COMBINE WITH PREVIOUS
                     NOPS = NOPS+1
                  %finish
               %repeat
               %cycle KK = 1,1,JJ
                  %if TARGET#EMAS %start
                     %if HEAD1=0 %then HEAD1 = HEADS(KK) %else %c
                        ASLIST(BOT1)_LINK = HEADS(KK)
                     BOT1 = BOTS(KK)
                  %finish %else %start
                     %if HEAD1=0 %then HEAD1 = HEADS(JJ+1-KK) %else %c
                        ASLIST(BOT1)_LINK = HEADS(JJ+1-KK)
                     BOT1 = BOTS(JJ+1-KK)
                  %finish
               %repeat
               %unless TARGET=IBM %or TARGET=IBMXA %or TARGET=AMDAHL %or %c
                  TARGET=EMAS %or ARRP=2 %or ((TARGET=PERQ %or %c
                  TARGET=ACCENT) %and PARM_COMPILER#0) %start
                                         ! BASE ADJUST
                  BINSERT(HEAD1,BOT1,VMYOP_S1,VMYOP_D,VMYOP_XTRA)
                  RPOP = 0
                  RPOP_FLAG = BADJ; RPOP_D = PTYPEP<<16!JJ
                  BINSERT(HEAD1,BOT1,RPOP_S1,RPOP_D,0)
               %finish
               BINSERT(HEAD1,BOT1,HDOPND_S1,HDOPND_D,HDOPND_XTRA)
               RPOP = 0; RPOP_FLAG = AINDX
               RPOP_D = ELSIZE<<20
               BINSERT(HEAD1,BOT1,RPOP_S1,RPOP_D,0);  ! SCALE
               NOPS = NOPS+2
            %finish %else %start
               RPOP = 0; RPOP_FLAG = SCONST
               BINSERT(HEAD1,BOT1,RPOP_S1,0,0)
               %if JJ>Q %then FAULT(20,JJ-Q,ARRNAME) %else %c
                  FAULT(21,Q-JJ,ARRNAME)
               P = P+2; SKIP APP
            %finish
            SOLDI = OLDI
            EXPOP(HEAD1,BOT1,NOPS,X'51');  ! EVALUATE THE REVERSE POLISH LIST
                                         ! CONSTANT ACCEPTABLE AS RESULT
            ACCESS = 3
            ACC = ELSIZE; PTYPE = PTYPEP; UNPACK; J = JJ
            %if TYPE=5 %and NAM>0 %then MLOPND = HDOPND
            OLDI = SOLDI;                ! FOR NAME==A(EL) VALIDATION
            %return
         %end;                           ! OF ROUTINE CANAME
         %routine CNAME(%integer Z)
!***********************************************************************
!*       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 ACCESSED BY P WHICH IS ADVANCED.             *
!*       Z SPECIFIES ACTION AS FOLLOWS:-                               *
!*       Z=0 COMPILE A ROUTINE CALL                                    *
!*       Z=1 ARRANGE  A 'STORE' OPERATION FROM ESTACK                  *
!*       Z=2 FETCH NAME TO ESTACK                                      *
!*       Z=3 GET 32 BIT ADDRESS(48BIT FOR BYTES) FOR PASSING BY NAME   *
!*       Z=4 SET 20 BIT ADDRESS(36BIT FOR BYTES) OF NAME IN REG        *
!*       Z=5  AS Z=2                                                   *
!*       Z=6 STORE ETOS (CONTAINS POINTER) INTO POINTER VARIABLE       *
!*       Z=7->10  NOT NOW USED                                         *
!*       Z=11 FETCH 32 BIT ADDRESS OF ARRAYHEAD                        *
!*       Z=12 FETCH ARRAYHEAD TO ESTACK                                *
!*       Z=13 GET 4 WORD ROUTINE DISCRIPTOR                            *
!*              (INTERNAL ROUTINES FIRST CREATE THE DISCRIPTOR)        *
!*                                                                     *
!***********************************************************************
            %integer JJ,KK,LEVELP,DISPP,NAMEP,PP,SAVESL,FNAME
            %record (RD) TOPND
            %switch S,FUNNY(11:13),SW(0:8)
            PP = P
            FNAME = A(P)<<8+A(P+1)
            %if Z=1 %or Z=6 %then STNAME = FNAME
            COPY TAG(FNAME,YES);         ! DECLARE IF UNKNOWN AT THIS POINT
            SAVESL = ACC
            JJ = J; JJ = 0 %if JJ=15
            NAMEP = FNAME
            LEVELP = I; DISPP = K
            FAULT(43,0,FNAME) %if %c
               LITL=1 %and ROUT=0=NAM %and (Z=1 %or Z=3 %or (Z=4 %and ARR=0))
            ->NOT SET %if TYPE=7
            %if (Z=0 %and (ROUT#1 %or 0#TYPE#6)) %or (Z=13 %and ROUT=0) %then %c
               FAULT(27,0,FNAME) %and ->NOT SET
            ->FUNNY(Z) %if Z>=10
            ->RTCALL %if ROUT=1
            ->SW(TYPE)
SW(6):
            FAULT(5,0,FNAME)
            ->NOT SET
SW(4):                                   !RECORD FORMAT NAME
            FAULT(87,0,FNAME)
SW(7):
NOT SET:                                 ! NAME NOT SET
            BASE = I; DISP = K; ACCESS = 0
            NAMEOPND = 0; NAMEOPND_PTYPE = X'51'
            PTYPE = X'51'; UNPACK
            %if 1<=Z<=5 %then NAMEOP(Z,4,NAMEP)
            P = P+2; SKIP APP; ->CHKEN
FUNNY(11):                               ! SET 32 BIT ADRESS OF ARRAYHEAD
FUNNY(12):                               ! MOVE ARRAYHEAD TO ESTACK
            ->SW(3) %if TYPE=3 %and (ARR=0 %or A(P+2)=1)
            %if PTYPE=SNPT %then CSNAME(12) %and ->CHKEN
            %if A(P+2)=2 %then P = P+3 %else NO APP
            NAMEOPND_FLAG = DNAME
            NAMEOPND_D = FNAME
            NAMEOPND_XTRA = 0
S(12):
S(11):                                   ! ARRAYS IN RECORDS BY NAME
            NAMEOPND_PTYPE = AHEADPT
            ->CHKEN
FUNNY(13):                               ! LOAD ADDR FOR RT-TYPE
            %if PTYPE=SNPT %then CSNAME(Z) %and P = P+1 %and ->CHKEN
            JJ = UNAMETRIP(RTFP,RTPARAMPT,0,FNAME)
            NAMEOPND_PTYPE = RTPARAMPT; NAMEOPND_FLAG = REFTRIP
            NAMEOPND_D = JJ
            NAMEOPND_XTRA = 0
            %if A(P+2)=2 %then P = P+3 %else NO APP
            ->CHKEN
RFUN:                                    ! RECORD FUNCTIONS
            EXPOPND = NAMEOPND
RMAP:                                    ! RECORD MAPS
            COPY TAG(NAMEP,NO);          ! SET KFORM ETC
            P = P-3
            NAMEP = -1
            CRNAME(Z,3,0,0,NAMEP)
            ->RBACK
SW(3):                                   ! RECORD
            CRNAME(Z,2*NAM,I,K,NAMEP)
RBACK:
            ->S(Z) %if Z>=10
            ->STRINREC %if TYPE=5 %and Z#6
            ->NOT SET %if TYPE=7
            NAMEOP(Z,BYTES(PREC),NAMEP)
            STNAME = NAMEP %if Z=1 %or Z=6
            ->CHKEN
SW(5):                                   ! TYPE =STRING
!
! ALL STRING OPERATIONS ARE ON THE RELEVANT DESCRIPTOR. Z=2 &Z=5
! REQUIRE A CURRENT LENGTH(IE MODIFIED) DESCRIPTOR. OTHER OPERATIONS
! REQUIRE THE MAX LENGTH DESCRIPTOR (IE UNMODIFIED HEADER)
!
            %if Z=6 %then ->SW(1)
            ->STRARR %if ARR>=1
            %if A(P+2)=2 %then P = P+3 %else NO APP
            BASE = I; ACCESS = 2*NAM; DISP = K
SMAP:       MLOPND = 0
            %if NAM#1 %then %start
               MLOPND_PTYPE = X'51'
               MLOPND_D = SAVESL-1
            %else
               MLOPND_PTYPE = X'61'
               MLOPND_FLAG = LOCALIR
               MLOPND_D = I<<16!K
            %finish
            NAMEOP(Z,4,NAMEP)
            ->CHKEN
STRARR:                                  ! STRINGARRAYS &  ARRAYNAMES
            TOPND = 0
            TOPND_PTYPE = AHEADPT; TOPND_FLAG = DNAME
            TOPND_D = FNAME
            CANAME(Z,ARR,TOPND)
            ->SMAP %unless Z=3 %and NAM#0
                                         ! MLOPND LEFT SET BY CANAME
            NAMEOP(3,4,NAMEP)
            ->CHKEN
STRINREC:                                ! STRINGS IN RECORDS
            SAVESL = ACC
            ->SMAP %unless Z=3 %and NAM#0 %and ARR#0
                                         ! MLOPND SET BY CANAME & SET LEFT SET%c
                                         BY CENAME
            NAMEOP(3,4,NAMEP)
            ->CHKEN
!
! SECTION TO DEAL WITH ALL NAMES INVOLVING ROUTINE CALL
!
RTCALL:                                  ! FIRST CHECK
            %if TYPE=0 %and Z#0 %then FAULT(23,0,FNAME) %and ->NOT SET
                                         ! RT NAME IN EXPRSN
            %if PTYPE=SNPT %then %start
               CSNAME(Z);                ! SPECIAL NAME
               ->BIM %if ROUT=1 %and NAM>1 %and Z#0
               ->CHKEN
            %finish
            CRCALL(FNAME); P = P+1;      ! DEAL WITH PARAMS
            ->CHKEN %if PTYPE&15=0
            ->UDM %if NAM>1;             ! MAPS
            %unless Z=2 %or Z=5 %or Z=3=TYPE %start;  ! FUNCTIONS
               FAULT(29,0,FNAME); BASE = 0
               ACCESS = 0; DISP = 0
            %finish
            ->RFUN %if TYPE=3
            ->CHKEN
UDM:                                     ! USER DEFINED MAPS
            DISP = 0
            ACCESS = 3
            BASE = 0
            EXPOPND = NAMEOPND
            ->RMAP %if TYPE=3
BIM:                                     ! BUILT IN MAPS
            NAMEP = -1
            STNAME = -1
            %if TYPE=5 %then SAVESL = 256 %and ->SMAP
            KK = Z; KK = 2 %if Z=5
            NAMEOP(Z,BYTES(PREC),NAMEP)
            ->CHKEN
SW(0):                                   ! %name PARAMETERS NO TYPE
                                         ! ALLOW FETCH ADDR OPERATIONS
                                         ! AND SPECIAL FOR BUILTIN MAPS
            %unless 3<=Z<=4 %then %start
               FAULT(90,0,FNAME); TYPE = 1
            %finish
SW(1):                                   ! TYPE =INTEGER
SW(2):                                   ! TYPE=REAL
            %if ARR=0 %or (Z=6 %and A(P+2)=2) %then %start
               BASE = I; ACCESS = 2*NAM
               DISP = K
               %if A(P+2)=2 %then P = P+3 %else NO APP
            %finish %else %start
               TOPND = 0
               TOPND_PTYPE = AHEADPT; TOPND_FLAG = DNAME
               TOPND_D = FNAME
               CANAME(Z,ARR,TOPND)
               NAM = 0
            %finish
            NAMEOP(Z,BYTES(PREC),NAMEP)
            ->CHKEN
!
CHKEN:      %while A(P)=1 %cycle
               FAULT(69,FROMAR2(P+1),FNAME)
               P = P+3; SKIP APP
            %repeat
            P = P+1
         %end

         %routine NAMEOP(%integer Z,SIZE,NAMEP)
!***********************************************************************
!*    FETCH OR STORE ETOS FROM OR TO VARIABLE DEFINED BY AREA ACCESS   *
!*    BASE AND DISP.                                                   *
!***********************************************************************
            %switch BIGACC(0:11)
            %record (RD) POPND
            %integer KK,PPTYPE
            KK = Z; KK = 2 %if Z=5
            XDISP = X'80000000' %if ACCESS<=3
            %if Z=6 %then %start;        ! NAME DEREFENCING
               FAULT(82,0,NAMEP) %unless %c
                  NAMEP&X'FFFF'=X'FFFF' %or (NAM!ARR#0 %and ROUT=0 %and %c
                  (ACCESS>=8 %or ACCESS=2))
               Z = 1; KK = 1; SIZE = 4
               PPTYPE = X'51'
               %if PTRSIZE(PTYPE&255)>4 %then PPTYPE = X'61'
                                         ! POINTER PTYPE
               %if PTRSIZE(PTYPE&255)>8 %then PPTYPE = X'71'
               PTYPE = PPTYPE
               %if ACCESS>=8 %then ACCESS = ACCESS-4 %else %c
                  ACCESS = 0 %and XDISP = x'80000000'
            %finish
            KK = KK&3
            ->BIGACC(ACCESS)
BIGACC(9):                               ! ALL ACCESS=9
BIGACC(5):
BIGACC(1):  IMPABORT;                    ! NO LONGER USED?
!

! ACCESS
! ******
! THIS VARIABLE DEFINES HOW TO ACCESS ANY IMP VARIABLE:-
! =0 VARIABLE DIRECTLY ADDRESSED IN 'BASE' BY 'DISP'
! =1 NOT USED
! =2 POINTER TO VARIABLE DIRECTLY ADDRESS BY 'BASE' & 'DISP'
! =3 POINTER AS IN =2 COMPUTED IN EXPOPND
! =4 VARIABLE 'XDISP' INTO RECORD AT BY 'BASE' &'DISP'
! =5 NOT USED
! =6 VAR 'XDISP' INTO RECORD ADDRESSED BY POINTER AT 'BASE' & 'DISP'
! =7 AS =6 BUT POINTER COMPUTED IN EXPOPND
! =8-11 AS 4-7 BUT THERE IS A POINTER TO ITEM AT 'XDISP' INTO RECORD
! POINTER HERE MEANS 32 BIT NORMALLY BUT BYTES MUSTBE AND STRING MAY
! HAVE TO BE 48 BIT
!
BIGACC(0):                               ! DIRECTLY ADDRESS
            %if NAMEP&X'FFFF'#X'FFFF' %start
               NAMEOPND_PTYPE <- PTYPE; NAMEOPND_FLAG = DNAME
               NAMEOPND_D = NAMEP&X'FFFF'
            %finish %else %start
               NAMEOPND_PTYPE <- PTYPE; NAMEOPND_FLAG = LOCALIR
               NAMEOPND_D = BASE<<16!DISP
            %finish
            NAMEOPND_XTRA = XDISP
ADOP:
            %return %if Z=1
            %if Z=3 %then %start
               POPND_PTYPE = X'51'; POPND_FLAG = SCONST
               POPND_D = ACC; POPND_XTRA=0
               %if TYPE=5 %then POPND = MLOPND
               PPTYPE = X'51'
               %if PTRSIZE(PTYPE&255)>4 %then PPTYPE = X'61'
               NAMEOPND_D = BRECTRIP(GETPTR,PPTYPE,0,NAMEOPND,POPND)
               NAMEOPND_PTYPE = PPTYPE
               TRIPLES(NAMEOPND_D)_X1 = PTYPE<<16!J
                                         ! TO FIND SIZE OF STRINGARRAYNAME
                                         ! EMAS NEEDS DIMENSIONALITY
            %finish %else %start
               %if Z=2 %or Z=5 %start;   ! FETCHING
                  %return %unless %c
                     (TARGET=PERQ{ %OR TARGET=EMAS} %or TARGET=PNX %or %c
                     TARGET=ACCENT %or 1<<target&emachine#0) %and %c
                     NAMEOPND_FLAG=INDIRECT
! ON NESTED ACC MACHINES
                  NAMEOPND_D = URECTRIP(PRELOAD,PTYPE,0,NAMEOPND)
               %finish %else %start;     ! Z=4 GET ADDRESS
                  %if nameopnd_flag=indname %and base=14 %start
                                         ! addr(const name)
                       %if type=5 %and nameopnd_xtra<0 %then disp=disp+4
                     kk = ctable(disp>>2)
                     %if nameopnd_xtra>0 %then kk = kk+nameopnd_xtra
                     nameopnd_flag = sconst; nameopnd_ptype = x'51'
                     nameopnd_d = kk; nameopnd_xtra = 0
                     %return
                  %finish
                   %if bimstr#0 %and namep&x'FFFF' <> x'FFFF' %c
                      %then kk=unametrip(DMASS,ptype,dont opt,namep&X'FFFF')
                  NAMEOPND_D = URECTRIP(GETAD,X'51',0,NAMEOPND)
                  NAMEOPND_PTYPE = X'51';  ! ADDRESS IS 32 BIT INTEGER
               %finish
            %finish
            NAMEOPND_FLAG = REFTRIP
            NAMEOPND_XTRA = 0
            %return
BIGACC(2):                               ! ALL ACCESS=2
            %if NAMEP&X'FFFF'#X'FFFF' %start
               NAMEOPND_PTYPE <- PTYPE; NAMEOPND_FLAG = INDNAME
               NAMEOPND_XB = 0
               NAMEOPND_D = NAMEP&X'FFFF'
               NAMEOPND_XTRA = X'80000000'
               ->ADOP
            %finish
            EXPOPND_PTYPE <- PTYPE; EXPOPND_FLAG = LOCALIR
            EXPOPND_D = BASE<<16!DISP
BIGACC(3):                               ! ACCESS=3
            %if EXPOPND_FLAG#REFTRIP %start
               %if Z=4 %and EXPOPND_PTYPE=X'51' %start;  ! GET  32 BIT ADDR OF%c
                                                         COMPUTED
                  NAMEOPND = EXPOPND
                  %return
               %finish
               KK = URECTRIP(PRELOAD,EXPOPND_PTYPE,0,EXPOPND)
               EXPOPND_PTYPE <- PTYPE; EXPOPND_FLAG = REFTRIP
               EXPOPND_D = KK
            %finish
            NAMEOPND_PTYPE <- PTYPE; NAMEOPND_FLAG = INDIRECT
            NAMEOPND_D = EXPOPND_D
            NAMEOPND_XTRA = X'80000000';  ! OFFSET NOT RELEVANT PERQ ONLY%c
                                          DISTINCTION
            ->ADOP
BIGACC(4):                               ! ALL ACCESS=4
            %if NAMEP&X'FFFF'#X'FFFF' %start
               NAMEOPND_PTYPE <- PTYPE; NAMEOPND_FLAG = DNAME
               NAMEOPND_D = NAMEP&X'FFFF'
               NAMEOPND_XTRA = XDISP
            %finish %else %start
               NAMEOPND_PTYPE <- PTYPE; NAMEOPND_FLAG = LOCALIR
               NAMEOPND_D = DISP+XDISP
               IMPABORT %if TARGET=PNX;  ! ABOVE LINE DOES NOT WORK ON PNX
                                         ! BUT PDS CANT FATHOM WHAT SORT
                                         ! OF SOURCE CODING CAN EVER REACH HERE
               NAMEOPND_XTRA = 0
            %finish
            ->ADOP
BIGACC(6):                               ! ALL ACCESS=6
            %if NAMEP&X'FFFF'#X'FFFF' %start
               NAMEOPND_PTYPE <- PTYPE; NAMEOPND_FLAG = INDNAME
               NAMEOPND_XB = 0
               NAMEOPND_D = NAMEP&X'FFFF'
               NAMEOPND_XTRA = XDISP; ->ADOP
            %finish
            NAMEOPND = 0
            NAMEOPND_PTYPE = X'51'; NAMEOPND_FLAG = LOCALIR
            NAMEOPND_D = BASE<<16!DISP
            KK = URECTRIP(PRELOAD,X'51',0,NAMEOPND)
            EXPOPND_PTYPE <- PTYPE; EXPOPND_FLAG = REFTRIP
            EXPOPND_D = KK
BIGACC(7):                               ! ALL ACCESS=7
            NAMEOPND_PTYPE <- PTYPE; NAMEOPND_FLAG = INDIRECT
            NAMEOPND_D = EXPOPND_D
            NAMEOPND_XTRA = XDISP
            ->ADOP
BIGACC(8):                               ! ALL ACCESS=8
            %if NAMEP&X'FFFF'#X'FFFF' %start
               NAMEOPND_PTYPE = X'51'; NAMEOPND_FLAG = DNAME
               NAMEOPND_D = NAMEP&X'FFFF'
               NAMEOPND_XTRA = 0
            %finish %else %start
               NAMEOPND_PTYPE = X'51'; NAMEOPND_FLAG = LOCALIR
               NAMEOPND_D = BASE<<16!DISP
               NAMEOPND_XTRA = 0
            %finish
            KK = URECTRIP(GETAD,X'51',0,NAMEOPND)
            EXPOPND_PTYPE = X'51'; EXPOPND_FLAG = REFTRIP
            EXPOPND_D = KK
            ->BIGACC(11);                ! HAS BECOME ACESS=11
BIGACC(10):                              ! ALL ACCESS=10
            %if NAMEP&X'FFFF'#X'FFFF' %start
               NAMEOPND = 0
               NAMEOPND_PTYPE = X'51'; NAMEOPND_FLAG = INDNAME
               NAMEOPND_D = NAMEP&X'FFFF'
            %finish %else %start
               NAMEOPND_PTYPE = X'51'; NAMEOPND_FLAG = LOCALIR
               NAMEOPND_D = BASE<<16!DISP
               KK = URECTRIP(GETAD,X'51',0,NAMEOPND)
               NAMEOPND_FLAG = VIAPTR; NAMEOPND_D = KK
               NAMEOPND_XTRA = 0
            %finish
            KK = URECTRIP(GETAD,X'51',0,NAMEOPND)
            EXPOPND_D = KK
            EXPOPND_FLAG = REFTRIP
BIGACC(11):                              ! ALL ACCESS=11
            NAMEOPND_PTYPE <- PTYPE; NAMEOPND_FLAG = VIAPTR
            NAMEOPND_D = EXPOPND_D
            NAMEOPND_XTRA = XDISP
            ->ADOP
         %end
         %routine CRCALL(%integer RTNAME)
!***********************************************************************
!*       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.                           *
!***********************************************************************
            %integer II,III,QQQ,JJ,JJJ,NPARMS,PT,LP,PSIZE,TWSP,PARMNO,ERRNO,
               FPTR,TYPEP,PRECP,NAMP,TL,CLINK,PSPECED,OUTP,PPTYPE
            %record (RD) OPND,OPND1,OPND2
            %record (LISTF) %name LCELL
            PT = PTYPE; JJJ = J; TL = OLDI
            TWSP = 0; FPTR = 0; QQQ=0
            LP = I; CLINK = K
            TYPEP = TYPE; PRECP = PREC; NAMP = NAM
            %if CLINK=0 %then PSPECED = 0 %else PSPECED = ASLIST(CLINK)_S3&255
!
            %begin
               %integer %array ARP(0:PSPECED)
               %switch FPD(0:3)
! NOW CHECK THAT THE RIGHT NUMBER OF PARAMETERS HAVE BEEN PROVIDED
! ALSO NOTE THE POINTERS TO ACTUAL PARAMETERS ALLOWING FOC 'C' COMPATABILITY
!
               P = P+2
               NPARMS = 0
               %while A(P)=1 %cycle
                  P = P+1
                  %if NPARMS<PSPECED %start
                     %if PARAMS BWARDS=YES %then %c
                        ARP(PSPECED-NPARMS) = P %else ARP(NPARMS+1) = P
                  %finish
                  NPARMS = NPARMS+1
                  SKIP EXP
               %repeat
               OUTP = P
               %if PSPECED#NPARMS %then %start
                                         ! WRONG NO OF PARAMETERS GIVEN
                  %if PSPECED=0 %then ERRNO = 17 %else %start
                     %if NPARMS<PSPECED %then ERRNO = 18 %else ERRNO = 19
                  %finish
                  FAULT(ERRNO,IMOD(PSPECED-NPARMS),RTNAME)
                  SKIP APP; P = P-1
                  NAMEOPND = 0; NAMEOPND_PTYPE = X'51';  ! ENSURE SENSIBLE%c
                                                         RESULT TRIPLE
                  ->OVER
               %finish
!
               II = UNAMETRIP(PRECL,PT&255,0,RTNAME)
               PARMNO = 0
               ->FIRST PARM
!
BAD PARM:                                ! BAD PARAMETER FAULT IT
            %if PARAMS BWARDS=Yes %then II=pspeced-parmno+1 %else ii=parmno
               FAULT(22,II,RTNAME)
NEXT PARM:     CLINK = LCELL_LINK
FIRSTPARM:     ->ENTRY SEQ %if CLINK=0;  ! DEPART AT ONCE IF NO PARAMS
               LCELL == ASLIST(CLINK)
               PSIZE = LCELL_ACC&X'FFFF'
               PARMNO = PARMNO+1
               P = ARP(PARMNO)
               PTYPE = LCELL_PTYPE
               UNPACK
               II = TYPE; III = PREC
               JJ = (NAM<<1!ARR)&3
               ->BAD PARM %unless %c
                  (JJ=0 %and ROUT=0) %or JJ=2 %or (A(P+3)=4 %and %c
                  A(P+4)=1 %and A(P+FROMAR2(P+1)+1)=2)
               OPND_PTYPE <- PTYPE; OPND_FLAG = DNAME
               OPND_D = RTNAME
               OPND_XTRA = PARMNO<<24!CLINK
!
! RT TYPE PARAMS, PASS 4 WORDS AS SET UP  BY QCODE INSTRN LVRD
!
               %if ROUT=1 %then %start
                  II = PTYPE; P = P+5
                  CNAME(13);             ! SET UP 4 WDS IN ACC
                  ->BAD PARM %if II&255#PTYPE&255;  ! PREC&TYPE SIMILAR
                  P = P+1
                  II = BRECTRIP(PASS4,RTPARAMPT,0,OPND,NAMEOPND)
                  FPTR = FPTR+RTPARAMSIZE
                  ->NEXT PARM
               %finish
               ->FPD(JJ)
FPD(0):                                  ! VALUE PARAMETERS
               %if TYPE=3 %start;        ! RECORDS BY VALUE
                  II = TSEXP(III);       ! CHECK FOR ZERO AS RECORD VALUE
                  %if II=1 %and III=0 %start
                     EXPOPND_PTYPE = X'51'; EXPOPND_FLAG = SCONST
                     EXPOPND_D = 0
                  %finish %else %start
                     P = ARP(PARMNO);    ! RESET NEEDED AFTER TSEXP
                     ->BAD PARM %unless %c
                        A(P+3)=4 %and A(P+4)=1 %and A(P+FROMAR2(P+1)+1)=2
                     P = P+5
                     CNAME(3)
                     P = P+1
                     JJ = 1
                     EXPOPND = NAMEOPND
                     ->BAD PARM %unless ACC=PSIZE
                  %finish
                   %if Recvalinwa=yes %and Psize#4 %start
                     get wsp(value,268)
                     opnd1=0; opnd1_flag=local ir
                     opnd1_ptype=X'33'; opnd1_d=rbase<<16!value
                     opnd1_xtra=268
                     ii=brectrip(recass,X'33',0,opnd1,expopnd)
                     triples(ii)_x1=psize
                     %if psize>268 %then fault(99,0,0);! too big (correctable)
                     opnd2=0; opnd2_ptype=X'51'
                     Opnd2_d=psize
                     ii=brectrip(getptr,X'51',0,opnd1,opnd2)
                     opnd1_d=ii; opnd1_flag=reftrip; opnd1_ptype=X'51'
                     ii=brectrip(Pass2,X'33',0,opnd,opnd1)
                     ->next parm
                  %finish
                  FPTR = FPTR+PSIZE
                  %if TARGET=EMAS %then FPTR = FPTR+8;  ! TIRESOME BACK%c
                                                        COMPATIBILITY
                                         ! WITH EMAS IMP ON RECORD VALUES
               %finish %else %if TYPE=5 %then %start
                  %if STRVALINWA=YES %start;  ! USING WORK AREA (2900)
                     CSTREXP(17)
                     PUSH(TWSP,VALUE,0,0);  ! REMEBER WA
                     FPTR = FPTR+PTRSIZE(X'35')
                     pptype = x'51'
                     %if ptrsize(x'35')>4 %then pptype = x'61'
                     opnd1 = 0; opnd2 = 0
                     opnd2_flag = sconst; opnd2_ptype = x'51'
                     opnd2_d = lcell_acc-1
                     opnd1_flag = localir; opnd1_ptype = x'35'
                     opnd1_d = rbase<<16!value
                     opnd1_d = brectrip(getptr,pptype,0,opnd1,opnd2)
                     opnd1_flag = reftrip; opnd1_ptype = pptype
                     ii = brectrip(pass2,x'35',0,opnd,opnd1)
                     ->next parm
                  %finish %else %start
                     CSTREXP(0)
                     FPTR = FPTR+ACC
                  %finish
               %finish %else %start
                  CSEXP(III<<4!II)
                  FPTR = FPTR+BYTES(III)
               %finish
               II = BRECTRIP(PASS1,PTYPE&255,0,OPND,EXPOPND)
               FPTR = (FPTR+MINPARAMSIZE-1)&(-MINPARAMSIZE)
               ->NEXT PARM
!
FPD(2):                                  ! NAME PARAMETERS
               PPTYPE = X'51';           ! PTYPE OF RESULTANT POINTER
               %if PTRSIZE(PTYPE&255)>4 %then PPTYPE = X'61'
               %if II#0 %start;          ! NOT A GENERAL NAME
                  QQQ = 0
                  %if A(P+3)=4 %and A(P+4)=1 %and A(P+FROMAR2(P+1)+1)=2 %start
                     P = P+5
                     REDUCE TAG(YES)
                     %if II=TYPE %and III=PREC %and (LITL#1 %or NAM#0) %and %c
                        (ROUT=0 %or NAM=2) %then QQQ = 1 %else P = P-5
                  %finish
                  %if QQQ#0 %then CNAME(3) {TRUE REF} %else %start
                                         ! EXPRESSION BY REFERENCE
                     ->BAD PARM %unless JJJ=14 %or LP=0
                     ->BAD PARM %if II=3
                     %if II=5 %start;    ! STRING EXPRESSION
                        CSTREXP(17)
                        PUSH(TWSP,VALUE,0,0)
                        QQQ = VALUE
                        OPND2_D = 255
                     %finish %else %start
                        GET WSP(QQQ,BYTES(III)>>2)
                        CSEXP(LCELL_PTYPE&255)
                        OPND2_D = BYTES(III)
                     %finish
                     OPND2_FLAG = SCONST
                     OPND2_PTYPE = X'51'
                   OPND2_XTRA=0
                     OPND1_FLAG = LOCALIR
                     OPND1_PTYPE = LCELL_PTYPE&255
                     OPND1_D = RBASE<<16!QQQ
                     OPND1_XTRA = 268;               ! size of area needed for stack dowm m-cs
                     %if II#5 %then %c
                        QQQ = BRECTRIP(LASS,LCELL_PTYPE&255,0,OPND1,EXPOPND)
                     QQQ = BRECTRIP(GETPTR,PPTYPE,0,OPND1,OPND2)
                     NAMEOPND_FLAG = REFTRIP
                     NAMEOPND_PTYPE = PPTYPE
                     NAMEOPND_D = QQQ
                  %finish
                  JJ = PTRSIZE(III<<4!II)
                  II = BRECTRIP(PASS2,PTYPE&255,0,OPND,NAMEOPND)
                  FPTR = FPTR+JJ
               %finish %else %start
                  ->BAD PARM %unless %c
                     A(P+3)=4 %and A(P+4)=1 %and A(P+1+FROMAR2(P+1))=2
                  P = P+5
                  FNAME = FROM AR2(P)
                  REDUCE TAG(NO)
                  OPND2_PTYPE = X'51'; OPND2_FLAG = SCONST
                  OPND2_D = ACC<<16!PTYPE
                  OPND2_XTRA = 0
                  %if TYPE=0 %start;     ! NAME AS GENERAL NAME
                     NAMEOPND_PTYPE <- PTYPE; NAMEOPND_FLAG = DNAME
                     NAMEOPND_D = FNAME
                     NAMEOPND_XTRA = X'80000000'
                  %finish %else %if NAM#0 %and TYPE=5 %start
                     CNAME(3)
                  %finish %else CNAME(4)
                  EXPOPND_D = BRECTRIP(CTGEN,X'61',0,NAMEOPND,OPND2)
                  EXPOPND_PTYPE = X'61'; EXPOPND_FLAG = REFTRIP
                  EXPOPND_XTRA = 0
                  II = BRECTRIP(PASS5,X'61',0,OPND,EXPOPND)
                  FPTR = FPTR+PTRSIZE(0)
               %finish
               P = P+1
               ->NEXT PARM
FPD(1):
FPD(3):                                  ! ARRAY NAME (&VALUE)
!
! 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
!
               P = P+5
               CNAME(12)
               P = P+1
               ->BAD PARM %unless 1<=ARR<=2 %and II=TYPE %and III=PREC
               II = BRECTRIP(PASS3,PTYPE&255,0,OPND,NAMEOPND)
               QQQ = ASLIST(TCELL)_UIOJ&15;  ! DIMENSION OF ACTUAL(IF KNOWN)
               JJ = LCELL_UIOJ&15;       ! DIMENSION OF FORMAL
               %if JJ=0 %then JJ = QQQ %and LCELL_UIOJ = LCELL_UIOJ!JJ
               %if QQQ=0 %then QQQ = JJ %and %c
                  ASLIST(TCELL)_UIOJ = ASLIST(TCELL)_UIOJ!JJ
               ->BAD PARM %unless JJ=QQQ
               FPTR = FPTR+AHEADSIZE
               ->NEXT PARM
ENTRY SEQ:                               ! CODE FOR RT ENTRY
               %while TWSP>0 %cycle
                  POP(TWSP,QQQ,JJ,III);  ! ONLY IF STR VALS & EMAS
                  RETURN WSP(QQQ,268)
               %repeat
               %if STRRESINWA=YES %and NAMP<=1 %and (TYPEP=3 %or %c
                  TYPEP=5) %start
                  GET WSP(QQQ,268);      ! AUTOMATIC RETURN
                  OPND2_PTYPE <- PT
                  OPND2_FLAG = LOCALIR
                  OPND2_D = RBASE<<16!QQQ
                  OPND2_XTRA = 268
                  Opnd_ptype<-pt; opnd_flag=dname
                  opnd_d=rtname; opnd_xtra=(pspeced+1)<<24
                  II = BRECTRIP(PASS6,PT,0,OPND,OPND2)
                  FPTR = FPTR+PTRSIZE(X'35')
               %finish
               II = UNAMETRIP(RCALL,PT&255,0,RTNAME)
               TRIPLES(II)_OPND1_XTRA = FPTR;  ! PASS PARAM SIZE TOTAL
               CURRINF_NMDECS = CURRINF_NMDECS!2
               ROUT = 1; TYPE = TYPEP; NAM = NAMP
               PREC = PRECP; PTYPE = PT
!
! RECOVER THE RESULT OF FNS & MAPS. OFTEN NOCODE WILL BE NEEDED
!
               %if PT&255#0 %start
                  %if NAM>=2 %then II = RCRMR %else II = RCRFR
                  II = UNAMETRIP(II,PT&255,0,RTNAME)
                  %if STRRESINWA=YES %then TRIPLES(II)_OPND1_XTRA = QQQ
                                         ! WORK AREA OFFSET
                  NAMEOPND_PTYPE = PT&255; NAMEOPND_FLAG = REFTRIP
                  NAMEOPND_D = II
                  NAMEOPND_XTRA = 0
               %finish
OVER:          P = OUTP
            %end;                        ! OF INNER BLOCK
         %end
         %integer %fn TSEXP(%integer %name VALUE)
            %switch SW(1:3)
            %integer PP,REXP,KK,SIGN,CT
            TYPE = 1; PP = P
            REXP = 2-A(P+1+FROM AR2(P+1))
            P = P+3
            SIGN = A(P)
            ->TYPED %unless SIGN=4 %or A(P+1)=2
            ->SW(A(P+1))
SW(1):                                   ! NAME
            P = P+2; REDUCE TAG(NO)
            ->TYPED
SW(2):                                   ! CONSTANT
            CT = A(P+2); TYPE = CT&7
            ->TYPED %unless CT=X'41' %and SIGN#3
            KK = FROMAR2(P+3)
            ->TYPED %unless REXP=0 %and 0<=KK<=255
            VALUE = KK
            P = P+6
            %if SIGN#2 %then %result = 1
            VALUE = -VALUE; %result = -1
SW(3):                                   ! SUB EXPRN
TYPED:      P = PP; %result = 0
         %end
         %routine SKIP EXP
!***********************************************************************
!*       SKIPS OVER THE EXPRESSION POINTED AT BY P. USED FOR ERROR     *
!*       RECOVERY AND TO EXTRACT INFORMATION ABOUT THE EXPRESSION.     *
!***********************************************************************
            %integer OPTYPE,PIN,J
            PIN = P
            P = P+3;                     ! TO P<+'>
            %cycle;                      ! DOWN THE LIST OF OPERATORS
               OPTYPE = A(P+1);          ! ALT OF P<OPERAND>
               P = P+2
               %if OPTYPE=0 %or OPTYPE>3 %then IMPABORT
               %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=5 %then P = P+A(P+1)+2 %else P = P+1+BYTES(A(P)>>4)
               %finish
!
               %if OPTYPE=1 %then %start;  ! NAME
                  P = P-1
                  P = P+3 %and SKIP APP %until A(P)=2;  ! 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                                   *
!*       P IS ON ALT OF P<APP> AT ENTRY                                *
!***********************************************************************
            %integer PIN
            PIN = P
            P = P+1 %and SKIP EXP %while A(P)=1
            P = P+1
         %end
         %routine NO APP
            P = P+2
            %if A(P)=1 %then %start;     ! <APP> PRESENT
               FAULT(17,0,FROM AR2(P-2))
               SKIP APP
            %finish %else P = P+1;       ! P NOW POINTS TO ENAME
         %end
         %routine TEST APP(%integer %name NUM)
!***********************************************************************
!*       THIS ROUTINE COUNTS THE NUMBER OF ACTUAL PARAMETERS           *
!*       WHICH IT RETURNS IN NUM.                                      *
!***********************************************************************
            %integer PP,Q
            Q = 0; PP = P; P = P+2;      ! 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 SET LINE
!***********************************************************************
!*       UPDATE THE STATEMENT NO                                       *
!***********************************************************************
%integer I,offset
            %return %if RLEVEL=0;        ! AMONG CONDITIONAL GLOBAL DECS
            offset=CURRINF_DIAGINF+2
            %if target=ORN %or 1<<target&riskmc#0 %Then Offset=Offset+2
            I = UCONSTTRIP(SLINE,X'41',0,LINE<<16!Offset)
            %if PARM_PROF#0 %then %start
               I = PROFAAD+4+4*LINE
            %finish
         %end
%routine STORE TAG(%integer KK,LEVEL,RBASE,J,SNDISP,ACC,SLINK,KFORM)
            %integer Q,I,TCELL
            %record (TAGF) %name LCELL
            TCELL = TAGS(KK)
!
! above line to stop local and routine having the same name
!
            Q = LEVEL<<8!RBASE<<4!J
            IMPABORT %unless (KFORM!ACC)>>16=0
            LCELL == ASLIST(TCELL)
            %if LCELL_UIOJ>>8&63=LEVEL %or kk=currinf_m-1 %then %start
               FAULT(7,0,KK)
               LCELL_UIOJ <- LCELL_UIOJ&X'C000'!Q;  ! COPY USED BITS ACCROSS
            %finish %else %start
               I = ASL; %if I=0 %then I = MORE SPACE
               LCELL == ASLIST(I)
               ASL = LCELL_LINK
               LCELL_LINK = TCELL!CURRINF_NAMES<<18
               LCELL_UIOJ = Q
               TAGS(KK) = I
               CURRINF_NAMES = KK
            %finish
            LCELL_PTYPE <- PTYPE
            LCELL_ACC <- ACC
            LCELL_SNDISP <- SNDISP
            LCELL_KFORM = KFORM
            LCELL_SLINK <- SLINK
         %end
         %routine COPY TAG(%integer TNAME,DECLARE)
!***********************************************************************
!*    A TAG IS A LIST CELL POINTED AT BY TAGS(NAME)                    *
!*    S1 HAS PTYPE<<16!USEBITS(2)!TEXT LEVEL(OLDI6)!RTLEVE(4)!DIMEN    *
!*    S2 HAS SECONDARY DISP(SIGNED)<<16! ACC OR ITEM SIZE IN BYTES     *
!*    S3 HAS PRIMARY DISP(K)<<16!KFORM WHICH IS POINTER TO FORMAT      *
!*                SIDE CHAIN FOR ITEMS OF TYPE RECORD                  *
!*    LINK HAS PTR TO TAG OF NAME HIDDEN WHEN THIS ONE DECLARED        *
!***********************************************************************
            %record (TAGF) %name LCELL
            TCELL = TAGS(TNAME)
            %if TCELL=0 %then %start;    ! NAME NOT SET
               TYPE = 7; PTYPE = X'57'; PREC = 5
               %if DECLARE=YES %start
                  FAULT(16,0,TNAME)
                  STORE TAG(TNAME,LEVEL,RBASE,0,0,4,N,0)
                  N = N+4
                  COPY TAG(TNAME,NO);    ! TO SET USE BITS
                  %return
               %finish
               ROUT = 0; NAM = 0; ARR = 0; LITL = 0; ACC = 4
               I = -1; J = -1; K = -1; OLDI = -1
            %finish %else %start
               LCELL == ASLIST(TCELL)
               PTYPE = LCELL_PTYPE&X'FFFF'
               USEBITS = LCELL_UIOJ>>14&3
               OLDI = LCELL_UIOJ>>8&63
               I = LCELL_UIOJ>>4&15
               J = LCELL_UIOJ&15
               LCELL_UIOJ <- LCELL_UIOJ!X'8000'
               MIDCELL = LCELL_S2
               SNDISP = LCELL_SNDISP&X'FFFF';  ! Sign extension on some hosts
               ACC = LCELL_ACC&X'FFFF'
               K = LCELL_SLINK&X'FFFF';  ! Sign extension on some hosts
               KFORM = LCELL_KFORM
               LITL = PTYPE>>14&3;       ! SIGNEXTENSION ON 16 BIT MACHINES
               ROUT = PTYPE>>12&3
               NAM = PTYPE>>10&3
               ARR = PTYPE>>8&3
               PREC = PTYPE>>4&15
               TYPE = PTYPE&15
            %finish
         %end
         %routine REDUCE TAG(%integer DECLARE)
!***********************************************************************
!*       AS COPY TAG FOR NAME AT A(P) EXCEPT:-                         *
!*       1) SPECIAL NAMES HAVE THEIR CORRECT PREC & TYPE SUBSTITUTED   *
!*       2) RECORD ELEMENTS HAVE THE SUBNAME PARTICULARS RETURNED      *
!***********************************************************************
            %integer SUBS,QQ,PP
            COPY TAG(FROMAR2(P),DECLARE)
            %if PTYPE=SNPT %then %start
               PTYPE = ACC; UNPACK
               %if k=42 {string} %then acc = 256 %else %if %c
                  k=48 {record} %then acc = x'7fff' %else ACC = BYTES(PREC)
            %finish;                     ! TO AVOID CHECKING PARAMS
            %if TYPE=3 %then %start
               PP = P; QQ = COPY RECORD TAG(SUBS); P = PP
            %finish
         %end
! LAYOUT OF PTYPE
! ****** ** *****
! PTYPE REQUIRES 16 BITS TO DEFINE A VARIABLE AND CAN BE REGARDED AS
! AS TWO BYTEINTEGERS:=
! UPPER ONE(UPTYPE):= LITL<<6!ROUT<<4!NAM<<2!ARR
! LOWER ONE(PTYPE) :=PREC<<4!TYPE
! OFTEN (EG IN EXPOP) ONLY THE LOWER PART IS REQUIRED AS FUNCTIONS
! ETC ARE PREFETCHED AND STACKED.
! LITL:= 1=CONST,2=EXTERNAL,3=EXTRINSIC(OR DYNAMIC), 0=NONE OF THESE
! ROUT:= 1 FOR ROUTINE OR FN OR MAP, =0 NONE OF THESE
! NAM := 2 FOR MAPS AND 'REFREFS',=1 FOR NAMES ,=0 DIRECTLY ADDRESSED
! ARR :=1 FOR ARRAYS =0 SCALARS
! PREC IS DESCRIPTOR SIZE CODE FOR EACH PRECISION:-
!     :=0 BITS,=3 BYTES, =5 WORDS, =6 D-WRDS, =7,QUAD WRDS
! TYPE:= THE VARIABLE TYPE
!     :=0 (TYPE GENERAL),=1 INTEGER, =2 REAL, =3 RECORD
!     :=4 (RECORDFORMAT),=5 STRING,  =6 LABEL/SWITCH. =7 NOT SET
!
         %routine UNPACK
            LITL = PTYPE>>14
            ROUT = PTYPE>>12&3
            NAM = PTYPE>>10&3
            ARR = PTYPE>>8&3
            PREC = PTYPE>>4&15
            TYPE = PTYPE&15
         %end
         %routine PACK(%integer %name PTYPE)
            PTYPE = (((((LITL&3)<<2!ROUT&3)<<2!NAM&3)<<2!ARR&3)<<4!PREC&15) %c
               <<4!TYPE&15
         %end
      %end;                              ! OF ROUTINE CSS

      %integer %fn NEWTRIP
!***********************************************************************
!*    SETS UP A NEW TRIPLE AND LINKS IT IN
!***********************************************************************
         %record (TRIPF) %name CURRT
         %integer I
         CURRT == TRIPLES(NEXT TRIP)
         I = NEXT TRIP
         %if I>=WORKA_LAST TRIP %then FAULT(102,WORKA_WKFILEK,0)
         NEXT TRIP = NEXT TRIP+1
         CURRT = 0
         CURRT_BLINK = TRIPLES(0)_BLINK
         TRIPLES(0)_BLINK = I
         TRIPLES(CURRT_BLINK)_FLINK = I
         %result = I
      %end
      %integer %fn UCONSTTRIP(%integer OPERN,OPTYPE,FLAGS,CONST)
!***********************************************************************
!*    SETS UP A UNARY TRIPLE WITH CONSTANT OPERAND                     *
!***********************************************************************
         %record (TRIPF) %name CURRT
         %integer CELL
         CELL = NEW TRIP
         CURRT == TRIPLES(CELL)
         CURRT_OPERN = OPERN
         CURRT_OPTYPE <- OPTYPE
         CURRT_FLAGS <- FLAGS
         CURRT_OPND1_PTYPE = X'51'
         CURRT_OPND1_D = CONST
	CURRT_OPND1_XTRA = 0
         %result = CELL
      %end
      %integer %fn ULCONSTTRIP(%integer OPERN,OPTYPE,FLAGS,CONST1,CONST2)
!***********************************************************************
!*    SETS UP A UNARY TRIPLE WITH CONSTANT OPERAND                     *
!***********************************************************************
         %record (TRIPF) %name CURRT
         %integer CELL
         CELL = NEW TRIP
         CURRT == TRIPLES(CELL)
         CURRT_OPERN = OPERN
         CURRT_OPTYPE <- OPTYPE
         CURRT_FLAGS <- FLAGS
         CURRT_OPND1_PTYPE = X'61'
         CURRT_OPND1_D = CONST1
         CURRT_OPND1_XTRA = CONST2
         %result = CELL
      %end
      %integer %fn UNAMETRIP(%integer OPERN,OPTYPE,FLAGS,NAME)
!***********************************************************************
!*    SETS UP A UNARY TRIPLE WITH ONE NAME OPERAND                     *
!***********************************************************************
         %record (TAGF) %name TAGINF
         %record (TRIPF) %name CURRT
         %integer CELL
         TAGINF == ASLIST(TAGS(NAME))
         CELL = NEW TRIP
         CURRT == TRIPLES(CELL)
         CURRT_OPERN = OPERN
         CURRT_OPTYPE <- OPTYPE
         CURRT_FLAGS <- FLAGS
         CURRT_OPND1_PTYPE = TAGINF_PTYPE
         CURRT_OPND1_FLAG = DNAME
         CURRT_OPND1_D = NAME
         CURRT_OPND1_XTRA = 0
         %result = CELL
      %end
      %integer %fn UTEMPTRIP(%integer OPERN,OPTYPE,FLAGS,TEMP)
!***********************************************************************
!*    SETS UP A UNARY TRIPLE WITH LOCAL TEMPORARY OPND                 *
!***********************************************************************
         %integer CELL
         %record (TRIPF) %name CURRT
         CELL = NEWTRIP
         CURRT == TRIPLES(CELL)
         CURRT_OPERN = OPERN
         CURRT_OPTYPE <- OPTYPE
         CURRT_FLAGS <- FLAGS
         CURRT_OPND1_PTYPE = OPTYPE; CURRT_OPND1_FLAG = LOCALIR
         CURRT_OPND1_D = TEMP
         CURRT_OPND1_XTRA = 0
         %result = CELL
      %end
      %routine KEEPUSECOUNT(%record (RD) %name OPND)
!***********************************************************************
!*    KEEPS PUSE AND CNT UP TO DATE                                    *
!***********************************************************************
         %record (TRIPF) %name REFT
         REFT == TRIPLES(OPND_D)
         %if REFT_CNT=0 %then %start
!            printstring("setting puse ")
!            write(opnd_d,4); write(triples(0)_blink,4); write(reft_puse,3)
!             newline
           REFT_PUSE = TRIPLES(0)_BLINK
         %finish
         REFT_CNT = REFT_CNT+1
      %end
      %integer %fn URECTRIP(%integer OPERN,OPTYPE,FLAGS,
         %record (RD) %name OPND1)
!***********************************************************************
!*    SETS UP A BINARY TRIPLE WITH  COMPLETE OPERANDS PROVIDED         *
!***********************************************************************
         %integer CELL,TEST
         %record (TRIPF) %name CURRT
         CELL = NEWTRIP
         CURRT == TRIPLES(CELL)
         CURRT_OPERN = OPERN
         CURRT_OPTYPE <- OPTYPE
         CURRT_FLAGS <- FLAGS
        TEST=OPND1_d
         TEST=OPND1_XTRA
         CURRT_OPND1 = OPND1
         %if 1<<OPND1_FLAG&BTREFMASK#0 %then KEEPUSECOUNT(OPND1)
         %result = CELL
      %end
      %integer %fn BRECTRIP(%integer OPERN,OPTYPE,FLAGS,
         %record (RD) %name OPND1,OPND2)
!***********************************************************************
!*    SETS UP A BINARY TRIPLE WITH  COMPLETE OPERANDS PROVIDED         *
!***********************************************************************
         %integer CELL,TEST
         %record (TRIPF) %name CURRT
         CELL = NEWTRIP
         CURRT == TRIPLES(CELL)
         CURRT_OPERN = OPERN
         CURRT_OPTYPE <- OPTYPE
         CURRT_FLAGS <- FLAGS
         TEST=OPND1_D
         TEST=OPND1_XTRA
         CURRT_OPND1 = OPND1
         TEST=OPND2_D
         TEST=OPND2_XTRA
         CURRT_OPND2 = OPND2
         %if 1<<OPND1_FLAG&BTREFMASK#0 %then KEEP USE COUNT(OPND1)
         %if 1<<OPND2_FLAG&BTREFMASK#0 %then KEEP USE COUNT(OPND2)
         %result = CELL
      %end
      %routine GET WSP(%integer %name PLACE, %integer SIZE)
!***********************************************************************
!*       FIND OR CREATE A TEMPORARY VARIABLE OF 'SIZE' WORDS           *
!***********************************************************************
         %integer J,K,L,F
         F = SIZE>>31;                   ! TOP BIT SET FOR MANUAL RETURN
                                         ! OTHERWISE NOTE IN TWSP LIST
                                         ! FOR AUTOMATIC RETURN
         SIZE = SIZE<<1>>1
         %if SIZE>4 %then SIZE = 0
         POP(CURRINF_AVL WSP(SIZE),J,K,L)
         %if K<=0 %then %start;          ! MUST CREATE TEMPORARY
            %if size=4 %then l=rnding(128+x'72') %else %if Size=2 %c
                %then l=rnding(128+x'62') %else l=3
            n=(n+L)&(\l)
            K = N
            %if SIZE=0 %then N = N+268 %else N = N+SIZE<<2
         %finish
         PLACE = K
         PUSH(TWSPHEAD,K,SIZE,0) %unless F#0
      %end
      %routine RETURN WSP(%integer PLACE,SIZE)
!***********************************************************************
!*    RETURNS WORKSPACE TO ORDERED FREE LIST. ADDRESSABLE CELLS        *
!*    ARE PUT AT THE TOP. NON-ADDRESSABLE ON THE BACK                  *
!***********************************************************************
         %integer CELL
         IMPABORT %unless PLACE<=N %and PLACE&1=0
         %if SIZE>4 %then SIZE = 0
         CELL = CURRINF_AVL WSP(SIZE)
         %while CELL>0 %cycle
            IMPABORT %if ASLIST(CELL)_S2=PLACE
            CELL = ASLIST(CELL)_LINK
         %repeat
         %if PLACE<511 %then PUSH(CURRINF_AVL WSP(SIZE),0,PLACE,0) %else %c
            INSERT AT END(CURRINF_AVL WSP(SIZE),0,PLACE,0)
      %end
      %routine REUSE TEMPS
         %integer JJ,KK,QQ
         %while TWSPHEAD#0 %cycle
            POP(TWSPHEAD,JJ,KK,QQ)
            RETURN WSP(JJ,KK)
         %repeat
      %end
      %integer %fn FROMAR2(%integer PTR)
         %result = A(PTR)<<8!A(PTR+1)
      %end
      %integer %fn FROMAR4(%integer PTR)
         %integer I
         MOVE BYTES(4,ADDR(A(0)),PTR,ADDR(I),0)
         %result = I
      %end
P2END:                                   ! EXITS AFTER COMPILATION
   %end;                                 ! OF SUBBLOCK CONTAINING PASS2
%end
%end %of %file
