diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 40b578325d1..3b6cefcb371 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,22 @@ +2016-12-14 Andre Vehreschild + + 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 PR fortran/78798 diff --git a/gcc/fortran/array.c b/gcc/fortran/array.c index 154b8606897..c531522f71f 100644 --- a/gcc/fortran/array.c +++ b/gcc/fortran/array.c @@ -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; } diff --git a/gcc/fortran/data.c b/gcc/fortran/data.c index 139ce880534..ea19732ccc3 100644 --- a/gcc/fortran/data.c +++ b/gcc/fortran/data.c @@ -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); } diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index da653363712..ae1a01b0ec4 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -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 *); diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c index 90f46e56e4d..a6f4e7204e1 100644 --- a/gcc/fortran/interface.c +++ b/gcc/fortran/interface.c @@ -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; } diff --git a/gcc/fortran/module.c b/gcc/fortran/module.c index e727adebc99..713f27271de 100644 --- a/gcc/fortran/module.c +++ b/gcc/fortran/module.c @@ -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) { diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c index f659a486ec9..a7a5e2a4b6b 100644 --- a/gcc/fortran/trans-decl.c +++ b/gcc/fortran/trans-decl.c @@ -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))) { diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index cbfad0babd9..2f45d40bec7 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -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); diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c index d34bdba9628..d9e185f2927 100644 --- a/gcc/fortran/trans-stmt.c +++ b/gcc/fortran/trans-stmt.c @@ -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