1: /*
   2:  * Copyright (c) 1980 Regents of the University of California.
   3:  * All rights reserved.  The Berkeley software License Agreement
   4:  * specifies the terms and conditions for redistribution.
   5:  */
   6: 
   7: #ifndef lint
   8: static char sccsid[] = "@(#)intr.c	5.2 (Berkeley) 8/29/85";
   9: #endif not lint
  10: 
  11: /*
  12:  * intr.c
  13:  *
  14:  * Routines for handling intrinsic functions, f77 compiler pass 1, 4.2 BSD.
  15:  *
  16:  * University of Utah CS Dept modification history:
  17:  *
  18:  * $Log:	intr.c,v $
  19:  * Revision 5.2  85/08/10  04:39:23  donn
  20:  * Various changes from Jerry Berkman.  We now call the new builtin log10()
  21:  * instead of the f77 library emulations; we figure out that builtins will
  22:  * return type double instead of type float; we get rid of lots of
  23:  * undocumented material; we ifdef 66 code and handle -r8/double flag.
  24:  *
  25:  * Revision 5.1  85/08/10  03:47:37  donn
  26:  * 4.3 alpha
  27:  *
  28:  * Revision 1.4  85/02/22  00:54:59  donn
  29:  * Mark intrinsic functions as having storage class STGINTR.  builtin()
  30:  * always returns STGEXT nodes.  Notice that the reference to the function
  31:  * in the external symbol table still uses STGEXT...  I hope this is right.
  32:  *
  33:  * Revision 1.3  85/01/15  21:05:40  donn
  34:  * Changes to distinguish explicit from implicit conversions with intrconv().
  35:  *
  36:  * Revision 1.2  84/12/15  01:02:33  donn
  37:  * Added a case for an integer*4 result from len() in inline().  Previously
  38:  * only -i2 provoked len() inline, sigh.
  39:  *
  40:  */
  41: 
  42: #include "defs.h"
  43: 
  44: extern ftnint intcon[14];
  45: extern double realcon[6];
  46: 
  47: union
  48:     {
  49:     int ijunk;
  50:     struct Intrpacked bits;
  51:     } packed;
  52: 
  53: struct Intrbits
  54:     {
  55:     int intrgroup /* :3 */;
  56:     int intrstuff /* result type or number of specifics */;
  57:     int intrno /* :7 */;
  58:     };
  59: 
  60: LOCAL struct Intrblock
  61:     {
  62:     char intrfname[VL];
  63:     struct Intrbits intrval;
  64:     } intrtab[ ] =
  65: {
  66: "int",      { INTRCONV, TYLONG },
  67: "real",     { INTRCONV, TYREAL },
  68: "dble",     { INTRCONV, TYDREAL },
  69: "dreal",    { INTRCONV, TYDREAL },
  70: "cmplx",    { INTRCONV, TYCOMPLEX },
  71: "dcmplx",   { INTRCONV, TYDCOMPLEX },
  72: "ifix",     { INTRCONV, TYLONG },
  73: "idint",    { INTRCONV, TYLONG },
  74: "float",    { INTRCONV, TYREAL },
  75: "dfloat",   { INTRCONV, TYDREAL },
  76: "sngl",     { INTRCONV, TYREAL },
  77: "ichar",    { INTRCONV, TYLONG },
  78: "char",     { INTRCONV, TYCHAR },
  79: 
  80: "max",      { INTRMAX, TYUNKNOWN },
  81: "max0",     { INTRMAX, TYLONG },
  82: "amax0",    { INTRMAX, TYREAL },
  83: "max1",     { INTRMAX, TYLONG },
  84: "amax1",    { INTRMAX, TYREAL },
  85: "dmax1",    { INTRMAX, TYDREAL },
  86: 
  87: "and",      { INTRBOOL, TYUNKNOWN, OPBITAND },
  88: "or",       { INTRBOOL, TYUNKNOWN, OPBITOR },
  89: "xor",      { INTRBOOL, TYUNKNOWN, OPBITXOR },
  90: "not",      { INTRBOOL, TYUNKNOWN, OPBITNOT },
  91: "lshift",   { INTRBOOL, TYUNKNOWN, OPLSHIFT },
  92: "rshift",   { INTRBOOL, TYUNKNOWN, OPRSHIFT },
  93: 
  94: "min",      { INTRMIN, TYUNKNOWN },
  95: "min0",     { INTRMIN, TYLONG },
  96: "amin0",    { INTRMIN, TYREAL },
  97: "min1",     { INTRMIN, TYLONG },
  98: "amin1",    { INTRMIN, TYREAL },
  99: "dmin1",    { INTRMIN, TYDREAL },
 100: 
 101: "aint",     { INTRGEN, 2, 0 },
 102: "dint",     { INTRSPEC, TYDREAL, 1 },
 103: 
 104: "anint",    { INTRGEN, 2, 2 },
 105: "dnint",    { INTRSPEC, TYDREAL, 3 },
 106: 
 107: "nint",     { INTRGEN, 4, 4 },
 108: "idnint",   { INTRGEN, 2, 6 },
 109: 
 110: "abs",      { INTRGEN, 6, 8 },
 111: "iabs",     { INTRGEN, 2, 9 },
 112: "dabs",     { INTRSPEC, TYDREAL, 11 },
 113: "cabs",     { INTRSPEC, TYREAL, 12 },
 114: "zabs",     { INTRSPEC, TYDREAL, 13 },
 115: "cdabs",    { INTRSPEC, TYDREAL, 13 },
 116: 
 117: "mod",      { INTRGEN, 4, 14 },
 118: "amod",     { INTRSPEC, TYREAL, 16 },
 119: "dmod",     { INTRSPEC, TYDREAL, 17 },
 120: 
 121: "sign",     { INTRGEN, 4, 18 },
 122: "isign",    { INTRGEN, 2, 19 },
 123: "dsign",    { INTRSPEC, TYDREAL, 21 },
 124: 
 125: "dim",      { INTRGEN, 4, 22 },
 126: "idim",     { INTRGEN, 2, 23 },
 127: "ddim",     { INTRSPEC, TYDREAL, 25 },
 128: 
 129: "dprod",    { INTRSPEC, TYDREAL, 26 },
 130: 
 131: "len",      { INTRSPEC, TYLONG, 27 },
 132: "index",    { INTRSPEC, TYLONG, 29 },
 133: 
 134: "imag",     { INTRGEN, 2, 31 },
 135: "aimag",    { INTRSPEC, TYREAL, 31 },
 136: "dimag",    { INTRSPEC, TYDREAL, 32 },
 137: 
 138: "conjg",    { INTRGEN, 2, 33 },
 139: "dconjg",   { INTRSPEC, TYDCOMPLEX, 34 },
 140: 
 141: "sqrt",     { INTRGEN, 4, 35 },
 142: "dsqrt",    { INTRSPEC, TYDREAL, 36 },
 143: "csqrt",    { INTRSPEC, TYCOMPLEX, 37 },
 144: "zsqrt",    { INTRSPEC, TYDCOMPLEX, 38 },
 145: "cdsqrt",   { INTRSPEC, TYDCOMPLEX, 38 },
 146: 
 147: "exp",      { INTRGEN, 4, 39 },
 148: "dexp",     { INTRSPEC, TYDREAL, 40 },
 149: "cexp",     { INTRSPEC, TYCOMPLEX, 41 },
 150: "zexp",     { INTRSPEC, TYDCOMPLEX, 42 },
 151: "cdexp",    { INTRSPEC, TYDCOMPLEX, 42 },
 152: 
 153: "log",      { INTRGEN, 4, 43 },
 154: "alog",     { INTRSPEC, TYREAL, 43 },
 155: "dlog",     { INTRSPEC, TYDREAL, 44 },
 156: "clog",     { INTRSPEC, TYCOMPLEX, 45 },
 157: "zlog",     { INTRSPEC, TYDCOMPLEX, 46 },
 158: "cdlog",    { INTRSPEC, TYDCOMPLEX, 46 },
 159: 
 160: "log10",    { INTRGEN, 2, 47 },
 161: "alog10",   { INTRSPEC, TYREAL, 47 },
 162: "dlog10",   { INTRSPEC, TYDREAL, 48 },
 163: 
 164: "sin",      { INTRGEN, 4, 49 },
 165: "dsin",     { INTRSPEC, TYDREAL, 50 },
 166: "csin",     { INTRSPEC, TYCOMPLEX, 51 },
 167: "zsin",     { INTRSPEC, TYDCOMPLEX, 52 },
 168: "cdsin",    { INTRSPEC, TYDCOMPLEX, 52 },
 169: 
 170: "cos",      { INTRGEN, 4, 53 },
 171: "dcos",     { INTRSPEC, TYDREAL, 54 },
 172: "ccos",     { INTRSPEC, TYCOMPLEX, 55 },
 173: "zcos",     { INTRSPEC, TYDCOMPLEX, 56 },
 174: "cdcos",    { INTRSPEC, TYDCOMPLEX, 56 },
 175: 
 176: "tan",      { INTRGEN, 2, 57 },
 177: "dtan",     { INTRSPEC, TYDREAL, 58 },
 178: 
 179: "asin",     { INTRGEN, 2, 59 },
 180: "dasin",    { INTRSPEC, TYDREAL, 60 },
 181: 
 182: "acos",     { INTRGEN, 2, 61 },
 183: "dacos",    { INTRSPEC, TYDREAL, 62 },
 184: 
 185: "atan",     { INTRGEN, 2, 63 },
 186: "datan",    { INTRSPEC, TYDREAL, 64 },
 187: 
 188: "atan2",    { INTRGEN, 2, 65 },
 189: "datan2",   { INTRSPEC, TYDREAL, 66 },
 190: 
 191: "sinh",     { INTRGEN, 2, 67 },
 192: "dsinh",    { INTRSPEC, TYDREAL, 68 },
 193: 
 194: "cosh",     { INTRGEN, 2, 69 },
 195: "dcosh",    { INTRSPEC, TYDREAL, 70 },
 196: 
 197: "tanh",     { INTRGEN, 2, 71 },
 198: "dtanh",    { INTRSPEC, TYDREAL, 72 },
 199: 
 200: "lge",      { INTRSPEC, TYLOGICAL, 73},
 201: "lgt",      { INTRSPEC, TYLOGICAL, 75},
 202: "lle",      { INTRSPEC, TYLOGICAL, 77},
 203: "llt",      { INTRSPEC, TYLOGICAL, 79},
 204: 
 205: "",     { INTREND, 0, 0} };
 206: 
 207: 
 208: LOCAL struct Specblock
 209:     {
 210:     char atype;
 211:     char rtype;
 212:     char nargs;
 213:     char spxname[XL];
 214:     char othername; /* index into callbyvalue table */
 215:     } spectab[ ] =
 216: {
 217:     { TYREAL,TYREAL,1,"r_int" },
 218:     { TYDREAL,TYDREAL,1,"d_int" },
 219: 
 220:     { TYREAL,TYREAL,1,"r_nint" },
 221:     { TYDREAL,TYDREAL,1,"d_nint" },
 222: 
 223:     { TYREAL,TYSHORT,1,"h_nint" },
 224:     { TYREAL,TYLONG,1,"i_nint" },
 225: 
 226:     { TYDREAL,TYSHORT,1,"h_dnnt" },
 227:     { TYDREAL,TYLONG,1,"i_dnnt" },
 228: 
 229:     { TYREAL,TYREAL,1,"r_abs" },
 230:     { TYSHORT,TYSHORT,1,"h_abs" },
 231:     { TYLONG,TYLONG,1,"i_abs" },
 232:     { TYDREAL,TYDREAL,1,"d_abs" },
 233:     { TYCOMPLEX,TYREAL,1,"c_abs" },
 234:     { TYDCOMPLEX,TYDREAL,1,"z_abs" },
 235: 
 236:     { TYSHORT,TYSHORT,2,"h_mod" },
 237:     { TYLONG,TYLONG,2,"i_mod" },
 238:     { TYREAL,TYREAL,2,"r_mod" },
 239:     { TYDREAL,TYDREAL,2,"d_mod" },
 240: 
 241:     { TYREAL,TYREAL,2,"r_sign" },
 242:     { TYSHORT,TYSHORT,2,"h_sign" },
 243:     { TYLONG,TYLONG,2,"i_sign" },
 244:     { TYDREAL,TYDREAL,2,"d_sign" },
 245: 
 246:     { TYREAL,TYREAL,2,"r_dim" },
 247:     { TYSHORT,TYSHORT,2,"h_dim" },
 248:     { TYLONG,TYLONG,2,"i_dim" },
 249:     { TYDREAL,TYDREAL,2,"d_dim" },
 250: 
 251:     { TYREAL,TYDREAL,2,"d_prod" },
 252: 
 253:     { TYCHAR,TYSHORT,1,"h_len" },
 254:     { TYCHAR,TYLONG,1,"i_len" },
 255: 
 256:     { TYCHAR,TYSHORT,2,"h_indx" },
 257:     { TYCHAR,TYLONG,2,"i_indx" },
 258: 
 259:     { TYCOMPLEX,TYREAL,1,"r_imag" },
 260:     { TYDCOMPLEX,TYDREAL,1,"d_imag" },
 261:     { TYCOMPLEX,TYCOMPLEX,1,"r_cnjg" },
 262:     { TYDCOMPLEX,TYDCOMPLEX,1,"d_cnjg" },
 263: 
 264:     { TYREAL,TYREAL,1,"r_sqrt", 1 },
 265:     { TYDREAL,TYDREAL,1,"d_sqrt", 1 },
 266:     { TYCOMPLEX,TYCOMPLEX,1,"c_sqrt" },
 267:     { TYDCOMPLEX,TYDCOMPLEX,1,"z_sqrt" },
 268: 
 269:     { TYREAL,TYREAL,1,"r_exp", 2 },
 270:     { TYDREAL,TYDREAL,1,"d_exp", 2 },
 271:     { TYCOMPLEX,TYCOMPLEX,1,"c_exp" },
 272:     { TYDCOMPLEX,TYDCOMPLEX,1,"z_exp" },
 273: 
 274:     { TYREAL,TYREAL,1,"r_log", 3 },
 275:     { TYDREAL,TYDREAL,1,"d_log", 3 },
 276:     { TYCOMPLEX,TYCOMPLEX,1,"c_log" },
 277:     { TYDCOMPLEX,TYDCOMPLEX,1,"z_log" },
 278: 
 279:     { TYREAL,TYREAL,1,"r_lg10", 14 },
 280:     { TYDREAL,TYDREAL,1,"d_lg10", 14 },
 281: 
 282:     { TYREAL,TYREAL,1,"r_sin", 4 },
 283:     { TYDREAL,TYDREAL,1,"d_sin", 4 },
 284:     { TYCOMPLEX,TYCOMPLEX,1,"c_sin" },
 285:     { TYDCOMPLEX,TYDCOMPLEX,1,"z_sin" },
 286: 
 287:     { TYREAL,TYREAL,1,"r_cos", 5 },
 288:     { TYDREAL,TYDREAL,1,"d_cos", 5 },
 289:     { TYCOMPLEX,TYCOMPLEX,1,"c_cos" },
 290:     { TYDCOMPLEX,TYDCOMPLEX,1,"z_cos" },
 291: 
 292:     { TYREAL,TYREAL,1,"r_tan", 6 },
 293:     { TYDREAL,TYDREAL,1,"d_tan", 6 },
 294: 
 295:     { TYREAL,TYREAL,1,"r_asin", 7 },
 296:     { TYDREAL,TYDREAL,1,"d_asin", 7 },
 297: 
 298:     { TYREAL,TYREAL,1,"r_acos", 8 },
 299:     { TYDREAL,TYDREAL,1,"d_acos", 8 },
 300: 
 301:     { TYREAL,TYREAL,1,"r_atan", 9 },
 302:     { TYDREAL,TYDREAL,1,"d_atan", 9 },
 303: 
 304:     { TYREAL,TYREAL,2,"r_atn2", 10 },
 305:     { TYDREAL,TYDREAL,2,"d_atn2", 10 },
 306: 
 307:     { TYREAL,TYREAL,1,"r_sinh", 11 },
 308:     { TYDREAL,TYDREAL,1,"d_sinh", 11 },
 309: 
 310:     { TYREAL,TYREAL,1,"r_cosh", 12 },
 311:     { TYDREAL,TYDREAL,1,"d_cosh", 12 },
 312: 
 313:     { TYREAL,TYREAL,1,"r_tanh", 13 },
 314:     { TYDREAL,TYDREAL,1,"d_tanh", 13 },
 315: 
 316:     { TYCHAR,TYLOGICAL,2,"hl_ge" },
 317:     { TYCHAR,TYLOGICAL,2,"l_ge" },
 318: 
 319:     { TYCHAR,TYLOGICAL,2,"hl_gt" },
 320:     { TYCHAR,TYLOGICAL,2,"l_gt" },
 321: 
 322:     { TYCHAR,TYLOGICAL,2,"hl_le" },
 323:     { TYCHAR,TYLOGICAL,2,"l_le" },
 324: 
 325:     { TYCHAR,TYLOGICAL,2,"hl_lt" },
 326:     { TYCHAR,TYLOGICAL,2,"l_lt" },
 327: 
 328:     { TYDREAL,TYDREAL,2,"d_dprod"}  /* dprod() with dblflag */
 329: } ;
 330: 
 331: char callbyvalue[ ][XL] =
 332:     {
 333:     "sqrt",
 334:     "exp",
 335:     "log",
 336:     "sin",
 337:     "cos",
 338:     "tan",
 339:     "asin",
 340:     "acos",
 341:     "atan",
 342:     "atan2",
 343:     "sinh",
 344:     "cosh",
 345:     "tanh",
 346:     "log10"
 347:     };
 348: 
 349: expptr intrcall(np, argsp, nargs)
 350: Namep np;
 351: struct Listblock *argsp;
 352: int nargs;
 353: {
 354: int i, rettype;
 355: Addrp ap;
 356: register struct Specblock *sp;
 357: register struct Chain *cp;
 358: expptr inline(), mkcxcon(), mkrealcon();
 359: expptr q, ep;
 360: int mtype;
 361: int op;
 362: int f1field, f2field, f3field;
 363: 
 364: packed.ijunk = np->vardesc.varno;
 365: f1field = packed.bits.f1;
 366: f2field = packed.bits.f2;
 367: f3field = packed.bits.f3;
 368: if(nargs == 0)
 369:     goto badnargs;
 370: 
 371: mtype = 0;
 372: for(cp = argsp->listp ; cp ; cp = cp->nextp)
 373:     {
 374: /* TEMPORARY */ ep = (expptr) (cp->datap);
 375: /* TEMPORARY */ if( ISCONST(ep) && ep->headblock.vtype==TYSHORT )
 376: /* TEMPORARY */     cp->datap = (tagptr) mkconv(tyint, ep);
 377:     mtype = maxtype(mtype, ep->headblock.vtype);
 378:     }
 379: 
 380: switch(f1field)
 381:     {
 382:     case INTRBOOL:
 383:         op = f3field;
 384:         if( ! ONEOF(mtype, MSKINT|MSKLOGICAL) )
 385:             goto badtype;
 386:         if(op == OPBITNOT)
 387:             {
 388:             if(nargs != 1)
 389:                 goto badnargs;
 390:             q = mkexpr(OPBITNOT, argsp->listp->datap, ENULL);
 391:             }
 392:         else
 393:             {
 394:             if(nargs != 2)
 395:                 goto badnargs;
 396:             q = mkexpr(op, argsp->listp->datap,
 397:                 argsp->listp->nextp->datap);
 398:             }
 399:         frchain( &(argsp->listp) );
 400:         free( (charptr) argsp);
 401:         return(q);
 402: 
 403:     case INTRCONV:
 404:         if (nargs == 1)
 405:             {
 406:             if(argsp->listp->datap->headblock.vtype == TYERROR)
 407:                 {
 408:                 free( (charptr) argsp->listp->datap);
 409:                 frchain( &(argsp->listp) );
 410:                 free( (charptr) argsp);
 411:                 return( errnode() );
 412:                 }
 413:             }
 414:         else if (nargs == 2)
 415:             {
 416:             if(argsp->listp->nextp->datap->headblock.vtype ==
 417:                 TYERROR ||
 418:                 argsp->listp->datap->headblock.vtype == TYERROR)
 419:                 {
 420:                 free( (charptr) argsp->listp->nextp->datap);
 421:                 free( (charptr) argsp->listp->datap);
 422:                 frchain( &(argsp->listp) );
 423:                 free( (charptr) argsp);
 424:                 return( errnode() );
 425:                 }
 426:             }
 427:         rettype = f2field;
 428:         if( ISCOMPLEX(rettype) && nargs==2)
 429:             {
 430:             expptr qr, qi;
 431:             if(dblflag) rettype = TYDCOMPLEX;
 432:             qr = (expptr) (argsp->listp->datap);
 433:             qi = (expptr) (argsp->listp->nextp->datap);
 434:             if(ISCONST(qr) && ISCONST(qi))
 435:                 q = mkcxcon(qr,qi);
 436:             else    q = mkexpr(OPCONV,intrconv(rettype-2,qr),
 437:                     intrconv(rettype-2,qi));
 438:             }
 439:         else if(nargs == 1)
 440:             {
 441:             if(rettype == TYLONG) rettype = tyint;
 442:             else if( dblflag )
 443:                 {
 444:                 if ( rettype == TYREAL )
 445:                     rettype = TYDREAL;
 446:                 else if( rettype == TYCOMPLEX )
 447:                     rettype = TYDCOMPLEX;
 448:                 }
 449:             q = intrconv(rettype, argsp->listp->datap);
 450:             }
 451:         else goto badnargs;
 452: 
 453:         q->headblock.vtype = rettype;
 454:         frchain(&(argsp->listp));
 455:         free( (charptr) argsp);
 456:         return(q);
 457: 
 458:     case INTRGEN:
 459:         sp = spectab + f3field;
 460: #ifdef ONLY66
 461:         if(no66flag)
 462:             if(sp->atype == mtype)
 463:                 goto specfunct;
 464:             else err66("generic function");
 465: #endif
 466: 
 467:         for(i=0; i<f2field ; ++i)
 468:             if(sp->atype == mtype)
 469:                 goto specfunct;
 470:             else
 471:                 ++sp;
 472:         goto badtype;
 473: 
 474:     case INTRSPEC:
 475:         sp = spectab + f3field;
 476:         if( dblflag )
 477:             {
 478:             /* convert specific complex functions to double complex:
 479: 			 *	 cabs,csqrt,cexp,clog,csin,ccos, aimag
 480: 			 * and convert real specifics to double:
 481: 			 *	 amod,alog,alog10
 482: 			 * (sqrt,cos,sin,... o.k. since go through INTRGEN)
 483: 			 */
 484:             if( (sp->atype==TYCOMPLEX && (sp+1)->atype==TYDCOMPLEX)
 485:                 ||(sp->atype==TYREAL && (sp+1)->atype==TYDREAL))
 486:                     sp++;
 487:             }
 488:     specfunct:
 489:         if(tyint==TYLONG && ONEOF(sp->rtype,M(TYSHORT)|M(TYLOGICAL))
 490:             && (sp+1)->atype==sp->atype)
 491:                 ++sp;
 492: 
 493:         if(nargs != sp->nargs)
 494:             goto badnargs;
 495:         if(mtype != sp->atype
 496:             && (!dblflag || f3field != 26 || mtype != TYDREAL ) )
 497:                 goto badtype;
 498:         fixargs(YES, argsp);
 499:         if(q = inline(sp-spectab, mtype, argsp->listp))
 500:             {
 501:             frchain( &(argsp->listp) );
 502:             free( (charptr) argsp);
 503:             }
 504:         else if(sp->othername)
 505:             {
 506:             ap = builtin(TYDREAL,
 507:                 varstr(XL, callbyvalue[sp->othername-1]) );
 508:             ap->vstg = STGINTR;
 509:             q = fixexpr( mkexpr(OPCCALL, ap, argsp) );
 510:             if( sp->rtype != TYDREAL )
 511:                 q = mkconv( sp->rtype, q );
 512:             }
 513:         else
 514:             {
 515:             ap = builtin(sp->rtype, varstr(XL, sp->spxname) );
 516:             ap->vstg = STGINTR;
 517:             q = fixexpr( mkexpr(OPCALL, ap, argsp) );
 518:             }
 519:         return(q);
 520: 
 521:     case INTRMIN:
 522:     case INTRMAX:
 523:         if(nargs < 2)
 524:             goto badnargs;
 525:         if( ! ONEOF(mtype, MSKINT|MSKREAL) )
 526:             goto badtype;
 527:         argsp->vtype = mtype;
 528:         q = mkexpr( (f1field==INTRMIN ? OPMIN : OPMAX), argsp, ENULL);
 529: 
 530:         q->headblock.vtype = mtype;
 531:         rettype = f2field;
 532:         if(rettype == TYLONG)
 533:             rettype = tyint;
 534:         else if(rettype == TYUNKNOWN)
 535:             rettype = mtype;
 536:         else if( dblflag && rettype == TYREAL )
 537:             rettype = TYDREAL;
 538:         return( intrconv(rettype, q) );
 539: 
 540:     default:
 541:         fatali("intrcall: bad intrgroup %d", f1field);
 542:     }
 543: badnargs:
 544:     errstr("bad number of arguments to intrinsic %s",
 545:         varstr(VL,np->varname) );
 546:     goto bad;
 547: 
 548: badtype:
 549:     errstr("bad argument type to intrinsic %s", varstr(VL, np->varname) );
 550: 
 551: bad:
 552:     return( errnode() );
 553: }
 554: 
 555: 
 556: 
 557: 
 558: intrfunct(s)
 559: char s[VL];
 560: {
 561: register struct Intrblock *p;
 562: char nm[VL];
 563: register int i;
 564: 
 565: for(i = 0 ; i<VL ; ++s)
 566:     nm[i++] = (*s==' ' ? '\0' : *s);
 567: 
 568: for(p = intrtab; p->intrval.intrgroup!=INTREND ; ++p)
 569:     {
 570:     if( eqn(VL, nm, p->intrfname) )
 571:         {
 572:         packed.bits.f1 = p->intrval.intrgroup;
 573:         packed.bits.f2 = p->intrval.intrstuff;
 574:         packed.bits.f3 = p->intrval.intrno;
 575:         return(packed.ijunk);
 576:         }
 577:     }
 578: 
 579: return(0);
 580: }
 581: 
 582: 
 583: 
 584: 
 585: 
 586: Addrp intraddr(np)
 587: Namep np;
 588: {
 589: Addrp q;
 590: register struct Specblock *sp;
 591: int f3field;
 592: 
 593: if(np->vclass!=CLPROC || np->vprocclass!=PINTRINSIC)
 594:     fatalstr("intraddr: %s is not intrinsic", varstr(VL,np->varname));
 595: packed.ijunk = np->vardesc.varno;
 596: f3field = packed.bits.f3;
 597: 
 598: switch(packed.bits.f1)
 599:     {
 600:     case INTRGEN:
 601:         /* imag, log, and log10 arent specific functions */
 602:         if(f3field==31 || f3field==43 || f3field==47)
 603:             goto bad;
 604: 
 605:     case INTRSPEC:
 606:         sp = spectab + f3field;
 607:         if( dblflag )
 608:             {
 609:             if((sp->atype==TYCOMPLEX && (sp+1)->atype==TYDCOMPLEX)
 610:                 ||(sp->atype==TYREAL && (sp+1)->atype==TYDREAL))
 611:                     sp++;
 612:             else if( f3field==4 )
 613:                     sp += 2;  /* h_nint -> h_dnnt */
 614:             else if( f3field==8 || f3field==18 || f3field==22)
 615:                     sp += 3;  /* r_{abs,sign,dim} ->d_... */
 616:             else if( f3field==26 )
 617:                     sp = spectab + 81; /* dprod */
 618: 
 619:             }
 620:         if(tyint==TYLONG && sp->rtype==TYSHORT)
 621:             ++sp;
 622:         q = builtin(sp->rtype, varstr(XL,sp->spxname) );
 623:         q->vstg = STGINTR;
 624:         return(q);
 625: 
 626:     case INTRCONV:
 627:     case INTRMIN:
 628:     case INTRMAX:
 629:     case INTRBOOL:
 630:     bad:
 631:         errstr("cannot pass %s as actual",
 632:             varstr(VL,np->varname));
 633:         return( (Addrp) errnode() );
 634:     }
 635: fatali("intraddr: impossible f1=%d\n", (int) packed.bits.f1);
 636: /* NOTREACHED */
 637: }
 638: 
 639: 
 640: 
 641: 
 642: 
 643: expptr inline(fno, type, args)
 644: int fno;
 645: int type;
 646: struct Chain *args;
 647: {
 648: register expptr q, t, t1;
 649: 
 650: switch(fno)
 651:     {
 652:     case 8: /* real abs */
 653:     case 9: /* short int abs */
 654:     case 10:    /* long int abs */
 655:     case 11:    /* double precision abs */
 656:         if( addressable(q = (expptr) (args->datap)) )
 657:             {
 658:             t = q;
 659:             q = NULL;
 660:             }
 661:         else
 662:             t = (expptr) mktemp(type,PNULL);
 663:         t1 = mkexpr(OPQUEST,
 664:             mkexpr(OPLE, intrconv(type,ICON(0)), cpexpr(t)),
 665:             mkexpr(OPCOLON, cpexpr(t),
 666:                 mkexpr(OPNEG, cpexpr(t), ENULL) ));
 667:         if(q)
 668:             t1 = mkexpr(OPCOMMA, mkexpr(OPASSIGN, cpexpr(t),q), t1);
 669:         frexpr(t);
 670:         return(t1);
 671: 
 672:     case 26:    /* dprod */
 673:         q = mkexpr(OPSTAR, intrconv(TYDREAL,args->datap), args->nextp->datap);
 674:         return(q);
 675: 
 676:     case 27:    /* len of character string */
 677:     case 28:
 678:         q = (expptr) cpexpr(args->datap->headblock.vleng);
 679:         frexpr(args->datap);
 680:         return(q);
 681: 
 682:     case 14:    /* half-integer mod */
 683:     case 15:    /* mod */
 684:         return( mkexpr(OPMOD, (expptr) (args->datap),
 685:             (expptr) (args->nextp->datap) ));
 686:     }
 687: return(NULL);
 688: }

Defined functions

inline defined in line 643; used 2 times
intraddr defined in line 586; used 2 times
intrcall defined in line 349; used 2 times

Defined variables

callbyvalue defined in line 331; used 1 times
intrtab defined in line 64; used 1 times
sccsid defined in line 8; never used
spectab defined in line 215; used 5 times

Defined struct's

Intrbits defined in line 53; used 2 times
  • in line 63(2)
Intrblock defined in line 60; used 2 times
  • in line 561(2)
Specblock defined in line 208; used 4 times
Last modified: 1985-08-29
Generated: 2016-12-26
Generated by src2html V0.67
page hit count: 1907
Valid CSS Valid XHTML 1.0 Strict