/* intrin.c -- Recognize references to intrinsics Copyright (C) 1995, 1996, 1997, 1998, 2002, 2003 Free Software Foundation, Inc. Contributed by James Craig Burley. This file is part of GNU Fortran. GNU Fortran is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. GNU Fortran is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with GNU Fortran; see the file COPYING. If not, write to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ #include "proj.h" #include "intrin.h" #include "expr.h" #include "info.h" #include "src.h" #include "symbol.h" #include "target.h" #include "top.h" struct _ffeintrin_name_ { const char *const name_uc; const char *const name_lc; const char *const name_ic; const ffeintrinGen generic; const ffeintrinSpec specific; }; struct _ffeintrin_gen_ { const char *const name; /* Name as seen in program. */ const ffeintrinSpec specs[2]; }; struct _ffeintrin_spec_ { const char *const name; /* Uppercase name as seen in source code, lowercase if no source name, "none" if no name at all (NONE case). */ const bool is_actualarg; /* Ok to pass as actual arg if -pedantic. */ const ffeintrinFamily family; const ffeintrinImp implementation; }; struct _ffeintrin_imp_ { const char *const name; /* Name of implementation. */ const ffecomGfrt gfrt_direct;/* library routine, direct-callable form. */ const ffecomGfrt gfrt_f2c; /* library routine, f2c-callable form. */ const ffecomGfrt gfrt_gnu; /* library routine, gnu-callable form. */ const char *const control; const char y2kbad; }; static ffebad ffeintrin_check_ (ffeintrinImp imp, ffebldOp op, ffebld args, ffeinfoBasictype *xbt, ffeinfoKindtype *xkt, ffetargetCharacterSize *xsz, bool *check_intrin, ffelexToken t, bool commit); static bool ffeintrin_check_any_ (ffebld arglist); static int ffeintrin_cmp_name_ (const void *name, const void *intrinsic); static const struct _ffeintrin_name_ ffeintrin_names_[] = { /* Alpha order. */ #define DEFNAME(UPPER,LOWER,MIXED,GEN,SPEC) \ { UPPER, LOWER, MIXED, FFEINTRIN_ ## GEN, FFEINTRIN_ ## SPEC }, #define DEFGEN(CODE,NAME,SPEC1,SPEC2) #define DEFSPEC(CODE,NAME,CALLABLE,FAMILY,IMP) #define DEFIMP(CODE,NAME,GFRTDIRECT,GFRTF2C,GFRTGNU,CONTROL) #define DEFIMPY(CODE,NAME,GFRTDIRECT,GFRTF2C,GFRTGNU,CONTROL,Y2KBAD) #include "intrin.def" #undef DEFNAME #undef DEFGEN #undef DEFSPEC #undef DEFIMP #undef DEFIMPY }; static const struct _ffeintrin_gen_ ffeintrin_gens_[] = { #define DEFNAME(UPPER,LOWER,MIXED,GEN,SPEC) #define DEFGEN(CODE,NAME,SPEC1,SPEC2) \ { NAME, { SPEC1, SPEC2, }, }, #define DEFSPEC(CODE,NAME,CALLABLE,FAMILY,IMP) #define DEFIMP(CODE,NAME,GFRTDIRECT,GFRTF2C,GFRTGNU,CONTROL) #define DEFIMPY(CODE,NAME,GFRTDIRECT,GFRTF2C,GFRTGNU,CONTROL,Y2KBAD) #include "intrin.def" #undef DEFNAME #undef DEFGEN #undef DEFSPEC #undef DEFIMP #undef DEFIMPY }; static const struct _ffeintrin_imp_ ffeintrin_imps_[] = { #define DEFNAME(UPPER,LOWER,MIXED,GEN,SPEC) #define DEFGEN(CODE,NAME,SPEC1,SPEC2) #define DEFSPEC(CODE,NAME,CALLABLE,FAMILY,IMP) #define DEFIMP(CODE,NAME,GFRTDIRECT,GFRTF2C,GFRTGNU,CONTROL) \ { NAME, FFECOM_gfrt ## GFRTDIRECT, FFECOM_gfrt ## GFRTF2C, \ FFECOM_gfrt ## GFRTGNU, CONTROL, FALSE }, #define DEFIMPY(CODE,NAME,GFRTDIRECT,GFRTF2C,GFRTGNU,CONTROL,Y2KBAD) \ { NAME, FFECOM_gfrt ## GFRTDIRECT, FFECOM_gfrt ## GFRTF2C, \ FFECOM_gfrt ## GFRTGNU, CONTROL, Y2KBAD }, #include "intrin.def" #undef DEFNAME #undef DEFGEN #undef DEFSPEC #undef DEFIMP #undef DEFIMPY }; static const struct _ffeintrin_spec_ ffeintrin_specs_[] = { #define DEFNAME(UPPER,LOWER,MIXED,GEN,SPEC) #define DEFGEN(CODE,NAME,SPEC1,SPEC2) #define DEFSPEC(CODE,NAME,CALLABLE,FAMILY,IMP) \ { NAME, CALLABLE, FAMILY, IMP, }, #define DEFIMP(CODE,NAME,GFRTDIRECT,GFRTF2C,GFRTGNU,CONTROL) #define DEFIMPY(CODE,NAME,GFRTDIRECT,GFRTF2C,GFRTGNU,CONTROL,Y2KBAD) #include "intrin.def" #undef DEFGEN #undef DEFSPEC #undef DEFIMP #undef DEFIMPY }; static ffebad ffeintrin_check_ (ffeintrinImp imp, ffebldOp op, ffebld args, ffeinfoBasictype *xbt, ffeinfoKindtype *xkt, ffetargetCharacterSize *xsz, bool *check_intrin, ffelexToken t, bool commit) { const char *c = ffeintrin_imps_[imp].control; bool subr = (c[0] == '-'); const char *argc; ffebld arg; ffeinfoBasictype bt; ffeinfoKindtype kt; ffetargetCharacterSize sz = FFETARGET_charactersizeNONE; ffeinfoKindtype firstarg_kt; bool need_col; ffeinfoBasictype col_bt = FFEINFO_basictypeNONE; ffeinfoKindtype col_kt = FFEINFO_kindtypeNONE; int colon = (c[2] == ':') ? 2 : 3; int argno; /* Check procedure type (function vs. subroutine) against invocation. */ if (op == FFEBLD_opSUBRREF) { if (!subr) return FFEBAD_INTRINSIC_IS_FUNC; } else if (op == FFEBLD_opFUNCREF) { if (subr) return FFEBAD_INTRINSIC_IS_SUBR; } else return FFEBAD_INTRINSIC_REF; /* Check the arglist for validity. */ if ((args != NULL) && (ffebld_head (args) != NULL)) firstarg_kt = ffeinfo_kindtype (ffebld_info (ffebld_head (args))); else firstarg_kt = FFEINFO_kindtype; for (argc = &c[colon + 3], arg = args; *argc != '\0'; ) { char optional = '\0'; char required = '\0'; char extra = '\0'; char basic; char kind; int length; int elements; bool lastarg_complex = FALSE; /* We don't do anything with keywords yet. */ do { } while (*(++argc) != '='); ++argc; if ((*argc == '?') || (*argc == '!') || (*argc == '*')) optional = *(argc++); if ((*argc == '+') || (*argc == 'n') || (*argc == 'p')) required = *(argc++); basic = *(argc++); kind = *(argc++); if (*argc == '[') { length = *++argc - '0'; if (*++argc != ']') length = 10 * length + (*(argc++) - '0'); ++argc; } else length = -1; if (*argc == '(') { elements = *++argc - '0'; if (*++argc != ')') elements = 10 * elements + (*(argc++) - '0'); ++argc; } else if (*argc == '&') { elements = -1; ++argc; } else elements = 0; if ((*argc == '&') || (*argc == 'i') || (*argc == 'w') || (*argc == 'x')) extra = *(argc++); if (*argc == ',') ++argc; /* Break out of this loop only when current arg spec completely processed. */ do { bool okay; ffebld a; ffeinfo i; bool anynum; ffeinfoBasictype abt = FFEINFO_basictypeNONE; ffeinfoKindtype akt = FFEINFO_kindtypeNONE; if ((arg == NULL) || (ffebld_head (arg) == NULL)) { if (required != '\0') return FFEBAD_INTRINSIC_TOOFEW; if (optional == '\0') return FFEBAD_INTRINSIC_TOOFEW; if (arg != NULL) arg = ffebld_trail (arg); break; /* Try next argspec. */ } a = ffebld_head (arg); i = ffebld_info (a); anynum = (ffeinfo_basictype (i) == FFEINFO_basictypeHOLLERITH) || (ffeinfo_basictype (i) == FFEINFO_basictypeTYPELESS); /* See how well the arg matches up to the spec. */ switch (basic) { case 'A': okay = (ffeinfo_basictype (i) == FFEINFO_basictypeCHARACTER) && ((length == -1) || (ffeinfo_size (i) == (ffetargetCharacterSize) length)); break; case 'C': okay = anynum || (ffeinfo_basictype (i) == FFEINFO_basictypeCOMPLEX); abt = FFEINFO_basictypeCOMPLEX; break; case 'I': okay = anynum || (ffeinfo_basictype (i) == FFEINFO_basictypeINTEGER); abt = FFEINFO_basictypeINTEGER; break; case 'L': okay = anynum || (ffeinfo_basictype (i) == FFEINFO_basictypeLOGICAL); abt = FFEINFO_basictypeLOGICAL; break; case 'R': okay = anynum || (ffeinfo_basictype (i) == FFEINFO_basictypeREAL); abt = FFEINFO_basictypeREAL; break; case 'B': okay = anynum || (ffeinfo_basictype (i) == FFEINFO_basictypeINTEGER) || (ffeinfo_basictype (i) == FFEINFO_basictypeLOGICAL); break; case 'F': okay = anynum || (ffeinfo_basictype (i) == FFEINFO_basictypeCOMPLEX) || (ffeinfo_basictype (i) == FFEINFO_basictypeREAL); break; case 'N': okay = anynum || (ffeinfo_basictype (i) == FFEINFO_basictypeCOMPLEX) || (ffeinfo_basictype (i) == FFEINFO_basictypeINTEGER) || (ffeinfo_basictype (i) == FFEINFO_basictypeREAL); break; case 'S': okay = anynum || (ffeinfo_basictype (i) == FFEINFO_basictypeINTEGER) || (ffeinfo_basictype (i) == FFEINFO_basictypeREAL); break; case 'g': okay = ((ffebld_op (a) == FFEBLD_opLABTER) || (ffebld_op (a) == FFEBLD_opLABTOK)); elements = -1; extra = '-'; break; case 's': okay = (((((ffeinfo_basictype (i) == FFEINFO_basictypeNONE) && (ffeinfo_kindtype (i) == FFEINFO_kindtypeNONE) && (ffeinfo_kind (i) == FFEINFO_kindSUBROUTINE)) || ((ffeinfo_basictype (i) == FFEINFO_basictypeINTEGER) && (ffeinfo_kindtype (i) == FFEINFO_kindtypeINTEGERDEFAULT) && (ffeinfo_kind (i) == FFEINFO_kindFUNCTION)) || (ffeinfo_kind (i) == FFEINFO_kindNONE)) && ((ffeinfo_where (i) == FFEINFO_whereDUMMY) || (ffeinfo_where (i) == FFEINFO_whereGLOBAL))) || ((ffeinfo_basictype (i) == FFEINFO_basictypeINTEGER) && (ffeinfo_kind (i) == FFEINFO_kindENTITY))); elements = -1; extra = '-'; break; case '-': default: okay = TRUE; break; } switch (kind) { case '1': case '2': case '3': case '4': case '5': case '6': case '7': case '8': case '9': akt = (kind - '0'); if ((ffeinfo_basictype (i) == FFEINFO_basictypeINTEGER) || (ffeinfo_basictype (i) == FFEINFO_basictypeLOGICAL)) { switch (akt) { /* Translate to internal kinds for now! */ default: break; case 2: akt = 4; break; case 3: akt = 2; break; case 4: akt = 5; break; case 6: akt = 3; break; case 7: akt = ffecom_pointer_kind (); break; } } okay &= anynum || (ffeinfo_kindtype (i) == akt); break; case 'A': okay &= anynum || (ffeinfo_kindtype (i) == firstarg_kt); akt = (firstarg_kt == FFEINFO_kindtype) ? FFEINFO_kindtypeNONE : firstarg_kt; break; case 'N': /* Accept integers and logicals not wider than the default integer/logical. */ if (ffeinfo_basictype (i) == FFEINFO_basictypeINTEGER) { okay &= anynum || (ffeinfo_kindtype (i) == FFEINFO_kindtypeINTEGER1 || ffeinfo_kindtype (i) == FFEINFO_kindtypeINTEGER2 || ffeinfo_kindtype (i) == FFEINFO_kindtypeINTEGER3); akt = FFEINFO_kindtypeINTEGER1; /* The default. */ } else if (ffeinfo_basictype (i) == FFEINFO_basictypeLOGICAL) { okay &= anynum || (ffeinfo_kindtype (i) == FFEINFO_kindtypeLOGICAL1 || ffeinfo_kindtype (i) == FFEINFO_kindtypeLOGICAL2 || ffeinfo_kindtype (i) == FFEINFO_kindtypeLOGICAL3); akt = FFEINFO_kindtypeLOGICAL1; /* The default. */ } break; case '*': default: break; } switch (elements) { ffebld b; case -1: break; case 0: if (ffeinfo_rank (i) != 0) okay = FALSE; break; default: if ((ffeinfo_rank (i) != 1) || (ffebld_op (a) != FFEBLD_opSYMTER) || ((b = ffesymbol_arraysize (ffebld_symter (a))) == NULL) || (ffebld_op (b) != FFEBLD_opCONTER) || (ffeinfo_basictype (ffebld_info (b)) != FFEINFO_basictypeINTEGER) || (ffeinfo_kindtype (ffebld_info (b)) != FFEINFO_kindtypeINTEGERDEFAULT) || (ffebld_constant_integer1 (ffebld_conter (b)) != elements)) okay = FALSE; break; } switch (extra) { case '&': if ((ffeinfo_kind (i) != FFEINFO_kindENTITY) || ((ffebld_op (a) != FFEBLD_opSYMTER) && (ffebld_op (a) != FFEBLD_opSUBSTR) && (ffebld_op (a) != FFEBLD_opARRAYREF))) okay = FALSE; break; case 'w': case 'x': if ((ffeinfo_kind (i) != FFEINFO_kindENTITY) || ((ffebld_op (a) != FFEBLD_opSYMTER) && (ffebld_op (a) != FFEBLD_opARRAYREF) && (ffebld_op (a) != FFEBLD_opSUBSTR))) okay = FALSE; break; case '-': case 'i': break; default: if (ffeinfo_kind (i) != FFEINFO_kindENTITY) okay = FALSE; break; } if ((optional == '!') && lastarg_complex) okay = FALSE; if (!okay) { /* If it wasn't optional, it's an error, else maybe it could match a later argspec. */ if (optional == '\0') return FFEBAD_INTRINSIC_REF; break; /* Try next argspec. */ } lastarg_complex = (ffeinfo_basictype (i) == FFEINFO_basictypeCOMPLEX); if (anynum) { /* If we know dummy arg type, convert to that now. */ if ((abt != FFEINFO_basictypeNONE) && (akt != FFEINFO_kindtypeNONE) && commit) { /* We have a known type, convert hollerith/typeless to it. */ a = ffeexpr_convert (a, t, NULL, abt, akt, 0, FFETARGET_charactersizeNONE, FFEEXPR_contextLET); ffebld_set_head (arg, a); } } arg = ffebld_trail (arg); /* Arg accepted, now move on. */ if (optional == '*') continue; /* Go ahead and try another arg. */ if (required == '\0') break; if ((required == 'n') || (required == '+')) { optional = '*'; required = '\0'; } else if (required == 'p') required = 'n'; } while (TRUE); } if (arg != NULL) return FFEBAD_INTRINSIC_TOOMANY; /* Set up the initial type for the return value of the function. */ need_col = FALSE; switch (c[0]) { case 'A': bt = FFEINFO_basictypeCHARACTER; sz = (c[2] == '*') ? FFETARGET_charactersizeNONE : 1; break; case 'C': bt = FFEINFO_basictypeCOMPLEX; break; case 'I': bt = FFEINFO_basictypeINTEGER; break; case 'L': bt = FFEINFO_basictypeLOGICAL; break; case 'R': bt = FFEINFO_basictypeREAL; break; case 'B': case 'F': case 'N': case 'S': need_col = TRUE; /* Fall through. */ case '-': default: bt = FFEINFO_basictypeNONE; break; } switch (c[1]) { case '1': case '2': case '3': case '4': case '5': case '6': case '7': case '8': case '9': kt = (c[1] - '0'); if ((bt == FFEINFO_basictypeINTEGER) || (bt == FFEINFO_basictypeLOGICAL)) { switch (kt) { /* Translate to internal kinds for now! */ default: break; case 2: kt = 4; break; case 3: kt = 2; break; case 4: kt = 5; break; case 6: kt = 3; break; case 7: kt = ffecom_pointer_kind (); break; } } break; case 'C': if (ffe_is_90 ()) need_col = TRUE; kt = 1; break; case '=': need_col = TRUE; /* Fall through. */ case '-': default: kt = FFEINFO_kindtypeNONE; break; } /* Determine collective type of COL, if there is one. */ if (need_col || c[colon + 1] != '-') { bool okay = TRUE; bool have_anynum = FALSE; int arg_count=0; for (arg = args, arg_count=0; arg != NULL; arg = ffebld_trail (arg), arg_count++ ) { ffebld a = ffebld_head (arg); ffeinfo i; bool anynum; if (a == NULL) continue; i = ffebld_info (a); if ( c[colon+1] != '*' && (c[colon+1]-'0') != arg_count ) continue; anynum = (ffeinfo_basictype (i) == FFEINFO_basictypeHOLLERITH) || (ffeinfo_basictype (i) == FFEINFO_basictypeTYPELESS); if (anynum) { have_anynum = TRUE; continue; } if ((col_bt == FFEINFO_basictypeNONE) && (col_kt == FFEINFO_kindtypeNONE)) { col_bt = ffeinfo_basictype (i); col_kt = ffeinfo_kindtype (i); } else { ffeexpr_type_combine (&col_bt, &col_kt, col_bt, col_kt, ffeinfo_basictype (i), ffeinfo_kindtype (i), NULL); if ((col_bt == FFEINFO_basictypeNONE) || (col_kt == FFEINFO_kindtypeNONE)) return FFEBAD_INTRINSIC_REF; } } if (have_anynum && ((col_bt == FFEINFO_basictypeNONE) || (col_kt == FFEINFO_kindtypeNONE))) { /* No type, but have hollerith/typeless. Use type of return value to determine type of COL. */ switch (c[0]) { case 'A': return FFEBAD_INTRINSIC_REF; case 'B': case 'I': case 'L': if ((col_bt != FFEINFO_basictypeNONE) && (col_bt != FFEINFO_basictypeINTEGER)) return FFEBAD_INTRINSIC_REF; /* Fall through. */ case 'N': case 'S': case '-': default: col_bt = FFEINFO_basictypeINTEGER; col_kt = FFEINFO_kindtypeINTEGER1; break; case 'C': if ((col_bt != FFEINFO_basictypeNONE) && (col_bt != FFEINFO_basictypeCOMPLEX)) return FFEBAD_INTRINSIC_REF; col_bt = FFEINFO_basictypeCOMPLEX; col_kt = FFEINFO_kindtypeREAL1; break; case 'R': if ((col_bt != FFEINFO_basictypeNONE) && (col_bt != FFEINFO_basictypeREAL)) return FFEBAD_INTRINSIC_REF; /* Fall through. */ case 'F': col_bt = FFEINFO_basictypeREAL; col_kt = FFEINFO_kindtypeREAL1; break; } } switch (c[0]) { case 'B': okay = (col_bt == FFEINFO_basictypeINTEGER) || (col_bt == FFEINFO_basictypeLOGICAL); if (need_col) bt = col_bt; break; case 'F': okay = (col_bt == FFEINFO_basictypeCOMPLEX) || (col_bt == FFEINFO_basictypeREAL); if (need_col) bt = col_bt; break; case 'N': okay = (col_bt == FFEINFO_basictypeCOMPLEX) || (col_bt == FFEINFO_basictypeINTEGER) || (col_bt == FFEINFO_basictypeREAL); if (need_col) bt = col_bt; break; case 'S': okay = (col_bt == FFEINFO_basictypeINTEGER) || (col_bt == FFEINFO_basictypeREAL) || (col_bt == FFEINFO_basictypeCOMPLEX); if (need_col) bt = ((col_bt != FFEINFO_basictypeCOMPLEX) ? col_bt : FFEINFO_basictypeREAL); break; } switch (c[1]) { case '=': if (need_col) kt = col_kt; break; case 'C': if (col_bt == FFEINFO_basictypeCOMPLEX) { if (col_kt != FFEINFO_kindtypeREALDEFAULT) *check_intrin = TRUE; if (need_col) kt = col_kt; } break; } if (!okay) return FFEBAD_INTRINSIC_REF; } /* Now, convert args in the arglist to the final type of the COL. */ for (argno = 0, argc = &c[colon + 3], arg = args; *argc != '\0'; ++argno) { char optional = '\0'; char required = '\0'; char extra = '\0'; char basic; char kind; int length; int elements; bool lastarg_complex = FALSE; /* We don't do anything with keywords yet. */ do { } while (*(++argc) != '='); ++argc; if ((*argc == '?') || (*argc == '!') || (*argc == '*')) optional = *(argc++); if ((*argc == '+') || (*argc == 'n') || (*argc == 'p')) required = *(argc++); basic = *(argc++); kind = *(argc++); if (*argc == '[') { length = *++argc - '0'; if (*++argc != ']') length = 10 * length + (*(argc++) - '0'); ++argc; } else length = -1; if (*argc == '(') { elements = *++argc - '0'; if (*++argc != ')') elements = 10 * elements + (*(argc++) - '0'); ++argc; } else if (*argc == '&') { elements = -1; ++argc; } else elements = 0; if ((*argc == '&') || (*argc == 'i') || (*argc == 'w') || (*argc == 'x')) extra = *(argc++); if (*argc == ',') ++argc; /* Break out of this loop only when current arg spec completely processed. */ do { bool okay; ffebld a; ffeinfo i; bool anynum; ffeinfoBasictype abt = FFEINFO_basictypeNONE; ffeinfoKindtype akt = FFEINFO_kindtypeNONE; if ((arg == NULL) || (ffebld_head (arg) == NULL)) { if (arg != NULL) arg = ffebld_trail (arg); break; /* Try next argspec. */ } a = ffebld_head (arg); i = ffebld_info (a); anynum = (ffeinfo_basictype (i) == FFEINFO_basictypeHOLLERITH) || (ffeinfo_basictype (i) == FFEINFO_basictypeTYPELESS); /* Determine what the default type for anynum would be. */ if (anynum) { switch (c[colon + 1]) { case '-': break; case '0': case '1': case '2': case '3': case '4': case '5': case '6': case '7': case '8': case '9': if (argno != (c[colon + 1] - '0')) break; case '*': abt = col_bt; akt = col_kt; break; } } /* Again, match arg up to the spec. We go through all of this again to properly follow the contour of optional arguments. Probably this level of flexibility is not needed, perhaps it's even downright naughty. */ switch (basic) { case 'A': okay = (ffeinfo_basictype (i) == FFEINFO_basictypeCHARACTER) && ((length == -1) || (ffeinfo_size (i) == (ffetargetCharacterSize) length)); break; case 'C': okay = anynum || (ffeinfo_basictype (i) == FFEINFO_basictypeCOMPLEX); abt = FFEINFO_basictypeCOMPLEX; break; case 'I': okay = anynum || (ffeinfo_basictype (i) == FFEINFO_basictypeINTEGER); abt = FFEINFO_basictypeINTEGER; break; case 'L': okay = anynum || (ffeinfo_basictype (i) == FFEINFO_basictypeLOGICAL); abt = FFEINFO_basictypeLOGICAL; break; case 'R': okay = anynum || (ffeinfo_basictype (i) == FFEINFO_basictypeREAL); abt = FFEINFO_basictypeREAL; break; case 'B': okay = anynum || (ffeinfo_basictype (i) == FFEINFO_basictypeINTEGER) || (ffeinfo_basictype (i) == FFEINFO_basictypeLOGICAL); break; case 'F': okay = anynum || (ffeinfo_basictype (i) == FFEINFO_basictypeCOMPLEX) || (ffeinfo_basictype (i) == FFEINFO_basictypeREAL); break; case 'N': okay = anynum || (ffeinfo_basictype (i) == FFEINFO_basictypeCOMPLEX) || (ffeinfo_basictype (i) == FFEINFO_basictypeINTEGER) || (ffeinfo_basictype (i) == FFEINFO_basictypeREAL); break; case 'S': okay = anynum || (ffeinfo_basictype (i) == FFEINFO_basictypeINTEGER) || (ffeinfo_basictype (i) == FFEINFO_basictypeREAL); break; case 'g': okay = ((ffebld_op (a) == FFEBLD_opLABTER) || (ffebld_op (a) == FFEBLD_opLABTOK)); elements = -1; extra = '-'; break; case 's': okay = (((((ffeinfo_basictype (i) == FFEINFO_basictypeNONE) && (ffeinfo_kindtype (i) == FFEINFO_kindtypeNONE) && (ffeinfo_kind (i) == FFEINFO_kindSUBROUTINE)) || ((ffeinfo_basictype (i) == FFEINFO_basictypeINTEGER) && (ffeinfo_kindtype (i) == FFEINFO_kindtypeINTEGERDEFAULT) && (ffeinfo_kind (i) == FFEINFO_kindFUNCTION)) || (ffeinfo_kind (i) == FFEINFO_kindNONE)) && ((ffeinfo_where (i) == FFEINFO_whereDUMMY) || (ffeinfo_where (i) == FFEINFO_whereGLOBAL))) || ((ffeinfo_basictype (i) == FFEINFO_basictypeINTEGER) && (ffeinfo_kind (i) == FFEINFO_kindENTITY))); elements = -1; extra = '-'; break; case '-': default: okay = TRUE; break; } switch (kind) { case '1': case '2': case '3': case '4': case '5': case '6': case '7': case '8': case '9': akt = (kind - '0'); if ((ffeinfo_basictype (i) == FFEINFO_basictypeINTEGER) || (ffeinfo_basictype (i) == FFEINFO_basictypeLOGICAL)) { switch (akt) { /* Translate to internal kinds for now! */ default: break; case 2: akt = 4; break; case 3: akt = 2; break; case 4: akt = 5; break; case 6: akt = 3; break; case 7: akt = ffecom_pointer_kind (); break; } } okay &= anynum || (ffeinfo_kindtype (i) == akt); break; case 'A': okay &= anynum || (ffeinfo_kindtype (i) == firstarg_kt); akt = (firstarg_kt == FFEINFO_kindtype) ? FFEINFO_kindtypeNONE : firstarg_kt; break; case '*': default: break; } switch (elements) { ffebld b; case -1: break; case 0: if (ffeinfo_rank (i) != 0) okay = FALSE; break; default: if ((ffeinfo_rank (i) != 1) || (ffebld_op (a) != FFEBLD_opSYMTER) || ((b = ffesymbol_arraysize (ffebld_symter (a))) == NULL) || (ffebld_op (b) != FFEBLD_opCONTER) || (ffeinfo_basictype (ffebld_info (b)) != FFEINFO_basictypeINTEGER) || (ffeinfo_kindtype (ffebld_info (b)) != FFEINFO_kindtypeINTEGERDEFAULT) || (ffebld_constant_integer1 (ffebld_conter (b)) != elements)) okay = FALSE; break; } switch (extra) { case '&': if ((ffeinfo_kind (i) != FFEINFO_kindENTITY) || ((ffebld_op (a) != FFEBLD_opSYMTER) && (ffebld_op (a) != FFEBLD_opSUBSTR) && (ffebld_op (a) != FFEBLD_opARRAYREF))) okay = FALSE; break; case 'w': case 'x': if ((ffeinfo_kind (i) != FFEINFO_kindENTITY) || ((ffebld_op (a) != FFEBLD_opSYMTER) && (ffebld_op (a) != FFEBLD_opARRAYREF) && (ffebld_op (a) != FFEBLD_opSUBSTR))) okay = FALSE; break; case '-': case 'i': break; default: if (ffeinfo_kind (i) != FFEINFO_kindENTITY) okay = FALSE; break; } if ((optional == '!') && lastarg_complex) okay = FALSE; if (!okay) { /* If it wasn't optional, it's an error, else maybe it could match a later argspec. */ if (optional == '\0') return FFEBAD_INTRINSIC_REF; break; /* Try next argspec. */ } lastarg_complex = (ffeinfo_basictype (i) == FFEINFO_basictypeCOMPLEX); if (anynum && commit) { /* If we know dummy arg type, convert to that now. */ if (abt == FFEINFO_basictypeNONE) abt = FFEINFO_basictypeINTEGER; if (akt == FFEINFO_kindtypeNONE) akt = FFEINFO_kindtypeINTEGER1; /* We have a known type, convert hollerith/typeless to it. */ a = ffeexpr_convert (a, t, NULL, abt, akt, 0, FFETARGET_charactersizeNONE, FFEEXPR_contextLET); ffebld_set_head (arg, a); } else if ((c[colon + 1] == '*') && commit) { /* This is where we promote types to the consensus type for the COL. Maybe this is where -fpedantic should issue a warning as well. */ a = ffeexpr_convert (a, t, NULL, col_bt, col_kt, 0, ffeinfo_size (i), FFEEXPR_contextLET); ffebld_set_head (arg, a); } arg = ffebld_trail (arg); /* Arg accepted, now move on. */ if (optional == '*') continue; /* Go ahead and try another arg. */ if (required == '\0') break; if ((required == 'n') || (required == '+')) { optional = '*'; required = '\0'; } else if (required == 'p') required = 'n'; } while (TRUE); } *xbt = bt; *xkt = kt; *xsz = sz; return FFEBAD; } static bool ffeintrin_check_any_ (ffebld arglist) { ffebld item; for (; arglist != NULL; arglist = ffebld_trail (arglist)) { item = ffebld_head (arglist); if ((item != NULL) && (ffebld_op (item) == FFEBLD_opANY)) return TRUE; } return FALSE; } /* Compare a forced-to-uppercase name with a known-upper-case name. */ static int upcasecmp_ (const char *name, const char *ucname) { for ( ; *name != 0 && *ucname != 0; name++, ucname++) { int i = TOUPPER(*name) - *ucname; if (i != 0) return i; } return *name - *ucname; } /* Compare name to intrinsic's name. The intrinsics table is sorted on the upper case entries; so first compare irrespective of case on the `uc' entry. If it matches, compare according to the setting of intrinsics case comparison mode. */ static int ffeintrin_cmp_name_ (const void *name, const void *intrinsic) { const char *const uc = ((const struct _ffeintrin_name_ *) intrinsic)->name_uc; const char *const lc = ((const struct _ffeintrin_name_ *) intrinsic)->name_lc; const char *const ic = ((const struct _ffeintrin_name_ *) intrinsic)->name_ic; int i; if ((i = upcasecmp_ (name, uc)) == 0) { switch (ffe_case_intrin ()) { case FFE_caseLOWER: return strcmp(name, lc); case FFE_caseINITCAP: return strcmp(name, ic); default: return 0; } } return i; } /* Return basic type of intrinsic implementation, based on its run-time implementation *only*. (This is used only when the type of an intrinsic name is needed without having a list of arguments, i.e. an interface signature, such as when passing the intrinsic itself, or really the run-time-library function, as an argument.) If there's no eligible intrinsic implementation, there must be a bug somewhere else; no such reference should have been permitted to go this far. (Well, this might be wrong.) */ ffeinfoBasictype ffeintrin_basictype (ffeintrinSpec spec) { ffeintrinImp imp; ffecomGfrt gfrt; assert (spec < FFEINTRIN_spec); imp = ffeintrin_specs_[spec].implementation; assert (imp < FFEINTRIN_imp); if (ffe_is_f2c ()) gfrt = ffeintrin_imps_[imp].gfrt_f2c; else gfrt = ffeintrin_imps_[imp].gfrt_gnu; assert (gfrt != FFECOM_gfrt); return ffecom_gfrt_basictype (gfrt); } /* Return family to which specific intrinsic belongs. */ ffeintrinFamily ffeintrin_family (ffeintrinSpec spec) { if (spec >= FFEINTRIN_spec) return FALSE; return ffeintrin_specs_[spec].family; } /* Check and fill in info on func/subr ref node. ffebld expr; // FUNCREF or SUBRREF with no info (caller // gets it from the modified info structure). ffeinfo info; // Already filled in, will be overwritten. ffelexToken token; // Used for error message. ffeintrin_fulfill_generic (&expr, &info, token); Based on the generic id, figure out which specific procedure is meant and pick that one. Else return an error, a la _specific. */ void ffeintrin_fulfill_generic (ffebld *expr, ffeinfo *info, ffelexToken t) { ffebld symter; ffebldOp op; ffeintrinGen gen; ffeintrinSpec spec = FFEINTRIN_specNONE; ffeinfoBasictype bt = FFEINFO_basictypeNONE; ffeinfoKindtype kt = FFEINFO_kindtypeNONE; ffetargetCharacterSize sz = FFETARGET_charactersizeNONE; ffeintrinImp imp; ffeintrinSpec tspec; ffeintrinImp nimp = FFEINTRIN_impNONE; ffebad error; bool any = FALSE; bool highly_specific = FALSE; int i; op = ffebld_op (*expr); assert ((op == FFEBLD_opFUNCREF) || (op == FFEBLD_opSUBRREF)); assert (ffebld_op (ffebld_left (*expr)) == FFEBLD_opSYMTER); gen = ffebld_symter_generic (ffebld_left (*expr)); assert (gen != FFEINTRIN_genNONE); imp = FFEINTRIN_impNONE; error = FFEBAD; any = ffeintrin_check_any_ (ffebld_right (*expr)); for (i = 0; (((size_t) i) < ARRAY_SIZE (ffeintrin_gens_[gen].specs)) && ((tspec = ffeintrin_gens_[gen].specs[i]) != FFEINTRIN_specNONE) && !any; ++i) { ffeintrinImp timp = ffeintrin_specs_[tspec].implementation; ffeinfoBasictype tbt; ffeinfoKindtype tkt; ffetargetCharacterSize tsz; ffeIntrinsicState state = ffeintrin_state_family (ffeintrin_specs_[tspec].family); ffebad terror; if (state == FFE_intrinsicstateDELETED) continue; if (timp != FFEINTRIN_impNONE) { if (!(ffeintrin_imps_[timp].control[0] == '-') != !(ffebld_op (*expr) == FFEBLD_opSUBRREF)) continue; /* Form of reference must match form of specific. */ } if (state == FFE_intrinsicstateDISABLED) terror = FFEBAD_INTRINSIC_DISABLED; else if (timp == FFEINTRIN_impNONE) terror = FFEBAD_INTRINSIC_UNIMPL; else { terror = ffeintrin_check_ (timp, ffebld_op (*expr), ffebld_right (*expr), &tbt, &tkt, &tsz, NULL, t, FALSE); if (terror == FFEBAD) { if (imp != FFEINTRIN_impNONE) { ffebad_start (FFEBAD_INTRINSIC_AMBIG); ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t)); ffebad_string (ffeintrin_gens_[gen].name); ffebad_string (ffeintrin_specs_[spec].name); ffebad_string (ffeintrin_specs_[tspec].name); ffebad_finish (); } else { if (ffebld_symter_specific (ffebld_left (*expr)) == tspec) highly_specific = TRUE; imp = timp; spec = tspec; bt = tbt; kt = tkt; sz = tkt; error = terror; } } else if (terror != FFEBAD) { /* This error has precedence over others. */ if ((error == FFEBAD_INTRINSIC_DISABLED) || (error == FFEBAD_INTRINSIC_UNIMPL)) error = FFEBAD; } } if (error == FFEBAD) error = terror; } if (any || (imp == FFEINTRIN_impNONE)) { if (!any) { if (error == FFEBAD) error = FFEBAD_INTRINSIC_REF; ffebad_start (error); ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t)); ffebad_string (ffeintrin_gens_[gen].name); ffebad_finish (); } *expr = ffebld_new_any (); *info = ffeinfo_new_any (); } else { if (!highly_specific && (nimp != FFEINTRIN_impNONE)) { fprintf (stderr, "lineno=%ld, gen=%s, imp=%s, timp=%s\n", (long) input_line, ffeintrin_gens_[gen].name, ffeintrin_imps_[imp].name, ffeintrin_imps_[nimp].name); assert ("Ambiguous generic reference" == NULL); abort (); } error = ffeintrin_check_ (imp, ffebld_op (*expr), ffebld_right (*expr), &bt, &kt, &sz, NULL, t, TRUE); assert (error == FFEBAD); *info = ffeinfo_new (bt, kt, 0, FFEINFO_kindENTITY, FFEINFO_whereFLEETING, sz); symter = ffebld_left (*expr); ffebld_symter_set_specific (symter, spec); ffebld_symter_set_implementation (symter, imp); ffebld_set_info (symter, ffeinfo_new (bt, kt, 0, (bt == FFEINFO_basictypeNONE) ? FFEINFO_kindSUBROUTINE : FFEINFO_kindFUNCTION, FFEINFO_whereINTRINSIC, sz)); if ((ffesymbol_attrs (ffebld_symter (symter)) & FFESYMBOL_attrsTYPE) && (((bt != ffesymbol_basictype (ffebld_symter (symter))) || (kt != ffesymbol_kindtype (ffebld_symter (symter))) || ((sz != FFETARGET_charactersizeNONE) && (sz != ffesymbol_size (ffebld_symter (symter))))))) { ffebad_start (FFEBAD_INTRINSIC_TYPE); ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t)); ffebad_string (ffeintrin_gens_[gen].name); ffebad_finish (); } if (ffeintrin_imps_[imp].y2kbad) { ffebad_start (FFEBAD_INTRINSIC_Y2KBAD); ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t)); ffebad_string (ffeintrin_gens_[gen].name); ffebad_finish (); } } } /* Check and fill in info on func/subr ref node. ffebld expr; // FUNCREF or SUBRREF with no info (caller // gets it from the modified info structure). ffeinfo info; // Already filled in, will be overwritten. bool check_intrin; // May be omitted, else set TRUE if intrinsic needs checking. ffelexToken token; // Used for error message. ffeintrin_fulfill_specific (&expr, &info, &check_intrin, token); Based on the specific id, determine whether the arg list is valid (number, type, rank, and kind of args) and fill in the info structure accordingly. Currently don't rewrite the expression, but perhaps someday do so for constant collapsing, except when an error occurs, in which case it is overwritten with ANY and info is also overwritten accordingly. */ void ffeintrin_fulfill_specific (ffebld *expr, ffeinfo *info, bool *check_intrin, ffelexToken t) { ffebld symter; ffebldOp op; ffeintrinGen gen; ffeintrinSpec spec; ffeintrinImp imp; ffeinfoBasictype bt = FFEINFO_basictypeNONE; ffeinfoKindtype kt = FFEINFO_kindtypeNONE; ffetargetCharacterSize sz = FFETARGET_charactersizeNONE; ffeIntrinsicState state; ffebad error; bool any = FALSE; const char *name; op = ffebld_op (*expr); assert ((op == FFEBLD_opFUNCREF) || (op == FFEBLD_opSUBRREF)); assert (ffebld_op (ffebld_left (*expr)) == FFEBLD_opSYMTER); gen = ffebld_symter_generic (ffebld_left (*expr)); spec = ffebld_symter_specific (ffebld_left (*expr)); assert (spec != FFEINTRIN_specNONE); if (gen != FFEINTRIN_genNONE) name = ffeintrin_gens_[gen].name; else name = ffeintrin_specs_[spec].name; state = ffeintrin_state_family (ffeintrin_specs_[spec].family); imp = ffeintrin_specs_[spec].implementation; if (check_intrin != NULL) *check_intrin = FALSE; any = ffeintrin_check_any_ (ffebld_right (*expr)); if (state == FFE_intrinsicstateDISABLED) error = FFEBAD_INTRINSIC_DISABLED; else if (imp == FFEINTRIN_impNONE) error = FFEBAD_INTRINSIC_UNIMPL; else if (!any) { error = ffeintrin_check_ (imp, ffebld_op (*expr), ffebld_right (*expr), &bt, &kt, &sz, check_intrin, t, TRUE); } else error = FFEBAD; /* Not really needed, but quiet -Wuninitialized. */ if (any || (error != FFEBAD)) { if (!any) { ffebad_start (error); ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t)); ffebad_string (name); ffebad_finish (); } *expr = ffebld_new_any (); *info = ffeinfo_new_any (); } else { *info = ffeinfo_new (bt, kt, 0, FFEINFO_kindENTITY, FFEINFO_whereFLEETING, sz); symter = ffebld_left (*expr); ffebld_set_info (symter, ffeinfo_new (bt, kt, 0, (bt == FFEINFO_basictypeNONE) ? FFEINFO_kindSUBROUTINE : FFEINFO_kindFUNCTION, FFEINFO_whereINTRINSIC, sz)); if ((ffesymbol_attrs (ffebld_symter (symter)) & FFESYMBOL_attrsTYPE) && (((bt != ffesymbol_basictype (ffebld_symter (symter))) || (kt != ffesymbol_kindtype (ffebld_symter (symter))) || (sz != ffesymbol_size (ffebld_symter (symter)))))) { ffebad_start (FFEBAD_INTRINSIC_TYPE); ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t)); ffebad_string (name); ffebad_finish (); } if (ffeintrin_imps_[imp].y2kbad) { ffebad_start (FFEBAD_INTRINSIC_Y2KBAD); ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t)); ffebad_string (name); ffebad_finish (); } } } /* Return run-time index of intrinsic implementation as direct call. */ ffecomGfrt ffeintrin_gfrt_direct (ffeintrinImp imp) { assert (imp < FFEINTRIN_imp); return ffeintrin_imps_[imp].gfrt_direct; } /* Return run-time index of intrinsic implementation as actual argument. */ ffecomGfrt ffeintrin_gfrt_indirect (ffeintrinImp imp) { assert (imp < FFEINTRIN_imp); if (! ffe_is_f2c ()) return ffeintrin_imps_[imp].gfrt_gnu; return ffeintrin_imps_[imp].gfrt_f2c; } void ffeintrin_init_0 () { int i; const char *p1; const char *p2; const char *p3; int colon; if (!ffe_is_do_internal_checks ()) return; assert (FFEINTRIN_gen == ARRAY_SIZE (ffeintrin_gens_)); assert (FFEINTRIN_imp == ARRAY_SIZE (ffeintrin_imps_)); assert (FFEINTRIN_spec == ARRAY_SIZE (ffeintrin_specs_)); for (i = 1; ((size_t) i) < ARRAY_SIZE (ffeintrin_names_); ++i) { /* Make sure binary-searched list is in alpha order. */ if (strcmp (ffeintrin_names_[i - 1].name_uc, ffeintrin_names_[i].name_uc) >= 0) assert ("name list out of order" == NULL); } for (i = 0; ((size_t) i) < ARRAY_SIZE (ffeintrin_names_); ++i) { assert ((ffeintrin_names_[i].generic == FFEINTRIN_genNONE) || (ffeintrin_names_[i].specific == FFEINTRIN_specNONE)); p1 = ffeintrin_names_[i].name_uc; p2 = ffeintrin_names_[i].name_lc; p3 = ffeintrin_names_[i].name_ic; for (; *p1 != '\0' && *p2 != '\0' && *p3 != '\0'; ++p1, ++p2, ++p3) { if ((ISDIGIT (*p1) || (*p1 == '_')) && (*p1 == *p2) && (*p1 == *p3)) continue; if (! ISUPPER ((unsigned char)*p1) || ! ISLOWER ((unsigned char)*p2) || (*p1 != TOUPPER (*p2)) || ((*p3 != *p1) && (*p3 != *p2))) break; } assert ((*p1 == *p2) && (*p1 == *p3) && (*p1 == '\0')); } for (i = 0; ((size_t) i) < ARRAY_SIZE (ffeintrin_imps_); ++i) { const char *c = ffeintrin_imps_[i].control; if (c[0] == '\0') continue; if ((c[0] != '-') && (c[0] != 'A') && (c[0] != 'C') && (c[0] != 'I') && (c[0] != 'L') && (c[0] != 'R') && (c[0] != 'B') && (c[0] != 'F') && (c[0] != 'N') && (c[0] != 'S')) { fprintf (stderr, "%s: bad return-base-type\n", ffeintrin_imps_[i].name); continue; } if ((c[1] != '-') && (c[1] != '=') && ((c[1] < '1') || (c[1] > '9')) && (c[1] != 'C')) { fprintf (stderr, "%s: bad return-kind-type\n", ffeintrin_imps_[i].name); continue; } if (c[2] == ':') colon = 2; else { if (c[2] != '*') { fprintf (stderr, "%s: bad return-modifier\n", ffeintrin_imps_[i].name); continue; } colon = 3; } if ((c[colon] != ':') || (c[colon + 2] != ':')) { fprintf (stderr, "%s: bad control\n", ffeintrin_imps_[i].name); continue; } if ((c[colon + 1] != '-') && (c[colon + 1] != '*') && (! ISDIGIT (c[colon + 1]))) { fprintf (stderr, "%s: bad COL-spec\n", ffeintrin_imps_[i].name); continue; } c += (colon + 3); while (c[0] != '\0') { while ((c[0] != '=') && (c[0] != ',') && (c[0] != '\0')) ++c; if (c[0] != '=') { fprintf (stderr, "%s: bad keyword\n", ffeintrin_imps_[i].name); break; } if ((c[1] == '?') || (c[1] == '!') || (c[1] == '+') || (c[1] == '*') || (c[1] == 'n') || (c[1] == 'p')) ++c; if ((c[1] != '-') && (c[1] != 'A') && (c[1] != 'C') && (c[1] != 'I') && (c[1] != 'L') && (c[1] != 'R') && (c[1] != 'B') && (c[1] != 'F') && (c[1] != 'N') && (c[1] != 'S') && (c[1] != 'g') && (c[1] != 's')) { fprintf (stderr, "%s: bad arg-base-type\n", ffeintrin_imps_[i].name); break; } if ((c[2] != '*') && ((c[2] < '1') || (c[2] > '9')) && (c[2] != 'A')) { fprintf (stderr, "%s: bad arg-kind-type\n", ffeintrin_imps_[i].name); break; } if (c[3] == '[') { if ((! ISDIGIT (c[4])) || ((c[5] != ']') && (++c, ! ISDIGIT (c[4]) || (c[5] != ']')))) { fprintf (stderr, "%s: bad arg-len\n", ffeintrin_imps_[i].name); break; } c += 3; } if (c[3] == '(') { if ((! ISDIGIT (c[4])) || ((c[5] != ')') && (++c, ! ISDIGIT (c[4]) || (c[5] != ')')))) { fprintf (stderr, "%s: bad arg-rank\n", ffeintrin_imps_[i].name); break; } c += 3; } else if ((c[3] == '&') && (c[4] == '&')) ++c; if ((c[3] == '&') || (c[3] == 'i') || (c[3] == 'w') || (c[3] == 'x')) ++c; if (c[3] == ',') { c += 4; continue; } if (c[3] != '\0') { fprintf (stderr, "%s: bad arg-list\n", ffeintrin_imps_[i].name); } break; } } } /* Determine whether intrinsic is okay as an actual argument. */ bool ffeintrin_is_actualarg (ffeintrinSpec spec) { ffeIntrinsicState state; if (spec >= FFEINTRIN_spec) return FALSE; state = ffeintrin_state_family (ffeintrin_specs_[spec].family); return (!ffe_is_pedantic () || ffeintrin_specs_[spec].is_actualarg) && (ffe_is_f2c () ? (ffeintrin_imps_[ffeintrin_specs_[spec].implementation].gfrt_f2c != FFECOM_gfrt) : (ffeintrin_imps_[ffeintrin_specs_[spec].implementation].gfrt_gnu != FFECOM_gfrt)) && ((state == FFE_intrinsicstateENABLED) || (state == FFE_intrinsicstateHIDDEN)); } /* Determine if name is intrinsic, return info. const char *name; // C-string name of possible intrinsic. ffelexToken t; // NULL if no diagnostic to be given. bool explicit; // TRUE if INTRINSIC name. ffeintrinGen gen; // (TRUE only) Generic id of intrinsic. ffeintrinSpec spec; // (TRUE only) Specific id of intrinsic. ffeintrinImp imp; // (TRUE only) Implementation id of intrinsic. if (ffeintrin_is_intrinsic (name, t, explicit, &gen, &spec, &imp)) // is an intrinsic, use gen, spec, imp, and // kind accordingly. */ bool ffeintrin_is_intrinsic (const char *name, ffelexToken t, bool explicit, ffeintrinGen *xgen, ffeintrinSpec *xspec, ffeintrinImp *ximp) { struct _ffeintrin_name_ *intrinsic; ffeintrinGen gen; ffeintrinSpec spec; ffeintrinImp imp; ffeIntrinsicState state; bool disabled = FALSE; bool unimpl = FALSE; intrinsic = bsearch (name, &ffeintrin_names_[0], ARRAY_SIZE (ffeintrin_names_), sizeof (struct _ffeintrin_name_), (void *) ffeintrin_cmp_name_); if (intrinsic == NULL) return FALSE; gen = intrinsic->generic; spec = intrinsic->specific; imp = ffeintrin_specs_[spec].implementation; /* Generic is okay only if at least one of its specifics is okay. */ if (gen != FFEINTRIN_genNONE) { int i; ffeintrinSpec tspec; bool ok = FALSE; name = ffeintrin_gens_[gen].name; for (i = 0; (((size_t) i) < ARRAY_SIZE (ffeintrin_gens_[gen].specs)) && ((tspec = ffeintrin_gens_[gen].specs[i]) != FFEINTRIN_specNONE); ++i) { state = ffeintrin_state_family (ffeintrin_specs_[tspec].family); if (state == FFE_intrinsicstateDELETED) continue; if (state == FFE_intrinsicstateDISABLED) { disabled = TRUE; continue; } if (ffeintrin_specs_[tspec].implementation == FFEINTRIN_impNONE) { unimpl = TRUE; continue; } if ((state == FFE_intrinsicstateENABLED) || (explicit && (state == FFE_intrinsicstateHIDDEN))) { ok = TRUE; break; } } if (!ok) gen = FFEINTRIN_genNONE; } /* Specific is okay only if not: unimplemented, disabled, deleted, or hidden and not explicit. */ if (spec != FFEINTRIN_specNONE) { if (gen != FFEINTRIN_genNONE) name = ffeintrin_gens_[gen].name; else name = ffeintrin_specs_[spec].name; if (((state = ffeintrin_state_family (ffeintrin_specs_[spec].family)) == FFE_intrinsicstateDELETED) || (!explicit && (state == FFE_intrinsicstateHIDDEN))) spec = FFEINTRIN_specNONE; else if (state == FFE_intrinsicstateDISABLED) { disabled = TRUE; spec = FFEINTRIN_specNONE; } else if (imp == FFEINTRIN_impNONE) { unimpl = TRUE; spec = FFEINTRIN_specNONE; } } /* If neither is okay, not an intrinsic. */ if ((gen == FFEINTRIN_genNONE) && (spec == FFEINTRIN_specNONE)) { /* Here is where we produce a diagnostic about a reference to a disabled or unimplemented intrinsic, if the diagnostic is desired. */ if ((disabled || unimpl) && (t != NULL)) { ffebad_start (disabled ? FFEBAD_INTRINSIC_DISABLED : FFEBAD_INTRINSIC_UNIMPLW); ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t)); ffebad_string (name); ffebad_finish (); } return FALSE; } /* Determine whether intrinsic is function or subroutine. If no specific id, scan list of possible specifics for generic to get consensus. If not unanimous, or clear from the context, return NONE. */ if (spec == FFEINTRIN_specNONE) { int i; ffeintrinSpec tspec; ffeintrinImp timp; bool at_least_one_ok = FALSE; for (i = 0; (((size_t) i) < ARRAY_SIZE (ffeintrin_gens_[gen].specs)) && ((tspec = ffeintrin_gens_[gen].specs[i]) != FFEINTRIN_specNONE); ++i) { if (((state = ffeintrin_state_family (ffeintrin_specs_[tspec].family)) == FFE_intrinsicstateDELETED) || (state == FFE_intrinsicstateDISABLED)) continue; if ((timp = ffeintrin_specs_[tspec].implementation) == FFEINTRIN_impNONE) continue; at_least_one_ok = TRUE; break; } if (!at_least_one_ok) { *xgen = FFEINTRIN_genNONE; *xspec = FFEINTRIN_specNONE; *ximp = FFEINTRIN_impNONE; return FALSE; } } *xgen = gen; *xspec = spec; *ximp = imp; return TRUE; } /* Return TRUE if intrinsic is standard F77 (or, if -ff90, F90). */ bool ffeintrin_is_standard (ffeintrinGen gen, ffeintrinSpec spec) { if (spec == FFEINTRIN_specNONE) { if (gen == FFEINTRIN_genNONE) return FALSE; spec = ffeintrin_gens_[gen].specs[0]; if (spec == FFEINTRIN_specNONE) return FALSE; } if ((ffeintrin_specs_[spec].family == FFEINTRIN_familyF77) || (ffe_is_90 () && ((ffeintrin_specs_[spec].family == FFEINTRIN_familyF90) || (ffeintrin_specs_[spec].family == FFEINTRIN_familyMIL) || (ffeintrin_specs_[spec].family == FFEINTRIN_familyASC)))) return TRUE; return FALSE; } /* Return kind type of intrinsic implementation. See ffeintrin_basictype, its sibling. */ ffeinfoKindtype ffeintrin_kindtype (ffeintrinSpec spec) { ffeintrinImp imp; ffecomGfrt gfrt; assert (spec < FFEINTRIN_spec); imp = ffeintrin_specs_[spec].implementation; assert (imp < FFEINTRIN_imp); if (ffe_is_f2c ()) gfrt = ffeintrin_imps_[imp].gfrt_f2c; else gfrt = ffeintrin_imps_[imp].gfrt_gnu; assert (gfrt != FFECOM_gfrt); return ffecom_gfrt_kindtype (gfrt); } /* Return name of generic intrinsic. */ const char * ffeintrin_name_generic (ffeintrinGen gen) { assert (gen < FFEINTRIN_gen); return ffeintrin_gens_[gen].name; } /* Return name of intrinsic implementation. */ const char * ffeintrin_name_implementation (ffeintrinImp imp) { assert (imp < FFEINTRIN_imp); return ffeintrin_imps_[imp].name; } /* Return external/internal name of specific intrinsic. */ const char * ffeintrin_name_specific (ffeintrinSpec spec) { assert (spec < FFEINTRIN_spec); return ffeintrin_specs_[spec].name; } /* Return state of family. */ ffeIntrinsicState ffeintrin_state_family (ffeintrinFamily family) { ffeIntrinsicState state; switch (family) { case FFEINTRIN_familyNONE: return FFE_intrinsicstateDELETED; case FFEINTRIN_familyF77: return FFE_intrinsicstateENABLED; case FFEINTRIN_familyASC: state = ffe_intrinsic_state_f2c (); state = ffe_state_max (state, ffe_intrinsic_state_f90 ()); return state; case FFEINTRIN_familyMIL: state = ffe_intrinsic_state_vxt (); state = ffe_state_max (state, ffe_intrinsic_state_f90 ()); state = ffe_state_max (state, ffe_intrinsic_state_mil ()); return state; case FFEINTRIN_familyGNU: state = ffe_intrinsic_state_gnu (); return state; case FFEINTRIN_familyF90: state = ffe_intrinsic_state_f90 (); return state; case FFEINTRIN_familyVXT: state = ffe_intrinsic_state_vxt (); return state; case FFEINTRIN_familyFVZ: state = ffe_intrinsic_state_f2c (); state = ffe_state_max (state, ffe_intrinsic_state_vxt ()); return state; case FFEINTRIN_familyF2C: state = ffe_intrinsic_state_f2c (); return state; case FFEINTRIN_familyF2U: state = ffe_intrinsic_state_unix (); return state; case FFEINTRIN_familyBADU77: state = ffe_intrinsic_state_badu77 (); return state; default: assert ("bad family" == NULL); return FFE_intrinsicstateDELETED; } }