!
%OWNINTEGER TRACE=0
%INCLUDE "host_host"
!
%INCLUDE "targ_target"
!
%INCLUDE  "bits_fmts"
!
%include "bits_subfmt"
!
%INCLUDE "bits_consts"
!
%INCLUDE "bits_triadops"
!
%INCLUDE "bits_com"
!
%EXTERNALROUTINESPEC OP4 RESTORE(%INTEGER ASUBINFO)
%EXTERNALROUTINESPEC OP4 RESTORETR
%EXTERNALROUTINESPEC OP4 SETUP(%INTEGER ASUBINFO)
%EXTERNALINTEGERFNSPEC OP4 NEWRD(%INTEGER ARGID)
%EXTERNALINTEGERFNSPEC GET PLAB
%EXTERNALINTEGERFNSPEC OP4 NEWDICT(%RECORD(RESF)%NAME RES)
%EXTERNALROUTINESPEC NEWTEMP(%RECORD(RESF)%NAME R,%INTEGER M,USE)
%EXTERNALINTEGERFNSPEC NEWTRIADR(%INTEGER OP,RES1W,RES2W)
%EXTERNALINTEGERFNSPEC NEWTRIAD2(%INTEGER OP,SLN,QOPD2,OPD2,VAL2)
%EXTERNALINTEGERFNSPEC OP4ARGCHECK(%INTEGER RES1,RES2)
!
%OWNRECORD(COMFMT)%NAME COM
!
%CONSTINTEGER SUBSBIT=1; ! no substitution
%CONSTINTEGER CODEBIT=2; ! generate code
%CONSTINTEGER DONEBIT=4; ! dealt with
%CONSTINTEGER ACTBIT=8; ! currently processing
%CONSTINTEGER SAVEBIT=16; ! SAVE  encountered
%CONSTINTEGER FTM=25 ; ! temp TRIAD qualifier for triad referencing FUN triad
!
%CONSTINTEGER SUBSMASK=7
%CONSTINTEGER SUBSLIMIT=200
!
%CONSTINTEGER TDUMP=1
!
%EXTERNALROUTINESPEC PRINT TR(%INTEGER INDEX,ADICT,ANAMES,
         LEVEL,%RECORD(TRIADF)%NAME TRIAD)
!*
%ROUTINE PRINT CHTRIADS
%RECORD(TRIADF)%NAME TR
%INTEGER CH
CH=1
%CYCLE
  TR==RECORD(COM_ATRIADS+CH*TRIADLENGTH)
  PRINT TR(CH,COM_ADICT,COM_ANAMES,0,TR)
  CH=TR_CHAIN
%REPEAT %UNTIL CH=0
%END;! PRINT CHTRIADS
!
!*
%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
!*
%EXTERNALROUTINE OP4 INIT1(%INTEGER COMAD)
COM==RECORD(COMAD)
TRACE=COM_OPTFLAGS&TDUMP
%END; ! op4 init1
!
%INTEGERFNSPEC SUBSTITUTE(%INTEGERNAME TRIND,%INTEGER TRINC)
!
%EXTERNALINTEGERFN OP4 SUBPROG
!
! search thro' subprogs. table and expand those subprogs which are not
! suitable for substitution
! returns 0 when table exhausted, 1 if expansion o.k., -1 if error
!
%RECORD(TRIADF)%NAME TR
%RECORD(SUBRECF)%NAME MAININFO
%INTEGER TRIND,TABIND,RES,LIMIT
!
! cycle thro' subprogs.table to determine those not suitable for substitution
! 
TABIND=COM_SUBTAB
%CYCLE
  MAININFO==RECORD(COM_ASAVE+TABIND)
  %IF MAININFO_FLAGS&SUBSBIT=0 %THENSTART; !currently marked for substitution
    LIMIT=MAININFO_TRCNT*MAININFO_REFSCNT
    %IF LIMIT>SUBSLIMIT %THEN MAININFO_FLAGS=MAININFO_FLAGS!SUBSBIT
  %FINISH
