Virgin import of the GCC 2.95.1 compilers

1 files changed, 57 insertions, 27 deletions

diff --git a/contrib/gcc/f/intrin.c b/contrib/gcc/f/intrin.c
index 6e27d21..dbf375b 100644
--- a/contrib/gcc/f/intrin.c
+++ b/contrib/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.org).
+   Contributed by James Craig Burley.
 
 This file is part of GNU Fortran.
 
@@ -32,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. */
@@ -57,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,
@@ -84,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_[]
@@ -99,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_[]
@@ -115,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
@@ -127,6 +137,7 @@ static struct _ffeintrin_imp_ ffeintrin_imps_[]
 #undef DEFGEN
 #undef DEFSPEC
 #undef DEFIMP
+#undef DEFIMPY
 };
 
 static struct _ffeintrin_spec_ ffeintrin_specs_[]
@@ -137,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
 };
 
 
@@ -153,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;
@@ -1152,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 = ((struct _ffeintrin_name_ *) intrinsic)->name_uc;
+  const char *lc = ((struct _ffeintrin_name_ *) intrinsic)->name_lc;
+  const char *ic = ((struct _ffeintrin_name_ *) intrinsic)->name_ic;
 
   return ffesrc_strcmp_2c (ffe_case_intrin (), name, uc, lc, ic);
 }
@@ -1374,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 ();
+	}
     }
 }
 
@@ -1408,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));
@@ -1489,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 ();
+	}
     }
 }
 
@@ -1522,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 ())
@@ -1558,8 +1587,9 @@ ffeintrin_init_0 ()
 	    break;
 	  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 ((unsigned char)*p2))
+	      || ((*p3 != *p1) && (*p3 != *p2)))
 	    break;
 	}
       assert ((*p1 == *p2) && (*p1 == *p3) && (*p1 == '\0'));
@@ -1567,7 +1597,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;
@@ -1745,7 +1775,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.
@@ -1757,7 +1787,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)
 {
@@ -1968,7 +1998,7 @@ ffeintrin_kindtype (ffeintrinSpec spec)
 
 /* Return name of generic intrinsic.  */
 
-char *
+const char *
 ffeintrin_name_generic (ffeintrinGen gen)
 {
   assert (gen < FFEINTRIN_gen);
@@ -1977,7 +2007,7 @@ ffeintrin_name_generic (ffeintrinGen gen)
 
 /* Return name of intrinsic implementation.  */
 
-char *
+const char *
 ffeintrin_name_implementation (ffeintrinImp imp)
 {
   assert (imp < FFEINTRIN_imp);
@@ -1986,7 +2016,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);