6/contrib/gcc/f/intrin.c

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