UNIX 7th Ed. - /usr/src/cmd/f77/intr.c

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

Defined functions

Defined variables

Defined struct's