+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.
{
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;
iter_stack = NULL;
t = expand_constructor (array->value.constructor);
- gfc_suppress_error = flag;
+
+ gfc_pop_suppress_errors ();
if (t == FAILURE)
mpz_clear (*result);
#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
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;
{
va_list argp;
- if (gfc_suppress_error)
+ if (suppress_errors)
return;
error_buffer.flag = 1;
}
+/* 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. */
static gfc_try
check_restricted (gfc_expr *e)
{
- gfc_symbol *sym;
+ gfc_symbol* sym;
gfc_try t;
if (e == NULL)
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:
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).
|| 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)
#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
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)
isym = specific = gfc_find_function (name);
if (isym == NULL)
{
- gfc_suppress_error = 0;
+ if (!error_flag)
+ gfc_pop_suppress_errors ();
return MATCH_NO;
}
&& 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;
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;
}
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)
{
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;
}
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;
if (isym == NULL)
return MATCH_NO;
- gfc_suppress_error = !error_flag;
+ if (!error_flag)
+ gfc_push_suppress_errors ();
init_arglist (isym);
/* 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);
return MATCH_YES;
fail:
- gfc_suppress_error = 0;
+ if (!error_flag)
+ gfc_pop_suppress_errors ();
return MATCH_NO;
}
+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
--- /dev/null
+! { 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
--- /dev/null
+! { 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
--- /dev/null
+! { 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
projects / thirdparty / gcc.git / commitdiff
