re PR fortran/19168 (Mismatched KINDs in SELECT CASE constucts is not handled correctly)

2005-01-16  Steven G. Kargl  <kargls@comcast.net>

	PR 19168
	* resolve.c (check_case_overlap): Typo in comment.
	(validate_case_label_expr):  Fix up kinds of case values
	(resolve_select): Properly handle kind mismatches.
testsuite/
	* gfortran.dg/select_5.f90: New test.

From-SVN: r93725

gcc/fortran/ChangeLog

+2005-01-16  Steven G. Kargl  <kargls@comcast.net>
+
+	PR 19168
+	* resolve.c (check_case_overlap): Typo in comment.
+	(validate_case_label_expr):  Fix up kinds of case values
+	(resolve_select): Properly handle kind mismatches.
+
 2004-01-16  Paul Brook  <paul@codesourcery.com>
 
 	PR fortran/17675

gcc/fortran/resolve.c

@@ -2579,7 +2579,7 @@ check_case_overlap (gfc_case * list)
 	  /* Count this merge.  */
 	  nmerges++;
 
-	  /* Cut the list in two pieces by steppin INSIZE places
+	  /* Cut the list in two pieces by stepping INSIZE places
              forward in the list, starting from P.  */
 	  psize = 0;
 	  q = p;
@@ -2676,32 +2676,38 @@ check_case_overlap (gfc_case * list)
 }
 
 
-/* Check to see if an expression is suitable for use in a CASE
-   statement.  Makes sure that all case expressions are scalar
-   constants of the same type/kind.  Return FAILURE if anything
-   is wrong.  */
+/* Check to see if an expression is suitable for use in a CASE statement.
+   Makes sure that all case expressions are scalar constants of the same
+   type.  Return FAILURE if anything is wrong.  */
 
 static try
 validate_case_label_expr (gfc_expr * e, gfc_expr * case_expr)
 {
-  gfc_typespec case_ts = case_expr->ts;
-
   if (e == NULL) return SUCCESS;
 
-  if (e->ts.type != case_ts.type)
+  if (e->ts.type != case_expr->ts.type)
     {
       gfc_error ("Expression in CASE statement at %L must be of type %s",
-		 &e->where, gfc_basic_typename (case_ts.type));
+		 &e->where, gfc_basic_typename (case_expr->ts.type));
       return FAILURE;
     }
 
-  if (e->ts.kind != case_ts.kind)
+  /* C805 (R808) For a given case-construct, each case-value shall be of
+     the same type as case-expr.  For character type, length differences
+     are allowed, but the kind type parameters shall be the same.  */
+
+  if (case_expr->ts.type == BT_CHARACTER && e->ts.kind != case_expr->ts.kind)
     {
       gfc_error("Expression in CASE statement at %L must be kind %d",
-                &e->where, case_ts.kind);
+                &e->where, case_expr->ts.kind);
       return FAILURE;
     }
 
+  /* Convert the case value kind to that of case expression kind, if needed.
+     FIXME:  Should a warning be issued?  */
+  if (e->ts.kind != case_expr->ts.kind)
+    gfc_convert_type_warn (e, &case_expr->ts, 2, 0);
+
   if (e->rank != 0)
     {
       gfc_error ("Expression in CASE statement at %L must be scalar",
@@ -2784,6 +2790,40 @@ resolve_select (gfc_code * code)
       return;
     }
 
+  /* PR 19168 has a long discussion concerning a mismatch of the kinds
+     of the SELECT CASE expression and its CASE values.  Walk the lists
+     of case values, and if we find a mismatch, promote case_expr to
+     the appropriate kind.  */
+
+  if (type == BT_LOGICAL || type == BT_INTEGER)
+    {
+      for (body = code->block; body; body = body->block)
+	{
+	  /* Walk the case label list.  */
+	  for (cp = body->ext.case_list; cp; cp = cp->next)
+	    {
+	      /* Intercept the DEFAULT case.  It does not have a kind.  */
+	      if (cp->low == NULL && cp->high == NULL)
+		continue;
+
+	      /* Unreachable case ranges are discarded, so ignore.  */	
+	      if (cp->low != NULL && cp->high != NULL
+		  && cp->low != cp->high
+		  && gfc_compare_expr (cp->low, cp->high) > 0)
+		continue;
+
+	      /* FIXME: Should a warning be issued?  */
+	      if (cp->low != NULL
+		  && case_expr->ts.kind != gfc_kind_max(case_expr, cp->low))
+		gfc_convert_type_warn (case_expr, &cp->low->ts, 2, 0);
+
+	      if (cp->high != NULL
+		  && case_expr->ts.kind != gfc_kind_max(case_expr, cp->high))
+ 		gfc_convert_type_warn (case_expr, &cp->high->ts, 2, 0);
+	    }
+	 }
+    }
+
   /* Assume there is no DEFAULT case.  */
   default_case = NULL;
   head = tail = NULL;

gcc/testsuite/ChangeLog

+2005-01-16  Steven G. Kargl  <kargls@comcast.net>
+
+	PR 19168
+	* gfortran.dg/select_5.f90: New test.
+
 2004-01-16  Paul Brook  <paul@codesourcery.com>
 
 	* gfortran.dg/common_4.f90: New test.

gcc/testsuite/gfortran.dg/select_5.f90

+! { dg-do run }
+! Test mismatched type kinds in a select statement.
+program select_5
+  integer*1 i          ! kind = 1, -128 <= i < 127
+  do i = 1, 3
+    select case (i)     
+    case (1_4)         ! kind = 4, reachable
+      if (i /=  1_4) call abort
+    case (2_8)         ! kind = 8, reachable
+      if (i /= 2_8) call abort
+    case (200)         ! kind = 4, unreachable because of range of i
+      call abort
+    case default
+      if (i /= 3) call abort
+    end select
+  end do
+end program select_5