pass3.i

    !!{GT:}%include "hostcodes.inc"

    CONSTINTEGER YES=1,NO=0

    !
    ! THESE CODE ARE ARBITARY BUT THE TOP DECIMAL DIGIT GIVES THE NO OF BYTES
    ! IN THE UNIT OF ADDRESSABILITY. BYTE ADDRESSED HOSTS BEING 1N ( also 0N) AND
    ! 16 BIT WORD ADDRESSED HOSTS BEING 2N ETC
    CONSTINTEGER PENTIUM=4;                 ! PENTIUM chip Unix stack and completely swopped
    constinteger MIPS=05;                   ! Imp on MIPS (all variants)
    CONSTINTEGER RS6=06;                    ! imp on IBM rs6000
    CONSTINTEGER M88K=07;                   ! Imp on all forms of 88k
                                            ! also serves for Sparc sinc there is a common b-e
    CONSTINTEGER VAX=08;                    ! Imp on Vax using F & G formats
    CONSTINTEGER UNISYS=09;                 ! Imp on UnisSys. Unix stack unswopped Vax reals
    CONSTINTEGER EMAS=10;                   ! emas on 2900 (unsigned shorts)
    CONSTINTEGER IBM=11;                    ! emas on 24 bit ibm hardware
    CONSTINTEGER IBMXA=12;                  ! emas of XA 31 bit hardware
    CONSTINTEGER WWC=13;                    ! WWc (Natsemi chip) completely swopped
    CONSTINTEGER AMDAHL=14;                 ! Emas on Amdahls guess at Xa Minor differences fron IBM)
    CONSTINTEGER PERQ3=15;                  ! ICL packaged 68k chip Unix stack but not swopped
    CONSTINTEGER GOULD=16;                  ! Gould unswopped forward stack. Needs 4&8 byte alined
    CONSTINTEGER VNS=17;                    ! Unix on 2900 unsigned shorts params as
                                            ! 2900. Long int available but not in Ecode
    CONSTINTEGER EAMD=18;                   ! Amdahl via the Emachine
    CONSTINTEGER DRS=19;                    ! Intel chip Unix stack and mostly swopped
    CONSTINTEGER PERQ=20;                   ! Pos perq now obselete. Fully swopped forward stack
    CONSTINTEGER PNX=21;                    ! ICL's perq2 Unix stack byte swopped (unsigned shorts)
    CONSTINTEGER ACCENT=22;                 ! Perq 1 under accent. obsolete now
                                            ! ACCENT DIFFERS FROM PERQ ONLY IN
                                            ! ASSEMBLES SEQUENCES&SYNTAX
                                            ! AND GENERATOR
    constinteger ORN=23
    CONSTINTEGER UNSIGNEDSHORTS=1<<emas!1<<pnx!1<<vns
    CONSTINTEGER LINTAVAIL=1<<IBM!1<<IBMXA!1<<amdahl!1<<EMAS!1<<GOULD!1<<MIPS
    CONSTINTEGER LLREALAVAIL=1<<IBM!1<<IBMXA!1<<amdahl!1<<EMAS!1<<MIPS
    CONSTINTEGER EMACHINE=1<<DRS!1<<PENTIUM!1<<WWC!1<<Vax!1<<GOULD!1<<PERQ3!1<<VNS!1<<EAMD!1<<ORN!1<<UniSys!1<<m88k!1<<rs6!1<<MIPS
    CONSTINTEGER IBMFPFORMAT=1<<ibm!1<<ibmxa!1<<amdahl!1<<emas!1<<gould!1<<vns!1<<EAMD
    constinteger VAXFPFORMAT=1<<Vax!1<<UniSys
    constinteger IEEEFPFORMAT=1<<WWC!1<<PERQ3!1<<DRS!1<<PENTIUM!1<<PERQ!1<<accent!1<<m88k!1<<rs6!1<<MIPS
    CONSTINTEGER BYTESWOPPED=1<<PERQ!1<<ACCENT!1<<WWC!1<<Vax!1<<PNX!1<<ORN
    CONSTINTEGER HALFSWOPPED=1<<PERQ!1<<ACCENT!1<<WWC!1<<Vax!1<<DRS!1<<PENTIUM!1<<ORN
    CONSTINTEGER WORDSWOPPED=1<<PERQ!1<<ACCENT!1<<WWC!1<<Vax!1<<DRS!1<<PENTIUM!1<<ORN
    CONSTINTEGER RISKMC=1<<M88K!1<<rs6!1<<MIPS
    !
    ! end of file hostcodes
    !

    CONSTINTEGER HOST=M88K
    CONSTINTEGER TARGET=RS6
    !
    ! 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 like
    ! passing Labels this still applies, this adhocery has caused problems with 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 dvs)
    !           Opnd2 exactly as for VMY
    !

    !
    ! RECORDFORMAT FOR ALL THE OPTION AND FLAG VARAIBLES
    !
    ! amended to remove non-alined longreal prior to bootstrapping to gould
    !
    RECORDFORMAT PARMF(INTEGER BITS1,BITS2,TTOPUT,
          BYTEINTEGER LET,DYNAMIC,LINE,TRACE,ARR,DBUG,CHK,DIAG,OPT,FREE,
          LIST,CPRMODE,COMPILER,Z,Y,PROF,INHCODE,DCOMP,FAULTY,X,STACK,MAP,QUOTES,S2,
          INTEGER LPOPUT,SP0)
    RECORDFORMAT LEVELF(INTEGER RBASE, DIAGINF, RAL, FLAG, L, M, NMDECS, ONWORD, ONINF,
             LABEL, JROUND, UNATT FORMATS, PSIZE, ENTRYAD, DISPLAY, AUXSBASE,
             NAMES, SNMAX,SN,RESSIZE,CLEVEL,SET, MAXPP, EXITLAB, CONTLAB, S3,
           INTEGERARRAY AVL WSP(0:4))

    IF 1<<host&unsignedshorts=0 START
    RECORDFORMAT RD((INTEGER S1 OR SHORT PTYPE,BYTE XB,FLAG),
          ((INTEGER D OR REAL R),
          INTEGER XTRA OR SHORT H0,H1,H2,H3 OR BYTE B0,B1,B2,B3,B4,B5,B6,B7))
    RECORDFORMAT TAGF((SHORTINTEGER PTYPE,UIOJ,SNDISP,ACC,SLINK,KFORM OR C
          INTEGER S1,S2,S3),INTEGER LINK)
    RECORDFORMAT TRIPF(BYTE OPERN,OPTYPE,CNT,DPTH,
          SHORTINTEGER FLAGS,PUSE,FLINK,BLINK,INTEGER X1,
          RECORD(RD) OPND1,OPND2)
    RECORDFORMAT LISTF((SHORTINTEGER PTYPE,(SHORT UIOJ OR BYTE XB,FLAG),
          SHORT SNDISP,ACC,SLINK,KFORM OR  INTEGER S1,S2,S3),INTEGER LINK)
    FINISH ELSE START
    RECORDFORMAT RD((INTEGER S1 OR HALF PTYPE,BYTE XB,FLAG),
          ((INTEGER D OR REAL R),
          INTEGER XTRA OR HALF H0,H1,H2,H3 OR BYTE B0,B1,B2,B3,B4,B5,B6,B7))
    RECORDFORMAT TAGF((HALFINTEGER PTYPE,UIOJ,SNDISP,ACC,SLINK,KFORM OR C
          INTEGER S1,S2,S3),INTEGER LINK)
    RECORDFORMAT TRIPF(BYTE OPERN,OPTYPE,CNT,DPTH,
          HALFINTEGER FLAGS,PUSE,FLINK,BLINK,INTEGER X1,
          RECORD(RD) OPND1,OPND2)
    RECORDFORMAT LISTF((HALFINTEGER PTYPE,(HALF UIOJ OR BYTE XB,FLAG),
          HALF SNDISP,ACC,SLINK,KFORM OR  INTEGER S1,S2,S3),INTEGER LINK)
    FINISH
    RECORDFORMAT WORKAF(INTEGER NNAMES,CCSIZE,DSIZE,ASL MAX,ASL CUR BTM,CONST PTR,
          CONST BTM,LASTTRIP,WKFILEAD,WKFILEK,FILE ADDR,RELEASE,AASL0,CONST LIMIT,
          RTCOUNT,ARTOP,AMAINEP,DICTBASE,OPTCNT,INCLHEAD,S2,S3,S4,
          INTEGERNAME LINE,N,S5,STRING(9)LADATE,
          BYTEINTEGERARRAYNAME CC,A,LETT,
          INTEGERARRAYNAME WORD,TAGS,CTABLE,
          RECORD(LEVELF)ARRAYNAME LEVELINF,
          INTEGERARRAY PLABS,PLINK(0:31),
          RECORD(LISTF)ARRAYNAME ASLIST)
    !
    ! TRIPF_FLAGS SIGNIFY AS FOLLOWS
    CONSTINTEGER LEAVE STACKED=2****0;      ! SET LEAVE RESULT IN ESTACK
    CONSTINTEGER LOADOP1=2****1;            ! OPERAND 1 NEEDS LOADING
    CONSTINTEGER LOADOP2=2****2;            ! OPERAND 2 NEEDS LOADING
    CONSTINTEGER NOTINREG=2****3;           ! PREVENT REG OPTIMISNG
                                            ! OF TEMPS OVER LOOPS&JUMPS
    CONSTINTEGER USE ESTACK=2****4;         ! KEEP DUPLICATE IN ESTACK
    CONSTINTEGER USE MSTACK=2****5;         ! PUT DUPLICAT ON MSTACK
    CONSTINTEGER CONSTANTOP=2****6;         ! ONE OPERAND IS CONSTANT(FOR FOLDING)
    CONSTINTEGER COMMUTABLE=2****7;         ! OPERATION IS COMMUTABLE
    CONSTINTEGER BSTRUCT=2****12;           ! Proc contains inner blks or RTs
    CONSTINTEGER USED LATE=2****13;         ! I-RESULT USED AFTER LAB OR A LONG WAY AHEAD
    CONSTINTEGER ASS LEVEL=2****14;         ! ASSEMBLER LEVEL OPERATION
    CONSTINTEGER DONT OPT=2****15;          ! DONT DUPLICATE THIS RESULT
                                            ! USED FOR BYTE PTR & OTHER SODS!
    !
    RECORDFORMAT EMASFHDRF(INTEGER ENDRA,STARTRA,FBYTESIZE,W3,W4,W5,W6,W7)
                                            ! FORMAT FOR ARRAY HEADS
    ! %END %OF  %FILE "ERCC07.TRIMP_TFORM1S"
    !
    ! 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
    EXTRINSIC RECORD (WORKAF) WORKA
    EXTRINSIC RECORD (PARMF) PARM
    EXTERNAL ROUTINE SPEC IMPABORT
          IF HOST#TARGET START
          EXTERNAL ROUTINE SPEC REFORMATC(RECORD (RD) NAME OPND)
          FINISH
    EXTERNAL ROUTINE SPEC MOVE BYTES(INTEGER L,FB,FO,TB,TO)
    EXTERNAL ROUTINE SPEC FAULT(INTEGER N,DATA,IDENT)
    EXTERNAL ROUTINE SPEC PRINT TRIPS(RECORD (TRIPF) ARRAY NAME TRIPLES)
    CONST BYTE INTEGER ARRAY BYTES(0:7)=0(3),1,2,4,8,16;
    CONST BYTE INTEGER ARRAY WORDS(0:7)=0(3),1,1,1,2,4;
    EXTERNAL ROUTINE CTOP(INTEGER NAME FLAG,MASK, INTEGER XTRA, RECORD (RD) NAME OPND1,OPND2)
    !***********************************************************************
    !*    AN OPERATION HAS BEEN FOUND WHERE BOTH OPERANDS ARE              *
    !*    CONSTANTS OR KNOWN AT COMPILE TIME. THIS ROUTINE INTERPRETS      *
    !*    THE OPERATION                                                    *
    !*    ON EXIT FLAG=0 IF INTERPRETED. REFRAINS FROM INTERPRETING        *
    !*    X=1/0 FOR EXAMPLE. CODE IS PLANTED FOR THESE FUNNIES             *
    !***********************************************************************
    ROUTINE SPEC EXTRACT(RECORD (RD) NAME OPND)
    INTEGER FN SPEC DEBYTESWOP(INTEGER VAL)
    CONST INTEGER UTRUNCMASK=X'00000800',BTRUNCMASK=X'00000013'
    INTEGER K,TYPEP,PRECP,OP,MAXD,SVAL,SVAL1,SVAL2,C,D,JJ,KK,TRUNCMASK,LB,UB,MP
    STRING (255) STRVAL,STRVAL1,STRVAL2
    LONG REAL LR
          IF 1<<HOST&LINTAVAIL#0 THEN START
          LONG INTEGER VAL,VAL1,VAL2
          FINISH ELSE START
          INTEGER VAL,VAL1,VAL2
          FINISH
          IF 1<<HOST&LLREALAVAIL#0 THEN START
          LONG LONG REAL RVAL,RVAL1,RVAL2
          FINISH ELSE START
          LONG REAL RVAL,RVAL1,RVAL2
          FINISH
    SWITCH UISW,URSW(10:48),BISW,BRSW(0:47)
          ON EVENT 1,2 START
             RETURN
          FINISH
          TYPEP=OPND1_PTYPE&7; PRECP=OPND1_PTYPE>>4&15; OP=FLAG
          RETURN IF 1<<HOST&LINTAVAIL=0 AND OPND1_PTYPE=X'61'
          RETURN IF 1<<HOST&LLREALAVAIL=0 AND OPND1_PTYPE=X'72'
          if opnd1_ptype&x'8'#0 then return;    ! Foreign constants can not be folded
          EXTRACT(OPND1)
          VAL1=VAL; RVAL1=RVAL; STRVAL1=STRVAL
          SVAL1<-VAL1
          IF OP<128 START;                   ! UNARY
             RETURN UNLESS 10<=OP<=48
             TRUNCMASK=UTRUNCMASK
             IF TYPEP=2 THEN ->URSW(OP) ELSE ->UISW(OP)
          FINISH
          OP=OP-128
          RETURN IF OP>47
          if opnd2_ptype&8#0 then return
          EXTRACT(OPND2)
          VAL2=VAL; RVAL2=RVAL; STRVAL2=STRVAL
          SVAL2<-VAL2
          TRUNCMASK=BTRUNCMASK
          IF TYPEP=2 THEN ->BRSW(OP) ELSE ->BISW(OP)
    UISW(10):                                ! ¬
          VAL1=¬VAL1
    INTEND:
          IF 1<<HOST&LINTAVAIL#0 AND PRECP=6 THEN START
             OPND1_D<-VAL1>>32
             OPND1_XTRA<-VAL1
             FLAG=0
          FINISH ELSE START
             SVAL<-VAL1
             IF SVAL=VAL1 OR 1<<OP&TRUNCMASK=0 THEN FLAG=0 AND OPND1_D=SVAL
                                             ! NO ARITH OFLOW CONDITION
          FINISH
          IF FLAG=0 START
             OPND1_PTYPE=PRECP<<4!1
             OPND1_FLAG=0
          FINISH
          RETURN
    UISW(11):                                ! INTEGER NEGATE
          VAL1=-VAL1; ->INT END
    UISW(13):                                ! INTEGER ABS
          VAL1=IMOD(VAL1); ->INT END
    UISW(12):                                ! INTEGER FLOAT
          RVAL1=VAL1; PRECP=PRECP+1
          ->REAL END
    URSW(15):                                ! STRETCH REAL
          PRECP=PRECP+1
    REAL END:OPND1_FLAG=SCONST
          IF PRECP=5 THEN OPND1_R=RVAL1 ELSE IF PRECP=6 THEN START
             LR=RVAL1;                       ! may be rounding
             MOVE BYTES(8,ADDR(LR),0,ADDR(OPND1_D),0)
          FINISH ELSE START
             OPND1_FLAG=LCONST
             OPND1_D=WORKA_ARTOP
             OPND1_XTRA=INTEGER(ADDR(RVAL1))
             WORKA_ARTOP=WORKA_ARTOP+16
             MOVE BYTES(16,ADDR(RVAL1),0,ADDR(WORKA_A(0)),OPND1_D)
          FINISH
          FLAG=0; OPND1_PTYPE=16*PRECP+2
          RETURN
    UISW(15):                                ! STRETCH INTEGER
          IF 1<<HOST&LINTAVAIL#0 AND PRECP=5 THEN PRECP=6 AND ->INT END
          IF PRECP=4 THEN PRECP=5 AND ->INT END
          RETURN
    UISW(14):                                ! SHORTEN INTEGER
          if precp=4 and 0<=val1<=255 then precp=3 and ->int end
          IF PRECP=5 and IMOD(VAL1)<=X'7FFF' THEN PRECP=4 AND ->INT END
          IF PRECP=6 AND VAL1=SVAL1 THEN PRECP=5 AND ->INT END
          RETURN
    URSW(14):                                ! SHORTEN REAL
          PRECP=PRECP-1
          ->REAL END
    URSW(12):                                ! FLOAT REAL
          IMPABORT
    UISW(16):                                ! SHORTEN FOR <-
          IF PRECP=5 THEN VAL1=VAL1&X'FFFF' AND PRECP=4 AND ->INTEND
          RETURN
    URSW(36):                                ! INT
          RETURN UNLESS MOD(RVAL1)<X'7FFFFFFE'
          VAL1=INT(RVAL1)
          PRECP=5
          ->INTEND
    URSW(37):                                ! INTPT
          RETURN UNLESS MOD(RVAL1)<X'7FFFFFFE'
          VAL1=INTPT(RVAL1)
          PRECP=5
          ->INTEND
    UISW(38):                                ! TOSTRING
          STRVAL1=TOSTRING(VAL1)
          ->STREND
    URSW(48):                                ! TRUNC coded without using itself as it
                                             ! it is not provided in the older compilers
          RETURN UNLESS MOD(RVAL1)<x'7ffffffe'
          IF RVAL>=0 THEN VAL1=INTPT(RVAL1) ELSE VAL1=-INTPT(MOD(RVAL1))
          PRECP=5
          ->INTEND
    BISW(0):                                 ! ADD
    BISW(14):                                ! COMBINE VMY RESULTS
          VAL1=VAL1+VAL2; ->INT END
    BISW(1):                                 ! MINUS
          VAL1=VAL1-VAL2; ->INT END
    BISW(2):                                 ! EXCLUSIVE OR
          VAL1=VAL1!!VAL2; ->INT END
    BISW(3):                                 ! OR
          VAL1=VAL1!VAL2; ->INT END
    BISW(4):                                 ! MULT
          VAL1=VAL1*VAL2; ->INT END
    BISW(6):RETURN;                          ! / DIVISION
    BISW(5):RETURN IF VAL2=0;                ! // DIVISION
          VAL1=VAL1//VAL2; ->INT END
    BISW(7):                                 ! AND
          VAL1=VAL1&VAL2; ->INT END
    BISW(9):                                 ! SLL
          IF PRECP=6 THEN VAL1=VAL1<<SVAL2 ELSE VAL1=SVAL1<<SVAL2
          ->INT END
    BISW(8):                                 ! SRL
          IF PRECP=6 THEN VAL1=VAL1>>SVAL2 ELSE VAL1=SVAL1>>SVAL2
          ->INT END
    BISW(13):                                ! VMY & CHK BOUNDS
          MAXD=XTRA>>24&15;                  ! MAX DIMENSION
          C=XTRA>>28;                        ! DIMENSION
          D=OPND2_D&X'FFFF';                 ! DV POINTER
          IF TARGET=PNX OR TARGET=PERQ OR TARGET=ACCENT OR 1<<TARGET&EMACHINE#0 START
             LB=DEBYTESWOP(WORKA_CTABLE(D+3*C+1))
             UB=DEBYTESWOP(WORKA_CTABLE(D+3*C))
             MP=DEBYTESWOP(WORKA_CTABLE(D+3*C-1))
             IF VAL1<LB OR VAL1>UB THEN FAULT(50,VAL1,XTRA&X'FFFF')
             VAL1=VAL1*MP UNLESS C=1
             ->INT END
          FINISH
          IF TARGET=EMAS START
             C=3*(MAXD+1-C)
             JJ=(VAL1-WORKA_CTABLE(D+C))*WORKA_CTABLE(D+C+1)
             IF JJ<0 OR JJ>WORKA_CTABLE(D+C+2) THEN FAULT(50,VAL1,XTRA&X'FFFF')
             VAL1=JJ
             ->INT END
          FINISH
          IF TARGET=IBM OR TARGET=AMDAHL OR TARGET=IBMXA START
             IF VAL1<WORKA_CTABLE(D+3*C) OR VAL1>WORKA_CTABLE(D+3*C+1) THEN FAULT(50,VAL1,XTRA&X'FFFF')
             VAL1=VAL1*WORKA_CTABLE(D+3*C+2)
             ->INTEND
          FINISH
          RETURN
    BISW(18):                                ! BADJ ADUST ARRAY BASE
          IF TARGET=PERQ OR 1<<TARGET&EMACHINE#0 OR TARGET=ACCENT OR TARGET=PNX START
             D=XTRA>>24&15;                  ! TOTAL NO OF DIMENSIONS
             KK=VAL2;                        ! DV DISP
             RETURN UNLESS KK>0
             JJ=DEBYTESWOP(WORKA_CTABLE(KK));! adjustment
             VAL1=VAL1+JJ
          FINISH
          ->INT END
    BISW(46):
    BISW(47):                                ! scomp & sdcomp
    BRSW(46):
    BRSW(47):                                ! scomp & sdcomp
    BISW(11):
    BISW(12):                                ! COMPARISONS
    BRSW(11):
    BRSW(12):                                ! REAL COMPARISONS
          MASK=XTRA;                         ! XTRA HAS IBM TYPE MASK
                                             ! RETURN MASK AS 15(=JUMP) OR 0 (IGNORE)
          FLAG=0
          IF TYPEP=2 THEN ->RCOMP
          IF TYPEP=5 THEN ->SCOMP
          IF (MASK&8#0 AND VAL1=VAL2) OR (MASK&4#0 AND VAL1<VAL2) OR (MASK&2#0 AND VAL1>VAL2) THEN MASK=15 ELSE C
             MASK=0
          if op=12{dsided} then opnd1=opnd2
          RETURN
    RCOMP:
          IF (MASK&8#0 AND RVAL1=RVAL2) OR (MASK&4#0 AND RVAL1<RVAL2) OR (MASK&2#0 AND RVAL1>RVAL2) THEN C
             MASK=15 ELSE MASK=0
          if op=12{dsided} then opnd1=opnd2
          RETURN
    SCOMP:
          IF (MASK&8#0 AND STRVAL1=STRVAL2) OR (MASK&4#0 AND STRVAL1<STRVAL2) OR (MASK&2#0 AND C
             STRVAL1>STRVAL2) THEN MASK=15 ELSE MASK=0
          if op=47{dsided} then opnd1=opnd2
          RETURN
    URSW(11):                                ! NEGATE
          RVAL1=-RVAL1; ->REAL END
    BRSW(13):                                ! ABS
          RVAL1=MOD(RVAL1); ->REAL END
    BRSW(0):                                 ! ADD
          RVAL1=RVAL1+RVAL2; ->REAL END
    BRSW(1):                                 ! SUBTRACT
          RVAL1=RVAL1-RVAL2; ->REAL END
    BRSW(4):                                 ! MULT
          RVAL1=RVAL1*RVAL2; ->REAL END
    BRSW(6):                                 ! DIVISION
          RETURN IF RVAL2=0;                 ! AVOID DIV BY ZERO
          RVAL1=RVAL1/RVAL2; ->REAL END
    BISW(10):                                ! '**' WITH 2 INTEGER OPERANDS
    BRSW(10):                                ! '**' WITH AT LEAST 1 REAL
          RETURN UNLESS OPND2_PTYPE&7=1 AND-77<=VAL2<=75
    !      RVAL1=RVAL1**VAL2
    !
    ! avoid exponentiation in case a support routine reqd
    !
          RVAL2=1
             rval2=rval2*rval1 for jj=1,1,imod(val2)
          if val2<0 then rval1=1.0/rval2 else rval1=rval2
          ->REALEND
    BISW(17):                                ! '****' WITH 2 INTEGER OPERAND
          RETURN UNLESS 0<=VAL2<=63
          VAL2=1
          WHILE SVAL2>0 CYCLE
             VAL2=VAL2*VAL1
             SVAL2=SVAL2-1
          REPEAT
          VAL1=VAL2; ->INT END
    BISW(24):                                ! CONCAT
          RETURN IF LENGTH(STRVAL1)+LENGTH(STRVAL2)>255
          STRVAL1=STRVAL1.STRVAL2
    STREND:                                  ! RETURN VALUE
          OPND1_PTYPE=X'35'
          OPND1_FLAG=LCONST
          OPND1_XTRA=LENGTH(STRVAL1)
          JJ=WORKA_ARTOP
          WORKA_A(JJ)=OPND1_XTRA
          FOR K=1,1,OPND1_XTRA CYCLE
             WORKA_A(JJ+K)=CHARNO(STRVAL1,K)
          REPEAT
          OPND1_D=JJ
          WORKA_ARTOP=(JJ+OPND1_XTRA+2)&(-2);  ! PERQ KEEP 16 BIT ALIGNED
          FLAG=0
          RETURN
    URSW(*):
    UISW(*):
    BRSW(*):
    BISW(*):
          RETURN
    ROUTINE EXTRACT(RECORD (RD) NAME OPND)
    !***********************************************************************
    !*    EXTRACTS A CONTANT OPERAND RETURNING REAL &INT VALUES           *
    !***********************************************************************
    INTEGER TYPE,PREC,I,AD
          TYPE=OPND_PTYPE; PREC=TYPE>>4
          TYPE=TYPE&15
          VAL=0; RVAL=0; STRVAL=""
          IF TYPE=5 START
             LENGTH(STRVAL)=WORKA_A(OPND_D)
             FOR I=1,1,OPND_XTRA CYCLE
                CHARNO(STRVAL,I)=WORKA_A(OPND_D+I)
             REPEAT
          FINISH ELSE IF TYPE=1 THEN START
             IF 1<<HOST&LINTAVAIL#0 AND PREC=6 THEN VAL=LENGTHENI(OPND_D)<<32!(OPND_XTRA&(LENGTHENI(-1)>>32)) ELSE C
                VAL=OPND_D
             RVAL=VAL
          FINISH ELSE START
             IF PREC=5 THEN RVAL=OPND_R ELSE IF PREC=6 THEN START
                MOVE BYTES(8,ADDR(OPND_D),0,ADDR(LR),0)
                RVAL=LR
             FINISH ELSE MOVE BYTES(16,ADDR(WORKA_A(0)),OPND_D,ADDR(RVAL),0)
          FINISH
    END
    INTEGER FN DEBYTESWOP(INTEGER VAL)
    !***********************************************************************
    !*    ITEMS IN THE THE CONST TABLE MAY BE BYTE SWOPPED. DEBYTESWOP BY  *
    !*    BYTE SWOPPING AGAIN. PDS PRAYS THERE WILL NEVER BE ARCHITECTURE  *
    !*    WHERE THIS IS NOT TRUE!                                          *
    !***********************************************************************
    RECORD (RD) OPND
          OPND=0
          OPND_PTYPE=X'51'
          OPND_D=VAL
          IF HOST#TARGET THEN REFORMATC(OPND)
          RESULT=OPND_D
    END
    END
    EXTERNAL ROUTINE TRIP OPT(RECORD (TRIPF) ARRAY NAME TRIPLES, INTEGER inptr)
    !***********************************************************************
    !*    SCANS A TRIPLES LIST FOR POSSIBLE OPTIMISATIONS                  *
    !***********************************************************************
    INTEGER CHANGES,DUPS,DUPTNO,PTR,I,J,K,VAL,XVAL,CURR,NEXT,OP1,OP2,CTOPOP,REVOP,APTYPE,FOLD AGAIN
    BYTE INTEGER ARRAY NAME A
    RECORD (TRIPF) NAME CURRT,NEWT,NEXTT
    RECORD (RD) NAME OPND1,OPND2,POPND,ROPND
    ROUTINE SPEC SWOP OPERANDS(RECORD (TRIPF) NAME CURRT)
    INTEGER FN SPEC POWEROF2(INTEGER VAL)
    INTEGER FN SPEC PRELOAD PLACE(INTEGER TRIP)
    ROUTINE SPEC INDOPT(RECORD (RD) NAME OPND)
    ROUTINE SPEC VMYOPT(INTEGER CURR)
    INTEGER FN SPEC SAME OPND(RECORD (RD) NAME OPND1,OPND2,integer ASSN)
    ROUTINE SPEC INVERT DIV(RECORD (TRIPF) NAME CURRT)
    ROUTINE SPEC CHECK DUPS(INTEGER STRIPNO,STRIPNO)
    ROUTINE SPEC PROPAGATE CASS(INTEGER STRIPNO, RECORD (RD) NAME N,C)
    ROUTINE SPEC DUPLICATE TRIP(INTEGER TRIPNO,DTRIPNO,FLAGBITS)
    ROUTINE SPEC DEC USE(INTEGER TRIPLE NO)
    ROUTINE SPEC DELETE TRIPLE(INTEGER TRIPLE NO)
          IF TARGET=AMDAHL OR TARGET=IBM OR TARGET=IBMXA START

                                             ! ON IBM VMY OF 0 ALWAYS ZERO
          CONST BYTE INTEGER ARRAY FOLD NOOP INFO(0:199)= 0(128),
                        X'89',X'41',X'89',X'89',X'B6',{+,-,!!,!,*} C
                        2,0,X'A4',1,1,{//,/,&,>>,<<} C
                        2,0,0,32,X'89',{**,COMP,DCOMP,VMY,COMB} C
                        0,0,2,0,0,{=,<-,****,BADJ,INDEX} C
                        0{IFETCH},0(3),
                        X'40'{CONCAT},0(*)
          FINISH ELSE IF TARGET=EMAS START
                                             ! INDEX IS NOT NECESSARILY A NOOP WHEN INDEX IS 0
    !
          CONST BYTE INTEGER ARRAY FOLD NOOP INFO(0:199)= 0(128),
                        X'89',X'41',X'89',X'89',X'B6',{+,-,!!,!,*} C
                        2,0,X'A4',1,1,{//,/,&,>>,<<} C
                        2,0,0,3,X'89',{**,COMP,DCOMP,VMY,COMB} C
                        0,0,2,0,0,{=,<-,****,BADJ,INDEX} C
                        0{IFETCH},0(3),
                        X'40'{CONCAT},0(*)
          FINISH ELSE START
          CONST BYTE INTEGER ARRAY FOLD NOOP INFO(0:199)= 0(128),
                        X'89',X'41',X'89',X'89',X'B6',{+,-,!!,!,*} C
                        2,0,X'A4',1,1,{//,/,&,>>,<<} C
                        2,0,0,3,X'89',{**,COMP,DCOMP,VMY,COMB} C
                        0,0,2,0,1,{=,<-,****,BADJ,INDEX} C
                        0{IFETCH},0(3),
                        X'40'{CONCAT},0(*)
          FINISH

    ! 2**0 SET IF SECOND OPERAND ZERO IS NOOP
    ! 2**1 SET IF SECOND OPERAND 1 IS A NOOP
    ! 2**2 SET IF SECOND OPERAND 0 MEANS RESULT=0
    ! 2**3 SET IF FIRST OPERAND ZERO IS NOOP
    ! 2**4 SET IF FIRST OPERAND 1 IS A NOOP
    ! 2**5 SET IF  FIRST OPERAND ZERO MEANS RESULT=0
    ! 2**6 SET IF FOLDING WITH ITSELF POSSIBLE BUT NOT SIMPE
    ! 2**7 SET FOR NORMAL FOLDING
    !
          A==WORKA_A
          CHANGES=0;                         ! NO CHANGES AS YET
          DUPS=0;                            ! NO DUPLICATES YET
          if parm_dcomp#0 then printstring("Optimising triples ") and print trips(triples)

    !
    ! LOOK FOR REGISTER TO STORE OPERATIONS ON  EMACHINES (xcept VNS and risk)
    !
             PTR=inptr
             WHILE PTR>0 CYCLE
                CURRT==TRIPLES(PTR)
                PTR=CURRT_FLINK
                NEXTT==TRIPLES(PTR)
                EXIT IF PTR=0;               ! THE END
                UNLESS NEXTT_OPERN=VASS AND NEXTT_OPTYPE=X'51'=CURRT_OPTYPE AND (NEXTT_OPND1_FLAG=DNAME OR C
                   NEXTT_OPND1_FLAG=INDNAME or NEXTT_OPND1_FLAG=arname) AND NEXTT_OPND2_FLAG=REFTRIP AND CURRT_PUSE=PTR AND CURRT_CNT=1 THEN C
                   CONTINUE
                CONTINUE UNLESS ADD<=CURRT_OPERN<=ANDL;    ! lshift & rshift also possible on pnx
                IF CURRT_FLAGS&COMMUTABLE#0 AND SAME OPND(CURRT_OPND2,NEXTT_OPND1,NO)=YES THEN C
                   SWOP OPERANDS(CURRT) ELSE START
                   CONTINUE UNLESS SAME OPND(CURRT_OPND1,NEXTT_OPND1,NO)=YES
                FINISH
                NEXTT_X1=CURRT_OPERN
                NEXTT_OPERN=RSTORE
                NEXTT_PUSE=0
                NEXTT_FLAGS<-DONT OPT!CURRT_FLAGS&(¬LOAD OP1);  ! THIS AVOIDS A USELESS PRELOAD
                NEXTT_opnd2=CURRT_opnd2
                triples(NEXTT_BLINK)_opern=NULLT
                changes=changes+1
             REPEAT
          IF CHANGES>0 AND PARM_DCOMP#0 THEN PRINT TRIPS(TRIPLES)
          WORKA_OPTCNT=WORKA_OPTCNT+CHANGES
          RETURN
    INTEGER FN POWEROF2(INTEGER VAL)
    !***********************************************************************
    !*    CHECKS IF VAL IS A POWER OF 2                                    *
    !***********************************************************************
    INTEGER I,J
          FOR I=1,1,30 CYCLE
             J=1<<I
             IF J=VAL THEN RESULT=I
             IF J>VAL THEN RESULT=0
          REPEAT
          RESULT=0
    END
    ROUTINE SWOP OPERANDS(RECORD (TRIPF) NAME CURRT)
    !***********************************************************************
    !*    EXCHANGE OPND1&OPND2 KEEPING THE FLAGS CORRECT                   *
    !***********************************************************************
    RECORD (RD) TOPND
    INTEGER FLAGS,NEWFLAGS
          TOPND=CURRT_OPND1
          CURRT_OPND1=CURRT_OPND2
          CURRT_OPND2=TOPND
          FLAGS=CURRT_FLAGS
          NEWFLAGS=FLAGS&(¬(LOADOP1+LOADOP2))
          IF FLAGS&LOADOP1#0 THEN NEWFLAGS=NEWFLAGS!LOADOP2
          IF FLAGS&LOADOP2#0 THEN NEWFLAGS=NEWFLAGS!LOADOP1
          CURRT_FLAGS=NEWFLAGS
          CHANGES=CHANGES+1
    END
    INTEGER FN PRELOAD PLACE(INTEGER TRIP)
    !***********************************************************************
    !*    LOOK FOR FIRST TRIPLE IN THE CHAIN THAT LEADS TO TRIP            *
    !*    CAN BE VERY COMPILCATED. RETURN -1 IF NOT SIMPLE                 *
    !***********************************************************************
    CONST INTEGER TRIPREFS=X'140';           ! BITMASK OF OPERAND FORMATS
    RECORD (RD) NAME OPND1,OPND2
    RECORD (TRIPF) NAME CURRT
          CURRT==TRIPLES(TRIP)
          OPND1==CURRT_OPND1
          OPND2==CURRT_OPND2
          IF CURRT_OPERN<128 OR 1<<CURRT_OPND2_FLAG&TRIPREFS=0 START
                                             ! BACK VIA OPND1
             IF 1<<CURRT_OPND1_FLAG&TRIPREFS=0 THEN RESULT=TRIP
             RESULT=PRELOAD PLACE(OPND1_D)
          FINISH
          IF 1<<CURRT_OPND1_FLAG&TRIPREFS=0 OR OPND1_D=CURRT_BLINK THEN RESULT=PRELOAD PLACE(OPND2_D)
    !
    ! BOTH OPERANDS ARE LOADED TRIPLES
    !
          IF CURRT_BLINK=OPND2_D THEN RESULT=PRELOADPLACE(OPND1_D)
          RESULT=-1;                         ! TOO COMPLICATED
    END
    ROUTINE INDOPT(RECORD (RD) NAME OPND)
    !***********************************************************************
    !*    OPND IS AN INDIRECT OFFSET. TRY TO SUBSUME PART OF THE EXPRESSION*
    !*    INTO THE OFFSET, REALLY GUNNING FOR IMP REFERENCES TO PAG0 ON IBM*
    !***********************************************************************
    INTEGER COP,X,VAL,OP,LIMIT
    RECORD (TRIPF) NAME RTRIP
    RECORD (RD) NAME COPND
          IF TARGET=IBM OR TARGET=AMDAHL OR TARGET=IBMXA THEN LIMIT=4096 ELSE IF TARGET=EMAS THEN C
             LIMIT=X'7FFFFFFF' ELSE LIMIT=1<<16
          RTRIP==TRIPLES(OPND_D)
          RETURN UNLESS RTRIP_CNT=1 AND RTRIP_FLAGS&CONSTANTOP#0
          OP=RTRIP_OPERN
          RETURN UNLESS OP=ADD OR OP=SUB
          RETURN UNLESS RTRIP_OPTYPE&7=1 AND RTRIP_OPTYPE>>4<6
          IF RTRIP_OPND1_FLAG<=1 THEN START
             COP=1;                          ! CONSTANT IS OP 1
             COPND==RTRIP_OPND1;             ! DEFINED BY COPND
          ELSE
             COP=2;                          ! CONSTANT IS OPERAND 2
             COPND==RTRIP_OPND2
          FINISH
          X=OPND_XTRA;                       ! CURRENT OFFSET
          IF X<0 THEN X=0
          VAL=COPND_D
          IF OP=ADD AND LIMIT>X+VAL>=0 THEN COPND_D=0 AND OPND_XTRA=X+VAL AND RETURN
                                             ! THE ZERO ADD WILL BE ELAIMINATED
          IF OP=SUB AND LIMIT>X-VAL>=0 AND COP=2 THEN COPND_D=0 AND OPND_XTRA=X-VAL
    END
    ROUTINE VMYOPT(INTEGER CURR)
    !***********************************************************************
    !*    ANALYSES A VMY AND REPACES WITH A CONSTANT MULTIPLY IF POSSIBLE  *
    !***********************************************************************
    RECORD (TRIPF) NAME CURRT
    RECORD (RD) NAME OPND2
    INTEGER C,D,VALUE,APTYPE,DV,I,J,DVNAME
          CURRT==TRIPLES(CURR)
          OPND2==CURRT_OPND2
          C=CURRT_X1>>28;                    ! CURRENT DIMENSION
          D=CURRT_X1>>24&15;                 ! MAX DIMENSION
          DV=0
          IF OPND2_FLAG=SCONST THEN DV=OPND2_D;    ! DOPE VECTOR IF CONST
          IF (TARGET=PNX OR TARGET=PERQ OR TARGET=ACCENT) AND C=1 THEN VALUE=1 AND ->TOMULT
          APTYPE=-1;                         ! ARRAY PTYPE
          DVNAME=CURRT_X1&X'FFFF'
          IF DVNAME>0 THEN APTYPE=WORKA_ASLIST(WORKA_TAGS(DVNAME))_PTYPE
          IF TARGET=EMAS START
             IF DV>0 START
                I=3*(D+1-C)
                IF WORKA_CTABLE(DV+I)=0 THEN VALUE=WORKA_CTABLE(DV+I+1) AND ->TOMULT
             FINISH
             IF APTYPE>>8=2 {ARR=2,NAM=0} AND C=1 AND APTYPE&7<=2 AND APTYPE&255#X'41' THEN VALUE=1 AND ->TOMULT
          FINISH
          IF TARGET=IBM OR TARGET=AMDAHL OR TARGET=IBMXA START
             IF C=1=D AND CURRT_OPND1_FLAG=REFTRIP THEN IBMVMY(CURR)
             IF OPND1_FLAG=SCONST AND OPND1_D=0 THEN VALUE=1 AND ->TOMULT
                                             ! ANY VMY OF 0 =0 ON IBMS
             IF DV>0 THEN VALUE=WORKA_CTABLE(DV+3*C+2) AND ->TOMULT
             IF C=1 START
                IF APTYPE&7<=2 THEN VALUE=BYTES(APTYPE>>4&7) AND ->TOMULT
                IF APTYPE&X'0C00'=0 START;    ! NAM=0
                   IF DVNAME>0 THEN VALUE=WORKA_ASLIST(WORKA_TAGS(DVNAME))_ACC AND ->TOMULT
                FINISH
             FINISH
          FINISH
          RETURN
    TOMULT:                                  ! CHANGE VMY TO INTEGER MULT
          CURRT_OPERN=MULT
          CURRT_FLAGS=CURRT_FLAGS!CONSTANT OP
          OPND2_PTYPE=CURRT_OPTYPE;          ! SOME M-CS HAVE 16 BIT OPERATIONS
          OPND2_FLAG=SCONST
          OPND2_D=VALUE
          CHANGES=CHANGES+1
    END
    ROUTINE DEC USE(INTEGER TRIPLE NO)
    !***********************************************************************
    !*    A TRIPLE HAS BEEN PASSED INTO 'DEAD' CODE. DECREMENT ITS USE     *
    !*    AND IF RELEVANT DELETE OPERATIONS LEADING TO IT                  *
    !***********************************************************************
    RECORD (TRIPF) NAME CURRT
          CURRT==TRIPLES(TRIPLE NO)
          IF CURRT_CNT=0 START
             PRINTSTRING("dec use???
    ")
             PRINT TRIPS(TRIPLES)
             MONITOR
          FINISH
          CURRT_CNT<-CURRT_CNT-1
          IF CURRT_CNT=1 THEN DUPS=DUPS-1
          IF CURRT_CNT=0 AND CURRT_OPERN#RSTORE AND CURRT_OPERN#NULLT THEN DELETE TRIPLE(TRIPLE NO)
    END
    ROUTINE DELETE TRIPLE(INTEGER TRIPLE NO)
    RECORD (TRIPF) NAME DELT
          DELT==TRIPLES(TRIPLE NO)
          IF 1<<DELT_OPND1_FLAG&BTREFMASK#0 THEN DEC USE(DELT_OPND1_D)
          IF DELT_OPERN>=128 AND 1<<DELT_OPND2_FLAG&BTREFMASK#0 THEN DEC USE(DELT_OPND2_D)
          DELT_X1=DELT_OPERN;                ! FOR DEBUGGING
          DELT_OPERN=NULLT;                  ! NO OP
          CHANGES=CHANGES+1
          DELT_FLAGS<-DELT_FLAGS!DONT OPT
    END
    ROUTINE DUPLICATE TRIP(INTEGER TRIPNO,DTRIPNO,FLAGBITS)
    !***********************************************************************
    !*    DTRIPNO IS A DUPLICATE OF TRIPNO. CHANGE ALL REFERENCES          *
    !*    AND DELETE IT                                                    *
    !***********************************************************************
    RECORD (RD) NAME OPND1,OPND2
    RECORD (TRIPF) NAME MASTER,CURRT,DUPT
    INTEGER CNT,PTR
          DUPS=DUPS+1
          DUPTNO=TRIPNO
          MASTER==TRIPLES(TRIPNO)
          DUPT==TRIPLES(DTRIPNO)
          MASTER_FLAGS=MASTER_FLAGS!FLAGBITS
          CNT=DUPT_CNT
          PTR=DUPT_FLINK
    !
          WHILE CNT>0 AND PTR>0 CYCLE
             CURRT==TRIPLES(PTR)
             PTR=CURRT_FLINK
             IF CURRT_OPERN=NULLT THEN CONTINUE
             OPND1==CURRT_OPND1
             OPND2==CURRT_OPND2
             IF OPND1_D=DTRIPNO AND 1<<OPND1_FLAG&BTREFMASK#0 START
                MASTER_CNT=MASTER_CNT+1
                OPND1_D=TRIPNO
                CURRT_FLAGS=CURRT_FLAGS!LOAD OP1
                CNT=CNT-1
             FINISH
             IF CURRT_OPERN>=128 AND OPND2_D=DTRIPNO AND 1<<OPND2_FLAG&BTREFMASK#0 START
                MASTER_CNT=MASTER_CNT+1
                OPND2_D=TRIPNO
                CURRT_FLAGS=CURRT_FLAGS!LOAD OP2
                CNT=CNT-1
             FINISH
          REPEAT
          DELETE TRIPLE(DTRIPNO)
    END
    ROUTINE INVERT DIV(RECORD (TRIPF) NAME CURRT)
    !***********************************************************************
    !*    DIVISION BY A REAL CONSTANT HAS BEEN FOUND                       *
    !*    SO INVERT IT AND CHANGE TO MULTIPLY. USE CTOP FOR OPERATIONS     *
    !*    THIS WILL FAIL IF NOT ENOUGH PRECISION ON HOST FOR TARGET        *
    !***********************************************************************
    INTEGER OP,PREC,FLAG,J
    RECORD (RD) WOPND,COPND
    LONG REAL LR
          COPND=CURRT_OPND2;                 ! THE CONST TO BE INVERTED
          PREC=CURRT_OPTYPE>>4;              ! PRECISION
          WOPND_S1=COPND_S1
    !
    ! SET UP WOPND AS REAL ONE IN GIGTH PRECISION
    !
          IF PREC=5 THEN WOPND_R=1.0 ELSE IF PREC=6 THEN START
             LR=1.0
             MOVE BYTES(8,ADDR(LR),0,ADDR(WOPND_D),0)
          FINISH ELSE START
             WOPND_PTYPE=X'61'
             WOPND_D=0
             WOPND_XTRA=1
             OP=IFLOAT
             CTOP(OP,J,0,WOPND,COPND);       ! FLOAT LONG 1 TO REAL
             RETURN IF OP#0;                 ! NO CAN DO
          FINISH
          OP=REAL DIV
          CTOP(OP,J,0,WOPND,COPND)
          RETURN IF OP#0
          CURRT_OPERN=MULT
          CURRT_OPND2=WOPND
    END
    ROUTINE CHECK DUPS(INTEGER TRIPNO,STRIPNO)
    !***********************************************************************
    !*    CHECK STARTING FROM STRIPNO FOR DUPLICATES OF TRIPNO             *
    !*    MAY BE MORE THAN ONE                                             *
    !***********************************************************************
    RECORD (TRIPF) NAME CURRT,DUPT,WORKT
    RECORD (RD) AOPND,DOPND1,DOPND2,WOPND1,WOPND2
    CONST INTEGER LMAX=4
    INTEGER ARRAY LABS(0:LMAX)
    INTEGER OP,NEXT,LPTR,I,J,CTRIPNO,OPERN,F,C11,C12,C21,C22,W12,W22,LABP
          DUPT==TRIPLES(TRIPNO)
          DOPND1=DUPT_OPND1; DOPND2=DUPT_OPND2
          OPERN=DUPT_OPERN
                                             ! COMPARISONS ARE IMPOSSIBLE TO OPTIMISE
                                             ! ON CONDITION CODE MACHINES
                                             ! POSSIBLE BUT DIFFICULT ON TRUE FLAG MCS
          IF OPERN=COMP OR OPERN=DCOMP OR OPERN=SCOMP OR OPERN=SDCMP THEN RETURN
          IF OPERN=PRECC OR OPERN=CONCAT OR OPERN=PRES1 OR OPERN=PRES2 THEN RETURN
          IF OPERN=PRECL OR PASS1<=OPERN<=PASS6 THEN RETURN
          if opern=getptr and dupt_optype=X'61' then return
                                            ! two word pointers are tricky things to store and pickup
          F=DUPT_FLAGS
          LPTR=0; LABP=0
          WHILE STRIPNO>0 CYCLE
             CURRT==TRIPLES(STRIPNO)
             EXIT IF CURRT_FLAGS&ASS LEVEL#0
             OP=CURRT_OPERN
             IF OP=FJUMP AND LPTR<=LMAX START
                J=CURRT_OPND1_D
                I=J&X'FFFF';                 ! THE LAB NO
                IF J<0 AND I>WORKA_NNAMES THEN LABS(LPTR)=I AND LPTR=LPTR+1
             FINISH
             IF OP=TLAB START
                LABP=USED LATE;              ! FLAG OPERAND IF DUPLICATE FOUND
                J=CURRT_OPND1_D&X'FFFF';     ! THE LAB NO
                FOR I=0,1,LPTR-1 CYCLE
                   ->JSEEN IF J=LABS(I)
                REPEAT
                EXIT;                        ! CAN NOT NORMALLY PASS LABES
    JSEEN:                                   ! THE FIRST JUMP TO THIS LAB HAS
                                             ! BEEN PASSED. THERE ARE NO BACK JUMPS
                                             ! TO INTERNAL LABELS FIRST REFERENCED
                                             ! VIA A FORWARD JUMP
             FINISH
             EXIT IF OP=RTXIT OR OP=RCALL
             EXIT IF OP=SETSW OR OP=AHASS OR OP=PTRAS OR OP=LASS
             IF OP=VASS OR OP=VJASS or strass1<=op<=strjt OR OP=DMASS OR OP=RSTORE START;        ! ASSIGNMENT
                AOPND=CURRT_OPND1;           ! DEST OF ASSIGNMENT
                IF AOPND_FLAG=INDIRECT AND (DOPND1_FLAG=INDIRECT OR DOPND2_FLAG=INDIRECT) START
                                             ! MAPPED ARRAYS MAKE AY ARRAY OR MAP ASSIGNMENT
                                             ! DIFFICULT TO CHECK OUT. ONLY SAFE CASE
                                             ! IS TO DIFFERENT ARRAYS BUT NOT
                                             ! IF EITHER ARE ARRAYNAMES
                   EXIT
                FINISH ELSE START
                   EXIT IF SAME OPND(AOPND,DOPND1,yes)=YES
                   EXIT IF OPERN>=128 AND SAME OPND(AOPND,DOPND2,yes)=YES
                FINISH
             FINISH
             if op=getad or op=getptr Start
                aopnd=currt_opnd1
                if same opnd(aopnd,dopnd1,yes)=yes then exit
                if opern>=128 and same opnd(aopnd,dopnd2,yes)=yes then exit
             finish
             CTRIPNO=STRIPNO
             STRIPNO=CURRT_FLINK
             IF OP=OPERN AND (OP#VMY OR DUPT_X1=CURRT_X1) START
                C11=SAME OPND(DOPND1,CURRT_OPND1,NO)
                IF OPERN<128 START
                   IF C11=YES THEN DUPLICATE TRIP(TRIPNO,CTRIPNO,LABP)
                   CONTINUE
                FINISH
                                             ! NOW BINARY ONES
                C22=SAME OPND(DOPND2,CURRT_OPND2,NO)
                C12=NO; C21=NO
                IF F&COMMUTABLE#0 START
                   C12=SAME OPND(DOPND1,CURRT_OPND2,NO)
                   C21=SAME OPND(DOPND2,CURRT_OPND1,NO)
                FINISH
                IF C11=YES=C22 OR C21=YES=C12 START
                   DUPLICATE TRIP(TRIPNO,CTRIPNO,LABP)
                   CONTINUE
                FINISH
    !
    ! now check for distributed common expressions ie (a+b) %AND (a+x+b). The latter
    ! is changes to (a+b+x) and the common element eliminated
    !
                IF C12!C11!C22!C21=YES START
                   WORKT==TRIPLES(CURRT_PUSE)
                   WOPND1=WORKT_OPND1; WOPND2=WORKT_OPND2
                   IF OP=WORKT_OPERN AND WORKT_CNT=1 AND F&COMMUTABLE#0 START
                      W22=SAME OPND(DOPND2,WOPND2,NO)
                      W12=SAME OPND(DOPND1,WOPND2,NO)
                      IF C12=YES=W22 OR C22=YES=W12 OR C21=YES=W12 OR C11=YES=W22 START
                         IF C12=YES OR C22=YES START
                            WORKT_OPND2=CURRT_OPND1
                            CURRT_OPND1=WOPND2
                         FINISH ELSE START
                            WORKT_OPND2=CURRT_OPND2
                            CURRT_OPND2=WOPND2
                         FINISH
                         DUPLICATE TRIP(TRIPNO,CTRIPNO,LABP)
                         CONTINUE
                      FINISH
                   FINISH
                FINISH
             FINISH
          REPEAT
    END
    ROUTINE PROPAGATE CASS(INTEGER STRIPNO, RECORD (RD) NAME NOPND,COPND)
    !***********************************************************************
    !*    CHECK STARTING FROM STRIPNO FOR DUPLICATES OF TRIPNO             *
    !*    MAY BE MORE THAN ONE                                             *
    !***********************************************************************
    RECORD (TRIPF) NAME CURRT
    RECORD (RD) AOPND
    CONST INTEGER LMAX=4
    INTEGER ARRAY LABS(0:LMAX)
    INTEGER OP,NEXT,LPTR,I,J,CTRIPNO,LABP
          LPTR=0;
          WHILE STRIPNO>0 CYCLE
             CURRT==TRIPLES(STRIPNO)
             EXIT IF CURRT_FLAGS&ASS LEVEL#0
             OP=CURRT_OPERN
             IF OP=FJUMP AND LPTR<=LMAX START
                J=CURRT_OPND1_D
                I=J&X'FFFF';                 ! THE LAB NO
                IF J<0 AND I>WORKA_NNAMES THEN LABS(LPTR)=I AND LPTR=LPTR+1
             FINISH
             IF OP=TLAB START
                J=CURRT_OPND1_D&X'FFFF';     ! THE LAB NO
                FOR I=0,1,LPTR-1 CYCLE
                   ->JSEEN IF J=LABS(I)
                REPEAT
                EXIT;                        ! CAN NOT NORMALLY PASS LABES
    JSEEN:                                   ! THE FIRST JUMP TO THIS LAB HAS
                                             ! BEEN PASSED. THERE ARE NO BACK JUMPS
                                             ! TO INTERNAL LABELS FIRST REFERENCED
                                             ! VIA A FORWARD JUMP
             FINISH
             EXIT IF OP=RTXIT OR OP=RCALL
             EXIT IF OP=SETSW OR OP=PTRAS
             IF OP=VASS OR OP=STRASS2 OR OP=VJASS OR OP=DMASS OR OP=RSTORE OR OP=GETAD OR OP=GETPTR START
                                             ! ASSIGNMENT
                AOPND=CURRT_OPND1;           ! DEST OF ASSIGNMENT
                EXIT IF SAME OPND(AOPND,NOPND,yes)=YES
             FINISH
             IF SAME OPND(CURRT_OPND1,NOPND,NO)=YES START
                CHANGES=CHANGES+1
                IF OP<128 OR CURRT_FLAGS&CONSTANTOP#0 THEN FOLD AGAIN=YES
                CURRT_FLAGS=CURRT_FLAGS!CONSTANTOP
                CURRT_OPND1=COPND
             FINISH
             IF OP>=128 AND SAME OPND(CURRT_OPND2,NOPND,NO)=YES START
                CHANGES=CHANGES+1
                IF CURRT_FLAGS&CONSTANTOP#0 THEN FOLD AGAIN=YES
                CURRT_FLAGS=CURRT_FLAGS!CONSTANTOP
                CURRT_OPND2=COPND
             FINISH
             STRIPNO=CURRT_FLINK
          REPEAT
    END
    INTEGER FN SAME OPND(RECORD (RD) NAME OPND1,OPND2,integer ASSN)
    !***********************************************************************
    !*    ARE THESE OPERANDS THE SAME ?                                    *
    !*    If assn=yes then allow for possible overlapping assignments      *
    !*    in variant records                                               *
    !***********************************************************************
    INTEGER F,I,B1,B2
    !   printstring(" same opnd"); write(opnd1_flag,2); write(opnd2_flag,2); newline
          F=OPND1_FLAG
          if f=3 start     { ar pointer }
             result=no unless f=opnd2_flag
             b1=opnd1_d; b2=opnd2_d
             if a(b1)=a(b2) and a(b1+1)=a(b2+1) and a(b1+2)=2 and a(b2+2)=2 c
                and a(b1+3)=2 and a(b2+3)=2 then result=yes
             result=no
          finish
          IF F=2 OR F=5 START
               result=no unless f=opnd2_flag
             RESULT=NO UNLESS OPND1_D=OPND2_D AND OPND1_PTYPE&X'3000'=0
             IF ASSN=NO AND OPND1_PTYPE#OPND2_PTYPE THEN RESULT=NO
             IF OPND1_XTRA=OPND2_XTRA THEN RESULT=YES
             B1=BYTES(OPND1_PTYPE>>4&15)
             B2=BYTES(OPND2_PTYPE>>4&15)
             i=IMOD(OPND1_XTRA&X'FFFF'-OPND2_XTRA&X'FFFF')
             IF ASSN=YES AND (i<=B1 or i<=B2) THEN RESULT=YES
             RESULT=NO
          FINISH
          RESULT=NO UNLESS OPND1_S1&X'FFFF00FF'=OPND2_S1&X'FFFF00FF'
          IF F<=1 START;                     ! CONSTANTS
             IF OPND1_PTYPE=X'35' START
                RESULT=NO UNLESS OPND1_XTRA=OPND2_XTRA
                FOR I=1,1,OPND1_XTRA CYCLE
                   RESULT=NO UNLESS A(OPND1_D+I)=A(OPND2_D+I)
                REPEAT
                RESULT=YES
             FINISH
             RESULT=YES IF OPND1_D=OPND2_D AND (OPND1_XTRA=OPND2_XTRA OR OPND1_PTYPE&X'F0'<=X'50')
             RESULT=NO
          FINISH
          RESULT=YES IF OPND1_D=OPND2_D AND OPND1_XTRA=OPND2_XTRA
          RESULT=NO
    END
    END
    END OF FILE