00001
00002
00003
00004
00005
00006
00007
00008
00009
00010
00011
00012
00013
00014
00015
00016
00017
00018
00019
00020
00021
00022
00023
00024 #include "defs.h"
00025 #include "names.h"
00026
00027 union
00028 {
00029 int ijunk;
00030 struct Intrpacked bits;
00031 } packed;
00032
00033 struct Intrbits
00034 {
00035 char intrgroup ;
00036 char intrstuff ;
00037 char intrno ;
00038 char dblcmplx;
00039 char dblintrno;
00040 char extflag;
00041 };
00042
00043
00044
00045 LOCAL struct Intrblock
00046 {
00047 char intrfname[8];
00048 struct Intrbits intrval;
00049 } intrtab[ ] =
00050 {
00051 "int", { INTRCONV, TYLONG },
00052 "real", { INTRCONV, TYREAL, 1 },
00053
00054 "dble", { INTRCONV, TYDREAL },
00055 "cmplx", { INTRCONV, TYCOMPLEX },
00056 "dcmplx", { INTRCONV, TYDCOMPLEX, 0, 1 },
00057 "ifix", { INTRCONV, TYLONG },
00058 "idint", { INTRCONV, TYLONG },
00059 "float", { INTRCONV, TYREAL },
00060 "dfloat", { INTRCONV, TYDREAL },
00061 "sngl", { INTRCONV, TYREAL },
00062 "ichar", { INTRCONV, TYLONG },
00063 "iachar", { INTRCONV, TYLONG },
00064 "char", { INTRCONV, TYCHAR },
00065 "achar", { INTRCONV, TYCHAR },
00066
00067
00068
00069
00070
00071 "max", { INTRMAX, TYUNKNOWN },
00072 "max0", { INTRMAX, TYLONG },
00073 "amax0", { INTRMAX, TYREAL },
00074 "max1", { INTRMAX, TYLONG },
00075 "amax1", { INTRMAX, TYREAL },
00076 "dmax1", { INTRMAX, TYDREAL },
00077
00078 "and", { INTRBOOL, TYUNKNOWN, OPBITAND },
00079 "or", { INTRBOOL, TYUNKNOWN, OPBITOR },
00080 "xor", { INTRBOOL, TYUNKNOWN, OPBITXOR },
00081 "not", { INTRBOOL, TYUNKNOWN, OPBITNOT },
00082 "lshift", { INTRBOOL, TYUNKNOWN, OPLSHIFT },
00083 "rshift", { INTRBOOL, TYUNKNOWN, OPRSHIFT },
00084
00085 "min", { INTRMIN, TYUNKNOWN },
00086 "min0", { INTRMIN, TYLONG },
00087 "amin0", { INTRMIN, TYREAL },
00088 "min1", { INTRMIN, TYLONG },
00089 "amin1", { INTRMIN, TYREAL },
00090 "dmin1", { INTRMIN, TYDREAL },
00091
00092 "aint", { INTRGEN, 2, 0 },
00093 "dint", { INTRSPEC, TYDREAL, 1 },
00094
00095 "anint", { INTRGEN, 2, 2 },
00096 "dnint", { INTRSPEC, TYDREAL, 3 },
00097
00098 "nint", { INTRGEN, 4, 4 },
00099 "idnint", { INTRGEN, 2, 6 },
00100
00101 "abs", { INTRGEN, 6, 8 },
00102 "iabs", { INTRGEN, 2, 9 },
00103 "dabs", { INTRSPEC, TYDREAL, 11 },
00104 "cabs", { INTRSPEC, TYREAL, 12, 0, 13 },
00105 "zabs", { INTRSPEC, TYDREAL, 13, 1 },
00106
00107 "mod", { INTRGEN, 4, 14 },
00108 "amod", { INTRSPEC, TYREAL, 16, 0, 17 },
00109 "dmod", { INTRSPEC, TYDREAL, 17 },
00110
00111 "sign", { INTRGEN, 4, 18 },
00112 "isign", { INTRGEN, 2, 19 },
00113 "dsign", { INTRSPEC, TYDREAL, 21 },
00114
00115 "dim", { INTRGEN, 4, 22 },
00116 "idim", { INTRGEN, 2, 23 },
00117 "ddim", { INTRSPEC, TYDREAL, 25 },
00118
00119 "dprod", { INTRSPEC, TYDREAL, 26 },
00120
00121 "len", { INTRSPEC, TYLONG, 27 },
00122 "index", { INTRSPEC, TYLONG, 29 },
00123
00124 "imag", { INTRGEN, 2, 31 },
00125 "aimag", { INTRSPEC, TYREAL, 31, 0, 32 },
00126 "dimag", { INTRSPEC, TYDREAL, 32 },
00127
00128 "conjg", { INTRGEN, 2, 33 },
00129 "dconjg", { INTRSPEC, TYDCOMPLEX, 34, 1 },
00130
00131 "sqrt", { INTRGEN, 4, 35 },
00132 "dsqrt", { INTRSPEC, TYDREAL, 36 },
00133 "csqrt", { INTRSPEC, TYCOMPLEX, 37, 0, 38 },
00134 "zsqrt", { INTRSPEC, TYDCOMPLEX, 38, 1 },
00135
00136 "exp", { INTRGEN, 4, 39 },
00137 "dexp", { INTRSPEC, TYDREAL, 40 },
00138 "cexp", { INTRSPEC, TYCOMPLEX, 41, 0, 42 },
00139 "zexp", { INTRSPEC, TYDCOMPLEX, 42, 1 },
00140
00141 "log", { INTRGEN, 4, 43 },
00142 "alog", { INTRSPEC, TYREAL, 43, 0, 44 },
00143 "dlog", { INTRSPEC, TYDREAL, 44 },
00144 "clog", { INTRSPEC, TYCOMPLEX, 45, 0, 46 },
00145 "zlog", { INTRSPEC, TYDCOMPLEX, 46, 1 },
00146
00147 "log10", { INTRGEN, 2, 47 },
00148 "alog10", { INTRSPEC, TYREAL, 47, 0, 48 },
00149 "dlog10", { INTRSPEC, TYDREAL, 48 },
00150
00151 "sin", { INTRGEN, 4, 49 },
00152 "dsin", { INTRSPEC, TYDREAL, 50 },
00153 "csin", { INTRSPEC, TYCOMPLEX, 51, 0, 52 },
00154 "zsin", { INTRSPEC, TYDCOMPLEX, 52, 1 },
00155
00156 "cos", { INTRGEN, 4, 53 },
00157 "dcos", { INTRSPEC, TYDREAL, 54 },
00158 "ccos", { INTRSPEC, TYCOMPLEX, 55, 0, 56 },
00159 "zcos", { INTRSPEC, TYDCOMPLEX, 56, 1 },
00160
00161 "tan", { INTRGEN, 2, 57 },
00162 "dtan", { INTRSPEC, TYDREAL, 58 },
00163
00164 "asin", { INTRGEN, 2, 59 },
00165 "dasin", { INTRSPEC, TYDREAL, 60 },
00166
00167 "acos", { INTRGEN, 2, 61 },
00168 "dacos", { INTRSPEC, TYDREAL, 62 },
00169
00170 "atan", { INTRGEN, 2, 63 },
00171 "datan", { INTRSPEC, TYDREAL, 64 },
00172
00173 "atan2", { INTRGEN, 2, 65 },
00174 "datan2", { INTRSPEC, TYDREAL, 66 },
00175
00176 "sinh", { INTRGEN, 2, 67 },
00177 "dsinh", { INTRSPEC, TYDREAL, 68 },
00178
00179 "cosh", { INTRGEN, 2, 69 },
00180 "dcosh", { INTRSPEC, TYDREAL, 70 },
00181
00182 "tanh", { INTRGEN, 2, 71 },
00183 "dtanh", { INTRSPEC, TYDREAL, 72 },
00184
00185 "lge", { INTRSPEC, TYLOGICAL, 73},
00186 "lgt", { INTRSPEC, TYLOGICAL, 75},
00187 "lle", { INTRSPEC, TYLOGICAL, 77},
00188 "llt", { INTRSPEC, TYLOGICAL, 79},
00189
00190 #if 0
00191 "epbase", { INTRCNST, 4, 0 },
00192 "epprec", { INTRCNST, 4, 4 },
00193 "epemin", { INTRCNST, 2, 8 },
00194 "epemax", { INTRCNST, 2, 10 },
00195 "eptiny", { INTRCNST, 2, 12 },
00196 "ephuge", { INTRCNST, 4, 14 },
00197 "epmrsp", { INTRCNST, 2, 18 },
00198 #endif
00199
00200 "fpexpn", { INTRGEN, 4, 81 },
00201 "fpabsp", { INTRGEN, 2, 85 },
00202 "fprrsp", { INTRGEN, 2, 87 },
00203 "fpfrac", { INTRGEN, 2, 89 },
00204 "fpmake", { INTRGEN, 2, 91 },
00205 "fpscal", { INTRGEN, 2, 93 },
00206
00207 "cdabs", { INTRSPEC, TYDREAL, 13, 1, 0, 1 },
00208 "cdsqrt", { INTRSPEC, TYDCOMPLEX, 38, 1, 0, 1 },
00209 "cdexp", { INTRSPEC, TYDCOMPLEX, 42, 1, 0, 1 },
00210 "cdlog", { INTRSPEC, TYDCOMPLEX, 46, 1, 0, 1 },
00211 "cdsin", { INTRSPEC, TYDCOMPLEX, 52, 1, 0, 1 },
00212 "cdcos", { INTRSPEC, TYDCOMPLEX, 56, 1, 0, 1 },
00213
00214 "iand", { INTRBOOL, TYUNKNOWN, OPBITAND, 0, 0, 2 },
00215 "ior", { INTRBOOL, TYUNKNOWN, OPBITOR, 0, 0, 2 },
00216 "ieor", { INTRBOOL, TYUNKNOWN, OPBITXOR, 0, 0, 2 },
00217
00218 "btest", { INTRBGEN, TYLOGICAL, OPBITTEST,0, 0, 2 },
00219 "ibclr", { INTRBGEN, TYUNKNOWN, OPBITCLR, 0, 0, 2 },
00220 "ibset", { INTRBGEN, TYUNKNOWN, OPBITSET, 0, 0, 2 },
00221 "ibits", { INTRBGEN, TYUNKNOWN, OPBITBITS,0, 0, 2 },
00222 "ishft", { INTRBGEN, TYUNKNOWN, OPBITSH, 0, 0, 2 },
00223 "ishftc", { INTRBGEN, TYUNKNOWN, OPBITSHC, 0, 0, 2 },
00224
00225 "" };
00226
00227
00228 LOCAL struct Specblock
00229 {
00230 char atype;
00231
00232 char rtype;
00233 char nargs;
00234 char spxname[8];
00235 char othername;
00236 } spectab[ ] =
00237 {
00238 { TYREAL,TYREAL,1,"r_int" },
00239 { TYDREAL,TYDREAL,1,"d_int" },
00240
00241 { TYREAL,TYREAL,1,"r_nint" },
00242 { TYDREAL,TYDREAL,1,"d_nint" },
00243
00244 { TYREAL,TYSHORT,1,"h_nint" },
00245 { TYREAL,TYLONG,1,"i_nint" },
00246
00247 { TYDREAL,TYSHORT,1,"h_dnnt" },
00248 { TYDREAL,TYLONG,1,"i_dnnt" },
00249
00250 { TYREAL,TYREAL,1,"r_abs" },
00251 { TYSHORT,TYSHORT,1,"h_abs" },
00252 { TYLONG,TYLONG,1,"i_abs" },
00253 { TYDREAL,TYDREAL,1,"d_abs" },
00254 { TYCOMPLEX,TYREAL,1,"c_abs" },
00255 { TYDCOMPLEX,TYDREAL,1,"z_abs" },
00256
00257 { TYSHORT,TYSHORT,2,"h_mod" },
00258 { TYLONG,TYLONG,2,"i_mod" },
00259 { TYREAL,TYREAL,2,"r_mod" },
00260 { TYDREAL,TYDREAL,2,"d_mod" },
00261
00262 { TYREAL,TYREAL,2,"r_sign" },
00263 { TYSHORT,TYSHORT,2,"h_sign" },
00264 { TYLONG,TYLONG,2,"i_sign" },
00265 { TYDREAL,TYDREAL,2,"d_sign" },
00266
00267 { TYREAL,TYREAL,2,"r_dim" },
00268 { TYSHORT,TYSHORT,2,"h_dim" },
00269 { TYLONG,TYLONG,2,"i_dim" },
00270 { TYDREAL,TYDREAL,2,"d_dim" },
00271
00272 { TYREAL,TYDREAL,2,"d_prod" },
00273
00274 { TYCHAR,TYSHORT,1,"h_len" },
00275 { TYCHAR,TYLONG,1,"i_len" },
00276
00277 { TYCHAR,TYSHORT,2,"h_indx" },
00278 { TYCHAR,TYLONG,2,"i_indx" },
00279
00280 { TYCOMPLEX,TYREAL,1,"r_imag" },
00281 { TYDCOMPLEX,TYDREAL,1,"d_imag" },
00282 { TYCOMPLEX,TYCOMPLEX,1,"r_cnjg" },
00283 { TYDCOMPLEX,TYDCOMPLEX,1,"d_cnjg" },
00284
00285 { TYREAL,TYREAL,1,"r_sqrt", 1 },
00286 { TYDREAL,TYDREAL,1,"d_sqrt", 1 },
00287 { TYCOMPLEX,TYCOMPLEX,1,"c_sqrt" },
00288 { TYDCOMPLEX,TYDCOMPLEX,1,"z_sqrt" },
00289
00290 { TYREAL,TYREAL,1,"r_exp", 2 },
00291 { TYDREAL,TYDREAL,1,"d_exp", 2 },
00292 { TYCOMPLEX,TYCOMPLEX,1,"c_exp" },
00293 { TYDCOMPLEX,TYDCOMPLEX,1,"z_exp" },
00294
00295 { TYREAL,TYREAL,1,"r_log", 3 },
00296 { TYDREAL,TYDREAL,1,"d_log", 3 },
00297 { TYCOMPLEX,TYCOMPLEX,1,"c_log" },
00298 { TYDCOMPLEX,TYDCOMPLEX,1,"z_log" },
00299
00300 { TYREAL,TYREAL,1,"r_lg10" },
00301 { TYDREAL,TYDREAL,1,"d_lg10" },
00302
00303 { TYREAL,TYREAL,1,"r_sin", 4 },
00304 { TYDREAL,TYDREAL,1,"d_sin", 4 },
00305 { TYCOMPLEX,TYCOMPLEX,1,"c_sin" },
00306 { TYDCOMPLEX,TYDCOMPLEX,1,"z_sin" },
00307
00308 { TYREAL,TYREAL,1,"r_cos", 5 },
00309 { TYDREAL,TYDREAL,1,"d_cos", 5 },
00310 { TYCOMPLEX,TYCOMPLEX,1,"c_cos" },
00311 { TYDCOMPLEX,TYDCOMPLEX,1,"z_cos" },
00312
00313 { TYREAL,TYREAL,1,"r_tan", 6 },
00314 { TYDREAL,TYDREAL,1,"d_tan", 6 },
00315
00316 { TYREAL,TYREAL,1,"r_asin", 7 },
00317 { TYDREAL,TYDREAL,1,"d_asin", 7 },
00318
00319 { TYREAL,TYREAL,1,"r_acos", 8 },
00320 { TYDREAL,TYDREAL,1,"d_acos", 8 },
00321
00322 { TYREAL,TYREAL,1,"r_atan", 9 },
00323 { TYDREAL,TYDREAL,1,"d_atan", 9 },
00324
00325 { TYREAL,TYREAL,2,"r_atn2", 10 },
00326 { TYDREAL,TYDREAL,2,"d_atn2", 10 },
00327
00328 { TYREAL,TYREAL,1,"r_sinh", 11 },
00329 { TYDREAL,TYDREAL,1,"d_sinh", 11 },
00330
00331 { TYREAL,TYREAL,1,"r_cosh", 12 },
00332 { TYDREAL,TYDREAL,1,"d_cosh", 12 },
00333
00334 { TYREAL,TYREAL,1,"r_tanh", 13 },
00335 { TYDREAL,TYDREAL,1,"d_tanh", 13 },
00336
00337 { TYCHAR,TYLOGICAL,2,"hl_ge" },
00338 { TYCHAR,TYLOGICAL,2,"l_ge" },
00339
00340 { TYCHAR,TYLOGICAL,2,"hl_gt" },
00341 { TYCHAR,TYLOGICAL,2,"l_gt" },
00342
00343 { TYCHAR,TYLOGICAL,2,"hl_le" },
00344 { TYCHAR,TYLOGICAL,2,"l_le" },
00345
00346 { TYCHAR,TYLOGICAL,2,"hl_lt" },
00347 { TYCHAR,TYLOGICAL,2,"l_lt" },
00348
00349 { TYREAL,TYSHORT,1,"hr_expn" },
00350 { TYREAL,TYLONG,1,"ir_expn" },
00351 { TYDREAL,TYSHORT,1,"hd_expn" },
00352 { TYDREAL,TYLONG,1,"id_expn" },
00353
00354 { TYREAL,TYREAL,1,"r_absp" },
00355 { TYDREAL,TYDREAL,1,"d_absp" },
00356
00357 { TYREAL,TYDREAL,1,"r_rrsp" },
00358 { TYDREAL,TYDREAL,1,"d_rrsp" },
00359
00360 { TYREAL,TYREAL,1,"r_frac" },
00361 { TYDREAL,TYDREAL,1,"d_frac" },
00362
00363 { TYREAL,TYREAL,2,"r_make" },
00364 { TYDREAL,TYDREAL,2,"d_make" },
00365
00366 { TYREAL,TYREAL,2,"r_scal" },
00367 { TYDREAL,TYDREAL,2,"d_scal" },
00368
00369 { 0 }
00370 } ;
00371
00372 #if 0
00373 LOCAL struct Incstblock
00374 {
00375 char atype;
00376 char rtype;
00377 char constno;
00378 } consttab[ ] =
00379 {
00380 { TYSHORT, TYLONG, 0 },
00381 { TYLONG, TYLONG, 1 },
00382 { TYREAL, TYLONG, 2 },
00383 { TYDREAL, TYLONG, 3 },
00384
00385 { TYSHORT, TYLONG, 4 },
00386 { TYLONG, TYLONG, 5 },
00387 { TYREAL, TYLONG, 6 },
00388 { TYDREAL, TYLONG, 7 },
00389
00390 { TYREAL, TYLONG, 8 },
00391 { TYDREAL, TYLONG, 9 },
00392
00393 { TYREAL, TYLONG, 10 },
00394 { TYDREAL, TYLONG, 11 },
00395
00396 { TYREAL, TYREAL, 0 },
00397 { TYDREAL, TYDREAL, 1 },
00398
00399 { TYSHORT, TYLONG, 12 },
00400 { TYLONG, TYLONG, 13 },
00401 { TYREAL, TYREAL, 2 },
00402 { TYDREAL, TYDREAL, 3 },
00403
00404 { TYREAL, TYREAL, 4 },
00405 { TYDREAL, TYDREAL, 5 }
00406 };
00407 #endif
00408
00409 char *callbyvalue[ ] =
00410 {0,
00411 "sqrt",
00412 "exp",
00413 "log",
00414 "sin",
00415 "cos",
00416 "tan",
00417 "asin",
00418 "acos",
00419 "atan",
00420 "atan2",
00421 "sinh",
00422 "cosh",
00423 "tanh"
00424 };
00425
00426 void
00427 r8fix(Void)
00428 {
00429 register struct Intrblock *I;
00430 register struct Specblock *S;
00431
00432 for(I = intrtab; I->intrfname[0]; I++)
00433 if (I->intrval.intrgroup != INTRGEN)
00434 switch(I->intrval.intrstuff) {
00435 case TYREAL:
00436 I->intrval.intrstuff = TYDREAL;
00437 I->intrval.intrno = I->intrval.dblintrno;
00438 break;
00439 case TYCOMPLEX:
00440 I->intrval.intrstuff = TYDCOMPLEX;
00441 I->intrval.intrno = I->intrval.dblintrno;
00442 I->intrval.dblcmplx = 1;
00443 }
00444
00445 for(S = spectab; S->atype; S++)
00446 switch(S->atype) {
00447 case TYCOMPLEX:
00448 S->atype = TYDCOMPLEX;
00449 if (S->rtype == TYREAL)
00450 S->rtype = TYDREAL;
00451 else if (S->rtype == TYCOMPLEX)
00452 S->rtype = TYDCOMPLEX;
00453 switch(S->spxname[0]) {
00454 case 'r':
00455 S->spxname[0] = 'd';
00456 break;
00457 case 'c':
00458 S->spxname[0] = 'z';
00459 break;
00460 default:
00461 Fatal("r8fix bug");
00462 }
00463 break;
00464 case TYREAL:
00465 S->atype = TYDREAL;
00466 switch(S->rtype) {
00467 case TYREAL:
00468 S->rtype = TYDREAL;
00469 if (S->spxname[0] != 'r')
00470 Fatal("r8fix bug");
00471 S->spxname[0] = 'd';
00472 case TYDREAL:
00473 break;
00474
00475 case TYSHORT:
00476 if (!strcmp(S->spxname, "hr_expn"))
00477 S->spxname[1] = 'd';
00478 else if (!strcmp(S->spxname, "h_nint"))
00479 strcpy(S->spxname, "h_dnnt");
00480 else Fatal("r8fix bug");
00481 break;
00482
00483 case TYLONG:
00484 if (!strcmp(S->spxname, "ir_expn"))
00485 S->spxname[1] = 'd';
00486 else if (!strcmp(S->spxname, "i_nint"))
00487 strcpy(S->spxname, "i_dnnt");
00488 else Fatal("r8fix bug");
00489 break;
00490
00491 default:
00492 Fatal("r8fix bug");
00493 }
00494 }
00495 }
00496
00497
00498 expptr
00499 #ifdef KR_headers
00500 intrcall(np, argsp, nargs)
00501 Namep np;
00502 struct Listblock *argsp;
00503 int nargs;
00504 #else
00505 intrcall(Namep np, struct Listblock *argsp, int nargs)
00506 #endif
00507 {
00508 int i, rettype;
00509 Addrp ap;
00510 register struct Specblock *sp;
00511 register struct Chain *cp;
00512 expptr q, ep;
00513 int mtype;
00514 int op;
00515 int f1field, f2field, f3field;
00516 char *s;
00517 static char bit_bits[] = "?bit_bits",
00518 bit_shift[] = "?bit_shift",
00519 bit_cshift[] = "?bit_cshift";
00520 static char *bitop[3] = { bit_bits, bit_shift, bit_cshift };
00521 static int t_pref[2] = { 'l', 'q' };
00522
00523 packed.ijunk = np->vardesc.varno;
00524 f1field = packed.bits.f1;
00525 f2field = packed.bits.f2;
00526 f3field = packed.bits.f3;
00527 if(nargs == 0)
00528 goto badnargs;
00529
00530 mtype = 0;
00531 for(cp = argsp->listp ; cp ; cp = cp->nextp)
00532 {
00533 ep = (expptr)cp->datap;
00534 if( ISCONST(ep) && ep->headblock.vtype==TYSHORT )
00535 cp->datap = (char *) mkconv(tyint, ep);
00536 mtype = maxtype(mtype, ep->headblock.vtype);
00537 }
00538
00539 switch(f1field)
00540 {
00541 case INTRBGEN:
00542 op = f3field;
00543 if( ! ONEOF(mtype, MSKINT) )
00544 goto badtype;
00545 if (op < OPBITBITS) {
00546 if(nargs != 2)
00547 goto badnargs;
00548 if (op != OPBITTEST) {
00549 #ifdef TYQUAD
00550 if (mtype == TYQUAD)
00551 op += 2;
00552 #endif
00553 goto intrbool2;
00554 }
00555 q = mkexpr(op, (expptr)argsp->listp->datap,
00556 (expptr)argsp->listp->nextp->datap);
00557 q->exprblock.vtype = TYLOGICAL;
00558 goto intrbool2a;
00559 }
00560 if (nargs != 2 && (nargs != 3 || op == OPBITSH))
00561 goto badnargs;
00562 cp = argsp->listp;
00563 ep = (expptr)cp->datap;
00564 if (ep->headblock.vtype < TYLONG)
00565 cp->datap = (char *)mkconv(TYLONG, ep);
00566 while(cp->nextp) {
00567 cp = cp->nextp;
00568 ep = (expptr)cp->datap;
00569 if (ep->headblock.vtype != TYLONG)
00570 cp->datap = (char *)mkconv(TYLONG, ep);
00571 }
00572 if (op == OPBITSH) {
00573 ep = (expptr)argsp->listp->nextp->datap;
00574 if (ISCONST(ep)) {
00575 if ((i = ep->constblock.Const.ci) < 0) {
00576 q = (expptr)argsp->listp->datap;
00577 if (ISCONST(q)) {
00578 ep->constblock.Const.ci = -i;
00579 op = OPRSHIFT;
00580 goto intrbool2;
00581 }
00582 }
00583 else {
00584 op = OPLSHIFT;
00585 goto intrbool2;
00586 }
00587 }
00588 }
00589 else if (nargs == 2) {
00590 if (op == OPBITBITS)
00591 goto badnargs;
00592 cp->nextp = mkchain((char*)ICON(-1), 0);
00593 }
00594 ep = (expptr)argsp->listp->datap;
00595 i = ep->headblock.vtype;
00596 s = bitop[op - OPBITBITS];
00597 *s = t_pref[i - TYLONG];
00598 ap = builtin(i, s, 1);
00599 return fixexpr((Exprp)
00600 mkexpr(OPCCALL, (expptr)ap, (expptr)argsp) );
00601
00602 case INTRBOOL:
00603 op = f3field;
00604 if( ! ONEOF(mtype, MSKINT|MSKLOGICAL) )
00605 goto badtype;
00606 if(op == OPBITNOT)
00607 {
00608 if(nargs != 1)
00609 goto badnargs;
00610 q = mkexpr(OPBITNOT, (expptr)argsp->listp->datap, ENULL);
00611 }
00612 else
00613 {
00614 if(nargs != 2)
00615 goto badnargs;
00616 intrbool2:
00617 q = mkexpr(op, (expptr)argsp->listp->datap,
00618 (expptr)argsp->listp->nextp->datap);
00619 }
00620 intrbool2a:
00621 frchain( &(argsp->listp) );
00622 free( (charptr) argsp);
00623 return(q);
00624
00625 case INTRCONV:
00626 rettype = f2field;
00627 switch(rettype) {
00628 case TYLONG:
00629 rettype = tyint;
00630 break;
00631 case TYLOGICAL:
00632 rettype = tylog;
00633 }
00634 if( ISCOMPLEX(rettype) && nargs==2)
00635 {
00636 expptr qr, qi;
00637 qr = (expptr) argsp->listp->datap;
00638 qi = (expptr) argsp->listp->nextp->datap;
00639 if (qr->headblock.vtype == TYDREAL
00640 || qi->headblock.vtype == TYDREAL)
00641 rettype = TYDCOMPLEX;
00642 if(ISCONST(qr) && ISCONST(qi))
00643 q = mkcxcon(qr,qi);
00644 else q = mkexpr(OPCONV,mkconv(rettype-2,qr),
00645 mkconv(rettype-2,qi));
00646 }
00647 else if(nargs == 1) {
00648 if (f3field && ((Exprp)argsp->listp->datap)->vtype
00649 == TYDCOMPLEX)
00650 rettype = TYDREAL;
00651 q = mkconv(rettype+100, (expptr)argsp->listp->datap);
00652 if (q->tag == TADDR)
00653 q->addrblock.parenused = 1;
00654 }
00655 else goto badnargs;
00656
00657 q->headblock.vtype = rettype;
00658 frchain(&(argsp->listp));
00659 free( (charptr) argsp);
00660 return(q);
00661
00662
00663 #if 0
00664 case INTRCNST:
00665
00666
00667
00668
00669
00670
00671
00672
00673
00674
00675
00676
00677
00678
00679
00680
00681
00682
00683
00684
00685
00686
00687
00688
00689
00690
00691
00692 { register struct Incstblock *cstp;
00693 extern ftnint intcon[14];
00694 extern double realcon[6];
00695
00696 cstp = consttab + f3field;
00697 for(i=0 ; i<f2field ; ++i)
00698 if(cstp->atype == mtype)
00699 goto foundconst;
00700 else
00701 ++cstp;
00702 goto badtype;
00703
00704 foundconst:
00705 switch(cstp->rtype)
00706 {
00707 case TYLONG:
00708 return(mkintcon(intcon[cstp->constno]));
00709
00710 case TYREAL:
00711 case TYDREAL:
00712 return(mkrealcon(cstp->rtype,
00713 realcon[cstp->constno]) );
00714
00715 default:
00716 Fatal("impossible intrinsic constant");
00717 }
00718 }
00719 #endif
00720
00721 case INTRGEN:
00722 sp = spectab + f3field;
00723 if(no66flag)
00724 if(sp->atype == mtype)
00725 goto specfunct;
00726 else err66("generic function");
00727
00728 for(i=0; i<f2field ; ++i)
00729 if(sp->atype == mtype)
00730 goto specfunct;
00731 else
00732 ++sp;
00733 warn1 ("bad argument type to intrinsic %s", np->fvarname);
00734
00735
00736
00737
00738
00739
00740
00741 sp = spectab + f3field;
00742 mtype = sp -> atype;
00743 goto specfunct;
00744
00745 case INTRSPEC:
00746 sp = spectab + f3field;
00747 specfunct:
00748 if(tyint==TYLONG && ONEOF(sp->rtype,M(TYSHORT)|M(TYLOGICAL))
00749 && (sp+1)->atype==sp->atype)
00750 ++sp;
00751
00752 if(nargs != sp->nargs)
00753 goto badnargs;
00754 if(mtype != sp->atype)
00755 goto badtype;
00756
00757
00758
00759
00760 fixargs (NO, argsp);
00761 cast_args (mtype, argsp -> listp);
00762
00763 if(q = Inline((int)(sp-spectab), mtype, argsp->listp))
00764 {
00765 frchain( &(argsp->listp) );
00766 free( (charptr) argsp);
00767 } else {
00768
00769 if(sp->othername) {
00770
00771
00772 ap = builtin(sp->rtype,
00773 callbyvalue[sp->othername], 1);
00774 q = fixexpr((Exprp)
00775 mkexpr(OPCCALL, (expptr)ap, (expptr)argsp) );
00776 } else {
00777 fixargs(YES, argsp);
00778 ap = builtin(sp->rtype, sp->spxname, 0);
00779 q = fixexpr((Exprp)
00780 mkexpr(OPCALL, (expptr)ap, (expptr)argsp) );
00781 }
00782 }
00783 return(q);
00784
00785 case INTRMIN:
00786 case INTRMAX:
00787 if(nargs < 2)
00788 goto badnargs;
00789 if( ! ONEOF(mtype, MSKINT|MSKREAL) )
00790 goto badtype;
00791 argsp->vtype = mtype;
00792 q = mkexpr( (f1field==INTRMIN ? OPMIN : OPMAX), (expptr)argsp, ENULL);
00793
00794 q->headblock.vtype = mtype;
00795 rettype = f2field;
00796 if(rettype == TYLONG)
00797 rettype = tyint;
00798 else if(rettype == TYUNKNOWN)
00799 rettype = mtype;
00800 return( mkconv(rettype, q) );
00801
00802 default:
00803 fatali("intrcall: bad intrgroup %d", f1field);
00804 }
00805 badnargs:
00806 errstr("bad number of arguments to intrinsic %s", np->fvarname);
00807 goto bad;
00808
00809 badtype:
00810 errstr("bad argument type to intrinsic %s", np->fvarname);
00811
00812 bad:
00813 return( errnode() );
00814 }
00815
00816
00817
00818 int
00819 #ifdef KR_headers
00820 intrfunct(s)
00821 char *s;
00822 #else
00823 intrfunct(char *s)
00824 #endif
00825 {
00826 register struct Intrblock *p;
00827 int i;
00828 extern int intr_omit;
00829
00830 for(p = intrtab; p->intrval.intrgroup!=INTREND ; ++p)
00831 {
00832 if( !strcmp(s, p->intrfname) )
00833 {
00834 if (i = p->intrval.extflag) {
00835 if (i & intr_omit)
00836 return 0;
00837 if (noextflag)
00838 errext(s);
00839 }
00840 packed.bits.f1 = p->intrval.intrgroup;
00841 packed.bits.f2 = p->intrval.intrstuff;
00842 packed.bits.f3 = p->intrval.intrno;
00843 packed.bits.f4 = p->intrval.dblcmplx;
00844 return(packed.ijunk);
00845 }
00846 }
00847
00848 return(0);
00849 }
00850
00851
00852
00853
00854
00855 Addrp
00856 #ifdef KR_headers
00857 intraddr(np)
00858 Namep np;
00859 #else
00860 intraddr(Namep np)
00861 #endif
00862 {
00863 Addrp q;
00864 register struct Specblock *sp;
00865 int f3field;
00866
00867 if(np->vclass!=CLPROC || np->vprocclass!=PINTRINSIC)
00868 fatalstr("intraddr: %s is not intrinsic", np->fvarname);
00869 packed.ijunk = np->vardesc.varno;
00870 f3field = packed.bits.f3;
00871
00872 switch(packed.bits.f1)
00873 {
00874 case INTRGEN:
00875
00876 if(f3field==31 || f3field==43 || f3field==47)
00877 goto bad;
00878
00879 case INTRSPEC:
00880 sp = spectab + f3field;
00881 if (tyint == TYLONG
00882 && (sp->rtype == TYSHORT || sp->rtype == TYLOGICAL))
00883 ++sp;
00884 q = builtin(sp->rtype, sp->spxname,
00885 sp->othername ? 1 : 0);
00886 return(q);
00887
00888 case INTRCONV:
00889 case INTRMIN:
00890 case INTRMAX:
00891 case INTRBOOL:
00892 case INTRCNST:
00893 case INTRBGEN:
00894 bad:
00895 errstr("cannot pass %s as actual", np->fvarname);
00896 return((Addrp)errnode());
00897 }
00898 fatali("intraddr: impossible f1=%d\n", (int) packed.bits.f1);
00899 return 0;
00900 }
00901
00902
00903
00904 void
00905 #ifdef KR_headers
00906 cast_args(maxtype, args)
00907 int maxtype;
00908 chainp args;
00909 #else
00910 cast_args(int maxtype, chainp args)
00911 #endif
00912 {
00913 for (; args; args = args -> nextp) {
00914 expptr e = (expptr) args->datap;
00915 if (e -> headblock.vtype != maxtype)
00916 if (e -> tag == TCONST)
00917 args->datap = (char *) mkconv(maxtype, e);
00918 else {
00919 Addrp temp = mktmp(maxtype, ENULL);
00920
00921 puteq(cpexpr((expptr)temp), e);
00922 args->datap = (char *)temp;
00923 }
00924 }
00925 }
00926
00927
00928
00929 expptr
00930 #ifdef KR_headers
00931 Inline(fno, type, args)
00932 int fno;
00933 int type;
00934 struct Chain *args;
00935 #else
00936 Inline(int fno, int type, struct Chain *args)
00937 #endif
00938 {
00939 register expptr q, t, t1;
00940
00941 switch(fno)
00942 {
00943 case 8:
00944 case 9:
00945 case 10:
00946 case 11:
00947 if( addressable(q = (expptr) args->datap) )
00948 {
00949 t = q;
00950 q = NULL;
00951 }
00952 else
00953 t = (expptr) mktmp(type,ENULL);
00954 t1 = mkexpr(type == TYREAL && forcedouble ? OPDABS : OPABS,
00955 cpexpr(t), ENULL);
00956 if(q)
00957 t1 = mkexpr(OPCOMMA, mkexpr(OPASSIGN, cpexpr(t),q), t1);
00958 frexpr(t);
00959 return(t1);
00960
00961 case 26:
00962 q = mkexpr(OPSTAR, mkconv(TYDREAL,(expptr)args->datap),
00963 (expptr)args->nextp->datap);
00964 return(q);
00965
00966 case 27:
00967 q = (expptr) cpexpr(((tagptr)args->datap)->headblock.vleng);
00968 frexpr((expptr)args->datap);
00969 return mkconv(tyioint, q);
00970
00971 case 14:
00972 case 15:
00973 return mkexpr(OPMOD, (expptr) args->datap,
00974 (expptr) args->nextp->datap);
00975 }
00976 return(NULL);
00977 }