expr.c

Go to the documentation of this file.

/****************************************************************
Copyright 1990 - 1996, 2000-2001 by AT&T, Lucent Technologies and Bellcore.

Permission to use, copy, modify, and distribute this software
and its documentation for any purpose and without fee is hereby
granted, provided that the above copyright notice appear in all
copies and that both that the copyright notice and this
permission notice and warranty disclaimer appear in supporting
documentation, and that the names of AT&T, Bell Laboratories,
Lucent or Bellcore or any of their entities not be used in
advertising or publicity pertaining to distribution of the
software without specific, written prior permission.

AT&T, Lucent and Bellcore disclaim all warranties with regard to
this software, including all implied warranties of
merchantability and fitness.  In no event shall AT&T, Lucent or
Bellcore be liable for any special, indirect or consequential
damages or any damages whatsoever resulting from loss of use,
data or profits, whether in an action of contract, negligence or
other tortious action, arising out of or in connection with the
use or performance of this software.
****************************************************************/

#include "defs.h"
#include "output.h"
#include "names.h"

typedef struct { double dreal, dimag; } dcomplex;

static void consbinop Argdcl((int, int, Constp, Constp, Constp));
static void conspower Argdcl((Constp, Constp, long int));
static void zdiv Argdcl((dcomplex*, dcomplex*, dcomplex*));
static tagptr mkpower Argdcl((tagptr));
static tagptr stfcall Argdcl((Namep, struct Listblock*));

extern char dflttype[26];
extern int htype;

/* little routines to create constant blocks */

 Constp
#ifdef KR_headers
mkconst(t)
        int t;
#else
mkconst(int t)
#endif
{
        Constp p;

        p = ALLOC(Constblock);
        p->tag = TCONST;
        p->vtype = t;
        return(p);
}


/* mklogcon -- Make Logical Constant */

 expptr
#ifdef KR_headers
mklogcon(l)
        int l;
#else
mklogcon(int l)
#endif
{
        Constp  p;

        p = mkconst(tylog);
        p->Const.ci = l;
        return( (expptr) p );
}



/* mkintcon -- Make Integer Constant */

 expptr
#ifdef KR_headers
mkintcon(l)
        ftnint l;
#else
mkintcon(ftnint l)
#endif
{
        Constp p;

        p = mkconst(tyint);
        p->Const.ci = l;
        return( (expptr) p );
}




/* mkaddcon -- Make Address Constant, given integer value */

 expptr
#ifdef KR_headers
mkaddcon(l)
        long l;
#else
mkaddcon(long l)
#endif
{
        Constp p;

        p = mkconst(TYADDR);
        p->Const.ci = l;
        return( (expptr) p );
}



/* mkrealcon -- Make Real Constant.  The type t is assumed
   to be TYREAL or TYDREAL */

 expptr
#ifdef KR_headers
mkrealcon(t, d)
        int t;
        char *d;
#else
mkrealcon(int t, char *d)
#endif
{
        Constp p;

        p = mkconst(t);
        p->Const.cds[0] = cds(d,CNULL);
        p->vstg = 1;
        return( (expptr) p );
}


/* mkbitcon -- Make bit constant.  Reads the input string, which is
   assumed to correctly specify a number in base 2^shift (where   shift
   is the input parameter).   shift   may not exceed 4, i.e. only binary,
   quad, octal and hex bases may be input. */

 expptr
#ifdef KR_headers
mkbitcon(shift, leng, s)
        int shift;
        int leng;
        char *s;
#else
mkbitcon(int shift, int leng, char *s)
#endif
{
        Constp p;
        unsigned long m, ovfl, x, y, z;
        int L32, len;
        char buff[100], *s0 = s;
#ifndef NO_LONG_LONG
        ULlong u;
#endif
        static char *kind[3] = { "Binary", "Hex", "Octal" };

        p = mkconst(TYLONG);
        /* Song and dance to convert to TYQUAD only if ftnint is too small. */
        m = x = y = ovfl = 0;
        /* Older C compilers may not know about */
        /* UL suffixes on hex constants... */
        while(--leng >= 0)
                if(*s != ' ') {
                        if (!m) {
                                z = x;
                                x = ((x << shift) | hextoi(*s++)) & ff;
                                if (!((x >> shift) - z))
                                        continue;
                                m = (ff << (L32 = 32 - shift)) & ff;
                                --s;
                                x = z;
                                }
                        ovfl |= y & m;
                        y = y << shift | (x >> L32);
                        x = ((x << shift) | hextoi(*s++)) & ff;
                        }
        /* Don't change the type to short for short constants, as
         * that is dangerous -- there is no syntax for long constants
         * with small values.
         */
        p->Const.ci = (ftnint)x;
#ifndef NO_LONG_LONG
        if (m) {
                if (allow_i8c) {
                        u = y;
                        p->Const.ucq = (u << 32) | x;
                        p->vtype = TYQUAD;
                        }
                else
                        ovfl = 1;
                }
#else
        ovfl |= m;
#endif
        if (ovfl) {
                if (--shift == 3)
                        shift = 1;
                if ((len = (int)leng) > 60)
                        sprintf(buff, "%s constant '%.60s' truncated.",
                                kind[shift], s0);
                else
                        sprintf(buff, "%s constant '%.*s' truncated.",
                                kind[shift], len, s0);
                err(buff);
                }
        return( (expptr) p );
}





/* mkstrcon -- Make string constant.  Allocates storage and initializes
   the memory for a copy of the input Fortran-string. */

 expptr
#ifdef KR_headers
mkstrcon(l, v)
        int l;
        char *v;
#else
mkstrcon(int l, char *v)
#endif
{
        Constp p;
        char *s;

        p = mkconst(TYCHAR);
        p->vleng = ICON(l);
        p->Const.ccp = s = (char *) ckalloc(l+1);
        p->Const.ccp1.blanks = 0;
        while(--l >= 0)
                *s++ = *v++;
        *s = '\0';
        return( (expptr) p );
}



/* mkcxcon -- Make complex contsant.  A complex number is a pair of
   values, each of which may be integer, real or double. */

 expptr
#ifdef KR_headers
mkcxcon(realp, imagp)
        expptr realp;
        expptr imagp;
#else
mkcxcon(expptr realp, expptr imagp)
#endif
{
        int rtype, itype;
        Constp p;

        rtype = realp->headblock.vtype;
        itype = imagp->headblock.vtype;

        if( ISCONST(realp) && ISNUMERIC(rtype) && ISCONST(imagp) && ISNUMERIC(itype) )
        {
                p = mkconst( (rtype==TYDREAL||itype==TYDREAL)
                                ? TYDCOMPLEX : tycomplex);
                if (realp->constblock.vstg || imagp->constblock.vstg) {
                        p->vstg = 1;
                        p->Const.cds[0] = ISINT(rtype)
                                ? string_num("", realp->constblock.Const.ci)
                                : realp->constblock.vstg
                                        ? realp->constblock.Const.cds[0]
                                        : dtos(realp->constblock.Const.cd[0]);
                        p->Const.cds[1] = ISINT(itype)
                                ? string_num("", imagp->constblock.Const.ci)
                                : imagp->constblock.vstg
                                        ? imagp->constblock.Const.cds[0]
                                        : dtos(imagp->constblock.Const.cd[0]);
                        }
                else {
                        p->Const.cd[0] = ISINT(rtype)
                                ? realp->constblock.Const.ci
                                : realp->constblock.Const.cd[0];
                        p->Const.cd[1] = ISINT(itype)
                                ? imagp->constblock.Const.ci
                                : imagp->constblock.Const.cd[0];
                        }
        }
        else
        {
                err("invalid complex constant");
                p = (Constp)errnode();
        }

        frexpr(realp);
        frexpr(imagp);
        return( (expptr) p );
}


/* errnode -- Allocate a new error block */

 expptr
errnode(Void)
{
        struct Errorblock *p;
        p = ALLOC(Errorblock);
        p->tag = TERROR;
        p->vtype = TYERROR;
        return( (expptr) p );
}





/* mkconv -- Make type conversion.  Cast expression   p   into type   t.
   Note that casting to a character copies only the first sizeof(char)
   bytes. */

 expptr
#ifdef KR_headers
mkconv(t, p)
        int t;
        expptr p;
#else
mkconv(int t, expptr p)
#endif
{
        expptr q;
        int pt, charwarn = 1;

        if (t >= 100) {
                t -= 100;
                charwarn = 0;
                }
        if(t==TYUNKNOWN || t==TYERROR)
                badtype("mkconv", t);
        pt = p->headblock.vtype;

/* Casting to the same type is a no-op */

        if(t == pt)
                return(p);

/* If we're casting a constant which is not in the literal table ... */

        else if( ISCONST(p) && pt!=TYADDR && pt != TYCHAR
                || p->tag == TADDR && p->addrblock.uname_tag == UNAM_CONST)
        {
#ifndef NO_LONG_LONG
                if (t != TYQUAD && pt != TYQUAD)        /*20010820*/
#endif
                if (ISINT(t) && ISINT(pt) || ISREAL(t) && ISREAL(pt)) {
                        /* avoid trouble with -i2 */
                        p->headblock.vtype = t;
                        return p;
                        }
                q = (expptr) mkconst(t);
                consconv(t, &q->constblock, &p->constblock );
                if (p->tag == TADDR)
                        q->constblock.vstg = p->addrblock.user.kludge.vstg1;
                frexpr(p);
        }
        else {
                if (pt == TYCHAR && t != TYADDR && charwarn
                                && (!halign || p->tag != TADDR
                                || p->addrblock.uname_tag != UNAM_CONST))
                        warn(
                 "ichar([first char. of] char. string) assumed for conversion to numeric");
                q = opconv(p, t);
                }

        if(t == TYCHAR)
                q->constblock.vleng = ICON(1);
        return(q);
}



/* opconv -- Convert expression   p   to type   t   using the main
   expression evaluator; returns an OPCONV expression, I think  14-jun-88 mwm */

 expptr
#ifdef KR_headers
opconv(p, t)
        expptr p;
        int t;
#else
opconv(expptr p, int t)
#endif
{
        expptr q;

        if (t == TYSUBR)
                err("illegal use of subroutine name");
        q = mkexpr(OPCONV, p, ENULL);
        q->headblock.vtype = t;
        return(q);
}



/* addrof -- Create an ADDR expression operation */

 expptr
#ifdef KR_headers
addrof(p)
        expptr p;
#else
addrof(expptr p)
#endif
{
        return( mkexpr(OPADDR, p, ENULL) );
}



/* cpexpr - Returns a new copy of input expression   p   */

 tagptr
#ifdef KR_headers
cpexpr(p)
        tagptr p;
#else
cpexpr(tagptr p)
#endif
{
        tagptr e;
        int tag;
        chainp ep, pp;

/* This table depends on the ordering of the T macros, e.g. TNAME */

        static int blksize[ ] =
        {
                0,
                sizeof(struct Nameblock),
                sizeof(struct Constblock),
                sizeof(struct Exprblock),
                sizeof(struct Addrblock),
                sizeof(struct Primblock),
                sizeof(struct Listblock),
                sizeof(struct Impldoblock),
                sizeof(struct Errorblock)
        };

        if(p == NULL)
                return(NULL);

/* TNAMEs are special, and don't get copied.  Each name in the current
   symbol table has a unique TNAME structure. */

        if( (tag = p->tag) == TNAME)
                return(p);

        e = cpblock(blksize[p->tag], (char *)p);

        switch(tag)
        {
        case TCONST:
                if(e->constblock.vtype == TYCHAR)
                {
                        e->constblock.Const.ccp =
                            copyn((int)e->constblock.vleng->constblock.Const.ci+1,
                                e->constblock.Const.ccp);
                        e->constblock.vleng =
                            (expptr) cpexpr(e->constblock.vleng);
                }
        case TERROR:
                break;

        case TEXPR:
                e->exprblock.leftp =  (expptr) cpexpr(p->exprblock.leftp);
                e->exprblock.rightp = (expptr) cpexpr(p->exprblock.rightp);
                break;

        case TLIST:
                if(pp = p->listblock.listp)
                {
                        ep = e->listblock.listp =
                            mkchain((char *)cpexpr((tagptr)pp->datap), CHNULL);
                        for(pp = pp->nextp ; pp ; pp = pp->nextp)
                                ep = ep->nextp =
                                    mkchain((char *)cpexpr((tagptr)pp->datap),
                                                CHNULL);
                }
                break;

        case TADDR:
                e->addrblock.vleng = (expptr)  cpexpr(e->addrblock.vleng);
                e->addrblock.memoffset = (expptr)cpexpr(e->addrblock.memoffset);
                e->addrblock.istemp = NO;
                break;

        case TPRIM:
                e->primblock.argsp = (struct Listblock *)
                    cpexpr((expptr)e->primblock.argsp);
                e->primblock.fcharp = (expptr) cpexpr(e->primblock.fcharp);
                e->primblock.lcharp = (expptr) cpexpr(e->primblock.lcharp);
                break;

        default:
                badtag("cpexpr", tag);
        }

        return(e);
}

