!                                                                   f4opt1a
! 04/02/87 - make OPTFILES an own record
!
!                                                                    f4opt1
! 07/12/86 - insert include files
!                                                                    ftn4opt8
! 24/11/86 - generate code for all procs, even if substituted
!                                                                    ftn4opt7
! 09/11/86 - generate code for any procs not referenced
!                                                                    ftn4opt6
! 30/09/86 - correct processing of exclusion list
!                                                                    ftn4opt5
! 16/09/86 - suppress tracing in -W option processing
!                                                                    ftn4opt4
! 14/09/86 - support for -W option nominating inclusion/exclusion lists
!                                                                    ftn4opt3
! 15/06/86 - set Subslimit from Options2
! 14/06/86 - mask out mode field in label rds
! 12/06/86 - avoid substituting EXTERNAL procs
! 09/12/85 - taken from op48, new include files inserted
!
%OWNINTEGER TRACE=0
!
%INCLUDE "ftn_ht"
!
{%INCLUDE "ftn_consts1"}
!* modified 23/09/86
!*
!*
%constinteger WSCALE = 2;! scale word address to byte address
%constinteger BSCALE = 0;! scaling factor for words to architectural units
%constinteger CSCALE = 0;! byte offset to architectural unit offset
%constinteger DSCALE = 2;! dict pointer scaling in RES records
!*
%constinteger W1 =  4 ;!  1 word  in architectural units
%constinteger W2 =  8 ;!  2 words in architectural units
%constinteger W3 = 12 ;!  3 words in architectural units
%constinteger W4 = 16 ;!  4 words in architectural units
!*
%constinteger TRIADLENGTH    = 12 ;! size of an individual triad
%constinteger BLRECSIZE      = 44 ;! size of a block table entry in architectural units
%constinteger LOOPRECSIZE    = 16 ;! size of a loop table entry
%constinteger PROPRECSIZE    = 12 ;! size of a propagation table entry
%constinteger CLOOPSZ        = 12 ;! size of cloop table entry
%constinteger FRSIZE         =  8 ;! size of freelist created by PUSHFREE
%constinteger TESZ           = 20
%constinteger DTSZ           = 20
%constinteger ARTICSZ        =  4
%constinteger CTSIZE         =  2 ;! used in OP3
%constinteger EXTNSIZE       =  4 ;! used in OP3
!*
!* following used in strength reduction
!*
%constinteger RDSZ           =  8
%constinteger RUSESZ         = 12
%constinteger RTESTSZ        =  4
%constinteger RDEFSZ         = 16
%constinteger USESZ          = 32
%constinteger SRUSESZ        =  2
%constinteger SRSCALE        =  2;! SR==RECORD(ABLOCKS + SRPTR<<SRSCALE)
%constinteger SRFIXED        = 36
!*
!*
%conststring(5) REG1="reg7"
%constinteger GLAOFFSET=32
%if target=ibm %thenstart
   %constinteger dvarea=7
%finishelsestart
   %constinteger DVAREA=2
%finish
!*
!***********************************************************************
!* Constants defining the size of DICT records                         *
!***********************************************************************
!*
   %constinteger IDRECSIZE    = 28;! size of dict entry reserved for a new identifier
   %constinteger CONRECSIZE   = 16
   %constinteger CNSTRECMIN   =  4
   %constinteger IMPDORECSIZE = 12;! size of DATA-implied-DO list item
   %constinteger LABRECSIZE   = 40
   %constinteger PLABRECSIZE  =  8;! N.B. this is a reduced size for compiler using Put interfaces
   %constinteger XREFSIZE     =  8
   %constinteger CMNRECEXT    = 16;! extra space on iden record for common block name
   %constinteger TMPRECSIZE   = 20
   %constinteger DVRECSIZE    = 28
   %constinteger TRIADSIZE    = 12
   %constinteger LBLKSIZE     = 520
