re PR fortran/35723 (Can't use run-time array element in character declaration)

2008-10-09  Daniel Kraft  <d@domob.eu>

	PR fortran/35723
	* gfortran.h (gfc_suppress_error): Removed from header.
	(gfc_push_suppress_errors), (gfc_pop_suppress_errors): New methods.
	* array.c (gfc_array_size): Use new gfc_push/pop_suppress_errors
	instead of directly changing gfc_suppress_error.
	* intrinsic.c (gfc_intrinsic_func_interface): Ditto.
	(gfc_intrinsic_sub_interface): Ditto.
	* error.c (suppress_errors): Made static from `gfc_suppress_error'.
	(gfc_push_suppress_errors), (gfc_pop_suppress_errors): New methods.
	(gfc_notify_std), (gfc_error): Use new static name of global.
	* expr.c (check_arglist), (check_references): New methods.
	(check_restricted): Check arglists and references of EXPR_FUNCTIONs
	and EXPR_VARAIBALEs, respectively.  Allow PARAMETER symbols.

2008-10-09  Daniel Kraft  <d@domob.eu>

	PR fortran/35723
	* gfortran.dg/restricted_expression_1.f90: New test.
	* gfortran.dg/restricted_expression_2.f90: New test.
	* gfortran.dg/restricted_expression_3.f90: New test.

From-SVN: r141001

10 files changed, 238 insertions, 23 deletions

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index b0ef1ce..a2ca844 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,19 @@
+2008-10-09  Daniel Kraft  <d@domob.eu>
+
+	PR fortran/35723
+	* gfortran.h (gfc_suppress_error): Removed from header.
+	(gfc_push_suppress_errors), (gfc_pop_suppress_errors): New methods.
+	* array.c (gfc_array_size): Use new gfc_push/pop_suppress_errors
+	instead of directly changing gfc_suppress_error.
+	* intrinsic.c (gfc_intrinsic_func_interface): Ditto.
+	(gfc_intrinsic_sub_interface): Ditto.
+	* error.c (suppress_errors): Made static from `gfc_suppress_error'.
+	(gfc_push_suppress_errors), (gfc_pop_suppress_errors): New methods.
+	(gfc_notify_std), (gfc_error): Use new static name of global.
+	* expr.c (check_arglist), (check_references): New methods.
+	(check_restricted): Check arglists and references of EXPR_FUNCTIONs
+	and EXPR_VARAIBALEs, respectively.  Allow PARAMETER symbols.
+
 2008-10-07  Jakub Jelinek  <jakub@redhat.com>
 
 	* f95-lang.c (poplevel): Don't clear BLOCK_VARS if functionbody.
diff --git a/gcc/fortran/array.c b/gcc/fortran/array.c
index d99ed9e..70cf662 100644
--- a/gcc/fortran/array.c
+++ b/gcc/fortran/array.c
@@ -2073,14 +2073,13 @@ gfc_array_size (gfc_expr *array, mpz_t *result)
 {
   expand_info expand_save;
   gfc_ref *ref;
-  int i, flag;
+  int i;
   gfc_try t;
 
   switch (array->expr_type)
     {
     case EXPR_ARRAY:
-      flag = gfc_suppress_error;
-      gfc_suppress_error = 1;
+      gfc_push_suppress_errors ();
 
       expand_save = current_expand;
 
@@ -2091,7 +2090,8 @@ gfc_array_size (gfc_expr *array, mpz_t *result)
       iter_stack = NULL;
 
       t = expand_constructor (array->value.constructor);
-      gfc_suppress_error = flag;
+
+      gfc_pop_suppress_errors ();
 
       if (t == FAILURE)
 	mpz_clear (*result);
diff --git a/gcc/fortran/error.c b/gcc/fortran/error.c
index 7a5fbd3..a7005e9 100644
--- a/gcc/fortran/error.c
+++ b/gcc/fortran/error.c
@@ -30,13 +30,33 @@ along with GCC; see the file COPYING3.  If not see
 #include "flags.h"
 #include "gfortran.h"
 
-int gfc_suppress_error = 0;
+static int suppress_errors = 0;
 
 static int terminal_width, buffer_flag, errors, warnings;
 
 static gfc_error_buf error_buffer, warning_buffer, *cur_error_buffer;
 
 
+/* Go one level deeper suppressing errors.  */
+
+void
+gfc_push_suppress_errors (void)
+{
+  gcc_assert (suppress_errors >= 0);
+  ++suppress_errors;
+}
+
+
+/* Leave one level of error suppressing.  */
+
+void
+gfc_pop_suppress_errors (void)
+{
+  gcc_assert (suppress_errors > 0);
+  --suppress_errors;
+}
+
+
 /* Per-file error initialization.  */
 
 void
@@ -764,7 +784,7 @@ gfc_notify_std (int std, const char *nocmsgid, ...)
   if ((gfc_option.allow_std & std) != 0 && !warning)
     return SUCCESS;
 
-  if (gfc_suppress_error)
+  if (suppress_errors)
     return warning ? SUCCESS : FAILURE;
 
   cur_error_buffer = warning ? &warning_buffer : &error_buffer;
@@ -850,7 +870,7 @@ gfc_error (const char *nocmsgid, ...)
 {
   va_list argp;
 
-  if (gfc_suppress_error)
+  if (suppress_errors)
     return;
 
   error_buffer.flag = 1;
diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c
index 7f6bf1b..5a167b7 100644
--- a/gcc/fortran/expr.c
+++ b/gcc/fortran/expr.c
@@ -2503,6 +2503,64 @@ restricted_intrinsic (gfc_expr *e)
 }
 
 
+/* Check the expressions of an actual arglist.  Used by check_restricted.  */
+
+static gfc_try
+check_arglist (gfc_actual_arglist* arg, gfc_try (*checker) (gfc_expr*))
+{
+  for (; arg; arg = arg->next)
+    if (checker (arg->expr) == FAILURE)
+      return FAILURE;
+
+  return SUCCESS;
+}
+
+
+/* Check the subscription expressions of a reference chain with a checking
+   function; used by check_restricted.  */
+
+static gfc_try
+check_references (gfc_ref* ref, gfc_try (*checker) (gfc_expr*))
+{
+  int dim;
+
+  if (!ref)
+    return SUCCESS;
+
+  switch (ref->type)
+    {
+    case REF_ARRAY:
+      for (dim = 0; dim != ref->u.ar.dimen; ++dim)
+	{
+	  if (checker (ref->u.ar.start[dim]) == FAILURE)
+	    return FAILURE;
+	  if (checker (ref->u.ar.end[dim]) == FAILURE)
+	    return FAILURE;
+	  if (checker (ref->u.ar.stride[dim]) == FAILURE)
+	    return FAILURE;
+	}
+      break;
+
+    case REF_COMPONENT:
+      /* Nothing needed, just proceed to next reference.  */
+      break;
+
+    case REF_SUBSTRING:
+      if (checker (ref->u.ss.start) == FAILURE)
+	return FAILURE;
+      if (checker (ref->u.ss.end) == FAILURE)
+	return FAILURE;
+      break;
+
+    default:
+      gcc_unreachable ();
+      break;
+    }
+
+  return check_references (ref->next, checker);
+}
+
+
 /* Verify that an expression is a restricted expression.  Like its
    cousin check_init_expr(), an error message is generated if we
    return FAILURE.  */
@@ -2510,7 +2568,7 @@ restricted_intrinsic (gfc_expr *e)
 static gfc_try
 check_restricted (gfc_expr *e)
 {
-  gfc_symbol *sym;
+  gfc_symbol* sym;
   gfc_try t;
 
   if (e == NULL)
@@ -2526,8 +2584,22 @@ check_restricted (gfc_expr *e)
       break;
 
     case EXPR_FUNCTION:
-      t = e->value.function.esym ? external_spec_function (e)
-				 : restricted_intrinsic (e);
+      if (e->value.function.esym)
+	{
+	  t = check_arglist (e->value.function.actual, &check_restricted);
+	  if (t == SUCCESS)
+	    t = external_spec_function (e);
+	}
+      else
+	{
+	  if (e->value.function.isym && e->value.function.isym->inquiry)
+	    t = SUCCESS;
+	  else
+	    t = check_arglist (e->value.function.actual, &check_restricted);
+
+	  if (t == SUCCESS)
+	    t = restricted_intrinsic (e);
+	}
       break;
 
     case EXPR_VARIABLE:
@@ -2561,6 +2633,10 @@ check_restricted (gfc_expr *e)
 	  break;
 	}
 
+      /* Check reference chain if any.  */
+      if (check_references (e->ref, &check_restricted) == FAILURE)
+	break;
+
       /* gfc_is_formal_arg broadcasts that a formal argument list is being
 	 processed in resolve.c(resolve_formal_arglist).  This is done so
 	 that host associated dummy array indices are accepted (PR23446).
@@ -2571,6 +2647,7 @@ check_restricted (gfc_expr *e)
 	    || sym->attr.use_assoc
 	    || sym->attr.dummy
 	    || sym->attr.implied_index
+	    || sym->attr.flavor == FL_PARAMETER
 	    || (sym->ns && sym->ns == gfc_current_ns->parent)
 	    || (sym->ns && gfc_current_ns->parent
 		  && sym->ns == gfc_current_ns->parent->parent)
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index b032486..42f5516 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -770,7 +770,10 @@ typedef struct
 #endif
 
 
-extern int gfc_suppress_error;
+/* Suppress error messages or re-enable them.  */
+
+void gfc_push_suppress_errors (void);
+void gfc_pop_suppress_errors (void);
 
 
 /* Character length structures hold the expression that gives the
diff --git a/gcc/fortran/intrinsic.c b/gcc/fortran/intrinsic.c
index 035aef7..7acdcb0 100644
--- a/gcc/fortran/intrinsic.c
+++ b/gcc/fortran/intrinsic.c
@@ -3598,7 +3598,8 @@ gfc_intrinsic_func_interface (gfc_expr *expr, int error_flag)
     return (do_simplify (expr->value.function.isym, expr) == FAILURE)
 	   ? MATCH_ERROR : MATCH_YES;
 
-  gfc_suppress_error = !error_flag;
+  if (!error_flag)
+    gfc_push_suppress_errors ();
   flag = 0;
 
   for (actual = expr->value.function.actual; actual; actual = actual->next)
@@ -3611,7 +3612,8 @@ gfc_intrinsic_func_interface (gfc_expr *expr, int error_flag)
   isym = specific = gfc_find_function (name);
   if (isym == NULL)
     {
-      gfc_suppress_error = 0;
+      if (!error_flag)
+	gfc_pop_suppress_errors ();
       return MATCH_NO;
     }
 
@@ -3621,7 +3623,11 @@ gfc_intrinsic_func_interface (gfc_expr *expr, int error_flag)
       && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Function '%s' "
 			 "as initialization expression at %L", name,
 			 &expr->where) == FAILURE)
-    return MATCH_ERROR;
+    {
+      if (!error_flag)
+	gfc_pop_suppress_errors ();
+      return MATCH_ERROR;
+    }
 
   gfc_current_intrinsic_where = &expr->where;
 
@@ -3633,7 +3639,8 @@ gfc_intrinsic_func_interface (gfc_expr *expr, int error_flag)
       if (gfc_check_min_max (expr->value.function.actual) == SUCCESS)
 	goto got_specific;
 
-      gfc_suppress_error = 0;
+      if (!error_flag)
+	gfc_pop_suppress_errors ();
       return MATCH_NO;
     }
 
@@ -3641,7 +3648,7 @@ gfc_intrinsic_func_interface (gfc_expr *expr, int error_flag)
      incarnations.  If the generic name is also a specific, we check
      that name last, so that any error message will correspond to the
      specific.  */
-  gfc_suppress_error = 1;
+  gfc_push_suppress_errors ();
 
   if (isym->generic)
     {
@@ -3651,15 +3658,19 @@ gfc_intrinsic_func_interface (gfc_expr *expr, int error_flag)
 	  if (specific == isym)
 	    continue;
 	  if (check_specific (specific, expr, 0) == SUCCESS)
-	    goto got_specific;
+	    {
+	      gfc_pop_suppress_errors ();
+	      goto got_specific;
+	    }
 	}
     }
 
-  gfc_suppress_error = !error_flag;
+  gfc_pop_suppress_errors ();
 
   if (check_specific (isym, expr, error_flag) == FAILURE)
     {
-      gfc_suppress_error = 0;
+      if (!error_flag)
+	gfc_pop_suppress_errors ();
       return MATCH_NO;
     }
 
@@ -3669,7 +3680,9 @@ got_specific:
   expr->value.function.isym = specific;
   gfc_intrinsic_symbol (expr->symtree->n.sym);
 
-  gfc_suppress_error = 0;
+  if (!error_flag)
+    gfc_pop_suppress_errors ();
+
   if (do_simplify (specific, expr) == FAILURE)
     return MATCH_ERROR;
 
@@ -3709,7 +3722,8 @@ gfc_intrinsic_sub_interface (gfc_code *c, int error_flag)
   if (isym == NULL)
     return MATCH_NO;
 
-  gfc_suppress_error = !error_flag;
+  if (!error_flag)
+    gfc_push_suppress_errors ();
 
   init_arglist (isym);
 
@@ -3729,7 +3743,8 @@ gfc_intrinsic_sub_interface (gfc_code *c, int error_flag)
 
   /* The subroutine corresponds to an intrinsic.  Allow errors to be
      seen at this point.  */
-  gfc_suppress_error = 0;
+  if (!error_flag)
+    gfc_pop_suppress_errors ();
 
   if (isym->resolve.s1 != NULL)
     isym->resolve.s1 (c);
@@ -3751,7 +3766,8 @@ gfc_intrinsic_sub_interface (gfc_code *c, int error_flag)
   return MATCH_YES;
 
 fail:
-  gfc_suppress_error = 0;
+  if (!error_flag)
+    gfc_pop_suppress_errors ();
   return MATCH_NO;
 }
 
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 8ea5a24..2e61e8c 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,10 @@
+2008-10-09  Daniel Kraft  <d@domob.eu>
+
+	PR fortran/35723
+	* gfortran.dg/restricted_expression_1.f90: New test.
+	* gfortran.dg/restricted_expression_2.f90: New test.
+	* gfortran.dg/restricted_expression_3.f90: New test.
+
 2008-10-08  Jerry DeLisle  <jvdelisle@gcc.gnu.org
 
 	PR libfortran/37707
diff --git a/gcc/testsuite/gfortran.dg/restricted_expression_1.f90 b/gcc/testsuite/gfortran.dg/restricted_expression_1.f90
new file mode 100644
index 0000000..45211a5
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/restricted_expression_1.f90
@@ -0,0 +1,25 @@
+! { dg-do compile }
+! { dg-options "-pedantic -ffixed-form" }
+
+! PR fortran/35723
+! An argument subscript into a parameter array was not allowed as
+! dimension.  Check this is fixed.
+
+! Contributed by Dick Hendrickson <dick.hendrickson@gmail.com>
+
+      call       vf0016(  1,  2,  3)
+
+      end
+      SUBROUTINE VF0016(nf1,nf2,nf3)
+      CHARACTER(LEN=9,KIND=1),DIMENSION(3), PARAMETER
+     $     ::  TEST_STRINGS =
+     $  (/'       HI','ABC      ','  CDEFG  '/)
+      CHARACTER :: TEST_ARRAY
+     $(LEN_TRIM(ADJUSTL(TEST_STRINGS(nf1))),
+     $ SUM(LEN_TRIM(ADJUSTL(TEST_STRINGS))),
+     $ LEN_TRIM(ADJUSTL(ADJUSTR(TEST_STRINGS(3)))),
+     $ SUM(LEN_TRIM(ADJUSTL(ADJUSTR(TEST_STRINGS(NF1:NF3:NF2)))))   )
+
+       print *, 2, 10, 5, 7
+       print *, shape (test_array)
+         end
diff --git a/gcc/testsuite/gfortran.dg/restricted_expression_2.f90 b/gcc/testsuite/gfortran.dg/restricted_expression_2.f90
new file mode 100644
index 0000000..9c28166
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/restricted_expression_2.f90
@@ -0,0 +1,25 @@
+! { dg-do compile }
+! { dg-options "-pedantic -ffixed-form" }
+
+! PR fortran/35723
+! Check that a program using a local variable subscript is still rejected.
+
+! Contributed by Tobias Burnus <burnus@gcc.gnu.org>
+
+      call       vf0016(  1,  2,  3)
+
+      end
+      SUBROUTINE VF0016(nf1,nf2,nf3)
+      CHARACTER(LEN=9,KIND=1),DIMENSION(3), PARAMETER
+     $     ::  TEST_STRINGS =
+     $  (/'       HI','ABC      ','  CDEFG  '/)
+      INTEGER :: i = 2
+      CHARACTER :: TEST_ARRAY
+     $(LEN_TRIM(ADJUSTL(TEST_STRINGS(i))), ! { dg-error "'i' cannot appear" }
+     $ SUM(LEN_TRIM(ADJUSTL(TEST_STRINGS))),
+     $ LEN_TRIM(ADJUSTL(ADJUSTR(TEST_STRINGS(3)))),
+     $ SUM(LEN_TRIM(ADJUSTL(ADJUSTR(TEST_STRINGS(NF1:NF3:NF2)))))   )
+
+       print *, 2, 10, 5, 7
+       print *, shape (test_array)
+         end
diff --git a/gcc/testsuite/gfortran.dg/restricted_expression_3.f90 b/gcc/testsuite/gfortran.dg/restricted_expression_3.f90
new file mode 100644
index 0000000..0b84f67
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/restricted_expression_3.f90
@@ -0,0 +1,26 @@
+! { dg-do compile }
+
+! PR fortran/35723
+! Check that a dummy-argument array with non-restricted subscript is
+! rejected and some more reference-checks.
+
+PROGRAM main
+  IMPLICIT NONE
+  CALL test (5, (/ 1, 2, 3, 4, 5, 6, 7, 8, 9 /), "0123456789" )
+
+CONTAINS
+
+  SUBROUTINE test (n, arr, str)
+    IMPLICIT NONE
+    INTEGER :: n, arr(:)
+    CHARACTER(len=10) :: str
+
+    INTEGER :: i = 5
+    INTEGER :: ok1(arr(n)), ok2(LEN_TRIM (str(3:n)))
+    INTEGER :: ok3(LEN_TRIM("hello, world!"(2:n)))
+    INTEGER :: wrong1(arr(i)) ! { dg-error "'i' cannot appear" }
+    INTEGER :: wrong2(LEN_TRIM (str(i:n))) ! { dg-error "'i' cannot appear" }
+    INTEGER :: wrong3(LEN_TRIM ("hello, world!"(i:n))) ! { dg-error "'i' cannot appear" }
+  END SUBROUTINE test
+
+END PROGRAM main