intr.c

Go to the documentation of this file.

/****************************************************************
Copyright 1990, 1992, 1994-6, 1998 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 "names.h"

union
        {
        int ijunk;
        struct Intrpacked bits;
        } packed;

struct Intrbits
        {
        char intrgroup /* :3 */;
        char intrstuff /* result type or number of generics */;
        char intrno /* :7 */;
        char dblcmplx;
        char dblintrno; /* for -r8 */
        char extflag;   /* for -cd, -i90 */
        };

/* List of all intrinsic functions.  */

LOCAL struct Intrblock
        {
        char intrfname[8];
        struct Intrbits intrval;
        } intrtab[ ] =
{
"int",          { INTRCONV, TYLONG },
"real",         { INTRCONV, TYREAL, 1 },
                /* 1 ==> real(TYDCOMPLEX) yields TYDREAL */
"dble",         { INTRCONV, TYDREAL },
"dreal",        { INTRCONV, TYDREAL, 0, 0, 0, 1 },
"cmplx",        { INTRCONV, TYCOMPLEX },
"dcmplx",       { INTRCONV, TYDCOMPLEX, 0, 1 },
"ifix",         { INTRCONV, TYLONG },
"idint",        { INTRCONV, TYLONG },
"float",        { INTRCONV, TYREAL },
"dfloat",       { INTRCONV, TYDREAL },
"sngl",         { INTRCONV, TYREAL },
"ichar",        { INTRCONV, TYLONG },
"iachar",       { INTRCONV, TYLONG },
"char",         { INTRCONV, TYCHAR },
"achar",        { INTRCONV, TYCHAR },

/* any MAX or MIN can be used with any types; the compiler will cast them
   correctly.  So rules against bad syntax in these expressions are not
   enforced */

"max",          { INTRMAX, TYUNKNOWN },
"max0",         { INTRMAX, TYLONG },
"amax0",        { INTRMAX, TYREAL },
"max1",         { INTRMAX, TYLONG },
"amax1",        { INTRMAX, TYREAL },
"dmax1",        { INTRMAX, TYDREAL },

"and",          { INTRBOOL, TYUNKNOWN, OPBITAND },
"or",           { INTRBOOL, TYUNKNOWN, OPBITOR },
"xor",          { INTRBOOL, TYUNKNOWN, OPBITXOR },
"not",          { INTRBOOL, TYUNKNOWN, OPBITNOT },
"lshift",       { INTRBOOL, TYUNKNOWN, OPLSHIFT },
"rshift",       { INTRBOOL, TYUNKNOWN, OPRSHIFT },

"min",          { INTRMIN, TYUNKNOWN },
"min0",         { INTRMIN, TYLONG },
"amin0",        { INTRMIN, TYREAL },
"min1",         { INTRMIN, TYLONG },
"amin1",        { INTRMIN, TYREAL },
"dmin1",        { INTRMIN, TYDREAL },

"aint",         { INTRGEN, 2, 0 },
"dint",         { INTRSPEC, TYDREAL, 1 },

"anint",        { INTRGEN, 2, 2 },
"dnint",        { INTRSPEC, TYDREAL, 3 },

"nint",         { INTRGEN, 4, 4 },
"idnint",       { INTRGEN, 2, 6 },

"abs",          { INTRGEN, 6, 8 },
"iabs",         { INTRGEN, 2, 9 },
"dabs",         { INTRSPEC, TYDREAL, 11 },
"cabs",         { INTRSPEC, TYREAL, 12, 0, 13 },
"zabs",         { INTRSPEC, TYDREAL, 13, 1 },

"mod",          { INTRGEN, 4, 14 },
"amod",         { INTRSPEC, TYREAL, 16, 0, 17 },
"dmod",         { INTRSPEC, TYDREAL, 17 },

"sign",         { INTRGEN, 4, 18 },
"isign",        { INTRGEN, 2, 19 },
"dsign",        { INTRSPEC, TYDREAL, 21 },

"dim",          { INTRGEN, 4, 22 },
"idim",         { INTRGEN, 2, 23 },
"ddim",         { INTRSPEC, TYDREAL, 25 },

"dprod",        { INTRSPEC, TYDREAL, 26 },

"len",          { INTRSPEC, TYLONG, 27 },
"index",        { INTRSPEC, TYLONG, 29 },

"imag",         { INTRGEN, 2, 31 },
"aimag",        { INTRSPEC, TYREAL, 31, 0, 32 },
"dimag",        { INTRSPEC, TYDREAL, 32 },

"conjg",        { INTRGEN, 2, 33 },
"dconjg",       { INTRSPEC, TYDCOMPLEX, 34, 1 },

"sqrt",         { INTRGEN, 4, 35 },
"dsqrt",        { INTRSPEC, TYDREAL, 36 },
"csqrt",        { INTRSPEC, TYCOMPLEX, 37, 0, 38 },
"zsqrt",        { INTRSPEC, TYDCOMPLEX, 38, 1 },

"exp",          { INTRGEN, 4, 39 },
"dexp",         { INTRSPEC, TYDREAL, 40 },
"cexp",         { INTRSPEC, TYCOMPLEX, 41, 0, 42 },
"zexp",         { INTRSPEC, TYDCOMPLEX, 42, 1 },

"log",          { INTRGEN, 4, 43 },
"alog",         { INTRSPEC, TYREAL, 43, 0, 44 },
"dlog",         { INTRSPEC, TYDREAL, 44 },
"clog",         { INTRSPEC, TYCOMPLEX, 45, 0, 46 },
"zlog",         { INTRSPEC, TYDCOMPLEX, 46, 1 },

"log10",        { INTRGEN, 2, 47 },
"alog10",       { INTRSPEC, TYREAL, 47, 0, 48 },
"dlog10",       { INTRSPEC, TYDREAL, 48 },

"sin",          { INTRGEN, 4, 49 },
"dsin",         { INTRSPEC, TYDREAL, 50 },
"csin",         { INTRSPEC, TYCOMPLEX, 51, 0, 52 },
"zsin",         { INTRSPEC, TYDCOMPLEX, 52, 1 },

"cos",          { INTRGEN, 4, 53 },
"dcos",         { INTRSPEC, TYDREAL, 54 },
"ccos",         { INTRSPEC, TYCOMPLEX, 55, 0, 56 },
"zcos",         { INTRSPEC, TYDCOMPLEX, 56, 1 },

"tan",          { INTRGEN, 2, 57 },
"dtan",         { INTRSPEC, TYDREAL, 58 },

"asin",         { INTRGEN, 2, 59 },
"dasin",        { INTRSPEC, TYDREAL, 60 },

"acos",         { INTRGEN, 2, 61 },
"dacos",        { INTRSPEC, TYDREAL, 62 },

"atan",         { INTRGEN, 2, 63 },
"datan",        { INTRSPEC, TYDREAL, 64 },

"atan2",        { INTRGEN, 2, 65 },
"datan2",       { INTRSPEC, TYDREAL, 66 },

"sinh",         { INTRGEN, 2, 67 },
"dsinh",        { INTRSPEC, TYDREAL, 68 },

"cosh",         { INTRGEN, 2, 69 },
"dcosh",        { INTRSPEC, TYDREAL, 70 },

"tanh",         { INTRGEN, 2, 71 },
"dtanh",        { INTRSPEC, TYDREAL, 72 },

"lge",          { INTRSPEC, TYLOGICAL, 73},
"lgt",          { INTRSPEC, TYLOGICAL, 75},
"lle",          { INTRSPEC, TYLOGICAL, 77},
"llt",          { INTRSPEC, TYLOGICAL, 79},

#if 0
"epbase",       { INTRCNST, 4, 0 },
"epprec",       { INTRCNST, 4, 4 },
"epemin",       { INTRCNST, 2, 8 },
"epemax",       { INTRCNST, 2, 10 },
"eptiny",       { INTRCNST, 2, 12 },
"ephuge",       { INTRCNST, 4, 14 },
"epmrsp",       { INTRCNST, 2, 18 },
#endif

"fpexpn",       { INTRGEN, 4, 81 },
"fpabsp",       { INTRGEN, 2, 85 },
"fprrsp",       { INTRGEN, 2, 87 },
"fpfrac",       { INTRGEN, 2, 89 },
"fpmake",       { INTRGEN, 2, 91 },
"fpscal",       { INTRGEN, 2, 93 },

"cdabs",        { INTRSPEC, TYDREAL,    13, 1, 0, 1 },
"cdsqrt",       { INTRSPEC, TYDCOMPLEX, 38, 1, 0, 1 },
"cdexp",        { INTRSPEC, TYDCOMPLEX, 42, 1, 0, 1 },
"cdlog",        { INTRSPEC, TYDCOMPLEX, 46, 1, 0, 1 },
"cdsin",        { INTRSPEC, TYDCOMPLEX, 52, 1, 0, 1 },
"cdcos",        { INTRSPEC, TYDCOMPLEX, 56, 1, 0, 1 },

"iand",         { INTRBOOL, TYUNKNOWN, OPBITAND, 0, 0, 2 },
"ior",          { INTRBOOL, TYUNKNOWN, OPBITOR,  0, 0, 2 },
"ieor",         { INTRBOOL, TYUNKNOWN, OPBITXOR, 0, 0, 2 },

"btest",        { INTRBGEN, TYLOGICAL, OPBITTEST,0, 0, 2 },
"ibclr",        { INTRBGEN, TYUNKNOWN, OPBITCLR, 0, 0, 2 },
"ibset",        { INTRBGEN, TYUNKNOWN, OPBITSET, 0, 0, 2 },
"ibits",        { INTRBGEN, TYUNKNOWN, OPBITBITS,0, 0, 2 },
"ishft",        { INTRBGEN, TYUNKNOWN, OPBITSH,  0, 0, 2 },
"ishftc",       { INTRBGEN, TYUNKNOWN, OPBITSHC, 0, 0, 2 },

"" };