/* frexpr -- Free expression -- frees up memory used by expression   p   */

 void
#ifdef KR_headers
frexpr(p)
        tagptr p;
#else
frexpr(tagptr p)
#endif
{
        chainp q;

        if(p == NULL)
                return;

        switch(p->tag)
        {
        case TCONST:
                if( ISCHAR(p) )
                {
                        free( (charptr) (p->constblock.Const.ccp) );
                        frexpr(p->constblock.vleng);
                }
                break;

        case TADDR:
                if (p->addrblock.vtype > TYERROR)       /* i/o block */
                        break;
                frexpr(p->addrblock.vleng);
                frexpr(p->addrblock.memoffset);
                break;

        case TERROR:
                break;

/* TNAME blocks don't get free'd - probably because they're pointed to in
   the hash table. 14-Jun-88 -- mwm */

        case TNAME:
                return;

        case TPRIM:
                frexpr((expptr)p->primblock.argsp);
                frexpr(p->primblock.fcharp);
                frexpr(p->primblock.lcharp);
                break;

        case TEXPR:
                frexpr(p->exprblock.leftp);
                if(p->exprblock.rightp)
                        frexpr(p->exprblock.rightp);
                break;

        case TLIST:
                for(q = p->listblock.listp ; q ; q = q->nextp)
                        frexpr((tagptr)q->datap);
                frchain( &(p->listblock.listp) );
                break;

        default:
                badtag("frexpr", p->tag);
        }

        free( (charptr) p );
}

 void
#ifdef KR_headers
wronginf(np)
        Namep np;
#else
wronginf(Namep np)
#endif
{
        int c;
        ftnint k;
        warn1("fixing wrong type inferred for %.65s", np->fvarname);
        np->vinftype = 0;
        c = letter(np->fvarname[0]);
        if ((np->vtype = impltype[c]) == TYCHAR
        && (k = implleng[c]))
                np->vleng = ICON(k);
        }

/* fix up types in expression; replace subtrees and convert
   names to address blocks */

 expptr
#ifdef KR_headers
fixtype(p)
        tagptr p;
#else
fixtype(tagptr p)
#endif
{

        if(p == 0)
                return(0);

        switch(p->tag)
        {
        case TCONST:
                if(ONEOF(p->constblock.vtype,MSKINT|MSKLOGICAL|MSKADDR|
                    MSKREAL) )
                        return( (expptr) p);

                return( (expptr) putconst((Constp)p) );

        case TADDR:
                p->addrblock.memoffset = fixtype(p->addrblock.memoffset);
                return( (expptr) p);

        case TERROR:
                return( (expptr) p);

        default:
                badtag("fixtype", p->tag);

/* This case means that   fixexpr   can't call   fixtype   with any expr,
   only a subexpr of its parameter. */

        case TEXPR:
                if (((Exprp)p)->typefixed)
                        return (expptr)p;
                return( fixexpr((Exprp)p) );

        case TLIST:
                return( (expptr) p );

        case TPRIM:
                if(p->primblock.argsp && p->primblock.namep->vclass!=CLVAR)
                {
                        if(p->primblock.namep->vtype == TYSUBR)
                        {
                                err("function invocation of subroutine");
                                return( errnode() );
                        }
                        else {
                                if (p->primblock.namep->vinftype)
                                        wronginf(p->primblock.namep);
                                return( mkfunct(p) );
                                }
                }

/* The lack of args makes   p   a function name, substring reference
   or variable name. */

                else    return mklhs((struct Primblock *) p, keepsubs);
        }
}


 int
#ifdef KR_headers
badchleng(p)
        expptr p;
#else
badchleng(expptr p)
#endif
{
        if (!p->headblock.vleng) {
                if (p->headblock.tag == TADDR
                && p->addrblock.uname_tag == UNAM_NAME)
                        errstr("bad use of character*(*) variable %.60s",
                                p->addrblock.user.name->fvarname);
                else
                        err("Bad use of character*(*)");
                return 1;
                }
        return 0;
        }


 static expptr
#ifdef KR_headers
cplenexpr(p)
        expptr p;
#else
cplenexpr(expptr p)
#endif
{
        expptr rv;

        if (badchleng(p))
                return ICON(1);
        rv = cpexpr(p->headblock.vleng);
        if (ISCONST(p) && p->constblock.vtype == TYCHAR)
                rv->constblock.Const.ci += p->constblock.Const.ccp1.blanks;
        return rv;
        }


/* special case tree transformations and cleanups of expression trees.
   Parameter   p   should have a TEXPR tag at its root, else an error is
   returned */

 expptr
#ifdef KR_headers
fixexpr(p)
        Exprp p;
#else
fixexpr(Exprp p)
#endif
{
        expptr lp, rp, q;
        char *hsave;
        int opcode, ltype, rtype, ptype, mtype;

        if( ISERROR(p) || p->typefixed )
                return( (expptr) p );
        else if(p->tag != TEXPR)
                badtag("fixexpr", p->tag);
        opcode = p->opcode;

/* First set the types of the left and right subexpressions */

        lp = p->leftp;
        if (!ISCONST(lp) || lp->constblock.vtype != TYCHAR)
                lp = p->leftp = fixtype(lp);
        ltype = lp->headblock.vtype;

        if(opcode==OPASSIGN && lp->tag!=TADDR)
        {
                err("left side of assignment must be variable");
 eret:
                frexpr((expptr)p);
                return( errnode() );
        }

        if(rp = p->rightp)
        {
                if (!ISCONST(rp) || rp->constblock.vtype != TYCHAR)
                        rp = p->rightp = fixtype(rp);
                rtype = rp->headblock.vtype;
        }
        else
                rtype = 0;

        if(ltype==TYERROR || rtype==TYERROR)
                goto eret;

/* Now work on the whole expression */

        /* force folding if possible */

        if( ISCONST(lp) && (rp==NULL || ISCONST(rp)) )
        {
                q = opcode == OPCONV && lp->constblock.vtype == p->vtype
                        ? lp : mkexpr(opcode, lp, rp);

/* mkexpr is expected to reduce constant expressions */

                if( ISCONST(q) ) {
                        p->leftp = p->rightp = 0;
                        frexpr((expptr)p);
                        return(q);
                        }
                free( (charptr) q );    /* constants did not fold */
        }

        if( (ptype = cktype(opcode, ltype, rtype)) == TYERROR)
                goto eret;

        if (ltype == TYCHAR && ISCONST(lp)) {
                if (opcode == OPCONV) {
                        hsave = halign;
                        halign = 0;
                        lp = (expptr)putconst((Constp)lp);
                        halign = hsave;
                        }
                else
                        lp = (expptr)putconst((Constp)lp);
                p->leftp = lp;
                }
        if (rtype == TYCHAR && ISCONST(rp))
                p->rightp = rp = (expptr)putconst((Constp)rp);

        switch(opcode)
        {
        case OPCONCAT:
                if(p->vleng == NULL)
                        p->vleng = mkexpr(OPPLUS, cplenexpr(lp),
                                        cplenexpr(rp) );
                break;

        case OPASSIGN:
                if (rtype == TYREAL || ISLOGICAL(ptype)
                 || rtype == TYDREAL && ltype == TYREAL && !ISCONST(rp))
                        break;
        case OPPLUSEQ:
        case OPSTAREQ:
                if(ltype == rtype)
                        break;
                if( ! ISCONST(rp) && ISREAL(ltype) && ISREAL(rtype) )
                        break;
                if( ISCOMPLEX(ltype) || ISCOMPLEX(rtype) )
                        break;
                if( ONEOF(ltype, MSKADDR|MSKINT) && ONEOF(rtype, MSKADDR|MSKINT)
                    && typesize[ltype]>=typesize[rtype] )
                            break;

/* Cast the right hand side to match the type of the expression */

                p->rightp = fixtype( mkconv(ptype, rp) );
                break;

        case OPSLASH:
                if( ISCOMPLEX(rtype) )
                {
                        p = (Exprp) call2(ptype,

/* Handle double precision complex variables */

                            (char*)(ptype == TYCOMPLEX ? "c_div" : "z_div"),
                            mkconv(ptype, lp), mkconv(ptype, rp) );
                        break;
                }
        case OPPLUS:
        case OPMINUS:
        case OPSTAR:
        case OPMOD:
                if(ptype==TYDREAL && ( (ltype==TYREAL && ! ISCONST(lp) ) ||
                    (rtype==TYREAL && ! ISCONST(rp) ) ))
                        break;
                if( ISCOMPLEX(ptype) )
                        break;

/* Cast both sides of the expression to match the type of the whole
   expression.  */

                if(ltype != ptype && (ltype < TYINT1 || ptype > TYDREAL))
                        p->leftp = fixtype(mkconv(ptype,lp));
                if(rtype != ptype && (rtype < TYINT1 || ptype > TYDREAL))
                        p->rightp = fixtype(mkconv(ptype,rp));
                break;

        case OPPOWER:
                rp = mkpower((expptr)p);
                if (rp->tag == TEXPR)
                        rp->exprblock.typefixed = 1;
                return rp;

        case OPLT:
        case OPLE:
        case OPGT:
        case OPGE:
        case OPEQ:
        case OPNE:
                if(ltype == rtype)
                        break;
                if (htype) {
                        if (ltype == TYCHAR) {
                                p->leftp = fixtype(mkconv(rtype,lp));
                                break;
                                }
                        if (rtype == TYCHAR) {
                                p->rightp = fixtype(mkconv(ltype,rp));
                                break;
                                }
                        }
                mtype = cktype(OPMINUS, ltype, rtype);
                if(mtype==TYDREAL && (ltype==TYREAL || rtype==TYREAL))
                        break;
                if( ISCOMPLEX(mtype) )
                        break;
                if(ltype != mtype)
                        p->leftp = fixtype(mkconv(mtype,lp));
                if(rtype != mtype)
                        p->rightp = fixtype(mkconv(mtype,rp));
                break;

        case OPCONV:
                ptype = cktype(OPCONV, p->vtype, ltype);
                if(lp->tag==TEXPR && lp->exprblock.opcode==OPCOMMA
                 && !ISCOMPLEX(ptype))
                {
                        lp->exprblock.rightp =
                            fixtype( mkconv(ptype, lp->exprblock.rightp) );
                        free( (charptr) p );
                        p = (Exprp) lp;
                }
                break;

        case OPADDR:
                if(lp->tag==TEXPR && lp->exprblock.opcode==OPADDR)
                        Fatal("addr of addr");
                break;

        case OPCOMMA:
        case OPQUEST:
        case OPCOLON:
                break;

        case OPMIN:
        case OPMAX:
        case OPMIN2:
        case OPMAX2:
        case OPDMIN:
        case OPDMAX:
        case OPABS:
        case OPDABS:
                ptype = p->vtype;
                break;

        default:
                break;
        }

        p->vtype = ptype;
        p->typefixed = 1;
        return((expptr) p);
}


/* fix an argument list, taking due care for special first level cases */

 int
#ifdef KR_headers
fixargs(doput, p0)
        int doput;
        struct Listblock *p0;
#else
fixargs(int doput, struct Listblock *p0)
#endif
        /* doput is true if constants need to be passed by reference */
{
        chainp p;
        tagptr q, t;
        int qtag, nargs;

        nargs = 0;
        if(p0)
                for(p = p0->listp ; p ; p = p->nextp)
                {
                        ++nargs;
                        q = (tagptr)p->datap;
                        qtag = q->tag;
                        if(qtag == TCONST)
                        {

/* Call putconst() to store values in a constant table.  Since even
   constants must be passed by reference, this can optimize on the storage
   required */

                                p->datap = doput ? (char *)putconst((Constp)q)
                                                 : (char *)q;
                                continue;
                        }

/* Take a function name and turn it into an Addr.  This only happens when
   nothing else has figured out the function beforehand */

                        if (qtag == TPRIM && q->primblock.argsp == 0) {
                            if (q->primblock.namep->vclass==CLPROC
                             && q->primblock.namep->vprocclass != PTHISPROC) {
                                p->datap = (char *)mkaddr(q->primblock.namep);
                                continue;
                                }

                            if (q->primblock.namep->vdim != NULL) {
                                p->datap = (char *)mkscalar(q->primblock.namep);
                                if ((q->primblock.fcharp||q->primblock.lcharp)
                                 && (q->primblock.namep->vtype != TYCHAR
                                  || q->primblock.namep->vdim))
                                        sserr(q->primblock.namep);
                                continue;
                                }

                            if (q->primblock.namep->vdovar
                             && (t = (tagptr) memversion(q->primblock.namep))) {
                                p->datap = (char *)fixtype(t);
                                continue;
                                }
                            }
                        p->datap = (char *)fixtype(q);
                }
        return(nargs);
}



