This is the mail archive of the
fortran@gcc.gnu.org
mailing list for the GNU Fortran project.
[Patch, Fortran] PING: PR fortran/35723
- From: Daniel Kraft <d at domob dot eu>
- To: Fortran List <fortran at gcc dot gnu dot org>, gcc-patches <gcc-patches at gcc dot gnu dot org>
- Date: Tue, 07 Oct 2008 19:11:10 +0200
- Subject: [Patch, Fortran] PING: PR fortran/35723
Hi,
this is an updated patch for PR 35723 including a merge with Paul's
recent checkin for 35680 and removal of the "wrong" error suppressing.
No regressions on GNU/Linux-x86-32 and also both the duplicate error
problem (fixed by Paul) and the "lost" errors reported by Dominique are
no longer issues.
Despite removal of error suppressing, I would like to keep the clean up
of error suppression code in there; the code in interface.c had at least
some cases where the suppression-flag could stay set and be not
reverted. I've not tried to construct a test case exercising this,
however. Is this ok?
Patch in general ok for trunk? Should I try to backport it?
Cheers,
Daniel
--
Done: Arc-Bar-Cav-Rog-Sam-Val-Wiz
To go: Hea-Kni-Mon-Pri-Ran-Tou
2008-10-07 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 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.
Index: gcc/fortran/intrinsic.c
===================================================================
--- gcc/fortran/intrinsic.c (revision 140935)
+++ gcc/fortran/intrinsic.c (working copy)
@@ -3598,7 +3598,8 @@ gfc_intrinsic_func_interface (gfc_expr *
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 *
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 *
&& 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 *
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 *
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 *
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
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
/* 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
return MATCH_YES;
fail:
- gfc_suppress_error = 0;
+ if (!error_flag)
+ gfc_pop_suppress_errors ();
return MATCH_NO;
}
Index: gcc/fortran/array.c
===================================================================
--- gcc/fortran/array.c (revision 140935)
+++ gcc/fortran/array.c (working copy)
@@ -2073,14 +2073,13 @@ gfc_array_size (gfc_expr *array, mpz_t *
{
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 *
iter_stack = NULL;
t = expand_constructor (array->value.constructor);
- gfc_suppress_error = flag;
+
+ gfc_pop_suppress_errors ();
if (t == FAILURE)
mpz_clear (*result);
Index: gcc/fortran/gfortran.h
===================================================================
--- gcc/fortran/gfortran.h (revision 140935)
+++ gcc/fortran/gfortran.h (working copy)
@@ -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
Index: gcc/fortran/error.c
===================================================================
--- gcc/fortran/error.c (revision 140935)
+++ gcc/fortran/error.c (working copy)
@@ -30,13 +30,33 @@ along with GCC; see the file COPYING3.
#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 *noc
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;
Index: gcc/fortran/expr.c
===================================================================
--- gcc/fortran/expr.c (revision 140935)
+++ gcc/fortran/expr.c (working copy)
@@ -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)
Index: gcc/testsuite/gfortran.dg/restricted_expression_3.f90
===================================================================
--- gcc/testsuite/gfortran.dg/restricted_expression_3.f90 (revision 0)
+++ gcc/testsuite/gfortran.dg/restricted_expression_3.f90 (revision 0)
@@ -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
Index: gcc/testsuite/gfortran.dg/restricted_expression_2.f90
===================================================================
--- gcc/testsuite/gfortran.dg/restricted_expression_2.f90 (revision 0)
+++ gcc/testsuite/gfortran.dg/restricted_expression_2.f90 (revision 0)
@@ -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
Index: gcc/testsuite/gfortran.dg/restricted_expression_1.f90
===================================================================
--- gcc/testsuite/gfortran.dg/restricted_expression_1.f90 (revision 0)
+++ gcc/testsuite/gfortran.dg/restricted_expression_1.f90 (revision 0)
@@ -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