mkintqcon(int n, char *s)
#endif
{
#ifdef NO_LONG_LONG
return mkintcon(convci(n, s));
#else
#ifndef LLONG_MAX
#ifdef LONGLONG_MAX
#define LLONG_MAX LONGLONG_MAX
#else
#define LLONG_MAX 0x7fffffffffffffffLL
#endif
#endif
Constp p;
Llong sum, t;
char *s0;
int n0, warned = 0;
s0 = s;
n0 = n;
sum = 0;
while(n-- > 0) {
/* sum = 10*sum + (*s++ - '0'); */
t = *s++ - '0';
if (sum > LLONG_MAX/10) {
ovfl:
warned = int_trunc(n0,s0);
sum = LLONG_MAX;
break;
}
sum *= 10;
if (sum > LLONG_MAX - t)
goto ovfl;
sum += t;
}
p = mkconst(tyint);
if (sum > LONG_MAX) {
if (allow_i8c) {
p->vtype = TYQUAD;
p->Const.cq = sum;
}
else {
p->Const.ci = LONG_MAX;
if (!warned)
int_trunc(n0,s0);
}
}
else
p->Const.ci = (ftnint) sum;
return (tagptr)p;
#endif
}
nextdata(ftnint *elenp)
#endif
{
register struct Impldoblock *ip;
struct Primblock *pp;
register Namep np;
register struct Rplblock *rp;
tagptr p;
expptr neltp;
register expptr q;
int skip;
ftnint off, vlen;
while(curdtp)
{
p = (tagptr)curdtp->datap;
if(p->tag == TIMPLDO)
{
ip = &(p->impldoblock);
if(ip->implb==NULL || ip->impub==NULL || ip->varnp==NULL)
fatali("bad impldoblock 0%o", (int) ip);
if(ip->isactive)
ip->varvp->Const.ci += ip->impdiff;
else
{
q = fixtype(cpexpr(ip->implb));
if( ! ISICON(q) )
goto doerr;
ip->varvp = (Constp) q;
if(ip->impstep)
{
q = fixtype(cpexpr(ip->impstep));
if( ! ISICON(q) )
goto doerr;
ip->impdiff = q->constblock.Const.ci;
frexpr(q);
}
else
ip->impdiff = 1;
q = fixtype(cpexpr(ip->impub));
if(! ISICON(q))
goto doerr;
ip->implim = q->constblock.Const.ci;
frexpr(q);
ip->isactive = YES;
rp = ALLOC(Rplblock);
rp->rplnextp = rpllist;
rpllist = rp;
rp->rplnp = ip->varnp;
rp->rplvp = (expptr) (ip->varvp);
rp->rpltag = TCONST;
}
if( (ip->impdiff>0 && (ip->varvp->Const.ci <= ip->implim))
|| (ip->impdiff<0 && (ip->varvp->Const.ci >= ip->implim)) )
{ /* start new loop */
curdtp = ip->datalist;
goto next;
}
/* clean up loop */
if(rpllist)
{
rp = rpllist;
rpllist = rpllist->rplnextp;
free( (charptr) rp);
}
else
Fatal("rpllist empty");
frexpr((expptr)ip->varvp);
ip->isactive = NO;
curdtp = curdtp->nextp;
goto next;
}
pp = (struct Primblock *) p;
np = pp->namep;
cur_varname = np->fvarname;
skip = YES;
if(p->primblock.argsp==NULL && np->vdim!=NULL)
{ /* array initialization */
q = (expptr) mkaddr(np);
off = typesize[np->vtype] * curdtelt;
if(np->vtype == TYCHAR)
off *= np->vleng->constblock.Const.ci;
q->addrblock.memoffset =
mkexpr(OPPLUS, q->addrblock.memoffset, mkintcon(off) );
if( (neltp = np->vdim->nelt) && ISCONST(neltp))
{
if(++curdtelt < neltp->constblock.Const.ci)
skip = NO;
}
else
err("attempt to initialize adjustable array");
}
else
q = mklhs((struct Primblock *)cpexpr((expptr)pp), 0);
if(skip)
{
curdtp = curdtp->nextp;
curdtelt = 0;
}
if(q->headblock.vtype == TYCHAR)
if(ISICON(q->headblock.vleng))
*elenp = q->headblock.vleng->constblock.Const.ci;
else {
err("initialization of string of nonconstant length");
continue;
}
else *elenp = typesize[q->headblock.vtype];
if (np->vstg == STGBSS) {
vlen = np->vtype==TYCHAR
? np->vleng->constblock.Const.ci
: typesize[np->vtype];
if(vlen > 0)
np->vstg = STGINIT;
}
return( (Addrp) q );
doerr:
err("nonconstant implied DO parameter");
frexpr(q);
curdtp = curdtp->nextp;
next:
curdtelt = 0;
}
return(NULL);
}
intrcall(Namep np, struct Listblock *argsp, int nargs)
#endif
{
int i, rettype;
Addrp ap;
register struct Specblock *sp;
register struct Chain *cp;
expptr q, ep;
int mtype;
int op;
int f1field, f2field, f3field;
packed.ijunk = np->vardesc.varno;
f1field = packed.bits.f1;
f2field = packed.bits.f2;
f3field = packed.bits.f3;
if(nargs == 0)
goto badnargs;
mtype = 0;
for(cp = argsp->listp ; cp ; cp = cp->nextp)
{
ep = (expptr)cp->datap;
if( ISCONST(ep) && ep->headblock.vtype==TYSHORT )
cp->datap = (char *) mkconv(tyint, ep);
mtype = maxtype(mtype, ep->headblock.vtype);
}
switch(f1field)
{
case INTRBOOL:
op = f3field;
if( ! ONEOF(mtype, MSKINT|MSKLOGICAL) )
goto badtype;
if(op == OPBITNOT)
{
if(nargs != 1)
goto badnargs;
q = mkexpr(OPBITNOT, (expptr)argsp->listp->datap, ENULL);
}
else
{
if(nargs != 2)
goto badnargs;
q = mkexpr(op, (expptr)argsp->listp->datap,
(expptr)argsp->listp->nextp->datap);
}
frchain( &(argsp->listp) );
free( (charptr) argsp);
return(q);
case INTRCONV:
rettype = f2field;
switch(rettype) {
case TYLONG:
rettype = tyint;
break;
case TYLOGICAL:
rettype = tylog;
}
if( ISCOMPLEX(rettype) && nargs==2)
{
expptr qr, qi;
qr = (expptr) argsp->listp->datap;
qi = (expptr) argsp->listp->nextp->datap;
if(ISCONST(qr) && ISCONST(qi))
q = mkcxcon(qr,qi);
else q = mkexpr(OPCONV,mkconv(rettype-2,qr),
mkconv(rettype-2,qi));
}
else if(nargs == 1) {
if (f3field && ((Exprp)argsp->listp->datap)->vtype
== TYDCOMPLEX)
rettype = TYDREAL;
q = mkconv(rettype+100, (expptr)argsp->listp->datap);
if (q->tag == TADDR)
q->addrblock.parenused = 1;
}
else goto badnargs;
q->headblock.vtype = rettype;
frchain(&(argsp->listp));
free( (charptr) argsp);
return(q);
#if 0
case INTRCNST:
/* Machine-dependent f77 stuff that f2c omits:
intcon contains
radix for short int
radix for long int
radix for single precision
radix for double precision
precision for short int
precision for long int
precision for single precision
precision for double precision
emin for single precision
emin for double precision
emax for single precision
emax for double prcision
largest short int
largest long int
realcon contains
tiny for single precision
tiny for double precision
huge for single precision
huge for double precision
mrsp (epsilon) for single precision
mrsp (epsilon) for double precision
*/
{ register struct Incstblock *cstp;
extern ftnint intcon[14];
extern double realcon[6];
cstp = consttab + f3field;
for(i=0 ; i<f2field ; ++i)
if(cstp->atype == mtype)
goto foundconst;
else
++cstp;
goto badtype;
foundconst:
switch(cstp->rtype)
{
case TYLONG:
return(mkintcon(intcon[cstp->constno]));
case TYREAL:
case TYDREAL:
return(mkrealcon(cstp->rtype,
realcon[cstp->constno]) );
default:
Fatal("impossible intrinsic constant");
}
}
#endif
case INTRGEN:
sp = spectab + f3field;
if(no66flag)
if(sp->atype == mtype)
goto specfunct;
else err66("generic function");
for(i=0; i<f2field ; ++i)
if(sp->atype == mtype)
goto specfunct;
else
++sp;
warn1 ("bad argument type to intrinsic %s", np->fvarname);
/* Made this a warning rather than an error so things like "log (5) ==>
log (5.0)" can be accommodated. When none of these cases matches, the
argument is cast up to the first type in the spectab list; this first
type is assumed to be the "smallest" type, e.g. REAL before DREAL
before COMPLEX, before DCOMPLEX */
sp = spectab + f3field;
mtype = sp -> atype;
goto specfunct;
case INTRSPEC:
sp = spectab + f3field;
specfunct:
if(tyint==TYLONG && ONEOF(sp->rtype,M(TYSHORT)|M(TYLOGICAL))
&& (sp+1)->atype==sp->atype)
++sp;
if(nargs != sp->nargs)
goto badnargs;
if(mtype != sp->atype)
goto badtype;
/* NOTE!! I moved fixargs (YES) into the ELSE branch so that constants in
the inline expression wouldn't get put into the constant table */
fixargs (NO, argsp);
cast_args (mtype, argsp -> listp);
if(q = Inline((int)(sp-spectab), mtype, argsp->listp))
{
frchain( &(argsp->listp) );
free( (charptr) argsp);
} else {
if(sp->othername) {
/* C library routines that return double... */
/* sp->rtype might be TYREAL */
ap = builtin(sp->rtype,
callbyvalue[sp->othername], 1);
q = fixexpr((Exprp)
mkexpr(OPCCALL, (expptr)ap, (expptr)argsp) );
} else {
fixargs(YES, argsp);
ap = builtin(sp->rtype, sp->spxname, 0);
q = fixexpr((Exprp)
mkexpr(OPCALL, (expptr)ap, (expptr)argsp) );
} /* else */
} /* else */
return(q);
case INTRMIN:
case INTRMAX:
if(nargs < 2)
goto badnargs;
if( ! ONEOF(mtype, MSKINT|MSKREAL) )
goto badtype;
argsp->vtype = mtype;
q = mkexpr( (f1field==INTRMIN ? OPMIN : OPMAX), (expptr)argsp, ENULL);
q->headblock.vtype = mtype;
rettype = f2field;
if(rettype == TYLONG)
rettype = tyint;
else if(rettype == TYUNKNOWN)
rettype = mtype;
return( mkconv(rettype, q) );
default:
fatali("intrcall: bad intrgroup %d", f1field);
}
badnargs:
errstr("bad number of arguments to intrinsic %s", np->fvarname);
goto bad;
badtype:
errstr("bad argument type to intrinsic %s", np->fvarname);
bad:
return( errnode() );
}