TABIND=MAININFO_LINK
%REPEAT %UNTIL TABIND=0
!
! now expand those subprogs which are not marked for substitution
!
TABIND=COM_SUBTAB
%CYCLE
  MAININFO==RECORD(COM_ASAVE+TABIND)
  %IF 0<MAININFO_FLAGS&SUBSMASK<DONEBIT %THENSTART ; ! not marked for substitution
    ! restore subprog. triads & dict. to ATRIADS & DICT
    MAININFO_FLAGS=MAININFO_FLAGS!ACTBIT
    OP4 RESTORE(TABIND)
    %IF TRACE#0 %THENSTART
      PRINTSTRING("ADDRESS OF TRIADS AREA =")
      PRHEX(COM_ATRIADS);NEWLINE
!      PRINTSTRING("RESTORED TRIADS OF MAIN PROG:-")
!      NEWLINE
!      PRINT CHTRIADS
!      NEWLINE
    %FINISH
    !cycle thro' triads substituting relevant subprog. calls
    TRIND=1
    %CYCLE
      TR==RECORD(COM_ATRIADS+TRIND*TRIADLENGTH)
      %IF TR_OP=FUN %OR TR_OP=SUBR %THENSTART
        RES=SUBSTITUTE(TRIND,0)
        %IF RES<0 %THEN %RESULT=RES
        TR==RECORD(COM_ATRIADS+TRIND*TRIADLENGTH)
        %IF TRACE#0 %THEN PRINT CHTRIADS
      %FINISH
      TRIND=TR_CHAIN
    %REPEAT %UNTIL TRIND=0
    MAININFO_FLAGS=(MAININFO_FLAGS!!ACTBIT)!DONEBIT
    %RESULT=1
  %FINISH
  TABIND=MAININFO_LINK
%REPEAT %UNTIL TABIND=0
%RESULT=0
%END; ! subprogs
!
!
%INTEGERFN SUBSTITUTE(%INTEGERNAME TRIND,%INTEGER TRINC)
!
! substitute  subprog. triads into main prog.
! returns 1 if substitution o.k. , -1 if error
!
%RECORD(SUBRECF)%NAME SUBINFO
%RECORD(TRIADF)%NAME TR,ATR,SUBTR
%RECORD(PRECF)%NAME PROC,SUB
%RECORD(SRECF)%NAME PL
%RECORD(RESF) RES1,RES2,RESLAB
%INTEGERARRAY LABS(0:63),REPLABS(0:63)
%INTEGERARRAY ID(0:255),REPID(0:255)
%INTEGER TABIND,AIND,SUBIND,SUBDICT,NEXTIND,SNAMIND,LABIND
%INTEGER TRDIF,NUMLABS,NUMARGS,NUMIDS,NA,L,I,RES
%STRING(32)%NAME SUBNAME
!
%ROUTINE GETLAB(%RECORD(RESF)%NAME RES)
    %CYCLE I=1,1,NUMLABS
      %IF LABS(I)=RES_W %THEN RES_W=REPLABS(I) %AND %RETURN
    %REPEAT
    NUMLABS=NUMLABS+1
    LABS(NUMLABS)=RES_W
    RES_W=GET PLAB
    REPLABS(NUMLABS)=RES_W
    %IF TRACE#0 %THENSTART
      PRINTSTRING("NEW LABEL RD FOR ")
      PRHEX(LABS(NUMLABS))
      PRINTSTRING(" IS ")
      PRHEX(REPLABS(NUMLABS))
      NEWLINE
    %FINISH
