contrib/gcc/f/intrin.c

   1 /* intrin.c -- Recognize references to intrinsics
   2    Copyright (C) 1995-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 = ((struct _ffeintrin_name_ *) intrinsic)->name_uc;
1169   const char *lc = ((struct _ffeintrin_name_ *) intrinsic)->name_lc;
1170   const char *ic = ((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 (! IN_CTYPE_DOMAIN (*p1)
1585               || ! IN_CTYPE_DOMAIN (*p2)
1586               || ! IN_CTYPE_DOMAIN (*p3))
1587             break;
1588           if ((ISDIGIT (*p1) || (*p1 == '_')) && (*p1 == *p2) && (*p1 == *p3))
1589             continue;
1590           if (! ISUPPER ((unsigned char)*p1) || ! ISLOWER ((unsigned char)*p2)
1591               || (*p1 != toupper ((unsigned char)*p2))
1592               || ((*p3 != *p1) && (*p3 != *p2)))
1593             break;
1594         }
1595       assert ((*p1 == *p2) && (*p1 == *p3) && (*p1 == '\0'));
1596     }
1597
1598   for (i = 0; ((size_t) i) < ARRAY_SIZE (ffeintrin_imps_); ++i)
1599     {
1600       const char *c = ffeintrin_imps_[i].control;
1601
1602       if (c[0] == '\0')
1603         continue;
1604
1605       if ((c[0] != '-')
1606           && (c[0] != 'A')
1607           && (c[0] != 'C')
1608           && (c[0] != 'I')
1609           && (c[0] != 'L')
1610           && (c[0] != 'R')
1611           && (c[0] != 'B')
1612           && (c[0] != 'F')
1613           && (c[0] != 'N')
1614           && (c[0] != 'S'))
1615         {
1616           fprintf (stderr, "%s: bad return-base-type\n",
1617                    ffeintrin_imps_[i].name);
1618           continue;
1619         }
1620       if ((c[1] != '-')
1621           && (c[1] != '=')
1622           && ((c[1] < '1')
1623               || (c[1] > '9'))
1624           && (c[1] != 'C'))
1625         {
1626           fprintf (stderr, "%s: bad return-kind-type\n",
1627                    ffeintrin_imps_[i].name);
1628           continue;
1629         }
1630       if (c[2] == ':')
1631         colon = 2;
1632       else
1633         {
1634           if (c[2] != '*')
1635             {
1636               fprintf (stderr, "%s: bad return-modifier\n",
1637                        ffeintrin_imps_[i].name);
1638               continue;
1639             }
1640           colon = 3;
1641         }
1642       if ((c[colon] != ':') || (c[colon + 2] != ':'))
1643         {
1644           fprintf (stderr, "%s: bad control\n",
1645                    ffeintrin_imps_[i].name);
1646           continue;
1647         }
1648       if ((c[colon + 1] != '-')
1649           && (c[colon + 1] != '*')
1650           && ((c[colon + 1] < '0')
1651               || (c[colon + 1] > '9')))
1652         {
1653           fprintf (stderr, "%s: bad COL-spec\n",
1654                    ffeintrin_imps_[i].name);
1655           continue;
1656         }
1657       c += (colon + 3);
1658       while (c[0] != '\0')
1659         {
1660           while ((c[0] != '=')
1661                  && (c[0] != ',')
1662                  && (c[0] != '\0'))
1663             ++c;
1664           if (c[0] != '=')
1665             {
1666               fprintf (stderr, "%s: bad keyword\n",
1667                        ffeintrin_imps_[i].name);
1668               break;
1669             }
1670           if ((c[1] == '?')
1671               || (c[1] == '!')
1672               || (c[1] == '+')
1673               || (c[1] == '*')
1674               || (c[1] == 'n')
1675               || (c[1] == 'p'))
1676             ++c;
1677           if ((c[1] != '-')
1678               && (c[1] != 'A')
1679               && (c[1] != 'C')
1680               && (c[1] != 'I')
1681               && (c[1] != 'L')
1682               && (c[1] != 'R')
1683               && (c[1] != 'B')
1684               && (c[1] != 'F')
1685               && (c[1] != 'N')
1686               && (c[1] != 'S')
1687               && (c[1] != 'g')
1688               && (c[1] != 's'))
1689             {
1690               fprintf (stderr, "%s: bad arg-base-type\n",
1691                        ffeintrin_imps_[i].name);
1692               break;
1693             }
1694           if ((c[2] != '*')
1695               && ((c[2] < '1')
1696                   || (c[2] > '9'))
1697               && (c[2] != 'A'))
1698             {
1699               fprintf (stderr, "%s: bad arg-kind-type\n",
1700                        ffeintrin_imps_[i].name);
1701               break;
1702             }
1703           if (c[3] == '[')
1704             {
1705               if (((c[4] < '0') || (c[4] > '9'))
1706                   || ((c[5] != ']')
1707                       && (++c, (c[4] < '0') || (c[4] > '9')
1708                           || (c[5] != ']'))))
1709                 {
1710                   fprintf (stderr, "%s: bad arg-len\n",
1711                            ffeintrin_imps_[i].name);
1712                   break;
1713                 }
1714               c += 3;
1715             }
1716           if (c[3] == '(')
1717             {
1718               if (((c[4] < '0') || (c[4] > '9'))
1719                   || ((c[5] != ')')
1720                       && (++c, (c[4] < '0') || (c[4] > '9')
1721                           || (c[5] != ')'))))
1722                 {
1723                   fprintf (stderr, "%s: bad arg-rank\n",
1724                            ffeintrin_imps_[i].name);
1725                   break;
1726                 }
1727               c += 3;
1728             }
1729           else if ((c[3] == '&')
1730                    && (c[4] == '&'))
1731             ++c;
1732           if ((c[3] == '&')
1733               || (c[3] == 'i')
1734               || (c[3] == 'w')
1735               || (c[3] == 'x'))
1736             ++c;
1737           if (c[3] == ',')
1738             {
1739               c += 4;
1740               continue;
1741             }
1742           if (c[3] != '\0')
1743             {
1744               fprintf (stderr, "%s: bad arg-list\n",
1745                        ffeintrin_imps_[i].name);
1746             }
1747           break;
1748         }
1749     }
1750 }
1751
1752 /* Determine whether intrinsic is okay as an actual argument.  */
1753
1754 bool
1755 ffeintrin_is_actualarg (ffeintrinSpec spec)
1756 {
1757   ffeIntrinsicState state;
1758
1759   if (spec >= FFEINTRIN_spec)
1760     return FALSE;
1761
1762   state = ffeintrin_state_family (ffeintrin_specs_[spec].family);
1763
1764   return (!ffe_is_pedantic () || ffeintrin_specs_[spec].is_actualarg)
1765 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1766     && (ffe_is_f2c ()
1767         ? (ffeintrin_imps_[ffeintrin_specs_[spec].implementation].gfrt_f2c
1768            != FFECOM_gfrt)
1769         : (ffeintrin_imps_[ffeintrin_specs_[spec].implementation].gfrt_gnu
1770            != FFECOM_gfrt))
1771 #endif
1772     && ((state == FFE_intrinsicstateENABLED)
1773         || (state == FFE_intrinsicstateHIDDEN));
1774 }
1775
1776 /* Determine if name is intrinsic, return info.
1777
1778    const char *name;            // C-string name of possible intrinsic.
1779    ffelexToken t;               // NULL if no diagnostic to be given.
1780    bool explicit;               // TRUE if INTRINSIC name.
1781    ffeintrinGen gen;            // (TRUE only) Generic id of intrinsic.
1782    ffeintrinSpec spec;          // (TRUE only) Specific id of intrinsic.
1783    ffeintrinImp imp;            // (TRUE only) Implementation id of intrinsic.
1784    if (ffeintrin_is_intrinsic (name, t, explicit,
1785                                &gen, &spec, &imp))
1786                                 // is an intrinsic, use gen, spec, imp, and
1787                                 // kind accordingly.  */
1788
1789 bool
1790 ffeintrin_is_intrinsic (const char *name, ffelexToken t, bool explicit,
1791                         ffeintrinGen *xgen, ffeintrinSpec *xspec,
1792                         ffeintrinImp *ximp)
1793 {
1794   struct _ffeintrin_name_ *intrinsic;
1795   ffeintrinGen gen;
1796   ffeintrinSpec spec;
1797   ffeintrinImp imp;
1798   ffeIntrinsicState state;
1799   bool disabled = FALSE;
1800   bool unimpl = FALSE;
1801
1802   intrinsic = bsearch (name, &ffeintrin_names_[0],
1803                        ARRAY_SIZE (ffeintrin_names_),
1804                        sizeof (struct _ffeintrin_name_),
1805                          (void *) ffeintrin_cmp_name_);
1806
1807   if (intrinsic == NULL)
1808     return FALSE;
1809
1810   gen = intrinsic->generic;
1811   spec = intrinsic->specific;
1812   imp = ffeintrin_specs_[spec].implementation;
1813
1814   /* Generic is okay only if at least one of its specifics is okay.  */
1815
1816   if (gen != FFEINTRIN_genNONE)
1817     {
1818       int i;
1819       ffeintrinSpec tspec;
1820       bool ok = FALSE;
1821
1822       name = ffeintrin_gens_[gen].name;
1823
1824       for (i = 0;
1825            (((size_t) i) < ARRAY_SIZE (ffeintrin_gens_[gen].specs))
1826            && ((tspec
1827                 = ffeintrin_gens_[gen].specs[i]) != FFEINTRIN_specNONE);
1828            ++i)
1829         {
1830           state = ffeintrin_state_family (ffeintrin_specs_[tspec].family);
1831
1832           if (state == FFE_intrinsicstateDELETED)
1833             continue;
1834
1835           if (state == FFE_intrinsicstateDISABLED)
1836             {
1837               disabled = TRUE;
1838               continue;
1839             }
1840
1841           if (ffeintrin_specs_[tspec].implementation == FFEINTRIN_impNONE)
1842             {
1843               unimpl = TRUE;
1844               continue;
1845             }
1846
1847           if ((state == FFE_intrinsicstateENABLED)
1848               || (explicit
1849                   && (state == FFE_intrinsicstateHIDDEN)))
1850             {
1851               ok = TRUE;
1852               break;
1853             }
1854         }
1855       if (!ok)
1856         gen = FFEINTRIN_genNONE;
1857     }
1858
1859   /* Specific is okay only if not: unimplemented, disabled, deleted, or
1860      hidden and not explicit.  */
1861
1862   if (spec != FFEINTRIN_specNONE)
1863     {
1864       if (gen != FFEINTRIN_genNONE)
1865         name = ffeintrin_gens_[gen].name;
1866       else
1867         name = ffeintrin_specs_[spec].name;
1868
1869       if (((state = ffeintrin_state_family (ffeintrin_specs_[spec].family))
1870            == FFE_intrinsicstateDELETED)
1871           || (!explicit
1872               && (state == FFE_intrinsicstateHIDDEN)))
1873         spec = FFEINTRIN_specNONE;
1874       else if (state == FFE_intrinsicstateDISABLED)
1875         {
1876           disabled = TRUE;
1877           spec = FFEINTRIN_specNONE;
1878         }
1879       else if (imp == FFEINTRIN_impNONE)
1880         {
1881           unimpl = TRUE;
1882           spec = FFEINTRIN_specNONE;
1883         }
1884     }
1885
1886   /* If neither is okay, not an intrinsic.  */
1887
1888   if ((gen == FFEINTRIN_genNONE) && (spec == FFEINTRIN_specNONE))
1889     {
1890       /* Here is where we produce a diagnostic about a reference to a
1891          disabled or unimplemented intrinsic, if the diagnostic is desired.  */
1892
1893       if ((disabled || unimpl)
1894           && (t != NULL))
1895         {
1896           ffebad_start (disabled
1897                         ? FFEBAD_INTRINSIC_DISABLED
1898                         : FFEBAD_INTRINSIC_UNIMPLW);
1899           ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
1900           ffebad_string (name);
1901           ffebad_finish ();
1902         }
1903
1904       return FALSE;
1905     }
1906
1907   /* Determine whether intrinsic is function or subroutine.  If no specific
1908      id, scan list of possible specifics for generic to get consensus.  If
1909      not unanimous, or clear from the context, return NONE.  */
1910
1911   if (spec == FFEINTRIN_specNONE)
1912     {
1913       int i;
1914       ffeintrinSpec tspec;
1915       ffeintrinImp timp;
1916       bool at_least_one_ok = FALSE;
1917
1918       for (i = 0;
1919            (((size_t) i) < ARRAY_SIZE (ffeintrin_gens_[gen].specs))
1920            && ((tspec
1921                 = ffeintrin_gens_[gen].specs[i]) != FFEINTRIN_specNONE);
1922            ++i)
1923         {
1924           if (((state = ffeintrin_state_family (ffeintrin_specs_[tspec].family))
1925                == FFE_intrinsicstateDELETED)
1926               || (state == FFE_intrinsicstateDISABLED))
1927             continue;
1928
1929           if ((timp = ffeintrin_specs_[tspec].implementation)
1930               == FFEINTRIN_impNONE)
1931             continue;
1932
1933           at_least_one_ok = TRUE;
1934           break;
1935         }
1936
1937       if (!at_least_one_ok)
1938         {
1939           *xgen = FFEINTRIN_genNONE;
1940           *xspec = FFEINTRIN_specNONE;
1941           *ximp = FFEINTRIN_impNONE;
1942           return FALSE;
1943         }
1944     }
1945
1946   *xgen = gen;
1947   *xspec = spec;
1948   *ximp = imp;
1949   return TRUE;
1950 }
1951
1952 /* Return TRUE if intrinsic is standard F77 (or, if -ff90, F90).  */
1953
1954 bool
1955 ffeintrin_is_standard (ffeintrinGen gen, ffeintrinSpec spec)
1956 {
1957   if (spec == FFEINTRIN_specNONE)
1958     {
1959       if (gen == FFEINTRIN_genNONE)
1960         return FALSE;
1961
1962       spec = ffeintrin_gens_[gen].specs[0];
1963       if (spec == FFEINTRIN_specNONE)
1964         return FALSE;
1965     }
1966
1967   if ((ffeintrin_specs_[spec].family == FFEINTRIN_familyF77)
1968       || (ffe_is_90 ()
1969           && ((ffeintrin_specs_[spec].family == FFEINTRIN_familyF90)
1970               || (ffeintrin_specs_[spec].family == FFEINTRIN_familyMIL)
1971               || (ffeintrin_specs_[spec].family == FFEINTRIN_familyASC))))
1972     return TRUE;
1973   return FALSE;
1974 }
1975
1976 /* Return kind type of intrinsic implementation.  See ffeintrin_basictype,
1977    its sibling.  */
1978
1979 ffeinfoKindtype
1980 ffeintrin_kindtype (ffeintrinSpec spec)
1981 {
1982   ffeintrinImp imp;
1983   ffecomGfrt gfrt;
1984
1985   assert (spec < FFEINTRIN_spec);
1986   imp = ffeintrin_specs_[spec].implementation;
1987   assert (imp < FFEINTRIN_imp);
1988
1989   if (ffe_is_f2c ())
1990     gfrt = ffeintrin_imps_[imp].gfrt_f2c;
1991   else
1992     gfrt = ffeintrin_imps_[imp].gfrt_gnu;
1993
1994   assert (gfrt != FFECOM_gfrt);
1995
1996   return ffecom_gfrt_kindtype (gfrt);
1997 }
1998
1999 /* Return name of generic intrinsic.  */
2000
2001 const char *
2002 ffeintrin_name_generic (ffeintrinGen gen)
2003 {
2004   assert (gen < FFEINTRIN_gen);
2005   return ffeintrin_gens_[gen].name;
2006 }
2007
2008 /* Return name of intrinsic implementation.  */
2009
2010 const char *
2011 ffeintrin_name_implementation (ffeintrinImp imp)
2012 {
2013   assert (imp < FFEINTRIN_imp);
2014   return ffeintrin_imps_[imp].name;
2015 }
2016
2017 /* Return external/internal name of specific intrinsic.  */
2018
2019 const char *
2020 ffeintrin_name_specific (ffeintrinSpec spec)
2021 {
2022   assert (spec < FFEINTRIN_spec);
2023   return ffeintrin_specs_[spec].name;
2024 }
2025
2026 /* Return state of family.  */
2027
2028 ffeIntrinsicState
2029 ffeintrin_state_family (ffeintrinFamily family)
2030 {
2031   ffeIntrinsicState state;
2032
2033   switch (family)
2034     {
2035     case FFEINTRIN_familyNONE:
2036       return FFE_intrinsicstateDELETED;
2037
2038     case FFEINTRIN_familyF77:
2039       return FFE_intrinsicstateENABLED;
2040
2041     case FFEINTRIN_familyASC:
2042       state = ffe_intrinsic_state_f2c ();
2043       state = ffe_state_max (state, ffe_intrinsic_state_f90 ());
2044       return state;
2045
2046     case FFEINTRIN_familyMIL:
2047       state = ffe_intrinsic_state_vxt ();
2048       state = ffe_state_max (state, ffe_intrinsic_state_f90 ());
2049       state = ffe_state_max (state, ffe_intrinsic_state_mil ());
2050       return state;
2051
2052     case FFEINTRIN_familyGNU:
2053       state = ffe_intrinsic_state_gnu ();
2054       return state;
2055
2056     case FFEINTRIN_familyF90:
2057       state = ffe_intrinsic_state_f90 ();
2058       return state;
2059
2060     case FFEINTRIN_familyVXT:
2061       state = ffe_intrinsic_state_vxt ();
2062       return state;
2063
2064     case FFEINTRIN_familyFVZ:
2065       state = ffe_intrinsic_state_f2c ();
2066       state = ffe_state_max (state, ffe_intrinsic_state_vxt ());
2067       return state;
2068
2069     case FFEINTRIN_familyF2C:
2070       state = ffe_intrinsic_state_f2c ();
2071       return state;
2072
2073     case FFEINTRIN_familyF2U:
2074       state = ffe_intrinsic_state_unix ();
2075       return state;
2076
2077     case FFEINTRIN_familyBADU77:
2078       state = ffe_intrinsic_state_badu77 ();
2079       return state;
2080
2081     default:
2082       assert ("bad family" == NULL);
2083       return FFE_intrinsicstateDELETED;
2084     }
2085 }