/* mkscalar -- only called by   fixargs   above, and by some routines in
   io.c */

 Addrp
#ifdef KR_headers
mkscalar(np)
        Namep np;
#else
mkscalar(Namep np)
#endif
{
        Addrp ap;

        vardcl(np);
        ap = mkaddr(np);

        /* The prolog causes array arguments to point to the
         * (0,...,0) element, unless subscript checking is on.
         */
        if( !checksubs && np->vstg==STGARG)
        {
                struct Dimblock *dp;
                dp = np->vdim;
                frexpr(ap->memoffset);
                ap->memoffset = mkexpr(OPSTAR,
                    (np->vtype==TYCHAR ?
                    cpexpr(np->vleng) :
                    (tagptr)ICON(typesize[np->vtype]) ),
                    cpexpr(dp->baseoffset) );
        }
        return(ap);
}


 static void
#ifdef KR_headers
adjust_arginfo(np)
        Namep np;
#else
adjust_arginfo(Namep np)
#endif
                        /* adjust arginfo to omit the length arg for the
                           arg that we now know to be a character-valued
                           function */
{
        struct Entrypoint *ep;
        chainp args;
        Argtypes *at;

        for(ep = entries; ep; ep = ep->entnextp)
                for(args = ep->arglist; args; args = args->nextp)
                        if (np == (Namep)args->datap
                        && (at = ep->entryname->arginfo))
                                --at->nargs;
        }


 expptr
#ifdef KR_headers
mkfunct(p0)
        expptr p0;
#else
mkfunct(expptr p0)
#endif
{
        struct Primblock *p = (struct Primblock *)p0;
        struct Entrypoint *ep;
        Addrp ap;
        Extsym *extp;
        Namep np;
        expptr q;
        extern chainp new_procs;
        int k, nargs;
        int vclass;

        if(p->tag != TPRIM)
                return( errnode() );

        np = p->namep;
        vclass = np->vclass;


        if(vclass == CLUNKNOWN)
        {
                np->vclass = vclass = CLPROC;
                if(np->vstg == STGUNKNOWN)
                {
                        if(np->vtype!=TYSUBR && (k = intrfunct(np->fvarname))
                                && (zflag || !(*(struct Intrpacked *)&k).f4
                                        || dcomplex_seen))
                        {
                                np->vstg = STGINTR;
                                np->vardesc.varno = k;
                                np->vprocclass = PINTRINSIC;
                        }
                        else
                        {
                                extp = mkext(np->fvarname,
                                        addunder(np->cvarname));
                                extp->extstg = STGEXT;
                                np->vstg = STGEXT;
                                np->vardesc.varno = extp - extsymtab;
                                np->vprocclass = PEXTERNAL;
                        }
                }
                else if(np->vstg==STGARG)
                {
                    if(np->vtype == TYCHAR) {
                        adjust_arginfo(np);
                        if (np->vpassed) {
                                char wbuf[160], *who;
                                who = np->fvarname;
                                sprintf(wbuf, "%s%s%s\n\t%s%s%s",
                                        "Character-valued dummy procedure ",
                                        who, " not declared EXTERNAL.",
                        "Code may be wrong for previous function calls having ",
                                        who, " as a parameter.");
                                warn(wbuf);
                                }
                        }
                    np->vprocclass = PEXTERNAL;
                }
        }

        if(vclass != CLPROC) {
                if (np->vstg == STGCOMMON)
                        fatalstr(
                         "Cannot invoke common variable %.50s as a function.",
                                np->fvarname);
                errstr("%.80s cannot be called.", np->fvarname);
                goto error;
                }

/* F77 doesn't allow subscripting of function calls */

        if(p->fcharp || p->lcharp)
        {
                err("no substring of function call");
                goto error;
        }
        impldcl(np);
        np->vimpltype = 0;      /* invoking as function ==> inferred type */
        np->vcalled = 1;
        nargs = fixargs( np->vprocclass!=PINTRINSIC,  p->argsp);

        switch(np->vprocclass)
        {
        case PEXTERNAL:
                if(np->vtype == TYUNKNOWN)
                {
                        dclerr("attempt to use untyped function", np);
                        np->vtype = dflttype[letter(np->fvarname[0])];
                }
                ap = mkaddr(np);
                if (!extsymtab[np->vardesc.varno].extseen) {
                        new_procs = mkchain((char *)np, new_procs);
                        extsymtab[np->vardesc.varno].extseen = 1;
                        }
call:
                q = mkexpr(OPCALL, (expptr)ap, (expptr)p->argsp);
                q->exprblock.vtype = np->vtype;
                if(np->vleng)
                        q->exprblock.vleng = (expptr) cpexpr(np->vleng);
                break;

        case PINTRINSIC:
                q = intrcall(np, p->argsp, nargs);
                break;

        case PSTFUNCT:
                q = stfcall(np, p->argsp);
                break;

        case PTHISPROC:
                warn("recursive call");

/* entries   is the list of multiple entry points */

                for(ep = entries ; ep ; ep = ep->entnextp)
                        if(ep->enamep == np)
                                break;
                if(ep == NULL)
                        Fatal("mkfunct: impossible recursion");

                ap = builtin(np->vtype, ep->entryname->cextname, -2);
                /* the negative last arg prevents adding */
                /* this name to the list of used builtins */
                goto call;

        default:
                fatali("mkfunct: impossible vprocclass %d",
                    (int) (np->vprocclass) );
        }
        free( (charptr) p );
        return(q);

error:
        frexpr((expptr)p);
        return( errnode() );
}



 static expptr
#ifdef KR_headers
stfcall(np, actlist)
        Namep np;
        struct Listblock *actlist;
#else
stfcall(Namep np, struct Listblock *actlist)
#endif
{
        chainp actuals;
        int nargs;
        chainp oactp, formals;
        int type;
        expptr Ln, Lq, q, q1, rhs, ap;
        Namep tnp;
        struct Rplblock *rp;
        struct Rplblock *tlist;

        if (np->arginfo) {
                errstr("statement function %.66s calls itself.",
                        np->fvarname);
                return ICON(0);
                }
        np->arginfo = (Argtypes *)np;   /* arbitrary nonzero value */
        if(actlist)
        {
                actuals = actlist->listp;
                free( (charptr) actlist);
        }
        else
                actuals = NULL;
        oactp = actuals;

        nargs = 0;
        tlist = NULL;
        if( (type = np->vtype) == TYUNKNOWN)
        {
                dclerr("attempt to use untyped statement function", np);
                type = np->vtype = dflttype[letter(np->fvarname[0])];
        }
        formals = (chainp) np->varxptr.vstfdesc->datap;
        rhs = (expptr) (np->varxptr.vstfdesc->nextp);

        /* copy actual arguments into temporaries */
        while(actuals!=NULL && formals!=NULL)
        {
                if (!(tnp = (Namep) formals->datap)) {
                        /* buggy statement function declaration */
                        q = ICON(1);
                        goto done;
                        }
                rp = ALLOC(Rplblock);
                rp->rplnp = tnp;
                ap = fixtype((tagptr)actuals->datap);
                if(tnp->vtype==ap->headblock.vtype && tnp->vtype!=TYCHAR
                    && (ap->tag==TCONST || ap->tag==TADDR) )
                {

/* If actuals are constants or variable names, no temporaries are required */
                        rp->rplvp = (expptr) ap;
                        rp->rplxp = NULL;
                        rp->rpltag = ap->tag;
                }
                else    {
                        rp->rplvp = (expptr) mktmp(tnp->vtype, tnp->vleng);
                        rp -> rplxp = NULL;
                        putexpr ( mkexpr(OPASSIGN, cpexpr(rp->rplvp), ap));
                        if((rp->rpltag = rp->rplvp->tag) == TERROR)
                                err("disagreement of argument types in statement function call");
                }
                rp->rplnextp = tlist;
                tlist = rp;
                actuals = actuals->nextp;
                formals = formals->nextp;
                ++nargs;
        }

        if(actuals!=NULL || formals!=NULL)
                err("statement function definition and argument list differ");

        /*
   now push down names involved in formal argument list, then
   evaluate rhs of statement function definition in this environment
*/

        if(tlist)       /* put tlist in front of the rpllist */
        {
                for(rp = tlist; rp->rplnextp; rp = rp->rplnextp)
                        ;
                rp->rplnextp = rpllist;
                rpllist = tlist;
        }

/* So when the expression finally gets evaled, that evaluator must read
   from the globl   rpllist   14-jun-88 mwm */

        q = (expptr) mkconv(type, fixtype(cpexpr(rhs)) );

        /* get length right of character-valued statement functions... */
        if (type == TYCHAR
         && (Ln = np->vleng)
         && q->tag != TERROR
         && (Lq = q->exprblock.vleng)
         && (Lq->tag != TCONST
                || Ln->constblock.Const.ci != Lq->constblock.Const.ci)) {
                q1 = (expptr) mktmp(type, Ln);
                putexpr ( mkexpr(OPASSIGN, cpexpr(q1), q));
                q = q1;
                }

        /* now generate the tree ( t1=a1, (t2=a2,... , f))))) */
        while(--nargs >= 0)
        {
                if(rpllist->rplxp)
                        q = mkexpr(OPCOMMA, rpllist->rplxp, q);
                rp = rpllist->rplnextp;
                frexpr(rpllist->rplvp);
                free((char *)rpllist);
                rpllist = rp;
        }
 done:
        frchain( &oactp );
        np->arginfo = 0;
        return(q);
}


static int replaced;

/* mkplace -- Figure out the proper storage class for the input name and
   return an addrp with the appropriate stuff */

 Addrp
#ifdef KR_headers
mkplace(np)
        Namep np;
#else
mkplace(Namep np)
#endif
{
        Addrp s;
        struct Rplblock *rp;
        int regn;

        /* is name on the replace list? */

        for(rp = rpllist ; rp ; rp = rp->rplnextp)
        {
                if(np == rp->rplnp)
                {
                        replaced = 1;
                        if(rp->rpltag == TNAME)
                        {
                                np = (Namep) (rp->rplvp);
                                break;
                        }
                        else    return( (Addrp) cpexpr(rp->rplvp) );
                }
        }

        /* is variable a DO index in a register ? */

        if(np->vdovar && ( (regn = inregister(np)) >= 0) )
                if(np->vtype == TYERROR)
                        return((Addrp) errnode() );
                else
                {
                        s = ALLOC(Addrblock);
                        s->tag = TADDR;
                        s->vstg = STGREG;
                        s->vtype = TYIREG;
                        s->memno = regn;
                        s->memoffset = ICON(0);
                        s -> uname_tag = UNAM_NAME;
                        s -> user.name = np;
                        return(s);
                }

        if (np->vclass == CLPROC && np->vprocclass != PTHISPROC)
                errstr("external %.60s used as a variable", np->fvarname);
        vardcl(np);
        return(mkaddr(np));
}

 static expptr
#ifdef KR_headers
subskept(p, a)
        struct Primblock *p;
        Addrp a;
#else
subskept(struct Primblock *p, Addrp a)
#endif
{
        expptr ep;
        struct Listblock *Lb;
        chainp cp;

        if (a->uname_tag != UNAM_NAME)
                erri("subskept: uname_tag %d", a->uname_tag);
        a->user.name->vrefused = 1;
        a->user.name->visused = 1;
        a->uname_tag = UNAM_REF;
        Lb = (struct Listblock *)cpexpr((tagptr)p->argsp);
        for(cp = Lb->listp; cp; cp = cp->nextp)
                cp->datap = (char *)putx(fixtype((tagptr)cp->datap));
        if (a->vtype == TYCHAR) {
                ep = p->fcharp  ? mkexpr(OPMINUS, cpexpr(p->fcharp), ICON(1))
                                : ICON(0);
                Lb->listp = mkchain((char *)ep, Lb->listp);
                }
        return (expptr)Lb;
        }

 static void
