!                                                      f3opt2
!05/08/87 - insert test for cmplx, line 2677 of PRESVAL
!                                                                    f3opt1
! 07/12/86 - insert include files
!          - don't allocate breg if Numoptregs=0
!                                                                    ftn3opt8
! 13/11/86 - leave int2 srtemps as int2 rather than force int4
!                                                                    ftn3opt7
! 12/11/86 - in Strength allow int2 as well as int4
!                                                                    ftn3opt6
! 09/11/86 - Opnd to take no action for char items
! 07/11/86 - use ftn_consts4 - srscale=4
!                                                                    ftn3opt5
! 16/08/86 - unmask actions of Replace and Desc
! 17/08/86 - in Desc delete >>1 of complex scale factor
! 22/08/86 - if Gould set Scale=1 in Desc (scaling incorporated in Gen)
!                                                                    ftn3opt4
! 08/07/86 - set mode LOG4 for comparison vts
! 13/06/86 - avoid CRENT on array triads
! 09/06/86 - suppress irrelevant '2900' optimisations
! 26/02/86 - set OPCAT for CHIND to 21 so that contents of Breg are preserved
! 09/12/85 - taken from op3b45, new include files incorporated,
!            remove include of targ_arrtr
! 29/11/84 - set Opcat for PAUSE to 21
! 24/10/84 - line 2345, also test for OP=MOO
!          - line 2785, scaling factor corrected to SRSCALE
! 23/10/84 - call ADDCODE at line 1153
! 02/10/84 - remove error message at PASS1(0) & PASS2(0)
! 05/07/84 - put routine ARRTR in include file targ_arrtr
! 06/06/84 - extend array OPCAT for INTRIN & DCMPLX
! 05/06/84 - do not optimise arrays with constant subscripts (ARRTR)
! 13/03/84 - correct TYPES and LENGTHS in routine DESC
! 19/01/84 - CTSIZE & EXTNSIZE NOW IN HOST
! 18/01/84 - BLOCK BIT STRIP ADDRESSES ARE NOW RELATIVE TO ABLOCKS
! 07/11/83 COPIED FROM ERCS06.REL8002_OP3B23
!*
%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
!*
%routine Copy(%integer Length,Fbase,Fdisp,Tbase,Tdisp)
!***********************************************************************
!* copy Length bytes from fbase(fdisp) to tbase(tdisp)                 *
!***********************************************************************
%integer I,From,To
      %if Length<=0 %then %return
      From=Fbase+Fdisp
      To=Tbase+Tdisp
      %cycle I=0,1,Length-1
         byteinteger(To+I)=byteinteger(From+I)
      %repeat
%end;! Copy
!*
!
!
!
!
%INTEGERFUNCTIONSPEC CREATETE (%INTEGER M)
%INTEGERFUNCTIONSPEC CREATEDT (%INTEGER M)
%INTEGERFUNCTIONSPEC ARBASE (%RECORD (RESF) OPD)
%INTEGERFUNCTIONSPEC CHAFTER (%INTEGER TR)
%ROUTINESPEC ELIM (%INTEGER TR)
%ROUTINESPEC TEXTPASS (%INTEGER BREG)
!
!
!
%owninteger Bregmode=1
!
%EXTERNALROUTINE OP3
!
!
!
%ROUTINESPEC LOOPSEL (%INTEGER L)
%ROUTINESPEC LOOPBUILD
%ROUTINESPEC COMMTEMPS
%INTEGERFUNCTIONSPEC STRENGTH
%ROUTINESPEC REPLACE (%INTEGER S)
%ROUTINESPEC BTEMPREP (%INTEGER MAX)
%ROUTINESPEC VALUE (%INTEGER S)
%ROUTINESPEC DESC (%INTEGER S)
%ROUTINESPEC PRINTSR
%ROUTINESPEC PRINTTE
%ROUTINESPEC PRINTDT
!
!
%OWNINTEGERARRAYFORMAT TABF (0:1000)
%INTEGERARRAYNAME ENTBTAB
%RECORD (CLOOPRECF) %NAME CL
%RECORD (BLRECF) %NAME BB
%RECORD (LOOPRECF) %NAME LO
%RECORD (CONRECF) %NAME CN
%RECORD (TRIADF) %NAME TT
%RECORD (SREDF) %NAME SR
!
%CONSTINTEGER INFIN = X'80000001'
!
%INTEGER I,SAVEPTR,DLOOPCH,BCOORD,CLOOPPTR,BREGTEMP,ADDTRIAD
%INTEGER TEMAXCOORD,COORDMAX,BACKTARG
!
!**********************************************************************
!* OP3 CONTROL.                                                       *
!*   BUILD AND PROCESS ALL LOOPS, STARTING AT INNERMOST.              *
!**********************************************************************
!
      %IF SRFLAGS & 16 # 0 %THEN PRINTSR
      COORDMAX = BSWORDS << 5
      TEINDEX = 1
      DTINDEX = 1
      VALTEMPHEAD = 0
      DESTEMPHEAD = 0
      TECH = ADDR (VALTEMPHEAD)
      DTCH = ADDR (DESTEMPHEAD)
      BCOORD = BSBITS
      TEMAXCOORD = BCOORD
!* PROCESS TEXT FROM INNERMOST LOOPS OUTWARDS.
      %UNLESS FREELOOPS = 0 %THEN LOOPSEL (0)
!* NOW PROCESS ENTRY-LEVEL BLOCKS.
      SAVEPTR = FREETABS
      ENTBTAB == ARRAY (ATABS + ENTBPTR,TABF)
      DLOOPCH = ADDR (DLOOPHEAD)
      DLOOPHEAD = 0
      DLOOPTAIL = 0
      %FOR I = 1,1,ENTBTAB(0) %CYCLE
         CLOOPTAIL = CREATETAB (CLOOPSZ)
         CL == RECORD (ATABS + CLOOPTAIL)
         CL_BLOCK = ENTBTAB (I)
         INTEGER (DLOOPCH) = CLOOPTAIL
         CL_PDCHAIN = 0
         DLOOPCH = ADDR (CL_PDCHAIN)
         CL_PDBACKCHAIN = DLOOPTAIL
         DLOOPTAIL = CLOOPTAIL
      %REPEAT
      CLOOPHEAD = DLOOPHEAD
      LOOPDEPTH = 0
      BACKTARG = 0
      BREGTEMP = 0
      LOOP = -1     { X'FFFF' }
      LOOPBUILD
      %IF SRFLAGS & 16 # 0 %THENSTART
         PRINTTE
         PRINTDT
      %FINISH
!* ATTEMPT TO COMMON UP TEMPORARIES ALLOCATED IN OP3.
      COMMTEMPS %UNLESS FREELOOPS = 0
!
!
!
!
%ROUTINE LOOPSEL (%INTEGER L)
!
!************************************************************************
!* RECURSIVE ROUTINE TO PROCESS ALL "SON" LOOPS OF A GIVEN LOOP.        *
!*  PARAMETER IS A LOOPTAB POINTER FOR CURRENT LOOP.   CALLS ROUTINE TO *
!*  HANDLE STRENGTH REDUCTION TEMPORARIES BEFORE PROCESSING INNER LOOPS.*
!************************************************************************
!
%INTEGER LOOPPTR,BTEMP
!
      LOOPPTR = L
      %CYCLE
         LOOP = LOOPPTR
         BTEMP = STRENGTH;!  PROCESS SR TEMPS FOR THIS LOOP.
         LO == RECORD (ALOOPS + LOOPPTR)
         %UNLESS LO_DOWN = 0 %THENSTART
            LOOPSEL (LO_DOWN)
            LO == RECORD (ALOOPS + LOOPPTR)
         %FINISH
         SAVEPTR = FREETABS
         CLOOPHEAD = CREATETAB (CLOOPSZ)
         CL == RECORD (ATABS + CLOOPHEAD)
         CL_BLOCK = LO_BLOCK
         CL_PDCHAIN = 0
         CL_PDBACKCHAIN = 0
         DLOOPHEAD = CLOOPHEAD
         CLOOPTAIL = CLOOPHEAD
         DLOOPTAIL = CLOOPHEAD
         DLOOPCH = ADDR (CL_PDCHAIN)
         BB == RECORD (ABLOCKS + LO_BLOCK * BLSIZE)
         LOOPDEPTH = BB_DEPTH
         BACKTARG = BB_BTARG
         LOOP = LOOPPTR
         BREGTEMP = BTEMP
         LOOPBUILD
         LOOPPTR = LO_ACROSS;!   PROCESS NEXT "BROTHER" IF ANY.
      %REPEAT %UNTIL LOOPPTR = 0
!
%END;!   LOOPSEL
!
!
!
!
%ROUTINE LOOPBUILD
!
!**************************************************************************
!* EXTEND CLOOP LIST TO HOLD ALL FORWARD CONNECTIONS OF THE ENTRY BLOCKS  *
!*  WHICH ARE IN THE LOOP.  BLOCKS WHICH HAVE NOT YET BEEN PROCESSED ARE  *
!*  CHAINED INTO DLOOP LIST.                                              *
!**************************************************************************
!
%INTEGER BLK,PTR
!
      CLOOPPTR = CLOOPHEAD
      %CYCLE
         CL == RECORD (ATABS + CLOOPPTR)
         BB == RECORD (ABLOCKS + CL_BLOCK * BLSIZE)
         %UNLESS BB_FCON = 0 %THENSTART
            CN == RECORD (ATABS + BB_FCON)
            %FOR I = 1,1,CN_COUNT %CYCLE
               BLK = CN_BLOCK(I)
               %UNLESS BLK = 0 %THENSTART
                  BB == RECORD (ABLOCKS + BLK * BLSIZE)
                  %IF BB_DEPTH >= LOOPDEPTH %THENSTART
                     %FOR PTR = CLOOPHEAD,CLOOPSZ,CLOOPTAIL %CYCLE
                        CL == RECORD (ATABS + PTR)
                        %IF CL_BLOCK = BLK %THEN -> L1;!  BLOCK ALREADY IN LIST
                     %REPEAT
                     CLOOPTAIL = CREATETAB (CLOOPSZ)
                     CL == RECORD (ATABS + CLOOPTAIL)
                     CL_BLOCK = BLK
                     %IF BB_DEPTH = LOOPDEPTH %THENSTART
                        INTEGER (DLOOPCH) = CLOOPTAIL
                        DLOOPCH = ADDR (CL_PDCHAIN)
                        CL_PDCHAIN = 0
                        CL_PDBACKCHAIN = DLOOPTAIL
                        DLOOPTAIL = CLOOPTAIL
                     %FINISH
                  %FINISH
               %FINISH
      L1:   %REPEAT
         %FINISH
         CLOOPPTR = CLOOPPTR + CLOOPSZ
      %REPEAT %UNTIL CLOOPPTR > CLOOPTAIL
!
!* LOOP-LEVEL DIAGNOSTICS:
      %IF SRFLAGS & 8 # 0 %THENSTART
         NEWLINE
         NEWLINE
         PRINTSTRING (" BACK TARGET & CLOOP BLOCKS AFTER OP3A")
         NEWLINE
         NEWLINE
         %UNLESS BACKTARG = 0 %THENSTART
            PRBLOCK (BACKTARG)
            PRBLTRIADS (BACKTARG)
         %FINISH
         %FOR CLOOPPTR = CLOOPHEAD,CLOOPSZ,CLOOPTAIL %CYCLE
            CL == RECORD (ATABS + CLOOPPTR)
            PRBLOCK (CL_BLOCK)
            PRBLTRIADS (CL_BLOCK)
         %REPEAT
      %FINISH
!
      TEXTPASS (BREGTEMP)
!
!* MORE LOOP-LEVEL DIAGNOSTICS:
      %IF SRFLAGS & 32 # 0 %THENSTART
         NEWLINE
         NEWLINE
         PRINTSTRING (" BACK TARGET & CLOOP BLOCKS AFTER OP3B")
         NEWLINE
         NEWLINE
         %UNLESS BACKTARG = 0 %THENSTART
            PRBLOCK (BACKTARG)
            PRBLTRIADS (BACKTARG)
         %FINISH
         %FOR CLOOPPTR = CLOOPHEAD,CLOOPSZ,CLOOPTAIL %CYCLE
            CL == RECORD (ATABS + CLOOPPTR)
            PRBLOCK (CL_BLOCK)
            PRBLTRIADS (CL_BLOCK)
         %REPEAT
      %FINISH
