Hi all, a ping on this patch. Rebased to current trunk.
Bootstraps and regtests fine on x86_64-linux-gnu/f21. Ok for trunk? - Andre > On Mon, 4 May 2015 16:53:15 +0200 > Andre Vehreschild <ve...@gmx.de> wrote: > > > Hi all, > > > > I like to present here a first patch for using class arrays in associate. > > Upto now gfortran crashed, when a class array-section/element was selected > > in an associate. This patch fixes this now for class array sections as well > > as for single elements. > > > > The story of the patch is told quite shortly: > > > > - parse.c::parse_associate() needs to gather more information about what the > > target is like. Previously the target's rank and array_spec was not > > computed, which disallowed the use of further array refs in the associate > > body: associate (vec => class_matrix(2:3, 2)) > > vec(1) = ... ! <- Unclassifiable statement, because no array_spec was > > attached to vec. This is fixed by the second hunk of the patch. > > > > - The third hunk in primary.c prevents setting the dimension attribute on a > > class object's symbol. > > > > - The hunks in resolve.c take care about adding dummy full array_refs and in > > resolve_assoc_var correct the class type, when the target expression's > > rank is 0. Previously the symbol would have an array valued type, when the > > target's base type was array valued. But for a scalar target this needed > > some polishing. > > > > - Additionally a test was added. > > > > Bootstraps and regtests ok on x86_64-linux-gnu/f21. > > > > Ok for trunk? > > > > Note, this patch was diffed from a trunk with my older patches for > > > > PR65548, v3 https://gcc.gnu.org/ml/fortran/2015-04/msg00123.html and > > PR44672, v5 https://gcc.gnu.org/ml/fortran/2015-04/msg00124.html > > > > applied. > > > > Regards, > > Andre > > -- Andre Vehreschild * Email: vehre ad gmx dot de
pr64674_3.clog
Description: Binary data
diff --git a/gcc/fortran/parse.c b/gcc/fortran/parse.c
index 56c6782..c707142 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 e467e0b..86639aa 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 f365e8f..b26115d 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -4974,6 +4974,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.
@@ -4999,6 +5023,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;
@@ -7965,6 +8032,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. */
@@ -8027,6 +8097,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))
@@ -8036,22 +8107,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 5d6555b..7747a67 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/gfortran.dg/associate_18.f08 b/gcc/testsuite/gfortran.dg/associate_18.f08
new file mode 100644
index 0000000..fdcc645
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/associate_18.f08
@@ -0,0 +1,64 @@
+! { dg-do run }
+!
+! Contributed by Antony Lewis <ant...@cosmologist.info>
+! Andre Vehreschild <ve...@gcc.gnu.org>
+! 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
+
+ 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
+ end associate
+ if (any (reshape(im, [20]) /= [23,23,23,23, 23,9,9,23, &
+ 23,10,9,23, 23,23,23,23, 23,23,23,23])) call abort()
+end program
+