LOCAL struct Specblock
        {
        char atype;             /* Argument type; every arg must have
                                   this type */
        char rtype;             /* Result type */
        char nargs;             /* Number of arguments */
        char spxname[8];        /* Name of the function in Fortran */
        char othername;         /* index into callbyvalue table */
        } spectab[ ] =
{
        { TYREAL,TYREAL,1,"r_int" },
        { TYDREAL,TYDREAL,1,"d_int" },

        { TYREAL,TYREAL,1,"r_nint" },
        { TYDREAL,TYDREAL,1,"d_nint" },

        { TYREAL,TYSHORT,1,"h_nint" },
        { TYREAL,TYLONG,1,"i_nint" },

        { TYDREAL,TYSHORT,1,"h_dnnt" },
        { TYDREAL,TYLONG,1,"i_dnnt" },

        { TYREAL,TYREAL,1,"r_abs" },
        { TYSHORT,TYSHORT,1,"h_abs" },
        { TYLONG,TYLONG,1,"i_abs" },
        { TYDREAL,TYDREAL,1,"d_abs" },
        { TYCOMPLEX,TYREAL,1,"c_abs" },
        { TYDCOMPLEX,TYDREAL,1,"z_abs" },

        { TYSHORT,TYSHORT,2,"h_mod" },
        { TYLONG,TYLONG,2,"i_mod" },
        { TYREAL,TYREAL,2,"r_mod" },
        { TYDREAL,TYDREAL,2,"d_mod" },

        { TYREAL,TYREAL,2,"r_sign" },
        { TYSHORT,TYSHORT,2,"h_sign" },
        { TYLONG,TYLONG,2,"i_sign" },
        { TYDREAL,TYDREAL,2,"d_sign" },

        { TYREAL,TYREAL,2,"r_dim" },
        { TYSHORT,TYSHORT,2,"h_dim" },
        { TYLONG,TYLONG,2,"i_dim" },
        { TYDREAL,TYDREAL,2,"d_dim" },

        { TYREAL,TYDREAL,2,"d_prod" },

        { TYCHAR,TYSHORT,1,"h_len" },
        { TYCHAR,TYLONG,1,"i_len" },

        { TYCHAR,TYSHORT,2,"h_indx" },
        { TYCHAR,TYLONG,2,"i_indx" },

        { TYCOMPLEX,TYREAL,1,"r_imag" },
        { TYDCOMPLEX,TYDREAL,1,"d_imag" },
        { TYCOMPLEX,TYCOMPLEX,1,"r_cnjg" },
        { TYDCOMPLEX,TYDCOMPLEX,1,"d_cnjg" },

        { TYREAL,TYREAL,1,"r_sqrt", 1 },
        { TYDREAL,TYDREAL,1,"d_sqrt", 1 },
        { TYCOMPLEX,TYCOMPLEX,1,"c_sqrt" },
        { TYDCOMPLEX,TYDCOMPLEX,1,"z_sqrt" },

        { TYREAL,TYREAL,1,"r_exp", 2 },
        { TYDREAL,TYDREAL,1,"d_exp", 2 },
        { TYCOMPLEX,TYCOMPLEX,1,"c_exp" },
        { TYDCOMPLEX,TYDCOMPLEX,1,"z_exp" },

        { TYREAL,TYREAL,1,"r_log", 3 },
        { TYDREAL,TYDREAL,1,"d_log", 3 },
        { TYCOMPLEX,TYCOMPLEX,1,"c_log" },
        { TYDCOMPLEX,TYDCOMPLEX,1,"z_log" },

        { TYREAL,TYREAL,1,"r_lg10" },
        { TYDREAL,TYDREAL,1,"d_lg10" },

        { TYREAL,TYREAL,1,"r_sin", 4 },
        { TYDREAL,TYDREAL,1,"d_sin", 4 },
        { TYCOMPLEX,TYCOMPLEX,1,"c_sin" },
        { TYDCOMPLEX,TYDCOMPLEX,1,"z_sin" },

        { TYREAL,TYREAL,1,"r_cos", 5 },
        { TYDREAL,TYDREAL,1,"d_cos", 5 },
        { TYCOMPLEX,TYCOMPLEX,1,"c_cos" },
        { TYDCOMPLEX,TYDCOMPLEX,1,"z_cos" },

        { TYREAL,TYREAL,1,"r_tan", 6 },
        { TYDREAL,TYDREAL,1,"d_tan", 6 },

        { TYREAL,TYREAL,1,"r_asin", 7 },
        { TYDREAL,TYDREAL,1,"d_asin", 7 },

        { TYREAL,TYREAL,1,"r_acos", 8 },
        { TYDREAL,TYDREAL,1,"d_acos", 8 },

        { TYREAL,TYREAL,1,"r_atan", 9 },
        { TYDREAL,TYDREAL,1,"d_atan", 9 },

        { TYREAL,TYREAL,2,"r_atn2", 10 },
        { TYDREAL,TYDREAL,2,"d_atn2", 10 },

        { TYREAL,TYREAL,1,"r_sinh", 11 },
        { TYDREAL,TYDREAL,1,"d_sinh", 11 },

        { TYREAL,TYREAL,1,"r_cosh", 12 },
        { TYDREAL,TYDREAL,1,"d_cosh", 12 },

        { TYREAL,TYREAL,1,"r_tanh", 13 },
        { TYDREAL,TYDREAL,1,"d_tanh", 13 },

        { TYCHAR,TYLOGICAL,2,"hl_ge" },
        { TYCHAR,TYLOGICAL,2,"l_ge" },

        { TYCHAR,TYLOGICAL,2,"hl_gt" },
        { TYCHAR,TYLOGICAL,2,"l_gt" },

        { TYCHAR,TYLOGICAL,2,"hl_le" },
        { TYCHAR,TYLOGICAL,2,"l_le" },

        { TYCHAR,TYLOGICAL,2,"hl_lt" },
        { TYCHAR,TYLOGICAL,2,"l_lt" },

        { TYREAL,TYSHORT,1,"hr_expn" },
        { TYREAL,TYLONG,1,"ir_expn" },
        { TYDREAL,TYSHORT,1,"hd_expn" },
        { TYDREAL,TYLONG,1,"id_expn" },

        { TYREAL,TYREAL,1,"r_absp" },
        { TYDREAL,TYDREAL,1,"d_absp" },

        { TYREAL,TYDREAL,1,"r_rrsp" },
        { TYDREAL,TYDREAL,1,"d_rrsp" },

        { TYREAL,TYREAL,1,"r_frac" },
        { TYDREAL,TYDREAL,1,"d_frac" },

        { TYREAL,TYREAL,2,"r_make" },
        { TYDREAL,TYDREAL,2,"d_make" },

        { TYREAL,TYREAL,2,"r_scal" },
        { TYDREAL,TYDREAL,2,"d_scal" },

        { 0 }
} ;

