!                                                                   ftriads1
! 10/10/86 - copied from ftntriads6
!
! 20/02/86 - comment out code for SW(ARREL) in PRINT TRIAD
! 22/01/86 - insert FPTOS, change PRINT TR for type 4 STMT triads
!          - include updated ftn_fmts files
! 14/01/85 - conditional compilation
! 28/11/84 - include cfort_ files for common version
! 18/09/84 - insert switch for STFNID in ANAL and set QUAL(24) to "STFNID"
! 10/07/84 - new version of targ_fptos
! 03/07/84 - put FPTOS in an include file
!          - set up string REG1 in tagr_taget & substitute for "reg-1"
! 21/03/84 - amend arrays OPVALS, ST, SZTY & REG
! 19/03/84 - change some address increments to W! etc.
! 08.03.84 - change INTEGER mapping increments to W1
! 28/02/84 - FPTOS inserted
!*
! 01/11/83 copied from ercs06.rel90_optextb15
!*
%CONSTINTEGER OPSYS=0
!  =0  (Emas  ISO)
!  =1  (VME  EBCDIC)
!*
%include "ftn_ht"
{%include "ftn_consts3"}
!* 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_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'
!*
{%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
!*
!*
!***********************************************************************
!* Exports                                                             *
!***********************************************************************
!*
%routinespec Print Tr(%integer Index,Adict,Anames,Level,
                      %record(Triadf)%name Triads)
!*
!
%externalstring(36) %fnspec FPTOS (%integer REAL ADDR{ess}, REAL MODE {3 for REAL* 4})
!                                                         {4 for REAL* 8}
!*
{%include "ftn_copy1"}
!* modified 23/09/86
!*
%routine Copy(%integer Length,Fbase,Fdisp,Tbase,Tdisp)
!***********************************************************************
!* copy Length bytes from fbase(fdisp) to tbase(tdisp)                 *
!***********************************************************************
%integer I,From,To
      %if Length<=0 %then %return
      From=Fbase+Fdisp
      To=Tbase+Tdisp
      %cycle I=0,1,Length-1
         byteinteger(To+I)=byteinteger(From+I)
      %repeat
%end;! Copy
!*
!*
!*
{%include "targ_etoinitoe"}
!*
! **********************************************************************
! include EBCDIC/ISO conversion routines if required
!***********************************************************************
!*
{end "targ_etoinitoe"}
!*
%CONSTSTRING(7) %ARRAY OPVALS(0:116)=                                  %C
      "NULL",     "REL",      "+",        "-",
      "*",        "/",        "NEG",      "=",
      "CVT",      "ARR",      "ARR1",     "BOP",
      "ASGN",     "",         "EXP",      "",
      "AND",      "OR",       "NOT",      "EQUIV",
      "NEQ",      "GT",       "LT",       "NE",       
      "EQ",       "GE",      "LE",       "SUBSTR",
      "CHAR",     "CONCAT",   "CHHEAD",   "",
      "STOD1",    "STOD2",    "STODA",    "",      
      "EOD1",     "EOD2",     "EODA",     "EODB",
      "BRK",      "DEFARR",   "RSUB",     "RDIV",    
      "DCHAR",    "ASH",      "",         "",
      "STRTIO",   "IOITEM",   "IODO",     "IOSPEC",
      "IO",       "DIOITEM",  "ASGN",     "ASMT",
      "SUBS",     "ARGARR",   "INIT",     "INCR",     
      "DECR",     "DINIT",    "PINCR",    "",
      "NOOP",     "FUN",      "CALL",     "ARG",
      "STRTSF",   "ENDSF",    "CALLSF",   "IFUN",
      "DARG",     "IARG",     "REPL",     "REF",
      "LOADB",    "STOREB",   "MOO",      "",
      "JIT",      "JIF",      "JINN",     "JINP",
      "JINZ",     "JIN",      "JIP",      "JIZ",
      "CGT",      "GOTO",     "RET",      "STOP",
      "PAUSE",    "EOT",  "NINT",    "ANINT",
      "STMT",     "ITS",      "PA", "TOCHAR",
   "DIM",       "DMULT",      "AINT",     "ABS",
      "MOD",      "SIGN",     "MIN",      "MAX",
      "REAL",     "IMAG",     "CMPLX",    "CONJG",
      "LEN",      "ICHAR",    "INDEX",    "DCMPLX",
      "INTRIN"

!*
%CONSTSTRING(7) %ARRAY QUAL(0:66)=     %C
      "NULL",      "LABID",    "PLABID",   "PROCID",    "STKLIT",
    "GLALIT",     "SRTEMP",      "Breg",  "VALTEMP",   "DESTEMP",
          "",           "",          "",         "",          "",
          "",    "LSCALID",   "OSCALID",  "CSCALID",   "ASCALID",
   "PSCALID",      "ARRID",     "TMPID",   "PERMID",    "STFNID",
          "",           "",          "",         "",          "",
          "",           "",     "TRIAD",    "ARREL",    "CHAREL",
     "CHVAL",           "",          "",         "",           "",
          "",           "",          "",         "",           "",
          "",           "",          "",         "",           "",
          "",           "",          "",         "",           "",
          "",           "",          "",         "",           "",
          "",           "",          "",          "",       "LIT",
    "NEGLIT",     "CNSTID"
%CONSTBYTEINTEGERARRAY ST(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',X'05',X'51',X'31'
%CONSTSTRING(8) %ARRAY SZTY(0:15)=   %C
      "INT2",    "INT4",     "INT8",     "REAL4",     "REAL8",
      "REAL16",  "CMPLX4",   "CMPLX8",   "CMPLX16",   "LOG1",
      "LOG2",    "LOG4",    "LOG8",      "CHARMODE",  "HOLMODE",
      "BYTE"

%CONSTBYTEINTEGERARRAY C(0:15)='0','1','2','3','4','5','6','7',
                               '8','9','A','B','C','D','E','F'
%CONSTSTRING(2) %ARRAY COMPAR(1:6)="GT","LV","NE","EQ","GE","LE"
%CONSTSTRING(5) %ARRAY LOGVAL(0:1)="FALSE","TRUE"
%CONSTBYTEINTEGERARRAY INDENT(1:9)=10,8,8,14,10,10,10,6,68
%CONSTSTRING(6) TMPRES="IR IN "
%OWNINTEGER IRADR
!*
!*                        PSTRING                                    *!
!*
%ROUTINE PSTRING(%INTEGER TAB,%STRING(32) S,%INTEGER LEVEL)
%INTEGER LEN
%SWITCH SW(0:1)
      LEN=LENGTH(S)
      -> SW(TAB) %IF TAB<2 %AND TAB>=0
      -> PRINT
SW(0): 
      NEWLINE
      PRINTSTRING("TRIADNO   LHS     OP      RHS")
      %IF LEVEL=2 %THEN %START
         SPACES(11)
         PRINTSTRING("QL        QR        MODE")
      %FINISH
      NEWLINE
      %RETURN
SW(1):
      PRINTSTRING("t".S)
      SPACES(INDENT(TAB)-LEN-1)
      %RETURN
PRINT:
      PRINTSTRING(S)
      %IF IRADR#0 %THENSTART
         WRITE(IRADR,12)
         IRADR=0
         LEN=LEN+12
      %FINISH
      SPACES(INDENT(TAB)-LEN)
      %RETURN
%END
!*                                                                   *!
!*                           ITOS                                    *!
!*                                                                   *!
%STRING(31) %FN ITOS(%INTEGER N)
%CONSTINTEGERARRAY TENS(0:9)=%C
1,10,100,1000,10000,100000,1000000,10000000,100000000,1000000000
%STRING(11) RES
%INTEGER M,R,I,STARTED,J
      %IF N=0 %THEN %RESULT="0";
      %IF N<0 %THEN N=-N %AND RES="-" %ELSE RES=""
      STARTED=0
      %CYCLE I=9,-1,0
      R=TENS(I)
      %IF N>=R %OR STARTED#0 %START
      STARTED=1
      M=N//R
      RES=RES.TOSTRING(M+'0')
      N=N-M*R
      %FINISH
      %REPEAT
      %RESULT=RES
%END
!*                                                                   *!
!*                         ANAL                                      *!
!*                                                                   *!
%ROUTINE ANAL(%INTEGER INDEX,OPD,TAB,ADICT,ANAMES,LEVEL)
%SWITCH SW(0:66)
%SWITCH T(0:14)
%STRING(32) S
%INTEGER J,LEN,ADR,IDEN,I,K
%REAL X,Y
%LONGREAL XX,YY
{%LONGLONGREAL XXX,YYY   }
%RECORD (CONSTRECF) %NAME CNST
%RECORD (PRECF) %NAME SCAL
%RECORD (PRECF) %NAME PROC
%RECORD (TMPF) %NAME TMP
%RECORD (LABRECF) %NAME LAB
%RECORD(PLABF)%NAME PLAB
%RECORD(TERECF)%NAME TE
%RECORD(DTRECF)%NAME DT
      -> SW(INDEX)
SW(*):%RETURN
SW(NULL):   !NULL                                             NULL
      PSTRING(TAB,QUAL(0),LEVEL)
      %RETURN
SW(LIT):   !LITERAL                                          LIT
      S=ITOS(OPD)
SW1:  PSTRING(TAB,S,LEVEL)
      %RETURN
SW(NEGLIT):
      S="-".ITOS(OPD)
      ->SW1
SW(CNSTID):   !CONST RECORD IN DICT                             CNSTID
      CNST==RECORD(OPD<<DSCALE+ADICT)
      ADR=CNST_DADDR
      -> T(CNST_MODE)
T(INT2):
      %if HOST=PERQPNX %or HOST=ICL2900 %thenstart
         J=HALFINTEGER(ADR+ADICT)
      %finishelsestart
         J=SHORTINTEGER(ADR+ADICT)
      %finish
      -> INT
T(INT4):
      J=INTEGER(ADR+ADICT)
      -> INT
T(INT8):
      J=INTEGER(ADR+ADICT+W1)
INT:  S=ITOS(J)
SOUT: PSTRING(TAB,S,LEVEL)
      %RETURN
T(REAL4):
      X=REAL(ADR+ADICT)
      S=FPTOS(ADDR(X),3)
      ->SOUT
T(REAL8):
      XX=LONGREAL(ADR+ADICT)
      S=FPTOS(ADDR(XX),4)
      ->SOUT
!*
{%include "targ_text2"}
! ***********************************************************************
! include code for REAL*16 numbers if required in OPTEXTnn
! ***********************************************************************
{end "targ_text2"}
!*
T(CMPLX8):
      X=REAL(ADR+ADICT)
      Y=REAL(ADR+ADICT+W1)
      S="(".FPTOS(ADDR(X),3).",".FPTOS(ADDR(Y),3).")"
      ->SOUT
T(CMPLX16):
      XX=LONGREAL(ADR+ADICT)
      YY=LONGREAL(ADR+ADICT+W2)
      S="(".FPTOS(ADDR(XX),4).",".FPTOS(ADDR(YY),4).")"
      -> SOUT
SP:
      %IF CNST_MODE<6 %THEN J=9 %ELSE J=21
      SPACES(INDENT(TAB)-J)
      %RETURN
T(LOG4):
      J=INTEGER(ADR+ADICT)
      -> LOG
T(LOG8):
      J=INTEGER(ADR+ADICT+W1)
LOG:
      %IF J#0 %THEN J=1
      PSTRING(TAB,LOGVAL(J),LEVEL)
      %RETURN
T(CHARMODE):
T(HOLMODE):
      LEN=INTEGER(ADR+ADICT)
      %IF LEN>4 %THEN LEN=4
      COPY(LEN,ADR+ADICT,4,ADDR(S),1)
      LENGTH(S)=LEN
      S="'".S."'"
      LEN=LEN+2
{%include "targ_text1"}
! *************************************************************************
! include code for EBCDIC/ISO conversion if required in OPTEXTnn
! *************************************************************************
{end "targ_text1"}
      PSTRING(TAB,S,LEVEL)
      %RETURN
T(*):
      %RETURN
SW(SRTEMP):  ! strength reduction temporary
      S="sr".ITOS(OPD)
      ->SOUT
SW(ARREL):   ! ARRAY ELEMENT TRIAD
SW(CHAREL):   ! CHAR SUBSTRING TRIAD
SW(TRIAD):   !TRIAD                                            TRIAD
      S=ITOS(OPD)
      S="t".S
      ->SOUT
SW(LSCALID):   !LOCAL SCALAR                                     LSCALID
SW(OSCALID):   !OWN SCALAR                                       OSCALID
SW(CSCALID):   !COMMON SCALAR                                    CSCALID
SW(ASCALID):   !   scalar equivalenced to array
SW(PSCALID):   !PARAMETER SCALAR                                 PSCALID
SW(ARRID):   !ARRAY ID                                         ARRID
      SCAL==RECORD(OPD<<DSCALE+ADICT)
      S=STRING(ANAMES+SCAL_IDEN)
      ->SOUT
SW(PERMID):
SW(TMPID):   !TEMP SCALAR                                      TMPID
      TMP==RECORD(OPD<<DSCALE+ADICT)
      s=itos(tmp_index)
      s="TEMP".s
      ->SOUT
SW(LABID):  !LABEL IDENTIFIER                                 LABID
      LAB==RECORD(OPD<<DSCALE+ADICT)
      S=ITOS(LAB_LAB)
      S="LABEL ".S
      ->SOUT
SW(PLABID):  !PRIVATE LABEL IDENTIFIER                         PLABID
      PLAB==RECORD(ADICT+OPD<<DSCALE)
      s=ITOS(PLAB_INDEX)
      s="PLAB".s
      ->SOUT
SW(PROCID):  !PROCEDURE IDENTIFIER                             PROCID
SW(STFNID):  !STMT. FUNCTION IDENTIFIER
      PROC==RECORD(ADICT+OPD<<DSCALE)
      S=STRING(ANAMES+PROC_IDEN)
      ->SOUT
!SW(ARREL):  !ARRAY ELEMENT REFERENCE                          ARREL
!      PROC==RECORD(OPD<<DSCALE+ADICT)
!      S=STRING(ANAMES+PROC_IDEN)
!      ->SOUT
SW(VALTEMP):
      TE==RECORD(ADICT+OPD<<DSCALE)
      s=ITOS(TE_INDEX)
      s="vt".s
      ->SOUT
SW(DESTEMP):
      DT==RECORD(ADICT+OPD<<DSCALE)
      s=ITOS(DT_INDEX)
      s="dt".s
      ->SOUT
SW(BREG):
      S=REG1
      ->SOUT
%END
!*
!*                         PRINT TRIAD
!*
%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(%INTEGER AD,LEN)
%INTEGER I
      %CYCLE I=1,1,3
         SPACES(2)
         PRHEX(INTEGER(AD))
         AD=AD+W1
      %REPEAT
%END;! DUMP
!*
%externalroutine Print Tr(%integer Index,Adict,Anames,Level,
                      %record(Triadf)%name Triads)
%INTEGER I,J,VAL
%STRING(32) MODE,OP,NO,SPARE
%STRING(1) P
      NO=""
      SPARE=""
      IRADR=0
      %IF LEVEL<0 %THENSTART
         LEVEL=-LEVEL
         PSTRING(0,NO,LEVEL)
      %FINISH
      NO=ITOS(INDEX)
      PSTRING(1,NO,LEVEL)
      P="t"
      OP=OPVALS(TRIADS_OP&X'7F')
      %IF OP="PAUSE" %OR OP="STOP" %THENSTART
         PSTRING(2," ",LEVEL)
         ->SKIP
      %FINISH
      %IF OP="IOSPEC" %THENSTART
         PRINTSTRING("        IOSPEC                ")
         ->OUT
      %FINISH
      %IF OP="IO" %THENSTART
         PRINTSTRING("        IO                    ")
         ->OUT
      %FINISH
      %IF OP="PA" %THENSTART
         PSTRING(2,"NULL",LEVEL)
         PSTRING(3,OP,LEVEL)
         PSTRING(4,"NULL",LEVEL)
         -> OUT
      %FINISH
      %IF OP="STMT" %THENSTART
         PSTRING(2,ITOS(TRIADS_SLN),LEVEL)
         MODE="NULL"
        %IF TRIADS_VAL2=4 %THENSTART
          PSTRING(3,OP,LEVEL)
          %IF TRIADS_QOPD2=0 %THEN SPARE="start " %ELSE SPARE="end "
          SPARE=SPARE.STRING(TRIADS_OPD2<<DSCALE+ADICT)
          PSTRING(4,SPARE,LEVEL)
          ->SKIP2
        %FINISH
      %FINISHELSESTART
         ANAL(TRIADS_QOPD1,TRIADS_OPD1,2,ADICT,ANAMES,LEVEL)
         MODE=SZTY(TRIADS_MODE&15)
      %FINISH
SKIP: PSTRING(3,OP,LEVEL)
      ANAL(TRIADS_QOPD2,TRIADS_OPD2,4,ADICT,ANAMES,LEVEL)
SKIP2:%IF LEVEL=2 %THEN %START
         PSTRING(5,MODE,LEVEL)
         PSTRING(6,QUAL(TRIADS_QOPD1),LEVEL)
         PSTRING(7,QUAL(TRIADS_QOPD2),LEVEL)
         %IF SPARE#"" %THEN PSTRING(8,SPARE,LEVEL) %AND SPARE=""
      %FINISH
OUT:  DUMP(ADDR(TRIADS_OP),12)
      NEWLINE
%end;! Print Tr
!*
%endoffile