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

1 files changed, 51 insertions, 11 deletions

diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 4615df7..cd3eb17 100644
--- a/gcc/fortran/resolve.c
+++ b/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;