#ifdef KR_headers
substrerr(np) Namep np;
#else
substrerr(Namep np)
#endif
{
        void (*f) Argdcl((const char*, const char*));
        f = checksubs ? errstr : warn1;
        (*f)("substring of %.65s is out of bounds.", np->fvarname);
        }

 static int doing_vleng;

/* mklhs -- Compute the actual address of the given expression; account
   for array subscripts, stack offset, and substring offsets.  The f -> C
   translator will need this only to worry about the subscript stuff */

 expptr
#ifdef KR_headers
mklhs(p, subkeep)
        struct Primblock *p;
        int subkeep;
#else
mklhs(struct Primblock *p, int subkeep)
#endif
{
        Addrp s;
        Namep np;

        if(p->tag != TPRIM)
                return( (expptr) p );
        np = p->namep;

        replaced = 0;
        s = mkplace(np);
        if(s->tag!=TADDR || s->vstg==STGREG)
        {
                free( (charptr) p );
                return( (expptr) s );
        }
        s->parenused = p->parenused;

        /* compute the address modified by subscripts */

        if (!replaced)
                s->memoffset = (subkeep && np->vdim && p->argsp
                                && (np->vdim->ndim > 1 || np->vtype == TYCHAR
                                && (!ISCONST(np->vleng)
                                  || np->vleng->constblock.Const.ci != 1)))
                                ? subskept(p,s)
                                : mkexpr(OPPLUS, s->memoffset, suboffset(p) );
        frexpr((expptr)p->argsp);
        p->argsp = NULL;

        /* now do substring part */

        if(p->fcharp || p->lcharp)
        {
                if(np->vtype != TYCHAR)
                        sserr(np);
                else    {
                        if(p->lcharp == NULL)
                                p->lcharp = (expptr)(
                                        /* s->vleng == 0 only with errors */
                                        s->vleng ? cpexpr(s->vleng) : ICON(1));
                        else if (ISCONST(p->lcharp)
                                 && ISCONST(np->vleng)
                                 && p->lcharp->constblock.Const.ci
                                        > np->vleng->constblock.Const.ci)
                                                substrerr(np);
                        if(p->fcharp) {
                                doing_vleng = 1;
                                s->vleng = fixtype(mkexpr(OPMINUS,
                                                p->lcharp,
                                        mkexpr(OPMINUS, p->fcharp, ICON(1) )));
                                doing_vleng = 0;
                                }
                        else    {
                                frexpr(s->vleng);
                                s->vleng = p->lcharp;
                                }
                        if (s->memoffset
                         && ISCONST(s->memoffset)
                         && s->memoffset->constblock.Const.ci < 0)
                                substrerr(np);
                }
        }

        s->vleng = fixtype( s->vleng );
        s->memoffset = fixtype( s->memoffset );
        free( (charptr) p );
        return( (expptr) s );
}





/* deregister -- remove a register allocation from the list; assumes that
   names are deregistered in stack order (LIFO order - Last In First Out) */

 void
#ifdef KR_headers
deregister(np)
        Namep np;
#else
deregister(Namep np)
#endif
{
        if(nregvar>0 && regnamep[nregvar-1]==np)
        {
                --nregvar;
        }
}




/* memversion -- moves a DO index REGISTER into a memory location; other
   objects are passed through untouched */

 Addrp
#ifdef KR_headers
memversion(np)
        Namep np;
#else
memversion(Namep np)
#endif
{
        Addrp s;

        if(np->vdovar==NO || (inregister(np)<0) )
                return(NULL);
        np->vdovar = NO;
        s = mkplace(np);
        np->vdovar = YES;
        return(s);
}



/* inregister -- looks for the input name in the global list   regnamep */

 int
#ifdef KR_headers
inregister(np)
        Namep np;
#else
inregister(Namep np)
#endif
{
        int i;

        for(i = 0 ; i < nregvar ; ++i)
                if(regnamep[i] == np)
                        return( regnum[i] );
        return(-1);
}



/* suboffset -- Compute the offset from the start of the array, given the
   subscripts as arguments */

 expptr
#ifdef KR_headers
suboffset(p)
        struct Primblock *p;
#else
suboffset(struct Primblock *p)
#endif
{
        int n;
        expptr si, size;
        chainp cp;
        expptr e, e1, offp, prod;
        struct Dimblock *dimp;
        expptr sub[MAXDIM+1];
        Namep np;

        np = p->namep;
        offp = ICON(0);
        n = 0;
        if(p->argsp)
                for(cp = p->argsp->listp ; cp ; cp = cp->nextp)
                {
                        si = fixtype(cpexpr((tagptr)cp->datap));
                        if (!ISINT(si->headblock.vtype)) {
                                NOEXT("non-integer subscript");
                                si = mkconv(TYLONG, si);
                                }
                        sub[n++] = si;
                        if(n > maxdim)
                        {
                                erri("more than %d subscripts", maxdim);
                                break;
                        }
                }

        dimp = np->vdim;
        if(n>0 && dimp==NULL)
                errstr("subscripts on scalar variable %.68s", np->fvarname);
        else if(dimp && dimp->ndim!=n)
                errstr("wrong number of subscripts on %.68s", np->fvarname);
        else if(n > 0)
        {
                prod = sub[--n];
                while( --n >= 0)
                        prod = mkexpr(OPPLUS, sub[n],
                            mkexpr(OPSTAR, prod, cpexpr(dimp->dims[n].dimsize)) );
                if(checksubs || np->vstg!=STGARG)
                        prod = mkexpr(OPMINUS, prod, cpexpr(dimp->baseoffset));

/* Add in the run-time bounds check */

                if(checksubs)
                        prod = subcheck(np, prod);
                size = np->vtype == TYCHAR ?
                    (expptr) cpexpr(np->vleng) : ICON(typesize[np->vtype]);
                prod = mkexpr(OPSTAR, prod, size);
                offp = mkexpr(OPPLUS, offp, prod);
        }

/* Check for substring indicator */

        if(p->fcharp && np->vtype==TYCHAR) {
                e = p->fcharp;
                e1 = mkexpr(OPMINUS, cpexpr(e), ICON(1));
                if (!ISCONST(e) && (e->tag != TPRIM || e->primblock.argsp)) {
                        e = (expptr)mktmp(TYLONG, ENULL);
                        putout(putassign(cpexpr(e), e1));
                        p->fcharp = mkexpr(OPPLUS, cpexpr(e), ICON(1));
                        e1 = e;
                        }
                offp = mkexpr(OPPLUS, offp, e1);
                }
        return(offp);
}




 expptr
#ifdef KR_headers
subcheck(np, p)
        Namep np;
        expptr p;
#else
subcheck(Namep np, expptr p)
#endif
{
        struct Dimblock *dimp;
        expptr t, checkvar, checkcond, badcall;

        dimp = np->vdim;
        if(dimp->nelt == NULL)
                return(p);      /* don't check arrays with * bounds */
        np->vlastdim = 0;
        if( ISICON(p) )
        {

/* check for negative (constant) offset */

                if(p->constblock.Const.ci < 0)
                        goto badsub;
                if( ISICON(dimp->nelt) )

/* see if constant offset exceeds the array declaration */

                        if(p->constblock.Const.ci < dimp->nelt->constblock.Const.ci)
                                return(p);
                        else
                                goto badsub;
        }

/* We know that the subscript offset   p   or   dimp -> nelt   is not a constant.
   Now find a register to use for run-time bounds checking */

        if(p->tag==TADDR && p->addrblock.vstg==STGREG)
        {
                checkvar = (expptr) cpexpr(p);
                t = p;
        }
        else    {
                checkvar = (expptr) mktmp(TYLONG, ENULL);
                t = mkexpr(OPASSIGN, cpexpr(checkvar), p);
        }
        checkcond = mkexpr(OPLT, t, cpexpr(dimp->nelt) );
        if( ! ISICON(p) )
                checkcond = mkexpr(OPAND, checkcond,
                    mkexpr(OPLE, ICON(0), cpexpr(checkvar)) );

/* Construct the actual test */

        badcall = call4(p->headblock.vtype, "s_rnge",
            mkstrcon(strlen(np->fvarname), np->fvarname),
            mkconv(TYLONG,  cpexpr(checkvar)),
            mkstrcon(strlen(procname), procname),
            ICON(lineno) );
        badcall->exprblock.opcode = OPCCALL;
        p = mkexpr(OPQUEST, checkcond,
            mkexpr(OPCOLON, checkvar, badcall));

        return(p);

badsub:
        frexpr(p);
        errstr("subscript on variable %s out of range", np->fvarname);
        return ( ICON(0) );
}




 Addrp
#ifdef KR_headers
mkaddr(p)
        Namep p;
#else
mkaddr(Namep p)
#endif
{
        Extsym *extp;
        Addrp t;
        int k;

        switch( p->vstg)
        {
        case STGAUTO:
                if(p->vclass == CLPROC && p->vprocclass == PTHISPROC)
                        return (Addrp) cpexpr((expptr)xretslot[p->vtype]);
                goto other;

        case STGUNKNOWN:
                if(p->vclass != CLPROC)
                        break;  /* Error */
                extp = mkext(p->fvarname, addunder(p->cvarname));
                extp->extstg = STGEXT;
                p->vstg = STGEXT;
                p->vardesc.varno = extp - extsymtab;
                p->vprocclass = PEXTERNAL;
                if ((extp->exproto || infertypes)
                && (p->vtype == TYUNKNOWN || p->vimpltype)
                && (k = extp->extype))
                        inferdcl(p, k);


        case STGCOMMON:
        case STGEXT:
        case STGBSS:
        case STGINIT:
        case STGEQUIV:
        case STGARG:
        case STGLENG:
 other:
                t = ALLOC(Addrblock);
                t->tag = TADDR;

                t->vclass = p->vclass;
                t->vtype = p->vtype;
                t->vstg = p->vstg;
                t->memno = p->vardesc.varno;
                t->memoffset = ICON(p->voffset);
                if (p->vdim)
                    t->isarray = 1;
                if(p->vleng)
                {
                        t->vleng = (expptr) cpexpr(p->vleng);
                        if( ISICON(t->vleng) )
                                t->varleng = t->vleng->constblock.Const.ci;
                }

/* Keep the original name around for the C code generation */

                t -> uname_tag = UNAM_NAME;
                t -> user.name = p;
                return(t);

        case STGINTR:

                return ( intraddr (p));

        case STGSTFUNCT:

                errstr("invalid use of statement function %.64s.", p->fvarname);
                return putconst((Constp)ICON(0));
        }
        badstg("mkaddr", p->vstg);
        /* NOT REACHED */ return 0;
}




/* mkarg -- create storage for a new parameter.  This is called when a
   function returns a string (for the return value, which is the first
   parameter), or when a variable-length string is passed to a function. */

 Addrp
#ifdef KR_headers
mkarg(type, argno)
        int type;
        int argno;
#else
mkarg(int type, int argno)
#endif
{
        Addrp p;

        p = ALLOC(Addrblock);
        p->tag = TADDR;
        p->vtype = type;
        p->vclass = CLVAR;

/* TYLENG is the type of the field holding the length of a character string */

        p->vstg = (type==TYLENG ? STGLENG : STGARG);
        p->memno = argno;
        return(p);
}




/* mkprim -- Create a PRIM (primary/primitive) block consisting of a
   Nameblock (or Paramblock), arguments (actual params or array
   subscripts) and substring bounds.  Requires that   v   have lots of
   extra (uninitialized) storage, since it could be a paramblock or
   nameblock */

 expptr
#ifdef KR_headers
mkprim(v0, args, substr)
        Namep v0;
        struct Listblock *args;
        chainp substr;
#else
mkprim(Namep v0, struct Listblock *args, chainp substr)
#endif
{
        typedef union {
                struct Paramblock paramblock;
                struct Nameblock nameblock;
                struct Headblock headblock;
                } *Primu;
        Primu v = (Primu)v0;
        struct Primblock *p;

        if(v->headblock.vclass == CLPARAM)
        {

/* v   is to be a Paramblock */

                if(args || substr)
                {
                        errstr("no qualifiers on parameter name %s",
                            v->paramblock.fvarname);
                        frexpr((expptr)args);
                        if(substr)
                        {
                                frexpr((tagptr)substr->datap);
                                frexpr((tagptr)substr->nextp->datap);
                                frchain(&substr);
                        }
                        frexpr((expptr)v);
                        return( errnode() );
                }
                return( (expptr) cpexpr(v->paramblock.paramval) );
        }

        p = ALLOC(Primblock);
        p->tag = TPRIM;
        p->vtype = v->nameblock.vtype;

/* v   is to be a Nameblock */

        p->namep = (Namep) v;
        p->argsp = args;
        if(substr)
        {
                p->fcharp = (expptr) substr->datap;
                p->lcharp = (expptr) substr->nextp->datap;
                frchain(&substr);
        }
        return( (expptr) p);
}



