2003-03-22 Bud Davis <bdavis9659@comcast.net>

	* com.c (ffecom_constantunion_with_type): New function.
	* com.h (ffecom_constantunion_with_type): Declare.
	* stc.c (ffestc_R810): Check for kind type.
	* ste.c (ffeste_R810): Use ffecom_constantunion_with_type
	to discern SELECT CASE variables.


git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@64709 138bc75d-0d04-0410-961f-82ee72b054a4

5 files changed, 96 insertions, 9 deletions

diff --git a/gcc/f/ChangeLog b/gcc/f/ChangeLog
index 73eddc137e3..848f6498785 100644
--- a/gcc/f/ChangeLog
+++ b/gcc/f/ChangeLog
@@ -1,3 +1,11 @@
+2003-03-22  Bud Davis  <bdavis9659@comcast.net>
+
+	* com.c (ffecom_constantunion_with_type): New function.
+	* com.h (ffecom_constantunion_with_type): Declare.
+	* stc.c (ffestc_R810): Check for kind type.
+	* ste.c (ffeste_R810): Use ffecom_constantunion_with_type
+	to discern SELECT CASE variables.
+
 2003-03-15  Roger Sayle  <roger@eyesopen.com>
 
 	* stb.c (ffestb_R100110_): Allow the number before the X format
diff --git a/gcc/f/com.c b/gcc/f/com.c
index 08954852c95..b850774be78 100644
--- a/gcc/f/com.c
+++ b/gcc/f/com.c
@@ -10591,6 +10591,78 @@ ffecom_constantunion (ffebldConstantUnion *cu, ffeinfoBasictype bt,
   return item;
 }
 
