From a3d3c0f5fa9cd88e6285f60c593cb753cc53d4c2 Mon Sep 17 00:00:00 2001
From: Daniel Kraft <d@domob.eu>
Date: Thu, 9 Oct 2008 09:28:22 +0200
Subject: [PATCH] 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
---
gcc/fortran/ChangeLog | 16 ++++
gcc/fortran/array.c | 8 +-
gcc/fortran/error.c | 26 +++++-
gcc/fortran/expr.c | 83 ++++++++++++++++++-
gcc/fortran/gfortran.h | 5 +-
gcc/fortran/intrinsic.c | 40 ++++++---
gcc/testsuite/ChangeLog | 7 ++
.../gfortran.dg/restricted_expression_1.f90 | 25 ++++++
.../gfortran.dg/restricted_expression_2.f90 | 25 ++++++
.../gfortran.dg/restricted_expression_3.f90 | 26 ++++++
10 files changed, 238 insertions(+), 23 deletions(-)
create mode 100644 gcc/testsuite/gfortran.dg/restricted_expression_1.f90
create mode 100644 gcc/testsuite/gfortran.dg/restricted_expression_2.f90
create mode 100644 gcc/testsuite/gfortran.dg/restricted_expression_3.f90
diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index b0ef1cef8be5..a2ca844018c0 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 d99ed9e30a06..70cf66294da8 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 7a5fbd347111..a7005e9fbb61 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 7f6bf1b07e47..5a167b7067f8 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 b032486abfd5..42f5516b746b 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 035aef70d659..7acdcb05e608 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 8ea5a241cb09..2e61e8ca8a49 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 000000000000..45211a585f40
--- /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 000000000000..9c281664a841
--- /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 000000000000..0b84f67aa588
--- /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
--
GitLab