com.c (ffecom_constantunion_with_type): New function.

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.

From-SVN: r64709

8 files changed, 284 insertions, 9 deletions

diff --git a/gcc/f/ChangeLog b/gcc/f/ChangeLog
index 73eddc1..848f649 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 0895485..b850774 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 8b8bb86..b58e5ba 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 a28e3a9..b9602c2 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 7b9b86c..7d625cb 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)",
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 9bda0cd..25baba3 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,8 @@
+2003-03-22  Bud Davis  <bdavis9659@comcast.net>
+
+	* g77.f-torture/execute/select.f: New test.
+	* g77.f-torture/noncompile/select_no_compile.f: New test.
+
 2003-03-21  Nathan Sidwell  <nathan@codesourcery.com>
 
 	PR c++/9898
diff --git a/gcc/testsuite/g77.f-torture/execute/select.f b/gcc/testsuite/g77.f-torture/execute/select.f
new file mode 100644
index 0000000..f1024330
--- /dev/null
+++ b/gcc/testsuite/g77.f-torture/execute/select.f
@@ -0,0 +1,173 @@
+C   integer byte case with integer byte parameters as case(s)
+        subroutine ib
+        integer *1 a /1/
+        integer *1  one,two,three
+        parameter (one=1,two=2,three=3)
+        select case (a)
+        case (one)
+        case (two)
+           call abort
+        case (three)
+           call abort
+        case default
+           call abort
+        end select
+        print*,'normal ib'
+        end
+C   integer halfword case with integer halfword parameters
+        subroutine ih
+        integer *2 a /1/
+        integer *2  one,two,three
+        parameter (one=1,two=2,three=3)
+        select case (a)
+        case (one)
+        case (two)
+           call abort
+        case (three)
+           call abort
+        case default
+           call abort
+        end select
+        print*,'normal ih'
+        end
+C   integer case with integer parameters
+        subroutine iw
+        integer *4 a /1/
+        integer *4  one,two,three
+        parameter (one=1,two=2,three=3)
+        select case (a)
+        case (one)
+        case (two)
+           call abort
+        case (three)
+           call abort
+        case default
+           call abort
+        end select
+        print*,'normal iw'
+        end
+C   integer double case with integer double parameters
+        subroutine id
+        integer *8 a /1/
+        integer *8  one,two,three
+        parameter (one=1,two=2,three=3)
+        select case (a)
+        case (one)
+        case (two)
+           call abort
+        case (three)
+           call abort
+        case default
+           call abort
+        end select
+        print*,'normal id'
+        end
+C   integer byte select with integer case
+       subroutine ib_mixed
+       integer*1 s /1/
+       select case (s)
+       case (1)
+       case (2)
+         call abort
+       end select
+       print*,'ib ok'
+       end
+C   integer halfword with integer case
+       subroutine ih_mixed
+       integer*2 s /1/
+       select case (s)
+       case (1)
+       case default
+         call abort
+       end select
+       print*,'ih ok'
+       end
+C   integer word with integer case
+       subroutine iw_mixed
+       integer s /5/
+       select case (s)
+       case (1)
+          call abort
+       case (2)
+          call abort
+       case (3)
+          call abort
+       case (4)
+          call abort
+       case (5)
+C                   
+       case (6)
+           call abort
+       case default
+           call abort
+       end select
+       print*,'iw ok'
+       end
+C   integer doubleword with integer case
+       subroutine id_mixed
+       integer *8 s /1024/
+       select case (s)
+       case (1)
+           call abort
+       case (1023)
+           call abort
+       case (1025)
+           call abort
+       case (1024)
+C
+       end select
+       print*,'i8 ok'
+       end
+       subroutine l1_mixed
+       logical*1 s /.TRUE./
+       select case (s)
+       case (.TRUE.)
+       case (.FALSE.)
+          call abort
+       end select
+       print*,'l1 ok'
+       end
+       subroutine l2_mixed
+       logical*2 s /.FALSE./
+       select case (s)
+       case (.TRUE.)
+           call abort
+       case (.FALSE.)
+       end select
+       print*,'lh ok'
+       end
+       subroutine l4_mixed
+       logical*4 s /.TRUE./
+       select case (s)
+       case (.FALSE.)
+         call abort
+       case (.TRUE.)
+       end select
+       print*,'lw ok'
+       end
+       subroutine l8_mixed
+       logical*8 s /.TRUE./
+       select case (s)
+       case (.TRUE.)
+       case (.FALSE.)
+          call abort
+       end select
+       print*,'ld ok'
+       end
+C   main
+C -- regression cases
+        call ib
+        call ih
+        call iw
+        call id
+C -- new functionality
+        call ib_mixed
+        call ih_mixed
+        call iw_mixed
+        call id_mixed
+        end
+        
+
+
+
+
diff --git a/gcc/testsuite/g77.f-torture/noncompile/select_no_compile.f b/gcc/testsuite/g77.f-torture/noncompile/select_no_compile.f
new file mode 100644
index 0000000..f7dad33
--- /dev/null
+++ b/gcc/testsuite/g77.f-torture/noncompile/select_no_compile.f
@@ -0,0 +1,10 @@
+       integer*1 one
+       integer*2 two
+       parameter (one=1)
+       parameter (two=2)
+       select case (I)
+       case (one)
+       case (two)
+       end select
+       end
+