#if 0
LOCAL struct Incstblock
        {
        char atype;
        char rtype;
        char constno;
        } consttab[ ] =
{
        { TYSHORT, TYLONG, 0 },
        { TYLONG, TYLONG, 1 },
        { TYREAL, TYLONG, 2 },
        { TYDREAL, TYLONG, 3 },

        { TYSHORT, TYLONG, 4 },
        { TYLONG, TYLONG, 5 },
        { TYREAL, TYLONG, 6 },
        { TYDREAL, TYLONG, 7 },

        { TYREAL, TYLONG, 8 },
        { TYDREAL, TYLONG, 9 },

        { TYREAL, TYLONG, 10 },
        { TYDREAL, TYLONG, 11 },

        { TYREAL, TYREAL, 0 },
        { TYDREAL, TYDREAL, 1 },

        { TYSHORT, TYLONG, 12 },
        { TYLONG, TYLONG, 13 },
        { TYREAL, TYREAL, 2 },
        { TYDREAL, TYDREAL, 3 },

        { TYREAL, TYREAL, 4 },
        { TYDREAL, TYDREAL, 5 }
};
#endif

char *callbyvalue[ ] =
        {0,
        "sqrt",
        "exp",
        "log",
        "sin",
        "cos",
        "tan",
        "asin",
        "acos",
        "atan",
        "atan2",
        "sinh",
        "cosh",
        "tanh"
        };

 void
