gcc/f/intrin.c

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