/* vardcl -- attempt to fill out the Name template for variable   v.
   This function is called on identifiers known to be variables or
   recursive references to the same function */

 void
#ifdef KR_headers
vardcl(v)
        Namep v;
#else
vardcl(Namep v)
#endif
{
        struct Dimblock *t;
        expptr neltp;
        extern int doing_stmtfcn;

        if(v->vclass == CLUNKNOWN) {
                v->vclass = CLVAR;
                if (v->vinftype) {
                        v->vtype = TYUNKNOWN;
                        if (v->vdcldone) {
                                v->vdcldone = 0;
                                impldcl(v);
                                }
                        }
                }
        if(v->vdcldone)
                return;
        if(v->vclass == CLNAMELIST)
                return;

        if(v->vtype == TYUNKNOWN)
                impldcl(v);
        else if(v->vclass!=CLVAR && v->vprocclass!=PTHISPROC)
        {
                dclerr("used as variable", v);
                return;
        }
        if(v->vstg==STGUNKNOWN) {
                if (doing_stmtfcn) {
                        /* neither declare this variable if its only use */
                        /* is in defining a stmt function, nor complain  */
                        /* that it is never used */
                        v->vimpldovar = 1;
                        return;
                        }
                v->vstg = implstg[ letter(v->fvarname[0]) ];
                v->vimplstg = 1;
                }

/* Compute the actual storage location, i.e. offsets from base addresses,
   possibly the stack pointer */

        switch(v->vstg)
        {
        case STGBSS:
                v->vardesc.varno = ++lastvarno;
                break;
        case STGAUTO:
                if(v->vclass==CLPROC && v->vprocclass==PTHISPROC)
                        break;
                if(t = v->vdim)
                        if( (neltp = t->nelt) && ISCONST(neltp) ) ;
                        else
                                dclerr("adjustable automatic array", v);
                break;

        default:
                break;
        }
        v->vdcldone = YES;
}



/* Set the implicit type declaration of parameter   p   based on its first
   letter */

 void
#ifdef KR_headers
impldcl(p)
        Namep p;
#else
impldcl(Namep p)
#endif
{
        int k;
        int type;
        ftnint leng;

        if(p->vdcldone || (p->vclass==CLPROC && p->vprocclass==PINTRINSIC) )
                return;
        if(p->vtype == TYUNKNOWN)
        {
                k = letter(p->fvarname[0]);
                type = impltype[ k ];
                leng = implleng[ k ];
                if(type == TYUNKNOWN)
                {
                        if(p->vclass == CLPROC)
                                return;
                        dclerr("attempt to use undefined variable", p);
                        type = dflttype[k];
                        leng = 0;
                }
                settype(p, type, leng);
                p->vimpltype = 1;
        }
}

 void
#ifdef KR_headers
inferdcl(np, type)
        Namep np;
        int type;
#else
inferdcl(Namep np, int type)
#endif
{
        int k = impltype[letter(np->fvarname[0])];
        if (k != type) {
                np->vinftype = 1;
                np->vtype = type;
                frexpr(np->vleng);
                np->vleng = 0;
                }
        np->vimpltype = 0;
        np->vinfproc = 1;
        }

 LOCAL int
#ifdef KR_headers
zeroconst(e)
        expptr e;
#else
zeroconst(expptr e)
#endif
{
        Constp c = (Constp) e;
        if (c->tag == TCONST)
                switch(c->vtype) {
                case TYINT1:
                case TYSHORT:
                case TYLONG:
#ifdef TYQUAD0
                case TYQUAD:
#endif
                        return c->Const.ci == 0;
#ifndef NO_LONG_LONG
                case TYQUAD:
                        return c->Const.cq == 0;
#endif

                case TYREAL:
                case TYDREAL:
                        if (c->vstg == 1)
                                return !strcmp(c->Const.cds[0],"0.");
                        return c->Const.cd[0] == 0.;

                case TYCOMPLEX:
                case TYDCOMPLEX:
                        if (c->vstg == 1)
                                return !strcmp(c->Const.cds[0],"0.")
                                    && !strcmp(c->Const.cds[1],"0.");
                        return c->Const.cd[0] == 0. && c->Const.cd[1] == 0.;
                }
        return 0;
        }

 void
#ifdef KR_headers
paren_used(p) struct Primblock *p;
#else
paren_used(struct Primblock *p)
#endif
{
        Namep np;

        p->parenused = 1;
        if (!p->argsp && (np = p->namep) && np->vdim)
                warn1("inappropriate operation on unsubscripted array %.50s",
                        np->fvarname);
        }

#define ICONEQ(z, c)  (ISICON(z) && z->constblock.Const.ci==c)
#define COMMUTE { e = lp;  lp = rp;  rp = e; }

/* mkexpr -- Make expression, and simplify constant subcomponents (tree
   order is not preserved).  Assumes that   lp   is nonempty, and uses
   fold()   to simplify adjacent constants */

 expptr
#ifdef KR_headers
mkexpr(opcode, lp, rp)
        int opcode;
        expptr lp;
        expptr rp;
#else
mkexpr(int opcode, expptr lp, expptr rp)
#endif
{
        expptr e, e1;
        int etype;
        int ltype, rtype;
        int ltag, rtag;
        long L;
        static long divlineno;

        if (parstate < INEXEC) {

                /* Song and dance to get statement functions right */
                /* while catching incorrect type combinations in the */
                /* first executable statement. */

                ltype = lp->headblock.vtype;
                ltag = lp->tag;
                if(rp && opcode!=OPCALL && opcode!=OPCCALL)
                {
                        rtype = rp->headblock.vtype;
                        rtag = rp->tag;
                }
                else rtype = 0;

                etype = cktype(opcode, ltype, rtype);
                if(etype == TYERROR)
                        goto error;
                goto no_fold;
                }

        ltype = lp->headblock.vtype;
        if (ltype == TYUNKNOWN) {
                lp = fixtype(lp);
                ltype = lp->headblock.vtype;
                }
        ltag = lp->tag;
        if(rp && opcode!=OPCALL && opcode!=OPCCALL)
        {
                rtype = rp->headblock.vtype;
                if (rtype == TYUNKNOWN) {
                        rp = fixtype(rp);
                        rtype = rp->headblock.vtype;
                        }
                rtag = rp->tag;
        }
        else rtype = 0;

        etype = cktype(opcode, ltype, rtype);
        if(etype == TYERROR)
                goto error;

        switch(opcode)
        {
                /* check for multiplication by 0 and 1 and addition to 0 */

        case OPSTAR:
                if( ISCONST(lp) )
                        COMMUTE

                if( ISICON(rp) )
                        {
                                if(rp->constblock.Const.ci == 0)
                                        goto retright;
                                goto mulop;
                        }
                break;

        case OPSLASH:
        case OPMOD:
                if( zeroconst(rp) && lineno != divlineno ) {
                        warn("attempted division by zero");
                        divlineno = lineno;
                        }
                if(opcode == OPMOD)
                        break;

/* Handle multiplying or dividing by 1, -1 */

mulop:
                if( ISICON(rp) )
                {
                        if(rp->constblock.Const.ci == 1)
                                goto retleft;

                        if(rp->constblock.Const.ci == -1)
                        {
                                frexpr(rp);
                                return( mkexpr(OPNEG, lp, ENULL) );
                        }
                }

/* Group all constants together.  In particular,

        (x * CONST1) * CONST2 ==> x * (CONST1 * CONST2)
        (x * CONST1) / CONST2 ==> x * (CONST1 / CONST2)
*/

                if (!ISINT(etype) || lp->tag != TEXPR || !lp->exprblock.rightp
                                || !ISICON(lp->exprblock.rightp))
                        break;

                if (lp->exprblock.opcode == OPLSHIFT) {
                        L = 1 << lp->exprblock.rightp->constblock.Const.ci;
                        if (opcode == OPSTAR || ISICON(rp) &&
                                        !(L % rp->constblock.Const.ci)) {
                                lp->exprblock.opcode = OPSTAR;
                                lp->exprblock.rightp->constblock.Const.ci = L;
                                }
                        }

                if (lp->exprblock.opcode == OPSTAR) {
                        if(opcode == OPSTAR)
                                e = mkexpr(OPSTAR, lp->exprblock.rightp, rp);
                        else if(ISICON(rp) &&
                            (lp->exprblock.rightp->constblock.Const.ci %
                            rp->constblock.Const.ci) == 0)
                                e = mkexpr(OPSLASH, lp->exprblock.rightp, rp);
                        else    break;

                        e1 = lp->exprblock.leftp;
                        free( (charptr) lp );
                        return( mkexpr(OPSTAR, e1, e) );
                        }
                break;


        case OPPLUS:
                if( ISCONST(lp) )
                        COMMUTE
                            goto addop;

        case OPMINUS:
                if( ICONEQ(lp, 0) )
                {
                        frexpr(lp);
                        return( mkexpr(OPNEG, rp, ENULL) );
                }

                if( ISCONST(rp) && is_negatable((Constp)rp))
                {
                        opcode = OPPLUS;
                        consnegop((Constp)rp);
                }

/* Group constants in an addition expression (also subtraction, since the
   subtracted value was negated above).  In particular,

        (x + CONST1) + CONST2 ==> x + (CONST1 + CONST2)
*/

addop:
                if( ISICON(rp) )
                {
                        if(rp->constblock.Const.ci == 0)
                                goto retleft;
                        if( ISPLUSOP(lp) && ISICON(lp->exprblock.rightp) )
                        {
                                e = mkexpr(OPPLUS, lp->exprblock.rightp, rp);
                                e1 = lp->exprblock.leftp;
                                free( (charptr) lp );
                                return( mkexpr(OPPLUS, e1, e) );
                        }
                }
                if (opcode == OPMINUS && (ISINT(etype) || doing_vleng)) {
                        /* check for (i [+const]) - (i [+const]) */
                        if (lp->tag == TPRIM)
                                e = lp;
                        else if (lp->tag == TEXPR && lp->exprblock.opcode == OPPLUS
                                        && lp->exprblock.rightp->tag == TCONST) {
                                e = lp->exprblock.leftp;
                                if (e->tag != TPRIM)
                                        break;
                                }
                        else
                                break;
                        if (e->primblock.argsp)
                                break;
                        if (rp->tag == TPRIM)
                                e1 = rp;
                        else if (rp->tag == TEXPR && rp->exprblock.opcode == OPPLUS
                                        && rp->exprblock.rightp->tag == TCONST) {
                                e1 = rp->exprblock.leftp;
                                if (e1->tag != TPRIM)
                                        break;
                                }
                        else
                                break;
                        if (e->primblock.namep != e1->primblock.namep
                                        || e1->primblock.argsp)
                                break;
                        L = e == lp ? 0 : lp->exprblock.rightp->constblock.Const.ci;
                        if (e1 != rp)
                                L -= rp->exprblock.rightp->constblock.Const.ci;
                        frexpr(lp);
                        frexpr(rp);
                        return ICON(L);
                        }

                break;


        case OPPOWER:
                break;

/* Eliminate outermost double negations */

        case OPNEG:
        case OPNEG1:
                if(ltag==TEXPR && lp->exprblock.opcode==OPNEG)
                {
                        e = lp->exprblock.leftp;
                        free( (charptr) lp );
                        return(e);
                }
                break;

/* Eliminate outermost double NOTs */

        case OPNOT:
                if(ltag==TEXPR && lp->exprblock.opcode==OPNOT)
                {
                        e = lp->exprblock.leftp;
                        free( (charptr) lp );
                        return(e);
                }
                break;

        case OPCALL:
        case OPCCALL:
                etype = ltype;
                if(rp!=NULL && rp->listblock.listp==NULL)
                {
                        free( (charptr) rp );
                        rp = NULL;
                }
                break;

        case OPAND:
        case OPOR:
                if( ISCONST(lp) )
                        COMMUTE

                            if( ISCONST(rp) )
                        {
                                if(rp->constblock.Const.ci == 0)
                                        if(opcode == OPOR)
                                                goto retleft;
                                        else
                                                goto retright;
                                else if(opcode == OPOR)
                                        goto retright;
                                else
                                        goto retleft;
                        }
        case OPEQV:
        case OPNEQV:

        case OPBITAND:
        case OPBITOR:
        case OPBITXOR:
        case OPBITNOT:
        case OPLSHIFT:
        case OPRSHIFT:
        case OPBITTEST:
        case OPBITCLR:
        case OPBITSET:
#ifdef TYQUAD
        case OPQBITCLR:
        case OPQBITSET:
#endif

        case OPLT:
        case OPGT:
        case OPLE:
        case OPGE:
        case OPEQ:
        case OPNE:

        case OPCONCAT:
                break;
        case OPMIN:
        case OPMAX:
        case OPMIN2:
        case OPMAX2:
        case OPDMIN:
        case OPDMAX:

        case OPASSIGN:
        case OPASSIGNI:
        case OPPLUSEQ:
        case OPSTAREQ:
        case OPMINUSEQ:
        case OPSLASHEQ:
        case OPMODEQ:
        case OPLSHIFTEQ:
        case OPRSHIFTEQ:
        case OPBITANDEQ:
        case OPBITXOREQ:
        case OPBITOREQ:

        case OPCONV:
        case OPADDR:
        case OPWHATSIN:

        case OPCOMMA:
        case OPCOMMA_ARG:
        case OPQUEST:
        case OPCOLON:
        case OPDOT:
        case OPARROW:
        case OPIDENTITY:
        case OPCHARCAST:
        case OPABS:
        case OPDABS:
                break;

        default:
                badop("mkexpr", opcode);
        }

 no_fold:
        e = (expptr) ALLOC(Exprblock);
        e->exprblock.tag = TEXPR;
        e->exprblock.opcode = opcode;
        e->exprblock.vtype = etype;
        e->exprblock.leftp = lp;
        e->exprblock.rightp = rp;
        if(ltag==TCONST && (rp==0 || rtag==TCONST) )
                e = fold(e);
        return(e);

retleft:
        frexpr(rp);
        if (lp->tag == TPRIM)
                paren_used(&lp->primblock);
        return(lp);

retright:
        frexpr(lp);
        if (rp->tag == TPRIM)
                paren_used(&rp->primblock);
        return(rp);

error:
        frexpr(lp);
        if(rp && opcode!=OPCALL && opcode!=OPCCALL)
                frexpr(rp);
        return( errnode() );
}