r8fix(Void)     /* adjust tables for -r8 */
{
        register struct Intrblock *I;
        register struct Specblock *S;

        for(I = intrtab; I->intrfname[0]; I++)
                if (I->intrval.intrgroup != INTRGEN)
                    switch(I->intrval.intrstuff) {
                        case TYREAL:
                                I->intrval.intrstuff = TYDREAL;
                                I->intrval.intrno = I->intrval.dblintrno;
                                break;
                        case TYCOMPLEX:
                                I->intrval.intrstuff = TYDCOMPLEX;
                                I->intrval.intrno = I->intrval.dblintrno;
                                I->intrval.dblcmplx = 1;
                        }

        for(S = spectab; S->atype; S++)
            switch(S->atype) {
                case TYCOMPLEX:
                        S->atype = TYDCOMPLEX;
                        if (S->rtype == TYREAL)
                                S->rtype = TYDREAL;
                        else if (S->rtype == TYCOMPLEX)
                                S->rtype = TYDCOMPLEX;
                        switch(S->spxname[0]) {
                                case 'r':
                                        S->spxname[0] = 'd';
                                        break;
                                case 'c':
                                        S->spxname[0] = 'z';
                                        break;
                                default:
                                        Fatal("r8fix bug");
                                }
                        break;
                case TYREAL:
                        S->atype = TYDREAL;
                        switch(S->rtype) {
                            case TYREAL:
                                S->rtype = TYDREAL;
                                if (S->spxname[0] != 'r')
                                        Fatal("r8fix bug");
                                S->spxname[0] = 'd';
                            case TYDREAL:       /* d_prod */
                                break;

                            case TYSHORT:
                                if (!strcmp(S->spxname, "hr_expn"))
                                        S->spxname[1] = 'd';
                                else if (!strcmp(S->spxname, "h_nint"))
                                        strcpy(S->spxname, "h_dnnt");
                                else Fatal("r8fix bug");
                                break;

                            case TYLONG:
                                if (!strcmp(S->spxname, "ir_expn"))
                                        S->spxname[1] = 'd';
                                else if (!strcmp(S->spxname, "i_nint"))
                                        strcpy(S->spxname, "i_dnnt");
                                else Fatal("r8fix bug");
                                break;

                            default:
                                Fatal("r8fix bug");
                            }
                }
        }

 static expptr
