This is the mail archive of the
gcc-patches@gcc.gnu.org
mailing list for the GCC project.
[Patch, fortran] PR41600 - [OOP] SELECT TYPE with associate-name => exp: Arrays not supported
- From: Paul Richard Thomas <paul dot richard dot thomas at gmail dot com>
- To: fortran at gcc dot gnu dot org, gcc-patches <gcc-patches at gcc dot gnu dot org>, Tobias Burnus <burnus at net-b dot de>
- Date: Sun, 18 Mar 2012 21:09:11 +0100
- Subject: [Patch, fortran] PR41600 - [OOP] SELECT TYPE with associate-name => exp: Arrays not supported
Dear All,
Please find attached a fix for PR41600 plus some. It is reasonably
straightforward but the following should be noted:
(i) gfc_get_vptr_from_expr exploits that seeming fact that tracing
back any class expression through TREE_OPERAND 0 eventually gets one
back to the class expression. I will root through the various
functions that operate on class objects to remove the front-endery
that does the same thing but in a much more cumbersome way;
(ii) GFC_CLASS_TYPE_P has been introduced, as it should have been in
the first place :-( Its first use is in (i);
(iii) The error that is thrown in resolve_assoc_var is necessary
because wrong code is produced at the moment since the size of the
declared type, rather than the dynamic type, is used for allocation of
the temporary. The necessary machinery is in place to fix this and I
will do so soon; and
(iv) select_type_set_tmp was broken up to make the logic more
transparent. The result is only a little longer than it would have
been without the calls to select_derived_set_tmp and
select_class_set_tmp.
There is quite a lot of retrospective tidying up to do using (i) and (ii)!
Bootstraps and regtests on FC9/x86_64 - OK for trunk?
Cheers
Paul
2012-03-18 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.
2012-03-18 Paul Thomas <pault@gcc.gnu.org>
PR fortran/41600
* gfortran.dg/select_type_26.f03 : New test.
Index: gcc/fortran/trans-array.c
===================================================================
*** gcc/fortran/trans-array.c (revision 185482)
--- gcc/fortran/trans-array.c (working copy)
*************** add_to_offset (tree *cst_offset, tree *o
*** 3068,3073 ****
--- 3068,3103 ----
}
}
+
+ 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
*** 3195,3204 ****
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);
}
--- 3225,3231 ----
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
*** 6010,6019 ****
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. */
--- 6037,6043 ----
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. */
Index: gcc/fortran/trans-expr.c
===================================================================
*** gcc/fortran/trans-expr.c (revision 185482)
--- gcc/fortran/trans-expr.c (working copy)
*************** gfc_vtable_copy_get (tree decl)
*** 147,157 ****
#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;
--- 147,171 ----
#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
*** 167,177 ****
/* 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));
--- 181,199 ----
/* 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
*** 3518,3524 ****
/* 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)
{
--- 3540,3546 ----
/* 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)
{
Index: gcc/fortran/symbol.c
===================================================================
*** gcc/fortran/symbol.c (revision 185482)
--- gcc/fortran/symbol.c (working copy)
*************** gfc_is_associate_pointer (gfc_symbol* sy
*** 4882,4887 ****
--- 4882,4890 ----
if (!sym->assoc)
return false;
+ if (sym->ts.type == BT_CLASS)
+ return true;
+
if (!sym->assoc->variable)
return false;
Index: gcc/fortran/trans-stmt.c
===================================================================
*** gcc/fortran/trans-stmt.c (revision 185482)
--- gcc/fortran/trans-stmt.c (working copy)
*************** trans_associate_var (gfc_symbol *sym, gf
*** 1140,1145 ****
--- 1140,1149 ----
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
*** 1191,1198 ****
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;
--- 1195,1203 ----
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
*** 1217,1223 ****
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);
--- 1222,1268 ----
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);
Index: gcc/fortran/expr.c
===================================================================
*** gcc/fortran/expr.c (revision 185482)
--- gcc/fortran/expr.c (working copy)
*************** gfc_get_variable_expr (gfc_symtree *var)
*** 3821,3826 ****
--- 3821,3829 ----
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;
Index: gcc/fortran/trans-types.c
===================================================================
*** gcc/fortran/trans-types.c (revision 185482)
--- gcc/fortran/trans-types.c (working copy)
*************** gfc_typenode_for_spec (gfc_typespec * sp
*** 1106,1111 ****
--- 1106,1114 ----
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
Index: gcc/fortran/trans.h
===================================================================
*** gcc/fortran/trans.h (revision 185482)
--- gcc/fortran/trans.h (working copy)
*************** tree gfc_vtable_size_get (tree);
*** 348,355 ****
--- 348,357 ----
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 {
*** 827,832 ****
--- 829,836 ----
#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) \
Index: gcc/fortran/resolve.c
===================================================================
*** gcc/fortran/resolve.c (revision 185482)
--- gcc/fortran/resolve.c (working copy)
*************** resolve_variable (gfc_expr *e)
*** 5081,5089 ****
}
/* 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);
--- 5081,5095 ----
}
/* 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)
*** 7928,7934 ****
}
! /* Resolve an associate name: Resolve target and ensure the type-spec is
correct as well as possibly the array-spec. */
static void
--- 7934,7940 ----
}
! /* 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
*** 7984,7991 ****
sym->attr.dimension = 0;
return;
}
! if (target->rank > 0)
sym->attr.dimension = 1;
if (sym->attr.dimension)
{
--- 7990,8015 ----
sym->attr.dimension = 0;
return;
}
!
! /* We cannot deal with class selectors that need temporaries.
! Note: This breaks associate_1.f03 and associate_5.f03. */
! 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)
{
Index: gcc/fortran/match.c
===================================================================
*** gcc/fortran/match.c (revision 185482)
--- gcc/fortran/match.c (working copy)
*************** gfc_match_select (void)
*** 5112,5117 ****
--- 5112,5177 ----
}
+ /* Transfer the selector typespec to the associate name. */
+
+ static void
+ copy_ts_from_selector_to_associate (gfc_expr *expr1, gfc_expr *expr2)
+ {
+ gfc_symbol *sym = expr1->symtree->n.sym;
+
+ /* Ensure that any array reference is resolved. */
+ gfc_resolve_expr (expr2);
+
+ /* 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 right class container is obtained. */
+ if (expr2->ts.type == BT_CLASS
+ && CLASS_DATA (expr2)->as
+ && expr2->ref && expr2->ref->type == REF_ARRAY)
+ {
+ if (expr2->ref->u.ar.type == AR_FULL)
+ expr2->rank = CLASS_DATA (expr2)->as->rank;
+ else if (expr2->ref->u.ar.type == AR_SECTION)
+ expr2->rank = expr2->ref->u.ar.dimen;
+ }
+
+ if (expr2->ts.type != BT_CLASS)
+ {
+ /* The correct class container has to be available. */
+ if (expr2->rank)
+ {
+ sym->attr.dimension = 1;
+ sym->as = gfc_get_array_spec ();
+ sym->as->rank = expr2->rank;
+ sym->as->type = AS_DEFERRED;
+ }
+ else
+ sym->as = NULL;
+ sym->ts.type = BT_CLASS;
+ sym->ts.u.derived = expr2->ts.u.derived;
+ sym->attr.pointer = 1;
+ gfc_build_class_symbol (&sym->ts, &sym->attr, &sym->as, false);
+ }
+ else
+ {
+ /* The correct class container has to be available. */
+ if (expr2->rank)
+ {
+ sym->attr.dimension = 1;
+ sym->as = gfc_get_array_spec ();
+ sym->as->rank = expr2->rank;
+ sym->as->type = AS_DEFERRED;
+ }
+ else
+ sym->as = NULL;
+ sym->ts.type = BT_CLASS;
+ sym->ts.u.derived = CLASS_DATA (expr2)->ts.u.derived;
+ sym->attr.pointer = 1;
+ gfc_build_class_symbol (&sym->ts, &sym->attr, &sym->as, false);
+ }
+ }
+
+
/* Push the current selector onto the SELECT TYPE stack. */
static void
*************** select_type_push (gfc_symbol *sel)
*** 5126,5189 ****
}
! /* 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. */
--- 5186,5288 ----
}
! /* 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)
*** 5194,5200 ****
select_type_stack->tmp = tmp;
}
!
/* Match a SELECT TYPE statement. */
match
--- 5293,5299 ----
select_type_stack->tmp = tmp;
}
!
/* Match a SELECT TYPE statement. */
match
*************** gfc_match_select_type (void)
*** 5204,5209 ****
--- 5303,5309 ----
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)
*** 5225,5237 ****
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
{
--- 5325,5340 ----
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
{
Index: gcc/testsuite/gfortran.dg/select_type_26.f03
===================================================================
*** gcc/testsuite/gfortran.dg/select_type_26.f03 (revision 0)
--- gcc/testsuite/gfortran.dg/select_type_26.f03 (revision 0)
***************
*** 0 ****
--- 1,80 ----
+ ! { 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) :: m
+ 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
+ end
+