!* modified 24/09/82
!*
%INCLUDE "ERCS06.OPT_CTLSPECS"
%INCLUDE "ERCS06.PERQ_COMFMT"
%INCLUDE "ERCS06.PERQ_TRIADOPS"
!*
%SYSTEMROUTINESPEC OUTFILE(%STRING(31) S,
                           %INTEGER SIZE,GAP,PROTECTION,
                           %INTEGERNAME CONADDR,FLAG)
%SYSTEMINTEGERMAPSPEC COMREG(%INTEGER N)
!*
%EXTERNALROUTINESPEC PRINT TR(%INTEGER INDEX,ADICT,ANAMES,
           LEVEL,%RECORD(TRIADF)%NAME TRIAD)
!*
%EXTERNALROUTINESPEC BLOCKS(%INTEGER GOTOLIST)
%EXTERNALROUTINESPEC OP2
%EXTERNALROUTINESPEC OPTSOURCE
!*
%ROUTINE PRINT TRIADS
%INTEGER I
%RECORD(TRIADF)%NAME TR
      %CYCLE I=1,1,LASTTRIAD
         TR==RECORD(ATRIADS+I*TRIADLENGTH)
         PRINT TR(I,ADICT,ANAMES,0,TR)
      %REPEAT
%END;! PRINT TRIADS
!*
%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

%EXTERNALROUTINE OPTCTL(%INTEGER ACOM,NEXT TR,BITS,ASSGOTOS)
%RECORD(COMFMT)%NAME COM
%RECORD(TRIADF)%NAME TR
%INTEGER F,I
      COM==RECORD(ACOM)
      ADICT=COM_ADICT
      MAXDICT=COM_MAXDICT
      MAXTRIADS=COM_MAXTRIADS
      ANAMES=COM_ANAMES
      ATRIADS=COM_ATRIADS
      OPT=COM_OPT
      OPTFLAGS=COM_OPTFLAGS
      SRFLAGS=COMREG(54)
      DPTR=COM_DPTR
      LASTTRIAD=NEXTTR-1
      BSBITS=COM_NEXTBIT
      BSWORDS=(BSBITS+31)>>5
      BSSIZE=BSWORDS<<2
      BLSIZE=BLRECSIZE+3*BSSIZE
      %CYCLE I=0,1,15
         CMNCOORDS(I)=INTEGER(COM_ACMNBITS+I<<2)
      %REPEAT
      ACMNCOORDS=ADDR(CMNCOORDS(0))
      ACURRDEF=ADDR(CURRDEF(0))
      OUTFILE("T#BLOCKS",4096,4096,0,ABLOCKS,F)
      %IF F#0 %THEN %MONITOR %AND %STOP
      MAXBLOCKS=4096
      OUTFILE("T#TABS",4096,4096,0,ATABS,F)
      %IF F#0 %THEN %MONITOR %AND %STOP
      MAXTABS=4096
      OUTFILE("T#LOOPS",4096,4096,0,ALOOPS,F)
      %IF F#0 %THEN %MONITOR %AND %STOP
      MAXLOOPS=4096
!*
      %IF OPTFLAGS&1#0 %THEN PRINT TRIADS
      %IF OPTFLAGS&32#0 %THENSTART
         OPTSOURCE
         %STOP
      %FINISH
      BLOCKS(ASSGOTOS)
      %IF OPTFLAGS&8#0 %THEN PRINT TRIADS
      OP2
      %IF OPTFLAGS&16#0 %THEN PRINT TRIADS
%END;! OPTCTL
%EXTERNALROUTINE BLOCKSFULL
      %MONITOR
      %STOP
%END;! BLOCKSFULL
!*
%EXTERNALROUTINE TABSFULL
      %MONITOR
      %STOP
%END;! TABSFULL
!*
%EXTERNALROUTINE DICTFULL
      %MONITOR
      %STOP
%END;! DICTFULL
!*
%EXTERNALROUTINE LOOPSFULL
      %MONITOR
      %STOP
%END;! LOOPSFULL
!*
%EXTERNALROUTINE TRIADSFULL
      %MONITOR
      %STOP
%END;! TRIADSFULL
!*
%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 + 2
      %FOR I = 1,1,9 %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
!*
%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:4)
!*
      TR==RECORD(ATRIADS+INDEX*TRIADLENGTH)
      ->DEF(DEFTEST(TR_OP))
!*
DEF(0):                                 ! no defining context
      %RESULT=0
!*
DEF(1):                                 ! ASMT,ASGN
      %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 %THEN %RESULT=-1;! args and all commons at risk
      %IF ID_CLASS & CMNBIT # 0 %AND ARGRISK # 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 = ARGARR %THEN ->SET
            %IF TR_OP = 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
!*
%END;! ALLDEF
!*
%EXTERNALROUTINE SETCMNBITS(%INTEGER CUR)
!* OR common coordinates into CURRDEF bitstrip
!*
%INTEGER CMN,L
      CMN=ACMNCOORDS
      CUR=ACURRDEF
      L=X'18000000'!BSSIZE
      *LDTB_L; *LDA_CMN; *CYD_0; *LDA_CUR; *ORS_%L=%DR
