+2012-05-05 Paul Thomas <pault@gcc.gnu.org>
+
+ PR fortran/41600
+ * trans-array.c (build_array_ref): New static function.
+ (gfc_conv_array_ref, gfc_get_dataptr_offset): Call it.
+ * trans-expr.c (gfc_get_vptr_from_expr): New function.
+ (gfc_conv_derived_to_class): Add a new argument for a caller
+ supplied vptr and use it if it is not NULL.
+ (gfc_conv_procedure_call): Add NULL to call to above.
+ symbol.c (gfc_is_associate_pointer): Return true if symbol is
+ a class object.
+ * trans-stmt.c (trans_associate_var): Handle class associate-
+ names.
+ * expr.c (gfc_get_variable_expr): Supply the array-spec if
+ possible.
+ * trans-types.c (gfc_typenode_for_spec): Set GFC_CLASS_TYPE_P
+ for class types.
+ * trans.h : Add prototypes for gfc_get_vptr_from_expr and
+ gfc_conv_derived_to_class. Define GFC_CLASS_TYPE_P.
+ * resolve.c (resolve_variable): For class arrays, ensure that
+ the target expression has all the necessary _data references.
+ (resolve_assoc_var): Throw a "not yet implemented" error for
+ class array selectors that need a temporary.
+ * match.c (copy_ts_from_selector_to_associate,
+ select_derived_set_tmp, select_class_set_tmp): New functions.
+ (select_type_set_tmp): Call one of last two new functions.
+ (gfc_match_select_type): Copy_ts_from_selector_to_associate is
+ called if associate-name is typed.
+
+ PR fortran/53191
+ * resolve.c (resolve_ref): C614 applied to class expressions.
+
2012-05-05 Janne Blomqvist <jb@gcc.gnu.org>
PR fortran/49010
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;
}
+/* 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
}
-/* Set the temporary for the current SELECT TYPE selector. */
+/* Set the temporary for the current derived type SELECT TYPE selector. */
-static void
-select_type_set_tmp (gfc_typespec *ts)
+static gfc_symtree *
+select_derived_set_tmp (gfc_typespec *ts)
{
char name[GFC_MAX_SYMBOL_LEN];
gfc_symtree *tmp;
- if (!ts)
+ 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))
{
- select_type_stack->tmp = NULL;
- return;
+ 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 (!gfc_type_is_extensible (ts->u.derived))
- return;
+ if (select_type_stack->selector->ts.type == BT_CLASS
+ && !select_type_stack->selector->attr.class_ok)
+ return NULL;
- if (ts->type == BT_CLASS)
- sprintf (name, "__tmp_class_%s", ts->u.derived->name);
- else
- sprintf (name, "__tmp_type_%s", ts->u.derived->name);
+ 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, taking care as to
- whether or not it is a class object or not. */
+/* 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))
{
- if (ts->type == BT_CLASS)
- {
- CLASS_DATA (tmp->n.sym)->attr.dimension
+ tmp->n.sym->attr.pointer = 1;
+ tmp->n.sym->attr.dimension
= CLASS_DATA (select_type_stack->selector)->attr.dimension;
- CLASS_DATA (tmp->n.sym)->attr.codimension
+ 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;
- }
+ 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)
- gfc_build_class_symbol (&tmp->n.sym->ts, &tmp->n.sym->attr,
- &tmp->n.sym->as, false);
+ 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_stack->tmp = tmp;
}
-
+
/* Match a SELECT TYPE statement. */
match
match m;
char name[GFC_MAX_SYMBOL_LEN];
bool class_array;
+ gfc_symbol *sym;
m = gfc_match_label ();
if (m == MATCH_ERROR)
m = MATCH_ERROR;
goto cleanup;
}
+
+ sym = expr1->symtree->n.sym;
if (expr2->ts.type == BT_UNKNOWN)
- expr1->symtree->n.sym->attr.untyped = 1;
+ 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;
+ copy_ts_from_selector_to_associate (expr1, expr2);
+
+ sym->attr.flavor = FL_VARIABLE;
+ sym->attr.referenced = 1;
+ sym->attr.class_ok = 1;
}
else
{
{
/* F03:C614. */
if (ref->u.c.component->attr.pointer
- || ref->u.c.component->attr.proc_pointer)
+ || ref->u.c.component->attr.proc_pointer
+ || (ref->u.c.component->ts.type == BT_CLASS
+ && CLASS_DATA (ref->u.c.component)->attr.pointer))
{
gfc_error ("Component to the right of a part reference "
"with nonzero rank must not have the POINTER "
"attribute at %L", &expr->where);
return FAILURE;
}
- else if (ref->u.c.component->attr.allocatable)
+ else if (ref->u.c.component->attr.allocatable
+ || (ref->u.c.component->ts.type == BT_CLASS
+ && CLASS_DATA (ref->u.c.component)->attr.allocatable))
+
{
gfc_error ("Component to the right of a part reference "
"with nonzero rank must not have the ALLOCATABLE "
}
/* 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;
+ 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);
}
-/* Resolve an associate name: Resolve target and ensure the type-spec is
+/* Resolve an associate-name: Resolve target and ensure the type-spec is
correct as well as possibly the array-spec. */
static void
sym->attr.dimension = 0;
return;
}
- if (target->rank > 0)
+
+ /* 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 && 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)
{
if (!sym->assoc)
return false;
+ if (sym->ts.type == BT_CLASS)
+ return true;
+
if (!sym->assoc->variable)
return false;
}
}
+
+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
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);
+ se->expr = build_array_ref (se->expr, offset, sym->backend_decl);
}
return;
}
- tmp = gfc_conv_array_data (desc);
- tmp = build_fold_indirect_ref_loc (input_location,
- tmp);
- tmp = gfc_build_array_ref (tmp, offset, NULL);
+ 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. */
#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. */
-static void
+ 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)
+ gfc_typespec class_ts, tree vptr)
{
gfc_symbol *vtab;
gfc_ss *ss;
/* 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));
+ 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));
/* 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);
+ gfc_conv_derived_to_class (&parmse, e, fsym->ts, NULL);
}
else if (se->ss && se->ss->info->useflags)
{
gfc_expr *e;
tree tmp;
bool class_target;
+ tree desc;
+ tree offset;
+ tree dim;
+ int n;
gcc_assert (sym->assoc);
e = sym->assoc->target;
gfc_finish_block (&se.post));
}
- /* CLASS arrays just need the descriptor to be directly assigned. */
- else if (class_target && sym->attr.dimension)
+ /* 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;
gcc_assert (!sym->attr.dimension);
gfc_init_se (&se, NULL);
- gfc_conv_expr (&se, e);
+
+ /* 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);
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_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. */
#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) \
+2012-05-05 Paul Thomas <pault@gcc.gnu.org>
+
+ PR fortran/41600
+ * gfortran.dg/select_type_26.f03 : New test.
+ * gfortran.dg/select_type_27.f03 : New test.
+
+ PR fortran/53191
+ * gfortran.dg/select_type_28.f03 : New test.
+
2012-05-05 Janne Blomqvist <jb@gcc.gnu.org>
PR fortran/49010
--- /dev/null
+! { 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.
+! (F2003 C614)
+ 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
--- /dev/null
+! { 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.
+! (F2003 C614)
+ 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
--- /dev/null
+! { dg-do compile }
+!
+! Fix for PR53191
+!
+ 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. (F2003 C614)
+
+ select type(bar => m%foo) ! { dg-error "part reference with nonzero rank" }
+ type is(t0)
+ if (any (bar%j .ne. [99, 198, 297, 396])) call abort
+ type is(t1)
+ call abort
+ end select
+
+end
projects / thirdparty / gcc.git / commitdiff