#define ERR(s)   { errs = s; goto error; }

/* cktype -- Check and return the type of the expression */

 int
#ifdef KR_headers
cktype(op, lt, rt)
        int op;
        int lt;
        int rt;
#else
cktype(int op, int lt, int rt)
#endif
{
        char *errs;

        if(lt==TYERROR || rt==TYERROR)
                goto error1;

        if(lt==TYUNKNOWN)
                return(TYUNKNOWN);
        if(rt==TYUNKNOWN)

/* If not unary operation, return UNKNOWN */

                if(!is_unary_op (op) && op != OPCALL && op != OPCCALL)
                        return(TYUNKNOWN);

        switch(op)
        {
        case OPPLUS:
        case OPMINUS:
        case OPSTAR:
        case OPSLASH:
        case OPPOWER:
        case OPMOD:
                if( ISNUMERIC(lt) && ISNUMERIC(rt) )
                        return( maxtype(lt, rt) );
                ERR("nonarithmetic operand of arithmetic operator")

        case OPNEG:
        case OPNEG1:
                if( ISNUMERIC(lt) )
                        return(lt);
                ERR("nonarithmetic operand of negation")

        case OPNOT:
                if(ISLOGICAL(lt))
                        return(lt);
                ERR("NOT of nonlogical")

        case OPAND:
        case OPOR:
        case OPEQV:
        case OPNEQV:
                if(ISLOGICAL(lt) && ISLOGICAL(rt))
                        return( maxtype(lt, rt) );
                ERR("nonlogical operand of logical operator")

        case OPLT:
        case OPGT:
        case OPLE:
        case OPGE:
        case OPEQ:
        case OPNE:
                if(lt==TYCHAR || rt==TYCHAR || ISLOGICAL(lt) || ISLOGICAL(rt))
                {
                        if(lt != rt){
                                if (htype
                                        && (lt == TYCHAR && ISNUMERIC(rt)
                                         || rt == TYCHAR && ISNUMERIC(lt)))
                                                return TYLOGICAL;
                                ERR("illegal comparison")
                                }
                }

                else if( ISCOMPLEX(lt) || ISCOMPLEX(rt) )
                {
                        if(op!=OPEQ && op!=OPNE)
                                ERR("order comparison of complex data")
                }

                else if( ! ISNUMERIC(lt) || ! ISNUMERIC(rt) )
                        ERR("comparison of nonarithmetic data")
        case OPBITTEST:
                return(TYLOGICAL);

        case OPCONCAT:
                if(lt==TYCHAR && rt==TYCHAR)
                        return(TYCHAR);
                ERR("concatenation of nonchar data")

        case OPCALL:
        case OPCCALL:
        case OPIDENTITY:
                return(lt);

        case OPADDR:
        case OPCHARCAST:
                return(TYADDR);

        case OPCONV:
                if(rt == 0)
                        return(0);
                if(lt==TYCHAR && ISINT(rt) )
                        return(TYCHAR);
                if (ISLOGICAL(lt) && ISLOGICAL(rt)
                ||  ISINT(lt) && rt == TYCHAR)
                        return lt;
        case OPASSIGN:
        case OPASSIGNI:
        case OPMINUSEQ:
        case OPPLUSEQ:
        case OPSTAREQ:
        case OPSLASHEQ:
        case OPMODEQ:
        case OPLSHIFTEQ:
        case OPRSHIFTEQ:
        case OPBITANDEQ:
        case OPBITXOREQ:
        case OPBITOREQ:
                if (ISLOGICAL(lt) && ISLOGICAL(rt) && op == OPASSIGN)
                        return lt;
                if(lt==TYCHAR || rt==TYCHAR || ISLOGICAL(lt) || ISLOGICAL(rt))
                        if((op!=OPASSIGN && op != OPPLUSEQ && op != OPMINUSEQ)
                            || (lt!=rt))
                        {
                                ERR("impossible conversion")
                        }
                return(lt);

        case OPMIN:
        case OPMAX:
        case OPDMIN:
        case OPDMAX:
        case OPMIN2:
        case OPMAX2:
        case OPBITOR:
        case OPBITAND:
        case OPBITXOR:
        case OPBITNOT:
        case OPLSHIFT:
        case OPRSHIFT:
        case OPWHATSIN:
        case OPABS:
        case OPDABS:
                return(lt);

        case OPBITCLR:
        case OPBITSET:
#ifdef TYQUAD0
        case OPQBITCLR:
        case OPQBITSET:
#endif
                if (lt < TYLONG)
                        lt = TYLONG;
                return(lt);
#ifndef NO_LONG_LONG
        case OPQBITCLR:
        case OPQBITSET:
                return TYQUAD;
#endif

        case OPCOMMA:
        case OPCOMMA_ARG:
        case OPQUEST:
        case OPCOLON:           /* Only checks the rightmost type because
                                   of C language definition (rightmost
                                   comma-expr is the value of the expr) */
                return(rt);

        case OPDOT:
        case OPARROW:
            return (lt);
        default:
                badop("cktype", op);
        }
error:
        err(errs);
error1:
        return(TYERROR);
}

 static void
intovfl(Void)
{ err("overflow simplifying integer constants."); }

#ifndef NO_LONG_LONG
 static void
#ifdef KR_headers
LRget(Lp, Rp, lp, rp) Llong *Lp, *Rp; expptr lp, rp;
#else
LRget(Llong *Lp, Llong *Rp, expptr lp, expptr rp)
#endif
{
        if (lp->headblock.vtype == TYQUAD)
                *Lp = lp->constblock.Const.cq;
        else
                *Lp = lp->constblock.Const.ci;
        if (rp->headblock.vtype == TYQUAD)
                *Rp = rp->constblock.Const.cq;
        else
                *Rp = rp->constblock.Const.ci;
        }
#endif /*NO_LONG_LONG*/

/* fold -- simplifies constant expressions; it assumes that e -> leftp and
   e -> rightp are TCONST or NULL */

 expptr
#ifdef KR_headers
fold(e)
        expptr e;
#else
fold(expptr e)
#endif
{
        Constp p;
        expptr lp, rp;
        int etype, mtype, ltype, rtype, opcode;
        ftnint i, bl, ll, lr;
        char *q, *s;
        struct Constblock lcon, rcon;
        ftnint L;
        double d;
#ifndef NO_LONG_LONG
        Llong LL, LR;
#endif

        opcode = e->exprblock.opcode;
        etype = e->exprblock.vtype;

        lp = e->exprblock.leftp;
        ltype = lp->headblock.vtype;
        rp = e->exprblock.rightp;

        if(rp == 0)
                switch(opcode)
                {
                case OPNOT:
#ifndef NO_LONG_LONG
                        if (ltype == TYQUAD)
                         lp->constblock.Const.cq = ! lp->constblock.Const.cq;
                        else
#endif
                         lp->constblock.Const.ci = ! lp->constblock.Const.ci;
 retlp:
                        e->exprblock.leftp = 0;
                        frexpr(e);
                        return(lp);

                case OPBITNOT:
#ifndef NO_LONG_LONG
                        if (ltype == TYQUAD)
                         lp->constblock.Const.cq = ~ lp->constblock.Const.cq;
                        else
#endif
                        lp->constblock.Const.ci = ~ lp->constblock.Const.ci;
                        goto retlp;

                case OPNEG:
                case OPNEG1:
                        consnegop((Constp)lp);
                        goto retlp;

                case OPCONV:
                case OPADDR:
                        return(e);

                case OPABS:
                case OPDABS:
                        switch(ltype) {
                            case TYINT1:
                            case TYSHORT:
                            case TYLONG:
                                if ((L = lp->constblock.Const.ci) < 0) {
                                        lp->constblock.Const.ci = -L;
                                        if (L != -lp->constblock.Const.ci)
                                                intovfl();
                                        }
                                goto retlp;
#ifndef NO_LONG_LONG
                            case TYQUAD:
                                if ((LL = lp->constblock.Const.cq) < 0) {
                                        lp->constblock.Const.cq = -LL;
                                        if (LL != -lp->constblock.Const.cq)
                                                intovfl();
                                        }
                                goto retlp;
#endif
                            case TYREAL:
                            case TYDREAL:
                                if (lp->constblock.vstg) {
                                    s = lp->constblock.Const.cds[0];
                                    if (*s == '-')
                                        lp->constblock.Const.cds[0] = s + 1;
                                    goto retlp;
                                }
                                if ((d = lp->constblock.Const.cd[0]) < 0.)
                                        lp->constblock.Const.cd[0] = -d;
                            case TYCOMPLEX:
                            case TYDCOMPLEX:
                                return e;       /* lazy way out */
                            }
                default:
                        badop("fold", opcode);
                }

        rtype = rp->headblock.vtype;

        p = ALLOC(Constblock);
        p->tag = TCONST;
        p->vtype = etype;
        p->vleng = e->exprblock.vleng;

        switch(opcode)
        {
        case OPCOMMA:
        case OPCOMMA_ARG:
        case OPQUEST:
        case OPCOLON:
                goto ereturn;

        case OPAND:
                p->Const.ci = lp->constblock.Const.ci &&
                    rp->constblock.Const.ci;
                break;

        case OPOR:
                p->Const.ci = lp->constblock.Const.ci ||
                    rp->constblock.Const.ci;
                break;

        case OPEQV:
                p->Const.ci = lp->constblock.Const.ci ==
                    rp->constblock.Const.ci;
                break;

        case OPNEQV:
                p->Const.ci = lp->constblock.Const.ci !=
                    rp->constblock.Const.ci;
                break;

        case OPBITAND:
#ifndef NO_LONG_LONG
                if (etype == TYQUAD) {
                        LRget(&LL, &LR, lp, rp);
                        p->Const.cq = LL & LR;
                        }
                else
#endif
                p->Const.ci = lp->constblock.Const.ci &
                    rp->constblock.Const.ci;
                break;

        case OPBITOR:
#ifndef NO_LONG_LONG
                if (etype == TYQUAD) {
                        LRget(&LL, &LR, lp, rp);
                        p->Const.cq = LL | LR;
                        }
                else
#endif
                p->Const.ci = lp->constblock.Const.ci |
                    rp->constblock.Const.ci;
                break;

        case OPBITXOR:
#ifndef NO_LONG_LONG
                if (etype == TYQUAD) {
                        LRget(&LL, &LR, lp, rp);
                        p->Const.cq = LL ^ LR;
                        }
                else
#endif
                p->Const.ci = lp->constblock.Const.ci ^
                    rp->constblock.Const.ci;
                break;

        case OPLSHIFT:
#ifndef NO_LONG_LONG
                if (etype == TYQUAD) {
                        LRget(&LL, &LR, lp, rp);
                        p->Const.cq = LL << (int)LR;
                        if (p->Const.cq >> (int)LR != LL)
                                intovfl();
                        break;
                        }
#endif
                p->Const.ci = lp->constblock.Const.ci <<
                    rp->constblock.Const.ci;
                if ((((unsigned long)p->Const.ci) >> rp->constblock.Const.ci)
                                != lp->constblock.Const.ci)
                        intovfl();
                break;

        case OPRSHIFT:
#ifndef NO_LONG_LONG
                if (etype == TYQUAD) {
                        LRget(&LL, &LR, lp, rp);
                        p->Const.cq = LL >> (int)LR;
                        }
                else
#endif
                p->Const.ci = (unsigned long)lp->constblock.Const.ci >>
                    rp->constblock.Const.ci;
                break;

        case OPBITTEST:
#ifndef NO_LONG_LONG
                if (ltype == TYQUAD)
                        p->Const.ci = (lp->constblock.Const.cq &
                                1LL << rp->constblock.Const.ci) != 0;
                else
#endif
                p->Const.ci = (lp->constblock.Const.ci &
                                1L << rp->constblock.Const.ci) != 0;
                break;

        case OPBITCLR:
#ifndef NO_LONG_LONG
                if (etype == TYQUAD) {
                        LRget(&LL, &LR, lp, rp);
                        p->Const.cq = LL & ~(1LL << (int)LR);
                        }
                else
#endif
                p->Const.ci = lp->constblock.Const.ci &
                                ~(1L << rp->constblock.Const.ci);
                break;

        case OPBITSET:
#ifndef NO_LONG_LONG
                if (etype == TYQUAD) {
                        LRget(&LL, &LR, lp, rp);
                        p->Const.cq = LL | (1LL << (int)LR);
                        }
                else
#endif
                p->Const.ci = lp->constblock.Const.ci |
                                1L << rp->constblock.Const.ci;
                break;

        case OPCONCAT:
                ll = lp->constblock.vleng->constblock.Const.ci;
                lr = rp->constblock.vleng->constblock.Const.ci;
                bl = lp->constblock.Const.ccp1.blanks;
                p->Const.ccp = q = (char *) ckalloc(ll+lr+bl);
                p->Const.ccp1.blanks = rp->constblock.Const.ccp1.blanks;
                p->vleng = ICON(ll+lr+bl);
                s = lp->constblock.Const.ccp;
                for(i = 0 ; i < ll ; ++i)
                        *q++ = *s++;
                for(i = 0 ; i < bl ; i++)
                        *q++ = ' ';
                s = rp->constblock.Const.ccp;
                for(i = 0; i < lr; ++i)
                        *q++ = *s++;
                break;


        case OPPOWER:
                if( !ISINT(rtype)
                 || rp->constblock.Const.ci < 0 && zeroconst(lp))
                        goto ereturn;
                conspower(p, (Constp)lp, rp->constblock.Const.ci);
                break;

        case OPSLASH:
                if (zeroconst(rp))
                        goto ereturn;
                /* no break */

        default:
                if(ltype == TYCHAR)
                {
                        lcon.Const.ci = cmpstr(lp->constblock.Const.ccp,
                            rp->constblock.Const.ccp,
                            lp->constblock.vleng->constblock.Const.ci,
                            rp->constblock.vleng->constblock.Const.ci);
                        rcon.Const.ci = 0;
                        mtype = tyint;
                }
                else    {
                        mtype = maxtype(ltype, rtype);
                        consconv(mtype, &lcon, &lp->constblock);
                        consconv(mtype, &rcon, &rp->constblock);
                }
                consbinop(opcode, mtype, p, &lcon, &rcon);
                break;
        }

        frexpr(e);
        return( (expptr) p );
 ereturn:
        free((char *)p);
        return e;
}



