gcc/f/intrin.c

   1 /* intrin.c -- Recognize references to intrinsics
   2    Copyright (C) 1995, 1996, 1997, 1998, 2002 Free Software Foundation, Inc.
   3    Contributed by James Craig Burley.
   4
   5 This file is part of GNU Fortran.
   6
   7 GNU Fortran is free software; you can redistribute it and/or modify
   8 it under the terms of the GNU General Public License as published by
   9 the Free Software Foundation; either version 2, or (at your option)
  10 any later version.
  11
  12 GNU Fortran is distributed in the hope that it will be useful,
  13 but WITHOUT ANY WARRANTY; without even the implied warranty of
  14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15 GNU General Public License for more details.
  16
  17 You should have received a copy of the GNU General Public License
  18 along with GNU Fortran; see the file COPYING.  If not, write to
  19 the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA
  20 02111-1307, USA.
  21
  22 */
  23
  24 #include "proj.h"
  25 #include "intrin.h"
  26 #include "expr.h"
  27 #include "info.h"
  28 #include "src.h"
  29 #include "symbol.h"
  30 #include "target.h"
  31 #include "top.h"
  32
  33 struct _ffeintrin_name_
  34   {
  35     const char *const name_uc;
  36     const char *const name_lc;
  37     const char *const name_ic;
  38     const ffeintrinGen generic;
  39     const ffeintrinSpec specific;
  40   };
  41
  42 struct _ffeintrin_gen_
  43   {
  44     const char *const name;                     /* Name as seen in program. */
  45     const ffeintrinSpec specs[2];
  46   };
  47
  48 struct _ffeintrin_spec_
  49   {
  50     const char *const name;     /* Uppercase name as seen in source code,
  51                                    lowercase if no source name, "none" if no
  52                                    name at all (NONE case). */
  53     const bool is_actualarg;    /* Ok to pass as actual arg if -pedantic. */
  54     const ffeintrinFamily family;
  55     const ffeintrinImp implementation;
  56   };
  57
  58 struct _ffeintrin_imp_
  59   {
  60     const char *const name;     /* Name of implementation. */
  61     const ffecomGfrt gfrt_direct;/* library routine, direct-callable form. */
  62     const ffecomGfrt gfrt_f2c;  /* library routine, f2c-callable form. */
  63     const ffecomGfrt gfrt_gnu;  /* library routine, gnu-callable form. */
  64     const char *const control;
  65     const char y2kbad;
  66   };
  67
  68 static ffebad ffeintrin_check_ (ffeintrinImp imp, ffebldOp op,
  69                                 ffebld args, ffeinfoBasictype *xbt,
  70                                 ffeinfoKindtype *xkt,
  71                                 ffetargetCharacterSize *xsz,
  72                                 bool *check_intrin,
  73                                 ffelexToken t,
  74                                 bool commit);
  75 static bool ffeintrin_check_any_ (ffebld arglist);
  76 static int ffeintrin_cmp_name_ (const void *name, const void *intrinsic);
  77
  78 static const struct _ffeintrin_name_ ffeintrin_names_[]
  79 =
  80 {                               /* Alpha order. */
  81 #define DEFNAME(UPPER,LOWER,MIXED,GEN,SPEC) \
  82   { UPPER, LOWER, MIXED, FFEINTRIN_ ## GEN, FFEINTRIN_ ## SPEC },
  83 #define DEFGEN(CODE,NAME,SPEC1,SPEC2)
  84 #define DEFSPEC(CODE,NAME,CALLABLE,FAMILY,IMP)
  85 #define DEFIMP(CODE,NAME,GFRTDIRECT,GFRTF2C,GFRTGNU,CONTROL)
  86 #define DEFIMPY(CODE,NAME,GFRTDIRECT,GFRTF2C,GFRTGNU,CONTROL,Y2KBAD)
  87 #include "intrin.def"
  88 #undef DEFNAME
  89 #undef DEFGEN
  90 #undef DEFSPEC
  91 #undef DEFIMP
  92 #undef DEFIMPY
  93 };
  94
  95 static const struct _ffeintrin_gen_ ffeintrin_gens_[]
  96 =
  97 {
  98 #define DEFNAME(UPPER,LOWER,MIXED,GEN,SPEC)
  99 #define DEFGEN(CODE,NAME,SPEC1,SPEC2) \
 100   { NAME, { SPEC1, SPEC2, }, },
 101 #define DEFSPEC(CODE,NAME,CALLABLE,FAMILY,IMP)
 102 #define DEFIMP(CODE,NAME,GFRTDIRECT,GFRTF2C,GFRTGNU,CONTROL)
 103 #define DEFIMPY(CODE,NAME,GFRTDIRECT,GFRTF2C,GFRTGNU,CONTROL,Y2KBAD)
 104 #include "intrin.def"
 105 #undef DEFNAME
 106 #undef DEFGEN
 107 #undef DEFSPEC
 108 #undef DEFIMP
 109 #undef DEFIMPY
 110 };
 111
 112 static const struct _ffeintrin_imp_ ffeintrin_imps_[]
 113 =
 114 {
 115 #define DEFNAME(UPPER,LOWER,MIXED,GEN,SPEC)
 116 #define DEFGEN(CODE,NAME,SPEC1,SPEC2)
 117 #define DEFSPEC(CODE,NAME,CALLABLE,FAMILY,IMP)
 118 #define DEFIMP(CODE,NAME,GFRTDIRECT,GFRTF2C,GFRTGNU,CONTROL) \
 119       { NAME, FFECOM_gfrt ## GFRTDIRECT, FFECOM_gfrt ## GFRTF2C, \
 120         FFECOM_gfrt ## GFRTGNU, CONTROL, FALSE },
 121 #define DEFIMPY(CODE,NAME,GFRTDIRECT,GFRTF2C,GFRTGNU,CONTROL,Y2KBAD) \
 122       { NAME, FFECOM_gfrt ## GFRTDIRECT, FFECOM_gfrt ## GFRTF2C, \
 123         FFECOM_gfrt ## GFRTGNU, CONTROL, Y2KBAD },
 124 #include "intrin.def"
 125 #undef DEFNAME
 126 #undef DEFGEN
 127 #undef DEFSPEC
 128 #undef DEFIMP
 129 #undef DEFIMPY
 130 };
 131
 132 static const struct _ffeintrin_spec_ ffeintrin_specs_[]
 133 =
 134 {
 135 #define DEFNAME(UPPER,LOWER,MIXED,GEN,SPEC)
 136 #define DEFGEN(CODE,NAME,SPEC1,SPEC2)
 137 #define DEFSPEC(CODE,NAME,CALLABLE,FAMILY,IMP) \
 138   { NAME, CALLABLE, FAMILY, IMP, },
 139 #define DEFIMP(CODE,NAME,GFRTDIRECT,GFRTF2C,GFRTGNU,CONTROL)
 140 #define DEFIMPY(CODE,NAME,GFRTDIRECT,GFRTF2C,GFRTGNU,CONTROL,Y2KBAD)
 141 #include "intrin.def"
 142 #undef DEFGEN
 143 #undef DEFSPEC
 144 #undef DEFIMP
 145 #undef DEFIMPY
 146 };
 147 \f
 148
 149 static ffebad
 150 ffeintrin_check_ (ffeintrinImp imp, ffebldOp op,
 151                   ffebld args, ffeinfoBasictype *xbt,
 152                   ffeinfoKindtype *xkt,
 153                   ffetargetCharacterSize *xsz,
 154                   bool *check_intrin,
 155                   ffelexToken t,
 156                   bool commit)
 157 {
 158   const char *c = ffeintrin_imps_[imp].control;
 159   bool subr = (c[0] == '-');
 160   const char *argc;
 161   ffebld arg;
 162   ffeinfoBasictype bt;
 163   ffeinfoKindtype kt;
 164   ffetargetCharacterSize sz = FFETARGET_charactersizeNONE;
 165   ffeinfoKindtype firstarg_kt;
 166   bool need_col;
 167   ffeinfoBasictype col_bt = FFEINFO_basictypeNONE;
 168   ffeinfoKindtype col_kt = FFEINFO_kindtypeNONE;
 169   int colon = (c[2] == ':') ? 2 : 3;
 170   int argno;
 171
 172   /* Check procedure type (function vs. subroutine) against
 173      invocation.  */
 174
 175   if (op == FFEBLD_opSUBRREF)
 176     {
 177       if (!subr)
 178         return FFEBAD_INTRINSIC_IS_FUNC;
 179     }
 180   else if (op == FFEBLD_opFUNCREF)
 181     {
 182       if (subr)
 183         return FFEBAD_INTRINSIC_IS_SUBR;
 184     }
 185   else
 186     return FFEBAD_INTRINSIC_REF;
 187
 188   /* Check the arglist for validity.  */
 189
 190   if ((args != NULL)
 191       && (ffebld_head (args) != NULL))
 192     firstarg_kt = ffeinfo_kindtype (ffebld_info (ffebld_head (args)));
 193   else
 194     firstarg_kt = FFEINFO_kindtype;
 195
 196   for (argc = &c[colon + 3],
 197          arg = args;
 198        *argc != '\0';
 199        )
 200     {
 201       char optional = '\0';
 202       char required = '\0';
 203       char extra = '\0';
 204       char basic;
 205       char kind;
 206       int length;
 207       int elements;
 208       bool lastarg_complex = FALSE;
 209
 210       /* We don't do anything with keywords yet.  */
 211       do
 212         {
 213         } while (*(++argc) != '=');
 214
 215       ++argc;
 216       if ((*argc == '?')
 217           || (*argc == '!')
 218           || (*argc == '*'))
 219         optional = *(argc++);
 220       if ((*argc == '+')
 221           || (*argc == 'n')
 222           || (*argc == 'p'))
 223         required = *(argc++);
 224       basic = *(argc++);
 225       kind = *(argc++);
 226       if (*argc == '[')
 227         {
 228           length = *++argc - '0';
 229           if (*++argc != ']')
 230             length = 10 * length + (*(argc++) - '0');
 231           ++argc;
 232         }
 233       else
 234         length = -1;
 235       if (*argc == '(')
 236         {
 237           elements = *++argc - '0';
 238           if (*++argc != ')')
 239             elements = 10 * elements + (*(argc++) - '0');
 240           ++argc;
 241         }
 242       else if (*argc == '&')
 243         {
 244           elements = -1;
 245           ++argc;
 246         }
 247       else
 248         elements = 0;
 249       if ((*argc == '&')
 250           || (*argc == 'i')
 251           || (*argc == 'w')
 252           || (*argc == 'x'))
 253         extra = *(argc++);
 254       if (*argc == ',')
 255         ++argc;
 256
 257       /* Break out of this loop only when current arg spec completely
 258          processed.  */
 259
 260       do
 261         {
 262           bool okay;
 263           ffebld a;
 264           ffeinfo i;
 265           bool anynum;
 266           ffeinfoBasictype abt = FFEINFO_basictypeNONE;
 267           ffeinfoKindtype akt = FFEINFO_kindtypeNONE;
 268
 269           if ((arg == NULL)
 270               || (ffebld_head (arg) == NULL))
 271             {
 272               if (required != '\0')
 273                 return FFEBAD_INTRINSIC_TOOFEW;
 274               if (optional == '\0')
 275                 return FFEBAD_INTRINSIC_TOOFEW;
 276               if (arg != NULL)
 277                 arg = ffebld_trail (arg);
 278               break;    /* Try next argspec. */
 279             }
 280
 281           a = ffebld_head (arg);
 282           i = ffebld_info (a);
 283           anynum = (ffeinfo_basictype (i) == FFEINFO_basictypeHOLLERITH)
 284             || (ffeinfo_basictype (i) == FFEINFO_basictypeTYPELESS);
 285
 286           /* See how well the arg matches up to the spec.  */
 287
 288           switch (basic)
 289             {
 290             case 'A':
 291               okay = (ffeinfo_basictype (i) == FFEINFO_basictypeCHARACTER)
 292                 && ((length == -1)
 293                     || (ffeinfo_size (i) == (ffetargetCharacterSize) length));
 294               break;
 295
 296             case 'C':
 297               okay = anynum
 298                 || (ffeinfo_basictype (i) == FFEINFO_basictypeCOMPLEX);
 299               abt = FFEINFO_basictypeCOMPLEX;
 300               break;
 301
 302             case 'I':
 303               okay = anynum
 304                 || (ffeinfo_basictype (i) == FFEINFO_basictypeINTEGER);
 305               abt = FFEINFO_basictypeINTEGER;
 306               break;
 307
 308             case 'L':
 309               okay = anynum
 310                 || (ffeinfo_basictype (i) == FFEINFO_basictypeLOGICAL);
 311               abt = FFEINFO_basictypeLOGICAL;
 312               break;
 313
 314             case 'R':
 315               okay = anynum
 316                 || (ffeinfo_basictype (i) == FFEINFO_basictypeREAL);
 317               abt = FFEINFO_basictypeREAL;
 318               break;
 319
 320             case 'B':
 321               okay = anynum
 322                 || (ffeinfo_basictype (i) == FFEINFO_basictypeINTEGER)
 323                 || (ffeinfo_basictype (i) == FFEINFO_basictypeLOGICAL);
 324               break;
 325
 326             case 'F':
 327               okay = anynum
 328                 || (ffeinfo_basictype (i) == FFEINFO_basictypeCOMPLEX)
 329                 || (ffeinfo_basictype (i) == FFEINFO_basictypeREAL);
 330               break;
 331
 332             case 'N':
 333               okay = anynum
 334                 || (ffeinfo_basictype (i) == FFEINFO_basictypeCOMPLEX)
 335                 || (ffeinfo_basictype (i) == FFEINFO_basictypeINTEGER)
 336                 || (ffeinfo_basictype (i) == FFEINFO_basictypeREAL);
 337               break;
 338
 339             case 'S':
 340               okay = anynum
 341                 || (ffeinfo_basictype (i) == FFEINFO_basictypeINTEGER)
 342                 || (ffeinfo_basictype (i) == FFEINFO_basictypeREAL);
 343               break;
 344
 345             case 'g':
 346               okay = ((ffebld_op (a) == FFEBLD_opLABTER)
 347                       || (ffebld_op (a) == FFEBLD_opLABTOK));
 348               elements = -1;
 349               extra = '-';
 350               break;
 351
 352             case 's':
 353               okay = (((((ffeinfo_basictype (i) == FFEINFO_basictypeNONE)
 354                          && (ffeinfo_kindtype (i) == FFEINFO_kindtypeNONE)
 355                          && (ffeinfo_kind (i) == FFEINFO_kindSUBROUTINE))
 356                         || ((ffeinfo_basictype (i) == FFEINFO_basictypeINTEGER)
 357                             && (ffeinfo_kindtype (i) == FFEINFO_kindtypeINTEGERDEFAULT)
 358                             && (ffeinfo_kind (i) == FFEINFO_kindFUNCTION))
 359                         || (ffeinfo_kind (i) == FFEINFO_kindNONE))
 360                        && ((ffeinfo_where (i) == FFEINFO_whereDUMMY)
 361                            || (ffeinfo_where (i) == FFEINFO_whereGLOBAL)))
 362                       || ((ffeinfo_basictype (i) == FFEINFO_basictypeINTEGER)
 363                           && (ffeinfo_kind (i) == FFEINFO_kindENTITY)));
 364               elements = -1;
 365               extra = '-';
 366               break;
 367
 368             case '-':
 369             default:
 370               okay = TRUE;
 371               break;
 372             }
 373
 374           switch (kind)
 375             {
 376             case '1': case '2': case '3': case '4': case '5':
 377             case '6': case '7': case '8': case '9':
 378               akt = (kind - '0');
 379               if ((ffeinfo_basictype (i) == FFEINFO_basictypeINTEGER)
 380                   || (ffeinfo_basictype (i) == FFEINFO_basictypeLOGICAL))
 381                 {
 382                   switch (akt)
 383                     {   /* Translate to internal kinds for now! */
 384                     default:
 385                       break;
 386
 387                     case 2:
 388                       akt = 4;
 389                       break;
 390
 391                     case 3:
 392                       akt = 2;
 393                       break;
 394
 395                     case 4:
 396                       akt = 5;
 397                       break;
 398
 399                     case 6:
 400                       akt = 3;
 401                       break;
 402
 403                     case 7:
 404                       akt = ffecom_pointer_kind ();
 405                       break;
 406                     }
 407                 }
 408               okay &= anynum || (ffeinfo_kindtype (i) == akt);
 409               break;
 410
 411             case 'A':
 412               okay &= anynum || (ffeinfo_kindtype (i) == firstarg_kt);
 413               akt = (firstarg_kt == FFEINFO_kindtype) ? FFEINFO_kindtypeNONE
 414                 : firstarg_kt;
 415               break;
 416
 417             case '*':
 418             default:
 419               break;
 420             }
 421
 422           switch (elements)
 423             {
 424               ffebld b;
 425
 426             case -1:
 427               break;
 428
 429             case 0:
 430               if (ffeinfo_rank (i) != 0)
 431                 okay = FALSE;
 432               break;
 433
 434             default:
 435               if ((ffeinfo_rank (i) != 1)
 436                   || (ffebld_op (a) != FFEBLD_opSYMTER)
 437                   || ((b = ffesymbol_arraysize (ffebld_symter (a))) == NULL)
 438                   || (ffebld_op (b) != FFEBLD_opCONTER)
 439                   || (ffeinfo_basictype (ffebld_info (b)) != FFEINFO_basictypeINTEGER)
 440                   || (ffeinfo_kindtype (ffebld_info (b)) != FFEINFO_kindtypeINTEGERDEFAULT)
 441                   || (ffebld_constant_integer1 (ffebld_conter (b)) != elements))
 442                 okay = FALSE;
 443               break;
 444             }
 445
 446           switch (extra)
 447             {
 448             case '&':
 449               if ((ffeinfo_kind (i) != FFEINFO_kindENTITY)
 450                   || ((ffebld_op (a) != FFEBLD_opSYMTER)
 451                       && (ffebld_op (a) != FFEBLD_opSUBSTR)
 452                       && (ffebld_op (a) != FFEBLD_opARRAYREF)))
 453                 okay = FALSE;
 454               break;
 455
 456             case 'w':
 457             case 'x':
 458               if ((ffeinfo_kind (i) != FFEINFO_kindENTITY)
 459                   || ((ffebld_op (a) != FFEBLD_opSYMTER)
 460                       && (ffebld_op (a) != FFEBLD_opARRAYREF)
 461                       && (ffebld_op (a) != FFEBLD_opSUBSTR)))
 462                 okay = FALSE;
 463               break;
 464
 465             case '-':
 466             case 'i':
 467               break;
 468
 469             default:
 470               if (ffeinfo_kind (i) != FFEINFO_kindENTITY)
 471                 okay = FALSE;
 472               break;
 473             }
 474
 475           if ((optional == '!')
 476               && lastarg_complex)
 477             okay = FALSE;
 478
 479           if (!okay)
 480             {
 481               /* If it wasn't optional, it's an error,
 482                  else maybe it could match a later argspec.  */
 483               if (optional == '\0')
 484                 return FFEBAD_INTRINSIC_REF;
 485               break;    /* Try next argspec. */
 486             }
 487
 488           lastarg_complex
 489             = (ffeinfo_basictype (i) == FFEINFO_basictypeCOMPLEX);
 490
 491           if (anynum)
 492             {
 493               /* If we know dummy arg type, convert to that now.  */
 494
 495               if ((abt != FFEINFO_basictypeNONE)
 496                   && (akt != FFEINFO_kindtypeNONE)
 497                   && commit)
 498                 {
 499                   /* We have a known type, convert hollerith/typeless
 500                      to it.  */
 501
 502                   a = ffeexpr_convert (a, t, NULL,
 503                                        abt, akt, 0,
 504                                        FFETARGET_charactersizeNONE,
 505                                        FFEEXPR_contextLET);
 506                   ffebld_set_head (arg, a);
 507                 }
 508             }
 509
 510           arg = ffebld_trail (arg);     /* Arg accepted, now move on. */
 511
 512           if (optional == '*')
 513             continue;   /* Go ahead and try another arg. */
 514           if (required == '\0')
 515             break;
 516           if ((required == 'n')
 517               || (required == '+'))
 518             {
 519               optional = '*';
 520               required = '\0';
 521             }
 522           else if (required == 'p')
 523             required = 'n';
 524         } while (TRUE);
 525     }
 526
 527   if (arg != NULL)
 528     return FFEBAD_INTRINSIC_TOOMANY;
 529
 530   /* Set up the initial type for the return value of the function.  */
 531
 532   need_col = FALSE;
 533   switch (c[0])
 534     {
 535     case 'A':
 536       bt = FFEINFO_basictypeCHARACTER;
 537       sz = (c[2] == '*') ? FFETARGET_charactersizeNONE : 1;
 538       break;
 539
 540     case 'C':
 541       bt = FFEINFO_basictypeCOMPLEX;
 542       break;
 543
 544     case 'I':
 545       bt = FFEINFO_basictypeINTEGER;
 546       break;
 547
 548     case 'L':
 549       bt = FFEINFO_basictypeLOGICAL;
 550       break;
 551
 552     case 'R':
 553       bt = FFEINFO_basictypeREAL;
 554       break;
 555
 556     case 'B':
 557     case 'F':
 558     case 'N':
 559     case 'S':
 560       need_col = TRUE;
 561       /* Fall through.  */
 562     case '-':
 563     default:
 564       bt = FFEINFO_basictypeNONE;
 565       break;
 566     }
 567
 568   switch (c[1])
 569     {
 570     case '1': case '2': case '3': case '4': case '5':
 571     case '6': case '7': case '8': case '9':
 572       kt = (c[1] - '0');
 573       if ((bt == FFEINFO_basictypeINTEGER)
 574           || (bt == FFEINFO_basictypeLOGICAL))
 575         {
 576           switch (kt)
 577             {   /* Translate to internal kinds for now! */
 578             default:
 579               break;
 580
 581             case 2:
 582               kt = 4;
 583               break;
 584
 585             case 3:
 586               kt = 2;
 587               break;
 588
 589             case 4:
 590               kt = 5;
 591               break;
 592
 593             case 6:
 594               kt = 3;
 595               break;
 596
 597             case 7:
 598               kt = ffecom_pointer_kind ();
 599               break;
 600             }
 601         }
 602       break;
 603
 604     case 'C':
 605       if (ffe_is_90 ())
 606         need_col = TRUE;
 607       kt = 1;
 608       break;
 609
 610     case '=':
 611       need_col = TRUE;
 612       /* Fall through.  */
 613     case '-':
 614     default:
 615       kt = FFEINFO_kindtypeNONE;
 616       break;
 617     }
 618
 619   /* Determine collective type of COL, if there is one.  */
 620
 621   if (need_col || c[colon + 1] != '-')
 622     {
 623       bool okay = TRUE;
 624       bool have_anynum = FALSE;
 625       int  arg_count=0;
 626
 627       for (arg = args, arg_count=0;
 628            arg != NULL;
 629            arg = ffebld_trail (arg), arg_count++ )
 630         {
 631           ffebld a = ffebld_head (arg);
 632           ffeinfo i;
 633           bool anynum;
 634
 635           if (a == NULL)
 636             continue;
 637           i = ffebld_info (a);
 638
 639           if ( c[colon+1] != '*' && (c[colon+1]-'0') != arg_count )
 640             continue;
 641
 642           anynum = (ffeinfo_basictype (i) == FFEINFO_basictypeHOLLERITH)
 643             || (ffeinfo_basictype (i) == FFEINFO_basictypeTYPELESS);
 644           if (anynum)
 645             {
 646               have_anynum = TRUE;
 647               continue;
 648             }
 649
 650           if ((col_bt == FFEINFO_basictypeNONE)
 651               && (col_kt == FFEINFO_kindtypeNONE))
 652             {
 653               col_bt = ffeinfo_basictype (i);
 654               col_kt = ffeinfo_kindtype (i);
 655             }
 656           else
 657             {
 658               ffeexpr_type_combine (&col_bt, &col_kt,
 659                                     col_bt, col_kt,
 660                                     ffeinfo_basictype (i),
 661                                     ffeinfo_kindtype (i),
 662                                     NULL);
 663               if ((col_bt == FFEINFO_basictypeNONE)
 664                   || (col_kt == FFEINFO_kindtypeNONE))
 665                 return FFEBAD_INTRINSIC_REF;
 666             }
 667         }
 668
 669       if (have_anynum
 670           && ((col_bt == FFEINFO_basictypeNONE)
 671               || (col_kt == FFEINFO_kindtypeNONE)))
 672         {
 673           /* No type, but have hollerith/typeless.  Use type of return
 674              value to determine type of COL.  */
 675
 676           switch (c[0])
 677             {
 678             case 'A':
 679               return FFEBAD_INTRINSIC_REF;
 680
 681             case 'B':
 682             case 'I':
 683             case 'L':
 684               if ((col_bt != FFEINFO_basictypeNONE)
 685                   && (col_bt != FFEINFO_basictypeINTEGER))
 686                 return FFEBAD_INTRINSIC_REF;
 687               /* Fall through.  */
 688             case 'N':
 689             case 'S':
 690             case '-':
 691             default:
 692               col_bt = FFEINFO_basictypeINTEGER;
 693               col_kt = FFEINFO_kindtypeINTEGER1;
 694               break;
 695
 696             case 'C':
 697               if ((col_bt != FFEINFO_basictypeNONE)
 698                   && (col_bt != FFEINFO_basictypeCOMPLEX))
 699                 return FFEBAD_INTRINSIC_REF;
 700               col_bt = FFEINFO_basictypeCOMPLEX;
 701               col_kt = FFEINFO_kindtypeREAL1;
 702               break;
 703
 704             case 'R':
 705               if ((col_bt != FFEINFO_basictypeNONE)
 706                   && (col_bt != FFEINFO_basictypeREAL))
 707                 return FFEBAD_INTRINSIC_REF;
 708               /* Fall through.  */
 709             case 'F':
 710               col_bt = FFEINFO_basictypeREAL;
 711               col_kt = FFEINFO_kindtypeREAL1;
 712               break;
 713             }
 714         }
 715
 716       switch (c[0])
 717         {
 718         case 'B':
 719           okay = (col_bt == FFEINFO_basictypeINTEGER)
 720             || (col_bt == FFEINFO_basictypeLOGICAL);
 721           if (need_col)
 722             bt = col_bt;
 723           break;
 724
 725         case 'F':
 726           okay = (col_bt == FFEINFO_basictypeCOMPLEX)
 727             || (col_bt == FFEINFO_basictypeREAL);
 728           if (need_col)
 729             bt = col_bt;
 730           break;
 731
 732         case 'N':
 733           okay = (col_bt == FFEINFO_basictypeCOMPLEX)
 734             || (col_bt == FFEINFO_basictypeINTEGER)
 735             || (col_bt == FFEINFO_basictypeREAL);
 736           if (need_col)
 737             bt = col_bt;
 738           break;
 739
 740         case 'S':
 741           okay = (col_bt == FFEINFO_basictypeINTEGER)
 742             || (col_bt == FFEINFO_basictypeREAL)
 743             || (col_bt == FFEINFO_basictypeCOMPLEX);
 744           if (need_col)
 745             bt = ((col_bt != FFEINFO_basictypeCOMPLEX) ? col_bt
 746                   : FFEINFO_basictypeREAL);
 747           break;
 748         }
 749
 750       switch (c[1])
 751         {
 752         case '=':
 753           if (need_col)
 754             kt = col_kt;
 755           break;
 756
 757         case 'C':
 758           if (col_bt == FFEINFO_basictypeCOMPLEX)
 759             {
 760               if (col_kt != FFEINFO_kindtypeREALDEFAULT)
 761                 *check_intrin = TRUE;
 762               if (need_col)
 763                 kt = col_kt;
 764             }
 765           break;
 766         }
 767
 768       if (!okay)
 769         return FFEBAD_INTRINSIC_REF;
 770     }
 771
 772   /* Now, convert args in the arglist to the final type of the COL.  */
 773
 774   for (argno = 0, argc = &c[colon + 3],
 775          arg = args;
 776        *argc != '\0';
 777        ++argno)
 778     {
 779       char optional = '\0';
 780       char required = '\0';
 781       char extra = '\0';
 782       char basic;
 783       char kind;
 784       int length;
 785       int elements;
 786       bool lastarg_complex = FALSE;
 787
 788       /* We don't do anything with keywords yet.  */
 789       do
 790         {
 791         } while (*(++argc) != '=');
 792
 793       ++argc;
 794       if ((*argc == '?')
 795           || (*argc == '!')
 796           || (*argc == '*'))
 797         optional = *(argc++);
 798       if ((*argc == '+')
 799           || (*argc == 'n')
 800           || (*argc == 'p'))
 801         required = *(argc++);
 802       basic = *(argc++);
 803       kind = *(argc++);
 804       if (*argc == '[')
 805         {
 806           length = *++argc - '0';
 807           if (*++argc != ']')
 808             length = 10 * length + (*(argc++) - '0');
 809           ++argc;
 810         }
 811       else
 812         length = -1;
 813       if (*argc == '(')
 814         {
 815           elements = *++argc - '0';
 816           if (*++argc != ')')
 817             elements = 10 * elements + (*(argc++) - '0');
 818           ++argc;
 819         }
 820       else if (*argc == '&')
 821         {
 822           elements = -1;
 823           ++argc;
 824         }
 825       else
 826         elements = 0;
 827       if ((*argc == '&')
 828           || (*argc == 'i')
 829           || (*argc == 'w')
 830           || (*argc == 'x'))
 831         extra = *(argc++);
 832       if (*argc == ',')
 833         ++argc;
 834
 835       /* Break out of this loop only when current arg spec completely
 836          processed.  */
 837
 838       do
 839         {
 840           bool okay;
 841           ffebld a;
 842           ffeinfo i;
 843           bool anynum;
 844           ffeinfoBasictype abt = FFEINFO_basictypeNONE;
 845           ffeinfoKindtype akt = FFEINFO_kindtypeNONE;
 846
 847           if ((arg == NULL)
 848               || (ffebld_head (arg) == NULL))
 849             {
 850               if (arg != NULL)
 851                 arg = ffebld_trail (arg);
 852               break;    /* Try next argspec. */
 853             }
 854
 855           a = ffebld_head (arg);
 856           i = ffebld_info (a);
 857           anynum = (ffeinfo_basictype (i) == FFEINFO_basictypeHOLLERITH)
 858             || (ffeinfo_basictype (i) == FFEINFO_basictypeTYPELESS);
 859
 860           /* Determine what the default type for anynum would be.  */
 861
 862           if (anynum)
 863             {
 864               switch (c[colon + 1])
 865                 {
 866                 case '-':
 867                   break;
 868                 case '0': case '1': case '2': case '3': case '4':
 869                 case '5': case '6': case '7': case '8': case '9':
 870                   if (argno != (c[colon + 1] - '0'))
 871                     break;
 872                 case '*':
 873                   abt = col_bt;
 874                   akt = col_kt;
 875                   break;
 876                 }
 877             }
 878
 879           /* Again, match arg up to the spec.  We go through all of
 880              this again to properly follow the contour of optional
 881              arguments.  Probably this level of flexibility is not
 882              needed, perhaps it's even downright naughty.  */
 883
 884           switch (basic)
 885             {
 886             case 'A':
 887               okay = (ffeinfo_basictype (i) == FFEINFO_basictypeCHARACTER)
 888                 && ((length == -1)
 889                     || (ffeinfo_size (i) == (ffetargetCharacterSize) length));
 890               break;
 891
 892             case 'C':
 893               okay = anynum
 894                 || (ffeinfo_basictype (i) == FFEINFO_basictypeCOMPLEX);
 895               abt = FFEINFO_basictypeCOMPLEX;
 896               break;
 897
 898             case 'I':
 899               okay = anynum
 900                 || (ffeinfo_basictype (i) == FFEINFO_basictypeINTEGER);
 901               abt = FFEINFO_basictypeINTEGER;
 902               break;
 903
 904             case 'L':
 905               okay = anynum
 906                 || (ffeinfo_basictype (i) == FFEINFO_basictypeLOGICAL);
 907               abt = FFEINFO_basictypeLOGICAL;
 908               break;
 909
 910             case 'R':
 911               okay = anynum
 912                 || (ffeinfo_basictype (i) == FFEINFO_basictypeREAL);
 913               abt = FFEINFO_basictypeREAL;
 914               break;
 915
 916             case 'B':
 917               okay = anynum
 918                 || (ffeinfo_basictype (i) == FFEINFO_basictypeINTEGER)
 919                 || (ffeinfo_basictype (i) == FFEINFO_basictypeLOGICAL);
 920               break;
 921
 922             case 'F':
 923               okay = anynum
 924                 || (ffeinfo_basictype (i) == FFEINFO_basictypeCOMPLEX)
 925                 || (ffeinfo_basictype (i) == FFEINFO_basictypeREAL);
 926               break;
 927
 928             case 'N':
 929               okay = anynum
 930                 || (ffeinfo_basictype (i) == FFEINFO_basictypeCOMPLEX)
 931                 || (ffeinfo_basictype (i) == FFEINFO_basictypeINTEGER)
 932                 || (ffeinfo_basictype (i) == FFEINFO_basictypeREAL);
 933               break;
 934
 935             case 'S':
 936               okay = anynum
 937                 || (ffeinfo_basictype (i) == FFEINFO_basictypeINTEGER)
 938                 || (ffeinfo_basictype (i) == FFEINFO_basictypeREAL);
 939               break;
 940
 941             case 'g':
 942               okay = ((ffebld_op (a) == FFEBLD_opLABTER)
 943                       || (ffebld_op (a) == FFEBLD_opLABTOK));
 944               elements = -1;
 945               extra = '-';
 946               break;
 947
 948             case 's':
 949               okay = (((((ffeinfo_basictype (i) == FFEINFO_basictypeNONE)
 950                          && (ffeinfo_kindtype (i) == FFEINFO_kindtypeNONE)
 951                          && (ffeinfo_kind (i) == FFEINFO_kindSUBROUTINE))
 952                         || ((ffeinfo_basictype (i) == FFEINFO_basictypeINTEGER)
 953                             && (ffeinfo_kindtype (i) == FFEINFO_kindtypeINTEGERDEFAULT)
 954                             && (ffeinfo_kind (i) == FFEINFO_kindFUNCTION))
 955                         || (ffeinfo_kind (i) == FFEINFO_kindNONE))
 956                        && ((ffeinfo_where (i) == FFEINFO_whereDUMMY)
 957                            || (ffeinfo_where (i) == FFEINFO_whereGLOBAL)))
 958                       || ((ffeinfo_basictype (i) == FFEINFO_basictypeINTEGER)
 959                           && (ffeinfo_kind (i) == FFEINFO_kindENTITY)));
 960               elements = -1;
 961               extra = '-';
 962               break;
 963
 964             case '-':
 965             default:
 966               okay = TRUE;
 967               break;
 968             }
 969
 970           switch (kind)
 971             {
 972             case '1': case '2': case '3': case '4': case '5':
 973             case '6': case '7': case '8': case '9':
 974               akt = (kind - '0');
 975               if ((ffeinfo_basictype (i) == FFEINFO_basictypeINTEGER)
 976                   || (ffeinfo_basictype (i) == FFEINFO_basictypeLOGICAL))
 977                 {
 978                   switch (akt)
 979                     {   /* Translate to internal kinds for now! */
 980                     default:
 981                       break;
 982
 983                     case 2:
 984                       akt = 4;
 985                       break;
 986
 987                     case 3:
 988                       akt = 2;
 989                       break;
 990
 991                     case 4:
 992                       akt = 5;
 993                       break;
 994
 995                     case 6:
 996                       akt = 3;
 997                       break;
 998
 999                     case 7:
1000                       akt = ffecom_pointer_kind ();
1001                       break;
1002                     }
1003                 }
1004               okay &= anynum || (ffeinfo_kindtype (i) == akt);
1005               break;
1006
1007             case 'A':
1008               okay &= anynum || (ffeinfo_kindtype (i) == firstarg_kt);
1009               akt = (firstarg_kt == FFEINFO_kindtype) ? FFEINFO_kindtypeNONE
1010                 : firstarg_kt;
1011               break;
1012
1013             case '*':
1014             default:
1015               break;
1016             }
1017
1018           switch (elements)
1019             {
1020               ffebld b;
1021
1022             case -1:
1023               break;
1024
1025             case 0:
1026               if (ffeinfo_rank (i) != 0)
1027                 okay = FALSE;
1028               break;
1029
1030             default:
1031               if ((ffeinfo_rank (i) != 1)
1032                   || (ffebld_op (a) != FFEBLD_opSYMTER)
1033                   || ((b = ffesymbol_arraysize (ffebld_symter (a))) == NULL)
1034                   || (ffebld_op (b) != FFEBLD_opCONTER)
1035                   || (ffeinfo_basictype (ffebld_info (b)) != FFEINFO_basictypeINTEGER)
1036                   || (ffeinfo_kindtype (ffebld_info (b)) != FFEINFO_kindtypeINTEGERDEFAULT)
1037                   || (ffebld_constant_integer1 (ffebld_conter (b)) != elements))
1038                 okay = FALSE;
1039               break;
1040             }
1041
1042           switch (extra)
1043             {
1044             case '&':
1045               if ((ffeinfo_kind (i) != FFEINFO_kindENTITY)
1046                   || ((ffebld_op (a) != FFEBLD_opSYMTER)
1047                       && (ffebld_op (a) != FFEBLD_opSUBSTR)
1048                       && (ffebld_op (a) != FFEBLD_opARRAYREF)))
1049                 okay = FALSE;
1050               break;
1051
1052             case 'w':
1053             case 'x':
1054               if ((ffeinfo_kind (i) != FFEINFO_kindENTITY)
1055                   || ((ffebld_op (a) != FFEBLD_opSYMTER)
1056                       && (ffebld_op (a) != FFEBLD_opARRAYREF)
1057                       && (ffebld_op (a) != FFEBLD_opSUBSTR)))
1058                 okay = FALSE;
1059               break;
1060
1061             case '-':
1062             case 'i':
1063               break;
1064
1065             default:
1066               if (ffeinfo_kind (i) != FFEINFO_kindENTITY)
1067                 okay = FALSE;
1068               break;
1069             }
1070
1071           if ((optional == '!')
1072               && lastarg_complex)
1073             okay = FALSE;
1074
1075           if (!okay)
1076             {
1077               /* If it wasn't optional, it's an error,
1078                  else maybe it could match a later argspec.  */
1079               if (optional == '\0')
1080                 return FFEBAD_INTRINSIC_REF;
1081               break;    /* Try next argspec. */
1082             }
1083
1084           lastarg_complex
1085             = (ffeinfo_basictype (i) == FFEINFO_basictypeCOMPLEX);
1086
1087           if (anynum && commit)
1088             {
1089               /* If we know dummy arg type, convert to that now.  */
1090
1091               if (abt == FFEINFO_basictypeNONE)
1092                 abt = FFEINFO_basictypeINTEGER;
1093               if (akt == FFEINFO_kindtypeNONE)
1094                 akt = FFEINFO_kindtypeINTEGER1;
1095
1096               /* We have a known type, convert hollerith/typeless to it.  */
1097
1098               a = ffeexpr_convert (a, t, NULL,
1099                                    abt, akt, 0,
1100                                    FFETARGET_charactersizeNONE,
1101                                    FFEEXPR_contextLET);
1102               ffebld_set_head (arg, a);
1103             }
1104           else if ((c[colon + 1] == '*') && commit)
1105             {
1106               /* This is where we promote types to the consensus
1107                  type for the COL.  Maybe this is where -fpedantic
1108                  should issue a warning as well.  */
1109
1110               a = ffeexpr_convert (a, t, NULL,
1111                                    col_bt, col_kt, 0,
1112                                    ffeinfo_size (i),
1113                                    FFEEXPR_contextLET);
1114               ffebld_set_head (arg, a);
1115             }
1116
1117           arg = ffebld_trail (arg);     /* Arg accepted, now move on. */
1118
1119           if (optional == '*')
1120             continue;   /* Go ahead and try another arg. */
1121           if (required == '\0')
1122             break;
1123           if ((required == 'n')
1124               || (required == '+'))
1125             {
1126               optional = '*';
1127               required = '\0';
1128             }
1129           else if (required == 'p')
1130             required = 'n';
1131         } while (TRUE);
1132     }
1133
1134   *xbt = bt;
1135   *xkt = kt;
1136   *xsz = sz;
1137   return FFEBAD;
1138 }
1139
1140 static bool
1141 ffeintrin_check_any_ (ffebld arglist)
1142 {
1143   ffebld item;
1144
1145   for (; arglist != NULL; arglist = ffebld_trail (arglist))
1146     {
1147       item = ffebld_head (arglist);
1148       if ((item != NULL)
1149           && (ffebld_op (item) == FFEBLD_opANY))
1150         return TRUE;
1151     }
1152
1153   return FALSE;
1154 }
1155
1156 /* Compare a forced-to-uppercase name with a known-upper-case name.  */
1157
1158 static int
1159 upcasecmp_ (const char *name, const char *ucname)
1160 {
1161   for ( ; *name != 0 && *ucname != 0; name++, ucname++)
1162     {
1163       int i = TOUPPER(*name) - *ucname;
1164
1165       if (i != 0)
1166         return i;
1167     }
1168
1169   return *name - *ucname;
1170 }
1171
1172 /* Compare name to intrinsic's name.
1173    The intrinsics table is sorted on the upper case entries; so first
1174    compare irrespective of case on the `uc' entry.  If it matches,
1175    compare according to the setting of intrinsics case comparison mode.  */
1176
1177 static int
1178 ffeintrin_cmp_name_ (const void *name, const void *intrinsic)
1179 {
1180   const char *const uc = ((const struct _ffeintrin_name_ *) intrinsic)->name_uc;
1181   const char *const lc = ((const struct _ffeintrin_name_ *) intrinsic)->name_lc;
1182   const char *const ic = ((const struct _ffeintrin_name_ *) intrinsic)->name_ic;
1183   int i;
1184
1185   if ((i = upcasecmp_ (name, uc)) == 0)
1186     {
1187       switch (ffe_case_intrin ())
1188         {
1189         case FFE_caseLOWER:
1190           return strcmp(name, lc);
1191         case FFE_caseINITCAP:
1192           return strcmp(name, ic);
1193         default:
1194           return 0;
1195         }
1196     }
1197
1198   return i;
1199 }
1200
1201 /* Return basic type of intrinsic implementation, based on its
1202    run-time implementation *only*.  (This is used only when
1203    the type of an intrinsic name is needed without having a
1204    list of arguments, i.e. an interface signature, such as when
1205    passing the intrinsic itself, or really the run-time-library
1206    function, as an argument.)
1207
1208    If there's no eligible intrinsic implementation, there must be
1209    a bug somewhere else; no such reference should have been permitted
1210    to go this far.  (Well, this might be wrong.)  */
1211
1212 ffeinfoBasictype
1213 ffeintrin_basictype (ffeintrinSpec spec)
1214 {
1215   ffeintrinImp imp;
1216   ffecomGfrt gfrt;
1217
1218   assert (spec < FFEINTRIN_spec);
1219   imp = ffeintrin_specs_[spec].implementation;
1220   assert (imp < FFEINTRIN_imp);
1221
1222   if (ffe_is_f2c ())
1223     gfrt = ffeintrin_imps_[imp].gfrt_f2c;
1224   else
1225     gfrt = ffeintrin_imps_[imp].gfrt_gnu;
1226
1227   assert (gfrt != FFECOM_gfrt);
1228
1229   return ffecom_gfrt_basictype (gfrt);
1230 }
1231
1232 /* Return family to which specific intrinsic belongs.  */
1233
1234 ffeintrinFamily
1235 ffeintrin_family (ffeintrinSpec spec)
1236 {
1237   if (spec >= FFEINTRIN_spec)
1238     return FALSE;
1239   return ffeintrin_specs_[spec].family;
1240 }
1241
1242 /* Check and fill in info on func/subr ref node.
1243
1244    ffebld expr;                 // FUNCREF or SUBRREF with no info (caller
1245                                 // gets it from the modified info structure).
1246    ffeinfo info;                // Already filled in, will be overwritten.
1247    ffelexToken token;           // Used for error message.
1248    ffeintrin_fulfill_generic (&expr, &info, token);
1249
1250    Based on the generic id, figure out which specific procedure is meant and
1251    pick that one.  Else return an error, a la _specific.  */
1252
1253 void
1254 ffeintrin_fulfill_generic (ffebld *expr, ffeinfo *info, ffelexToken t)
1255 {
1256   ffebld symter;
1257   ffebldOp op;
1258   ffeintrinGen gen;
1259   ffeintrinSpec spec = FFEINTRIN_specNONE;
1260   ffeinfoBasictype bt = FFEINFO_basictypeNONE;
1261   ffeinfoKindtype kt = FFEINFO_kindtypeNONE;
1262   ffetargetCharacterSize sz = FFETARGET_charactersizeNONE;
1263   ffeintrinImp imp;
1264   ffeintrinSpec tspec;
1265   ffeintrinImp nimp = FFEINTRIN_impNONE;
1266   ffebad error;
1267   bool any = FALSE;
1268   bool highly_specific = FALSE;
1269   int i;
1270
1271   op = ffebld_op (*expr);
1272   assert ((op == FFEBLD_opFUNCREF) || (op == FFEBLD_opSUBRREF));
1273   assert (ffebld_op (ffebld_left (*expr)) == FFEBLD_opSYMTER);
1274
1275   gen = ffebld_symter_generic (ffebld_left (*expr));
1276   assert (gen != FFEINTRIN_genNONE);
1277
1278   imp = FFEINTRIN_impNONE;
1279   error = FFEBAD;
1280
1281   any = ffeintrin_check_any_ (ffebld_right (*expr));
1282
1283   for (i = 0;
1284        (((size_t) i) < ARRAY_SIZE (ffeintrin_gens_[gen].specs))
1285          && ((tspec = ffeintrin_gens_[gen].specs[i]) != FFEINTRIN_specNONE)
1286          && !any;
1287        ++i)
1288     {
1289       ffeintrinImp timp = ffeintrin_specs_[tspec].implementation;
1290       ffeinfoBasictype tbt;
1291       ffeinfoKindtype tkt;
1292       ffetargetCharacterSize tsz;
1293       ffeIntrinsicState state
1294       = ffeintrin_state_family (ffeintrin_specs_[tspec].family);
1295       ffebad terror;
1296
1297       if (state == FFE_intrinsicstateDELETED)
1298         continue;
1299
1300       if (timp != FFEINTRIN_impNONE)
1301         {
1302           if (!(ffeintrin_imps_[timp].control[0] == '-')
1303               != !(ffebld_op (*expr) == FFEBLD_opSUBRREF))
1304             continue;           /* Form of reference must match form of specific. */
1305         }
1306
1307       if (state == FFE_intrinsicstateDISABLED)
1308         terror = FFEBAD_INTRINSIC_DISABLED;
1309       else if (timp == FFEINTRIN_impNONE)
1310         terror = FFEBAD_INTRINSIC_UNIMPL;
1311       else
1312         {
1313           terror = ffeintrin_check_ (timp, ffebld_op (*expr),
1314                                      ffebld_right (*expr),
1315                                      &tbt, &tkt, &tsz, NULL, t, FALSE);
1316           if (terror == FFEBAD)
1317             {
1318               if (imp != FFEINTRIN_impNONE)
1319                 {
1320                   ffebad_start (FFEBAD_INTRINSIC_AMBIG);
1321                   ffebad_here (0, ffelex_token_where_line (t),
1322                                ffelex_token_where_column (t));
1323                   ffebad_string (ffeintrin_gens_[gen].name);
1324                   ffebad_string (ffeintrin_specs_[spec].name);
1325                   ffebad_string (ffeintrin_specs_[tspec].name);
1326                   ffebad_finish ();
1327                 }
1328               else
1329                 {
1330                   if (ffebld_symter_specific (ffebld_left (*expr))
1331                       == tspec)
1332                     highly_specific = TRUE;
1333                   imp = timp;
1334                   spec = tspec;
1335                   bt = tbt;
1336                   kt = tkt;
1337                   sz = tkt;
1338                   error = terror;
1339                 }
1340             }
1341           else if (terror != FFEBAD)
1342             {                   /* This error has precedence over others. */
1343               if ((error == FFEBAD_INTRINSIC_DISABLED)
1344                   || (error == FFEBAD_INTRINSIC_UNIMPL))
1345                 error = FFEBAD;
1346             }
1347         }
1348
1349       if (error == FFEBAD)
1350         error = terror;
1351     }
1352
1353   if (any || (imp == FFEINTRIN_impNONE))
1354     {
1355       if (!any)
1356         {
1357           if (error == FFEBAD)
1358             error = FFEBAD_INTRINSIC_REF;
1359           ffebad_start (error);
1360           ffebad_here (0, ffelex_token_where_line (t),
1361                        ffelex_token_where_column (t));
1362           ffebad_string (ffeintrin_gens_[gen].name);
1363           ffebad_finish ();
1364         }
1365
1366       *expr = ffebld_new_any ();
1367       *info = ffeinfo_new_any ();
1368     }
1369   else
1370     {
1371       if (!highly_specific && (nimp != FFEINTRIN_impNONE))
1372         {
1373           fprintf (stderr, "lineno=%ld, gen=%s, imp=%s, timp=%s\n",
1374                    (long) lineno,
1375                    ffeintrin_gens_[gen].name,
1376                    ffeintrin_imps_[imp].name,
1377                    ffeintrin_imps_[nimp].name);
1378           assert ("Ambiguous generic reference" == NULL);
1379           abort ();
1380         }
1381       error = ffeintrin_check_ (imp, ffebld_op (*expr),
1382                                 ffebld_right (*expr),
1383                                 &bt, &kt, &sz, NULL, t, TRUE);
1384       assert (error == FFEBAD);
1385       *info = ffeinfo_new (bt,
1386                            kt,
1387                            0,
1388                            FFEINFO_kindENTITY,
1389                            FFEINFO_whereFLEETING,
1390                            sz);
1391       symter = ffebld_left (*expr);
1392       ffebld_symter_set_specific (symter, spec);
1393       ffebld_symter_set_implementation (symter, imp);
1394       ffebld_set_info (symter,
1395                        ffeinfo_new (bt,
1396                                     kt,
1397                                     0,
1398                                     (bt == FFEINFO_basictypeNONE)
1399                                     ? FFEINFO_kindSUBROUTINE
1400                                     : FFEINFO_kindFUNCTION,
1401                                     FFEINFO_whereINTRINSIC,
1402                                     sz));
1403
1404       if ((ffesymbol_attrs (ffebld_symter (symter)) & FFESYMBOL_attrsTYPE)
1405           && (((bt != ffesymbol_basictype (ffebld_symter (symter)))
1406                || (kt != ffesymbol_kindtype (ffebld_symter (symter)))
1407                || ((sz != FFETARGET_charactersizeNONE)
1408                    && (sz != ffesymbol_size (ffebld_symter (symter)))))))
1409         {
1410           ffebad_start (FFEBAD_INTRINSIC_TYPE);
1411           ffebad_here (0, ffelex_token_where_line (t),
1412                        ffelex_token_where_column (t));
1413           ffebad_string (ffeintrin_gens_[gen].name);
1414           ffebad_finish ();
1415         }
1416       if (ffeintrin_imps_[imp].y2kbad)
1417         {
1418           ffebad_start (FFEBAD_INTRINSIC_Y2KBAD);
1419           ffebad_here (0, ffelex_token_where_line (t),
1420                        ffelex_token_where_column (t));
1421           ffebad_string (ffeintrin_gens_[gen].name);
1422           ffebad_finish ();
1423         }
1424     }
1425 }
1426
1427 /* Check and fill in info on func/subr ref node.
1428
1429    ffebld expr;                 // FUNCREF or SUBRREF with no info (caller
1430                                 // gets it from the modified info structure).
1431    ffeinfo info;                // Already filled in, will be overwritten.
1432    bool check_intrin;           // May be omitted, else set TRUE if intrinsic needs checking.
1433    ffelexToken token;           // Used for error message.
1434    ffeintrin_fulfill_specific (&expr, &info, &check_intrin, token);
1435
1436    Based on the specific id, determine whether the arg list is valid
1437    (number, type, rank, and kind of args) and fill in the info structure
1438    accordingly.  Currently don't rewrite the expression, but perhaps
1439    someday do so for constant collapsing, except when an error occurs,
1440    in which case it is overwritten with ANY and info is also overwritten
1441    accordingly.  */
1442
1443 void
1444 ffeintrin_fulfill_specific (ffebld *expr, ffeinfo *info,
1445                             bool *check_intrin, ffelexToken t)
1446 {
1447   ffebld symter;
1448   ffebldOp op;
1449   ffeintrinGen gen;
1450   ffeintrinSpec spec;
1451   ffeintrinImp imp;
1452   ffeinfoBasictype bt = FFEINFO_basictypeNONE;
1453   ffeinfoKindtype kt = FFEINFO_kindtypeNONE;
1454   ffetargetCharacterSize sz = FFETARGET_charactersizeNONE;
1455   ffeIntrinsicState state;
1456   ffebad error;
1457   bool any = FALSE;
1458   const char *name;
1459
1460   op = ffebld_op (*expr);
1461   assert ((op == FFEBLD_opFUNCREF) || (op == FFEBLD_opSUBRREF));
1462   assert (ffebld_op (ffebld_left (*expr)) == FFEBLD_opSYMTER);
1463
1464   gen = ffebld_symter_generic (ffebld_left (*expr));
1465   spec = ffebld_symter_specific (ffebld_left (*expr));
1466   assert (spec != FFEINTRIN_specNONE);
1467
1468   if (gen != FFEINTRIN_genNONE)
1469     name = ffeintrin_gens_[gen].name;
1470   else
1471     name = ffeintrin_specs_[spec].name;
1472
1473   state = ffeintrin_state_family (ffeintrin_specs_[spec].family);
1474
1475   imp = ffeintrin_specs_[spec].implementation;
1476   if (check_intrin != NULL)
1477     *check_intrin = FALSE;
1478
1479   any = ffeintrin_check_any_ (ffebld_right (*expr));
1480
1481   if (state == FFE_intrinsicstateDISABLED)
1482     error = FFEBAD_INTRINSIC_DISABLED;
1483   else if (imp == FFEINTRIN_impNONE)
1484     error = FFEBAD_INTRINSIC_UNIMPL;
1485   else if (!any)
1486     {
1487       error = ffeintrin_check_ (imp, ffebld_op (*expr),
1488                                 ffebld_right (*expr),
1489                                 &bt, &kt, &sz, check_intrin, t, TRUE);
1490     }
1491   else
1492     error = FFEBAD;     /* Not really needed, but quiet -Wuninitialized. */
1493
1494   if (any || (error != FFEBAD))
1495     {
1496       if (!any)
1497         {
1498
1499           ffebad_start (error);
1500           ffebad_here (0, ffelex_token_where_line (t),
1501                        ffelex_token_where_column (t));
1502           ffebad_string (name);
1503           ffebad_finish ();
1504         }
1505
1506       *expr = ffebld_new_any ();
1507       *info = ffeinfo_new_any ();
1508     }
1509   else
1510     {
1511       *info = ffeinfo_new (bt,
1512                            kt,
1513                            0,
1514                            FFEINFO_kindENTITY,
1515                            FFEINFO_whereFLEETING,
1516                            sz);
1517       symter = ffebld_left (*expr);
1518       ffebld_set_info (symter,
1519                        ffeinfo_new (bt,
1520                                     kt,
1521                                     0,
1522                                     (bt == FFEINFO_basictypeNONE)
1523                                     ? FFEINFO_kindSUBROUTINE
1524                                     : FFEINFO_kindFUNCTION,
1525                                     FFEINFO_whereINTRINSIC,
1526                                     sz));
1527
1528       if ((ffesymbol_attrs (ffebld_symter (symter)) & FFESYMBOL_attrsTYPE)
1529           && (((bt != ffesymbol_basictype (ffebld_symter (symter)))
1530                || (kt != ffesymbol_kindtype (ffebld_symter (symter)))
1531                || (sz != ffesymbol_size (ffebld_symter (symter))))))
1532         {
1533           ffebad_start (FFEBAD_INTRINSIC_TYPE);
1534           ffebad_here (0, ffelex_token_where_line (t),
1535                        ffelex_token_where_column (t));
1536           ffebad_string (name);
1537           ffebad_finish ();
1538         }
1539       if (ffeintrin_imps_[imp].y2kbad)
1540         {
1541           ffebad_start (FFEBAD_INTRINSIC_Y2KBAD);
1542           ffebad_here (0, ffelex_token_where_line (t),
1543                        ffelex_token_where_column (t));
1544           ffebad_string (name);
1545           ffebad_finish ();
1546         }
1547     }
1548 }
1549
1550 /* Return run-time index of intrinsic implementation as direct call.  */
1551
1552 ffecomGfrt
1553 ffeintrin_gfrt_direct (ffeintrinImp imp)
1554 {
1555   assert (imp < FFEINTRIN_imp);
1556
1557   return ffeintrin_imps_[imp].gfrt_direct;
1558 }
1559
1560 /* Return run-time index of intrinsic implementation as actual argument.  */
1561
1562 ffecomGfrt
1563 ffeintrin_gfrt_indirect (ffeintrinImp imp)
1564 {
1565   assert (imp < FFEINTRIN_imp);
1566
1567   if (! ffe_is_f2c ())
1568     return ffeintrin_imps_[imp].gfrt_gnu;
1569   return ffeintrin_imps_[imp].gfrt_f2c;
1570 }
1571
1572 void
1573 ffeintrin_init_0 ()
1574 {
1575   int i;
1576   const char *p1;
1577   const char *p2;
1578   const char *p3;
1579   int colon;
1580
1581   if (!ffe_is_do_internal_checks ())
1582     return;
1583
1584   assert (FFEINTRIN_gen == ARRAY_SIZE (ffeintrin_gens_));
1585   assert (FFEINTRIN_imp == ARRAY_SIZE (ffeintrin_imps_));
1586   assert (FFEINTRIN_spec == ARRAY_SIZE (ffeintrin_specs_));
1587
1588   for (i = 1; ((size_t) i) < ARRAY_SIZE (ffeintrin_names_); ++i)
1589     {                           /* Make sure binary-searched list is in alpha
1590                                    order. */
1591       if (strcmp (ffeintrin_names_[i - 1].name_uc,
1592                   ffeintrin_names_[i].name_uc) >= 0)
1593         assert ("name list out of order" == NULL);
1594     }
1595
1596   for (i = 0; ((size_t) i) < ARRAY_SIZE (ffeintrin_names_); ++i)
1597     {
1598       assert ((ffeintrin_names_[i].generic == FFEINTRIN_genNONE)
1599               || (ffeintrin_names_[i].specific == FFEINTRIN_specNONE));
1600
1601       p1 = ffeintrin_names_[i].name_uc;
1602       p2 = ffeintrin_names_[i].name_lc;
1603       p3 = ffeintrin_names_[i].name_ic;
1604       for (; *p1 != '\0' && *p2 != '\0' && *p3 != '\0'; ++p1, ++p2, ++p3)
1605         {
1606           if ((ISDIGIT (*p1) || (*p1 == '_')) && (*p1 == *p2) && (*p1 == *p3))
1607             continue;
1608           if (! ISUPPER ((unsigned char)*p1) || ! ISLOWER ((unsigned char)*p2)
1609               || (*p1 != TOUPPER (*p2))
1610               || ((*p3 != *p1) && (*p3 != *p2)))
1611             break;
1612         }
1613       assert ((*p1 == *p2) && (*p1 == *p3) && (*p1 == '\0'));
1614     }
1615
1616   for (i = 0; ((size_t) i) < ARRAY_SIZE (ffeintrin_imps_); ++i)
1617     {
1618       const char *c = ffeintrin_imps_[i].control;
1619
1620       if (c[0] == '\0')
1621         continue;
1622
1623       if ((c[0] != '-')
1624           && (c[0] != 'A')
1625           && (c[0] != 'C')
1626           && (c[0] != 'I')
1627           && (c[0] != 'L')
1628           && (c[0] != 'R')
1629           && (c[0] != 'B')
1630           && (c[0] != 'F')
1631           && (c[0] != 'N')
1632           && (c[0] != 'S'))
1633         {
1634           fprintf (stderr, "%s: bad return-base-type\n",
1635                    ffeintrin_imps_[i].name);
1636           continue;
1637         }
1638       if ((c[1] != '-')
1639           && (c[1] != '=')
1640           && ((c[1] < '1')
1641               || (c[1] > '9'))
1642           && (c[1] != 'C'))
1643         {
1644           fprintf (stderr, "%s: bad return-kind-type\n",
1645                    ffeintrin_imps_[i].name);
1646           continue;
1647         }
1648       if (c[2] == ':')
1649         colon = 2;
1650       else
1651         {
1652           if (c[2] != '*')
1653             {
1654               fprintf (stderr, "%s: bad return-modifier\n",
1655                        ffeintrin_imps_[i].name);
1656               continue;
1657             }
1658           colon = 3;
1659         }
1660       if ((c[colon] != ':') || (c[colon + 2] != ':'))
1661         {
1662           fprintf (stderr, "%s: bad control\n",
1663                    ffeintrin_imps_[i].name);
1664           continue;
1665         }
1666       if ((c[colon + 1] != '-')
1667           && (c[colon + 1] != '*')
1668           && (! ISDIGIT (c[colon + 1])))
1669         {
1670           fprintf (stderr, "%s: bad COL-spec\n",
1671                    ffeintrin_imps_[i].name);
1672           continue;
1673         }
1674       c += (colon + 3);
1675       while (c[0] != '\0')
1676         {
1677           while ((c[0] != '=')
1678                  && (c[0] != ',')
1679                  && (c[0] != '\0'))
1680             ++c;
1681           if (c[0] != '=')
1682             {
1683               fprintf (stderr, "%s: bad keyword\n",
1684                        ffeintrin_imps_[i].name);
1685               break;
1686             }
1687           if ((c[1] == '?')
1688               || (c[1] == '!')
1689               || (c[1] == '+')
1690               || (c[1] == '*')
1691               || (c[1] == 'n')
1692               || (c[1] == 'p'))
1693             ++c;
1694           if ((c[1] != '-')
1695               && (c[1] != 'A')
1696               && (c[1] != 'C')
1697               && (c[1] != 'I')
1698               && (c[1] != 'L')
1699               && (c[1] != 'R')
1700               && (c[1] != 'B')
1701               && (c[1] != 'F')
1702               && (c[1] != 'N')
1703               && (c[1] != 'S')
1704               && (c[1] != 'g')
1705               && (c[1] != 's'))
1706             {
1707               fprintf (stderr, "%s: bad arg-base-type\n",
1708                        ffeintrin_imps_[i].name);
1709               break;
1710             }
1711           if ((c[2] != '*')
1712               && ((c[2] < '1')
1713                   || (c[2] > '9'))
1714               && (c[2] != 'A'))
1715             {
1716               fprintf (stderr, "%s: bad arg-kind-type\n",
1717                        ffeintrin_imps_[i].name);
1718               break;
1719             }
1720           if (c[3] == '[')
1721             {
1722               if ((! ISDIGIT (c[4]))
1723                   || ((c[5] != ']')
1724                       && (++c, ! ISDIGIT (c[4])
1725                           || (c[5] != ']'))))
1726                 {
1727                   fprintf (stderr, "%s: bad arg-len\n",
1728                            ffeintrin_imps_[i].name);
1729                   break;
1730                 }
1731               c += 3;
1732             }
1733           if (c[3] == '(')
1734             {
1735               if ((! ISDIGIT (c[4]))
1736                   || ((c[5] != ')')
1737                       && (++c, ! ISDIGIT (c[4])
1738                           || (c[5] != ')'))))
1739                 {
1740                   fprintf (stderr, "%s: bad arg-rank\n",
1741                            ffeintrin_imps_[i].name);
1742                   break;
1743                 }
1744               c += 3;
1745             }
1746           else if ((c[3] == '&')
1747                    && (c[4] == '&'))
1748             ++c;
1749           if ((c[3] == '&')
1750               || (c[3] == 'i')
1751               || (c[3] == 'w')
1752               || (c[3] == 'x'))
1753             ++c;
1754           if (c[3] == ',')
1755             {
1756               c += 4;
1757               continue;
1758             }
1759           if (c[3] != '\0')
1760             {
1761               fprintf (stderr, "%s: bad arg-list\n",
1762                        ffeintrin_imps_[i].name);
1763             }
1764           break;
1765         }
1766     }
1767 }
1768
1769 /* Determine whether intrinsic is okay as an actual argument.  */
1770
1771 bool
1772 ffeintrin_is_actualarg (ffeintrinSpec spec)
1773 {
1774   ffeIntrinsicState state;
1775
1776   if (spec >= FFEINTRIN_spec)
1777     return FALSE;
1778
1779   state = ffeintrin_state_family (ffeintrin_specs_[spec].family);
1780
1781   return (!ffe_is_pedantic () || ffeintrin_specs_[spec].is_actualarg)
1782     && (ffe_is_f2c ()
1783         ? (ffeintrin_imps_[ffeintrin_specs_[spec].implementation].gfrt_f2c
1784            != FFECOM_gfrt)
1785         : (ffeintrin_imps_[ffeintrin_specs_[spec].implementation].gfrt_gnu
1786            != FFECOM_gfrt))
1787     && ((state == FFE_intrinsicstateENABLED)
1788         || (state == FFE_intrinsicstateHIDDEN));
1789 }
1790
1791 /* Determine if name is intrinsic, return info.
1792
1793    const char *name;            // C-string name of possible intrinsic.
1794    ffelexToken t;               // NULL if no diagnostic to be given.
1795    bool explicit;               // TRUE if INTRINSIC name.
1796    ffeintrinGen gen;            // (TRUE only) Generic id of intrinsic.
1797    ffeintrinSpec spec;          // (TRUE only) Specific id of intrinsic.
1798    ffeintrinImp imp;            // (TRUE only) Implementation id of intrinsic.
1799    if (ffeintrin_is_intrinsic (name, t, explicit,
1800                                &gen, &spec, &imp))
1801                                 // is an intrinsic, use gen, spec, imp, and
1802                                 // kind accordingly.  */
1803
1804 bool
1805 ffeintrin_is_intrinsic (const char *name, ffelexToken t, bool explicit,
1806                         ffeintrinGen *xgen, ffeintrinSpec *xspec,
1807                         ffeintrinImp *ximp)
1808 {
1809   struct _ffeintrin_name_ *intrinsic;
1810   ffeintrinGen gen;
1811   ffeintrinSpec spec;
1812   ffeintrinImp imp;
1813   ffeIntrinsicState state;
1814   bool disabled = FALSE;
1815   bool unimpl = FALSE;
1816
1817   intrinsic = bsearch (name, &ffeintrin_names_[0],
1818                        ARRAY_SIZE (ffeintrin_names_),
1819                        sizeof (struct _ffeintrin_name_),
1820                          (void *) ffeintrin_cmp_name_);
1821
1822   if (intrinsic == NULL)
1823     return FALSE;
1824
1825   gen = intrinsic->generic;
1826   spec = intrinsic->specific;
1827   imp = ffeintrin_specs_[spec].implementation;
1828
1829   /* Generic is okay only if at least one of its specifics is okay.  */
1830
1831   if (gen != FFEINTRIN_genNONE)
1832     {
1833       int i;
1834       ffeintrinSpec tspec;
1835       bool ok = FALSE;
1836
1837       name = ffeintrin_gens_[gen].name;
1838
1839       for (i = 0;
1840            (((size_t) i) < ARRAY_SIZE (ffeintrin_gens_[gen].specs))
1841            && ((tspec
1842                 = ffeintrin_gens_[gen].specs[i]) != FFEINTRIN_specNONE);
1843            ++i)
1844         {
1845           state = ffeintrin_state_family (ffeintrin_specs_[tspec].family);
1846
1847           if (state == FFE_intrinsicstateDELETED)
1848             continue;
1849
1850           if (state == FFE_intrinsicstateDISABLED)
1851             {
1852               disabled = TRUE;
1853               continue;
1854             }
1855
1856           if (ffeintrin_specs_[tspec].implementation == FFEINTRIN_impNONE)
1857             {
1858               unimpl = TRUE;
1859               continue;
1860             }
1861
1862           if ((state == FFE_intrinsicstateENABLED)
1863               || (explicit
1864                   && (state == FFE_intrinsicstateHIDDEN)))
1865             {
1866               ok = TRUE;
1867               break;
1868             }
1869         }
1870       if (!ok)
1871         gen = FFEINTRIN_genNONE;
1872     }
1873
1874   /* Specific is okay only if not: unimplemented, disabled, deleted, or
1875      hidden and not explicit.  */
1876
1877   if (spec != FFEINTRIN_specNONE)
1878     {
1879       if (gen != FFEINTRIN_genNONE)
1880         name = ffeintrin_gens_[gen].name;
1881       else
1882         name = ffeintrin_specs_[spec].name;
1883
1884       if (((state = ffeintrin_state_family (ffeintrin_specs_[spec].family))
1885            == FFE_intrinsicstateDELETED)
1886           || (!explicit
1887               && (state == FFE_intrinsicstateHIDDEN)))
1888         spec = FFEINTRIN_specNONE;
1889       else if (state == FFE_intrinsicstateDISABLED)
1890         {
1891           disabled = TRUE;
1892           spec = FFEINTRIN_specNONE;
1893         }
1894       else if (imp == FFEINTRIN_impNONE)
1895         {
1896           unimpl = TRUE;
1897           spec = FFEINTRIN_specNONE;
1898         }
1899     }
1900
1901   /* If neither is okay, not an intrinsic.  */
1902
1903   if ((gen == FFEINTRIN_genNONE) && (spec == FFEINTRIN_specNONE))
1904     {
1905       /* Here is where we produce a diagnostic about a reference to a
1906          disabled or unimplemented intrinsic, if the diagnostic is desired.  */
1907
1908       if ((disabled || unimpl)
1909           && (t != NULL))
1910         {
1911           ffebad_start (disabled
1912                         ? FFEBAD_INTRINSIC_DISABLED
1913                         : FFEBAD_INTRINSIC_UNIMPLW);
1914           ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
1915           ffebad_string (name);
1916           ffebad_finish ();
1917         }
1918
1919       return FALSE;
1920     }
1921
1922   /* Determine whether intrinsic is function or subroutine.  If no specific
1923      id, scan list of possible specifics for generic to get consensus.  If
1924      not unanimous, or clear from the context, return NONE.  */
1925
1926   if (spec == FFEINTRIN_specNONE)
1927     {
1928       int i;
1929       ffeintrinSpec tspec;
1930       ffeintrinImp timp;
1931       bool at_least_one_ok = FALSE;
1932
1933       for (i = 0;
1934            (((size_t) i) < ARRAY_SIZE (ffeintrin_gens_[gen].specs))
1935            && ((tspec
1936                 = ffeintrin_gens_[gen].specs[i]) != FFEINTRIN_specNONE);
1937            ++i)
1938         {
1939           if (((state = ffeintrin_state_family (ffeintrin_specs_[tspec].family))
1940                == FFE_intrinsicstateDELETED)
1941               || (state == FFE_intrinsicstateDISABLED))
1942             continue;
1943
1944           if ((timp = ffeintrin_specs_[tspec].implementation)
1945               == FFEINTRIN_impNONE)
1946             continue;
1947
1948           at_least_one_ok = TRUE;
1949           break;
1950         }
1951
1952       if (!at_least_one_ok)
1953         {
1954           *xgen = FFEINTRIN_genNONE;
1955           *xspec = FFEINTRIN_specNONE;
1956           *ximp = FFEINTRIN_impNONE;
1957           return FALSE;
1958         }
1959     }
1960
1961   *xgen = gen;
1962   *xspec = spec;
1963   *ximp = imp;
1964   return TRUE;
1965 }
1966
1967 /* Return TRUE if intrinsic is standard F77 (or, if -ff90, F90).  */
1968
1969 bool
1970 ffeintrin_is_standard (ffeintrinGen gen, ffeintrinSpec spec)
1971 {
1972   if (spec == FFEINTRIN_specNONE)
1973     {
1974       if (gen == FFEINTRIN_genNONE)
1975         return FALSE;
1976
1977       spec = ffeintrin_gens_[gen].specs[0];
1978       if (spec == FFEINTRIN_specNONE)
1979         return FALSE;
1980     }
1981
1982   if ((ffeintrin_specs_[spec].family == FFEINTRIN_familyF77)
1983       || (ffe_is_90 ()
1984           && ((ffeintrin_specs_[spec].family == FFEINTRIN_familyF90)
1985               || (ffeintrin_specs_[spec].family == FFEINTRIN_familyMIL)
1986               || (ffeintrin_specs_[spec].family == FFEINTRIN_familyASC))))
1987     return TRUE;
1988   return FALSE;
1989 }
1990
1991 /* Return kind type of intrinsic implementation.  See ffeintrin_basictype,
1992    its sibling.  */
1993
1994 ffeinfoKindtype
1995 ffeintrin_kindtype (ffeintrinSpec spec)
1996 {
1997   ffeintrinImp imp;
1998   ffecomGfrt gfrt;
1999
2000   assert (spec < FFEINTRIN_spec);
2001   imp = ffeintrin_specs_[spec].implementation;
2002   assert (imp < FFEINTRIN_imp);
2003
2004   if (ffe_is_f2c ())
2005     gfrt = ffeintrin_imps_[imp].gfrt_f2c;
2006   else
2007     gfrt = ffeintrin_imps_[imp].gfrt_gnu;
2008
2009   assert (gfrt != FFECOM_gfrt);
2010
2011   return ffecom_gfrt_kindtype (gfrt);
2012 }
2013
2014 /* Return name of generic intrinsic.  */
2015
2016 const char *
2017 ffeintrin_name_generic (ffeintrinGen gen)
2018 {
2019   assert (gen < FFEINTRIN_gen);
2020   return ffeintrin_gens_[gen].name;
2021 }
2022
2023 /* Return name of intrinsic implementation.  */
2024
2025 const char *
2026 ffeintrin_name_implementation (ffeintrinImp imp)
2027 {
2028   assert (imp < FFEINTRIN_imp);
2029   return ffeintrin_imps_[imp].name;
2030 }
2031
2032 /* Return external/internal name of specific intrinsic.  */
2033
2034 const char *
2035 ffeintrin_name_specific (ffeintrinSpec spec)
2036 {
2037   assert (spec < FFEINTRIN_spec);
2038   return ffeintrin_specs_[spec].name;
2039 }
2040
2041 /* Return state of family.  */
2042
2043 ffeIntrinsicState
2044 ffeintrin_state_family (ffeintrinFamily family)
2045 {
2046   ffeIntrinsicState state;
2047
2048   switch (family)
2049     {
2050     case FFEINTRIN_familyNONE:
2051       return FFE_intrinsicstateDELETED;
2052
2053     case FFEINTRIN_familyF77:
2054       return FFE_intrinsicstateENABLED;
2055
2056     case FFEINTRIN_familyASC:
2057       state = ffe_intrinsic_state_f2c ();
2058       state = ffe_state_max (state, ffe_intrinsic_state_f90 ());
2059       return state;
2060
2061     case FFEINTRIN_familyMIL:
2062       state = ffe_intrinsic_state_vxt ();
2063       state = ffe_state_max (state, ffe_intrinsic_state_f90 ());
2064       state = ffe_state_max (state, ffe_intrinsic_state_mil ());
2065       return state;
2066
2067     case FFEINTRIN_familyGNU:
2068       state = ffe_intrinsic_state_gnu ();
2069       return state;
2070
2071     case FFEINTRIN_familyF90:
2072       state = ffe_intrinsic_state_f90 ();
2073       return state;
2074
2075     case FFEINTRIN_familyVXT:
2076       state = ffe_intrinsic_state_vxt ();
2077       return state;
2078
2079     case FFEINTRIN_familyFVZ:
2080       state = ffe_intrinsic_state_f2c ();
2081       state = ffe_state_max (state, ffe_intrinsic_state_vxt ());
2082       return state;
2083
2084     case FFEINTRIN_familyF2C:
2085       state = ffe_intrinsic_state_f2c ();
2086       return state;
2087
2088     case FFEINTRIN_familyF2U:
2089       state = ffe_intrinsic_state_unix ();
2090       return state;
2091
2092     case FFEINTRIN_familyBADU77:
2093       state = ffe_intrinsic_state_badu77 ();
2094       return state;
2095
2096     default:
2097       assert ("bad family" == NULL);
2098       return FFE_intrinsicstateDELETED;
2099     }
2100 }