!!{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