! fgen3
! 26/04/87 - fault char as unit arg to INQUIRE
! fgen2
! 09/04/87 - include contents of gsyn71 instead of ftn_gsynt70
! fgen1
! 16/11/86 - incorporate changes up to ftngen26
! 10/10/86 - insert include files
! ftngen23
! 10/09/86 - change interpretation of Com_Opt
! 09/09/86 - in CHECK PMODE set correct result for IMAG
! 07/09/86 - INTRINFN supporting Gould extensions
! 06/09/86 - call BSStidy after END
! ftngen22
! 19/08/86 - generate scaling for arrays if Gould opt
! ftngen21
! 15/08/86 - int*2 consts treated sensibly in Start Of Do Loop
! 06/08/86 - allow int*2 as IOSTAT var
! 02/08/86 - in phi(81) allow int*2 parameter values
!* ftngen20
! 27/07/86 - in Link Param check for invalid intrin arg form
! 26/07/86 - in phi(51) set 'assigned bit' for fn name in input list
! 22/07/86 - add test to phi(46) to trap DO terminating on END
!* MODIFIED 06/07/86 ftngen19
!*
%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_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'
!*
!*
{%include "ercs01:gsyn71"}
!*
!* Syntax tables generated from file SYNTAX71 on 06/04/87 at 16.09.36
!*
%CONSTBYTEINTEGERARRAY OS(0:1600)= %C
0, 0, 34, 1, 1, 2, 25, 1, 1, 3,
10, 7, 2, 3, 29, 61, 0, 91, 1, 1,
92, 0, 13, 1, 0, 1, 3, 20, 4, 1,
2, 1, 4, 17, 1, 1, 0, 1, 2, 20,
4, 1, 1, 1, 3, 17, 0, 1, 3, 87,
0, 1, 2, 92, 1, 1, 0, 1, 2, 87,
0, 1, 1, 0, 1, 3, 20, 5, 1, 2,
1, 4, 17, 1, 1, 0, 1, 2, 20, 5,
1, 1, 1, 3, 17, 0, 1, 2, 1, 3,
17, 1, 1, 0, 1, 1, 1, 2, 17, 0,
20, 2, 1, 1, 0, 20, 3, 1, 1, 0,
22, 1, 1, 0, 23, 1, 1, 0, 24, 1,
1, 0, 88, 1, 1, 89, 0, 0, 88, 1,
1, 89, 1, 0, 12, 4, 1, 3, 20, 4,
1, 2, 16, 4, 1, 1, 0, 12, 3, 1,
2, 20, 4, 1, 1, 16, 3, 0, 12, 4,
1, 3, 20, 5, 1, 2, 16, 4, 1, 1,
0, 12, 3, 1, 2, 20, 5, 1, 1, 16,
3, 0, 12, 3, 1, 2, 16, 3, 1, 1,
0, 12, 2, 1, 1, 16, 2, 0, 12, 3,
1, 2, 16, 3, 20, 4, 1, 1, 0, 12,
3, 1, 2, 87, 3, 1, 1, 0, 12, 3,
1, 2, 16, 3, 20, 5, 1, 1, 0, 12,
2, 1, 1, 16, 2, 0, 1, 2, 1, 1,
66, 0, 1, 1, 0, 13, 1, 0, 26, 1,
1, 27, 0, 1, 2, 13, 3, 75, 0, 62,
0, 1, 1, 62, 0, 1, 2, 1, 3, 49,
4, 75, 0, 1, 1, 49, 2, 0, 48, 0,
35, 3, 1, 2, 36, 0, 13, 1, 0, 1,
2, 13, 3, 75, 0, 1, 2, 1, 3, 49,
4, 75, 0, 1, 1, 49, 2, 0, 60, 1,
0, 60, 2, 0, 13, 1, 0, 20, 0, 0,
20, 6, 0, 21, 0, 0, 21, 6, 0, 21,
0, 0, 20, 0, 0, 74, 0, 1, 1, 74,
0, 1, 2, 74, 0, 1, 2, 1, 1, 74,
0, 1, 1, 13, 1, 0, 1, 1, 0, 1,
1, 13, 1, 0, 13, 1, 0, 1, 4, 1,
3, 1, 2, 1, 5, 79, 1, 1, 0, 1,
3, 1, 2, 1, 1, 1, 4, 79, 0, 1,
2, 1, 3, 79, 1, 1, 0, 1, 1, 1,
2, 79, 0, 1, 2, 1, 1, 0, 1, 2,
1, 1, 0, 80, 5, 1, 4, 1, 3, 1,
2, 77, 5, 1, 1, 0, 80, 4, 1, 3,
1, 2, 1, 1, 77, 4, 0, 80, 3, 1,
2, 77, 3, 1, 1, 0, 80, 2, 1, 1,
77, 2, 0, 80, 4, 1, 3, 77, 4, 1,
2, 1, 1, 0, 80, 2, 1, 1, 77, 2,
0, 1, 2, 1, 1, 20, 7, 78, 2, 0,
1, 1, 0, 13, 1, 0, 26, 1, 1, 27,
0, 13, 1, 0, 20, 1, 0, 20, 5, 0,
20, 4, 0, 20, 2, 0, 20, 3, 0, 20,
16, 0, 20, 18, 0, 20, 17, 0, 20, 19,
0, 20, 20, 0, 1, 1, 0, 1, 1, 0,
1, 1, 34, 3, 1, 4, 25, 3, 73, 2,
0, 34, 2, 0, 1, 1, 34, 3, 1, 4,
25, 3, 38, 2, 0, 34, 2, 1, 3, 25,
2, 38, 1, 0, 1, 1, 0, 13, 1, 0,
90, 1, 3, 1, 1, 72, 3, 0, 90, 1,
2, 72, 2, 0, 34, 3, 1, 4, 25, 3,
93, 7, 4, 2, 1, 1, 0, 34, 2, 1,
3, 25, 2, 93, 7, 3, 1, 0, 10, 7,
2, 1, 29, 0, 50, 1, 1, 2, 52, 2,
2, 57, 1, 1, 53, 0, 50, 1, 1, 1,
52, 2, 1, 53, 0, 50, 4, 1, 1, 53,
0, 50, 4, 1, 1, 52, 1, 1, 53, 0,
35, 2, 41, 29, 0, 35, 3, 1, 2, 41,
33, 29, 0, 35, 2, 41, 29, 0, 29, 0,
50, 7, 1, 1, 53, 0, 94, 1, 1, 2,
95, 0, 50, 5, 1, 1, 53, 0, 50, 5,
1, 1, 52, 1, 1, 53, 0, 84, 3, 0,
96, 0, 46, 0, 84, 1, 86, 1, 1, 2,
85, 1, 0, 84, 2, 0, 1, 2, 1, 1,
30, 0, 31, 0, 50, 8, 1, 1, 53, 0,
50, 6, 1, 1, 53, 0, 50, 2, 1, 2,
52, 2, 2, 57, 1, 1, 53, 0, 50, 2,
1, 1, 52, 2, 1, 53, 0, 70, 0, 69,
0, 50, 1, 1, 2, 57, 1, 1, 53, 0,
50, 1, 1, 2, 52, 2, 2, 57, 1, 1,
53, 0, 50, 1, 1, 1, 52, 2, 1, 53,
0, 47, 0, 1, 1, 44, 0, 50, 3, 1,
1, 53, 0, 50, 3, 1, 1, 52, 1, 1,
53, 0, 45, 0, 68, 0, 50, 2, 1, 2,
52, 2, 2, 57, 1, 1, 53, 0, 50, 2,
1, 1, 52, 2, 1, 53, 0, 50, 2, 1,
2, 57, 1, 1, 53, 0, 82, 3, 1, 1,
0, 82, 2, 1, 1, 0, 1, 2, 81, 1,
0, 1, 1, 0, 13, 1, 0, 1, 2, 1,
1, 0, 1, 1, 0, 1, 2, 52, 1, 2,
1, 1, 0, 1, 3, 52, 1, 3, 1, 2,
52, 2, 2, 1, 1, 0, 1, 2, 52, 1,
2, 1, 1, 52, 2, 1, 0, 1, 1, 52,
1, 1, 0, 1, 2, 1, 1, 0, 1, 1,
0, 11, 0, 0, 1, 1, 0, 11, 0, 0,
1, 1, 0, 1, 1, 52, 1, 1, 0, 1,
1, 52, 2, 1, 0, 1, 1, 52, 3, 1,
0, 52, 4, 1, 0, 52, 5, 1, 0, 1,
1, 52, 6, 1, 0, 1, 2, 1, 1, 0,
1, 1, 0, 1, 1, 0, 1, 2, 52, 1,
2, 1, 1, 0, 1, 1, 52, 1, 1, 0,
1, 2, 1, 1, 0, 1, 1, 0, 1, 3,
1, 2, 54, 2, 1, 1, 0, 1, 2, 1,
1, 54, 1, 0, 11, 24, 0, 11, 8, 0,
11, 9, 0, 11, 21, 0, 11, 10, 0, 11,
11, 0, 11, 12, 0, 11, 13, 0, 11, 14,
0, 11, 15, 0, 11, 16, 0, 11, 17, 0,
11, 18, 0, 11, 19, 0, 11, 20, 0, 11,
22, 0, 11, 23, 0, 11, 24, 0, 11, 7,
0, 1, 4, 1, 3, 1, 2, 55, 0, 1,
6, 55, 1, 1, 1, 0, 1, 4, 1, 3,
55, 0, 1, 6, 55, 1, 1, 1, 0, 1,
2, 1, 1, 0, 51, 2, 1, 1, 0, 34,
2, 1, 3, 25, 2, 56, 3, 1, 1, 0,
1, 1, 0, 1, 5, 20, 10, 17, 15, 0,
34, 6, 1, 7, 18, 1, 5, 20, 10, 17,
15, 19, 0, 84, 0, 34, 1, 1, 2, 85,
0, 0, 34, 2, 1, 3, 18, 1, 1, 19,
29, 0, 34, 2, 1, 3, 18, 1, 1, 19,
29, 0, 1, 3, 1, 2, 1, 1, 28, 0,
1, 3, 1, 2, 28, 0, 1, 1, 0, 0(412);
!*
!********************************* exports ****************************
!*
%integerfnspec Generate(%record(Triadf)%arrayname Triads,
%integerarrayname Output,
%integername Nexttriad,
%integer Kgen,Path,Labrecad,Acom)
!*
!********************************* imports ****************************
!*
%externalroutinespec Print Tr(%integer Index,Adict,Anames,Level,
%record(Triadf)%name Triad)
%externalintegerfnspec Coerce Const(%integer A,Oldmode,Newmode,Adict,
%integername Dptr)
%externalroutinespec Const Eval(%integer Resl,Op,Resr,
%record(Resf)%name Res,%integer Ptr,
%integername Dptr)
%externalintegerfnspec Gconval(%integer Il,Op,Ir,%integername Val)
%externalroutinespec New Temp(%record(Resf)%name R,%integer M,Use)
%externalroutinespec Codegen(%integer Cgenep,
%record(Triadf)%arrayname Triads,
%integer Comad)
%externalroutinespec Freelistcell(%integername Listhead,%integer N)
%externalroutinespec BSStidy
%externalroutinespec Dicful
%externalintegerfnspec Genful
%externalroutinespec F77abort(%integer N)
%externalroutinespec Lfault(%integer Er)
%externalroutinespec Tfault(%integer Er,Ta,Tb)
%externalroutinespec Fault(%integer Er)
%externalroutinespec Ifault(%integer E,I)
%externalintegerfnspec Newlistcell(%integername Listhead,%integer N)
%externalintegerfnspec Freesp(%integer N)
%externalintegerfnspec Setlab(%integer Lab,%integername Labrecptr)
%externalintegerfnspec Setconrec(%record(Resf) R)
%externalintegerfnspec Conin(%integer Val)
%externalintegerfnspec Dictspace(%integer Length)
%externalroutinespec Cklab
%externalroutinespec Optctl(%integer Acom,Nexttr,Bits,Assgotos)
%externalroutinespec Optsource(%integer A,B,C,D,E,F)
%externalintegerfnspec Op4 Save
%externalintegerfnspec Op4 Ref(%string(63) S)
%externalroutinespec Op4 ArgRef(%string(63) S)
!*
!**********************************************************************
!*
%owninteger Comad
%owninteger Pathreport ;! 0
! 1 FORCE UPDATE TO TABLE WHETHER OR NOT LABELLED
!*
%owninteger Stfnstart
%owninteger Loglist
%ownrecord(Resf) Res
%ownrecord(Resf) Rnull
%owninteger Dotest
%owninteger Notflag
%owninteger Relop
%owninteger Cexmode;! 'const' expression mode -
%owninteger Tmlist
%owninteger dexpstart
%owninteger dexpnum
!*
%constinteger RNULLW=0
!*
%CONSTSTRING(12)%array IOSPECS(1:25)= %C
"UNIT=", "FMT=", "REC=", "END=", "ERR=","IOSTAT=","FILE=","STATUS=",
"ACCESS=","FORM=","RECL=","BLANK=","EXIST=","OPENED=","NUMBER=",
"NAMED=","NAME=","NREC=","SEQUENTIAL=","DIRECT=","FORMATTED=",
"UNFORMATTED=","NEXTREC=","DESC=",""
!*
%CONSTSTRING(9)%array IOTYPES(1:8)= %C
"READ", "WRITE", "REWIND", "BACKSPACE",
"ENDFILE", "OPEN", "CLOSE", "INQUIRE"
!*
%CONSTINTEGERARRAY IOMASKS(1:8)= %C
X'7E',X'6E',X'62'(3),X'1041FE2',X'1E2',X'FFFEE2'
!*
%CONSTBYTEINTEGERARRAY OPENPP(0:25)= %C
0(7),X'42',X'43',X'44',X'45',0,X'46',0(5),1,0(5),X'47',0
!*
%CONSTBYTEINTEGERARRAY CLOSEPP(0:25)=0(8),X'40',0(17)
!*
%CONSTBYTEINTEGERARRAY INQUIREPP(0:25)= %C
0(7),X'40',0,X'66',X'69',X'2C',X'4E',X'A1',X'A2',X'23',X'A4',
X'45',X'30',X'47',X'48',X'4A',X'4B',X'2D',X'4F',0
!*
%recordformat dexpfmt(%integer res,opl,op,opr)
!*
!*
!***********************************************************************
!*
!*
%EXTERNALINTEGERFN GET PLAB
!***********************************************************************
!* Provide a new dict record for a private label *
!***********************************************************************
%RECORD(COMFMT)%NAME COM
%RECORD(PLABF)%NAME PLAB
%RECORD(RESF) R
%INTEGER I
COM==RECORD(COMAD)
I=COM_DPTR
COM_DPTR=COM_DPTR+PLABRECSIZE
DICFUL %IF COM_DPTR>COM_DICLEN
PLAB==RECORD(COM_ADICT+I)
PLAB_BLKIND=0
PLAB_USE=0
PLAB_X1=17;! referenced in explicit GOTO
PLAB_INDEX=COM_NEXT PLAB
PLAB_CODEAD=0
PLAB_REF=0
PLAB_REFCHAIN=0
COM_NEXT PLAB=COM_NEXT PLAB+1
R_H0=I>>DSCALE
R_FORM=PLABID
R_MODE=0
%RESULT=R_W
%END;! GET PLAB
!*
%EXTERNALINTEGERFN NEW TRIADR(%INTEGER OP,RES1W,RES2W)
%INTEGER CUR,I
%RECORD(TRIADF)%NAME TR
%record(Comfmt)%name Com
Com==record(Comad)
CUR = COM_NEXT TRIAD
COM_NEXT TRIAD = CUR + 1
TR==RECORD(COM_ATRIADS+CUR*Triadlength)
TR_OP=OP
TR_USE=0
TR_RES1_W=RES1W
TR_RES2_W=RES2W
TR_CHAIN=COM_NEXT TRIAD
%RESULT = CUR
%END;! NEW TRIADR
!*
%EXTERNALINTEGERFN NEW TRIAD2(%INTEGER OP,SLN,QOPD2,OPD2,VAL2)
%INTEGER CUR
%RECORD(TRIADF) %NAME TR
%record(Comfmt)%name Com
Com==record(Comad)
CUR = COM_NEXT TRIAD
COM_NEXT TRIAD = CUR + 1
TR==RECORD(COM_ATRIADS+CUR*Triadlength)
TR_OP=OP
TR_VAL2=VAL2
TR_SLN=SLN
TR_QOPD2=QOPD2
TR_OPD2=OPD2
TR_MODE2=0
TR_CHAIN=COM_NEXT TRIAD
%RESULT = CUR
%END;! NEW TRIAD2
!*
!*
%externalintegerfn Generate(%record(Triadf)%arrayname Triads,
%integerarrayname Output,
%integername Nexttriad,
%integer Kgen,Path,Labrecad,Acom)
!*
%routinespec ARITHOP(%record(RESF) Resl,%integer OP,%record(RESF) Resr)
%routinespec CONDC(%integer LLIST)
%routinespec LOGTOACC(%integer NOT)
%routinespec ANDOR(%integer P1)
%routinespec SETCA(%record(RESF) R)
%integerfnspec SIMPLE INT(%integer R)
%routinespec CHECK BACK LAB
%routinespec START OF DO LOOP(%integer MODE)
%routinespec END DO SUB(%integer DOREC,P)
%routinespec END OF DO LOOP(%integer Mode)
%routinespec LINK PARAM(%integer FPTR,R)
%routinespec INTRINFN(%integer FNPTR,PCT,PLINK)
%routinespec MOD LHS OP(%record(RESF) RES,%integer MODE)
%integerfnspec New Plab
%integerfnspec INSERT STFN
%integerfnspec Convert(%integer Resw,Newmode)
%externalroutinespec Alloc Nmlist(%integer R)
!{PA} %routinespec PATHCOUNT(%integer LINE,INDEX)
!{ITS} %routinespec ITSACT(%integer ENTRY)
!*
%CONSTBYTEINTEGERARRAY COMPOPS(0:12) = %C
0,0,GT,0,LT,0,NE,0,EQ,0,GE,0,LE
!*
%integer ADICT,ATRIADS,IGEN,I,J,K,L,ADJ,PTR,SPTR,PCT,CONCATLIST
%integer SAVELINK, II, KK, LL, SAVEINDEX
%integer BC,OP,DOLAB,P,P1,P2,CHResl,CHResr,Opmode,Condmask
%integer IOFORM,IOMODE,IOINDEX,IOCONTROLS,IOMASK,IOTYPE
%integer IOFLAGS
%integer CUR STATFN
%integer STAT TRIAD;! first triad for current statement
%integer STAT TYPE;! set non-zero for statements requiring special treatment
%integer FALSE JUMP;! triad index of last triad in logical if condition
%integer SAVECONCATS;! push CONCATLIST in PHI91 and pop in PHI92
%record(RESF) TRUE LAB;! res plabel record for true addresses in logical if
%record(RESF) LOGPTR
%record(Resf) R
%record(ARRAYDVF)%name DVREC
%record(PRECF)%name PP
%record(SRECF)%name SS
%record(LRECF)%name LLL
%record(DORECF)%name DOREC
%record(PRECF)%name ARRAYREC
%record(PRECF)%name STATFN
%record(IFRECF)%name IFREC
%record(LABRECF)%name LABREC
%record(FNRECF)%name FNREC
%record(CONSTRECF)%name CON
%record(PLABF)%name PLAB
%record(RESF) Resl,Resr,CHRES
%record(COMFMT)%name COM
%record(TRIADF)%name TR
%record(OBJFMT)%name OBJ
%integer IODOINIT,IODEPTH,IOCURDIMS,IOSTARTED
%ownrecord(RESF)%array SUBSCRIPT(0:7)
%recordformat GSAVEFMT(%shortinteger II,KK,LL,SL)
%record (GSAVEFMT) %name GSAVE
%record(dexpfmt)%name dexprec
%switch PHI(0 : 100)
%switch SW52(1:12)
!*
{%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
!*
%routine Fill(%integer Length,Fbase,Fdisp,Filler)
!***********************************************************************
!* fill Length bytes from fbase(fdisp) with Filler *
!***********************************************************************
%integer I,From
%if Length<=0 %then %return
From=Fbase+Fdisp
%cycle I=0,1,Length-1
byteinteger(From+I)=Filler
%repeat
%end;! Fill
!*
!*
!*
!***********************************************************************
!* Routines to generate triads *
!***********************************************************************
!*
%routine TRIAD ERROR
F77abort(1)
%end;! TRIAD ERROR
!*
%integerfn ADDR TRIAD(%integer INDEX)
%if INDEX>COM_MAXTRIADS %then TRIAD ERROR
%result=ADDR(TRIADS(INDEX))
%end;! ADDR TRIAD
!*
%routine PRINT CHTRIADS
%record(TRIADF)%name TR
%integer CH
CH=1
%cycle
TR==record(ATRIADS+CH*TRIADLENGTH)
PRINT TR(CH,COM_ADICT,COM_ANAMES,0,TR)
CH=TR_CHAIN
%repeat %until CH=0
%end;! PRINT CHTRIADS
!*
%routine Call Tfault(%integer Er,%string(31) S,%integer Tb)
Tfault(Er,addr(S),Tb)
%end;! Call Tfault
!*
%integerfn NEW TRIAD(%integer OP,RES1W,%integer QOPD2,OPD2)
%integer CUR
%record(TRIADF) %name TR
CUR = NEXT TRIAD
NEXT TRIAD = CUR + 1
{%include "pf_gen1"}
!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
!+ possible architecture-dependant optimisation
!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
{end "pf_gen1"}
TR==record(ADDR TRIAD(CUR))
TR_OP=OP
TR_USE=0
TR_RES1_W=RES1W
TR_QOPD2=QOPD2
TR_OPD2=OPD2
TR_MODE2=0
TR_CHAIN=NEXT TRIAD
%result = CUR
%end;! NEW TRIAD
!*
%integerfn Triad Res(%integer MODE,OP,RES1W,RES2W)
%record(Resf) R
R_H0=NEW TRIADR(OP,RES1W,RES2W)
R_MODE=MODE
R_FORM=TRIAD
%result=R_W
%end;! Triad Res
!*
%integerfn Form Res(%integer H0,FORM,MODE)
%record(Resf) R
R_H0=H0
R_FORM=FORM
R_MODE=MODE
%result=R_W
%end;! Form Res
!*
!*
%integerfn CONOUT(%record(RESF) R)
%record(CONSTRECF)%name CON
%if R_FORM=LIT %then %result=R_H0
%if R_FORM=NEGLIT %then %result=-R_H0
CON==record(COM_ADICT+R_H0<<DSCALE)
%result=integer(COM_ADICT+CON_DADDR)
%end;! CONOUT
!*
%integerfn Boundval(%integer Bound)
%record(Resf) R
R_W=Bound
%if R_Form=0 %thenstart
%result=R_H0
%finishelsestart
%result=integer(Com_Adict+R_H0<<DSCALE)
%finish
%end;! Boundval
!*
%routine Check Do Index(%integer Rd,Dohead)
%record(Dorecf) %name Dorec
%while Dohead#0 %cycle
Dorec==record(Com_Adict+Dohead)
%if Dorec_Indexrd_W=Rd %thenstart;! NESTED USE OF DO VAR
Lfault(147)
%return
%finish
Dohead=Dorec_Link1
%repeat
%end;! Check Do Index
!*
COMAD=ACOM;! for any other routines to map
COM==record(ACOM)
ADICT=COM_ADICT
ATRIADS=ADDR(TRIADS(0))
STAT TRIAD=NEXT TRIAD;! first triad for this statement
STAT TYPE=0
CONCATLIST=0
SAVECONCATS=0
SAVEINDEX=0
Cexmode=0
!*
%if Path=-2 %thenstart;! subprog entry
I = New Triad2(STMT,Com_Linest,NULL,NULL,2)
PP==record(Adict+Labrecad);! actually the subprog record
Resl_W=New Plab
PP_Disp=Resl_H0
Plab_X1=9;! explicitly referenced, entry statement
I = New Triad2(STMT,Labrecad,PLABID,Resl_H0,0)
%result=0
%finish
!*
%if Path=-3 %thenstart;! start of statement fn
Stfnstart=Next Triad
%result=0
%finish
!*
%if Labrecad # NULL %thenstart
Labrec==record(Adict+Labrecad)
Dolab=Labrec_X0&4
%finishelse Dolab=0
%if Path = 3 %then Dotest=1 %and -> Checkdo;! avoid any spurious errors when checking DO labels
%unless Path=-1 %thenstart;! except for const eval
%if Com_Nextch # 10 %or Path = 0 %thenstart
%if Com_Maxinp>Com_Inp %then Com_Inp=Com_Maxinp
Fault(100); ! syntax error
Dotest=1;! to avoid spurious error report
-> Check Do
%finish
%finish
NOTFLAG = 0
DOTEST = 0
PCT = 0
COM_FNLST=0
%if KGEN<0 %thenstart
KGEN=-KGEN
IGEN=OUTPUT(KGEN)
%finishelse IGEN=KGEN
!*
!******** statement triad
!*
%if LABRECAD # NULL %thenstart
I=LABID
J=1
%finishelsestart
-> CHECK DO %if OS(IGEN)=0
I=NULL
J=2
%finish
%UNLESS PATH=-1 %thenstart
I = NEW TRIAD2(STMT,COM_LINEST,I,LABRECAD>>DSCALE,J)
%finish
-> CHECK DO %if OS(IGEN) = 0; ! NO CODE TO PLANT
!*
!******** PATH ANALYSIS
!*
!{PA} %if COM_PATHANAL#0 %and PATH>0 %thenstart
!{PA} %if COM_LAB#0 %or PATHREPORT#0 %then PATHCOUNT(COM_LINEST,0)
!{PA} PATHREPORT=0
!{PA} %finish
!*
!*
BC=0
LL=0
SAVELINK=0
II=0
KK=0
LL=0
->START
PHI(1):
PHI1: II = IGEN+1
KK = KGEN
!RHO-SYMBOL
LL = KGEN+OS(IGEN)
PHI1A:IGEN = OUTPUT(LL)
%if IGEN<=0 %thenstart
KGEN = -IGEN
IGEN = OUTPUT(KGEN)
%finish
SAVELINK=1
START:
{%include "pf_gen3"}
I=SAVEINDEX
SAVEINDEX=SAVEINDEX+W4
%IF SAVEINDEX>=COM_MAXGEN %THENSTART
%IF GENFUL#0 %THENSTART
LFAULT(307)
%result=0
%FINISH
%FINISH
GSAVE==RECORD(COM_SAVEGEN+I)
GSAVE_II=II
GSAVE_KK=KK
GSAVE_LL=LL
GSAVE_SL=SAVELINK
{end "pf_gen3"}
L1: P = OS(IGEN)
IGEN = IGEN+1
%if COM_PTRACE#0 %thenstart
PRINTSTRING(" PHI")
WRITE(P,2)
SPACE
%finish
-> PHI(P)
PHI(0):
{%include "pf_gen4"}
SAVEINDEX=SAVEINDEX-W4
GSAVE==RECORD(COM_SAVEGEN+SAVEINDEX)
II=GSAVE_II
KK=GSAVE_KK
LL=GSAVE_LL
SAVELINK=GSAVE_SL
{end "pf_gen4"}
%if SAVELINK=0 %thenstart
CHECK DO:%if DOLAB = 4 %then END OF DO LOOP(0)
%result=0
%finish
OUTPUT(LL)=Res_W
IGEN=II
KGEN=KK
->L1
!*
PHI(2):->L1;! DUMMY
!*
PHI(3):IGEN=OS(IGEN)<<8!OS(IGEN+1)
->L1;! for patching
!*
PHI(10):
!***********************************************************************
!* ARITHOP WITH OP,Resl AND Resr FROM TREE *
!***********************************************************************
!SETP3
OP = OS(IGEN)
Resl_W = OUTPUT(KGEN+OS(IGEN+1))
Resr_W = OUTPUT(KGEN+OS(IGEN+2))
IGEN=IGEN+3
L100:
%if Resl_FORM=LABID %thenstart;! assigned label
SS==record(ADICT+NEWLISTCELL(COM_ASSGOTOS,2))
SS_INF0=Resl_H0<<DSCALE
I=NEW TRIADR(ASGN,Resr_W,Resl_W)
->L1
%finish
%if HOLMODE>=Resl_MODE>=CHARMODE %C
%or HOLMODE>=Resr_MODE>=CHARMODE %thenstart
%UNLESS Resl_MODE=CHARMODE %and Resr_MODE=CHARMODE %C
%and (OP=1 %or OP=7) %thenstart
LFAULT(132)
%result=0
%finish
Res_W=Triad Res(CHARMODE,OP,Resr_W,Resl_W)
%if COM_OPT&1#0 %then MOD LHS OP(Resr,0)
%finishelse ARITHOP(Resl,OP,Resr)
-> L1
!*
PHI(11):
!***********************************************************************
!* RES = constant integer *
!***********************************************************************
Res_W=OS(IGEN)
IGEN=IGEN+1
->L1
!*
PHI(12):
!***********************************************************************
!* SAVE CURRENT OPERAND DESCRIPTOR AND OPERATOR IN GENERATE TREE *
!***********************************************************************
!SETP1
PTR=FREESP(2)
SS==record(PTR+ADICT)
SS_INF0=OP
SS_LINK1=Res_W
OUTPUT(KGEN+OS(IGEN))=PTR
IGEN=IGEN+1
-> L1
!*
PHI(13):
!***********************************************************************
!* SET RESULT DESCRIPTOR FROM TREE ENTRY P1 *
!***********************************************************************
P1=OS(IGEN)
IGEN=IGEN+1
Res_W = OUTPUT(KGEN+P1)
CHRES=RES;! in case needed for substring checking
COM_RESCOM1=Res_W;! for ANALYSE to reference const expression
-> L1
!*
PHI(15):
!***********************************************************************
!* PLANT CODE FOR ARITHMETIC IF *
!***********************************************************************
%BEGIN
%CONSTBYTEINTEGERARRAY ARITHIFMASK(0:7)= %C
0, JIP, JIZ, JINN, JIN, JINZ, JINP, 0 ;! USED BY PHI(15) TO OPTIMISE ARITH IF BRANCHES
%CONSTINTEGERARRAY NEXT(0:2)=1,2,0
%ownintegerarray LDESC(0:2)
%ownintegerarray FL(0:2)
%integer DEFAULT,LAST
DEFAULT=0
LAST=0
%cycle I = 0,1,2
Resl_W=OUTPUT(KGEN+I+1)
%if Resl_W=0 %then DEFAULT=1;! some label refers to next stat
LDESC(I) = Resl_H0
FL(I) = 1<<I
%repeat
%cycle I = 0,1,2
J=NEXT(I)
%if LDESC(I) = LDESC(J) %thenstart
FL(J)=FL(J)!FL(I)
LDESC(I) = 0
FL(I)=0
%finishelsestart
%if I>LAST %then LAST=I;! identifies the last jump
%finish
%repeat
%cycle I = 0,1,2
J=LDESC(I)
%UNLESS J = 0 %thenstart
LABREC==record(ADICT+J<<DSCALE)
K=ARITHIFMASK(FL(I))
%if K=0 %or (DEFAULT=0 %and LAST=I) %thenstart;! ALL REMAINING LABELS THE SAME
Res_W=Form Res(J,LABID,0)
K=NEW TRIADR(GOTO,Res_W,RNULLW)
%finishelsestart
K=NEW TRIAD(K,Res_W,LABID,J)
%if LAST=I %thenstart;! set marker
TR==record(ADDR TRIAD(K))
TR_USE=1;! to indicate to OPT1 that this is the last triad of a block
%finish
{2900} Res_FORM=NULL;! to avoid reloading acc
%finish
%if LABREC_LINE # 0 %thenstart;! BACKWARD JUMP
CHECK BACK LAB
%finishelsestart;! FORWARD REFERENCE
PTR=NEW LIST CELL(LABREC_LINK2,3)
SS==record(ADICT+PTR)
SS_INF0=K;! triad index
SS_INF2=COM_LINEST
%finish
%finish
%repeat
%end
-> LABW
!*
PHI(16):
!***********************************************************************
!* ARITHOP WITH Resl AND OP FROM TREE, Resr=CURRENT OPERAND *
!***********************************************************************
P1=OS(IGEN)
I = OUTPUT(KGEN+P1)
IGEN=IGEN+1
SS==record(ADICT+I)
OP=SS_INF0
Resl_W=SS_LINK1
Resr_W = Res_W
%if OP=1 %then ->L872;! to process concatenation
FREE LIST CELL(I,2)
-> L100
!*
PHI(17):
!***********************************************************************
!* IF UNARY - AT START OF EXPRESSION CALL ARITHOP *
!***********************************************************************
%if OP=0 %or OP=10 %then ->L1;! + or none
Resl_W = Res_W
Resr_W = Res_W
-> L100
!*
PHI(18):
!***********************************************************************
!* BEFORE PROCESSING STATEMENT AFTER LOGICAL IF *
!* SETS 'TRUE' ADDRESS BEFORE STATEMENT *
!* SAVE record WITH 'FALSE' ADDRESS IN LOGPTR *
!***********************************************************************
NOTFLAG=NOTFLAG!!1
CONDC(1);! PLANT JUMP IF FALSE
FALSE JUMP=NEXT TRIAD-2
STAT TYPE=1;! note logical if (for special case GOTO action)
TRUE LAB=LLL_ORLAB
SETCA(TRUE LAB);! FILL .TRUE. ADDRESSES
LOGPTR=LLL_ANDLAB
FREE LIST CELL(LOGLIST,5)
LLL==record(ADICT+LOGLIST)
RELOP=0
!{PA} %if COM_PATHANAL#0 %then PATHCOUNT(COM_LINEST,1);! record SYMBOL 1
!{ITS} %if COM_ITSMODE=2 %then COM_STATEMENT=0 %and ITSACT(2)
->L1
!*
PHI(19):
!***********************************************************************
!* FOLLOWING STATEMENT AFTER LOGICAL IF *
!* SETS 'FALSE' ADDRESS USING record SAVED IN LOGPTR *
!***********************************************************************
SETCA(LOGPTR)
COM_LABWARN=0
!!Z FREE REGS
!{PA} PATHREPORT=1
->L1
!*
PHI(21):
!***********************************************************************
!* AFTER .NOT. *
!* SETS NOTFLAG *
!* TIDIES UP AND/OR LISTS TO CORRECT BRACKET COUNT LEVEL *
!***********************************************************************
NOTFLAG=NOTFLAG!!1
!*
PHI(20):
!***********************************************************************
!* NOTE CURRENT OPERATOR CODE *
!***********************************************************************
!SETP1
OP = OS(IGEN)
IGEN=IGEN+1
-> L1
!*
PHI(22):
!***********************************************************************
!* AFTER COMPARATOR (.EQ.,.NE.,.GT.,.GE.,.LT.,.LE.) *
!* SAVE CURRENT OPERAND DESCRIPTOR AND COMPARATOR CODE *
!***********************************************************************
PTR=FREESP(2)
SS==record(ADICT+PTR)
SS_INF0=OUTPUT(KGEN+2);! COMPARATOR CODE
SS_LINK1=Res_W
RELOP=PTR
-> L1
!*
PHI(23):
!***********************************************************************
!* AFTER .OR. *
!***********************************************************************
ANDOR(0)
-> L1
!*
PHI(24):
!***********************************************************************
!* AFTER .AND. *
!***********************************************************************
ANDOR(1)
-> L1
!*
PHI(25):
!***********************************************************************
!* COMPILES CODE AT END OF LOGICAL ASSIGNMENT OR LOGICAL *
!* EXPRESSION AS PARAM *
!***********************************************************************
P1=OS(IGEN)
IGEN=IGEN+1
I=OUTPUT(KGEN+P1)
-> L1 %if I = 0
BC=I>>16
%if RELOP#0 %or LLL_ANDLAB_W#0 %or LLL_ORLAB_W#0 %thenstart
%if LLL_Andlab_W=0 %and LLL_Orlab_W=0 %thenstart
SS==record(ADICT+RELOP)
CONDMASK=SS_INF0
Resl_W=SS_LINK1
OPMODE=Resl_MODE
%if OPMODE<Res_MODE %then OPMODE=Res_MODE
R_W=NULL
R_MODE=OPMODE
%if Resl_MODE#OPMODE %thenstart
%if OPMODE=CHARMODE %then LFAULT(132)
Resl_W=Triad Res(OPMODE,CVT,R_W,Resl_W)
%finish
%if Res_MODE#OPMODE %thenstart
%if OPMODE=CHARMODE %then LFAULT(132)
Res_W=Triad Res(OPMODE,CVT,R_W,Res_W)
%finish
Res_W=Triad Res(LOG4{Res_Mode},Compops(Condmask),Resl_W,Res_W);! keeping Res_MODE=char/non-char as indicator
%finishelsestart
LOGTOACC(0)
%finish
->L252
%finishelsestart
%if NOTFLAG#0 %thenstart
Res_H0=NEW TRIADR(NOT,Res_W,RNULLW)
Res_FORM=TRIAD
L252: OUTPUT(KGEN+P1+1)=Res_W
%finish
%finish
NOTFLAG=LLL_NOTFLAG
RELOP=LLL_RELOP
FREE LIST CELL(LOGLIST,5)
LLL==record(ADICT+LOGLIST)
->L1
!*
PHI(26):
!***********************************************************************
!* ACTION AT '(' FOR LOGICAL EXPRESSIONS *
!* PUSHES DOWN AND/OR LISTS *
!* STORES BRACKET COUNT AND UPDATE IT *
!***********************************************************************
-> L1 %if BC = 0
L260: BC = BC+1;! COMMON CODE FOR PI(34)
PTR=NEW LIST CELL(LOGLIST,5)
LLL==record(ADICT+LOGLIST)
LLL_ORLAB_W=0
LLL_ANDLAB_W=0
LLL_NOTFLAG=NOTFLAG
NOTFLAG=0
LLL_RELOP=RELOP
RELOP=0
->L1
!*
PHI(27):
!***********************************************************************
!* ACTION AT ')' IN LOGICAL EXPRESSIONS *
!* RESET BRACKET COUNT *
!* POPUP AND/OR LISTS IF NEITHER USED AND BC>1 *
!***********************************************************************
%if Res_FORM=TRIAD %thenstart
I=TRIADS(Res_H0)_OP
%UNLESS I=NEG %or I=MULT %or I=DIV %thenstart
Res_W=Triad Res(Res_MODE,BRK,Res_W,RNULLW)
%finish
%finish
-> L1 %if BC = 0
BC = BC-1
%if LLL_ORLAB_W=0 %and LLL_ANDLAB_W=0 %thenstart
NOTFLAG=LLL_NOTFLAG!!NOTFLAG
%finishelsestart
LOGTOACC(LLL_NOTFLAG)
NOTFLAG=0
%finish
%if RELOP=0 %then RELOP=LLL_RELOP
FREE LIST CELL(LOGLIST,5)
LLL==record(ADICT+LOGLIST)
->L1
!*
PHI(28):
!***********************************************************************
!* PLANT CODE FOR DO STATEMENT *
!* FORM DO-LIST ENTRY *
!***********************************************************************
I=5
L281: PTR=NEW LIST CELL(COM_DOPTR,10)
DOREC==record(ADICT+PTR)
DOREC_LABLIST=0
DOREC_LINE=COM_LINEST
Resl_W = OUTPUT(KGEN+I)
%if Resl_W&X'7FFF'=0 %thenstart;! no label specified
Dorec_Label=Resl_W;! includes nesting level
%finishelsestart
LABREC==record(ADICT+(Resl_W&X'7FFF')<<DSCALE);! LABEL record
LABREC_X0=LABREC_X0!4;! MARK AS REFERENCED BY DO
I=Resl_H0
DOREC_LABEL=(Resl_W&X'FF000000')!LABREC_LAB;! DEPTH<<24!LABEL
%finish
%if P=94 %thenstart;! DO WHILE
Dorec_Indexrd_W=0
Dorec_Loopad_W=New Plab
I=New Triad2(STMT,0,PLABID,Dorec_Loopad_H0,0)
->L340;! to prepare for logical expression
%finishelsestart
DOREC_INDEXRD_W = OUTPUT(KGEN+4);! INDEX R.D.
CHECK DO INDEX(DOREC_INDEXRD_W,DOREC_LINK1)
DOREC_INCRD_W = OUTPUT(KGEN+1)
DOREC_FINALRD_W = OUTPUT(KGEN+2)
Resl_W = OUTPUT(KGEN+3);! INITIAL VALUE R.D.
START OF DO LOOP(0)
!{PA} PATHREPORT=1;! TO ENSURE FIRST STAT IN DO LOOP IS REPORTED
-> L1
%finish
!*
PHI(29):
!***********************************************************************
!* SET MARKER FOR STATEMENTS PERMITTED TO TERMINATE DO LOOP *
!***********************************************************************
DOTEST = 1
-> L1
!*
PHI(30):
!***********************************************************************
!* COMPUTED GOTO *
!***********************************************************************
Com_Inhibop4=1
SPTR = OUTPUT(KGEN+2)
L300: I = NEW TRIAD(CGT,Res_W,NULL,SPTR>>DSCALE)
%if Res_Mode>INT8 %then Lfault(131);! not an integer expression
%WHILE SPTR#0 %cycle
SS==record(ADICT+SPTR)
SPTR=SS_LINK1
LABREC==record(ADICT+SS_INF0)
%if LABREC_LINE # 0 %thenstart;! backward jump
CHECK BACK LAB
%finishelsestart;! forward
PTR=NEWLISTCELL(LABREC_LINK2,3)
SS==record(ADICT+PTR)
SS_INF0=I;! triad index
SS_INF2=COM_LINEST
%finish
%repeat
-> L1
!*
PHI(31):
!***********************************************************************
!* UNCONDITIONAL AND ASSIGNED GOTO *
!***********************************************************************
Res_W=OUTPUT(KGEN+1)
%if Res_FORM=LABID %thenstart;! LABEL record
LABREC==record(ADICT+Res_H0<<DSCALE)
%if LABREC_LINE#0 %thenstart;! ALREADY DEFINED
CHECK BACK LAB
%finishelsestart;! FORWARD REFERENCE
PTR=NEW LIST CELL(LABREC_LINK2,3);! CHAIN OF FORWARD REFS
SS==record(ADICT+PTR)
SS_INF0=NEXT TRIAD
SS_INF2=COM_LINEST
%finish
%if STAT TYPE=1 %and COM_OPT&1#0 %thenstart;! logical if
TR==record(ADDR TRIAD(FALSE JUMP))
TR_OP=TR_OP!!1 ;! JIT <-> JIF
TR_RES2=RES;! modify last condition to go to user label
NEXT TRIAD=FALSE JUMP+1
%if TRUE LAB_W#0 %thenstart
%cycle I=STAT TRIAD,1,FALSE JUMP-1
TR==record(ADDR TRIAD(I))
%if TR_RES2_W=TRUE LAB_W %then TR_RES2=RES
%repeat
%finish
%if LOGPTR_W#0 %thenstart;! check if private label for false is still needed
PLAB==record(ADICT+LOGPTR_H0<<DSCALE)
%if PLAB_USE<=1 %then LOGPTR=0
%finish
->LABW
%finish
%finishelsestart;! ASSIGNED GOTO
{%if Res_MODE # 1 %then LFAULT(190);! reject int*2 - now allowed}
%finish
I = NEW TRIAD(GOTO,Res_W,NULL,NULL)
LABW: COM_LABWARN = 1
-> L1
!*
PHI(33):
!***********************************************************************
!* CALLED AFTER PHI32 TO PERFORM COMPUTED GOTO IF LABEL PARAMS *
!***********************************************************************
SPTR = OUTPUT(KGEN+1)
-> L1 %if SPTR = 0;! no label params
Res_W=0
-> L300
!*
PHI(34):
!***********************************************************************
!* ABOUT TO COMPILE AN EXPRESSION WHICH MAY BE LOGICAL *
!* NO ACTION UNLESS THIS IS SO *
!***********************************************************************
L340: P1=OS(IGEN)
IGEN=IGEN+1
I = OUTPUT(KGEN+P1)
%if I = 0 %and BC = 0 %then -> L1; ! NOTFLAG=0(NO LOGICAL COMPONENT)
OUTPUT(KGEN+P1) = BC<<16!I; ! NOW CONTAINS BC<<16!NOTFLAG
BC = 0
-> L260
!*
PHI(48):
!***********************************************************************
!* Call on parameterless function *
!***********************************************************************
!*
PHI(35):
!***********************************************************************
!* START OF PROCESSING FN *
!***********************************************************************
FNREC==record(ADICT+NEW LIST CELL(COM_FNLST,4));! MAKE FN record AVAIL TO SETPARAM FOR INTRINS CHECK
%if P=48 %then I=2 %ELSE I=OS(IGEN) %and IGEN=IGEN+1
FNREC_FPTR=OUTPUT(KGEN+I);! dict record for function
FNREC_HEAD=0
FNREC_PCT=0
-> L1 %UNLESS P=48
!*
PHI(36):
!***********************************************************************
!* AFTER <IDEN> ( <PARAMLIST> ) *
!***********************************************************************
PP==record(ADICT+FNREC_FPTR)
%if PP_X0&3#0 %thenstart;! intrinsic function reference
INTRINFN(FNREC_FPTR,FNREC_PCT,FNREC_HEAD)
->L36B;! to free FNLST entry
%finish
I=SETMODE(PP_TYPE&X'3F')
%if I=LOG1 %then I=LOG4
!{2900} %if I=INT2 %then I=INT4
Res_MODE=I
I=FUN
L36A: Res_H0=FNREC_FPTR>>DSCALE
Res_FORM=PROCID
%if FNREC_HEAD#0 %thenstart
Resr_W=Form Res(FNREC_HEAD,TRIAD,FNREC_PCT)
%finishelse Resr=RNULL
Res_H0=NEW TRIADR(I,Res_W,Resr_W)
Res_FORM=TRIAD
%if Com_Opt&2#0 %then I=Op4 Ref(string(Com_Anames+PP_Iden))
L36B: FREE LIST CELL(COM_FNLST,4)
FNREC==record(ADICT+COM_FNLST)
-> L1
!*
PHI(38):
!***********************************************************************
!* FOLLOWING EVALUATION OF PARAM TO EXTERNAL SUBPROG *
!* SET PARAM DESCRIPTOR ON STACK *
!***********************************************************************
I=KGEN+OS(IGEN)
IGEN=IGEN+1
LINK PARAM(FNREC_FPTR,OUTPUT(I+2))
->L1
!*
PHI(41):
!***********************************************************************
!* AFTER CALL <IDEN> *
!***********************************************************************
PP==record(ADICT+FNREC_FPTR)
Res_MODE=NULL
I=SUBR
->L36A
!*
PHI(44):
!***********************************************************************
!* RETURN I *
!***********************************************************************
Com_Inhibop4=1
%if COM_SUBPROGTYPE=1 %then ->L451
Com_Vreturn=1
L440:
!{ITS} %if COM_ITSMODE#0 %then ITSACT(3);! REPORT RETURN
OP = RET
->L452
!*
PHI(45):
!***********************************************************************
!* STOP *
!***********************************************************************
L451: Res_H0 = 0; Res_H1 = 0
L450:
!{ITS} %if COM_ITSMODE#0 %then ITSACT(4);! REPORT STOP
OP = STOP
L452: I = NEW TRIAD(OP,Res_W,NULL,NULL)
-> LABW
!*
PHI(46):
!***********************************************************************
!* END *
!***********************************************************************
%if Dolab=4 %thenstart
Lfault(294) {DO terminating on an END statement}
Dolab=0
%finish
!*
BSStidy
!*
%if COM_SUBPROGTYPE=1 %thenstart
OP=STOP
I=4
%finishelsestart
OP=RET
I=3
%finish
!{ITS} %if COM_ITSMODE#0 %then ITSACT(I)
I=NEW TRIADR(OP,RNULLW,RNULLW)
I=NEW TRIADR(EOT,RNULLW,RNULLW);! SUBPROGEND
TR==record(ADDR TRIAD(I))
TR_CHAIN=0
!*
Cklab
!*
!****** Checklist processing (parameter arrays)
%while Com_Checklist#0 %cycle
SS==record(Adict+Com_Checklist)
PP==record(Adict+SS_Inf0)
%if PP_Class&X'60'=X'60' %thenstart
Tfault(248,Com_Anames+PP_Iden,0)
%finish
Com_Checklist=SS_Link1
%repeat
!*
%if Com_Subprogtype=2 %and Com_Funresdisp=0 %then Lfault(195)
{ fn result not assigned }
!*
%if COM_F77PARM&X'02000000'#0 %then PRINT CHTRIADS
%if COM_FNO=0 %and COM_SCANONLY=NO %thenstart
%if COM_OPT#0 %and COM_SUBPROGTYPE#5 %thenstart
%if Com_Opt&2#0 %thenstart;! save all relevant info
I=Op4 Save
Com_Subprogtype=-1
%result=1
%finish
OPTCTL(ACOM,NEXTTRIAD,32,COM_ASSGOTOS)
OBJ==record(COM_OBJADDR)
%if OBJ_OPTFLAGS&32#0 %thenstart
COM_HEADINGS=1
%if COM_TMINDEX=0 %then TMLIST=0
OPTSOURCE(COM_ADICT,COM_ANAMES,COM_ATRIADS, %
COM_DESTEMPS,COM_ADOPTDATA,TMLIST)
%finish
%finish
CODEGEN(3,TRIADS,ACOM);! GENERATE CODE
%finishelsestart
CODEGEN(4,TRIADS,ACOM)
COM_SUBPROGTYPE=-1
%finish
%result=1
!*
PHI(47):
!***********************************************************************
!* RETURN *
!***********************************************************************
%if COM_SUBPROGTYPE=1 %then ->L451
Res_W=NULL
->L440
!*
PHI(49):
!***********************************************************************
!* AFTER REF TO MULTI-DIMENSIONAL ARRAY ELEMENT *
!***********************************************************************
Resl_W=OUTPUT(KGEN+OS(IGEN))
CHRES=Resl;! in case needed for substring checking
IGEN=IGEN+1
ARRAYREC==record(ADICT+Resl_H0<<DSCALE)
DVREC==record(ADICT+ARRAYREC_ADDR4)
PCT=DVREC_DIMS
L=0
ADJ=0
%if ARRAYREC_CLASS&X'C0'=0 %thenstart;! not adjustable
%cycle J=1,1,PCT
RES=SUBSCRIPT(J)
%if Res_MODE>INT4 %thenstart
Res_W=Convert(Res_W,INT4)
SUBSCRIPT(J)=RES
%finish
%if Res_FORM&CONSTMASK#0 %thenstart
K=CONOUT(RES)
%if COM_ARRAYCHECKS=FULL %thenstart
%UNLESS Boundval(DVREC_B(J)_L)<=K %c
%and K<=Boundval(DVREC_B(J)_U) %thenstart
TFAULT(232,COM_ANAMES+ARRAYREC_IDEN,0)
%finish
%finish
%finishelse L=1
%repeat
%finishelsestart
L=1
ADJ=1
%finish
!*
! %UNLESS COM_ARRAYCHECKS=FULL %and L=1 %and PCT>1 %thenstart;! ARRAYCHECKS#FULL or 1 subscript or all int
%if PCT>1 %thenstart
%cycle I=PCT,-1,2
J=DVREC_B(I-1)_M
%if J>0 %thenstart
Res_W=CONIN(J)
%finishelsestart;! set R.D. to multiplier in DV
Res_W=Form Res(Dvrec_Addrdv+I<<2,GLALIT,INT4)
%if COM_OPT&1#0 %thenstart;! ensure multiplier info avail for optext
%if COM_TMINDEX=0 %then TMLIST=0
K=TMLIST
%WHILE K#0 %cycle
SS==record(ADICT+K)
%if SS_INF0=Res_W %then ->PHI49A;! entry already there
K=SS_LINK1
%repeat
SS==record(ADICT+NEWLISTCELL(TMLIST,3))
SS_INF0=Res_W
COM_TMINDEX=COM_TMINDEX+1
SS_INF2=(I<<16)!Resl_H0;! multiplier no., dict record(dscaled)
%finish
%finish
PHI49A: ARITHOP(SUBSCRIPT(I),MULT,RES)
%UNLESS I=PCT %then ARITHOP(RES,ADD,SUBSCRIPT(I+1))
SUBSCRIPT(I)=RES
%repeat
ARITHOP(RES,ADD,SUBSCRIPT(1))
%finishelse RES=SUBSCRIPT(1)
! %if COM_ARRAYCHECKS#NO %and L=1 %thenstart;! 1-dimensional check required
! Res_W=Triad Res(Res_MODE,SUBS,RNULLW,Res_W)
! %finishelsestart
I=ARRAYREC_TYPE
%if I=CHARTYPE %thenstart
J=ARRAYREC_LEN
%if J#0 %thenstart
Resr_W=CONIN(J)
%finishelsestart
Resr=RNULL
Resr_MODE=INT4
Resr_W=Triad Res(INT4,LEN,Resr_W,Resl_W)
%finish
ARITHOP(RES,MULT,Resr)
%finishelsestart
%if Target=Gould %and Com_Opt&1#0 %thenstart
Resr_W=Conin(Modetobytes(Resl_Mode))
Arithop(Res,MULT,Resr)
%finish
%finish
! %finish
! %finishelsestart;! full checks and non-const subscripts (or adj dims) and >1 subscript
! RES=SUBSCRIPT(1)
! Res_W=Triad Res(Res_FORM,SUBS,RNULLW,Res_W)
! %cycle I=2,1,PCT
! Res_W=Triad Res(SUBSCRIPT(I)_FORM,SUBS,Res_W,SUBSCRIPT(I)_W)
! %repeat
! %finish
Res_W=Form Res(New Triadr(ARR,Resl_W,Res_W),ARREL,Resl_Mode)
->L1
!*
PHI(50):
!***********************************************************************
!* Start processing I/O statement *
!* P1 (IOTYPE) = 1 READ *
!* 2 WRITE,PRINT *
!* 3 REWIND *
!* 4 BACKSPACE *
!* 5 ENDFILE *
!* 6 OPEN *
!* 7 CLOSE *
!* 8 INQUIRE *
!***********************************************************************
Com_Inhibop4=1
IOTYPE=OS(IGEN)
IGEN=IGEN+1
IOFORM=0
IOMODE=0
IOFLAGS=0
%if IOTYPE<=2 %then IOMODE=X'60' %ELSESTART
%if 3<=IOTYPE<=5 %then IOFORM=7 %C
%ELSE IOFORM=8
%finish
!*
%if IOTYPE>5 %and COM_JBRMODE#0 %then LFAULT(311);! not yet available
!*
IOMODE=IOMODE!(1<<(IOTYPE-1));! Set sequential file as default, I/O type as spec
IOFLAGS=IOFLAGS!(COM_CHARACTER CODE<<1);! set if EBCDIC
%if COM_CONTROL&X'10000010'=0 %then IOFLAGS=IOFLAGS!4;! unassigned check
IOFLAGS=IOFLAGS!8;! relaxing ANSI
IOCONTROLS=0;! bit significance to check multiple or conflicting control specs
IOMASK=IOMASKS(IOTYPE)
IODOINIT=0
IODEPTH=0
IOCURDIMS=0
Res_W=NULL
IOSTARTED=NEW TRIAD(STRTIO,Res_W,LIT,IOTYPE)
IOINDEX=0
->L1
!*
PHI(51):
!***********************************************************************
!* PROCESS I/O LIST ITEM *
!***********************************************************************
P1=OS(IGEN)
IGEN=IGEN+1
Res_W=OUTPUT(KGEN+P1)
%if Res_W=0 %then ->L1;! controlled var
!* reject also if expression and input list *********************************
%if IOTYPE=1 %and (Res_FORM=LIT %or Res_FORM=CNSTID) %thenstart
LFAULT(298);! not valid in input list
->L1
%finish
PHI51A:IOINDEX=IOINDEX+1
%if IOTYPE=1 %thenstart
%if Res_FORM=ARREL %then TRIADS(Res_H0)_OP=DEFARR
I=DIOITEM
%if Res_Form=PROCID %thenstart
PP==record(Com_Adict+Res_H0<<DSCALE)
PP_X1=PP_X1!2
%finish
%finishelse I=IOITEM
I=NEW TRIAD(I,Res_W,LIT,IOINDEX)
->L1
!*
%integerfn CHECK DESC TO VAR(%record(RESF) RES,%integer MODE)
%result=0
%end;! CHECK DESC TO VAR
!*
PHI(52):
!***********************************************************************
!* Process I/O specification clause *
!***********************************************************************
P1=OS(IGEN)
P2=OS(IGEN+1)
IGEN=IGEN+2
Res_W=OUTPUT(KGEN+P2)
L520: %if P1<16 %thenstart
%if P1=15 %then I=X'8000' %ELSE I=1<<P1
%finishelsestart
I=P1-16
I=1<<I
I=I<<16
%finish
%if IOCONTROLS&I#0 %then Call TFAULT(211,IOSPECS(P1),0);!repeated defn
%if IOMASK&I=0 %then Call TFAULT(212,IOSPECS(P1),0);!incompatible specification
IOCONTROLS=IOCONTROLS!I
%if P1>6 %thenstart;! OPEN,CLOSE,INQUIRE
%if IOTYPE=6 %then J=OPENPP(P1) %ELSESTART
%if IOTYPE=7 %then J=CLOSEPP(P1) %ELSE J=INQUIREPP(P1)
%finish
%UNLESS IOTYPE=8 %then J=J!X'100'
%if J&X'80'#0 %then I=4 %ELSESTART
%if J&X'40'#0 %then I=5 %ELSE I=1
%finish
%if MODETOST(Res_MODE)&15#I %thenstart
Call TFAULT(217,IOSPECS(P1),0);! invalid specifier
->L1
%finish
L52B: I=NEW TRIAD(IOSPEC,Res_W,P1,J)
->L1
%finish
J=0
->SW52(P1)
!*
SW52(1):! UNIT=
!*
%if Res_W=0 %thenstart ;!default unit specified (table initialised for default)
%if IOTYPE>2 %then Call TFAULT(223,IOTYPES(IOTYPE),0)
->L1
%finish
!*
%if Res_MODE=CHARMODE %or Res_FORM=ARRID %thenstart
%if Iotype=8 %then Lfault(213) %and ->L1
IOMODE=(IOMODE&X'0F')!X'50';! internal file
%if Res_Form=PROCID %thenstart
PP==record(Com_Adict+Res_H0<<DSCALE)
PP_X1=PP_X1!2;! to ensure that fn unassigned is not reported
%finish
!* check that it is not a concatenation or other expression ***********************
%finishelsestart
%UNLESS Res_MODE<=INT8 %thenstart
LFAULT(213);!invalid unit or internal file specifier
->L1
%finish
%finish
->L52B
!*
SW52(2): ! FMT=
!*
%if Res_W=0 %thenstart ;! list directed
%if IOMODE&X'F0'=X'50' %then LFAULT(220);! invalid for internal file
IOFORM = 3;! form = 3
->L1
%finish
!*
J=Res_FORM
!*
%if J=LIT %thenstart;! format label
K=Res_H0
L524: IOFORM=1;! form = 1
%UNLESS 0<K<=99999 %then IFAULT(110,K) %and ->L1;! invalid statement label
I=SETLAB(K,PTR)
LABREC==record(ADICT+PTR)
%if I=0 %thenstart ;! already set or referenced
I=LABREC_X0
%UNLESS I=8 %or I=16 %then IFAULT(302,K) %and ->L1;! already used as a statement label
%finish
LABREC_X0=8
Res_W=Form Res(PTR>>DSCALE,LABID,0)
->L52B
%finish
!*
%if LSCALID<=J<=CSCALID %thenstart ;! Scalar, must be assigned
%if Res_MODE=CHARMODE %thenstart
IOFORM=2
->L52B
%finish
IOFORM=1;! form=1
%UNLESS Res_MODE<=INT8 %thenstart
L521: LFAULT(214);! wrong type
->L1
%finish
->L52B
%finish
!*
IOFORM=2;! form=2
!*
%if J=ARRID %thenstart ;! special iden (must be character array)
PP==record(ADICT+Res_H0<<DSCALE)
%UNLESS PP_TYPE=5 %then LFAULT(191);! non-char array is non-standard
->L52B
%finish
!*
%if Res_MODE=CHARMODE %then ->L52B
!*
%if J=CNSTID %thenstart
CON==record(ADICT+Res_H0<<DSCALE)
%if CON_MODE=INT4 %thenstart
K=INTEGER(ADICT+CON_DADDR)
->L524
%finish
%if CON_MODE=INT8 %thenstart;! possible if I8 default chosen
K=INTEGER(ADICT+CON_DADDR+4)
->L524
%finish
%finish
!*
%if J=Procid %thenstart;! actually namelist
Ioform=10
PP==record(Adict+Res_H0<<Dscale)
%if PP_addr4=0 %then Alloc Nmlist(Res_W)
->L52B
%finish
!*
->L521;! else error
!*
SW52(3): ! REC=
!*
IOMODE=IOMODE!X'70';! iotype=7 (over-riding default 6)
%UNLESS Res_MODE<=INT8 %then LFAULT(216) %and ->L1
->L52B
!*
SW52(4): ! END =
!*
SW52(5): ! ERR=
!*
J=Res_H0
%UNLESS Res_FORM=0 %and 0<J %thenstart
%if Res_FORM=1 %thenstart;! INT IN DICT
%if Res_MODE<=2 %thenstart;! INT4 or INT8
J=INTEGER(ADICT+J<<DSCALE+4*(Res_MODE-1))
%finish
%if 0<J<=99999 %then ->SW525A
%finish
Call TFAULT(224,IOSPECS(P1),0)
->L1
%finish
SW525A:I=SETLAB(J,PTR)
LABREC==record(ADICT+PTR)
%if LABREC_X0&8#0 %thenstart
IFAULT(228,LABREC_LINE);! already used as format label
%finishelsestart
%if LABREC_X0&1#0 %thenstart
IFAULT(225,J) ;! refers to a non-exec statement
%finishelsestart
LABREC_X1=LABREC_X1!4;! label in I/O statement
%if LABREC_LINE#0 %thenstart ;! already defined
CHECK BACK LAB
%finish
Res_w=Form Res(PTR>>DSCALE,LABID,0)
J=0
->L52B
%finish
%finish
->L1
!*
SW52(6): ! IOSTAT=
!*
%unless Res_Mode<=INT4 %then LFAULT(226) %and ->L1
->L52B
!*
!*
PHI(53):
!***********************************************************************
!* End of I/O statement processing *
!***********************************************************************
%if IOTYPE=8 %thenstart;! INQUIRE
%if IOCONTROLS&X'82'=0 %then LFAULT(313);! UNIT or FILE required
%if IOCONTROLS&X'82'=X'82' %then LFAULT(314);! not both
%finish
%if 6<=IOTYPE<=7 %thenstart;! OPEN,CLOSE
%UNLESS IOCONTROLS&2#0 %then LFAULT(315);! UNIT required
%finish
Res_FORM=LIT
Res_MODE=INT4
Res_H0=IOMODE
I=NEW TRIAD(ENDIO,Res_W,LIT,IOFLAGS)
TRIADS(IOSTARTED)_QOPD1=LIT
TRIADS(IOSTARTED)_OPD1=IOFORM;! to enable correct i/o proc to be called
DOTEST=1;! allow I/O statements to terminate DO
->L1
!*
PHI(54):
!***********************************************************************
!* Process auxiliary I/O statment information clause *
!***********************************************************************
I=OS(IGEN)
P1=OUTPUT(KGEN+I+1);! control item
Res_W=OUTPUT(KGEN+I);! expression descriptor
IGEN=IGEN+1
->L520
!*
PHI(55):
!***********************************************************************
!* P1 = 0 start of implied-DO loop processing (in I/O list) *
!* 1 end of loop processing *
!***********************************************************************
P1=OS(IGEN)
IGEN=IGEN+1
!*
IOINDEX=IOINDEX+1
Res_FORM=P1
Res_H0=IOINDEX
I=NEW TRIAD(IODO,Res_W,NULL,NULL);! to ensure this is kept within the coroutine
!*
%if P1=0 %thenstart;! start
PTR=NEW LIST CELL(COM_DOPTR,10)
DOREC==record(ADICT+PTR)
DOREC_INDEXRD_W=OUTPUT(KGEN+5);! index
{ %if DOREC_INDEXRD_MODE=INT2 %thenstart;! I*2 NOT ALLOWED }
{ LFAULT(190) }
{ %result=0 }
{ %finish }
CHECK DO INDEX(I,DOREC_LINK1)
DOREC_INCRD_W=OUTPUT(KGEN+2)
DOREC_FINALRD_W=OUTPUT(KGEN+3)
Resl_W=OUTPUT(KGEN+4);! initial
DOREC_LABEL=0
START OF DO LOOP(1)
%finishelsestart;! end
END DO SUB(COM_DOPTR,1)
FREE LIST CELL(COM_DOPTR,10)
%finish
->L1
!*
PHI(56):
!***********************************************************************
!* Expression or array element in I/O list *
!* P1 locates RES in tree *
!***********************************************************************
P1=OS(IGEN)
IGEN=IGEN+1
Res_W=OUTPUT(KGEN+P1)
%if Res_FORM=TRIAD %and IOTYPE=1 %thenstart;! look for expression in input list
TR==record(ADDR TRIAD(Res_H0))
I=TR_OP
%if I#ARR %and I#ARR1 %and I#CHAR %thenstart
LFAULT(298)
->L1
%finish
%finish
->PHI51A
!*
PHI(57):
!***********************************************************************
!* Ensure that I/O related expressions are computed in the co-routine *
!***********************************************************************
I=NEW TRIADR(IODO,RNULLW,RNULLW)
->L1
!*
PHI(60):
!***********************************************************************
!* COMPILES INITIAL CODE ON ENTRY TO A STATEMENT FUNCTION *
!* SETS RESULT DESCRIPTOR *
!***********************************************************************
! COM_FAST PROLOGUE=NO
P1=OS(IGEN)
IGEN=IGEN+1
CUR STATFN=OUTPUT(KGEN+P1)
STATFN == record(ADICT+CUR STATFN)
Res_W=STATFN_LINK2
-> L1
!*
PHI(61):
!***********************************************************************
!* AFTER COMPILATION OF AN ASSIGNMENT TAKE FURTHER ACTION IF *
!* IT WAS A STATEMENT FUNCTION *
!* COMPILES RETURN *
!* CLEARS LIST OF PARAMETERS(SFPTR) *
!* LINKS SHORTENED FORM OF PARAMETER LIST TO STATEMENT FN record *
!* UPDATES START OF CODE ADDRESS FOR MAIN ENTRY *
!***********************************************************************
-> L1 %if COM_SFMK = 0
COM_SFMK = 0
SPTR=0
%if COM_SFPTR#0 %thenstart
%WHILE COM_SFPTR#0 %cycle
PP==record(ADICT+COM_SFPTR)
PTR=NEW LIST CELL(SPTR,3)
SS==record(ADICT+PTR)
RES=RNULL
Res_MODE=SETMODE(PP_TYPE&X'3F')
Res_H0=PP_LEN;! in case char
SS_INF0=Res_W
FREE LIST CELL(COM_SFPTR,8)
%repeat
%finish
STATFN==record(ADICT+CUR STATFN)
STATFN_Link3=SPTR>>DSCALE
Res_W=Form Res(Cur Statfn>>DSCALE,STFNID,Setmode(Statfn_Type&X'3F'))
%if Statfn_Type=CHARTYPE %thenstart;! allow assignment to temp
I=NEXT TRIAD-1
TRIADS(I)_RES1_W=RES_W
I=New Triadr(ENDSF,RNULLW,Res_W)
%finish
I=NEXT TRIAD-1
TRIADS(I)_OP=ENDSF
TRIADS(I)_RES1=RES
STATFN_ADDR4=STFNSTART+1
TRIADS(STFNSTART)_CHAIN=NEXT TRIAD
!{PA} PATHREPORT=1;! ENSURE REPORTING OF FIRST ACTUAL PROG STATEMENT
-> L1
!*
PHI(62):
!***********************************************************************
!* COMPILE CALL ON STATEMENT FUNCTION *
!***********************************************************************
I=OUTPUT(KGEN+2)
STATFN==record(ADICT+I)
Res_W=INSERT STFN
-> L1
!*
PHI(66):
!***********************************************************************
!* AFTER <U>**<F> *
!***********************************************************************
Resl_W=OUTPUT(KGEN+2)
Resr_W=OUTPUT(KGEN+1)
%if Resl_MODE=CHARMODE %or Resr_MODE=CHARMODE %thenstart
LFAULT(132)
%result=0
%finish
ARITHOP(Resl,8,Resr)
-> L1
!*
PHI(68):
!***********************************************************************
!* STOP <INT> *
!***********************************************************************
Res_W = OUTPUT(KGEN+1)
->L450
!*
PHI(69):
!***********************************************************************
!* PAUSE <INT> OR PAUSE ' <TEXT> ' *
!***********************************************************************
Res_W = OUTPUT(KGEN+1)
L691: I=New Triad(PAUSE,Res_W,NULL,NULL)
->L1
!*
PHI(70):
!***********************************************************************
!* PAUSE *
!***********************************************************************
Res_W = 0
->L691
!*
PHI(72):
!***********************************************************************
!* Coerce subscripts to I*4 if necessary *
!* Note R.D. for subscript in SUBSCRIPT array *
!***********************************************************************
P1=OS(IGEN)
IGEN=IGEN+1
Res_W=OUTPUT(KGEN+P1);! evaluated subscript
%unless Res_Mode=INT2 %then Res_W=Simple Int(Res_W)
SUBSCRIPT(OUTPUT(KGEN+P1-1))_W=Res_W
->L1
!*
PHI(73):
!***********************************************************************
!* SET FORMAT PARAM (SYSTEM4 ONLY) *
!***********************************************************************
IGEN=IGEN+1
->L1
!*
PHI(74):
!***********************************************************************
!* Extract R.D.s for lower and upper substring expressions *
!***********************************************************************
Resl_W=SIMPLE INT(OUTPUT(KGEN+2))
Resr_W=SIMPLE INT(OUTPUT(KGEN+1))
COM_RESCOM1=Resl_W
CHResl=Resl_W
COM_RESCOM2=Resr_W
CHResr=Resr_W
->L1
!*
PHI(75):
!***********************************************************************
!* Obtain descriptor to substring *
!***********************************************************************
COM_INP=OUTPUT(KGEN+1)
Resl_W=CHResl
Resr_W=CHResr;! in case either corrupted by PHI(49) when processing array el
PP==record(ADICT+CHRes_H0<<DSCALE)
I=PP_LEN
%if Resl_FORM=LIT %thenstart
%UNLESS 1<=Resl_H0 %thenstart
PHI75A: TFAULT(257,COM_ANAMES+PP_IDEN,0);! invalid substring value
->L1
%finish
%if Resr_FORM=LIT %thenstart
%UNLESS Resl_H0<=Resr_H0 %then ->PHI75A;! lower > upper
%if I#0 %and I<Resr_H0 %then ->PHI75A;! upper > max
%finish
%finish
%if Resl_MODE#INT4 %then Resl_W=Convert(Resl_W,INT4)
%if Resr_MODE#INT4 %then Resr_W=Convert(Resr_W,INT4)
Resr_W=Triad Res(CHARMODE,SUBSTR,Resl_W,Resr_W)
Res_W=Triad Res(CHARMODE,CHAR,Res_W,Resr_W)
->L1
!*
PHI(77):
!***********************************************************************
!* Constant operation with Resl and OP from tree, Resr = RES *
!***********************************************************************
I=KGEN+OS(IGEN)
IGEN=IGEN+1
OP=OUTPUT(I+1)
PHI77A:Resl_W=OUTPUT(I)
PHI77B:%if cexmode=2 %thenstart;! data-implied-do expression
%if dexpstart=0 %thenstart
dexpstart=Com_Dptr
Com_Dptr=Com_Dptr+16;! to ensure space for count
%finish
I=dexpstart+16*dexpnum
dexprec==record(Com_Adict+I)
Com_Dptr=Com_Dptr+16
dexpnum=dexpnum+1
integer(Com_Adict+I+16)=dexpnum
dexprec_Opl=Resl_W
Dexprec_Op=Op
Dexprec_Opr=Res_W
Res_W=X'A0000000'!I
%finishelsestart
CONST EVAL(Resl_W,OP,Res_W,RES,COM_ADICT,COM_DPTR)
%finish
->L1
!*
PHI(78):
!***********************************************************************
!* Constant operation with Resl only from tree *
!***********************************************************************
I=KGEN+OS(IGEN)
IGEN=IGEN+1
->PHI77A
!*
PHI(79):
!***********************************************************************
!* Unary operation on constant *
!***********************************************************************
%if OP=0 %then ->L1;! + or nothing
Resl_W=0
Resr_W=Res_W
->PHI77B
!*
PHI(80):
!***********************************************************************
!* Save current RES and OP *
!***********************************************************************
I=KGEN+OS(IGEN)
IGEN=IGEN+1
OUTPUT(I)=Res_W
OUTPUT(I+1)=OP
->L1
!*
!*
PHI(81):
!***********************************************************************
!* Assign constant expression value to constant name, checking *
!* compatability *
!* OUTPUT(P1) = INP value (in case of error to be reported) *
!* OUTPUT(P1+1) = RES for constant expression *
!* OUTPUT(P1+2) = DICT @ of constant name record *
!***********************************************************************
I=KGEN+OS(IGEN)
IGEN=IGEN+1
PP==record(ADICT+OUTPUT(I+2));! constant name record
J=PP_TYPE
K=SETMODE(J&X'3F')
%if J=X'54' %then K=LOG4;! not given correctly by SETMODE
Res_W=OUTPUT(I+1);! constant form of RES
L=Res_Mode&15
%if K=L %thenstart
%if K=CHARMODE %thenstart
I=PP_LEN;! name length
J=Res_H0<<DSCALE;! dict @ of const
K=INTEGER(ADICT+J);! length of const
%if I#K %thenstart
%if I=0 %thenstart;! (*) specification
PP_LEN=K
%finishelsestart
L=Dictspace((I+7)&X'FFFC')
INTEGER(ADICT+L)=I
%if I<K %thenstart
COPY(I,ADICT+J,4,ADICT+L,4)
%finishelsestart
FILL(I,ADICT+L,4,COM_SPACECHAR)
COPY(K,ADICT+J,4,ADICT+L,4)
%finish
Res_H0=L>>DSCALE; Res_H1=X'100'!CHARMODE
%finish
%finish
%finish
PP_CONSTRES=Res_W
->L1
%finish
%if 0<=K<=8 %and 0<=L<=8 %thenstart;! compatible arithmetic modes
%if Res_FORM=0 %thenstart
%if K<=1 %and L<=1 %thenstart;! int*2 and int*4
Res_Mode=K
PP_Constres=Res_W
->L1
%finish
I=Res_H0
%if I&X'8000'#0 %then I=I!X'FFFF0000'
INTEGER(ADICT)=I;! integer value for coertion
I=0
%finishelse I=Res_H0<<DSCALE
Res_H0=COERCE CONST(I,L,K,ADICT,COM_DPTR)>>DSCALE
Res_Form=1; Res_Mode=K
PP_CONSTRES=Res_W
->L1
%finishelsestart;! error
COM_INP=OUTPUT(I)
FAULT(278);! const expression of the wrong type
%finish
->L1
!*
PHI(82):
!***********************************************************************
!* Set CEXMODE to indicate type of expression being evaluated *
!* = 0 any const expression *
!* 1 int const expression *
!* 2 DATA-implied D0 subscript *
!* 3 dimension bound expression *
!***********************************************************************
CEXMODE=OS(IGEN)
IGEN=IGEN+1
dexpstart=0
dexpnum=0
->L1
!*
PHI(84):
!***********************************************************************
!* Block IF, ELSEIF, ELSE of ENDIF statement *
!* P1 = 0 IF(...)THEN *
!* 1 ELSEIF(...)THEN *
!* 2 ELSE *
!* 3 ENDIF *
!***********************************************************************
P1=OS(IGEN)
IGEN=IGEN+1
COM_LABWARN=0
!{PA} PATHREPORT=1
!*
!!L FREEREGS
IFREC==record(ADICT+COM_IFPTR)
!*
%if P1>0 %thenstart;! ELSEIF, ELSE, ENDIF - note label enclosures
I=COM_LINEST
%if P1=3 %then I=I-1;! ENDIF stat is not part of enclosure
PTR=IFREC_LABLIST
%WHILE PTR#0 %cycle
SS==record(ADICT+PTR)
LABREC==record(ADICT+SS_INF0);! label record
LABREC_IFEND=I;! complete IF-block enclosure
FREE LIST CELL(PTR,2)
%repeat
%if COM_DOPTR#0 %thenstart
DOREC==record(ADICT+COM_DOPTR)
I=IFREC_LINE
%if IFREC_TYPE=0 %then I=I-1
%if DOREC_LINE>I %then LFAULT(234)
%finish
%finish
!*
%if 1<=P1<=2 %thenstart;! ELSEIF, ELSE - fill in jumps
Ifrec_Endiflab_W=New Plab
I=NEW TRIADR(GOTO,IFREC_ENDIFLAB_W,RNULLW);! goto ENDIF
SETCA(IFREC_FALSELAB);! will define a private label if required
IFREC_FALSELAB_W=0
!!! line number update needed here to give correct lineno for soft errors
%finish
!*
%if P1<3 %thenstart;! IF, ELSEIF, ELSE
PTR=NEWLISTCELL(COM_IFPTR,6)
IFREC==record(ADICT+PTR)
IFREC_TYPE=P1
IFREC_ENDIFLAB_W=0;! in case IF
IFREC_FALSELAB_W=0;! in case ELSE
IFREC_LABLIST=0
I=COM_LINEST
%if P1=0 %then I=I+1;! IF stat is not part of enclosure
IFREC_LINE=I;! for start of label enclosures
%finishelsestart
%WHILE COM_IFPTR#0 %cycle
IFREC==record(ADICT+COM_IFPTR)
SETCA(IFREC_ENDIFLAB)
SETCA(IFREC_FALSELAB)
FREE LIST CELL(COM_IFPTR,6)
%if IFREC_TYPE=0 %then %EXIT
%repeat
%finish
->L1
!*
PHI(85):
!***********************************************************************
!* After IF(...)THEN, ELSEIF *
!* Fill in the jumps etc. *
!***********************************************************************
P1=OS(IGEN)
IGEN=IGEN+1;! note P1 not used, but available if required
NOTFLAG=NOTFLAG!!1
CONDC(1)
SETCA(LLL_ORLAB);! fill true addresses
LOGPTR=LLL_ANDLAB
FREE LIST CELL(LOGLIST,5)
LLL==record(ADICT+LOGLIST)
IFREC==record(ADICT+COM_IFPTR)
IFREC_FALSELAB=LOGPTR
->L1
!*
PHI(86):
!***********************************************************************
!* ELSEIF statment *
!* Check that the expression is logical and go to common code *
!***********************************************************************
P1=OS(IGEN)
IGEN=IGEN+1
I=OUTPUT(KGEN+P1)
%if I=0 %and BC=0 %thenstart;! not logical
LFAULT(192);! expression must be logical
%finish
OUTPUT(KGEN+P1)=BC<<16!I
BC=0
->L260
!*
PHI(87):
!***********************************************************************
!* process a character item which is being concatenated *
!* check that RES is of type character *
!* force RES to form 15 *
!* P1=0 first on chain *
!* >0 link RES record to chain at node P1 *
!* RES describes head of chain *
!***********************************************************************
P1=OS(IGEN)
IGEN=IGEN+1
OP=1
L872: %if Res_W=0 %then ->L1;! after bracketed expression
%if Res_MODE#CHARMODE %thenstart
LFAULT(132);! invalid combination
CONCATLIST=0
->L1
%finish
!*
PTR=FREESP(2)
SS==record(ADICT+PTR)
SS_INF0=Res_W
SS_LINK1=CONCATLIST
CONCATLIST=PTR
Res_W=0;! to avoid repeated entries after bracketed expressions
!*
->L1
!*
PHI(88):
!***********************************************************************
!* after EQV or NEQV *
!***********************************************************************
LOGTOACC(0)
OUTPUT(KGEN+2)=Res_W
->L1
!*
PHI(89):
!***********************************************************************
!* after RHS of EQV or NEQV *
!***********************************************************************
P1=OS(IGEN)
IGEN=IGEN+1
LOGTOACC(0)
%if P1=0 %then I=EQUIV %ELSE I=NEQ
Resr_W=OUTPUT(KGEN+2)
Res_W=Triad Res(LOG4,I,Res_W,Resr_W)
->L1
!*
PHI(90):
!***********************************************************************
!* Start of processing array subscript *
!***********************************************************************
Res_W=0
%if COM_OPT=NO %then I=NEW TRIADR(BOP,Res_W,Res_W)
->L1
!*
PHI(91):
!***********************************************************************
!* Prior to <EX> *
!***********************************************************************
PTR=FREESP(2)
SS==record(ADICT+PTR)
SS_INF0=CONCATLIST
SS_LINK1=SAVECONCATS
SAVECONCATS=PTR
CONCATLIST=0
->L1
!*
PHI(92):
!***********************************************************************
!* After <EX> generate triads for concat if necessary *
!***********************************************************************
%if CONCATLIST#0 %thenstart
Resl_W=NULL
%WHILE CONCATLIST#0 %cycle
SS==record(ADICT+CONCATLIST)
Resr_W=SS_INF0
CONCATLIST=SS_LINK1
%if CONCATLIST=0 %then I=CHHEAD %ELSE I=CONCAT
Resl_W=Triad Res(CHARMODE,I,Resl_W,Resr_W)
%repeat
RES=Resl
%finish
%if SAVECONCATS#0 %thenstart
SS==record(ADICT+SAVECONCATS)
CONCATLIST=SS_INF0
FREELISTCELL(SAVECONCATS,2)
%finish
->L1
!*
PHI(93):
!***********************************************************************
!* Resl is actual arg in stat fn call corresponding to formal arg Resr *
!***********************************************************************
Resl_W=OUTPUT(KGEN+OS(IGEN+1))
Resr_W=OUTPUT(KGEN+OS(IGEN+2))
IGEN=IGEN+3
SS==record(Adict+Resr_W)
Resr_W=SS_INF0
%UNLESS Resl_MODE=Resr_MODE %then Resl_W=Convert(Resl_W,Resr_MODE)
SS_INF2=Resl_W
->L1
!*
PHI(94):
!***********************************************************************
!* prior to logical expression in DO WHILE *
!***********************************************************************
I=3
->L281
!*
PHI(95):
!***********************************************************************
!* after logical expression in DO WHILE *
!***********************************************************************
NOTFLAG=NOTFLAG!!1
CONDC(1)
SETCA(LLL_ORLAB);! fill true addresses
DOREC_ENDREF=LLL_ANDLAB
FREE LIST CELL(LOGLIST,5)
LLL==record(ADICT+LOGLIST)
->L1
!*
PHI(96):
!***********************************************************************
!* after END DO *
!***********************************************************************
END OF DO LOOP(1)
Dotest=1;! allow to terminate labelled DO
->L1
!*
%integerfn Insert Stfn
%integerfnspec Stfn Check(%record(Resf) R)
%record(SRECF)%name SS
%record(TRIADF)%name TT
%record(RESF) RES1,RES2
%integer I,J,DIF,NUMPLABS
%ownintegerarray ARGS(0:255)
%ownintegerarray PLABS(0:65)
%ownintegerarray REPPLABS(0:63)
%cycle I=0,1,63
PLABS(I)=0
%repeat
NUMPLABS=0
I=STATFN_LINK3<<DSCALE
J=0
%WHILE I#0 %cycle
SS==record(ADICT+I)
J=J+1
RES1_W=SS_INF2
%if RES1_FORM=TRIAD %or Res1_Form=ARREL %thenstart
%UNLESS RES1_MODE=CHARMODE %or %C
CMPLX8<=RES1_MODE<=CMPLX32 %thenstart
NEW TEMP(RES2,RES1_MODE,1)
RES2_FORM=PERMID
I=NEW TRIADR(ASMT,RES2_W,RES1_W)
RES1=RES2
%finish
%finish
ARGS(J)=RES1_W
I=SS_LINK1
%repeat
I=STATFN_ADDR4;! first triad of st fn
DIF=NEXT TRIAD-I
TT==record(ADDR(TRIADS(I)))
%WHILE TT_OP#ENDSF %cycle
RES1_W=STFN CHECK(TT_RES1)
RES2_W=STFN CHECK(TT_RES2)
%if TT_OP=STMT %thenstart
J=NEW TRIAD2(STMT,TT_SLN,RES2_FORM,RES2_H0,TT_VAL2)
%finishelsestart
J=NEW TRIADR(TT_OP,RES1_W,RES2_W)
%finish
I=I+1
TT==record(ADDR(TRIADS(I)))
%repeat
%result=STFN CHECK(TT_RES2)
!*
%integerfn Stfn Check(%record(RESF) R)
%integer I
%if R_FORM=VALTEMP %thenstart;! arg
%result=ARGS(R_H0)
%finish
%if R_FORM=PLABID %thenstart
%if NUMPLABS#0 %thenstart
%cycle I=1,1,NUMPLABS
%if PLABS(I)=R_W %then %result=REPPLABS(I)
%repeat
%finish
NUMPLABS=NUMPLABS+1
PLABS(NUMPLABS)=R_W
R_W=New Plab
REPPLABS(NUMPLABS)=R_W
%result=R_W
%finish
%if R_FORM&TEXTMASK#0 %thenstart
R_H0=R_H0+DIF
%finish
%result=R_W
%end;! STFN CHECK
!*
%end;! INSERT STFN
!*
!*
%routine INTRINFN(%integer FNPTR,PCT,PLINK)
!***********************************************************************
!* check intrinsic fn calls have correct number of actual args *
!* generate explicit triads for in-line fns *
!***********************************************************************
%ROUTINESPEC NEXTARG
%constbyteintegerarray Bitspars(0:28)= %c
0, 2, 2, 2, 1, 2, 3, 2, 2, 2, 3, 2, 2, 2, 0, 0,
1, 1, 1, 1, 2, 2, 1, 1, 2, 1, 1, 1, 1
%record(RESF) Resl
%record(TRIADF)%name TR
%record(PRECF)%name FN
%integer FNDETAILS,FNGROUP,INDEX,FMODE,PMODE,OP
%switch F(0:28)
!*
FN==record(ADICT+FNPTR)
FNDETAILS=FN_LINK2
INDEX=FNDETAILS>>24
FNGROUP=FN_X0&3
FMODE=(FNDETAILS>>16)&X'F'
PMODE=(FNDETAILS>>20)&X'F'
!*
%if PCT=0 %thenstart
ERR: LFAULT(139);! wrong number of params
RES=RNULL
%return
%finish
!*
%if FNGROUP=1 %thenstart;! calls on standard library fns
TYPE1: %UNLESS PCT=FNDETAILS&3 %then ->ERR
Resl_MODE=FMODE
Resl_FORM=PROCID
Resl_H0=FNPTR>>DSCALE
Res_W=Form Res(PLINK,TRIAD,PMODE)
Res_W=Triad Res(FMODE,IFUN,Resl_W,Res_W)
%WHILE PLINK#0 %cycle
TR==record(ADDR(TRIADS(PLINK)))
TR_OP=ARG;! use only (was DARG)
PLINK=TR_OPD2
%repeat
%return
%finish
!*
%if Index>X'C0' %thenstart;! special intrinsics
%if Pct#Bitspars(Index-X'C0') %then ->Err
Res_W=Triad Res(Fmode,INTRIN,Form Res(Index-X'C0',LIT,Fmode), %c
Form Res(Plink,TRIAD,0))
%return
%finish
!*
INDEX=INDEX&X'7F'
TR==record(ADDR(TRIADS(PLINK)))
TR_OP=NULL
RES=TR_RES1
NEXT TRIAD = NEXT TRIAD - 1;! the last (arg) triad is to be replaced
Resl=RNULL
Resl_MODE=FMODE
->F(INDEX)
!*
F(1): {INT IFIX IDINT}
!*
F(3): {REAL FLOAT SNGL}
!*
F(4): {DBLE}
%UNLESS PCT=1 %then ->ERR
%if PMODE>=CMPLX8 %thenstart
PMODE=PMODE-3;! complex to corresponding real
Resl_MODE=PMODE
Res_W=Triad Res(PMODE,REALL,Resl_W,Res_W)
%finish
%if FMODE=PMODE %then %RETURN
Resl_MODE=FMODE
Op=CVT
Setr: Res_W=Triad Res(FMODE,Op,Resl_W,Res_W)
%RETURN
!*
F(6): {CMPLX}
%if PCT>2 %then ->ERR
%if PCT=1 %thenstart
%if FMODE=PMODE %then %RETURN
%finishelsestart
NEXTARG
Resl=RES;! real part
RES=TR_RES1;! complex part
%finish
%if Fmode=CMPLX16 %then Op=DCMPLX %else Op=CMPLX
->Setr
!*
F(9): {AINT DINT}
OP=AINT
SET1: %UNLESS PCT=1 %then ->ERR
->Setr
!*
F(10): {ANINT DNINT}
OP=ANINT
->SET1
!*
F(11): {NINT IDNINT}
OP=NINT
->SET1
!*
F(12): {ABS IABS CABS DABS}
%if PMODE>=CMPLX8 %thenstart
FMODE=PMODE-3;! real result
FN_LINK2=(FNDETAILS<<8)>>8!(20<<24);! to call standard fn
FN_TYPE=FN_TYPE&X'F2';! real result of corresponding size
Fn_X0=(Fn_X0&X'FC')!1
Next Triad=Next Triad+1
->TYPE1;! to generate triad for standard fn call
%finish
OP=ABS
->SET1
!*
F(13): {MOD AMOD DMOD}
OP=MOD
SET2: %UNLESS PCT=2 %then ->ERR
NEXTARG
Res_W=Triad Res(FMODE,OP,Res_W,TR_RES1_W)
%RETURN
!*
F(14): {SIGN ISIGN DSIGN}
OP=SIGN
->SET2
!*
F(15): {DIM IDIM DDIM}
OP=DIM
->SET2
!*
F(16): {DPROD}
OP=DMULT
FMODE=PMODE+1;! to allow for I8=... as well as R8=... after optimisation
->SET2
!*
F(17): {MAX MAX0 AMAX1 DMAX1}
!*
F(18): {AMAX0}
!*
F(19): {MAX1}
OP=MAX
SET3: %UNLESS PCT>1 %then ->ERR
PCT=PCT-1
%WHILE PCT>0 %cycle
PCT=PCT-1
NEXTARG
Res_W=Triad Res(Pmode,Op,Res_W,Tr_Res1_W)
%repeat
%if FMODE=PMODE %then %RETURN
Op=CVT
->Setr
!*
F(20): {MIN MIN0 AMIN1 DMIN1}
!*
F(21): {AMIN0}
!*
F(22): {MIN1}
OP=MIN
->SET3
!*
F(7): {ICHAR}
OP=ICHAR
->SET1
!*
F(8): {CHAR}
%UNLESS Res_MODE=INT4 %then Res_W=Convert(Res_W,INT4)
OP=TOCHAR
->SET1
!*
F(23): {LEN}
OP=LEN
->SET1
!*
F(24): {INDEX}
OP=CHIND
->SET2
!*
F(25): {IMAG}
OP=IMAG
->SET1
!*
F(26): {CONJG}
OP=CONJG
->SET1
!*
%routine NEXTARG
%record(TRIADF)%name T1
%integer INDEX,LINK,LAST
INDEX=TR_OPD2
TR==record(ADDR(TRIADS(INDEX)))
TR_OP=NULL
LINK=TR_CHAIN
LAST=INDEX-1
%WHILE LAST>0 %cycle
T1==record(ADDR(TRIADS(LAST)))
%if T1_CHAIN=INDEX %thenstart
T1_CHAIN=LINK
%RETURN
%finish
LAST=LAST-1
%repeat
%end;! NEXTARG
!*
%end;! INTRINFN
!*
%integerfn DELBRK(%integer OP,%record(RESF) R)
%record(TRIADF)%name TR,TT
%UNLESS R_FORM=TRIAD %then %result=R_W
TR==record(ADDR(TRIADS(R_H0)))
%UNLESS TR_OP=BRK %then %result=R_W
%if OP>3 %or TR_QOPD1#TRIAD %thenstart;! definitely redundant
OUT: TR_OP=NULL
%result=TR_RES1_W
%finish
TT==record(ADDR(TRIADS(TR_OPD1)))
%if TT_OP>3 %then ->OUT
%result=R_W;! brackets needed after all
%end;! DELBRK
!*
%routine MOD LHS OP(%record(RESF) RES,%integer MODE)
!***********************************************************************
!* If optimising and arg or target of assignment is a character *
!* substring or an array element then modify CHAR or ARR triad to *
!* DCHAR or DARR respectively to indicate this *
!***********************************************************************
%record(TRIADF)%name TR
%integer FORM,INDEX
MODE=0;! argarr gets us into all sorts of trouble
FORM=Res_FORM
INDEX=Res_H0
%if FORM=CHAREL %thenstart
TR==record(ADDR TRIAD(INDEX))
TR_OP=DCHAR
FORM=TR_QOPD1
INDEX=TR_OPD1
%finish
!*
%if FORM=ARREL %thenstart
TR==record(ADDR TRIAD(INDEX))
%if MODE=0 %then TR_OP=DARR %ELSE TR_OP=ARGARR
%finish
%end;! MOD LHS OP
!*
%routine CHECK PMODE(%integer PTR,MODE)
%integer I,J,K,L,ST
%CONSTBYTEINTEGERARRAY GENMASK(0:8)=1,1,1,2,2,2,4,4,4
%record(PRECF)%name PP
ST=MODETOST(MODE)
PP==record(ADICT+PTR)
I=PP_LINK2;! FN DETAILS
J=I>>8&X'FF';! PARAMETER SIZE/TYPE
%if J=0 %thenstart;! PARAMETER MODE NOT SET (GENERIC)
K=I>>4&15;! GENERIC RANGE
%if MODE<=CMPLX32 %thenstart
%if K&GENMASK(MODE)#0 %thenstart;! VALID GENERIC TYPE
%if I>>24=X'99' %then Mode=Mode-3 {IMAG}
I=I!MODE<<20!ST<<8
%if I>>16&X'F'=0 %thenstart;! FN MODE NOT SET
I=I!MODE<<16
PP_TYPE=ST
%finish
PP_LINK2=I
%RETURN
%finish
%finish
ERR: %if I>>24=x'D0' %then %return {ADDR}
LFAULT(143)
%finishelsestart
%if J#ST %thenstart
%UNLESS J=X'51' %and MODE<=INT4 %then ->ERR
%finish
%finish
%RETURN
%end;! CHECK PMODE
!*
%routine LINK PARAM(%integer FPTR,R)
%record(RESF) RES
%record(PRECF)%name PP
%integer FORM,VAL
Res_W=R
VAL=FNREC_HEAD
%if VAL#0 %thenstart
FORM=TRIAD
%finishelse FORM=NULL
FNREC_HEAD=NEW TRIAD(DARG,Res_W,FORM,VAL)
%if COM_OPT#0 %thenstart
MOD LHS OP(RES,1)
%finish
%if Com_Opt&2#0 %and Res_Form=PROCID %thenstart
PP==record(Com_Adict+Res_H0<<Dscale)
Op4 ArgRef(string(Com_Anames+PP_Iden))
%finish
FNREC_PCT=FNREC_PCT+1
PP==record(ADICT+FPTR)
%if PP_X0&7#0 %thenstart
%if Res_Form=ARRID %thenstart
Lfault(143)
%return
%finish
CHECK PMODE(FPTR,Res_MODE)
%finish
%end;! LINK PARAM
!*
%integerfn Convert(%integer Resw,Newmode)
%record(RESF) R
%record(RESF) RL
%record(CONSTRECF)%name CON
%integer AD
!*
Rl_W=Resw
%if RL_W=0 %then %result=0;! for special use of RES (e.g. as char substring)
%if RL_FORM&CONSTMASK#0 %and NEWMODE<CMPLX8 %thenstart
AD=0
%if RL_FORM=LIT %thenstart
%if NEWMODE=INT2 %then Rl_MODE=INT2 %and %result=Rl_W
INTEGER(ADICT)=RL_H0
AD=0
%finishelsestart
%if RL_FORM=NEGLIT %thenstart
%if NEWMODE=INT2 %then Rl_MODE=INT2 %and %result=Rl_W
INTEGER(ADICT)=-RL_H0
AD=0
%finishelsestart
CON==record(ADICT+RL_H0<<DSCALE)
AD=CON_DADDR
%finish
%finish
%if Rl_Mode#INT2 %and Newmode#INT2 %thenstart
R_W=Form Res(Coerce Const(Ad,Rl_Mode,Newmode,Adict,
Com_Dptr)>>DSCALE,1,Newmode)
%result=Form Res(Setconrec(R)>>DSCALE,CNSTID,Newmode)
%finish
%finish
R=RNULL
R_MODE=NEWMODE
%result=Triad Res(NEWMODE,CVT,R_W,Resw)
%end;! Convert
!*
%routine ARITHOP(%record(RESF) Resl,%integer OP,%record(RESF) Resr)
!***********************************************************************
!* Resl,Resr RESULT DESCRIPTORS FOR LEFT AND RIGHT OPERANDS WHERE REL.*
!* OP 1 COMPARE *
!* 2 + *
!* 3 - *
!* 4 * *
!* 5 / *
!* 6 UNARY - *
!* 7 ASSIGN (LEFT OPERAND TO RIGHT OPERAND LOCATION *
!* 8 ** *
!* OPERATION MODE IS MAX(OPERAND MODES) *
!***********************************************************************
!*
%integer LF, LA, LMODE, RF, RA, RMODE, OPMODE
%integer I
!*
!{2900}%CONSTBYTEINTEGERARRAY SETOPMODE(0:80)= %C
!{2900}X'01',X'01',X'02',X'03',X'04',X'05',X'53',X'54',X'55',
!{2900}X'01',X'01',X'02',X'03',X'04',X'05',X'53',X'54',X'55',
!{2900}X'02',X'02',X'02',X'04',X'04',X'05',X'54',X'54',X'55',
!{2900}X'03',X'03',X'04',X'03',X'04',X'05',X'63',X'64',X'65',
!{2900}X'04',X'04',X'04',X'04',X'04',X'05',X'64',X'64',X'65',
!{2900}X'05',X'05',X'05',X'05',X'05',X'05',X'65',X'65',X'65',
!{2900}X'13',X'13',X'14',X'23',X'24',X'25',X'33',X'34',X'35',
!{2900}X'14',X'14',X'14',X'24',X'24',X'25',X'34',X'34',X'35',
!{2900}X'15',X'15',X'15',X'25',X'25',X'25',X'35',X'35',X'35'
!{2900}!*
!{2900}%CONSTBYTEINTEGERARRAY CHANGEMODE(0:15) = %C
!{2900} 0,1,2,3,4,5,6,7,8,1,0,0,0,1,2,0
!*
{PERQ}%CONSTBYTEINTEGERARRAY SETOPMODE(0:80)= %C
{PERQ}X'00',X'01',X'02',X'03',X'04',X'05',X'53',X'54',X'55',
{PERQ}X'01',X'01',X'02',X'03',X'04',X'05',X'53',X'54',X'55',
{PERQ}X'02',X'02',X'02',X'04',X'04',X'05',X'54',X'54',X'55',
{PERQ}X'03',X'03',X'04',X'03',X'04',X'05',X'63',X'64',X'65',
{PERQ}X'04',X'04',X'04',X'04',X'04',X'05',X'64',X'64',X'65',
{PERQ}X'05',X'05',X'05',X'05',X'05',X'05',X'65',X'65',X'65',
{PERQ}X'13',X'13',X'14',X'23',X'24',X'25',X'33',X'34',X'35',
{PERQ}X'14',X'14',X'14',X'24',X'24',X'25',X'34',X'34',X'35',
{PERQ}X'15',X'15',X'15',X'25',X'25',X'25',X'35',X'35',X'35'
{PERQ}!*
{PERQ}%CONSTBYTEINTEGERARRAY CHANGEMODE(0:15) = %C
{PERQ} 0,1,2,3,4,5,6,7,8,0,0,0,0,0,0,0
!*
%CONSTBYTEINTEGERARRAY TRIADOP(0:5)= 0, 0, ADD, SUB, MULT, DIV
!*
%switch SW(6 : 8)
%switch CSW(6:8)
!*
!****** EXPAND RESULT DESRIPTOR FOR RHS OPERAND
%if 1<OP<6 %thenstart
Resl_W=DELBRK(OP,Resl)
Resr_W=DELBRK(OP,Resr)
%finish
RA = Resr_H0
RMODE = Resr_MODE
RF = Resr_FORM
!****** FOR DIADIC OPERATORS EXPAND RESULT DESC FOR LEFT OPERAND
LA = Resl_H0
LMODE = Resl_MODE
LF = Resl_FORM
!*
LMODE=CHANGEMODE(LMODE)
RMODE=CHANGEMODE(RMODE)
%if Lmode=INT2 %and Rmode=INT4 %and Rf=Lit %then Rmode=INT2
%if Rmode=INT2 %and Lmode=INT4 %and Lf=Lit %then Lmode=INT2
OPMODE = SETOPMODE(LMODE*9+RMODE)
%if OPMODE>15 %thenstart;! SOME COMPLEX ITEM
OPMODE=OPMODE&15+3
%if OP<=5 %thenstart
Res_W=NULL
%if LMODE#OPMODE %and LMODE#OPMODE-3 %thenstart
%if LMODE<CMPLX8 %thenstart
Res_MODE=OPMODE-3
%finishelsestart
Res_MODE=OPMODE
%finish
Resl_W=Triad Res(Res_MODE,CVT,Res_W,Resl_W)
%finish
%if RMODE#OPMODE %and RMODE#OPMODE-3 %thenstart
%if RMODE<CMPLX8 %thenstart
Res_MODE=OPMODE-3
%finishelsestart
Res_MODE=OPMODE
%finish
Resr_W=Triad Res(Res_MODE,CVT,Res_W,Resr_W)
%finish
->SETRES
%finishelse ->CSW(OP)
%finish
!*
%if OP > 5 %then -> SW(OP)
!*
%if LF&CONSTMASK#0 %and RF&CONSTMASK#0 %C
%and LMODE!RMODE<=INT8 %thenstart
%if GCONVAL(CONOUT(Resl),OP,CONOUT(Resr),I)=0 %thenstart
RESINT: Res_W=CONIN(I)
%if LMODE!RMODE=INT4 %then %RETURN
%if Lmode!Rmode=INT2 %then Res_Mode=INT2 %and %return
%if Res_FORM#CNSTID %thenstart;! if I8 and >16 bits comput at run time
Res_MODE=INT8
%RETURN
%finish
%finish
%finish
!*
Res_FORM=NULL
Res_MODE=OPMODE
%if LMODE#OPMODE %or Resl_Mode=BYTE %then Resl_W=Convert(Resl_W,OPMODE)
%if RMODE#OPMODE %or Resr_Mode=BYTE %then Resr_W=Convert(Resr_W,OPMODE)
Resl_MODE=OPMODE
SETRES: Res_W=Triad Res(OPMODE,TRIADOP(OP),Resl_W,Resr_W)
%RETURN
!*
SW(6): ! UNARY -
Resr_W=DELBRK(OP,Resr)
%if RF=LIT %thenstart
I=-RA
->RESINT
%finish
%if RMODE=INT2 %thenstart
Resl_FORM=NULL
Resl_MODE=INT4
Resr_W=Triad Res(INT4,CVT,Resl_W,Resr_W)
RMODE=INT4
%finish
CSW(6): Res_H0=NEW TRIAD(NEG,Resr_W,NULL,NULL)
Res_Form=TRIAD; Res_Mode=RMODE
%RETURN
!*
SW(7): ! ASSIGN LHS TO RHS
%if RMODE#LMODE %thenstart
%unless Lmode=INT2 %and Rmode=INT4 %thenstart
Resl_W=Convert(Resl_W,RMODE)
%finish
LMODE=RMODE
%finish
Asgn: %if RMODE=LMODE %then I=ASMT %ELSE I=CVT
I=NEW TRIADR(I,Resr_W,Resl_W)
%if COM_OPT&1#0 %then MOD LHS OP(Resr,0)
%RETURN
!*
CSW(7): %unless REAL4<=Lmode<=CMPLX32 %thenstart
Resl_W=Convert(Resl_W,Rmode-3)
Lmode=Rmode-3
%finish
->Asgn
!*
SW(8):!**
%if RMODE>5 %or LMODE>5 %thenstart
LFAULT(134)
Res_W=NULL
%RETURN
%finish
CSW(8): %if Resr_MODE>INT4 %and Resr_MODE#OPMODE %thenstart
Res_W=NULL
Res_MODE=OPMODE
Resr_W=Triad Res(OPMODE,CVT,Res_W,Resr_W)
%finish
%if Resl_MODE#OPMODE %thenstart
Res_W=NULL
Res_MODE=OPMODE
Resl_W=Triad Res(OPMODE,CVT,Res_W,Resl_W)
%finish
Resl_MODE=OPMODE
Res_W=Triad Res(OPMODE,EXP,Resl_W,Resr_W)
%RETURN
!*
%end; ! ARITHOP
!*
%routine SETCA(%record(RESF) R)
!***********************************************************************
!* define private label for conditional branches *
!***********************************************************************
%integer I
%if R_W#0 %thenstart
I=NEW TRIAD2(STMT,NULL,PLABID,R_H0,0)
%finish
%end;! SETCA
!*
%integerfn SIMPLE INT(%integer R)
!***********************************************************************
!* Ensure that any integer expressions requiring DR are loaded and *
!* that the result is a simple integer value *
!***********************************************************************
%record(RESF) RES
%if R=0 %then %result=0
Res_W=R
%if Res_MODE#INT4 %thenstart
Res_W=Convert(Res_W,INT4)
%result=Res_W
%finishelse %result=R
%result=R
%end;! SIMPLE INT
!*
%routine CHECK BACK LAB
%integer I,Er
%if Com_Allowvax=NO %then Er=205 %else Er=330;! error else warning
I=LABREC_DOSTART
%if I#0 %thenstart
%UNLESS I<=COM_LINEST<=LABREC_DOEND %then %C
IFAULT(Er,LABREC_LINE)
%finish
I=LABREC_IFSTART
%if I#0 %thenstart
%UNLESS I<=COM_LINEST<=LABREC_IFEND %then %C
IFAULT(203,LABREC_LINE)
%finish
%end;! CHECK BACK LAB
!*
%routine CONDC(%integer LLIST)
!***********************************************************************
!* COMPILE TESTS IN LOGICAL EXPRESSIONS
!* COMPILE LOAD AND TEST AND BC FOR LOGICAL VARS
!* IF RELOP # 0 COMPARE AND BRANCH
!***********************************************************************
%integer I,JUMPOP,CONDMASK,OPMODE
%record(RESF) R,PLABREC
%record(PLABF)%name PLAB
%record(SRECF)%name SSS
%if LLIST=0 %thenstart
PLABREC=LLL_ORLAB
%finishelse PLABREC=LLL_ANDLAB
%if PLABREC_W=0 %thenstart
Plabrec_W=New Plab
%if LLIST=0 %thenstart
LLL_ORLAB=PLABREC
%finishelse LLL_ANDLAB=PLABREC
%finish
PLAB==record(ADICT+PLABREC_H0<<DSCALE)
PLAB_USE=PLAB_USE+1
%if RELOP#0 %thenstart;! COMPARISON TO BE PERFORMED
SSS==record(ADICT+RELOP)
CONDMASK=SSS_INF0
Resl_W=SSS_LINK1
OPMODE=Resl_MODE
%if (OPMODE<Res_MODE %and Res_Mode#BYTE) %or Opmode=BYTE %c
%then OPMODE=Res_MODE
R_W=NULL
R_MODE=OPMODE
%if Resl_MODE#OPMODE %thenstart
%if OPMODE=CHARMODE %then LFAULT(132)
Resl_W=Triad Res(OPMODE,CVT,R_W,Resl_W)
%finish
%if Res_MODE#OPMODE %thenstart
%if OPMODE=CHARMODE %then LFAULT(132)
Res_W=Triad Res(OPMODE,CVT,R_W,Res_W)
%finish
Res_W=Triad Res(INT4{Res_Mode},Compops(Condmask),Resl_W,Res_W);! keeping Res_MODE=char/non-char as indicator
%finish
%if NOTFLAG=0 %then JUMPOP=JIT %ELSE JUMPOP=JIF
I=NEW TRIADR(JUMPOP,Res_W,PLABREC_W)
I=NEW TRIAD2(STMT,NULL,NULL,NULL,3);! start of block
NOTFLAG=0
RELOP=0
%end;! CONDC
!*
%routine LOGTOACC(%integer NOTFL)
%record(RESF) Resl
%integer I,J
%if RELOP=0 %and LLL_ANDLAB_W=0 %and LLL_ORLAB_W=0 %then %RETURN
CONDC(0);! PLANTS JUMP IF TRUE
SETCA(LLL_ANDLAB);! FILLS .AND. ADDRESSES
LLL_ANDLAB_W=0
%if NOTFL =0 %then I=0 %ELSE I=1
NEW TEMP(RES,LOG4,2)
Res_FORM=PERMID
Resl_W=Form Res(I,LIT,LOG4)
J=NEW TRIADR(ASMT,Res_W,Resl_W)
Resr_W=New Plab
J=NEW TRIADR(GOTO,Resr_W,RNULLW)
SETCA(LLL_ORLAB);! FILL .TRUE. ADDRESSES
LLL_ORLAB_W=0
Resl_H0=I!!1
J=NEW TRIADR(ASMT,Res_W,Resl_W)
J=NEW TRIAD2(STMT,NULL,PLABID,Resr_H0,0)
%end;! LOGTOACC
!*
%routine ANDOR(%integer P1)
!***********************************************************************
!* COMPILE CODE FOR .AND. OR .OR. CONDITION AND SET UP AND/OR LISTS *
!* P1 = 0 .OR. *
!* 1 .AND. *
!***********************************************************************
NOTFLAG=NOTFLAG!!P1
CONDC(P1)
%if P1=0 %thenstart
SETCA(LLL_ANDLAB)
LLL_ANDLAB_W=0
%finish
%end;! ANDOR
!*
%routine START OF DO LOOP(%integer PAR)
%integer M,IMODE,OP
%record(RESF) R
%if DOREC_INDEXRD_MODE<=INT4 %then M=0 %ELSE M=X'800000';! can use BREG
%UNLESS DOREC_INCRD_MODE<=INT4 %and DOREC_FINALRD_MODE<=INT4 %C
%and Resl_MODE<=INT4 %and DOREC_INCRD_FORM=LIT %C
%and DOREC_FINALRD_FORM#NEGLIT %and Resl_FORM#NEGLIT %C
%then M=M!X'400000';! if 0 then all simpl int consts
DOREC_LABEL=DOREC_LABEL!M;! for end of loop processing
%if DOREC_INCRD_FORM=LIT %and DOREC_INCRD_H0=0 %thenstart;! zero increment
LFAULT(295)
DOREC_INCRD_H0=1
%finish
%if M=0 %thenstart;! simple case
%if DOREC_FINALRD_FORM # LIT %thenstart;! final is not simple int const
NEW TEMP(Resr,INT4,2)
Resr_FORM=PERMID
I = NEW TRIADR(ASMT,Resr_W,DOREC_FINALRD_W)
DOREC_FINALRD=Resr
%finish
%if COM_OPT&1#0 %thenstart
%UNLESS Resl_MODE=INT4 %then Resl_W=Convert(Resl_W,INT4)
OP=ASMT
%finishelse OP=STOD1
I = NEW TRIADR(OP,DOREC_INDEXRD_W,Resl_W);! index, initial
%if Com_F77parm&X'800'=0 %thenstart;! do zero trip test
%unless Resl_FORM=LIT %C
%and DOREC_FINALRD_FORM=LIT %thenstart;! unless both initial and final are const
Dorec_Endref_W=New Plab
%if COM_OPT&1=0 %thenstart
I=NEW TRIADR(STOD2,DOREC_FINALRD_W,DOREC_ENDREF_W)
%finishelsestart
R_W=Triad Res(INT4,GT,DOREC_INDEXRD_W,DOREC_FINALRD_W)
I=NEW TRIADR(JIT,R_W,DOREC_ENDREF_W)
%finish
%finishelsestart;! compile-time decision
%if DOREC_FINALRD_H0<Resl_H0 %thenstart;! zero trip
Dorec_Endref_W=New Plab
I = NEW TRIADR(GOTO,DOREC_ENDREF_W,RNULLW)
%finishelse DOREC_ENDREF_W=0
%finish
%finishelse DOREC_ENDREF_W=0
I = NEW TRIAD2(STMT,0,0,0,3);! to ensure a back target block
Dorec_Loopad_W=New Plab
I = NEW TRIAD2(STMT,NULL,PLABID,DOREC_LOOPAD_H0,0)
%RETURN
%finish
!*
IMODE=DOREC_INDEXRD_MODE
%if Resl_MODE#IMODE %then Resl_W=Convert(Resl_W,IMODE)
I = NEW TRIADR(ASMT,DOREC_INDEXRD_W,Resl_W);! index=initial
%if DOREC_INCRD_FORM#LIT %or DOREC_INCRD_H0#1 %C
%or IMODE>INT4 %thenstart;! unless default int 1 and int required
K=1
NEW TEMP(Resr,IMODE,2)
Resr_FORM=PERMID
%UNLESS DOREC_INCRD_MODE=IMODE %then %c
Dorec_Incrd_W=Convert(DOREC_INCRD_W,IMODE)
I = NEW TRIADR(ASMT,Resr_W,DOREC_INCRD_W)
DOREC_INCRD=Resr
%finishelse K=0
!*
%if DOREC_FINALRD_MODE#IMODE %thenstart
R_W=NULL
R_MODE=IMODE
Dorec_Finalrd_W=Triad Res(IMODE,CVT,R_W,DOREC_FINALRD_W)
%finish
R_W=Triad Res(IMODE,SUB,DOREC_FINALRD_W,DOREC_INDEXRD_W)
NEW TEMP(Resr,INT4,1)
Resr_FORM=PERMID
DOREC_ICRD=Resr
%if K=0 %thenstart
R_H0 = NEW TRIADR(ADD,R_W,FORM RES(1,LIT,INT4))
%finishelsestart
R_H0=NEW TRIADR(ADD,R_W,DOREC_INCRD_W)
R_H0=NEW TRIADR(DIV,R_W,DOREC_INCRD_W)
%finish
%if R_MODE#Resr_MODE %then R_W=Convert(R_W,Resr_MODE)
I = NEW TRIADR(ASMT,Resr_W,R_W)
Dorec_Endref_W=New Plab
I=NEW TRIADR(JINP,Resr_W,DOREC_ENDREF_W)
TR==record(ADDR TRIAD(I))
TR_USE=1;! to indicate last in block (for OP1)
I = NEW TRIAD2(STMT,0,0,0,3);! to ensure a back target block
Dorec_Loopad_W=New Plab
I = NEW TRIAD2(STMT,NULL,PLABID,DOREC_LOOPAD_H0,0)
%end;! START OF DO LOOP
!*
%routine END DO SUB(%integer DOPTR,PAR)
%integer I
%record(DORECF)%name DOREC
%record(RESF) R
DOREC==record(ADICT+DOPTR)
%if Dorec_Indexrd_W=0 %thenstart;! DO WHILE
I=New Triadr(GOTO,Dorec_Loopad_W,RNULLW)
Setca(Dorec_Endref)
%return
%finish
%if DOREC_LABEL&X'C00000'#0 %thenstart;! not all int consts
R_W=Triad Res(DOREC_INDEXRD_MODE,ADD,DOREC_INDEXRD_W,DOREC_INCRD_W)
I = NEW TRIADR(ASMT,DOREC_INDEXRD_W,R_W)
R_W=Form Res(1,LIT,INT4)
R_W=Triad Res(INT4,SUB,DOREC_ICRD_W,R_W)
I=NEW TRIADR(ASMT,DOREC_ICRD_W,R_W);! count=count-1
I=NEW TRIADR(JIP,DOREC_ICRD_W,DOREC_LOOPAD_W)
TR==record(ADDR TRIAD(I))
TR_USE=1;! to indicate last in block
I=NEW TRIAD2(STMT,NULL,NULL,NULL,3);! new block
%finishelsestart;! all int consts
%if COM_OPT&1=0 %thenstart
I = NEW TRIADR(EOD1,DOREC_INDEXRD_W,DOREC_INCRD_W)
I = NEW TRIADR(EOD2,DOREC_FINALRD_W,DOREC_LOOPAD_W)
%finishelsestart
R_W=Triad Res(INT4,ADD,DOREC_INDEXRD_W,DOREC_INCRD_W)
I=NEW TRIADR(ASMT,DOREC_INDEXRD_W,R_W)
R_W=Triad Res(INT4,GE,DOREC_FINALRD_W,DOREC_INDEXRD_W)
I=NEW TRIADR(JIT,R_W,DOREC_LOOPAD_W)
I=NEW TRIAD2(STMT,NULL,NULL,NULL,3)
%finish
%finish
Setca(Dorec_Endref)
%end;! END DO SUB
!*
%routine END OF DO LOOP(%integer Mode)
!***********************************************************************
!* Mode = 0 *
!* THE LABEL ON THE CURRENT STATEMENT HAS BEEN SPECIFIED IN A DO STAT *
!* = 1 *
!* END DO statement *
!***********************************************************************
%integer J,L,PTR
%record(DORECF)%name DOREC
%record(SRECF)%name SS
%record(IFRECF)%name IFREC
%record(LABRECF)%name LABREC
%if Mode=0 %and DOTEST = 0 %thenstart
LFAULT(294);! ILLEGAL STATEMENT TERMINATING DO
%finish
DOTEST = 0
!{PA} J=0;! FOR PATH ANALYSIS
%cycle
DOREC == record(ADICT+COM_DOPTR)
%if DOREC_INDEXRD_W&X'FF000000'#X'FF000000' %thenstart;! valid record
L=Dorec_Label&X'FFFFF'
%if Mode=1 %and (L#0 %and L=COM_LAB) %then %return;! dont process ENDDO
%if Mode=1 %or (L#0 %and L=COM_LAB) %thenstart
! N.B. DO DEPTH IS IN TOP BYTE
Mode=0;! to process only one loop for ENDDO
!{PA} %if J#0 %and COM_PATHANAL#0 %then PATHCOUNT(COM_LINEST,J)
!{PA} J=J+1
%if COM_IFPTR#0 %thenstart
IFREC==record(ADICT+COM_IFPTR)
%if IFREC_LINE>DOREC_LINE %then LFAULT(234)
%finish
END DO SUB(COM_DOPTR,0)
!{PA} PATHREPORT=1
%finishelseEXIT;! FROM CYCLE
%finish
PTR=DOREC_LABLIST
%WHILE PTR#0 %cycle
SS==record(ADICT+PTR)
LABREC==record(ADICT+SS_INF0);! label record
LABREC_DOEND=COM_LINEST;! complete DO enclosure
FREE LIST CELL(PTR,2)
%repeat
FREE LIST CELL(COM_DOPTR,10)
%if COM_DOPTR = 0 %thenRETURN
%repeat
!*
I = COM_DOPTR
%WHILE I # 0 %cycle
DOREC == record(ADICT+I)
%if DOREC_LABEL&X'FFFFF'=COM_LAB %and Com_Lab#0 %thenstart
LFAULT(148); ! ILLEGAL STATEMENT TERMINATING DO, OR WRONGLY N ESTED DO
DOREC_INDEXRD_W = X'FF000000'
%finish
I = DOREC_LINK1
%repeat
PATHREPORT=1;! ENSURE NEXT STAT IS REPORTED WHEN PA IN USE
%end; ! END OF DO LOOP
!*
!*
%integerfn New Plab
!***********************************************************************
!* Provide a new dict record for a private label *
!***********************************************************************
%integer I
I=Dict Space(PLABRECSIZE)
PLAB==record(ADICT+I)
PLAB_BLKIND=0
PLAB_USE=0
PLAB_X1=1;! referenced in explicit GOTO
PLAB_INDEX=COM_NEXT PLAB
COM_NEXT PLAB=COM_NEXT PLAB+1
%result=Form Res(I>>DSCALE,PLABID,0)
%end;! New Plab
!*
!{PA} %routine PATHCOUNT(%integer LINE,INDEX)
!{PA} %integer I
!{PA} I = NEW TRIAD2(PA,LINE,NULL,NULL,INDEX)
!{PA} %end;! PATHCOUNT
!*
!{ITS} %routine ITSACT(%integer ENTRY)
!{ITS} %integer I
!{ITS} I = NEW TRIAD2(ITS,ENTRY,NULL,NULL,NULL)
!{ITS} %end;! ITSACT
!*
%end;! GENERATE
!*
!*
%endoffile