re PR fortran/64674 ([OOP] ICE in ASSOCIATE with class array)
gcc/fortran/ChangeLog: 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. gcc/testsuite/ChangeLog: 2015-06-23 Andre Vehreschild <vehre@gmx.de> PR fortran/64674 * gfortran.dg/associate_18.f08: New test. From-SVN: r224827
This commit is contained in:
Andre Vehreschild
Andre Vehreschild
parent
bcd119b7a3
commit
76540ac3e3
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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);
|
||||
|
|
|
|||
|
|
@ -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 () == '(')
|
||||
|
|
|
|||
|
|
@ -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. */
|
||||
|
|
|
|||
|
|
@ -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);
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
Loading…
Reference in New Issue