aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--gcc/fortran/ChangeLog15
-rw-r--r--gcc/fortran/parse.c80
-rw-r--r--gcc/fortran/primary.c3
-rw-r--r--gcc/fortran/resolve.c156
-rw-r--r--gcc/fortran/trans-expr.c3
-rw-r--r--gcc/testsuite/ChangeLog5
-rw-r--r--gcc/testsuite/gfortran.dg/associate_18.f0880
7 files changed, 327 insertions, 15 deletions
diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 148bc80..808bf7e 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,18 @@
+2015-06-23 Andre Vehreschild <vehre@gmx.de>
+
+ 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 <mikael@gcc.gnu.org>
PR fortran/66549
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 e332095..ea235a7 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 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/ChangeLog b/gcc/testsuite/ChangeLog
index 8e2ab43..9b5d2dc 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,8 @@
+2015-06-23 Andre Vehreschild <vehre@gmx.de>
+
+ PR fortran/64674
+ * gfortran.dg/associate_18.f08: New test.
+
2015-06-23 Uros Bizjak <ubizjak@gmail.com>
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 0000000..1616850
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/associate_18.f08
@@ -0,0 +1,80 @@
+! { dg-do run }
+!
+! Contributed by Antony Lewis <antony@cosmologist.info>
+! Andre Vehreschild <vehre@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
+ 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
+
generated by cgit v1.1 at 2024-11-02 16:01:32 +0000