! 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 "host_host"
!*
%INCLUDE "targ_target"
!*
!%INCLUDE "pf_version"
!*
%INCLUDE "bits_fmts"
!*
%INCLUDE "bits_optspecs"
!*
%INCLUDE "bits_optfmts"
!
%INCLUDE "bits_consts"
!*
%INCLUDE "bits_triadops"
!*
%INCLUDE "pf_optfill"
!*
%INCLUDE "pf_copy"
!*
%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 %THEN TR_USE=1; ! SET USE BIT IF APPROPRIATE
  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<<BSCALE>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)<<BSCALE
  %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<<BSCALE>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<<BSCALE>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<<BSCALE>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 %THEN SETBITS(TR_RES1,BLADDR,USE,OLDIND)
    %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<<BSCALE>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)<<BSCALE
%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<<BSCALE>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<<BSCALE
%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<<BSCALE>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<<BSCALE
%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)<<BSCALE
%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<<BSCALE>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<<BSCALE
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<<BSCALE>MAXTABS %THEN TABSFULL
NEWBL_FCON=FREETABS
FCON==RECORD(ATABS+FREETABS)
FCON_COUNT=1
FCON_BLOCK(1)=BLCUR
FREETABS=FREETABS+2<<BSCALE
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
          SKIP3:
          %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<<BSCALE>MAXLOOPS %THEN LOOPSFULL
      NEWLOOP=FREELOOPS
      LOOPENT==RECORD(ALOOPS+FREELOOPS) ; ! CREATE LOOPTAB ENTRY
      FREELOOPS=FREELOOPS+4<<BSCALE
      %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<<BSCALE,FREELOOPS-4<<BSCALE %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