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