!*
!*
!********************* TRIAD qualifiers ********************************
!*
%CONSTINTEGER NULL    = 0
%CONSTINTEGER LABID   = 1
%CONSTINTEGER PLABID  = 2
%CONSTINTEGER PROCID  = 3
%CONSTINTEGER STKLIT  = 4
%CONSTINTEGER GLALIT  = 5
%CONSTINTEGER SRTEMP  = 6
%CONSTINTEGER BREG    = 7
%CONSTINTEGER VALTEMP = 8
%CONSTINTEGER DESTEMP = 9
%CONSTINTEGER LSCALID =16
%CONSTINTEGER OSCALID =17
%CONSTINTEGER CSCALID =18
%CONSTINTEGER ASCALID =19
%CONSTINTEGER PSCALID =20
%CONSTINTEGER ARRID   =21
%CONSTINTEGER TMPID   =22
%CONSTINTEGER PERMID  =23
%CONSTINTEGER STFNID  =24
%CONSTINTEGER ITMPID  =22
%CONSTINTEGER RTMPID  =22
%CONSTINTEGER ETMPID  =22
%CONSTINTEGER TRIAD   =32
%CONSTINTEGER ARREL   =33
%CONSTINTEGER CHAREL  =34
%CONSTINTEGER CHVAL   =35
%CONSTINTEGER LIT     =64
%CONSTINTEGER NEGLIT  =65
%CONSTINTEGER CNSTID  =66
!*
!********************* TRIAD masks *************************************
!*
%CONSTINTEGER CONSTMASK=X'40'
%CONSTINTEGER IDMASK   =X'10'
%CONSTINTEGER TEXTMASK =X'20'
!*
!********************* other useful masks ******************************
!*
%CONSTINTEGER ARRAYBIT  = X'04'
%CONSTINTEGER CMNBIT    = X'02'
%CONSTINTEGER EQUIVBIT  = X'80'
!*
!********************* modes *******************************************
!*
%CONSTINTEGER INT2    = 0, INT4    = 1, INT8    = 2
%CONSTINTEGER REAL4   = 3, REAL8   = 4, REAL16  = 5
%CONSTINTEGER CMPLX8  = 6, CMPLX16 = 7, CMPLX32 = 8
%CONSTINTEGER LOG1    = 9, LOG2    =10, LOG4    =11
%CONSTINTEGER LOG8    =12, CHARMODE=13, HOLMODE =14
%CONSTINTEGER BYTE    =15, HEXCONST=16
!*
!********************* types *******************************************
!*
%CONSTINTEGER INTTYPE   = 1
%CONSTINTEGER REALTYPE  = 2
%CONSTINTEGER CMPLXTYPE = 3
%CONSTINTEGER LOGTYPE   = 4
%CONSTINTEGER CHARTYPE  = 5
!*
!********************* scaling factors *********************************
!*
!*
!********************* length of maximum source statement **************
!*
%CONSTINTEGER INPUT LIMIT = 1328
!*
!********************* mode to size/type *******************************
!*
%CONSTBYTEINTEGERARRAY MODETOST(0:15)=  %C
   X'41',X'51',X'61',X'52',X'62',X'72',
   X'53',X'63',X'73',X'34',X'44',X'54',X'64',5,0,X'31'
!*
!********************* mode to bytes etc. ******************************
!*
%CONSTBYTEINTEGERARRAY CSIZE(0:15)=  %c
   2,4,8,4,8,16,8,16,32,1,2,4,8,1,0,1
%CONSTBYTEINTEGERARRAY ModetoBytes(0:15)=  %c
   2,4,8,4,8,16,8,16,32,1,2,4,8,1,0,1
%CONSTBYTEINTEGERARRAY ModetoTempBytes(0:15)=  %c
   4,4,8,4,8,16,8,16,32,4,4,4,8,4,4,4
%CONSTBYTEINTEGERARRAY SETMODE(0:63)= %C
0(4),10,13,0(11),1,3,6,11,0(12),2,4,7,8,0(12),15,5,8,9,0(11)
!*
!********************** location of pseudo common record in dict *******
!*
%CONSTINTEGER PSEUDOCMN=20
!*
!********************** location of blank common record in dict ********
!*
%CONSTINTEGER BLCMPTR=96
!*
!********************** other useful consts ****************************
!*
%CONSTINTEGER NO  = 0
%CONSTINTEGER YES = 1
%CONSTINTEGER FULL= 2
!*
!********************** area identifiers *******************************
!*
%constinteger STACK   = 0
%CONSTINTEGER GLA     = 2
%CONSTINTEGER SST     = 4
%CONSTINTEGER GST     = 5
%CONSTINTEGER DIAGS   = 6
%if target=ibm %thenstart
   %constinteger scalars=7
%finishelsestart
   %CONSTINTEGER SCALARS = 2
