retval(register int t)
#endif
{
register Addrp p;
switch(t)
{
case TYCHAR:
case TYCOMPLEX:
case TYDCOMPLEX:
break;
case TYLOGICAL:
t = tylogical;
case TYINT1:
case TYADDR:
case TYSHORT:
case TYLONG:
#ifdef TYQUAD
case TYQUAD:
#endif
case TYREAL:
case TYDREAL:
case TYLOGICAL1:
case TYLOGICAL2:
p = (Addrp) cpexpr((expptr)retslot);
p->vtype = t;
p1_subr_ret (mkconv (t, fixtype((expptr)p)));
break;
default:
badtype("retval", t);
}
}
mktmpn(int nelt, register int type, expptr lengp)
#endif
{
ftnint leng;
chainp p, oldp;
register Addrp q;
extern int krparens;
if(type==TYUNKNOWN || type==TYERROR)
badtype("mktmpn", type);
if(type==TYCHAR)
if(lengp && ISICON(lengp) )
leng = lengp->constblock.Const.ci;
else {
err("adjustable length");
return( (Addrp) errnode() );
}
else if (type > TYCHAR || type < TYADDR) {
erri("mktmpn: unexpected type %d", type);
exit(1);
}
/*
* if a temporary of appropriate shape is on the templist,
* remove it from the list and return it
*/
if (krparens == 2 && ONEOF(type,M(TYREAL)|M(TYCOMPLEX)))
type++;
for(oldp=CHNULL, p=templist[type]; p ; oldp=p, p=p->nextp)
{
q = (Addrp) (p->datap);
if(q->ntempelt==nelt &&
(type!=TYCHAR || q->vleng->constblock.Const.ci==leng) )
{
if(oldp)
oldp->nextp = p->nextp;
else
templist[type] = p->nextp;
free( (charptr) p);
return(q);
}
}
q = autovar(nelt, type, lengp, "");
return(q);
}
setdata(register Addrp varp, register Constp valp, ftnint elen)
#endif
{
struct Constblock con;
register int type;
int i, k, valtype;
ftnint offset;
char *varname;
static Addrp badvar;
register unsigned char *s;
static int last_lineno;
static char *last_varname;
if (varp->vstg == STGCOMMON) {
if (!(dfile = blkdfile))
dfile = blkdfile = opf(blkdfname, textwrite);
}
else {
if (procclass == CLBLOCK) {
if (varp != badvar) {
badvar = varp;
warn1("%s is not in a COMMON block",
varp->uname_tag == UNAM_NAME
? varp->user.name->fvarname
: "???");
}
return;
}
if (!(dfile = initfile))
dfile = initfile = opf(initfname, textwrite);
}
varname = dataname(varp->vstg, varp->memno);
offset = varp->memoffset->constblock.Const.ci;
type = varp->vtype;
valtype = valp->vtype;
if(type!=TYCHAR && valtype==TYCHAR)
{
if(! ftn66flag
&& (last_varname != cur_varname || last_lineno != lineno)) {
/* prevent multiple warnings */
last_lineno = lineno;
warn1(
"non-character datum %.42s initialized with character string",
last_varname = cur_varname);
}
varp->vleng = ICON(typesize[type]);
varp->vtype = type = TYCHAR;
}
else if( (type==TYCHAR && valtype!=TYCHAR) ||
(cktype(OPASSIGN,type,valtype) == TYERROR) )
{
err("incompatible types in initialization");
return;
}
if(type == TYADDR)
con.Const.ci = valp->Const.ci;
else if(type != TYCHAR)
{
if(valtype == TYUNKNOWN)
con.Const.ci = valp->Const.ci;
else consconv(type, &con, valp);
}
k = 1;
switch(type)
{
case TYLOGICAL:
case TYINT1:
case TYLOGICAL1:
case TYLOGICAL2:
case TYSHORT:
case TYLONG:
#ifdef TYQUAD
case TYQUAD:
#endif
dataline(varname, offset, type);
prconi(dfile, con.Const.ci);
break;
case TYADDR:
dataline(varname, offset, type);
prcona(dfile, con.Const.ci);
break;
case TYCOMPLEX:
case TYDCOMPLEX:
k = 2;
case TYREAL:
case TYDREAL:
dataline(varname, offset, type);
prconr(dfile, &con, k);
break;
case TYCHAR:
k = valp -> vleng -> constblock.Const.ci;
if (elen < k)
k = elen;
s = (unsigned char *)valp->Const.ccp;
for(i = 0 ; i < k ; ++i) {
dataline(varname, offset++, TYCHAR);
fprintf(dfile, "\t%d\n", *s++);
}
k = elen - valp->vleng->constblock.Const.ci;
if(k > 0) {
dataline(varname, offset, TYBLANK);
fprintf(dfile, "\t%d\n", k);
}
break;
default:
badtype("setdata", type);
}
}
putconst(register Constp p)
#endif
{
register Addrp q;
struct Literal *litp, *lastlit;
int k, len, type;
int litflavor;
double cd[2];
ftnint nblanks;
char *strp;
char cdsbuf0[64], cdsbuf1[64], *ds[2];
if (p->tag != TCONST)
badtag("putconst", p->tag);
q = ALLOC(Addrblock);
q->tag = TADDR;
type = p->vtype;
q->vtype = ( type==TYADDR ? tyint : type );
q->vleng = (expptr) cpexpr(p->vleng);
q->vstg = STGCONST;
/* Create the new label for the constant. This is wasteful of labels
because when the constant value already exists in the literal pool,
this label gets thrown away and is never reclaimed. It might be
cleaner to move this down past the first switch() statement below */
q->memno = newlabel();
q->memoffset = ICON(0);
q -> uname_tag = UNAM_CONST;
/* Copy the constant info into the Addrblock; do this by copying the
largest storage elts */
q -> user.Const = p -> Const;
q->user.kludge.vstg1 = p->vstg; /* distinguish string from binary fp */
/* check for value in literal pool, and update pool if necessary */
k = 1;
switch(type)
{
case TYCHAR:
if (halign) {
strp = p->Const.ccp;
nblanks = p->Const.ccp1.blanks;
len = p->vleng->constblock.Const.ci;
litflavor = LIT_CHAR;
goto loop;
}
else
q->memno = BAD_MEMNO;
break;
case TYCOMPLEX:
case TYDCOMPLEX:
k = 2;
if (p->vstg)
cd[1] = atof(ds[1] = p->Const.cds[1]);
else
ds[1] = cds(dtos(cd[1] = p->Const.cd[1]), cdsbuf1);
case TYREAL:
case TYDREAL:
litflavor = LIT_FLOAT;
if (p->vstg)
cd[0] = atof(ds[0] = p->Const.cds[0]);
else
ds[0] = cds(dtos(cd[0] = p->Const.cd[0]), cdsbuf0);
goto loop;
case TYLOGICAL1:
case TYLOGICAL2:
case TYLOGICAL:
type = tylogical;
goto lit_int_flavor;
case TYLONG:
type = tyint;
case TYSHORT:
case TYINT1:
#ifdef TYQUAD
case TYQUAD:
#endif
lit_int_flavor:
litflavor = LIT_INT;
/* Scan the literal pool for this constant value. If this same constant
has been assigned before, use the same label. Note that this routine
does NOT consider two differently-typed constants with the same bit
pattern to be the same constant */
loop:
lastlit = litpool + nliterals;
for(litp = litpool ; litp<lastlit ; ++litp)
/* Remove this type checking to ensure that all bit patterns are reused */
if(type == litp->littype) switch(litflavor)
{
case LIT_CHAR:
if (len == (int)litp->litval.litival2[0]
&& nblanks == litp->litval.litival2[1]
&& !memcmp(strp, litp->cds[0], len)) {
q->memno = litp->litnum;
frexpr((expptr)p);
q->user.Const.ccp1.ccp0 = litp->cds[0];
return(q);
}
break;
case LIT_FLOAT:
if(cd[0] == litp->litval.litdval[0]
&& !strcmp(ds[0], litp->cds[0])
&& (k == 1 ||
cd[1] == litp->litval.litdval[1]
&& !strcmp(ds[1], litp->cds[1]))) {
ret:
q->memno = litp->litnum;
frexpr((expptr)p);
return(q);
}
break;
case LIT_INT:
if(p->Const.ci == litp->litval.litival)
goto ret;
break;
}
/* If there's room in the literal pool, add this new value to the pool */
if(nliterals < maxliterals)
{
++nliterals;
/* litp now points to the next free elt */
litp->littype = type;
litp->litnum = q->memno;
switch(litflavor)
{
case LIT_CHAR:
litp->litval.litival2[0] = len;
litp->litval.litival2[1] = nblanks;
q->user.Const.ccp = litp->cds[0] =
memcpy(gmem(len,0), strp, len);
break;
case LIT_FLOAT:
litp->litval.litdval[0] = cd[0];
litp->cds[0] = copys(ds[0]);
if (k == 2) {
litp->litval.litdval[1] = cd[1];
litp->cds[1] = copys(ds[1]);
}
break;
case LIT_INT:
litp->litval.litival = p->Const.ci;
break;
} /* switch (litflavor) */
}
else
many("literal constants", 'L', maxliterals);
break;
case TYADDR:
break;
default:
badtype ("putconst", p -> vtype);
break;
} /* switch */
if (type != TYCHAR || halign)
frexpr((expptr)p);
return( q );
}
lengtype(register int type, ftnint len)
#endif
{
register int length = (int)len;
switch(type)
{
case TYREAL:
if(length == typesize[TYDREAL])
return(TYDREAL);
if(length == typesize[TYREAL])
goto ret;
break;
case TYCOMPLEX:
if(length == typesize[TYDCOMPLEX])
return(TYDCOMPLEX);
if(length == typesize[TYCOMPLEX])
goto ret;
break;
case TYINT1:
case TYSHORT:
case TYDREAL:
case TYDCOMPLEX:
case TYCHAR:
case TYLOGICAL1:
case TYLOGICAL2:
case TYUNKNOWN:
case TYSUBR:
case TYERROR:
#ifdef TYQUAD
case TYQUAD:
#endif
goto ret;
case TYLOGICAL:
switch(length) {
case 0: return tylog;
case 1: return TYLOGICAL1;
case 2: return TYLOGICAL2;
case 4: goto ret;
}
break;
case TYLONG:
if(length == 0)
return(tyint);
if (length == 1)
return TYINT1;
if(length == typesize[TYSHORT])
return(TYSHORT);
#ifdef TYQUAD
if(length == typesize[TYQUAD] && use_tyquad)
return(TYQUAD);
#endif
if(length == typesize[TYLONG])
goto ret;
break;
default:
badtype("lengtype", type);
}
if(len != 0)
err("incompatible type-length combination");
ret:
return(type);
}
