pass2.i

    !
    ! 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 ICL9CEZRS6IMP
    constinteger RELEASE=4
    include "hostcodes.inc"
    !
    CONSTINTEGER HOST=mips
    CONSTINTEGER TARGET=MIPS
    CONSTINTEGER STANDARDPT=X'51'
    CONSTINTEGER MINAPT=X'51';              ! MINIMUM PTYPE FOR WHICH ARITHMETIC
                                            ! OPERATORS ARE AVAILABLE
    CONSTINTEGER MINAPREC=MINAPT>>4
    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,
                                            X'61'{%LONG INTEGER FAULT},
                                            X'62'{%LONG REAL},
                                            X'72'{%LONGLONGREAL WARN};
    !
    ! 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,0,4,0(13)             {PREC=6},
                                            8,0(15)                 {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=YES;            ! 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,7,7,0(13)                    {PREC=6},
             0,7,7,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,7,7,0(13)                    {PREC=6},
             0,7,7,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,7,7,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=NO;           ! YES FOR REVERSED PARAMETERS
    CONSTINTEGER DISPLAY NEEDED=YES;        ! DISPLAY NEEDED IN LOCAL SPACE
    CONSTINTEGER DISPLAY ROUNDING=7;       ! Display on D-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
    !

    !!{GT:}%include "impcompdate.inc"
       const string (9) LADATE="Apr 95";    ! LAST ALTERED
       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, iblkid, 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
       integer curlinead,nextlinead,currentSSalt
       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=Gouldor Host=M88k or Host=RS6 or Host=MIPS  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)! MAXDICT
          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)
      recordformat swdataform(integer lseen,default,integerarray slabs(0:1023))
       externalroutinespec free(integer ad)
       externalintegerfnspec malloc(integer space)
       external routine spec INITASL(record (LISTF) array name A,
          integer name B)
     externalroutinespec printtrips(record(tripf)arrayname trops)
     externalroutinespec phex (integer val)
       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  first 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))
    externalstringfnspec printname (integer jj)
       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_const ptr=1;                ! leaving zero for dont knows
          WORKA_ASLIST == ASLIST
          PLABEL = 24999
          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,internalblockid
          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
          routine spec outsym(integer sym)
          routinespec force line
          routine spec outstring(string(255) str)
          routinespec outint(integer id)
          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)
           recordformat outform(integer line,length,lastnl,prevlast,bytearrayname l)
          ownbyteintegerarray lspace(0:128*1024)
          ownrecord(outform) opline
          constinteger breakoplines=99

          opline=0
          opline_l==lspace
          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
          internalblockid=0
          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
          outsym(NL)
          outstring("/* end of automatic translation */")
          outsym(NL)
          force line
          LINE = 99999
          EPILOGUE(STMTS)

          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
    integerfn insert curly(integer cad,at)
    !***********************************************************************
    !*  Adds in a curly bracket comment                                    *
    !*  Checks for the case of a C macro (Ist char #) %and reinserts       *
    !*  The 'comment' unchanged                                            *
    !***********************************************************************
    integer i,j,k,scount,res
    ownbytearray save (1:64*1024)
          scount=0
          if at >opline_length then at=opline_length { should not happen }
          for i=at,1,opline_length-1 cycle
              scount=scount+1
              save(scount)=opline_l(i)
          repeat
          opline_length=at

          if byteinteger(curlinead)#'#' { C macro } start
             outsym(9)            { Tab }
             outstring("/*")
          else
             outsym('{')
          finish
          j=cad
          i=0
          cycle
             j=j+1; i=i+1
             if byteinteger(j)=NL or byteinteger(j)='}' start
                if byteinteger(curlinead)#'#' { C macro } start
                   outstring("*/")
                else
                   if byteinteger(j)='}' then outsym('}')
                finish
                res=i+1
                exit
              else
                 opline_l(opline_length)=byteinteger(j)
                 opline_length=opline_length+1
              finish
            repeat
          for i=1,1,scount cycle
            opline_l(opline_length)=save(i)
            opline_length=opline_length+1
          repeat
          result=res
    end
    integerfn locate curly(integer cad)
    !***********************************************************************
    !* Try to find where to insert a curly comment by counting commas      *
    !***********************************************************************
    integer ccount,firstc,i,bcount,commaafter
          ccount=0; bcount=0; commaafter=0
    !
    ! first check if there is a comma after the curly comment
    !
         i=cad
         i=i+1 until byteinteger(i)='}' or byteinteger(i)=NL
         if byteinteger(i)='}' start
            i=i+1
            i=i+1 while byteinteger(i)=' '
            if byteinteger(i)=',' then commaafter=1 and ccount=1
         finish
          for i=cad,-1,curlinead cycle
             if byteinteger(i)=',' start
                if ccount=0 then firstc=i
                ccount=ccount+1
             finish
          repeat
          if ccount=0 then result=opline_length
          if commaafter=0 start
             for i=firstc,1,cad-1 cycle
                 if 33<=byteinteger(i)<=127 then bcount=bcount+1
                 if byteinteger(i)='{' or byteinteger(i)='}' then bcount=bcount+1
             repeat
          finish
          for i=0,1,opline_length cycle
             if opline_l(i)=',' or opline_l(i)=';' start
                ccount=ccount-1
                if ccount=0 then -> next
             finish
          repeat
          result=opline_length
    next:
    !printstring("locate "); write(commaafter,1); write(bcount,0)
    !     write(opline_l(i),4);  write(opline_l(i+1),4); newline
          if commaafter#0 then result=i
          if bcount=0 then result=i+1
          for i=i,1,opline_length cycle
            if 33<=opline_l(i)<=127 then bcount=bcount-1
            if bcount=0 then start
                i=i+1 while i<opline_length-1 andc
                   ('a'<=opline_l(i+1)<='z' or 'A'<=opline_l(i+1)<='Z' orc
                     '0'<=opline_l(i+1)<='9' or opline_l(i+1)='_') andc
                   ('a'<=opline_l(i)<='z' or 'A'<=opline_l(i)<='Z' orc
                     '0'<=opline_l(i)<='9' or opline_l(i)='_')
                if opline_l(i+1)='*' and opline_l(i)='/' then i=i-1
                if opline_l(i+1)='/'  and opline_l(i)='*' then i=i+1
                 if opline_l(i+1)='*' and opline_l(i+2)='/' then i=i+2
    !printstring("locate2 ");     write(opline_l(i),4);  write(opline_l(i+1),4); newline
                result=i+1
            finish
          repeat
          result=opline_length
    end
    routine curly check(integer mode)
    owninteger last linead
    integer i,at

    !printstring("checking curly"); write(nextlinead,6); write(curlinead,6)
    !write(last linead,6); printsymbol(byteinteger(curlinead));
    !printsymbol(byteinteger(curlinead+1)); printsymbol(byteinteger(curlinead+2));
    !printsymbol(byteinteger(curlinead+3)); printsymbol(byteinteger(curlinead+4));newline
    !         %if nextlinead=curlinead %start
    !           i=curlinead
    !           i=i+1 %while byteinteger(i)=' '
    !           %if byteinteger(i)='{' %then warn(12,0)
    !        %finish
             if nextlinead>curlinead and curlinead#last linead  c
               and nextlinead-curlinead <=2047 start
                for i=curlinead,1,nextlinead-1 cycle
                   if byteinteger(i)='{' then start
                     at=locate curly(i)
                     i=i+insert curly(i,at)
    !                 %if mode=1 %then warn(12,0)
                   finish
                repeat
               last linead=curlinead     { avoid multiple copies of curlies }
             finish
    end
    !*
    routine force line
    !***********************************************************************
    !*   Push out current line after dealing with any missed or            *
    !*   faulty lines and merging back any {} comments                     *
    !***********************************************************************
    integer i,at
    externalintegerspec filesseen
          if filesseen=0 or line <20000 start { omit include ifiles if any }
    !printstring("Force line"); write(nextlinead,5); write(curlinead,5); write(lastlinead,5); newline
    !      %for i=curlinead,1,nextlinead %cycle
    !          printsymbol(byteinteger(i))
    !      %repeat
    !      newline
    !      %for i=0,1,opline_length-1 %cycle
    !           printsymbol(opline_l(i))
    !      %repeat
    !     newline
    !        printstring("  end of force line daignostics"); newline
             curlycheck(0)
             return if opline_length=0
             for i=0,1,opline_length-1 cycle
                print symbol(opline_l(i))
             repeat
             newline
          finish
          i=opline_length-1
          i=i-1 while I>0 and (opline_l(i)='}' or opline_l(i)=NL )
    	if i>=0 then opline_prevlast=opline_l(i)
          opline_length=0
          opline_lastnl=-1
    end
    routine outsym(integer sym)
          if sym=NL then opline_lastnl=opline_length
          opline_l(opline_length)=sym
          opline_length=opline_length+1
          if currentSSalt=12{Const integers and constlists } and sym=',' c
             and opline_length-opline_lastnl > breakoplines>>1 start
             outsym(NL); return
          finish
          if opline_length-opline_lastnl > breakoplines start
             if opline_l(opline_lastnl+1)#'#' start
                if sym=' ' or sym=',' or sym=')' then outsym(NL)
             finish
          finish
    end {outsym}
    !*
    routine outsep
    !***********************************************************************
    !*    Outputs a semicolon avoiding obvious duplicates                  *
    !***********************************************************************
    integer i
          i=opline_length-1
          while i>=0 and c
             (opline_l(i)=NL or opline_l(i)='}') cycle
             i=i-1
          repeat
    !      printstring("Outsep i,l(i),prev="); write(i,1); space
    !      printsymbol(opline_l(i))%if i>=0
    !      space; printsymbol(opline_prevlast); newline
          if i>=0 and opline_l(i)=';' then return
          if i<0 and opline_prevlast=';' then return
          outsym(';')
    end {outsep}
    !*
    routine outstring(string(255) s)
    integer i,j,sym
          j=opline_length
          for i=1,1,length(s) cycle
             sym=charno(s,i)
             if sym=NL then start
                opline_l(j)='¬'; opline_l(j+1)='n'; j=j+2
             finish else if sym='"' start
                opline_l(j)='¬'; opline_l(j+1)='"'; j=j+2
             else
                opline_l(j)=sym
                j=j+1
             finish
          repeat
          opline_length=j
    end
    routine outcommentend
          if opline_l(opline_length-1)#'*' start
    {GT:}    ! Let 'indent' take care of this ...
             !outsym(' ') %while opline_length-opline_lastnl <78
          finish
          outstring("*/")
    end
    string(255)fn validname(string(255) name)
    !***********************************************************************
    !* Check name is not a C reserved word. If so amaned it                *
    {GT:} ! Should also check for std library names???
    !***********************************************************************
    constinteger nr=34+1
    conststring(11)array rnames(0:nr)="sizeof","auto","static","extern","register",
                                        "typedef","char","short","long","int",
                                        "unsigned","float","double","void","enum",
                                        "struct","union","if","else","while",
                                        "do","for","switch","case","default",
                                        "break","continue","return","goto","abs",
                                        "fabs","volatile","asm","const","signed",
                        { AND NOW LIBS }"exit"
    integer i
          for i=0,1,nr cycle
             if name=rnames(i) then start
                charno(name,1)=charno(name,1)-32
                result=name
             finish
          repeat
          result=name
    end
    !*
    routine revisename(string(255)name name)
    integer i
         {if parm_quotes#0 %then} return
         for i=1,1,length(name) cycle
            if 'a'<=charno(name,i)<='z' then charno(name,i)=charno(name,i)-32
         repeat
    end
    !*
    routine outname(integer id)
    !***********************************************************************
    !*    produce name text from an id                                     *
    !***********************************************************************
    integer i,ad
    record(listf)name lcell
    string(255) name
          i=worka_word(id)
          ad=addr(worka_lett(i))
          name=string(ad)
          lcell==aslist(worka_tags(id))
          if lcell_ptype&x'ff00'=x'4000' and lcell_uioj&x'f0'=0 c
             then revisename(name)
          name=validname(name) unless lcell_ptype=x'156'   { Dont revise switches CmcP }
          outstring(name)
          if opline_length-opline_lastnl > breakoplines start
             if opline_l(opline_lastnl+1)#'#' then outsym(NL)
          finish
    end
    !*
    routine outswadname(integer id)
    !***********************************************************************
    !*   output a sw name adjusting it if in an inner block
    !***********************************************************************
    integer i,ad
    record(listf)name lcell
    string(255) name
          i=worka_word(id)
          ad=addr(worka_lett(i))
          name=string(ad)
          lcell==aslist(worka_tags(id))
          if lcell_ptype&x'ff00'=x'4000' and lcell_uioj&x'f0'=0 c
             then revisename(name)
          outstring(name)
          if currinf_iblkid>0 start
             outsym('_'); outint(currinf_iblkid)
          finish
    end

    integerfn possible typename(integer id,stringname typename)
    !***********************************************************************
    !*   if id ends in "...type" set typename to ..._type                  *
    !***********************************************************************
    integer i,ad,j
    string(255) name,firstpart,s,t
          i=worka_word(id)
          ad=addr(worka_lett(i))
          name=string(ad)
          j=0;
          while name -> s.("type").name cycle
             if j=0 then firstpart=s else firstpart=firstpart."type".s
            j=j+1
          repeat
          if name="" and length(firstpart)>3 start      { ended in ...type }
             typename=firstpart."_type"
             result=1
          else
             typename="not_a_valid_type_name"
             result=0
          finish
    end

    routine outrevisablename(integer id)
    !***********************************************************************
    !*    produce name text from an id  and revise without tag check       *
    !***********************************************************************
    integer i,ad
    string(255) name
          i=worka_word(id)
          ad=addr(worka_lett(i))
          name=string(ad)
          revisename(name)
          outstring(validname(name))
          if opline_length-opline_lastnl > breakoplines start
             if opline_l(opline_lastnl+1)#'#' then outsym(NL)
          finish
    end
    !*
    routine out formatname(integer kf)
    integer i,kk
    record(listf)name lcell
    string(255) s
          for i=0,1,worka_nnames cycle
             kk=tags(i)
             if kk#0 start
                lcell==aslist(kk)
                if lcell_ptype&15=4 and lcell_kform=kf start
                   if possible typename(i,s)>0 start
                      outstring(s)
                   else
                      if lcell_ptype=4 then outstring("struct ") else outstring("union ")
                      outname(i)
                   finish
                   return
                finish
             finish
           repeat
           outstring(" ? unknown format name ?")
    !      %monitor
    end
    !*
    !*
    routine out extern(integer extern)
          if extern&3=0 start
             outstring("static const ")
          finish else if extern=1 start
            outstring("static ")
          finish else if extern=3 start
            outstring("extern ")
          finish
    end
    routine outhex(integer value)
    CONSTSTRING(1)ARRAY HEX(0:15)="0","1","2","3","4",
                   "5","6","7","8","9","A","B","C","D","E","F"
    INTEGER I,digit
    STRING(8)RES
          RES=""
          FOR I=8<<2-4,-4,0 CYCLE
             digit=VALUE>>I&15
              if res#"" or digit#0 then RES=RES.HEX(digit)
          REPEAT
          if res="" then res="0"
          outstring("0x".res)
    end

    routine outtype(integer type,kf)
          if type=x'31' start
             outstring("unsigned char ")
          finish else if type=x'41' start
             outstring("short int ")
          finish else if type=x'51' start
             outstring("int ")
          finish else if type=x'61' start
             outstring("INT64 ")
          finish else if type=x'52' start
             outstring("float ")
          finish else if type=x'62' start
             outstring("double ")
          finish else if type=x'72' start
             outstring("long double ")
          finish else if type=x'35'  start
              outstring("char * ")
          finish else if type=x'33' start
              outformatname(kf)
             outsym(' ')
          else
             outstring("void ")
    {GT:DEBUG outstring("/*");outhex(type);outstring("*/")}
          finish
    end {outtype }
    !*
    routine outxtype(integer xtype,kf)
    integer rout,nam,arr,type
           rout=xtype>>12&1
           nam=xtype>>10&3
           arr=xtype>>8&3
           type=xtype&7
           outtype(xtype&255,kf)
           if (rout#0 or arr#0 or nam&1#0) and type#5 then outsym('*')
    end

    routine outlhex(integer msh,lsh)
    CONSTSTRING(1)ARRAY HEX(0:15)="0","1","2","3","4",
                   "5","6","7","8","9","A","B","C","D","E","F"
    INTEGER I,digit
    string(16)res
          RES=""
          FOR I=8<<2-4,-4,0 CYCLE
             digit=msh>>I&15
              if res#"" or digit#0 then RES=RES.HEX(digit)
          REPEAT
          FOR I=8<<2-4,-4,0 CYCLE
             digit=lsh>>I&15
              if res#"" or digit#0 then RES=RES.HEX(digit)
          REPEAT
          if res="" then res="0"
          outstring("0x".res)
    end
    {GT: outhex moved higher up}
    !*
    routine outint(integer value)
    !***********************************************************************
    !*    SIMPLE MINDED ALL IMP VERSION NOT USING STRINGS                  *
    !***********************************************************************
    INTEGER SIGN,WORK,PTR
    BYTEINTEGERARRAY CH(0:15)
          if value=x'80000000' then outhex(value) and return
          SIGN=' '
          IF VALUE<0 THEN SIGN='-' AND VALUE=-VALUE
          PTR=0
          CYCLE
             WORK=VALUE//10
             CH(PTR)=VALUE-10*WORK
             VALUE=WORK
             PTR=PTR+1
          REPEATUNTIL VALUE=0
          WORK=PTR-1
          OUTSYM(SIGN) if sign='-'
          outSYM(CH(PTR)+'0') FOR PTR=WORK,-1,0
    end
    !*
    routine outinternames(integer info)
    !***********************************************************************
    !* output any intermediate (union) names needed to access              *
    !* elements of imps more general record as C struct                    *
    !************************************************************************

    integer k,id
          for k=12,-4,0 cycle
             id=info>>k&15
             if id#0 start
                if id&8#0 then start
                   outstring("s")
                   outint(id&7)
                else
                   outstring("u")
                   outint(id&7-1{ union update })
                finish
                outsym('.')
             finish
          repeat
    end
    !*
    ROUTINESPEC OUTFL (LONGREAL X, INTEGER N)
    ROUTINE PRINT (LONGREAL X, INTEGER N,M)
    !***********************************************************************
    !*       PRINTS A REAL NUMBER (X) ALLOWING N PLACES BEFORE THE DECIMAL *
    !*       POINT AND M PLACES AFTER.IT REQUIRES (M+N+2) PRINT PLACES     *
    !*       UNLESS (M=0) WHEN  (N+1) PLACES ARE REQUIRED.                 *
    !*                                                                     *
    !*       A LITTLE CARE IS NEEDED TO AVOID UNNECESSARY LOSS OF ACCURACY *
    !*       AND TO AVOID OVERFLOW WHEN DEALING WITH VERY LARGE NUMBERS    *
    CONSTLONGREAL DZ=0
    !***********************************************************************
    LONGREAL Y,Z,ROUND,FACTOR
    INTEGER I,J,L,MORIG
    BYTEINTEGER SIGN
          M=M&63;                           ! DEAL WITH STUPID PARAMS
          MORIG=M
          IF N<0 THEN N=1; N=N&31;          ! DEAL WITH STUPID PARAMS
          X=X+DZ;                           ! NORMALISE
          SIGN=' ';                         ! '+' IMPLIED
          IF X<0 THEN SIGN='-'
          Y=MOD(X);                         ! ALL WORK DONE WITH Y
          ROUND=0.5/10**M;                  ! ROUNDING FACTOR
          IF Y>1.0*10**16 OR N=0 THENSTART;       ! MEANINGLESS FIGURES GENERATED
             IF N>M THEN M=N;               ! FOR FIXED POINT PRINTING
             OUTFL(X,M);                 ! OF ENORMOUS NUMBERS
             RETURN;                        ! SO PRINT IN FLOATING FORM
          FINISH
          I=0; Z=1; Y=Y+ROUND
          UNTIL Z>Y CYCLE;                  ! COUNT LEADING PLACES
             I=I+1; Z=10*Z;                 ! NO DANGER OF OVERFLOW HERE
          REPEAT
          OUTSYM(SIGN)
          J=I-1; Z=10**J
          FACTOR=1/10
          CYCLE
             UNTIL J<0 CYCLE
                L=INT PT(Y/Z);              ! OBTAIN NEXT DIGIT
                Y=Y-L*Z; Z=Z*FACTOR;        ! AND REDUCE TOTAL
                OUTSYM(L+'0')
                J=J-1
             REPEAT
             IF M=0 THENEXIT;             ! NO DECIMAL PART TO BE O/P
             OUTSTRING(".")
             J=M-1; Z=10**(J-1); M=0
             Y=10*Y*Z
          REPEAT
          if MORIG>0 start          { Chop any redundant trailing 0s}
             opline_length=opline_length-1 while c
               opline_l(opline_length-1)='0' and opline_l(opline_length-2)#'.'
          finish
    END;                                    ! OF ROUTINE PRINT
    ROUTINE OUTFL (LONGREAL X, INTEGER N)
    !***********************************************************************
    !*       PRINTS IN FLOATING POINT FORMAT WITH N PLACES AFTER THE       *
    !*       DECIMAL POINT. ALWAYS TAKES N+7 PRINTING POSITIONS.           *
    !*       CARE REQUIRED TO AVOID OVERFLOW WITH LARGE X                  *
    !***********************************************************************
    LONGREAL SIGN,ROUND,FACTOR,LB,UB
    CONSTLONGREAL DZ=0
    INTEGER COUNT,INC
         inc=integer(addr(x))
          if inc>>20&x'7ff'=x'7ff' start
             outstring("NAN {"); outhex(inc); outhex(integer(addr(x)+4))
             outsym('}'); return
          finish
          ROUND=0.5/10**N;                  ! TO ROUND SCALED NO
          LB=1-ROUND; UB=10-ROUND
          SIGN=1
          X=X+DZ;                           ! NORMALISE
          IF X=0 THEN COUNT=0 ELSESTART
             IF X<0 THEN X=-X AND SIGN=-SIGN
             INC=1; COUNT=0
             FACTOR=1/10
             IF X<=1 THEN FACTOR=10 AND INC=-1
                                            ! FORCE INTO RANGE 1->10
             WHILE X<LB OR X>=UB CYCLE
                X=X*FACTOR; COUNT=COUNT+INC
             REPEAT
          FINISH
          PRINT(SIGN*X,1,N)
          if count#0 start
             OUTSTRING("E")
             OUTINT(COUNT)
          finish
    END;                                    ! OF ROUTINE OUTFL
       routine FORCE TRIPS
    !***********************************************************************
    !*    FORCE OUT THE TRIPLES TO CODE. NEEDED IN CEND ETC                *
    !***********************************************************************
          triples(0)=0
          nexttrip=1
          triples(0)_flink=1       { return any triples }
          end

          routine COMPILE A STMNT
             integer I
             force trips
             I = NEXTP
             STARSIZE = A(NEXTP)<<16+A(NEXTP+1)<<8+A(NEXTP+2)
             NEXTP = NEXTP+STARSIZE
             LINE = A(I+3)<<8+A(I+4)
             curlinead=fromar4(I+5)
             nextlinead=fromar4(NEXTP+5)
             STMTS = STMTS+1
             opline_line=line
             CSS(I+9)
              if a(NEXTP+3)<<8!A(NEXTP+4)=line then start
               curly check(1)
               outsym(9)
             else
                force line
             finish
          end
    integerfn nextstmntalt
          result=a(NEXTP+9)
    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)
             routine spec CCYCBODY(integer UA,ELAB,CLAB)
             routine spec CLOOP(integer ALT,MARKC,MARKUI)
             routine spec CIFTHEN(integer MARKIU,MARKC,MARKUI,MARKE,MARKR,Afterelse)
             integer fn spec CREATE AH(integer MODE,
                record (RD) name EOPND,NOPND)
             routine spec TORP(integer name HEAD,BOT,NOPS,integer mode)
             integer fn spec INTEXP(integer name VALUE, integer PRECTYPE)
             integer fn spec CONSTEXP(integer PRECTYPE)
             routine spec CSEXP(integer MODE)
             routine spec labexp
             routine spec outopnd(record(rd)name opnd,integer mode)
             routine spec outtriple(integer tripno,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)
             routine spec DECLARE ARRAYS(integer A,B)
             routine spec DECLARE SCALARS(integer B)
             routine spec CRSPEC(integer M)
             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)
              integer fn spec tcond
             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 myrflevel)
                routinespec process format(integer level,alt,structor union,intid,
                      integername strid,ophed,opbot)
             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 array rfhead,rfbot(0:12,0:12),rfalt(0:12)
    integer rflevel

             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,lhformatname,doinglabel
             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
            doinglabel=0
             CURR INST = 0; INAFORMAT = 0
             currentSSalt=a(p)
             ->SW(currentSSalt)
    SW(13):                                  ! INCLUDE SOMETHING
          begin
          string(255) s,head,tail
          s=string(addr(a(P+2)))       { File name}
          if s-> head.(".inc").tail then s=head.".h"
          outstring("#include "); outsym('"')
          outstring(s)
          outsym('"')
          end
          ->cssexit2
    SW(24):                                  ! REDUNDANT SEP
          if a(p+1)=10 then outsym(' ')         { extar neline }
          ->css exit2
    SW(2):                                   ! <CMARK> <COMMENT TEXT>
          p=p+1
          kk=a(p); p=p+1;                    ! kk=1 # comment, =2 ! comment, =3 %comment
           jj=a(p); jjj=0
          if KK=1 then outsym('#') else outstring("/*")    { preserve any #defines in the imp}
          while jj#NL cycle
             if JJ>128 and jjj<128 then outsym('%')
             outsym(jj&127)
             jjj=jj
             p=p+1; jj=a(p)
             if jjj='¬' and JJ=13{CR} and KK=1 then outsym(NL) and p=p+1 and continue
             if jjj=',' and ((kk=2 and jj='!') or (kk=1 and jj='#')) start { unscramble comments ending with a comma = continuation}
                if kk=1 start
                   outsym(NL); outsym('#')
                else
                   outcommentend; outsym(NL)
                   outstring("/*")
                finish
                jjj=jj; p=p+1; jj=a(p)
             finish
          repeat
          if kk>1 then outcommentend
          ->CSSEXIT2
    CSSEXIT: outsep unless opline_length>0 and  opline_l(opline_length-1)='}'
    Cssexit2: 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)
             outname(from ar2(P+3))
             outsym(':'); curly check(0);  outsym(NL);
            if 1<<next stmntalt&(1<<6!1<<4!1<<18!1<<9)#0 then outsep
             ->CSSEXIT2
    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
             ->CSSEXIT2
    SW(22):                                  ! '%CONTROL' (CONST)
             ->CSSEXIT2
    !
    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
             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
             ->CSSEXIT2
    SWITCH:  begin;                          ! SWITCH LABEL
                record (LISTF) name LCELL
                record(swdataform)name swdata
                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+6
                COPY TAG(FNAME,NO)
                if OLDI#LEVEL or TYPE#6 then FAULT(4,0,FNAME) and ->BEND
                LCELL==aslist(k)
                swdata==record(LCELL_S1)
                swdata_slabs(swdata_lseen)=p
                swdata_lseen=swdata_lseen+1
                outswadname(fname); outstring("_"); labexp; outsym(':')
                curly check(0); outsym(NL);
               if 1<<next stmntalt&(1<<6!1<<4!1<<18!1<<9)#0 then outsep
    BEND:    end
             FORCE TRIPS if PARM_OPT=0
             ->CSSEXIT2
    SW(23):
                                             ! SWITCH(*):
             begin
                record (LISTF) name LCELL
                record(swdataform)name swdata
                integer FNAME,JJ,RES
                FNAME = FROM AR2(P+1)
                COPY TAG(FNAME,NO)
                if OLDI=LEVEL and TYPE=6 start
                   LCELL == ASLIST(K)
                   swdata==record(LCELL_S1)
                   swdata_default=p
                   outswadname(fname); outstring("_default:")
                finish else FAULT(4,0,FNAME)
             end
             FORCE TRIPS if PARM_OPT=0
             ->CSSEXIT2
    !
    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
             P = P+1
             MARKER = P+FROMAR2(P);          ! TO ALT OF DECLN
             P = P+2; ROUT = 0; LITL = 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)
                if qq=1 then ->cssexit2   { ignore formats }
                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)
               integer etype
                etype=A(P+1)
                ->S(etype)
    S(1):                                    ! ENDOFPROGRAM
    {GT:}       outstring("exit(0);"{"imp_stop();"}); outsym(NL)
    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)
                outsym('}') if etype=1
                ->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)
                outstring("}"); ! outstring(" /* proc */")
    BEND:    end
             ->CSSEXIT2
    !
    SW(11):
             begin
                integer MARKER1,RTNAME,KKK,PTR,PTYPEP,CNT,PP,PCHAIN,AXNAME,
                   PNAME,NPARAMS,SCHAIN,PARMSPACE,D,PARAMPTYPE,PARAMACC,pcount
                record (LISTF) name LCELL,LCELL2,TCELL
                P = P+1; MARKER1 = FROM AR2(P)+P;  ! (SEX)(RT)(SPEC')(NAME)(FPP)
               markc=a(marker1)
    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(2); 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(2); P = Q; ->AGN
                finish
    {GT:} ! BUG !!!  externalroutinespec fred(int i)
    !       translates to void fred(void)

                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
                   if ptypep&x'c000'=0 then outstring("static ")
                   outtype(ptypep&255,tcell_kform)
                   if ptypep&x'800'#0 and ptypep&7#5 then outsym('*')
                   if axname=0 then outname(rtname) else outstring(string(axname))
                   outsym('(')
                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
                         outtype(paramptype&255,kform); outname(pname); outstring("(")
                         lcell2==aslist(schain)
                         if KKK=0 then outstring("void ") else start
                            for pcount=1,1,KKK cycle
                               if lcell2_s1&x'10000000'#0 start
                                  outtype(lcell2_s1>>16&255,lcell2_sndisp); outstring("()")
                               else
                                  outxtype(lcell2_s1>>16,lcell2_sndisp)
                               finish
                               if lcell2_link#0 then outsym(',')
                               lcell2==aslist(lcell2_link)
                            repeat
                         finish
                         outstring(")")
                         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'
                         outxtype(paramptype,kform); outname(pname);
                         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
                outsym(',') unless pchain=0
                   repeat
                   P = PP
                repeat;                      ! UNTIL NO MORE FP-PART
                outstring(") {")
                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
             ->cssexit2
    !
    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
                      outstring("main() {")
                   finish else FAULT(58,0,0)
                finish else start
                   SET LINE;                 ! SO 'ENTERED FROM LINE' IS OK
                   outstring("{")
                   RHEAD(-1,0,1)
                finish
                RDISPLAY(-1)
             end
             ->CSSEXIT2
    !
    SW(15):
                                   ! '%ON'(EVENT')(N)(NLIST)'%start'

    ! Shouldn't we compile a CSTART(..., 3) here? ... Yes! - code supplied by PDS:

             p=p+2; skip exp;
             while a(p)=1 cycle
               p=p+1
               skip exp
             repeat
             p=p+1
             outstring("if (0) {")
             outsym(NL)
             cstart(0,3)
             outstring(" }")

    ! and in cstart, do...  %if code=3 %then outstring("#endif /* On event */") %and outsym(NL)
    ! so ... where is the %FINISH handled if not there???

             ->CSSEXIT

    SW(16):
             begin;                          ! %switch (SWITCH LIST)
                integer Q,RANGE,KKK,LB,UB,PP,D0,OPHEAD,V,R,datad
                record (RD) OPND1,OPND2
                record(swdataform)name swdata
    !            FAULT(57,0,0) %unless LEVEL>=2
                Q = P
                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
                      LB = 0; UB = 10; RANGE = 1024
                   finish
                   datad=malloc(4*range+8)
                   swdata==record(datad)
                   swdata_lseen=0; swdata_default=0
                   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
                      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,datad,LB,UB)
                      STORE TAG(K,LEVEL,RBASE,1,0,4,OPHEAD,0)
    {GT:}             outstring("int "); outswadname(k); outstring("_value;")
    {GT:}             outstring("int "); outswadname(k); outstring("_line;")
    {GT:}             outstring("char *"); outswadname(k); outstring("_file;")
                   repeat;                   ! FOR ANY MORE NAMES IN NAMELIST
                   Q = PP; P = Q
                repeat;                      ! UNTIL A(Q)=2
             end; ->CSSEXIT2
    !
    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)
                integerfn spec INIT SPACE(integer A,B)
                integer SLENGTH,PP,SIGN,TAGDISP,DVO,K,STALLOC,SPOINT,tp,savep,
                   CONSTSFOUND,CPREC,EXTRN,NNAMES,MARK,QPUTP,LB,CTYPE,CONSTP,
                   FORMAT,DPTYPE,DIMEN,SACC,TYPEP,KK,orlevel,savesndisp,savekform,II
                record (RD) COPND,FCOPND
                own long real ZERO=0
                string (255) SCONST,NAMTXT
                record (LISTF) name LCELL
                QPUTP = 5;                  ! NORMAL CASE GLA SYMBOLTABLES
                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)
                if type=5 and a(p)#1 and extrn=0 then extrn=1
                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
                      outstring("#define "); outname(k); outsym(' ')
                      outstring(namtxt); outsym(NL)
                   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 RLEVEL=0 and EXTRN=0 start
                      outstring("#define ")
                      outrevisablename(k)
                   else
                      out extern(EXTRN)
                      if ptype=x'35' then outstring("char ") else outtype(ptype&255,kform)
                      if nam#0 then outsym('*')
                      outname(k)
                   finish
                   if ptype=x'35' then start
                      outstring(" ["); outint(stalloc); outsym(']')
                   finish
                   tp=1
                   if A(P-1)=1 then start;     ! CONSTANT GIVEN
                      savep=p; p=p-3; tp=tsexp(kk); p=savep
                      if RLEVEL=0 and EXTRN=0 start
                         outstring(" "); outstring("(") if tp<=0
                      else
                         outsym('=')
                      finish
                      XTRACT CONST(CTYPE,CPREC)
                   finish else start
                      WARN(7,K) if EXTRN=0;   ! %const NOT INITIALISED
                      FCOPND = 0; COPND = 0
                   finish
                   if RLEVEL=0 and EXTRN=0 start
                     outsym(')') if tp<=0
                   else
                     outsep
                   finish
                   outsym(NL) unless a(MARK)=2
                   PTYPE = DPTYPE; UNPACK;   ! MAY HAVE BEEN CONSTANT EVALUATIONS
                                             ! WHICH HAVE CHANGED PTYPE
                   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_const ptr
                            if type=5 then ctable(tagdisp)=acc and c
                                 worka_const ptr=worka_const ptr+1
                            ctable(worka_const ptr) = fcopnd_d
                            worka_const ptr = worka_const ptr+1
                            if worka_const ptr>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; savekform=kform
                DVO = DOPE VECTOR(NO,TYPE,STALLOC,0,K)
                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
                PP=p
    begin
                shortinteger savedp, savedp2, savedptype
                integer i;
                integer count; count = 0
    !GT: This is where arrays are declared.  We want to adjust the base of
    !    each array if the lower bound is non-0 so that accesses to the array
    !    can use the natural bounds (which in Imp are not forced to start at 0)

    ! Ideally we would allow static declarations to remain static declarations,
    ! but this does not work for multi-dimensional arrays so these too will
    ! come off the heap for now

    ! Also dynamic arrays simply are not converted correctly at the moment, so
    ! this code takes care of that too.

    ! We must plant code at the end of each procedure to free the heap arrays
    ! Note if we use a mark/release scheme this can be very cheap.

    ! Remember to initialise if members given, and to initialise to zero otherwise
    ! (can be done in the allocate heap space procedure)

                if format=0 start
                   savedptype = ptype&255
                   outextern(EXTRN)
                   outtype(savedptype,savekform)
                   for ii=dimen,-1,1 cycle
                     outsym('*') for i = 1,1,ii
                     outname(k);
                     outsym('_') and outint(ii) if ii#dimen
                     outsym(',') if ii#1
                   repeat
                   outsym(';'); outsym(NL)

                   outextern(EXTRN)
                   outstring("int ");
                   for ii=dimen,-1,1 cycle
                     outname(k);
                     outstring("_dim_")
                     outint(ii)
                     outsym(',') if ii#1
                   repeat
                   outsym(';'); outsym(NL)

                   for ii=dimen,-1,1 cycle
                      outname(k);
                      outsym('_') and outint(ii) if ii#dimen
                      p=ctable(savesndisp+3*ii+2)
                      savedp = p
                      outstring(" = (")
                      outtype(savedptype,savekform)
                      outsym('*') for i = 1,1,ii
                      outstring(")malloc(((")
                      csexp(x'51'); outsym(')')
                      if ctable(savesndisp+3*ii)=x'80000000'start
                         outsym('-'); p=ctable(savesndisp+3*ii+1)
                         outsym('('); csexp(x'51'); outstring(")+1")
                      finish else if ctable(savesndisp+3*ii)<1 start
                         outsym('+'); outint(1-ctable(savesndisp+3*ii))
                      finish else if ctable(savesndisp+3*ii)>1 start
                         outsym('-'); outint(ctable(savesndisp+3*ii)-1)
                      finish
                      outstring(") * sizeof(");
                      outtype(savedptype,savekform)
                      outsym('*') for i = 1,1,ii-1
                      outstring(") );"); outsym(NL);

                      if ctable(savesndisp+3*ii)=x'80000000'start
                         outname(k);
                         outsym('_') and outint(ii) if ii#dimen
                         outstring(" -= ");
                         p=ctable(savesndisp+3*ii+1)
                         csexp(x'51')
                      finish else if ctable(savesndisp+3*ii)#0 start
                         outname(k);
                         outsym('_') and outint(ii) if ii#dimen
                         outstring(" -= ");
                         outint(ctable(savesndisp+3*ii))
                      finish;  ! otherwise based at 0 already

                      outsym(';'); outsym(NL);

                      outstring("for ("); outname(k)
                      outstring("_dim_"); outint(ii);
                      outstring(" = ")

                      if ctable(savesndisp+3*ii)=x'80000000'start
                         p=ctable(savesndisp+3*ii+1)
                         csexp(x'51')
                      finish else if ctable(savesndisp+3*ii)#0 start
                         outint(ctable(savesndisp+3*ii))
                      finish else outint(0);

                      outstring("; "); outname(k)
                      outstring("_dim_"); outint(ii);
                      outstring(" <= ")

                      csexp(x'51')
                      outstring("; "); outname(k)
                      outstring("_dim_"); outint(ii);
                      outstring("++) {"); outsym(NL);
                   repeat
                   for ii=1,1,dimen cycle
                     if ii#1 then start
                       outname(k);outsym('_') and outint(ii) if ii#dimen
                       outstring("["); outname(k)
                       outstring("_dim_"); outint(ii);
                       outstring("] = "); outname(k)
                       outsym('_'); outint(ii-1)
                       outstring(";"); outsym(NL)
                     finish else start
                       outstring("/* Assign initialised elements if any */"); outsym(NL)
                     finish
                     outsym('}'); outsym(NL)
                   repeat

                outsym('{'); outsym(NL); ! for static decl after code!
                outextern(EXTRN)
                outtype(savedptype,savekform)
                outname(k); outstring("_data[] ")

                finish

                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
                cas(qputp)=(cas(qputp)+arrayrounding)&(¬arrayrounding)
                SPOINT = cas(qputp)

                if FORMAT=0 then start
                   if A(PP)=1 then start
                     P = PP+1
                     count = INIT SPACE(QQ,SLENGTH)
                   finish
                finish
                outsep  if format=0

                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.
    !
                PTYPE = TYPEP; UNPACK
                if Format#0 then qputp=0     { avoid data fixup in pownarrayhead}
                TAGDISP = POWNARRAYHEAD(PTYPE,dimen,LB,QQ,SPOINT,QPUTP,DVO,NAMTXT)
                SNDISP=savesndisp
                STORE TAG(K,LEVEL,0,dimen,SNDISP,ACC,TAGDISP,saveKFORM)

                /* if no init declarations, don't do this... */
                outsym(NL);
                outstring("int "); outname(k); outstring("_inels = 0;"); outsym(NL);

                ACC = SACC; PTYPE = TYPEP; UNPACK
                PP=p

                %for ii=dimen,-1,1 %cycle
                      p=ctable(savesndisp+3*ii+2)
                      outstring("for ("); outname(k)
                      outstring("_dim_"); outint(ii);
                      outstring(" = ")

                      savedp = p;

    !                  outstring(" /* 1:")
    !                  csexp(x'51')
    !                  outstring(" */ ")

                      %if ctable(savesndisp+3*ii)=x'80000000'%start
                         p=ctable(savesndisp+3*ii+1)
                         csexp(x'51')
                      %finish %else %if ctable(savesndisp+3*ii)#0 %start
                         outint(ctable(savesndisp+3*ii))
                      %finish %else outint(0);

                      outstring("; "); outname(k)
                      outstring("_dim_"); outint(ii);
                      outstring(" <= ")
                      p = savedp;
                      csexp(x'51')
                      outstring("; "); outname(k)
                      outstring("_dim_"); outint(ii);

                      outstring("++) {"); outsym(NL);

                      outstring("if (")
                      outname(k)
                      outstring("_inels == "); outint(count); outstring(") break;");outsym(NL)

                      %if ctable(savesndisp+3*ii)=x'80000000'%start
                         p=ctable(savesndisp+3*ii+1)
    !                     outstring(" /* 2:")
    !                     csexp(x'51')
    !                     outstring(" */ ")
                      %finish
                %repeat

                outname(k)
                %for ii=dimen,-1,1 %cycle
                  outstring("["); outname(k); outstring("_dim_")
                  outint(ii)
                  outstring("]")
                %repeat
                outstring(" = ")
                outname(k)
                outstring("_data[")
                outname(k)
                outstring("_inels++];"); outsym(NL)
                %for ii=dimen,-1,1 %cycle
                      outstring("}"); outsym(NL);
                %repeat
                outsym('}'); outsym(NL); ! End of static init

    %end; ! of tweak to make arrays based at non-0

                ->BEND
    %integerfn 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,PIN,PP,contype,conprec,ppp,value
    %integer nels out
          nels out = 0
          pIN=p; contype=type
          conprec=prec
     outstring(" = {")
          SPP = 0; WRIT = 0
          %until A(P-1)=2 %cycle
             p=p-3; PP=p; skip exp
             %if A(P)=1 %start;     ! REPITITION FACTOR
                P = P+2
                %if A(P-1)=2 %then %start     { * found issue warning }
                   RF = 1                     { Except for 0(*) when detectable }
                   %unless a(PP+3)=4 %and a(PP+4)=2 %and a(PP+5)=x'41' %andc
                      a(PP+6)=a(PP+7)=0 %and a(PP+8)=2 %then warn(10,0)
                %finish %else %start
                   P = P+2
                   %if INTEXP(RF,MINAPT)#0 %then warn(10,0) %and RF = 1
                %finish
                P = P+1
             %finish %else RF = 1 %and P = P+2
             nels out = nels out + RF
             warn(10,0) %if RF<=0
              spp=p
             %cycle I = RF,-1,1
                p=pp
                %if contype=5 %then cstrexp(1) %else csexp(conprec<<4!contype)
                consts found=consts found+1
                outsym(',') %unless i=1 %and a(spp-1)=2  { very last const}
             %if (contype=5 %and consts found&3=0) %or consts found&7=0 %c
                  %then outsym(NL)
             %repeat
             p=spp
          %repeat
          outstring("}")
          %result = nels out
    %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,PP
                   STYPE = PTYPE; SACC = ACC;  ! MAY BE CHANGED IF CONST IS EXPR
                   %if CONTYPE=5 %then %start
                      P = P-3; CSTREXP(1)
                      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'
                      PP=P; p=p-3; csexp(mode)
                      p=pp; I = CONSTEXP(MODE)   { Evaluate again to get storeable value }
    !                  %if CONSTP=0 %then FAULT(41,0,0)
                                             ! CANT EVALUATE EXPT
                      COPND = EXPOPND;       ! GET RESULT OPND
                      COPND_PTYPE = MODE
                   %finish
                   PTYPE = STYPE; UNPACK; ACC = SACC

                   FCOPND = COPND
                %end
    BEND:    %end; ->CSSEXIT2
    SW(10):
          %begin;                         ! %recordformat (RDECLN)
          %integer NAME,OPHEAD,OPBOT,NLIST,HeadCell,FHEAD,SPEC,l1,l2,strid,fpt
          %record (LISTF) %name LCELL,FRCELL
           %string(255) typename
          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
             %for l1=0,1,12 %cycle
               %for l2=0,1,12 %cycle
                  rfhead(l1,l2)=0
                  rfbot(l1,l2)=0
               %repeat
               rfalt(l1)=0
              %repeat
             INAFORMAT = 1
             rflevel=0
             crformat(rflevel)
             INAFORMAT = 0
             %if PARM_Z#0 %start
                %for l1=0,1,12 %cycle
                  %for l2=0,1,12 %cycle
                      %if rfhead(l1,l2)#0 %start
                          printstring("level&rfalt="); write(l1,5); write(l2,5); newline
                          printlist(rfhead(l1,l2))
                      %finish
                   %repeat
                %repeat
             %finish
             strid=0;                 { for generating internal names }
            HeadCell=rfhead(0,1)
             %if HeadCell=0 %start      { No alternatives at top level }
                outstring("struct "); outname(name)
                outsym('{'); outsym(NL)
                process format(0,0,'s',0,strid,ophead,opbot)
                fpt=4
             else
                outstring("union "); outname(name)
                outsym('{'); outsym(NL)
                process format(0,0,'u',0,strid,ophead,opbot)
                fpt=x'14'
             finish
             outsym('}'); outsym(';'); outsym(NL)
             if PARM_Z#0 start
                printstring("after processing")
                printlist(ophead)
             finish
             if possible typename(name,typename)#0 start
                outsym(NL)
                outstring("typedef ")
                if HeadCell=0 start      { No alternatives at top level }
                   outstring("struct ")
                else
                   outstring("union ")
                finish
                outname(name)
                outstring(" ".typename.";")
                outsym(NL)
             finish
             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
             if PARM_Z#0 start
                    printstring("before throwing dummy cell")
                    printlist(kform)
             finish
             POP(KFORM,I,I,FHEAD);     ! THROW DUMMY CELL
                                       ! GET HEAD OF FORWARD REFS
             fhead=ophead
             while FHEAD>0 cycle;      ! THROUGH format changeFORWARD REFS
                FRCELL == ASLIST(fhead)
                if frcell_ptype=x'433' and frcell_kform=lcell_kform start
                   FRCELL_UIOJ = FRCELL_UIOJ&X'FFFFFFF0';  ! SET J BACK TO 0
                   FRCELL_ACC <- ACC;     ! ACC TO CORRECT VALUE
                   FRCELL_KFORM = OPHEAD;  ! CORRECT KFORM
                finish
                fhead=frcell_link
             repeat
             LCELL_UIOJ = LCELL_UIOJ&X'FFFFFFF0';  ! J BACK TO ZERO
             LCELL_ACC <- ACC
             LCELL_SLINK = name;     ! KFORM&SLINK TO SIDECHAIN & name
             LCELL_PTYPE=fpt        { To distinguish unions from structs }
             LCELL_KFORM = OPHEAD
             if PARM_Z#0 start
                printstring("after processing self refs")
                printlist(ophead)
             finish
          finish
    end; ->CSSEXIT2
    !
    SW(19):
                                             ! '*' (UCI) (S)
    !         FAULT(57,0,0) %unless LEVEL>=2
            outstring("***Untranslateable stmnt***")
             i=curlinead
             while i<nextlinead cycle
                outsym(byteinteger(i))
                i=i+1
             repeat
             ->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
                  outstring("*** imp construction too difficult***")
                result = OPHEAD
             end

             routine CRFORMAT(integer myrflevel)
    !***********************************************************************
    !*       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 = 0;          ! 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 = 0; 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
                            D2=dope vector(NO,typep&7,acc,0,fromar2(q))>>2
                                             ! DOPE VECTOR INTO SHAREABLE S.T.
                            ACC = SACC; PTYPE = TYPEP; UNPACK
                            RL = ROUNDING LENGTH(PTYPE&255,0);  ! FOR ELEMENT AS%c
                                                                SCALAR
                            if RL<ARRAYINREC ROUNDING then c
                               RL = ARRAYINREC ROUNDING
                            cycle
                               ROUND
                               D1 = 0
                               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)
                      rflevel=rflevel+1
                      binsert(rfhead(myrflevel,rfalt(myrflevel)),rfbot(myrflevel,rfalt(myrflevel)),
                        0,rflevel,0)
                      CRFORMAT(rflevel)
                      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
                      rfalt(myrflevel)=rfalt(myrflevel)+1
                   CRFORMAT(myrflevel)
                   if ACC>INC then INC = ACC
                finish else P = P+1
                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)
                   if aslist(tags(fname))_ptype=x'4051' then warn(11,0)
                   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(rfhead(myrflevel,rfalt(myrflevel)),rfbot(myrflevel,rfalt(myrflevel)),
                      CELL_S1,CELL_S2,CELL_S3)
    !               %if PTYPE=X'433' %and ACC=MAXRECSIZE %then %c
                      PUSH(ASLIST(FORM)_S3,OPBOT,0,0)
    ! NOTE FORWARD REFERENCE
                end
                routine ROUND
                end
             end;                            ! OF ROUTINE CRFORMAT
    routine out fmt cell(record(listf)name lcell)
    !***********************************************************************
    !* print out a single cell of a format list                            *
    !***********************************************************************
    integer pt,name,dvdisp,nd,ii
    record(listf)name fcell
          pt=lcell_s1>>16
          name=lcell_S1>>4&X'FFF'
          if pt&x'cff'=x'35' start
             outstring("char "); outname(name)
          else
             OUT XTYPE(PT&x'cff',lcell_kform)
             outname(name)
          finish
          if PT&x'300'#0 start
             nd=lcell_s1&15
             dvdisp=lcell_sndisp
                for ii=nd,-1,1 cycle
                   p=ctable(dvdisp+3*ii+2)
                   outstring(" [")
                   csexp(x'51')
                   if ctable(dvdisp+3*ii)=x'80000000'start
                      outsym('-'); p=ctable(dvdisp+3*ii+1)
                      outsym('('); csexp(x'51'); outstring(")+1")
                   finish else if ctable(dvdisp+3*ii)<1 start
                      outsym('+'); outint(1-ctable(dvdisp+3*ii))
                   finish else if ctable(dvdisp+3*ii)>1 start
                      outsym('-'); outint(ctable(dvdisp+3*ii)-1)
                   finish
                   outsym(']')
                repeat
          finish
          if pt&x'cff'=x'35' start
             outsym('['); outint(lcell_acc); outsym(']')
          finish
          outsep
          outsym(NL)
    end
    routine process format(integer level,alt,structor union,intid,
          integername strid,ophead,opbot)
    !***********************************************************************
    !* process one level of the recordformay data structure and call       &
    !* itself recursively to handle lower levels. Note C unions cal        &
    !* can have only one element in each alternative so imp multi-         &
    !* element alternatives have to be coalesced into structures           &
    !* this is the main problem                                            &
    !***********************************************************************
    record (listf)lcell
    integer i,j,k,newid,lstrid

          if structorunion='s' start   { struct only 1 alt }
             while rfhead(level,alt)#0 cycle
                pop(rfhead(level,alt),lcell_s1,lcell_s2,lcell_s3)
                if lcell_s1#0 start
                   out fmt cell(lcell)
                   lcell_slink=intid
                   binsert(ophead,opbot,lcell_s1,lcell_s2,lcell_s3)
                else                   { union within struct }
                   newid=intid<<4!(lcell_s2{-1}{ union update })
                   outstring("union {"); outsym(NL)
                   process format(lcell_s2,0,'u',newid,strid,ophead,opbot)
                   outstring("} u"); outint(lcell_s2-1)
                   outsym(';'); outsym(NL)
                finish
             repeat
          else                          { union with at least 2 alternatives }
             for i=alt,1,rfalt(level) cycle
                if rfhead(level,i)=rfbot(level,i) start   { only 1 alt }
                   pop(rfhead(level,i),lcell_s1,lcell_s2,lcell_s3)
                   if lcell_s1#0 start
                      out fmt cell(lcell)
                      lcell_slink=intid
                      binsert(ophead,opbot,lcell_s1,lcell_s2,lcell_s3)
                   else                   { union within union }
                      newid=intid<<4!(lcell_s2{-1}{ union update })
                      outstring("union {"); outsym(NL)
                      process format(lcell_s2,0,'u',newid,strid,ophead,opbot)
                      outstring("} u"); outint(lcell_s2-1)
                      outsym(';'); outsym(NL)
                   finish
                else                 { force in a struct }
                   lstrid=strid; strid=strid+1
                   newid=intid<<4!8!lstrid
                   outstring("struct {"); outsym(NL)
                   process format(level,i,'s',newid,strid,ophead,opbot)
                   outstring("} s"); outint(lstrid)
                   outsym(';'); outsym(NL)
                finish
            repeat
          finish
    end

             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'51'
                   TOPND_UIOJ <- ENAME<<4
                   PUSH(ASLIST(CELL)_LINK,TOPND_S1,0,0)
                finish
                PTYPE = X'51'; TCELL = 0; unpack
                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 (6<=z<=7 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 or Z=7 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'51' %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 !
                   if rptype&x'f00'=x'400' then outstring("->") else outstring(".")
                   outinternames(q)
                   outname(ename)
                   ->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 6<=z<=7)) 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 =0
    !                     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 thenstart
                         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,Firsttrip,trip
                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  and mode=1 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  ENDFLAG#0 start;    ! NO RUN-TIME OPERATIONS
                      outopnd(opnd2,0)
                      OPND1 = OPND2; ->TIDY
                   finish
                   Firsttrip = BRECTRIP(PRECC,X'35',0,OPND1,OPND2)
                   OPND1_FLAG = REFTRIP
                   OPND1_D = Firsttrip;              ! CHANGE TO TRIPLES REFERENCE
                   DOTS = 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)
                   dots = dots +1; ->NEXT
                finish
    !          printtrips(triples)
                outstring("imp_concat(") for i=2,1,DOTS
                trip=Firsttrip
                while trip #0 cycle
                   outopnd(Triples(trip)_opnd2,0)
                   if trip=Firsttrip then outstring(",") else start
                      outstring(")")
                      outsym(',') unless Triples(trip)_puse=0
                   finish
                   trip=Triples(trip)_puse
                repeat
    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,alt,I
                   alt  = A(P);              ! ALTERNATIVE OF OPERAND
                   OPND = 0
                   result = 75 if alt >2
                   if alt #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) and mode#0 start
                          opnd_flag=lconst; opnd_ptype=x'35'
                          opnd_d=midcell; opnd_xtra=kform
                          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
                         OPND_FLAG = ARNAME
                         OPND_D = P
                         p=p+2; skip app
                         while a(p)=1 cycle
                            p=p+3; skip app;
                         repeat
                         p=p+1
                      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
          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
          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
          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
             outstring("NULL,")
          finish else start
             ->ERROR unless A(P)=1;    ! P(OPERAND)=NAME
             P = P+1; P2 = P
             CNAME(2)
             outsym(',')
             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
          ->ERROR unless A(P)=3;       ! P(OPERAND)='('(EXPR)')'
          SEXPRN = SEXPRN+1; P = P+1
          CSTREXP(0);                 ! FULL 32 BIT ADDRESS
          outsym(',')
          OPND2_PTYPE = X'51'; OPND2_FLAG = SCONST
          OPND2_D = LAB
          if A(P)=2 then outstring("NULL") and ->END
          if A(P+1)#CONCOP then ERR = 72 and ->ERROR
          P2 = P+1; P = P2+1
          if A(P)=3 then start
            P = P2
             outstring("_imptempstring)")
             if lab=0 then outsym(';') else outsym('+')
             outstring("imp_resolve(_imptempstring,")
             ->RES
          finish
          ->ERROR unless A(P)=1
          P = P+3 and SKIP APP until A(P)=2
          if A(P+1)=1 then start
            P = P2
             outstring("_imptempstring)")
             if lab=0 then outsym(';') else outsym('+')
             outstring("imp_resolve(_imptempstring,")
             ->RES
          finish
          P1 = P+1
          P = P2+2
          CNAME(2)
          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,scell
    record(swdataform)name swdata
    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
    !     printstring("undeclaring"); printstring(printname(jj)); newline
                                             ! OBTAIN NEXT NAME FORM DECLNS
    !
    ! GET ONLY THE MINIMUM OF DETALS NECESSARY
    !
             S4 = LCELL_LINK
             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  then start
    !            printstring("clearing list for "); printstring(printname(jj)); newline; printlist(k)
                CLEAR LIST(K)
             Finish
             if TYPE=4  then start
    !            printstring("clearing list for "); printstring(printname(jj)); newline; printlist(t_kform)
                CLEAR LIST(t_kform)
             Finish
             if type=6 start
                scell==aslist(lcell_slink)
                swdata==record(scell_s1)
                outstring("goto "); outswadname(jj); outstring("_skip;"); outsym(NL)
    {GT:}  ! NOTE goto t_despatch ... should pass in __LINE__ and __FILE__
           ! rather than allow them to be picked up at point of dispatch
           ! by which time they are meaningless
                outswadname(jj); outstring("_despatch:"); outsym(NL)
                outstring("switch ("); outswadname(jj);
                outstring("_value) {"); outsym(NL)
                for lnum=0,1,swdata_lseen-1 cycle
                   outstring("case ")
                   p=swdata_slabs(lnum); csexp(x'51') { No symbolic consts}
                   outstring(": goto "); outswadname(jj)
                   outsym('_')
                   p=swdata_slabs(lnum); labexp
                   outsym(';'); outsym(NL)
                repeat
                outstring("default:")
                if swdata_default#0 then start
                    outstring("goto "); outswadname(jj)
                    outstring("_default;")
                else
    {GT:}   ! NOTE: using __LINE__ and __FILE__ from the dispatch table
            ! is not very helpful.  We really want to know where the switch
            ! was jumped to from, at the source of the original ->sw(i)
            ! so I now note the originals into name_file and name_line
            ! at the point of the jump.  I think it's worth the overhead
            ! of the two extra assignments.

            ! NOTE ALSO: I assume the body of BADSWITCH is
            ! dumped at a %endofprogram - would be better not to,
            ! and to supply it in "imptoc.h" instead
            ! because of problems described elsewhere to
            ! do with limitations of this traslator
            ! (though I haven't yet found where it's dumped so I may be wrong)

                    outstring("BADSWITCH("); outswadname(jj);
    {GT:}!          outstring("_value,__LINE__,__FILE__);")
                    outstring("_value,")
                    outswadname(jj); outstring("_line,")
                    outswadname(jj);outstring("_file);")
                finish
                outsym(NL); outsym('}'); outsym(NL)
                outswadname(jj); outstring("_skip:;"); outsym(NL)
                free(addr(swdata))
                kk=t_slink
                clear list(kk)
             finish
             LCELL_LINK = ASL; ASL = TAGS(JJ)
             TAGS(JJ) = S4&X'3FFFF'
             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
          if type=5 start
            outstring("char ")
          finish else outtype(ptype&255,xtra)
          until A(P-1)=2 cycle;        ! DOWN THE NAMELIST
             N = (N+RL+SFRAME MISALIGN)&(¬RL)-SFRAME MISALIGN
             SCAL NAME = FROM AR2(P)
             if nam#0 then outstring("*")
             outname(scalname)
             P = P+3
             STORE TAG(SCAL NAME,LEVEL,RBASE,0,SNDISP,ACC,N,XTRA)
             N = N+INC
             if type=5 and nam=0 start
               outstring(" ["); outint(acc);
               outstring("] ")
             finish
             if a(p-1)=1 then outsym(',')
          repeat
          N = (N+MIN PARAM SIZE-1)&(-MIN PARAM SIZE);  ! THIS IS NECESSARY !
    end
    integer fn DOPE VECTOR(integer TAMPER,TYPEP,ELSIZE,MODE,IDEN)
    !***********************************************************************
    !* Construcst a pseudo dope vector for the handling of arrays          *
    !* which is as much like the compiler one as possible. Since           *
    !* C arrays all start from 0 but Imp ones can start from anywhere      *
    !* provision is needed to take off the lower bound from each index     *
    !* on every access.                                                    *
    !* The dope vector consists of:-                                       *
    !*     word 0 ignored                                                  *
    !*     word 1 dimensions<<16 ! element size                            *
    !*     word 2 ignored                                                  *
    !*     and then a triple for each dimension                            *
    !*     word 0 the lower bound if constant                              *
    !*     word 1 pointer to the lb expression                             *
    !*     word 2 pointer to the ub expression                             *
    !*                                                                     *
    !* If TAMPER =YES then small +ve lower bounds are reset                *
    !* to zero in the interests of access efficiency                       *
    !*  IDEN is only for error messages                                    *
    !*  Mode not relevant                                                  *
    !***********************************************************************
    integer I,JJ,K,ND,D,M0,HEAD,NOPS,TYPEPP,PIN,etype,value
    record (RD) OPND
    record (LISTF) name LCELL
    integer array LBH,LBB,LBp,UBp(0:12)
    integer array DV(0:39);      ! ENOUGH FOR 12 DIMENSIONS
          ND = 0; TYPEPP = 0; PIN = P
          M0 = 1
          until A(P)=2 cycle
             ND = ND+1; P = P+1
             LBp(ND)=p; etype=tsexp(value)
             p= LBp(ND)+3
             FAULT(37,0,IDEN) and ND = 1 if ND>12
             LBH(ND) = 0; LBB(ND) = 0
             NOPS=0
             TORP(LBH(ND),LBB(ND),NOPS,1)
             UBp(ND)=p
             skip exp
             if imod(etype)=1 start
                expop(LBH(ND),LBB(ND),NOPS,x'251')
                lbb(ND)=expopnd_d
             else
                lbb(ND)=x'80000000'       { Mark as not known }
             finish
          repeat
          P = P+1
    !
    ! now tamper with the lower bounds if permitted
    !
          if TAMPER=YES start
             cycle D = 1,1,ND
                if LBB(d)>0 and LBB(d)*ND<=6 then LBB(d)=0
             repeat
          finish
    !
    ! SET UP THE DOPEVECTOR
    !
          DV(1) = ND<<16!ELSIZE
          for d=1,1,nd cycle
             k=3*d
             DV(k)=LBB(d)
             DV(K+1)=LBp(d)
             DV(k+2)=UBp(d)
          repeat

          K = 3*ND+2
          j = ND;                 ! set dimensionality
          SNDISP = 4*WORKA_CONST PTR
          I = SNDISP
          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)
          result = I
    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,TOPp,iden
    record (RD) OPND1
          SAVE STACK PTR;              ! FOR LATER UNDECLARING
          ARRP = 2*FORMAT+1; ARR = ARRP; PACK(PTYPEP)
          ELSIZE = ACC
    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
          DVDISP = DOPE VECTOR(YES,TYPE,ELSIZE,1,FROMAR2(PP))
          TOPP=P
          ND = J
          CDV = 1
          if LWB=0 and FORMAT=0 then PTYPEPP = PTYPEP+256
          SNDISP = SNDISP>>2
          DVDISP=DVDISP>>2
    DECL:                                    ! MAKE DECLN - BOTH WAYS
          J = ND
          RL=ROUNDINGLENGTH(AHEADPT,1)
          N = (N+RL)&(¬RL);              ! MAY BE BENEFITS IN WORD ALIGNMENT
          cycle JJJ = 0,1,NN-1;        ! DOWN NAMELIST
             iden = FROM AR2(PP+3*JJJ)
             PTYPE = PTYPEPP; UNPACK
             STORE TAG(iden,LEVEL,RBASE,ND,dvdisp,ELSIZE,N,FINF)
             N = N+AHEADSIZE
             if format=0 start
                 if ptypepp&15=5 then outstring("char ") else outtype(ptypepp&255,finf)
                outname(iden)
                for ii=nd,-1,1 cycle
                   p=ctable(dvdisp+3*ii+2)
                   outstring(" [")
                   csexp(x'51')
                   if ctable(dvdisp+3*ii)=x'80000000'start
                      outsym('-'); p=ctable(dvdisp+3*ii+1)
                      outsym('('); csexp(x'51'); outstring(")+1")
                   finish else if ctable(dvdisp+3*ii)<1 start
                      outsym('+'); outint(1-ctable(dvdisp+3*ii))
                   finish else if ctable(dvdisp+3*ii)>1 start
                      outsym('-'); outint(ctable(dvdisp+3*ii)-1)
                   finish
                   outsym(']')
                   if ptypepp&15=5 start
                     outstring(" ["); outint(elsize);
                     outstring("] ")
                   finish
                repeat
                if jjj#NN-1 then outsym(';') and outsym(NL)
             finish
          repeat
          P = TOPP+1;                     ! PAST REST OF ARRAYLIST
          if A(P-1)=2 then return
          outsym(';') and outsym(NL)
          ->start
    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)
                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

    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,pcount
    record(listf) name lcell
    string(255) ss
          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)
             outstring("#define "); outstring(string(axname))
             AXNAME = ADDR(A(WORKA_ARTOP))
             outsym(' ')
             if string(axname)="s_cstring" then outstring("s__cstring") else outstring(string(axname))
              outsym(NL)
             WORKA_ARTOP = (WORKA_ARTOP+4+A(P))&(-4)
             P = P+A(P)+1
          finish
          CFPLIST(OPHEAD,NPARMS)
          PCHKWORD = 0
          ss=string(axname)             { symbol table vsn of name }
          if 0<=m<=1 start
             unless typep&x'c000'#0 andc
                 (ss="malloc" or ss="free" or ss="realloc" or ss="perror" orc
                  ss="getcwd"  or ss="strlen") c
                 then start
    !            %if typep&x'c000'=0 %then outstring("static ")
                if typep&x'c000'=x'8000' then outstring("extern ")
                outtype(typep&255,skform)
                if typep&x'800'#0 and typep&7#5 then outsym('*')
                outname(kk); outsym('('); outsym(' ')
                lcell==aslist(ophead)
                if nparms=0 then outstring("void ") else start
                   for pcount=1,1,nparms cycle
                      if lcell_s1&x'10000000'#0 start
    {GT: Unfixed bug.  Type parameter i 0 in an externalspec }
    {    and shows up as  extern void itos(void, void)       }
    {    instead of       extern void itos(int, int)         }
                         outtype(lcell_s1>>16&255,lcell_sndisp); outstring("()")
                      else
                         outxtype(lcell_s1>>16,lcell_sndisp)
                      finish
                      if lcell_link#0 then outsym(',')
                      lcell==aslist(lcell_link)
                   repeat
                finish
                outstring(");")
             finish
          finish
          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&1; PTYPE = TYPEP
          STORE TAG(KK,LEVEL,RBASE,j,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 = kform
                      LCELL_ACC <- ACC
                      NPARMS = NPARMS+1
                      P = P+3
                   repeat
                   P = PP
                repeat
                OPBOT = OPHEAD; INC = 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
                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
    {GT:}!         FAULT(105,0,0) if RLEVEL>=2  {REMOVING THIS ALLOWS NESTED PROCS}
                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 start      { For begin blocks  }
                   if axname=0  start        { not initial begin }
                      currinf_iblkid=internalblockid
                      internalblockid=internalblockid+1   { keep a blk no for switches & labels }
                   finish
                   W3 = 0
                else
                   W3 = RTNAME+1
                   internalblockid=0
                finish
                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,savepos
    record (RD) RPOP
    record (LISTF) name LCELL
    record(swdataform)name swdata
    owninteger depth
    switch SW(1:9)
          depth=depth+1
          if depth=1 then savepos=opline_length and outsym(' ')
          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 start
             if depth=1 then opline_l(savepos)='{'
    {GT:}    if opline_l(opline_length-1) # '{' then outstring("; ")
             CUI(CODE)
            if depth=1 then outstring(";}")
          finish
          depth=depth-1
          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
             outstring("goto "); outname(lname)
          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
             outsym('{'); outswadname(lname); outstring("_value=")
             CSEXP(MINAPT)
    {GT:}  ! NOTE goto t_despatch ... should pass in __LINE__ and __FILE__
           ! rather than allow them to be picked up at point of dispatch
           ! by which time they are meaningless
    {GT:}    outstring("; "); outswadname(lname); outstring("_line = __LINE__")
    {GT:}    outstring("; "); outswadname(lname); outstring("_file = __FILE__")
             outstring("; goto "); outswadname(lname)
             outstring("_despatch;}")
             REPORTUI = 1
          finish
          depth=depth-1
          return
    SW(3):                                   ! RETURN
          FAULT(30,0,0) unless CURRINF_FLAG&X'3FFF'=X'1000'
          P = P+1
          outstring("return ")
    RET:  KK = UCONSTTRIP(RTXIT,X'51',0,0)
          REPORT UI = 1
          CURR INST = 1 if CODE=0
          depth=depth-1
          return
    SW(4):                                   ! %result(ASSOP)(EXPR)
          outstring("return ")
          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(0);        ! 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
          depth=depth-1
          return
    SW(5):                                   ! %monitor (AUI)
    ! Woud be nice to intercept this at the level above and translate
    ! %if <cond> %then %monitor
    ! to
    ! assert(!(cond))
    {GT:} outstring("assert(_IMP_MONITOR_)")
          P = P+1; ->AUI
    SW(6):                                   ! %stop
    {GT:} outstring("exit(0)"{"imp_stop()"})
    !      KK = UCONSTTRIP(XSTOP,X'51',0,0)
          P = P+1
          CURR INST = 1 if CODE=0
          REPORTUI = 1
          depth=depth-1
          return
    SW(7):                                   !'%SIGNAL'(EVENT')(N)(OPEXPR)
          P = P+5
          KK = INTEXP(J,MINAPT);       ! EVENT NO TO J
          if A(P)=1 start;             ! SUBEVENT SPECIFIED
                   P = P+3;  skip exp
          finish
          outstring("*** IMP signals untranslateable *****")
          depth=depth-1
          return
    SW(8):                                   ! %exit
          outstring(" break ")
          REPORTUI = 1
          CURR INST = 1 if CODE=0
          depth=depth-1
          return
    SW(9):                                   ! %continue
          REPORTUI = 1
          CURR INST = 1 if CODE=0
          outstring(" continue ")
          depth=depth-1
          return
             end
             routine CIFTHEN(integer MARKIU,MARKC,MARKUI,MARKE,MARKR,Afterelse)
    !***********************************************************************
    !*    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,ctype
    const integer NULL ELSE=4
    switch ESW(1:NULL ELSE)
    owninteger depth=0
                depth=depth+1
                LINETRIP = -1
                SET LINE and LINETRIP = TRIPLES(0)_BLINK
                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
    ! '%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
    !
                ctype=rlevel
                if tcond#0 then ctype=0
                P = MARKC                   { may be changed by tcond }
                if ctype=0 start
                    if Afterelse=NO then outsym(NL) and outstring("#if")
                else
                   outstring("if ")
                finish
                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
                   If ctype#0 then  curly check(1) and outsym('{'); outsym(NL)
                   CSTART(CCRES,1)
                   If ctype#0 then outstring("}");  ! outstring(" /* if clause */")
                   if A(P)<=2 then PLABEL = PLABEL-1 and ELSELAB = PLABEL
                   MARKE = P
                   REPORT = LAST INST
                finish else start
                   if CCRES#2 start
                      if ctype=0 then outsym(NL)
                      P = MARKUI; CUI(1)
                      if MARKE#0 and a(MARKE)#NULL ELSE and opline_l(opline_length-1)#'}' then outsep
                      REPORT = REPORTUI
                   finish else start;     ! FIRST UI NEVER EXECUTED
                      REPORT = 1
                   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
                                             ! CONDITIONAL&MERGE OR REPLACE
                ->ESW(ELSEALT)
    ESW(1):                                  ! '%ELSESTART'
                if ctype=0 start
                   outsym(NL); outstring("#else"); curly check(1); outsym(NL)
                else
                   outstring(" else {"); curly check(1);  outsym(NL)
                 finish
                if CCRES=0 then CURRINF_NMDECS = CURRINF_NMDECS!1
                CSTART(CCRES,2)
                If ctype#0 then outstring("}");   ! outstring(" /* else clause*/")
                if ctype=0 start
                   outsym(NL); outstring("#endif")
                finish
                ->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
                J = NEXT TRIP
                if ctype=0 start
                   outsym(NL); outstring("#else"); outsym(NL)
                   CIFTHEN(P,P+3,MARKUI,MARKE,MARKR,no)
                   outsym(NL); outstring("#endif")
                else
                   outstring(" else ");       ! outsym('{')
                   CIFTHEN(P,P+3,MARKUI,MARKE,MARKR,NO)
                   outsym(NL);                !  outsym('}')
                finish
                REPORT = 0;                  ! CANT TELL IN GENERAL
                ->ENTER ELSELAB
    ESW(3):                                  ! '%ELSE'<UI>
                 if ctype=0 start
                   outsym(nl); outstring("#else"); outsym(NL)
               else
                   outstring(" else ")
               finish
                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
                   if ctype=0 then start
                      outsep
                      outsym(NL)
                      outstring("#endif")
                   else
                      if depth>1 then outsep
                   finish
                finish
    ENTER ELSELAB:
                if ELSELAB>0 then ELRES = ENTER LAB(ELSELAB,B'11'!REPORT<<2)
          depth=depth-1; return
                                             ! CONDITIONAL MERGE
    ESW(NULL ELSE):                          ! NULL ELSE CLAUSE
               if ctype=0 start
                   outsep if start=0
                   outsym(NL); outstring("#endif")
               finish
             depth=depth-1;
             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
    {GT:}if CODE=3 then outstring("/* beginning of onevent block */") and outsym(NL)
          SKIPCODE = NO
          if 1<=CODE<=2 and CCRES!CODE=3 then SKIPCODE = YES
                                       ! NEVER EXECUTED
          FINISHAR = FROMAR4(P);       ! TO START OF AR FOR FINISH
          OLDLINE = LINE;              ! FOR ERROR MESSAGES
          cycle;                       ! THROUGH INTERVENING STATMNTS
             OLDNEXTP = NEXTP
             COMPILE A STMNT
          repeat until OLDNEXTP>=FINISHAR;    ! HAVING COMPILED FINISH
    {GT:}if CODE=3 then outstring("/* end of onevent block */") and outsym(NL)

          P = FINISHAR+10;              ! 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
          curly check(1)
          outsym('{'); outsym(NL)
          while NEXTP<=FINISHAR cycle
             COMPILE A STMNT
          repeat
          outstring("}"); ! outstring(" /* loop */")
          currinf_EXITLAB = SAVEE; currinf_CONTLAB = SAVEC
          P = FINISHAR+10
          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,FINALP,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)
    switch SW(0:6)
          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)+10;          ! TO UNTIL CLAUSE IF ANY
          if A(PP)=1 start;            ! %repeat %until <COND>
             outstring("do ")
             C CYC BODY(1,L2,L3)
    !         L3 = L3*ENTER LAB(L3,B'011');  ! DELETE IF NOT NEEDED
             SET LINE
             outstring(" while ")
             P = PP+1; CCRES = CCOND(0,2,L1,0)
          finish else start
             outstring("for (;;) ")
             C CYC BODY(1,L2,L1);      ! CONTINUES DIRECT TO TOP
             !outstring(" while (1) /* FOR EVER */")
    !         ENTER JUMP(15,L1,0)
          finish
    !      L2 = L2*ENTER LAB(L2,B'011');  ! DELETE IF NOT NEEDED
    WAYOUT:                                  ! REMOVE LABELS NOT REQUIRED
          return
    sw(1):                            ! UI while cond
          outstring("while ")
          ccres=ccond(0,1,l2,b'11')
          p=markui
          cui(1)
    !      enter jump(15,l1,0)         ! uncoditional back to while
    !      L2 = L2*ENTER LAB(L2,B'111');  ! CONDITIONAL(?) & REPLACE ENV
          ->WAYOUT
    SW(2):                                   ! UI %until COND
          P = MARKUI
          outstring("do ")
          CUI(1)
          P = MARKC
          outsep; outstring(" while ")
          CCRES = CCOND(0,2,L1,0)
          ->WAYOUT
    SW(6):                                   ! %for ... %cycle
    SW(3):                                   ! UI %for ....
          FORCNT = FORCNT+1;           ! TO DETCT FORS IN ENCLOSED STMTS
          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
    !
          P = INITP
          SKIP EXP;                    ! P TO STEP EXPRSN
          STEPP = P; SKIP EXP;         ! P TO FINAL
          FINALP=p
    !
          P = STEPP
          FOR EXP(STEPOPND,1,1);       ! Investigate step and evaluate if constant
          outstring(" for (")
          if FOT=INDNAME then outsym('*')
          outname(FORNAME)
          outsym('=')
          P = INITP; csexp(FORPT)
          outsep
          outsym(' ')
          if FOT=INDNAME then outsym('*')
          outname(FORNAME)
          if STEPOPND_FLAG<=1 start
             FAULT(92,0,0) if STEPOPND_D=0;   ! ZERO STEP
             if STEPOPND_D<0 then outstring(">=") else outstring("<=")
          finish else start
             outstring("<=")
             warn(10,0)
          finish
          p=finalp; csexp(FORPT)
          outsep
          outsym(' ')
          if FOT=INDNAME then outsym('*')
          outname(FORNAME)
          if STEPOPND_FLAG<=1 and iMOD(STEPOPND_D)=1 start
             if STEPOPND_D<0 then outstring("--") else outstring("++")
          else
             outstring("+=")
             p=STEPP; csexp(FORPT)
          finish
          outstring(") ")
    !
          P = MARKUI;                  ! TO UI OR '%CYCLE'(HOLE)
          if ALT=3 then start;         ! DEAL WITH CONTROLLED STMNTS
             CUI(0)
          finish else start
             CCYCBODY(0,L2,L3)
             finish
          ->WAYOUT
    SW(4):                                   ! %while COND %cycle
          SET LINE
          outstring("while ")
          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
          outstring("do ")
          C CYC BODY(0,L2,L3)
          P = MARKC
    !      L3 = L3*ENTER LAB(L3,B'011');  ! CONTINUE LABEL IF NEEDED
          LINE = FLINE; SET LINE
          outsep; outstring(" while ")
          CCRES = CCOND(0,2,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        *
    !*    dont generate anything                                           *
    !***********************************************************************
    integer INP,VAL,SUBBITS
    integer exphead,expbot,nops
          exphead=0; expbot=0; nops=0
          INP = P; P = P+3
          torp(exphead,expbot,nops,1)
          if nops>>16&7=0 start        { nothing difficult }
             expop(exphead,expbot,nops,x'200'+FORPT)
             EOPND = EXPOPND;       ! EXPRESSION A LITERAL CONST
          else
             eopnd_flag=255
          finish
    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,D,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,0);       ! 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
             tripopt(triples,triples(0)_flink)
                outopnd(expopnd,0)
                return
    ST:                                      ! STRINGS
                p = p1
                if assop=3 then start
                   outstring("imp_strjam(")
                   if nam#0 then warn(10,0)
                finish else outstring("strcpy(")
                CNAME(2)
                outsym(',')
             p = p2
                CSTREXP(0)
                if assop=3 then outsym(',') and outint(accp-1)
                outsym(')')
                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
                   outstring("memset(")
                   P = P1; CNAME(3)
                   outstring(",0,")
                   OPND1 = NAMEOPND
                   OPND2 = 0
                   OPND2_PTYPE = X'51'; OPND2_FLAG = SCONST
                   outstring("sizeof( ")
                   p=p1; reducetag(NO)
                   outformatname(kform)
                   outsym(')'); outsym(')')
                   P = P2; SKIP EXP
                   return
                finish
                if assop=3 {<-} start
                   ->BACK unless TYPE=3 and A(P2+3)=4 and A(P2+4)=1
                   outstring("memcpy(")
                   P = P1; CNAME(3)
                   outsym(',')
                   OPND1 = NAMEOPND
                   ACCP = ACC
                   P = P2+5; CNAME(3)
                   outsym(',')
                   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
                   outstring("sizeof( ")
                   p=p1; reducetag(NO)
                   outformatname(kform)
                   outsym(')'); outsym(')')
                   P = P2; SKIP EXP
                   return
                finish
                p=P1; cname(7)
                outstring("=")
                p=p2+5; cname(7)
                P = P2; SKIP EXP
                return
    SW(4):                                   ! RESOLUTION
                outstring("imp_resolve(")
                P = P1; CNAME(2)
                outsym(',')
                P = P2;
                if TYPE=5 then CRES(0) else start
                   SKIP EXP
                   FAULT(71,0,LHNAME) unless TYPE=7
                finish
                outsym(')')
                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==
               lhformatname=kform
                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)
                outsym('=')
                P = P2+5
                RHNAME = A(P)<<8!A(P+1)
                if typep=3 start
                  reduce tag(NO)
                  if kform#lhformatname start
                     outsym('('); outformatname(lhformatname)
                     outstring("*)")
                  finish
                finish
                CNAME(KK);                   ! DESCRPTR FETCHED
                if kk=12 start
    !printstring("dv reset "); write( LHCELL_SNDISP,5); write(sndisp,5); write(ctable(sndisp+3),5); newline
                if lhcell_uioj&15=0 then  lhcell_uioj= lhcell_uioj!(j&15)
                if LHCELL_SNDISP=0 then LHCELL_SNDISP=sndisp
             finish
                ->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
                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 outopnd(record(rd)name opnd,integer mode)
    !***********************************************************************
    !*   Outputs an operand which may be a complete tree                   *
    !*      mode&1 = 0 output as is                                        *
    !*      mode&1 = 1 output enclosed in ( and )                          *
    !*       mode&2#0 output as a store not a load                         *
    !*       Mode&256#0 all consts as numeric for switches                 *
    !***********************************************************************
    integer i,pp
    longreal r
    switch sw(0:9)
          if mode&1=1 then outsym('(')
          ->sw(opnd_flag)
    sw(0):                                {short const }
    sw(1):                               {long const }
          if opnd_ptype&7=1 start
             if opnd_ptype&x'f0'=x'60' then outlhex(opnd_d,opnd_xtra) else start
                if opnd_ptype&8#0 and doinglabel=0 then start
                   if opnd_ptype>>4&7=3 start
    {GT:}             outsym('''');
                      if opnd_d = '¬' or opnd_d = '''' c
                       then outsym('¬');
                      outsym(opnd_d);
                      outsym('''')
                   finish else outhex(opnd_d)
                finish else outint(opnd_d)
             finish
          finish
          if opnd_ptype=x'52' then outfl(opnd_r,7)
          if opnd_ptype=x'62' start
             integer(addr(r))=opnd_d
             integer(addr(r)+4)=opnd_xtra
             outfl(r,15)
          finish
          if opnd_ptype=x'72' start
             outstring("NAN or unrepresentable value")
          finish
          if opnd_ptype=x'35' start
             outsym('"')
             outstring(string(addr(a(opnd_d))))
             outsym('"')
          finish
    wayout:
          if mode&1=1 then outsym(')')
          return
    sw(2):                              { name as dictionary no }
          outname(opnd_d)
          ->wayout
    sw(3):                              { name(app) as ar pointer }
          pp=p; p=opnd_d
          if mode&2#0 then cname(1) else cname(2)
          p=pp; ->wayout
    sw(8):                              { triple }
          outtriple(opnd_d,mode&x'ff00')
          ->wayout
    end
    routine outtriple(integer tripno,mode)
    !***********************************************************************
    !*  output an expression defined by a triple which can head a tree     *
    !*  mode as for outopnd                                                *
    !***********************************************************************
    record(tripf)name trip
    conststring(3)array rsassop(ADD:ANDL)="+=","-=","^=",
                                           "|=","*=","/="(2),"&=";
    string(15) op,opl
    integer case,i,j
    switch sw(0:192)
          trip==triples(tripno)
          if mode=1 and doinglabel=0 then outsym('(')
          case=trip_opern
          ->sw(case)
    sw(ADD):
          op="+"; opl="plus"
    binop:
          outopnd(trip_opnd1,mode&x'ff00'!trip_opnd1_flag>>3&1)
           if doinglabel#0 then outstring(opl) else outstring(op)
          outopnd(trip_opnd2,mode&x'ff00'!trip_opnd2_flag>>3&1)
    wayout:
          if mode=1 and doinglabel=0 then outsym(')')
          return
    sw(SUB): op="-"; opl="minus"; ->binop
    sw(NONEQ): op="^"; opl="non"; ->binop
    sw(ORL): op="|"; opl="or"; ->binop
    sw(MULT): op="*"; opl="mul"; ->binop
    sw(INTDIV): op=" / "; opl="idiv"; ->binop
    sw(REALDIV): op=" / "; opl="div"; ->binop
    sw(ANDL): op="&"; opl="and"; ->binop
    sw(RSHIFT): op=">>"; opl="rsh";
          if doinglabel=0 then start
             if trip_opnd1_ptype&x'ff'=x'61' then start
                 outstring("(UINT64)")
             else
                 outstring("(unsigned)")
             finish
          finish; ->binop
    sw(LSHIFT): op="<<"; opl="lsh"; ->binop
    sw(iexp):
          outstring("(int)")
    sw(REXP):
          outstring("pow(")
          outopnd(trip_opnd1,mode&x'ff00')
          outstring(",")
          outopnd(trip_opnd2,mode&x'ff00')
          outstring(")")
          ->wayout
    sw(RSTORE):
    !     printstring("Rstore:")
          if ADD<=trip_x1<=SUB and 0<=trip_opnd2_flag<=1 andc
              trip_opnd2_d=1 and trip_opnd1_ptype&x'ff00'=0{not pointer}start
             outopnd(trip_opnd1,mode&x'ff00')
             if trip_x1=ADD then outstring("++") else outstring("--")
             ->wayout
          finish
          op=rsassop(trip_x1); ->assop
    sw(VASS):sw(VJASS):
          op="="
    assop:
          outopnd(trip_opnd1,mode&x'ff00'!2)
          outstring(op)
          outopnd(trip_opnd2,mode&x'ff00'!0)
          ->wayout
    sw(NOTL): op="~"; opl="not"
    unaryop:
           if doinglabel#0 then outstring(opl) else outstring(op)
           outopnd(trip_opnd1,mode&x'ff00'!trip_opnd1_flag>>3&1)
          ->wayout
    sw(LNEG):
          op="-"; opl="uminus"; ->unaryop
    sw(IFLOAT):
          if trip_opnd1_flag=SCONST start
               trip_opnd1_ptype=x'62'
               begin
               longreal x;
               x=trip_opnd1_d
               trip_opnd1_d=integer(addr(x))
               trip_opnd1_xtra=integer(addr(x)+4)
               end
               op=""
               ->unaryop
          finish
          op="(double)"; ->unaryop
    sw(SHRTN):sw(LNGTHN):sw(JAMSHRTN):sw(NULLT):sw(PRELOAD):
          outopnd(trip_opnd1,mode&x'ff00'!0)
    end {outtriple }
             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,form
                EXPHEAD = 0; EXPBOT = 0
                NOPS = 0; Form=0
                P = P+3
                if a(p)=4 and a(P+1)=3 then Form=1   { Bracketed expr }
                TORP(EXPHEAD,EXPBOT,NOPS,0)
                EXPOP(EXPHEAD,EXPBOT,NOPS,MODE&x'ffff')
    !            tripopt(triples,triples(0)_flink)
                outopnd(expopnd,Form! mode>>16)
             end
    routine labexp
    !***********************************************************************
    !*    Evaluates the expression in a switch label to a valid cname      *
    !*    This means operators have to be replaced by lettere              *
    !***********************************************************************
          doinglabel=1
          csexp(x'51')
          doinglabel=0
    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,1)
    !      ->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,1)
                EXPOP(EXPHEAD,EXPBOT,NOPS,X'200'+PRECTYPE)
                CODE = 1 unless EXPOPND_FLAG<=1 and EXPOPND_PTYPE&x'77'=PRECTYPE
                VALUE = EXPOPND_D
                ACC = SACC; PTYPE = SPTYPE
                UNPACK
                result = CODE
             end
             routine TORP(integer name HEAD,BOT,NOPS,integer mode)
    !***********************************************************************
    !*       CONVERT THE SIGNED EXPRESSION INDEXED BY P INTO REVERSE       *
    !*      POLISH NOTATION. THE REVERSE POLISH LIST IS ADDED TO 'HEAD'    *
    !*      WHICH MAY CONTAIN ANOTHER EXPRESSION. THE NUMBER OF OPERATORS  *
    !*      IS ADDED TO NOPS.                                              *
    !*      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     *
    !*    mode # 0 if const expressions to be evaluated                    *
    !***********************************************************************
                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,PIN
                record (TAGF) name LCELL
                record (RD) RPOP
    !
                PASSHEAD = 0; RPHEAD = 0; SAVEHEAD = 0
                REAL = 0; REALOP = 0; BDISP = 0
                RPBOT = 0; OPSTK = 0; OPPSTK = 0
                PIN=p
    !
                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
                TYPE = PTYPE&7; PREC = PTYPE>>4&15
                if PTYPE=X'FFFF' then PTYPE = X'51';    ! NAME NOT SET
                if PTYPE=SNPT then PTYPE = LCELL_ACC and UNPACK
                if (mode#0 or string(addr(worka_lett(word(opname))))="pi") c
                   and PTYPE&X'FF00'=X'4000' and A(P+2)=2=A(P+3) and 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 or d=3 then start
                   d=4; RPOP_D = FROM AR2(P+1)
    !               PTYPE = ptype&8!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,mode)
                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 constform#0 and 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
                                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 PT2=7 then PT2=1
                      if RULES=4 then PT1 = CELL_S2&7;    ! ORIGINAL PT FOR ARRAYS%c
                                                          ETC
                      if PT1=7 then PT1=1
                      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,sp3)
                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

    {GT:} ! Would be nice to apply de-morgan's law below and invert the actual
          ! conditional tests, eg
          !        a=1 %and b>fred
          ! ->     a#1 %or b<=fred
          !
          ! Since Imp80 has no %predicates, we don't need to re-insert any "!"s
          ! at a lower level, except for conditional string resolution, i.e.
          !       a->a.("->").b
          ! ->    (%not a->a.("->").b)
          !
          ! If we add this as a general mechanism, then when translating to
          ! C we can clean up 'unless' and 'repeat until' statements, which map
          ! to C's if and while statements.
          !
          ! Also it would be useful in my %if <cond> %then %monitor
          ! extension, which maps to assert(!(<cond>))
          !
          ! NOTE: ** it would appear SKIP SC(1) and SKIP COND()
          ! do exactly what I want here!
          !
    !           %if iu=2 %then outstring("(!")
                outsym('(')
                if iu=2 then start
                  SKIP SC(1);                  ! SKIP THE 1ST CMPARSN
                  SKIP COND(1);                ! AND ANY %and/%or CLAUSES
                else
                  SKIP SC(0);                  ! SKIP THE 1ST CMPARSN
                  SKIP COND(0);                ! AND ANY %and/%or CLAUSES
                finish
                outstring(") ")
    !           %if iu=2 %then outsym(')')
                result=0
    routine SKIP SC(integer REVERSED)
    !***********************************************************************
    !*       REVERSED=1 FOR RECURSIVE CALL IN %not(SC)                     *
    !*       SKIPS OVER A SIMPLE CONDITION. P ON ALT OF<SC>                *
    !***********************************************************************

    !
    ! In Imp to C translator we do NOT generate jumps so the logic
    ! for REVERSED which changes the jump destinations does not
    ! do anything.  Instead we must explicity apply de-morgan's
    ! law to the operands and operators.  I am in the process
    ! of adding that code now.  SKIP COND is done already

    conststring(5) array CMP(0:10)=" ??? ","==",">=",">",
                           "!=","<=","<","!=","?->??",
                           "==","!="

    conststring(6) array REVCMP(0:10)=" ??? ","!=","<","<=",
                           "==",">",">=","==","!?->??",
                           "!=","=="

    switch SCALT(1:4)
    integer ALT,TE1,TE2,PRECP,TYPEp,finalp,rexp
          ALT = A(P); P = P+1
          ->SCALT(ALT)
    SCALT(1):                                ! <EXP><COMP><EXP><SECONDSIDE>
          C1_SP1 = P
          te1=tsexp(TE2)
          typep=type; precp=prec
          p = c1_sp1             { tsexp may not reset p }
          SKIP EXP
          C1_CMP1 = A(P)
          C1_REV = 3*REVERSED
          P = P+1; C1_SP2 = P
          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; C1_SP3=P; SKIP EXP
          finish
          finalp=p
    !      outsym('(') %unless a(finalp)=3
          if typep=5 start
             p=c1_sp1
             if c1_cmp1=8 start
               outstring("imp_resolve(")
               p=p+5; cname(2)
                outsym(',')
               p=c1_sp2; cres(1)
               if REVERSED=1 then start
                 outstring(")!=0"); ! De-Morgan's law
               else
                 outstring(")==0")
               finish
               if c1_cmp2#0 then outstring("untranslateable cond")
            else
                if c1_cmp2#0 then outsym('(')
                outstring("strcmp(")
                cstrexp(0)
                outsym(',')
                p=c1_sp2; cstrexp(0)
                outsym(')')
                if REVERSED=1 then start
                  outstring(REVcmp(c1_cmp1)); ! de-morgan's law
                else
                  outstring(cmp(c1_cmp1))
                finish
                outsym('0')
                if c1_cmp2#0 then start
                   if REVERSED=1 then start
                      outstring(") || ("); ! De-Morgan's Law
                   else
                      outstring(") && (")
                   finish
                   p=c1_sp2; cstrexp(0)
                   outsym(',')
                   p=c1_sp3
                   cstrexp(0)
                   outsym(')')
                finish
            finish
          else
             if c1_cmp2#0 then outsym('(')
             p=c1_sp1
             REXP = 2-A(P+1+FROM AR2(P+1))
             if rexp#0 then outsym('(')
             if c1_cmp1>8 then p=p+5 and cname(4) else csexp(precp<<4!typep!256)
             if rexp#0 then outsym(')')
             if REVERSED=1 then start
                outstring(REVcmp(c1_cmp1)); ! DeMorgan's law
             else
                outstring(cmp(c1_cmp1))
             finish
             p=c1_sp2
             REXP = 2-A(P+1+FROM AR2(P+1))
             if rexp#0 then outsym('(')
             if c1_cmp1>8 then p=p+5 and cname(4) else csexp(precp<<4!typep!256)
             if rexp#0 then outsym(')')
             if c1_cmp2#0 start
                if REVERSED=1 then start
                   outstring(") || (")
                else
                   outstring(") && (")
                finish
                if rexp#0 then outsym('(')
                p=c1_sp2; csexp(precp<<4!typep)
                if rexp#0 then outsym(')')
                if REVERSED=1 then start
                   outstring(REVcmp(c1_cmp1)); ! DeMorgan's law
                else
                   outstring(cmp(c1_cmp2))
                finish
                p=c1_sp3
                REXP = 2-A(P+1+FROM AR2(P+1))
                if rexp#0 then outsym('(')
                csexp(precp<<4!typep)
                if rexp#0 then outsym(')')
                outsym(')')
             finish
          finish
          p=finalp
    !      outsym(')') %unless a(finalp)=3
          return
    SCALT(2):                                ! '('<SC><RESTOFCOND>')'
          outsym('(')
          L = L+1
          SKIP SC(REVERSED)
          SKIP COND(REVERSED)
          L = L-1
          outsym(')')
          return
    SCALT(3):                                ! %not(SC)
    {GT:}!outstring("!(")
         ! now that SKIP SC and SKIP COND reverse properly,
         ! we do not need to negate here as well...
          SKIP SC(REVERSED!!1)
         !outsym(')')
          return
    SCALT(4):
          if REVERSED=1 then outstring("/* what is a pseudo-boolean? - is the conditio accidentally inverted? */");
          csexp(x'51');             ! single pseudo boolean expr
       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)
    {GT: experimenting with reversing}

                         if REVERSED=1 then start
                           ! Apply de-morgan to operators
                           if alt=1 then outstring(" || ") else outstring(" && ")
                         else
                           if alt=1 then outstring(" && ") else outstring(" || ")
                         finish

                         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
             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)
             result=0
             end
             routine ENTER JUMP(integer TFMASK,LAB,FLAGS)
             end
             routine REMOVE LAB(integer 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)                  *
    !*       67=%integerfn TRUNC(%longreal X)                              *
    !***********************************************************************
    integer fn spec OPTMAP
    switch ADHOC(0:67)

    const string(80) array SMDETAILS(0:NO OF SNS) = c
      /* 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)",
      /* 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)",
      /* 45 */ "%byteintegermap CHARNO(%stringname STR,%integer CHARREQD)",
      /* 46 */ "%string(1)",
      /* 47 */ "%string(255)",
      /* 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)",
      /* 67 */ "%integerfn TRUNC(%longreal X)"

    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","sqrt" , "log"  , "sin",
          "cos"  , "tan"  , "exp"  , "s#closestream",
          "s#iradius","atan2","imp_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,formatname,NOPS
          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.
    !
          ->adhoc(snno)
    adhoc(47):                                   ! substring
             outstring("imp_substring(")
          p=p+1; cstrexp(0); outsym(',')
          p=p+1; csexp(x'51'); outsym(',')
          p=p+1; csexp(x'51'); outsym(')');
          p=p+1; ->OKEXIT
    adhoc(24):                                   ! arccos
    adhoc(25):                                   ! sqrt
    adhoc(26):                                   ! log
    adhoc(27):                                   ! sin
    adhoc(28):                                   ! cos
    adhoc(29):                                   !tan
    adhoc(30):                                   ! exp
          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
          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>
    ADHOC(6):ADHOC(7):                       ! NEWLINES(=6) & SPACES(=7)
          if parm_arr=0 start
             if snno=6 then outstring("_imp_newlines(") else outstring("_imp_spaces(")
             p=p+1; csexp(x'51')
             outsym(')')
             p=p+1
             ->OKEXIT
          finish
          p=p+1
          if tsexp(jj)>0 and jj>0 start
    {GT:}    outstring("fprintf(out_file, "); outsym('"')
             for xtra=1,1,jj cycle
                if snno=6 then outstring("¬n") else outstring(" ")
            repeat
             outsym('"'); outsym(')')
          else
             p=PIN+3
             outstring("{ for (_imptempint=1; _imptempint<=")
             csexp(x'51')
             outstring("; _imptempint++) fprintf(out_file, "); outsym('"')
             if snno=6 then outstring("¬n") else outstring(" ")
             outsym('"')
             outstring(");}")
          finish
          P = P+1
          ->OKEXIT
    ADHOC(37):                                  ! printstring
          if parm_arr=0 then start
            outstring("_imp_printstring(")
          finishelsestart
    {GT:}   outstring("fprintf(out_file, "); outsym('"'); outstring("%s")
            outsym('"'); outstring(", ")
          finish
          p=p+1
          cstrexp(0)
          outstring(")")
          P=P+1; ->OKEXIT
    adhoc(2):                                   ! newline
          if parm_arr=0 start
             outstring("_imp_newlines(1)")
          else
    {GT:}    outstring("fprintf(out_file, "); outsym('"'); outstring("%s")
             outsym('"'); outstring(", "); outsym('"'); outsym('¬')
             outsym('n'); outsym('"');outsym(')')
          finish
          P=P+1; ->OKEXIT
    adhoc(3):                                        ! space
          if parm_arr=0 start
             outstring("_imp_spaces(1)")
          else
    {GT:}    outstring("fprintf(out_file, "); outsym('"'); outstring("%s")
             outsym('"'); outstring(", "); outsym('"'); outsym(' ')
             outsym('"'); outsym(')')
          finish
          P=P+1; ->OKEXIT
    adhoc(21):                                  ! real
    adhoc(22):                                  ! integer
    adhoc(61):                                  ! halfinteger
    adhoc(66):                                  ! shortinteger
    adhoc(39):                                  ! longreal
    adhoc(32):                                  ! byteinteger
    adhoc(54):adhoc(55):                         ! long int & longlongreal
          outstring("(*(")
          outtype(snptype&255,0)
          outstring(" *)(")
          p=p+1; csexp(x'51')
          outstring("))")
          P=P+1; ->OKEXIT
    adhoc(42):                                  ! string
          outstring("((char *)")
          p=p+1; csexp(x'51')
          outstring(")")
          P=P+1; ->OKEXIT
    adhoc(45):                                   ! charno
    {GT: Needs special handling for charno(s,0); also for LHS = ..}
          if z#2 then warn(10,0)
          p=p+1; cstrexp(0)
          outsym('[')
          p=p+1; csexp(x'51')
          outstring("-1]")
          p=p+1
          ->OKexit
    ADHOC(36):                               ! length
    {GT: Also needs special treatment on LHS }
          if z#2 then warn(10,0)
          outstring("strlen(")
          p=p+1; cstrexp(0)
          outstring(")")
          P=P+1; ->OKEXIT
    adhoc(46):                                  ! tostring
          outstring("imp_tostring(")
          p=p+1; csexp(x'51')
          outstring(")")
          P=P+1; ->OKEXIT
    ADHOC(9): adhoc(40):                      ! printsymbol & printch
          if parm_arr=0 start
             outstring("_imp_printsymbol(")
          else
    {GT:}    outstring("fprintf(out_file, ");
             outsym('"')
             outstring("%c")
             outsym('"');
             outstring(", ");
          finish
          p=p+1; csexp(x'51')
          outstring(")")
          P = P+1
          ->OKEXIT
    ADHOC(12):                               ! write
          if parm_arr=0 start
             outstring("_imp_write(")
             p=p+1; csexp(x'51'); outsym(',')
             p=p+1; csexp(x'51'); outsym(')')
             p=P+1; ->OKEXIT
          finish
          p=p+1; skip exp; p=p+1; jj=tsexp(xtra)
          p=PIN+2
          if jj#0 start
             outstring("fprintf(out_file, "); outsym('"'); outstring("%")
             outint(imod(xtra)+1); outstring("d"); outsym('"'); outstring(",")
          else
             outstring("fprintf(out_file, "); outsym('"'); outstring(" %d"); outsym('"'); outstring(",")
          finish
          p=p+1; csexp(x'51')
          outstring(")")
          p=PIN+2; skip app
          p=p-1; ->OKEXIT
    ADHOC(19):                               ! print
          if parm_arr=0 start
             outstring("_imp_print(")
             p=p+1; csexp(x'62'); outsym(',')
             p=p+1; csexp(x'51'); outsym(',')
             p=p+1; csexp(x'51'); outsym(')')
          else
             outstring("fprintf(out_file, "); outsym('"'); outstring(" %f"); outsym('"'); outstring(",")
             p=p+1; csexp(x'62')
             outstring(")")
          Finish
          p=PIN+2; skip app
          p=p-1; ->OKEXIT
    ADHOC(20):                               ! printfl
          if parm_arr=0 start
             outstring("_imp_printf(")
             p=p+1; csexp(x'62'); outsym(',')
             p=p+1; csexp(x'51'); outsym(')')
          else
             outstring("fprintf(out_file, "); outsym('"'); outstring(" %e"); outsym('"'); outstring(",")
             p=p+1; csexp(x'62')
             outstring(")")
          finish
          p=PIN+2; skip app
          p=p-1; ->OKEXIT

    ADHOC(0):                               ! SELECT INPUT
          if parm_arr=0 start
             outstring("_imp_selectinput(")
             p=p+1; csexp(x'51'); outsym(')')
             p=p+1; ->OKEXIT
          finish
          ! if C i-o we can not handle this so fall thru
    {GT:}
          outstring("selectinput(")
          p=p+1; csexp(x'51'); outstring(")")
          p=p+1;
          ->OKEXIT

    ADHOC(1):                               ! SELECT OUTPUT
          if parm_arr=0 start
             outstring("_imp_selectoutput(")
             p=p+1; csexp(x'51'); outsym(')')
             p=p+1; ->OKEXIT
          finish
          ! if C i-o we can not handle this so fall thru
    {GT:}
          outstring("selectoutput(")
          p=p+1; csexp(x'51'); outstring(")")
          p=p+1;
          ->OKEXIT

    ADHOC(64):ADHOC(65):                      ! 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
          outstring("((long int) floor(")
          p=p+1
          CSEXP(typeflag(12)&255);    ! LONGLONGREAL MODE or longreal if defaulted
          if SNNO=64 then outstring("+0.5")
          outstring("))")
          P = P+1
          P0 = X'61'; ->OKEXIT
    ADHOC(16):ADHOC(17):                      ! INT(=16) AND INTPT (=17)
          outstring("((int) floor(")
          p=p+1
          CSEXP(LRLPT)
          if SNNO=16 then outstring("+0.5")
          outstring("))")
          P = P+1
          ->OKEXIT
    ADHOC(67):                                 ! trunc
          outstring("((int)(")
          p=p+1
          CSEXP(LRLPT)
          outstring("))")
          P = P+1
          ->OKEXIT

    {GT:}
    ADHOC(4):                                ! SKIP SYMBOL
          outstring("(void)fgetc(in_file)")
          P = P+2 { DON'T KNOW HOW MUCH TO ALTER P BY }; ->OKEXIT

    ADHOC(8):                                ! NEXT SYMBOL
          P = P+6;
          CNAME(1);
          outstring("ungetc(fgetc(in_file), in_file)")
          P = P+2; ->OKEXIT

    ADHOC(10):                                ! READ SYMBOL
    ADHOC(41):                                ! READ CH
          P = P+6;
          CNAME(1);
          outstring(" = fgetc(in_file)")
          P = P+2; ->OKEXIT

    ADHOC(14):                                ! ADDR(=14)
          P = P+6; CNAME(4);           ! FETCH ADDRESS MODE
          P = P+2; ->OKEXIT
    ADHOC(23):                                ! MOD(=23)
          outstring("fabs(")
          p=p+1
          csexp(x'62')
          outstring(")")
          P = P+1
          ->OKEXIT
    ADHOC(51):                               ! imod
          outstring("abs(")
          p=p+1
          csexp(x'51')
          outstring(")")
          P = P+1
          ->OKEXIT
    ADHOC(52):                               ! PI(=52)
    ADHOC(38):                                ! NL(=38). THIS FN IS PICKED OFF
                P = P+1
                ->OKEXIT;                    ! ERROR EG NL=A+B
    ADHOC(48):                               ! RECORD(=48)
          p=p+1
          if tsexp(jj)=1 and jj=0 start
             outstring("NULL")
          else
             if z#4 start
                outsym('(')
    !            outsym('('); outtype(x'33',lhformatname)
    !            outsym('*')
    !            outsym(')')
             finish
             p=PIN+3
             CSEXP(X'51')
             P = P+1
             outsym(')')
          finish
          DISP = 0; BASE = 0; ACCESS = 3
          OLDI = 0; ACC = X'FFFF'
          SNPTYPE = SNPTYPE+X'1C00';   ! ADD MAP BITS
          PTYPE = SNPTYPE; UNPACK
          return
    ADHOC(49):                               ! ARRAY(=49)
          p=p+1
          skip exp
          ERRNO = 22; ERRVAL = 2
          ->ERREXIT unless A(P+4)=4 and A(P+5)=1
          P = P+6; formatname=fromar2(p)
          copytag(formatname,NO)
          p=p+4
          ->ERREXIT unless A(P)=2
          xtra=p+2
          outstring("(("); outtype(ptype&255,lhformatname)
          outstring("*)(")
          p=PIN+3
          CSEXP(X'51');                ! ADDR(A(0)) TO NEST
          outstring("))")
          copytag(formatname,NO)
          P = xtra
          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

    ADHOC(*):                                ! NEXTSYMBOL(=8) & NEXTITEM(=44)
                                             ! ALSO ANY WITH NO C EQUIVALENTS
    {GT:} outstring("/* Call to ");
          outstring(SMDETAILS(snno));
          outstring (" - please modify pass2.i to handle it */")
          skip app; p=p-1; -> OKEXIT

    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 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
                   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,LB,
       ARRNAME,Q,PRECP,NAMINF,DVD,DVDP,PRIVOPS
    record (RD) VMYOP,RPOP
    record (TAGF) name LCELL
    integer array HEADS,BOTS(0:12)
                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
                      heads(kk)=p; skip exp
                      P = P+1
                   repeat
                   pp=p; outstring(" [")
                   DVDP=DVD+3*jj
                   cycle KK = jj,-1,1
                      p=heads(kk); csexp(x'51')
                      LB=Ctable(DVDP)
                      if DVD#0 start    { we know how to adjust bounds }

    !GT: remove the correction for the lower bound from array accesses
    !    because we now do the correction at the point of declaration

                         if LB=x'80000000' start
    !GT:                    outstring("-(")
    !GT:                    p=Ctable(DVDP+1); csexp(x'51'); outsym(')')
                         finish else if lb>0 start
    !GT:                    outsym('-'); outint(LB)
                         finish else if LB=0 start
    !                        outint(LB)
                         finish else if LB<0 start
    !GT:                    outsym('+'); outint(-LB)
                         finish
                      else
                         warn(13,0)
                      finish
                      outstring("] [") unless kk=1
                      DVDP=DVDP-3
                   repeat
                   p=pp; outsym(']')
                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
                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 namepreamble(integer z,fname)
    !***********************************************************************
    !*     puts any unary operators on front of the name                   *
    !*     assumes ptype has been set and unpacked                         *
    !***********************************************************************
    integer typep,qq,subs,pp
          typep=type
          pp=p
          if typep=3 then qq=copy record tag(subs) and p=pp
          if z=3 and type#5 and (nam=0 or arr#0) then outsym('&')
          if z=4 and type#5 and (nam=0 or arr#0) then outstring("(int)&")
          if z=4 and (type=5 or (nam#0 and arr=0)) then outstring("(int)")
          if (z=1 or z=2) and ((nam#0 and arr=0=rout) orc
          (nam>=2 and rout=1{mapping fn call })) and type#5 c
           and not(typep=3 and qq=0){ NOT RECORD WITHOUT SUBNAME} then outsym('*')
          if z=7 and typep=3 and qq=0 and nam#0 and arr=0 thenc
             outsym('*')          { record pointer without subname }
          outname(fname)
          if typep=3 then copy tag(fname,no)
    end
    !*
             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
               namepreamble(z,fname)
                ->SW(TYPE)
    SW(6):
                FAULT(5,0,FNAME)
                ->NOT SET
    SW(4):                                   !RECORD FORMAT NAME
                FAULT(87,0,FNAME)
    NOT SET:                                 ! NAME NOT SET
               namepreamble(z,fname)
    SW(7):
                BASE = I; DISP = K; ACCESS = 0
                NAMEOPND = 0; NAMEOPND_PTYPE = X'51'
                PTYPE = X'51'; UNPACK
                P = P+2
                if a(p)=1 start
                   {%if z=1 %or z=3 %or z=4 %then jj='[' %else} jj='('
                   outsym(jj)
                   p=p+1; csexp(x'51')
                   while a(p)=1 cycle
                       outsym(','); p=p+1; csexp(x'51')
                   repeat
                   outsym(jj+1+jj>>6)      { ')' or ']' }
               finish
               p=p+1
              ->CHKEN
    FUNNY(11):                               ! SET 32 BIT ADRESS OF ARRAYHEAD
    FUNNY(12):                               ! MOVE ARRAYHEAD TO ESTACK
                if PTYPE=SNPT then CSNAME(12) and ->CHKEN
                namepreamble(z,fname)
                ->SW(3) if TYPE=3 and (ARR=0 or A(P+2)=1)
                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
               namepreamble(z,fname)
                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
               namepreamble(z,fname)
                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)
                   outsym('_'); outname(fromar2(P+1))
                   P = P+3; SKIP APP
                repeat
                P = P+1
             end

             routine NAMEOP(integer Z,SIZE,NAMEP)
             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,DVD,DVDP,LB,KK
    record (RD) OPND,OPND1,OPND2
    record (LISTF) name LCELL
                PT = PTYPE; JJJ = J; TL = OLDI
                TWSP = 0; FPTR = 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
                   outsym('(')
                   ->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
                  outsym(',') unless clink=0
    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
                      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
                         -> bad parm
                      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(6)
                         P = P+1
                         JJ = 1
                         EXPOPND = NAMEOPND
                         ->BAD PARM unless ACC=PSIZE
                      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(0)
                         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_flag = reftrip; opnd1_ptype = pptype
                         ->next parm
                      finish else start
                         CSTREXP(0)
                         FPTR = FPTR+ACC
                      finish
                   finish else start
                      CSEXP(III<<4!II)
                      FPTR = FPTR+BYTES(III)
                   finish
                   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(0)
                            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'
                         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
                         NAMEOPND_FLAG = REFTRIP
                         NAMEOPND_PTYPE = PPTYPE
                         NAMEOPND_D = QQQ
                      finish
                      JJ = PTRSIZE(III<<4!II)
                      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_PTYPE = X'61'; EXPOPND_FLAG = REFTRIP
                      EXPOPND_XTRA = 0
                      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
                   reduce tag(NO)
                   DVD = SNDISP
                   if DVD#0 then outsym('&'); CNAME(12)
                   P = P+1
                   ->BAD PARM unless 1<=ARR<=2 and II=TYPE and III=PREC
                   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
                   if DVD#0 start    { have info to adjust basepoint }
                      DVDP=DVD+3*jj
                      cycle KK = jj,-1,1
                         LB=Ctable(DVDP)
                         outsym('[')
                         if LB=x'80000000' start
                            outstring("-(")
                            p=Ctable(DVDP+1); csexp(x'51'); outsym(')')
                         finish else if lb>0 start
                            outsym('-'); outint(LB)
                         finish else if LB<=0 start
                            {outsym('+');} outint(-LB)
                         finish
                         outstring("] ")
                         DVDP=DVDP-3
                      repeat
                   finish
                   FPTR = FPTR+AHEADSIZE
                   ->NEXT PARM
    ENTRY SEQ:                               ! CODE FOR RT ENTRY
                   outsym(')')
                   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
                      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,KK,SIGN,CT
          TYPE = 1; PP = P
          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)
          if ptype&x'ff0f'=x'4001' start   { any const int }
             if a(p+2)=2 and a(p+3)=2 and a(p+4)=2 then start
                value=midcell
                p=p+5
                if sign#2 then result = 2
                value=-value; result=-2
             finish
          finish
          ->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 a(p+5)=2
          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
    !*
    integerfn tsc
    integer value,res,PP
    switch sw(1:4)
    !printstring("tsc  with p="); write(p,5); newline
          PP=p
          ->sw(a(p))
    sw(1):
             p=p+1
             res=tsexp(value)
             if res=0 then result=0
             p=p+1
    !printstring("tcond part2 with p="); write(p,5); newline
             res=tsexp(value)
             if res=0 then result=0
             p=p+1
             if a(p-1)=1 then result=0
             RESULT=1
    SW(2):
             p=p+1; res=tcond
    !printstring("returns from tcond with res & p "); write(res,1); write(p,5); newline
             result=res
    SW(3):
             P=P+1
             result=tsc
    sw(4):                   ! boolean
          result=tsexp(value)
    end
    integerfn tcond
    !***********************************************************************
    !*     Check for a simple compile time condition. PP to First exp      *
    !***********************************************************************
    integer value,res,PP
    !printstring("tcond with p="); write(p,5); newline
          PP=p
          res=tsc
          if res=0 then result=0
          if a(p)=3 then p=p+1 and result=1
          until a(p)=2 cycle
             p=p+1; res=tsc
             if res=0 then result=0
          repeat
          p=p+1
          result=1
    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,precp
                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 start
                         precp=A(P)>>4
                         if precp=3 then precp=4
                         P = P+1+BYTES(precp)
                      finish
                   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
    !***********************************************************************
    !*  Deals with unexpected parameters                                   *
    !***********************************************************************
          P = P+2
          if A(P)=1 then start;        ! <APP> PRESENT
             FAULT(17,0,FROM AR2(P-2))
             outsym('[')
             while a(p)=1 cycle
               p=p+1
               csexp(x'51')
               if a(p)=1 then outsym(',')
             repeat
            p=p+1; outsym(']')
          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; kform = -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 i=1{FAULT(102,WORKA_WKFILEK,0)}
             NEXT TRIP = i +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
             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
             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
             record (TRIPF) name CURRT
             CELL = NEWTRIP
             CURRT == TRIPLES(CELL)
             CURRT_OPERN = OPERN
             CURRT_OPTYPE <- OPTYPE
             CURRT_FLAGS <- FLAGS
             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
             record (TRIPF) name CURRT
             CELL = NEWTRIP
             CURRT == TRIPLES(CELL)
             CURRT_OPERN = OPERN
             CURRT_OPTYPE <- OPTYPE
             CURRT_FLAGS <- FLAGS
             CURRT_OPND1 = OPND1
             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