%INCLUDE "ERCC07.TRIMP_TFORM1S"
%INCLUDE "ERCC07.TRIPCNSTS"
%EXTRINSICRECORD (WORKAF) WORKA
%EXTRINSICRECORD (PARMF) PARM
%EXTERNALROUTINESPEC IMPABORT
%IF HOST#TARGET %START
      %EXTERNALROUTINESPEC REFORMATC(%RECORD(RD)%NAME OPND)
%FINISH
%EXTERNALROUTINESPEC MOVE BYTES(%INTEGER L,FB,FO,TB,TO)
%EXTERNALROUTINESPEC FAULT(%INTEGER N,DATA,IDENT)
%EXTERNALROUTINESPEC PRINT TRIPS(%RECORD (TRIPF) %ARRAYNAME TRIPLES)
%CONSTBYTEINTEGERARRAY WORDS(0:7)=0(3),1,1,1,2,4;
%EXTERNALROUTINE CTOP(%INTEGERNAME 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             *
!***********************************************************************
%ROUTINESPEC EXTRACT(%RECORD (RD) %NAME OPND)
%INTEGERFNSPEC DEBYTESWOP(%INTEGER VAL)
%CONSTINTEGER 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
      %IF 1<<HOST&LINTAVAIL#0 %THENSTART
      %LONGINTEGER VAL,VAL1,VAL2
      %FINISHELSESTART
      %INTEGER VAL,VAL1,VAL2
      %FINISH
      %IF 1<<HOST&LLREALAVAIL#0 %THENSTART
      %LONGLONGREAL RVAL,RVAL1,RVAL2
      %FINISHELSESTART
      %LONGREAL RVAL,RVAL1,RVAL2
      %FINISH
%SWITCH UISW,URSW(10:40),BISW,BRSW(0:24)
      %ONEVENT 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'
      EXTRACT(OPND1)
      VAL1=VAL; RVAL1=RVAL; STRVAL1=STRVAL
      SVAL1<-VAL1
      %IF OP<128 %START;                ! UNARY
         %RETURNUNLESS 10<=OP<=40
         TRUNCMASK=UTRUNCMASK
         %IF TYPEP=2 %THEN ->URSW(OP) %ELSE ->UISW(OP)
      %FINISH
      OP=OP-128
      %RETURNIF OP>24
      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 %THENSTART
         OPND1_D<-VAL1>>32
         OPND1_XTRA<-VAL1
         FLAG=0
      %FINISHELSESTART
         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 %ELSEIF PRECP=6 %THEN %C
         OPND1_LR=RVAL1 %ELSESTART
         OPND1_FLAG=LCONST
         OPND1_D=WORKA_ARTOP
         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 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
      %RETURNUNLESS MOD(RVAL1)<X'7FFFFFFE'
      VAL1=INT(RVAL1)
      PRECP=5
      ->INTEND
URSW(37):                               ! INTPT
      %RETURNUNLESS MOD(RVAL1)<X'7FFFFFFE'
      VAL1=INTPT(RVAL1)
      PRECP=5
      ->INTEND
UISW(38):                               ! TOSTRING
      STRVAL1=TOSTRING(VAL1)
      ->STREND
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):%RETURNIF 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=OPND2_D>>16&31;                 ! MAX DIMENSION
      C=OPND2_D>>24;                       ! DIMENSION
      D=OPND2_D&X'FFFF';                   ! DV POINTER
      %RETURNUNLESS D>0;                ! UNLESS DV AVAILABLE
      %IF TARGET=PNX %OR TARGET=PERQ %OR TARGET=ACCENT %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=IBMXA %START
         %IF VAL1<WORKA_CTABLE(D+3*C) %OR VAL1>WORKA_CTABLE(D+3*C+1) %C
            %THEN FAULT(50,VAL1,XTRA&X'FFFF')
            VAL1=VAL1*WORKA_CTABLE(D+3*C+2)
         ->INTEND
      %FINISH
      %RETURN
