!                                                            f1opt1
! 07/12/86 - copy of ftn1opt3
!          - insert include files
! 05/07/86 - avoid setting use bit for CVT when also assignment (complex ops)
! 02/12/85 - taken from op147,new include files incorporated
! 07/11/85 - set DEF bit if mode of opd1 is char, at SWTR(IOSPEC)
! 3//6/85  - insert check for POSLEB at SKIP3 in TOPOLOGY
! 31/10/84 - set NEWBLFLAG=1 at SWTR(IOSPEC)
! 08/10/84 - remove call to GENBLOCK
! 19/07/84 - GENBLOCK  corrected to insert a new label in 1st triad
!            of new block if required
!          - LPPTR now deals with LEBs for multiple loops
! 02/07/84 - at SWTR(ASMT) set USE bit for opd2 before DEF bit for opd1
!            set NEWBLFLAFG in IOSPEC switch
! 02/04/84 - new code in BLOCKS to deal with list-directed I/O
! 31/01/84 - UPDATE SETUSE FOR DCMPLX & INTRIN
! 31/01/84 - NEW TRIADS DCMPLX, INTRIN, (IFUN)
! 17/01/84 - REMAP ON TO A TABLE IF ITS FULL ROUTINE HAS BEEN CALLED
! 12/01/84 - MAKE BIT STRIP ADDRESSES RELATIVE IN A BLOCK ENTRY
! 31/10/83 COPIED FROM ERCS06.REL8002_OP1B15
!*
%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
!*
%routine Fill(%integer Length,Fbase,Fdisp,Filler)
!***********************************************************************
!* fill Length bytes from fbase(fdisp) with Filler                     *
!***********************************************************************
%integer I,From
      %if Length<=0 %then %return
      From=Fbase+Fdisp
      %cycle I=0,1,Length-1
         byteinteger(From+I)=Filler
      %repeat
%end;! Fill
!*
%routine Zero(%integer Addr,Length)
!***********************************************************************
!* Set Length (a multiple of 4) bytes to zero                          *
!***********************************************************************
%integer I
      I=0
      %while I<Length %cycle
         integer(Addr+I)=0
         I=I+4 {bytes}
      %repeat
%end;! Zero
!*
!*
%EXTERNALINTEGERFNSPEC GETPLABDICT
!
%ownINTEGER TRACE
!
%CONSTINTEGER ENTBIT=X'40'; ! BLOCK HAS BEEN ENTERED
%CONSTINTEGER ENTBITOFF=X'BF'

%OWNRECORD(BLRECF)%NAME PRBL

%ROUTINE BDUMPTRACE
TRACE=OPTFLAGS&BDUMP
%END
!
%ROUTINE PRBLHEAD(%INTEGER BLIND)
PRINTSTRING("BLOCK")
WRITE(BLIND,1)
NEWLINE
%END

%ROUTINE PRBLFIELDS
PRINTSTRING("DEPTH                   ");WRITE(PRBL_DEPTH,1);NEWLINE
PRINTSTRING("BACK DOMINATOR BLOCK    ");WRITE(PRBL_BDOM,1);NEWLINE
PRINTSTRING("BACK TARGET BLOCK       ");WRITE(PRBL_BTARG,1);NEWLINE
PRINTSTRING("BLOCK FOLLOWING         ");WRITE(PRBL_CHAIN,1);NEWLINE
PRINTSTRING("1ST TRIAD OF BLOCK      ");WRITE(PRBL_TEXT,1);NEWLINE
PRINTSTRING("ADDRESS OF USE BIT STRIP RELATIVE TO START OF BLOCK TABLE")
WRITE(PRBL_USE,1);NEWLINE
PRINTSTRING("ADDRESS OF DEF BIT STRIP RELATIVE TO START OF BLOCK TABLE")
WRITE(PRBL_DEF,1);NEWLINE
PRINTSTRING("ADDRESS OF BOE BIT STRIP RELATIVE TO START OF BLOCK TABLE")
WRITE(PRBL_BOE,1);NEWLINE
PRINTSTRING("FLAGS SET               ");WRITE(PRBL_FLAGS,1);NEWLINE
%END

%ROUTINE PRFCONS(%INTEGER FCONPTR)
%RECORD(CONRECF)%NAME CON
%INTEGER I
%IF FCONPTR#0 %START
  CON==RECORD(ATABS+FCONPTR)
  %IF CON_COUNT=0 %THEN %C
    PRINTSTRING("BLOCK TERMINATED BY STOP OR GOTO I(I UNASSIGNED)") %C
  %ELSESTART
    PRINTSTRING("FORWARD CONNECTIONS TO BLOCKS")
    WRITE(CON_BLOCK(I),1) %FOR I=1,1,CON_COUNT
  %FINISH
%FINISHELSE PRINTSTRING("NO FORWARD CONNECTIONS")
NEWLINE
%END; ! PRFCONS
!
%ROUTINE PRBCONS(%INTEGER BCONPTR)
%RECORD(CONRECF)%NAME CON
%INTEGER I
%IF BCONPTR#0 %START
  CON==RECORD(ATABS+BCONPTR)
  %IF CON_COUNT=0 %THEN %C
    PRINTSTRING("CONTROL CAN NEVER REACH THIS BLOCK") %C
  %ELSESTART
    PRINTSTRING("BACKWARD CONNECTIONS TO BLOCKS")
    WRITE(CON_BLOCK(I),1) %FOR I=1,1,CON_COUNT
  %FINISH
%FINISHELSE PRINTSTRING("NO BACKWARD CONNECTIONS")
NEWLINE
%END; ! PRBCONS

%ROUTINE PRBLCONS
PRFCONS(PRBL_FCON)
PRBCONS(PRBL_BCON)
%END; ! PRBLCONS
!
%ROUTINE PRINT3BS(%INTEGER BLOCKPOINT)
%RECORD(BLRECF) %NAME BB
%INTEGERARRAYFORMAT BF(0:15)
%INTEGERARRAYNAME B
!
  BB==RECORD(BLOCKPOINT)
  B==ARRAY(BB_USE+ABLOCKS,BF)
  PRINTSTRING("USE ")
  PRINTBS(B)
!
  B==ARRAY(BB_DEF+ABLOCKS,BF)
  PRINTSTRING("DEF ")
  PRINTBS(B)
!
  B==ARRAY(BB_BOE+ABLOCKS,BF)
  PRINTSTRING("BOE ")
  PRINTBS(B)
%END
!*
!*
!*
%EXTERNALROUTINESPEC TOPOLOGY
%EXTERNALROUTINESPEC SETBITS(%RECORD(RESF) RES,
                                  %INTEGER ADDR,USEORDEF,TRIND)

%EXTERNALROUTINE BLOCKS(%INTEGER GTOLABPTR)

%RECORD(BLRECF)%NAME BL,TMPBL
%RECORD(TRIADF)%NAME TR
%RECORD(CONRECF)%NAME CON
%RECORD(SRECF)%NAME GTOLABS,BLKS
%RECORD(LABRECF)%NAME LAB
%INTEGERARRAYNAME ENTBTAB,EXBTAB
%INTEGERARRAYFORMAT TABF(0:100)

!%CONSTBYTEINTEGERARRAY BSDO(0:20)=
!                       0,0,0,0,1,1,1,1,1,1,0,0,0,0,0,1,1,1,0,1,1

