re PR fortran/78672 (Gfortran test suite failures with a sanitized compiler)
gcc/fortran/ChangeLog: 2016-12-14 Andre Vehreschild <vehre@gcc.gnu.org> PR fortran/78672 * array.c (gfc_find_array_ref): Add flag to return NULL when no ref is found instead of erroring out. * data.c (gfc_assign_data_value): Only constant expressions are valid for initializers. * gfortran.h: Reflect change of gfc_find_array_ref's signature. * interface.c (compare_actual_formal): Access the non-elemental array-ref. Prevent taking a REF_COMPONENT for a REF_ARRAY. Correct indentation. * module.c (load_omp_udrs): Clear typespec before reading into it. * trans-decl.c (gfc_build_qualified_array): Prevent accessing the array when it is a coarray. * trans-expr.c (gfc_conv_cst_int_power): Use wi::abs()-function instead of crutch preventing sanitizer's bickering here. * trans-stmt.c (gfc_trans_deallocate): Only get data-component when it is a descriptor-array here. From-SVN: r243647
This commit is contained in:
parent
e397febfb8
commit
eb401400f5
|
@ -1,3 +1,22 @@
|
|||
2016-12-14 Andre Vehreschild <vehre@gcc.gnu.org>
|
||||
|
||||
PR fortran/78672
|
||||
* array.c (gfc_find_array_ref): Add flag to return NULL when no ref is
|
||||
found instead of erroring out.
|
||||
* data.c (gfc_assign_data_value): Only constant expressions are valid
|
||||
for initializers.
|
||||
* gfortran.h: Reflect change of gfc_find_array_ref's signature.
|
||||
* interface.c (compare_actual_formal): Access the non-elemental
|
||||
array-ref. Prevent taking a REF_COMPONENT for a REF_ARRAY. Correct
|
||||
indentation.
|
||||
* module.c (load_omp_udrs): Clear typespec before reading into it.
|
||||
* trans-decl.c (gfc_build_qualified_array): Prevent accessing the array
|
||||
when it is a coarray.
|
||||
* trans-expr.c (gfc_conv_cst_int_power): Use wi::abs()-function instead
|
||||
of crutch preventing sanitizer's bickering here.
|
||||
* trans-stmt.c (gfc_trans_deallocate): Only get data-component when it
|
||||
is a descriptor-array here.
|
||||
|
||||
2016-12-13 Janus Weil <janus@gcc.gnu.org>
|
||||
|
||||
PR fortran/78798
|
||||
|
|
|
@ -2563,7 +2563,7 @@ cleanup:
|
|||
characterizes the reference. */
|
||||
|
||||
gfc_array_ref *
|
||||
gfc_find_array_ref (gfc_expr *e)
|
||||
gfc_find_array_ref (gfc_expr *e, bool allow_null)
|
||||
{
|
||||
gfc_ref *ref;
|
||||
|
||||
|
@ -2573,7 +2573,12 @@ gfc_find_array_ref (gfc_expr *e)
|
|||
break;
|
||||
|
||||
if (ref == NULL)
|
||||
gfc_internal_error ("gfc_find_array_ref(): No ref found");
|
||||
{
|
||||
if (allow_null)
|
||||
return NULL;
|
||||
else
|
||||
gfc_internal_error ("gfc_find_array_ref(): No ref found");
|
||||
}
|
||||
|
||||
return &ref->u.ar;
|
||||
}
|
||||
|
|
|
@ -483,7 +483,10 @@ gfc_assign_data_value (gfc_expr *lvalue, gfc_expr *rvalue, mpz_t index,
|
|||
|
||||
if (ref || last_ts->type == BT_CHARACTER)
|
||||
{
|
||||
if (lvalue->ts.u.cl->length == NULL && !(ref && ref->u.ss.length != NULL))
|
||||
/* An initializer has to be constant. */
|
||||
if (rvalue->expr_type != EXPR_CONSTANT
|
||||
|| (lvalue->ts.u.cl->length == NULL
|
||||
&& !(ref && ref->u.ss.length != NULL)))
|
||||
return false;
|
||||
expr = create_character_initializer (init, last_ts, ref, rvalue);
|
||||
}
|
||||
|
|
|
@ -3214,7 +3214,7 @@ bool gfc_check_constructor (gfc_expr *, bool (*)(gfc_expr *));
|
|||
bool gfc_array_size (gfc_expr *, mpz_t *);
|
||||
bool gfc_array_dimen_size (gfc_expr *, int, mpz_t *);
|
||||
bool gfc_array_ref_shape (gfc_array_ref *, mpz_t *);
|
||||
gfc_array_ref *gfc_find_array_ref (gfc_expr *);
|
||||
gfc_array_ref *gfc_find_array_ref (gfc_expr *, bool a = false);
|
||||
tree gfc_conv_array_initializer (tree type, gfc_expr *);
|
||||
bool spec_size (gfc_array_spec *, mpz_t *);
|
||||
bool spec_dimen_size (gfc_array_spec *, int, mpz_t *);
|
||||
|
|
|
@ -2803,6 +2803,7 @@ compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
|
|||
int i, n, na;
|
||||
unsigned long actual_size, formal_size;
|
||||
bool full_array = false;
|
||||
gfc_array_ref *actual_arr_ref;
|
||||
|
||||
actual = *ap;
|
||||
|
||||
|
@ -2942,37 +2943,38 @@ compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
|
|||
and assumed-shape dummies, the string length needs to match
|
||||
exactly. */
|
||||
if (a->expr->ts.type == BT_CHARACTER
|
||||
&& a->expr->ts.u.cl && a->expr->ts.u.cl->length
|
||||
&& a->expr->ts.u.cl->length->expr_type == EXPR_CONSTANT
|
||||
&& f->sym->ts.u.cl && f->sym->ts.u.cl && f->sym->ts.u.cl->length
|
||||
&& f->sym->ts.u.cl->length->expr_type == EXPR_CONSTANT
|
||||
&& (f->sym->attr.pointer || f->sym->attr.allocatable
|
||||
|| (f->sym->as && f->sym->as->type == AS_ASSUMED_SHAPE))
|
||||
&& (mpz_cmp (a->expr->ts.u.cl->length->value.integer,
|
||||
f->sym->ts.u.cl->length->value.integer) != 0))
|
||||
{
|
||||
if (where && (f->sym->attr.pointer || f->sym->attr.allocatable))
|
||||
gfc_warning (OPT_Wargument_mismatch,
|
||||
"Character length mismatch (%ld/%ld) between actual "
|
||||
"argument and pointer or allocatable dummy argument "
|
||||
"%qs at %L",
|
||||
mpz_get_si (a->expr->ts.u.cl->length->value.integer),
|
||||
mpz_get_si (f->sym->ts.u.cl->length->value.integer),
|
||||
f->sym->name, &a->expr->where);
|
||||
else if (where)
|
||||
gfc_warning (OPT_Wargument_mismatch,
|
||||
"Character length mismatch (%ld/%ld) between actual "
|
||||
"argument and assumed-shape dummy argument %qs "
|
||||
"at %L",
|
||||
mpz_get_si (a->expr->ts.u.cl->length->value.integer),
|
||||
mpz_get_si (f->sym->ts.u.cl->length->value.integer),
|
||||
f->sym->name, &a->expr->where);
|
||||
return 0;
|
||||
}
|
||||
&& a->expr->ts.u.cl && a->expr->ts.u.cl->length
|
||||
&& a->expr->ts.u.cl->length->expr_type == EXPR_CONSTANT
|
||||
&& f->sym->ts.type == BT_CHARACTER && f->sym->ts.u.cl
|
||||
&& f->sym->ts.u.cl->length
|
||||
&& f->sym->ts.u.cl->length->expr_type == EXPR_CONSTANT
|
||||
&& (f->sym->attr.pointer || f->sym->attr.allocatable
|
||||
|| (f->sym->as && f->sym->as->type == AS_ASSUMED_SHAPE))
|
||||
&& (mpz_cmp (a->expr->ts.u.cl->length->value.integer,
|
||||
f->sym->ts.u.cl->length->value.integer) != 0))
|
||||
{
|
||||
if (where && (f->sym->attr.pointer || f->sym->attr.allocatable))
|
||||
gfc_warning (OPT_Wargument_mismatch,
|
||||
"Character length mismatch (%ld/%ld) between actual "
|
||||
"argument and pointer or allocatable dummy argument "
|
||||
"%qs at %L",
|
||||
mpz_get_si (a->expr->ts.u.cl->length->value.integer),
|
||||
mpz_get_si (f->sym->ts.u.cl->length->value.integer),
|
||||
f->sym->name, &a->expr->where);
|
||||
else if (where)
|
||||
gfc_warning (OPT_Wargument_mismatch,
|
||||
"Character length mismatch (%ld/%ld) between actual "
|
||||
"argument and assumed-shape dummy argument %qs "
|
||||
"at %L",
|
||||
mpz_get_si (a->expr->ts.u.cl->length->value.integer),
|
||||
mpz_get_si (f->sym->ts.u.cl->length->value.integer),
|
||||
f->sym->name, &a->expr->where);
|
||||
return 0;
|
||||
}
|
||||
|
||||
if ((f->sym->attr.pointer || f->sym->attr.allocatable)
|
||||
&& f->sym->ts.deferred != a->expr->ts.deferred
|
||||
&& a->expr->ts.type == BT_CHARACTER)
|
||||
&& f->sym->ts.deferred != a->expr->ts.deferred
|
||||
&& a->expr->ts.type == BT_CHARACTER)
|
||||
{
|
||||
if (where)
|
||||
gfc_error ("Actual argument at %L to allocatable or "
|
||||
|
@ -3195,15 +3197,20 @@ compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
|
|||
return 0;
|
||||
}
|
||||
|
||||
/* Find the last array_ref. */
|
||||
actual_arr_ref = NULL;
|
||||
if (a->expr->ref)
|
||||
actual_arr_ref = gfc_find_array_ref (a->expr, true);
|
||||
|
||||
if (f->sym->attr.volatile_
|
||||
&& a->expr->ref && a->expr->ref->u.ar.type == AR_SECTION
|
||||
&& actual_arr_ref && actual_arr_ref->type == AR_SECTION
|
||||
&& !(f->sym->as && f->sym->as->type == AS_ASSUMED_SHAPE))
|
||||
{
|
||||
if (where)
|
||||
gfc_error ("Array-section actual argument at %L is "
|
||||
"incompatible with the non-assumed-shape "
|
||||
"dummy argument %qs due to VOLATILE attribute",
|
||||
&a->expr->where,f->sym->name);
|
||||
&a->expr->where, f->sym->name);
|
||||
return 0;
|
||||
}
|
||||
|
||||
|
|
|
@ -4710,6 +4710,7 @@ load_omp_udrs (void)
|
|||
|
||||
mio_lparen ();
|
||||
mio_pool_string (&name);
|
||||
gfc_clear_ts (&ts);
|
||||
mio_typespec (&ts);
|
||||
if (strncmp (name, "operator ", sizeof ("operator ") - 1) == 0)
|
||||
{
|
||||
|
|
|
@ -1053,7 +1053,7 @@ gfc_build_qualified_array (tree decl, gfc_symbol * sym)
|
|||
layout_type (type);
|
||||
}
|
||||
|
||||
if (TYPE_NAME (type) != NULL_TREE
|
||||
if (TYPE_NAME (type) != NULL_TREE && as->rank > 0
|
||||
&& GFC_TYPE_ARRAY_UBOUND (type, as->rank - 1) != NULL_TREE
|
||||
&& VAR_P (GFC_TYPE_ARRAY_UBOUND (type, as->rank - 1)))
|
||||
{
|
||||
|
|
|
@ -2864,9 +2864,9 @@ gfc_conv_cst_int_power (gfc_se * se, tree lhs, tree rhs)
|
|||
return 0;
|
||||
|
||||
m = wrhs.to_shwi ();
|
||||
/* There's no ABS for HOST_WIDE_INT, so here we go. It also takes care
|
||||
of the asymmetric range of the integer type. */
|
||||
n = (unsigned HOST_WIDE_INT) (m < 0 ? -m : m);
|
||||
/* Use the wide_int's routine to reliably get the absolute value on all
|
||||
platforms. Then convert it to a HOST_WIDE_INT like above. */
|
||||
n = wi::abs (wrhs).to_shwi ();
|
||||
|
||||
type = TREE_TYPE (lhs);
|
||||
sgn = tree_int_cst_sgn (rhs);
|
||||
|
|
|
@ -6483,7 +6483,8 @@ gfc_trans_deallocate (gfc_code *code)
|
|||
&& !(!last && expr->symtree->n.sym->attr.pointer))
|
||||
{
|
||||
if (is_coarray && expr->rank == 0
|
||||
&& (!last || !last->u.c.component->attr.dimension))
|
||||
&& (!last || !last->u.c.component->attr.dimension)
|
||||
&& GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se.expr)))
|
||||
{
|
||||
/* Add the ref to the data member only, when this is not
|
||||
a regular array or deallocate_alloc_comp will try to
|
||||
|
|
Loading…
Reference in New Issue