BISW(18):                               ! ARRAY SCALE
      %IF TARGET=PERQ %OR TARGET=ACCENT %OR TARGET=PNX %START
         D=VAL2>>16&31;                 ! TOTAL NO OF DIMENSIONS
         KK=VAL2&X'FFFF';               ! DV DISP
         %RETURNUNLESS KK>0
         JJ=WORKA_CTABLE(KK+4);         ! LB(1)
         JJ=DEBYTESWOP(JJ)
         C=6
         %WHILE C<=3*D %CYCLE
            MP=DEBYTESWOP(WORKA_CTABLE(KK+C-1))
            JJ=JJ+MP*DEBYTESWOP(WORKA_CTABLE(KK+C+1))
            C=C+3
         %REPEAT
         VAL1=VAL1-JJ
      %FINISH
      ->INT END
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 (MASK&8#0 %AND VAL1=VAL2) %OR (MASK&4#0 %AND VAL1<VAL2) %OR %C
         (MASK&2#0 %AND VAL1>VAL2) %THEN MASK=15 %ELSE MASK=0
      %RETURN
RCOMP:
      %IF (MASK&8#0 %AND RVAL1=RVAL2) %OR (MASK&4#0 %AND RVAL1<RVAL2) %OR %C
         (MASK&2#0 %AND RVAL1>RVAL2) %THEN MASK=15 %ELSE MASK=0
      %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
      %RETURNIF RVAL2=0;                ! AVOID DIV BY ZERO
      RVAL1=RVAL1/RVAL2; ->REAL END
BISW(10):                               ! '**' WITH 2 INTEGER OPERANDS
BRSW(10):                               ! '**' WITH AT LEAST 1 REAL
      %RETURNUNLESS OPND2_PTYPE&7=1 %AND-63<=VAL2<=63
      RVAL1=RVAL1**VAL2
      ->REALEND
BISW(17):                               ! '****' WITH 2 INTEGER OPERAND
      %RETURNUNLESS 0<=VAL2<=63
      VAL2=1
      %WHILE SVAL2>0 %CYCLE
         VAL2=VAL2*VAL1
         SVAL2=SVAL2-1
      %REPEAT
      VAL1=VAL2; ->INT END
BISW(24):                               ! CONCAT
      %RETURNIF 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
      %FINISHELSEIF TYPE=1 %THENSTART
         %IF 1<<HOST&LINTAVAIL#0 %AND PREC=6 %THEN %C
            VAL=LENGTHENI(OPND_D)<<32!(OPND_XTRA&(LENGTHENI(-1)>>32)) %C
            %ELSE VAL=OPND_D
         RVAL=VAL
      %FINISHELSESTART
         %IF PREC=5 %THEN RVAL=OPND_R %ELSE %C
            %IF PREC=6 %THEN RVAL=OPND_LR %ELSE %C
            MOVE BYTES(16,ADDR(WORKA_A(0)),OPND_D,ADDR(RVAL),0)
      %FINISH
%END
%INTEGERFN 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
%EXTERNALROUTINE FLAG AND FOLD(%RECORD (TRIPF) %ARRAYNAME TRIPLES)
!***********************************************************************
!*    WORKS DOWN AN ARRAY OF TRIPLES SETTING BITS FOR CODE GENERATOR   *
!*    ALSO FOLDS OUT ANY REMAINING CONSTANT OPERATIONS                 *
!***********************************************************************
%INTEGER STPTR,CURRTRIPNO,I,J,DEPTH,COP
%CONSTINTEGER FOLDI=X'1C00007F';        ! FOLD 10-16 & 36-38
%CONSTINTEGER FOLDR=X'0107FFFF';        ! FOLD 128-146 &152
%RECORD (TRIPF) %NAME CURRT,REFT
%ROUTINESPEC BACKTRACK(%RECORD(TRIPF)%NAME CURRT)
%ROUTINESPEC INSPECT OPND(%INTEGER NO)
%ROUTINESPEC REPLACE TRIPREF(%INTEGER TRIP, %RECORD (RD) %NAME OPND)
      STPTR=TRIPLES(0)_FLINK
      DEPTH=0
!
      %WHILE STPTR>0 %CYCLE
         CURRT==TRIPLES(STPTR)
         CURRTRIPNO=STPTR
         STPTR=CURRT_FLINK
         COP=CURRT_OPERN;               ! CURRENT OPERATION
         INSPECT OPND(1)
         %IF COP>=128 %THEN INSPECT OPND(2)
!
         %IF CURRT_FLAGS&CONSTANTOP#0 %AND ((COP<128 %AND %C
            FOLDI&1<<(COP-10)#0) %OR (CURRT_OPND1_FLAG<=1 %AND %C
            CURRT_OPND2_FLAG<=1 %AND FOLDR&1<<(COP&31)#0)) %START
            I=COP
            CTOP(I,J,CURRT_X1,CURRT_OPND1,CURRT_OPND2)
            %IF I=0 %THENSTART
               CURRT_X1=COP;    ! FOR DEBUGGING OPTIMISATIONS
               CURRT_OPERN=NULLT
               REPLACE TRIPREF(CURR TRIPNO,CURRT_OPND1)
            %FINISH
         %FINISH
         %IF COP=LASS %AND CURRT_FLAGS&CONSTANTOP#0 %AND %C
            CURRT_CNT>0 %THEN REPLACE TRIPREF(CURRTRIPNO,CURRT_OPND2)
         %IF TARGET=PNX %OR TARGET=PERQ %OR TARGET=ACCENT %START
            CURRT_DPTH<-DEPTH
            %IF CURRT_CNT>0 %AND %C
               (TARGET=PERQ %OR TARGET=ACCENT %OR CURRT_OPTYPE&7=1) %THEN %C
               DEPTH=DEPTH+WORDS(CURRT_OPTYPE>>4)
         %FINISH
         %IF TARGET=EMAS %START;        ! DO SOME CRUDE REGISTER ALLOCATION
            CURRT_DPTH=0;               ! USE ACCR
            %IF COP=VMY %OR COP=COMB %OR COP=BADJ %C
               %OR COP=FORPRE %OR COP=FORPR2 %OR COP=FOREND %C
               %THEN CURRT_DPTH=7;      ! USE BREG
            %IF CURRT_OPTYPE=X'35' %AND COP=PRELOAD %THEN %C
               CURRT_DPTH=1;            ! USE DR
            %IF COP=VMY %THEN BACK TRACK(CURRT)
         %FINISH
      %REPEAT
      %RETURN
%ROUTINE BACKTRACK(%RECORD(TRIPF)%NAME CURRT)
!***********************************************************************
!*    TRIES TO GET ALL OPERANDS OF A VMY EVALUATED IN B                *
!***********************************************************************
%INTEGER I
%RECORD(RD)%NAME OPND
%RECORD(TRIPF)%NAME REFT
      %IF TARGET=EMAS %START;           ! EMAS ONLY OPTIMISATION
         %FOR I=1,1,2 %CYCLE
            %IF I=1 %THEN OPND==CURRT_OPND1 %ELSE OPND==CURRT_OPND2
            %IF OPND_FLAG=REFTRIP %AND(CURRT_OPERN#SUB %OR I=1) %START
               REFT==TRIPLES(OPND_D)
               %IF REFT_OPERN=ADD %OR REFT_OPERN=MULT %OR %C
                  REFT_OPERN=SUB %THEN %START
                  REFT_DPTH=7
                  BACK TRACK(REFT)
               %FINISH
            %FINISH
            %EXIT %IF CURRT_OPERN<128
         %REPEAT
      %FINISH
%END
%ROUTINE INSPECT OPND(%INTEGER NO)
%RECORD (TRIPF) %NAME RTRIP
%RECORD (RD) %NAME OPND
%CONSTBYTEINTEGERARRAY LOAD ALLOW(0:199)=LOAD OP1(128){UNARY},
                                        LOADOP1!LOADOP2(10),
                                        LOADOP1{**},
                                        LOADOP1!LOADOP2(2),
                                        LOADOP1{VMY},
                                        LOADOP1!LOADOP2,
                                        LOADOP2(2){ASS AND JAM ASS},
                                        LOADOP1{****},
                                        LOADOP1{SCALE},
                                        LOADOP1!LOADOP2,
                                        LOADOP2{INDEXED FETCH},
                                        LOADOP2{LASS},
                                        LOADOP1!LOADOP2(3),
                                        LOADOP2{IOCP DONT LOAD EPNO},
                                        LOADOP2(6){P PASSING},
                                        0(6){LABELS AND SWITCH DECLS},
                                        LOADOP2{GOTO SW LOAD OPERAND},
                                        LOADOP2(7){STR,PTR&RESULT ASSMNT},
                                        LOADOP1!LOADOP2(2){STR COMP&DCOMP},
                                        LOADOP2(2){PRE RES DONT LD WKAREA},
                                        LOADOP1{RESLN DONT LOAD LABEL},
                                        LOADOP2{RES FINALE DONT LOAD WKAREA},
                                        LOADOP1!LOADOP2{SIG EVNT UNUSED},
                                        LOADOP2{REC ASSNMNT},
                                        LOADOP1!LOADOP2(*)

%INTEGER I,LOADOP,OPERN
      OPND==CURRT_OPND1
      LOADOP=LOAD OP1
      %IF NO=2 %THEN OPND==CURRT_OPND2 %AND LOADOP=LOAD OP2
      LOADOP=LOADOP&LOAD ALLOW(CURRT_OPERN)
      %IF OPND_FLAG<=1 %THEN CURRT_FLAGS=CURRT_FLAGS!CONSTANTOP
      %IF OPND_FLAG<8 %THEN CURRT_FLAGS=CURRT_FLAGS!LOADOP
      %IF 1<<OPND_FLAG&BTREFMASK#0 %START
         RTRIP==TRIPLES(OPND_D)
         OPERN=RTRIP_OPERN
         %IF RTRIP_PUSE#CURRTRIPNO %OR OPERN=PRECC %OR %C
            (OPERN=LASS %AND RTRIP_FLINK#CURRTRIPNO) %OR %C
            OPERN=CONCAT %OR OPERN=ITOS1 %THEN %C
            CURRT_FLAGS=CURRT_FLAGS!LOADOP
         %IF TARGET=PNX %AND RTRIP_PUSE=CURRTRIPNO %AND RTRIP_OPTYPE&7=1 %THEN %C
            DEPTH=DEPTH-WORDS(RTRIP_OPTYPE>>4)
         %IF (TARGET=PERQ %OR TARGET=ACCENT) %AND RTRIP_PUSE=CURRTRIPNO %C
            %THEN DEPTH=DEPTH-WORDS(RTRIP_OPTYPE>>4)
         %IF TARGET=EMAS %AND OPND_FLAG=INDIRECT %AND RTRIP_DPTH=0 %THEN %C
            RTRIP_DPTH=7;               ! USE BREG FOR EXPRESSION
      %FINISH
%END
%ROUTINE REPLACE TRIPREF(%INTEGER TRIP, %RECORD (RD) %NAME OPND)
%INTEGER PTR,COUNT
%RECORD (TRIPF) %NAME RTRIP
      PTR=STPTR
      COUNT=TRIPLES(TRIP)_CNT
      TRIPLES(TRIP)_CNT=0
      %WHILE COUNT>0 %AND PTR>0 %CYCLE
         RTRIP==TRIPLES(PTR)
         PTR=RTRIP_FLINK
         %IF RTRIP_OPND1_FLAG=REFTRIP %AND RTRIP_OPND1_D=TRIP %START
            RTRIP_OPND1=OPND
            COUNT=COUNT-1
         %FINISH
         %IF RTRIP_OPERN>=128 %AND RTRIP_OPND2_FLAG=REFTRIP %AND %C
            RTRIP_OPND2_D=TRIP %START
            RTRIP_OPND2=OPND
            COUNT=COUNT-1
         %FINISH
      %REPEAT
%END
%END
%EXTERNALROUTINE TRIP OPT(%RECORD (TRIPF) %ARRAYNAME TRIPLES,
    %INTEGERNAME NEXT TRIP)
!***********************************************************************
!*    SCANS A TRIPLES LIST FOR POSSIBLE OPTIMISATIONS                  *
!***********************************************************************
%INTEGER CHANGES,DUPS,DUPTNO,PTR,I,J,K,VAL,XVAL,CURR,NEXT,OP1,OP2,
         CTOPOP,REVOP,APTYPE
%BYTEINTEGERARRAYNAME A
%RECORD (TRIPF) %NAME CURRT,NEWT,NEXTT
%RECORD (RD) %NAME OPND1,OPND2,POPND
%ROUTINESPEC SWOP OPERANDS(%RECORD (TRIPF) %NAME CURRT)
%INTEGERFNSPEC POWEROF2(%INTEGER VAL)
%INTEGERFNSPEC PRELOAD PLACE(%INTEGER TRIP)
%ROUTINESPEC NOOP(%INTEGER TRIPLE, %RECORD (RD) %NAME ROPND)

%INTEGERFNSPEC SAME OPND(%RECORD (RD) %NAME OPND1,OPND2)
%ROUTINESPEC CHECK DUPS(%INTEGER STRIPNO,STRIPNO)
%ROUTINESPEC DUPLICATE TRIP(%INTEGER TRIPNO,DTRIPNO)
%ROUTINESPEC DEC USE(%INTEGER TRIPLE NO)
%ROUTINESPEC DELETE TRIPLE(%INTEGER TRIPLE NO)
%CONSTBYTEINTEGERARRAY 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,{=,<-,****,SCALE,INDEX} %C
                    0{IFETCH},0(3),
                    X'40'{CONCAT},0(*)

! 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
!
      CHANGES=0;                        ! NO CHANGES AS YET
      DUPS=0;                           ! NO DUPLICATES YET

      FLAG AND FOLD(TRIPLES)
      A==WORKA_A
!
! ADVANCED FOLDING FACTOR CONSTANTS OUT OF 2 OR MORE TRIPLES
! TO SAVE AN OPERATION. ONLY MORE USUSAL CASE CATERED FOR AS IN
! VAR+CONST+CONST.
!
      PTR=TRIPLES(0)_FLINK
      %WHILE PTR>0 %CYCLE
         CURRT==TRIPLES(PTR)
         NEXT=CURRT_FLINK
         %EXITIF NEXT<=0
         NEXTT==TRIPLES(NEXT)
         %WHILE NEXTT_OPERN=NULLT %AND NEXTT_FLINK>0 %CYCLE
            NEXT=NEXTT_FLINK;           ! SKIP OVER ANY NOOPS
            NEXTT==TRIPLES(NEXT)
         %REPEAT
         %UNLESS CURRT_CNT=1 %AND NEXTT_CNT=1 %AND %C
            CURRT_FLAGS&NEXTT_FLAGS&CONSTANTOP#0 %AND CURRT_PUSE=NEXT %THEN %C
            PTR=NEXT %ANDCONTINUE
         PTR=NEXT %ANDCONTINUEUNLESS (CURRT_FLAGS!NEXTT_FLAGS)&DONT OPT=0
         J=CURRT_OPERN
         K=NEXTT_OPERN
         %UNLESS FOLD NOOP INFO(J)>>6#0 %AND FOLD NOOP INFO(K)>>6#0 %THEN %C
            PTR=NEXT %ANDCONTINUE
         %IF CURRT_OPND1_FLAG<=1 %THEN OP1=1 %AND OPND1==CURRT_OPND1 %ELSE %C
            OP1=2 %AND OPND1==CURRT_OPND2
         %IF NEXTT_OPND1_FLAG<=1 %THEN OP2=1 %AND OPND2==NEXTT_OPND1 %ELSE %C
            OP2=2 %AND OPND2==NEXTT_OPND2
         CTOPOP=0; REVOP=0
         %IF J=K %AND FOLD NOOP INFO(J)&X'80'#0 %THEN CTOPOP=J
         %IF J=K=SUB %START
            %IF OP2=2 %START
               %IF OP1=2 %THEN CTOPOP=ADD %ELSE CTOPOP=SUB
            %FINISHELSESTART;           ! OP2=1 CASE
               %IF OP1=1 %THEN CTOPOP=SUB %AND REVOP=ADD %ELSE CTOPOP=ADD
            %FINISH
         %FINISH
         %IF J=ADD %AND K=SUB %AND OP2=2 %THEN CTOPOP=SUB
         %IF J=SUB %AND K=ADD %THENSTART
            %IF OP1=1 %THEN CTOPOP=ADD %ELSE CTOPOP=SUB
         %FINISH
         %IF J=K=CONCAT %AND OP1=OP2=2 %THEN CTOPOP=CONCAT
         %IF CTOPOP#0 %START
            CTOP(CTOPOP,K,0,OPND1,OPND2)
            %IF CTOPOP=0 %THENSTART
               %IF OP2=2 %THEN OPND2==NEXTT_OPND1 %ELSE OPND2==NEXTT_OPND2
               NOOP(NEXT,OPND2)
               %IF REVOP#0 %THEN CURRT_OPERN=REVOP
               %CONTINUE
            %FINISH
         %FINISH
         PTR=NEXT
      %REPEAT
!      %IF CHANGES>0 %THEN PRINT TRIPS(TRIPLES)
!
! FIRST REAL OPTIMISATION IS TO SEARCH FOR AND REMOVE NOPS
! LIKE *1 OR <<0 OR +0 ETC. THESE ARE SURPRISINGLY COMMON
! IN PROGRAMS MADE MACHINE INDEPENDENT BY LIBERAL USE
! OF CONSTANT VARIABLES
!
! ALSO DOES A FEW REARRANGEMENTS OF SIMPLE COMPARISONS AND ARITHMETICS
!
      PTR=TRIPLES(0)_FLINK
      %WHILE PTR>0 %CYCLE
         CURRT==TRIPLES(PTR);           ! EXAMINE EACH TRIPLE
         CURR=PTR
         PTR=CURRT_FLINK
         %CONTINUEIF CURRT_FLAGS&DONT OPT#0
         I=CURRT_OPERN
         %IF (TARGET=EMAS %OR TARGET=IBMXA) %AND I=MULT %C
            %AND CURRT_CNT=1 %START
            NEXTT==TRIPLES(CURRT_PUSE)
            %IF NEXTT_OPERN=LNGTHN %START
               CURRT_OPTYPE=CURRT_OPTYPE+X'10'
               NEXTT_OPND1_PTYPE=NEXTT_OPND1_PTYPE+X'10'
               I=MULTX
               CURRT_OPERN=MULTX
               NOOP(CURRT_PUSE,NEXTT_OPND1)
            %FINISH
         %FINISH
         %CONTINUE %IF CURRT_FLAGS&CONSTANTOP=0
         OPND1==CURRT_OPND1
         OPND2==CURRT_OPND2
         %IF OPND1_FLAG<=1 %THEN %C
            OP1=1 %AND VAL=OPND1_D %AND XVAL=OPND1_XTRA %ELSE %C
            OP1=2 %AND VAL=OPND2_D %AND XVAL=OPND2_XTRA
         %IF I=DCOMP %AND OP1=2 %START; ! EXPAND I=0=J ETC
            I=COMP; CURRT_OPERN=COMP
            NEXTT==TRIPLES(CURRT_PUSE)
            NEXTT_OPND1=OPND2
            NEXTT_FLAGS=NEXTT_FLAGS!LOADOP1
         %FINISH
         %IF I=COMP %START
            J=CURRT_X1&15;              ! IBM COND MASK
            NEXTT==TRIPLES(CURRT_FLINK)
            %IF CURRT_OPTYPE&7=1 %START; ! TRANSFORM I>=1 TO I>0 ETC
               %IF (OP1=2 %AND ((VAL=1 %AND (J=4 %OR J=10)) %OR (VAL=-1 %AND %C
                  (J=2 %OR J=12)))) %OR (OP1=1 %AND ((VAL=1 %AND (J=2 %OR %C
                  J=12)) %OR (VAL=-1 %AND (J=4 %OR J=10)))) %START
                  J=J!!8
                  CURRT_X1=CURRT_X1!!8
                  NEXTT_X1=NEXTT_X1!!8; ! ALSO ALTER MASK IN THE JUMP
                  VAL=0
                  %IF OP1=2 %THEN OPND2_D=0 %ELSE OPND1_D=0
               %FINISH
            %FINISH
            %IF VAL=0 %AND (XVAL=0 %OR CURRT_OPTYPE>>4<=5) %AND %C
               (TARGET=EMAS %OR TARGET=IBM %OR TARGET=IBMXA %OR 7<=J<=8)  %START
               CURRT_OPERN=ZCOMP
               %IF OP1=1 %THEN %START
                  SWOP OPERANDS(CURRT)
                  %IF J&6=2 %OR J&6=4 %THEN %C
                     CURRT_X1=CURRT_X1!!6 %AND NEXTT_X1=NEXTT_X1!!6
                  %FINISH
               CURRT_FLAGS<-CURRT_FLAGS&(\LOADOP2)!DONT OPT
            %FINISH
         %FINISH
         %IF (TARGET=PNX %OR TARGET=EMAS %OR TARGET=IBMXA) %AND %C
            (I=LSHIFT %OR I=RSHIFT) %AND 1<=VAL<=31 %AND OP1=2 %START
                                        ! <<CONST AND >> CONST
            CURRT_OPERN=CLSHIFT
            %IF I=RSHIFT %THEN VAL=-VAL %AND OPND2_D=VAL
            I=CLSHIFT
            CURRT_FLAGS=CURRT_FLAGS&(\LOADOP2)
         %FINISH
!         %IF I=INTDIV %AND OP1=2 %AND VAL>1 %START
!            J=POWEROF2(VAL)
!            %IF J>0 %START
!               CURRT_OPERN=CASHIFT
!               I=CASHIFT
!               OPND2_D=-J
!               CURRT_FLAGS=CURRT_FLAGS&(\LOADOP2)
!            %FINISH
!         %FINISH
!
! THE ABOVE OPTIMISATION IS UNSOUND FOR NEGATIVE OPERANDS
!
         %UNLESS TARGET=PERQ %OR TARGET=ACCENT %START
                                        ! THESE HAVE NO ARITHMETIC SHIFT
            %IF I=MULT %AND VAL>1 %AND CURRT_OPTYPE&15=1 %START
               J=POWEROF2(VAL)
               %IF J>0 %START
                  %IF OP1=1 %THEN SWOP OPERANDS(CURRT)
                  CURRT_OPERN=CASHIFT
                  I=CASHIFT
                  OPND2_D=J
                  CURRT_FLAGS=CURRT_FLAGS&(\LOADOP2)
               %FINISH
            %FINISH
         %FINISH
         %IF I>=128 %THENSTART;         ! BINARY OPERATIONS
            %IF I=VMY %START;           ! SOME VMY ARE NO OPS
               %IF TARGET=PNX %OR TARGET=PERQ %OR TARGET=ACCENT %C
                   %THEN VAL=VAL>>24;   ! DIM=1 IS NOOP
               %IF TARGET=EMAS %START
                  APTYPE=CURRT_X1>>16
                  %IF APTYPE>>8=2 %AND APTYPE&7<=2 %AND APTYPE&255#X'41' %C
                     %THEN VAL=VAL>>24; ! DIMEN 1 IS NOOP
                  %FINISH
               %FINISH
            J=FOLD NOOP INFO(I)&X'3F'
            %IF CURRT_OPTYPE>>4=6 %AND VAL=0 %THEN VAL=XVAL %ELSE %CONTINUE
            %CONTINUEUNLESS VAL<=1 %AND J#0 %AND CURRT_OPTYPE&7=1
            POPND==OPND1;               ! FOR PASSING FORWARD
            %IF OP1=1 %THEN K=3 %AND POPND==OPND2 %ELSE K=0
! BIT SHIFT FOR MASK
            %IF (J&(1<<K)#0 %AND VAL=0) %OR (J&(2<<K)#0 %AND VAL=1) %START
               NOOP(CURR,POPND);        ! THIS IS NOOP
               %CONTINUE
            %FINISH
            %IF J&(4<<K)#0 %AND VAL=0 %THENSTART
               %IF OPND1_FLAG=REFTRIP %THEN DEC USE(OPND1_D)
               %IF OP1=2 %THEN OPND1=OPND2; ! RESULT IS ZERO
               NOOP(CURR,OPND1)
                                        ! MAY CAUSE OTHER NOOPS
                                        ! EG I=(A+B)*0
            %FINISH
            %IF VAL=0 %AND OP1=1 %AND CURRT_OPERN=SUB %THEN %C
               OPND1=OPND2 %AND CURRT_OPERN=LNEG
                                        ! OPTIMISE"0-X"
         %FINISH %ELSE %START;          ! UNARY OPERATORS
                                        ! CAN OPTIMISE LOAD DOUBLE & SHRINK
                                        ! FOR PERQ & ACCENT
         %FINISH

      %REPEAT
!      %IF CHANGES>0 %AND PARM_DCOMP#0 %THEN CHANGES=0 %AND PRINT TRIPS(TRIPLES)
!
! LOOK FOR REGISTER TO STORE OPERATIONS ON PNX
!
      %IF TARGET=PNX %START
         PTR=TRIPLES(0)_FLINK
         %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 %C
               %AND (NEXTT_OPND1_FLAG=DNAME %OR NEXTT_OPND1_FLAG=INDNAME) %C
               %AND NEXTT_OPND2_FLAG=REFTRIP %AND %C
               CURRT_PUSE=PTR %AND CURRT_CNT=1 %THEN %CONTINUE
            %CONTINUE %UNLESS ADD<=CURRT_OPERN<=LSHIFT
            %IF CURRT_FLAGS&COMMUTABLE#0 %AND %C
               SAME OPND(CURRT_OPND2,NEXTT_OPND1)=YES %THEN %C
               SWOP OPERANDS(CURRT) %ELSE %START
                 %CONTINUE %UNLESS SAME OPND(CURRT_OPND1,NEXTT_OPND1)=YES
            %FINISH
            CURRT_X1=CURRT_OPERN
            CURRT_OPERN=RSTORE
            CURRT_PUSE=0
            CURRT_FLAGS=CURRT_FLAGS&(\LOAD OP1);! THIS AVOIDS A USELESS PRELOAD
            DELETE TRIPLE(PTR)
         %REPEAT
      %FINISH
!
! PASS TO CHECK FOR COMMON SUBEXPRESSIONS. DONE IN SUCH A WAY THAT
! SEQUENCES ARE DETECTED AND COMBINED
!
      PTR=TRIPLES(0)_FLINK
      %WHILE PTR>0 %CYCLE
         CURRT==TRIPLES(PTR)
         %IF CURRT_FLAGS&DONT OPT=0 %THEN CHECK DUPS(PTR,CURRT_FLINK)
         PTR=CURRT_FLINK
      %REPEAT
!
! NESTED ACCUMULATOR PASS. AVOID EXCHANGES BY ARRANGING EARLY LOADS
! OF OPERANDS FOR NON COMMUTABLE OPERATIONS
!
      %IF TARGET=PNX %OR TARGET=PERQ %OR TARGET=ACCENT %START
         PTR=TRIPLES(0)_FLINK
         %WHILE PTR>0 %CYCLE
            CURRT==TRIPLES(PTR)
            %IF CURRT_OPERN>=128 %AND CURRT_OPERN#VASS %AND %C
               CURRT_OPERN#VJASS %AND %C
               (TARGET=PERQ %OR TARGET=ACCENT %OR CURRT_OPTYPE&7=1) %AND %C
               CURRT_FLAGS&(LOADOP1!LOADOP2!COMMUTABLE)=LOADOP1 %AND %C
               CURRT_OPND2_FLAG=REFTRIP %AND 1<<CURRT_OPND1_FLAG&BTREFMASK=0 %START
               J=PRELOAD PLACE(CURRT_OPND2_D)
               %IF J>=0 %AND CURRT_DPTH=TRIPLES(J)_DPTH %START
                                       ! PLACE ACCESSIBLE
                  I=J; K=0
                  %WHILE I#PTR %CYCLE;  ! CHECK FOR DEPTH OF NESTING
                     NEXTT==TRIPLES(I)
!                  PRINTSTRING("TRIPLE EXAMINED")
!               WRITE(I,5); WRITE(OP1,5)
!                  NEWLINE
                     %IF NEXTT_DPTH<CURRT_DPTH %THEN K=999 %AND %EXIT
                                        ! LOWER ESTACK ITEMS WILL BE USED
                                        ! CANOT PRELOAD THIS ITEM
                     OP1=NEXTT_OPERN
                     %IF OP1=IOCPC %OR OP1=PRECL %OR OP1=RCALL %OR %C
                        OP1=RCRFR %OR OP1=RCRMR %THEN %C
                        K=999 %ANDEXIT
                     %IF K<NEXTT_DPTH %THEN K=NEXTT_DPTH
                     I=NEXTT_FLINK
                  %REPEAT
                  %IF K+WORDS(CURRT_OPTYPE>>4)>=6 %THEN %C
                     PTR=CURRT_FLINK %ANDCONTINUE
                  NEXTT==TRIPLES(J)
                  NEWT==TRIPLES(NEXT TRIP)
                  NEWT=0
                  NEWT_OPERN=PRELOAD;   ! PRELOAD
                  NEWT_CNT=1
                  NEWT_OPTYPE=CURRT_OPTYPE
                  NEWT_FLAGS=LOADOP1!LEAVE STACKED
                  NEWT_PUSE=PTR
                  NEWT_OPND1=CURRT_OPND1
                  CURRT_FLAGS=CURRT_FLAGS&(\LOAD OP1); ! OP1 DOES NOT NEED LOAD
                  CURRT_OPND1_FLAG=REFTRIP
                  CURRT_OPND1_D=NEXT TRIP
                  CURRT_OPND1_XTRA=0
                                        ! LINK IN NEW TRIPLE
                  NEWT_FLINK=J
                  NEWT_BLINK=NEXTT_BLINK
                  NEXTT_BLINK=NEXT TRIP
                  TRIPLES(NEWT_BLINK)_FLINK=NEXT TRIP
                  NEXT TRIP=NEXT TRIP+1
!
! CORRECT DEPTH OF NESTING FIELD
!
                  NEWT_DPTH=NEXTT_DPTH
                  %WHILE J#PTR %CYCLE
                        NEXTT_DPTH=NEXTT_DPTH+WORDS(NEWT_OPTYPE>>4)
                        J=NEXTT_FLINK
                        NEXTT==TRIPLES(J)
                  %REPEAT
                  CHANGES=CHANGES+1
               %FINISH
            %FINISH
            PTR=CURRT_FLINK
         %REPEAT
      %FINISH
!
! PASS TO TRY TO KEEP DUPLICTE TRIPLES IN ESTACK. THE SAVING
! HERE IS SO LARGE THAT IT IS WORTH THE EFFORT TO FIND THESE
! RATHER RARE CASES. OFTEN THE FORM IS A(I)=A(I)+B.
!
      %IF (TARGET=PNX %OR TARGET=PERQ %OR TARGET=ACCENT) %C
         %AND DUPS>0 %START;            ! THERE IS AT LEST ONE
         PTR=TRIPLES(0)_FLINK
         %WHILE PTR>0 %CYCLE
            CURRT==TRIPLES(PTR)
            NEXTT==CURRT
            %CYCLE
               NEXT=NEXTT_FLINK
               NEXTT==TRIPLES(NEXT)
            %REPEATUNTIL NEXTT_OPERN#NULLT
            %IF CURRT_CNT=2 %AND %C
               (TARGET=PERQ %OR TARGET=ACCENT %OR CURRT_OPTYPE&7=1) %START; ! ONLY DUPILCATES POSSIBLE
               %IF CURRT_PUSE#NEXT %AND ((NEXTT_OPND1_FLAG=REFTRIP %AND %C
                  NEXTT_OPND1_D=PTR) %OR (NEXTT_OPND2_FLAG=REFTRIP %AND %C
                  NEXTT_FLAGS&(COMMUTABLE!LOADOP1)=COMMUTABLE!LOADOP1 %AND %C
                  NEXTT_OPND2_D=PTR)) %START
                  CURRT_FLAGS=CURRT_FLAGS!USE ESTACK
                  CHANGES=CHANGES+1
                  PTR=NEXT
                  %CONTINUE
               %FINISH
               %IF CURRT_PUSE=NEXT %AND %C
                  NEXTT_OPND1_FLAG=REFTRIP=NEXTT_OPND2_FLAG %AND %C
                  NEXTT_OPND1_D=PTR=NEXTT_OPND2_D %THENSTART
                  CURRT_FLAGS=CURRT_FLAGS!USE ESTACK
                  CHANGES=CHANGES+1
                  PTR=NEXT; %CONTINUE
               %FINISH
               %IF CURRT_PUSE=NEXT %AND NEXTT_FLINK=NEXTT_PUSE#0 %AND %C
                  (NEXTT_FLAGS&COMMUTABLE#0 %OR %C
                  (NEXTT_OPND1_FLAG=REFTRIP %AND NEXTT_OPND1_D=PTR)) %START
                  NEWT==TRIPLES(NEXTT_FLINK)
                  NEWT==TRIPLES(NEWT_FLINK) %WHILE NEWT_OPERN=NULLT
                  %IF (NEWT_OPND2_FLAG=REFTRIP %AND NEWT_OPND2_D=PTR) %OR %C
                     (NEWT_FLAGS&COMMUTABLE#0 %AND %C
                     NEWT_OPND1_FLAG=REFTRIP %AND NEWT_OPND1_D=PTR) %START
                        CURRT_FLAGS=CURRT_FLAGS!USE ESTACK
                        CHANGES=CHANGES+1
                        PTR=NEXT
                        %CONTINUE
                  %FINISH
               %FINISH
            %FINISH
            PTR=NEXT
         %REPEAT
      %FINISH
!      %IF CHANGES>0 %AND PARM_DCOMP#0 %THEN PRINT TRIPS(TRIPLES)
      %RETURN
%INTEGERFN 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 %THENRESULT=I
         %IF J>VAL %THENRESULT=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
%END
%INTEGERFN PRELOAD PLACE(%INTEGER TRIP)
!***********************************************************************
!*    LOOK FOR FIRST TRIPLE IN THE CHAIN THAT LEADS TO TRIP            *
!*    CAN BE VERY COMPILCATED. RETURN -1 IF NOT SIMPLE                 *
!***********************************************************************
%CONSTINTEGER 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 %THENRESULT=TRIP
         %RESULT=PRELOAD PLACE(OPND1_D)
      %FINISH
      %IF 1<<CURRT_OPND1_FLAG&TRIPREFS=0 %OR OPND1_D=CURRT_BLINK %THEN %C
         %RESULT=PRELOAD PLACE(OPND2_D)
!
! BOTH OPERANDS ARE LOADED TRIPLES
!
      %IF CURRT_BLINK=OPND2_D %THENRESULT=PRELOADPLACE(OPND1_D)
      %RESULT=-1;                       ! TOO COMPLICATED
%END
%ROUTINE NOOP(%INTEGER TRIPLE NO, %RECORD (RD) %NAME ROPND)
!***********************************************************************
!*    THIS TRIPLE HAS BECOME A NOOP.DELETE IT AND PASS ITS ENTRY TRIPLE*
!*    FORWARD TO ANT WHO USE IT                                        *
!***********************************************************************
%RECORD (TRIPF) %NAME CURRT,NOOPT
%RECORD (RD) %NAME OPND1,OPND2
%INTEGER PTR,CNT
      NOOPT==TRIPLES(TRIPLE NO);        ! THIS ONE TO BECOME NOOP
      CNT=NOOPT_CNT;                    ! HOW MANY TIMES USED
      IMPABORT %UNLESS CNT=1;           ! NO OPS ELIMINATED BEFORE DUPS
      PTR=NOOPT_BLINK
      %WHILE PTR>0 %CYCLE
         CURRT==TRIPLES(PTR)
         %IF CURRT_PUSE=TRIPLE NO %THEN CURRT_PUSE=NOOPT_PUSE
         PTR=CURRT_BLINK
      %REPEAT
      PTR=NOOPT_FLINK
      %CYCLE
         CURRT==TRIPLES(PTR)
         PTR=CURRT_FLINK
         %CONTINUEIF CURRT_OPERN=NULLT
         OPND1==CURRT_OPND1
         OPND2==CURRT_OPND2
         %IF (OPND1_FLAG=REFTRIP %OR OPND1_FLAG=INDIRECT) %AND %C
            OPND1_D=TRIPLE NO %THENSTART
            %IF OPND1_FLAG=INDIRECT %THENRETURN; ! CAN OPTIMISE AT PRESESNT
            OPND1=ROPND
            CNT=CNT-1
            %IF OPND1_FLAG#REFTRIP %THEN CURRT_FLAGS=CURRT_FLAGS!LOAD OP1
         %FINISH
         %IF CURRT_OPERN>=128 %AND OPND2_D=TRIPLE NO %AND %C
            (OPND2_FLAG=REFTRIP %OR OPND2_FLAG=INDIRECT) %START
            %IF OPND2_FLAG=INDIRECT %THENRETURN
            OPND2=ROPND
            CNT=CNT-1
            %IF OPND2_FLAG#REFTRIP %THEN CURRT_FLAGS=CURRT_FLAGS!LOAD OP2
         %FINISH
         %IF CNT=0 %OR PTR=0 %THENEXIT
         %IF 1<<NOOPT_OPND1_FLAG&BTREFMASK=0  %AND %C
         (TARGET=PERQ %OR TARGET=ACCENT %OR %C
         (TARGET=PNX %AND NOOPT_OPTYPE&7=1))%THEN %C
            CURRT_DPTH<-CURRT_DPTH-WORDS(NOOPT_OPTYPE>>4)
      %REPEAT
      NOOPT_X1=NOOPT_OPERN;             ! FOR DEBUGGING
      NOOPT_OPERN=NULLT;                ! SET AS NOOP
      NOOPT_PUSE=0
      NOOPT_FLAGS<-NOOPT_FLAGS!DONT OPT; ! SKIP DUP CHECKING
      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)
      CURRT_CNT<-CURRT_CNT-1
      %IF CURRT_CNT=1 %THEN DUPS=DUPS-1
      %IF CURRT_CNT=0 %AND CURRT_OPERN#RSTORE %THEN DELETE TRIPLE(TRIPLE NO)
%END
%ROUTINE DELETE TRIPLE(%INTEGER TRIPLE NO)
%RECORD (TRIPF) %NAME DELT
      DELT==TRIPLES(TRIPLE NO)
      %IF DELT_OPND1_FLAG=REFTRIP %OR DELT_OPND1_FLAG=INDIRECT %THEN %C
         DEC USE(DELT_OPND1_D)
      %IF DELT_OPERN>=128 %AND (DELT_OPND2_FLAG=REFTRIP %OR %C
         DELT_OPND2_FLAG=INDIRECT) %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)
!***********************************************************************
!*    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)
      CNT=DUPT_CNT
      PTR=DUPT_FLINK
!
      %WHILE CNT>0 %AND PTR>0 %CYCLE
         CURRT==TRIPLES(PTR)
         PTR=CURRT_FLINK
         %IF CURRT_OPERN=NULLT %THENCONTINUE
         OPND1==CURRT_OPND1
         OPND2==CURRT_OPND2
         %IF OPND1_D=DTRIPNO %AND (OPND1_FLAG=REFTRIP %OR %C
            OPND1_FLAG=INDIRECT) %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 %C
            (OPND2_FLAG=REFTRIP %OR OPND2_FLAG=INDIRECT) %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 CHECK DUPS(%INTEGER TRIPNO,STRIPNO)
!***********************************************************************
!*    CHECK STARTING FROM STRIPNO FOR DUPLICATES OF TRIPNO             *
!*    MAY BE MORE THAN ONE                                             *
!***********************************************************************
%RECORD (TRIPF) %NAME CURRT,DUPT
%INTEGER OPERN,F,NEXT
      DUPT==TRIPLES(TRIPNO)
      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 %C
         %THEN %RETURN
      F=DUPT_FLAGS
      %WHILE STRIPNO>0 %CYCLE
         CURRT==TRIPLES(STRIPNO)
         %EXITIF CURRT_OPERN=TLAB %OR CURRT_OPERN=RTXIT %OR CURRT_OPERN=RCALL
         %EXITIF CURRT_OPERN=VASS %OR CURRT_OPERN=VJASS; ! PRO TEM
         NEXT=CURRT_FLINK
         %IF CURRT_OPERN=OPERN %AND ((OPERN<128 %AND %C
            SAME OPND(DUPT_OPND1,CURRT_OPND1)=YES) %OR (OPERN>=128 %AND %C
            SAME OPND(DUPT_OPND1,CURRT_OPND1)=YES %AND %C
            SAME OPND(DUPT_OPND2,CURRT_OPND2)=YES) %OR (F&COMMUTABLE#0 %AND %C
            SAME OPND(DUPT_OPND1,CURRT_OPND2)=YES %AND %C
            SAME OPND(DUPT_OPND2,CURRT_OPND1)=YES)) %START
            DUPLICATE TRIP(TRIPNO,STRIPNO)
            CHANGES=CHANGES+1
         %FINISH
         STRIPNO=NEXT
      %REPEAT
%END
%INTEGERFN SAME OPND(%RECORD (RD) %NAME OPND1,OPND2)
!***********************************************************************
!*    ARE THESE OPERANDS THE SAME ?                                    *
!***********************************************************************
%INTEGER F,I
      %RESULT=NO %UNLESS OPND1_S1=OPND2_S1
      F=OPND1_FLAG
      %IF F=2 %OR F=5 %START
         %RESULT=NO %UNLESS %C
            OPND1_D=OPND2_D %AND OPND1_XTRA=OPND2_XTRA %AND %C
            OPND1_PTYPE&X'3000'=0
         %RESULT=YES
      %FINISH
      %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 %C
            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
%ENDOFFILE