%END;! SETCMNBITS
!*
%EXTERNALROUTINE SETBIT(%INTEGER STRIPADDR,INDEX)
      *LDTB_X'FFFF'; *LDA_STRIPADDR; *LB_INDEX; *LSS_1; *ST_(%DR+%B)
%END;! SETBIT
!*
%EXTERNALROUTINE PUTBIT(%INTEGER STRIPADDR,INDEX,VAL)
      *LDTB_X'FFFF'; *LDA_STRIPADDR; *LB_INDEX; *LSS_VAL; *ST_(%DR+%B)
%END;! PUTBIT
!*
%EXTERNALROUTINE CLEARBIT(%INTEGER STRIPADDR,INDEX)
      *LDTB_X'FFFF'; *LDA_STRIPADDR; *LB_INDEX; *LSS_0; *ST_(%DR+%B)
%END;! CLEARBIT
!*
%EXTERNALROUTINE GETBIT(%INTEGER STRIPADDR,INDEX,%INTEGERNAME VAL)
%INTEGER I
      *LDTB_X'FFFF'; *LDA_STRIPADDR; *LB_INDEX; *LSS_(%DR+%B); *ST_I
      VAL=I
%END;! GETBIT
!*
%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
!*
%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 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<30 %THEN I=REVOP(TR_OP) %ELSE %RETURN
      %IF I=0 %THEN %RETURN;! not reversible
!*
      %IF TR_QOPD1=TR_QOPD2 %THENSTART
         %IF TR_OPD2>TR_OPD1 %THENSTART
SWAP:       TR_OP=I
            R=TR_RES1
            TR_RES1=TR_RES2
            TR_RES2=R
         %FINISH
          %RETURN
      %FINISH
!*
      %IF TR_QOPD2>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 NEXTTRIAD
!***********************************************************************
!*                                                                     *
!* 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=STMT %AND CUR_VAL2&SOB#0 %THEN %RESULT=0;! returns end-of-block
            %IF CUR_OP#NULL %THEN %EXIT
            CHAINOUT
         %REPEAT
!*
         %IF CUR_OP#STMT %AND CUR_OP#REPL %THENSTART
            %CYCLE
               %IF CUR_QOPD1 & TEXTMASK = 0 %THEN %EXIT
                REPL INDEX=CUR_OPD1
               TR==RECORD(ATRIADS+REPL INDEX*TRIADLENGTH)
               %IF TR_OP=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=REPL %THEN %RESULT=1
            CUR_RES2=TR_RES1;! perform replacement
            %IF CUR_QOPD2 & TEXTMASK # 0 %THENSTART;! update use count
               TR==RECORD(ADICT+CUR_OPD2*TRIADLENGTH)
               TR_USE=TR_USE+1
            %FINISH
            TREVERSE(CURRTRIAD)
            DELUSE(REPL INDEX)
            %RESULT=1
         %FINISH
      %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=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=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_MODE2&BMBIT)>>BMBITSHIFT
      %FINISH
!*
!* strength reduction temporary is loop variable
!*
      %IF QUAL=SRTEMP %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_MODE2&BMBIT)>>BMBITSHIFT
      %FINISH
!*
!* strength reduction temporary is loop variable
!*
      %IF QUAL=SRTEMP %THEN %RESULT=0
!*
!* anything else (const) must be loop const
!*
      %RESULT=1
!*
%END;! LOOPCON2
!*
%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
!*
%RECORD(PRECF)%NAME ID
%RECORD(BLRECF)%NAME BL
%INTEGER PATH,NUMCON,ACON,CURBL,CVAL,BIT,BLSTRIP,I
!*
      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+32*I)=0
      %REPEAT
      PATH=0
      CURBL=BLOCK
      BL==RECORD(ABLOCKS+CURBL*BLRECSIZE)
      *LSQ_PATH; *ST_%TOS
      PATH=1
      %IF FROMORTO=0 %THEN ->BUSYF;! busy-on-exit from
!*
BUSY: I=BL_BOE
      GETBIT(I,CVAL,BIT)
      %IF BIT#0 %THEN %RESULT=1;! busy
!*
      I=BL_DEF
      GETBIT(I,CVAL,BIT)
      %IF BIT#0 %THENSTART;! if not BOE but DEF then not busy-on-exit this path
EXIT:    *LSD_%TOS; *ST_PATH
         %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+4
      CURBL=INTEGER(ACON)
      %IF CURBL=0 %THENSTART;! exit block being processed
         %IF ID_CLASS&CMNBIT#0 %OR ID_CLASS=11 %THEN %RESULT=1;! common anad 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=ENTBPTR
         NUMCON=INTEGER(ACON)-1
         CURBL=INTEGER(ACON)
         ACON=ACON+4
         ->CHECK;! ensure that entry block has not already been processed
      %FINISH
!*
CHECK:GETBIT(BLSTRIP,CURBL,BIT)
      %IF BIT#0 %THEN ->NEXTC
      SETBIT(BLSTRIP,CURBL)
      *LSD_PATH; *ST_%TOS
      BL==RECORD(ABLOCKS+CURBL*BLRECSIZE)
      ->BUSY
!*
%END;! BUSYONX
!*
!*
%ENDOFFILE