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) 08/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 } 689