head	1.4;
access;
symbols;
locks
	gtoal:1.4; strict;
comment	@# @;


1.4
date	2022.08.17.23.49.57;	author gtoal;	state Exp;
branches;
next	1.3;

1.3
date	2022.08.17.22.21.54;	author gtoal;	state Exp;
branches;
next	1.2;

1.2
date	2022.08.17.07.35.29;	author gtoal;	state Exp;
branches;
next	1.1;

1.1
date	2022.08.17.07.34.57;	author gtoal;	state Exp;
branches;
next	;


desc
@Pass 3 of Peter Stephens' Imp to C translator
@


1.4
log
@more formatting
@
text
@!!{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):                                ! \ (C translation needs to be careful here!)
   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;                       ! CANNOT NORMALLY PASS LABELS
            
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
@


1.3
log
@indentation and formatting
@
text
@d90 1
a90 1
%IF 1<<host&unsignedshorts=0 %START
d101 1
a101 1
%FINISH %ELSE %START
d112 1
a112 1
%FINISH
d114 8
a121 8
  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)
d141 1
a141 1
! %END %OF  %FILE "ERCC07.TRIMP_TFORM1S"
d380 1
a380 1
UISW(10):                                ! \
d382 1
a382 1
   INTEND:
d631 1
a631 1
   STREND:                                  ! RETURN VALUE
d1054 6
a1059 5
            %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
d1155 3
a1157 3
            ! BEEN PASSED. THERE ARE NO BACK JUMPS
            ! TO INTERNAL LABELS FIRST REFERENCED
            ! VIA A FORWARD JUMP
@


1.2
log
@re-indented more consistently
@
text
@d322 1
a322 1
%IF HOST#TARGET %START
d324 1
a324 1
%FINISH
d344 1
a344 1
   %IF 1<<HOST&LINTAVAIL#0 %THEN %START
d346 1
a346 1
   %FINISH %ELSE %START
d348 2
a349 2
   %FINISH
   %IF 1<<HOST&LLREALAVAIL#0 %THEN %START
d351 1
a351 1
   %FINISH %ELSE %START
d353 2
a354 1
   %FINISH
d359 1
d380 1
a380 1
   UISW(10):                                ! \
d397 10
a406 5
   UISW(11):                                ! INTEGER NEGATE
   VAL1=-VAL1; ->INT END
   UISW(13):                                ! INTEGER ABS
   VAL1=IMOD(VAL1); ->INT END
   UISW(12):                                ! INTEGER FLOAT
d409 2
a410 1
   URSW(15):                                ! STRETCH REAL
d425 2
a426 1
   UISW(15):                                ! STRETCH INTEGER
d430 2
a431 1
   UISW(14):                                ! SHORTEN INTEGER
d436 2
a437 1
   URSW(14):                                ! SHORTEN REAL
d440 2
a441 1
   URSW(12):                                ! FLOAT REAL
d443 2
a444 1
   UISW(16):                                ! SHORTEN FOR <-
d447 2
a448 1
   URSW(36):                                ! INT
d453 2
a454 1
   URSW(37):                                ! INTPT
d459 2
a460 1
   UISW(38):                                ! TOSTRING
d463 2
a464 1
   URSW(48):                                ! TRUNC coded without using itself as it
d470 35
a504 17
   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
d507 2
a508 1
   BISW(8):                                 ! SRL
d511 2
a512 1
   BISW(13):                                ! VMY & CHK BOUNDS
d524 1
d532 1
d538 1
d540 2
a541 1
   BISW(18):                                ! BADJ ADUST ARRAY BASE
d550 9
a558 8
   BISW(46):
   BISW(47):                                ! scomp & sdcomp
   BRSW(46):
   BRSW(47):                                ! scomp & sdcomp
   BISW(11):
   BISW(12):                                ! COMPARISONS
   BRSW(11):
   BRSW(12):                                ! REAL COMPARISONS
d568 2
a569 1
   RCOMP:
d574 2
a575 1
   SCOMP:
d580 22
a601 11
   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
