/* intrin.c -- Recognize references to intrinsics
- Copyright (C) 1995-1998 Free Software Foundation, Inc.
- Contributed by James Craig Burley (burley@gnu.ai.mit.edu).
+ Copyright (C) 1995, 1996, 1997, 1998 Free Software Foundation, Inc.
+ Contributed by James Craig Burley.
This file is part of GNU Fortran.
*/
#include "proj.h"
-#include <ctype.h>
#include "intrin.h"
#include "expr.h"
#include "info.h"
struct _ffeintrin_name_
{
- char *name_uc;
- char *name_lc;
- char *name_ic;
+ const char *name_uc;
+ const char *name_lc;
+ const char *name_ic;
ffeintrinGen generic;
ffeintrinSpec specific;
};
struct _ffeintrin_gen_
{
- char *name; /* Name as seen in program. */
+ const char *name; /* Name as seen in program. */
ffeintrinSpec specs[2];
};
struct _ffeintrin_spec_
{
- char *name; /* Uppercase name as seen in source code,
+ const char *name; /* Uppercase name as seen in source code,
lowercase if no source name, "none" if no
name at all (NONE case). */
bool is_actualarg; /* Ok to pass as actual arg if -pedantic. */
struct _ffeintrin_imp_
{
- char *name; /* Name of implementation. */
+ const char *name; /* Name of implementation. */
#if FFECOM_targetCURRENT == FFECOM_targetGCC
ffecomGfrt gfrt_direct; /* library routine, direct-callable form. */
ffecomGfrt gfrt_f2c; /* library routine, f2c-callable form. */
ffecomGfrt gfrt_gnu; /* library routine, gnu-callable form. */
#endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */
- char *control;
+ const char *control;
+ char y2kbad;
};
static ffebad ffeintrin_check_ (ffeintrinImp imp, ffebldOp op,
#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 struct _ffeintrin_gen_ ffeintrin_gens_[]
{ 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 struct _ffeintrin_imp_ ffeintrin_imps_[]
#if FFECOM_targetCURRENT == FFECOM_targetGCC
#define DEFIMP(CODE,NAME,GFRTDIRECT,GFRTF2C,GFRTGNU,CONTROL) \
{ NAME, FFECOM_gfrt ## GFRTDIRECT, FFECOM_gfrt ## GFRTF2C, \
- FFECOM_gfrt ## GFRTGNU, CONTROL },
+ 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 },
#elif FFECOM_targetCURRENT == FFECOM_targetFFE
#define DEFIMP(CODE,NAME,GFRTDIRECT,GFRTF2C,GFRTGNU,CONTROL) \
- { NAME, CONTROL },
+ { NAME, CONTROL, FALSE },
+#define DEFIMPY(CODE,NAME,GFRTDIRECT,GFRTF2C,GFRTGNU,CONTROL,Y2KBAD) \
+ { NAME, CONTROL, Y2KBAD },
#else
#error
#endif
#undef DEFGEN
#undef DEFSPEC
#undef DEFIMP
+#undef DEFIMPY
};
static struct _ffeintrin_spec_ ffeintrin_specs_[]
#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
ffelexToken t,
bool commit)
{
- char *c = ffeintrin_imps_[imp].control;
+ const char *c = ffeintrin_imps_[imp].control;
bool subr = (c[0] == '-');
- char *argc;
+ const char *argc;
ffebld arg;
ffeinfoBasictype bt;
ffeinfoKindtype kt;
static int
ffeintrin_cmp_name_ (const void *name, const void *intrinsic)
{
- char *uc = (char *) ((struct _ffeintrin_name_ *) intrinsic)->name_uc;
- char *lc = (char *) ((struct _ffeintrin_name_ *) intrinsic)->name_lc;
- char *ic = (char *) ((struct _ffeintrin_name_ *) intrinsic)->name_ic;
+ const char *uc = ((const struct _ffeintrin_name_ *) intrinsic)->name_uc;
+ const char *lc = ((const struct _ffeintrin_name_ *) intrinsic)->name_lc;
+ const char *ic = ((const struct _ffeintrin_name_ *) intrinsic)->name_ic;
return ffesrc_strcmp_2c (ffe_case_intrin (), name, uc, lc, ic);
}
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 ();
+ }
}
}
ffeIntrinsicState state;
ffebad error;
bool any = FALSE;
- char *name;
+ const char *name;
op = ffebld_op (*expr);
assert ((op == FFEBLD_opFUNCREF) || (op == FFEBLD_opSUBRREF));
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 ();
+ }
}
}
ffeintrin_init_0 ()
{
int i;
- char *p1;
- char *p2;
- char *p3;
+ const char *p1;
+ const char *p2;
+ const char *p3;
int colon;
if (!ffe_is_do_internal_checks ())
p3 = ffeintrin_names_[i].name_ic;
for (; *p1 != '\0' && *p2 != '\0' && *p3 != '\0'; ++p1, ++p2, ++p3)
{
- if (!isascii (*p1) || !isascii (*p2) || !isascii (*p3))
- break;
- if ((isdigit (*p1) || (*p1 == '_')) && (*p1 == *p2) && (*p1 == *p3))
+ if ((ISDIGIT (*p1) || (*p1 == '_')) && (*p1 == *p2) && (*p1 == *p3))
continue;
- if (!isupper (*p1) || !islower (*p2)
- || (*p1 != toupper (*p2)) || ((*p3 != *p1) && (*p3 != *p2)))
+ 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)
{
- char *c = ffeintrin_imps_[i].control;
+ const char *c = ffeintrin_imps_[i].control;
if (c[0] == '\0')
continue;
|| (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'))
- || ((c[2] != '*')
- && ((c[2] < '1')
- || (c[2] > '9'))
- && (c[2] != 'A')))
+ 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-type\n",
+ fprintf (stderr, "%s: bad arg-kind-type\n",
ffeintrin_imps_[i].name);
break;
}
/* Determine if name is intrinsic, return info.
- char *name; // C-string name of possible intrinsic.
+ 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.
// kind accordingly. */
bool
-ffeintrin_is_intrinsic (char *name, ffelexToken t, bool explicit,
+ffeintrin_is_intrinsic (const char *name, ffelexToken t, bool explicit,
ffeintrinGen *xgen, ffeintrinSpec *xspec,
ffeintrinImp *ximp)
{
/* Return name of generic intrinsic. */
-char *
+const char *
ffeintrin_name_generic (ffeintrinGen gen)
{
assert (gen < FFEINTRIN_gen);
/* Return name of intrinsic implementation. */
-char *
+const char *
ffeintrin_name_implementation (ffeintrinImp imp)
{
assert (imp < FFEINTRIN_imp);
/* Return external/internal name of specific intrinsic. */
-char *
+const char *
ffeintrin_name_specific (ffeintrinSpec spec)
{
assert (spec < FFEINTRIN_spec);