#ifdef KR_headers
foldminmax(ismin, argsp) int ismin; struct Listblock *argsp;
#else
foldminmax(int ismin, struct Listblock *argsp)
#endif
{
#ifndef NO_LONG_LONG
        Llong cq, cq1;
#endif
        Constp h;
        double cd, cd1;
        ftnint ci;
        int mtype;
        struct Chain *cp, *cpx;

        mtype = argsp->vtype;
        cp = cpx = argsp->listp;
        h = &((expptr)cp->datap)->constblock;
#ifndef NO_LONG_LONG
        if (mtype == TYQUAD) {
                cq = h->vtype == TYQUAD ? h->Const.cq : h->Const.ci;
                while(cp = cp->nextp) {
                        h = &((expptr)cp->datap)->constblock;
                        cq1 = h->vtype == TYQUAD ? h->Const.cq : h->Const.ci;
                        if (ismin) {
                                if (cq > cq1) {
                                        cq = cq1;
                                        cpx = cp;
                                        }
                                }
                        else {
                                if (cq < cq1) {
                                        cq = cq1;
                                        cpx = cp;
                                        }
                                }
                        }
                }
        else
#endif
        if (ISINT(mtype)) {
                ci = h->Const.ci;
                if (ismin)
                        while(cp = cp->nextp) {
                                h = &((expptr)cp->datap)->constblock;
                                if (ci > h->Const.ci) {
                                        ci = h->Const.ci;
                                        cpx = cp;
                                        }
                                }
                else
                        while(cp = cp->nextp) {
                                h = &((expptr)cp->datap)->constblock;
                                if (ci < h->Const.ci) {
                                        ci = h->Const.ci;
                                        cpx = cp;
                                        }
                                }
                }
        else {
                if (ISREAL(h->vtype))
                        cd = h->vstg ? atof(h->Const.cds[0]) : h->Const.cd[0];
#ifndef NO_LONG_LONG
                else if (h->vtype == TYQUAD)
                        cd = (double)(h->Const.cq);
#endif
                else
                        cd = h->Const.ci;
                while(cp = cp->nextp) {
                        h = &((expptr)cp->datap)->constblock;
                        if (ISREAL(h->vtype))
                                cd1 = h->vstg   ? atof(h->Const.cds[0])
                                                : h->Const.cd[0];
#ifndef NO_LONG_LONG
                        else if (h->vtype == TYQUAD)
                                cd1 = (double)(h->Const.cq);
#endif
                        else
                                cd1 = h->Const.ci;
                        if (ismin) {
                                if (cd > cd1) {
                                        cd = cd1;
                                        cpx = cp;
                                        }
                                }
                        else {
                                if (cd < cd1) {
                                        cd = cd1;
                                        cpx = cp;
                                        }
                                }
                        }
                }
        h = &((expptr)cpx->datap)->constblock;
        cpx->datap = 0;
        frexpr((tagptr)argsp);
        if (h->vtype != mtype)
                return mkconv(mtype, (expptr)h);
        return (expptr)h;
        }


 expptr
#ifdef KR_headers
intrcall(np, argsp, nargs)
        Namep np;
        struct Listblock *argsp;
        int nargs;