%finish
%CONSTINTEGER IOAREA  = 8
%CONSTINTEGER ZEROGST = 9
%CONSTINTEGER CONSTS  =10
!*
!********************** system procedures ******************************
!*
%constinteger F77AUX   = 0
%constinteger F77STOP  = 1
%constinteger F77PAUSE = 2
%constinteger F77IOA   = 3
%constinteger F77IOB   = 4
%constinteger F77IOC   = 5
%constinteger F77IOD   = 6
%constinteger F77IOE   = 7
%constinteger F77IOF   = 8
%constinteger F77FILE  = 9
%constinteger IMPSTOP  =10
%constinteger F77RTERR =11
%constinteger F77IOAR  =12
%constinteger F77IOBR  =13
%constinteger F77IOG   =14
%constinteger F77CPSTR =15
%constinteger F77CONCAT=16
%constinteger F77INDEX =17
%constinteger FIBITS   =18
%constinteger FISHFTC  =19
%constinteger F77PCHECK=20
%constinteger F77IOH   =21
%constinteger F77IOI   =22
!***********************************************************************
!*
!
{%INCLUDE  "ftn_fmts2"}
!* 09/12/85 - add recordformat SUBFMT
!* modified 14/03/85
!*
!***********************************************************************
!* Formats for accessing dictionary records                            *
!***********************************************************************
!*
%recordformat PRECF(%byteinteger CLASS,TYPE,X0,X1,
                    %integer LINK1, LINK2,
                   (%shortinteger COORD,LINK3  %OR %integer LAST   %C
                        %OR %integer CONSTRES %OR %integer INF3),
                    %integer ADDR4,
                    %shortinteger DISP,LEN,IDEN,IIN,
                    %integer LINE,XREF,CMNLENGTH,CMNREFAD)
!*
%recordformat SRECF(%integer INF0, LINK1, INF2, INF3, INF4)
!*
%recordformat RESF((%integer W %OR %shortinteger H0,
                      (%shortinteger H1 %OR %byteinteger FORM,MODE)))
!*
%recordformat DORECF( %C
    %integer LABEL, LINK1,
    %record(RESF) LOOPAD, ENDREF, INDEXRD, INCRD, FINALRD, ICRD,
    %integer LABLIST,LINE)
!*
%recordformat BFMT(%integer L,U,M)
!*
%recordformat ARRAYDVF(%integer DIMS, ADDRDV,ADDRZERO,  %C
            %integer ZEROTOFIRST, ADFIRST, NUMELS, ELLENGTH,  %C
            %record(BFMT) %ARRAY B(1 : 7))
!*
!*
%recordformat LRECF(%integer NOTFLAG,LINK1,
                    %record(RESF) ORLAB,ANDLAB,
                    %integer RELOP)
!*
%recordformat IFRECF(%integer TYPE,LINK1,
                     %record(RESF) ENDIFLAB,FALSELAB,
                     %integer LABLIST,LINE)
!*
%recordformat LABRECF(%shortinteger BLKIND,%byteinteger X0,X1,  %C
            %integer LINK1,LINK2,LINK3,ADDR4,LINK5,LAB,LINE,  %C
            %shortinteger DOSTART,DOEND,IFSTART,IFEND)
!*
%recordformat PLABF(%shortinteger BLKIND,%byteinteger USE,X1,
                    %integer INDEX,CODEAD,REF,REFCHAIN)
!*
%recordformat IMPDORECF(%integer VAL,LINK,IDEN)
!*
%recordformat CONSTRECF(%shortinteger MODE,LENGTH,
                      (%integer VALUE %OR %integer LINK1),
                      %integer DADDR,CADDR)
!*
%recordformat TMPF((%byteinteger CLASS,TYPE,
                        %shortinteger LEN %OR %integer W0),
                    %integer LINK1,
                    %byteinteger REG,MODE,%shortinteger INDEX,
                    %shortinteger COORD,USECNT,
                    %integer ADDR)
!*
%recordformat CHARF(%integer ADESC,LINK,LEN)
!*
%recordformat FNRECF(%integer FPTR,LINK1,HEAD,PCT)
!*
%recordformat TERECF(%shortinteger MODE,LOOP,
                      %integer CHAIN,DISP1,INDEX,
                      %shortinteger COORD,FLAGS)
!*
%recordformat DTRECF(%shortinteger MODE,IDENT,
                      %integer CHAIN,DISP2,
                      %shortinteger FLAGS,INDEX,
                     (%integer LOOP %OR %record(RESF) CONST))
