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