%END
!
%INTEGERFN GETRES(%RECORD(RESF)%NAME RES)
%RECORD(TRIADF)%NAME COPYTR
%INTEGER NEWIND
%RECORD(RESF) RES2
  %IF RES_FORM=PLABID %OR RES_FORM=LABID %THEN GETLAB(RES) %C
  %ELSEIF RES_FORM=FTM %THEN RES_FORM=PERMID %C
  %ELSEIF RES_FORM&TEXTMASK#0 %THEN RES_H0=RES_H0+TRDIF %C
  %ELSEIF RES_FORM&IDMASK#0 %OR RES_FORM=CNSTID %OR RES_FORM=PROCID %THENSTART
    %CYCLE I=1,1,NUMARGS
      %IF RES_W=ID(I) %THENSTART
        RES2_W=REPID(I)
        ! check for RES2 being HOLMODE
        %IF RES_MODE#RES2_MODE %THEN RES2_MODE=RES_MODE
        RES=RES2
        %IF RES_FORM=ARREL %THENSTART
          COPYTR==RECORD(COM_ATRIADS+RES_H0*TRIADLENGTH)
          NEWIND=NEWTRIADR(DEFARR,COPYTR_RES1_W,COPYTR_RES2_W)
          TR_CHAIN=NEWIND
          TR==RECORD(COM_ATRIADS+NEWIND*TRIADLENGTH)
          TR_CHAIN=SUBIND
          %IF TRACE#0 %THENSTART
            PRINTSTRING(" FOR ACTUAL ARG ")
            PRHEX(RES_W)
            PRINTSTRING(", NEW DEFARR TRIAD CREATED;-")
            PRINT TR(NEWIND,COM_ADICT,COM_ANAMES,0,TR)
          %FINISH
          RES_H0=NEWIND
        %FINISH
      %RESULT=1
      %FINISH
    %REPEAT
    %CYCLE I=NUMARGS+1,1,NUMIDS
      %IF ID(I)=RES_W %THEN RES_W=REPID(I) %AND %RESULT=1
    %REPEAT
    NUMIDS=NUMIDS+1
    ID(NUMIDS)=RES_W
    RES_W=OP4 NEWDICT(RES)
    REPID(NUMIDS)=RES_W
    %IF TRACE#0 %THENSTART
      PRINTSTRING("RD FOR ")
      PRHEX(ID(NUMIDS))
      PRINTSTRING(" BECOMES ")
      PRHEX(REPID(NUMIDS))
      NEWLINE
    %FINISH
  %FINISH
%RESULT=1
%END; ! end getres
!
TR==RECORD(COM_ATRIADS+TRIND*TRIADLENGTH)
SUB==RECORD(TR_OPD1<<DSCALE+COM_ADICT)
SUBNAME==STRING(COM_ANAMES+SUB_IDEN)
TABIND=COM_SUBTAB
%CYCLE
  SUBINFO==RECORD(TABIND+COM_ASAVE)
  %IF SUBINFO_NAME=SUBNAME %THEN %EXIT
  TABIND=SUBINFO_LINK
  %IF TABIND=0 %THEN %RESULT=0
! are external subs. etc. included in table ???
%REPEAT
%IF SUBINFO_FLAGS&ACTBIT=ACTBIT %THEN %RESULT=-3
%IF SUBINFO_FLAGS&SUBSBIT#0 %THEN %RESULT=0
! set up dict. area etc. for new subprog
SUBDICT=SUBINFO_DICT
OP4 SETUP(TABIND)
TRDIF=COM_NEXTTRIAD-1; ! save index of last triad in main prog.
!
! store SUBNAME in dictionary
I=COM_ADICT+COM_DPTR
SNAMIND=COM_DPTR>>DSCALE
COM_DPTR=COM_DPTR+((LENGTH(SUBNAME)+4)>>2)<<2
STRING(I)=SUBNAME
!
! restore subprog. triads to end of ATRIADS (from COM_NEXTTRIAD)
OP4 RESTORETR
! add a new triad to restored triads for RETURN
! this will be chained to main prog triads later
RESLAB_W=GET PLAB
LABIND=NEWTRIAD2(STMT,0,PLABID,RESLAB_H0,0)
%IF TRACE#0 %THENSTART
  PRINTSTRING("NEW PRIVATE LABEL CREATED FOR RETURN STMT:")
  PRHEX(RESLAB_W)
  NEWLINE
  PRINTSTRING("TRIADS FOR SUBPROGRAM ".SUBNAME." RESTORES");NEWLINE
  PRINTSTRING("INDEX OF FIRST TRIAD =")
  WRITE(TRDIF+1,1);NEWLINE
%FINISH
!
! set up RDs to subprog.dummy args, in array ID
SUB==RECORD(SUBDICT+SUBINFO_PROG)
L=SUB_LINK2
%IF TR_OP=FUN %THEN ID(1)=OP4 NEWRD(SUBINFO_PROG) %AND NUMARGS=1 %ELSE %C
  NUMARGS=0