!*
!*
!***********************************************************************
!* TRIAD record format                                                 *
!***********************************************************************
!*
%recordformat TRIADF(  %C
               %byteinteger OP,
               (%byteinteger USE %OR %byteinteger VAL2),
               %shortinteger CHAIN,
               (%record(RESF) RES1      %OR     %C
               (%shortinteger OPD1,%byteinteger QOPD1,MODE  %OR  %C
               (%integer SLN %OR %integer VAL1))),
               (%record(RESF) RES2      %OR   %C
                %shortinteger OPD2,%byteinteger QOPD2,MODE2))
!*
!***********************************************************************
!* COM record format                                                   *
!***********************************************************************
!*
%recordformat COMFMT(%integer CONTROL,OPT,OPTIONS1,OPTIONS2,PTRACE,
      ADICT,ANAMES,ADOUTPUT,ADBLKDTAID,DICLEN,DPTR,
      MAXTRIADS,NEXTPLAB,ALABH,ADLHEAD,
      SUBPROGTYPE,SFPTR,EXTERNALS,CBNPTR,SCPTR,CHECKLIST,
      RESCOM1,RESCOM2,F77PARM,FNO,FAULTY,LINEST,CMNIIN,SFMK,
      LISTL,LISTSTREAM,DIAGSTREAM,LISTMODE,XREF,
      PACKCMN,ITSMODE,PATHANAL,CHARACTER CODE,SPACE CHAR,
      HEADINGS,ARRAYCHECKS,JBRMODE,MESSLEN,NAMESLEN,
      NEXTCH,FUNRESDISP,WARNCOUNT,INP,MAXINP,MESSCOUNT,
      UNASSPATTERN,LISTCODE,PI21INT,DOPTR,SUBPROGPTR,
      FNLST,LAB,NAMESFREE,ALGOLREF,FIRSTSTATNUM,CEXPDICT,
      COMMONBASE,FASTPROLOGUE,STATEMENT,IFPTR,
      CNSTCA,COMMENTCNT,ADIDENT,ADERRIDEN,
      ADEXT,MAXDICT,MAXNAMES,MAXOUTPUT,MAXEXT,
      ACOMP,ASUBNAMES,MAXPSTACK,
      ATRIADS,TRFILEID,TRBLOCK,CMNCNT,SCANONLY,NOISY,
      MAXANAL,MAXGEN,SAVEANAL,SAVEGEN,OPTFLAGS,NEXTBIT,
      ACMNBITS,NEXTTEMP,ASSGOTOS,TMPPTR,DESTEMPS,OBJADDR,
      AREAADDR,PASTART,ADOPTDATA,TMINDEX,VRETURN,ENTRIES,
      EQUCHK,LABWARN,LINENO,MAXIBUFF,
      COMMENTS,DIAGLEVEL,WARNNOT77,WARNLENGTH,ALLOWUNIX,ALLOWVAX,
      ONETRIP,HOST,TARGET,MONERRS,CODECA,
      GLACA,DIAGCA,SSTCA,GSTCA,CONSTCA,SCALARCA,IOAREACA,ZGSTCA,STACKCA,
      W1,W2,W4,STATORDERMODE,CURSTATCLASS,LISTPOINT,STACKBASE,
      NEXTTRIAD,ASAVE,MAXSAVE,SUBTAB,LASTSUBTAB,
      INHIBOP4,ARGCNT,IDCNT,LABCNT,TMLIST,MAINPROG,PROCINDEX,CONSOLE)
!*
!***********************************************************************
!* record format for communicating with optimiser                      *
!***********************************************************************
!*
%recordformat OBJFMT(%string(35) MODULE,%integer MAINEP,I,J,K,
                     ADATE,ATIME,OPTIONS2,EXTPROCS,ATRIADS,MAXTRIADS,
                     ABLOCKS,MAXBLOCKS,ALOOP,MAXLOOP,ATABS,MAXTABS,
                     SRFLAGS,INHIBMASK,OPT,OPTFLAGS,OPTDESC0,OPTDESC1,
                     D1,D2,D3,D4)
!*
!***********************************************************************
!*
!*
%RECORDFORMAT SUBRECF(%INTEGER LINK,FLAGS,TRIADS,DICT,NAMES,PTRS,PROG,
      LABCNT,ARGCNT,IDCNT,TRCNT,REFSCNT,SUBSCNT,
      DPTR,NEXTTRIAD,NAMESFREE,NEXTBIT,SUBPROGTYPE,SUBPROGPTR,
      CBNPTR,SCPTR,CMNIIN,FUNRESDISP,CMNCNT,ASSGOTOS,VRETURN,ENTRIES,
      TMLIST,ALABS,ALHEADS,NEXTPLAB,
      %STRING(32) NAME,%INTEGERARRAY COORDS(0:15))
