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.
Give me couple of days to see whether I can push this to the end.
Otherwise, your patch will be good enough.
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,9 @@ gfc_conv_intrinsic_to_class (gfc_se *parmse, gfc_e
}
+static void gfc_conv_component_ref (gfc_se * se, gfc_ref * ref);
+
+
/* Takes a scalarized class array expression and returns the
address of a temporary scalar class object of the 'declared'
type.
@@ -706,30 +634,28 @@ 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;
stmtblock_t block;
bool full_array = false;
gfc_init_block (&block);
- class_ref = NULL;
+ if (e->symtree
+ && e->symtree->n.sym->ts.type == BT_CLASS)
+ class_subref = &e->ref;
+ else
+ class_subref = 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 (ref->next == NULL)
- break;
+ 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 +691,57 @@ 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;
+ gfc_ref ref;
+
+ if ((*class_subref)
+ && (*class_subref)->next)
+ {
+ gcc_assert ((*class_subref)->next->type == REF_ARRAY);
+ dt_sym = e->ts.u.derived->components->ts.u.derived;
+ }
+ else
+ dt_sym = e->ts.u.derived;
+
+ memset (&ref, 0, sizeof (ref));
+
+ while (!gfc_compare_derived_types (dt_sym, dummy_sym))
+ {
+ if (POINTER_TYPE_P (TREE_TYPE (parmse->expr)))
+ parmse->expr = build_fold_indirect_ref_loc (input_location,
+ parmse->expr);
+
+ ref.u.c.component = dt_sym->components;
+ ref.u.c.sym = dt_sym;
+ gfc_conv_component_ref (parmse, &ref);
+
+ if (!POINTER_TYPE_P (TREE_TYPE (parmse->expr)))
+ parmse->expr = gfc_build_addr_expr (NULL_TREE, parmse->expr);
+
+ gcc_assert (dt_sym->components->ts.type == BT_CLASS
+ || dt_sym->components->ts.type == BT_DERIVED);
+ dt_sym = dt_sym->components->ts.u.derived;
+ }
+ }
+
+ 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 +770,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)
+ 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 +814,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 +3760,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. */
@@ -4522,72 +4495,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
@@ -4599,10 +4507,9 @@ 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))
+ && e->ts.type == BT_CLASS
+ && !gfc_compare_derived_types (fsym->ts.u.derived,
+ e->ts.u.derived))
gfc_conv_class_to_class (&parmse, e, fsym->ts, false,
fsym->attr.intent != INTENT_IN
&& (CLASS_DATA (fsym)->attr.class_pointer
