Fortran: Remove adding and removing of caf_get. [PR107635]
Preparatory work for PR107635. During resolve prevent adding caf_get calls for expressions on the left-hand-side of an assignment and removing them later on again. Furthermore has the caf_token in a component become a pointer to the component and not the backend_decl of the caf-component. In some cases the caf_token was added as last component in a derived type and not as the next one following the component that it was needed to be associated to. gcc/fortran/ChangeLog: PR fortran/107635 * gfortran.h (gfc_comp_caf_token): Convenient macro for accessing caf_token's tree. * resolve.cc (gfc_resolve_ref): Backup caf_lhs when resolving expr in array_ref. (remove_caf_get_intrinsic): Removed. (resolve_variable): Set flag caf_lhs when resolving lhs of assignment to prevent insertion of caf_get. (resolve_lock_unlock_event): Same, but the lhs is the parameter. (resolve_ordinary_assign): Move conversion to caf_send to resolve_codes. (resolve_codes): Adress caf_get and caf_send here. (resolve_fl_derived0): Set component's caf_token when token is necessary. * trans-array.cc (gfc_conv_array_parameter): Get a coarray for expression that have a corank. (structure_alloc_comps): Use macro to get caf_token's tree. (gfc_alloc_allocatable_for_assignment): Same. * trans-expr.cc (gfc_get_ultimate_alloc_ptr_comps_caf_token): Same. (gfc_trans_structure_assign): Same. * trans-intrinsic.cc (conv_expr_ref_to_caf_ref): Same. (has_ref_after_cafref): New function to figure that after a reference of a coarray another reference is present. (conv_caf_send): Get rhs from correct place, when caf_get is not removed. * trans-types.cc (gfc_get_derived_type): Get caf_token from component and no longer guessing.
This commit is contained in:
Andre Vehreschild
parent
d9d92b1c1b
commit
91d52f87c5
6 changed files with 158 additions and 131 deletions
|
|
@ -1214,11 +1214,12 @@ typedef struct gfc_component
|
|||
/* Needed for procedure pointer components. */
|
||||
struct gfc_typebound_proc *tb;
|
||||
/* When allocatable/pointer and in a coarray the associated token. */
|
||||
tree caf_token;
|
||||
struct gfc_component *caf_token;
|
||||
}
|
||||
gfc_component;
|
||||
|
||||
#define gfc_get_component() XCNEW (gfc_component)
|
||||
#define gfc_comp_caf_token(cm) (cm)->caf_token->backend_decl
|
||||
|
||||
/* Formal argument lists are lists of symbols. */
|
||||
typedef struct gfc_formal_arglist
|
||||
|
|
|
|||
|
|
@ -85,6 +85,8 @@ static bitmap_obstack labels_obstack;
|
|||
/* True when simplifying a EXPR_VARIABLE argument to an inquiry function. */
|
||||
static bool inquiry_argument = false;
|
||||
|
||||
/* True when we are on left hand side in an assignment of a coarray. */
|
||||
static bool caf_lhs = false;
|
||||
|
||||
/* Is the symbol host associated? */
|
||||
static bool
|
||||
|
|
@ -5578,7 +5580,7 @@ gfc_resolve_ref (gfc_expr *expr)
|
|||
{
|
||||
int current_part_dimension, n_components, seen_part_dimension, dim;
|
||||
gfc_ref *ref, **prev, *array_ref;
|
||||
bool equal_length;
|
||||
bool equal_length, old_caf_lhs;
|
||||
|
||||
for (ref = expr->ref; ref; ref = ref->next)
|
||||
if (ref->type == REF_ARRAY && ref->u.ar.as == NULL)
|
||||
|
|
@ -5588,13 +5590,18 @@ gfc_resolve_ref (gfc_expr *expr)
|
|||
break;
|
||||
}
|
||||
|
||||
old_caf_lhs = caf_lhs;
|
||||
caf_lhs = false;
|
||||
for (prev = &expr->ref; *prev != NULL;
|
||||
prev = *prev == NULL ? prev : &(*prev)->next)
|
||||
switch ((*prev)->type)
|
||||
{
|
||||
case REF_ARRAY:
|
||||
if (!resolve_array_ref (&(*prev)->u.ar))
|
||||
return false;
|
||||
{
|
||||
caf_lhs = old_caf_lhs;
|
||||
return false;
|
||||
}
|
||||
break;
|
||||
|
||||
case REF_COMPONENT:
|
||||
|
|
@ -5604,7 +5611,10 @@ gfc_resolve_ref (gfc_expr *expr)
|
|||
case REF_SUBSTRING:
|
||||
equal_length = false;
|
||||
if (!gfc_resolve_substring (*prev, &equal_length))
|
||||
return false;
|
||||
{
|
||||
caf_lhs = old_caf_lhs;
|
||||
return false;
|
||||
}
|
||||
|
||||
if (expr->expr_type != EXPR_SUBSTRING && equal_length)
|
||||
{
|
||||
|
|
@ -5618,6 +5628,7 @@ gfc_resolve_ref (gfc_expr *expr)
|
|||
}
|
||||
break;
|
||||
}
|
||||
caf_lhs = old_caf_lhs;
|
||||
|
||||
/* Check constraints on part references. */
|
||||
|
||||
|
|
@ -5924,21 +5935,6 @@ add_caf_get_intrinsic (gfc_expr *e)
|
|||
free (wrapper);
|
||||
}
|
||||
|
||||
|
||||
static void
|
||||
remove_caf_get_intrinsic (gfc_expr *e)
|
||||
{
|
||||
gcc_assert (e->expr_type == EXPR_FUNCTION && e->value.function.isym
|
||||
&& e->value.function.isym->id == GFC_ISYM_CAF_GET);
|
||||
gfc_expr *e2 = e->value.function.actual->expr;
|
||||
e->value.function.actual->expr = NULL;
|
||||
gfc_free_actual_arglist (e->value.function.actual);
|
||||
gfc_free_shape (&e->shape, e->rank);
|
||||
*e = *e2;
|
||||
free (e2);
|
||||
}
|
||||
|
||||
|
||||
/* Resolve a variable expression. */
|
||||
|
||||
static bool
|
||||
|
|
@ -6284,13 +6280,18 @@ resolve_variable (gfc_expr *e)
|
|||
t = false;
|
||||
|
||||
if (sym->as)
|
||||
for (n = 0; n < sym->as->rank; n++)
|
||||
{
|
||||
if (!gfc_resolve_expr (sym->as->lower[n]))
|
||||
t = false;
|
||||
if (!gfc_resolve_expr (sym->as->upper[n]))
|
||||
t = false;
|
||||
}
|
||||
{
|
||||
bool old_caf_lhs = caf_lhs;
|
||||
caf_lhs = false;
|
||||
for (n = 0; n < sym->as->rank; n++)
|
||||
{
|
||||
if (!gfc_resolve_expr (sym->as->lower[n]))
|
||||
t = false;
|
||||
if (!gfc_resolve_expr (sym->as->upper[n]))
|
||||
t = false;
|
||||
}
|
||||
caf_lhs = old_caf_lhs;
|
||||
}
|
||||
specification_expr = saved_specification_expr;
|
||||
|
||||
if (t)
|
||||
|
|
@ -6365,7 +6366,8 @@ resolve_procedure:
|
|||
if (t)
|
||||
gfc_expression_rank (e);
|
||||
|
||||
if (t && flag_coarray == GFC_FCOARRAY_LIB && gfc_is_coindexed (e))
|
||||
if (t && flag_coarray == GFC_FCOARRAY_LIB && !caf_lhs
|
||||
&& gfc_is_coindexed (e))
|
||||
add_caf_get_intrinsic (e);
|
||||
|
||||
if (sym->attr.ext_attr & (1 << EXT_ATTR_DEPRECATED) && sym != sym->result)
|
||||
|
|
@ -10906,15 +10908,9 @@ find_reachable_labels (gfc_code *block)
|
|||
}
|
||||
}
|
||||
|
||||
|
||||
static void
|
||||
resolve_lock_unlock_event (gfc_code *code)
|
||||
{
|
||||
if (code->expr1->expr_type == EXPR_FUNCTION
|
||||
&& code->expr1->value.function.isym
|
||||
&& code->expr1->value.function.isym->id == GFC_ISYM_CAF_GET)
|
||||
remove_caf_get_intrinsic (code->expr1);
|
||||
|
||||
if ((code->op == EXEC_LOCK || code->op == EXEC_UNLOCK)
|
||||
&& (code->expr1->ts.type != BT_DERIVED
|
||||
|| code->expr1->expr_type != EXPR_VARIABLE
|
||||
|
|
@ -11993,45 +11989,7 @@ resolve_ordinary_assign (gfc_code *code, gfc_namespace *ns)
|
|||
if (lhs->ts.type == BT_CLASS && rhs->ts.type != BT_CLASS)
|
||||
gfc_find_vtab (&rhs->ts);
|
||||
|
||||
bool caf_convert_to_send = flag_coarray == GFC_FCOARRAY_LIB
|
||||
&& (lhs_coindexed
|
||||
|| caf_possible_reallocate (lhs)
|
||||
|| (code->expr2->expr_type == EXPR_FUNCTION
|
||||
&& code->expr2->value.function.isym
|
||||
&& code->expr2->value.function.isym->id == GFC_ISYM_CAF_GET
|
||||
&& (code->expr1->rank == 0 || code->expr2->rank != 0)
|
||||
&& !gfc_expr_attr (rhs).allocatable
|
||||
&& !gfc_has_vector_subscript (rhs)));
|
||||
|
||||
gfc_check_assign (lhs, rhs, 1, !caf_convert_to_send);
|
||||
|
||||
/* Insert a GFC_ISYM_CAF_SEND intrinsic, when the LHS is a coindexed variable.
|
||||
Additionally, insert this code when the RHS is a CAF as we then use the
|
||||
GFC_ISYM_CAF_SEND intrinsic just to avoid a temporary; but do not do so if
|
||||
the LHS is (re)allocatable or has a vector subscript. If the LHS is a
|
||||
noncoindexed array and the RHS is a coindexed scalar, use the normal code
|
||||
path. */
|
||||
if (caf_convert_to_send)
|
||||
{
|
||||
if (code->expr2->expr_type == EXPR_FUNCTION
|
||||
&& code->expr2->value.function.isym
|
||||
&& code->expr2->value.function.isym->id == GFC_ISYM_CAF_GET)
|
||||
remove_caf_get_intrinsic (code->expr2);
|
||||
code->op = EXEC_CALL;
|
||||
gfc_get_sym_tree (GFC_PREFIX ("caf_send"), ns, &code->symtree, true);
|
||||
code->resolved_sym = code->symtree->n.sym;
|
||||
code->resolved_sym->attr.flavor = FL_PROCEDURE;
|
||||
code->resolved_sym->attr.intrinsic = 1;
|
||||
code->resolved_sym->attr.subroutine = 1;
|
||||
code->resolved_isym = gfc_intrinsic_subroutine_by_id (GFC_ISYM_CAF_SEND);
|
||||
gfc_commit_symbol (code->resolved_sym);
|
||||
code->ext.actual = gfc_get_actual_arglist ();
|
||||
code->ext.actual->expr = lhs;
|
||||
code->ext.actual->next = gfc_get_actual_arglist ();
|
||||
code->ext.actual->next->expr = rhs;
|
||||
code->expr1 = NULL;
|
||||
code->expr2 = NULL;
|
||||
}
|
||||
gfc_check_assign (lhs, rhs, 1);
|
||||
|
||||
return false;
|
||||
}
|
||||
|
|
@ -12956,7 +12914,22 @@ gfc_resolve_code (gfc_code *code, gfc_namespace *ns)
|
|||
start:
|
||||
t = true;
|
||||
if (code->op != EXEC_COMPCALL && code->op != EXEC_CALL_PPC)
|
||||
t = gfc_resolve_expr (code->expr1);
|
||||
{
|
||||
switch (code->op)
|
||||
{
|
||||
case EXEC_ASSIGN:
|
||||
case EXEC_LOCK:
|
||||
case EXEC_UNLOCK:
|
||||
case EXEC_EVENT_POST:
|
||||
case EXEC_EVENT_WAIT:
|
||||
caf_lhs = gfc_is_coindexed (code->expr1);
|
||||
break;
|
||||
default:
|
||||
break;
|
||||
}
|
||||
t = gfc_resolve_expr (code->expr1);
|
||||
caf_lhs = false;
|
||||
}
|
||||
forall_flag = forall_save;
|
||||
gfc_do_concurrent_flag = do_concurrent_save;
|
||||
|
||||
|
|
@ -13077,15 +13050,46 @@ start:
|
|||
if (!t)
|
||||
break;
|
||||
|
||||
if (code->expr1->ts.type == BT_CLASS)
|
||||
gfc_find_vtab (&code->expr2->ts);
|
||||
if (flag_coarray == GFC_FCOARRAY_LIB
|
||||
&& (gfc_is_coindexed (code->expr1)
|
||||
|| caf_possible_reallocate (code->expr1)
|
||||
|| (code->expr2->expr_type == EXPR_FUNCTION
|
||||
&& code->expr2->value.function.isym
|
||||
&& code->expr2->value.function.isym->id
|
||||
== GFC_ISYM_CAF_GET
|
||||
&& (code->expr1->rank == 0 || code->expr2->rank != 0)
|
||||
&& !gfc_expr_attr (code->expr2).allocatable
|
||||
&& !gfc_has_vector_subscript (code->expr2))))
|
||||
{
|
||||
/* Insert a GFC_ISYM_CAF_SEND intrinsic, when the LHS is a
|
||||
coindexed variable. Additionally, insert this code when the
|
||||
RHS is a CAF as we then use the GFC_ISYM_CAF_SEND intrinsic
|
||||
just to avoid a temporary; but do not do so if the LHS is
|
||||
(re)allocatable or has a vector subscript. If the LHS is a
|
||||
noncoindexed array and the RHS is a coindexed scalar, use the
|
||||
normal code path. */
|
||||
code->op = EXEC_CALL;
|
||||
gfc_get_sym_tree (GFC_PREFIX ("caf_send"), ns, &code->symtree,
|
||||
true);
|
||||
code->resolved_sym = code->symtree->n.sym;
|
||||
code->resolved_sym->attr.flavor = FL_PROCEDURE;
|
||||
code->resolved_sym->attr.intrinsic = 1;
|
||||
code->resolved_sym->attr.subroutine = 1;
|
||||
code->resolved_isym
|
||||
= gfc_intrinsic_subroutine_by_id (GFC_ISYM_CAF_SEND);
|
||||
gfc_commit_symbol (code->resolved_sym);
|
||||
code->ext.actual = gfc_get_actual_arglist ();
|
||||
code->ext.actual->expr = code->expr1;
|
||||
code->ext.actual->next = gfc_get_actual_arglist ();
|
||||
code->ext.actual->next->expr = code->expr2;
|
||||
|
||||
/* Remove a GFC_ISYM_CAF_GET inserted for a coindexed variable on
|
||||
the LHS. */
|
||||
if (code->expr1->expr_type == EXPR_FUNCTION
|
||||
&& code->expr1->value.function.isym
|
||||
&& code->expr1->value.function.isym->id == GFC_ISYM_CAF_GET)
|
||||
remove_caf_get_intrinsic (code->expr1);
|
||||
code->expr1 = NULL;
|
||||
code->expr2 = NULL;
|
||||
break;
|
||||
}
|
||||
|
||||
if (code->expr1->ts.type == BT_CLASS)
|
||||
gfc_find_vtab (&code->expr2->ts);
|
||||
|
||||
/* If this is a pointer function in an lvalue variable context,
|
||||
the new code will have to be resolved afresh. This is also the
|
||||
|
|
@ -16204,6 +16208,7 @@ resolve_fl_derived0 (gfc_symbol *sym)
|
|||
token->attr.artificial = 1;
|
||||
token->attr.caf_token = 1;
|
||||
}
|
||||
c->caf_token = token;
|
||||
}
|
||||
}
|
||||
|
||||
|
|
|
|||
|
|
@ -9124,6 +9124,7 @@ gfc_conv_array_parameter (gfc_se *se, gfc_expr *expr, bool g77,
|
|||
{
|
||||
/* Every other type of array. */
|
||||
se->want_pointer = (ctree) ? 0 : 1;
|
||||
se->want_coarray = expr->corank;
|
||||
gfc_conv_expr_descriptor (se, expr);
|
||||
|
||||
if (size)
|
||||
|
|
@ -10141,9 +10142,11 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, tree dest,
|
|||
&& caf_dereg_mode != GFC_CAF_COARRAY_NOCOARRAY)
|
||||
{
|
||||
if (c->caf_token)
|
||||
caf_token = fold_build3_loc (input_location, COMPONENT_REF,
|
||||
TREE_TYPE (c->caf_token),
|
||||
decl, c->caf_token, NULL_TREE);
|
||||
caf_token
|
||||
= fold_build3_loc (input_location, COMPONENT_REF,
|
||||
TREE_TYPE (gfc_comp_caf_token (c)),
|
||||
decl, gfc_comp_caf_token (c),
|
||||
NULL_TREE);
|
||||
else if (attr->dimension && !attr->proc_pointer)
|
||||
caf_token = gfc_conv_descriptor_token (comp);
|
||||
}
|
||||
|
|
@ -10366,8 +10369,8 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, tree dest,
|
|||
|
||||
gfc_init_se (&se, NULL);
|
||||
token = fold_build3_loc (input_location, COMPONENT_REF,
|
||||
pvoid_type_node, decl, c->caf_token,
|
||||
NULL_TREE);
|
||||
pvoid_type_node, decl,
|
||||
gfc_comp_caf_token (c), NULL_TREE);
|
||||
comp = gfc_conv_scalar_to_descriptor (&se, comp,
|
||||
c->ts.type == BT_CLASS
|
||||
? CLASS_DATA (c)->attr
|
||||
|
|
@ -10584,15 +10587,10 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, tree dest,
|
|||
dst_tok = gfc_conv_descriptor_token (dcmp);
|
||||
else
|
||||
{
|
||||
/* For a scalar allocatable component the caf_token is
|
||||
the next component. */
|
||||
if (!c->caf_token)
|
||||
c->caf_token = c->next->backend_decl;
|
||||
dst_tok = fold_build3_loc (input_location,
|
||||
COMPONENT_REF,
|
||||
pvoid_type_node, dest,
|
||||
c->caf_token,
|
||||
NULL_TREE);
|
||||
dst_tok
|
||||
= fold_build3_loc (input_location, COMPONENT_REF,
|
||||
pvoid_type_node, dest,
|
||||
gfc_comp_caf_token (c), NULL_TREE);
|
||||
}
|
||||
tmp
|
||||
= duplicate_allocatable_coarray (dcmp, dst_tok, comp, ctype,
|
||||
|
|
@ -11477,8 +11475,8 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop,
|
|||
else if (expr1->ts.type == BT_CHARACTER && expr1->ts.u.cl->backend_decl)
|
||||
{
|
||||
tmp = TYPE_SIZE_UNIT (TREE_TYPE (gfc_typenode_for_spec (&expr1->ts)));
|
||||
tmp = fold_build2_loc (input_location, MULT_EXPR,
|
||||
gfc_array_index_type, tmp,
|
||||
tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
|
||||
fold_convert (gfc_array_index_type, tmp),
|
||||
expr1->ts.u.cl->backend_decl);
|
||||
}
|
||||
else if (UNLIMITED_POLY (expr1) && expr2->ts.type != BT_CLASS)
|
||||
|
|
|
|||
|
|
@ -167,7 +167,10 @@ gfc_get_ultimate_alloc_ptr_comps_caf_token (gfc_se *outerse, gfc_expr *expr)
|
|||
if (last_caf_ref == NULL)
|
||||
return NULL_TREE;
|
||||
|
||||
tree comp = last_caf_ref->u.c.component->caf_token, caf;
|
||||
tree comp = last_caf_ref->u.c.component->caf_token
|
||||
? gfc_comp_caf_token (last_caf_ref->u.c.component)
|
||||
: NULL_TREE,
|
||||
caf;
|
||||
gfc_se se;
|
||||
bool comp_ref = !last_caf_ref->u.c.component->attr.dimension;
|
||||
if (comp == NULL_TREE && comp_ref)
|
||||
|
|
@ -9917,10 +9920,12 @@ gfc_trans_structure_assign (tree dest, gfc_expr * expr, bool init, bool coarray)
|
|||
if (cm->ts.type == BT_CLASS)
|
||||
field = gfc_class_data_get (field);
|
||||
|
||||
token = is_array ? gfc_conv_descriptor_token (field)
|
||||
: fold_build3_loc (input_location, COMPONENT_REF,
|
||||
TREE_TYPE (cm->caf_token), dest,
|
||||
cm->caf_token, NULL_TREE);
|
||||
token
|
||||
= is_array
|
||||
? gfc_conv_descriptor_token (field)
|
||||
: fold_build3_loc (input_location, COMPONENT_REF,
|
||||
TREE_TYPE (gfc_comp_caf_token (cm)), dest,
|
||||
gfc_comp_caf_token (cm), NULL_TREE);
|
||||
|
||||
if (is_array)
|
||||
{
|
||||
|
|
|
|||
|
|
@ -1326,7 +1326,8 @@ conv_expr_ref_to_caf_ref (stmtblock_t *block, gfc_expr *expr)
|
|||
arr_desc_token_offset);
|
||||
}
|
||||
else if (ref->u.c.component->caf_token)
|
||||
tmp2 = compute_component_offset (ref->u.c.component->caf_token,
|
||||
tmp2 = compute_component_offset (gfc_comp_caf_token (
|
||||
ref->u.c.component),
|
||||
TREE_TYPE (tmp));
|
||||
else
|
||||
tmp2 = integer_zero_node;
|
||||
|
|
@ -1932,6 +1933,14 @@ gfc_conv_intrinsic_caf_get (gfc_se *se, gfc_expr *expr, tree lhs, tree lhs_kind,
|
|||
se->string_length = argse.string_length;
|
||||
}
|
||||
|
||||
static bool
|
||||
has_ref_after_cafref (gfc_expr *expr)
|
||||
{
|
||||
for (gfc_ref *ref = expr->ref; ref; ref = ref->next)
|
||||
if (ref->type == REF_ARRAY && ref->u.ar.codimen)
|
||||
return ref->next;
|
||||
return false;
|
||||
}
|
||||
|
||||
/* Send data to a remote coarray. */
|
||||
|
||||
|
|
@ -1949,8 +1958,16 @@ conv_caf_send (gfc_code *code) {
|
|||
|
||||
gcc_assert (flag_coarray == GFC_FCOARRAY_LIB);
|
||||
|
||||
lhs_expr = code->ext.actual->expr;
|
||||
rhs_expr = code->ext.actual->next->expr;
|
||||
lhs_expr
|
||||
= code->ext.actual->expr->expr_type == EXPR_FUNCTION
|
||||
&& code->ext.actual->expr->value.function.isym->id == GFC_ISYM_CAF_GET
|
||||
? code->ext.actual->expr->value.function.actual->expr
|
||||
: code->ext.actual->expr;
|
||||
rhs_expr = code->ext.actual->next->expr->expr_type == EXPR_FUNCTION
|
||||
&& code->ext.actual->next->expr->value.function.isym->id
|
||||
== GFC_ISYM_CAF_GET
|
||||
? code->ext.actual->next->expr->value.function.actual->expr
|
||||
: code->ext.actual->next->expr;
|
||||
lhs_is_coindexed = gfc_is_coindexed (lhs_expr);
|
||||
rhs_is_coindexed = gfc_is_coindexed (rhs_expr);
|
||||
may_require_tmp = gfc_check_dependency (lhs_expr, rhs_expr, true) == 0
|
||||
|
|
@ -2165,6 +2182,9 @@ conv_caf_send (gfc_code *code) {
|
|||
gfc_add_block_to_block (&block, &lhs_se.post);
|
||||
return gfc_finish_block (&block);
|
||||
}
|
||||
else if (rhs_expr->expr_type == EXPR_FUNCTION
|
||||
&& rhs_expr->value.function.isym->id == GFC_ISYM_CAF_GET)
|
||||
rhs_expr = rhs_expr->value.function.actual->expr;
|
||||
|
||||
gfc_add_block_to_block (&block, &lhs_se.pre);
|
||||
|
||||
|
|
@ -2276,7 +2296,8 @@ conv_caf_send (gfc_code *code) {
|
|||
|
||||
if (!rhs_is_coindexed)
|
||||
{
|
||||
if (lhs_caf_attr.alloc_comp || lhs_caf_attr.pointer_comp)
|
||||
if (lhs_caf_attr.alloc_comp || lhs_caf_attr.pointer_comp
|
||||
|| has_ref_after_cafref (lhs_expr))
|
||||
{
|
||||
tree reference, dst_realloc;
|
||||
reference = conv_expr_ref_to_caf_ref (&block, lhs_expr);
|
||||
|
|
@ -2313,7 +2334,8 @@ conv_caf_send (gfc_code *code) {
|
|||
caf_decl = build_fold_indirect_ref_loc (input_location, caf_decl);
|
||||
rhs_image_index = gfc_caf_get_image_index (&block, rhs_expr, caf_decl);
|
||||
tmp = rhs_se.expr;
|
||||
if (rhs_caf_attr.alloc_comp || rhs_caf_attr.pointer_comp)
|
||||
if (rhs_caf_attr.alloc_comp || rhs_caf_attr.pointer_comp
|
||||
|| has_ref_after_cafref (lhs_expr))
|
||||
{
|
||||
tmp_stat = gfc_find_stat_co (lhs_expr);
|
||||
|
||||
|
|
|
|||
|
|
@ -2817,7 +2817,7 @@ gfc_get_derived_type (gfc_symbol * derived, int codimen)
|
|||
tree *chain = NULL;
|
||||
bool got_canonical = false;
|
||||
bool unlimited_entity = false;
|
||||
gfc_component *c, *last_c = nullptr;
|
||||
gfc_component *c;
|
||||
gfc_namespace *ns;
|
||||
tree tmp;
|
||||
bool coarray_flag, class_coarray_flag;
|
||||
|
|
@ -3127,16 +3127,12 @@ gfc_get_derived_type (gfc_symbol * derived, int codimen)
|
|||
gcc_assert (field);
|
||||
/* Overwrite for class array to supply different bounds for different
|
||||
types. */
|
||||
if (class_coarray_flag || !c->backend_decl)
|
||||
if (class_coarray_flag || !c->backend_decl || c->attr.caf_token)
|
||||
c->backend_decl = field;
|
||||
if (c->attr.caf_token && last_c)
|
||||
last_c->caf_token = field;
|
||||
|
||||
if (c->attr.pointer && (c->attr.dimension || c->attr.codimension)
|
||||
&& !(c->ts.type == BT_DERIVED && strcmp (c->name, "_data") == 0))
|
||||
GFC_DECL_PTR_ARRAY_P (c->backend_decl) = 1;
|
||||
|
||||
last_c = c;
|
||||
}
|
||||
|
||||
/* Now lay out the derived type, including the fields. */
|
||||
|
|
@ -3162,24 +3158,24 @@ gfc_get_derived_type (gfc_symbol * derived, int codimen)
|
|||
|
||||
copy_derived_types:
|
||||
|
||||
for (c = derived->components; c; c = c->next)
|
||||
{
|
||||
/* Do not add a caf_token field for class container components. */
|
||||
if ((codimen || coarray_flag)
|
||||
&& !c->attr.dimension && !c->attr.codimension
|
||||
&& (c->attr.allocatable || c->attr.pointer)
|
||||
&& !derived->attr.is_class)
|
||||
{
|
||||
/* Provide sufficient space to hold "_caf_symbol". */
|
||||
char caf_name[GFC_MAX_SYMBOL_LEN + 6];
|
||||
gfc_component *token;
|
||||
snprintf (caf_name, sizeof (caf_name), "_caf_%s", c->name);
|
||||
token = gfc_find_component (derived, caf_name, true, true, NULL);
|
||||
gcc_assert (token);
|
||||
c->caf_token = token->backend_decl;
|
||||
suppress_warning (c->caf_token);
|
||||
}
|
||||
}
|
||||
if (!derived->attr.vtype)
|
||||
for (c = derived->components; c; c = c->next)
|
||||
{
|
||||
/* Do not add a caf_token field for class container components. */
|
||||
if ((codimen || coarray_flag) && !c->attr.dimension
|
||||
&& !c->attr.codimension && (c->attr.allocatable || c->attr.pointer)
|
||||
&& !derived->attr.is_class)
|
||||
{
|
||||
/* Provide sufficient space to hold "_caf_symbol". */
|
||||
char caf_name[GFC_MAX_SYMBOL_LEN + 6];
|
||||
gfc_component *token;
|
||||
snprintf (caf_name, sizeof (caf_name), "_caf_%s", c->name);
|
||||
token = gfc_find_component (derived, caf_name, true, true, NULL);
|
||||
gcc_assert (token);
|
||||
gfc_comp_caf_token (c) = token->backend_decl;
|
||||
suppress_warning (gfc_comp_caf_token (c));
|
||||
}
|
||||
}
|
||||
|
||||
for (gfc_symbol *dt = gfc_derived_types; dt; dt = dt->dt_next)
|
||||
{
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue