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
This commit is contained in:
Daniel Kraft
Daniel Kraft
parent
cdb148c194
commit
a3d3c0f5fa
10 changed files with 238 additions and 23 deletions
|
|
@ -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.
|
||||
|
|
|
|||
|
|
@ -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);
|
||||
|
|
|
|||
|
|
@ -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;
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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;
|
||||
}
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
25
gcc/testsuite/gfortran.dg/restricted_expression_1.f90
Normal file
25
gcc/testsuite/gfortran.dg/restricted_expression_1.f90
Normal file
|
|
@ -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
|
||||
25
gcc/testsuite/gfortran.dg/restricted_expression_2.f90
Normal file
25
gcc/testsuite/gfortran.dg/restricted_expression_2.f90
Normal file
|
|
@ -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
|
||||
26
gcc/testsuite/gfortran.dg/restricted_expression_3.f90
Normal file
26
gcc/testsuite/gfortran.dg/restricted_expression_3.f90
Normal file
|
|
@ -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
|
||||
Loading…
Add table
Reference in a new issue