#else
intrcall(Namep np, struct Listblock *argsp, int nargs)
#endif
{
        int i, rettype;
        ftnint k;
        Addrp ap;
        register struct Specblock *sp;
        register struct Chain *cp;
        expptr q, ep;
        int constargs, mtype, op;
        int f1field, f2field, f3field;
        char *s;
        static char     bit_bits[] =    "?bit_bits",
                        bit_shift[] =   "?bit_shift",
                        bit_cshift[] =  "?bit_cshift";
        static char *bitop[3] = { bit_bits, bit_shift, bit_cshift };
        static int t_pref[2] = { 'l', 'q' };

        packed.ijunk = np->vardesc.varno;
        f1field = packed.bits.f1;
        f2field = packed.bits.f2;
        f3field = packed.bits.f3;
        if(nargs == 0)
                goto badnargs;

        mtype = 0;
        constargs = 1;
        for(cp = argsp->listp ; cp ; cp = cp->nextp)
        {
                ep = (expptr)cp->datap;
                if (!ISCONST(ep))
                        constargs = 0;
                else if( ep->headblock.vtype==TYSHORT )
                        cp->datap = (char *) mkconv(tyint, ep);
                mtype = maxtype(mtype, ep->headblock.vtype);
        }

        switch(f1field)
        {
        case INTRBGEN:
                op = f3field;
                if( ! ONEOF(mtype, MSKINT) )
                        goto badtype;
                if (op < OPBITBITS) {
                        if(nargs != 2)
                                goto badnargs;
                        if (op != OPBITTEST) {
#ifdef TYQUAD
                                if (mtype == TYQUAD)
                                        op += 2;
#endif
                                goto intrbool2;
                                }
                        q = mkexpr(op, (expptr)argsp->listp->datap,
                                        (expptr)argsp->listp->nextp->datap);
                        q->exprblock.vtype = TYLOGICAL;
                        goto intrbool2a;
                        }
                if (nargs != 2 && (nargs != 3 || op == OPBITSH))
                        goto badnargs;
                cp = argsp->listp;
                ep = (expptr)cp->datap;
                if (ep->headblock.vtype < TYLONG)
                        cp->datap = (char *)mkconv(TYLONG, ep);
                while(cp->nextp) {
                        cp = cp->nextp;
                        ep = (expptr)cp->datap;
                        if (ep->headblock.vtype != TYLONG)
                                cp->datap = (char *)mkconv(TYLONG, ep);
                        }
                if (op == OPBITSH) {
                        ep = (expptr)argsp->listp->nextp->datap;
                        if (ISCONST(ep)) {
                                if ((k = ep->constblock.Const.ci) < 0) {
                                        q = (expptr)argsp->listp->datap;
                                        if (ISCONST(q)) {
                                                ep->constblock.Const.ci = -k;
                                                op = OPRSHIFT;
                                                goto intrbool2;
                                                }
                                        }
                                else {
                                        op = OPLSHIFT;
                                        goto intrbool2;
                                        }
                                }
                        }
                else if (nargs == 2) {
                        if (op == OPBITBITS)
                                goto badnargs;
                        cp->nextp = mkchain((char*)ICON(-1), 0);
                        }
                ep = (expptr)argsp->listp->datap;
                i = ep->headblock.vtype;
                s = bitop[op - OPBITBITS];
                *s = t_pref[i - TYLONG];
                ap = builtin(i, s, 1);
                return fixexpr((Exprp)
                                mkexpr(OPCCALL, (expptr)ap, (expptr)argsp) );

        case INTRBOOL:
                op = f3field;
                if( ! ONEOF(mtype, MSKINT|MSKLOGICAL) )
                        goto badtype;
                if(op == OPBITNOT)
                {
                        if(nargs != 1)
                                goto badnargs;
                        q = mkexpr(OPBITNOT, (expptr)argsp->listp->datap, ENULL);
                }
                else
                {
                        if(nargs != 2)
                                goto badnargs;
 intrbool2:
                        q = mkexpr(op, (expptr)argsp->listp->datap,
                                        (expptr)argsp->listp->nextp->datap);
                }
 intrbool2a:
                frchain( &(argsp->listp) );
                free( (charptr) argsp);
                return(q);

        case INTRCONV:
                rettype = f2field;
                switch(rettype) {
                  case TYLONG:
                        rettype = tyint;
                        break;
                  case TYLOGICAL:
                        rettype = tylog;
                  }
                if( ISCOMPLEX(rettype) && nargs==2)
                {
                        expptr qr, qi;
                        qr = (expptr) argsp->listp->datap;
                        qi = (expptr) argsp->listp->nextp->datap;
                        if (qr->headblock.vtype == TYDREAL
                         || qi->headblock.vtype == TYDREAL)
                                rettype = TYDCOMPLEX;
                        if(ISCONST(qr) && ISCONST(qi))
                                q = mkcxcon(qr,qi);
                        else    q = mkexpr(OPCONV,mkconv(rettype-2,qr),
                            mkconv(rettype-2,qi));
                }
                else if(nargs == 1) {
                        if (f3field && ((Exprp)argsp->listp->datap)->vtype
                                        == TYDCOMPLEX)
                                rettype = TYDREAL;
                        q = mkconv(rettype+100, (expptr)argsp->listp->datap);
                        if (q->tag == TADDR)
                                q->addrblock.parenused = 1;
                        }
                else goto badnargs;

                q->headblock.vtype = rettype;
                frchain(&(argsp->listp));
                free( (charptr) argsp);
                return(q);


#if 0
        case INTRCNST:

/* Machine-dependent f77 stuff that f2c omits:

intcon contains
        radix for short int
        radix for long int
        radix for single precision
        radix for double precision
        precision for short int
        precision for long int
        precision for single precision
        precision for double precision
        emin for single precision
        emin for double precision
        emax for single precision
        emax for double prcision
        largest short int
        largest long int

realcon contains
        tiny for single precision
        tiny for double precision
        huge for single precision
        huge for double precision
        mrsp (epsilon) for single precision
        mrsp (epsilon) for double precision
*/
        {       register struct Incstblock *cstp;
                extern ftnint intcon[14];
                extern double realcon[6];

                cstp = consttab + f3field;
                for(i=0 ; i<f2field ; ++i)
                        if(cstp->atype == mtype)
                                goto foundconst;
                        else
                                ++cstp;
                goto badtype;

foundconst:
                switch(cstp->rtype)
                {
                case TYLONG:
                        return(mkintcon(intcon[cstp->constno]));

                case TYREAL:
                case TYDREAL:
                        return(mkrealcon(cstp->rtype,
                            realcon[cstp->constno]) );

                default:
                        Fatal("impossible intrinsic constant");
                }
        }
#endif

        case INTRGEN:
                sp = spectab + f3field;
                if(no66flag)
                        if(sp->atype == mtype)
                                goto specfunct;
                        else err66("generic function");

                for(i=0; i<f2field ; ++i)
                        if(sp->atype == mtype)
                                goto specfunct;
                        else
                                ++sp;
                warn1 ("bad argument type to intrinsic %s", np->fvarname);

/* Made this a warning rather than an error so things like "log (5) ==>
   log (5.0)" can be accommodated.  When none of these cases matches, the
   argument is cast up to the first type in the spectab list; this first
   type is assumed to be the "smallest" type, e.g. REAL before DREAL
   before COMPLEX, before DCOMPLEX */

                sp = spectab + f3field;
                mtype = sp -> atype;
                goto specfunct;

        case INTRSPEC:
                sp = spectab + f3field;
specfunct:
                if(tyint==TYLONG && ONEOF(sp->rtype,M(TYSHORT)|M(TYLOGICAL))
                    && (sp+1)->atype==sp->atype)
                        ++sp;

                if(nargs != sp->nargs)
                        goto badnargs;
                if(mtype != sp->atype)
                        goto badtype;

/* NOTE!!  I moved fixargs (YES) into the ELSE branch so that constants in
   the inline expression wouldn't get put into the constant table */

                fixargs (NO, argsp);
                cast_args (mtype, argsp -> listp);

                if(q = Inline((int)(sp-spectab), mtype, argsp->listp))
                {
                        frchain( &(argsp->listp) );
                        free( (charptr) argsp);
                } else {

                    if(sp->othername) {
                        /* C library routines that return double... */
                        /* sp->rtype might be TYREAL */
                        ap = builtin(sp->rtype,
                                callbyvalue[sp->othername], 1);
                        q = fixexpr((Exprp)
                                mkexpr(OPCCALL, (expptr)ap, (expptr)argsp) );
                    } else {
                        fixargs(YES, argsp);
                        ap = builtin(sp->rtype, sp->spxname, 0);
                        q = fixexpr((Exprp)
                                mkexpr(OPCALL, (expptr)ap, (expptr)argsp) );
                    } /* else */
                } /* else */
                return(q);

        case INTRMIN:
        case INTRMAX:
                if(nargs < 2)
                        goto badnargs;
                if( ! ONEOF(mtype, MSKINT|MSKREAL) )
                        goto badtype;
                argsp->vtype = mtype;
                if (constargs)
                        q = foldminmax(f1field==INTRMIN, argsp);
                else
                        q = mkexpr(f1field==INTRMIN ? OPMIN : OPMAX,
                                        (expptr)argsp, ENULL);

                q->headblock.vtype = mtype;
                rettype = f2field;
                if(rettype == TYLONG)
                        rettype = tyint;
                else if(rettype == TYUNKNOWN)
                        rettype = mtype;
                return( mkconv(rettype, q) );

        default:
                fatali("intrcall: bad intrgroup %d", f1field);
        }
badnargs:
        errstr("bad number of arguments to intrinsic %s", np->fvarname);
        goto bad;

badtype:
        errstr("bad argument type to intrinsic %s", np->fvarname);

bad:
        return( errnode() );
}



 int
