===================================================================
*************** gfc_vtable_copy_get (tree decl)
#undef VTABLE_COPY_FIELD
/* Takes a derived type expression and returns the address of a temporary
! class object of the 'declared' type. */
! static void
gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e,
! gfc_typespec class_ts)
{
gfc_symbol *vtab;
gfc_ss *ss;
#undef VTABLE_COPY_FIELD
+ /* Obtain the vptr of the last class reference in an expression. */
+
+ tree
+ gfc_get_vptr_from_expr (tree expr)
+ {
+ tree tmp = expr;
+ while (tmp && !GFC_CLASS_TYPE_P (TREE_TYPE (tmp)))
+ tmp = TREE_OPERAND (tmp, 0);
+ tmp = gfc_class_vptr_get (tmp);
+ return tmp;
+ }
+
+
/* Takes a derived type expression and returns the address of a temporary
! class object of the 'declared' type. If vptr is not NULL, this is
! used for the temporary class object. */
! void
gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e,
! gfc_typespec class_ts, tree vptr)
{
gfc_symbol *vtab;
gfc_ss *ss;
*************** gfc_conv_derived_to_class (gfc_se *parms
/* Set the vptr. */
ctree = gfc_class_vptr_get (var);
! /* Remember the vtab corresponds to the derived type
! not to the class declared type. */
! vtab = gfc_find_derived_vtab (e->ts.u.derived);
! gcc_assert (vtab);
! tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab));
gfc_add_modify (&parmse->pre, ctree,
fold_convert (TREE_TYPE (ctree), tmp));
/* Set the vptr. */
ctree = gfc_class_vptr_get (var);
! if (vptr != NULL_TREE)
! {
! /* Use the dynamic vptr. */
! tmp = vptr;
! }
! else
! {
! /* In this case the vtab corresponds to the derived type and the
! vptr must point to it. */
! vtab = gfc_find_derived_vtab (e->ts.u.derived);
! gcc_assert (vtab);
! tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab));
! }
gfc_add_modify (&parmse->pre, ctree,
fold_convert (TREE_TYPE (ctree), tmp));
*************** gfc_conv_procedure_call (gfc_se * se, gf
/* The derived type needs to be converted to a temporary
CLASS object. */
gfc_init_se (&parmse, se);
! gfc_conv_derived_to_class (&parmse, e, fsym->ts);
}
else if (se->ss && se->ss->info->useflags)
{
/* The derived type needs to be converted to a temporary
CLASS object. */
gfc_init_se (&parmse, se);
! gfc_conv_derived_to_class (&parmse, e, fsym->ts, NULL);
}
else if (se->ss && se->ss->info->useflags)
{
===================================================================
*************** add_to_offset (tree *cst_offset, tree *o
}
}
+
+ static tree
+ build_array_ref (tree desc, tree offset, tree decl)
+ {
+ tree tmp;
+
+ /* Class array references need special treatment because the assigned
+ type size needs to be used to point to the element. */
+ if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc))
+ && TREE_CODE (desc) == COMPONENT_REF
+ && GFC_CLASS_TYPE_P (TREE_TYPE (TREE_OPERAND (desc, 0))))
+ {
+ tree type = gfc_get_element_type (TREE_TYPE (desc));
+ tmp = TREE_OPERAND (desc, 0);
+ tmp = gfc_get_class_array_ref (offset, tmp);
+ tmp = fold_convert (build_pointer_type (type), tmp);
+ tmp = build_fold_indirect_ref_loc (input_location, tmp);
+ }
+ else
+ {
+ tmp = gfc_conv_array_data (desc);
+ tmp = build_fold_indirect_ref_loc (input_location, tmp);
+ tmp = gfc_build_array_ref (tmp, offset, decl);
+ }
+
+ return tmp;
+ }
+
+
+
/* Build an array reference. se->expr already holds the array descriptor.
This should be either a variable, indirect variable reference or component
reference. For arrays which do not have a descriptor, se->expr will be
*************** gfc_conv_array_ref (gfc_se * se, gfc_arr
offset = fold_build2_loc (input_location, PLUS_EXPR,
gfc_array_index_type, offset, cst_offset);
! /* Access the calculated element. */
! tmp = gfc_conv_array_data (se->expr);
! tmp = build_fold_indirect_ref (tmp);
! se->expr = gfc_build_array_ref (tmp, offset, sym->backend_decl);
}
offset = fold_build2_loc (input_location, PLUS_EXPR,
gfc_array_index_type, offset, cst_offset);
! se->expr = build_array_ref (se->expr, offset, sym->backend_decl);
}
*************** gfc_get_dataptr_offset (stmtblock_t *blo
return;
}
! tmp = gfc_conv_array_data (desc);
! tmp = build_fold_indirect_ref_loc (input_location,
! tmp);
! tmp = gfc_build_array_ref (tmp, offset, NULL);
/* Offset the data pointer for pointer assignments from arrays with
subreferences; e.g. my_integer => my_type(:)%integer_component. */
return;
}
! tmp = build_array_ref (desc, offset, NULL);
/* Offset the data pointer for pointer assignments from arrays with
subreferences; e.g. my_integer => my_type(:)%integer_component. */
===================================================================
*************** gfc_is_associate_pointer (gfc_symbol* sy
if (!sym->assoc)
return false;
+ if (sym->ts.type == BT_CLASS)
+ return true;
+
if (!sym->assoc->variable)
return false;
===================================================================
*************** trans_associate_var (gfc_symbol *sym, gf
gfc_expr *e;
tree tmp;
bool class_target;
+ tree desc;
+ tree offset;
+ tree dim;
+ int n;
gcc_assert (sym->assoc);
e = sym->assoc->target;
*************** trans_associate_var (gfc_symbol *sym, gf
gfc_finish_block (&se.post));
}
! /* CLASS arrays just need the descriptor to be directly assigned. */
! else if (class_target && sym->attr.dimension)
{
gfc_se se;
gfc_finish_block (&se.post));
}
! /* Derived type temporaries, arising from TYPE IS, just need the
! descriptor of class arrays to be assigned directly. */
! else if (class_target && sym->ts.type == BT_DERIVED && sym->attr.dimension)
{
gfc_se se;
*************** trans_associate_var (gfc_symbol *sym, gf
gcc_assert (!sym->attr.dimension);
gfc_init_se (&se, NULL);
! gfc_conv_expr (&se, e);
tmp = TREE_TYPE (sym->backend_decl);
tmp = gfc_build_addr_expr (tmp, se.expr);
gcc_assert (!sym->attr.dimension);
gfc_init_se (&se, NULL);
!
! /* Class associate-names come this way because they are
! unconditionally associate pointers and the symbol is scalar. */
! if (sym->ts.type == BT_CLASS && CLASS_DATA (sym)->attr.dimension)
! {
! /* For a class array we need a descriptor for the selector. */
! gfc_conv_expr_descriptor (&se, e, gfc_walk_expr (e));
!
! /* Obtain a temporary class container for the result. */
! gfc_conv_class_to_class (&se, e, sym->ts, false);
! se.expr = build_fold_indirect_ref_loc (input_location, se.expr);
!
! /* Set the offset. */
! desc = gfc_class_data_get (se.expr);
! offset = gfc_index_zero_node;
! for (n = 0; n < e->rank; n++)
! {
! dim = gfc_rank_cst[n];
! tmp = fold_build2_loc (input_location, MULT_EXPR,
! gfc_array_index_type,
! gfc_conv_descriptor_stride_get (desc, dim),
! gfc_conv_descriptor_lbound_get (desc, dim));
! offset = fold_build2_loc (input_location, MINUS_EXPR,
! gfc_array_index_type,
! offset, tmp);
! }
! gfc_conv_descriptor_offset_set (&se.pre, desc, offset);
! }
! else if (sym->ts.type == BT_CLASS && e->ts.type == BT_CLASS
! && CLASS_DATA (e)->attr.dimension)
! {
! /* This is bound to be a class array element. */
! gfc_conv_expr_reference (&se, e);
! /* Get the _vptr component of the class object. */
! tmp = gfc_get_vptr_from_expr (se.expr);
! /* Obtain a temporary class container for the result. */
! gfc_conv_derived_to_class (&se, e, sym->ts, tmp);
! se.expr = build_fold_indirect_ref_loc (input_location, se.expr);
! }
! else
! gfc_conv_expr (&se, e);
tmp = TREE_TYPE (sym->backend_decl);
tmp = gfc_build_addr_expr (tmp, se.expr);
===================================================================
*************** gfc_get_variable_expr (gfc_symtree *var)
e->ref = gfc_get_ref ();
e->ref->type = REF_ARRAY;
e->ref->u.ar.type = AR_FULL;
+ e->ref->u.ar.as = gfc_copy_array_spec (var->n.sym->ts.type == BT_CLASS
+ ? CLASS_DATA (var->n.sym)->as
+ : var->n.sym->as);
}
return e;
===================================================================
*************** gfc_typenode_for_spec (gfc_typespec * sp
case BT_CLASS:
basetype = gfc_get_derived_type (spec->u.derived);
+ if (spec->type == BT_CLASS)
+ GFC_CLASS_TYPE_P (basetype) = 1;
+
/* If we're dealing with either C_PTR or C_FUNPTR, we modified the
type and kind to fit a (void *) and the basetype returned was a
ptr_type_node. We need to pass up this new information to the
===================================================================
*************** tree gfc_vtable_size_get (tree);
tree gfc_vtable_extends_get (tree);
tree gfc_vtable_def_init_get (tree);
tree gfc_vtable_copy_get (tree);
+ tree gfc_get_vptr_from_expr (tree);
tree gfc_get_class_array_ref (tree, tree);
tree gfc_copy_class_to_class (tree, tree, tree);
+ void gfc_conv_derived_to_class (gfc_se *, gfc_expr *, gfc_typespec, tree);
void gfc_conv_class_to_class (gfc_se *, gfc_expr *, gfc_typespec, bool);
/* Initialize an init/cleanup block. */
*************** struct GTY((variable_size)) lang_decl {
#define GFC_ARRAY_TYPE_P(node) TYPE_LANG_FLAG_2(node)
/* Fortran POINTER type. */
#define GFC_POINTER_TYPE_P(node) TYPE_LANG_FLAG_3(node)
+ /* Fortran CLASS type. */
+ #define GFC_CLASS_TYPE_P(node) TYPE_LANG_FLAG_4(node)
/* The GFC_TYPE_ARRAY_* members are present in both descriptor and
descriptorless array types. */
#define GFC_TYPE_ARRAY_LBOUND(node, dim) \
===================================================================
*************** resolve_variable (gfc_expr *e)
}
/* 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. */
! if (sym->assoc && !sym->attr.dimension && e->ref && e->ref->type == REF_ARRAY)
! return FAILURE;
if (sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.generic)
sym->ts.u.derived = gfc_find_dt_in_generic (sym->ts.u.derived);
}
/* 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.
! TODO Understand why class scalar expressions must be excluded. */
! if (sym->assoc && !(sym->ts.type == BT_CLASS && e->rank == 0))
! {
! if (sym->ts.type == BT_CLASS)
! gfc_fix_class_refs (e);
! if (!sym->attr.dimension && e->ref && e->ref->type == REF_ARRAY)
! return FAILURE;
! }
if (sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.generic)
sym->ts.u.derived = gfc_find_dt_in_generic (sym->ts.u.derived);
*************** gfc_type_is_extensible (gfc_symbol *sym)
}
! /* Resolve an associate name: Resolve target and ensure the type-spec is
correct as well as possibly the array-spec. */
static void
}
! /* Resolve an associate-name: Resolve target and ensure the type-spec is
correct as well as possibly the array-spec. */
static void
*************** resolve_assoc_var (gfc_symbol* sym, bool
sym->attr.dimension = 0;
return;
}
! if (target->rank > 0)
sym->attr.dimension = 1;
if (sym->attr.dimension)
{
sym->attr.dimension = 0;
return;
}
!
! /* We cannot deal with class selectors that need temporaries. */
! if (target->ts.type == BT_CLASS
! && gfc_ref_needs_temporary_p (target->ref))
! {
! gfc_error ("CLASS selector at %L needs a temporary which is not "
! "yet implemented", &target->where);
! return;
! }
!
! if (target->ts.type == BT_CLASS)
! {
! gfc_ref *ref;
! bool seen_array = false;
! for (ref = target->ref; ref; ref = ref->next)
! {
! if (ref->type == REF_ARRAY && ref->u.ar.type != AR_ELEMENT)
! seen_array = true;
!
! if (!ref->next)
! break;
! }
!
! if (ref && ref->type != REF_ARRAY && seen_array)
! {
! gfc_error ("CLASS selector at %L is an array with CLASS "
! "components; this is not allowed since the "
! "elements could have different dynamic types",
! &target->where);
! return;
! }
! }
!
! if (target->ts.type != BT_CLASS && target->rank > 0)
sym->attr.dimension = 1;
+ else 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)
{
===================================================================
*************** gfc_match_select (void)
}
+ /* Transfer the selector typespec to the associate name. */
+
+ static void
+ copy_ts_from_selector_to_associate (gfc_expr *associate, gfc_expr *selector)
+ {
+ gfc_ref *ref;
+ gfc_symbol *assoc_sym;
+
+ assoc_sym = associate->symtree->n.sym;
+
+ /* Ensure that any array reference is resolved. */
+ gfc_resolve_expr (selector);
+
+ /* At this stage the expression rank and arrayspec dimensions have
+ not been completely sorted out. We must get the expr2->rank
+ right here, so that the correct class container is obtained. */
+ ref = selector->ref;
+ while (ref && ref->next)
+ ref = ref->next;
+
+ if (selector->ts.type == BT_CLASS
+ && CLASS_DATA (selector)->as
+ && ref && ref->type == REF_ARRAY)
+ {
+ if (ref->u.ar.type == AR_FULL)
+ selector->rank = CLASS_DATA (selector)->as->rank;
+ else if (ref->u.ar.type == AR_SECTION)
+ selector->rank = ref->u.ar.dimen;
+ else
+ selector->rank = 0;
+ }
+
+ if (selector->ts.type != BT_CLASS)
+ {
+ /* The correct class container has to be available. */
+ if (selector->rank)
+ {
+ assoc_sym->attr.dimension = 1;
+ assoc_sym->as = gfc_get_array_spec ();
+ assoc_sym->as->rank = selector->rank;
+ assoc_sym->as->type = AS_DEFERRED;
+ }
+ else
+ assoc_sym->as = NULL;
+
+ assoc_sym->ts.type = BT_CLASS;
+ assoc_sym->ts.u.derived = selector->ts.u.derived;
+ assoc_sym->attr.pointer = 1;
+ gfc_build_class_symbol (&assoc_sym->ts, &assoc_sym->attr,
+ &assoc_sym->as, false);
+ }
+ else
+ {
+ /* The correct class container has to be available. */
+ if (selector->rank)
+ {
+ assoc_sym->attr.dimension = 1;
+ assoc_sym->as = gfc_get_array_spec ();
+ assoc_sym->as->rank = selector->rank;
+ assoc_sym->as->type = AS_DEFERRED;
+ }
+ else
+ assoc_sym->as = NULL;
+ assoc_sym->ts.type = BT_CLASS;
+ assoc_sym->ts.u.derived = CLASS_DATA (selector)->ts.u.derived;
+ assoc_sym->attr.pointer = 1;
+ gfc_build_class_symbol (&assoc_sym->ts, &assoc_sym->attr,
+ &assoc_sym->as, false);
+ }
+ }
+
+
/* Push the current selector onto the SELECT TYPE stack. */
static void
*************** select_type_push (gfc_symbol *sel)
}
! /* Set the temporary for the current SELECT TYPE selector. */
! static void
! select_type_set_tmp (gfc_typespec *ts)
{
char name[GFC_MAX_SYMBOL_LEN];
gfc_symtree *tmp;
! if (!ts)
{
! select_type_stack->tmp = NULL;
! return;
}
! if (!gfc_type_is_extensible (ts->u.derived))
! return;
! if (ts->type == BT_CLASS)
! sprintf (name, "__tmp_class_%s", ts->u.derived->name);
! else
! sprintf (name, "__tmp_type_%s", ts->u.derived->name);
gfc_get_sym_tree (name, gfc_current_ns, &tmp, false);
gfc_add_type (tmp->n.sym, ts, NULL);
! /* Copy across the array spec to the selector, taking care as to
! whether or not it is a class object or not. */
if (select_type_stack->selector->ts.type == BT_CLASS
- && select_type_stack->selector->attr.class_ok
&& (CLASS_DATA (select_type_stack->selector)->attr.dimension
|| CLASS_DATA (select_type_stack->selector)->attr.codimension))
{
! if (ts->type == BT_CLASS)
! {
! CLASS_DATA (tmp->n.sym)->attr.dimension
= CLASS_DATA (select_type_stack->selector)->attr.dimension;
! CLASS_DATA (tmp->n.sym)->attr.codimension
= CLASS_DATA (select_type_stack->selector)->attr.codimension;
! CLASS_DATA (tmp->n.sym)->as = gfc_get_array_spec ();
! CLASS_DATA (tmp->n.sym)->as
! = CLASS_DATA (select_type_stack->selector)->as;
! }
! else
! {
! tmp->n.sym->attr.dimension
! = CLASS_DATA (select_type_stack->selector)->attr.dimension;
! tmp->n.sym->attr.codimension
! = CLASS_DATA (select_type_stack->selector)->attr.codimension;
! tmp->n.sym->as = gfc_get_array_spec ();
! tmp->n.sym->as = CLASS_DATA (select_type_stack->selector)->as;
! }
}
gfc_set_sym_referenced (tmp->n.sym);
gfc_add_flavor (&tmp->n.sym->attr, FL_VARIABLE, name, NULL);
tmp->n.sym->attr.select_type_temporary = 1;
if (ts->type == BT_CLASS)
! gfc_build_class_symbol (&tmp->n.sym->ts, &tmp->n.sym->attr,
! &tmp->n.sym->as, false);
/* Add an association for it, so the rest of the parser knows it is
an associate-name. The target will be set during resolution. */
}
! /* Set the temporary for the current derived type SELECT TYPE selector. */
! static gfc_symtree *
! select_derived_set_tmp (gfc_typespec *ts)
{
char name[GFC_MAX_SYMBOL_LEN];
gfc_symtree *tmp;
! sprintf (name, "__tmp_type_%s", ts->u.derived->name);
! gfc_get_sym_tree (name, gfc_current_ns, &tmp, false);
! gfc_add_type (tmp->n.sym, ts, NULL);
!
! /* Copy across the array spec to the selector. */
! if (select_type_stack->selector->ts.type == BT_CLASS
! && select_type_stack->selector->attr.class_ok
! && (CLASS_DATA (select_type_stack->selector)->attr.dimension
! || CLASS_DATA (select_type_stack->selector)->attr.codimension))
{
! tmp->n.sym->attr.dimension
! = CLASS_DATA (select_type_stack->selector)->attr.dimension;
! tmp->n.sym->attr.codimension
! = CLASS_DATA (select_type_stack->selector)->attr.codimension;
! tmp->n.sym->as
! = gfc_copy_array_spec (CLASS_DATA (select_type_stack->selector)->as);
}
+
+ gfc_set_sym_referenced (tmp->n.sym);
+ gfc_add_flavor (&tmp->n.sym->attr, FL_VARIABLE, name, NULL);
+ tmp->n.sym->attr.select_type_temporary = 1;
+
+ return tmp;
+ }
+
+
+ /* Set the temporary for the current class SELECT TYPE selector. */
+
+ static gfc_symtree *
+ select_class_set_tmp (gfc_typespec *ts)
+ {
+ char name[GFC_MAX_SYMBOL_LEN];
+ gfc_symtree *tmp;
! if (select_type_stack->selector->ts.type == BT_CLASS
! && !select_type_stack->selector->attr.class_ok)
! return NULL;
! sprintf (name, "__tmp_class_%s", ts->u.derived->name);
gfc_get_sym_tree (name, gfc_current_ns, &tmp, false);
gfc_add_type (tmp->n.sym, ts, NULL);
! /* Copy across the array spec to the selector. */
if (select_type_stack->selector->ts.type == BT_CLASS
&& (CLASS_DATA (select_type_stack->selector)->attr.dimension
|| CLASS_DATA (select_type_stack->selector)->attr.codimension))
{
! tmp->n.sym->attr.pointer = 1;
! tmp->n.sym->attr.dimension
= CLASS_DATA (select_type_stack->selector)->attr.dimension;
! tmp->n.sym->attr.codimension
= CLASS_DATA (select_type_stack->selector)->attr.codimension;
! tmp->n.sym->as
! = gfc_copy_array_spec (CLASS_DATA (select_type_stack->selector)->as);
}
gfc_set_sym_referenced (tmp->n.sym);
gfc_add_flavor (&tmp->n.sym->attr, FL_VARIABLE, name, NULL);
tmp->n.sym->attr.select_type_temporary = 1;
+ gfc_build_class_symbol (&tmp->n.sym->ts, &tmp->n.sym->attr,
+ &tmp->n.sym->as, false);
+
+ return tmp;
+ }
+
+
+ static void
+ select_type_set_tmp (gfc_typespec *ts)
+ {
+ gfc_symtree *tmp;
+
+ if (!ts)
+ {
+ select_type_stack->tmp = NULL;
+ return;
+ }
+
+ if (!gfc_type_is_extensible (ts->u.derived))
+ return;
+
+ /* Logic is a LOT clearer with separate functions for class and derived
+ type temporaries! There are not many more lines of code either. */
if (ts->type == BT_CLASS)
! tmp = select_class_set_tmp (ts);
! else
! tmp = select_derived_set_tmp (ts);
!
! if (tmp == NULL)
! return;
/* Add an association for it, so the rest of the parser knows it is
an associate-name. The target will be set during resolution. */
*************** select_type_set_tmp (gfc_typespec *ts)
select_type_stack->tmp = tmp;
}
!
/* Match a SELECT TYPE statement. */
match
select_type_stack->tmp = tmp;
}
!
/* Match a SELECT TYPE statement. */
match
*************** gfc_match_select_type (void)
match m;
char name[GFC_MAX_SYMBOL_LEN];
bool class_array;
+ gfc_symbol *sym;
m = gfc_match_label ();
if (m == MATCH_ERROR)
*************** gfc_match_select_type (void)
m = MATCH_ERROR;
goto cleanup;
}
if (expr2->ts.type == BT_UNKNOWN)
! expr1->symtree->n.sym->attr.untyped = 1;
else
! expr1->symtree->n.sym->ts = expr2->ts;
! expr1->symtree->n.sym->attr.flavor = FL_VARIABLE;
! expr1->symtree->n.sym->attr.referenced = 1;
! expr1->symtree->n.sym->attr.class_ok = 1;
}
else
{
m = MATCH_ERROR;
goto cleanup;
}
+
+ sym = expr1->symtree->n.sym;
if (expr2->ts.type == BT_UNKNOWN)
! sym->attr.untyped = 1;
else
! copy_ts_from_selector_to_associate (expr1, expr2);
!
! sym->attr.flavor = FL_VARIABLE;
! sym->attr.referenced = 1;
! sym->attr.class_ok = 1;
}
else
{
===================================================================
***************
+ ! { dg-do run }
+ ! Tests fix for PR41600 and further SELECT TYPE functionality.
+ !
+ ! Reported by Tobias Burnus <burnus@gcc.gnu.org>
+ !
+ implicit none
+ type t0
+ integer :: j = 42
+ end type t0
+
+ type, extends(t0) :: t1
+ integer :: k = 99
+ end type t1
+
+ type t
+ integer :: i
+ class(t0), allocatable :: foo(:)
+ end type t
+
+ type t_scalar
+ integer :: i
+ class(t0), allocatable :: foo
+ end type t_scalar
+
+ type(t) :: m
+ type(t_scalar) :: m1(4)
+ integer :: n
+
+ ! Test the fix for PR41600 itself - first with m%foo of declared type.
+ allocate(m%foo(3), source = [(t0(n), n = 1,3)])
+ select type(bar => m%foo)
+ type is(t0)
+ if (any (bar%j .ne. [1,2,3])) call abort
+ type is(t1)
+ call abort
+ end select
+
+ deallocate(m%foo)
+ allocate(m%foo(3), source = [(t1(n, n*10), n = 4,6)])
+
+ ! Then with m%foo of another dynamic type.
+ select type(bar => m%foo)
+ type is(t0)
+ call abort
+ type is(t1)
+ if (any (bar%k .ne. [40,50,60])) call abort
+ end select
+
+ ! Try it with a selector array section.
+ select type(bar => m%foo(2:3))
+ type is(t0)
+ call abort
+ type is(t1)
+ if (any (bar%k .ne. [50,60])) call abort
+ end select
+
+ ! Try it with a selector array element.
+ select type(bar => m%foo(2))
+ type is(t0)
+ call abort
+ type is(t1)
+ if (bar%k .ne. 50) call abort
+ end select
+
+ ! Now try class is and a selector which is an array section of an associate name.
+ select type(bar => m%foo)
+ type is(t0)
+ call abort
+ class is (t1)
+ if (any (bar%j .ne. [4,5,6])) call abort
+ select type (foobar => bar(3:2:-1))
+ type is (t1)
+ if (any (foobar%k .ne. [60,50])) call abort
+ end select
+ end select
+
+ ! Now try class is and a selector which is an array element of an associate name.
+ select type(bar => m%foo)
+ type is(t0)
+ call abort
+ class is (t1)
+ if (any (bar%j .ne. [4,5,6])) call abort
+ select type (foobar => bar(2))
+ type is (t1)
+ if (foobar%k .ne. 50) call abort
+ end select
+ end select
+
+ ! Check class a component of an element of an array. Note that an array of such
+ ! objects cannot be allowed since the elements could have different dynamic types.
+ do n = 1, 2
+ allocate(m1(n)%foo, source = t1(n*99, n*999))
+ end do
+ do n = 3, 4
+ allocate(m1(n)%foo, source = t0(n*99))
+ end do
+ select type(bar => m1(3)%foo)
+ type is(t0)
+ if (bar%j .ne. 297) call abort
+ type is(t1)
+ call abort
+ end select
+ select type(bar => m1(1)%foo)
+ type is(t0)
+ call abort
+ type is(t1)
+ if (bar%k .ne. 999) call abort
+ end select
+ end
===================================================================
***************
+ ! { dg-do run }
+ ! Tests fix for PR41600 and further SELECT TYPE functionality.
+ ! This differs from the original and select_type_26.f03 by 'm'
+ ! being a class object rather than a derived type.
+ !
+ ! Reported by Tobias Burnus <burnus@gcc.gnu.org>
+ !
+ implicit none
+ type t0
+ integer :: j = 42
+ end type t0
+
+ type, extends(t0) :: t1
+ integer :: k = 99
+ end type t1
+
+ type t
+ integer :: i
+ class(t0), allocatable :: foo(:)
+ end type t
+
+ type t_scalar
+ integer :: i
+ class(t0), allocatable :: foo
+ end type t_scalar
+
+ class(t), allocatable :: m
+ class(t_scalar), allocatable :: m1(:)
+ integer :: n
+
+ allocate (m)
+ allocate (m1(4))
+
+ ! Test the fix for PR41600 itself - first with m%foo of declared type.
+ allocate(m%foo(3), source = [(t0(n), n = 1,3)])
+ select type(bar => m%foo)
+ type is(t0)
+ if (any (bar%j .ne. [1,2,3])) call abort
+ type is(t1)
+ call abort
+ end select
+
+ deallocate(m%foo)
+ allocate(m%foo(3), source = [(t1(n, n*10), n = 4,6)])
+
+ ! Then with m%foo of another dynamic type.
+ select type(bar => m%foo)
+ type is(t0)
+ call abort
+ type is(t1)
+ if (any (bar%k .ne. [40,50,60])) call abort
+ end select
+
+ ! Try it with a selector array section.
+ select type(bar => m%foo(2:3))
+ type is(t0)
+ call abort
+ type is(t1)
+ if (any (bar%k .ne. [50,60])) call abort
+ end select
+
+ ! Try it with a selector array element.
+ select type(bar => m%foo(2))
+ type is(t0)
+ call abort
+ type is(t1)
+ if (bar%k .ne. 50) call abort
+ end select
+
+ ! Now try class is and a selector which is an array section of an associate name.
+ select type(bar => m%foo)
+ type is(t0)
+ call abort
+ class is (t1)
+ if (any (bar%j .ne. [4,5,6])) call abort
+ select type (foobar => bar(3:2:-1))
+ type is (t1)
+ if (any (foobar%k .ne. [60,50])) call abort
+ end select
+ end select
+
+ ! Now try class is and a selector which is an array element of an associate name.
+ select type(bar => m%foo)
+ type is(t0)
+ call abort
+ class is (t1)
+ if (any (bar%j .ne. [4,5,6])) call abort
+ select type (foobar => bar(2))
+ type is (t1)
+ if (foobar%k .ne. 50) call abort
+ end select
+ end select
+
+ ! Check class a component of an element of an array. Note that an array of such
+ ! objects cannot be allowed since the elements could have different dynamic types.
+ do n = 1, 2
+ allocate(m1(n)%foo, source = t1(n*99, n*999))
+ end do
+ do n = 3, 4
+ allocate(m1(n)%foo, source = t0(n*99))
+ end do
+ select type(bar => m1(3)%foo)
+ type is(t0)
+ if (bar%j .ne. 297) call abort
+ type is(t1)
+ call abort
+ end select
+ select type(bar => m1(1)%foo)
+ type is(t0)
+ call abort
+ type is(t1)
+ if (bar%k .ne. 999) call abort
+ end select
+ end
===================================================================
***************
+ ! { dg-do compile }
+ ! SELECT TYPE.
+ !
+ implicit none
+ type t0
+ integer :: j = 42
+ end type t0
+ type, extends(t0) :: t1
+ integer :: k = 99
+ end type t1
+ type t
+ integer :: i
+ class(t0), allocatable :: foo
+ end type t
+ type(t) :: m(4)
+ integer :: n
+
+ do n = 1, 2
+ allocate(m(n)%foo, source = t0(n*99))
+ end do
+ do n = 3, 4
+ allocate(m(n)%foo, source = t1(n*99, n*999))
+ end do
+
+ ! An array of objects with ultimate class components cannot be a selector
+ ! since each element could have a different dynamic type.
+
+ select type(bar => m%foo) ! { dg-error "is an array with CLASS components" }
+ type is(t0)
+ if (any (bar%j .ne. [99, 198, 297, 396])) call abort
+ type is(t1)
+ call abort
+ end select
+
+ end