* update_web_docs (PREPROCESS): Rename to WWWPREPROCESS.

[pf3gnuchains/gcc-fork.git] / gcc / f / intrin.c

diff --git a/gcc/f/intrin.c b/gcc/f/intrin.c
index 1f07d0c..0bc6d0e 100644 (file)
--- a/gcc/f/intrin.c
+++ b/gcc/f/intrin.c
@@ -1,6 +1,6 @@
 /* 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.
 
@@ -22,7 +22,6 @@ the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA
 */
 
 #include "proj.h"
-#include <ctype.h>
 #include "intrin.h"
 #include "expr.h"
 #include "info.h"
@@ -33,22 +32,22 @@ the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA
 
 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. */
@@ -58,13 +57,14 @@ struct _ffeintrin_spec_
 
 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,
@@ -85,11 +85,13 @@ static struct _ffeintrin_name_ ffeintrin_names_[]
 #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_[]
@@ -100,11 +102,13 @@ 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_[]
@@ -116,10 +120,15 @@ 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
@@ -128,6 +137,7 @@ static struct _ffeintrin_imp_ ffeintrin_imps_[]
 #undef DEFGEN
 #undef DEFSPEC
 #undef DEFIMP
+#undef DEFIMPY
 };
 
 static struct _ffeintrin_spec_ ffeintrin_specs_[]
@@ -138,10 +148,12 @@ 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
 
@@ -154,9 +166,9 @@ ffeintrin_check_ (ffeintrinImp imp, ffebldOp op,
                  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;
@@ -1153,9 +1165,9 @@ ffeintrin_check_any_ (ffebld arglist)
 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);
 }
@@ -1375,6 +1387,14 @@ ffeintrin_fulfill_generic (ffebld *expr, ffeinfo *info, ffelexToken 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 ();
+       }
     }
 }
 
@@ -1409,7 +1429,7 @@ ffeintrin_fulfill_specific (ffebld *expr, ffeinfo *info,
   ffeIntrinsicState state;
   ffebad error;
   bool any = FALSE;
-  char *name;
+  const char *name;
 
   op = ffebld_op (*expr);
   assert ((op == FFEBLD_opFUNCREF) || (op == FFEBLD_opSUBRREF));
@@ -1490,6 +1510,14 @@ ffeintrin_fulfill_specific (ffebld *expr, ffeinfo *info,
          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 ();
+       }
     }
 }
 
@@ -1523,9 +1551,9 @@ void
 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 ())
@@ -1553,12 +1581,11 @@ ffeintrin_init_0 ()
       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'));
@@ -1566,7 +1593,7 @@ ffeintrin_init_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;
@@ -1744,7 +1771,7 @@ ffeintrin_is_actualarg (ffeintrinSpec spec)
 
 /* 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.
@@ -1756,7 +1783,7 @@ ffeintrin_is_actualarg (ffeintrinSpec spec)
                                // 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)
 {
@@ -1967,7 +1994,7 @@ ffeintrin_kindtype (ffeintrinSpec spec)
 
 /* Return name of generic intrinsic.  */
 
-char *
+const char *
 ffeintrin_name_generic (ffeintrinGen gen)
 {
   assert (gen < FFEINTRIN_gen);
@@ -1976,7 +2003,7 @@ ffeintrin_name_generic (ffeintrinGen gen)
 
 /* Return name of intrinsic implementation.  */
 
-char *
+const char *
 ffeintrin_name_implementation (ffeintrinImp imp)
 {
   assert (imp < FFEINTRIN_imp);
@@ -1985,7 +2012,7 @@ ffeintrin_name_implementation (ffeintrinImp imp)
 
 /* Return external/internal name of specific intrinsic.         */
 
-char *
+const char *
 ffeintrin_name_specific (ffeintrinSpec spec)
 {
   assert (spec < FFEINTRIN_spec);