/* assign constant l = r , doing coercion */

 void
#ifdef KR_headers
consconv(lt, lc, rc)
        int lt;
        Constp lc;
        Constp rc;
#else
consconv(int lt, Constp lc, Constp rc)
#endif
{
        int rt = rc->vtype;
        union Constant *lv = &lc->Const, *rv = &rc->Const;

        lc->vtype = lt;
        if (ONEOF(lt, MSKREAL|MSKCOMPLEX) && ONEOF(rt, MSKREAL|MSKCOMPLEX)) {
                memcpy((char *)lv, (char *)rv, sizeof(union Constant));
                lc->vstg = rc->vstg;
                if (ISCOMPLEX(lt) && ISREAL(rt)) {
                        if (rc->vstg)
                                lv->cds[1] = cds("0",CNULL);
                        else
                                lv->cd[1] = 0.;
                        }
                return;
                }
        lc->vstg = 0;

        switch(lt)
        {

/* Casting to character means just copying the first sizeof (character)
   bytes into a new 1 character string.  This is weird. */

        case TYCHAR:
                *(lv->ccp = (char *) ckalloc(1)) = (char)rv->ci;
                lv->ccp1.blanks = 0;
                break;

        case TYINT1:
        case TYSHORT:
        case TYLONG:
#ifdef TYQUAD0
        case TYQUAD:
#endif
                if(rt == TYCHAR)
                        lv->ci = rv->ccp[0];
                else if( ISINT(rt) ) {
#ifndef NO_LONG_LONG
                        if (rt == TYQUAD)
                                lv->ci = (ftnint)(rv->cq);
                        else
#endif
                        lv->ci = rv->ci;
                        }
                else    lv->ci = (ftnint)(rc->vstg
                                        ? atof(rv->cds[0]) : rv->cd[0]);

                break;
#ifndef NO_LONG_LONG
        case TYQUAD:
                if(rt == TYCHAR)
                        lv->cq = rv->ccp[0];
                else if( ISINT(rt) ) {
                        if (rt == TYQUAD)
                                lv->cq = rv->cq;
                        else
                                lv->cq = rv->ci;
                        }
                else    lv->cq = (ftnint)(rc->vstg
                                        ? atof(rv->cds[0]) : rv->cd[0]);

                break;
#endif

        case TYCOMPLEX:
        case TYDCOMPLEX:
                lv->cd[1] = 0.;

        case TYREAL:
        case TYDREAL:
#ifndef NO_LONG_LONG
                if (rt == TYQUAD)
                        lv->cd[0] = (double)(rv->cq);
                else
#endif
                lv->cd[0] = rv->ci;
                break;

        case TYLOGICAL:
        case TYLOGICAL1:
        case TYLOGICAL2:
                lv->ci = rv->ci;
                break;
        }
}



/* Negate constant value -- changes the input node's value */

 void
#ifdef KR_headers
consnegop(p)
        Constp p;
#else
consnegop(Constp p)
#endif
{
        char *s;
        ftnint L;
#ifndef NO_LONG_LONG
        Llong LL;
#endif

        if (p->vstg) {
                /* 20010820: comment out "*s == '0' ? s :" to preserve */
                /* the sign of zero */
                if (ISCOMPLEX(p->vtype)) {
                        s = p->Const.cds[1];
                        p->Const.cds[1] = *s == '-' ? s+1
                                        : /* *s == '0' ? s : */ s-1;
                        }
                s = p->Const.cds[0];
                p->Const.cds[0] = *s == '-' ? s+1
                                : /* *s == '0' ? s : */ s-1;
                return;
                }
        switch(p->vtype)
        {
        case TYINT1:
        case TYSHORT:
        case TYLONG:
#ifdef TYQUAD0
        case TYQUAD:
#endif
                p->Const.ci = -(L = p->Const.ci);
                if (L != -p->Const.ci)
                        intovfl();
                break;
#ifndef NO_LONG_LONG
        case TYQUAD:
                p->Const.cq = -(LL = p->Const.cq);
                if (LL != -p->Const.cq)
                        intovfl();
                break;
#endif
        case TYCOMPLEX:
        case TYDCOMPLEX:
                p->Const.cd[1] = - p->Const.cd[1];
                /* fall through and do the real parts */
        case TYREAL:
        case TYDREAL:
                p->Const.cd[0] = - p->Const.cd[0];
                break;
        default:
                badtype("consnegop", p->vtype);
        }
}



/* conspower -- Expand out an exponentiation */

 LOCAL void
#ifdef KR_headers
conspower(p, ap, n)
        Constp p;
        Constp ap;
        ftnint n;
#else
conspower(Constp p, Constp ap, ftnint n)
#endif
{
        union Constant *powp = &p->Const;
        int type;
        struct Constblock x, x0;

        if (n == 1) {
                memcpy((char *)powp, (char *)&ap->Const, sizeof(ap->Const));
                return;
                }

        switch(type = ap->vtype)        /* pow = 1 */
        {
        case TYINT1:
        case TYSHORT:
        case TYLONG:
#ifdef TYQUAD0
        case TYQUAD:
#endif
                powp->ci = 1;
                break;
#ifndef NO_LONG_LONG
        case TYQUAD:
                powp->cq = 1;
                break;
#endif
        case TYCOMPLEX:
        case TYDCOMPLEX:
                powp->cd[1] = 0;
        case TYREAL:
        case TYDREAL:
                powp->cd[0] = 1;
                break;
        default:
                badtype("conspower", type);
        }

        if(n == 0)
                return;
        switch(type)    /* x0 = ap */
        {
        case TYINT1:
        case TYSHORT:
        case TYLONG:
#ifdef TYQUAD0
        case TYQUAD:
#endif
                x0.Const.ci = ap->Const.ci;
                break;
#ifndef NO_LONG_LONG
        case TYQUAD:
                x0.Const.cq = ap->Const.cq;
                break;
#endif
        case TYCOMPLEX:
        case TYDCOMPLEX:
                x0.Const.cd[1] =
                        ap->vstg ? atof(ap->Const.cds[1]) : ap->Const.cd[1];
        case TYREAL:
        case TYDREAL:
                x0.Const.cd[0] =
                        ap->vstg ? atof(ap->Const.cds[0]) : ap->Const.cd[0];
                break;
        }
        x0.vtype = type;
        x0.vstg = 0;
        if(n < 0)
        {
                n = -n;
                if( ISINT(type) )
                {
                        switch(ap->Const.ci) {
                                case 0:
                                        err("0 ** negative number");
                                        return;
                                case 1:
                                case -1:
                                        goto mult;
                                }
                        err("integer ** negative number");
                        return;
                }
                else if (!x0.Const.cd[0]
                                && (!ISCOMPLEX(type) || !x0.Const.cd[1])) {
                        err("0.0 ** negative number");
                        return;
                        }
                consbinop(OPSLASH, type, &x, p, &x0);
        }
        else
 mult:          consbinop(OPSTAR, type, &x, p, &x0);

        for( ; ; )
        {
                if(n & 01)
                        consbinop(OPSTAR, type, p, p, &x);
                if(n >>= 1)
                        consbinop(OPSTAR, type, &x, &x, &x);
                else
                        break;
        }
}



/* do constant operation cp = a op b -- assumes that   ap and bp   have data
   matching the input   type */

 LOCAL void
#ifdef KR_headers
consbinop(opcode, type, cpp, app, bpp)
        int opcode;
        int type;
        Constp cpp;
        Constp app;
        Constp bpp;
