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

Defined functions

Defined variables

Defined struct's

Defined macros