!*
%CONSTINTEGER SUBSIZE=232
%CONSTINTEGER LABSIZE=128
%CONSTINTEGER LHEADSIZE=620
!*
!
{%INCLUDE "ftn_triadops1"}
!*
!*********************** TRIAD operator values *************************
!*
%constinteger ADD    = X'02'
%constinteger SUB    = X'03'
%constinteger MULT   = X'04'
%constinteger DIV    = X'05'
%constinteger NEG    = X'06'
%constinteger ASMT   = X'07'
%constinteger CVT    = X'08'
%constinteger ARR    = X'09'
%constinteger ARR1   = X'0A'
%constinteger BOP    = X'0B'
%constinteger ASGN   = X'0C'
%constinteger EXP    = X'0E'
%constinteger EXP3   = X'0F'
%constinteger AND    = X'10'
%constinteger OR     = X'11'
%constinteger NOT    = X'12'
%constinteger EQUIV  = X'13'
%constinteger NEQ    = X'14'
%constinteger GT     = X'15'
%constinteger LT     = X'16'
%constinteger NE     = X'17'
%constinteger EQ     = X'18'
%constinteger GE     = X'19'
%constinteger LE     = X'1A'
%constinteger SUBSTR = X'1B'
%constinteger CHAR   = X'1C'
%constinteger CONCAT = X'1D'
%constinteger CHHEAD = X'1E'
%constinteger STOD1  = X'20'
%constinteger STOD2  = X'21'
%constinteger EOD1   = X'24'
%constinteger EOD2   = X'25'
%constinteger BRK    = X'28'
%constinteger DARR   = X'29'
%constinteger DEFARR = X'29'
%constinteger RRSUB  = X'2A'
%constinteger RRDIV  = X'2B'
%constinteger DCHAR  = X'2C'
%constinteger ASH    = X'2D'
%constinteger STRTIO = X'30'
%constinteger IOITEM = X'31'
%constinteger IODO   = X'32'
%constinteger IOSPEC = X'33'
%constinteger IO     = X'34'
%constinteger ENDIO  = X'34'
%constinteger DIOITEM= X'35'
%constinteger SUBS   = X'38'
%constinteger ARGARR = X'39'
%constinteger INIT   = X'3A'
%constinteger INCR   = X'3B'
%constinteger DECR   = X'3C'
%constinteger DINIT  = X'3D'
%constinteger PINCR  = X'3E'
%constinteger NOOP   = X'40'
%constinteger FUN    = X'41'
%constinteger SUBR   = X'42'
%constinteger ARG    = X'43'
%constinteger STRTSF = X'44'
%constinteger ENDSF  = X'45'
%constinteger CALLSF = X'46'
%constinteger IFUN   = X'47'
%constinteger DARG   = X'48'
%constinteger IARG   = X'49'
%constinteger REPL   = X'4A'
%constinteger REF    = X'4B'
%constinteger LOADB  = X'4C'
%constinteger STOREB = X'4D'
%constinteger MOO    = X'4E'
%constinteger JIT    = X'50'
%constinteger JIF    = X'51'
%constinteger JINN   = X'52'
%constinteger JINP   = X'53'
%constinteger JINZ   = X'54'
%constinteger JIN    = X'55'
%constinteger JIP    = X'56'
%constinteger JIZ    = X'57'
%constinteger CGT    = X'58'
%constinteger GOTO   = X'59'
%constinteger RET    = X'5A'
%constinteger STOP   = X'5B'
%constinteger PAUSE  = X'5C'
%constinteger EOT    = X'5D'
%constinteger NINT   = X'5E'
%constinteger ANINT  = X'5F'
%constinteger STMT   = X'60'
%constinteger ITS    = X'61'
%constinteger PA     = X'62'
%constinteger TOCHAR = X'63'
%constinteger DIM    = X'64'
%constinteger DMULT  = X'65'
%constinteger AINT   = X'66'
%constinteger ABS    = X'67'
%constinteger MOD    = X'68'
%constinteger SIGN   = X'69'
%constinteger MIN    = X'6A'
%constinteger MAX    = X'6B'
%constinteger REALL  = X'6C'
%constinteger IMAG   = X'6D'
%constinteger CMPLX  = X'6E'
%constinteger CONJG  = X'6F'
%constinteger LEN    = X'70'
%constinteger ICHAR  = X'71'
%constinteger CHIND  = X'72'
%constinteger DCMPLX = X'73'
%constinteger INTRIN = X'74'
!*
!
%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)
!
%externalintegerfnspec Get Space(%integer Size)
!
%recordformat Optfilesfmt(%integer Inaddr,Inlen,Exaddr,Exlen)
%ownrecord(Optfilesfmt) Optfiles = 0
!
%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 Externbit = 32;! set if appearing in an external statement
%CONSTINTEGER FTM=25 ; ! temp TRIAD qualifier for triad referencing FUN triad
!
%CONSTINTEGER SUBSMASK=7
%OWNINTEGER SUBSLIMIT=200
%owninteger Inclistcnt,Exclistcnt
%ownstring(31)%arrayformat Listfmt(0:254)
%ownstring(31)%arrayname Inclist
%ownstring(31)%arrayname Exclist
!
%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
!*
%routine Set Names(%integer Ad,Len,%string(31)%arrayname Names,%integername Count)
%integer I,J,C
%ownbyteintegerarray A(0:31)
!*
%routine Set
      Count=Count+1
      A(0)=J
      Names(Count)=string(addr(A(0)))
{printstring("Set:");write(Count,1);write(J,1);printstring(Names(Count));newline}
      J=0
