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