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

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 8fa62a2b7a23748858dd21e585fe2587d3fcf7dd..190a68a71cdcc7e4971bbebd4456b03c5d7a01e1 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,10 @@
+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

diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 4615df77e154a560a306beb636a4df47d73bc1d6..cd3eb177d173750a18b49c5c729c84882ee799cf 100644 (file)
--- 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;

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 821cfea0393b0d9368308b28fa8dd97ea199fa1d..ba894d92ecf568609bb4f85df2ee10578f67c684 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,8 @@
+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.

diff --git a/gcc/testsuite/gfortran.dg/select_5.f90 b/gcc/testsuite/gfortran.dg/select_5.f90
new file mode 100644 (file)
index 0000000..b1478e6
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/select_5.f90
@@ -0,0 +1,17 @@
+! { 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