%WHILE L#0 %CYCLE
  PL==RECORD(SUBDICT+L)
  NUMARGS=NUMARGS+1
  L=PL_LINK1
  ID(NUMARGS)=OP4 NEWRD(PL_INF0)
%REPEAT
!
! check actual args. against dummy args.
AIND=TR_OPD2
%IF TR_OP=FUN %THENSTART
  %IF TR_MODE=CHARMODE %OR CMPLX8<=TR_MODE<=CMPLX32 %THEN %C
    SUBINFO_FLAGS=SUBINFO_FLAGS!CODEBIT %AND %RESULT=0
  L=2
%FINISH %ELSE L=1
%CYCLE NA=L,1,NUMARGS
  ATR==RECORD(COM_ATRIADS+AIND*TRIADLENGTH)
  AIND=ATR_OPD2
  I=OP4ARGCHECK(ATR_RES1_W,ID(NA))
  %IF I#0 %THEN SUBINFO_FLAGS=SUBINFO_FLAGS!CODEBIT %AND %RESULT=0
%REPEAT
!
! if a function call, set up a temporary to hold result
%IF TR_OP =FUN %THENSTART
  NEWTEMP(RES1,TR_MODE,1)
  RES1_FORM=PERMID
  REPID(1)=RES1_W
  NUMARGS=1
%FINISH %ELSE NUMARGS=0
!
! set up corresponding RDs to actual args in array REPID
AIND=TR_OPD2
%WHILE AIND#0 %CYCLE; ! cycle 'back' thro' ARG triads
  ATR==RECORD(COM_ATRIADS+AIND*TRIADLENGTH)
  AIND=ATR_OPD2
  RES1=ATR_RES1
  ATR_OP=NOOP; ! eliminate ARG triad(may be reassigned below)
  %IF RES1_FORM&CONSTMASK#0 %THEN ->NEWT1; ! create temp in case any assignments
  %IF RES1_FORM=TRIAD %THENSTART
    %UNLESS RES1_MODE=CHARMODE %OR CMPLX8<=RES1_MODE<=CMPLX32 %THENSTART
      NEWT1:
      NEWTEMP(RES2,RES1_MODE,1)
      RES2_FORM=PERMID
      ! change DARG triad to ASMT triad for new temp.
      ! chaining will be o.k. ? ? ?
      ATR_RES1=RES2
      ATR_RES2=RES1
      ATR_OP=ASMT
      RES1=RES2
    %FINISH
  %FINISHELSEIF RES1_FORM=ARREL %THENSTART
    SUBTR==RECORD(COM_ATRIADS+RES1_H0*TRIADLENGTH)
    ! assuming SUBTR_OP is always ARR/DEFARR
    %IF SUBTR_QOPD2&CONSTMASK=0 %THENSTART
      NEWTEMP(RES2,SUBTR_MODE2,1)
      RES2_FORM=PERMID
      ! change DARG triad to ASMT triad for new temp
      ATR_RES1=RES2
      ATR_RES2=SUBTR_RES2
      ATR_OP=ASMT
      SUBTR_RES2=RES2; ! make DEFARR triad point to new temp
      ! chaining of triads will remaon o.k.
    %FINISH
    ! save original DEFARR triad as template for later refs
    ! but make its op NOOP
    SUBTR_OP=NOOP
  %FINISH
  NUMARGS=NUMARGS+1
  REPID(NUMARGS)=RES1_W
%REPEAT
%IF TRACE#0 %THENSTART
  %CYCLE I=1,1,NUMARGS
    PRINTSTRING("DUMMY ARG ")
    PRHEX(ID(I))
    PRINTSTRING(" BECOMES ")
    PRHEX(REPID(I))
    NEWLINE
  %REPEAT