d603 5
a607 3
   RVAL1=RVAL1/RVAL2; ->REAL END
   BISW(10):                                ! '**' WITH 2 INTEGER OPERANDS
   BRSW(10):                                ! '**' WITH AT LEAST 1 REAL
d609 1
a609 1
   !      RVAL1=RVAL1**VAL2
d617 2
a618 1
   BISW(17):                                ! '****' WITH 2 INTEGER OPERAND
d625 4
a628 2
   VAL1=VAL2; ->INT END
   BISW(24):                                ! CONCAT
d644 5
a648 4
   URSW(*):
   UISW(*):
   BRSW(*):
   BISW(*):
d650 1
d675 1
d689 1
d691 1
d784 1
d797 1
d814 1
d838 1
d868 1
d906 2
a907 1
      TOMULT:                                  ! CHANGE VMY TO INTEGER MULT
d915 1
d933 1
d944 1
d982 1
d1015 1
d1125 1
d1152 2
a1153 1
            JSEEN:                                   ! THE FIRST JUMP TO THIS LAB HAS
d1180 1
d1222 1
d1224 1
d1226 1
@


1.1
log
@Initial revision
@
text
@d4 1
a4 1
            
d13 1
a13 1
                                        ! also serves for Sparc sinc there is a common b-e
d24 1
a24 1
                                        ! 2900. Long int available but not in Ecode
d30 3
a32 3
                                        ! ACCENT DIFFERS FROM PERQ ONLY IN
                                        ! ASSEMBLES SEQUENCES&SYNTAX
                                        ! AND GENERATOR
d82 3
a84 3
      %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)
d86 3
a88 3
         LABEL, JROUND, UNATT FORMATS, PSIZE, ENTRYAD, DISPLAY, AUXSBASE, 
         NAMES, SNMAX,SN,RESSIZE,CLEVEL,SET, MAXPP, EXITLAB, CONTLAB, S3,
       %INTEGERARRAY AVL WSP(0:4))
d91 10
a100 10
%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)
d102 10
a111 10
%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)
d114 8
a121 8
      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)
d128 1
a128 1
                                        ! OF TEMPS OVER LOOPS&JUMPS
d137 1
a137 1
                                        ! USED FOR BYTE PTR & OTHER SODS!
d140 1
a140 1
                                        ! FORMAT FOR ARRAY HEADS
d146 1
a146 1
                                        ! in opnd_d and opnd_xtra
d148 2
a149 2
                                        ! found elsewhere(at top of ar) by
                                        ! meanse of base&offset inf in_d and _xtra
d151 3
a153 3
                                        ! the dictionary after adjusting by
                                        ! possible offset for item in
                                        ! in records lead to the variable
d155 4
a158 4
                                        ! this form local to pass2
                                        ! and used to identify functions
                                        ! with params before the call
                                        ! is planted
d160 3
a162 3
                                        ! At an offset(_xtra) from address in
                                        ! referenced triple can be found a
                                        ! pointer to the required operand
d164 3
a166 3
                                        ! in dictionary identify a pointer
                                        ! variable at possible offset from
                                        ! this pointer
d168 4
a171 4
                                        ! the refenced triple has computed
                                        ! the (32bit) address of an item
                                        ! an offset may have to be applied
                                        ! before the fetch or store
d173 2
a174 2
                                        ! opnd_b=base<<16!offset used only for
                                        ! compiler generated temporaries
d176 1
a176 1
                                        ! triple opnd_d
d178 1
a178 1
                                        ! code generating pass(es)
d281 2
a282 2
                                        ! NEEDS TO BE TRIPLE IF COMBINED
                                        ! LABEL LIST IS USED
d303 1
a303 1
                                        ! RECORD RELATIVE TO ABSOLUTE
d308 2
a309 2
                                        ! SAME AS AINDX FOR ALL TARGETS
                                        ! BUT PNX !
d311 1
a311 1
                                        ! GENERATED BY OPTIMISER
d313 1
a313 1
                                        ! GENERATED BY OPTIMISER
d315 1
a315 1
                                        ! GENERATED BYOPTIMISER
d322 3
a324 3
      %IF HOST#TARGET %START
      %EXTERNAL %ROUTINE %SPEC REFORMATC(%RECORD (RD) %NAME OPND)
      %FINISH
