Le 20/02/2015 22:50, Mikael Morin a écrit :
> Le 16/02/2015 21:18, Bernd Edlinger a écrit :
>>
>> again, with attachments,
>> sorry.
>>
>>
>>>
>>> Hi,
>>>
>>>
>>> this patch fixes PR64980 and PR61960 at the same time.
>>>
>>> The unreduced test case for PR64230 is also included, because a previous
>>> version
>>> of this patch caused this test to fail but the complete test suite passed
>>> without any
>>> indication of any problem.
>>>
> Hello Bernd,
>
> I think the testcases can do without any VIEW_CONVERT_EXPR at all.
> I'm currently trying to avoid them with the attached patch, which is not
> free of regressions unfortunately.
I finally arrived to the attached patch.
It may be a bit risky, and with the release preparation stage in mind, I
realize that your patch is probably the better alternative.
So your patch is OK for trunk.
Mikael
Index: trans-expr.c
===================================================================
--- trans-expr.c (révision 220717)
+++ trans-expr.c (copie de travail)
@@ -496,81 +496,6 @@ gfc_conv_derived_to_class (gfc_se *parmse, gfc_exp
}
-/* Create a new class container, which is required as scalar coarrays
- have an array descriptor while normal scalars haven't. Optionally,
- NULL pointer checks are added if the argument is OPTIONAL. */
-
-static void
-class_scalar_coarray_to_class (gfc_se *parmse, gfc_expr *e,
- gfc_typespec class_ts, bool optional)
-{
- tree var, ctree, tmp;
- stmtblock_t block;
- gfc_ref *ref;
- gfc_ref *class_ref;
-
- gfc_init_block (&block);
-
- class_ref = NULL;
- for (ref = e->ref; ref; ref = ref->next)
- {
- if (ref->type == REF_COMPONENT
- && ref->u.c.component->ts.type == BT_CLASS)
- class_ref = ref;
- }
-
- if (class_ref == NULL
- && e->symtree && e->symtree->n.sym->ts.type == BT_CLASS)
- tmp = e->symtree->n.sym->backend_decl;
- else
- {
- /* Remove everything after the last class reference, convert the
- expression and then recover its tailend once more. */
- gfc_se tmpse;
- ref = class_ref->next;
- class_ref->next = NULL;
- gfc_init_se (&tmpse, NULL);
- gfc_conv_expr (&tmpse, e);
- class_ref->next = ref;
- tmp = tmpse.expr;
- }
-
- var = gfc_typenode_for_spec (&class_ts);
- var = gfc_create_var (var, "class");
-
- ctree = gfc_class_vptr_get (var);
- gfc_add_modify (&block, ctree,
- fold_convert (TREE_TYPE (ctree), gfc_class_vptr_get (tmp)));
-
- ctree = gfc_class_data_get (var);
- tmp = gfc_conv_descriptor_data_get (gfc_class_data_get (tmp));
- gfc_add_modify (&block, ctree, fold_convert (TREE_TYPE (ctree), tmp));
-
- /* Pass the address of the class object. */
- parmse->expr = gfc_build_addr_expr (NULL_TREE, var);
-
- if (optional)
- {
- tree cond = gfc_conv_expr_present (e->symtree->n.sym);
- tree tmp2;
-
- tmp = gfc_finish_block (&block);
-
- gfc_init_block (&block);
- tmp2 = gfc_class_data_get (var);
- gfc_add_modify (&block, tmp2, fold_convert (TREE_TYPE (tmp2),
- null_pointer_node));
- tmp2 = gfc_finish_block (&block);
-
- tmp = build3_loc (input_location, COND_EXPR, void_type_node,
- cond, tmp, tmp2);
- gfc_add_expr_to_block (&parmse->pre, tmp);
- }
- else
- gfc_add_block_to_block (&parmse->pre, &block);
-}
-
-
/* Takes an intrinsic type expression and returns the address of a temporary
class object of the 'declared' type. */
void
@@ -686,6 +611,35 @@ gfc_conv_intrinsic_to_class (gfc_se *parmse, gfc_e
}
+static void gfc_conv_component_ref (gfc_se * se, gfc_ref * ref);
+
+static void
+access_parent_derived_type (gfc_se *se, gfc_symbol *base_type,
+ gfc_symbol *extended_type)
+{
+ gfc_ref ref;
+
+ memset (&ref, 0, sizeof (ref));
+
+ while (!gfc_compare_derived_types (base_type, extended_type))
+ {
+ if (POINTER_TYPE_P (TREE_TYPE (se->expr)))
+ se->expr = build_fold_indirect_ref_loc (input_location, se->expr);
+
+ ref.u.c.component = extended_type->components;
+ ref.u.c.sym = extended_type;
+ gfc_conv_component_ref (se, &ref);
+
+ if (!POINTER_TYPE_P (TREE_TYPE (se->expr)))
+ se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
+
+ gcc_assert (extended_type->components->ts.type == BT_CLASS
+ || extended_type->components->ts.type == BT_DERIVED);
+ extended_type = gfc_get_derived_super_type (extended_type);
+ }
+}
+
+
/* Takes a scalarized class array expression and returns the
address of a temporary scalar class object of the 'declared'
type.
@@ -706,30 +660,29 @@ gfc_conv_class_to_class (gfc_se *parmse, gfc_expr
tree var;
tree tmp;
tree vptr;
+ tree orig_expr = parmse->expr;
tree cond = NULL_TREE;
gfc_ref *ref;
- gfc_ref *class_ref;
+ gfc_ref **class_subref = NULL;
stmtblock_t block;
bool full_array = false;
gfc_init_block (&block);
- class_ref = NULL;
- for (ref = e->ref; ref; ref = ref->next)
+ if (e->expr_type == EXPR_VARIABLE)
{
- if (ref->type == REF_COMPONENT
- && ref->u.c.component->ts.type == BT_CLASS)
- class_ref = ref;
+ if (e->symtree
+ && e->symtree->n.sym->ts.type == BT_CLASS)
+ class_subref = &e->ref;
- if (ref->next == NULL)
- break;
+ for (ref = e->ref; ref; ref = ref->next)
+ {
+ if (ref->type == REF_COMPONENT
+ && ref->u.c.component->ts.type == BT_CLASS)
+ class_subref = &ref->next;
+ }
}
- if ((ref == NULL || class_ref == ref)
- && (!class_ts.u.derived->components->as
- || class_ts.u.derived->components->as->rank != -1))
- return;
-
/* Test for FULL_ARRAY. */
if (e->rank == 0 && gfc_expr_attr (e).codimension
&& gfc_expr_attr (e).dimension)
@@ -765,9 +718,40 @@ gfc_conv_class_to_class (gfc_se *parmse, gfc_expr
}
else
{
- if (TREE_TYPE (parmse->expr) != TREE_TYPE (ctree))
+ if (!class_ts.u.derived->components->as)
+ {
+ gfc_symbol *dt_sym;
+ gfc_symbol *dummy_sym = class_ts.u.derived->components->ts.u.derived;
+
+ if (class_subref
+ && (*class_subref)
+ && (*class_subref)->next)
+ gcc_assert ((*class_subref)->next->type == REF_ARRAY);
+ else
+ parmse->expr = gfc_class_data_get (parmse->expr);
+
+ dt_sym = CLASS_DATA (e)->ts.u.derived;
+
+ if (!dummy_sym->attr.unlimited_polymorphic
+ && gfc_type_is_extension_of (dummy_sym, dt_sym))
+ access_parent_derived_type (parmse, dummy_sym, dt_sym);
+ }
+
+ if (POINTER_TYPE_P (TREE_TYPE (parmse->expr))
+ && !POINTER_TYPE_P (TREE_TYPE (ctree)))
+ parmse->expr = build_fold_indirect_ref_loc (input_location,
+ parmse->expr);
+
+ if (TYPE_CANONICAL (TREE_TYPE (ctree))
+ != TYPE_CANONICAL (TREE_TYPE (parmse->expr))
+ || TYPE_MAIN_VARIANT (TREE_TYPE (ctree))
+ != TYPE_MAIN_VARIANT (TREE_TYPE (parmse->expr))
+ || (TREE_TYPE (ctree) != TREE_TYPE (parmse->expr)
+ && AGGREGATE_TYPE_P (ctree)))
parmse->expr = fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
TREE_TYPE (ctree), parmse->expr);
+ else if (TREE_TYPE (parmse->expr) != TREE_TYPE (ctree))
+ parmse->expr = fold_convert (TREE_TYPE (ctree), parmse->expr);
gfc_add_modify (&block, ctree, parmse->expr);
}
@@ -796,19 +780,18 @@ gfc_conv_class_to_class (gfc_se *parmse, gfc_expr
First we have to find the corresponding class reference. */
tmp = NULL_TREE;
- if (class_ref == NULL
- && e->symtree && e->symtree->n.sym->ts.type == BT_CLASS)
- tmp = e->symtree->n.sym->backend_decl;
+ if (class_subref == NULL || *class_subref == NULL)
+ tmp = orig_expr;
else
{
/* Remove everything after the last class reference, convert the
expression and then recover its tailend once more. */
gfc_se tmpse;
- ref = class_ref->next;
- class_ref->next = NULL;
+ gfc_ref *r = *class_subref;
+ *class_subref = NULL;
gfc_init_se (&tmpse, NULL);
gfc_conv_expr (&tmpse, e);
- class_ref->next = ref;
+ *class_subref = r;
tmp = tmpse.expr;
}
@@ -841,7 +824,11 @@ gfc_conv_class_to_class (gfc_se *parmse, gfc_expr
{
gfc_init_block (&block);
- tmp2 = gfc_conv_descriptor_data_get (gfc_class_data_get (var));
+ if (!class_ts.u.derived->components->as)
+ tmp2 = gfc_class_data_get (var);
+ else
+ tmp2 = gfc_conv_descriptor_data_get (gfc_class_data_get (var));
+
gfc_add_modify (&block, tmp2, fold_convert (TREE_TYPE (tmp2),
null_pointer_node));
tmp2 = gfc_finish_block (&block);
@@ -3783,10 +3770,6 @@ gfc_apply_interface_mapping_to_expr (gfc_interface
expr->symtree = sym->new_sym;
else if (sym->expr)
gfc_replace_expr (expr, gfc_copy_expr (sym->expr));
- /* Replace base type for polymorphic arguments. */
- if (expr->ref && expr->ref->type == REF_COMPONENT
- && sym->expr && sym->expr->ts.type == BT_CLASS)
- expr->ref->u.c.sym = sym->expr->ts.u.derived;
}
/* ...and to subexpressions in expr->value. */
@@ -4155,6 +4138,61 @@ conv_arglist_function (gfc_se *se, gfc_expr *expr,
}
+static bool
+class_container_needed (gfc_symbol *fsym, gfc_expr *e)
+{
+ gfc_ref **class_subref = NULL, *ref;
+
+ if (!fsym || fsym->ts.type != BT_CLASS || e->ts.type != BT_CLASS)
+ return false;
+
+ if (UNLIMITED_POLY (fsym) && !UNLIMITED_POLY (e))
+ return true;
+
+ if (CLASS_DATA (fsym)->as && CLASS_DATA (fsym)->as->type == AS_ASSUMED_RANK
+ && !(CLASS_DATA (e)->as && CLASS_DATA (e)->as->type == AS_ASSUMED_RANK))
+ return true;
+
+ if (!UNLIMITED_POLY (fsym)
+ && !gfc_compare_derived_types (CLASS_DATA (fsym)->ts.u.derived,
+ CLASS_DATA (e)->ts.u.derived))
+ return true;
+
+ if (gfc_expr_attr (e).allocatable && !CLASS_DATA (fsym)->attr.allocatable)
+ return true;
+
+ if (gfc_expr_attr (e).pointer != CLASS_DATA (fsym)->attr.class_pointer)
+ return true;
+
+ if (gfc_expr_attr (e).target
+ && !fsym->attr.target
+ && !CLASS_DATA (fsym)->attr.class_pointer)
+ return true;
+
+ if (e->expr_type == EXPR_VARIABLE)
+ {
+ if (e->symtree->n.sym->ts.type == BT_CLASS)
+ class_subref = &e->ref;
+
+ for (ref = e->ref; ref; ref = ref->next)
+ {
+ if (ref->type == REF_COMPONENT
+ && ref->u.c.component->ts.type == BT_CLASS)
+ class_subref = &ref->next;
+ }
+
+ gcc_assert (class_subref);
+ if (*class_subref && (*class_subref)->next)
+ {
+ gcc_assert ((*class_subref)->next->type == REF_ARRAY);
+ return true;
+ }
+ }
+
+ return false;
+}
+
+
/* Generate code for a procedure call. Note can return se->post != NULL.
If se->direct_byref is set then se->expr contains the return parameter.
Return nonzero, if the call has alternate specifiers.
@@ -4522,72 +4560,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol *
}
else
{
- if (e->ts.type == BT_CLASS && fsym
- && fsym->ts.type == BT_CLASS
- && (!CLASS_DATA (fsym)->as
- || CLASS_DATA (fsym)->as->type != AS_ASSUMED_RANK)
- && CLASS_DATA (e)->attr.codimension)
- {
- gcc_assert (!CLASS_DATA (fsym)->attr.codimension);
- gcc_assert (!CLASS_DATA (fsym)->as);
- gfc_add_class_array_ref (e);
- parmse.want_coarray = 1;
- gfc_conv_expr_reference (&parmse, e);
- class_scalar_coarray_to_class (&parmse, e, fsym->ts,
- fsym->attr.optional
- && e->expr_type == EXPR_VARIABLE);
- }
- else if (e->ts.type == BT_CLASS && fsym
- && fsym->ts.type == BT_CLASS
- && !CLASS_DATA (fsym)->as
- && !CLASS_DATA (e)->as
- && (CLASS_DATA (fsym)->attr.class_pointer
- != CLASS_DATA (e)->attr.class_pointer
- || CLASS_DATA (fsym)->attr.allocatable
- != CLASS_DATA (e)->attr.allocatable))
- {
- type = gfc_typenode_for_spec (&fsym->ts);
- var = gfc_create_var (type, fsym->name);
- gfc_conv_expr (&parmse, e);
- if (fsym->attr.optional
- && e->expr_type == EXPR_VARIABLE
- && e->symtree->n.sym->attr.optional)
- {
- stmtblock_t block;
- tree cond;
- tmp = gfc_build_addr_expr (NULL_TREE, parmse.expr);
- cond = fold_build2_loc (input_location, NE_EXPR,
- boolean_type_node, tmp,
- fold_convert (TREE_TYPE (tmp),
- null_pointer_node));
- gfc_start_block (&block);
- gfc_add_modify (&block, var,
- fold_build1_loc (input_location,
- VIEW_CONVERT_EXPR,
- type, parmse.expr));
- gfc_add_expr_to_block (&parmse.pre,
- fold_build3_loc (input_location,
- COND_EXPR, void_type_node,
- cond, gfc_finish_block (&block),
- build_empty_stmt (input_location)));
- parmse.expr = gfc_build_addr_expr (NULL_TREE, var);
- parmse.expr = build3_loc (input_location, COND_EXPR,
- TREE_TYPE (parmse.expr),
- cond, parmse.expr,
- fold_convert (TREE_TYPE (parmse.expr),
- null_pointer_node));
- }
- else
- {
- gfc_add_modify (&parmse.pre, var,
- fold_build1_loc (input_location,
- VIEW_CONVERT_EXPR,
- type, parmse.expr));
- parmse.expr = gfc_build_addr_expr (NULL_TREE, var);
- }
- }
- else
- gfc_conv_expr_reference (&parmse, e);
+ gfc_conv_expr_reference (&parmse, e);
/* Catch base objects that are not variables. */
if (e->ts.type == BT_CLASS
@@ -4598,11 +4571,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol *
/* A class array element needs converting back to be a
class object, if the formal argument is a class object. */
- if (fsym && fsym->ts.type == BT_CLASS
- && e->ts.type == BT_CLASS
- && ((CLASS_DATA (fsym)->as
- && CLASS_DATA (fsym)->as->type == AS_ASSUMED_RANK)
- || CLASS_DATA (e)->attr.dimension))
+ if (class_container_needed (fsym, e))
gfc_conv_class_to_class (&parmse, e, fsym->ts, false,
fsym->attr.intent != INTENT_IN
&& (CLASS_DATA (fsym)->attr.class_pointer
