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