! ARRAY FOR TRIADS WHICH HAVE THEIR USE COUNT SET
%CONSTBYTEINTEGERARRAY SETUSE(0:116) =
                                     0,0,1,1,1,1,1,0,1,1,
                                     1,0,0,0,1,1,1,1,1,1,
                                     1,1,1,1,1,1,1,1,1,1,
                                     1,0,0,0,0,0,0,0,0,0,
                                     1,1,1,1,1,1,0,0,0,0,
                                     0,0,0,0,0,0,0,0,0,0, {SET BIT FOR ARGARR ???
                                     0,0,0,0,0,1,0,1,0,0,
                                     0,1,1,1,0,0,0,0,1,0,
                                     0,0,0,0,0,0,0,0,0,0,
                                     0,0,0,0,1,1,0,0,0,1,
                                     1,1,1,1,1,1,1,1,1,1,
                                     1,1,1,1,1,1,1

%OWNINTEGER LDIO ; ! flag for list-directed I/O
%SWITCH SWTR(0:116)
%INTEGER CURBLK,LASTBLK,LABCOUNT,NEXTLAB
%INTEGER NEWBLFLAG,CONNECT
%INTEGER IND,TLEN,I,OLDIND
%INTEGER BLADDR,BLIND

%ROUTINE SETENTBIT(%INTEGER BLIND)
! SET ENTERED FLAG IN EVERY BLOCK THAT CAN BE ENTERED FROM BLOCK BLIND
%RECORD(BLRECF)%NAME BL
%RECORD(CONRECF)%NAME FCON
%INTEGER FCIND
!
BL==RECORD(ABLOCKS+BLIND*BLSIZE)
%IF BL_FLAGS&ENTBIT#0 %THEN %RETURN; ! THIS PATH ALREADY DEALT WITH
BL_FLAGS=BL_FLAGS!ENTBIT
FCON==RECORD(ATABS+BL_FCON); ! GET FCONS OF BL
%CYCLE FCIND=1,1,FCON_COUNT
  ! SET ENTERED BIT OF ITS FCONS
  %UNLESS FCON_BLOCK(FCIND)=0 %THEN SETENTBIT(FCON_BLOCK(FCIND))
%REPEAT
%END; ! SETENTBIT
!
%ROUTINE ELIMBCON(%INTEGER BL)
! SET BCON LIST OF BL TO ZERO
! ELIMINATE BLOCK BL FROM THE BCON LISTS OF ITS FCONS
! ELIMINATE ALL BUT THE FIRST TRIAD OF BL ( WHICH IS A NEVER REACK BLOCK)
%RECORD(CONRECF)%NAME FCON,BCON
%RECORD(BLRECF)%NAME FBL,CBL
%RECORD(TRIADF)%NAME SOBTR,NXTTR
%RECORD(SRECF)%NAME LIST
%INTEGERNAME LASTLINK
%INTEGER FCIND,BCIND,IND,I,BCLPTR
!
CBL==RECORD(ABLOCKS+BL*BLSIZE)
CBL_BCON=0; ! RESET BCON LIST TO ZERO - A NEVER REACH BLOCK
!
FCON==RECORD(ATABS+CBL_FCON)
! PRINTSTRING("ELIMINATE BLOCK")
! WRITE(BL,1)
! PRINTSTRING(" FROM ")
! PRFCONS(CBL_FCON)
!
%FOR FCIND=1,1,FCON_COUNT %CYCLE
  FBL==RECORD(ABLOCKS+FCON_BLOCK(FCIND)*BLSIZE); ! GET FORWARD CONNECTION BLOCK
  %IF FBL_BCON=0 %THEN %CONTINUE; ! THIS BLOCK ALREADY DEALT WITH
  LASTLINK==FBL_BCON; ! SAVE LIST POINTER
  BCLPTR=LASTLINK
  %WHILE BCLPTR#0 %CYCLE
    LIST==RECORD(ADICT+BCLPTR)
    %IF LIST_INF0=BL %THEN %EXIT; ! ALWAYS EXIT VIA HERE,
                                  ! AS BL IS ALWAYS IN BCON LIST
    LASTLINK==LIST_LINK1; ! SAVE OLD POINTER
    BCLPTR=LASTLINK
  %REPEAT
  LASTLINK=LIST_LINK1
%REPEAT
!
! NOW ELIMINATE TRIADS OF BL
SOBTR==RECORD(ATRIADS+CBL_TEXT*TRIADLENGTH); ! GET 1ST TRIAD IN BLOCK
IND=SOBTR_CHAIN
JP182:
%CYCLE
  NXTTR==RECORD(ATRIADS+IND*TRIADLENGTH); ! GET NEXT TRIAD
  %IF NXTTR_USE&SOB#0 %THEN %EXIT; ! EXIT VIA HERE UNLESS LAST BLOCK
  IND=NXTTR_CHAIN
%REPEAT %UNTIL IND=0
SOBTR_CHAIN=IND; ! LINK IST TRIAD OF BLOCK TO IST TRIAD OF NEXT BLOCK
!
%END; ! ELIMBCON
!
%ROUTINE NEWBLOCK
%INTEGER BLLEN
BLIND=BLIND+1
BLLEN=BLIND*BLSIZE
%IF BLLEN+BLSIZE>MAXBLOCKS %THEN BLOCKSFULL
TMPBL==RECORD(ABLOCKS+BLLEN)
TMPBL_FLAGS=0
TMPBL_CHAIN=0
TMPBL_FCON=0
TMPBL_BCON=0
TMPBL_BDOM=0
TMPBL_DEPTH=0
TMPBL_BTARG=0
TMPBL_TEXT=0
TMPBL_CORRUPT=0
TMPBL_BUB1=0
TMPBL_USE=BLLEN+BLRECSIZE
TMPBL_DEF=BLLEN+BLRECSIZE+BSSIZE
TMPBL_BOE=BLLEN+BLRECSIZE+BSSIZE+BSSIZE
FILL(BSSIZE*3,ABLOCKS+TMPBL_USE,0,0); ! ZERO BIT STRIPS
%END

BDUMPTRACE
%IF TRACE#0 %START
  PRINTSTRING("ENTERING BLOCKS"); NEWLINE
  PRINTSTRING("NO. OF TRIADS ="); WRITE(LASTTRIAD,4); NEWLINE
%FINISH

BLIND=-1
CURBLK=0
NEWBLFLAG=0
CONNECT=0
ENTBPTR=0
EXBPTR=0
LABCOUNT=0

NEWBLOCK; ! CREATE BLOCK 0
BLADDR=0
BL==RECORD(ABLOCKS) ; ! INTIALISE BLOCK 0
BL_TEXT=0
TLEN=BSBITS*PROPRECSIZE;           ! CALCULATE LENTGH OF PROPTAB
%IF TLEN>MAXTABS %THEN TABSFULL
FILL(TLEN,ATABS,0,0);                ! ZERO PROPTAB
FREETABS=TLEN;                     ! SET NEXT FREE LOCATION IN ATABS
CON==RECORD(ATABS+FREETABS);       ! SET UP CONNECTION LIST FOR BLOCK 0(DUMMY)

IND=1
%CYCLE
  TR==RECORD(ATRIADS+IND*TRIADLENGTH)
  %IF SETUSE(TR_OP)&1=1 %THENSTART
    %unless Tr_Op=CVT %and Tr_Qopd1#0 %then TR_USE=1; ! SET USE BIT IF APPROPRIATE
  %FINISH
  OLDIND=IND; ! SAVE IND FOR SETTING TEXT FIELD OF BL
  IND=TR_CHAIN; ! GET IND OF NEXT TRIAD
  ->SWTR(TR_OP)

SWTR(STMT):
  %IF TR_VAL2<2 %START
    LAB==RECORD(TR_OPD2<<DSCALE+ADICT)
    %IF LAB_X1=0 %AND NEWBLFLAG=0 %THEN %CONTINUE 
    %IF LAB_BLKIND=0 %START
      NEWBLOCK
      LAB_BLKIND=BLIND
    %FINISH
    LASTBLK=CURBLK
    CURBLK=LAB_BLKIND
    NEWBLFLAG=0; ! RESET TO INDICATE LABELLLED STATEMENT
  %FINISHELSEIF NEWBLFLAG=1 %START
    LASTBLK=CURBLK
    NEWBLOCK
    CURBLK=BLIND
  %FINISHELSE %CONTINUE
  TR_USE=TR_USE!SOB
  BL==RECORD(ABLOCKS+BLADDR); ! REMAP INCASE ABLOCKS CHANGED
  BL_CHAIN=CURBLK
  BL_FCON=FREETABS
  BLADDR=CURBLK*BLSIZE
  BL==RECORD(ABLOCKS+BLADDR)
  BL_TEXT=OLDIND
  %IF CONNECT=1 %START; ! FORWARD CONNECTION FROM LASTBLK TO CURBLK
    ! CHECK IF CURBLK ALREADY ON FCON
    %CYCLE I=1,1,LABCOUNT
      %IF CON_BLOCK(I)=CURBLK %THEN ->STMT2
    %REPEAT
    LABCOUNT=LABCOUNT+1
    %IF FREETABS+LABCOUNT<<WSCALE>MAXTABS %THEN TABSFULL
    CON_BLOCK(LABCOUNT)=CURBLK
    PUSHFREE(LASTBLK,BL_BCON);! BACKWARD CONNECTION FROM CURBLK TO LASTBLK
  %FINISHELSE CONNECT=1; ! SET CONNECT FLAG AS DEFAULT
  STMT2:
  CON_COUNT=LABCOUNT
  FREETABS=FREETABS+(LABCOUNT+1)<<WSCALE
  %IF FREETABS>MAXTABS %THEN TABSFULL
  LABCOUNT=0
  CON==RECORD(ATABS+FREETABS)
  %IF TRACE#0 %THEN %START
    PRBLHEAD(LASTBLK)
    PRBL==RECORD(ABLOCKS+LASTBLK*BLSIZE)
    PRINTSTRING("BLOCK FOLLOWING      ");WRITE(PRBL_CHAIN,1);NEWLINE
    PRINTSTRING("IST TRIAD OF BLOCK   ");WRITE(PRBL_TEXT,1);NEWLINE
    PRINTSTRING("ADDRESS OF BIT STRIP RELATIVE TO START OF BLOCK TABLE  ")
    WRITE(PRBL_USE,1)
    NEWLINES(2)
  %FINISH
  %IF NEWBLFLAG=0 %AND LAB_X1&EBBIT=EBBIT %START
    PUSHFREE(0,BL_BCON)
    PUSHFREE(BLIND,ENTBPTR)
  %FINISH %ELSE NEWBLFLAG=0
  %CONTINUE

SWTR(JIT):  SWTR(JIF):
  NEWBLFLAG=1

SWTR(JINN):  SWTR(JINP):
SWTR(JINZ): SWTR(JIN):  SWTR(JIP):   SWTR(JIZ):
  LAB==RECORD(TR_OPD2<<DSCALE+ADICT)
  %IF TR_QOPD1&IDMASK=IDMASK %THEN SETBITS(TR_RES1,BLADDR,USE,OLDIND)
  JMP1:
  %IF LAB_BLKIND=0 %START
    NEWBLOCK
    LAB_BLKIND=BLIND
  %FINISHELSESTART
    ! CHECK IF ALREADY ON FCON LIST
    %CYCLE I=1,1,LABCOUNT
      %IF CON_BLOCK(I)=LAB_BLKIND %THEN -> J2
    %REPEAT
    TMPBL==RECORD(ABLOCKS+LAB_BLKIND*BLSIZE)
  %FINISH
  LABCOUNT=LABCOUNT+1
  %IF FREETABS+LABCOUNT<<WSCALE>MAXTABS %THEN TABSFULL %AND %C
    CON==RECORD(ATABS+FREETABS)
  CON_BLOCK(LABCOUNT)=LAB_BLKIND
  PUSHFREE(CURBLK,TMPBL_BCON)
  J2:
  %IF TR_USE=1 %THEN NEWBLFLAG=1 %AND TR_USE=0
  %CONTINUE

SWTR(GOTO):
  CONNECT=0
  %IF TR_QOPD1=LABID %OR TR_QOPD1=PLABID %START
    LAB==RECORD(TR_OPD1<<DSCALE+ADICT)
    NEWBLFLAG=1
    ->JMP1
  %FINISH
  NEXTLAB=GTOLABPTR
  GOTO1:
  %IF TR_QOPD1&IDMASK=IDMASK %THEN SETBITS(TR_RES1,BLADDR,USE,OLDIND)
  %WHILE NEXTLAB#0 %CYCLE
    GTOLABS==RECORD(NEXTLAB+ADICT)
    LAB==RECORD(ADICT+GTOLABS_INF0)
    %IF LAB_X0&8=0 %THENSTART;! not a format label
      %IF LAB_BLKIND=0 %START
        NEWBLOCK
        LAB_BLKIND=BLIND
      %FINISHELSESTART
        !CHECK IF ALREADY ON FCON LIST
        %CYCLE I=1,1,LABCOUNT
          %IF CON_BLOCK(I)=LAB_BLKIND %THEN ->GOTO2
        %REPEAT
        TMPBL==RECORD(ABLOCKS+LAB_BLKIND*BLSIZE)
      %FINISH
      LABCOUNT=LABCOUNT+1
      %IF FREETABS+LABCOUNT<<WSCALE>MAXTABS %THEN TABSFULL %AND %C
        CON==RECORD(ATABS+FREETABS)
      CON_BLOCK(LABCOUNT)=LAB_BLKIND
      PUSHFREE(CURBLK,TMPBL_BCON)
      GOTO2:
    %FINISH
    NEXTLAB=GTOLABS_LINK1
  %REPEAT
  NEWBLFLAG=1
  %CONTINUE

SWTR(CGT):
  NEXTLAB=TR_OPD2<<DSCALE
  ->GOTO1

SWTR(STOP):
  NEWBLFLAG=1
  CONNECT=0
  LABCOUNT=0
  %CONTINUE

SWTR(RET):
  BL_FLAGS=BL_FLAGS!RETBIT
  %IF TR_QOPD1&IDMASK=IDMASK %THEN SETBITS(TR_RES1,BLADDR,USE,OLDIND)
  LABCOUNT=1
  %IF FREETABS+1<<WSCALE>MAXTABS %THEN TABSFULL %AND %C
    CON==RECORD(ATABS+FREETABS)
  CON_BLOCK(1)=0
  PUSHFREE(BLIND,EXBPTR)
SETARGBITS(BLIND)
  CONNECT=0
  NEWBLFLAG=1
  %CONTINUE

SWTR(ARGARR):
%IF TR_QOPD1&IDMASK=IDMASK %THEN SETBITS(TR_RES1,BLADDR,USE,OLDIND)

SWTR(ASMT):
SWTR(DARR): ; ! SWTR(DEFARR):
  %IF TR_QOPD2&IDMASK=IDMASK %THEN SETBITS(TR_RES2,BLADDR,USE,OLDIND)
  %IF TR_QOPD1&IDMASK=IDMASK %THEN SETBITS(TR_RES1,BLADDR,DEF,OLDIND)
  %CONTINUE

SWTR(CVT):
  %IF TR_QOPD2&IDMASK=IDMASK %THEN SETBITS(TR_RES2,BLADDR,USE,OLDIND)
  %CONTINUE

SWTR(ASGN):
SWTR(DCHAR):
  %IF TR_QOPD1&IDMASK=IDMASK %THEN SETBITS(TR_RES1,BLADDR,DEF,OLDIND)
  %CONTINUE

SWTR(ARR):
  %IF TR_QOPD1&IDMASK=IDMASK %THEN SETBITS(TR_RES1,BLADDR,USE,OLDIND)
  %IF TR_QOPD2&IDMASK=IDMASK %THEN SETBITS(TR_RES2,BLADDR,USE,OLDIND)
  %CONTINUE

SWTR(ADD):  SWTR(MULT):
SWTR(GT):   SWTR(LT):   SWTR(NE):   SWTR(EQ):   SWTR(GE):   SWTR(LE):
TREVERSE(OLDIND); ! PUT OPERANDS IN CORRECT ORDER

SWTR(NINT):  SWTR(ANINT):  SWTR(TOCHAR):  SWTR(DIM):  SWTR(DMULT):
SWTR(AINT):  SWTR(ABS):  SWTR(MOD):  SWTR(SIGN):  SWTR(MIN):
SWTR(MAX):  SWTR(REALL):  SWTR(IMAG):  SWTR(CMPLX): SWTR(DCMPLX):
SWTR(CONJG):  SWTR(LEN):  SWTR(ICHAR):  SWTR(CHIND):  
SWTR(SUB):  SWTR(DIV):  SWTR(EXP):
SWTR(AND):  SWTR(OR):   SWTR(EQUIV):SWTR(NEQ):
SWTR(SUBSTR):
  %IF TR_QOPD2&IDMASK=IDMASK %THEN SETBITS(TR_RES2,BLADDR,USE,OLDIND)

SWTR(NEG):  SWTR(NOT):  SWTR(CHAR): SWTR( ARG):
  %IF TR_QOPD1&IDMASK=IDMASK %THEN SETBITS(TR_RES1,BLADDR,USE,OLDIND)
  %CONTINUE

SWTR(DARG):
  %IF TR_QOPD1&IDMASK=IDMASK %THEN SETBITS(TR_RES1,BLADDR,USE,OLDIND)
  %IF TR_QOPD1&IDMASK=IDMASK %THEN SETBITS(TR_RES1,BLADDR,DEF,OLDIND)
  %CONTINUE


SWTR(FUN):  SWTR(SUBR):
  BL_FLAGS=BL_FLAGS!FUNCBIT
  SETCMNBITS(ABLOCKS+BL_USE)
  SETCMNBITS(ABLOCKS+BL_DEF)
  SETCMNBITS(ABLOCKS+BL_BOE)
  %CONTINUE

SWTR(STRTIO):
  %IF TR_OPD1=3 %THEN LDIO=1 %ELSE LDIO=0
  %CONTINUE

SWTR(IOSPEC):
  %IF TR_QOPD2<4 %START
    %IF TR_QOPD1&IDMASK=IDMASK %THENSTART
      %IF TR_MODE=CHARMODE %THEN SETBITS(TR_RES1,BLADDR,DEF,OLDIND)
      SETBITS(TR_RES1,BLADDR,USE,OLDIND)
    %FINISH
  %CONTINUE
  %FINISH
  %IF TR_QOPD2>5 %START
    %IF TR_QOPD1&IDMASK=IDMASK %THEN ->SWTR(DARG);! to set use and def bits
    %CONTINUE
  %FINISH
  LAB==RECORD(TR_OPD1<<DSCALE+ADICT)
  %IF LAB_BLKIND=0 %START
    NEWBLOCK
    LAB_BLKIND=BLIND
  %FINISHELSE TMPBL==RECORD(ABLOCKS+LAB_BLKIND*BLSIZE)
  LABCOUNT=LABCOUNT+1
  %IF FREETABS+LABCOUNT<<WSCALE>MAXTABS %THEN TABSFULL %AND %C
    CON==RECORD(ATABS+FREETABS)
  CON_BLOCK(LABCOUNT)=LAB_BLKIND
  PUSHFREE(CURBLK,TMPBL_BCON)
  NEWBLFLAG=1
  %CONTINUE

SWTR(IOITEM): ;! WRITE
  %IF TR_QOPD1&IDMASK=IDMASK %THEN SETBITS(TR_RES1,BLADDR,USE,OLDIND)
  %CONTINUE

SWTR(DIOITEM): ; ! READ
  %IF TR_QOPD1&IDMASK=IDMASK %THENSTART
    SETBITS(TR_RES1,BLADDR,DEF,OLDIND)
    %IF LDIO=1 %THEN SETBITS(TR_RES1,BLADDR,USE,OLDIND)
  %FINISH
  %CONTINUE

SWTR(IO):
  %IF LABCOUNT>0 %THEN NEWBLFLAG=1
  %CONTINUE

SWTR(IODO):
  %CONTINUE

SWTR(EOT):
  %EXIT

SWTR(INTRIN): SWTR(IFUN):
SWTR(*):
  %IF TRACE#0 %START
   PRINTSTRING("TRIAD WITH OPERAND, ")
    WRITE(TR_OP,4)
    PRINTSTRING(", NOT DEALT WITH")
    NEWLINE
  %FINISH
  %CONTINUE

%REPEAT %UNTIL IND=0; ! END OF IST CYCLE TO SET UP BLOCKS
!
! FINISH SETTING FIELDS OF LAST BLOCK
BL_FCON=FREETABS
CON_COUNT=LABCOUNT
FREETABS=FREETABS+(LABCOUNT+1)<<WSCALE
%IF FREETABS>MAXTABS %THEN TABSFULL %AND %C
  CON==RECORD(ATABS+FREETABS)
BL_CHAIN=0
%IF TRACE#0 %THENSTART
  PRBLHEAD(CURBLK)
  PRBL==RECORD(ABLOCKS+CURBLK*BLSIZE)
  PRINTSTRING("BLOCK FOLLOWING     ");WRITE(PRBL_CHAIN,1);NEWLINE
  PRINTSTRING("1ST TRIAD OF BLOCK   ");WRITE(PRBL_TEXT,1);NEWLINE
  PRINTSTRING("ADDRESS OF BIT STRIP RELATVIE TO START OF BLOCK TABLE ")
  WRITE(PRBL_USE,1)
  NEWLINES(2)
%FINISH
!
BL==RECORD(ABLOCKS); ! GET NULL BLOCK
BL_BCON=0; ! SET BCON OF NULL BLOCK
BL_FCON=0; ! SET FCON OF NULL BLOCK
!
! SET UP ENTRY BLOCK TABLE
ENTBTAB==ARRAY(ATABS+FREETABS,TABF)
I=1
%WHILE ENTBPTR#0 %CYCLE
  BLKS==RECORD(ADICT+ENTBPTR)
  %IF FREETABS+I<<WSCALE>MAXTABS %THEN TABSFULL %AND %C
    ENTBTAB==ARRAY(ATABS+FREETABS,TABF)
  ENTBTAB(I)=BLKS_INF0
  I=I+1
  ENTBPTR=BLKS_LINK1
%REPEAT
ENTBPTR=FREETABS
FREETABS=FREETABS+I<<WSCALE
%IF FREETABS>MAXTABS %THEN TABSFULL %AND %C
  ENTBTAB==ARRAY(ATABS+FREETABS,TABF)
ENTBTAB(0)=I-1
!
! SET UP EXIT BLOCK TABLE
EXBTAB==ARRAY(ATABS+FREETABS,TABF)
I=1
%WHILE EXBPTR#0 %CYCLE
  BLKS==RECORD(ADICT+EXBPTR)
  %IF FREETABS+I<<WSCALE>MAXTABS %THEN TABSFULL %AND %C
    EXBTAB==ARRAY(ATABS+FREETABS,TABF)
  EXBTAB(I)=BLKS_INF0
  I=I+1
  EXBPTR=BLKS_LINK1
%REPEAT
EXBPTR=FREETABS
FREETABS=FREETABS+I<<WSCALE
%IF FREETABS>MAXTABS %THEN TABSFULL %AND %C
  EXBTAB==ARRAY(ATABS+FREETABS,TABF)
EXBTAB(0)=I-1
!
! CYCLE THRO' BLOCKS FROM ENTRY BLOCKS TO DETERMINE WHICH BLOCKS
! CONTROL CAN NEVER REACH
%CYCLE I=1,1,ENTBTAB(0)
  SETENTBIT(ENTBTAB(I))
%REPEAT
!
! NOW CYCLE THRO' BLOCKS LOOKING FOR THOSE WHICH HAVE NEVER BEEN REACHED
%CYCLE I=1,1,BLIND
  BL==RECORD(ABLOCKS+I*BLSIZE)
  %IF BL_FLAGS&ENTBIT=0 %THEN ELIMBCON(I) %ELSE %C
    BL_FLAGS=BL_FLAGS&ENTBITOFF
%REPEAT
!
! CYCLE THRO' BLOCKS TO SET UP BACK CONNECTION LISTS
%CYCLE I=1,1,BLIND
  CON==RECORD(ATABS+FREETABS)
  LABCOUNT=0
  BL==RECORD(ABLOCKS+I*BLSIZE)
  NEXTLAB=BL_BCON
  %WHILE NEXTLAB#0 %CYCLE
    LABCOUNT=LABCOUNT+1
    BLKS==RECORD(ADICT+NEXTLAB)
    NEXTLAB=BLKS_LINK1
    CON_BLOCK(LABCOUNT)=BLKS_INF0
  %REPEAT
  BL_BCON=FREETABS
  CON_COUNT=LABCOUNT
  %IF LABCOUNT>0 %THEN BL_BDOM=CON_BLOCK(1)
  FREETABS=FREETABS+(LABCOUNT+1)<<WSCALE
%REPEAT
!
NEXTBLOCK=BLIND+1
%IF TRACE#0 %START
  %FOR IND=1,1,BLIND %CYCLE
    PRBLHEAD(IND)
    PRBL==RECORD(ABLOCKS+IND*BLSIZE)
    PRBLCONS
    PRINT3BS(ABLOCKS+IND*BLSIZE)
  %REPEAT
%FINISH
!
TOPOLOGY
!
%END; ! BLOCKS
!
%EXTERNALROUTINE PRLOOP(%INTEGER PTR,DEPTH)
%RECORD(LOOPRECF)%NAME LOOP,TMPLOOP
LOOP==RECORD(ALOOPS+PTR)
NEWLINE
PRINTSTRING("LOOP WITH INDEX")
WRITE(PTR//LOOPRECSIZE,1)
NEWLINE
PRINTSTRING("LOOP ENTRY BLOCK IS")
WRITE(LOOP_BLOCK,1)
NEWLINE
%UNLESS DEPTH=0 %START
  PRINTSTRING("DEPTH OF LOOP IS")
  WRITE(DEPTH,1)
  NEWLINE
%FINISH
%IF LOOP_DOWN=0 %THEN %C
  PRINTSTRING("NO LOOPS CONTAINED IN THE CURRENT LOOP") %ELSE %C
  %START
  PRINTSTRING("INDEX OF LOOPS CONTAINED IN CURRENT LOOP:-")
  NEWLINE; SPACES(4)
  PTR=LOOP_DOWN
  %CYCLE
    WRITE(PTR//LOOPRECSIZE,1)
    TMPLOOP==RECORD(PTR+ALOOPS)
    PTR=TMPLOOP_ACROSS
  %REPEAT %UNTIL PTR=0
  %FINISH
NEWLINE
%END

%EXTERNALROUTINE PRLOOPS(%INTEGER PTR,DEPTH)
%RECORD(LOOPRECF)%NAME LOOP
%CYCLE
  PRLOOP(PTR,DEPTH)
  LOOP==RECORD(ALOOPS+PTR)
  %UNLESS LOOP_DOWN=0 %THEN PRLOOPS(LOOP_DOWN,DEPTH+1)
  PTR=LOOP_ACROSS
%REPEAT %UNTIL PTR=0
%END

%EXTERNALROUTINE PRLOOPTAB
%RECORD(LOOPRECF)%NAME LOOP
%INTEGER PTR
%IF FREELOOPS=0 %THENSTART
  NEWLINE
  PRINTSTRING("NO LOOPS IN THIS COMPILATION")
  NEWLINE
  %RETURN
%FINISH
LOOP==RECORD(ALOOPS)
PRINTSTRING("LOOP TABLE:")
NEWLINES(2)
PRINTSTRING("INDEX OF LOOPS AT DEPTH 1:-")
NEWLINE
SPACES(4)
WRITE(0,1)
PTR=LOOP_ACROSS
%WHILE PTR#0 %CYCLE
  WRITE(PTR//LOOPRECSIZE,1)
  LOOP==RECORD(ALOOPS+PTR)
  PTR=LOOP_ACROSS
%REPEAT
NEWLINE
PRLOOPS(0,1)
NEWLINE
%END

%EXTERNALROUTINE TOPOLOGY

%INTEGERARRAY RW(0:NEXTBLOCK*2),RX(0:NEXTBLOCK*2),RZ(0:NEXTBLOCK*2)
%INTEGERARRAYNAME ENTBTAB
%INTEGERARRAYFORMAT TABF(0:1000)
%RECORD(BLRECF)%NAME BL,TMPBL
%RECORD(CONRECF)%NAME CON,TMPCON
%RECORD(LOOPRECF)%NAME LOOPENT,TMPLP
%INTEGER RWPTR,RWEND,RXPTR,RXEND,RZPTR,RZEND,TMPRZ
%INTEGER BCON,BTARG,DEPTH,NEWLOOP,BDOM,BLCUR,NEWBL,BLPTR,LPCNT
%INTEGER POSLEB
%INTEGER IND,I,J
%INTEGER %ARRAY LPPTR(0:100)

%ROUTINE PRINTRW
%INTEGER I
WRITE(RW(I),1) %FOR I=1,1,RWEND
NEWLINE
%END

%ROUTINE PRINTRX
%INTEGER I
WRITE(RX(I),1) %FOR I=1,1,RXEND
NEWLINE
%END

%ROUTINE PRINTRZ
%INTEGER I
WRITE(RZ(I),1) %FOR I=1,1,RZEND
NEWLINE
%END

%INTEGERFN GENBLOCK
%RECORD(BLRECF)%NAME NEWBL,BDOMBL,TMPBL
%RECORD(CONRECF)%NAME BCON,NEWBCON,FCON
%RECORD(TRIADF)%NAME TT
%RECORD(SRECF)%NAME GTOLABS
%RECORD(LABRECF)%NAME MTCHLAB
%RECORD(RESF) LABEL
%INTEGER BLADDR,I,J,K,NEWTR,LAST,NEXT,LABS

LABEL_W=NULL
BCON==RECORD(ATABS+BL_BCON)
%IF FREETABS+BCON_COUNT<<WSCALE>MAXTABS %THEN TABSFULL %AND %C
  BCON==RECORD(ATABS+BL_BCON)
NEWBCON==RECORD(ATABS+FREETABS)
J=1
%FOR I=1,1,BCON_COUNT %CYCLE
  %FOR K=1,1,LPPTR(0) %CYCLE
    %IF BCON_BLOCK(I)=LPPTR(K) %THEN -> NOCOPY
  %REPEAT
    NEWBCON_BLOCK(J)=BCON_BLOCK(I)
    J=J+1
    %UNLESS BCON_BLOCK(I)=0 {A PROGRAM ENTRY BLOCK} %START
      TMPBL==RECORD(ABLOCKS+BCON_BLOCK(I)*BLSIZE)
      ! search for label connecting to BLCUR thro' triads of TMPBL block
      TT==RECORD(ATRIADS+TMPBL_TEXT*TRIADLENGTH)
      %CYCLE
        %IF TT_OP=GOTO %THENSTART
          %IF TT_QOPD1&IDMASK#0 %THEN %RESULT=0; ! CAN'T INSERT NEW LABEL FOR ASSIGNED GOTO
          ->NEWLAB; ! OTHERWISE LABEL MUST ALWAYS MATCH THAT OF BLCUR
        %FINISH
        %IF TT_OP<JIT %OR TT_OP >CGT %THEN ->NEXTOP
        %IF TT_OP=CGT %THENSTART
          LABS=TT_OPD2<<DSCALE
          %WHILE LABS#0 %CYCLE
            GTOLABS==RECORD(ADICT+LABS)
            MTCHLAB==RECORD(ADICT+GTOLABS_INF0)
            %IF MTCHLAB_BLKIND=BLCUR %THEN %EXIT
            LABS=GTOLABS_LINK1
            ! MUST ALWAYS FIND A MATCH
          %REPEAT
        %FINISHELSESTART
          MTCHLAB==RECORD(TT_OPD2<<DSCALE+ADICT)
          %IF MTCHLAB_BLKIND#BLCUR %THEN ->NEXTOP
        %FINISH
        ->NEWLAB
        NEXTOP:
        TT==RECORD(ATRIADS+TT_CHAIN*TRIADLENGTH)
      %REPEAT %UNTIL TT_OP=STMT %AND TT_USE&SOB#0
      ->NOMATCH
      NEWLAB:
      %IF LABEL_W=NULL %THENSTART
        LABEL_W=GETPLABDICT
        MTCHLAB==RECORD(ADICT+LABEL_H0<<DSCALE)
        MTCHLAB_BLKIND=NEXTBLOCK
      %FINISH
      %IF TT_OP=CGT %THEN GTOLABS_INF0=LABEL_H0<<DSCALE %ELSE %C
      %IF TT_OP=GOTO %THEN TT_RES1=LABEL %ELSE %C
        TT_RES2=LABEL
      NOMATCH:
    %FINISH; ! GENERATING NEW FORWARD CONNECTION TO NEWBLOCK
NOCOPY:
%REPEAT
NEWBCON_COUNT=J-1
I=FREETABS; ! save to assign to BCON of new block
FREETABS=FREETABS+J<<WSCALE
BLADDR=NEXTBLOCK*BLSIZE
%IF BLADDR+BLSIZE>MAXBLOCKS %THEN BLOCKSFULL
NEWBL==RECORD(BLADDR+ABLOCKS)
%IF TRACE#0 %START
  PRINTSTRING("BLOCK"); WRITE(NEXTBLOCK,1)
  PRINTSTRING(" GENERATED FOR BACK TARGET OF LOOP"); NEWLINE
%FINISH
NEWBL_BCON=I
%FOR I=1,1,NEWBCON_COUNT %CYCLE
  TMPBL==RECORD(ABLOCKS+NEWBCON_BLOCK(I)*BLSIZE)
      FCON==RECORD(ATABS+TMPBL_FCON)
      %FOR K=1,1,FCON_COUNT %CYCLE
        %IF FCON_BLOCK(K)=BLCUR %THEN %EXIT
      %REPEAT
      FCON_BLOCK(K)=NEXTBLOCK
      %IF TRACE#0 %START
        PRINTSTRING("NEW FORWARD CONNECTION TO BLOCK")
        WRITE(NEXTBLOCK,1)
        PRINTSTRING(" FROM BLOCK"); WRITE(NEWBCON_BLOCK(I),1)
        NEWLINE
      %FINISH
%REPEAT
%IF TRACE#0 %AND LABEL_W #NULL %THENSTART
          PRINTSTRING("NEW PRIVATE LABEL CREATED FOR GENERATED BLCOK")
          NEWLINE
%FINISH
BDOMBL==RECORD(ABLOCKS+BL_BDOM*BLSIZE)
NEWBL_BDOM=BL_BDOM
NEWBL_FLAGS=0
NEWBL_CHAIN=0
NEWBL_CORRUPT=0
NEWBL_BUB1=0
NEWBL_DEPTH=BDOMBL_DEPTH
NEWBL_BTARG=BDOMBL_BTARG
NEWBL_USE=BLADDR+BLRECSIZE
NEWBL_DEF=BLADDR+BLRECSIZE+BSSIZE
NEWBL_BOE=BLADDR+BLRECSIZE+BSSIZE+BSSIZE
FILL(BSSIZE*3,ABLOCKS+NEWBL_USE,0,0); ! ZERO BIT STRIP
BCON_COUNT=LPPTR(0)+1
BCON_BLOCK(I)=LPPTR(I) %FOR I=1,1,LPPTR(0)
BCON_BLOCK(I+1)=NEXTBLOCK
%IF FREETABS+2<<WSCALE>MAXTABS %THEN TABSFULL
NEWBL_FCON=FREETABS
FCON==RECORD(ATABS+FREETABS)
FCON_COUNT=1
FCON_BLOCK(1)=BLCUR
FREETABS=FREETABS+2<<WSCALE
BL_BDOM=NEXTBLOCK

! COPY BOE BIT STRIP FROM BL TO NEWBLOCK
!!MOVE(BSSIZE,BL_BOE,NEWBL_BOE);! PROBABLY NOT REQUIRED  GEM 17/12/82

! CREATE A STMT TRIAD IN THE NEW BLOCK AND CHAIN IT
  NEWTR=GETTRIAD
  NEWBL_TEXT=NEWTR
  TT==RECORD(ATRIADS+NEWTR*TRIADLENGTH)
  TT_OP=STMT
  %IF LABEL_W=NULL %THEN TT_VAL2=SOB!3 { UNLABELLED MARKER } %ELSE %C
    TT_VAL2=SOB; ! PRIVATE LABEL
  TT_RES2=LABEL
  TT_CHAIN=BL_TEXT
  NEXT=BDOMBL_TEXT
  %UNTIL NEXT=BL_TEXT %CYCLE
    TT==RECORD(ATRIADS+NEXT*TRIADLENGTH)
    NEXT=TT_CHAIN
  %REPEAT
  TT_CHAIN=NEWTR

%IF TRACE#0 %START
  PRBLOCK(NEXTBLOCK)
  PRINTSTRING("BACKWARD CONNECTIONS FROM BLOCK"); WRITE(BLCUR,1)
  PRINTSTRING(" TO BLOCKS")
  WRITE(BCON_BLOCK(1),1); WRITE(BCON_BLOCK(2),1)
  NEWLINE
  PRINTSTRING("ADD NEW BLOCK TO RW BEFORE BLCUR")
  NEWLINES(2)
%FINISH
! ADD NEW BLOCK TO RW BEFORE BLCUR
%FOR I=RWEND, -1,RWPTR %CYCLE
  RW(I+1)=RW(I)
%REPEAT
RW(RWPTR)=NEXTBLOCK
RWEND=RWEND+1
RWPTR=RWPTR+1

NEXTBLOCK=NEXTBLOCK+1
%RESULT=1
%END; ! GENBLOCK

FREELOOPS=0; ! INITIALISE LOOPTABLE INDEX
ENTBTAB==ARRAY(ATABS+ENTBPTR,TABF)
RWEND=ENTBTAB(0)
RW(IND)=ENTBTAB(IND) %FOR IND=1,1,RWEND; ! PUT ALL ENTRY BLOCKS ON RW
%IF TRACE#0 %START
  NEWLINES(2)
  PRINTSTRING("TOPOLOGICAL ANALYSIS")
  NEWLINES(2)
  PRINTSTRING("ENTRY BLOCKS ARE")
  PRINTRW
%FINISH
RWPTR=1; ! START ANALYSIS WITH FIRST ENTRY BLOCK
%WHILE RWPTR<=RWEND %CYCLE
  BLCUR=RW(RWPTR);
  BL==RECORD(ABLOCKS+BLCUR*BLSIZE)
  %IF TRACE#0 %START
    NEWLINE
    PRINTSTRING("PROCESSING BLOCK")
    WRITE(BLCUR,1)
    NEWLINE
  %FINISH
  CON==RECORD(ATABS+BL_FCON); ! FORWARD CONNECTIONS FOR BLCUR
  %FOR IND=1,1,CON_COUNT %CYCLE
    NEWBL=CON_BLOCK(IND)
    %IF NEWBL=0 %THEN %CONTINUE
    %FOR I=1,1,RWEND %CYCLE; ! CHECK IF NEWBL ALREADY ON RW
      %IF RW(I)=NEWBL %THEN ->SKIP1
    %REPEAT
    RWEND=RWEND+1
    RW(RWEND)=NEWBL ; ! ADD FORWARD CONNECTIONS TO RW
    TMPBL==RECORD(ABLOCKS+NEWBL*BLSIZE)
    TMPBL_BDOM=BLCUR; ! FIRST GUESS AT BDOM
                      ! FCON ALWAYS DOMINATED BY BLCUR HERE
  SKIP1: ; ! JUMP TO HERE IF NEWBL ALREADY ON RW
  %REPEAT

! DETERMINE BACK DOM & TARG OF BLCUR AND COLLECT LOOP INFO
  POSLEB=0
  CON==RECORD(ATABS+BL_BCON); ! BACK CONNECTIONS OF BLCUR
  %IF CON_COUNT>1 %START
    NEWBL=BLCUR
    RXEND=0
    %WHILE NEWBL#0 %CYCLE ; ! FORM BACK DOM CHAIN ON RX
      TMPBL==RECORD(ABLOCKS+NEWBL*BLSIZE)
      NEWBL=TMPBL_BDOM
      RXEND=RXEND+1
      RX(RXEND)=NEWBL
    %REPEAT
    %IF TRACE#0 %START
      PRINTSTRING("BACK DOMINATOR CHAIN FROM CURRENT BLOCK IS")
      PRINTRX
    %FINISH
    RXPTR=1
    BDOM=1

! CHECK BC PATHS FROM BLCUR TO DETERMINE BACK DOM
! & CHECK IF BLOCK IS POSS. LOOP ENTRY
    %IF TRACE#0 %START
      PRINTSTRING("CHECK BC PATHS")
      PRINTSTRING(" TO DETERMINE IF POSSIBLE LOOP ENTRY BLOCK")
      NEWLINE
    %FINISH
    RZEND=0
  LPCNT=0; ! intialise loop count
    %FOR IND=1,1,CON_COUNT %CYCLE; ! PROCESS EACH BCON
      RZEND=RZEND+1
      RZ(RZEND)=CON_BLOCK(IND) ; ! ADD BACK CON OF BLCUR TO RZ
      %IF TRACE#0 %START
        PRINTSTRING("CURRENT BCON IS BLOCK")
        WRITE(RZ(RZEND),1)
        NEWLINE
      %FINISH
      RZPTR=RZEND-1
      TMPRZ=RZEND
      POSLEB=1
      %CYCLE; ! PROCESS CURRENT RZ ENTRY TO FIND BACK DOM
              ! & CHECK FOR POSSIBLE LOOPS
        RZPTR=RZPTR+1
        BCON=RZ(RZPTR)
        %IF BCON=0 %START
          BDOM=RXEND; ! POINT BDOM TO NULL RX ENTRY
          POSLEB=0
          %EXIT
        %FINISH

! SEARCH RX TO DETERMINE IF BCON IS A MEMEBER OF BACK DOM CHAIN
        %FOR I=1,1,RXEND %CYCLE
          %IF BCON=RX(I) %THEN ->SKIP2
        %REPEAT
        %IF BCON#BLCUR %START; ! I.E. IF NOT BACK AT START
          TMPBL==RECORD(ABLOCKS+BCON*BLSIZE)
          TMPCON==RECORD(ATABS+TMPBL_BCON)
          %FOR I=1,1,TMPCON_COUNT %CYCLE
          ! ADD BCS OF BCON TO RZ IF NOT ALREADY PRESENT
            %FOR J=1,1,RZEND %CYCLE
              %IF RZ(J)=TMPCON_BLOCK(I) %THEN ->SKIP3
            %REPEAT
            RZEND=RZEND+1
            RZ(RZEND)=TMPCON_BLOCK(I); ! ADD BACK CON OF BCON TO RZ
            %CONTINUE
	  SKIP3:
          %IF J < TMPRZ %THEN POSLEB=0
	  %REPEAT
        %FINISH
        %CONTINUE
        SKIP2:  ; !JUMP HERE IF BCON IS MEMBER OF BACK DOM CHAIN
        %IF I>BDOM %THEN BDOM=I
        POSLEB=0
      %REPEAT %UNTIL RZPTR=RZEND; ! END OF PROCESSING CURRENT RZ ENTRY

      %IF TRACE#0 %START
        PRINTSTRING("BACK CONNECTION LISTS FROM CURRENT BLOCK:-")
        PRINTRZ
        PRINTSTRING("INDEX OF ENTRIES FOR CURRENT BCON IS")
        WRITE(TMPRZ,1)
        NEWLINE
      %FINISH
      %IF POSLEB=1 %START
        BL_FLAGS=BL_FLAGS!LEBIT
        LPCNT=LPCNT+1
        LPPTR(LPCNT)=RZ(TMPRZ); ! REMEMBER BLOCK LEADING INTO LOOP FOR GENBLOCK
        %IF TRACE#0 %THENSTART
          PRINTSTRING("BLOCK IS A POSSIBLE LOOP ENTRY BLOCK FROM BLOCK")
          WRITE(RZ(TMPRZ),1)
          NEWLINE
        %FINISH
      %FINISH
    %REPEAT; ! END OF BC PATHS CHECK

  LPPTR(0)=LPCNT; ! save no. of loops 
    BL_BDOM=RX(BDOM)
  %FINISH; ! END OF BACK DOM & TARG DETERMINATION & LOOP INFO COLLECTION

  %IF TRACE#0 %START
    PRINTSTRING("BACK DOMINATOR OF CURRENT BLOCK IS")
    WRITE(BL_BDOM,1)
    NEWLINE
  %FINISH
  %IF BL_FLAGS&LEBIT=LEBIT %START
    TMPBL==RECORD(ABLOCKS+BL_BDOM*BLSIZE); ! GET BDOM BLOCK
! ??? CAN A PROGRAM ENTRY BLOCK EVER BE A LOOP ENTRY BLOCK ???
    %IF TMPBL_FCON#0 {NULL BLOCK} %START
      CON==RECORD(ATABS+TMPBL_FCON); ! FORWARD CONNECTIONS OF BL_BDOM
      %IF CON_COUNT>1 %THEN BL_FLAGS=BL_FLAGS&X'EF' %AND %C
      ->LLLL{  I=GENBLOCK}; ! generate back target block
    %FINISH %ELSE ->LLLL{I=GENBLOCK}
!    %IF I=0 %THEN ->LLLL; ! new block hasn't been generated
    BTARG=BL_BDOM
    DEPTH=TMPBL_DEPTH+1
    %IF TRACE#0 %START
      PRINTSTRING("CURRENT BLOCK IS A POSSIBLE LOOP ENTRY BLOCK")
      NEWLINE
      PRINTSTRING("BACK TARGET IS")
      WRITE(BTARG,1)
      NEWLINE
      PRINTSTRING("DEPTH IS")
      WRITE(DEPTH,1)
      NEWLINE
    %FINISH

! SET DEPTH & BTARG FOR ALL MEMBERS OF LOOP
    RX(1)=BTARG
    RX(2)=BLCUR
    RXPTR=2
    RXEND=2
    %IF TRACE#0 %START
      PRINTSTRING("SET DEPTH & BTARG FIELDS OF FOLLOWING BLOCKS TO")
      WRITE(DEPTH,1)
      WRITE(BTARG,1)
      PRINTSTRING(" RESPECTIVELY")
      NEWLINE
    %FINISH
    %WHILE RXPTR<=RXEND %CYCLE
      BLPTR=RX(RXPTR)
      %IF TRACE#0 %THEN WRITE(BLPTR,1)
      TMPBL==RECORD(ABLOCKS+BLPTR*BLSIZE)
      TMPBL_DEPTH=DEPTH
      TMPBL_BTARG=BTARG
      CON==RECORD(ATABS+TMPBL_BCON)
      %FOR IND=1,1,CON_COUNT %CYCLE
        %FOR I=1,1,RXEND %CYCLE
          %IF CON_BLOCK(IND)=RX(I) %THEN ->SKIP5
        %REPEAT
        RXEND=RXEND+1
        RX(RXEND)=CON_BLOCK(IND)
        SKIP5:
      %REPEAT
      RXPTR=RXPTR+1
    %REPEAT; ! END OF SETTING DEPTH & BTARG
    %IF TRACE#0 %THEN NEWLINE

! SET UP LOOPTAB ENTRY FOR BLCURRENT

    %IF FREELOOPS+4<<WSCALE>MAXLOOPS %THEN LOOPSFULL
      NEWLOOP=FREELOOPS
      LOOPENT==RECORD(ALOOPS+FREELOOPS) ; ! CREATE LOOPTAB ENTRY
      FREELOOPS=FREELOOPS+4<<WSCALE
      %IF TRACE#0 %START
        PRINTSTRING("CREATING LOOPTAB ENTRY FOR BLOCK")
        WRITE(BLCUR,1)
        NEWLINE
      %FINISH
      LOOPENT_ST=0
      LOOPENT_ACROSS=0
      LOOPENT_DOWN=0
      LOOPENT_BLOCK=BLCUR
      %IF DEPTH=1 %START
        %IF NEWLOOP#0 %START
          IND=0
          %CYCLE; ! ADD NEWLLOP TO ACROSS CHAIN FOR DEPTH 1 LOOPS
            TMPLP==RECORD(ALOOPS+IND)
            IND=TMPLP_ACROSS
          %REPEAT %UNTIL IND=0
          TMPLP_ACROSS=NEWLOOP
        %FINISH
      %FINISHELSESTART; ! START DEPTH>1
! FIND NEAREST LOOP ENTRY BLOCK IN BDC WHICH IS AT NEXT LEVEL UP
      TMPBL==RECORD(ABLOCKS+BLCUR*BLSIZE)
      %CYCLE
        BLPTR=TMPBL_BDOM
        TMPBL==RECORD(ABLOCKS+BLPTR*BLSIZE)
        %IF TMPBL_FLAGS&LEBIT=LEBIT %AND TMPBL_DEPTH=DEPTH-1 %THEN %EXIT
      %REPEAT
! SEARCH LOOPTAB FOR ENTRY WHICH CORRESPONDS TO BLPTR
      %FOR IND=0,4<<WSCALE,FREELOOPS-4<<WSCALE %CYCLE
        TMPLP==RECORD(ALOOPS+IND)
        %IF TMPLP_BLOCK=BLPTR %THEN %EXIT
      %REPEAT
! ADD CURRENT BLOCK TO LOOPTAB CHAINS
      %IF TMPLP_DOWN#0 %THEN LOOPENT_ACROSS=TMPLP_DOWN
      TMPLP_DOWN=NEWLOOP
    %FINISH
  %FINISH
LLLL:  RWPTR=RWPTR+1
%REPEAT
%IF TRACE#0 %THEN PRLOOPTAB
%END
%ENDOFFILE