%FINISH
! if a function call, search thro' main prog. for refs. to current triad TRIND
! & replace by ref. to new temp held in REPID(1)
%IF TR_OP=FUN %THENSTART
  I=TR_CHAIN
  %CYCLE
    SUBTR==RECORD(COM_ATRIADS+I*TRIADLENGTH)
    %IF SUBTR_QOPD1&TEXTMASK#0 %AND SUBTR_OPD1=TRIND-TRINC %THENSTART
      SUBTR_RES1_W=REPID(1)
       ! unless at outer level, make PERMID a temp. marker for GETRES
      %IF TRINC#0 %THEN SUBTR_RES1_FORM=FTM; ! corrected to PERMID in GETRES
      %EXIT
    %FINISH
    %IF SUBTR_QOPD2&TEXTMASK#0 %AND SUBTR_OPD2=TRIND-TRINC %THENSTART
      SUBTR_RES2_W=REPID(1)
      %IF TRINC#0 %THEN SUBTR_RES2_FORM=FTM; ! corrected to PERMID in GETRES
      %EXIT
    %FINISH
    I=SUBTR_CHAIN+TRINC
  %REPEAT
%FINISH
! set calling triad in main prog to STMT triad(type 4) for start of subrprog
TR_OP=STMT
TR_VAL2=4
TR_VAL1=0
TR_QOPD2=0
TR_OPD2=SNAMIND
NEXTIND=TR_CHAIN; ! set index for next triad in main prog.
! chain in subprog. triads at point of call
TR_CHAIN=TRDIF+1
!
! modify subprog. triads & update DICT
SUBINFO_FLAGS=SUBINFO_FLAGS!ACTBIT; ! set to trap recursion
SUBIND=TRDIF+1; ! start of restored triads
NUMLABS=0
NUMIDS=NUMARGS
%CYCLE
  SUBTR==RECORD(COM_ATRIADS+SUBIND*TRIADLENGTH)
  %IF SUBTR_OP=EOT %THEN %EXIT
  %UNLESS SUBTR_CHAIN=0 %THEN SUBTR_CHAIN=SUBTR_CHAIN+TRDIF
  %IF SUBTR_OP=NOOP %THEN ->NEXT
  %IF SUBTR_OP=STMT %THENSTART
    %IF SUBTR_VAL2<2 %THEN GETLAB(SUBTR_RES2)
  %FINISHELSEIF SUBTR_OP=RET %THENSTART
    RET1:
    SUBIND=SUBTR_CHAIN
    ATR==RECORD(COM_ATRIADS+SUBIND*TRIADLENGTH)
    %IF ATR_OP=EOT %THEN %EXIT
    %IF ATR_OP=STMT %AND ATR_VAL2=2 %THENSTART
      SUBIND=ATR_CHAIN+TRDIF
      ATR==RECORD(COM_ATRIADS+SUBIND*TRIADLENGTH)
      %IF ATR_OP=RET %THEN SUBTR_CHAIN=ATR_CHAIN+TRDIF %AND ->RET1
    %FINISH
    SUBTR_OP=GOTO
    SUBTR_RES1=RESLAB
  %FINISHELSESTART
    RES=GETRES(SUBTR_RES1)
    %IF RES<0 %THEN %RESULT=RES
    RES=GETRES(SUBTR_RES2)
    %IF RES<0 %THEN %RESULT=RES
    %IF SUBTR_OP=SUBR %OR SUBTR_OP=FUN %THENSTART
      RES=SUBSTITUTE(SUBIND,TRDIF) 
      %IF RES<0 %THEN %RESULT=RES
      OP4 SETUP(TABIND)
      SUBTR==RECORD(COM_ATRIADS+SUBIND*TRIADLENGTH)
    %FINISH
  %FINISH
  NEXT:
  SUBIND=SUBTR_CHAIN
  TR==SUBTR; ! save previous triad for possible rechaining in GETRES
%REPEAT
!
! for end of subprog. create STMT triad (type 4) from last RET triad
! with pointer to SUBNAME dict entry
SUBTR_OP=STMT
SUBTR_VAL2=4
SUBTR_VAL1=0
SUBTR_QOPD2=1
SUBTR_OPD2=SNAMIND
SUBTR_CHAIN=LABIND; ! chain to new STMT triad for RETURN stmt
!  get this triad & chain into triads for main prog.
SUBTR==RECORD(COM_ATRIADS+LABIND*TRIADLENGTH)
SUBTR_CHAIN=NEXTIND
!
! set TRIND to last triad of dubprog.
TRIND=LABIND
!
SUBINFO_FLAGS=SUBINFO_FLAGS!!ACTBIT
%RESULT=1
!
%END; ! SUBSTITUTE
!
%ENDOFFILE