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: }
|
Last modified: 1985-08-29
Generated: 2016-12-26 |
Generated by src2html V0.67
page hit count: 2198 |
|