! fcelim1
! 07/12/86 - copy of ftncelim3
! - insert include files
! 12/06/86 - correction to error path on NEG
! 20/02/86 - comment out code after temp. return in OPTCVT
! 02/12/85 - taken from conelim43, new include files incorporated
! 24/09/84 - check for PROCID line 780 of OPTNEG
! 09/08/84 - correction to OPTDIV, line 672 moved to line 681
! copied from pnxrel01_conelimp41
! 13/06/84 - delete use of RSUB as op to CONOP
! 12/03/84 only generate MOO triad if target is 2900
! 22/11/83 set up TRACE flag and CDUMPTRACE routine
! 27/10/83 copied from ERCS06.REL90_CONELIMB12
!*
%INCLUDE "ftn_ht"
!*
{%INCLUDE "ftn_fmts2"}
!* 09/12/85 - add recordformat SUBFMT
!* modified 14/03/85
!*
!***********************************************************************
!* Formats for accessing dictionary records *
!***********************************************************************
!*
%recordformat PRECF(%byteinteger CLASS,TYPE,X0,X1,
%integer LINK1, LINK2,
(%shortinteger COORD,LINK3 %OR %integer LAST %C
%OR %integer CONSTRES %OR %integer INF3),
%integer ADDR4,
%shortinteger DISP,LEN,IDEN,IIN,
%integer LINE,XREF,CMNLENGTH,CMNREFAD)
!*
%recordformat SRECF(%integer INF0, LINK1, INF2, INF3, INF4)
!*
%recordformat RESF((%integer W %OR %shortinteger H0,
(%shortinteger H1 %OR %byteinteger FORM,MODE)))
!*
%recordformat DORECF( %C
%integer LABEL, LINK1,
%record(RESF) LOOPAD, ENDREF, INDEXRD, INCRD, FINALRD, ICRD,
%integer LABLIST,LINE)
!*
%recordformat BFMT(%integer L,U,M)
!*
%recordformat ARRAYDVF(%integer DIMS, ADDRDV,ADDRZERO, %C
%integer ZEROTOFIRST, ADFIRST, NUMELS, ELLENGTH, %C
%record(BFMT) %ARRAY B(1 : 7))
!*
!*
%recordformat LRECF(%integer NOTFLAG,LINK1,
%record(RESF) ORLAB,ANDLAB,
%integer RELOP)
!*
%recordformat IFRECF(%integer TYPE,LINK1,
%record(RESF) ENDIFLAB,FALSELAB,
%integer LABLIST,LINE)
!*
%recordformat LABRECF(%shortinteger BLKIND,%byteinteger X0,X1, %C
%integer LINK1,LINK2,LINK3,ADDR4,LINK5,LAB,LINE, %C
%shortinteger DOSTART,DOEND,IFSTART,IFEND)
!*
%recordformat PLABF(%shortinteger BLKIND,%byteinteger USE,X1,
%integer INDEX,CODEAD,REF,REFCHAIN)
!*
%recordformat IMPDORECF(%integer VAL,LINK,IDEN)
!*
%recordformat CONSTRECF(%shortinteger MODE,LENGTH,
(%integer VALUE %OR %integer LINK1),
%integer DADDR,CADDR)
!*
%recordformat TMPF((%byteinteger CLASS,TYPE,
%shortinteger LEN %OR %integer W0),
%integer LINK1,
%byteinteger REG,MODE,%shortinteger INDEX,
%shortinteger COORD,USECNT,
%integer ADDR)
!*
%recordformat CHARF(%integer ADESC,LINK,LEN)
!*
%recordformat FNRECF(%integer FPTR,LINK1,HEAD,PCT)
!*
%recordformat TERECF(%shortinteger MODE,LOOP,
%integer CHAIN,DISP1,INDEX,
%shortinteger COORD,FLAGS)
!*
%recordformat DTRECF(%shortinteger MODE,IDENT,
%integer CHAIN,DISP2,
%shortinteger FLAGS,INDEX,
(%integer LOOP %OR %record(RESF) CONST))
!*
!*
!***********************************************************************
!* TRIAD record format *
!***********************************************************************
!*
%recordformat TRIADF( %C
%byteinteger OP,
(%byteinteger USE %OR %byteinteger VAL2),
%shortinteger CHAIN,
(%record(RESF) RES1 %OR %C
(%shortinteger OPD1,%byteinteger QOPD1,MODE %OR %C
(%integer SLN %OR %integer VAL1))),
(%record(RESF) RES2 %OR %C
%shortinteger OPD2,%byteinteger QOPD2,MODE2))
!*
!***********************************************************************
!* COM record format *
!***********************************************************************
!*
%recordformat COMFMT(%integer CONTROL,OPT,OPTIONS1,OPTIONS2,PTRACE,
ADICT,ANAMES,ADOUTPUT,ADBLKDTAID,DICLEN,DPTR,
MAXTRIADS,NEXTPLAB,ALABH,ADLHEAD,
SUBPROGTYPE,SFPTR,EXTERNALS,CBNPTR,SCPTR,CHECKLIST,
RESCOM1,RESCOM2,F77PARM,FNO,FAULTY,LINEST,CMNIIN,SFMK,
LISTL,LISTSTREAM,DIAGSTREAM,LISTMODE,XREF,
PACKCMN,ITSMODE,PATHANAL,CHARACTER CODE,SPACE CHAR,
HEADINGS,ARRAYCHECKS,JBRMODE,MESSLEN,NAMESLEN,
NEXTCH,FUNRESDISP,WARNCOUNT,INP,MAXINP,MESSCOUNT,
UNASSPATTERN,LISTCODE,PI21INT,DOPTR,SUBPROGPTR,
FNLST,LAB,NAMESFREE,ALGOLREF,FIRSTSTATNUM,CEXPDICT,
COMMONBASE,FASTPROLOGUE,STATEMENT,IFPTR,
CNSTCA,COMMENTCNT,ADIDENT,ADERRIDEN,
ADEXT,MAXDICT,MAXNAMES,MAXOUTPUT,MAXEXT,
ACOMP,ASUBNAMES,MAXPSTACK,
ATRIADS,TRFILEID,TRBLOCK,CMNCNT,SCANONLY,NOISY,
MAXANAL,MAXGEN,SAVEANAL,SAVEGEN,OPTFLAGS,NEXTBIT,
ACMNBITS,NEXTTEMP,ASSGOTOS,TMPPTR,DESTEMPS,OBJADDR,
AREAADDR,PASTART,ADOPTDATA,TMINDEX,VRETURN,ENTRIES,
EQUCHK,LABWARN,LINENO,MAXIBUFF,
COMMENTS,DIAGLEVEL,WARNNOT77,WARNLENGTH,ALLOWUNIX,ALLOWVAX,
ONETRIP,HOST,TARGET,MONERRS,CODECA,
GLACA,DIAGCA,SSTCA,GSTCA,CONSTCA,SCALARCA,IOAREACA,ZGSTCA,STACKCA,
W1,W2,W4,STATORDERMODE,CURSTATCLASS,LISTPOINT,STACKBASE,
NEXTTRIAD,ASAVE,MAXSAVE,SUBTAB,LASTSUBTAB,
INHIBOP4,ARGCNT,IDCNT,LABCNT,TMLIST,MAINPROG,PROCINDEX,CONSOLE)
!*
!***********************************************************************
!* record format for communicating with optimiser *
!***********************************************************************
!*
%recordformat OBJFMT(%string(35) MODULE,%integer MAINEP,I,J,K,
ADATE,ATIME,OPTIONS2,EXTPROCS,ATRIADS,MAXTRIADS,
ABLOCKS,MAXBLOCKS,ALOOP,MAXLOOP,ATABS,MAXTABS,
SRFLAGS,INHIBMASK,OPT,OPTFLAGS,OPTDESC0,OPTDESC1,
D1,D2,D3,D4)
!*
!***********************************************************************
!*
!*
%RECORDFORMAT SUBRECF(%INTEGER LINK,FLAGS,TRIADS,DICT,NAMES,PTRS,PROG,
LABCNT,ARGCNT,IDCNT,TRCNT,REFSCNT,SUBSCNT,
DPTR,NEXTTRIAD,NAMESFREE,NEXTBIT,SUBPROGTYPE,SUBPROGPTR,
CBNPTR,SCPTR,CMNIIN,FUNRESDISP,CMNCNT,ASSGOTOS,VRETURN,ENTRIES,
TMLIST,ALABS,ALHEADS,NEXTPLAB,
%STRING(32) NAME,%INTEGERARRAY COORDS(0:15))
!*
%CONSTINTEGER SUBSIZE=232
%CONSTINTEGER LABSIZE=128
%CONSTINTEGER LHEADSIZE=620
!*
!*
{%INCLUDE "ftn_optspecs1"}
!*
!***********************************************************************
!* External data items *
!***********************************************************************
!*
%EXTRINSICINTEGER ADICT ;! @ of dictionary area
%EXTRINSICINTEGER MAXDICT ;! currect available length of dictionary
%EXTRINSICINTEGER ANAMES ;! @ of name table
%EXTRINSICINTEGER ABLOCKS ;! @ of block table
%EXTRINSICINTEGER MAXBLOCKS ;! current available length of block table area
%EXTRINSICINTEGER NEXTBLOCK ;! next available block index
%EXTRINSICINTEGER FREEBLOCKS
%EXTRINSICINTEGER CBNPTR ;! listhead of common block records
%EXTRINSICINTEGER SCPTR ;! listhead of local identifiers
%EXTRINSICINTEGER ATABS ;! @ of area for assorted optimiser tables
%EXTRINSICINTEGER MAXTABS ;! curent available length of opt table area
%EXTRINSICINTEGER FREETABS ;! next free location in opt table area
%EXTRINSICINTEGER EXBPTR ;! exit block table
%EXTRINSICINTEGER ENTBPTR ;! entry block table
%EXTRINSICINTEGER ALOOPS ;! @ loop table area
%EXTRINSICINTEGER MAXLOOPS ;! current available length of loop table area
%EXTRINSICINTEGER FREELOOPS ;! next free location in loop table area
%EXTRINSICINTEGER ATRIADS ;! @ of triad area
%EXTRINSICINTEGER LASTTRIAD ;! last allocated triad index
%EXTRINSICINTEGER MAXTRIADS ;! current available number of triads
%EXTRINSICINTEGER FREETRIADS;! listhead of released triads
%EXTRINSICINTEGER BLSIZE ;! length (in architecture units) of a block entry
%EXTRINSICINTEGER BSBITS ;! length (in bits) of bit string
%EXTRINSICINTEGER BSSIZE ;! length (in architecture units) of a bit strip
%EXTRINSICINTEGER BSWORDS ;! length in 2900 words of a bit strip
%EXTRINSICINTEGER OPT ;! optimisation level 0, 1 or 2
%EXTRINSICINTEGER OPTFLAGS ;! tracing level 1 Triads 2 Blocks 4 Loops
%EXTRINSICINTEGER INHIBMASK ;! inhibits specific optimisations
%EXTRINSICINTEGER SRFLAGS ;! strength reduction diagnostic flags
%EXTRINSICINTEGER SRHEAD
%EXTRINSICINTEGER SRCH
%EXTRINSICINTEGER APROPTABS ;! @ bsbits * prop table entries
%EXTRINSICINTEGER CLOOPHEAD ;! head of list of all blocks in current loop
%EXTRINSICINTEGER PLOOPHEAD ;! subset of CLOOPHEAD list already processed
%EXTRINSICINTEGER DLOOPHEAD ;! CLOOPHEAD list - PLOOPHEAD list
%EXTRINSICINTEGER CLOOPTAIL
%EXTRINSICINTEGER PLOOPTAIL
%EXTRINSICINTEGER DLOOPTAIL
%EXTRINSICINTEGER DLOOPPTR ;! current DLOOP record
%EXTRINSICINTEGER LOOP ;! current pointer to looptab
%EXTRINSICINTEGER BACKTARG ;! blocktab index of back target block
%EXTRINSICINTEGER BTARGTRIAD;! index of triad within back target block to which new triads chained
%EXTRINSICINTEGER OLDBTARGTRIAD
%EXTRINSICINTEGER LOOPDEPTH ;! depth of current loop
%EXTRINSICINTEGER LOOPENT ;! blocktab index of loop entry block
%EXTRINSICINTEGER CURRBLK ;! blocktab index of current block
%EXTRINSICINTEGER CURRTRIAD ;! triad index of triad currently being processed
%EXTRINSICINTEGER PREVTRIAD ;! previous triad (for rechaining)
%EXTRINSICINTEGER ACMNCOORDS;! @ CMNCOORDS
%EXTRINSICINTEGER ACURRDEF ;! @ CURRDEF
%EXTRINSICINTEGER ASTFNDEF
%EXTRINSICINTEGER ARGRISK
%EXTRINSICINTEGER VALTEMPHEAD
%EXTRINSICINTEGER DESTEMPHEAD
%EXTRINSICINTEGER DTINDEX
%EXTRINSICINTEGER TEINDEX
%EXTRINSICINTEGER TECH
%EXTRINSICINTEGER DTCH
!*
%EXTRINSICINTEGERARRAY CMNCOORDS(0:15) ;!
%EXTRINSICINTEGERARRAY CLOOPUSE(0:15) ;!
%EXTRINSICINTEGERARRAY PLOOPUSE(0:15) ;!
%EXTRINSICINTEGERARRAY DLOOPUSE(0:15) ;!
%EXTRINSICINTEGERARRAY CLOOPDEF(0:15) ;!
%EXTRINSICINTEGERARRAY PLOOPDEF(0:15) ;!
%EXTRINSICINTEGERARRAY DLOOPDEF(0:15) ;!
%EXTRINSICINTEGERARRAY CURRDEF(0:15) ;!
%EXTRINSICINTEGERARRAY STFNDEF(0:15)
!*
!***********************************************************************
!* Service procedures *
!***********************************************************************
!*
%EXTERNALROUTINESPEC BLOCKSFULL ;! to be called when block table exhausted
%EXTERNALROUTINESPEC TABSFULL ;! to be called when opt table exhausted
%EXTERNALROUTINESPEC DICTFULL ;! to be called when dictionary is full
%EXTERNALROUTINESPEC LOOPSFULL ;! to be called when loop table is full
!*
%EXTERNALINTEGERFNSPEC GETTRIAD
%EXTERNALINTEGERFNSPEC ALLDEF(%INTEGER INDEX)
%EXTERNALINTEGERFNSPEC NEXTTRIAD
%EXTERNALINTEGERFNSPEC NEXTTR
%EXTERNALROUTINESPEC UPDATE CURRDEF
%EXTERNALROUTINESPEC DELUSE(%INTEGER INDEX)
%EXTERNALROUTINESPEC DELUSEX(%INTEGER INDEX)
%EXTERNALINTEGERFNSPEC LOOPCON1(%INTEGER INDEX)
%EXTERNALINTEGERFNSPEC LOOPCON2(%INTEGER INDEX)
%EXTERNALROUTINESPEC TREVERSE(%INTEGER INDEX)
%EXTERNALINTEGERFNSPEC BUSYONX(%INTEGER FROMORTO,BLOCK,IDPTR)
%EXTERNALROUTINESPEC SETCMNBITS(%INTEGER STRIPADDR)
%EXTERNALROUTINESPEC SETARGBITS(%INTEGER BLIND)
%EXTERNALROUTINESPEC SETBIT(%INTEGER STRIPADDR,INDEX)
%EXTERNALROUTINESPEC PUTBIT(%INTEGER STRIPADDR,INDEX,VAL)
%EXTERNALROUTINESPEC CLEARBIT(%INTEGER STRIPADDR,INDEX)
%EXTERNALROUTINESPEC GETBIT(%INTEGER STRIPADDR,INDEX,%INTEGERNAME VAL)
%EXTERNALINTEGERFNSPEC CONOUT(%RECORD(RESF) R)
%EXTERNALINTEGERFNSPEC CONIN(%INTEGER VAL)
%EXTERNALINTEGERFNSPEC CONOP(%RECORD(RESF) RL,%INTEGER OP,
%RECORD(RESF) RR,%RECORD(RESF)%NAME R)
%EXTERNALINTEGERFNSPEC CONVAL(%INTEGER CONST1,CONST2,OP,MODE)
%EXTERNALINTEGERFNSPEC CREATETAB(%INTEGER A)
%EXTERNALINTEGERFNSPEC CREATEDTAB(%INTEGER A)
%EXTERNALROUTINESPEC PRBLOCK(%INTEGER BL)
%EXTERNALROUTINESPEC PRBLTRIADS(%INTEGER BL)
%EXTERNALROUTINESPEC PRINTBS(%INTEGERARRAYNAME B)
%EXTERNALROUTINESPEC PUSHFREE(%INTEGER VAL,%INTEGERNAME LINK)
!*
!*
{%INCLUDE "ftn_optfmts1"}
!*
!***********************************************************************
!* Optimiser record formats *
!***********************************************************************
!*
%RECORDFORMAT BLRECF(%BYTEINTEGER FLAGS,DEPTH,%SHORTINTEGER CHAIN,
%INTEGER FCON,
%INTEGER BCON,BDOM,BTARG,TEXT,
%INTEGER CORRUPT,BUB1,
%INTEGER USE,DEF,BOE)
!*
%RECORDFORMAT CONRECF((%INTEGER COUNT %OR %INTEGERARRAY BLOCK(0:1000)))
!*
%RECORDFORMAT LOOPRECF(%INTEGER BLOCK,DOWN,ACROSS,ST)
!*
%RECORDFORMAT CLOOPRECF(%INTEGER BLOCK,PDCHAIN,PDBACKCHAIN)
!*
%RECORDFORMAT PROPRECF(%SHORTINTEGER DEFCT,TEXT,DEFN,
%BYTEINTEGER FLAGS,COORD2,
%RECORD(RESF) REPL)
!*
%RECORDFORMAT SREDF(%SHORTINTEGER MODE,IDENT,LOOP,DUMP,INIT,
%BYTEINTEGER FLAGS,SPARE1,
%SHORTINTEGER USECT,SPARE2,
%INTEGER WEIGHT,
%INTEGER CHAIN,
(%SHORTINTEGERARRAY INCR(1:3),TEST(1:3),USE(1:1000) %C
%OR %SHORTINTEGERARRAY ALLREFS(1:1006)))
!*
!***********************************************************************
!* Constant definitions *
!***********************************************************************
!*
%CONSTINTEGER USE = 0 ;! variable usage
%CONSTINTEGER DEF = 1 ;!
!*
%CONSTINTEGER TDUMP = 1 ;! dump triads before optimiastion
%CONSTINTEGER BDUMP = 2 ;! dump block tables
%CONSTINTEGER LDUMP = 4 ;! dump loop tables
%CONSTINTEGER T1DUMP = 8 ;! dump triads after OP1
%CONSTINTEGER T2DUMP = 16 ;! dump triads after OP2
%CONSTINTEGER T3DUMP = X'200' ;! dump triads after OP3
%CONSTINTEGER SDUMP = 32 ;! give reconstructed source
%CONSTINTEGER S1DUMP = X'800' ;! reconstructed source after OP1
%CONSTINTEGER S2DUMP = X'1000' ;! reconstructed source after OP2
%CONSTINTEGER EDUMP = 64 ;! dump elimination info
%CONSTINTEGER CDUMP = X'80' ;! constant elimination
%CONSTINTEGER PDUMP = X'100';! proptabs
%CONSTINTEGER SEOBDUMP = X'400' ;! dump triads for block after SUBSEOB
%CONSTINTEGER SSDUMP = X'2000' ;! trace path through SUBSUM
!*
%CONSTINTEGER INHIBSUBSUM = 1
%CONSTINTEGER INHIBOP2A = 2
%CONSTINTEGER INHIBEXPOPTS = 4
%CONSTINTEGER INHIBBMOVE = 8
%CONSTINTEGER INHIBEXPELIM = 16
%CONSTINTEGER INHIBSTR = 32
!*
%CONSTINTEGER FUNCBIT = X'80' ;! block contains a function call
%CONSTINTEGER RETBIT = X'20' ;! block is a procedure return block
%CONSTINTEGER LEBIT = X'10' ;! block is a loop entry block
%CONSTINTEGER ARTICBIT = X'08' ;! block is an articulation block
!*
%CONSTINTEGER EBBIT = X'08' ;! entry block marker in label table
!*
%CONSTINTEGER SOB = X'80' ;! start of block marker in STMT triad
%CONSTINTEGER BMBIT = x'80' ;! in TR_OP indicates it has been backward moved
%CONSTINTEGER BMBIT OFF = x'7F' ;! mask for deleting BMBIT
%CONSTINTEGER BMBIT SHIFT = 7
!*
%CONSTINTEGER TESTREPBIT = 2
%CONSTINTEGER REVTESTBIT = 1
%CONSTINTEGER BREGBIT = 4
%CONSTINTEGER SCANDBIT = 8
!*
%CONSTINTEGER SRTEMPBIT = 1
%CONSTINTEGER ACTARGBIT = 2
%CONSTINTEGER INITLOADBIT = 4
!*
%CONSTINTEGER FROM = 0 ;! param to BUSYONX
%CONSTINTEGER TO = 1 ;! ditto
%CONSTINTEGER BUSY = 1
%CONSTINTEGER NOT BUSY = 0
!*
%CONSTBYTEINTEGERARRAY DEFTEST(0:116)= %C
0(7),1,0(4),1,0(38),5,0,1,0(11),3,4,0(3),6,0,2,0(44);! ASMT,ASGN,FUN,CALL,DARG
!*
!*
%RECORDFORMAT OPTDFMT( %C
%INTEGER ADICT ,{ @ of dictionary area}
%INTEGER MAXDICT ,{ currect available length of dictionary}
%INTEGER ANAMES ,{ @ of name table}
%INTEGER ABLOCKS ,{ @ of block table}
%INTEGER MAXBLOCKS ,{ current available length of block table area}
%INTEGER NEXTBLOCK ,{ next available block index}
%INTEGER FREEBLOCKS,
%INTEGER CBNPTR ,{ listhead of common block records}
%INTEGER SCPTR ,{ listhead of local identifiers}
%INTEGER ATABS ,{ @ of area for assorted optimiser tables}
%INTEGER MAXTABS ,{ curent available length of opt table area}
%INTEGER FREETABS ,{ next free location in opt table area}
%INTEGER EXBPTR ,{ exit block table}
%INTEGER ENTBPTR ,{ entry block table}
%INTEGER ALOOPS ,{ @ loop table area}
%INTEGER MAXLOOPS ,{ current available length of loop table area}
%INTEGER FREELOOPS ,{ next free location in loop table area}
%INTEGER ATRIADS ,{ @ of triad area}
%INTEGER LASTTRIAD ,{ last allocated triad index}
%INTEGER MAXTRIADS ,{ current available number of triads}
%INTEGER FREETRIADS,{ listhead of released triads}
%INTEGER BLSIZE ,{ length (in architecture units) of a block entry}
%INTEGER BSBITS ,{ length (in bits) of bit string}
%INTEGER BSSIZE ,{ length (in architecture units) of a bit strip}
%INTEGER BSWORDS ,{ length in 2900 words of a bit strip}
%INTEGER OPT ,{ optimisation level 0, 1 or 2}
%INTEGER OPTFLAGS ,{ tracing level 1 Triads 2 Blocks 4 Loops }
%INTEGER INHIBMASK ,{ inhibits specific optimisations}
%INTEGER SRFLAGS ,{ strength reduction diagnostic flags}
%INTEGER SRHEAD,
%INTEGER SRCH,
%INTEGER APROPTABS ,{ @ bsbits * prop table entries}
%INTEGER CLOOPHEAD ,{ head of list of all blocks in current loop }
%INTEGER PLOOPHEAD ,{ subset of CLOOPHEAD list already processed}
%INTEGER DLOOPHEAD ,{ CLOOPHEAD list - PLOOPHEAD list}
%INTEGER CLOOPTAIL,
%INTEGER PLOOPTAIL,
%INTEGER DLOOPTAIL,
%INTEGER DLOOPPTR ,{ current DLOOP record}
%INTEGER LOOP ,{ current pointer to looptab}
%INTEGER BACKTARG ,{ blocktab index of back target block}
%INTEGER BTARGTRIAD,{ index of triad within back target block to which new triads chained}
%INTEGER OLDBTARGTRIAD,
%INTEGER LOOPDEPTH ,{ depth of current loop}
%INTEGER LOOPENT ,{ blocktab index of loop entry block}
%INTEGER CURRBLK ,{ blocktab index of current block}
%INTEGER CURRTRIAD ,{ triad index of triad currently being processed}
%INTEGER PREVTRIAD ,{ previous triad (for rechaining)}
%INTEGER ACMNCOORDS,{ @ CMNCOORDS}
%INTEGER ACURRDEF ,{ @ CURRDEF}
%INTEGER ASTFNDEF,
%INTEGER ARGRISK,
%INTEGER VALTEMPHEAD,
%INTEGER DESTEMPHEAD,
%INTEGER DTINDEX,
%INTEGER TEINDEX,
%INTEGER TECH,
%INTEGER DTCH)
!*
!
{%INCLUDE "ftn_consts1"}
!* modified 23/09/86
!*
!*
%constinteger WSCALE = 2;! scale word address to byte address
%constinteger BSCALE = 0;! scaling factor for words to architectural units
%constinteger CSCALE = 0;! byte offset to architectural unit offset
%constinteger DSCALE = 2;! dict pointer scaling in RES records
!*
%constinteger W1 = 4 ;! 1 word in architectural units
%constinteger W2 = 8 ;! 2 words in architectural units
%constinteger W3 = 12 ;! 3 words in architectural units
%constinteger W4 = 16 ;! 4 words in architectural units
!*
%constinteger TRIADLENGTH = 12 ;! size of an individual triad
%constinteger BLRECSIZE = 44 ;! size of a block table entry in architectural units
%constinteger LOOPRECSIZE = 16 ;! size of a loop table entry
%constinteger PROPRECSIZE = 12 ;! size of a propagation table entry
%constinteger CLOOPSZ = 12 ;! size of cloop table entry
%constinteger FRSIZE = 8 ;! size of freelist created by PUSHFREE
%constinteger TESZ = 20
%constinteger DTSZ = 20
%constinteger ARTICSZ = 4
%constinteger CTSIZE = 2 ;! used in OP3
%constinteger EXTNSIZE = 4 ;! used in OP3
!*
!* following used in strength reduction
!*
%constinteger RDSZ = 8
%constinteger RUSESZ = 12
%constinteger RTESTSZ = 4
%constinteger RDEFSZ = 16
%constinteger USESZ = 32
%constinteger SRUSESZ = 2
%constinteger SRSCALE = 4;! SR==RECORD(ABLOCKS + SRPTR<<SRSCALE)
%constinteger SRFIXED = 36
!*
!*
%conststring(5) REG1="reg7"
%constinteger GLAOFFSET=32
%if target=ibm %thenstart
%constinteger dvarea=7
%finishelsestart
%constinteger DVAREA=2
%finish
!*
!***********************************************************************
!* Constants defining the size of DICT records *
!***********************************************************************
!*
%constinteger IDRECSIZE = 28;! size of dict entry reserved for a new identifier
%constinteger CONRECSIZE = 16
%constinteger CNSTRECMIN = 4
%constinteger IMPDORECSIZE = 12;! size of DATA-implied-DO list item
%constinteger LABRECSIZE = 40
%constinteger PLABRECSIZE = 8;! N.B. this is a reduced size for compiler using Put interfaces
%constinteger XREFSIZE = 8
%constinteger CMNRECEXT = 16;! extra space on iden record for common block name
%constinteger TMPRECSIZE = 20
%constinteger DVRECSIZE = 28
%constinteger TRIADSIZE = 12
%constinteger LBLKSIZE = 520
!*
!*
!********************* TRIAD qualifiers ********************************
!*
%CONSTINTEGER NULL = 0
%CONSTINTEGER LABID = 1
%CONSTINTEGER PLABID = 2
%CONSTINTEGER PROCID = 3
%CONSTINTEGER STKLIT = 4
%CONSTINTEGER GLALIT = 5
%CONSTINTEGER SRTEMP = 6
%CONSTINTEGER BREG = 7
%CONSTINTEGER VALTEMP = 8
%CONSTINTEGER DESTEMP = 9
%CONSTINTEGER LSCALID =16
%CONSTINTEGER OSCALID =17
%CONSTINTEGER CSCALID =18
%CONSTINTEGER ASCALID =19
%CONSTINTEGER PSCALID =20
%CONSTINTEGER ARRID =21
%CONSTINTEGER TMPID =22
%CONSTINTEGER PERMID =23
%CONSTINTEGER STFNID =24
%CONSTINTEGER ITMPID =22
%CONSTINTEGER RTMPID =22
%CONSTINTEGER ETMPID =22
%CONSTINTEGER TRIAD =32
%CONSTINTEGER ARREL =33
%CONSTINTEGER CHAREL =34
%CONSTINTEGER CHVAL =35
%CONSTINTEGER LIT =64
%CONSTINTEGER NEGLIT =65
%CONSTINTEGER CNSTID =66
!*
!********************* TRIAD masks *************************************
!*
%CONSTINTEGER CONSTMASK=X'40'
%CONSTINTEGER IDMASK =X'10'
%CONSTINTEGER TEXTMASK =X'20'
!*
!********************* other useful masks ******************************
!*
%CONSTINTEGER ARRAYBIT = X'04'
%CONSTINTEGER CMNBIT = X'02'
%CONSTINTEGER EQUIVBIT = X'80'
!*
!********************* modes *******************************************
!*
%CONSTINTEGER INT2 = 0, INT4 = 1, INT8 = 2
%CONSTINTEGER REAL4 = 3, REAL8 = 4, REAL16 = 5
%CONSTINTEGER CMPLX8 = 6, CMPLX16 = 7, CMPLX32 = 8
%CONSTINTEGER LOG1 = 9, LOG2 =10, LOG4 =11
%CONSTINTEGER LOG8 =12, CHARMODE=13, HOLMODE =14
%CONSTINTEGER BYTE =15, HEXCONST=16
!*
!********************* types *******************************************
!*
%CONSTINTEGER INTTYPE = 1
%CONSTINTEGER REALTYPE = 2
%CONSTINTEGER CMPLXTYPE = 3
%CONSTINTEGER LOGTYPE = 4
%CONSTINTEGER CHARTYPE = 5
!*
!********************* scaling factors *********************************
!*
!*
!********************* length of maximum source statement **************
!*
%CONSTINTEGER INPUT LIMIT = 1328
!*
!********************* mode to size/type *******************************
!*
%CONSTBYTEINTEGERARRAY MODETOST(0:15)= %C
X'41',X'51',X'61',X'52',X'62',X'72',
X'53',X'63',X'73',X'34',X'44',X'54',X'64',5,0,X'31'
!*
!********************* mode to bytes etc. ******************************
!*
%CONSTBYTEINTEGERARRAY CSIZE(0:15)= %c
2,4,8,4,8,16,8,16,32,1,2,4,8,1,0,1
%CONSTBYTEINTEGERARRAY ModetoBytes(0:15)= %c
2,4,8,4,8,16,8,16,32,1,2,4,8,1,0,1
%CONSTBYTEINTEGERARRAY ModetoTempBytes(0:15)= %c
4,4,8,4,8,16,8,16,32,4,4,4,8,4,4,4
%CONSTBYTEINTEGERARRAY SETMODE(0:63)= %C
0(4),10,13,0(11),1,3,6,11,0(12),2,4,7,8,0(12),15,5,8,9,0(11)
!*
!********************** location of pseudo common record in dict *******
!*
%CONSTINTEGER PSEUDOCMN=20
!*
!********************** location of blank common record in dict ********
!*
%CONSTINTEGER BLCMPTR=96
!*
!********************** other useful consts ****************************
!*
%CONSTINTEGER NO = 0
%CONSTINTEGER YES = 1
%CONSTINTEGER FULL= 2
!*
!********************** area identifiers *******************************
!*
%constinteger STACK = 0
%CONSTINTEGER GLA = 2
%CONSTINTEGER SST = 4
%CONSTINTEGER GST = 5
%CONSTINTEGER DIAGS = 6
%if target=ibm %thenstart
%constinteger scalars=7
%finishelsestart
%CONSTINTEGER SCALARS = 2
%finish
%CONSTINTEGER IOAREA = 8
%CONSTINTEGER ZEROGST = 9
%CONSTINTEGER CONSTS =10
!*
!********************** system procedures ******************************
!*
%constinteger F77AUX = 0
%constinteger F77STOP = 1
%constinteger F77PAUSE = 2
%constinteger F77IOA = 3
%constinteger F77IOB = 4
%constinteger F77IOC = 5
%constinteger F77IOD = 6
%constinteger F77IOE = 7
%constinteger F77IOF = 8
%constinteger F77FILE = 9
%constinteger IMPSTOP =10
%constinteger F77RTERR =11
%constinteger F77IOAR =12
%constinteger F77IOBR =13
%constinteger F77IOG =14
%constinteger F77CPSTR =15
%constinteger F77CONCAT=16
%constinteger F77INDEX =17
%constinteger FIBITS =18
%constinteger FISHFTC =19
%constinteger F77PCHECK=20
%constinteger F77IOH =21
%constinteger F77IOI =22
!***********************************************************************
!*
!*
{%INCLUDE "ftn_triadops1"}
!*
!*********************** TRIAD operator values *************************
!*
%constinteger ADD = X'02'
%constinteger SUB = X'03'
%constinteger MULT = X'04'
%constinteger DIV = X'05'
%constinteger NEG = X'06'
%constinteger ASMT = X'07'
%constinteger CVT = X'08'
%constinteger ARR = X'09'
%constinteger ARR1 = X'0A'
%constinteger BOP = X'0B'
%constinteger ASGN = X'0C'
%constinteger EXP = X'0E'
%constinteger EXP3 = X'0F'
%constinteger AND = X'10'
%constinteger OR = X'11'
%constinteger NOT = X'12'
%constinteger EQUIV = X'13'
%constinteger NEQ = X'14'
%constinteger GT = X'15'
%constinteger LT = X'16'
%constinteger NE = X'17'
%constinteger EQ = X'18'
%constinteger GE = X'19'
%constinteger LE = X'1A'
%constinteger SUBSTR = X'1B'
%constinteger CHAR = X'1C'
%constinteger CONCAT = X'1D'
%constinteger CHHEAD = X'1E'
%constinteger STOD1 = X'20'
%constinteger STOD2 = X'21'
%constinteger EOD1 = X'24'
%constinteger EOD2 = X'25'
%constinteger BRK = X'28'
%constinteger DARR = X'29'
%constinteger DEFARR = X'29'
%constinteger RRSUB = X'2A'
%constinteger RRDIV = X'2B'
%constinteger DCHAR = X'2C'
%constinteger ASH = X'2D'
%constinteger STRTIO = X'30'
%constinteger IOITEM = X'31'
%constinteger IODO = X'32'
%constinteger IOSPEC = X'33'
%constinteger IO = X'34'
%constinteger ENDIO = X'34'
%constinteger DIOITEM= X'35'
%constinteger SUBS = X'38'
%constinteger ARGARR = X'39'
%constinteger INIT = X'3A'
%constinteger INCR = X'3B'
%constinteger DECR = X'3C'
%constinteger DINIT = X'3D'
%constinteger PINCR = X'3E'
%constinteger NOOP = X'40'
%constinteger FUN = X'41'
%constinteger SUBR = X'42'
%constinteger ARG = X'43'
%constinteger STRTSF = X'44'
%constinteger ENDSF = X'45'
%constinteger CALLSF = X'46'
%constinteger IFUN = X'47'
%constinteger DARG = X'48'
%constinteger IARG = X'49'
%constinteger REPL = X'4A'
%constinteger REF = X'4B'
%constinteger LOADB = X'4C'
%constinteger STOREB = X'4D'
%constinteger MOO = X'4E'
%constinteger JIT = X'50'
%constinteger JIF = X'51'
%constinteger JINN = X'52'
%constinteger JINP = X'53'
%constinteger JINZ = X'54'
%constinteger JIN = X'55'
%constinteger JIP = X'56'
%constinteger JIZ = X'57'
%constinteger CGT = X'58'
%constinteger GOTO = X'59'
%constinteger RET = X'5A'
%constinteger STOP = X'5B'
%constinteger PAUSE = X'5C'
%constinteger EOT = X'5D'
%constinteger NINT = X'5E'
%constinteger ANINT = X'5F'
%constinteger STMT = X'60'
%constinteger ITS = X'61'
%constinteger PA = X'62'
%constinteger TOCHAR = X'63'
%constinteger DIM = X'64'
%constinteger DMULT = X'65'
%constinteger AINT = X'66'
%constinteger ABS = X'67'
%constinteger MOD = X'68'
%constinteger SIGN = X'69'
%constinteger MIN = X'6A'
%constinteger MAX = X'6B'
%constinteger REALL = X'6C'
%constinteger IMAG = X'6D'
%constinteger CMPLX = X'6E'
%constinteger CONJG = X'6F'
%constinteger LEN = X'70'
%constinteger ICHAR = X'71'
%constinteger CHIND = X'72'
%constinteger DCMPLX = X'73'
%constinteger INTRIN = X'74'
!*
!*
{%INCLUDE "ftn_copy1"}
!* modified 23/09/86
!*
%constINTEGER TRACE=0
!
%EXTERNALROUTINESPEC PRINT TR(%INTEGER INDEX,ADICT,ANAMES,
LEVEL,%RECORD(TRIADF)%NAME TRIAD)
%EXTERNALINTEGERFNSPEC CONRES(%INTEGER CONST,MODE)
%EXTERNALINTEGERFNSPEC CONCHECK(%RECORD(RESF) RES)
%EXTERNALINTEGERFNSPEC CONVERTMODE(%RECORD(RESF)%NAME RES,%INTEGER MODE)
%EXTERNALINTEGERFNSPEC CONINVERT(%RECORD(RESF) RES1,
%RECORD(RESF)%NAME RES)
%OWNRECORD(RESF) RNULL
%CONSTBYTEINTEGERARRAY MODETYPE(0:15)=
1,1,1,2,2,2,3,3,
3,4,5,5,0,4,4,0
%EXTERNALROUTINE CDUMPTRACE
! TRACE=OPTFLAGS&CDUMP
%END
!
%EXTERNALROUTINE OPTDIV
! OPTIMISE THE DIV TRIAD
%RECORD(TRIADF)%NAME CTR,OPD1TR,TMPTR,NEWTR
%RECORD(RESF) RES
%INTEGER NEWIND,OK,DELIND
%INTEGER CMODE,CVAL
CTR==RECORD(ATRIADS+CURRTRIAD*TRIADLENGTH)
%IF TRACE#0 %START
PRINTSTRING("OPTIMISING DIV TRIAD, INDEX")
WRITE(CURRTRIAD,1);NEWLINE
PRINTTR(CURRTRIAD,ADICT,ANAMES,0,CTR)
%FINISH
%IF CTR_QOPD2&CONSTMASK#0 %START
%IF CTR_QOPD1&CONSTMASK#0 %START
! BOTH OPERANDS ARE CONSTANT
OK=CONOP(CTR_RES1,DIV,CTR_RES2,RES)
%IF OK#0 %THEN %RETURN
CTR_RES1=RES
CTR_OP=(CTR_OP&BMBIT)!REPL
%IF TRACE#0 %START
PRINTSTRING("BOTH OPERANDS ARE CONSTANT - TRIAD OPTIMISED TO:")
NEWLINE
->PROUT
%FINISH
%RETURN
%FINISH
! OPD2 IS A CONSTANT, OPD1 IS NOT
CVAL=CONCHECK(CTR_RES2)
%IF CVAL=1 %START
! DIVISION BY 1
CTR_RES2=0
CTR_OP=(CTR_OP&BMBIT)!REPL
%IF TRACE#0 %START
PRINTSTRING("OPD2 IS A CONSTANT, OPD1 IS NOT");NEWLINE
PRINTSTRING("DIVISION BY 1 - TRIAD OPTIMISED TO:");NEWLINE
->PROUT
%FINISH
%RETURN
%FINISH
%IF CTR_QOPD1&TEXTMASK#0 %START
! OPD1 IS A TRIAD, OPD2 IS NOT
! (-A)/2 BECOMES A/-2
OPD1TR==RECORD(ATRIADS+CTR_OPD1*TRIADLENGTH)
%IF OPD1TR_OP&BMBITOFF=NEG %START
%IF OPD1TR_QOPD1&TEXTMASK#0 %START
TMPTR==RECORD(ATRIADS+OPD1TR_OPD1*TRIADLENGTH)
TMPTR_USE=TMPTR_USE+1
%FINISH
OK=CONOP(RNULL,NEG,CTR_RES2,RES)
%IF OK#0 %THEN %RETURN
%IF TRACE#0 %START
PRINTSTRING("OPD1 IS A TRIAD WITH NEG OP");NEWLINE
PRINTSTRING("DELETEING TRIAD WITH INDEX")
WRITE(CTR_OPD1,1);NEWLINE
%FINISH
DELUSE(CTR_OPD1)
CTR_RES1_W=OPD1TR_RES1_W
CTR_RES2=RES
%IF TRACE#0 %START
PRINTSTRING("TRIAD OPTIMISED TO:");NEWLINE
->PROUT
%FINISH
%FINISH
%FINISH
%IF MODETYPE(CTR_MODE2)=REALTYPE %START
! DIVISION BY REAL CONSTANT BECOMES MULTIPLICATION BY
! RECIPROCAL CONSTANT
OK=CONINVERT(CTR_RES2,RES)
%IF OK#0 %THEN %RETURN
CTR_RES2=RES
CTR_OP=(CTR_OP&BMBIT)!MULT
%IF TRACE#0 %START
PRINTSTRING("DIVISION BY REAL CONST.")
PRINTSTRING(" BECOMES MULTIPLICATION BY RECIPROCAL CONST")
NEWLINE
PRINTSTRING("TRIAD OPTIMISED TO:");NEWLINE
->PROUT
%FINISH
%FINISH
OUT1:
%IF TRACE#0 %START
PRINTSTRING("END OF DEALING WITH CONSTANTS - EXIT FROM OPTDIV")
NEWLINE
%FINISH
%RETURN
PROUT:
%IF TRACE#0 %START
PRINT TR(CURRTRIAD,ADICT,ANAMES,0,CTR)
->OUT1
%FINISH
%FINISH; ! END OF DEALING WITH CONSTANTS
! HERE IF CTR_QOPD2 IS NOT A CONSTANT
! A/B/C BECOMES A/(B*C) IN REAL MODE ONLY
%IF MODETYPE(CTR_MODE)# REALTYPE %OR MODETYPE(CTR_MODE2)#REALTYPE %C
%THEN %RETURN
%IF CTR_QOPD1&TEXTMASK=0 %THEN %RETURN
! OPD1 IS A TRIAD
%IF TRACE#0 %START
PRINTSTRING("OPD2 IS NOT A CONSTANT, OPD1 IS ATRIAD & MODE IS REAL")
NEWLINE
%FINISH
OPD1TR==RECORD(ATRIADS+CTR_OPD1*TRIADLENGTH)
%IF OPD1TR_OP&BMBIT#0 %THEN %RETURN; ! A LOOP CONSTANT
%IF OPD1TR_OP#DIV %THEN %RETURN
%IF OPD1TR_USE#1 %THEN %RETURN
%IF TRACE#0 %START
PRINTSTRING("GET A NEW TRIAD");NEWLINE
%FINISH
NEWIND=GETTRIAD; ! GET A NEW TRIAD
NEWTR==RECORD(ATRIADS+NEWIND*TRIADLENGTH)
NEWTR_OP=MULT
NEWTR_USE=1
NEWTR_CHAIN=CURRTRIAD
NEWTR_MODE=CTR_MODE
NEWTR_RES2_W=CTR_RES2_W
CTR_QOPD2=TRIAD
CTR_OPD2=NEWIND
NEWTR_RES1_W=OPD1TR_RES2_W
DELIND=CTR_OPD1
CTR_RES1_W=OPD1TR_RES1_W
TREVERSE(NEWIND); ! ENSURE CORRECT ORDER OF B*C OPERANDS
CURRTRIAD=NEWIND; ! RESET CURRTRIAD SO THAT NEWTRIAD CAN BE FURTHER OPTIMISED
%IF TRACE#0 %START
PRINTSTRING("DELETEING TRIAD WITH INDEX")
WRITE(DELIND,1);NEWLINE
%FINISH
DELUSEX(DELIND); ! DELETE A/B
TMPTR==RECORD(ATRIADS+PREVTRIAD*TRIADLENGTH)
TMPTR_CHAIN=NEWIND
%IF TRACE#0 %START
PRINTSTRING("CURRTRIAD NOW HAS INDEX")
WRITE(NEWIND,1); NEWLINE
PRINTTR(CURRTRIAD,ADICT,ANAMES,0,NEWTR)
PRINTSTRING("CURRTRIAD CHAINED TO TRIAD WITH INDEX")
WRITE(NEWTR_CHAIN,1);NEWLINE
PRINTTR(NEWTR_CHAIN,ADICT,ANAMES,0,CTR)
PRINTSTRING("EXIT FROM OPTDIV")
%FINISH
%END; ! OPTDIV
%EXTERNALROUTINE OPTNEG
!OPTIMISE THE NEG TRIAD
%RECORD(TRIADF)%NAME CTR,OPD1TR
%RECORD(RESF) RES
%INTEGER OK
CTR==RECORD(ATRIADS+CURRTRIAD*TRIADLENGTH)
%IF TRACE#0 %START
PRINTSTRING("OPTIMISING NEG TRIAD, INDEX")
WRITE(CURRTRIAD,1);NEWLINE
PRINTTR(CURRTRIAD,ADICT,ANAMES,0,CTR)
%FINISH
%IF CTR_QOPD1&IDMASK#0 %OR CTR_QOPD1=PROCID %THEN %RETURN
%IF MODETYPE(CTR_MODE)=CMPLXTYPE %THEN %RETURN
%IF CTR_QOPD1&CONSTMASK#0 %START
! OPD1 IS ACONSTANT - NEGATE IT
OK=CONOP(RNULL,NEG,CTR_RES1,RES)
%IF OK#0 %THEN %RETURN
CTR_RES1=RES
%IF TRACE#0 %START
PRINTSTRING("OPD1 IS A CONSTANT - NEGATE IT")
NEWLINE
%FINISH
->SETREPL
%FINISH
! QOPD1 IS A TRIAD
%IF TRACE#0 %START
PRINTSTRING("OPD1 IS A TRIAD, INDEX")
WRITE(CTR_OPD1,1);NEWLINE
%FINISH
OPD1TR==RECORD(ATRIADS+CTR_OPD1*TRIADLENGTH)
%IF OPD1TR_USE#1 %THEN %RETURN
%IF OPD1TR_OP&BMBITOFF=SUB %START
!NEG(A SUB B) BECOMES B SUB A
RES=OPD1TR_RES1
OPD1TR_RES1=OPD1TR_RES2
OPD1TR_RES2=RES
%IF TRACE#0 %START
PRINTSTRING("NEG(A SUB B) BECOMES B SUB A")
NEWLINE
PRINTSTRING("OPD1 TRIAD BECOMES");NEWLINE
PRINTTR(CTR_OPD1,ADICT,ANAMES,0,OPD1TR)
%FINISH
->SETREPL
%FINISH
%IF OPD1TR_OP&BMBITOFF=ADD %START
%IF OPD1TR_QOPD2&CONSTMASK=0 %THEN %RETURN
! NEG(ANY+CT) BECOMES -CT-ANY
OK=CONOP(RNULL,NEG,OPD1TR_RES2,RES)
%IF OK#0 %THEN %RETURN
OPD1TR_RES2=OPD1TR_RES1
OPD1TR_RES1=RES
OPD1TR_OP=(OPD1TR_OP&BMBIT)!SUB
%IF TRACE#0 %START
PRINTSTRING("NEG(ANY+CONST) BECOMES (-CONST)-ANY")
NEWLINE
PRINTSTRING("OPD1 TRIAD BECOMES");NEWLINE
PRINTTR(CTR_OPD1,ADICT,ANAMES,0,OPD1TR)
%FINISH
->SETREPL
%FINISH
%IF OPD1TR_OP&BMBITOFF=MULT %OR OPD1TR_OP&BMBITOFF=DIV %START
%IF OPD1TR_QOPD1&CONSTMASK#0 %START
! NEG(CT /* ANY) BECOMES -CT /* ANY
OK=CONOP(RNULL,NEG,OPD1TR_RES1,RES)
%IF OK#0 %THEN %RETURN
OPD1TR_RES1=RES
%IF TRACE#0 %START
PRINTSTRING("NEG(CONST/*ANY) BECOMES (-CONST)/*ANY")
NEWLINE
PRINTSTRING("OPD1 TRIAD BECOMES");NEWLINE
PRINTTR(CTR_OPD1,ADICT,ANAMES,0,OPD1TR)
%FINISH
->SETREPL
%FINISH
%IF OPD1TR_QOPD2&CONSTMASK=0 %THEN %RETURN
! OPD2 IS A CONSTANT
OK=CONOP(RNULL,NEG,OPD1TR_RES2,RES)
%IF OK#0 %THEN %RETURN
OPD1TR_RES2=RES
%IF TRACE#0 %START
PRINTSTRING("OPD2 IS ACONSTANT");NEWLINE
PRINTSTRING("OPD1 TRIAD BECOMES");NEWLINE
PRINTTR(CTR_OPD1,ADICT,ANAMES,0,OPD1TR)
%FINISH
%FINISH %ELSE %RETURN
SETREPL:
CTR_OP=(CTR_OP&BMBIT)!REPL
%IF TRACE#0 %START
PRINTSTRING("CURRTRIAD BECOMES");NEWLINE
PRINTTR(CURRTRIAD,ADICT,ANAMES,0,CTR)
%FINISH
! ADD FURTHER CHECKS
! E.G. NEG(CVT(A*10)) BECOMES CVT(A * -10)
%END; ! OPTNEG
!
%EXTERNALROUTINE CONELIM
! CONSTANT EXPRESSION ELIMINATION
! ADD, SUB & MULT TRIADS
%CONSTINTEGER TABADD=0,TABSUB=1,TABMULT=2,TABCSUB=3
%RECORD(TRIADF)%NAME CTR,TROPD1,TROPD2,TRFST,TRSCND
%RECORD(RESF) RES1,RES2,RES
%INTEGER OK,CVAL,OP1,OP2,DELIND,TAB1IND,TAB2IND,TAB3IND
%INTEGER FSTIND,SCNDIND,CURROP
%SWITCH ACT(0:235)
!
%CONSTBYTEINTEGERARRAY CETAB1(0:95)=1,7,14,20,
0,0,14,26,
1,33,0,0,
0(4),
0,0,39,46,
52,59,0(2),
14,64,1,33,
0,0,1,7,
14,20,0,0,
0(4),
0,0,71,78,
84,91,0,0,
0(12),
226,226,229,229,
96,101,0,0,
0(4),
107,112,120,125,
0,0,120,133,
107,140,0,0,
0(4),
0,0,147,153,
160,166,0,0
!
%CONSTBYTEINTEGERARRAY CETAB2(0:231)=0,1,2,3,4,5,6,
1,2,3,4,7,5,6,
8,2,3,4,5,6,
9,2,3,4,10,6,
9,2,3,4,7,5,6,
1,2,3,4,10,6,
1,2,3,4,11,12,6,
1,3,13,7,5,6,
8,2,3,4,11,14,6,
9,3,13,10,6,
9,2,3,4,7,5,6,
8,2,3,4,11,12,6,
9,3,13,7,5,6,
1,2,3,4,11,14,6,
1,3,13,10,6,
15,3,4,5,6,
15,3,4,7,5,6,
1,3,13,5,6,
1,2,3,4,12,7,11,6,
8,3,13,5,6,
8,3,16,13,17,7,11,6,
9,3,4,12,7,11,6,
1,3,16,13,7,11,6,
1,3,13,12,11,6,
1,3,13,12,7,11,6,
8,3,13,14,11,6,
9,3,22,4,7,11,6,
1,2,3,4,18,
8,2,3,4,18,
15,2,3,19,20,
9,3,16,13,17,7,18,
1,3,16,13,7,18,
15,3,4,18,
1,3,13,18,
8,3,13,18,
15,3,22,19,21,
9,22,23,2,3,4,7,18,
1,3,24,
8,3,24
!
%CONSTBYTEINTEGERARRAY CETAB3(0:15)=173,178,183,188,
178,173,183,195,
0,0,201,0,
205,209,213,218
!
%INTEGERFUNCTION CCHECK(%INTEGER TRIND,%RECORD(RESF)%NAME RES)
! CHECKS THE SUITABILITY OF A TRIAD FOR CONST. ELIM.
! RESULT IS O,1,2 OR 3 IF OP IS +,-C,* OR C- RESPECTIVELY, ELSE -1
! RES WILL HOLD CONST. POINTER OR 0
!
%RECORD(TRIADF)%NAME TR
TR==RECORD(ATRIADS+TRIND*TRIADLENGTH)
RES=RNULL
%IF TR_USE# 1 %THEN %RESULT=-1
%IF TR_OP&BMBITOFF=SUB %START
%IF TR_QOPD1&CONSTMASK#0 %THEN RES=TR_RES1 %AND %RESULT=TABCSUB
%FINISH
%IF TR_QOPD2&CONSTMASK#0 %THEN RES=TR_RES2
%IF TR_OP&BMBITOFF=ADD %THEN %RESULT=TABADD
%IF TR_OP&BMBITOFF=MULT %THEN %RESULT=TABMULT
%IF TR_OP&BMBIT=SUB %THEN %RESULT=TABSUB
RES=RNULL
%RESULT=-1
%END; ! CCHECK
!
CE0:
CTR==RECORD(ATRIADS+CURRTRIAD*TRIADLENGTH)
%IF TRACE#0 %START
PRINTSTRING("CONSTANT EXPRESSION ELIMINATION");NEWLINE
PRINTSTRING("FOR ADD, SUB OR MULT TRIAD, INDEX")
WRITE(CURRTRIAD,1);NEWLINE
PRINTTR(CURRTRIAD,ADICT,ANAMES,0,CTR)
%FINISH
%IF CTR_OP&BMBITOFF=ADD %START
! ELIMINATE OPERANDS WHICH ARE NEG TRIADS
%IF TRACE#0 %START
PRINTSTRING("ELIMINATE OPERANDS WHICH ARE NEG TRIADS")
NEWLINE
%FINISH
%IF CTR_QOPD1&TEXTMASK#0 %START
TROPD1==RECORD(ATRIADS+CTR_OPD1*TRIADLENGTH)
%IF TRACE#0 %START
PRINTSTRING("OPD1 IS A TRIAD -")
NEWLINE
PRINTTR(CTR_OPD1,ADICT,ANAMES,0,TROPD1)
%FINISH
DELIND=CTR_OPD1
%IF TROPD1_OP&BMBITOFF=NEG %START
! (-ANY1) + ANY2 BECOMES ANY2-ANY1
CTR_RES1=CTR_RES2
CEN10:
! ANY2 + (-ANY1) BECOMES ANY2-ANY1
CTR_OP=(CTR_OP&BMBIT)!SUB
CEN20:
CTR_RES2=TROPD1_RES1
! IF NEG HAS TEXT OPD, UPDATE USE COUNT
%IF TROPD1_QOPD1&TEXTMASK#0 %START
TRSCND==RECORD(ATRIADS+TROPD1_OPD1*TRIADLENGTH)
TRSCND_USE=TRSCND_USE+1
%FINISH
%IF TRACE#0 %START
PRINTSTRING("(-ANY1) + ANY2 BECOMES ANY2-ANY1")
NEWLINE
PRINTSTRING("ANY2 + (-ANY1) BECOMES ANY2-ANY1")
NEWLINE
PRINTSTRING("CURRTRIAD BECOMES");NEWLINE
PRINTTR(CURRTRIAD,ADICT,ANAMES,0,CTR)
PRINTSTRING("DELETE TRIAD")
WRITE(DELIND,1);NEWLINE
PRINTSTRING("AND THEN START AGAIN")
NEWLINE
%FINISH
! DELETE USE OF THE NEG TRIAD
DELUSE(DELIND)
TREVERSE(CURRTRIAD)
->CE0; ! START AGAIN
%FINISH; ! TROPD1_OP=NEG
! CEN30:
%IF CTR_QOPD2&TEXTMASK#0 %START
TROPD1==RECORD(ATRIADS+CTR_OPD2*TRIADLENGTH)
%IF TRACE#0 %START
PRINTSTRING("OPD2 IS A TRIAD -")
NEWLINE
PRINTTR(CTR_OPD2,ADICT,ANAMES,0,TROPD1)
%FINISH
DELIND=CTR_OPD2
%IF TROPD1_OP&BMBITOFF=NEG %THEN ->CEN10
%FINISH
%FINISH; ! CTR_QOPD1 IS A TRIAD
! CEN50:
CURROP=TABADD
! CE12:
%FINISH %ELSEIF CTR_OP&BMBITOFF=SUB %START
! ELIMINATE OPD2 IF A NEG TRIAD
%IF TRACE#0 %START
PRINTSTRING("ELIMINATE OPD2 IF A NEG TRIAD")
NEWLINE
%FINISH
%IF CTR_QOPD2&TEXTMASK#0 %START
TROPD1==RECORD(ATRIADS+CTR_OPD2*TRIADLENGTH)
%IF TRACE#0 %START
PRINTSTRING("OPD2 IS A TRIAD -")
NEWLINE
PRINTTR(CTR_OPD2,ADICT,ANAMES,0,TROPD1)
%FINISH
DELIND=CTR_OPD2
%IF TROPD1_OP&BMBITOFF=NEG %THEN CTR_OP=(CTR_OP&BMBIT)!ADD %C
%AND ->CEN20
%FINISH
CURROP=TABSUB
! CE14:
%FINISH %ELSE CURROP=TABMULT
!
! REJECT COMPLEX
%IF MODETYPE(CTR_MODE)=CMPLXTYPE %OR MODETYPE(CTR_MODE2)=CMPLXTYPE %C
%THEN %RETURN
! CE1:
%IF CTR_QOPD1&CONSTMASK#0 %AND CTR_QOPD2&CONSTMASK#0 %START
! BOTH OPERANDS ARE CONSTANTS
OK=CONOP(CTR_RES1,CTR_OP&BMBITOFF,CTR_RES2,RES)
%IF OK#0 %THEN %RETURN
CTR_OP=(CTR_OP&BMBIT)!REPL
CTR_RES1=RES
%IF TRACE#0 %START
PRINTSTRING("BOTH OPERANDS ARE CONSTANTS")
NEWLINE
PRINTSTRING("CURRTRIAD BECOMES");NEWLINE
PRINTTR(CURRTRIAD,ADICT,ANAMES,0,CTR)
PRINTSTRING("EXIT FROM CONELIM");NEWLINE
%FINISH
%RETURN
%FINISH
!
! CE20:
%IF CTR_QOPD1&CONSTMASK#0 %THEN %START
! ONLY OPD1 IS CONST. OP MUST BE SUB
CE11F:
%UNLESS CTR_OP&X'7F'=SUB %THEN %RETURN;! GEM 30/09/83 to clear bug D15
%IF TRACE#0 %START
PRINTSTRING("ONLY OPD1 IS A CONSTANT - CONST-ID OR CONST-TRIAD")
NEWLINE
%FINISH
! CONST-ID OR CONST-TRIAD
CVAL=CONCHECK(CTR_RES1)
%IF CVAL=0 %START
CTR_OP=(CTR_OP&BMBIT)!NEG
CTR_RES1=CTR_RES2
CTR_RES2=RNULL
%IF TRACE#0 %START
PRINTSTRING("CONSTANT IS ZERO - CURRTRIAD BECOMES")
NEWLINE
PRINTTR(CURRTRIAD,ADICT,ANAMES,0,CTR)
PRINTSTRING("EXIT FROM CONELIM");NEWLINE
%FINISH
%RETURN
%FINISH
! CE80:
%IF CTR_QOPD2&TEXTMASK=0 %THEN %RETURN; ! QOPD2 IS ID
! QOPD2 IS A TRIAD
FSTIND=CTR_OPD2
TRFST==RECORD(ATRIADS+FSTIND*TRIADLENGTH)
%IF TRACE#0 %START
PRINTSTRING("OPD2 IS A TRIAD -")
NEWLINE
PRINTTR(CTR_OPD2,ADICT,ANAMES,0,TRFST)
%FINISH
RES2=CTR_RES1
CURROP=TABCSUB
->CE85
%FINISH
!
! CE25:
%IF CTR_QOPD2&CONSTMASK#0 %START
! ONLY OPD2 IS CONSTANT
%IF TRACE#0 %START
PRINTSTRING("ONLY OPD2 IS CONSTANT - CHECK FOR VALUES -1,0,1,2")
NEWLINE
%FINISH
! CHECK FOR VALUE -1,0,1 OR 2
CVAL=CONCHECK(CTR_RES2)
%IF -2<CVAL<3 %START
%IF CURROP#TABMULT %START
! ADD OR SUB TRIAD
%IF CVAL=0 %THEN %START
CTR_OP=(CTR_OP&BMBIT)!REPL
%IF TRACE#0 %START
PRINTSTRING("ADD OR SUB TRIAD - CONST IS 0")
NEWLINE
PRINTSTRING("CURRTRIAD BECOMES");NEWLINE
PRINTTR(CURRTRIAD,ADICT,ANAMES,0,CTR)
PRINTSTRING("EXIT FROM CONELIM");NEWLINE
%FINISH
%RETURN
%FINISH
%FINISH %ELSESTART
! MULT TRIAD
%IF TRACE#0 %START
PRINTSTRING("MULT TRIAD - ")
%FINISH
%IF CVAL=-1 %START
CTR_OP=(CTR_OP&BMBIT)!NEG
CTR_RES2=RNULL
%IF TRACE#0 %START
PRINTSTRING("CONST. -1");NEWLINE
PRINTSTRING("CURRTRIAD BECOMES");NEWLINE
PRINTTR(CURRTRIAD,ADICT,ANAMES,0,CTR)
PRINTSTRING("EXIT FROM CONELIM");NEWLINE
%FINISH
%RETURN
%FINISH
%IF CVAL=2 %START
! MULTIPLY BY 2
%IF MODETYPE(CTR_MODE)=INTTYPE %THEN ->CE37
%IF CTR_QOPD1&TEXTMASK#0 %START
TROPD1==RECORD(ATRIADS+CTR_OPD1*TRIADLENGTH)
TROPD1_USE=TROPD1_USE+1
%FINISH
CTR_RES2=CTR_RES1
CTR_OP=(CTR_OP&BMBIT)!ADD
%IF TRACE#0 %START
PRINTSTRING("CONST. IS 2");NEWLINE
PRINTSTRING("CURRTRIAD BECOMES");NEWLINE
PRINTTR(CURRTRIAD,ADICT,ANAMES,0,CTR)
PRINTSTRING("EXIT FROM CONELIM");NEWLINE
%FINISH
%RETURN
%FINISH
%IF CVAL=0 %START
! DECREMENT USE COUNT IF OPD1 IS A TRIAD
%IF CTR_QOPD1&TEXTMASK#0 %THEN DELUSE(CTR_OPD1)
CTR_RES1=CTR_RES2
%FINISH
! CVAL=0 OR 1
CTR_OP=(CTR_OP&BMBIT)!REPL
%IF TRACE#0 %START
PRINTSTRING("CONST. IS 0 OR 1");NEWLINE
PRINTSTRING("CURRTRIAD BECOMES");NEWLINE
PRINTTR(CURRTRIAD,ADICT,ANAMES,0,CTR)
PRINTSTRING("EXIT FROM CONELIM");NEWLINE
%FINISH
%RETURN
%FINISH; ! MULT TRIAD
%FINISH; ! OPD2 IS A SPECIAL CONSTANT
! OPD2 IS A CONSTANT, BUT NOT A SPECIAL CASE
! CE35:
%IF TRACE#0 %START
PRINTSTRING("OPD2 IS A CONST., BUT NOT A SPECIAL CASE")
NEWLINE
%FINISH
%IF CURROP=TABSUB %AND MODETYPE(CTR_MODE2)=REALTYPE %START
! SUB REAL CONST. BECOMES ADD REAL CONST.
OK=CONOP(RNULL,NEG,CTR_RES2,RES)
%IF OK#0 %THEN %RETURN
CTR_RES2=RES
CTR_OP=(CTR_OP&BMBIT)!ADD
CURROP=TABADD
%IF TRACE#0 %START
PRINTSTRING("SUB REAL CONST. BECOMES ADD REAL CONST.")
NEWLINE
PRINTSTRING("CURRTRIAD BECOMES");NEWLINE
PRINTTR(CURRTRIAD,ADICT,ANAMES,0,CTR)
%FINISH
%FINISH
CE37:
%IF CTR_QOPD1&TEXTMASK=0 %THEN %RETURN
CE3F:
! TRIAD OP CONST.
%IF TRACE#0 %START
PRINTSTRING("TRIAD OP CONST. - ")
NEWLINE
%FINISH
! FIRST ATTEMPT TO REMOVE NEG TRIAD IF OP=MULT
! (-A) * 10 BECOMES A * -10
%IF CTR_OP&BMBITOFF=MULT %START
TROPD1==RECORD(ATRIADS+CTR_OPD1*TRIADLENGTH)
%IF TROPD1_OP&BMBITOFF=NEG %AND TROPD1_USE=1 %START
! OPD1 IS A NEG TRIAD WITH USE=1
%IF TRACE#0 %START
PRINTSTRING("OPD1 IS A NEG TRIAD,USE=1")
NEWLINE
PRINTSTRING("(-A) * CONST. BECOMES A * -CONST.")
NEWLINE
PRINTSTRING("DECREMENT USE OF NEG TRIAD, INDEX")
WRITE(CTR_OPD1,1);NEWLINE
%FINISH
OK=CONOP(RNULL,NEG,CTR_RES2,RES); ! NEGATE THE CONST.
%IF OK#0 %THEN %RETURN
DELUSEX(CTR_OPD1); ! DECREMENT USE OF NEG TRIAD
CTR_RES1=TROPD1_RES1
CTR_RES2=RES; ! PLANT THE NEW CONST.
%IF TRACE#0 %START
PRINTSTRING("CURRTRIAD BECOMES");NEWLINE
PRINTTR(CURRTRIAD,ADICT,ANAMES,0,CTR)
PRINTSTRING("START AGAIN");NEWLINE
%FINISH
->CE0; ! START AGAIN
%FINISH
%FINISH; ! OP=MULT
! CE83:
FSTIND=CTR_OPD1
TRFST==RECORD(ATRIADS+FSTIND*TRIADLENGTH)
RES2=CTR_RES2
!
CE85:
OP1=CCHECK(FSTIND,RES)
%IF RES_W=RNULL_W %THEN %RETURN
! THERE IS A CONST. IN TRFST
%IF TRACE#0 %START
PRINTSTRING("THERE IS A CONSTANT IN TRIAD")
WRITE(FSTIND,1);NEWLINE
PRINTTR(FSTIND,ADICT,ANAMES,0,TRFST)
%FINISH
! DERIVE CETAB3 INDEX
TAB3IND=OP1*4+CURROP
RES1=RES
TAB2IND=CETAB3(TAB3IND)
%IF TAB2IND=0 %THEN %RETURN
%IF TRACE#0 %START
PRINTSTRING("CETAB3 INDEX IS")
WRITE(TAB3IND,1);NEWLINE
PRINTSTRING("CETAB2 INDEX IS")
WRITE(TAB2IND,1);NEWLINE
PRINTSTRING("JUMP TO ACTION")
WRITE(CETAB2(TAB2IND),1);NEWLINE
%FINISH
->ACT(CETAB2(TAB2IND))
!
%FINISH; ! OPD2 IS A CONST.
!
! HERE, NEITHER OPERAND IS A CONST.
! TRY VARIOUS POSSIBILITIES OF ELIMINATION BY COMBINATION
! CE15F:
%IF TRACE#0 %START
PRINTSTRING("NEITHER OPERAND IS CONST.");NEWLINE
%FINISH
%IF CTR_OP&BMBITOFF=SUB %START
%IF CTR_QOPD1=CTR_QOPD2 %AND CTR_OPD1=CTR_OPD2 %START
! N-N BECOMES 0
CTR_OP=(CTR_OP&BMBIT)!REPL
%IF CTR_QOPD1&TEXTMASK#0 %START
DELUSE(CTR_OPD1)
DELUSE(CTR_OPD2)
%FINISH
CTR_RES1_W=CONRES(0,CTR_MODE)
CTR_RES2=RNULL
%IF TRACE#0 %START
PRINTSTRING("N-N BECOMES 0");NEWLINE
PRINTSTRING("CURRTRIAD BECOMES");NEWLINE
PRINTTR(CURRTRIAD,ADICT,ANAMES,0,CTR)
PRINTSTRING("EXIT FROM CONELIM");NEWLINE
%FINISH
%RETURN
%FINISH
%FINISH; ! CTR_OP=SUB & OPD1=OPD2
!
! CE45:
%IF CTR_QOPD1&TEXTMASK=0 %START
%IF CTR_QOPD2&TEXTMASK=0 %THEN %RETURN; ! ID OP ID
! ID OP TRIAD - OP MUST BE SUB
TROPD2==RECORD(ATRIADS+CTR_OPD2*TRIADLENGTH)
%IF TRACE#0 %START
PRINTSTRING("ID OP TRIAD - OP MUST BE SUB")
NEWLINE
PRINTSTRING("TRIAD IS")
NEWLINE
PRINTTR(CTR_OPD2,ADICT,ANAMES,0,TROPD2)
%FINISH
%IF TROPD2_RES1_W=CTR_RES1_W %START
! LOOK FOR A CONSTANT IN THE SAME TRIAD, AND USE=1
OP2=CCHECK(CTR_OPD2,RES2)
%IF RES2_W=RNULL_W %THEN %START
%IF OP2=-1 %OR OP2=TABMULT %THEN %RETURN
%FINISH
%IF OP2#TABMULT %START
! CEI40:
! TROPD2_OP IS + OR -
! CASE A: ID - (ID+-ANY)
%IF TRACE#0 %START
PRINTSTRING("CASE A: ID - (ID+-ANY)")
NEWLINE
%FINISH
%IF OP2=TABADD %THEN OP1=NEG %ELSE OP1=REPL
RES=TROPD2_RES2
DELIND=CTR_OPD2
->CEI90
%FINISH
! OP2 IS MULT
! ID - (ID*CONST) WHERE (ID*CONST) IS USED ONLY ONCE
! GENERATE (ID*1-CONST)
RES1_W=CONRES(1,CTR_MODE)
OK=CONOP(RES1,SUB,RES2,RES)
%IF OK#0 %THEN %RETURN
DELIND=CTR_OPD2
CTR_RES2=RES
CTR_OP=(CTR_OP&BMBIT)!MULT
DELUSE(DELIND)
%IF TRACE#0 %START
PRINTSTRING("ID - (ID*1-CONST) BECOMES ID * (1-CONST)")
NEWLINE
PRINTSTRING("DELETE TRIAD")
WRITE(DELIND,1);NEWLINE
PRINTSTRING("CURRTRIAD BECOMES");NEWLINE
PRINTTR(CURRTRIAD,ADICT,ANAMES,0,CTR)
PRINTSTRING("START AGAIN");NEWLINE
%FINISH
->CE0
%FINISH %ELSESTART
!CEI20:
%IF TROPD2_RES2_W#CTR_RES1_W %THEN %RETURN
%IF TROPD2_OP&BMBITOFF#ADD %THEN %RETURN
! CASE B:ID - (ANY+ID)
%IF TRACE#0 %START
PRINTSTRING("CASE B: ID - (ANY+ID)")
NEWLINE
%FINISH
OP1=NEG
RES=TROPD2_RES1
DELIND=CTR_OPD2
->CEI90
%FINISH
%FINISH; ! OPD1 = ID
!
%IF CTR_QOPD2&TEXTMASK=0 %START
! TRIAD OP ID
! CE53:
%IF CTR_OP&BMBITOFF=MULT %THEN %RETURN
TROPD1==RECORD(ATRIADS+CTR_OPD1*TRIADLENGTH)
%IF TROPD1_RES1_W=CTR_RES2_W %START
%IF TRACE#0 %START
PRINTSTRING("TRIAD OP ID");NEWLINE
PRINTSTRING("TRIAD IS")
NEWLINE
PRINTTR(CTR_OPD1,ADICT,ANAMES,0,TROPD1)
%FINISH
! LOOK FOR A CONST. IN SAME TRIAD WITH USE=1
OP2=CCHECK(CTR_OPD1,RES1)
%IF RES1_W=RNULL_W %THEN %START
%IF OP2=-1 %OR OP2=TABMULT %THEN %RETURN
%FINISH
%IF OP2#TABMULT %START
! CEI60:
! TROPD1_OP IS + OR -
%IF CURROP#TABSUB %THEN %RETURN
! CASE C: (ID+-ANY) - ID
%IF TRACE#0 %START
PRINTSTRING("CASE C: (ID+-ANY) - ID")
NEWLINE
%FINISH
%IF OP2=TABADD %THEN OP1=REPL %ELSE OP1=NEG
RES=TROPD1_RES2
DELIND=CTR_OPD1
->CEI90
%FINISH
! (ID*CONST) +- ID
! (ID*CONST) IS USED ONLY ONCE
! GENERATE (ID*CONST+-1)
RES2_W=CONRES(1,CTR_MODE)
! ADD 1 TO OR SUBTRACT 1 FROM THE CONST
OK=CONOP(RES1,CTR_OP&BMBITOFF,RES2,RES)
%IF OK#0 %THEN %RETURN
DELIND=CTR_OPD1
CTR_RES1=CTR_RES2
CTR_RES2=RES
CTR_OP=(CTR_OP&BMBIT)!MULT
DELUSE(DELIND)
%IF TRACE#0 %START
PRINTSTRING("(ID*CONST) +- ID BECOMES ID * (CONST+-1)")
NEWLINE
PRINTSTRING("DELETE TRIAD ")
WRITE(DELIND,1)
PRINTSTRING("CURRTRIAD BECOMES");NEWLINE
PRINTTR(CURRTRIAD,ADICT,ANAMES,0,CTR)
PRINTSTRING("START AGAIN");NEWLINE
%FINISH
->CE0
%FINISH %ELSESTART
! CEI80:
%IF TROPD1_RES2_W#CTR_RES2_W %THEN %RETURN
%IF TROPD1_OP&BMBITOFF=ADD %START
%IF CTR_OP&BMBITOFF=ADD %THEN %RETURN
! CASE D: (ANY+ID) - ID
%IF TRACE#0 %START
PRINTSTRING("CASE D: (ANY+ID) - ID")
NEWLINE
%FINISH
%FINISH %ELSEIF TROPD1_OP&BMBITOFF=SUB %START
%IF CTR_OP&BMBITOFF#ADD %THEN %RETURN
! CASE E: (ANY-ID) + ID
%IF TRACE#0 %START
PRINTSTRING("CASE E: (ANY-ID) + ID")
NEWLINE
%FINISH
%FINISH %ELSE %RETURN
OP1=REPL
RES=TROPD1_RES1
DELIND=CTR_OPD1
CEI90:
! REPL/NEG IS IN OP1
! ANY IS IN RES
! INDEX OF TRIAD OPERAND IN DELIND
CTR_OP=(CTR_OP&BMBIT)!OP1
CTR_RES1=RES
CTR_RES2=RNULL
%IF CTR_QOPD1&TEXTMASK#0 %START
TROPD1==RECORD(ATRIADS+CTR_OPD1*TRIADLENGTH)
TROPD1_USE=TROPD1_USE+1
%FINISH
DELUSE(DELIND)
%IF TRACE#0 %START
PRINTSTRING("DELETE TRIAD ")
WRITE(DELIND,1);NEWLINE
PRINTSTRING("CURRTRIAD BECOMES");NEWLINE
PRINTTR(CURRTRIAD,ADICT,ANAMES,0,CTR)
PRINTSTRING("EXIT FROM CONELIM");NEWLINE
%FINISH
%RETURN
%FINISH
%FINISH; ! OPD2=ID
!
! CE60:
! BOTH OPERANDS ARE TRIADS
! OPTIMISATION IS POSSIBLE IF BOTH CONTAIN CONSTANTS
%IF TRACE#0 %START
PRINTSTRING("BOTH OPERANDS ARE TRIADS")
NEWLINE
%FINISH
OP1=CCHECK(CTR_OPD1,RES1)
%IF RES1_W=RNULL_W %THEN %RETURN
! CTR_OPD1 CONTAINS A CONSTANT
OP2=CCHECK(CTR_OPD2,RES2)
%IF RES2_W=RNULL_W %THEN %RETURN
! CTR_OPD2 CONTAINS A CONSTANT
TAB1IND=2*(CURROP+3*(OP2+4*OP1))
%IF TRACE#0 %START
PRINTSTRING("BOTH OPERANDS CONTAIN CONSTANTS")
NEWLINE
PRINTSTRING("CETAB1 INDEX IS")
WRITE(TAB1IND,1);NEWLINE
%FINISH
%IF CETAB1(TAB1IND)=0 %THEN %RETURN; ! NO ELIMINATION
TROPD1==RECORD(ATRIADS+CTR_OPD1*TRIADLENGTH)
TROPD2==RECORD(ATRIADS+CTR_OPD2*TRIADLENGTH)
%IF TRACE#0 %START
PRINTSTRING("TRIAD OPD1 -")
NEWLINE
PRINTTR(CTR_OPD1,ADICT,ANAMES,0,TROPD1)
PRINTSTRING("TRIAD OPD2 -")
NEWLINE
PRINTTR(CTR_OPD2,ADICT,ANAMES,0,TROPD2)
%FINISH
!
! SAVE OPD1 &OPD2 IN FST &SCND RESPECTIVELY
TRFST==TROPD1
FSTIND=CTR_OPD1
TRSCND==TROPD2
SCNDIND=CTR_OPD2
!
%IF TROPD1_OP&BMBIT#0 %THEN %START
%IF TROPD2_OP&BMBIT=0 %THEN ->CE70; ! OPD1 IS A LOOP CONST, OPD2 IS NOT
%FINISH %ELSESTART
%IF TROPD2_OP&BMBIT#0 %THEN ->CE68; ! OPD2 IS A LOOP CONST,OPD1 IS NOT
%FINISH
!
! BOTH OPERANDS ARE LOOP CONSTS., OR BOTH ARE NOT
! SCAN THE CHAIN TO FIND EARLIER TRIAD
CE64:
%IF TROPD2_CHAIN=CURRTRIAD %OR TROPD1_CHAIN=SCNDIND %THEN ->CE70
%IF TROPD2_CHAIN=FSTIND %OR TROPD1_CHAIN=CURRTRIAD %THEN ->CE68
TROPD1==RECORD(ATRIADS+TROPD1_CHAIN*TRIADLENGTH)
TROPD2==RECORD(ATRIADS+TROPD2_CHAIN*TRIADLENGTH)
->CE64
!
CE68:
%IF TRACE#0 %START
PRINTSTRING("EITHER OPD2 IS A LOOPCONST. AND OPD1 IS NOT, OR")
NEWLINE
PRINTSTRING("OPD2 IS THE EARLIER TRIAD")
NEWLINE
PRINTSTRING("CHANGE ORDER OF TWO TRIADS")
NEWLINE
%FINISH
!
! CHANGE FST & SCND ROUND
TROPD1==TRFST
DELIND=FSTIND
TRFST==TRSCND
FSTIND=SCNDIND
TRSCND==TROPD1
SCNDIND=DELIND
TAB1IND=TAB1IND+1
!
CE70:
TAB2IND=CETAB1(TAB1IND)-1
!
CENEXT:
TAB2IND=TAB2IND+1
%IF TRACE#0 %START
PRINTSTRING("CETAB2 INDEX IS")
WRITE(TAB2IND,1);NEWLINE
PRINTSTRING("GOT TO ACTION")
WRITE(CETAB2(TAB2IND),1);NEWLINE
%FINISH
->ACT(CETAB2(TAB2IND))
!
ACT(0):%RETURN
!
ACT(1):
OK=CONOP(RES1,ADD,RES2,RES); ! CON1+CON2
%IF OK#0 %THEN %RETURN
->CENEXT
!
ACT(2):
%IF MODETYPE(CTR_MODE)#REALTYPE %THEN ->CENEXT
%IF TRFST_OP&BMBITOFF#SUB %THEN ->CENEXT
! MINUS REAL CONST. BECOMES PLUS REAL CONST.
OK=CONOP(RNULL,NEG,RES,RES); ! NEGATE RES
%IF OK#0 %THEN %RETURN
TRFST_OP=(TRFST_OP&BMBIT)!ADD; ! MINUS BECOMES PLUS
->CENEXT
!
ACT(3):
->CENEXT
!
ACT(4):
TRFST_RES2=RES
->CENEXT
!
ACT(5):
CTR_RES2=TRSCND_RES1
->CENEXT
!
ACT(6):
DELUSEX(SCNDIND)
%IF TRACE#0 %START
PRINTSTRING("ACTION 6 - DELETE TRIAD")
WRITE(SCNDIND,1);NEWLINE
PRINTSTRING("CURRTRIAD BECOMES");NEWLINE
PRINTTR(CURRTRIAD,ADICT,ANAMES,0,CTR)
PRINTSTRING("TRFST BECOMES")
NEWLINE
PRINTTR(FSTIND,ADICT,ANAMES,0,TRFST)
PRINTSTRING("START AGAIN");NEWLINE
%FINISH
->CE0
!
ACT(7):
CTR_RES1=CTR_RES2
->CENEXT
!
ACT(8):
OK=CONOP(RES1,SUB,RES2,RES); ! CON1-CON2
%IF OK#0 %THEN %RETURN
->CENEXT
!
ACT(9):
OK=CONOP(RES2,SUB,RES1,RES); ! CON2-CON1
->CENEXT
!
ACT(10):
CTR_RES1=TRSCND_RES1
->CENEXT
!
ACT(11):
CTR_RES2=TRSCND_RES2
->CENEXT
!
ACT(12):
CTR_OP=(CTR_OP&BMBIT)!SUB
->CENEXT
!
ACT(13):
TRFST_RES1=RES
->CENEXT
!
ACT(14):
CTR_OP=(CTR_OP&BMBIT)!ADD
->CENEXT
!
ACT(15):
OK=CONOP(RES1,MULT,RES2,RES)
%IF OK#0 %THEN %RETURN
->CENEXT
!
ACT(16):
TRFST_RES2=TRFST_RES1
->CENEXT
!
ACT(17):
TRFST_OP=(TRFST_OP&BMBIT)!SUB
->CENEXT
!
ACT(18):
CTR_OP=(CTR_OP&BMBIT)!REPL
CTR_RES2=0
%IF TRACE#0 %START
PRINTSTRING("ACTION 18 - CURRTRIAD BECOMES")
NEWLINE
PRINTTR(CURRTRIAD,ADICT,ANAMES,0,CTR)
PRINTSTRING("TRFST BECOMES")
NEWLINE
PRINTTR(FSTIND,ADICT,ANAMES,0,TRFST)
%FINISH
%RETURN
!
ACT(19):
TRFST_RES2=CTR_RES2
OP1=TRFST_OP&BMBITOFF
TRFST_OP=CTR_OP&BMBITOFF
CTR_OP=OP1
->CENEXT
!
ACT(20):
CTR_RES2=RES
%IF TRACE#0 %START
PRINTSTRING("CURRTRIAD BECOMES");NEWLINE
PRINTTR(CURRTRIAD,ADICT,ANAMES,0,CTR)
PRINTSTRING("TRFST BECOMES")
NEWLINE
PRINTTR(FSTIND,ADICT,ANAMES,0,TRFST)
PRINTSTRING("START AGAIN");NEWLINE
%FINISH
->CE0
!
ACT(21):
CTR_RES2=CTR_RES1
CTR_RES1=RES
%IF TRACE#0 %START
PRINTSTRING("CURRTRIAD BECOMES");NEWLINE
PRINTTR(CURRTRIAD,ADICT,ANAMES,0,CTR)
PRINTSTRING("TRFST BECOMES")
NEWLINE
PRINTTR(FSTIND,ADICT,ANAMES,0,TRFST)
PRINTSTRING("START AGAIN");NEWLINE
%FINISH
->CE0
!
ACT(22):
TRFST_RES1=TRFST_RES2
->CENEXT
!
ACT(23):
TRFST_OP=(TRFST_OP&BMBIT)!ADD
->CENEXT
!
ACT(24):
%IF TRFST_RES1_W#TRSCND_RES1_W %THEN %RETURN
CTR_RES1=TRFST_RES1
CTR_RES2=RES
CTR_OP=(CTR_OP&BMBIT)!MULT
DELUSEX(FSTIND)
DELUSE(SCNDIND)
%IF TRACE#0 %START
PRINTSTRING("DELETE TRIAD")
WRITE(FSTIND,1);NEWLINE
PRINTSTRING("DELETE TRIAD")
WRITE(SCNDIND,1);NEWLINE
PRINTSTRING("CURRTRIAD BECOMES");NEWLINE
PRINTTR(CURRTRIAD,ADICT,ANAMES,0,CTR)
PRINTSTRING("START AGAIN")
%FINISH
->CE0
!
%END; ! CONELIM
!
%EXTERNALROUTINE FACTORISE
! ATTEMPT FACTORIASTION OF EXPRESSIONS
%RECORD(TRIADF)%NAME CTR,TRFST,TRSCND,TRTMP
%RECORD(RESF) RES
%INTEGER COP,FSTIND,SCNDIND,IND
!
CTR==RECORD(ATRIADS+CURRTRIAD*TRIADLENGTH)
COP=CTR_OP&BMBITOFF
%IF COP#ADD %AND COP#SUB %THEN %RETURN
%IF CTR_QOPD1&TEXTMASK=0 %OR CTR_QOPD2&TEXTMASK=0 %THEN %RETURN
! OPERANDS ARE BOTH TRIADS
%IF TRACE#0 %START
PRINTSTRING("ATTEMPT FACTORISATION OF EXPRESSION - CURRTRIAD IS")
WRITE(CURRTRIAD,1);NEWLINE
PRINTTR(CURRTRIAD,ADICT,ANAMES,0,CTR)
%FINISH
%IF CTR_RES1_W=CTR_RES2_W %THEN %RETURN
TRSCND==RECORD(ATRIADS+CTR_OPD1*TRIADLENGTH)
SCNDIND=CTR_OPD1
%IF TRSCND_OP&BMBITOFF#MULT %OR TRSCND_USE#1 %THEN %RETURN
TRFST==RECORD(ATRIADS+CTR_OPD2*TRIADLENGTH)
FSTIND=CTR_OPD2
%IF TRFST_OP&BMBITOFF#MULT %OR TRFST_USE#1 %THEN %RETURN
! BOTH OPERANDS HAVE OP=* AND USE=1
%IF TRFST_OP&BMBIT#0 %START
! TRFST IS A LOOP CONSTANT
%IF TRSCND_OP&BMBIT=0 %START
! TRSCND IS NOT A LOOP CONSTANT - SWAP FST & SCND
%IF TRACE#0 %START
PRINTSTRING("SWAP TRFST AND TRSCND");NEWLINE
%FINISH
IND=FSTIND
TRTMP==TRFST
FSTIND=SCNDIND
TRFST==TRSCND
SCNDIND=IND
TRSCND==TRTMP
%FINISH
%FINISH
!
! FSTIND POINTS TO THE TRIAD WHICH IS TO BE MANIPULATED
! SCNDIND POINTS TO THE TRIAD WHICH WILL DISAPPEAR IF A COMMON
! OPERAND IS FOUND, PERMITTING FACTORISATION
%IF TRACE#0 %START
PRINTSTRING("TRFST HAS INDEX")
WRITE(FSTIND,1);NEWLINE
PRINTTR(FSTIND,ADICT,ANAMES,0,TRFST)
PRINTSTRING("TRSCND HAS INDEX")
WRITE(SCNDIND,1);NEWLINE
PRINTTR(SCNDIND,ADICT,ANAMES,0,TRSCND)
%FINISH
%IF TRSCND_RES2_W#TRFST_RES2_W %START
%IF TRSCND_RES1_W#TRFST_RES1_W %START
%IF TRFST_RES2_W#TRSCND_RES1_W %START
%IF TRFST_RES1_W#TRSCND_RES2_W %THEN %RETURN
RES=TRFST_RES1
TRFST_RES1=TRFST_RES2
TRFST_RES2=RES
->FAC50
%FINISH
%FINISH %ELSE %START
! FAC20
RES=TRFST_RES1
TRFST_RES1=TRFST_RES2
TRFST_RES2=RES
%FINISH
! FAC30
RES=TRSCND_RES1
TRSCND_RES1=TRSCND_RES2
TRSCND_RES2=RES
%FINISH; ! TRSCND_RES2=TRFST_RES2
!
FAC50:
TRSCND_OP=NULL
CTR_RES2_W=TRSCND_RES2_W
TRFST_RES2_W=TRSCND_RES1_W
CTR_OP=(CTR_OP&BMBIT)!MULT; ! TRFST_OP IS *
TRFST_OP=(TRFST_OP&BMBIT)!COP
%IF FSTIND#CTR_OPD1 %START
RES=TRFST_RES1
TRFST_RES1=TRFST_RES2
TRFST_RES2=RES
%FINISH
!
!FAC60:
TREVERSE(FSTIND)
%IF TRACE#0 %START
PRINTSTRING("TRFST HAS INDEX")
WRITE(FSTIND,1);NEWLINE
PRINTTR(FSTIND,ADICT,ANAMES,0,TRFST)
PRINTSTRING("TRSCND HAS INDEX")
WRITE(SCNDIND,1);NEWLINE
PRINTTR(SCNDIND,ADICT,ANAMES,0,TRSCND)
%FINISH
CTR_OPD1=FSTIND
%IF CTR_QOPD2&TEXTMASK#0 %START
! THE COMMON FACTOR WAS A TRIAD, DELETE ITS USE COUNT
%IF TRACE#0 %START
PRINTSTRING("THE COMMON FACTOR WAS A TRIAD, INDEX")
WRITE(CTR_OPD2,1)
PRINTSTRING(" - DELETE ITS USE COUNT");NEWLINE
%FINISH
DELUSE(CTR_OPD2)
TREVERSE(CURRTRIAD)
%FINISH
%IF TRACE#0 %START
PRINTSTRING("CURRTRIAD BECOMES");NEWLINE
PRINTTR(CURRTRIAD,ADICT,ANAMES,0,CTR)
PRINTSTRING("EXIT FROM FACTORISE");NEWLINE
%FINISH
!
%END; ! FACTORISE
!
%EXTERNALROUTINE LINEARISE
! ATTEMPT LINEARISATION OF EXPRESSIONS
! MULT,SUB & ADD TRIADS
%RECORD(TRIADF)%NAME CTR,TRFST,TRSCND,TRTMP
%RECORD(BLRECF)%NAME CBL
%INTEGER FSTIND,SCNDIND,IND,TLSIGN,OK
!
%INTEGERFUNCTION LINCHTRIADS(%INTEGER IND)
! CHECK FOR TRIAD OPERANDS IN THE TRIAD WITH INDEX IND
! POINTERS TO ARR OR BACKWARD MOVED TRIADS ARE EXCEPTED
! RETURNS 1 IF TRIAD OPERANDS ELSE 0
%RECORD(TRIADF)%NAME TR,TROPD
!
TR==RECORD(ATRIADS+IND*TRIADLENGTH)
%IF TR_QOPD1&TEXTMASK#0 %START
TROPD==RECORD(ATRIADS+TR_OPD1*TRIADLENGTH)
%IF TROPD_OP&BMBITOFF# ARR %AND TROPD_OP&BMBIT=0 %THEN %C
%RESULT=1; ! OPD1 IS A TRIAD
%FINISH
%IF TR_QOPD2&TEXTMASK=0 %THEN %RESULT=0
TROPD==RECORD(ATRIADS+TR_OPD2*TRIADLENGTH)
%IF TROPD_OP&BMBITOFF=ARR %OR TROPD_OP&BMBIT#0 %THEN %RESULT=0
%RESULT=1
%END; ! LINCHTRIADS
!
%INTEGERFUNCTION LINEAROP(%INTEGER IND)
! RECOGNISE VALID COMBINATIONS OF OPERATORS FOR LINEARISATION
! RETURNS 1 IF VALID, ELSE 0
%RECORD(TRIADF)%NAME TR
%INTEGER OP,COP
!
TR==RECORD(ATRIADS+IND*TRIADLENGTH)
OP=TR_OP&BMBITOFF
COP=CTR_OP&BMBITOFF
%IF OP#ADD %AND OP#SUB %START
%IF OP#MULT %OR OP#COP %THEN %RESULT=0
TLSIGN=MULT
%FINISH %ELSE %START
! LRP20:
%IF COP=OP %THEN TLSIGN=ADD %ELSE %START
!LRP30:
%IF COP=MULT %THEN %RESULT=0
TLSIGN=SUB
%FINISH
%FINISH
%RESULT=1
%END; ! LINEAROP
!
CTR==RECORD(ATRIADS+CURRTRIAD*TRIADLENGTH)
%IF CTR_QOPD2&TEXTMASK=0 %OR CTR_QOPD1&TEXTMASK=0 %THEN %RETURN
%IF CTR_RES1_W=CTR_RES2_W %THEN %RETURN
TRSCND==RECORD(ATRIADS+CTR_OPD2*TRIADLENGTH)
%IF TRSCND_OP&BMBITOFF=ARR %OR TRSCND_OP&BMBIT#0 %THEN %RETURN
TRFST==RECORD(ATRIADS+CTR_OPD1*TRIADLENGTH)
%IF TRFST_OP&BMBITOFF=ARR %OR TRFST_OP&BMBIT#0 %THEN %RETURN
%IF TRACE#0 %START
PRINTSTRING("LINEARISATION OF EXPRESSIONS - CURRTRIAD INDEX=")
WRITE(CURRTRIAD,1);NEWLINE
PRINTTR(CURRTRIAD,ADICT,ANAMES,0,CTR)
PRINTSTRING("OPD1 POINT TO TRIAD WITH INDEX(FSTIND)")
WRITE(CTR_OPD1,1);NEWLINE
PRINTTR(CTR_OPD1,ADICT,ANAMES,0,TRFST)
PRINTSTRING("OPD2 POINTS TO TRIAD WITH INDEX(SCNDIND)")
WRITE(CTR_OPD2,1);NEWLINE
PRINTTR(CTR_OPD2,ADICT,ANAMES,0,TRSCND)
PRINTSTRING("NOW TEST IF ONE OF THE TRIADS CAN BE LINEARISED")
NEWLINE
%FINISH
!
! NOW TEST IF ONE OF THE TRIADS CAN BE LINEARISED
FSTIND=CTR_OPD1
SCNDIND=CTR_OPD2
OK=LINCHTRIADS(FSTIND)
%IF OK=1 %START
! OPD1 CONTAINS A TRIAD
OK=LINCHTRIADS(SCNDIND)
%IF OK=1 %THEN %RETURN
%FINISH %ELSESTART
!LIN10:
OK=LINCHTRIADS(SCNDIND)
%IF OK=0 %START
!LIN20:
OK=LINEAROP(FSTIND)
%IF OK=1 %THEN SCNDIND=FSTIND %AND ->LIN40
%FINISH %ELSE SCNDIND=FSTIND
%FINISH
!LIN30:
OK=LINEAROP(SCNDIND)
%IF OK=0 %THEN%RETURN
LIN40:
%IF SCNDIND#CTR_OPD2 %START
! SWAP FST AND SCND
%IF TRACE#0 %START
PRINTSTRING("SWAP FSTIND & SCNDIND");NEWLINE
%FINISH
FSTIND=CTR_OPD2
TRTMP==TRFST
TRFST==TRSCND
TRSCND==TRTMP
%FINISH
%IF TRSCND_USE#1 %THEN %RETURN
!
! LIN50:
! CHECK THAT TRFST PRECEDES TRSCNDN SINCE TRSCND IS
! GOING TO POINT OT TRFST AFTER LINEARISATION
%IF TRACE#0 %START
PRINTSTRING("CHECK THAT TRFST PRECEDES TRSCND");NEWLINE
%FINISH
CBL==RECORD(ABLOCKS+CURRBLK*BLSIZE)
IND=CBL_TEXT
!
LIN60:
TRTMP==RECORD(ATRIADS+IND*TRIADLENGTH)
IND=TRTMP_CHAIN
%IF IND#SCNDIND %START
%IF IND#FSTIND %THEN ->LIN60
%FINISH %ELSESTART
! LIN70: TRTMP_CHAIN=SCNDIND
! NECESSARY TO RECHAIN TRFST & TRSCNDN
! WILL THIS HAVE ANY SIDE-EFFECTS?
%IF TRACE#0 %START
PRINTSTRING("RECHAIN TRFST & TRSCND");NEWLINE
%FINISH
TRTMP_CHAIN=TRSCND_CHAIN
TRSCND_CHAIN=TRFST_CHAIN
TRFST_CHAIN=SCNDIND
%FINISH
!
!LIN80:
%IF CTR_OPD1=SCNDIND %START
CTR_RES2_W=CTR_RES1_W
CTR_RES1_W=TRSCND_RES1_W
%FINISH %ELSESTART
CTR_RES1_W=CTR_RES2_W
CTR_RES2_W=TRSCND_RES1_W
%FINISH
!
!LIN87:
! OPERANDS HAVE NOW BEEN JUGGLED TO GET ALINEAR SEQUENCE
TREVERSE(CURRTRIAD)
TRSCND_OP=TLSIGN; ! SET NEW SIGN IN THE LINEARISED TRIAD
TRSCND_OPD1=FSTIND
TRSCND_QOPD1=TRIAD
TREVERSE(SCNDIND)
%IF TRACE#0 %START
PRINTSTRING("CURRTRIAD BECOMES");NEWLINE
PRINTTR(CURRTRIAD,ADICT,ANAMES,0,CTR)
PRINTSTRING("TRFST BECOMES");NEWLINE
PRINTTR(FSTIND,ADICT,ANAMES,0,TRFST)
PRINTSTRING("TRSCND BECOMES");NEWLINE
PRINTTR(SCNDIND,ADICT,ANAMES,0,TRSCND)
PRINTSTRING("EXIT FROM LINEARISE");NEWLINE
%FINISH
!
%END; ! LINEARISE
!
%EXTERNALROUTINE OPTCVT
! OPTIMISE THE CVT TRIAD
%RECORD(TRIADF)%NAME CTR,TROPD
%INTEGER OK
%RECORD(RESF) RES
!
CTR==RECORD(ATRIADS+CURRTRIAD*TRIADLENGTH)
%IF TRACE#0 %START
PRINTSTRING("OPTIMISE THE CVT TRIAD, INDEX")
WRITE(CURRTRIAD,1);NEWLINE
PRINTTR(CURRTRIAD,ADICT,ANAMES,0,CTR)
%FINISH
%IF CTR_QOPD2&CONSTMASK#0 %START
! OPD2 IS CONSTANT, CONVERT IF COMPLEX NOT INVOLVED
%IF MODETYPE(CTR_MODE)=CMPLXTYPE %OR MODETYPE(CTR_MODE2)=CMPLXTYPE %C
%THEN %RETURN
%IF CTR_MODE=INT2 %THEN %RETURN; ! REJECT TARGET INT*2
RES=CTR_RES2
OK=CONVERTMODE(RES,CTR_MODE)
%IF OK#0 %THEN %RETURN; ! REJECT SOURCE INT*2
CTR_RES1=RES
->SETREPL
%FINISH
!
%IF CTR_QOPD2&TEXTMASK=0 %THEN %RETURN
!OPD2 IS ATRIAD
TROPD==RECORD(ATRIADS+CTR_OPD2*TRIADLENGTH)
%IF TRACE#0 %START
PRINTSTRING("OPD2 IS A TRIAD, INDEX")
WRITE(CTR_OPD2,1);NEWLINE
PRINTTR(CTR_OPD2,ADICT,ANAMES,0,TROPD)
%FINISH
%RETURN;! TEMPORARY !!!!!!!!
!%IF MODETYPE(CTR_MODE)#INTTYPE %START
! LCCN86
! LOOK FOR (R4*R4)->R8 & GENERATE DMULT
! %IF CTR_MODE#REAL8 %THEN %RETURN
! %IF CTR_MODE2#REAL4 %THEN %RETURN
!%FINISH %ELSESTART
! LCCN87
! LOOK FOR (I4*I4)->I8 &GENERATE DMULT
! %IF CTR_MODE#INT8 %THEN %RETURN
! %IF CTR_MODE2#INT4 %THEN %RETURN
!%FINISH
!
! LCCN88
!%IF TROPD_USE#1 %OR TROPD_OP&BMBITOFF#MULT %THEN %RETURN
!TROPD_OP=(TROPD_OP&BMBIT)!DMULT
!%IF TRACE#0 %START
! PRINTSTRING("OPD2 TRIAD BECOMES");! NEWLINE
! PRINTTR(CTR_OPD2,ADICT,ANAMES,0,TROPD)
!%FINISH
!CTR_OPD1=CTR_OPD2
!CTR_QOPD1=CTR_QOPD2
!CTR_RES2=RNULL
SETREPL:
CTR_OP=(CTR_OP&BMBIT)!REPL
%IF TRACE#0 %START
PRINTSTRING("CURRTRIAD BECOMES");NEWLINE
PRINTTR(CURRTRIAD,ADICT,ANAMES,0,CTR)
%FINISH
!
%END; ! OPTCVT
!
%EXTERNALROUTINE OPTEXP
! EXPONENTIATE OPTIMISATION
%RECORD(TRIADF)%NAME CTR
%INTEGER CVAL,OK
%RECORD(RESF) RES,PWRRES,RES2
!
! GRECIP=0
!
CTR==RECORD(ATRIADS+CURRTRIAD*TRIADLENGTH)
%IF MODETYPE(CTR_MODE)=CMPLXTYPE %OR MODETYPE(CTR_MODE2)=CMPLXTYPE %C
%THEN %RETURN
%IF TRACE#0 %START
PRINTSTRING("EXPONENTIATE OPTIMISATION - CURRTRIAD INDEX,")
WRITE( CURRTRIAD,1);NEWLINE
PRINTTR(CURRTRIAD,ADICT,ANAMES,0,CTR)
%FINISH
%IF CTR_QOPD1&CONSTMASK#0 %START
! BASE IS CONSTANT
! CHECK FOR 0 OR 1
%IF TRACE#0 %START
PRINTSTRING("BASE IS CONSTANT");NEWLINE
%FINISH
CVAL=CONCHECK(CTR_RES1)
%IF CVAL=0 %OR CVAL=1 %START
! 0**ANY BECOMES 0, 1**ANY BECOMES 1
%IF TRACE#0 %START
PRINTSTRING("BASE IS 0 OR 1");NEWLINE
%FINISH
%IF CTR_QOPD2&TEXTMASK#0 %THEN DELUSE(CTR_OPD2)
->SETREPL
%FINISH; ! BASE IS 0 OR 1
%IF CVAL=-1 %START
! LEXP20
! BASE IS -1
%IF MODETYPE(CTR_MODE)=INTTYPE %START
CTR_OP=(CTR_OP&BMBIT)!EXP3
%RETURN
%FINISH
%FINISH; ! BASE IS -1
!
!
! IF INTEGER CONST.** ANY IN I4 MODE
! GET CONST. VALUE & CHECK FOR POWER OF 2
! SEE LISTING @ LEXP15-LEXP20, LEXP25-LEXP39
!
!
%FINISH; ! QOPD1 IS A CONTANT
!
! LEXP40:
%IF CTR_QOPD2&CONSTMASK#0 %START
! QOPD2 IS A CONSTANT
%IF TRACE#0 %START
PRINTSTRING("POWER IS CONSTANT");NEWLINE
%FINISH
CVAL=CONCHECK(CTR_RES2)
%IF CVAL=0 %START
! ANY ** 0 BECOMES 1
! GENERATE 1 OF MODE CTR_MODE
%IF TRACE#0 %START
PRINTSTRING("POWER IS 0 - ANY**0 BECOMES 1");NEWLINE
%FINISH
%IF CTR_QOPD1&TEXTMASK#0 %THEN DELUSE(CTR_OPD1)
CTR_RES1_W=CONRES(1,CTR_MODE)
->SETREPL
%FINISH
%IF CVAL=1 %START
! LEXP77
%IF TRACE#0 %START
PRINTSTRING("POWER IS 1");NEWLINE
%FINISH
->SETREPL
%FINISH
%IF CVAL=-1 %START
! POWER IS -1, A**-1 BECOMES 1/A
%IF TRACE#0 %START
PRINTSTRING("POWER IS -1 - ANY**-1 BECOMES 1/ANY")
NEWLINE
%FINISH
CTR_RES2=CTR_RES1
CTR_RES1_W=CONRES(1,CTR_MODE)
CTR_OP=(CTR_OP&BMBIT)!DIV
->OUT1
%FINISH
%IF CVAL=2 %AND MODETYPE(CTR_MODE2)=REALTYPE %THEN %C
CTR_RES2_W=CONRES(2,INT4)
!
! LEXP50:
! IF POWER IS NEGATIVE CHANGE TO POSITIVE & SET
! GRECIP TO TRIGGER GENERATION OF 1/EXP AT END
!
!
%IF MODETYPE(CTR_MODE2)=INTTYPE %START
! LEXP53:
! INTEGER CONST. POWER - BASE**INT.CONST.
%IF CTR_QOPD1&CONSTMASK#0 %START
! BASE ALSO CONSTANT - EVALUATE
%IF CVAL<0 %START
! POWER IS NEGATIVE, CHANGE TO POSITIVE
%IF TRACE#0 %START
PRINTSTRING("POWER IS NEGATIVE, CHANGE TO POSITIVE")
NEWLINE
%FINISH
OK=CONOP(RNULL,NEG,CTR_RES2,PWRRES)
%IF OK#0 %THEN %RETURN
%FINISH %ELSE PWRRES=CTR_RES2
OK=CONOP(CTR_RES1,CTR_OP&BMBITOFF,PWRRES,RES)
%IF OK#0 %THEN %RETURN
%IF CVAL<0 %START
! ORIGINAL POWER WAS NEGATIVE - GENERATE 1/CONST.
%IF TRACE#0 %START
PRINTSTRING("ORIGINAL POWER WAS NEGATIVE - GENERATE 1/CONST")
NEWLINE
%FINISH
RES2_W=CONRES(1,RES_MODE)
OK=CONOP(RES2,DIV,RES,RES)
%IF OK#0 %THEN %RETURN
%FINISH
CTR_RES1=RES
SETREPL:
CTR_RES2=RNULL
CTR_OP=(CTR_OP&BMBIT)!REPL
OUT1:
%IF TRACE#0 %START
PRINTSTRING("CURRTRIAD BECOMES");NEWLINE
PRINTTR(CURRTRIAD,ADICT,ANAMES,0,CTR)
%FINISH
->EXIT1
%FINISH; ! BOTH OPDS. ARE CONSTANT
!
!
! IF NUMBER OF MULTIPLICATIONS REQUIRED TO PERFORM EXPONENTIATION IS
! <=8, THEN GENERATE NECESSARY MULTS. - LISTING @ LEXP60-LEXP80
! & IF ORIGINAL PWER WAS NEGATIVE, GENERATE RECIPROCATION -
! LISTING @LEXPREP2
!
!
->EXIT1
%FINISH
! LEXP80:
! BASE ** REAL CONST.
!
!
! IF REAL CONSTANT IS INTEGRAL, CONVERT TO INT4 MODE,
! TEST NUMBER OF MULTS. REQUIRED (LISTING @ LEXP80-LEXP88) & IF <= 8
! GENEARATE NECESSARY MULTS. & CONTINUE AS FOR INT. CONST. POWER(LEXP61)
!
!
! LEXP90:
! BASE**REAL CONST. NOT SUITABLE FOR IN-LINE EXPANSION
!
!
! GENERATE EXP1 OR EXP2 IN PLACE OF EXP & %RETURN
!
!
! LEXP100:
! REAL **REAL CONST.
!
!
! IF POWER=0.5 GENERATE SQRT(BASE)& %RETURN
! OTHERWISE ->LEXP150
!
!
%FINISH; ! QOPD2 IS CONST.
!
!LEXP110:
! NEITHER BASE NOR POWER IS CONSTANT
!
!
! IF MODE IS INTEGER %RETURN
! LOOK FOR REAL**CVT(INT) & CHANGE TO REAL**INT
!
!
!LEXP150:
!
!
! A**B BECOMES EXP(B*LOG(A)))
! GENEARATE RECIPROCATION IF ORIGINAL POWER NEGATIVE
!
!
EXIT1:
%IF TRACE#0 %START
PRINTSTRING("EXIT FROM OPTEXP");NEWLINE
%FINISH
%RETURN
!
%END; ! OPTEXP
!
%EXTERNALROUTINE OPTFUN
! REPLACE SINGLE OR DOUBLE PRECISION CALLS OF BASIC FNS BY MOO
!
%CONSTBYTEINTEGERARRAY MMLTYPE(0:11)=
0,1, 3, 2, 0,4, 5, 6, 0,0,0,7
! {SQRT EXP LOG SIN COS TAN ATAN}
%RECORD(TRIADF)%NAME TR
%RECORD(PRECF)%NAME FN
%INTEGER I,J
!
%UNLESS TARGET=ICL2900 %THEN %RETURN
TR==RECORD(ATRIADS+CURRTRIAD*TRIADLENGTH)
FN==RECORD(ADICT+TR_OPD1<<DSCALE)
%UNLESS FN_X0&3=1 %THEN %RETURN; ! ONLY STANDARD FN. CALLS
I=FN_LINK2; ! FN DETAILS
%UNLESS REAL4<=(I>>20)&X'F'<=REAL8 %THEN %RETURN; ! ONLY REAL*4 & REAL*8
I=I>>24; ! FN INDEX
%UNLESS 1<=I<=11 %THEN %RETURN
J=MMLTYPE(I)
%IF J=0 %THEN %RETURN
%IF TR_MODE=REAL8 %THEN J=J+8
TR_QOPD1=LIT
TR_OPD1=J
TR_OP=MOO
%END; ! OPTFUN
!
%EXTERNALROUTINE FLOWOFCONT
%END
!
%ENDOFFILE