#ifdef KR_headers
intrfunct(s)
        char *s;
#else
intrfunct(char *s)
#endif
{
        register struct Intrblock *p;
        int i;
        extern int intr_omit;

        for(p = intrtab; p->intrval.intrgroup!=INTREND ; ++p)
        {
                if( !strcmp(s, p->intrfname) )
                {
                        if (i = p->intrval.extflag) {
                                if (i & intr_omit)
                                        return 0;
                                if (noextflag)
                                        errext(s);
                                }
                        packed.bits.f1 = p->intrval.intrgroup;
                        packed.bits.f2 = p->intrval.intrstuff;
                        packed.bits.f3 = p->intrval.intrno;
                        packed.bits.f4 = p->intrval.dblcmplx;
                        return(packed.ijunk);
                }
        }

        return(0);
}





 Addrp
#ifdef KR_headers
intraddr(np)
        Namep np;
#else
intraddr(Namep np)
#endif
{
        Addrp q;
        register struct Specblock *sp;
        int f3field;

        if(np->vclass!=CLPROC || np->vprocclass!=PINTRINSIC)
                fatalstr("intraddr: %s is not intrinsic", np->fvarname);
        packed.ijunk = np->vardesc.varno;
        f3field = packed.bits.f3;

        switch(packed.bits.f1)
        {
        case INTRGEN:
                /* imag, log, and log10 arent specific functions */
                if(f3field==31 || f3field==43 || f3field==47)
                        goto bad;

        case INTRSPEC:
                sp = spectab + f3field;
                if (tyint == TYLONG
                && (sp->rtype == TYSHORT || sp->rtype == TYLOGICAL))
                        ++sp;
                q = builtin(sp->rtype, sp->spxname,
                        sp->othername ? 1 : 0);
                return(q);

        case INTRCONV:
        case INTRMIN:
        case INTRMAX:
        case INTRBOOL:
        case INTRCNST:
        case INTRBGEN:
bad:
                errstr("cannot pass %s as actual", np->fvarname);
                return((Addrp)errnode());
        }
        fatali("intraddr: impossible f1=%d\n", (int) packed.bits.f1);
        /* NOT REACHED */ return 0;
}



 void
