gcc/fortran/:

2010-05-11  Daniel Franke  <franke.daniel@gmail.com>

	PR fortran/31820
	* resolve.c (validate_case_label_expr): Removed FIXME.
	(resolve_select): Raise default warning on case labels out of range
	of the case expression.

gcc/testsuite/:
2010-05-11  Daniel Franke  <franke.daniel@gmail.com>

	PR fortran/31820
	* gfortran.dg/select_5.f90: Updated.

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

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index af70b8c..1b8c65c 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,9 +1,16 @@
+2010-05-11  Daniel Franke  <franke.daniel@gmail.com>
+
+       PR fortran/31820
+       * resolve.c (validate_case_label_expr): Removed FIXME.
+       (resolve_select): Raise default warning on case labels out of range
+       of the case expression.
+
 2010-05-10  Daniel Franke  <franke.daniel@gmail.com>
 
        PR fortran/27866
        PR fortran/35003
        PR fortran/42809
-       * intrinsic.c (gfc_convert_type_warn): Be more dicsriminative
+       * intrinsic.c (gfc_convert_type_warn): Be more discriminative
        about conversion warnings.
 
 2010-05-10  Janus Weil  <janus@gcc.gnu.org>

diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 5afb08d..da8d896 100644 (file)
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -6747,8 +6747,9 @@ validate_case_label_expr (gfc_expr *e, gfc_expr *case_expr)
       return FAILURE;
     }
 
-  /* Convert the case value kind to that of case expression kind, if needed.
-     FIXME:  Should a warning be issued?  */
+  /* Convert the case value kind to that of case expression kind,
+     if needed */
+
   if (e->ts.kind != case_expr->ts.kind)
     gfc_convert_type_warn (e, &case_expr->ts, 2, 0);
 
@@ -6834,6 +6835,31 @@ resolve_select (gfc_code *code)
       return;
     }
 
+
+  /* Raise a warning if an INTEGER case value exceeds the range of
+     the case-expr. Later, all expressions will be promoted to the
+     largest kind of all case-labels.  */
+
+  if (type == BT_INTEGER)
+    for (body = code->block; body; body = body->block)
+      for (cp = body->ext.case_list; cp; cp = cp->next)
+       {
+         if (cp->low
+             && gfc_check_integer_range (cp->low->value.integer,
+                                         case_expr->ts.kind) != ARITH_OK)
+           gfc_warning ("Expression in CASE statement at %L is "
+                        "not in the range of %s", &cp->low->where,
+                        gfc_typename (&case_expr->ts));
+
+         if (cp->high
+             && cp->low != cp->high
+             && gfc_check_integer_range (cp->high->value.integer,
+                                         case_expr->ts.kind) != ARITH_OK)
+           gfc_warning ("Expression in CASE statement at %L is "
+                        "not in the range of %s", &cp->high->where,
+                        gfc_typename (&case_expr->ts));
+       }
+
   /* 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
@@ -6856,7 +6882,6 @@ resolve_select (gfc_code *code)
                  && gfc_compare_expr (cp->low, cp->high, INTRINSIC_GT) > 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);
@@ -6907,8 +6932,8 @@ resolve_select (gfc_code *code)
 
          /* Deal with single value cases and case ranges.  Errors are
             issued from the validation function.  */
-         if(validate_case_label_expr (cp->low, case_expr) != SUCCESS
-            || validate_case_label_expr (cp->high, case_expr) != SUCCESS)
+         if (validate_case_label_expr (cp->low, case_expr) != SUCCESS
+             || validate_case_label_expr (cp->high, case_expr) != SUCCESS)
            {
              t = FAILURE;
              break;
@@ -6930,7 +6955,7 @@ resolve_select (gfc_code *code)
              value = cp->low->value.logical == 0 ? 2 : 1;
              if (value & seen_logical)
                {
-                 gfc_error ("constant logical value in CASE statement "
+                 gfc_error ("Constant logical value in CASE statement "
                             "is repeated at %L",
                             &cp->low->where);
                  t = FAILURE;

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index c664140..29b19b9 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,8 @@
+2010-05-11  Daniel Franke  <franke.daniel@gmail.com>
+
+       PR fortran/31820
+       * gfortran.dg/select_5.f90: Updated.
+
 2010-05-11  Jan Hubicka  <jh@suse.cz>
 
        PR tree-optimize/44063

diff --git a/gcc/testsuite/gfortran.dg/select_5.f90 b/gcc/testsuite/gfortran.dg/select_5.f90
index 2e2997c..9afc160 100644 (file)
--- a/gcc/testsuite/gfortran.dg/select_5.f90
+++ b/gcc/testsuite/gfortran.dg/select_5.f90
@@ -3,13 +3,20 @@
 program select_5
   integer(kind=1) i          ! kind = 1, -128 <= i < 127
   do i = 1, 3
-    select case (i)     
-    case (1_4)         ! kind = 4, reachable
+    select case (i)
+
+    ! kind = 4, reachable
+    case (1_4)
       if (i /=  1_4) call abort
-    case (2_8)         ! kind = 8, reachable
+
+    ! kind = 8, reachable
+    case (2_8)
       if (i /= 2_8) call abort
-    case (200)         ! kind = 4, unreachable because of range of i
+
+    ! kind = 4, unreachable because of range of i
+    case (200)                       ! { dg-warning "not in the range" }
       call abort
+
     case default
       if (i /= 3) call abort
     end select