+/* Transform constant-union to tree, with the type known.  */
+
+tree
+ffecom_constantunion_with_type (ffebldConstantUnion *cu,
+		      tree tree_type, ffebldConst ct)
+{
+  tree item;
+
+  int val;
+
+  switch (ct)
+  {
+#if FFETARGET_okINTEGER1
+	  case  FFEBLD_constINTEGER1:
+         	  val = ffebld_cu_val_integer1 (*cu);
+		  item = build_int_2 (val, (val < 0) ? -1 : 0);
+		  break;
+#endif
+#if FFETARGET_okINTEGER2
+	  case  FFEBLD_constINTEGER2:
+		  val = ffebld_cu_val_integer2 (*cu);
+		  item = build_int_2 (val, (val < 0) ? -1 : 0);
+		  break;
+#endif
+#if FFETARGET_okINTEGER3
+	  case  FFEBLD_constINTEGER3:
+		  val = ffebld_cu_val_integer3 (*cu);
+		  item = build_int_2 (val, (val < 0) ? -1 : 0);
+		  break;
+#endif
+#if FFETARGET_okINTEGER4
+	  case  FFEBLD_constINTEGER4:
+		  val = ffebld_cu_val_integer4 (*cu);
+		  item = build_int_2 (val, (val < 0) ? -1 : 0);
+		  break;
+#endif
+#if FFETARGET_okLOGICAL1
+	  case  FFEBLD_constLOGICAL1:
+		  val = ffebld_cu_val_logical1 (*cu);
+		  item = build_int_2 (val, (val < 0) ? -1 : 0);
+		  break;
+#endif
+#if FFETARGET_okLOGICAL2
+          case  FFEBLD_constLOGICAL2:
+		  val = ffebld_cu_val_logical2 (*cu);
+		  item = build_int_2 (val, (val < 0) ? -1 : 0);
+		  break;
+#endif
+#if FFETARGET_okLOGICAL3
+	  case  FFEBLD_constLOGICAL3:
+		  val = ffebld_cu_val_logical3 (*cu);
+		  item = build_int_2 (val, (val < 0) ? -1 : 0);
+		  break;
+#endif
+#if FFETARGET_okLOGICAL4
+	  case  FFEBLD_constLOGICAL4:
+		  val = ffebld_cu_val_logical4 (*cu);
+		  item = build_int_2 (val, (val < 0) ? -1 : 0);
+		  break;
+#endif
+	  default:
+		  assert ("constant type not supported"==NULL);
+		  return error_mark_node;
+		  break;
+  }
+
+  TREE_TYPE (item) = tree_type;
+
+  TREE_CONSTANT (item) = 1;
+
+  return item;
+}
 /* Transform expression into constant tree.
 
    If the expression can be transformed into a tree that is constant,
diff --git a/gcc/f/com.h b/gcc/f/com.h
index 8b8bb861e82..b58e5ba1205 100644
--- a/gcc/f/com.h
+++ b/gcc/f/com.h
@@ -210,6 +210,8 @@ tree ffecom_arg_expr (ffebld expr, tree *length);
 tree ffecom_arg_ptr_to_const_expr (ffebld expr, tree *length);
 tree ffecom_arg_ptr_to_expr (ffebld expr, tree *length);
 tree ffecom_call_gfrt (ffecomGfrt ix, tree args, tree hook);
+tree ffecom_constantunion_with_type (ffebldConstantUnion *cu, 
+		            tree tree_type,ffebldConst ct);
 tree ffecom_constantunion (ffebldConstantUnion *cu, ffeinfoBasictype bt,
 			   ffeinfoKindtype kt, tree tree_type);
 tree ffecom_const_expr (ffebld expr);
diff --git a/gcc/f/stc.c b/gcc/f/stc.c
index a28e3a949e6..b9602c20a46 100644
--- a/gcc/f/stc.c
+++ b/gcc/f/stc.c
@@ -9197,11 +9197,17 @@ ffestc_R810 (ffesttCaseList cases, ffelexToken name)
 	    }
 	  if (((caseobj->expr1 != NULL)
 	       && ((ffeinfo_basictype (ffebld_info (caseobj->expr1))
-		    != s->type)))
+		    != s->type)
+		   || ((ffeinfo_kindtype (ffebld_info (caseobj->expr1))
+		       != s->kindtype) 
+		       && (ffeinfo_kindtype (ffebld_info (caseobj->expr1)) != FFEINFO_kindtypeINTEGER1 ))
 	      || ((caseobj->range)
 		  && (caseobj->expr2 != NULL)
 		  && ((ffeinfo_basictype (ffebld_info (caseobj->expr2))
-		       != s->type))))
+		       != s->type)
+		      || ((ffeinfo_kindtype (ffebld_info (caseobj->expr2))
+			  != s->kindtype)
+		      && (ffeinfo_kindtype (ffebld_info (caseobj->expr2)) != FFEINFO_kindtypeINTEGER1)))))))
 	    {
 	      ffebad_start (FFEBAD_CASE_TYPE_DISAGREE);
 	      ffebad_here (0, ffelex_token_where_line (caseobj->t),
@@ -9212,6 +9218,8 @@ ffestc_R810 (ffesttCaseList cases, ffelexToken name)
 	      continue;
 	    }
 
+
+
 	  if ((s->type == FFEINFO_basictypeLOGICAL) && (caseobj->range))
 	    {
 	      ffebad_start (FFEBAD_CASE_LOGICAL_RANGE);
diff --git a/gcc/f/ste.c b/gcc/f/ste.c
index 7b9b86c0068..7d625cb6159 100644
--- a/gcc/f/ste.c
+++ b/gcc/f/ste.c
@@ -2711,21 +2711,18 @@ ffeste_R810 (ffestw block, unsigned long casenum)
     do
       {
 	texprlow = (c->low == NULL) ? NULL_TREE
-	  : ffecom_constantunion (&ffebld_constant_union (c->low), s->type,
-				  s->kindtype,
-				  ffecom_tree_type[s->type][s->kindtype]);
+	  : ffecom_constantunion_with_type (&ffebld_constant_union (c->low),
+				  ffecom_tree_type[s->type][s->kindtype],c->low->consttype);
 	if (c->low != c->high)
 	  {
 	    texprhigh = (c->high == NULL) ? NULL_TREE
-	      : ffecom_constantunion (&ffebld_constant_union (c->high),
-				      s->type, s->kindtype,
-				      ffecom_tree_type[s->type][s->kindtype]);
+	      : ffecom_constantunion_with_type (&ffebld_constant_union (c->high),
+				      ffecom_tree_type[s->type][s->kindtype],c->high->consttype);
 	    pushok = pushcase_range (texprlow, texprhigh, convert,
 				     tlabel, &duplicate);
 	  }
 	else
 	  pushok = pushcase (texprlow, convert, tlabel, &duplicate);
-	assert((pushok != 2) || (pushok != 0));
 	if (pushok == 2)
 	  {
 	    ffebad_start_msg ("SELECT (at %0) has duplicate cases -- check integer overflow of CASE(s)",