! froot1a
! 04/03/87 - set Com_Allowvax, Com_Allowunix to 0
! 25/02/87 - change Version message
! froot1
! 10/10/86 - insert include files
! ftnroot9
! 30/09/86 - set Com_Listmode non-zero if code listing only
! ftnroot8
! 10/09/86 - Com_Opt&1 normal optimisation &2 inline subprograms
! 06/07/86 - adjust space for Output in T#Names ftnroot7
! Modified 11/6/86 - Put in PNX table size control ftnroot6
! Modified 05/06/86 ftnroot5
!
! FORTRAN 77 CTL MODULE
!
%OWNSTRING (70) VERSION = %c
"Amdahl Fortran77 Compiler Version 2.00"
%constinteger Rel = 0
%constinteger Vers = 1
!*
%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
!*
!*
!*
!***********************************************************************
!* Exports *
!***********************************************************************
!*
%integerfnspec FORT77 (%integer Control,Options1,Options2,F77parm,
Optflags,Srflags,Console,Liststream,Diagstream,
Diaglevel,Dsize,Tsize,Bsize,Lsize,Asize,Sp2)
%routinespec Dicful
%routinespec Namesful
%routinespec Extful
%routinespec F77abort(%integer N)
%integerfnspec Outputful
%integerfnspec Analful
%integerfnspec Genful
!*
%owninteger CurDsize,CurTsize,CurBsize,CurLsize,CurAsize,curSsize
!***********************************************************************
!* Imports *
!***********************************************************************
!*
%externalroutinespec Codegen(%integer Cgenep,
%record(Triadf)%arrayname Triads,
%integer Comad)
%externalintegerfnspec Analstart(%record(Triadf)%arrayname Triads,
%integer Comad,%integername Count)
%EXTERNALROUTINESPEC INIT ALLOC (%INTEGER MODE, COMAD, REL, AVERS)
%externalroutinespec Init Num(%integer Comad)
%externalroutinespec F77area(%integer index,size,%integername ad)
%externalroutinespec Free(%integer byteaddress)
!*
%externalroutinespec Op4 Init(%integer Comad)
%externalroutinespec op4 Init1(%integer Comad)
%externalintegerfnspec Op4 Subprog
%externalroutinespec Reset Oplist
%externalroutinespec Lfault(%integer N)
%externalroutinespec Op4 Resetanal
!*
%externalroutinespec Optsource(%integer a,b,c,d,e,f)
%externalroutinespec Optctl(%integer Acom,Nexttr,Bits,Assgotos)
%if Target=gould %thenstart
%externalroutinespec mcodeon
%finish
!*
!***********************************************************************
!* OWN variables *
!***********************************************************************
!*
%owninteger ComCONTROL,OPT,OPTIONS1,OPTIONS2,PTRACE,
ADICT,ANAMES,ADOUTPUT,ADBLKDTAID,DICLEN,DPTR,
MAXTRIADS,NEXTPLAB,ALABH,ADLHEAD,
SUBPROGTYPE,SFPTR,EXTERNALS,CBNPTR,SCPTR,CHECKLIST,
RESCOM1,RESCOM2,F77PARMS,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,ComHOST,ComTARGET,MONERRS,TRANSMTM,
GLACA,PLTCA,SSTCA,GSTCA,CONSTCA,SCALARCA,IOAREACA,ZGSTCA,STACKCA,
ComW1,ComW2,ComW4,STATORDERMODE,CURSTATCLASS,LISTPOINT,STACKBASE,
NEXTTRIAD,ASAVE,MAXSAVE,SUBTAB,LASTSUBTAB,
INHIBOP4,ARGCNT,IDCNT,LABCNT,TMLIST,MAINPROG,PROCINDEX,ComCONSOLE,
NEXTSAVE
!*
%ownrecord(Objfmt) Obj
%ownrecord(Comfmt)%name Com
%owninteger Comad
!*
!*
%CONSTBYTEINTEGERARRAY HEX(0 : 15) = %C
'0','1','2','3','4','5','6',
'7','8','9','A','B','C','D','E','F'
!*
%ROUTINE PRHEX(%INTEGER J)
%INTEGER K
%CYCLE K = 28,-4,0
PRINT SYMBOL(HEX((J>>K)&15))
%REPEAT
%END
!*
!
%EXTERNALINTEGERFN FORT77 (%INTEGER CONTROL, OPTIONS1, OPTIONS2, F77PARMS, OPTFLAGS, %C
SRFLAGS, CONSOLE, LISTSTREAM, DIAGSTREAM, DIAGLEVEL, DSIZE, TSIZE, BSIZE, LSIZE, ASIZE, SP2)
%ownrecord(Triadf)%arrayformat Trform(0:10000)
%ownrecord(Triadf)%arrayname Triads
%integer Diclen,Maxtriads,Maxblocks,Maxloops
%integer I,J,K,F,Count
%string(63) S
!*
Com==record(addr(ComControl))
%if Target=gould %thenstart
%if Control&X'4000'#0 %then mcodeon
%finish
Comad=addr(Com_Control)
!*
!****** Host dependent data
!*
Com_Host=HOST
Com_W1=W1
Com_W2=W2
Com_W4=W3
!*
!******
!*
Com_Messlen=1
!*
!******* ESTABLISH Com_Options
!*
Com_Control = Control
Com_Options1=Options1
Com_Options2=Options2
F77parms=F77parms!2;! inhibit argument checks
Com_F77parm=F77PARMS
Com_Opt=(Com_Options1>>20)&15
%if Com_Opt#0 %then Com_F77parm=Com_F77parm!X'17';! all checks off
Com_Optflags=Optflags
Obj_Srflags=Srflags
Obj_Inhibmask=0
%if Host=IBM %thenstart
Com_Liststream=Liststream
Com_Diagstream=Diagstream
Com_Console=Diagstream
%finishelsestart
Com_Liststream=Liststream
Com_Diagstream=Diagstream
Com_Console=Console
%finish
Com_Noisy=1;! report routine name to diagstream
%if Srflags#0 %thenstart
printstring(" SRFLAGS = X")
Prhex(Srflags)
%finish
!*
%if Dsize=0 %then Dsize=128
%if Dsize<16 %then Dsize=16
%if Dsize>128 %then Dsize=128
CurDsize = Dsize
!*
%if Tsize=0 %then Tsize=256
%if Tsize<32 %then Tsize=32
! %if Tsize>256 %then Tsize=256
CurTsize=Tsize
!*
%if Bsize=0 %then Bsize=128
%if Bsize<16 %then Bsize=16
! %if Bsize>128 %then Bsize=128
CurBsize=Bsize
!*
%if Lsize=0 %then Lsize=32
%if Lsize<1 %then Lsize=1
! %if Lsize>16 %then Lsize=16
CurLsize=Lsize
%if asize=0 %then asize=256
%if asize<16 %then asize=16
!%if asize>256 %then asize=256
CurAsize=Asize
!*
Diclen=Dsize<<10
Dsize=Dsize<<10
!*
Tsize=Tsize<<10
Maxtriads=Tsize//12
!*
Maxblocks=Bsize<<10
Bsize=Bsize<<10
!*
Maxloops=Lsize<<10
Lsize=Lsize<<10
asize=asize<<10
!*
Com_Objaddr=addr(Obj)
F77area(0,Dsize,Com_Adict);! T#DICT
%IF COM_ADICT < 1 %THEN %RESULT = -COM_ADICT
Com_Diclen=Diclen
F77area(1,X'c000',Com_Anames);! T#NAMES
%IF COM_ANAMES < 1 %THEN %RESULT = -COM_ANAMES
Com_Nameslen=x'2000'
Com_Adoutput=Com_Anames+X'2000'
Com_Maxoutput=4000
Com_Saveanal=Com_Anames+X'6000'
Com_Maxanal=X'4000'
Com_Savegen=Com_Anames+X'a000'
Com_Maxgen=X'2000'
f77area(2,Tsize,Com_Atriads);! T#TRIADS
%IF COM_ATRIADS < 1 %THEN %RESULT = -COM_ATRIADS
Com_Maxtriads=Maxtriads
%if Com_Opt&1#0 %thenstart
F77area(3,Bsize,Obj_Ablocks);! T#BLOCKS
%IF OBJ_ABLOCKS < 1 %THEN %RESULT = -OBJ_ABLOCKS
Obj_Maxblocks=Maxblocks
F77area(4,asize,Obj_Atabs);! T#TABS
%IF OBJ_ATABS < 1 %THEN %RESULT = -OBJ_ATABS
Obj_Maxtabs=asize ;!X'8000'
F77area(5,Lsize,Obj_Aloop);! T#LOOPS
%IF OBJ_ALOOP < 1 %THEN %RESULT = -OBJ_ALOOP
Obj_Maxloop=Maxloops
%finish
%if Com_Opt&2#0 %thenstart
F77area(6,X'40000',Com_Asave);! T#SAVE
Com_Maxsave=X'40000'
%finish
Triads==array(Com_Atriads,Trform)
!*
Com_Allowvax=0
Com_Allowunix=0
!*
%if Host=IBM %thenstart
%if Com_Control&2=0 %thenstart;! listing required
%if Liststream>=0 %and Diagstream>=0 %then Com_Listmode=1 %c
%else Com_Listmode=2
Com_Listl=1
%finishelsestart
Com_Listmode=0
Com_Listl=0
%finish
%finishelsestart
%if Com_Control&2=0 %thenstart;! listing required
Com_Listl=1
set: %if Diagstream>0 %and Liststream>0 %thenstart
Com_Listmode=2
%finishelsestart
Com_Listmode=1
%if Diagstream<0 %then Com_Diagstream=-Diagstream
%if Liststream<0 %then Com_Liststream=-Liststream
%finish
selectoutput(Com_Liststream)
%finishelsestart
Com_Listl=0
%if Com_Control&X'4000'#0 %then ->set {code listing required}
Com_Listmode=0
%if Diagstream<0 %then Com_Diagstream=-Diagstream
Com_Liststream=Com_Diagstream
selectoutput(Com_Diagstream)
%finish
Com_Console=Com_Diagstream
%finish
Com_Xref=(Com_Control&X'800')>>11
Com_Scanonly=(Com_Options1&X'20')>>5
%if Com_Control&X'400000'#0 %thenstart;! EBCDIC
Com_Character Code=1
Com_Space Char=X'40'
%finishelsestart;! ISO
Com_Character Code=0
Com_Space Char=X'20'
%finish
Com_Itsmode=0
Com_Unasspattern=X'81818181'
%if Com_Control&X'10'#0 %then Com_F77parm=(Com_F77parm)!X'7'
! nochar,noarg,nochar (NOCHECK)
%if Com_Control&X'20'#0 %then Com_F77parm=Com_F77parm!X'10'
! nobound (NOARRAY)
!*
%if Com_F77parm&X'F'#7 %and Diaglevel<0 %then Diaglevel=0;! to ensure some diags available
%if Diaglevel<0 %then Com_Control=Com_Control!X'10000';! to minimise overhead
Com_Diaglevel=Diaglevel
!*
%if Com_F77parm&X'8'#0 %then Com_Arraychecks=YES %C
%else Com_Arraychecks=NO
!*
%if Com_Options1&X'10'#0 %then Com_Optflags=Com_Optflags!32;! oplist
Obj_Optflags=Com_Optflags
!*
Com_Pathanal=Com_Control&X'80';! PROFILE BIT
!*
Init Alloc(0,Comad,Rel<<16!Vers,addr(Version))
Init Num(Comad)
! %if Com_Listl#0 %thenstart
! newline
! printstring(Version)
! newlines(2)
! %finish
!*
Com_Lineno=-1
Com_Linest=0
Com_Warncount=0;! individual counts for each subprog
Com_Messcount=0
Com_Commonbase=0
Com_Headings=0
Com_Mainprog=0;! set after a main program - used to check multiples
Com_Procindex=0;! used to default main prog out of position for Opt3
Com_Adoptdata=0;! will be set non-zero on entry to optimiser
!*
Count=0
!*
%if Com_Opt&2#0 %thenstart
Op4 Init(Comad)
Op4 Init1(Comad)
%finish
!*
I=Analstart(Triads,Comad,Count)
!*
%if Com_Opt&2#0 %and Com_Fno=0 %thenstart
!printstring("
!Subtab Lastsubtab Nextsave ")
!write(Com_Subtab,4)
!write(Com_Lastsubtab,4)
!write(Com_Nextsave,4)
!newlines(2)
!dump(Com_Asave,Com_Nextsave)
%if Obj_Optflags&32#0 %then Reset Oplist
%cycle
%if Com_Fno#0 %or Com_Faulty#0 %then %exit
J=Op4 Subprog
%if J=-3 %then Lfault(347);! recursion
%if J<=0 %then %exit
Op4 Resetanal
%if Com_Opt&1#0 %thenstart
Optctl(Comad,Com_Nexttriad,32,Com_Assgotos)
%finish
%IF OBJ_OPTFLAGS&X'10000'#0 %THENSTART;! DIS=OPLIST
SELECTOUTPUT(COM_DIAGSTREAM)
OPTSOURCE(COM_ADICT,COM_ANAMES,COM_ATRIADS, %C
COM_DESTEMPS,COM_ADOPTDATA,COM_TMLIST)
SELECTOUTPUT(COM_LISTSTREAM)
%FINISH
%IF OBJ_OPTFLAGS&32#0 %THENSTART
NEWPAGE
COM_HEADINGS=1
%IF COM_TMINDEX=0 %THEN COM_TMLIST=0
OPTSOURCE(COM_ADICT,COM_ANAMES,COM_ATRIADS, %C
COM_DESTEMPS,COM_ADOPTDATA,COM_TMLIST)
%FINISH
Codegen(3,Triads,Comad)
%repeat
%finish
!*
%if I#0 %then Codegen(I,Triads,Comad)
!*
%if Host=PERQPNX %thenstart
Free(Com_Adict<<1)
Free(Com_Anames<<1)
%if Com_Opt&1#0 %thenstart
Free(Obj_Ablocks<<1)
Free(Obj_Atabs<<1)
Free(Obj_Aloop<<1)
%finish
%finishelsestart
Free(Com_Adict)
Free(Com_Anames)
%if Com_Opt&1#0 %thenstart
Free(Obj_Ablocks)
Free(Obj_Atabs)
Free(Obj_Aloop)
%finish
%finish
%if Com_Faulty=0 %then %result=Com_Linest %c
%else %result=-Com_Faulty
%end;! PNXFort77
!*
%routine Abort(%string(63) S, %integer cursize,maxsize,IDletter)
printstring("
***Compilation aborted due to ")
printstring(S)
printstring(" table overflow
***This may be avoided by reducing the size or complexity of the subprogram
***currently being compiled
")
%if cursize#maxsize %and IDletter#'s' %start
printstring("*** Alternatively the table size may be increased from the current
***")
write(cursize,1)
printstring(" Kb towards a maximum of")
write(maxsize,1)
printstring(" Kb by use of the compiler option -N")
printsymbol(IDletter)
printstring("(numKb)")
%finish
!deleteobjectfile
newline
%stop
%end;! Abort
!*
%externalroutine Dicful
Abort("Dictionary",CurDsize,128,'d')
%end
!*
!*
%externalroutine Namesful
Abort("Name",0,0,0)
%end
!*
%externalroutine Extful
Abort("Externals",0,0,0)
%end
!*
%externalroutine F77abort(%integer N)
%if N=1 %then Abort("Triad",CurTsize,10000,'t')
%if N=2 %then Abort("Block",CurBsize,10000,'b')
%if N=3 %then Abort("Loop",CurLsize,10000,'l')
%if N=4 %then Abort("Tab",CurAsize,10000,'a')
%if N=5 %then Abort("Com_Saveanal",0,0,0)
%if N=5 %then Abort("Asave",Curssize,10000,'s')
Abort("???",0,0,0)
%end;! F77abort
!*
%externalintegerfn Outputful
%result=1
%end
!*
%externalintegerfn Analful
%result=1
%end
!*
%externalintegerfn Genful
%result=1
%end
!*
!*
%endoffile