%end
!*
      J=0
      %cycle I=0,1,Len-1
         C=byteinteger(Ad+I)
{printstring("Char:");write(C,1);newline}
         %if C<=' ' %or C=',' %thenstart  {valid separators?}
            %if J>0 %thenstart
               Set
               %if Count=254 %then %return
            %finish
         %finishelsestart
            %if 'a'<=C<='z' %then C=C-'a'+'A'
            %if J<31 %thenstart
               J=J+1
               A(J)=C
            %finish
         %finish
      %repeat
      %if J>0 %then Set
%end;! Set Names
!*
%EXTERNALROUTINE OP4 INIT1(%INTEGER COMAD)
%integer I,Options2
      Com==record(Comad)
      Options2=Com_Options2
      I=Options2>>16
      %if I>100 %then Subslimit=I %else Subslimit=200
      Trace=Com_Optflags&Tdump
      Inclistcnt=0
      Exclistcnt=0
      %if Options2&X'300' # 0 %thenstart
         I=Get Space(8128)
         Inclist==array(I,Listfmt)
         Exclist==array(I+4064,Listfmt)
{printstring("Wopt:")}
{write(Optfiles_Inaddr,8);write(Optfiles_Inlen,4)}
{write(Optfiles_Exaddr,8);write(Optfiles_Exlen,4)}
{newline}
         %if Options2&X'100'#0 %thenstart
            Set Names(Optfiles_Inaddr,Optfiles_Inlen,Inclist,Inclistcnt)
         %finish
         %if Options2&X'200'#0 %thenstart
            Set Names(Optfiles_Exaddr,Optfiles_Exlen,Exclist,Exclistcnt)
         %finish
      %finish
{      %if Inclistcnt#0 %thenstart}
{         printstring("Inclist:}
{")}
{         %cycle I=1,1,Inclistcnt}
{            printstring(Inclist(I))}
{            newline}
{         %repeat}
{      %finish}
{      %if Exclistcnt#0 %thenstart}
{         printstring("Exclist:}
{")}
{         %cycle I=1,1,Exclistcnt}
{            printstring(Exclist(I))}
{            newline}
{         %repeat}
{      %finish}
%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,I
!
! 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 Maininfo_Flags&Externbit#0 %or Maininfo_Refscnt=1 %thenstart
               MAININFO_FLAGS=MAININFO_FLAGS!SUBSBIT
            %finishelsestart
               %if Limit>Subslimit %thenstart;! check for inclusion regardless
                  %if Inclistcnt#0 %thenstart
                     %cycle I=1,1,Inclistcnt
                        %if Inclist(I)=Maininfo_Name %then ->Next
                     %repeat
                  %finish
                  Maininfo_Flags=Maininfo_Flags!Subsbit
               %finishelsestart;! check for exclusion regardless
                  %if Exclistcnt#0 %thenstart
                     %cycle I=1,1,Exclistcnt
                        %if Exclist(I)=Maininfo_Name %thenstart
                           Maininfo_Flags=Maininfo_Flags!Subsbit
                           ->Next
                        %finish
                     %repeat
                  %finish
               %finish
            %finish
         %finish
Next:    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 MAININFO_FLAGS&DONEBIT=0 %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)
      Res_Mode=0
    %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