+++ /dev/null
-/* intrin.c -- Recognize references to intrinsics
- Copyright (C) 1995, 1996, 1997, 1998, 2002 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
-};
-\f
-
-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) lineno,
- 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;
- }
-}
projects / msp430-gcc.git / blobdiff