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