* Copyright (c) 1980 Regents of the University of California.
* All rights reserved. The Berkeley software License Agreement
* specifies the terms and conditions for redistribution.
static char sccsid
[] = "@(#)proc.c 5.8 (Berkeley) %G%";
* Routines for handling procedures, f77 compiler, pass 1.
* University of Utah CS Dept modification history:
* Revision 5.9 86/01/28 22:30:28 donn
* Let functions of type character have adjustable length.
* Revision 5.8 86/01/10 19:02:19 donn
* More dbx hacking -- filter out incomplete declarations (with bogus types).
* Revision 5.7 86/01/10 13:53:02 donn
* Since we now postpone determination of the type of an argument, we must
* make sure to emit stab information at the end of the routine when we
* definitely have the type. Notice some care was taken to make sure that
* arguments appear in order in the output file since that's how dbx wants
* them. Also a minor change for dummy procedures.
* Revision 5.6 86/01/06 16:28:06 donn
* Sigh. We can't commit to defining a symbol as a variable instead of a
* function based only on what we have seen through the declaration section;
* this was properly handled for normal variables but not for arguments.
* Revision 5.5 86/01/01 21:59:17 donn
* Pick up CHARACTER*(*) declarations for variables which aren't dummy
* arguments, and complain about them.
* Revision 5.4 85/12/20 19:18:35 donn
* Don't assume that dummy procedures of unknown type are functions of type
* undefined until the user (mis-)uses them that way -- they may also be
* Revision 5.3 85/09/30 23:21:07 donn
* Print space with prspace() in outlocvars() so that alignment is preserved.
* Revision 5.2 85/08/10 05:03:34 donn
* Support for NAMELIST i/o from Jerry Berkman.
* Revision 5.1 85/08/10 03:49:14 donn
* Revision 3.11 85/06/04 03:45:29 donn
* Changed retval() to recognize that a function declaration might have
* bombed out earlier, leaving an error node behind...
* Revision 3.10 85/03/08 23:13:06 donn
* Finally figured out why function calls and array elements are not legal
* dummy array dimension declarator elements. Hacked safedim() to stop 'em.
* Revision 3.9 85/02/02 00:26:10 donn
* Removed the call to entrystab() in enddcl() -- this was redundant (it was
* also done in startproc()) and confusing to dbx to boot.
* Revision 3.8 85/01/14 04:21:53 donn
* Added changes to implement Jerry's '-q' option.
* Revision 3.7 85/01/11 21:10:35 donn
* In conjunction with other changes to implement SAVE statements, function
* nameblocks were changed to make it appear that they are 'saved' too --
* this arranges things so that function return values are forced out of
* register before a return.
* Revision 3.6 84/12/10 19:27:20 donn
* comblock() signals an illegal common block name by returning a null pointer,
* but incomm() wasn't able to handle it, leading to core dumps. I put the
* fix in incomm() to pick up null common blocks.
* Revision 3.5 84/11/21 20:33:31 donn
* It seems that I/O elements are treated as character strings so that their
* length can be passed to the I/O routines... Unfortunately the compiler
* assumes that no temporaries can be of type CHARACTER and casually tosses
* length and type info away when removing TEMP blocks. This has been fixed...
* Revision 3.4 84/11/05 22:19:30 donn
* Fixed a silly bug in the last fix.
* Revision 3.3 84/10/29 08:15:23 donn
* Added code to check the type and shape of subscript declarations,
* per Jerry Berkman's suggestion.
* Revision 3.2 84/10/29 05:52:07 donn
* Added change suggested by Jerry Berkman to report an error when an array
* Revision 3.1 84/10/13 02:12:31 donn
* Merged Jerry Berkman's version into mine.
* Revision 2.1 84/07/19 12:04:09 donn
* Changed comment headers for UofU.
* Revision 1.6 84/07/19 11:32:15 donn
* Incorporated fix to setbound() to detect backward array subscript limits.
* The fix is by Bob Corbett, donated by Jerry Berkman.
* Revision 1.5 84/07/18 18:25:50 donn
* Fixed problem with doentry() where a placeholder for a return value
* was not allocated if the first entry didn't require one but a later
* Revision 1.4 84/05/24 20:52:09 donn
* Installed firewall #ifdef around the code that recycles stack temporaries,
* since it seems to be broken and lacks a good fix for the time being.
* Revision 1.3 84/04/16 09:50:46 donn
* Fixed mkargtemp() so that it only passes back a copy of a temporary, keeping
* the original for its own use. This fixes a set of bugs that are caused by
* elements in the argtemplist getting stomped on.
* Revision 1.2 84/02/28 21:12:58 donn
* Added Berkeley changes for subroutine call argument temporaries fix.
LOCAL sizelist
*varsizes
;
/* start a new procedure */
execerr("missing end statement", CNULL
);
procclass
= CLMAIN
; /* default */
/* end of procedure. generate variables, epilogs, and prologs */
err("DO loop or BLOCK IF not closed");
for(lp
= labeltab
; lp
< labtabend
; ++lp
)
if(lp
->stateno
!=0 && lp
->labdefined
==NO
)
errstr("missing statement number %s", convic(lp
->stateno
) );
procinit(); /* clean up for next procedure */
/* End of declaration section of procedure. Allocate storage. */
register struct Entrypoint
*ep
;
for(ep
= entries
; ep
; ep
= ep
->entnextp
) {
/* ROUTINES CALLED WHEN ENCOUNTERING ENTRY POINTS */
/* Main program or Block data */
startproc(prgname
, class)
register struct Entrypoint
*p
;
procname
= prgname
->varname
;
fprintf(diagfile
, " %s", (class==CLMAIN
? "MAIN" : "BLOCK DATA") );
fprintf(diagfile
, " %s", varstr(XL
, procname
) );
fprintf(diagfile
, ":\n");
progname
= newentry( prgname
);
puthead("MAIN_", CLMAIN
);
newentry( mkname(5, "MAIN") );
p
->entrylabel
= newlabel();
/* subroutine or function statement */
struct Extsym
*newentry(v
)
register struct Extsym
*p
;
p
= mkext( varunder(VL
, v
->varname
) );
if(p
==NULL
|| p
->extinit
|| ! ONEOF(p
->extstg
, M(STGUNKNOWN
)|M(STGEXT
)) )
dclerr("invalid entry name", v
);
else dclerr("external name already used", v
);
v
->vprocclass
= PTHISPROC
;
entrypt(class, type
, length
, entname
, args
)
register struct Entrypoint
*p
, *ep
;
fprintf(diagfile
, " entry ");
fprintf(diagfile
, " %s", varstr(XL
, entname
->varname
) );
fprintf(diagfile
, ":\n");
if( entname
->vclass
== CLPARAM
) {
errstr("entry name %s used in 'parameter' statement",
varstr(XL
, entname
->varname
) );
if( ((type
== TYSUBR
) || (class == CLENTRY
&& proctype
== TYSUBR
))
&& (entname
->vtype
!= TYUNKNOWN
&& entname
->vtype
!= TYSUBR
) ) {
errstr("subroutine entry %s previously declared",
varstr(XL
, entname
->varname
) );
if( (entname
->vstg
!= STGEXT
&& entname
->vstg
!= STGUNKNOWN
)
|| (entname
->vdim
!= NULL
) ) {
errstr("subroutine or function entry %s previously declared",
varstr(XL
, entname
->varname
) );
if( (class == CLPROC
|| class == CLENTRY
) && type
!= TYSUBR
)
/* arrange to save function return values */
entry
= newentry( entname
);
puthead( varstr(XL
, procname
= entry
->extname
), class);
q
= mkname(VL
, nounder(XL
,entry
->extname
) );
if( (type
= lengtype(type
, (int) length
)) != TYCHAR
)
if(entries
) /* put new block at end of entries list */
for(ep
= entries
; ep
->entnextp
; ep
= ep
->entnextp
)
p
->entrylabel
= newlabel();
q
->vprocclass
= PTHISPROC
;
settype(q
, type
, (int) length
);
/* hold all initial entry points till end of declarations */
{ /* may need to preserve CLENTRY here */
putforce(TYINT
, ICON(0) );
typeaddr
= autovar(1, TYADDR
, PNULL
);
putbranch( cpexpr(typeaddr
) );
for(i
= 0; i
< NTYPES
; ++i
)
else if(procclass
!= CLBLOCK
)
/* generate code to return value of type t */
p
= (Addrp
) cpexpr(retslot
);
p
= (Addrp
) cpexpr(retslot
);
return; /* someone else already complained */
/* Allocate extra argument array if needed. Generate prologs. */
register struct Entrypoint
*p
;
argvec
= autovar(lastargslot
/SZADDR
, TYADDR
, PNULL
);
if(lastargslot
>0 && nentry
>1)
argvec
= autovar(1 + lastargslot
/SZADDR
, TYADDR
, PNULL
);
argvec
= autovar(lastargslot
/SZADDR
, TYADDR
, PNULL
);
for(p
= entries
; p
; p
= p
->entnextp
)
* manipulate argument lists (allocate argument slot positions)
* keep track of return types and labels
optbuff (SKLABEL
, 0, ep
->entrylabel
, 0);
putlabel(ep
->entrylabel
);
else if(procclass
== CLBLOCK
)
impldcl( np
= mkname(VL
, nounder(XL
, ep
->entryname
->extname
) ) );
if(proctype
== TYUNKNOWN
)
if( (proctype
= type
) == TYCHAR
)
procleng
= (np
->vleng
? np
->vleng
->constblock
.constant
.ci
: (ftnint
) (-1));
err("noncharacter entry of character function");
else if( (np
->vleng
? np
->vleng
->constblock
.constant
.ci
: (ftnint
) (-1)) != procleng
)
err("mismatched character entry lengths");
err("character entry of noncharacter function");
else if(type
!= proctype
)
rtvlabel
[type
] = newlabel();
ep
->typelabel
= rtvlabel
[type
];
chslot
= nextarg(TYADDR
);
chlgslot
= nextarg(TYLENG
);
np
->vardesc
.varno
= chslot
;
np
->vleng
= (expptr
) mkarg(TYLENG
, chlgslot
);
else if( ISCOMPLEX(type
) )
cxslot
= nextarg(TYADDR
);
np
->vardesc
.varno
= cxslot
;
retslot
= autovar(1, TYDREAL
, PNULL
);
np
->voffset
= retslot
->memoffset
->constblock
.constant
.ci
;
for(p
= ep
->arglist
; p
; p
= p
->nextp
)
if(! (( q
= (Namep
) (p
->datap
) )->vdcldone
) )
q
->vardesc
.varno
= nextarg(TYADDR
);
for(p
= ep
->arglist
; p
; p
= p
->nextp
)
if(! (( q
= (Namep
) (p
->datap
) )->vdcldone
) )
if(q
->vclass
== CLPROC
&& q
->vtype
== TYUNKNOWN
)
if(q
->vleng
== NULL
) /* character*(*) */
mkarg(TYLENG
, nextarg(TYLENG
) );
else if(q
->vclass
==CLPROC
&& nentry
==1)
optbuff (SKLABEL
, 0, ep
->entrylabel
, 0);
putlabel(ep
->entrylabel
);
lastargslot
+= typesize
[type
];
/* generate variable references */
register struct Hashentry
*p
;
for(p
= hashtab
; p
<lasthash
; ++p
)
if( (qclass
==CLUNKNOWN
&& qstg
!=STGARG
) ||
(qclass
==CLVAR
&& qstg
==STGUNKNOWN
) )
warn1("local variable %s never used", varstr(VL
,q
->varname
) );
else if(qclass
==CLPROC
&& q
->vprocclass
==PEXTERNAL
&& qstg
!=STGARG
)
mkext(varunder(VL
, q
->varname
)) ->extstg
= STGEXT
;
if (qclass
== CLVAR
&& qstg
== STGBSS
)
if (SMALLVAR(q
->varsize
))
enlist(q
->varsize
, q
, NULL
);
prlocvar(memname(qstg
, q
->vardesc
.varno
), q
->varsize
);
prlocdata(memname(qstg
, q
->vardesc
.varno
), q
->varsize
,
q
->vtype
, q
->initoffset
, &(q
->inlcomm
));
else if(qclass
==CLVAR
&& qstg
!=STGARG
)
if(q
->vdim
&& !ISICON(q
->vdim
->nelt
) )
dclerr("adjustable dimension on non-argument", q
);
if(qtype
==TYCHAR
&& (q
->vleng
==NULL
|| !ISICON(q
->vleng
)))
dclerr("adjustable leng on nonargument", q
);
for (i
= 0 ; i
< nequiv
; ++i
)
if ( (leng
= eqvclass
[i
].eqvleng
) != 0 )
enlist(leng
, NULL
, eqvclass
+ i
);
else if (eqvclass
[i
].init
== NO
)
prlocvar(memname(STGEQUIV
, i
), leng
);
eqvclass
[i
].inlcomm
= YES
;
prlocdata(memname(STGEQUIV
, i
), leng
, TYDREAL
,
eqvclass
[i
].initoffset
, &(eqvclass
[i
].inlcomm
));
register struct Entrypoint
*ep
;
for (ep
= entries
; ep
; ep
= ep
->entnextp
)
for (cp
= ep
->arglist
; cp
; cp
= cp
->nextp
)
if ((q
= (Namep
) cp
->datap
) && q
->vstg
== STGARG
) {
for (p
= hashtab
; p
<lasthash
; ++p
) if(q
= p
->varp
) {
if (q
->vtype
== TYUNKNOWN
|| q
->vtype
== TYERROR
)
if ( ONEOF(qclass
, M(CLVAR
)|M(CLPARAM
)|M(CLPROC
)) ) {
if (! ONEOF(qstg
,M(STGCOMMON
)|M(STGARG
) ) )
register struct Hashentry
*p
;
for(p
=hashtab
; p
<lasthash
; ++p
)
if( (q
= p
->varp
) && q
->vclass
==CLNAMELIST
)
for(p
= extsymtab
; p
<nextext
; ++p
)
leng
= typesize
[q
->vtype
];
if( ISICON(q
->vdim
->nelt
) )
leng
*= q
->vdim
->nelt
->constblock
.constant
.ci
;
leng
*= q
->vleng
->constblock
.constant
.ci
;
/* This routine creates a static block representing the namelist.
An equivalent declaration of the structure produced is:
char varname[16]; # 16 plus null padding -> 20
short int len; # length of type
struct dimensions *dimp; # null means scalar
int span[numberofdimensions];
where the namelistentry list terminates with a null varname
If dimp is not null, then the corner element of the array is at
varaddr. However, the element with subscripts (i1,...,in) is at
varaddr - dimp->baseoffset + sizeoftype * (i1+span[0]*(i2+span[1]*...)
register struct Dimblock
*dp
;
int type
, dimno
, dimoffset
;
fprintf(asmfile
, LABELFMT
, memname(STGINIT
, np
->vardesc
.varno
));
putstr(asmfile
, varstr(VL
, np
->varname
), 16);
for(q
= np
->varxptr
.namelist
; q
; q
= q
->nextp
)
vardcl( v
= (Namep
) (q
->datap
) );
if( ONEOF(v
->vstg
, MSKSTATIC
) )
putstr(asmfile
, varstr(VL
,v
->varname
), 16);
praddr(asmfile
, v
->vstg
, v
->vardesc
.varno
, v
->voffset
);
prconi(asmfile
, TYSHORT
, type
);
(v
->vleng
->constblock
.constant
.ci
) :
(ftnint
) typesize
[type
]);
praddr(asmfile
, STGINIT
, dimno
, (ftnint
)dimoffset
);
dimoffset
+= (3 + v
->vdim
->ndim
) * SZINT
;
praddr(asmfile
, STGNULL
,0,(ftnint
) 0);
dclerr("may not appear in namelist", v
);
fprintf(asmfile
, LABELFMT
, memname(STGINIT
,dimno
));
for(q
= np
->varxptr
.namelist
; q
; q
= q
->nextp
)
if(dp
= q
->datap
->nameblock
.vdim
)
prconi(asmfile
, TYINT
, (ftnint
) (dp
->ndim
) );
(ftnint
) (dp
->nelt
->constblock
.constant
.ci
) );
(ftnint
) (dp
->baseoffset
->constblock
.constant
.ci
));
for(i
=0; i
<dp
->ndim
; ++i
)
dp
->dims
[i
].dimsize
->constblock
.constant
.ci
);
register struct Extsym
*p
;
for(p
= extsymtab
; p
<nextext
; ++p
)
prstab(varstr(XL
,p
->extname
), N_BCOMM
, 0, 0);
for(q
= p
->extp
; q
; q
= q
->nextp
)
if(p
->extleng
% typealign
[type
] != 0)
dclerr("common alignment", v
);
p
->extleng
= roundup(p
->extleng
, typealign
[type
]);
v
->vardesc
.varno
= p
- extsymtab
;
size
= v
->vleng
->constblock
.constant
.ci
;
else size
= typesize
[type
];
if( (neltp
= t
->nelt
) && ISCONST(neltp
) )
size
*= neltp
->constblock
.constant
.ci
;
dclerr("adjustable array in common", v
);
prstab(varstr(XL
,p
->extname
), N_ECOMM
, 0, 0);
register struct Extsym
*p
;
for(p
= extsymtab
; p
< nextext
; ++p
)
if(p
->extstg
== STGCOMMON
)
if(p
->maxleng
!=0 && p
->extleng
!=0 && p
->maxleng
!=p
->extleng
&& !eqn(XL
,"_BLNK__ ",p
->extname
) )
warn1("incompatible lengths for common block %s",
nounder(XL
, p
->extname
) );
if(p
->maxleng
< p
->extleng
)
/* ROUTINES DEALING WITH AUTOMATIC AND TEMPORARY STORAGE */
/* frees a temporary block */
badtag ("frtemp",p
->tag
);
/* restore clobbered character string lengths */
if(t
->vtype
==TYCHAR
&& t
->varleng
!=0)
t
->vleng
= ICON(t
->varleng
);
/* put block on chain of temps to be reclaimed */
holdtemps
= mkchain(t
, holdtemps
);
/* allocate an automatic variable slot */
Addrp
autovar(nelt
, t
, lengp
)
leng
= lengp
->constblock
.constant
.ci
;
fatal("automatic variable of nonconstant length");
autoleng
= roundup( autoleng
, typealign
[t
]);
#if TARGET==PDP11 || TARGET==VAX
/* stack grows downward */
q
->memoffset
= ICON( - autoleng
);
q
->memoffset
= ICON( autoleng
);
* create a temporary block (TTEMP) when optimizing,
* an ordinary TADDR block when not optimizing
Tempp
mktmpn(nelt
, type
, lengp
)
return ( (Tempp
) mkaltmpn(nelt
,type
,lengp
) );
if(type
==TYUNKNOWN
|| type
==TYERROR
)
leng
= lengp
->constblock
.constant
.ci
;
err("adjustable length");
return( (Tempp
) errnode() );
altemp
= ALLOC(Addrblock
);
altemp
->vstg
= STGUNKNOWN
;
Addrp
mktemp(type
, lengp
)
return( (Addrp
) mktmpn(1,type
,lengp
) );
/* allocate a temporary location for the given temporary block;
if already allocated, return its location */
badtag ("altmpn",tp
->tag
);
if (t
->vstg
!= STGUNKNOWN
)
* Unformatted I/O parameters are treated like character
* strings (sigh) -- propagate type and length.
t
->varleng
= tp
->varleng
;
q
= mkaltmpn (tp
->ntempelt
, tp
->vtype
, tp
->vleng
);
cpn (sizeof(struct Addrblock
), (char*)q
, (char*)t
);
/* create and allocate space immediately for a temporary */
Addrp
mkaltemp(type
,lengp
)
return (mkaltmpn(1,type
,lengp
));
Addrp
mkaltmpn(nelt
,type
,lengp
)
if(type
==TYUNKNOWN
|| type
==TYERROR
)
badtype("mkaltmpn", type
);
leng
= lengp
->constblock
.constant
.ci
;
err("adjustable length");
return( (Addrp
) errnode() );
* if a temporary of appropriate shape is on the templist,
* remove it from the list and return it
* This code is broken until SKFRTEMP slots can be processed in putopt()
* instead of in optimize() -- all kinds of things in putpcc.c can
* bomb because of this. Sigh.
for(oldp
=CHNULL
, p
=templist
; p
; oldp
=p
, p
=p
->nextp
)
if(q
->vtype
==type
&& q
->ntempelt
==nelt
&&
(type
!=TYCHAR
|| q
->vleng
->constblock
.constant
.ci
==leng
) )
fprintf(diagfile
,"mkaltmpn reusing offset %d\n",
q
->memoffset
->constblock
.constant
.ci
);
q
= autovar(nelt
, type
, lengp
);
fprintf(diagfile
,"mkaltmpn new offset %d\n",
q
->memoffset
->constblock
.constant
.ci
);
/* The following routine is a patch which is only needed because the */
/* code for processing actual arguments for calls does not allocate */
/* the temps it needs before optimization takes place. A better */
/* solution is possible, but I do not have the time to implement it */
if (type
== TYUNKNOWN
|| type
== TYERROR
)
badtype("mkargtemp", type
);
leng
= lengp
->constblock
.constant
.ci
;
err("adjustable length");
return ((Addrp
) errnode());
&& (type
!= TYCHAR
|| q
->vleng
->constblock
.constant
.ci
== leng
))
p
->nextp
= activearglist
;
return ((Addrp
) cpexpr(q
));
q
= autovar(1, type
, lengp
);
activearglist
= mkchain(q
, activearglist
);
return ((Addrp
) cpexpr(q
));
/* VARIOUS ROUTINES FOR PROCESSING DECLARATIONS */
struct Extsym
*comblock(len
, s
)
p
= mkext( varunder(len
, s
) );
if(p
->extstg
== STGUNKNOWN
)
else if(p
->extstg
!= STGCOMMON
)
errstr("%s cannot be a common block name", s
);
if(v
->vstg
!= STGUNKNOWN
)
dclerr("incompatible common declaration", v
);
if(c
== (struct Extsym
*) 0)
return; /* Illegal common block name upstream */
c
->extp
= hookup(c
->extp
, mkchain(v
,CHNULL
) );
if(type
==TYSUBR
&& v
->vtype
!=TYUNKNOWN
&& v
->vstg
==STGARG
)
else if(type
< 0) /* storage class set */
if(v
->vstg
== STGUNKNOWN
)
else if(v
->vstg
!= -type
)
dclerr("incompatible storage declarations", v
);
else if(v
->vtype
== TYUNKNOWN
)
if( (v
->vtype
= lengtype(type
, length
))==TYCHAR
)
else if(!(v
->vstg
== STGARG
|| v
->vclass
== CLENTRY
||
(v
->vclass
== CLPROC
&& v
->vprocclass
== PTHISPROC
)))
dclerr("illegal adjustable length character variable", v
);
else if(v
->vtype
!=type
|| (type
==TYCHAR
&& v
->vleng
->constblock
.constant
.ci
!=length
) )
dclerr("incompatible type declarations", v
);
if(length
== typesize
[TYLOGICAL
])
badtype("lengtype", type
);
err("incompatible type-length combination");
if(v
->vstg
== STGUNKNOWN
)
else if(v
->vstg
!=STGINTR
)
dclerr("incompatible use of intrinsic function", v
);
if(v
->vprocclass
== PUNKNOWN
)
v
->vprocclass
= PINTRINSIC
;
else if(v
->vprocclass
!= PINTRINSIC
)
dclerr("invalid intrinsic declaration", v
);
if(k
= intrfunct(v
->varname
))
dclerr("unknown intrinsic function", v
);
if(v
->vclass
== CLUNKNOWN
)
else if(v
->vclass
!= CLPROC
)
dclerr("conflicting declarations", v
);
if(v
->vprocclass
== PUNKNOWN
)
v
->vprocclass
= PEXTERNAL
;
else if(v
->vprocclass
!= PEXTERNAL
)
dclerr("conflicting declarations", v
);
/* create dimensions block for array variable */
struct { expptr lb
, ub
; } dims
[ ];
register struct Dimblock
*p
;
if(v
->vclass
== CLUNKNOWN
)
else if(v
->vclass
!= CLVAR
)
dclerr("only variables may be arrays", v
);
dclerr("redimensioned array", v
);
v
->vdim
= p
= (struct Dimblock
*)
ckalloc( sizeof(int) + (3+6*nd
)*sizeof(expptr
) );
/* Save the bounds trees built up by the grammar routines for use in stabs */
if(dims
[i
].lb
== NULL
) p
->dims
[i
].lb
=ICON(1);
else p
->dims
[i
].lb
= (expptr
) cpexpr(dims
[i
].lb
);
if(ISCONST(p
->dims
[i
].lb
)) p
->dims
[i
].lbaddr
= (expptr
) PNULL
;
else p
->dims
[i
].lbaddr
= (expptr
) autovar(1, tyint
, PNULL
);
if(dims
[i
].ub
== NULL
) p
->dims
[i
].ub
=ICON(1);
else p
->dims
[i
].ub
= (expptr
) cpexpr(dims
[i
].ub
);
if(ISCONST(p
->dims
[i
].ub
)) p
->dims
[i
].ubaddr
= (expptr
) PNULL
;
else p
->dims
[i
].ubaddr
= (expptr
) autovar(1, tyint
, PNULL
);
if( (q
= dims
[i
].ub
) == NULL
)
err("only last bound may be asterisk");
p
->dims
[i
].dimsize
= ICON(1);;
p
->dims
[i
].dimexpr
= NULL
;
q
= mkexpr(OPMINUS
, q
, cpexpr(dims
[i
].lb
));
q
= mkexpr(OPPLUS
, q
, ICON(1) );
if (!ISINT(q
->headblock
.vtype
)) {
dclerr("dimension bounds must be integer expression", v
);
if ( q
->constblock
.constant
.ci
<= 0)
dclerr("array bounds out of sequence", v
);
p
->dims
[i
].dimexpr
= (expptr
) PNULL
;
p
->dims
[i
].dimsize
= (expptr
) autovar(1, tyint
, PNULL
);
p
->nelt
= mkexpr(OPSTAR
, p
->nelt
,
cpexpr(p
->dims
[i
].dimsize
) );
for(i
= nd
-2 ; i
>=0 ; --i
)
q
= mkexpr(OPPLUS
, t
, mkexpr(OPSTAR
, cpexpr(p
->dims
[i
].dimsize
), q
) );
p
->baseoffset
= (expptr
) autovar(1, tyint
, PNULL
);
* Check the dimensions of q to ensure that they are appropriately defined.
register struct Dimblock
*p
;
for (i
= 0; i
< p
->ndim
; ++i
)
if (e
= p
->dims
[i
].dimexpr
)
* The actual checking for chkdim() -- examines each expression.
e
= fixtype(cpexpr(expr
));
if (!ISINT(e
->exprblock
.vtype
))
dclerr("non-integer dimension", q
);
dclerr("undefined dimension", q
);
* A recursive routine to find undefined variables in dimension expressions.
if (e
->exprblock
.opcode
== OPCALL
|| e
->exprblock
.opcode
== OPCCALL
)
return safedim(e
->exprblock
.leftp
) && safedim(e
->exprblock
.rightp
);
switch (e
->addrblock
.vstg
)
if (e
->addrblock
.isarray
)
return safedim(e
->addrblock
.memoffset
);
LOCAL
enlist(size
, np
, ep
)
if (sp
->next
!= NULL
&& sp
->next
->size
<= size
)
register varlist
*first
, *last
;
register varlist
*vp
, *t
;
register sizelist
*sp
, *sp1
;
register struct Equivblock
*ep
;
sprintf(setbuff
, "\t.set\tv.%d,v.%d\n", bsslabel
,
sprintf(setbuff
, "\t.set\tv.%d,q.%d\n", bsslabel
, i
+ eqvstart
);
sprintf(sname
, "v.%d", np
->vardesc
.varno
);
prlocdata(sname
, np
->varsize
, np
->vtype
, np
->initoffset
,
pralign(typealign
[np
->vtype
]);
fprintf(initfile
, "%s:\n", sname
);
else if (ep
->eqvleng
>= 4)
else if (ep
->eqvleng
>= 2)
sprintf(sname
, "q.%d", i
+ eqvstart
);
prlocdata(sname
, ep
->eqvleng
, type
, ep
->initoffset
,
pralign(typealign
[type
]);
fprintf(initfile
, "%s:\n", sname
);
fprintf(initfile
, "%s\n", setbuff
);