d331 14
a344 14
!***********************************************************************
!*    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
d346 1
a346 1
      %FINISH %ELSE %START
d348 2
a349 2
      %FINISH
      %IF 1<<HOST&LLREALAVAIL#0 %THEN %START
d351 1
a351 1
      %FINISH %ELSE %START
d353 3
a355 41
      %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
d357 128
a484 76
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
d486 6
a491 2
BISW(8):                                 ! SRL
      %IF PRECP=6 %THEN VAL1=VAL1>>SVAL2 %ELSE VAL1=SVAL1>>SVAL2
d493 101
a593 119
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
d604 1
a604 1
            VAL=OPND_D
d612 8
a619 8
%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
d625 1
a625 1
%END
d628 20
a647 20
!***********************************************************************
!*    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
d649 1
a649 1
                                         ! ON IBM VMY OF 0 ALWAYS ZERO
d651 9
a659 9
                    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
!
d661 7
a667 7
                    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
d669 7
a675 7
                    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
d677 13
a689 13
! 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)
d691 33
a723 33
!
! 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
d730 7
a736 7
%END
%ROUTINE SWOP OPERANDS(%RECORD (TRIPF) %NAME CURRT)
!***********************************************************************
!*    EXCHANGE OPND1&OPND2 KEEPING THE FLAGS CORRECT                   *
!***********************************************************************
%RECORD (RD) TOPND
%INTEGER FLAGS,NEWFLAGS
d746 9
a754 9
%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
d759 1
a759 1
                                         ! BACK VIA OPND1
d764 3
a766 3
!
! BOTH OPERANDS ARE LOADED TRIPLES
!
d769 9
a777 9
%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
d779 1
a779 1
         LIMIT=X'7FFFFFFF' %ELSE LIMIT=1<<16
d796 1
a796 1
                                         ! THE ZERO ADD WILL BE ELAIMINATED
d798 8
a805 8
%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
d826 1
a826 1
                                         ! ANY VMY OF 0 =0 ON IBMS
d836 1
a836 1
TOMULT:                                  ! CHANGE VMY TO INTEGER MULT
d843 7
a849 7
%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
d860 3
a862 3
%END
%ROUTINE DELETE TRIPLE(%INTEGER TRIPLE NO)
%RECORD (TRIPF) %NAME DELT
d870 9
a878 9
%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
d886 1
a886 1
!
d907 10
a916 10
%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
d920 3
a922 3
!
! SET UP WOPND AS REAL ONE IN GIGTH PRECISION
!
d939 11
a949 11
%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
d953 3
a955 3
                                         ! COMPARISONS ARE IMPOSSIBLE TO OPTIMISE
                                         ! ON CONDITION CODE MACHINES
                                         ! POSSIBLE BUT DIFFICULT ON TRUE FLAG MCS
d960 1
a960 1
                                        ! two word pointers are tricky things to store and pickup
d979 4
a982 4
JSEEN:                                   ! THE FIRST JUMP TO THIS LAB HAS
                                         ! BEEN PASSED. THERE ARE NO BACK JUMPS
                                         ! TO INTERNAL LABELS FIRST REFERENCED
                                         ! VIA A FORWARD JUMP
d989 4
a992 4
                                         ! 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
d1012 1
a1012 1
                                         ! NOW BINARY ONES
d1023 4
a1026 4
!
! 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
!
d1048 11
a1058 11
%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
d1075 4
a1078 4
JSEEN:                                   ! THE FIRST JUMP TO THIS LAB HAS
                                         ! BEEN PASSED. THERE ARE NO BACK JUMPS
                                         ! TO INTERNAL LABELS FIRST REFERENCED
                                         ! VIA A FORWARD JUMP
d1083 1
a1083 1
                                         ! ASSIGNMENT
d1101 9
a1109 9
%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
d1115 1
a1115 1
            %and a(b1+3)=2 %and a(b2+3)=2 %then %result=yes
d1119 1
a1119 1
           %result=no %unless f=opnd2_flag
d1143 1
a1143 1
%END
@