! 08/01/85 - comment out routine TABFAIL, call F77abort in pf_ctl1
! 07/01/85 - Substituted F77abort call for tabfail.
! 29/08/84 - correction to SETBITS for CMNCOORDS(1)
! 27/08/84 - insert function GET PLABDICT
! 16/07/84 - put name of OPTCTL routine in an include file
! 04/07/84 - put SPECS to constant operations in include file "targ_constfns"
! 03/07/84 - replace scaling factor in OPTCTL by BSCALE
! 04/06/84 - correction to BUSYONX
! 02/04/84 - changes in SUBSUM for DIOITEM(list-directed)
! 15/03/84 - further changes of 4 to W1 in CONOP
! 21/02/84 - Replace increments of 4 by W1 in BUSYONX & CONOP
! 17/01/84 - CORRECT CREATETAB; MAKE BLOCKPOINT RELATIVE IN SETBITS
! 08/11/83 COPIED FROM ERCS06.REL90_OPTCTLB31
!*
%INCLUDE "host_host"
!*
%INCLUDE "targ_target"
!*
%INCLUDE "pf_version"
!*
%INCLUDE "bits_fmts"
!*
%INCLUDE "bits_ctlspecs"
!*
%INCLUDE "bits_optfmts"
!
%INCLUDE "bits_consts"
!*
%INCLUDE "bits_com"
!*
%INCLUDE "bits_triadops"
!*
%INCLUDE "pf_copy"
!*
%INCLUDE "pf_optfill"
!*
%INCLUDE "pf_bits"
!*
%INCLUDE "targ_constfns"
!*
%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)
!*
!*
%EXTERNALROUTINESPEC PRINT TR(%INTEGER INDEX,ADICT,ANAMES,
           LEVEL,%RECORD(TRIADF)%NAME TRIAD)
!*
%EXTERNALROUTINESPEC BLOCKS(%INTEGER GOTOLIST)
%EXTERNALROUTINESPEC OP2
%EXTERNALROUTINESPEC OP3
%externalroutinespec F77ABORT(%integer n)
%externalroutinespec Dicful
!*
!*
%CONSTINTEGER PLABRECSIZE=5*W1; ! size of a private label record
!*
%EXTERNALROUTINE PUSHFREE(%INTEGER VAL,%INTEGERNAME LINK)
%RECORD(COMFMT)%NAME COM
%RECORD(SRECF)%NAME FREE
      COM==RECORD(COMAD)
      FREE==RECORD(ADICT+COM_DPTR)
      FREE_INF0=VAL
      FREE_LINK1=LINK
      LINK=COM_DPTR
      COM_DPTR=COM_DPTR+FRSIZE
%END;! PUSHFREE
!*
%EXTERNALROUTINE PRINT CHTRIADS
%RECORD(TRIADF)%NAME TR
%INTEGER CH
CH=1
%CYCLE
  TR==RECORD(ATRIADS+CH*TRIADLENGTH)
  PRINT TR(CH,ADICT,ANAMES,0,TR)
  CH=TR_CHAIN
%REPEAT %UNTIL CH=0
%END;! PRINT CHTRIADS
!*
%OWNRECORD(BLRECF)%NAME PRBL
!*
%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("CORRUPT                 ");WRITE(PRBL_CORRUPT,1);NEWLINE
PRINTSTRING("ADDRESS OF USE BIT STRIP RELATIVE TO ABLOCKS")
WRITE(PRBL_USE,1);NEWLINE
PRINTSTRING("ADDRESS OF DEF BIT STRIP RLATIVE TO ABLOCKS")
WRITE(PRBL_DEF,1);NEWLINE
PRINTSTRING("ADDRESS OF BOE BIT STRIP RLATIVE TO ABLOCKS")
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
!
%EXTERNALROUTINE PRINTBS(%INTEGERARRAYNAME B)
%INTEGER BWORD,MASK,I
!
%IF ADDR(B(0))<X'FFFF' %THEN NEWLINE %AND %RETURN;! @ field now invalid
!
%FOR I=0,1,BSWORDS-1 %CYCLE
  BWORD=B(I)
  MASK=X'80000000'
  %CYCLE
    %IF BWORD&MASK=0 %THEN PRINTSYMBOL('0') %C
                     %ELSE PRINTSYMBOL('1')
    MASK=MASK>>1
  %REPEAT %UNTIL MASK=0
%REPEAT
NEWLINE
%END
!
%ROUTINE PRINT3BS(%INTEGER BLOCKPOINT)
%RECORD(BLRECF) %NAME BB
%INTEGERARRAYFORMAT BF(0:15)
%INTEGERARRAYNAME B
!
  BB==RECORD(BLOCKPOINT)
  B==ARRAY(ABLOCKS+BB_USE,BF)
  PRINTSTRING("USE ")
  PRINTBS(B)
!
  B==ARRAY(ABLOCKS+BB_DEF,BF)
  PRINTSTRING("DEF ")
  PRINTBS(B)
!
  B==ARRAY(ABLOCKS+BB_BOE,BF)
  PRINTSTRING("BOE ")
  PRINTBS(B)
%END
!
!
%EXTERNALROUTINE PRBLOCK(%INTEGER BLIND)
%IF BLIND=0 %THEN %RETURN
PRBLHEAD(BLIND);
NEWLINE
PRBL==RECORD(ABLOCKS+BLIND*BLSIZE)
PRBLFIELDS
PRBLCONS
PRINT3BS(ABLOCKS+BLIND*BLSIZE)
NEWLINE
%END
!
%EXTERNALROUTINE PRBLTRIADS(%INTEGER BLIND)
%RECORD(BLRECF)%NAME BL
%RECORD(TRIADF)%NAME TR
%INTEGER CHAIN
BL==RECORD(ABLOCKS+BLIND*BLSIZE)
CHAIN=BL_TEXT
TR==RECORD(ATRIADS+CHAIN*TRIADLENGTH)
%CYCLE
  PRINT TR(CHAIN,ADICT,ANAMES,0,TR)
  CHAIN=TR_CHAIN
  %IF CHAIN=0 %THEN %RETURN
  TR==RECORD(ATRIADS+CHAIN*TRIADLENGTH)
  %IF TR_OP&BMBITOFF=STMT %AND TR_VAL2&SOB#0 %THEN %RETURN
%REPEAT
%END; ! PRBLTRIADS
!*
%INCLUDE "targ_optctl"
%RECORD(OBJFMT) %NAME OBJ
%RECORD(COMFMT)%NAME COM
%RECORD(TRIADF)%NAME TR
%INTEGER F,I,J,K
      %CYCLE I=0,1,15
         CLOOPUSE(I)=0
         PLOOPUSE(I)=0
         DLOOPUSE(I)=0
         CLOOPDEF(I)=0
         PLOOPDEF(I)=0
         DLOOPDEF(I)=0
         CURRDEF(I)=0
         STFNDEF(I)=0
      %REPEAT
      J=(ADDR(DTCH)-ADDR(ADICT))>>WSCALE
      K=ADDR(ADICT)
      %CYCLE I=0,1,J
         INTEGER(K)=0
         K=K+W1
      %REPEAT
      CHEAD0=0
      CHEAD1=0
      CHEAD2=0
      CHEAD3=0
      COMAD=ACOM
      COM==RECORD(ACOM)
      COM_ADOPTDATA=ADDR(ADICT);! for diagnostic purposes
      OBJ==RECORD(COM_OBJADDR)
      ADICT=COM_ADICT
      MAXDICT=COM_DICLEN
      MAXTRIADS=COM_MAXTRIADS
      ANAMES=COM_ANAMES
      ATRIADS=COM_ATRIADS
      CBNPTR=COM_CBNPTR
      SCPTR=COM_SCPTR
      OPT=COM_OPT
      OPTFLAGS=COM_OPTFLAGS
      SRFLAGS=OBJ_SRFLAGS
      INHIBMASK=OBJ_INHIBMASK
      LASTTRIAD=NEXTTR-1
      BSBITS=COM_NEXTBIT
      BSWORDS=(BSBITS+31)>>5
      BSSIZE=BSWORDS<<BSCALE
      BLSIZE=BLRECSIZE+3*BSSIZE
      %CYCLE I=0,1,15
         CMNCOORDS(I)=INTEGER(COM_ACMNBITS+I<<BSCALE)
      %REPEAT
      ACMNCOORDS=ADDR(CMNCOORDS(0))
      ACURRDEF=ADDR(CURRDEF(0))
      ABLOCKS=OBJ_ABLOCKS
      MAXBLOCKS=OBJ_MAXBLOCKS
      ATABS=OBJ_ATABS
      MAXTABS=OBJ_MAXTABS
      ALOOPS=OBJ_ALOOP
      APROPTABS=ATABS
      MAXLOOPS=OBJ_MAXLOOP
!*
      FREETABS=W1
      FREELOOPS=0
!*
      %IF OPTFLAGS&TDUMP#0 %THEN PRINT CHTRIADS
!*
      BLOCKS(ASSGOTOS)