#ifdef KR_headers
cast_args(maxtype, args)
        int maxtype;
        chainp args;
#else
cast_args(int maxtype, chainp args)
#endif
{
    for (; args; args = args -> nextp) {
        expptr e = (expptr) args->datap;
        if (e -> headblock.vtype != maxtype)
            if (e -> tag == TCONST)
                args->datap = (char *) mkconv(maxtype, e);
            else {
                Addrp temp = mktmp(maxtype, ENULL);

                puteq(cpexpr((expptr)temp), e);
                args->datap = (char *)temp;
            } /* else */
    } /* for */
} /* cast_args */



 expptr
#ifdef KR_headers
Inline(fno, type, args)
        int fno;
        int type;
        struct Chain *args;
#else
Inline(int fno, int type, struct Chain *args)
#endif
{
        register expptr q, t, t1;

        switch(fno)
        {
        case 8: /* real abs */
        case 9: /* short int abs */
        case 10:        /* long int abs */
        case 11:        /* double precision abs */
                if( addressable(q = (expptr) args->datap) )
                {
                        t = q;
                        q = NULL;
                }
                else
                        t = (expptr) mktmp(type,ENULL);
                t1 = mkexpr(type == TYREAL && forcedouble ? OPDABS : OPABS,
                        cpexpr(t), ENULL);
                if(q)
                        t1 = mkexpr(OPCOMMA, mkexpr(OPASSIGN, cpexpr(t),q), t1);
                frexpr(t);
                return(t1);

        case 26:        /* dprod */
                q = mkexpr(OPSTAR, mkconv(TYDREAL,(expptr)args->datap),
                        (expptr)args->nextp->datap);
                return(q);

        case 27:        /* len of character string */
                q = (expptr) cpexpr(((tagptr)args->datap)->headblock.vleng);
                frexpr((expptr)args->datap);
                return mkconv(tyioint, q);

        case 14:        /* half-integer mod */
        case 15:        /* mod */
                return mkexpr(OPMOD, (expptr) args->datap,
                                (expptr) args->nextp->datap);
        }
        return(NULL);
}

---