diff options
Diffstat (limited to 'contrib/gcc/f/intrin.c')
| -rw-r--r-- | contrib/gcc/f/intrin.c | 2119 |
1 files changed, 0 insertions, 2119 deletions
diff --git a/contrib/gcc/f/intrin.c b/contrib/gcc/f/intrin.c deleted file mode 100644 index a379684..0000000 --- a/contrib/gcc/f/intrin.c +++ /dev/null @@ -1,2119 +0,0 @@ -/* 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 (void) -{ - 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; - } -} |
