lang/fortran/comp/intr.c

   1 /****************************************************************
   2 Copyright 1990 by AT&T Bell Laboratories and Bellcore.
   3
   4 Permission to use, copy, modify, and distribute this software
   5 and its documentation for any purpose and without fee is hereby
   6 granted, provided that the above copyright notice appear in all
   7 copies and that both that the copyright notice and this
   8 permission notice and warranty disclaimer appear in supporting
   9 documentation, and that the names of AT&T Bell Laboratories or
  10 Bellcore or any of their entities not be used in advertising or
  11 publicity pertaining to distribution of the software without
  12 specific, written prior permission.
  13
  14 AT&T and Bellcore disclaim all warranties with regard to this
  15 software, including all implied warranties of merchantability
  16 and fitness.  In no event shall AT&T or Bellcore be liable for
  17 any special, indirect or consequential damages or any damages
  18 whatsoever resulting from loss of use, data or profits, whether
  19 in an action of contract, negligence or other tortious action,
  20 arising out of or in connection with the use or performance of
  21 this software.
  22 ****************************************************************/
  23
  24 #include "defs.h"
  25 #include "names.h"
  26
  27 void cast_args ();
  28
  29 union
  30         {
  31         int ijunk;
  32         struct Intrpacked bits;
  33         } packed;
  34
  35 struct Intrbits
  36         {
  37         char intrgroup /* :3 */;
  38         char intrstuff /* result type or number of generics */;
  39         char intrno /* :7 */;
  40         char dblcmplx;
  41         char dblintrno; /* for -r8 */
  42         };
  43
  44 /* List of all intrinsic functions.  */
  45
  46 LOCAL struct Intrblock
  47         {
  48         char intrfname[8];
  49         struct Intrbits intrval;
  50         } intrtab[ ] =
  51 {
  52 "int",          { INTRCONV, TYLONG },
  53 "real",         { INTRCONV, TYREAL, 1 },
  54                 /* 1 ==> real(TYDCOMPLEX) yields TYDREAL */
  55 "dble",         { INTRCONV, TYDREAL },
  56 "cmplx",        { INTRCONV, TYCOMPLEX },
  57 "dcmplx",       { INTRCONV, TYDCOMPLEX, 0, 1 },
  58 "ifix",         { INTRCONV, TYLONG },
  59 "idint",        { INTRCONV, TYLONG },
  60 "float",        { INTRCONV, TYREAL },
  61 "dfloat",       { INTRCONV, TYDREAL },
  62 "sngl",         { INTRCONV, TYREAL },
  63 "ichar",        { INTRCONV, TYLONG },
  64 "iachar",       { INTRCONV, TYLONG },
  65 "char",         { INTRCONV, TYCHAR },
  66 "achar",        { INTRCONV, TYCHAR },
  67
  68 /* any MAX or MIN can be used with any types; the compiler will cast them
  69    correctly.  So rules against bad syntax in these expressions are not
  70    enforced */
  71
  72 "max",          { INTRMAX, TYUNKNOWN },
  73 "max0",         { INTRMAX, TYLONG },
  74 "amax0",        { INTRMAX, TYREAL },
  75 "max1",         { INTRMAX, TYLONG },
  76 "amax1",        { INTRMAX, TYREAL },
  77 "dmax1",        { INTRMAX, TYDREAL },
  78
  79 "and",          { INTRBOOL, TYUNKNOWN, OPBITAND },
  80 "or",           { INTRBOOL, TYUNKNOWN, OPBITOR },
  81 "xor",          { INTRBOOL, TYUNKNOWN, OPBITXOR },
  82 "not",          { INTRBOOL, TYUNKNOWN, OPBITNOT },
  83 "lshift",       { INTRBOOL, TYUNKNOWN, OPLSHIFT },
  84 "rshift",       { INTRBOOL, TYUNKNOWN, OPRSHIFT },
  85
  86 "min",          { INTRMIN, TYUNKNOWN },
  87 "min0",         { INTRMIN, TYLONG },
  88 "amin0",        { INTRMIN, TYREAL },
  89 "min1",         { INTRMIN, TYLONG },
  90 "amin1",        { INTRMIN, TYREAL },
  91 "dmin1",        { INTRMIN, TYDREAL },
  92
  93 "aint",         { INTRGEN, 2, 0 },
  94 "dint",         { INTRSPEC, TYDREAL, 1 },
  95
  96 "anint",        { INTRGEN, 2, 2 },
  97 "dnint",        { INTRSPEC, TYDREAL, 3 },
  98
  99 "nint",         { INTRGEN, 4, 4 },
 100 "idnint",       { INTRGEN, 2, 6 },
 101
 102 "abs",          { INTRGEN, 6, 8 },
 103 "iabs",         { INTRGEN, 2, 9 },
 104 "dabs",         { INTRSPEC, TYDREAL, 11 },
 105 "cabs",         { INTRSPEC, TYREAL, 12, 0, 13 },
 106 "zabs",         { INTRSPEC, TYDREAL, 13, 1 },
 107
 108 "mod",          { INTRGEN, 4, 14 },
 109 "amod",         { INTRSPEC, TYREAL, 16, 0, 17 },
 110 "dmod",         { INTRSPEC, TYDREAL, 17 },
 111
 112 "sign",         { INTRGEN, 4, 18 },
 113 "isign",        { INTRGEN, 2, 19 },
 114 "dsign",        { INTRSPEC, TYDREAL, 21 },
 115
 116 "dim",          { INTRGEN, 4, 22 },
 117 "idim",         { INTRGEN, 2, 23 },
 118 "ddim",         { INTRSPEC, TYDREAL, 25 },
 119
 120 "dprod",        { INTRSPEC, TYDREAL, 26 },
 121
 122 "len",          { INTRSPEC, TYLONG, 27 },
 123 "index",        { INTRSPEC, TYLONG, 29 },
 124
 125 "imag",         { INTRGEN, 2, 31 },
 126 "aimag",        { INTRSPEC, TYREAL, 31, 0, 32 },
 127 "dimag",        { INTRSPEC, TYDREAL, 32 },
 128
 129 "conjg",        { INTRGEN, 2, 33 },
 130 "dconjg",       { INTRSPEC, TYDCOMPLEX, 34, 1 },
 131
 132 "sqrt",         { INTRGEN, 4, 35 },
 133 "dsqrt",        { INTRSPEC, TYDREAL, 36 },
 134 "csqrt",        { INTRSPEC, TYCOMPLEX, 37, 0, 38 },
 135 "zsqrt",        { INTRSPEC, TYDCOMPLEX, 38, 1 },
 136
 137 "exp",          { INTRGEN, 4, 39 },
 138 "dexp",         { INTRSPEC, TYDREAL, 40 },
 139 "cexp",         { INTRSPEC, TYCOMPLEX, 41, 0, 42 },
 140 "zexp",         { INTRSPEC, TYDCOMPLEX, 42, 1 },
 141
 142 "log",          { INTRGEN, 4, 43 },
 143 "alog",         { INTRSPEC, TYREAL, 43, 0, 44 },
 144 "dlog",         { INTRSPEC, TYDREAL, 44 },
 145 "clog",         { INTRSPEC, TYCOMPLEX, 45, 0, 46 },
 146 "zlog",         { INTRSPEC, TYDCOMPLEX, 46, 1 },
 147
 148 "log10",        { INTRGEN, 2, 47 },
 149 "alog10",       { INTRSPEC, TYREAL, 47, 0, 48 },
 150 "dlog10",       { INTRSPEC, TYDREAL, 48 },
 151
 152 "sin",          { INTRGEN, 4, 49 },
 153 "dsin",         { INTRSPEC, TYDREAL, 50 },
 154 "csin",         { INTRSPEC, TYCOMPLEX, 51, 0, 52 },
 155 "zsin",         { INTRSPEC, TYDCOMPLEX, 52, 1 },
 156
 157 "cos",          { INTRGEN, 4, 53 },
 158 "dcos",         { INTRSPEC, TYDREAL, 54 },
 159 "ccos",         { INTRSPEC, TYCOMPLEX, 55, 0, 56 },
 160 "zcos",         { INTRSPEC, TYDCOMPLEX, 56, 1 },
 161
 162 "tan",          { INTRGEN, 2, 57 },
 163 "dtan",         { INTRSPEC, TYDREAL, 58 },
 164
 165 "asin",         { INTRGEN, 2, 59 },
 166 "dasin",        { INTRSPEC, TYDREAL, 60 },
 167
 168 "acos",         { INTRGEN, 2, 61 },
 169 "dacos",        { INTRSPEC, TYDREAL, 62 },
 170
 171 "atan",         { INTRGEN, 2, 63 },
 172 "datan",        { INTRSPEC, TYDREAL, 64 },
 173
 174 "atan2",        { INTRGEN, 2, 65 },
 175 "datan2",       { INTRSPEC, TYDREAL, 66 },
 176
 177 "sinh",         { INTRGEN, 2, 67 },
 178 "dsinh",        { INTRSPEC, TYDREAL, 68 },
 179
 180 "cosh",         { INTRGEN, 2, 69 },
 181 "dcosh",        { INTRSPEC, TYDREAL, 70 },
 182
 183 "tanh",         { INTRGEN, 2, 71 },
 184 "dtanh",        { INTRSPEC, TYDREAL, 72 },
 185
 186 "lge",          { INTRSPEC, TYLOGICAL, 73},
 187 "lgt",          { INTRSPEC, TYLOGICAL, 75},
 188 "lle",          { INTRSPEC, TYLOGICAL, 77},
 189 "llt",          { INTRSPEC, TYLOGICAL, 79},
 190
 191 #if 0
 192 "epbase",       { INTRCNST, 4, 0 },
 193 "epprec",       { INTRCNST, 4, 4 },
 194 "epemin",       { INTRCNST, 2, 8 },
 195 "epemax",       { INTRCNST, 2, 10 },
 196 "eptiny",       { INTRCNST, 2, 12 },
 197 "ephuge",       { INTRCNST, 4, 14 },
 198 "epmrsp",       { INTRCNST, 2, 18 },
 199 #endif
 200
 201 "fpexpn",       { INTRGEN, 4, 81 },
 202 "fpabsp",       { INTRGEN, 2, 85 },
 203 "fprrsp",       { INTRGEN, 2, 87 },
 204 "fpfrac",       { INTRGEN, 2, 89 },
 205 "fpmake",       { INTRGEN, 2, 91 },
 206 "fpscal",       { INTRGEN, 2, 93 },
 207
 208 "" };
 209
 210
 211 LOCAL struct Specblock
 212         {
 213         char atype;             /* Argument type; every arg must have
 214                                    this type */
 215         char rtype;             /* Result type */
 216         char nargs;             /* Number of arguments */
 217         char spxname[8];        /* Name of the function in Fortran */
 218         char othername;         /* index into callbyvalue table */
 219         } spectab[ ] =
 220 {
 221         { TYREAL,TYREAL,1,"r_int" },
 222         { TYDREAL,TYDREAL,1,"d_int" },
 223
 224         { TYREAL,TYREAL,1,"r_nint" },
 225         { TYDREAL,TYDREAL,1,"d_nint" },
 226
 227         { TYREAL,TYSHORT,1,"h_nint" },
 228         { TYREAL,TYLONG,1,"i_nint" },
 229
 230         { TYDREAL,TYSHORT,1,"h_dnnt" },
 231         { TYDREAL,TYLONG,1,"i_dnnt" },
 232
 233         { TYREAL,TYREAL,1,"r_abs" },
 234         { TYSHORT,TYSHORT,1,"h_abs" },
 235         { TYLONG,TYLONG,1,"i_abs" },
 236         { TYDREAL,TYDREAL,1,"d_abs" },
 237         { TYCOMPLEX,TYREAL,1,"c_abs" },
 238         { TYDCOMPLEX,TYDREAL,1,"z_abs" },
 239
 240         { TYSHORT,TYSHORT,2,"h_mod" },
 241         { TYLONG,TYLONG,2,"i_mod" },
 242         { TYREAL,TYREAL,2,"r_mod" },
 243         { TYDREAL,TYDREAL,2,"d_mod" },
 244
 245         { TYREAL,TYREAL,2,"r_sign" },
 246         { TYSHORT,TYSHORT,2,"h_sign" },
 247         { TYLONG,TYLONG,2,"i_sign" },
 248         { TYDREAL,TYDREAL,2,"d_sign" },
 249
 250         { TYREAL,TYREAL,2,"r_dim" },
 251         { TYSHORT,TYSHORT,2,"h_dim" },
 252         { TYLONG,TYLONG,2,"i_dim" },
 253         { TYDREAL,TYDREAL,2,"d_dim" },
 254
 255         { TYREAL,TYDREAL,2,"d_prod" },
 256
 257         { TYCHAR,TYSHORT,1,"h_len" },
 258         { TYCHAR,TYLONG,1,"i_len" },
 259
 260         { TYCHAR,TYSHORT,2,"h_indx" },
 261         { TYCHAR,TYLONG,2,"i_indx" },
 262
 263         { TYCOMPLEX,TYREAL,1,"r_imag" },
 264         { TYDCOMPLEX,TYDREAL,1,"d_imag" },
 265         { TYCOMPLEX,TYCOMPLEX,1,"r_cnjg" },
 266         { TYDCOMPLEX,TYDCOMPLEX,1,"d_cnjg" },
 267
 268         { TYREAL,TYREAL,1,"r_sqrt", 1 },
 269         { TYDREAL,TYDREAL,1,"d_sqrt", 1 },
 270         { TYCOMPLEX,TYCOMPLEX,1,"c_sqrt" },
 271         { TYDCOMPLEX,TYDCOMPLEX,1,"z_sqrt" },
 272
 273         { TYREAL,TYREAL,1,"r_exp", 2 },
 274         { TYDREAL,TYDREAL,1,"d_exp", 2 },
 275         { TYCOMPLEX,TYCOMPLEX,1,"c_exp" },
 276         { TYDCOMPLEX,TYDCOMPLEX,1,"z_exp" },
 277
 278         { TYREAL,TYREAL,1,"r_log", 3 },
 279         { TYDREAL,TYDREAL,1,"d_log", 3 },
 280         { TYCOMPLEX,TYCOMPLEX,1,"c_log" },
 281         { TYDCOMPLEX,TYDCOMPLEX,1,"z_log" },
 282
 283         { TYREAL,TYREAL,1,"r_lg10" },
 284         { TYDREAL,TYDREAL,1,"d_lg10" },
 285
 286         { TYREAL,TYREAL,1,"r_sin", 4 },
 287         { TYDREAL,TYDREAL,1,"d_sin", 4 },
 288         { TYCOMPLEX,TYCOMPLEX,1,"c_sin" },
 289         { TYDCOMPLEX,TYDCOMPLEX,1,"z_sin" },
 290
 291         { TYREAL,TYREAL,1,"r_cos", 5 },
 292         { TYDREAL,TYDREAL,1,"d_cos", 5 },
 293         { TYCOMPLEX,TYCOMPLEX,1,"c_cos" },
 294         { TYDCOMPLEX,TYDCOMPLEX,1,"z_cos" },
 295
 296         { TYREAL,TYREAL,1,"r_tan", 6 },
 297         { TYDREAL,TYDREAL,1,"d_tan", 6 },
 298
 299         { TYREAL,TYREAL,1,"r_asin", 7 },
 300         { TYDREAL,TYDREAL,1,"d_asin", 7 },
 301
 302         { TYREAL,TYREAL,1,"r_acos", 8 },
 303         { TYDREAL,TYDREAL,1,"d_acos", 8 },
 304
 305         { TYREAL,TYREAL,1,"r_atan", 9 },
 306         { TYDREAL,TYDREAL,1,"d_atan", 9 },
 307
 308         { TYREAL,TYREAL,2,"r_atn2", 10 },
 309         { TYDREAL,TYDREAL,2,"d_atn2", 10 },
 310
 311         { TYREAL,TYREAL,1,"r_sinh", 11 },
 312         { TYDREAL,TYDREAL,1,"d_sinh", 11 },
 313
 314         { TYREAL,TYREAL,1,"r_cosh", 12 },
 315         { TYDREAL,TYDREAL,1,"d_cosh", 12 },
 316
 317         { TYREAL,TYREAL,1,"r_tanh", 13 },
 318         { TYDREAL,TYDREAL,1,"d_tanh", 13 },
 319
 320         { TYCHAR,TYLOGICAL,2,"hl_ge" },
 321         { TYCHAR,TYLOGICAL,2,"l_ge" },
 322
 323         { TYCHAR,TYLOGICAL,2,"hl_gt" },
 324         { TYCHAR,TYLOGICAL,2,"l_gt" },
 325
 326         { TYCHAR,TYLOGICAL,2,"hl_le" },
 327         { TYCHAR,TYLOGICAL,2,"l_le" },
 328
 329         { TYCHAR,TYLOGICAL,2,"hl_lt" },
 330         { TYCHAR,TYLOGICAL,2,"l_lt" },
 331
 332         { TYREAL,TYSHORT,1,"hr_expn" },
 333         { TYREAL,TYLONG,1,"ir_expn" },
 334         { TYDREAL,TYSHORT,1,"hd_expn" },
 335         { TYDREAL,TYLONG,1,"id_expn" },
 336
 337         { TYREAL,TYREAL,1,"r_absp" },
 338         { TYDREAL,TYDREAL,1,"d_absp" },
 339
 340         { TYREAL,TYDREAL,1,"r_rrsp" },
 341         { TYDREAL,TYDREAL,1,"d_rrsp" },
 342
 343         { TYREAL,TYREAL,1,"r_frac" },
 344         { TYDREAL,TYDREAL,1,"d_frac" },
 345
 346         { TYREAL,TYREAL,2,"r_make" },
 347         { TYDREAL,TYDREAL,2,"d_make" },
 348
 349         { TYREAL,TYREAL,2,"r_scal" },
 350         { TYDREAL,TYDREAL,2,"d_scal" },
 351         { 0 }
 352 } ;
 353
 354 #if 0
 355 LOCAL struct Incstblock
 356         {
 357         char atype;
 358         char rtype;
 359         char constno;
 360         } consttab[ ] =
 361 {
 362         { TYSHORT, TYLONG, 0 },
 363         { TYLONG, TYLONG, 1 },
 364         { TYREAL, TYLONG, 2 },
 365         { TYDREAL, TYLONG, 3 },
 366
 367         { TYSHORT, TYLONG, 4 },
 368         { TYLONG, TYLONG, 5 },
 369         { TYREAL, TYLONG, 6 },
 370         { TYDREAL, TYLONG, 7 },
 371
 372         { TYREAL, TYLONG, 8 },
 373         { TYDREAL, TYLONG, 9 },
 374
 375         { TYREAL, TYLONG, 10 },
 376         { TYDREAL, TYLONG, 11 },
 377
 378         { TYREAL, TYREAL, 0 },
 379         { TYDREAL, TYDREAL, 1 },
 380
 381         { TYSHORT, TYLONG, 12 },
 382         { TYLONG, TYLONG, 13 },
 383         { TYREAL, TYREAL, 2 },
 384         { TYDREAL, TYDREAL, 3 },
 385
 386         { TYREAL, TYREAL, 4 },
 387         { TYDREAL, TYDREAL, 5 }
 388 };
 389 #endif
 390
 391 char *callbyvalue[ ] =
 392         {0,
 393         "sqrt",
 394         "exp",
 395         "log",
 396         "sin",
 397         "cos",
 398         "tan",
 399         "asin",
 400         "acos",
 401         "atan",
 402         "atan2",
 403         "sinh",
 404         "cosh",
 405         "tanh"
 406         };
 407
 408  void
 409 r8fix() /* adjust tables for -r8 */
 410 {
 411         register struct Intrblock *I;
 412         register struct Specblock *S;
 413
 414         for(I = intrtab; I->intrfname[0]; I++)
 415                 if (I->intrval.intrgroup != INTRGEN)
 416                     switch(I->intrval.intrstuff) {
 417                         case TYREAL:
 418                                 I->intrval.intrstuff = TYDREAL;
 419                                 I->intrval.intrno = I->intrval.dblintrno;
 420                                 break;
 421                         case TYCOMPLEX:
 422                                 I->intrval.intrstuff = TYDCOMPLEX;
 423                                 I->intrval.intrno = I->intrval.dblintrno;
 424                                 I->intrval.dblcmplx = 1;
 425                         }
 426
 427         for(S = spectab; S->atype; S++)
 428             switch(S->atype) {
 429                 case TYCOMPLEX:
 430                         S->atype = TYDCOMPLEX;
 431                         if (S->rtype == TYREAL)
 432                                 S->rtype = TYDREAL;
 433                         else if (S->rtype == TYCOMPLEX)
 434                                 S->rtype = TYDCOMPLEX;
 435                         switch(S->spxname[0]) {
 436                                 case 'r':
 437                                         S->spxname[0] = 'd';
 438                                         break;
 439                                 case 'c':
 440                                         S->spxname[0] = 'z';
 441                                         break;
 442                                 default:
 443                                         Fatal("r8fix bug");
 444                                 }
 445                         break;
 446                 case TYREAL:
 447                         S->atype = TYDREAL;
 448                         switch(S->rtype) {
 449                             case TYREAL:
 450                                 S->rtype = TYDREAL;
 451                                 if (S->spxname[0] != 'r')
 452                                         Fatal("r8fix bug");
 453                                 S->spxname[0] = 'd';
 454                             case TYDREAL:       /* d_prod */
 455                                 break;
 456
 457                             case TYSHORT:
 458                                 if (!strcmp(S->spxname, "hr_expn"))
 459                                         S->spxname[1] = 'd';
 460                                 else if (!strcmp(S->spxname, "h_nint"))
 461                                         strcpy(S->spxname, "h_dnnt");
 462                                 else Fatal("r8fix bug");
 463                                 break;
 464
 465                             case TYLONG:
 466                                 if (!strcmp(S->spxname, "ir_expn"))
 467                                         S->spxname[1] = 'd';
 468                                 else if (!strcmp(S->spxname, "i_nint"))
 469                                         strcpy(S->spxname, "i_dnnt");
 470                                 else Fatal("r8fix bug");
 471                                 break;
 472
 473                             default:
 474                                 Fatal("r8fix bug");
 475                             }
 476                 }
 477         }
 478
 479 expptr intrcall(np, argsp, nargs)
 480 Namep np;
 481 struct Listblock *argsp;
 482 int nargs;
 483 {
 484         int i, rettype;
 485         Addrp ap;
 486         register struct Specblock *sp;
 487         register struct Chain *cp;
 488         expptr Inline(), mkcxcon(), mkrealcon();
 489         expptr q, ep;
 490         int mtype;
 491         int op;
 492         int f1field, f2field, f3field;
 493
 494         packed.ijunk = np->vardesc.varno;
 495         f1field = packed.bits.f1;
 496         f2field = packed.bits.f2;
 497         f3field = packed.bits.f3;
 498         if(nargs == 0)
 499                 goto badnargs;
 500
 501         mtype = 0;
 502         for(cp = argsp->listp ; cp ; cp = cp->nextp)
 503         {
 504                 ep = (expptr)cp->datap;
 505                 if( ISCONST(ep) && ep->headblock.vtype==TYSHORT )
 506                         cp->datap = (char *) mkconv(tyint, ep);
 507                 mtype = maxtype(mtype, ep->headblock.vtype);
 508         }
 509
 510         switch(f1field)
 511         {
 512         case INTRBOOL:
 513                 op = f3field;
 514                 if( ! ONEOF(mtype, MSKINT|MSKLOGICAL) )
 515                         goto badtype;
 516                 if(op == OPBITNOT)
 517                 {
 518                         if(nargs != 1)
 519                                 goto badnargs;
 520                         q = mkexpr(OPBITNOT, (expptr)argsp->listp->datap, ENULL);
 521                 }
 522                 else
 523                 {
 524                         if(nargs != 2)
 525                                 goto badnargs;
 526                         q = mkexpr(op, (expptr)argsp->listp->datap,
 527                                         (expptr)argsp->listp->nextp->datap);
 528                 }
 529                 frchain( &(argsp->listp) );
 530                 free( (charptr) argsp);
 531                 return(q);
 532
 533         case INTRCONV:
 534                 rettype = f2field;
 535                 if(rettype == TYLONG)
 536                         rettype = tyint;
 537                 if( ISCOMPLEX(rettype) && nargs==2)
 538                 {
 539                         expptr qr, qi;
 540                         qr = (expptr) argsp->listp->datap;
 541                         qi = (expptr) argsp->listp->nextp->datap;
 542                         if(ISCONST(qr) && ISCONST(qi))
 543                                 q = mkcxcon(qr,qi);
 544                         else    q = mkexpr(OPCONV,mkconv(rettype-2,qr),
 545                             mkconv(rettype-2,qi));
 546                 }
 547                 else if(nargs == 1) {
 548                         if (f3field && ((Exprp)argsp->listp->datap)->vtype
 549                                         == TYDCOMPLEX)
 550                                 rettype = TYDREAL;
 551                         q = mkconv(rettype+100, (expptr)argsp->listp->datap);
 552                         }
 553                 else goto badnargs;
 554
 555                 q->headblock.vtype = rettype;
 556                 frchain(&(argsp->listp));
 557                 free( (charptr) argsp);
 558                 return(q);
 559
 560
 561 #if 0
 562         case INTRCNST:
 563
 564 /* Machine-dependent f77 stuff that f2c omits:
 565
 566 intcon contains
 567         radix for short int
 568         radix for long int
 569         radix for single precision
 570         radix for double precision
 571         precision for short int
 572         precision for long int
 573         precision for single precision
 574         precision for double precision
 575         emin for single precision
 576         emin for double precision
 577         emax for single precision
 578         emax for double prcision
 579         largest short int
 580         largest long int
 581
 582 realcon contains
 583         tiny for single precision
 584         tiny for double precision
 585         huge for single precision
 586         huge for double precision
 587         mrsp (epsilon) for single precision
 588         mrsp (epsilon) for double precision
 589 */
 590         {       register struct Incstblock *cstp;
 591                 extern ftnint intcon[14];
 592                 extern double realcon[6];
 593
 594                 cstp = consttab + f3field;
 595                 for(i=0 ; i<f2field ; ++i)
 596                         if(cstp->atype == mtype)
 597                                 goto foundconst;
 598                         else
 599                                 ++cstp;
 600                 goto badtype;
 601
 602 foundconst:
 603                 switch(cstp->rtype)
 604                 {
 605                 case TYLONG:
 606                         return(mkintcon(intcon[cstp->constno]));
 607
 608                 case TYREAL:
 609                 case TYDREAL:
 610                         return(mkrealcon(cstp->rtype,
 611                             realcon[cstp->constno]) );
 612
 613                 default:
 614                         Fatal("impossible intrinsic constant");
 615                 }
 616         }
 617 #endif
 618
 619         case INTRGEN:
 620                 sp = spectab + f3field;
 621                 if(no66flag)
 622                         if(sp->atype == mtype)
 623                                 goto specfunct;
 624                         else err66("generic function");
 625
 626                 for(i=0; i<f2field ; ++i)
 627                         if(sp->atype == mtype)
 628                                 goto specfunct;
 629                         else
 630                                 ++sp;
 631                 warn1 ("bad argument type to intrinsic %s", np->fvarname);
 632
 633 /* Made this a warning rather than an error so things like "log (5) ==>
 634    log (5.0)" can be accommodated.  When none of these cases matches, the
 635    argument is cast up to the first type in the spectab list; this first
 636    type is assumed to be the "smallest" type, e.g. REAL before DREAL
 637    before COMPLEX, before DCOMPLEX */
 638
 639                 sp = spectab + f3field;
 640                 mtype = sp -> atype;
 641                 goto specfunct;
 642
 643         case INTRSPEC:
 644                 sp = spectab + f3field;
 645 specfunct:
 646                 if(tyint==TYLONG && ONEOF(sp->rtype,M(TYSHORT)|M(TYLOGICAL))
 647                     && (sp+1)->atype==sp->atype)
 648                         ++sp;
 649
 650                 if(nargs != sp->nargs)
 651                         goto badnargs;
 652                 if(mtype != sp->atype)
 653                         goto badtype;
 654
 655 /* NOTE!!  I moved fixargs (YES) into the ELSE branch so that constants in
 656    the inline expression wouldn't get put into the constant table */
 657
 658                 fixargs (NO, argsp);
 659                 cast_args (mtype, argsp -> listp);
 660
 661                 if(q = Inline((int)(sp-spectab), mtype, argsp->listp))
 662                 {
 663                         frchain( &(argsp->listp) );
 664                         free( (charptr) argsp);
 665                 } else {
 666
 667                     if(sp->othername) {
 668                         /* C library routines that return double... */
 669                         /* sp->rtype might be TYREAL */
 670                         ap = builtin(sp->rtype,
 671                                 callbyvalue[sp->othername], 1);
 672                         q = fixexpr((Exprp)
 673                                 mkexpr(OPCCALL, (expptr)ap, (expptr)argsp) );
 674                     } else {
 675                         fixargs(YES, argsp);
 676                         ap = builtin(sp->rtype, sp->spxname, 0);
 677                         q = fixexpr((Exprp)
 678                                 mkexpr(OPCALL, (expptr)ap, (expptr)argsp) );
 679                     } /* else */
 680                 } /* else */
 681                 return(q);
 682
 683         case INTRMIN:
 684         case INTRMAX:
 685                 if(nargs < 2)
 686                         goto badnargs;
 687                 if( ! ONEOF(mtype, MSKINT|MSKREAL) )
 688                         goto badtype;
 689                 argsp->vtype = mtype;
 690                 q = mkexpr( (f1field==INTRMIN ? OPMIN : OPMAX), (expptr)argsp, ENULL);
 691
 692                 q->headblock.vtype = mtype;
 693                 rettype = f2field;
 694                 if(rettype == TYLONG)
 695                         rettype = tyint;
 696                 else if(rettype == TYUNKNOWN)
 697                         rettype = mtype;
 698                 return( mkconv(rettype, q) );
 699
 700         default:
 701                 fatali("intrcall: bad intrgroup %d", f1field);
 702         }
 703 badnargs:
 704         errstr("bad number of arguments to intrinsic %s", np->fvarname);
 705         goto bad;
 706
 707 badtype:
 708         errstr("bad argument type to intrinsic %s", np->fvarname);
 709
 710 bad:
 711         return( errnode() );
 712 }
 713
 714
 715
 716
 717 intrfunct(s)
 718 char *s;
 719 {
 720         register struct Intrblock *p;
 721
 722         for(p = intrtab; p->intrval.intrgroup!=INTREND ; ++p)
 723         {
 724                 if( !strcmp(s, p->intrfname) )
 725                 {
 726                         packed.bits.f1 = p->intrval.intrgroup;
 727                         packed.bits.f2 = p->intrval.intrstuff;
 728                         packed.bits.f3 = p->intrval.intrno;
 729                         packed.bits.f4 = p->intrval.dblcmplx;
 730                         return(packed.ijunk);
 731                 }
 732         }
 733
 734         return(0);
 735 }
 736
 737
 738
 739
 740
 741 Addrp intraddr(np)
 742 Namep np;
 743 {
 744         Addrp q;
 745         register struct Specblock *sp;
 746         int f3field;
 747
 748         if(np->vclass!=CLPROC || np->vprocclass!=PINTRINSIC)
 749                 fatalstr("intraddr: %s is not intrinsic", np->fvarname);
 750         packed.ijunk = np->vardesc.varno;
 751         f3field = packed.bits.f3;
 752
 753         switch(packed.bits.f1)
 754         {
 755         case INTRGEN:
 756                 /* imag, log, and log10 arent specific functions */
 757                 if(f3field==31 || f3field==43 || f3field==47)
 758                         goto bad;
 759
 760         case INTRSPEC:
 761                 sp = spectab + f3field;
 762                 if(tyint==TYLONG && sp->rtype==TYSHORT)
 763                         ++sp;
 764                 q = builtin(sp->rtype, sp->spxname,
 765                         sp->othername ? 1 : 0);
 766                 return(q);
 767
 768         case INTRCONV:
 769         case INTRMIN:
 770         case INTRMAX:
 771         case INTRBOOL:
 772         case INTRCNST:
 773 bad:
 774                 errstr("cannot pass %s as actual", np->fvarname);
 775                 return((Addrp)errnode());
 776         }
 777         fatali("intraddr: impossible f1=%d\n", (int) packed.bits.f1);
 778         /* NOT REACHED */ return 0;
 779 }
 780
 781
 782
 783 void cast_args (maxtype, args)
 784 int maxtype;
 785 chainp args;
 786 {
 787     for (; args; args = args -> nextp) {
 788         expptr e = (expptr) args->datap;
 789         if (e -> headblock.vtype != maxtype)
 790             if (e -> tag == TCONST)
 791                 args->datap = (char *) mkconv(maxtype, e);
 792             else {
 793                 Addrp temp = mktmp(maxtype, ENULL);
 794
 795                 puteq(cpexpr((expptr)temp), e);
 796                 args->datap = (char *)temp;
 797             } /* else */
 798     } /* for */
 799 } /* cast_args */
 800
 801
 802
 803 expptr Inline(fno, type, args)
 804 int fno;
 805 int type;
 806 struct Chain *args;
 807 {
 808         register expptr q, t, t1;
 809
 810         switch(fno)
 811         {
 812         case 8: /* real abs */
 813         case 9: /* short int abs */
 814         case 10:        /* long int abs */
 815         case 11:        /* double precision abs */
 816                 if( addressable(q = (expptr) args->datap) )
 817                 {
 818                         t = q;
 819                         q = NULL;
 820                 }
 821                 else
 822                         t = (expptr) mktmp(type,ENULL);
 823                 t1 = mkexpr(type == TYREAL && forcedouble ? OPDABS : OPABS,
 824                         cpexpr(t), ENULL);
 825                 if(q)
 826                         t1 = mkexpr(OPCOMMA, mkexpr(OPASSIGN, cpexpr(t),q), t1);
 827                 frexpr(t);
 828                 return(t1);
 829
 830         case 26:        /* dprod */
 831                 q = mkexpr(OPSTAR, mkconv(TYDREAL,(expptr)args->datap),
 832                         (expptr)args->nextp->datap);
 833                 return(q);
 834
 835         case 27:        /* len of character string */
 836                 q = (expptr) cpexpr(((tagptr)args->datap)->headblock.vleng);
 837                 frexpr((expptr)args->datap);
 838                 return(q);
 839
 840         case 14:        /* half-integer mod */
 841         case 15:        /* mod */
 842                 return mkexpr(OPMOD, (expptr) args->datap,
 843                                 (expptr) args->nextp->datap);
 844         }
 845         return(NULL);
 846 }