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