re PR fortran/31250 (Initialization expr as constant character length rejected)

PR fortran/31250
fortran/
* decl.c (match_char_spec): Move check for negative CHARACTER
length ...
* resolve.c (resolve_charlen): ... here.
(resolve_types): Resolve CHARACTER lengths earlier.
teststuite/
* gfortran.dg/char_length_2.f90: New.

From-SVN: r123763

5 files changed, 48 insertions, 13 deletions

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 28e2d16..fe6b139 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,11 @@
+2007-04-12  Tobias Schlüter  <tobi@gcc.gnu.org>
+
+	PR fortran/31250
+	* decl.c (match_char_spec): Move check for negative CHARACTER
+	length ...
+	* resolve.c (resolve_charlen): ... here.
+	(resolve_types): Resolve CHARACTER lengths earlier.
+
 2007-04-12  Daniel Franke  <franke.daniel@gmail.com>
 
 	PR fortran/31234
diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c
index 43e0235..9b54bca 100644
--- a/gcc/fortran/decl.c
+++ b/gcc/fortran/decl.c
@@ -1515,7 +1515,7 @@ no_match:
 static match
 match_char_spec (gfc_typespec *ts)
 {
-  int i, kind, seen_length;
+  int kind, seen_length;
   gfc_charlen *cl;
   gfc_expr *len;
   match m;
@@ -1646,15 +1646,7 @@ done:
   if (seen_length == 0)
     cl->length = gfc_int_expr (1);
   else
-    {
-      if (len == NULL || gfc_extract_int (len, &i) != NULL || i >= 0)
-	cl->length = len;
-      else
-	{
-	  gfc_free_expr (len);
-	  cl->length = gfc_int_expr (0);
-	}
-    }
+    cl->length = len;
 
   ts->cl = cl;
   ts->kind = kind;
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 467ccf4..8c4b46a 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -5389,6 +5389,8 @@ resolve_index_expr (gfc_expr *e)
 static try
 resolve_charlen (gfc_charlen *cl)
 {
+  int i;
+
   if (cl->resolved)
     return SUCCESS;
 
@@ -5402,6 +5404,15 @@ resolve_charlen (gfc_charlen *cl)
       return FAILURE;
     }
 
+  /* "If the character length parameter value evaluates to a negative
+     value, the length of character entities declared is zero."  */
+  if (cl->length && !gfc_extract_int (cl->length, &i) && i <= 0)
+    {
+      gfc_warning_now ("CHARACTER variable has zero length at %L",
+		       &cl->length->where);
+      gfc_replace_expr (cl->length, gfc_int_expr (0));
+    }
+
   return SUCCESS;
 }
 
@@ -7270,6 +7281,9 @@ resolve_types (gfc_namespace *ns)
 
   resolve_contained_functions (ns);
 
+  for (cl = ns->cl_list; cl; cl = cl->next)
+    resolve_charlen (cl);
+
   gfc_traverse_ns (ns, resolve_symbol);
 
   resolve_fntype (ns);
@@ -7287,9 +7301,6 @@ resolve_types (gfc_namespace *ns)
   forall_flag = 0;
   gfc_check_interfaces (ns);
 
-  for (cl = ns->cl_list; cl; cl = cl->next)
-    resolve_charlen (cl);
-
   gfc_traverse_ns (ns, resolve_values);
 
   if (ns->save_all)
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 2beab78..9f48f14 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,5 +1,8 @@
 2007-04-12  Tobias Schlüter  <tobi@gcc.gnu.org>
 
+	PR fortran/31250
+	* gfortran.dg/char_length_2.f90: New.
+
 	PR fortran/31266
 	* gfortran.dg/char_assign_1.f90: New.
 
diff --git a/gcc/testsuite/gfortran.dg/char_length_2.f90 b/gcc/testsuite/gfortran.dg/char_length_2.f90
new file mode 100644
index 0000000..dc2efb9
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/char_length_2.f90
@@ -0,0 +1,21 @@
+! { dg-do link }
+! Tests the fix for PR 31250
+! CHARACTER lengths weren't reduced early enough for all checks of
+! them to be meaningful.  Furthermore negative string lengths weren't
+! dealt with correctly.
+CHARACTER(len=0) :: c1  ! { dg-warning "CHARACTER variable has zero length" }
+CHARACTER(len=-1) :: c2  ! { dg-warning "CHARACTER variable has zero length" }
+PARAMETER(I=-100)
+CHARACTER(len=I) :: c3   ! { dg-warning "CHARACTER variable has zero length" }
+CHARACTER(len=min(I,500)) :: c4  ! { dg-warning "CHARACTER variable has zero length" }
+CHARACTER(len=max(I,500)) :: d1  ! no warning
+CHARACTER(len=5) :: d2   ! no warning
+
+if (len(c1) .ne. 0) call link_error ()
+if (len(c2) .ne. len(c1)) call link_error ()
+if (len(c3) .ne. len(c2)) call link_error ()
+if (len(c4) .ne. len(c3)) call link_error ()
+
+if (len(d1) .ne. 500) call link_error ()
+if (len(d2) .ne. 5) call link_error ()
+END