From 76540ac3e39cd58b0b0084f1f1b4fd0ea3c122b1 Mon Sep 17 00:00:00 2001 From: Andre Vehreschild Date: Tue, 23 Jun 2015 11:07:22 +0200 Subject: [PATCH] re PR fortran/64674 ([OOP] ICE in ASSOCIATE with class array) gcc/fortran/ChangeLog: 2015-06-23 Andre Vehreschild PR fortran/64674 * parse.c (parse_associate): Figure the rank and as of a class array in an associate early. * primary.c (gfc_match_varspec): Prevent setting the dimension attribute on the sym for classes. * resolve.c (resolve_variable): Correct the component ref's type for associated variables. Add a full array ref when class array's are associated. (resolve_assoc_var): Correct the type of the symbol, when in the associate the expression's rank becomes scalar. * trans-expr.c (gfc_conv_variable): Indirect ref needed for allocatable associated objects. gcc/testsuite/ChangeLog: 2015-06-23 Andre Vehreschild PR fortran/64674 * gfortran.dg/associate_18.f08: New test. From-SVN: r224827 --- gcc/fortran/ChangeLog | 15 ++ gcc/fortran/parse.c | 80 +++++++++++ gcc/fortran/primary.c | 3 +- gcc/fortran/resolve.c | 156 +++++++++++++++++++-- gcc/fortran/trans-expr.c | 3 +- gcc/testsuite/ChangeLog | 5 + gcc/testsuite/gfortran.dg/associate_18.f08 | 80 +++++++++++ 7 files changed, 327 insertions(+), 15 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/associate_18.f08 diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 148bc80cb13..808bf7e70a1 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,18 @@ +2015-06-23 Andre Vehreschild + + PR fortran/64674 + * parse.c (parse_associate): Figure the rank and as of a + class array in an associate early. + * primary.c (gfc_match_varspec): Prevent setting the + dimension attribute on the sym for classes. + * resolve.c (resolve_variable): Correct the component + ref's type for associated variables. Add a full array ref + when class array's are associated. + (resolve_assoc_var): Correct the type of the symbol, + when in the associate the expression's rank becomes scalar. + * trans-expr.c (gfc_conv_variable): Indirect ref needed for + allocatable associated objects. + 2015-06-19 Mikael Morin PR fortran/66549 diff --git a/gcc/fortran/parse.c b/gcc/fortran/parse.c index 56c67826dbe..c70714240d5 100644 --- a/gcc/fortran/parse.c +++ b/gcc/fortran/parse.c @@ -3958,6 +3958,8 @@ parse_associate (void) for (a = new_st.ext.block.assoc; a; a = a->next) { gfc_symbol* sym; + gfc_ref *ref; + gfc_array_ref *array_ref; if (gfc_get_sym_tree (a->name, NULL, &a->st, false)) gcc_unreachable (); @@ -3974,6 +3976,84 @@ parse_associate (void) for parsing component references on the associate-name in case of association to a derived-type. */ sym->ts = a->target->ts; + + /* Check if the target expression is array valued. This can not always + be done by looking at target.rank, because that might not have been + set yet. Therefore traverse the chain of refs, looking for the last + array ref and evaluate that. */ + array_ref = NULL; + for (ref = a->target->ref; ref; ref = ref->next) + if (ref->type == REF_ARRAY) + array_ref = &ref->u.ar; + if (array_ref || a->target->rank) + { + gfc_array_spec *as; + int dim, rank = 0; + if (array_ref) + { + /* Count the dimension, that have a non-scalar extend. */ + for (dim = 0; dim < array_ref->dimen; ++dim) + if (array_ref->dimen_type[dim] != DIMEN_ELEMENT + && !(array_ref->dimen_type[dim] == DIMEN_UNKNOWN + && array_ref->end[dim] == NULL + && array_ref->start[dim] != NULL)) + ++rank; + } + else + rank = a->target->rank; + /* When the rank is greater than zero then sym will be an array. */ + if (sym->ts.type == BT_CLASS) + { + if ((!CLASS_DATA (sym)->as && rank != 0) + || (CLASS_DATA (sym)->as + && CLASS_DATA (sym)->as->rank != rank)) + { + /* Don't just (re-)set the attr and as in the sym.ts, + because this modifies the target's attr and as. Copy the + data and do a build_class_symbol. */ + symbol_attribute attr = CLASS_DATA (a->target)->attr; + int corank = gfc_get_corank (a->target); + gfc_typespec type; + + if (rank || corank) + { + as = gfc_get_array_spec (); + as->type = AS_DEFERRED; + as->rank = rank; + as->corank = corank; + attr.dimension = rank ? 1 : 0; + attr.codimension = corank ? 1 : 0; + } + else + { + as = NULL; + attr.dimension = attr.codimension = 0; + } + attr.class_ok = 0; + type = CLASS_DATA (sym)->ts; + if (!gfc_build_class_symbol (&type, + &attr, &as)) + gcc_unreachable (); + sym->ts = type; + sym->ts.type = BT_CLASS; + sym->attr.class_ok = 1; + } + else + sym->attr.class_ok = 1; + } + else if ((!sym->as && rank != 0) + || (sym->as && sym->as->rank != rank)) + { + as = gfc_get_array_spec (); + as->type = AS_DEFERRED; + as->rank = rank; + as->corank = gfc_get_corank (a->target); + sym->as = as; + sym->attr.dimension = 1; + if (as->corank) + sym->attr.codimension = 1; + } + } } accept_statement (ST_ASSOCIATE); diff --git a/gcc/fortran/primary.c b/gcc/fortran/primary.c index e467e0b3ff0..86639aac65a 100644 --- a/gcc/fortran/primary.c +++ b/gcc/fortran/primary.c @@ -1911,7 +1911,8 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag, if (sym->assoc && gfc_peek_ascii_char () == '(' && !(sym->assoc->dangling && sym->assoc->st && sym->assoc->st->n.sym - && sym->assoc->st->n.sym->attr.dimension == 0)) + && sym->assoc->st->n.sym->attr.dimension == 0) + && sym->ts.type != BT_CLASS) sym->attr.dimension = 1; if ((equiv_flag && gfc_peek_ascii_char () == '(') diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index e332095ea9d..ea235a71e85 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -4969,6 +4969,30 @@ resolve_variable (gfc_expr *e) return false; } + /* For variables that are used in an associate (target => object) where + the object's basetype is array valued while the target is scalar, + the ts' type of the component refs is still array valued, which + can't be translated that way. */ + if (sym->assoc && e->rank == 0 && e->ref && sym->ts.type == BT_CLASS + && sym->assoc->target->ts.type == BT_CLASS + && CLASS_DATA (sym->assoc->target)->as) + { + gfc_ref *ref = e->ref; + while (ref) + { + switch (ref->type) + { + case REF_COMPONENT: + ref->u.c.sym = sym->ts.u.derived; + /* Stop the loop. */ + ref = NULL; + break; + default: + ref = ref->next; + break; + } + } + } /* If this is an associate-name, it may be parsed with an array reference in error even though the target is scalar. Fail directly in this case. @@ -4994,6 +5018,49 @@ resolve_variable (gfc_expr *e) e->ref->u.ar.dimen = 0; } + /* Like above, but for class types, where the checking whether an array + ref is present is more complicated. Furthermore make sure not to add + the full array ref to _vptr or _len refs. */ + if (sym->assoc && sym->ts.type == BT_CLASS + && CLASS_DATA (sym)->attr.dimension + && (e->ts.type != BT_DERIVED || !e->ts.u.derived->attr.vtype)) + { + gfc_ref *ref, *newref; + + newref = gfc_get_ref (); + newref->type = REF_ARRAY; + newref->u.ar.type = AR_FULL; + newref->u.ar.dimen = 0; + /* Because this is an associate var and the first ref either is a ref to + the _data component or not, no traversal of the ref chain is + needed. The array ref needs to be inserted after the _data ref, + or when that is not present, which may happend for polymorphic + types, then at the first position. */ + ref = e->ref; + if (!ref) + e->ref = newref; + else if (ref->type == REF_COMPONENT + && strcmp ("_data", ref->u.c.component->name) == 0) + { + if (!ref->next || ref->next->type != REF_ARRAY) + { + newref->next = ref->next; + ref->next = newref; + } + else + /* Array ref present already. */ + gfc_free_ref_list (newref); + } + else if (ref->type == REF_ARRAY) + /* Array ref present already. */ + gfc_free_ref_list (newref); + else + { + newref->next = ref; + e->ref = newref; + } + } + if (e->ref && !resolve_ref (e)) return false; @@ -7960,6 +8027,9 @@ gfc_type_is_extensible (gfc_symbol *sym) } +static void +resolve_types (gfc_namespace *ns); + /* Resolve an associate-name: Resolve target and ensure the type-spec is correct as well as possibly the array-spec. */ @@ -8022,6 +8092,7 @@ resolve_assoc_var (gfc_symbol* sym, bool resolve_target) return; } + /* We cannot deal with class selectors that need temporaries. */ if (target->ts.type == BT_CLASS && gfc_ref_needs_temporary_p (target->ref)) @@ -8031,22 +8102,81 @@ resolve_assoc_var (gfc_symbol* sym, bool resolve_target) return; } - if (target->ts.type != BT_CLASS && target->rank > 0) - sym->attr.dimension = 1; - else if (target->ts.type == BT_CLASS) + if (target->ts.type == BT_CLASS) gfc_fix_class_refs (target); - /* The associate-name will have a correct type by now. Make absolutely - sure that it has not picked up a dimension attribute. */ - if (sym->ts.type == BT_CLASS) - sym->attr.dimension = 0; - - if (sym->attr.dimension) + if (target->rank != 0) { - sym->as = gfc_get_array_spec (); - sym->as->rank = target->rank; - sym->as->type = AS_DEFERRED; - sym->as->corank = gfc_get_corank (target); + gfc_array_spec *as; + if (sym->ts.type != BT_CLASS && !sym->as) + { + as = gfc_get_array_spec (); + as->rank = target->rank; + as->type = AS_DEFERRED; + as->corank = gfc_get_corank (target); + sym->attr.dimension = 1; + if (as->corank != 0) + sym->attr.codimension = 1; + sym->as = as; + } + } + else + { + /* target's rank is 0, but the type of the sym is still array valued, + which has to be corrected. */ + if (sym->ts.type == BT_CLASS && CLASS_DATA (sym)->as) + { + gfc_array_spec *as; + symbol_attribute attr; + /* The associated variable's type is still the array type + correct this now. */ + gfc_typespec *ts = &target->ts; + gfc_ref *ref; + gfc_component *c; + for (ref = target->ref; ref != NULL; ref = ref->next) + { + switch (ref->type) + { + case REF_COMPONENT: + ts = &ref->u.c.component->ts; + break; + case REF_ARRAY: + if (ts->type == BT_CLASS) + ts = &ts->u.derived->components->ts; + break; + default: + break; + } + } + /* Create a scalar instance of the current class type. Because the + rank of a class array goes into its name, the type has to be + rebuild. The alternative of (re-)setting just the attributes + and as in the current type, destroys the type also in other + places. */ + as = NULL; + sym->ts = *ts; + sym->ts.type = BT_CLASS; + attr = CLASS_DATA (sym)->attr; + attr.class_ok = 0; + attr.associate_var = 1; + attr.dimension = attr.codimension = 0; + attr.class_pointer = 1; + if (!gfc_build_class_symbol (&sym->ts, &attr, &as)) + gcc_unreachable (); + /* Make sure the _vptr is set. */ + c = gfc_find_component (sym->ts.u.derived, "_vptr", true, true); + if (c->ts.u.derived == NULL) + c->ts.u.derived = gfc_find_derived_vtab (sym->ts.u.derived); + CLASS_DATA (sym)->attr.pointer = 1; + CLASS_DATA (sym)->attr.class_pointer = 1; + gfc_set_sym_referenced (sym->ts.u.derived); + gfc_commit_symbol (sym->ts.u.derived); + /* _vptr now has the _vtab in it, change it to the _vtype. */ + if (c->ts.u.derived->attr.vtab) + c->ts.u.derived = c->ts.u.derived->ts.u.derived; + c->ts.u.derived->ns->types_resolved = 0; + resolve_types (c->ts.u.derived->ns); + } } /* Mark this as an associate variable. */ diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index 5d6555bc84c..7747a6793c9 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -2529,7 +2529,8 @@ gfc_conv_variable (gfc_se * se, gfc_expr * expr) && !sym->attr.result && (CLASS_DATA (sym)->attr.dimension || CLASS_DATA (sym)->attr.codimension) - && !CLASS_DATA (sym)->attr.allocatable + && (sym->assoc + || !CLASS_DATA (sym)->attr.allocatable) && !CLASS_DATA (sym)->attr.class_pointer) se->expr = build_fold_indirect_ref_loc (input_location, se->expr); diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 8e2ab43089e..9b5d2dc8424 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,8 @@ +2015-06-23 Andre Vehreschild + + PR fortran/64674 + * gfortran.dg/associate_18.f08: New test. + 2015-06-23 Uros Bizjak PR target/66560 diff --git a/gcc/testsuite/gfortran.dg/associate_18.f08 b/gcc/testsuite/gfortran.dg/associate_18.f08 new file mode 100644 index 00000000000..16168500191 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/associate_18.f08 @@ -0,0 +1,80 @@ +! { dg-do run } +! +! Contributed by Antony Lewis +! Andre Vehreschild +! Check that associating array-sections/scalars is working +! with class arrays. +! + +program associate_18 + Type T + integer :: map = 1 + end Type T + + class(T), allocatable :: av(:) + class(T), allocatable :: am(:,:) + class(T), pointer :: pv(:) + class(T), pointer :: pm(:,:) + + integer :: iv(5) = 17 + integer :: im(4,5) = 23 + integer :: expect(20) = 23 + integer :: c + + allocate(av(2)) + associate(i => av(1)) + i%map = 2 + end associate + if (any (av%map /= [2,1])) call abort() + deallocate(av) + + allocate(am(3,4)) + associate(pam => am(2:3, 2:3)) + pam%map = 7 + pam(1,2)%map = 8 + end associate + if (any (reshape(am%map, [12]) /= [1,1,1, 1,7,7, 1,8,7, 1,1,1])) call abort() + deallocate(am) + + allocate(pv(2)) + associate(i => pv(1)) + i%map = 2 + end associate + if (any (pv%map /= [2,1])) call abort() + deallocate(pv) + + allocate(pm(3,4)) + associate(ppm => pm(2:3, 2:3)) + ppm%map = 7 + ppm(1,2)%map = 8 + end associate + if (any (reshape(pm%map, [12]) /= [1,1,1, 1,7,7, 1,8,7, 1,1,1])) call abort() + deallocate(pm) + + associate(i => iv(1)) + i = 7 + end associate + if (any (iv /= [7, 17, 17, 17, 17])) call abort() + + associate(pam => im(2:3, 2:3)) + pam = 9 + pam(1,2) = 10 + do c = 1, 2 + pam(2, c) = 0 + end do + end associate + if (any (reshape(im, [20]) /= [23,23,23,23, 23,9,0,23, & + 23,10,0,23, 23,23,23,23, 23,23,23,23])) call abort() + + expect(2:3) = 9 + do c = 1, 5 + im = 23 + associate(pam => im(:, c)) + pam(2:3) = 9 + end associate + if (any (reshape(im, [20]) /= expect)) call abort() + ! Shift expect + expect = [expect(17:), expect(:16)] + end do +end program + -- 2.30.2