#else
consbinop(int opcode, int type, Constp cpp, Constp app, Constp bpp)
#endif
{
        union Constant *ap = &app->Const,
                                *bp = &bpp->Const,
                                *cp = &cpp->Const;
        ftnint k;
        double ad[2], bd[2], temp;
        ftnint a, b;
#ifndef NO_LONG_LONG
        Llong aL, bL;
#endif

        cpp->vstg = 0;

        if (ONEOF(type, MSKREAL|MSKCOMPLEX)) {
                ad[0] = app->vstg ? atof(ap->cds[0]) : ap->cd[0];
                bd[0] = bpp->vstg ? atof(bp->cds[0]) : bp->cd[0];
                if (ISCOMPLEX(type)) {
                        ad[1] = app->vstg ? atof(ap->cds[1]) : ap->cd[1];
                        bd[1] = bpp->vstg ? atof(bp->cds[1]) : bp->cd[1];
                        }
                }
        switch(opcode)
        {
        case OPPLUS:
                switch(type)
                {
                case TYINT1:
                case TYSHORT:
                case TYLONG:
#ifdef TYQUAD0
                case TYQUAD:
#endif
                        cp->ci = ap->ci + bp->ci;
                        if (ap->ci != cp->ci - bp->ci)
                                intovfl();
                        break;
#ifndef NO_LONG_LONG
                case TYQUAD:
                        cp->cq = ap->cq + bp->cq;
                        if (ap->cq != cp->cq - bp->cq)
                                intovfl();
                        break;
#endif
                case TYCOMPLEX:
                case TYDCOMPLEX:
                        cp->cd[1] = ad[1] + bd[1];
                case TYREAL:
                case TYDREAL:
                        cp->cd[0] = ad[0] + bd[0];
                        break;
                }
                break;

        case OPMINUS:
                switch(type)
                {
                case TYINT1:
                case TYSHORT:
                case TYLONG:
#ifdef TYQUAD0
                case TYQUAD:
#endif
                        cp->ci = ap->ci - bp->ci;
                        if (ap->ci != bp->ci + cp->ci)
                                intovfl();
                        break;
#ifndef NO_LONG_LONG
                case TYQUAD:
                        cp->cq = ap->cq - bp->cq;
                        if (ap->cq != bp->cq + cp->cq)
                                intovfl();
                        break;
#endif
                case TYCOMPLEX:
                case TYDCOMPLEX:
                        cp->cd[1] = ad[1] - bd[1];
                case TYREAL:
                case TYDREAL:
                        cp->cd[0] = ad[0] - bd[0];
                        break;
                }
                break;

        case OPSTAR:
                switch(type)
                {
                case TYINT1:
                case TYSHORT:
                case TYLONG:
#ifdef TYQUAD0
                case TYQUAD:
#endif
                        cp->ci = (a = ap->ci) * (b = bp->ci);
                        if (a && cp->ci / a != b)
                                intovfl();
                        break;
#ifndef NO_LONG_LONG
                case TYQUAD:
                        cp->cq = (aL = ap->cq) * (bL = bp->cq);
                        if (aL && cp->cq / aL != bL)
                                intovfl();
                        break;
#endif
                case TYREAL:
                case TYDREAL:
                        cp->cd[0] = ad[0] * bd[0];
                        break;
                case TYCOMPLEX:
                case TYDCOMPLEX:
                        temp = ad[0] * bd[0]  -  ad[1] * bd[1] ;
                        cp->cd[1] = ad[0] * bd[1]  +  ad[1] * bd[0] ;
                        cp->cd[0] = temp;
                        break;
                }
                break;
        case OPSLASH:
                switch(type)
                {
                case TYINT1:
                case TYSHORT:
                case TYLONG:
#ifdef TYQUAD0
                case TYQUAD:
#endif
                        cp->ci = ap->ci / bp->ci;
                        break;
#ifndef NO_LONG_LONG
                case TYQUAD:
                        cp->cq = ap->cq / bp->cq;
                        break;
#endif
                case TYREAL:
                case TYDREAL:
                        cp->cd[0] = ad[0] / bd[0];
                        break;
                case TYCOMPLEX:
                case TYDCOMPLEX:
                        zdiv((dcomplex*)cp, (dcomplex*)ad, (dcomplex*)bd);
                        break;
                }
                break;

        case OPMOD:
                if( ISINT(type) )
                {
#ifndef NO_LONG_LONG
                        if (type == TYQUAD)
                                cp->cq = ap->cq % bp->cq;
                        else
#endif
                                cp->ci = ap->ci % bp->ci;
                        break;
                }
                else
                        Fatal("inline mod of noninteger");

        case OPMIN2:
        case OPDMIN:
                switch(type)
                {
                case TYINT1:
                case TYSHORT:
                case TYLONG:
#ifdef TYQUAD0
                case TYQUAD:
#endif
                        cp->ci = ap->ci <= bp->ci ? ap->ci : bp->ci;
                        break;
#ifndef NO_LONG_LONG
                case TYQUAD:
                        cp->cq = ap->cq <= bp->cq ? ap->cq : bp->cq;
                        break;
#endif
                case TYREAL:
                case TYDREAL:
                        cp->cd[0] = ad[0] <= bd[0] ? ad[0] : bd[0];
                        break;
                default:
                        Fatal("inline min of exected type");
                }
                break;

        case OPMAX2:
        case OPDMAX:
                switch(type)
                {
                case TYINT1:
                case TYSHORT:
                case TYLONG:
#ifdef TYQUAD0
                case TYQUAD:
#endif
                        cp->ci = ap->ci >= bp->ci ? ap->ci : bp->ci;
                        break;
#ifndef NO_LONG_LONG
                case TYQUAD:
                        cp->cq = ap->cq >= bp->cq ? ap->cq : bp->cq;
                        break;
#endif
                case TYREAL:
                case TYDREAL:
                        cp->cd[0] = ad[0] >= bd[0] ? ad[0] : bd[0];
                        break;
                default:
                        Fatal("inline max of exected type");
                }
                break;

        default:          /* relational ops */
                switch(type)
                {
                case TYINT1:
                case TYSHORT:
                case TYLONG:
#ifdef TYQUAD0
                case TYQUAD:
#endif
                        if(ap->ci < bp->ci)
                                k = -1;
                        else if(ap->ci == bp->ci)
                                k = 0;
                        else    k = 1;
                        break;
#ifndef NO_LONG_LONG
                case TYQUAD:
                        if(ap->cq < bp->cq)
                                k = -1;
                        else if(ap->cq == bp->cq)
                                k = 0;
                        else    k = 1;
                        break;
#endif
                case TYREAL:
                case TYDREAL:
                        if(ad[0] < bd[0])
                                k = -1;
                        else if(ad[0] == bd[0])
                                k = 0;
                        else    k = 1;
                        break;
                case TYCOMPLEX:
                case TYDCOMPLEX:
                        if(ad[0] == bd[0] &&
                            ad[1] == bd[1] )
                                k = 0;
                        else    k = 1;
                        break;
                case TYLOGICAL:
                        k = ap->ci - bp->ci;
                }

                switch(opcode)
                {
                case OPEQ:
                        cp->ci = (k == 0);
                        break;
                case OPNE:
                        cp->ci = (k != 0);
                        break;
                case OPGT:
                        cp->ci = (k == 1);
                        break;
                case OPLT:
                        cp->ci = (k == -1);
                        break;
                case OPGE:
                        cp->ci = (k >= 0);
                        break;
                case OPLE:
                        cp->ci = (k <= 0);
                        break;
                }
                break;
        }
}



/* conssgn - returns the sign of a Fortran constant */

 int
#ifdef KR_headers
conssgn(p)
        expptr p;
#else
conssgn(expptr p)
#endif
{
        char *s;

        if( ! ISCONST(p) )
                Fatal( "sgn(nonconstant)" );

        switch(p->headblock.vtype)
        {
        case TYINT1:
        case TYSHORT:
        case TYLONG:
#ifdef TYQUAD0
        case TYQUAD:
#endif
                if(p->constblock.Const.ci > 0) return(1);
                if(p->constblock.Const.ci < 0) return(-1);
                return(0);
#ifndef NO_LONG_LONG
        case TYQUAD:
                if(p->constblock.Const.cq > 0) return(1);
                if(p->constblock.Const.cq < 0) return(-1);
                return(0);
#endif

        case TYREAL:
        case TYDREAL:
                if (p->constblock.vstg) {
                        s = p->constblock.Const.cds[0];
                        if (*s == '-')
                                return -1;
                        if (*s == '0')
                                return 0;
                        return 1;
                        }
                if(p->constblock.Const.cd[0] > 0) return(1);
                if(p->constblock.Const.cd[0] < 0) return(-1);
                return(0);


/* The sign of a complex number is 0 iff the number is 0 + 0i, else it's 1 */

        case TYCOMPLEX:
        case TYDCOMPLEX:
                if (p->constblock.vstg)
                        return *p->constblock.Const.cds[0] != '0'
                            && *p->constblock.Const.cds[1] != '0';
                return(p->constblock.Const.cd[0]!=0 || p->constblock.Const.cd[1]!=0);

        default:
                badtype( "conssgn", p->constblock.vtype);
        }
        /* NOT REACHED */ return 0;
}

char *powint[ ] = {
        "pow_ii",
#ifdef TYQUAD
                  "pow_qq",
#endif
                  "pow_ri", "pow_di", "pow_ci", "pow_zi" };

 LOCAL expptr
#ifdef KR_headers
mkpower(p)
        expptr p;
#else
mkpower(expptr p)
#endif
{
        expptr q, lp, rp;
        int ltype, rtype, mtype, tyi;

        lp = p->exprblock.leftp;
        rp = p->exprblock.rightp;
        ltype = lp->headblock.vtype;
        rtype = rp->headblock.vtype;

        if (lp->tag == TADDR)
                lp->addrblock.parenused = 0;

        if (rp->tag == TADDR)
                rp->addrblock.parenused = 0;

        if(ISICON(rp))
        {
                if(rp->constblock.Const.ci == 0)
                {
                        frexpr(p);
                        if( ISINT(ltype) )
                                return( ICON(1) );
                        else if (ISREAL (ltype))
                                return mkconv (ltype, ICON (1));
                        else
                                return( (expptr) putconst((Constp)
                                        mkconv(ltype, ICON(1))) );
                }
                if(rp->constblock.Const.ci < 0)
                {
                        if( ISINT(ltype) )
                        {
                                frexpr(p);
                                err("integer**negative");
                                return( errnode() );
                        }
                        rp->constblock.Const.ci = - rp->constblock.Const.ci;
                        p->exprblock.leftp = lp
                                = fixexpr((Exprp)mkexpr(OPSLASH, ICON(1), lp));
                }
                if(rp->constblock.Const.ci == 1)
                {
                        frexpr(rp);
                        free( (charptr) p );
                        return(lp);
                }

                if( ONEOF(ltype, MSKINT|MSKREAL) ) {
                        p->exprblock.vtype = ltype;
                        return(p);
                }
        }
        if( ISINT(rtype) )
        {
                if(ltype==TYSHORT && rtype==TYSHORT && (!ISCONST(lp) || tyint==TYSHORT) )
                        q = call2(TYSHORT, "pow_hh", lp, rp);
                else    {
                        if(ONEOF(ltype,M(TYINT1)|M(TYSHORT)))
                        {
                                ltype = TYLONG;
                                lp = mkconv(TYLONG,lp);
                        }
#ifdef TYQUAD
                        if (ltype == TYQUAD)
                                rp = mkconv(TYQUAD,rp);
                        else
#endif
                        rp = mkconv(TYLONG,rp);
                        if (ISCONST(rp)) {
                                tyi = tyint;
                                tyint = TYLONG;
                                rp = (expptr)putconst((Constp)rp);
                                tyint = tyi;
                                }
                        q = call2(ltype, powint[ltype-TYLONG], lp, rp);
                }
        }
        else if( ISREAL( (mtype = maxtype(ltype,rtype)) )) {
                extern int callk_kludge;
                callk_kludge = TYDREAL;
                q = call2(mtype, "pow_dd", mkconv(TYDREAL,lp), mkconv(TYDREAL,rp));
                callk_kludge = 0;
                }
        else    {
                q  = call2(TYDCOMPLEX, "pow_zz",
                    mkconv(TYDCOMPLEX,lp), mkconv(TYDCOMPLEX,rp));
                if(mtype == TYCOMPLEX)
                        q = mkconv(TYCOMPLEX, q);
        }
        free( (charptr) p );
        return(q);
}


/* Complex Division.  Same code as in Runtime Library
*/


 LOCAL void
#ifdef KR_headers
zdiv(c, a, b)
        dcomplex *c;
        dcomplex *a;
        dcomplex *b;
#else
zdiv(dcomplex *c, dcomplex *a, dcomplex *b)
#endif
{
        double ratio, den;
        double abr, abi;

        if( (abr = b->dreal) < 0.)
                abr = - abr;
        if( (abi = b->dimag) < 0.)
                abi = - abi;
        if( abr <= abi )
        {
                if(abi == 0)
                        Fatal("complex division by zero");
                ratio = b->dreal / b->dimag ;
                den = b->dimag * (1 + ratio*ratio);
                c->dreal = (a->dreal*ratio + a->dimag) / den;
                c->dimag = (a->dimag*ratio - a->dreal) / den;
        }

        else
        {
                ratio = b->dimag / b->dreal ;
                den = b->dreal * (1 + ratio*ratio);
                c->dreal = (a->dreal + a->dimag*ratio) / den;
                c->dimag = (a->dimag - a->dreal*ratio) / den;
        }
}


 void
#ifdef KR_headers
sserr(np) Namep np;
#else
sserr(Namep np)
#endif
{
        errstr(np->vtype == TYCHAR
                ? "substring of character array %.70s"
                : "substring of noncharacter %.73s", np->fvarname);
        }

---