00001 /****************************************************************
00002 Copyright 1990, 1992, 1994-6 by AT&T, Lucent Technologies and Bellcore.
00003 
00004 Permission to use, copy, modify, and distribute this software
00005 and its documentation for any purpose and without fee is hereby
00006 granted, provided that the above copyright notice appear in all
00007 copies and that both that the copyright notice and this
00008 permission notice and warranty disclaimer appear in supporting
00009 documentation, and that the names of AT&T, Bell Laboratories,
00010 Lucent or Bellcore or any of their entities not be used in
00011 advertising or publicity pertaining to distribution of the
00012 software without specific, written prior permission.
00013 
00014 AT&T, Lucent and Bellcore disclaim all warranties with regard to
00015 this software, including all implied warranties of
00016 merchantability and fitness.  In no event shall AT&T, Lucent or
00017 Bellcore be liable for any special, indirect or consequential
00018 damages or any damages whatsoever resulting from loss of use,
00019 data or profits, whether in an action of contract, negligence or
00020 other tortious action, arising out of or in connection with the
00021 use or performance of this software.
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 /* :3 */;
00036         char intrstuff /* result type or number of generics */;
00037         char intrno /* :7 */;
00038         char dblcmplx;
00039         char dblintrno; /* for -r8 */
00040         char extflag;   /* for -cd, -i90 */
00041         };
00042 
00043 /* List of all intrinsic functions.  */
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                 /* 1 ==> real(TYDCOMPLEX) yields TYDREAL */
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 /* any MAX or MIN can be used with any types; the compiler will cast them
00068    correctly.  So rules against bad syntax in these expressions are not
00069    enforced */
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;             /* Argument type; every arg must have
00231                                    this type */
00232         char rtype;             /* Result type */
00233         char nargs;             /* Number of arguments */
00234         char spxname[8];        /* Name of the function in Fortran */
00235         char othername;         /* index into callbyvalue table */
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)     /* adjust tables for -r8 */
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:       /* d_prod */
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 /* Machine-dependent f77 stuff that f2c omits:
00667 
00668 intcon contains
00669         radix for short int
00670         radix for long int
00671         radix for single precision
00672         radix for double precision
00673         precision for short int
00674         precision for long int
00675         precision for single precision
00676         precision for double precision
00677         emin for single precision
00678         emin for double precision
00679         emax for single precision
00680         emax for double prcision
00681         largest short int
00682         largest long int
00683 
00684 realcon contains
00685         tiny for single precision
00686         tiny for double precision
00687         huge for single precision
00688         huge for double precision
00689         mrsp (epsilon) for single precision
00690         mrsp (epsilon) for double precision
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 /* Made this a warning rather than an error so things like "log (5) ==>
00736    log (5.0)" can be accommodated.  When none of these cases matches, the
00737    argument is cast up to the first type in the spectab list; this first
00738    type is assumed to be the "smallest" type, e.g. REAL before DREAL
00739    before COMPLEX, before DCOMPLEX */
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 /* NOTE!!  I moved fixargs (YES) into the ELSE branch so that constants in
00758    the inline expression wouldn't get put into the constant table */
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                         /* C library routines that return double... */
00771                         /* sp->rtype might be TYREAL */
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                     } /* else */
00782                 } /* else */
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                 /* imag, log, and log10 arent specific functions */
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         /* NOT REACHED */ 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             } /* else */
00924     } /* for */
00925 } /* cast_args */
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: /* real abs */
00944         case 9: /* short int abs */
00945         case 10:        /* long int abs */
00946         case 11:        /* double precision abs */
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:        /* dprod */
00962                 q = mkexpr(OPSTAR, mkconv(TYDREAL,(expptr)args->datap),
00963                         (expptr)args->nextp->datap);
00964                 return(q);
00965 
00966         case 27:        /* len of character string */
00967                 q = (expptr) cpexpr(((tagptr)args->datap)->headblock.vleng);
00968                 frexpr((expptr)args->datap);
00969                 return mkconv(tyioint, q);
00970 
00971         case 14:        /* half-integer mod */
00972         case 15:        /* mod */
00973                 return mkexpr(OPMOD, (expptr) args->datap,
00974                                 (expptr) args->nextp->datap);
00975         }
00976         return(NULL);
00977 }