!*
      %IF OPTFLAGS&(S1DUMP!T1DUMP)#0 %THENSTART
         PRINTSTRING("
After OP1:

")
         %IF OPTFLAGS&T1DUMP#0 %THEN PRINT CHTRIADS
      %FINISH
!*
      OP2
!*
      %IF OPTFLAGS&(S2DUMP!T2DUMP)#0 %THENSTART
         PRINTSTRING("
After OP2:

")
         %IF OPTFLAGS&T2DUMP#0 %THEN PRINT CHTRIADS
      %FINISH
!*
      OP3
!*
      COM_DESTEMPS=DESTEMPHEAD;! head of descriptor temporary list
      %IF OPTFLAGS&T3DUMP#0 %OR COM_F77PARM&X'04000000'#0 %THENSTART
         PRINTSTRING("

Triads after optimisation:

")
         PRINT CHTRIADS
      %FINISH
      %IF OPTFLAGS&S2DUMP#0 %THENSTART
         PRINTSTRING("
NEXTBLOCK: ");WRITE(NEXTBLOCK,1)
         PRINTSTRING("
FREELOOPS: ");WRITE(FREELOOPS,1)
         PRINTSTRING("
FREETABS:  ");WRITE(FREETABS,1)
         NEWLINE
      %FINISH
%END;! OPTCTL
!*                                !***                         PHEX
!*
%CONSTBYTEINTEGERARRAY C(0 : 15) =  '0','1','2','3',
               '4','5','6','7','8','9','A','B','C','D','E','F'
%ROUTINE PX(%INTEGER H)
%INTEGER I,J
      %IF HOST=PERQPNX %THEN H=H+H
      %CYCLE I = 0,1,3
         J=BYTEINTEGER(I+H)
         PRINTSYMBOL(C(J>>4))
         PRINTSYMBOL(C(J&15))
      %REPEAT
%END;                                   !OF PX
!*
%ROUTINE PHEX(%INTEGER N)
      PX(ADDR(N))
%END; !PHEX
!*
%ROUTINE DUMP(%INTEGER START,FINISH)
%INTEGER I,J
      I=START&(-4)
      %WHILE I<FINISH %CYCLE
      PRINTSYMBOL('(')
      PHEX(I)
      PRINTSTRING(")  ")
      %CYCLE J=I,4,I+28
      %IF J>=FINISH %THEN -> L
      SPACES(2)
      PHEX(INTEGER (J))
      %REPEAT
L: NEWLINE
      I=I+32
      %REPEAT
%END
!*
!*                           COMPDUMP
!*
%ROUTINE COMPDUMP(%STRING(15) S,%INTEGER START,LEN)
      NEWLINE
      PRINTSTRING(S)
      NEWLINES(2)
      DUMP(START,START+LEN)
%END
!*
!*                             TABFAIL
!*
!%ROUTINE TABFAIL(%STRING(6) S)
!%RECORD (COMFMT) %NAME COM
!      COM==RECORD(COMAD)
!      PRINTSTRING("
!*** COMPILER FAILURE - ")
!      PRINTSTRING(S)
!      PRINTSTRING(" TABLE OVERFLOW ***
!")
!      PRINTSTRING("
!***   COMPILER TABLES  ***
!")
!      COMPDUMP("CDATA",ADDR(ADICT),232)
!      COMPDUMP("TRIADS",ATRIADS,12*(LASTTRIAD+1))
!      COMPDUMP("BLOCKS",ABLOCKS,NEXTBLOCK*BLSIZE)
!      COMPDUMP("DICT",ADICT,COM_DPTR)
!      COMPDUMP("LOOPS",ALOOPS,FREELOOPS)
!      COMPDUMP("TABS",ATABS,FREETABS)
!      %MONITOR
!      %STOP
!%END
!*
!*                                  BLOCKSFULL
!*
%EXTERNALROUTINE BLOCKSFULL
!     TABFAIL("BLOCKS")
     F77ABORT(2)
%END;! BLOCKSFULL
!*
!*                                  TABSFULL
!*
%EXTERNALROUTINE TABSFULL
%INTEGER I
!      %IF MAXTABS<X'40000' %THENSTART
!         I=ICL9HNALTERVS(X'18001000',ATABS,X'40000',-1)
!         %IF I=0 %THENSTART
!            MAXTABS=X'40000'
!            %RETURN
!         %FINISH
!      %FINISH
!    TABFAIL("TABS")
    F77ABORT(4)
%END;! TABSFULL
!*
!*                                        DICTFULL
!*
%EXTERNALROUTINE DICTFULL
!    TABFAIL("DICT")
   Dicful
%END;! DICTFULL
!*
! *                                         LOOPSFULL
!*
%EXTERNALROUTINE LOOPSFULL
!    TABFAIL("LOOPS")
   F77ABORT(3)
%END;! LOOPSFULL
!*
!*                                        TRIADSFULL
!*
%EXTERNALROUTINE TRIADSFULL
!    TABFAIL("TRIADS")
   F77ABORT(1)
%END;! TRIADSFULL
!*
!
!*
%EXTERNALINTEGERFN GET PLABDICT
!***********************************************************************
!* Provide a new dict record for a private label                       *
!***********************************************************************
%RECORD(COMFMT)%NAME COM
%RECORD(PLABF)%NAME PLAB
%RECORD(RESF) R
%INTEGER I
      COM==RECORD(COMAD)
      I=COM_DPTR
      COM_DPTR=COM_DPTR+PLABRECSIZE
      DICTFULL %IF COM_DPTR>COM_DICLEN
      PLAB==RECORD(COM_ADICT+I)
      PLAB_BLKIND=0
      PLAB_USE=0
      PLAB_X1=17;! referenced in explicit GOTO
      PLAB_INDEX=COM_NEXT PLAB
      PLAB_CODEAD=0
      PLAB_REF=0
      PLAB_REFCHAIN=0
      COM_NEXT PLAB=COM_NEXT PLAB+1
      R_H0=I>>DSCALE
      R_FORM=PLABID
      R_MODE=0
      %RESULT=R_W
%END;! GET PLABDICT
!*
%EXTERNALINTEGERFUNCTION CREATETAB (%INTEGER A)
!
!***********************************************************************
!* CREATE A TABLE ENTRY OF LENGTH A ARCHITECTURAL UNITS                *
!***********************************************************************
!
%INTEGER B
!
      TABSFULL %IF FREETABS + A > MAXTABS
      B = FREETABS
      FILL(A,ATABS+B,0,0)
      FREETABS = FREETABS + A
      %RESULT = B
!
%END;!  CREATETAB
!
!
%EXTERNALINTEGERFUNCTION CREATEDTAB (%INTEGER A)
!
!**********************************************************************
!* CREATES A TABLE ENTRY IN THE DICTIONARY AREA, OF LENGTH A ARCHITECTURAL UNITS*
!**********************************************************************
!
%RECORD(COMFMT)%NAME COM
%INTEGER B
!
      COM==RECORD(COMAD)
      DICTFULL %IF COM_DPTR + A > MAXDICT
      B = COM_DPTR
      FILL(A,ADICT+B,0,0)
      COM_DPTR = COM_DPTR + A
      %RESULT = B
!
%END;!   CREATEDTAB
!
%EXTERNALINTEGERFUNCTION GETTRIAD
! 
%INTEGER TR,I
%RECORD (TRIADF) %NAME TT
!
      %UNLESS FREETRIADS = 0 %THENSTART
         TR = FREETRIADS
         TT == RECORD (ATRIADS + TR * TRIADLENGTH)
         FREETRIADS = TT_CHAIN
         %RESULT = TR
      %FINISH
!* NO SPARE TRIADS IN FREE CHAIN. CLAIM 10 MORE & CHAIN THEM.
      TRIADSFULL %IF LASTTRIAD + 10 >= MAXTRIADS
      TR = LASTTRIAD + 1
      %FOR I = 1,1,10 %CYCLE
         TT == RECORD (ATRIADS + TR * TRIADLENGTH)
         TR = TR + 1
         TT = 0
         TT_CHAIN = TR
      %REPEAT
      TT_CHAIN = 0
      TR = LASTTRIAD + 1
      FREETRIADS = LASTTRIAD + 2
      LASTTRIAD = LASTTRIAD + 10
      %RESULT = TR
!
!
%END ;!  GETTRIAD
!*
!*
!***********************************************************************
!*                                                                     *
!*            A L L D E F                                             *
!*                                                                     *
!***********************************************************************
!*
%EXTERNALINTEGERFN ALLDEF(%INTEGER INDEX)
!***********************************************************************
!*                                                                     *
!* identifies defining contexts within triad INDEX                     *
!*                                                                     *
!* result = 0   no defining context                                    *
!*          +ve result is coord of an item which is defined            *
!*                                      (no other items at risk)       *
!*         -1   unspecified common or ref args may be defined          *
!*        <-1   result is -coord of common item which is defined       *
!*                                      (ref args at risk)             *
!*                                                                     *
!* called by  UPDATE CURRDEF                                           *
!*            EXPELIM                                                  *
!*            BACKMOVE                                                 *
!*                                                                     *
!***********************************************************************
%RECORD(TRIADF)%NAME TR
%RECORD(PRECF)%NAME ID
%INTEGER C
%SWITCH DEF(0:6)
!*
      TR==RECORD(ATRIADS+INDEX*TRIADLENGTH)
      ->DEF(DEFTEST(TR_OP&BMBITOFF))
!*
DEF(0):                                 ! no defining context
      %RESULT=0
!*
DEF(1):                                 ! ASMT,ASGN,DIOITEM
      %WHILE TR_QOPD1&TEXTMASK#0 %CYCLE;! to reach DEFARR and DCHAR triads
         TR==RECORD(ATRIADS+TR_OPD1*TRIADLENGTH)
      %REPEAT
!*
SET:  ID==RECORD(ADICT+TR_OPD1<<DSCALE)
      C=ID_COORD
      %IF C=1 %OR C=3 %THEN %RESULT=-1;! args and all commons at risk
      %IF ID_CLASS & CMNBIT # 0 %THEN %RESULT=-C  %C
                                %ELSE %RESULT=C

!*
DEF(2):                               ! DARG
      %IF TR_QOPD1 & IDMASK # 0 %THEN ->SET
!*
      %IF TR_QOPD1 & TEXTMASK # 0 %THENSTART
         %CYCLE
            TR==RECORD(ATRIADS+TR_OPD1*TRIADLENGTH)
            %IF TR_OP&BMBITOFF = ARGARR %THEN ->SET
            %IF TR_OP&BMBITOFF = DCHAR %THENSTART
               %IF TR_QOPD1 & TEXTMASK #0 %THEN ->SET
            %FINISH
            %RESULT=0;! no defining context
         %REPEAT;! to locate character array element
      %FINISH
      %RESULT=0
!*
DEF(3):                                 ! FUN
      ID==RECORD(ADICT+TR_OPD1<<DSCALE)
      %IF ID_X0 & 3 # 0 %THEN %RESULT=0;! standard function
!*
DEF(4):                                 ! CALL
      %RESULT=-1;! unknown definitions of common or args
!*
DEF(5):                                 ! IOSPEC
      %IF TR_QOPD2<6 %THEN %RESULT=0
      %UNLESS TR_QOPD1&IDMASK#0 %THEN %RESULT=0
      ->DEF(1)
!*
DEF(6):                                 ! CALLSF
      %RESULT=-1
!*
%END;! ALLDEF
!*
!*
!*
%EXTERNALROUTINE SETBITS(%RECORD(RESF) TRIADOPD,
                         %INTEGER BLOCKPOINT,USEORDEF,TRIADIND)
!
!*******************************************************************
!* SET EITHER USE OR DEF IN BLOCKTAB BITSTRIPS.
!*   IF SETTING USE BIT, &DEF BIT IS NOT ALREADY SET, SET BOE TOO.
!*   IF DUMMY ARG, SET FOR ALL COMMON, &VICE VERSA.
!*******************************************************************
!
%RECORD(PRECF)%NAME PP
%RECORD(BLRECF)%NAME BB
%RECORD(PROPRECF)%NAME PR
!
!
%INTEGER COORD,BIT,I
%INTEGERARRAYFORMAT BF(0:15)
%INTEGERARRAYNAME B
!
!
      PP == RECORD(ADICT+TRIADOPD_H0<<DSCALE)
      BB == RECORD(ABLOCKS+BLOCKPOINT)
      COORD = PP_COORD
      %UNLESS COORD=1 %THENSTART
        %IF USEORDEF=USE %THENSTART
          SETBIT (ABLOCKS+BB_USE,COORD)
          SETBIT (ABLOCKS+BB_USE,1) %IF (PP_CLASS & CMNBIT) \= 0 %AND %C
            CMNCOORDS(1)=1
          GETBIT (ABLOCKS+BB_DEF,COORD,BIT)
          %IF BIT = 0 %THENSTART
            SETBIT (ABLOCKS+BB_BOE,COORD)
            SETBIT(ABLOCKS+BB_BOE,1) %IF (PP_CLASS & CMNBIT) \= 0 %AND %C
              CMNCOORDS(1)=1
          %FINISH
          PP_X1=PP_X1!8;! will ensure params are copied in
        %FINISHELSESTART
          SETBIT (ABLOCKS+BB_DEF,COORD)
          SETBIT (ABLOCKS+BB_DEF,1) %IF (PP_CLASS & CMNBIT) \= 0 %AND %C
            CMNCOORDS(1)=1
          PR == RECORD(ATABS+COORD*PROPRECSIZE)
          PR_DEFCT=PR_DEFCT+1
          PR_TEXT=TRIADIND
          PP_X0=PP_X0!X'2';! will ensure params are copied out
          PP_X1=PP_X1!X'A';! and copied in
        %FINISH
      %FINISHELSESTART
        %IF USEORDEF=USE %THENSTART
          GETBIT(ABLOCKS+BB_DEF,1,BIT)
          %IF BIT=0 %THENSTART
            B==ARRAY(ABLOCKS+BB_BOE,BF)
            B(I)=B(I)!CMNCOORDS(I) %FOR I=0,1,BSWORDS-1
          %FINISH
          B == ARRAY(ABLOCKS+BB_USE,BF)
        %FINISH %ELSE B == ARRAY(ABLOCKS+BB_DEF,BF)
        B(I)=B(I)!CMNCOORDS(I) %FOR I=0,1,BSWORDS-1
      %FINISH
%END
!*
!*
!***********************************************************************
!*                                                                     *
!*          U P D A T E   C U R R D E F                                *
!*                                                                     *
!***********************************************************************
!*
%EXTERNALROUTINE UPDATE CURRDEF
!***********************************************************************
!*                                                                     *
!* updates CURRDEF to reflect the definitions found in current triad   *
!*                                                                     *
!* called by  OP2 procedures                                           *
!*                                                                     *
!* calls      ALLDEF                                                   *
!*                                                                     *
!***********************************************************************
%RECORD(TRIADF)%NAME TR
%INTEGER C
      TR==RECORD(ATRIADS+CURRTRIAD*TRIADLENGTH)
      C=ALLDEF(CURRTRIAD)
      %IF C=0 %THEN %RETURN;! no defining context
      %IF C>0 %THENSTART;! item defined - no other common or ref args at risk
         SETBIT(ACURRDEF,C)
      %FINISHELSESTART;! all common or ref args at risk
         SETBIT(ACURRDEF,1)
         %IF C=-1 %THENSTART;! ref arg at risk, common at risk
            SETCMNBITS(ACURRDEF)
         %FINISHELSESTART;! common item defined, ref arg at risk
            C=-C
            SETBIT(ACURRDEF,C)
         %FINISH
      %FINISH
!*
%END;! UPDATE CURRDEF
!*
!*
!***********************************************************************
!*                                                                     *
!*         T R E V E R S E                                             *
!*                                                                     *
!***********************************************************************
!*
%EXTERNALROUTINE TREVERSE(%INTEGER INDEX)
!***********************************************************************
!*                                                                     *
!* reverse operands of triad INDEX if possible and necessary to ensure *
!* that RES1 is logically greater than RES2                            *
!*                                                                     *
!* order of precedence:  text > iden > const                           *
!*                                                                     *
!***********************************************************************
%CONSTBYTEINTEGERARRAY STRENGTH(0:66)=0(16),2(16),3(32),1(3)
%CONSTBYTEINTEGERARRAY REVOP(0:29) =  %C
   0,0,ADD,0,MULT,0,0,0,0,0,
   0,0,0,0,0,0,0,0,0,0,
   0,LT,GT,NE,EQ,LE,GE,0,0,0
%RECORD(TRIADF)%NAME TR
%RECORD(RESF) R
%INTEGER I
      TR==RECORD(ATRIADS+INDEX*TRIADLENGTH)
      %IF TR_OP&BMBITOFF<30 %THEN I=REVOP(TR_OP&BMBITOFF) %ELSE %RETURN
      %IF I=0 %THEN %RETURN;! not reversible
!*
      %IF TR_QOPD1=TR_QOPD2 %THENSTART
         %IF TR_OPD2<TR_OPD1 %THENSTART
SWAP:       TR_OP=(TR_OP&BMBIT)!I
            R=TR_RES1
            TR_RES1=TR_RES2
            TR_RES2=R
         %FINISH
          %RETURN
      %FINISH
!*
      %IF STRENGTH(TR_QOPD2)>STRENGTH(TR_QOPD1) %THEN ->SWAP
!*
%END;! TREVERSE
!*
%ROUTINE CHAINOUT
!***********************************************************************
!*                                                                     *
!* chain out the current triad                                         *
!*                                                                     *
!* CURRTRIAD is added to FREETRIADS list                               *
!* PREVTRIAD becomes CURRTRIAD                                         *
!*                                                                     *
!* called by  NEXTTRIAD                                                *
!*                                                                     *
!***********************************************************************
%RECORD(TRIADF)%NAME PREVTR
%RECORD(TRIADF)%NAME CURRTR
      PREVTR==RECORD(ATRIADS+PREVTRIAD*TRIADLENGTH)
      CURRTR==RECORD(ATRIADS+CURRTRIAD*TRIADLENGTH)
!*
      PREVTR_CHAIN=CURRTR_CHAIN
      CURRTR=0
      CURRTR_CHAIN=FREETRIADS
      FREETRIADS=CURRTRIAD
      CURRTRIAD=PREVTRIAD
%END;! CHAINOUT
!*
%EXTERNALINTEGERFN NEXTTR
!***********************************************************************
!*                                                                     *
!* get the next non_trivial triad from the chained text,deleting or    *
!* ignoring trivial triads                                             *
!*                                                                     *
!* set CURRTRIAD, PREVTRIAD                                            *
!*                                                                     *
!* result = 0  end of block                                            *
!*          1  normally                                                *
!*                                                                     *
!***********************************************************************
%RECORD(TRIADF)%NAME CUR
%RECORD(TRIADF)%NAME PREV
%RECORD(TRIADF)%NAME TR
%INTEGER REPL INDEX
!*
!*
      %CYCLE
         PREVTRIAD=CURRTRIAD
!*
         %CYCLE
            PREV==RECORD(ATRIADS+PREVTRIAD*TRIADLENGTH)
            CURRTRIAD=PREV_CHAIN
            %IF CURRTRIAD=0 %THEN %RESULT=0
            CUR==RECORD(ATRIADS+CURRTRIAD*TRIADLENGTH)
            %IF CUR_OP&BMBITOFF=STMT %AND CUR_VAL2&SOB#0 %THEN %RESULT=0;! returns end-of-block
            %IF CUR_OP&BMBITOFF#NULL %THEN %EXIT
            CHAINOUT
         %REPEAT
!*
!*
         %IF CUR_OP&BMBITOFF#STMT %AND CUR_OP&BMBITOFF#REPL %THENSTART
            %CYCLE
               %IF CUR_QOPD1 & TEXTMASK = 0 %THEN %EXIT
                REPL INDEX=CUR_OPD1
               TR==RECORD(ATRIADS+REPL INDEX*TRIADLENGTH)
               %IF TR_OP&BMBITOFF=REPL %THENSTART
                  CUR_RES1=TR_RES1;! perforn replacement
                  %IF CUR_QOPD1 & TEXTMASK # 0 %THENSTART;! update use count
                     TR==RECORD(ATRIADS+CUR_OPD1*TRIADLENGTH)
                     TR_USE=TR_USE+1
                  %FINISH
                  TREVERSE(CURRTRIAD)
                  DELUSE(REPL INDEX)
               %FINISHELSE %EXIT
            %REPEAT;! to reconsider RES1 in case TREVERSE caused a swap
!*
            %IF CUR_QOPD2 & TEXTMASK = 0 %THEN %RESULT=1
!*
            REPL INDEX=CUR_OPD2
            TR==RECORD(ATRIADS+REPL INDEX*TRIADLENGTH)
            %UNLESS TR_OP&BMBITOFF=REPL %THEN %RESULT=1
            CUR_RES2=TR_RES1;! perform replacement
            %IF CUR_QOPD2 & TEXTMASK # 0 %THENSTART;! update use count
               TR==RECORD(ATRIADS+CUR_OPD2*TRIADLENGTH)
               TR_USE=TR_USE+1
            %FINISH
            TREVERSE(CURRTRIAD)
            DELUSE(REPL INDEX)
            %RESULT=1
         %FINISH
      %REPEAT
%END;! NEXTTR
!*
%EXTERNALINTEGERFN NEXTTRIAD
!***********************************************************************
!*                                                                     *
!* as NEXTTR, but skips over REPL triads                               *
!*                                                                     *
!***********************************************************************
%RECORD(TRIADF)%NAME TR
%INTEGER F
      %CYCLE
         F=NEXTTR
         TR==RECORD(ATRIADS+CURRTRIAD*TRIADLENGTH)
         %IF TR_OP&BMBITOFF#REPL %THEN %RESULT=F
      %REPEAT
%END;! NEXTTRIAD
!*
%EXTERNALROUTINE DELUSEX(%INTEGER INDEX)
!***********************************************************************
!*                                                                     *
!* delete one use of triad INDEX                                       *
!*                                                                     *
!* if use is then <1 and not a user function then change to a null tria*d
!*                                                                     *
!***********************************************************************
%RECORD(TRIADF)%NAME TR
%INTEGER I
      TR==RECORD(ATRIADS+INDEX*TRIADLENGTH)
      I=TR_USE-1
      %IF I>=1 %THEN TR_USE=I %AND %RETURN
!*
      %IF TR_OP&BMBITOFF=FUN %THEN %RETURN;! user side effects must not be eliminated
!*
      TR_OP=NULL
%END;! DELUSEX
!*
%EXTERNALROUTINE DELUSE(%INTEGER INDEX)
!***********************************************************************
!*                                                                     *
!* delete one use of triad INDEX, including all triads referenced      *
!*                                                                     *
!* if use is then <1 and not a user function then change to a null tria*d
!*                                                                     *
!***********************************************************************
%RECORD(TRIADF)%NAME TR
%INTEGER I
      TR==RECORD(ATRIADS+INDEX*TRIADLENGTH)
      I=TR_USE-1
      %IF I>=1 %THEN TR_USE=I %AND %RETURN
!*
      %IF TR_OP&BMBITOFF=FUN %THEN %RETURN;! user side effects must not be eliminated
!*
      TR_OP=NULL
!*
      %IF TR_QOPD1&TEXTMASK#0 %THEN DELUSE(TR_OPD1)
      %IF TR_QOPD2&TEXTMASK#0 %THEN DELUSE(TR_OPD2)
!*
%END;! DELUSE
!*
%EXTERNALINTEGERFN LOOPCON1(%INTEGER INDEX)
!***********************************************************************
!*                                                                     *
!* check if operand 1 of triad INDEX is a loop constant                *
!*                                                                     *
!* result = 0  no                                                      *
!*          1  yes                                                     *
!*                                                                     *
!***********************************************************************
%RECORD(TRIADF)%NAME TR
%RECORD(PRECF)%NAME ID
%INTEGER C,A,BIT,QUAL
!*
      TR==RECORD(ATRIADS+INDEX*TRIADLENGTH)
      QUAL=TR_QOPD1
!*
!* identifier entry is a loop constant if it is not defined in any
!* of the blocks in the loop
!*
      %IF QUAL&IDMASK#0 %THENSTART
         ID==RECORD(ADICT+TR_OPD1<<DSCALE)
         A=ADDR(CLOOPDEF(0))
         C=ID_COORD
         GETBIT(A,C,BIT)
         %RESULT=BIT!!1
      %FINISH
!*
!* a triad is loop constantif it has been moved out of the loop by
!* backward movement
!*
      %IF QUAL&TEXTMASK#0 %THENSTART
         TR==RECORD(ATRIADS+TR_OPD1*TRIADLENGTH)
         %RESULT=(TR_OP&BMBIT)>>BMBITSHIFT
      %FINISH
!*
!* strength reduction temporary is loop variable
!*
      %IF QUAL=SRTEMP %THEN %RESULT=0
!*
!* treat procid as loop variable - invalid backward move occurred
!*
      %IF QUAL=PROCID %THEN %RESULT=0
!*
!* anything else (const) must be loop const
!*
      %RESULT=1
!*
%END;! LOOPCON1
!*
%EXTERNALINTEGERFN LOOPCON2(%INTEGER INDEX)
!***********************************************************************
!*                                                                     *
!* check if operand 2 of triad INDEX is a loop constant                *
!*                                                                     *
!* result = 0  no                                                      *
!*          1  yes                                                     *
!*                                                                     *
!***********************************************************************
%RECORD(TRIADF)%NAME TR
%RECORD(PRECF)%NAME ID
%INTEGER C,A,BIT,QUAL
!*
      TR==RECORD(ATRIADS+INDEX*TRIADLENGTH)
      QUAL=TR_QOPD2
!*
!* identifier entry is a loop constant if it is not defined in any
!* of the blocks in the loop
!*
      %IF QUAL&IDMASK#0 %THENSTART
         ID==RECORD(ADICT+TR_OPD2<<DSCALE)
         A=ADDR(CLOOPDEF(0))
         C=ID_COORD
         GETBIT(A,C,BIT)
         %RESULT=BIT!!1
      %FINISH
!*
!* a triad is loop constantif it has been moved out of the loop by
!* backward movement
!*
      %IF QUAL&TEXTMASK#0 %THENSTART
         TR==RECORD(ATRIADS+TR_OPD2*TRIADLENGTH)
         %RESULT=(TR_OP&BMBIT)>>BMBITSHIFT
      %FINISH
!*
!* strength reduction temporary is loop variable
!*
      %IF QUAL=SRTEMP %THEN %RESULT=0
!*
!* treat procid as loop variable - invalid backward move occurred
!*
      %IF QUAL=PROCID %THEN %RESULT=0
!*
!* anything else (const) must be loop const
!*
      %RESULT=1
!*
%END;! LOOPCON2
!*
%ROUTINE P(%INTEGER I)
PRINTSTRING("BUSYONX ")
WRITE(I,1)
NEWLINE
%END
!*
%EXTERNALINTEGERFN BUSYONX(%INTEGER FROMORTO,BLOCK,IDPTR)
!*
!* test whether a given variable is busy on exit from or to a given block
!*
!* FROMORTO = 0  busy-on-exit from
!*            1  busy-on-exit to
!* BLOCK         block index
!* IDPTR         scaled identifier pointer
!*
!* result   = 0  not busy
!*            1  busy
!*
%RECORDFORMAT SAVFMT(%INTEGER PATH,NUMCON,ACON,CURBL)
%RECORD(SAVFMT)%NAME SAVREC
%RECORD(PRECF)%NAME ID
%RECORD(BLRECF)%NAME BL
%RECORD(COMFMT)%NAME COM
%INTEGER PATH,NUMCON,ACON,CURBL,CVAL,BIT,BLSTRIP,I
%INTEGER SAVIND
!*
      COM==RECORD(COMAD)
      SAVIND=0
      PATH=0
      NUMCON=0
      ACON=0
      CURBL=0
      ID==RECORD(ADICT+IDPTR<<DSCALE)
      %IF ID_X1&EQUIVBIT#0 %THEN %RESULT=1;! equivalenced var always considered busy
      CVAL=ID_COORD
      %IF CVAL=0 %THEN %RESULT=1;! coord 0 always busy
!*
!* zero a block bitstrip
!*
      BLSTRIP=ATABS+FREETABS
      %CYCLE I=0,1,(NEXTBLOCK+31)>>5
         INTEGER(BLSTRIP+W1*I)=0
      %REPEAT
      PATH=0
      CURBL=BLOCK
      BL==RECORD(ABLOCKS+CURBL*BLSIZE)
%INCLUDE "pf_ctl1"
      PATH=1
      %IF FROMORTO=0 %THEN ->BUSYF;! busy-on-exit from
!*
BUSY: I=BL_BOE+ABLOCKS
      GETBIT(I,CVAL,BIT)
      %IF BIT#0 %THEN %RESULT=1;! busy
!*
      I=BL_DEF+ABLOCKS
      GETBIT(I,CVAL,BIT)
      %IF BIT#0 %THENSTART;! if not BOE but DEF then not busy-on-exit this path
EXIT:
%INCLUDE "pf_ctl2"
         %IF PATH=0 %THEN %RESULT=0;! not busy
         ->NEXTC;! to process the next connection from the previous block 
      %FINISH
!*
BUSYF:ACON=ATABS+BL_FCON
      NUMCON=INTEGER(ACON)
!*
NEXTC:%IF NUMCON=0 %THEN ->EXIT;! either STOP or this set of connections all processed
      NUMCON=NUMCON-1
      ACON=ACON+W1
      CURBL=INTEGER(ACON)
      %IF CURBL=0 %THENSTART;! exit block being processed
         %IF ID_CLASS&CMNBIT#0 %OR ID_CLASS=11 %THEN %RESULT=1;! common and function names busy at return
         %IF ID_X0&1#0 %THEN %RESULT=1;! dummy args also considered busy
!*
!* the entry blocks of the current subrogram are considered here to
!* protect against user relying on local values being retained
!*
         ACON=ATABS+ENTBPTR
         NUMCON=INTEGER(ACON)
         ACON=ACON+W1
         CURBL=INTEGER(ACON)
      %FINISH
!*
CHECK:GETBIT(BLSTRIP,CURBL,BIT)
! ensure that entry block has not already been processed
      %IF BIT#0 %THEN ->NEXTC
      SETBIT(BLSTRIP,CURBL)
%INCLUDE "pf_ctl1"
      BL==RECORD(ABLOCKS+CURBL*BLSIZE)
      ->BUSY
!*
%END;! BUSYONX
!*
%EXTERNALINTEGERFN CONOUT(%RECORD(RESF) R)
%RECORD(CONSTRECF)%NAME CON
      %IF R_FORM=LIT %THEN %RESULT=R_H0
      %IF R_FORM=NEGLIT %THEN %RESULT=-R_H0
      CON==RECORD(ADICT+R_H0<<DSCALE)
      %RESULT=INTEGER(ADICT+CON_DADDR)
%END;! INTVAL
!*
%EXTERNALINTEGERFN CONOP(%RECORD(RESF) RL,%INTEGER OP,%RECORD(RESF) RR,
                            %RECORD(RESF)%NAME R)
%RECORD(COMFMT)%NAME COM
%RECORD(CONSTRECF)%NAME CON
%INTEGER I
      %IF OP=5 %THEN %RESULT=1;! suspend div
      %IF RR_MODE=INT8 %THEN %RESULT=1
      %IF RL_MODE>REAL16 %OR RR_MODE>REAL16 %THEN %RESULT=1
      COM==RECORD(COMAD)
      %IF RL_FORM=LIT %THENSTART
         INTEGER(ADICT)=RL_H0
         RL_H0=0
      %FINISHELSESTART
         %IF RL_FORM=NEGLIT %THENSTART
            INTEGER(ADICT)=-RL_H0
            RL_H0=0
         %FINISHELSESTART
            CON==RECORD(ADICT+RL_H0<<DSCALE)
            RL_H0=CON_DADDR>>DSCALE
         %FINISH
      %FINISH
      RL_FORM=1
      %IF RR_FORM=LIT %THENSTART
         INTEGER(ADICT+W1)=RR_H0
         RR_H0=W1>>DSCALE
      %FINISHELSESTART
         %IF RR_FORM=NEGLIT %THENSTART
            INTEGER(ADICT+W1)=-RR_H0
            RR_H0=W1>>DSCALE
         %FINISHELSESTART
            CON==RECORD(ADICT+RR_H0<<DSCALE)
            RR_H0=CON_DADDR>>DSCALE
         %FINISH
      %FINISH
      RR_FORM=1
      %IF OP=EXP %THEN OP=7
      I=CONST EVAL(RL_W,OP,RR_W,RR,COM_ADICT,COM_DPTR)
      %IF I#0 %THEN %RESULT=1
      %IF RR_FORM=0 %THENSTART
         R=RR
         R_FORM=LIT
      %FINISHELSESTART
         R_FORM=CNSTID
         R_MODE=RR_MODE
         R_H0=SETCONREC(RR)>>DSCALE
      %FINISH
      %RESULT=0
%END;! CONOP
!*
%EXTERNALINTEGERFN CONVERTMODE(%RECORD(RESF)%NAME RES,%INTEGER NEWMODE)
%RECORD(RESF) R
%RECORD(RESF) RL
%RECORD(CONSTRECF)%NAME CON
%RECORD(COMFMT)%NAME COM
%INTEGER AD,I
!*
      COM==RECORD(COMAD)
!*
      %IF NEWMODE=INT2 %THEN %RESULT=1
      RL=RES;! for more efficient code
      AD=0
      %IF RL_FORM=LIT %THENSTART
         INTEGER(ADICT)=RL_H0
         AD=0
      %FINISHELSESTART
         %IF RL_FORM=NEGLIT %THENSTART
            INTEGER(ADICT)=-RL_H0
            AD=0
         %FINISHELSESTART
            CON==RECORD(ADICT+RL_H0<<DSCALE)
            AD=CON_DADDR
         %FINISH
      %FINISH
      R_FORM=1
      R_MODE=NEWMODE
      I=COERCE CONST(AD,RL_MODE,NEWMODE,ADICT,COM_DPTR)
      %IF I<0 %THEN %RESULT=1
      R_H0=I>>DSCALE
      RL_FORM=CNSTID
      RL_MODE=NEWMODE
      RL_H0=SETCONREC(R)>>DSCALE
      RES=RL
      %RESULT=0
%END;! CONVERTMODE
!*
%EXTERNALINTEGERFN CONRES(%INTEGER CONST,MODE)
!***********************************************************************
!* result is RES for integer value CONST converted to MODE             *
!***********************************************************************
%RECORD(RESF) R
%INTEGER I
      R_W=CONIN(CONST)
      %IF MODE#INT4 %THEN I=CONVERTMODE(R,MODE)
      %RESULT=R_W
%END;! CONRES
!*
%EXTERNALINTEGERFN CONINVERT(%RECORD(RESF) RES1,%RECORD(RESF)%NAME RES)
%RECORD(RESF) R1
      R1_W=CONRES(1,RES1_MODE)
      %RESULT=CONOP(R1,5,RES1,RES)
%END;! CONINVERT
!*
!***********************************************************************
!*                                                                     *
!***********************************************************************
!*                                                                     *
!*                S U B S U M P T I O N                                *
!*                                                                     *
!***********************************************************************
!*                                                                     *
!***********************************************************************
!*
!*
!*
%CONSTINTEGER INACTIVE    = 0
%CONSTINTEGER GLOBAL      = 1
%CONSTINTEGER LOCALACTIVE = X'30'
%CONSTINTEGER LOCALDELETE = X'10'
%CONSTINTEGER LOCNODELETE = X'20'
!*
%OWNINTEGER LCT;! count of currently active local entries
%OWNINTEGER CMNCT;! count of currently active local and common entries
%OWNINTEGER SUBFLAG
%CONSTBYTEINTEGERARRAY HEX(0 : 15) =   %C
 '0','1','2','3','4','5','6',
'7','8','9','A','B','C','D','E','F'
%ROUTINE PRHEX(%INTEGER J)
%INTEGER K
      %CYCLE K = 28,-4,0
         PRINT SYMBOL(HEX((J>>K)&15))
      %REPEAT
%END
!*
!*
!*
%ROUTINE DUMP PROPS
%RECORD(PROPRECF)%NAME PROP
%INTEGER AD,I
      PRINTSTRING("
Coord  Defct  Text  Defn  Flags  Coord2  Repl
")
      AD=APROPTABS
      %CYCLE I=0,1,BSBITS-1
         PROP==RECORD(AD)
         WRITE(I,3)
         WRITE(PROP_DEFCT,7)
         WRITE(PROP_TEXT,5)
         WRITE(PROP_DEFN,5)
         WRITE(PROP_FLAGS,6)
         WRITE(PROP_COORD2,7)
         SPACES(2)
         PRHEX(PROP_REPL_W)
         AD=AD+PROPRECSIZE
         NEWLINE
      %REPEAT
      NEWLINE
%END;! DUMP PROPS
!*
%EXTERNALROUTINE GLOBSUBS
!***********************************************************************
!*                                                                     *
!* Called by OP2 before loop selection and processing to initialise    *
!* PROPTAB entries for all globally subsumable variables, namely those *
!*  a) defined by a DATA statement only                                *
!*  b) defined once only in the text                                   *
!*                                                                     *
!* On entry, for each PROPTAB entry                                    *
!*    PR_DEFCT is the number of definitions of this coord in the text  *
!*    PR_TEXT  is the triad index of the last definition               *
!*                                                                     *
!*    if a local scalar has been initialised in a DATA statement then  *
!*    the constant value will be located by PP_LINK3                   *
!*                                                                     *
!*    entries of interest are those which have                         *
!*     a) PR_DEFCT = 0  and  PP_LINK3 # 0                              *
!*     b) PR_DEFCT = 1  and  pp_LINK3 = 0                              *
!*                                                                     *
!* On return, for each PROPTAB entry                                   *
!*    PR_FLAGS = 0  variable is not globally subsumable                *
!*               1  globally subsumable                                *
!*                  PR_REPL is RES for replacing constant              *
!*                  if the lone definition is of th form A=const (the  *
!*                  only form worth subsuming) then the assignment is  *
!*                  deleted                                            *
!*                                                                     *
!*    LCT   = 0     count of active local entries                      *
!*    CMNCT = 0     count of active local and common entries           *
!*                                                                     *
!***********************************************************************
!*
%RECORD(TRIADF)%NAME TR
%RECORD(PRECF)%NAME ID
%RECORD(PRECF)%NAME CMNBLK
%RECORD(PROPRECF)%NAME PROP
%RECORD(COMFMT)%NAME COM
%INTEGER I,J,C,CNT,F,PATH
      %IF OPTFLAGS&PDUMP#0 %THENSTART
         PRINTSTRING("
GLOBSUBS
")
      %FINISH
!*
      COM==RECORD(COMAD)
!*
!* set the coord2 field for all common items with bit strip entries
!*
      I=COM_CBNPTR
      %WHILE I#0 %CYCLE;! through all common blocks
         CMNBLK==RECORD(ADICT+I)
         J=CMNBLK_LINK2
         %WHILE J#0 %CYCLE;! through all items in common
            ID==RECORD(ADICT+J)
            C=ID_COORD
            %IF C#3 %THENSTART
               PROP==RECORD(APROPTABS+C*PROPRECSIZE)
               PROP_COORD2=1
            %FINISH
            J=ID_LINK2
         %REPEAT
         I=CMNBLK_ADDR4
      %REPEAT
!*
!* process all local scalar refs
!*
      I=COM_SCPTR
      PATH=0
LOOP: %WHILE I#0 %CYCLE
         ID==RECORD(ADICT+I)
         F=INACTIVE
         C=ID_COORD
         PROP==RECORD(APROPTABS+C*PROPRECSIZE)
         %IF C#0 %AND ID_CLASS=0 %AND ID_X0&1=0 %THENSTART;! local scalar
            %UNLESS ID_TYPE=CHARTYPE %OR ID_X1&X'80'#0 %THENSTART;! not char or equiv
               CNT=PROP_DEFCT
               %IF CNT=0 %THENSTART
                  %IF ID_LINK3=0 %THENSTART
                     {give warning - use of unassigned variable}
                  %FINISHELSESTART
                     {construct RES and save in REPL}
                     F=GLOBAL
                  %FINISH
               %FINISHELSESTART
                  %IF CNT=1 %AND ID_X1&2=0 %THENSTART;! only one definition and no DATA statement
                     TR==RECORD(ATRIADS+PROP_TEXT*TRIADLENGTH)
                    %IF TR_OP&X'7F'=ASMT  %C
                            %AND TR_QOPD2&CONSTMASK#0 %THENSTART
                        PROP_REPL=TR_RES2
                        TR_OP=NULL
                        F=GLOBAL
                     %FINISH
                  %FINISH
               %FINISH
            %FINISH
         %FINISH
         PROP_FLAGS=F
         %IF PATH=0 %THEN I=ID_LINK2 %ELSE I=ID_LINK1
      %REPEAT
!*
      %IF PATH=0 %THENSTART;! to process local temp refs as well
         PATH=1
         I=COM_TMPPTR
         ->LOOP
      %FINISH
!*
      LCT=0
      CMNCT=0
!*
      %IF OPTFLAGS&PDUMP#0 %THEN DUMP PROPS
!*
%END;! GLOBSUBS
!*
%EXTERNALROUTINE SUBSEOB
!***********************************************************************
!*                                                                     *
!* Called by OP2 after the optimisation of each block                  *
!*                                                                     *
!* Tidies up PROPTAB by clearing all entries local to each block       *
!* just processed                                                      *
!*                                                                     *
!* On entry                                                            *
!*    PROPTAB contains three significant cases                         *
!*     a) global entries, set up by GLOBSUBS                           *
!*     b) local entry for case  A = B                                  *
!*                              uses of A                              *
!*         A not busy on exit   End of Block                           *
!*     c) local entry for case  A = const                              *
!*                              uses of A                              *
!*         A busy on exit       End of Block                           *
!*    ?? check 'first entry ignored if interference maker is set'      *
!*    ??            (i.e. DUMCNT #0)                                   *
!*                                                                     *
!*    LCT = count of active local entries - types b),c)                *
!*                                                                     *
!* On return                                                           *
!*    only global entries are left on PROPTAB                          *
!*    for case b) entries the assignment A = B is deleted              *
!*    LCT = 0                                                          *
!*                                                                     *
!***********************************************************************
!*
%INTEGER I,F,P
%RECORD(PROPRECF)%NAME PROP
!*
      %IF OPTFLAGS&(PDUMP!SEOBDUMP)#0 %THENSTART
         PRINTSTRING("
SUBSEOB BLOCK")
      WRITE(CURRBLK,1)
         DUMP PROPS
      %FINISH
      P=APROPTABS
      %WHILE LCT#0 %CYCLE
         %UNTIL PROP_FLAGS & LOCALACTIVE # 0 %CYCLE
            P=P+PROPRECSIZE
            PROP==RECORD(P)
         %REPEAT
         LCT=LCT-1
         %IF PROP_FLAGS=LOCALDELETE %THEN DELUSE(PROP_DEFN)
         PROP_FLAGS=INACTIVE
      %REPEAT
      CMNCT=0;! all local and common entries have gone
!*
      %IF OPTFLAGS&PDUMP#0 %THENSTART
         DUMP PROPS
      %FINISH
             %IF OPTFLAGS&SEOBDUMP#0 %THEN PRBLTRIADS(CURRBLK)
!*
%END;! SUBSEOB
!*
%INTEGERFN SSUM(%RECORD(RESF) R)
!***********************************************************************
!*                                                                     *
!* Called by SUBSUM to decide if a given operand can be replaced by    *
!* a variable being subsumed                                           *
!* i.e. if there is an active PROPTAB entry for the coordinate of      *
!*      the given operand the value from PROPTAB is returned           *
!* SUBFLAG is set if replacement can occur                             *
!*                                                                     *
!***********************************************************************
!*
%RECORD(TRIADF)%NAME TR
%RECORD(PRECF)%NAME ID
%RECORD(PROPRECF)%NAME PROP
%INTEGER I
      %IF LSCALID<=R_FORM<=PERMID %AND R_FORM#ARRID %THENSTART
         ID==RECORD(ADICT+R_H0<<DSCALE)
         I=ID_COORD
         PROP==RECORD(APROPTABS+I*PROPRECSIZE)
         %IF I#0 %AND PROP_FLAGS#INACTIVE  %C
                 %AND R_MODE=PROP_REPL_MODE %THENSTART
            SUBFLAG=1
            R=PROP_REPL
            %IF R_FORM&TEXTMASK#0 %THENSTART
               TR==RECORD(ATRIADS+R_H0*TRIADLENGTH)
               TR_USE=TR_USE+1
            %FINISH
         %FINISH
      %FINISH
      %RESULT=R_W
%END;! SSUM
!*
%EXTERNALROUTINE SUBSUM
!***********************************************************************
!*                                                                     *
!* Called by OP2 control to process an individual triad                *
!*                                                                     *
!* Any possible subsumption within the triad is performed by calls     *
!* of SSUM                                                             *
!*                                                                     *
!* If the triad defines either of its operands the effect on current   *
!* PROPTAB entries is considered and, if possible, a new entry is      *
!* created                                                             *
!*                                                                     *
!* On entry                                                            *
!*    PROPTAB contains 3 types of entry                                *
!*     a) global entries, set up by GLOBSUBS                           *
!*     b) local entries for the case  A = B                            *
!*                                    uses of A                        *
!*                                    no further need of A             *
!*     c) local entries for the case  A = B                            *
!*                                    uses of A                        *
!*                                    some further need of A           *
!*    N.B. first entry ignored if 'interference' (DUMCNT#0)            *
!*                                                                     *
!*    LCT = count of active local entries                              *
!*                                                                     *
!*    CMNCT = count of local active common entries                     *
!*                                                                     *
!*    TRIAD = index of triad being considered                          *
!*                                                                     *
!*    BLOCK = index of block containing the current triad              *
!*                                                                     *
!* On return                                                           *
!*    PROPTAB entries may have been changed                            *
!*    LCT still correct count                                          *
!*    CMNCT  ditto                                                     *
!*                                                                     *
!***********************************************************************
!*
%ROUTINESPEC UPDATE PROP(%INTEGER FLAGS)
!*
%RECORD(TRIADF)%NAME TR,TT
%RECORD(BLRECF)%NAME BL
%RECORD(PRECF)%NAME ID,ID2
%RECORD(PROPRECF)%NAME PROP
%RECORD(RESF) RESA,RESB
%INTEGER TRIAD,BLOCK,CONSUB,COORDA,COORDB
%INTEGER T,PA,SAVECURRT,SAVELASTT
!*
      %IF OPTFLAGS&PDUMP#0 %THENSTART
         PRINTSTRING("
SUBSUM")
         WRITE(CURRTRIAD,4)
         NEWLINE
!         DUMP PROPS
!         PRBLTRIADS(CURRBLK)
      %FINISH
!*
      TRIAD=CURRTRIAD
      BLOCK=CURRBLK
      TR==RECORD(ATRIADS+TRIAD*TRIADLENGTH)
      BL==RECORD(ABLOCKS+BLOCK*BLRECSIZE)
!*
!* Stage 1
!*          ALLDEF is called to reveal the defining characteristics of the triad
!*
      T = ALLDEF(TRIAD)
!*
!*          T  is  0  if nothing is defined by the triad
!*                -1  if unspecified common may be defined
!*                +ve if a specified variable is defined
!*               <-1  if a specified common item is defined
!*
!* Stage 2A
!*          If the triad defines neither of its operands then call SSUM for
!*          each operand to replace, if possible, the operand by a value
!*          from PROPTAB. TREVERSE then ensures then operands are correctly
!*          ordered for subsequent processing.
!*
%IF OPTFLAGS&SSDUMP#0 %THENSTART
PRINTSTRING("STAGE 2A"); WRITE(T,1)
NEWLINE
%FINISH
      %IF T=0 %THENSTART
         SUBFLAG=0;! set by SSUM if any replacement occurs
         TR_RES1_W=SSUM(TR_RES1)
         TR_RES2_W=SSUM(TR_RES2) %UNLESS TR_OP=IOSPEC
         %IF SUBFLAG#0 %THEN TREVERSE(TRIAD)
         %RETURN
      %FINISH
!*
!* Stage 2Z
!*          Triad may cause common to be redefined. All active entries
!*          for common must be deactivated and assignments can not be 
!*          deleted, for the same reasons as for DARG.
!*
%IF OPTFLAGS&SSDUMP#0 %THENSTART
PRINTSTRING("STAGE 2Z
")
%FINISH
      %IF T<0 %THENSTART
         PA=APROPTABS+BSBITS*PROPRECSIZE;! note that this is past top item
         %WHILE CMNCT#0 %CYCLE
            %UNTIL PROP_COORD2#0 %CYCLE
               PA=PA-PROPRECSIZE
               PROP==RECORD(PA)
            %REPEAT
            %IF PROP_FLAGS#INACTIVE %THENSTART
               PROP_FLAGS=INACTIVE
               LCT=LCT-1
               CMNCT=CMNCT-1
               %FINISH
         %REPEAT
!*
!*          do subsumption of operand2
!*
         SUBFLAG=0
         TR_RES2_W=SSUM(TR_RES2)
         %IF SUBFLAG#0 %THEN TREVERSE(TRIAD)
         %RETURN
      %FINISH
!*
!* Stage 2B
!*          If triad is DARG then the operand1 value must be accurate,
!*          also it may be corrupted to an unknown value.
!*          Thus any subsumption being done to this variable is terminated
!*          and further subsumtion prevented.
!*          e.g. A = 1
!*               uses of A
!*               DARG A
!*          The uses of A will have been replaced by uses of the constant 1. The
!*          DARG stops this replacement, yet the assignment cannot be deleted
!*          nor can further uses of A be subsumed.
!*
!*          Treat IOSPEC & DIOITEM(list-directed) in the same way as some
!*          values are use and some are def
!*
%IF OPTFLAGS&SSDUMP#0 %THENSTART
PRINTSTRING("STAGE 2B
")
%FINISH
      %IF TR_OP&X'7F'=DARG %OR TR_OP&X'7F'=IOSPEC %OR %C
        TR_OP&X'7F'=DIOITEM %THENSTART
         %IF TR_QOPD1&IDMASK#0 %THENSTART
            ID==RECORD(ADICT+TR_OPD1<<DSCALE)
            %IF ID_COORD#0 %THENSTART
               PROP==RECORD(APROPTABS+ID_COORD*PROPRECSIZE)
               %IF PROP_FLAGS&LOCALACTIVE#0 %THENSTART
                  PROP_FLAGS=INACTIVE
                  LCT=LCT-1
                  CMNCT=CMNCT-PROP_COORD2
               %FINISH
            %FINISH
         %FINISH
         %RETURN
      %FINISH
!*
!* Stage 2C
!*          Triad defines its operand by ASMT
!*                                       ASSIGN
!*                                       DIOITEM(except list-directed)
!*          ASSIGN and IO triads are redefinitions which give no
!*          further chance of further subsumption and terminate any
!*          current subsumption
!*          e.g. A = B
!*               uses of A
!*               READ...A
!*             The uses of A will have been replaced by uses of B, and
!*             the READ enables the assignment to be deleted.
!*          For assignment triads first check for A = ... before and after
!*          subsumption of the RHS. See if this assignment supercedes an
!*          existing PROPTAB entry, and if it is suitable for further
!*          subsumption.
!*          e.g. 1) A = B               2) A = B
!*                  uses of A              uses of A
!*                  A = C                  A = C(I)
!*                  uses of A              uses of A
!*             In the first example, replace the first use of A, then delete
!*             the first assignment, create a new PROPTAB entry for the second
!*             assignment, and subsume the second batch of uses. In the second
!*             case subsumption of the second definition is a marginal case
!*             for optimisation.
!*
%IF OPTFLAGS&SSDUMP#0 %THENSTART
PRINTSTRING("STAGE 2C
")
%FINISH
      %IF TR_OP&X'7F'#ASMT %THENSTART
         %IF TR_QOPD1&IDMASK#0 %THENSTART
            ID==RECORD(ADICT+TR_OPD1<<DSCALE)
            %IF ID_COORD#0 %THENSTART
               PROP==RECORD(APROPTABS+ID_COORD*PROPRECSIZE)
               %IF PROP_FLAGS&LOCALACTIVE#0 %THENSTART
                  %IF PROP_FLAGS=LOCALDELETE %THEN DELUSE(PROP_DEFN)
                  PROP_FLAGS=INACTIVE
                  LCT=LCT-1
                  CMNCT=CMNCT-PROP_COORD2
               %FINISH
            %FINISH
         %FINISH
         %RETURN
      %FINISH
!*
!*          DO I=I,100 will cause I:=I to come through before or
!*          after subsumption of the RHS
!*
      %IF TR_RES1_W=TR_RES2_W %THEN TR_OP=NULL %AND %RETURN
!*
      TR_RES2_W=SSUM(TR_RES2)
      %IF TR_RES2_W=TR_RES1_W %THEN TR_OP=NULL %AND %RETURN
!*
!*          there is an assignment to operand1
!*          If ther is an active PROPTAB entry from aprevious definition
!*          deactivate the entry, deleting the previous assignment if possible
!*
      %IF TR_QOPD1&IDMASK#0 %THENSTART
         ID==RECORD(ADICT+TR_OPD1<<DSCALE)
         %IF ID_COORD#0 %THENSTART
            PROP==RECORD(APROPTABS+ID_COORD*PROPRECSIZE)
            %IF PROP_FLAGS&LOCALACTIVE#0 %THENSTART
               %IF PROP_FLAGS=LOCALDELETE %THEN DELUSE(PROP_DEFN)
               PROP_FLAGS=INACTIVE
               LCT=LCT-1
               CMNCT=CMNCT-PROP_COORD2
            %FINISH
         %FINISH
      %FINISH
!*
!*          now consider whether we have a candidate for future subsumption
!*
      %IF TR_QOPD2&TEXTMASK#0 %THEN %RETURN
      %IF TR_QOPD1&IDMASK=0 %THEN %RETURN
      %IF TR_MODE=LOG1 %THEN %RETURN
      ID==RECORD(ADICT+TR_OPD1<<DSCALE)
      %IF ID_COORD=0 %OR ID_COORD=3 %THEN %RETURN
      %IF ID_CLASS&ARRAYBIT#0 %OR ID_X1&EQUIVBIT#0 %THEN %RETURN
      %IF ID_TYPE=CHARTYPE %THEN %RETURN
      %IF TR_QOPD2&IDMASK#0 %THENSTART
         ID2==RECORD(ADICT+TR_OPD2<<DSCALE)
         %IF ID2_X1&EQUIVBIT#0 %THEN %RETURN
      %FINISH
      %IF ID_CLASS&CMNBIT=0 %THENSTART
         %IF TR_QOPD2&IDMASK#0 %THENSTART;! will already be mapped
            %IF ID2_CLASS&CMNBIT#0 %THEN %RETURN;! don't do not cmn := cmn
         %FINISH
      %FINISH
!*
!* Stage 3
!*          Triad is A := B both of which are suitable for subsumption
!*          N.B. if B is an array reference we must discover which array
!*               it is, so that redefinitions of the array causes subsumption
!*               to stop, unless different const subscripts are involved
!*
!*          Now decide whether or not the subsumption is worth doing.
!*          This involves scanning down the text until one of the following
!*          conditions occurs
!*                redefinition of A
!*                redefinition of B
!*                end-of-block
!*
!*          save information about the current position
!*
%IF OPTFLAGS&SSDUMP#0 %THENSTART
PRINTSTRING("STAGE 3
")
%FINISH
      SAVECURRT=CURRTRIAD
      SAVELASTT=LASTTRIAD
      CONSUB=0
      RESA=TR_RES1
      COORDA=ID_COORD
      RESB=TR_RES2
      %IF TR_QOPD2&IDMASK#0 %THEN COORDB=ID2_COORD %ELSE COORDB=0
!*
!*********** consider array reference
!*
!*
      %WHILE NEXTTRIAD#0 %CYCLE
         TT==RECORD(ATRIADS+CURRTRIAD*TRIADLENGTH)
         T=ALLDEF(CURRTRIAD)
         %IF T>0 %THENSTART
            %IF TT_RES1_W=RESA_W %THENSTART
!*
!* Stage 3.1
!*          We have A := B
!*                  uses of A
!*                  redefinition of A
!*          If the redefinition of A is due to a DARG, IOSPEC or
!*          DIOITEM(list-directed) then A must contain the correct value.
!*          The assignment therefore cannot be deleted. However, if B is
!*          constant there is still some advantage to be had by subsuming
!*          the uses of A. If it is not a DARG then the assignment can be
!*          deleted and the uses subsumed
!*
%IF OPTFLAGS&SSDUMP#0 %THENSTART
PRINTSTRING("STAGE 3.1
")
%FINISH
               %IF TT_OP=DARG %OR TT_OP=IOSPEC %OR %C
                TT_OP=DIOITEM %THENSTART
                  %IF RESB_FORM&CONSTMASK#0 %THENSTART
                     PROP_FLAGS=LOCNODELETE
                    %FINISHELSE ->BEND
               %FINISHELSESTART
                  PROP_FLAGS=LOCALDELETE
                  PROP_DEFN=SAVECURRT
               %FINISH
               PROP_REPL=RESB
               LCT=LCT+1
               CMNCT=CMNCT+PROP_COORD2
               ->BEND
            %FINISHELSESTART
               %IF TT_RES1_W=RESB_W %THENSTART
!*
!* Stage 3.2
!*          We have A := B
!*                  uses of A
!*                  redefinition of B
!*          We now have to scan then text following the redeinition, as the
!*          following situations can arise
!*          1) A := B
!*             uses of A
!*             B := X
!*             DARG A  or  use of A
!*           we can not really do anything as the value of A has to be
!*           saved somewhere and it may as well be in A. (Note that B
!*           cannot be a constant).
!*          2) A := B
!*             uses of A
!*             B := X
!*             A := Y
!*           here there are no complications - we can subsume the uses of A
!*           and delete the assignment when the time comes
!*          3) A := B
!*             uses of A
!*             B := X
!*             end-of-block
!*           if A is busy-on-exit from the block the situation is then same
!*           as 1) above. If it is not the situation is as 2) above
!*
%IF OPTFLAGS&SSDUMP#0 %THENSTART
PRINTSTRING("STAGE 3.2
")
%FINISH
                  %WHILE NEXTTRIAD#0 %CYCLE
                     TT==RECORD(ATRIADS+CURRTRIAD*TRIADLENGTH)
                     T=ALLDEF(CURRTRIAD)
                     %IF T>0 %THENSTART
                        %IF TT_RES1_W=RESA_W  %C
                                         %THEN UPDATE PROP(LOCALDELETE)
                        ->BEND
                     %FINISHELSESTART
                        %IF (T<0 %AND ID_CLASS&CMNBIT#0)  %C
                            %OR TT_RES1_W=RESA_W              %C
                            %OR TT_RES2_W=RESA_W              %C
                                        %THEN ->BEND
                     %FINISH
                  %REPEAT
                  %IF BUSYONX(FROM,CURRBLK,RESA_H0)=NOT BUSY %THEN  %C
                                        UPDATE PROP(LOCALDELETE)
                  ->BEND
               %FINISH
            %FINISH
         %FINISHELSESTART
            %IF T<0 %THENSTART
!*
!* Stage 3.7
!*          we have A := B
!*                  uses of A
!*                  possible redefinition of common
!*          N.B. B may only be common if A is
!*          This is treated as a redefinition
!*
%IF OPTFLAGS&SSDUMP#0 %THENSTART
PRINTSTRING("STAGE 3.7
")
%FINISH
               %IF ID_CLASS&CMNBIT#0 %THENSTART
                  %IF RESB_FORM&CONSTMASK#0 %THEN  %C
                                     UPDATE PROP(LOCNODELETE)
                  ->BEND
               %FINISH
            %FINISH
         %FINISH
      %REPEAT
!*
!* Stage 3.3
!*          We have A := B
!*                  uses of A
!*                  end-of-block
!*          What happens now depends on the business-on-exit of A.
!*          If A is not busy-on-exit then we can subsume the uses of A and
!*          delete the assignment at end-of-block. If A is busy the
!*          assignment must not be deleted, but if B is a constant the
!*          subsumptions are still worth doing.
!*
%IF OPTFLAGS&SSDUMP#0 %THENSTART
PRINTSTRING("STAGE 3.3
")
%FINISH
      %IF BUSYONX(FROM,CURRBLK,RESA_H0) = BUSY %THENSTART
         %IF RESB_FORM&CONSTMASK#0 %THENSTART
            PROP_FLAGS=LOCNODELETE
            PROP_REPL=RESB
            LCT=LCT+1
            CMNCT=CMNCT+PROP_COORD2
         %FINISH
      %FINISHELSESTART
         UPDATE PROP(LOCALDELETE)
      %FINISH
!*
BEND: CURRTRIAD=SAVECURRT
      LASTTRIAD=SAVELASTT
!*
      %IF OPTFLAGS&PDUMP#0 %THENSTART
         PRINTSTRING("
EXIT SUBSUM
")
         DUMP PROPS
         PRBLTRIADS(CURRBLK)
      %FINISH
!*
      %RETURN
!*
%ROUTINE UPDATE PROP(%INTEGER FLAGS)
      PROP_FLAGS=FLAGS
      PROP_REPL=RESB
      PROP_DEFN=SAVECURRT
      LCT=LCT+1
      CMNCT=CMNCT+PROP_COORD2
%END;! UPDATE PROP
!*
%END;! SUBSUM
!*
%ENDOFFILE