2.9BSD - /usr/src/cmd/f77/intr.c

   1: #include "defs"
   2: #include "string_defs"
   3: 
   4: /*
   5:  * Note: an addition has been made to the intrinsic
   6:  * function tables to support the fortran bit
   7:  * functions:
   8:  *  	igetbt, iand, ieor, inot, ior, ishft, iputbt
   9:  *
  10:  *  mod is selected by '#define BITFUNC'
  11:  * wfj and jlh 8 august 1979 USGS Menlo Park.
  12:  */
  13: /* INTRINSIC FUNCTIONS: The compiler needs to recognize the name of an
  14: intrinsic function, decide on which C routine to call depending on the
  15: type of the arguement, then call that routine and tell the compiler
  16: the type of the result.
  17:      The structure intrblock is the intrinsic function table. Each line
  18: of the table contains the intrinsic function name (intrtab[i].intrfname)
  19: and three numbers that are actually packed into one long word with the
  20: structure intrbits. The first number (intrtab.intrval.f1) tells how the
  21: type is to be checked and converted if necessary. The second number
  22: (intrtab.intrval.f2) tells either the type of the argument required
  23: or in the case of INTRGEN tells how many lines of the spectable to
  24: search. The third number (intrtab.intrval.f3) tells which line of the
  25: spectable to go to or to begin at.
  26:      The spectable is the structure specblock and contains four columns:
  27: the type of argument(s) required, the type of result returned, the number
  28: of arguments required, and the name of the C routine to be called.
  29:      INTRCONV, INTRBOOL, INTRMAX, and INTRMIN are all done internally
  30: with no subroutine call necessary. INTRSPEC requires that the argument
  31: be of the type specified. INTRGEN requires that the argument be of one
  32: of the types specified in the spectable beginning at line intrtab.intrval.
  33: f3 and going for intrtab.intrval.f2 lines.
  34: PLWard, Menlo  4/8/80                    */
  35: 
  36: #define BITFUNC
  37: 
  38: 
  39: union
  40:     {
  41:     int ijunk;
  42:     struct intrpacked bits;
  43:     } packed;
  44: 
  45: struct intrbits
  46:     {
  47:     int intrgroup /* :3 */;
  48:     int intrstuff /* result type or number of generics */;
  49:     int intrno /* :7 */;
  50:     };
  51: 
  52: LOCAL struct intrblock
  53:     {
  54:     char intrfname[VL];
  55:     struct intrbits intrval;
  56:     } intrtab[ ] =
  57: {
  58: "int",      { INTRCONV, TYLONG },
  59: "real",     { INTRCONV, TYREAL },
  60: "dble",     { INTRCONV, TYDREAL },
  61: "cmplx",    { INTRCONV, TYCOMPLEX },
  62: "dcmplx",   { INTRCONV, TYDCOMPLEX },
  63: "ifix",     { INTRCONV, TYLONG },
  64: "idint",    { INTRCONV, TYLONG },
  65: "float",    { INTRCONV, TYREAL },
  66: "dfloat",   { INTRCONV, TYDREAL },
  67: "sngl",     { INTRCONV, TYREAL },
  68: "ichar",    { INTRCONV, TYLONG },
  69: "char",     { INTRCONV, TYCHAR },
  70: 
  71: "max",      { INTRMAX, TYUNKNOWN },
  72: "max0",     { INTRMAX, TYLONG },
  73: "amax0",    { INTRMAX, TYREAL },
  74: "max1",     { INTRMAX, TYLONG },
  75: "amax1",    { INTRMAX, TYREAL },
  76: "dmax1",    { INTRMAX, TYDREAL },
  77: 
  78: "and",      { INTRBOOL, TYUNKNOWN, OPBITAND },
  79: "or",       { INTRBOOL, TYUNKNOWN, OPBITOR },
  80: "xor",      { INTRBOOL, TYUNKNOWN, OPBITXOR },
  81: "not",      { INTRBOOL, TYUNKNOWN, OPBITNOT },
  82: "lshift",   { INTRBOOL, TYUNKNOWN, OPLSHIFT },
  83: "rshift",   { INTRBOOL, TYUNKNOWN, OPRSHIFT },
  84: 
  85: "min",      { INTRMIN, TYUNKNOWN },
  86: "min0",     { INTRMIN, TYLONG },
  87: "amin0",    { INTRMIN, TYREAL },
  88: "min1",     { INTRMIN, TYLONG },
  89: "amin1",    { INTRMIN, TYREAL },
  90: "dmin1",    { INTRMIN, TYDREAL },
  91: 
  92: "aint",     { INTRGEN, 2, 0 },
  93: "dint",     { INTRSPEC, TYDREAL, 1 },
  94: 
  95: "anint",    { INTRGEN, 2, 2 },
  96: "dnint",    { INTRSPEC, TYDREAL, 3 },
  97: 
  98: "nint",     { INTRGEN, 4, 4 },
  99: "idnint",   { INTRGEN, 2, 6 },
 100: 
 101: "abs",      { INTRGEN, 6, 8 },
 102: "iabs",     { INTRGEN, 2, 9 },
 103: "dabs",     { INTRSPEC, TYDREAL, 11 },
 104: "cabs",     { INTRSPEC, TYREAL, 12 },
 105: "zabs",     { INTRSPEC, TYDREAL, 13 },
 106: 
 107: "mod",      { INTRGEN, 4, 14 },
 108: "amod",     { INTRSPEC, TYREAL, 16 },
 109: "dmod",     { INTRSPEC, TYDREAL, 17 },
 110: 
 111: "sign",     { INTRGEN, 4, 18 },
 112: "isign",    { INTRGEN, 2, 19 },
 113: "dsign",    { INTRSPEC, TYDREAL, 21 },
 114: 
 115: "dim",      { INTRGEN, 4, 22 },
 116: "idim",     { INTRGEN, 2, 23 },
 117: "ddim",     { INTRSPEC, TYDREAL, 25 },
 118: 
 119: "dprod",    { INTRSPEC, TYDREAL, 26 },
 120: 
 121: "len",      { INTRSPEC, TYLONG, 27 },
 122: "index",    { INTRSPEC, TYLONG, 29 },
 123: 
 124: "imag",     { INTRGEN, 2, 31 },
 125: "aimag",    { INTRSPEC, TYREAL, 31 },
 126: "dimag",    { INTRSPEC, TYDREAL, 32 },
 127: 
 128: "conjg",    { INTRGEN, 2, 33 },
 129: "dconjg",   { INTRSPEC, TYDCOMPLEX, 34 },
 130: 
 131: "sqrt",     { INTRGEN, 4, 35 },
 132: "dsqrt",    { INTRSPEC, TYDREAL, 36 },
 133: "csqrt",    { INTRSPEC, TYCOMPLEX, 37 },
 134: "zsqrt",    { INTRSPEC, TYDCOMPLEX, 38 },
 135: 
 136: "exp",      { INTRGEN, 4, 39 },
 137: "dexp",     { INTRSPEC, TYDREAL, 40 },
 138: "cexp",     { INTRSPEC, TYCOMPLEX, 41 },
 139: "zexp",     { INTRSPEC, TYDCOMPLEX, 42 },
 140: 
 141: "log",      { INTRGEN, 4, 43 },
 142: "alog",     { INTRSPEC, TYREAL, 43 },
 143: "dlog",     { INTRSPEC, TYDREAL, 44 },
 144: "clog",     { INTRSPEC, TYCOMPLEX, 45 },
 145: "zlog",     { INTRSPEC, TYDCOMPLEX, 46 },
 146: 
 147: "log10",    { INTRGEN, 2, 47 },
 148: "alog10",   { INTRSPEC, TYREAL, 47 },
 149: "dlog10",   { INTRSPEC, TYDREAL, 48 },
 150: 
 151: "sin",      { INTRGEN, 4, 49 },
 152: "dsin",     { INTRSPEC, TYDREAL, 50 },
 153: "csin",     { INTRSPEC, TYCOMPLEX, 51 },
 154: "zsin",     { INTRSPEC, TYDCOMPLEX, 52 },
 155: 
 156: "cos",      { INTRGEN, 4, 53 },
 157: "dcos",     { INTRSPEC, TYDREAL, 54 },
 158: "ccos",     { INTRSPEC, TYCOMPLEX, 55 },
 159: "zcos",     { INTRSPEC, TYDCOMPLEX, 56 },
 160: 
 161: "tan",      { INTRGEN, 2, 57 },
 162: "dtan",     { INTRSPEC, TYDREAL, 58 },
 163: 
 164: "asin",     { INTRGEN, 2, 59 },
 165: "dasin",    { INTRSPEC, TYDREAL, 60 },
 166: 
 167: "acos",     { INTRGEN, 2, 61 },
 168: "dacos",    { INTRSPEC, TYDREAL, 62 },
 169: 
 170: "atan",     { INTRGEN, 2, 63 },
 171: "datan",    { INTRSPEC, TYDREAL, 64 },
 172: 
 173: "atan2",    { INTRGEN, 2, 65 },
 174: "datan2",   { INTRSPEC, TYDREAL, 66 },
 175: 
 176: "sinh",     { INTRGEN, 2, 67 },
 177: "dsinh",    { INTRSPEC, TYDREAL, 68 },
 178: 
 179: "cosh",     { INTRGEN, 2, 69 },
 180: "dcosh",    { INTRSPEC, TYDREAL, 70 },
 181: 
 182: "tanh",     { INTRGEN, 2, 71 },
 183: "dtanh",    { INTRSPEC, TYDREAL, 72 },
 184: 
 185: "lge",      { INTRSPEC, TYLOGICAL, 73},
 186: "lgt",      { INTRSPEC, TYLOGICAL, 75},
 187: "lle",      { INTRSPEC, TYLOGICAL, 77},
 188: "llt",      { INTRSPEC, TYLOGICAL, 79},
 189: 
 190: #ifdef BITFUNC
 191: 
 192: "igetbt",   { INTRGEN,2, 81},
 193: "iand",     { INTRGEN, 2, 83},
 194: "ieor",     { INTRGEN, 2, 85},
 195: "inot",     { INTRGEN, 2, 87},
 196: "ior",      { INTRGEN, 2, 89},
 197: "ishft",    { INTRGEN, 2, 91},
 198: "iputbt",   { INTRGEN, 2, 93},
 199: 
 200: #endif
 201: 
 202: "" };
 203: 
 204: 
 205: LOCAL struct specblock
 206:     {
 207:     char atype;
 208:     char rtype;
 209:     char nargs;
 210:     char spxname[XL];
 211:     char othername; /* index into callbyvalue table */
 212:     } spectab[ ] =
 213: {
 214:     { TYREAL,TYREAL,1,"r_int" },
 215:     { TYDREAL,TYDREAL,1,"d_int" },
 216: 
 217:     { TYREAL,TYREAL,1,"r_nint" },
 218:     { TYDREAL,TYDREAL,1,"d_nint" },
 219: 
 220:     { TYREAL,TYSHORT,1,"h_nint" },
 221:     { TYREAL,TYLONG,1,"i_nint" },
 222: 
 223:     { TYDREAL,TYSHORT,1,"h_dnnt" },
 224:     { TYDREAL,TYLONG,1,"i_dnnt" },
 225: 
 226:     { TYREAL,TYREAL,1,"r_abs" },
 227:     { TYSHORT,TYSHORT,1,"h_abs" },
 228:     { TYLONG,TYLONG,1,"i_abs" },
 229:     { TYDREAL,TYDREAL,1,"d_abs" },
 230:     { TYCOMPLEX,TYREAL,1,"c_abs" },
 231:     { TYDCOMPLEX,TYDREAL,1,"z_abs" },
 232: 
 233:     { TYSHORT,TYSHORT,2,"h_mod" },
 234:     { TYLONG,TYLONG,2,"i_mod" },
 235:     { TYREAL,TYREAL,2,"r_mod" },
 236:     { TYDREAL,TYDREAL,2,"d_mod" },
 237: 
 238:     { TYREAL,TYREAL,2,"r_sign" },
 239:     { TYSHORT,TYSHORT,2,"h_sign" },
 240:     { TYLONG,TYLONG,2,"i_sign" },
 241:     { TYDREAL,TYDREAL,2,"d_sign" },
 242: 
 243:     { TYREAL,TYREAL,2,"r_dim" },
 244:     { TYSHORT,TYSHORT,2,"h_dim" },
 245:     { TYLONG,TYLONG,2,"i_dim" },
 246:     { TYDREAL,TYDREAL,2,"d_dim" },
 247: 
 248:     { TYREAL,TYDREAL,2,"d_prod" },
 249: 
 250:     { TYCHAR,TYSHORT,1,"h_len" },
 251:     { TYCHAR,TYLONG,1,"i_len" },
 252: 
 253:     { TYCHAR,TYSHORT,2,"h_indx" },
 254:     { TYCHAR,TYLONG,2,"i_indx" },
 255: 
 256:     { TYCOMPLEX,TYREAL,1,"r_imag" },
 257:     { TYDCOMPLEX,TYDREAL,1,"d_imag" },
 258:     { TYCOMPLEX,TYCOMPLEX,1,"r_cnjg" },
 259:     { TYDCOMPLEX,TYDCOMPLEX,1,"d_cnjg" },
 260: 
 261:     { TYREAL,TYREAL,1,"r_sqrt", 1 },
 262:     { TYDREAL,TYDREAL,1,"d_sqrt", 1 },
 263:     { TYCOMPLEX,TYCOMPLEX,1,"c_sqrt" },
 264:     { TYDCOMPLEX,TYDCOMPLEX,1,"z_sqrt" },
 265: 
 266:     { TYREAL,TYREAL,1,"r_exp", 2 },
 267:     { TYDREAL,TYDREAL,1,"d_exp", 2 },
 268:     { TYCOMPLEX,TYCOMPLEX,1,"c_exp" },
 269:     { TYDCOMPLEX,TYDCOMPLEX,1,"z_exp" },
 270: 
 271:     { TYREAL,TYREAL,1,"r_log", 3 },
 272:     { TYDREAL,TYDREAL,1,"d_log", 3 },
 273:     { TYCOMPLEX,TYCOMPLEX,1,"c_log" },
 274:     { TYDCOMPLEX,TYDCOMPLEX,1,"z_log" },
 275: 
 276:     { TYREAL,TYREAL,1,"r_lg10" },
 277:     { TYDREAL,TYDREAL,1,"d_lg10" },
 278: 
 279:     { TYREAL,TYREAL,1,"r_sin", 4 },
 280:     { TYDREAL,TYDREAL,1,"d_sin", 4 },
 281:     { TYCOMPLEX,TYCOMPLEX,1,"c_sin" },
 282:     { TYDCOMPLEX,TYDCOMPLEX,1,"z_sin" },
 283: 
 284:     { TYREAL,TYREAL,1,"r_cos", 5 },
 285:     { TYDREAL,TYDREAL,1,"d_cos", 5 },
 286:     { TYCOMPLEX,TYCOMPLEX,1,"c_cos" },
 287:     { TYDCOMPLEX,TYDCOMPLEX,1,"z_cos" },
 288: 
 289:     { TYREAL,TYREAL,1,"r_tan", 6 },
 290:     { TYDREAL,TYDREAL,1,"d_tan", 6 },
 291: 
 292:     { TYREAL,TYREAL,1,"r_asin", 7 },
 293:     { TYDREAL,TYDREAL,1,"d_asin", 7 },
 294: 
 295:     { TYREAL,TYREAL,1,"r_acos", 8 },
 296:     { TYDREAL,TYDREAL,1,"d_acos", 8 },
 297: 
 298:     { TYREAL,TYREAL,1,"r_atan", 9 },
 299:     { TYDREAL,TYDREAL,1,"d_atan", 9 },
 300: 
 301:     { TYREAL,TYREAL,2,"r_atn2", 10 },
 302:     { TYDREAL,TYDREAL,2,"d_atn2", 10 },
 303: 
 304:     { TYREAL,TYREAL,1,"r_sinh", 11 },
 305:     { TYDREAL,TYDREAL,1,"d_sinh", 11 },
 306: 
 307:     { TYREAL,TYREAL,1,"r_cosh", 12 },
 308:     { TYDREAL,TYDREAL,1,"d_cosh", 12 },
 309: 
 310:     { TYREAL,TYREAL,1,"r_tanh", 13 },
 311:     { TYDREAL,TYDREAL,1,"d_tanh", 13 },
 312: 
 313:     { TYCHAR,TYLOGICAL,2,"hl_ge" },
 314:     { TYCHAR,TYLOGICAL,2,"l_ge" },
 315: 
 316:     { TYCHAR,TYLOGICAL,2,"hl_gt" },
 317:     { TYCHAR,TYLOGICAL,2,"l_gt" },
 318: 
 319:     { TYCHAR,TYLOGICAL,2,"hl_le" },
 320:     { TYCHAR,TYLOGICAL,2,"l_le" },
 321: 
 322:     { TYCHAR,TYLOGICAL,2,"hl_lt" },
 323:     { TYCHAR,TYLOGICAL,2,"l_lt" }
 324: 
 325: #ifdef BITFUNC
 326:         ,
 327: 
 328:     { TYSHORT,TYSHORT,3,"h_getbit" },
 329:     { TYLONG,TYLONG,3,"i_getbit" },
 330:     { TYSHORT,TYSHORT,2,"h_iand" },
 331:     { TYLONG,TYLONG,2,"i_iand" },
 332:     { TYSHORT,TYSHORT,2,"h_ieor" },
 333:     { TYLONG,TYLONG,2,"i_ieor" },
 334:     { TYSHORT,TYSHORT,1,"h_not" },
 335:     { TYLONG,TYLONG,1,"i_not" },
 336:     { TYSHORT,TYSHORT,2,"h_ior" },
 337:     { TYLONG,TYLONG,2,"i_ior" },
 338:     { TYSHORT,TYSHORT,2,"h_ishft" },
 339:     { TYLONG,TYLONG,2,"i_ishft" },
 340:     { TYSHORT,TYSHORT,4,"h_putbit" },
 341:     { TYLONG,TYLONG,4,"i_putbit" }
 342: 
 343: #endif
 344: 
 345: } ;
 346: 
 347: 
 348: 
 349: 
 350: 
 351: 
 352: char callbyvalue[ ][XL] =
 353:     {
 354:     "sqrt",
 355:     "exp",
 356:     "log",
 357:     "sin",
 358:     "cos",
 359:     "tan",
 360:     "asin",
 361:     "acos",
 362:     "atan",
 363:     "atan2",
 364:     "sinh",
 365:     "cosh",
 366:     "tanh"
 367:     };
 368: 
 369: struct exprblock *intrcall(np, argsp, nargs)
 370: struct nameblock *np;
 371: struct listblock *argsp;
 372: int nargs;
 373: {
 374: int i, rettype;
 375: struct addrblock *ap;
 376: register struct specblock *sp;
 377: struct exprblock *q, *inline();
 378: register chainp cp;
 379: struct constblock *mkcxcon();
 380: expptr ep;
 381: int mtype;
 382: int op;
 383: 
 384: packed.ijunk = np->vardesc.varno;
 385: if(nargs == 0)
 386:     goto badnargs;
 387: 
 388: mtype = 0;
 389: for(cp = argsp->listp ; cp ; cp = cp->nextp)
 390:     {
 391: /* TEMPORARY */ ep = cp->datap;
 392: /* TEMPORARY */ if( ISCONST(ep) && ep->vtype==TYSHORT )
 393: /* TEMPORARY */     cp->datap = mkconv(tyint, ep);
 394:     mtype = maxtype(mtype, ep->vtype);
 395:     }
 396: 
 397: switch(packed.bits.f1)
 398:     {
 399:     case INTRBOOL:
 400:         op = packed.bits.f3;
 401:         if( ! ONEOF(mtype, MSKINT|MSKLOGICAL) )
 402:             goto badtype;
 403:         if(op == OPBITNOT)
 404:             {
 405:             if(nargs != 1)
 406:                 goto badnargs;
 407:             q = mkexpr(OPBITNOT, argsp->listp->datap, NULL);
 408:             }
 409:         else
 410:             {
 411:             if(nargs != 2)
 412:                 goto badnargs;
 413:             q = mkexpr(op, argsp->listp->datap,
 414:                 argsp->listp->nextp->datap);
 415:             }
 416:         frchain( &(argsp->listp) );
 417:         free(argsp);
 418:         return(q);
 419: 
 420:     case INTRCONV:
 421:         rettype = packed.bits.f2;
 422:         if(rettype == TYLONG)
 423:             rettype = tyint;
 424:         if( ISCOMPLEX(rettype) && nargs==2)
 425:             {
 426:             expptr qr, qi;
 427:             qr = argsp->listp->datap;
 428:             qi = argsp->listp->nextp->datap;
 429:             if(ISCONST(qr) && ISCONST(qi))
 430:                 q = mkcxcon(qr,qi);
 431:             else    q = mkexpr(OPCONV,mkconv(rettype-2,qr),
 432:                     mkconv(rettype-2,qi));
 433:             }
 434:         else if(nargs == 1)
 435:             q = mkconv(rettype, argsp->listp->datap);
 436:         else goto badnargs;
 437: 
 438:         q->vtype = rettype;
 439:         frchain(&(argsp->listp));
 440:         free(argsp);
 441:         return(q);
 442: 
 443: 
 444:     case INTRGEN:
 445:         sp = spectab + packed.bits.f3;
 446:         for(i=0; i<packed.bits.f2 ; ++i)
 447:             if(sp->atype == mtype)
 448:                 goto specfunct;
 449:             else
 450:                 ++sp;
 451:         goto badtype;
 452: 
 453:     case INTRSPEC:
 454:         sp = spectab + packed.bits.f3;
 455:         if(tyint==TYLONG && sp->rtype==TYSHORT)
 456:             ++sp;
 457: 
 458:     specfunct:
 459:         if(nargs != sp->nargs)
 460:             goto badnargs;
 461:         if(mtype != sp->atype)
 462:             goto badtype;
 463:         fixargs(YES, argsp);
 464:         if(q = inline(sp-spectab, mtype, argsp->listp))
 465:             {
 466:             frchain( &(argsp->listp) );
 467:             free(argsp);
 468:             }
 469:         else if(sp->othername)
 470:             {
 471:             ap = builtin(sp->rtype,
 472:                 varstr(XL, callbyvalue[sp->othername-1]) );
 473:             q = fixexpr( mkexpr(OPCCALL, ap, argsp) );
 474:             }
 475:         else
 476:             {
 477:             ap = builtin(sp->rtype, varstr(XL, sp->spxname) );
 478:             q = fixexpr( mkexpr(OPCALL, ap, argsp) );
 479:             }
 480:         return(q);
 481: 
 482:     case INTRMIN:
 483:     case INTRMAX:
 484:         if(nargs < 2)
 485:             goto badnargs;
 486:         if( ! ONEOF(mtype, MSKINT|MSKREAL) )
 487:             goto badtype;
 488:         argsp->vtype = mtype;
 489:         q = mkexpr( (packed.bits.f1==INTRMIN ? OPMIN : OPMAX), argsp, NULL);
 490: 
 491:         q->vtype = mtype;
 492:         rettype = packed.bits.f2;
 493:         if(rettype == TYLONG)
 494:             rettype = tyint;
 495:         else if(rettype == TYUNKNOWN)
 496:             rettype = mtype;
 497:         return( mkconv(rettype, q) );
 498: 
 499:     default:
 500:         error("intrcall: bad intrgroup %d", packed.bits.f1,0,FATAL1);
 501:     }
 502: badnargs:
 503:     error("bad number of arguments to intrinsic %s",
 504:         varstr(VL,np->varname),0,ERR1);
 505:     goto bad;
 506: 
 507: badtype:
 508:     error("bad argument type to intrinsic %s", varstr(VL, np->varname),
 509:         0,ERR1);
 510: 
 511: bad:
 512:     return( errnode() );
 513: }
 514: 
 515: 
 516: 
 517: 
 518: intrfunct(s)
 519: char s[VL];
 520: {
 521: register struct intrblock *p;
 522: char nm[VL];
 523: register int i;
 524: 
 525: for(i = 0 ; i<VL ; ++s)
 526:     nm[i++] = (*s==' ' ? '\0' : *s);
 527: 
 528: for(p = intrtab; p->intrval.intrgroup!=INTREND ; ++p)
 529:     {
 530:     if( eqn(VL, nm, p->intrfname) )
 531:         {
 532:         packed.bits.f1 = p->intrval.intrgroup;
 533:         packed.bits.f2 = p->intrval.intrstuff;
 534:         packed.bits.f3 = p->intrval.intrno;
 535:         return(packed.ijunk);
 536:         }
 537:     }
 538: 
 539: return(0);
 540: }
 541: 
 542: 
 543: 
 544: 
 545: 
 546: struct addrblock *intraddr(np)
 547: struct nameblock *np;
 548: {
 549: struct addrblock *q;
 550: struct specblock *sp;
 551: 
 552: if(np->vclass!=CLPROC || np->vprocclass!=PINTRINSIC)
 553:     error("intraddr: %s is not intrinsic", varstr(VL,np->varname),0,FATAL1);
 554: packed.ijunk = np->vardesc.varno;
 555: 
 556: switch(packed.bits.f1)
 557:     {
 558:     case INTRGEN:
 559:         /* imag, log, and log10 arent specific functions */
 560:         if(packed.bits.f3==31 || packed.bits.f3==43 || packed.bits.f3==47)
 561:             goto bad;
 562: 
 563:     case INTRSPEC:
 564:         sp = spectab + packed.bits.f3;
 565:         if(tyint==TYLONG && sp->rtype==TYSHORT)
 566:             ++sp;
 567:         q = builtin(sp->rtype, varstr(XL,sp->spxname) );
 568:         return(q);
 569: 
 570:     case INTRCONV:
 571:     case INTRMIN:
 572:     case INTRMAX:
 573:     case INTRBOOL:
 574:     bad:
 575:         error("cannot pass %s as actual",
 576:             varstr(VL,np->varname),0,ERR1);
 577:         return( errnode() );
 578:     }
 579: error("intraddr: impossible f1=%d\n", packed.bits.f1,0,FATAL1);
 580: /* NOTREACHED */
 581: }
 582: 
 583: 
 584: 
 585: 
 586: 
 587: struct exprblock *inline(fno, type, args)
 588: int fno;
 589: int type;
 590: chainp args;
 591: {
 592: register struct exprblock *q, *t, *t1;
 593: 
 594: switch(fno)
 595:     {
 596:     case 8: /* real abs */
 597:     case 9: /* short int abs */
 598:     case 10:    /* long int abs */
 599:     case 11:    /* double precision abs */
 600:         if( addressable(q = args->datap) )
 601:             {
 602:             t = q;
 603:             q = NULL;
 604:             }
 605:         else
 606:             t = mktemp(type);
 607:         t1 = mkexpr(OPQUEST,  mkexpr(OPLE, mkconv(type,ICON(0)), cpexpr(t)),
 608:             mkexpr(OPCOLON, cpexpr(t),
 609:                 mkexpr(OPNEG, cpexpr(t), NULL) ));
 610:         if(q)
 611:             t1 = mkexpr(OPCOMMA, mkexpr(OPASSIGN, cpexpr(t),q), t1);
 612:         frexpr(t);
 613:         return(t1);
 614: 
 615:     case 26:    /* dprod */
 616:         q = mkexpr(OPSTAR, args->datap, args->nextp->datap);
 617:         q->vtype = TYDREAL;
 618:         return(q);
 619: 
 620:     case 27:    /* len of character string */
 621:         q = cpexpr(args->datap->vleng);
 622:         frexpr(args->datap);
 623:         return(q);
 624: 
 625:     case 14:    /* half-integer mod */
 626:     case 15:    /* mod */
 627:         return( mkexpr(OPMOD, args->datap, args->nextp->datap) );
 628:     }
 629: return(NULL);
 630: }

Defined functions

Defined variables

Defined struct's

Defined macros