!
      FREETABS = SAVEPTR
!
%END;!   LOOPBUILD
!
!
!
!
%INTEGERFUNCTION STRENGTH
!
!************************************************************************
!* DECIDES ON MAPPINGS FOR ALL STRENGTH REDUCTION TEMPORARIES           *
!*  ASSOCIATED WITH A GIVEN LOOP.  ON ENTRY LOOP CONTAINS A LOOPTAB     *
!*  POINTER FOR THE CURRENT LOOP.  RETURNS A POINTER INTO SRTEMP TABLE  *
!*  FOR ENTRY MAPPED ONTO B-REG.                                        *
!************************************************************************
!
%RECORD (SREDF) %NAME SR1,SR2
%RECORD (TRIADF) %NAME TT2
!
%INTEGER TRID,SRPTR,MAXWEIGHT,MAXTEMP,IDENT,PTR1,PTR2,CHAIN
!
!* FIND LAST TRIAD IN LOOP'S BACK TARGET: WE MAY NEED TO ADD TRIADS THERE.
      LO == RECORD (ALOOPS + LOOP)
      BB == RECORD (ABLOCKS + LO_BLOCK * BLSIZE)
      BB == RECORD (ABLOCKS + BB_BTARG * BLSIZE)
      TRID = BB_TEXT
      TT == RECORD (ATRIADS + TRID * TRIADLENGTH)
      %CYCLE
         ADDTRIAD = TRID
         TRID = TT_CHAIN
         TT == RECORD (ATRIADS + TRID * TRIADLENGTH)
      %REPEAT %UNTIL TT_OP = INIT %OR TT_OP = GOTO   %C
                  %OR (TT_OP = STMT %AND TT_USE & SOB # 0)
!* FIND MAX-WEIGHTED TEMP IN THIS LOOP & MAP ONTO B-REG.  OTHERS ARE
!*   REPLACED BY DT OR TE ENTRIES.
      MAXWEIGHT = INFIN - 1
      MAXTEMP = 0
      CHAIN = LO_ST
      %WHILE CHAIN # 0 %CYCLE
         SRPTR = CHAIN
         SR == RECORD (ABLOCKS + SRPTR << SRSCALE)
         CHAIN = SR_CHAIN
!* STOP WHEN SR ENTRIES FOR A DIFFERENT LOOP ARE MET.
         %IF SR_LOOP # LOOP %THEN %EXIT
!* IGNORE ENTRY IF ALREADY SCANNED.
         %IF SR_FLAGS & SCANDBIT # 0 %THEN %CONTINUE
!* LOOK FOR IDENTICAL SR ENTRIES, & CHAIN THEM TOGETHER.
         PTR1 = SRPTR
         SR1 == SR
         SR2 == SR
         IDENT = SR_IDENT
         SR_IDENT = 0
         %CYCLE 
            PTR2 = SR2_CHAIN
            %IF PTR2 = 0 %THEN %EXIT
            SR2 == RECORD (ABLOCKS + PTR2 << SRSCALE)
            %IF SR2_LOOP # LOOP %THEN %EXIT
            %IF SR2_FLAGS & SCANDBIT # 0 %THEN %CONTINUE
            %IF SR2_IDENT # IDENT %THEN %CONTINUE
            TT == RECORD (ATRIADS + SR1_INIT * TRIADLENGTH)
            TT2== RECORD (ATRIADS + SR2_INIT * TRIADLENGTH)
            %IF TT_RES2_W # TT2_RES2_W %THEN %CONTINUE
            %FOR I = 1,1,3 %CYCLE
               %IF SR1_INCR(I) = 0 %THENSTART
                  %IF SR2_INCR(I) = 0 %THEN %EXIT   %C
                                      %ELSE -> L1
               %FINISH
               %IF SR2_INCR(I) = 0 %THEN -> L1
               TT == RECORD (ATRIADS + SR1_INCR(I) * TRIADLENGTH)
               TT2== RECORD (ATRIADS + SR2_INCR(I) * TRIADLENGTH)
               %IF TT_RES2_W # TT2_RES2_W %OR TT_OP # TT2_OP %THEN -> L1
            %REPEAT
!* TWO ENTRIES ARE IDENTICAL. ADD NEW ONE TO CHAIN.
            SR1_IDENT = PTR2
            PTR1 = PTR2
            SR1 == SR2
            SR1_IDENT = 0
!* WEIGHT OF COMBINED CHAIN IS MAX OF WEIGHTS OF ITS MEMBERS.
            %IF SR1_WEIGHT > SR_WEIGHT %THEN SR_WEIGHT = SR1_WEIGHT
!* MARK NEW ENTRY AS SCANNED.
            SR1_FLAGS = SR1_FLAGS ! SCANDBIT
!* IF ANY ENTRY IN CHAIN IS SUITABLE FOR TEST REPLACEMENT, THEN WHOLE CHAIN IS.
            SR_FLAGS = SR_FLAGS ! (SR1_FLAGS & TESTREPBIT)
!* INIT & INCR TRIADS FOR NEW SR ENTRY NOT NEEDED, SO SET THEM TO NULL,
!*   AND IF THEIR OPDS ARE TEXT, REDUCE THEIR USE CTS BY ONE.
            TRID = SR1_INIT
            I = 1
            %WHILE TRID#0 %CYCLE
               TT == RECORD (ATRIADS + TRID * TRIADLENGTH)
               TT_OP = NULL
               %IF TT_QOPD2 & TEXTMASK # 0 %THEN DELUSE (TT_OPD2)
               %IF I = 4 %THEN %EXIT
               TRID = SR1_INCR(I)
               I = I + 1
            %REPEAT
   L1:   %REPEAT
!* REPLACE LOWER WEIGHTED ENTRY BY A DT OR TE ENTRY.
         %IF SR_WEIGHT > MAXWEIGHT %AND SR_MODE <= INT4 %THENSTART
            MAXWEIGHT = SR_WEIGHT
            REPLACE (MAXTEMP) %UNLESS MAXTEMP = 0
            MAXTEMP = SRPTR
         %FINISHELSE REPLACE (SRPTR)
      %REPEAT
      %if Numoptregs=0 %thenstart
         %if Maxtemp#0 %then Replace(Maxtemp)
         %result=0
      %finish
      %IF MAXTEMP = 0 %THEN %RESULT = 0   %C
                      %ELSESTART
         BTEMPREP (MAXTEMP)
         %RESULT = MAXTEMP
      %FINISH
!
%END;!   STRENGTH
!
!
!
!
%ROUTINE BTEMPREP (%INTEGER MAX)
!
!****************************************************************************
!* MARKS THE B-REG SR ENTRY AS SUCH.  CHANGES THE OPD1 OF THE INIT TO B-REG,*
!*   AND ENSURES THAT ALL OTHER TESTS & USES POINT TO MAIN SR ENTRY         *
!*   IN CHAIN.                                                              *
!****************************************************************************
!
%RECORD (RESF) SRMAX,SRCURRENT
!
      SRMAX_H0 = MAX
      SRMAX_FORM = SRTEMP
      SR == RECORD (ABLOCKS + MAX << SRSCALE)
      Srmax_Mode=Sr_Mode
      SR_FLAGS = SR_FLAGS ! BREGBIT
      SR_DUMP = 0
      TT == RECORD (ATRIADS + SR_INIT * TRIADLENGTH)
      TT_QOPD1 = BREG
      SRCURRENT = SRMAX
!* SCAN THRO' ENTRIES IN AN IDENTITY CHAIN, CHANGING REFS TO POINT TO HEAD-OF-CHAIN.
      %WHILE SR_IDENT # 0 %CYCLE
         SRCURRENT_H0 = SR_IDENT
         SR == RECORD (ABLOCKS + SR_IDENT << SRSCALE)
         %FOR I = 1,1,3 %CYCLE
            %IF SR_TEST(I) = 0 %THEN %EXIT
            TT == RECORD (ATRIADS + SR_TEST(I) * TRIADLENGTH)
            %IF TT_RES1_W = SRCURRENT_W %THEN TT_RES1 = SRMAX
            %IF TT_RES2_W = SRCURRENT_W %THEN TT_RES2 = SRMAX
         %REPEAT
         %FOR I = 1,1,SR_USECT %CYCLE
            %IF SR_USE(I) = 0 %THEN %EXIT
            TT == RECORD (ATRIADS + SR_USE(I) * TRIADLENGTH)
            %IF TT_RES1_W = SRCURRENT_W %THEN TT_RES1 = SRMAX
            %IF TT_RES2_W = SRCURRENT_W %THEN TT_RES2 = SRMAX
         %REPEAT
      %REPEAT
!
%END;!   BTEMPREP
!
!
!
!
%ROUTINE REPLACE (%INTEGER SRENT)
!
!**************************************************************************
!* DECIDES WHETHER TO MAP AN SR TEMP ONTO A DT OR A TE ENTRY.             *
!*   (MAPPED ONTO DTEMP ONLY IF TEMP HAS NOT BEEN SELECTED FOR TEST       *
!*    REPLACEMENT, AND ALL THE USES ARE AS SUBSCRIPTS IN ARR OR DEFARR    *
!*    TRIADS USING THE SAME ARRAY.)                                       *
!**************************************************************************
!
%RECORD (RESF) CURRARR
!
      CURRARR_W = 0
      SR == RECORD (ABLOCKS + SRENT << SRSCALE)
      %IF SR_FLAGS & TESTREPBIT = 0 %THENSTART
         %CYCLE
            %FOR I = 1,1,SR_USECT %CYCLE
               %IF SR_USE(I) = 0 %THEN %EXIT
               TT == RECORD (ATRIADS + SR_USE(I) * TRIADLENGTH)
               %UNLESS TT_OP = ARR %OR TT_OP = DEFARR %THEN -> L1
               %IF TT_MODE=CHARMODE %THEN ->L1
               %IF CURRARR_W = 0 %THEN CURRARR = TT_RES1   %C
                                 %ELSESTART
                  %UNLESS TT_RES1_W = CURRARR_W %THEN -> L1
               %FINISH
            %REPEAT
            %IF SR_IDENT = 0 %THEN %EXIT
            SR == RECORD (ABLOCKS + SR_IDENT << SRSCALE)
         %REPEAT
         DESC (SRENT)
      %FINISHELSESTART
   L1:   VALUE (SRENT)
      %FINISH
!
%END;!   REPLACE
!
!
!
!
%ROUTINE VALUE (%INTEGER S)
!
!*********************************************************************
!* REPLACES AN SR TEMP WITH A TE ENTRY.                              *
!*********************************************************************
!
%RECORD (RESF) TEPTR,CURRSR
!
%RECORD (TERECF) %NAME TE
!
      SR == RECORD (ABLOCKS + S << SRSCALE)
      TEPTR_W = CREATETE (Sr_Mode)
      TE == RECORD (ADICT + TEPTR_H0 << DSCALE)
      TE_FLAGS = SRTEMPBIT
      TE_LOOP = LOOP
      TEMAXCOORD = TEMAXCOORD + 1
      TE_COORD = TEMAXCOORD
!* INIT TRIAD BECOMES AN ASMT.
      TT == RECORD (ATRIADS + SR_INIT * TRIADLENGTH)
      TT_OP = ASMT
      CURRSR_H0 = S
      CURRSR_FORM = SRTEMP
      CURRSR_MODE = Sr_Mode
!* FOR EACH ENTRY IN SR IDENTITY CHAIN, REPLACE SR REFS BY TE REFS IN
!*   INIT & ALL INCRS, TESTS, & USES.
      %CYCLE
         TT_RES1 = TEPTR
         %FOR I = 1,1,SR_USECT+6 %CYCLE
            %IF SR_ALLREFS(I) = 0 %THEN %CONTINUE
            TT == RECORD (ATRIADS + SR_ALLREFS(I) * TRIADLENGTH)
            %IF TT_RES1_W = CURRSR_W %THEN TT_RES1 = TEPTR
            %IF TT_RES2_W = CURRSR_W %THEN TT_RES2 = TEPTR
         %REPEAT
         %IF SR_IDENT = 0 %THEN %EXIT
         CURRSR_H0 = SR_IDENT
         SR == RECORD (ABLOCKS + SR_IDENT << SRSCALE)
         TT == RECORD (ATRIADS + SR_INIT * TRIADLENGTH)
      %REPEAT
!
%END;!   VALUE
!
!
!
!
%ROUTINE DESC (%INTEGER S)
!
!***********************************************************************
!* REPLACES AN SR TEMP WITH A DT ENTRY.                                *
!***********************************************************************
!
%RECORD (RESF) DTPTR,WINC,OPD
!
%RECORD (DTRECF) %NAME DT
%RECORD (TRIADF) %NAME TT1
!
%INTEGER MODE,BASE,TYPE,SCALE,NEWTR,CUSES,INC,TRID,I
!
%CONSTBYTEINTEGERARRAY TYPES(0:15) = INTTYPE(3),REALTYPE(3),CMPLXTYPE(3),
                                    LOGTYPE(4),CHARTYPE,0,INTTYPE
%CONSTBYTEINTEGERARRAY LENGTHS(0:15) = 2,4,8,4,8,16,8,16,32,1,2,4,8,1,0,1
!
%ROUTINESPEC ADDCODE (%INTEGER TR)
!
      SR == RECORD (ABLOCKS + S << SRSCALE)
      I=1
      TT == RECORD (ATRIADS + SR_USE(I) * TRIADLENGTH)
      OPD = TT_RES1
      BASE = ARBASE (OPD)
      MODE = TT_MODE
      DTPTR_W = CREATEDT (TT_MODE)
      DT == RECORD (ADICT + DTPTR_H0 << DSCALE)
      DT_IDENT = BASE
      DT_FLAGS = SRTEMPBIT
      DT_LOOP = LOOP
!* CALCULATE VALUE BY WHICH EACH INCREMENT MUST BE SCALED.
      TYPE = TYPES (MODE)
      SCALE = LENGTHS(MODE)
      %if Target=Gould %then Scale=1  {22/08/86}
!*
{      %IF TYPE = CMPLXTYPE %THEN SCALE = SCALE >> 1  deleted 17/08/86}
!*
      %IF TARGET=PERQPNX %THENSTART
        %IF SCALE#1 %THEN SCALE=SCALE>>1;! 16 bit word addresses
      %FINISH
!*
      %IF TARGET=ICL2900 %THENSTART
         %IF SCALE=2 %THEN SCALE=1;! for string descriptor use
      %FINISH
!*
!* MODIFY INIT TRIAD BY REPLACING SRTEMP BY THE NEW DTEMP, AND THE
!*    INITIAL VALUE BY A DEFARR TRIAD.
      TT1 == RECORD (ATRIADS + SR_INIT * TRIADLENGTH)
!* INSERT NEW TRIAD IMMEDIATELY BEFORE THE RELEVANT INIT.
      TRID = ADDTRIAD
      %CYCLE
         TT == RECORD (ATRIADS + TRID * TRIADLENGTH)
         %IF TT_CHAIN = SR_INIT %THEN %EXIT
         TRID = TT_CHAIN
      %REPEAT
      NEWTR = CHAFTER (TRID)
      TT == RECORD (ATRIADS + NEWTR * TRIADLENGTH)
      TT_RES1 = OPD
      TT_RES2 = TT1_RES2
      TT_OP = DEFARR
      TT_USE = 1
      TT1_RES1 = DTPTR
      TT1_OPD2 = NEWTR
      TT1_QOPD2 = TRIAD
      TT1_MODE2 = MODE
      TT1_OP = DINIT
!* MODIFY EACH OF THE INCR/DECR TRIADS BY SCALING THE INCREMENT AND
!*   REPLACING THE OLD SR TEMP BY THE NEW DT ENTRY.
      %FOR I = 1,1,3 %CYCLE
         %IF SR_INCR(I) = 0 %THEN %EXIT
         TT == RECORD (ATRIADS + SR_INCR(I) * TRIADLENGTH)
         %IF TT_OP # INCR %THENSTART
            TT_OP = INCR
            SCALE = -SCALE
         %FINISH
!* AMEND DT-INCR TRIADS SO THAT OPD 2 IS CORRECTLY SCALED FOR INCA.
!*   MAY INVOLVE CHAINING INTO THE BACK TARGET.
         %UNLESS SCALE = 1 %THENSTART
      L1:   INC = TT_OPD2
            WINC = TT_RES2
            %IF TT_QOPD2 & TEXTMASK # 0 %THENSTART
               TT1 == RECORD (ATRIADS + TT_OPD2 * TRIADLENGTH)
               %IF TT1_OP = REPL %OR TT1_OP = REF %THENSTART
                  ELIM (INC)
                  TT_RES2 = TT1_RES1
                  -> L1
               %FINISH
               %IF TT1_OP = MULT %AND TT1_USE = 1 %THENSTART
                  %IF TT1_QOPD2 & CONSTMASK # 0 %THEN   %C
                           TT1_RES2_W = CONIN (SCALE * CONOUT (TT1_RES2))   %C
                  %ELSEIF TT1_QOPD1 & CONSTMASK # 0 %THEN   %C
                           TT1_RES1_W = CONIN (SCALE * CONOUT (TT1_RES1)) %C
                  %ELSE ADDCODE(INC)
               %FINISHELSE ADDCODE (INC)
            %FINISHELSEIF TT_QOPD2 & CONSTMASK # 0 %THEN   %C
                           TT_RES2_W = CONIN (SCALE * CONOUT (TT_RES2))   %C
            %ELSE ADDCODE (ADDTRIAD) %AND ADDTRIAD = NEWTR
         %FINISH
         TT_RES1 = DTPTR
      %REPEAT
!* EACH USE TRIAD BECOMES A REPL WITH OPD 1 = THE NEW DTEMP.
      CUSES = 0
      %CYCLE
         %FOR I = 1,1,SR_USECT %CYCLE
            %IF SR_USE(I) = 0 %THEN %EXIT
            TT == RECORD (ATRIADS + SR_USE(I) * TRIADLENGTH)
            TT_RES1 = DTPTR
            TT_OP = REPL
            TT_RES2_W = 0
            CUSES = CUSES + 1
         %REPEAT
         %IF SR_IDENT = 0 %THEN %EXIT
         SR == RECORD (ABLOCKS + SR_IDENT << SRSCALE)
      %REPEAT
      SR == RECORD (ABLOCKS + S << SRSCALE)
      TT == RECORD (ATRIADS + SR_INIT * TRIADLENGTH)
      TT == RECORD (ATRIADS + TT_OPD2 * TRIADLENGTH)
      %IF TT_QOPD1 & TEXTMASK # 0 %THENSTART
         TT == RECORD (ATRIADS + TT_OPD1 * TRIADLENGTH)
         TT_USE = TT_USE + 1 - CUSES
      %FINISH
!
!
!
!
%ROUTINE ADDCODE (%INTEGER TR)
!
!************************************************************************
!* GENERATES  'INC * SCALE'  (OR  'INC NEG -' , IF SCALE = -1) TRIAD.   *
!************************************************************************
!
      NEWTR = CHAFTER (TR)
      TT1 == RECORD (ATRIADS + NEWTR * TRIADLENGTH)
      TT1_RES1 = WINC
      %UNLESS SCALE = -1 %THENSTART
         TT1_RES2_W = CONIN (SCALE)
         TT1_OP = MULT
      %FINISHELSE TT1_OP = NEG
      TT1_USE = 1
      TT_OPD2 = NEWTR
      TT_QOPD2 = TRIAD
      TT_MODE2 = INT4
!
%END;!   ADDCODE
!
%END;!   DESC
!
!
!
!
%ROUTINE COMMTEMPS
!
!***************************************************************************
!* EQUIVALENCES TOGETHER DT & TE ENTRIES WHICH ARE NOT ACTIVE AT THE SAME  *
!*   POINT IN THE FORTRAN SECTION.                                         *
!***************************************************************************
!
%OWNINTEGERARRAYFORMAT BF(0:15)
%INTEGERARRAYNAME B
!
%INTEGER CTAREA,PTR,MODE,BITNO,CTEND,CTLENGTH,CHAIN,SAVE
!
%RECORDFORMAT CTEMPF (%shortINTEGER TEMP)
!
%RECORD (TERECF) %NAME TE
%RECORD (DTRECF) %NAME DT
%RECORD (LOOPRECF) %NAME LO
%RECORD (BLRECF) %NAME BB
%RECORD (CTEMPF) %NAME CT
!
%ROUTINESPEC SETVAL (%INTEGER L)
%INTEGERFUNCTIONSPEC BITVAL (%INTEGER L)
%ROUTINESPEC ZEROBITS
!
!* FIRST COMMON UP TE ENTRIES.
      SAVE = FREETABS
      ZEROBITS
      PTR = VALTEMPHEAD
      %WHILE PTR # 0 %CYCLE
         TE == RECORD (ADICT + PTR << DSCALE)
         CHAIN = TE_CHAIN
         LOOP = TE_LOOP
!* TEMPS USED AT OUTER LEVEL CAN'T BE COMMONED.
         %UNLESS LOOP = -1 {X'FFFF'} %THENSTART
            TE_LOOP = 0
            MODE = TE_MODE
            BITNO = 0
!* SCAN CTEMP TABLE & BITSTRIPS TO FIND APPROPRIATE BIT-NO FOR TEMP.
            %CYCLE
               CT == RECORD (ATABS + CTAREA + BITNO * CTSIZE)
!* BIT-NO OK IF UNALLOCATED.
               %IF CT_TEMP = 0 %THEN %EXIT
               TE == RECORD (ADICT + CT_TEMP << DSCALE)
!* ALSO OK IF ALREADY ALLOCATED TO A TEMP OF SAME MODE, AND NEVER
!*   ACTIVE IN SAME LOOPS.
               %IF TE_MODE = MODE %AND BITVAL (LOOP) = 0 %THEN %EXIT
               BITNO = BITNO + 1
               %IF BITNO > COORDMAX %THEN -> L1;!   NO SUITABLE BIT-NO.
            %REPEAT
!* WE HAVE A GOOD BIT-NO.  ATTACH IT TO CHAIN.
            SETVAL (LOOP)
            TE_LOOP = CT_TEMP
            CT_TEMP = PTR
   L1:   %FINISH
         PTR = CHAIN
      %REPEAT
      FREETABS = SAVE
!
!* NOW COMMON UP DT ENTRIES.
!
      ZEROBITS
      PTR = DESTEMPHEAD
      %WHILE PTR # 0 %CYCLE
         DT == RECORD (ADICT + PTR << DSCALE)
         LOOP = DT_LOOP
!* TEMPS INITIALISED BY LOADER, OR USED AT OUTER LEVEL, CAN'T BE COMMONED.
         %UNLESS DT_FLAGS & INITLOADBIT # 0 %OR LOOP = -1 {X'FFFF'} %THENSTART
            DT_LOOP = 0
            BITNO = 0
!* SCAN CTEMP TABLE & BITSTRIPS TO FIND APPROPRIATE BIT-NO FOR TEMP.
            %CYCLE
               CT == RECORD (ATABS + CTAREA + BITNO * CTSIZE)
!* BIT-NO OK IF UNALLOCATED, OR ALLOCATED TO A TEMP WHICH IS NEVER
!*   ACTIVE IN SAME LOOPS.
               %IF CT_TEMP = 0 %OR BITVAL (LOOP) = 0 %THEN %EXIT
               BITNO = BITNO + 1
               %IF BITNO > COORDMAX %THEN -> L2
            %REPEAT
            SETVAL (LOOP)
            DT_LOOP = CT_TEMP
            CT_TEMP = PTR
   L2:   %FINISH
         PTR = DT_CHAIN
      %REPEAT
      FREETABS = SAVE
!
!
!
!
%ROUTINE ZEROBITS
!
!*********************************************************************
!* SET UP A TABLE AREA & CLEAR BLOCK USE BIT-STRIPS.                 *
!*********************************************************************
!
      PTR = ALOOPS
      %WHILE PTR < ALOOPS + FREELOOPS %CYCLE
         LO == RECORD (PTR)
         BB == RECORD (ABLOCKS + LO_BLOCK * BLSIZE)
         B == ARRAY (ABLOCKS+BB_USE,BF)
         B(I) = 0 %FOR I = 0,1,BSWORDS - 1
         PTR = PTR + LOOPRECSIZE
      %REPEAT
      CTLENGTH = CTSIZE * COORDMAX
      CTAREA = CREATETAB (CTLENGTH)
      CTEND = CTAREA + CTLENGTH
      PTR = CTAREA
      %CYCLE
         CT == RECORD (ATABS + PTR)
         CT_TEMP = 0
         PTR = PTR + CTSIZE
      %REPEAT %UNTIL PTR >= CTEND
!
%END;!   ZEROBITS
!
!
!
!
%ROUTINE SETVAL (%INTEGER L)
!
!*********************************************************************
!* SETS GIVEN BIT FOR LOOP L & ALL CONTAINED LOOPS (RECURSIVELY).    *
!*********************************************************************
!
%INTEGER DOWN
!
%RECORD (LOOPRECF) %NAME LO1
!
      LO1 == RECORD (ALOOPS + L)
      DOWN = LO1_DOWN
      %WHILE DOWN # 0 %CYCLE
         SETVAL (DOWN)
         LO == RECORD (ALOOPS + DOWN)
         DOWN = LO_ACROSS
      %REPEAT
      BB == RECORD (ABLOCKS + LO1_BLOCK * BLSIZE)
      SETBIT (ABLOCKS+BB_USE,BITNO)
!
%END;!   SETVAL
!
!
!
!
%INTEGERFUNCTION BITVAL (%INTEGER L)
!
!**************************************************************************
!* CHECKS WHETHER GIVEN BIT IS SET IN ANY LOOP CONTAINED IN LOOP L        *
!*   (RECURSIVELY).  IF SO, SETS BIT FOR THIS LOOP (TO SAVE TIME NEXT     *
!*   TIME.  RETURNS BIT VALUE FOR LOOP.                                   *
!**************************************************************************
!
%INTEGER BIT,DOWN
!
%RECORD (BLRECF) %NAME BB
!
      LO == RECORD (ALOOPS + L)
      BB == RECORD (ABLOCKS + LO_BLOCK * BLSIZE)
      DOWN = LO_DOWN
      GETBIT (ABLOCKS+BB_USE,BITNO,BIT)
      %IF BIT # 0 %THEN %RESULT = 1
      %WHILE DOWN # 0 %CYCLE
         %IF BITVAL (DOWN) = 1 %THENSTART
            SETBIT (ABLOCKS+BB_USE,BITNO)
            %RESULT = 1
         %FINISH
         LO == RECORD (ALOOPS + DOWN)
         DOWN = LO_ACROSS
      %REPEAT
      %RESULT = 0
!
%END;!   BITVAL
!
%END;!   COMMTEMPS
!
!
!
!
%ROUTINE PRINTSR
!
!*************************************************************************
!* PRINT CONTENTS OF STRENGTH REDUCTION TEMPORARIES TABLE.               *
!*************************************************************************
!
%INTEGER PTR 
!
      NEWLINE
      NEWLINE
      PRINTSTRING ("STRENGTH REDUCTION TABLE")
      NEWLINE
      PRINTSTRING ("   IDENT  LOOP   DUMP   INIT   FLAGS  USE CT WEIGHT")
      NEWLINE
      PTR = SRHEAD
      %WHILE PTR # 0 %CYCLE
         SR == RECORD (ABLOCKS + PTR << SRSCALE)
         WRITE (SR_IDENT,6)
         WRITE (SR_LOOP,6)
         WRITE (SR_DUMP,6)
         WRITE (SR_INIT,6)
         WRITE (SR_FLAGS,6)
         WRITE (SR_USECT,6)
         WRITE (SR_WEIGHT,6)
         NEWLINE
         PTR = SR_CHAIN
      %REPEAT
!
%END;!   PRINTSR
!
!
!
!
%ROUTINE PRINTTE
!
!*************************************************************************
!* PRINT CONTENTS OF VALUE TEMPORARIES TABLE.                            *
!*************************************************************************
!
%RECORD (TERECF) %NAME TE
!
%INTEGER PTR
!
      NEWLINE
      NEWLINE
      PRINTSTRING ("VALUE TEMPORARIES TABLE")
      NEWLINE
      PRINTSTRING ("   MODE   LOOP   INDEX  FLAGS")
      NEWLINE
      PTR = VALTEMPHEAD
      %WHILE PTR # 0 %CYCLE
         TE == RECORD (ADICT + PTR<<DSCALE)
         WRITE (TE_MODE,6)
         WRITE (TE_LOOP,6)
         WRITE (TE_INDEX,6)
         WRITE (TE_FLAGS,6)
         NEWLINE
         PTR = TE_CHAIN
      %REPEAT
!
%END;!   PRINTTE
!
!
!
!
%ROUTINE PRINTDT
!
!**************************************************************************
!* PRINT CONTENTS OF DESCRIPTOR TEMPORARIES TABLE.                        *
!**************************************************************************
!
%RECORD (DTRECF) %NAME DT
!
%INTEGER PTR 
!
      NEWLINE
      NEWLINE
      PRINTSTRING ("DESCRIPTOR TEMPORARIES TABLE")
      NEWLINE
      PRINTSTRING ("   MODE   IDENT  FLAGS  INDEX  LOOP")
      NEWLINE
      PTR = DESTEMPHEAD
      %WHILE PTR # 0 %CYCLE
         DT == RECORD (ADICT + PTR<<DSCALE)
         WRITE (DT_MODE,6)
         WRITE (DT_IDENT,6)
         WRITE (DT_FLAGS,6)
         WRITE (DT_INDEX,6)
         WRITE (DT_LOOP,6)
         NEWLINE
         PTR = DT_CHAIN
      %REPEAT
!
%END;!   PRINTDT
!
%END;!   OP3
!
!
!
!
%INTEGERFUNCTION CREATETE (%INTEGER M)
!
!********************************************************************
!* CREATE A VALTEMP ENTRY AND FILL IN THE EASY FIELDS.              *
!********************************************************************
!
%INTEGER TEADDR
!
%RECORD (RESF) TEPTR
%RECORD (TERECF) %NAME TE
!
      TEADDR = CREATEDTAB (TESZ)
      TE == RECORD (ADICT + TEADDR)
      TEADDR = TEADDR >> DSCALE
      TE_CHAIN = 0
      %UNLESS VALTEMPHEAD=0 %THEN TECH=TECH+ADICT
      INTEGER (TECH) = TEADDR
      TECH = ADDR (TE_CHAIN)-ADICT
      TEPTR_H0 = TEADDR
      TEPTR_FORM = VALTEMP
      TEPTR_MODE = M
      TE_DISP1 = 0
      TE_INDEX = TEINDEX
      TEINDEX = TEINDEX + 1
      TE_MODE = M
      TE_LOOP=LOOP
      TE_FLAGS=0
      %RESULT = TEPTR_W
!
%END;!   CREATETE
!
!
!
!
%INTEGERFUNCTION CREATEDT (%INTEGER M)
!
!********************************************************************
!* CREATE A DESTEMP ENTRY AND FILL IN THE EASY FIELDS.              *
!********************************************************************
!
%INTEGER DTADDR
!
%RECORD (RESF) DTPTR
%RECORD (DTRECF) %NAME DT
!
      DTADDR = CREATEDTAB (DTSZ)
      DT == RECORD (ADICT + DTADDR)
      DTADDR = DTADDR >> DSCALE
      DT_CHAIN = 0
      %UNLESS DESTEMPHEAD=0 %THEN DTCH=DTCH+ADICT
      INTEGER (DTCH) = DTADDR
      DTCH = ADDR (DT_CHAIN)-ADICT
      DTPTR_H0 = DTADDR
      DTPTR_FORM = DESTEMP
      DTPTR_MODE = M
      DT_DISP2 = 0
      DT_INDEX = DTINDEX
      DTINDEX = DTINDEX + 1
      DT_MODE = M
      DT_LOOP=LOOP
      DT_FLAGS=0
      %RESULT = DTPTR_W
!
%END;!   CREATEDT
!
!
!
%INTEGERFUNCTION CHAFTER (%INTEGER TR)
!
!*************************************************************************
!* CHAINS A NEW TRIAD INTO THE TEXT BETWEEN THE GIVEN TRIAD AND ITS      *
!*   SUCCESSOR.  RETURNS POINTER TO THE NEW TRIAD.                       *
!*************************************************************************
!
%INTEGER CHAIN,NEW
!
%RECORD (TRIADF) %NAME TT
!
      TT == RECORD (ATRIADS + TR * TRIADLENGTH)
      CHAIN = TT_CHAIN
      NEW = GETTRIAD
      TT_CHAIN = NEW
      TT == RECORD (ATRIADS + NEW * TRIADLENGTH)
      TT_CHAIN = CHAIN
      %RESULT = NEW
!
%END;!   CHAFTER
!
!
!
!
%ROUTINE ELIM (%INTEGER TR)
!
!***************************************************************************
!* REDUCE THE USE CT OF A REPL OR REF TRIAD BY ONE.  IF USE CT IS NOW      *
!*   ZERO SET OPERATOR TO NULL, ELSE IF OPD 1 IS A TRIAD INCREASE ITS USE  *
!*   CT BY ONE.                                                            *
!***************************************************************************
!
%RECORD (TRIADF) %NAME TT
!
      TT == RECORD (ATRIADS + TR * TRIADLENGTH)
      %if TT_Use>0 %then TT_USE = TT_USE - 1
      %IF TT_USE = 0 %THEN TT_OP = NULL   %C
            %ELSEIF TT_QOPD1 & TEXTMASK # 0 %THENSTART
         TT == RECORD (ATRIADS + TT_OPD1 * TRIADLENGTH)
         TT_USE = TT_USE + 1
      %FINISH
!
%END;!   ELIM
!
!
!
!
%INTEGERFUNCTION ARBASE (%RECORD (RESF) OPD)
!
!*************************************************************************
!* FINDS THE BASE ARRAY OF AN ARRAY ACCESSING FORM.                      *
!*************************************************************************
!
%INTEGER FORM,H0
!
%RECORD (TRIADF) %NAME TT
%RECORD (DTRECF) %NAME DT
!
      FORM = OPD_FORM
      H0 = OPD_H0
      %CYCLE
         %IF FORM & IDMASK # 0 %THEN %RESULT = H0
         %IF FORM = DESTEMP %THENSTART
            DT == RECORD (ADICT + H0 << DSCALE)
            %RESULT = DT_IDENT
         %FINISH
!* ELSE MUST BE TEXT PTR SO REPEAT PROCESS.
         TT == RECORD (ATRIADS + H0 * TRIADLENGTH)
         FORM = TT_QOPD1
         H0 = TT_OPD1
      %REPEAT
!
%END;!   ARBASE
!
!
!*
!***********************************************************************
!*                                                                     *
!***********************************************************************
!*                                                                     *
!*                   T E X T P A S S                                   *
!*                                                                     *
!***********************************************************************
!*                                                                     *
!***********************************************************************
!*
!
! 1/12/82 - INSERTED LINE 951 IN INCRTR & CHANGED BTEMP
!
!
!
%EXTERNALROUTINE TEXTPASS (%INTEGER BREGTEMP)
!
!
%ROUTINESPEC BLOKCHAIN
%INTEGERFUNCTIONSPEC GETNEXT
%INTEGERFUNCTIONSPEC OPND (%RECORD (RESF) OP,%INTEGER BUSE)
%ROUTINESPEC INITTR
%ROUTINESPEC INCRTR
%ROUTINESPEC ASMTCH
%ROUTINESPEC ARRTR
%ROUTINESPEC ARGCH
%ROUTINESPEC REDUSE (%RECORD (RESF) OP)
%ROUTINESPEC KEEPB (%INTEGER TR)
%ROUTINESPEC RESETB (%INTEGER TR)
%ROUTINESPEC BTEMP (%INTEGER BL)
%ROUTINESPEC RESARGS (%INTEGER TR)
%ROUTINESPEC CRENT
%INTEGERFUNCTIONSPEC BRDUMP(%INTEGER SRTEMP)
%INTEGERFUNCTIONSPEC OUTBLOCK (%INTEGER TR)
%INTEGERFUNCTIONSPEC BREGOPN (%RECORD (RESF) OP)
%ROUTINESPEC PRESVAL (%INTEGER TR)
%INTEGERFUNCTIONSPEC DTDUPL (%INTEGER DPTR)
%INTEGERFNSPEC TRSPEC(%RECORD(RESF) R)
%ROUTINESPEC CHECKBBOEX
!
!* DIVIDE OPERATIONS INTO 23 CATEGORIES TO DRIVE TEXT PASSES.
%CONSTBYTEINTEGERARRAY OPCAT (0:116) = %C
       0,        0,        7,        7,
   {  NULL      (01)      ADD       SUB
       7,        7,        3,       12,
   {  MULT      DIV       NEG       ASMT
       5,       15,        0,        0,
   {  CVT       ARR       ARR1      BOP
       8,        7,       22,        7,
   {  ASGN      (0D)      EXP       EXP3
       7,        0,        3,        7,
   {  AND       OR        NOT       EQUIV
       7,        7,        7,        7,
   {  NEQ       GT        LT        NE
       7,        7,        7,        7,
   {  EQ        GE        LE        SUBSTR
      27,       27,       27,        0,
   {  CHAR      CONCAT    CHHEAD    (1F)
       0,        0,        0,        0,
   {  STOD1     STOD2     STODA     (23)
       0,        0,        0,        0,
   {  EOD1      EOD2      EODA      EODB
      20,       15,        7,        7,
   {  BRK       DEFARR    RSUB      RDIV
       1,        7,        0,        0,
   {  DCHAR     ASH       (2E)      (2F)
      21,       13,        1,       24,
   {  STRTIO    IOITEM    IODO      IOSPEC
      21,       13,        0,        0,
   {  IO        DIOITEM   (36)      (37)
       0,       15,       17,       16,
   {  (38)      ARGARR    INIT      INCR
      16,       18,       16,        0,
   {  DECR      DINIT     PINCR     (3F)
       0,       10,        9,       11,
   {  NOOP      FUN       SUBR      ARG,
       0,        0,        9,       10,
   {  STRTSF    ENDSF     CALLSF    IFUN,
      11,       11,        1,       20,
   {  DARG      IARG      REPL      REF,
       1,       19,       23,        0,
   {  LOADB     STOREB    MOO       (4F)
       6,        6,        6,        6,
   {  JIT       JIF       JINN      JINP,
       6,        6,        6,        6,
   {  JINZ      JIN       JIP       JIZ,
       4,       14,        2,        1,
   {  CGT       GOTO      RET       STOP,
      21,        1,       25,       25,
   {  PAUSE     EOT       NINT      ANINT
       1,        0,        1,        7,
   {  STMT      ITS       PA        TOCHAR
       7,        7,       25,        7,
   {  DIM       DMULT     AINT      ABS
      26,        7,        7,        7,
   {  MOD       SIGN      MIN       MAX
       7,        7,        7,        7,
   {  REALL     IMAG      CMPLX     CONJG
       7,        7,       21,	     7,
   {  LEN       ICHAR     CHIND	    DCMPLX
      10
   {  INTRIN
!
%CONSTBYTEINTEGERARRAY CORRUPTB(0:29) =  %C
   0,0,0,0,0,  1,0,0,0,0,  0,0,0,1,0,  0,0,0,0,0,  0,1,1,1,0,  1,1,0,0,0
!
!
%RECORDFORMAT EXRECF (%shortINTEGER TRIAD,USES)
!
%RECORD (EXRECF) %NAME EX
%RECORD (SREDF) %NAME SR
%RECORD (BLRECF) %NAME BB,BB1
%RECORD (TRIADF) %NAME TT,TT1
%RECORD (CONRECF) %NAME CN
%RECORD (CLOOPRECF) %NAME CL
%RECORD (DTRECF) %NAME DT
!
%RECORD (RESF) BREGOP
!
%CONSTINTEGER BBOEXBIT = X'04'
%CONSTINTEGER BUSEDBIT = X'02'
%CONSTINTEGER BUSEDORBOE = X'06'
%CONSTINTEGER NOTBBOEX = X'FB'
!
%INTEGER DLOOPPTR,START,LASTBUT1,INITB,BEFBUSE,LASTBUSE,BNEEDED,BUSED
%INTEGER BBOEXIT,BCORRUPT,OLDDTCH,BLOCK,I,SAVEB,EXTNSTART,EXTNEND
%INTEGER BLOADED,BSAVED
!
!**************************************************************************
!* PROCESSES THE TEXT FOR EACH BLOCK IN THE CURRENT LOOP, INCLUDING       *
!*   CONTROLLING THE B REGISTER OVER THE LOOP.                            *
!**************************************************************************
!
      BREGOP_FORM = BREG
      BREGOP_MODE = INT4
      BREGOP_H0 = 0
      SAVEB = 0
      BLOADED=1
      BSAVED=0
      BBOEXIT=1
      DLOOPPTR = DLOOPHEAD
!* PROCESS EACH BLOCK IN LOOP.
      %WHILE DLOOPPTR # 0 %CYCLE
         CL == RECORD (ATABS + DLOOPPTR)
         BLOCK = CL_BLOCK
         BB == RECORD (ABLOCKS + BLOCK * BLSIZE)
         START = BB_TEXT
         CN == RECORD (ATABS + BB_FCON)
!* TEST WHETHER THIS BLOCK IS THE BACK TARG OF AN INNER LOOP, SINCE
!*   INNER LOOPS CAN CORRUPT B-REG.
         BCORRUPT = 0
         %IF BBOEXIT=0 %THEN BLOADED=0 %ELSE BLOADED=1
         %IF CN_COUNT # 0 %AND CN_BLOCK(1) # 0 %THENSTART
            BB1 == RECORD (ABLOCKS + CN_BLOCK(1) * BLSIZE)
            %IF BB1_DEPTH > LOOPDEPTH %THENSTART
               BCORRUPT = BB1_TEXT
               SAVEB = 1
            %FINISH
         %FINISH
         BLOKCHAIN
         DLOOPPTR = CL_PDCHAIN
      %REPEAT
!* IF B-REG HAS BEEN CORRUPTED IN LOOP, & SHOULD CONTAIN AN SR-TEMP,
!*   MAKE SURE THAT 1ST USE OF B-REG IN EACH BLOCK IS OK, & PUT STOREB
!*   TRIADS AFTER INIT, INCRS & DECRS.
      %IF SAVEB # 0 %AND BREGTEMP # 0 %THENSTART
         CHECKBBOEX
         DLOOPPTR = DLOOPHEAD
         %WHILE DLOOPPTR # 0 %CYCLE
            CL == RECORD (ATABS + DLOOPPTR)
            BTEMP (CL_BLOCK)
            DLOOPPTR = CL_PDCHAIN
         %REPEAT
         SR == RECORD (ABLOCKS + BREGTEMP << SRSCALE)
         KEEPB (SR_INIT)
         %FOR I = 1,1,3 %CYCLE
            %IF SR_INCR(I) # 0 %THEN KEEPB (SR_INCR(I))
         %REPEAT
      %FINISH
!
!
!
!
%ROUTINE BLOKCHAIN
!
!***************************************************************************
!* REORDERS & OPTIMISES TEXT IN THE GIVEN BLOCK, INCLUDING CONTROLLING THE *
!*   B REGISTER.                                                           *
!***************************************************************************
!
%INTEGER PTR,CAT
!
%SWITCH PASS1(0:29),PASS2(0:29),PASS3(0:29)
!
      LASTBUT1 = 0
      INITB = 0
      BEFBUSE = 0
      LASTBUSE = 0
      BNEEDED = 0
      BUSED = 0
      BBOEXIT = 0
      %IF SAVEB#0 %THENSTART
         BLOADED=0
         BCORRUPT=1
      %FINISH
!
!* PASS 1.  USES OF REF REPL ETC RESOLVED.  ALL USES OF TEMPS TIDIED UP.
      CURRTRIAD = START
      %WHILE GETNEXT = 1 %CYCLE
         TT == RECORD (ATRIADS + CURRTRIAD * TRIADLENGTH)
         CAT = OPCAT (TT_OP)
         -> PASS1 (CAT)
!
PASS1(0):
!      NEWLINE
!      NEWLINE
!      PRINTSTRING ("ERROR: OPERATOR VALUE ")
!      WRITE (TT_OP,3)
!      NEWLINE
PASS1(1):
PASS1(27):  !* CHAR
      -> PASS1END
PASS1(2):PASS1(3):PASS1(8):
      TT_RES1_W = OPND (TT_RES1,2)
      -> PASS1END
PASS1(4):   !* CGT
      TT_RES1_W = OPND (TT_RES1,2)
      ->CHECKB
PASS1(5):
      TT_RES2_W = OPND (TT_RES2,2)
      %IF TT_MODE<=INT8 %AND TT_MODE2>TT_MODE %THEN ->CHECKB
      -> PASS1END
PASS1(6):   !* JIT JIP JINN JINP JINZ JIN JIP JIZ
PASS1(7):   !* MULT DIV DMULT EXP3 AND OR EQUIV NEQ GT LT NE EQ GE LE RSUB RDIV
            !* ASH
      TT_RES1_W = OPND (TT_RES1,2)
      TT_RES2_W = OPND (TT_RES2,2)
      -> PASS1END
PASS1(19): !* STOREB
      BSAVED = 1
      -> PASS1END
PASS1(22):  !* EXP
      TT_RES1_W = OPND(TT_RES1,2)
      TT_RES2_W = OPND(TT_RES2,2)
      ->CHECKB
PASS1(23): !* MOO
      TT_RES2_W=OPND(TT_RES2,2)
      ->CHECKB
PASS1(26):  !* MOD
      TT_RES1_W=OPND(TT_RES1,2)
PASS1(25):  !* NINT  ANINT  AINT
      TT_RES2_W = OPND (TT_RES2,2)
      ->CHECKB
PASS1(9):   !* SUBR
PASS1(10):  !* FUN IFUN
      ARGCH
      ->Pass1end
PASS1(21):   ! STRTIO  IO
CHECKB:
      %IF BLOADED#0 %AND BSAVED=0 %AND BREGTEMP#0 %THENSTART
!         KEEPB(PREVTRIAD)
         SAVEB=1
         BSAVED=1
      %FINISH
      BCORRUPT=1
      BLOADED=0
      -> PASS1END
PASS1(11):  !* ARG DARG IARG
      ARGCH
      TT_RES1_W = OPND (TT_RES1,2)
DUMPB:%IF TT_QOPD1 = BREG %THENSTART
!         %IF BSAVED=0 %THEN KEEPB(PREVTRIAD)
         BCORRUPT=1
         SAVEB=1
         TT_OPD1 = BRDUMP(BREGTEMP)
         TT_QOPD1 = VALTEMP
         BSAVED=1
         BLOADED=0
      %FINISH
      %IF CAT=13 %THEN ->CHECKB;! for IOITEM, DIOITEM
      -> PASS1END
PASS1(12):
      TT_RES1_W = OPND (TT_RES1,1)
      TT_RES2_W = OPND (TT_RES2,2)
      ASMTCH
      -> PASS1END
PASS1(13):     !* IOITEM  DIOITEM
      TT_RES1_W=OPND (TT_RES1,1)
      %IF BLOADED#0 %AND BSAVED=0 %AND BREGTEMP#0 %THENSTART
!         KEEPB(PREVTRIAD)
         BCORRUPT=1
         SAVEB=1
         BLOADED=0
         BSAVED=1
      %FINISH
      ->DUMPB
PASS1(14):
      LASTBUT1 = PREVTRIAD
      TT_RES1_W = OPND (TT_RES1,2)
      -> PASS1END
PASS1(15):
      ARRTR
      -> PASS1END
PASS1(16):
      INCRTR
      -> PASS1END
PASS1(17):
      TT_RES2_W = OPND (TT_RES2,2)
      INITTR
      -> PASS1END
PASS1(18):
      TT_RES2_W = OPND (TT_RES2,2)
      DT == RECORD (ADICT + TT_OPD1 << DSCALE)
      DT_LOOP = LOOP
      -> PASS1END
PASS1(20):
      TT_OP = REPL
      ->PASS1END
!
PASS1(24):     !* IOSPEC
      TT_RES1_W=OPND (TT_RES1,1)
!
PASS1END:
      %REPEAT
!* IF AN INIT TRIAD HAS BEEN FOUND, CHAIN IT NEAR THE END OF THE BLOCK
!*   (BUT BEFORE GOTO IF PRESENT).
      %UNLESS INITB = 0 %THENSTART
         TT == RECORD (ATRIADS + INITB * TRIADLENGTH)
         TT1 == RECORD (ATRIADS + TT_CHAIN * TRIADLENGTH)
         %IF TT1_OP = STOREB %THEN TT == TT1
         %IF LASTBUT1 = 0 %THEN  %C
                  TT1 == RECORD (ATRIADS + PREVTRIAD * TRIADLENGTH)   %C
            %ELSE TT1 == RECORD (ATRIADS + LASTBUT1 * TRIADLENGTH)
         TT_CHAIN = TT1_CHAIN
         TT1_CHAIN = INITB
      %FINISH
!
!* BLOCK-LEVEL DIAGNOSTICS:
      %IF SRFLAGS & 64 # 0 %THENSTART
         NEWLINE
         NEWLINE
         PRINTSTRING ("BLOCK AFTER OP3B PASS 1")
         NEWLINE
         PRBLOCK (BLOCK)
         PRBLTRIADS (BLOCK)
      %FINISH
!
!* PASS 2.  SET UP A TEXT EXTENSION TABLE TO ANALYSE USE CTS TO DETECT
!*            OUT-OF-BLOCK REFS.
      EXTNSTART = FREETABS
      EXTNEND = EXTNSTART - EXTNSIZE
      CURRTRIAD = START
      %WHILE GETNEXT = 1 %CYCLE
         TT == RECORD (ATRIADS + CURRTRIAD * TRIADLENGTH)
         -> PASS2 (OPCAT (TT_OP))
!
PASS2(0):PASS2(20):
!      NEWLINE
!      NEWLINE
!      PRINTSTRING ("ERROR: OPERATOR VALUE ")
!      WRITE (TT_OP,3)
!      NEWLINE
PASS2(1):PASS2(8):PASS2(14):PASS2(16):PASS2(19):PASS2(21):
      -> PASS2END
PASS2(2):PASS2(4):PASS2(6):PASS2(13):PASS2(24):
      REDUSE (TT_RES1)
      -> PASS2END
PASS2(9):    !* SUBR
PASS2(17):PASS2(18):
PASS2(23):   !* MOO
PASS2(27):   !* CHAR
      REDUSE (TT_RES2)
      -> PASS2END
PASS2(12):
Pass2(15):            {ARR,DEFARR,ARGARR}
      REDUSE (TT_RES1)
      REDUSE (TT_RES2)
      -> PASS2END
PASS2(3):
      REDUSE (TT_RES1)
      CRENT
      -> PASS2END
PASS2(5):PASS2(10):PASS2(25):
      REDUSE (TT_RES2)
      CRENT
      -> PASS2END
PASS2(7):PASS2(11):{PASS2(15):}PASS2(22):PASS2(26):
      REDUSE (TT_RES1)
      REDUSE (TT_RES2)
      CRENT
!
PASS2END:
      %REPEAT
!
!* SCAN THRO' TEXT EXTN TABLE LOOKING FOR TRIADS WHICH HAVE OUTSTANDING
!*    USES, & STORE THEM IN TEMPS.
      %FOR PTR = EXTNSTART,EXTNSIZE,EXTNEND %CYCLE
         EX == RECORD (ATABS + PTR)
         %UNLESS EX_USES = 0 %THENSTART
            TT == RECORD (ATRIADS + EX_TRIAD * TRIADLENGTH)
            %IF TT_OP =ARG %OR TT_OP = DARG %OR TT_OP = IARG   %C
                                        %THEN RESARGS (EX_TRIAD)   %C
                                        %ELSE PRESVAL (EX_TRIAD)
         %FINISH
      %REPEAT
      FREETABS = EXTNSTART
!
      BB_FLAGS=BB_FLAGS!BUSED
      BB_CORRUPT = BCORRUPT
      %IF BCORRUPT = 0 %AND BLOADED # 0 %THENSTART
         BB_FLAGS = BB_FLAGS ! BBOEXBIT
         BBOEXIT=1
      %FINISH
!
!* BLOCK-LEVEL DIAGNOSTICS:
      %IF SRFLAGS & 64 # 0 %THENSTART
         NEWLINE
         NEWLINE
         PRINTSTRING ("BLOCK AFTER OP3B PASS 2")
         NEWLINE
         PRBLOCK (BLOCK)
         PRBLTRIADS (BLOCK)
      %FINISH
!
      CURRTRIAD = START
      %WHILE GETNEXT=1 %CYCLE
         TT==RECORD(ATRIADS+CURRTRIAD*TRIADLENGTH)
         ->PASS3 (OPCAT (TT_OP))
!
PASS3(0):PASS3(20):
PASS3(1):PASS3(8):PASS3(14):PASS3(16):PASS3(19):PASS3(21):PASS3(27):
      -> PASS3END
PASS3(2):PASS3(4):PASS3(6):PASS3(13):PASS3(24):
      TT_QOPD1 = TRSPEC (TT_RES1)
      -> PASS3END
PASS3(9):    !* SUBR
PASS3(17):PASS3(18):
PASS3(23):   !* MOO
      TT_QOPD2 = TRSPEC (TT_RES2)
      -> PASS3END
PASS3(12):
      TT_QOPD1 = TRSPEC (TT_RES1)
      TT_QOPD2 = TRSPEC (TT_RES2)
      -> PASS3END
PASS3(3):
      TT_QOPD1 = TRSPEC (TT_RES1)
      -> PASS3END
PASS3(5):PASS3(10):PASS3(25):
      TT_QOPD2 = TRSPEC (TT_RES2)
      -> PASS3END
PASS3(7):PASS3(11):PASS3(15):PASS3(22):PASS3(26):
      TT_QOPD1 = TRSPEC (TT_RES1)
      TT_QOPD2 = TRSPEC (TT_RES2)
!
PASS3END:
      %REPEAT
!
%END;!   BLOKCHAIN
!
!
!
!
%INTEGERFUNCTION OPND (%RECORD (RESF) OP,%INTEGER BUSE)
!
!**************************************************************************
!* CHECKS WHETHER OPERAND REFERS TO A SR-TEMP OR REPL OR REF, & CHANGES   *
!*   ACCORDINGLY.                                                         *
!* BUSE = 1  POTENTIAL DEFINING OF BREG                                   *
!*        2  POTENTIAL USE OF BREG                                        *
!*        3  MODIFICATION OF BREG                                         *
!*        6  subscript to array el - avoid replacing by destemp           *
!**************************************************************************
!
%INTEGER NEWTR,OPD
!
%RECORD (PRECF) %NAME DD
%RECORD (TRIADF) %NAME TT,TT1
!
%RECORD (RESF) TEPTR,WOPD
!
      %if Op_Mode=CHARMODE %then %result=Op_W
      WOPD = OP
      %CYCLE
         OPD = WOPD_H0
         %IF WOPD_FORM & TEXTMASK = 0 %THEN %EXIT
         TT == RECORD (ATRIADS + OPD * TRIADLENGTH)
         %IF BUSE=6 %THENSTART;! array element - check for dt
            BUSE=2
            %IF TT_OP=REPL %AND TT_QOPD1=DESTEMP %THEN ->L
         %FINISH
         %IF TT_OP = REF %THENSTART
!* REPLACE REF TRIAD BY ASMT-TO-TE & REPL-TO-TE.
            TT_OP = REPL
            %IF TT_QOPD1 & IDMASK # 0 %THENSTART
               DD == RECORD (ADICT + TT_OPD1 << DSCALE)
               %IF DD_CLASS & CMNBIT # 0 %THENSTART
L:                TEPTR_W = CREATETE (TT_MODE)
                  NEWTR = CHAFTER (OPD)
                  TT1 == RECORD (ATRIADS + NEWTR * TRIADLENGTH)
                  TT1_OP = ASMT
                  TT1_RES1 = TEPTR
                  TT1_RES2 = TT_RES1
                  TT_RES1 = TEPTR
               %FINISH
            %FINISH
         %FINISHELSEUNLESS TT_OP = REPL %OR TT_OP = BRK %THENSTART
!* IF TRIAD IS OUT-OF-BLOCK, MUST PRESERVE IN A TEMP.
            %IF OUTBLOCK (OPD) = 0 %THEN %RESULT = WOPD_W   %C
                                   %ELSE PRESVAL (OPD)
         %FINISH
!* REPLACE REF TO REPL OR BRK TRIAD BY THEIR OPD1, & TRY AGAIN.
         ELIM (OPD)
         WOPD = TT_RES1
      %REPEAT
!* REFERENCES TO SR-TEMP ARE REPLACED BY B-REG, IF VALID FOR THIS LOOP,
!*   OR A SUITABLE VALTEMP.
      %IF WOPD_FORM = SRTEMP %THENSTART
         %IF OPD = BREGTEMP %THENSTART
            BUSED = BUSEDBIT
            %UNLESS BUSE=1 %THENSTART;! unless defining only
               %IF BLOADED=0 %THENSTART
                RESETB(PREVTRIAD)
                    BSAVED=1
               %FINISH
               BLOADED=1
            %FINISH
            %UNLESS BUSE=2 %THEN BSAVED=0
            Bregop_Mode=Wopd_Mode
            %RESULT = BREGOP_W
         %FINISH
         WOPD_H0 = BRDUMP(OPD)
         WOPD_FORM = VALTEMP
         %RESULT = WOPD_W
      %FINISH
!     %IF WOPD_FORM & IDMASK # 0 %THENSTART
!
!* CODE REQUIRED HERE TO OPTIMISE THE ACCESSING OF COMMON ITEMS IN LOOPS
!*   (EITHER BY DESCRIPTOR OR BY XNB OR CTB).
!
!     %FINISH
      %RESULT = WOPD_W
!
%END;!   OPND
!
!
!
!
%ROUTINE ARGCH
!
!***********************************************************************
!* PROCESSES OUT-OF-BLOCK ARGUMENT CHAIN.                              *
!***********************************************************************
!
%INTEGER CHARG,NEWTR
!
%RECORD (TRIADF) %NAME TT,TT1
!
      TT == RECORD (ATRIADS + CURRTRIAD * TRIADLENGTH)
      %WHILE TT_QOPD2 # NULL %CYCLE
         CHARG = TT_OPD2
         TT1 == RECORD (ATRIADS + CHARG * TRIADLENGTH)
         %UNLESS TT1_OP = REPL %OR TT1_OP = BRK %THENSTART
            %IF OUTBLOCK (CHARG) = 0 %THEN %EXIT
!* IF ARG IS OUT-OF-BLOCK, BRING A COPY INTO THIS BLOCK, ADJUSTING
!*   USE-CTS ACCORDINGLY.
            NEWTR = CHAFTER (PREVTRIAD)
            TT_OPD2 = NEWTR
            TT == RECORD (ATRIADS + NEWTR * TRIADLENGTH)
            TT_RES1=TT1_RES1
            TT_RES2=TT1_RES2
            TT_OP=TT1_OP
            TT_USE=1
            %IF TT1_USE # 1 %AND TT1_QOPD1 & TEXTMASK # 0 %THENSTART
               TT == RECORD (ATRIADS + TT1_OPD1 * TRIADLENGTH)
               TT_USE = TT_USE + 1
            %FINISH
            TT == RECORD (ATRIADS + NEWTR * TRIADLENGTH)
            TT_RES1_W = OPND (TT_RES1,2)
            %IF TT_QOPD1 = BREG %THENSTART
               TT_OPD1 = BRDUMP(BREGTEMP)
               TT_QOPD1 = VALTEMP
            %FINISH
         %FINISHELSESTART
            TT_OPD2 = TT1_OPD2
         %FINISH
         ELIM (CHARG)
!* LOOP BACK TO CONSIDER NEXT ARG, IF ANY.
      %REPEAT
!
%END;!   ARGCH
!
!
!
!
%ROUTINE ASMTCH
!
!**********************************************************************
!* RECHAINS ASMT-TO-TE TRIADS.                                        *
!**********************************************************************
!
%RECORD (TERECF) %NAME TE
!
%INTEGER CHAIN
!
      %IF TT_QOPD1 = VALTEMP %THENSTART
         TE == RECORD (ADICT + TT_OPD1 << DSCALE)
         TE_LOOP = LOOP
         %IF TT_QOPD2 & TEXTMASK # 0 %THENSTART
            TT1 == RECORD (ATRIADS + TT_OPD2 * TRIADLENGTH)
            CHAIN = TT1_CHAIN
            %UNLESS CHAIN = CURRTRIAD %THENSTART
!* RECHAIN ASMT TRIAD AFTER OPD2 TRIAD.
               TT1_CHAIN = CURRTRIAD
               TT1 == RECORD (ATRIADS + PREVTRIAD * TRIADLENGTH)
               TT1_CHAIN = TT_CHAIN
               TT_CHAIN = CHAIN
               CURRTRIAD=PREVTRIAD;! to avoid looping if same text assigned to several Valtemps
            %FINISH
         %FINISH
      %FINISH
!
%END;!   ASMTCH
!
!
%ROUTINE ARRTR
!@@!!
!@@!!**************************************************************************
!@@!!* PROCESSES SUBSCRIPTION TRIADS.  REPLACES BY D-TEMPS IF SUBSCRIPT IS    *
!@@!!*   CONSTANT & ARRAY IS NOT A DUMMY ARGUMENT.                            *
!@@!!**************************************************************************
!@@!!
!@@!%RECORD (PRECF) %NAME DD
!@@!%RECORD (DTRECF) %NAME DT
!@@!!
!@@!%RECORD (RESF) DTPTR
!@@!!
!@@!      %IF TARGET=ICL2900 %AND TT_QOPD2 & CONSTMASK # 0 %AND %C
!@@!        TT_MODE#CHARMODE %AND TT_QOPD1 & IDMASK # 0 %THENSTART
!@@!         DD == RECORD (ADICT + TT_OPD1 << DSCALE)
!@@!         %UNLESS DD_CLASS & 1 # 0 %THENSTART
!@@!            OLDDTCH = DTCH
!@@!            DTPTR_W = CREATEDT (TT_MODE)
!@@!            DT == RECORD (ADICT + DTPTR_H0 << DSCALE)
!@@!            DT_CONST = TT_RES2
!@@!            DT_FLAGS = INITLOADBIT
!@@!            %IF TT_OP = ARGARR %AND   %C
!@@!                (TT_MODE = CHARMODE %OR TT_MODE = INT2) %THENSTART
!@@!               DT_FLAGS = INITLOADBIT ! ACTARGBIT
!@@!            %FINISH
!@@!            TT_OP = REPL
!@@!            DT_IDENT = TT_OPD1
!@@!            DTPTR_H0 = DTDUPL (DTPTR_H0);!   REMOVE DUPLICATE IF PRESENT.
!@@!            TT_RES1 = DTPTR
!@@!         %FINISH
!@@!      %FINISHELSESTART ;! no benefit on other systems
         TT_RES2_W = OPND (TT_RES2,6)
!@@!      %FINISH
      TT_RES1_W = OPND (TT_RES1,2)
!
%END;!   ARRTR
!
!
!
%ROUTINE INCRTR
!
!************************************************************************
!* IF OPND1 IS SR-TEMP (I.E. WILL BE B-REG), AND FOLLOWING TRIAD IS     *
!*   ALSO INCR, SWAP THEM.                                              *
!*   IF OPND1 IS D-TEMP, CHAIN AFTER LAST USE.                          *
!************************************************************************
!
%INTEGER TRID,USETRID
!
%RECORD (RESF) OPD1
!
      %IF TT_QOPD1 = SRTEMP %THENSTART
         %IF BLOADED=0 %THEN RESETB(PREVTRIAD)
         BLOADED=1
         BSAVED=0
         %CYCLE
            TRID = TT_CHAIN
            TT1 == RECORD (ATRIADS + TRID * TRIADLENGTH)
            %IF TT1_OP # NULL %THEN %EXIT
            TT_CHAIN = TT1_CHAIN
            TT1_CHAIN = FREETRIADS
            FREETRIADS = TRID
         %REPEAT
         %UNLESS TT1_OP = INCR %OR TT1_OP = DECR %THEN -> L1
         TT_CHAIN = TT1_CHAIN
         TT == RECORD (ATRIADS + PREVTRIAD * TRIADLENGTH)
         TT1_CHAIN = CURRTRIAD
         TT_CHAIN = TRID
         CURRTRIAD = TRID
         TT == TT1
      %FINISH
      %IF TT_QOPD1 # DESTEMP %THEN -> L1
!* TRIAD INCREMENTS A DESCRIPTOR.  CHAIN AFTER LAST USE, OR LAST IFUN
!*   (IF ANY), IN THIS BLOCK.
      USETRID = 0
      OPD1 = TT_RES1
      TRID = START
      TT1 == RECORD (ATRIADS + TRID * TRIADLENGTH)
      %CYCLE
         TRID = TT1_CHAIN
         %IF TRID = CURRTRIAD %THEN %EXIT
         TT1 == RECORD (ATRIADS + TRID * TRIADLENGTH)
         %UNLESS TT1_RES1_W = OPD1_W %OR TT1_RES2_W = OPD1_W %THENSTART
            %UNLESS TT1_OP = IFUN %OR TT1_OP=FUN  %C
              %OR TT1_OP=MOO %OR TT1_OP=SUBR %THEN %CONTINUE
         %FINISHELSESTART
            %IF TT1_OP = STMT %OR TT1_OP = REPL %OR TT1_OP = NULL %C
                                        %THEN %CONTINUE
         %FINISH
         USETRID = TRID
      %REPEAT
      TT1==RECORD(ATRIADS+USETRID*TRIADLENGTH)
      %UNLESS USETRID = 0 %OR TT1_OP = ARR %C
                            %OR TT1_OP = DEFARR %OR TT1_OP = ARGARR   %C
                            %OR TT1_CHAIN = CURRTRIAD %THENSTART
         TRID = TT_CHAIN
         TT_CHAIN = TT1_CHAIN
         TT1_CHAIN = CURRTRIAD
         TT1 == RECORD (ATRIADS + PREVTRIAD * TRIADLENGTH)
         TT1_CHAIN = TRID
         TT_OP = PINCR
         TT_RES2_W = OPND (TT_RES2,2)
         TT_RES1_W = OPND (TT_RES1,1)
         CURRTRIAD = PREVTRIAD
      %FINISHELSESTART
   L1:   TT_RES2_W = OPND (TT_RES2,2)
         TT_RES1_W = OPND (TT_RES1,1)
      %FINISH
!
%END
!
!
!
!
%ROUTINE INITTR
!
!**********************************************************************
!* REMOVES INIT TRIAD (TOGETHER WITH FOLLOWING STOREB IF PRESENT),    *
!*   FOR CHAINING IN AT END OF BLOCK.                                 *
!**********************************************************************
!
%INTEGER CHAIN
!
%RECORD (TERECF) %NAME TE
!
      INITB = CURRTRIAD
      CHAIN = TT_CHAIN
      TT1 == RECORD (ATRIADS + CHAIN * TRIADLENGTH)
      %IF TT1_OP = STOREB %THENSTART
         TE == RECORD (ADICT + TT1_OPD1 << DSCALE)
         TE_LOOP = LOOP
         CHAIN = TT1_CHAIN
      %FINISH
      TT == RECORD (ATRIADS + PREVTRIAD * TRIADLENGTH)
      TT_CHAIN = CHAIN
      CURRTRIAD = PREVTRIAD 
!
%END;!   INITTR
!
!
!
!
%INTEGERFUNCTION BRDUMP(%INTEGER BREGTEMP)
!
!*****************************************************************************
!* FINDS OR CREATES A VALTEMP ENTRY IN WHICH TO SAVE THE VALUE OF THE        *
!*   SR-TEMP MAPPED ONTO B-REG.                                              *
!*****************************************************************************
!
%RECORD (SREDF) %NAME SR
%RECORD (RESF) TEPTR
!
%RECORD (TERECF) %NAME TE
!
      SR == RECORD (ABLOCKS + BREGTEMP << SRSCALE)
      %IF SR_DUMP # 0 %THEN %RESULT = SR_DUMP
      Bregmode=Sr_Mode
      TEPTR_W = CREATETE (Bregmode)
      TE == RECORD (ADICT + TEPTR_H0 << DSCALE)
      TE_FLAGS = SRTEMPBIT
      SR_DUMP = TEPTR_H0
      %RESULT = TEPTR_H0
!
%END;!   BRDUMP
!
!
!
!
%INTEGERFUNCTION OUTBLOCK (%INTEGER TR)
!
!***********************************************************************
!* DECIDES IF GIVEN TRIAD IS DEFINED OUTSIDE CURRENT BLOCK.            *
!*   IF SO RETURNS 1, ELSE 0.                                          *
!***********************************************************************
!
%INTEGER TRID
!
%RECORD (TRIADF) %NAME TT
!
      TRID = START
      %CYCLE
         TT == RECORD (ATRIADS + TRID * TRIADLENGTH)
         TRID = TT_CHAIN
         %IF TRID = TR %THEN %RESULT = 0
         %IF TRID = CURRTRIAD %THEN %RESULT = 1
      %REPEAT
!
%END;!   OUTBLOCK
!
!
!
!
%ROUTINE PRESVAL (%INTEGER TR)
!
!***********************************************************************
!* SAVES INPUT EXPRESSION IN A VALTEMP OR DESTEMP ENTRY, IF NECESSARY. *
!***********************************************************************
!
%INTEGER MODE,FLAG,DICT,NEWTR1,NEWTR2,NEWOP,CHAIN
!
%RECORD (RESF) QTEMP
%RECORD (TRIADF) %NAME TT,TT1,TT2
%RECORD (PRECF) %NAME DD
%RECORD (DTRECF) %NAME DT
%RECORD (TERECF) %NAME TE
!
      TT == RECORD (ATRIADS + TR * TRIADLENGTH)
      %if GT<=TT_Op<=LE %then Mode=LOG4 %else Mode=TT_Mode
     %if TT_MODE<=REAL8 %AND CMPLX8<=TT_MODE2<=CMPLX32 %then  %c
           Mode=TT_MODE2
      %IF TT_OP = ARGARR %THENSTART
         %IF MODE = INT2 %OR MODE = CHARMODE %THEN FLAG = ACTARGBIT   %C
                                             %ELSE FLAG = 0
         -> L1
      %FINISHELSEIF TT_OP = DEFARR %OR (TT_OP = ARR %AND MODE = CHARMODE) %C
                                        %THENSTART
         FLAG = 0
!* IF EXPRESSION IS A SUBSCRIPTION, EITHER AS LHS OF ASMT, OR AS ACT ARG,
!*   OR CHAR, WE NEED A DESCRIPTOR, SO SAVE IN A DESTEMP.
   L1:   DICT = ARBASE (TT_RES1)
         OLDDTCH = DTCH
         QTEMP_W = CREATEDT (MODE)
         DT == RECORD (ADICT + QTEMP_H0 << DSCALE)
         DT_LOOP = 0
         DT_FLAGS = FLAG
         DT_IDENT = DICT
         NEWOP = DINIT
!* CHECK IF DESTEMP SUITABLE FOR GENERATION BY LOADER.
         %IF TT_QOPD2 & CONSTMASK # 0 %AND TT_QOPD1 & IDMASK # 0 %THENSTART
            DD == RECORD (ADICT + TT_OPD1 << DSCALE)
            %IF DD_CLASS & 1 = 0 %THENSTART
               FLAG = FLAG ! INITLOADBIT
               DT_FLAGS = FLAG
               DT_CONST = TT_RES2
               QTEMP_H0 = DTDUPL (QTEMP_H0);!   REMOVE DUPLICATE IF PRESENT.
               -> L2
            %FINISH
         %FINISH
      %FINISHELSESTART
!* NOT SUITABLE FOR DESTEMP, SO STORE IN A VALTEMP.
         QTEMP_W = CREATETE (MODE)
         TE == RECORD (ADICT + QTEMP_H0 << DSCALE)
         TE_LOOP = 0
         TE_FLAGS = 0
         NEWOP = ASMT
      %FINISH
      NEWTR1 = CHAFTER (TR)
      TT1 == RECORD (ATRIADS + NEWTR1 * TRIADLENGTH)
      CHAIN = TT1_CHAIN
      TT1 = TT
      TT1_CHAIN = CHAIN
      TT1_USE = 1
      NEWTR2 = CHAFTER (NEWTR1)
      TT2 == RECORD (ATRIADS + NEWTR2 * TRIADLENGTH)
      TT2_OP = NEWOP
      TT2_OPD2 = NEWTR1
      TT2_MODE2 = MODE
      TT2_QOPD2 = TRIAD
      TT2_RES1 = QTEMP
L2:   TT_RES1 = QTEMP
      TT_OP = REPL
!
%END;!   PRESVAL
!
!
!
!
%INTEGERFUNCTION DTDUPL (%INTEGER DPTR)
!
!*************************************************************************
!* CHECK FOR DUPLICATE LOADER-INITIALISED DTEMP.  IF FOUND DELETE NEW    *
!*   ENTRY AND RETURN POINTER TO OLD ONE.                                *
!*************************************************************************
!
%INTEGER PTR
!
%RECORD (DTRECF) %NAME DT1,DT2
!
      DT1 == RECORD (ADICT + DPTR << DSCALE)
      PTR = DESTEMPHEAD
      %CYCLE
         %IF PTR = DPTR %THEN %RESULT = PTR
         DT2 == RECORD (ADICT + PTR << DSCALE)
         %IF DT1_IDENT = DT2_IDENT %AND   %C
             DT1_CONST_W = DT2_CONST_W %AND   %C
             DT1_FLAGS = DT2_FLAGS %THEN %EXIT
         PTR = DT2_CHAIN
      %REPEAT
      DTCH = OLDDTCH
      INTEGER (DTCH+ADICT) = 0; ! DTCH MUST ALWAYS BE RELATIVE TO ADICT HERE
      %RESULT = PTR
!
%END;!   DTDUPL
!
!
!
!
%ROUTINE REDUSE (%RECORD (RESF) OP)
!
!*************************************************************************
!* FINDS TEXT EXTN ENTRY FOR A TRIAD, & REDUCES ITS USE CT BY 1.         *
!*************************************************************************
!
%INTEGER PTR 
!
      %IF OP_FORM & TEXTMASK # 0 %THENSTART
         %FOR PTR = EXTNSTART,EXTNSIZE,EXTNEND %CYCLE
            EX == RECORD (ATABS + PTR)
            %IF EX_TRIAD = OP_H0 %THENSTART
               EX_USES = EX_USES - 1
               %RETURN
            %FINISH
         %REPEAT
      %FINISH
!
%END;!   REDUSE
!
!
!
!
%ROUTINE CRENT
!
!***************************************************************************
!* CREATES AN ENTRY IN THE TEXT EXTN TABLE FOR CURRENT TRIAD, &            *
!*   INITIALISES IT.                                                       *
!***************************************************************************
!
      EXTNEND = CREATETAB (EXTNSIZE)
      EX == RECORD (ATABS + EXTNEND)
      EX_TRIAD = CURRTRIAD
      EX_USES = TT_USE
!
%END;!   CRENT
!
!
!
!
%ROUTINE BTEMP (%INTEGER BL)
!
!***************************************************************************
!* IF NECESSARY PUTS A LOADB IN FRONT OF FIRST USE OF B-REG IN A BLOCK.    *
!***************************************************************************
!
%RECORD (BLRECF) %NAME BB,BB1
%RECORD (CONRECF) %NAME CN
%RECORD (TRIADF) %NAME TT
!
%INTEGER I,PTR,NEXT,TRID
!
      BB == RECORD (ABLOCKS + BL * BLSIZE)
      CN == RECORD (ATABS + BB_BCON)
      %FOR I = 1,1,CN_COUNT %CYCLE
         %UNLESS CN_BLOCK(I) = 0 %THENSTART
            BB1 == RECORD (ABLOCKS + CN_BLOCK(I) * BLSIZE)
            %IF BB1_DEPTH < LOOPDEPTH %THEN %CONTINUE
            %IF BB1_DEPTH = LOOPDEPTH %AND BB1_FLAGS & BBOEXBIT # 0   %C
                                        %THEN %CONTINUE
!* B-REG IS NOT BUSY ON EXIT
            PTR = BB_TEXT
            TT == RECORD (ATRIADS + PTR * TRIADLENGTH)
            %CYCLE
               NEXT = TT_CHAIN
               TT == RECORD (ATRIADS + NEXT * TRIADLENGTH)
               %IF (BREGOPN (TT_RES1) = 1 %OR BREGOPN (TT_RES2) = 1) %THENSTART
                  %IF TT_OP = LOADB %THEN ->SCAN
                  %IF TT_OP = INIT %AND TT_QOPD1 = BREG %THEN ->SCAN
                  TRID = CHAFTER (PTR)
                  TT == RECORD (ATRIADS + TRID * TRIADLENGTH)
                  TT_OP = LOADB
                  TT_RES1 = BREGOP
                  TT_QOPD2 = VALTEMP
                  TT_OPD2 = BRDUMP(BREGTEMP)
                  TT_Mode=Bregmode
                  TT_MODE2 = Bregmode
SCAN:             %CYCLE
                     NEXT=TT_CHAIN
                     TT==RECORD(ATRIADS+NEXT*TRIADLENGTH)
                     %IF CORRUPTB(OPCAT(TT_OP))#0 %THEN ->AGAIN
                  %REPEAT %UNTIL TT_OP=STMT %AND TT_USE&SOB#0
                  %RETURN
               %FINISH
AGAIN:         PTR = NEXT
            %REPEAT %UNTIL TT_OP = STMT %AND TT_USE & SOB # 0
            %RETURN
         %FINISH
      %REPEAT
      %IF BB_CORRUPT = 0 %THEN BB_FLAGS = BB_FLAGS ! BBOEXBIT
!
%END;!   BTEMP
!
!
!
!
%ROUTINE RESARGS (%INTEGER TR)
!
!**************************************************************************
!* ENSURES THAT EXPRESSIONS IN AN OUT-OF-BLOCK ARG-CHAIN ARE SAVED IN     *
!*   VALTEMP OR DESTEMP ENTRIES, IF THEY ARE EXPRESSIONS OR ARRAY ELMTS.  *
!**************************************************************************
!
%RECORD (TRIADF) %NAME TT
!
%INTEGER TRID
!
      TRID = TR
      %CYCLE
         TT == RECORD (ATRIADS + TRID * TRIADLENGTH)
         %IF TT_QOPD1 & TEXTMASK # 0 %THEN PRESVAL (TT_OPD1)
         TRID = TT_OPD2
      %REPEAT %UNTIL TT_QOPD2 & TEXTMASK = 0
!
%END;!   RESARGS
!
!
!
!
%ROUTINE KEEPB (%INTEGER TR)
!
!*************************************************************************
!* GENERATES A TRIAD TO PRESERVE CONTENTS OF B-REG IN A VALTEMP.         *
!*************************************************************************
!
%RECORD (TRIADF) %NAME TT
!
%INTEGER TRID
!
      TRID = CHAFTER (TR)
      TT == RECORD (ATRIADS + TRID * TRIADLENGTH)
      TT_OP = STOREB
      TT_QOPD1 = VALTEMP
      TT_OPD1 = BRDUMP(BREGTEMP)
      TT_MODE = Bregmode
      TT_RES2 = BREGOP
      TT_Mode2=Bregmode
!
%END;!   KEEPB
!
!
!
!
%ROUTINE RESETB (%INTEGER TR)
!
!*************************************************************************
!* GENERATES A TRIAD TO RELOAD CONTENTS OF B-REG FROM A VALTEMP.         *
!*************************************************************************
!
%RECORD (TRIADF) %NAME TT
!
%INTEGER TRID
!
      TRID = CHAFTER (TR)
      TT == RECORD (ATRIADS + TRID * TRIADLENGTH)
      TT_OP = LOADB
      TT_RES1 = BREGOP
      TT_QOPD2 = VALTEMP
      TT_OPD2 = BRDUMP(BREGTEMP)
      TT_MODE2 = Bregmode
      TT_MODE = Bregmode
      BSAVED = 1;! avoid redundant stores
!
%END;!   RESETB
!
!
!
!
%INTEGERFUNCTION BREGOPN (%RECORD (RESF) OP)
!
!*************************************************************************
!* DETERMINE WHETHER THE GIVEN OPERAND IS, OR USES, B-REG.               *
!*************************************************************************
!
%RECORD (TRIADF) %NAME TT
!
      %IF OP_FORM = BREG %THEN %RESULT = 1
      %UNLESS OP_FORM & TEXTMASK # 0 %THEN %RESULT = 0
      TT == RECORD (ATRIADS + OP_H0 * TRIADLENGTH)
      %UNLESS TT_OP = ARR %OR TT_OP = DEFARR %OR TT_OP = ARGARR %C
                                        %THEN %RESULT = 0
      %IF TT_QOPD2 = BREG %THEN %RESULT = 1   %C
                          %ELSE %RESULT = 0
!
%END;!   BREGOPN
!
!
!
!
%INTEGERFUNCTION GETNEXT
!
!************************************************************************
!* GETS NEXT TRIAD, CHAINING OUT ANY NULLS, AND USING POINTERS CURR-    *
!*   AND PREV-TRIAD.                                                    *
!************************************************************************
!
      PREVTRIAD = CURRTRIAD
      %CYCLE
         TT == RECORD (ATRIADS + PREVTRIAD * TRIADLENGTH)
         CURRTRIAD = TT_CHAIN
         %IF CURRTRIAD=0 %THEN %RESULT=0
         TT == RECORD (ATRIADS + CURRTRIAD * TRIADLENGTH)
         %IF TT_OP = STMT %AND TT_USE & SOB # 0 %THEN %RESULT = 0
         %UNLESS TT_OP = NULL %THEN %RESULT = 1
         TT1 == RECORD (ATRIADS + PREVTRIAD * TRIADLENGTH)
         TT1_CHAIN = TT_CHAIN
         TT_CHAIN = FREETRIADS
         FREETRIADS = CURRTRIAD
      %REPEAT
!
%END;!   GETNEXT
!
%INTEGERFN TRSPEC(%RECORD(RESF) R)
!***********************************************************************
!* ENSURE THAT TRIAD AND ARREL OPERATORS ARE CORRECTLY SET             *
!* FOR ARREL REFERENCES RELOAD BREG IF NECESSARY                       *
!***********************************************************************
%RECORD(TRIADF)%NAME TR,TT
%RECORD(SREDF)%NAME SR
%INTEGER CHAIN,CAT
      %UNLESS R_FORM&TEXTMASK#0 %THEN %RESULT=R_FORM
      TR==RECORD(ATRIADS+R_H0*TRIADLENGTH)
      CAT=OPCAT(TR_OP)
      %IF CAT=15 %AND (TR_USE<2 %OR TR_MODE=CHARMODE) %THENSTART;! ARRAY ELEMENT
!* must now check whether this reference will require Breg to be reloaded
         %IF TR_QOPD2=BREG %THENSTART;! possible
            CHAIN=TR_CHAIN
            %WHILE CHAIN#CURRTRIAD %CYCLE
               TT==RECORD(ATRIADS+CHAIN*TRIADLENGTH)
               %IF CORRUPTB(OPCAT(TT_OP))#0 %THENSTART
                  %UNLESS TT_OP=CVT %AND TT_MODE>INT8 %THENSTART;! only CVT -> int causes problems
                     SR==RECORD(ABLOCKS+BREGTEMP<<SRSCALE)
                     %IF SR_DUMP=0 %THEN KEEPB(PREVTRIAD)
                     TR_OPD2=BRDUMP(BREGTEMP)
                     TR_QOPD2=VALTEMP
                     %RESULT=ARREL
                  %FINISH
               %FINISH
               CHAIN=TT_CHAIN
            %REPEAT
         %FINISH
         %RESULT=ARREL
      %FINISHELSESTART
         %IF CAT=15 %AND CMPLX8<=TR_MODE<=CMPLX32 %THEN %RESULT=ARREL %C
                                                  %ELSE %RESULT=TRIAD
      %FINISH
%END;! TRSPEC
!
%ROUTINE CHECKBBOEX
!
!***********************************************************************
!* ENSURE THAT BBOEXBIT IS NOT SET ERRONEOUSLY                         *
!***********************************************************************
!
%RECORD(BLRECF)%NAME BB,BB1
%RECORD(CONRECF)%NAME CN
%RECORD(CLOOPRECF)%NAME CL
%INTEGER CHECK,DLOOPPTR,I
      %UNTIL CHECK=0 %CYCLE
         CHECK=0
         DLOOPPTR=DLOOPHEAD
         %WHILE DLOOPPTR#0 %CYCLE
            CL==RECORD(ATABS+DLOOPPTR)
            BB==RECORD(ABLOCKS+CL_BLOCK*BLSIZE)
            %IF BB_FLAGS&BBOEXBIT=0 %THENSTART
               CN==RECORD(ATABS+BB_FCON)
               %FOR I=1,1,CN_COUNT %CYCLE
                  %UNLESS CN_BLOCK(I)=0 %THENSTART
                     BB1==RECORD(ABLOCKS+CN_BLOCK(I)*BLSIZE)
                     %IF BB1_FLAGS & BUSEDORBOE = BBOEXBIT %THENSTART
                        BB1_FLAGS = BB1_FLAGS & NOTBBOEX
                        CHECK = 1
                     %FINISH
                  %FINISH
               %REPEAT
            %FINISH
            DLOOPPTR=CL_PDCHAIN
         %REPEAT
      %REPEAT
%END;! CHECKBBOEX
!
%END;!   TEXTPASS
!
!
%ENDOFFILE