diff options
Diffstat (limited to 'usr.bin/f2c/intr.c')
-rw-r--r-- | usr.bin/f2c/intr.c | 854 |
1 files changed, 0 insertions, 854 deletions
diff --git a/usr.bin/f2c/intr.c b/usr.bin/f2c/intr.c deleted file mode 100644 index 210047f..0000000 --- a/usr.bin/f2c/intr.c +++ /dev/null @@ -1,854 +0,0 @@ -/**************************************************************** -Copyright 1990, 1992 by AT&T Bell Laboratories 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 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 and Bellcore disclaim all warranties with regard to this -software, including all implied warranties of merchantability -and fitness. In no event shall AT&T 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" - -void cast_args (); - -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 */ - }; - -/* 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 }, -"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 }, - -"" }; - - -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() /* 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"); - } - } - } - -expptr intrcall(np, argsp, nargs) -Namep np; -struct Listblock *argsp; -int nargs; -{ - int i, rettype; - Addrp ap; - register struct Specblock *sp; - register struct Chain *cp; - expptr Inline(), mkcxcon(), mkrealcon(); - expptr q, ep; - int mtype; - int op; - int f1field, f2field, f3field; - - packed.ijunk = np->vardesc.varno; - f1field = packed.bits.f1; - f2field = packed.bits.f2; - f3field = packed.bits.f3; - if(nargs == 0) - goto badnargs; - - mtype = 0; - for(cp = argsp->listp ; cp ; cp = cp->nextp) - { - ep = (expptr)cp->datap; - if( ISCONST(ep) && ep->headblock.vtype==TYSHORT ) - cp->datap = (char *) mkconv(tyint, ep); - mtype = maxtype(mtype, ep->headblock.vtype); - } - - switch(f1field) - { - case INTRBOOL: - op = f3field; - if( ! ONEOF(mtype, MSKINT|MSKLOGICAL) ) - goto badtype; - if(op == OPBITNOT) - { - if(nargs != 1) - goto badnargs; - q = mkexpr(OPBITNOT, (expptr)argsp->listp->datap, ENULL); - } - else - { - if(nargs != 2) - goto badnargs; - q = mkexpr(op, (expptr)argsp->listp->datap, - (expptr)argsp->listp->nextp->datap); - } - frchain( &(argsp->listp) ); - free( (charptr) argsp); - return(q); - - case INTRCONV: - rettype = f2field; - switch(rettype) { - case TYLONG: - rettype = tyint; - break; - case TYLOGICAL: - rettype = tylog; - } - if( ISCOMPLEX(rettype) && nargs==2) - { - expptr qr, qi; - qr = (expptr) argsp->listp->datap; - qi = (expptr) argsp->listp->nextp->datap; - if(ISCONST(qr) && ISCONST(qi)) - q = mkcxcon(qr,qi); - else q = mkexpr(OPCONV,mkconv(rettype-2,qr), - mkconv(rettype-2,qi)); - } - else if(nargs == 1) { - if (f3field && ((Exprp)argsp->listp->datap)->vtype - == TYDCOMPLEX) - rettype = TYDREAL; - q = mkconv(rettype+100, (expptr)argsp->listp->datap); - if (q->tag == TADDR) - q->addrblock.parenused = 1; - } - else goto badnargs; - - q->headblock.vtype = rettype; - frchain(&(argsp->listp)); - free( (charptr) argsp); - return(q); - - -#if 0 - case INTRCNST: - -/* Machine-dependent f77 stuff that f2c omits: - -intcon contains - radix for short int - radix for long int - radix for single precision - radix for double precision - precision for short int - precision for long int - precision for single precision - precision for double precision - emin for single precision - emin for double precision - emax for single precision - emax for double prcision - largest short int - largest long int - -realcon contains - tiny for single precision - tiny for double precision - huge for single precision - huge for double precision - mrsp (epsilon) for single precision - mrsp (epsilon) for double precision -*/ - { register struct Incstblock *cstp; - extern ftnint intcon[14]; - extern double realcon[6]; - - cstp = consttab + f3field; - for(i=0 ; i<f2field ; ++i) - if(cstp->atype == mtype) - goto foundconst; - else - ++cstp; - goto badtype; - -foundconst: - switch(cstp->rtype) - { - case TYLONG: - return(mkintcon(intcon[cstp->constno])); - - case TYREAL: - case TYDREAL: - return(mkrealcon(cstp->rtype, - realcon[cstp->constno]) ); - - default: - Fatal("impossible intrinsic constant"); - } - } -#endif - - case INTRGEN: - sp = spectab + f3field; - if(no66flag) - if(sp->atype == mtype) - goto specfunct; - else err66("generic function"); - - for(i=0; i<f2field ; ++i) - if(sp->atype == mtype) - goto specfunct; - else - ++sp; - warn1 ("bad argument type to intrinsic %s", np->fvarname); - -/* Made this a warning rather than an error so things like "log (5) ==> - log (5.0)" can be accommodated. When none of these cases matches, the - argument is cast up to the first type in the spectab list; this first - type is assumed to be the "smallest" type, e.g. REAL before DREAL - before COMPLEX, before DCOMPLEX */ - - sp = spectab + f3field; - mtype = sp -> atype; - goto specfunct; - - case INTRSPEC: - sp = spectab + f3field; -specfunct: - if(tyint==TYLONG && ONEOF(sp->rtype,M(TYSHORT)|M(TYLOGICAL)) - && (sp+1)->atype==sp->atype) - ++sp; - - if(nargs != sp->nargs) - goto badnargs; - if(mtype != sp->atype) - goto badtype; - -/* NOTE!! I moved fixargs (YES) into the ELSE branch so that constants in - the inline expression wouldn't get put into the constant table */ - - fixargs (NO, argsp); - cast_args (mtype, argsp -> listp); - - if(q = Inline((int)(sp-spectab), mtype, argsp->listp)) - { - frchain( &(argsp->listp) ); - free( (charptr) argsp); - } else { - - if(sp->othername) { - /* C library routines that return double... */ - /* sp->rtype might be TYREAL */ - ap = builtin(sp->rtype, - callbyvalue[sp->othername], 1); - q = fixexpr((Exprp) - mkexpr(OPCCALL, (expptr)ap, (expptr)argsp) ); - } else { - fixargs(YES, argsp); - ap = builtin(sp->rtype, sp->spxname, 0); - q = fixexpr((Exprp) - mkexpr(OPCALL, (expptr)ap, (expptr)argsp) ); - } /* else */ - } /* else */ - return(q); - - case INTRMIN: - case INTRMAX: - if(nargs < 2) - goto badnargs; - if( ! ONEOF(mtype, MSKINT|MSKREAL) ) - goto badtype; - argsp->vtype = mtype; - q = mkexpr( (f1field==INTRMIN ? OPMIN : OPMAX), (expptr)argsp, ENULL); - - q->headblock.vtype = mtype; - rettype = f2field; - if(rettype == TYLONG) - rettype = tyint; - else if(rettype == TYUNKNOWN) - rettype = mtype; - return( mkconv(rettype, q) ); - - default: - fatali("intrcall: bad intrgroup %d", f1field); - } -badnargs: - errstr("bad number of arguments to intrinsic %s", np->fvarname); - goto bad; - -badtype: - errstr("bad argument type to intrinsic %s", np->fvarname); - -bad: - return( errnode() ); -} - - - - -intrfunct(s) -char *s; -{ - register struct Intrblock *p; - - for(p = intrtab; p->intrval.intrgroup!=INTREND ; ++p) - { - if( !strcmp(s, p->intrfname) ) - { - 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 intraddr(np) -Namep np; -{ - 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: -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 cast_args (maxtype, args) -int maxtype; -chainp args; -{ - 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 Inline(fno, type, args) -int fno; -int type; -struct Chain *args; -{ - 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(q); - - case 14: /* half-integer mod */ - case 15: /* mod */ - return mkexpr(OPMOD, (expptr) args->datap, - (expptr) args->nextp->datap); - } - return(NULL); -} |