mirrors/gcc
0
0
Fork 0
mirror of https://gcc.gnu.org/git/gcc.git synced 2024-12-03 00:34:21 +08:00
Code Issues Actions Packages Projects Releases Wiki Activity

re PR fortran/78781 ([Coarray] ICE in gfc_deallocate_scalar_with_status, at fortran/trans.c:1588)

Browse Source 
gcc/fortran/ChangeLog:

2017-01-07  Andre Vehreschild  <vehre@gcc.gnu.org>

	PR fortran/78781
	PR fortran/78935
	* expr.c (gfc_check_pointer_assign): Return the same error message for
	rewritten coarray pointer assignments like for plain ones.
	* gfortran.h: Change prototype.
	* primary.c (caf_variable_attr): Set attributes used ones only only
	ones.  Add setting of pointer_comp attribute.
	(gfc_caf_attr): Add setting of pointer_comp attribute.
	* trans-array.c (gfc_array_allocate): Add flag that the component to
	allocate is not an ultimate coarray component.  Add allocation of
	pointer arrays.
	(structure_alloc_comps): Extend nullify to treat pointer components in
	coarrays correctly.  Restructure nullify to remove redundant code.
	(gfc_nullify_alloc_comp): Allow setting caf_mode flags.
	* trans-array.h: Change prototype of gfc_nullify_alloc_comp ().
	* trans-decl.c (generate_coarray_sym_init): Call nullify_alloc_comp for
	derived type coarrays with pointer components.
	* trans-expr.c (gfc_trans_structure_assign): Also treat pointer
	components.
	(trans_caf_token_assign): Handle assignment of token of scalar pointer
	components.
	(gfc_trans_pointer_assignment): Call above routine.
	* trans-intrinsic.c (conv_expr_ref_to_caf_ref): Add treating pointer
	components.
	(gfc_conv_intrinsic_caf_get): Likewise.
	(conv_caf_send): Likewise.
	* trans-stmt.c (gfc_trans_allocate): After allocating a derived type in
	a coarray pre-register the tokens.
	(gfc_trans_deallocate): Simply determining the coarray type (scalar or
	array) and deregistering it correctly.
	* trans-types.c (gfc_typenode_for_spec): Replace in_coarray flag by the
	actual codim to allow lookup of array types in the cache.
	(gfc_build_array_type): Likewise.
	(gfc_get_array_descriptor_base): Likewise.
	(gfc_get_array_type_bounds): Likewise.
	(gfc_get_derived_type): Likewise.
	* trans-types.h: Likewise.
	* trans.c (gfc_deallocate_with_status): Enable deregistering of all kind
	of coarray components.
	(gfc_deallocate_scalar_with_status): Use free() in fcoarray_single mode
	instead of caf_deregister.

libgfortran/ChangeLog:

2017-01-07  Andre Vehreschild  <vehre@gcc.gnu.org>

	PR fortran/78781
	PR fortran/78935
	* caf/single.c (send_by_ref): Fix addressing of non-allocatable scalar
	destination components.

gcc/testsuite/ChangeLog:

2017-01-07  Andre Vehreschild  <vehre@gcc.gnu.org>

	* gfortran.dg/coarray/ptr_comp_1.f08: New test.
	* gfortran.dg/coarray/ptr_comp_2.f08: New test.
	* gfortran.dg/coarray/ptr_comp_3.f08: New test.
	* gfortran.dg/coarray/ptr_comp_4.f08: New test.
	* gfortran.dg/coarray_ptr_comp_1.f08: New test.
	* gfortran.dg/coarray_ptr_comp_2.f08: New test.
	* gfortran.dg/coarray_ptr_comp_3.f08: New test.

From-SVN: r244196
This commit is contained in:
Andre Vehreschild 2017-01-07 18:26:58 +01:00
parent 0fc08a17f0
commit de91486c74
23 changed files with 631 additions and 111 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

44
gcc/fortran/ChangeLog
View File

@ -1,3 +1,47 @@
2017-01-07 Andre Vehreschild <vehre@gcc.gnu.org>
PR fortran/78781
PR fortran/78935
* expr.c (gfc_check_pointer_assign): Return the same error message for
rewritten coarray pointer assignments like for plain ones.
* gfortran.h: Change prototype.
* primary.c (caf_variable_attr): Set attributes used ones only only
ones. Add setting of pointer_comp attribute.
(gfc_caf_attr): Add setting of pointer_comp attribute.
* trans-array.c (gfc_array_allocate): Add flag that the component to
allocate is not an ultimate coarray component. Add allocation of
pointer arrays.
(structure_alloc_comps): Extend nullify to treat pointer components in
coarrays correctly. Restructure nullify to remove redundant code.
(gfc_nullify_alloc_comp): Allow setting caf_mode flags.
* trans-array.h: Change prototype of gfc_nullify_alloc_comp ().
* trans-decl.c (generate_coarray_sym_init): Call nullify_alloc_comp for
derived type coarrays with pointer components.
* trans-expr.c (gfc_trans_structure_assign): Also treat pointer
components.
(trans_caf_token_assign): Handle assignment of token of scalar pointer
components.
(gfc_trans_pointer_assignment): Call above routine.
* trans-intrinsic.c (conv_expr_ref_to_caf_ref): Add treating pointer
components.
(gfc_conv_intrinsic_caf_get): Likewise.
(conv_caf_send): Likewise.
* trans-stmt.c (gfc_trans_allocate): After allocating a derived type in
a coarray pre-register the tokens.
(gfc_trans_deallocate): Simply determining the coarray type (scalar or
array) and deregistering it correctly.
* trans-types.c (gfc_typenode_for_spec): Replace in_coarray flag by the
actual codim to allow lookup of array types in the cache.
(gfc_build_array_type): Likewise.
(gfc_get_array_descriptor_base): Likewise.
(gfc_get_array_type_bounds): Likewise.
(gfc_get_derived_type): Likewise.
* trans-types.h: Likewise.
* trans.c (gfc_deallocate_with_status): Enable deregistering of all kind
of coarray components.
(gfc_deallocate_scalar_with_status): Use free() in fcoarray_single mode
instead of caf_deregister.
2017-01-06 Jakub Jelinek <jakub@redhat.com>
* simplify.c (simplify_transformation_to_array): Use

17
gcc/fortran/expr.c
View File

@ -3708,9 +3708,20 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue)
if (rvalue->expr_type == EXPR_FUNCTION && !attr.pointer)
{
gfc_error ("Target expression in pointer assignment "
"at %L must deliver a pointer result",
&rvalue->where);
/* F2008, C725. For PURE also C1283. Sometimes rvalue is a function call
to caf_get. Map this to the same error message as below when it is
still a variable expression. */
if (rvalue->value.function.isym
&& rvalue->value.function.isym->id == GFC_ISYM_CAF_GET)
/* The test above might need to be extend when F08, Note 5.4 has to be
interpreted in the way that target and pointer with the same coindex
are allowed. */
gfc_error ("Data target at %L shall not have a coindex",
&rvalue->where);
else
gfc_error ("Target expression in pointer assignment "
"at %L must deliver a pointer result",
&rvalue->where);
return false;
}

2
gcc/fortran/gfortran.h
View File

@ -2836,7 +2836,7 @@ int gfc_validate_kind (bt, int, bool);
int gfc_get_int_kind_from_width_isofortranenv (int size);
int gfc_get_real_kind_from_width_isofortranenv (int size);
tree gfc_get_union_type (gfc_symbol *);
tree gfc_get_derived_type (gfc_symbol * derived, bool in_coarray = false);
tree gfc_get_derived_type (gfc_symbol * derived, int codimen = 0);
extern int gfc_index_integer_kind;
extern int gfc_default_integer_kind;
extern int gfc_max_integer_kind;

13
gcc/fortran/primary.c
View File

@ -2436,8 +2436,7 @@ gfc_expr_attr (gfc_expr *e)
static symbol_attribute
caf_variable_attr (gfc_expr *expr, bool in_allocate, bool *refs_comp)
{
int dimension, codimension, pointer, allocatable, target, coarray_comp,
alloc_comp;
int dimension, codimension, pointer, allocatable, target, coarray_comp;
symbol_attribute attr;
gfc_ref *ref;
gfc_symbol *sym;
@ -2458,7 +2457,8 @@ caf_variable_attr (gfc_expr *expr, bool in_allocate, bool *refs_comp)
codimension = CLASS_DATA (sym)->attr.codimension;
pointer = CLASS_DATA (sym)->attr.class_pointer;
allocatable = CLASS_DATA (sym)->attr.allocatable;
alloc_comp = CLASS_DATA (sym)->ts.u.derived->attr.alloc_comp;
attr.alloc_comp = CLASS_DATA (sym)->ts.u.derived->attr.alloc_comp;
attr.pointer_comp = CLASS_DATA (sym)->ts.u.derived->attr.pointer_comp;
}
else
{
@ -2466,8 +2466,10 @@ caf_variable_attr (gfc_expr *expr, bool in_allocate, bool *refs_comp)
codimension = sym->attr.codimension;
pointer = sym->attr.pointer;
allocatable = sym->attr.allocatable;
alloc_comp = sym->ts.type == BT_DERIVED
attr.alloc_comp = sym->ts.type == BT_DERIVED
? sym->ts.u.derived->attr.alloc_comp : 0;
attr.pointer_comp = sym->ts.type == BT_DERIVED
? sym->ts.u.derived->attr.pointer_comp : 0;
}
target = coarray_comp = 0;
@ -2545,7 +2547,6 @@ caf_variable_attr (gfc_expr *expr, bool in_allocate, bool *refs_comp)
attr.target = target;
attr.save = sym->attr.save;
attr.coarray_comp = coarray_comp;
attr.alloc_comp = alloc_comp;
return attr;
}
@ -2575,6 +2576,8 @@ gfc_caf_attr (gfc_expr *e, bool in_allocate, bool *refs_comp)
attr.pointer = CLASS_DATA (sym)->attr.class_pointer;
attr.allocatable = CLASS_DATA (sym)->attr.allocatable;
attr.alloc_comp = CLASS_DATA (sym)->ts.u.derived->attr.alloc_comp;
attr.pointer_comp = CLASS_DATA (sym)->ts.u.derived
->attr.pointer_comp;
}
}
else if (e->symtree)

112
gcc/fortran/trans-array.c
View File

@ -5469,7 +5469,8 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg,
gfc_expr **lower;
gfc_expr **upper;
gfc_ref *ref, *prev_ref = NULL, *coref;
bool allocatable, coarray, dimension, alloc_w_e3_arr_spec = false;
bool allocatable, coarray, dimension, alloc_w_e3_arr_spec = false,
non_ulimate_coarray_ptr_comp;
ref = expr->ref;
@ -5483,10 +5484,17 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg,
{
allocatable = expr->symtree->n.sym->attr.allocatable;
dimension = expr->symtree->n.sym->attr.dimension;
non_ulimate_coarray_ptr_comp = false;
}
else
{
allocatable = prev_ref->u.c.component->attr.allocatable;
/* Pointer components in coarrayed derived types must be treated
specially in that they are registered without a check if the are
already associated. This does not hold for ultimate coarray
pointers. */
non_ulimate_coarray_ptr_comp = (prev_ref->u.c.component->attr.pointer
&& !prev_ref->u.c.component->attr.codimension);
dimension = prev_ref->u.c.component->attr.dimension;
}
@ -5599,20 +5607,27 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg,
if (POINTER_TYPE_P (TREE_TYPE (se->expr)))
se->expr = build_fold_indirect_ref_loc (input_location, se->expr);
pointer = gfc_conv_descriptor_data_get (se->expr);
STRIP_NOPS (pointer);
if (coarray && flag_coarray == GFC_FCOARRAY_LIB)
{
pointer = non_ulimate_coarray_ptr_comp ? se->expr
: gfc_conv_descriptor_data_get (se->expr);
token = gfc_conv_descriptor_token (se->expr);
token = gfc_build_addr_expr (NULL_TREE, token);
}
else
pointer = gfc_conv_descriptor_data_get (se->expr);
STRIP_NOPS (pointer);
/* The allocatable variant takes the old pointer as first argument. */
if (allocatable)
gfc_allocate_allocatable (&elseblock, pointer, size, token,
status, errmsg, errlen, label_finish, expr,
coref != NULL ? coref->u.ar.as->corank : 0);
else if (non_ulimate_coarray_ptr_comp && token)
/* The token is set only for GFC_FCOARRAY_LIB mode. */
gfc_allocate_using_caf_lib (&elseblock, pointer, size, token, status,
errmsg, errlen,
GFC_CAF_COARRAY_ALLOC_ALLOCATE_ONLY);
else
gfc_allocate_using_malloc (&elseblock, pointer, size, status);
@ -8411,43 +8426,27 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
break;
case NULLIFY_ALLOC_COMP:
if (c->attr.pointer || c->attr.proc_pointer
/* Nullify
- allocatable components (regular or in class)
- components that have allocatable components
- pointer components when in a coarray.
Skip everything else especially proc_pointers, which may come
coupled with the regular pointer attribute. */
if (c->attr.proc_pointer
|| !(c->attr.allocatable || (c->ts.type == BT_CLASS
&& CLASS_DATA (c)->attr.allocatable)
|| cmp_has_alloc_comps))
|| (cmp_has_alloc_comps
&& ((c->ts.type == BT_DERIVED && !c->attr.pointer)
|| (c->ts.type == BT_CLASS
&& !CLASS_DATA (c)->attr.class_pointer)))
|| (caf_in_coarray (caf_mode) && c->attr.pointer)))
continue;
/* Coarrays need the component to be initialized before the api-call
is made. */
if (c->attr.allocatable && (c->attr.dimension || c->attr.codimension))
{
comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
decl, cdecl, NULL_TREE);
gfc_conv_descriptor_data_set (&fnblock, comp, null_pointer_node);
cmp_has_alloc_comps = false;
}
else if (c->attr.allocatable)
{
/* Allocatable scalar components. */
comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
decl, cdecl, NULL_TREE);
tmp = fold_build2_loc (input_location, MODIFY_EXPR,
void_type_node, comp,
build_int_cst (TREE_TYPE (comp), 0));
gfc_add_expr_to_block (&fnblock, tmp);
if (gfc_deferred_strlen (c, &comp))
{
comp = fold_build3_loc (input_location, COMPONENT_REF,
TREE_TYPE (comp),
decl, comp, NULL_TREE);
tmp = fold_build2_loc (input_location, MODIFY_EXPR,
TREE_TYPE (comp), comp,
build_int_cst (TREE_TYPE (comp), 0));
gfc_add_expr_to_block (&fnblock, tmp);
}
cmp_has_alloc_comps = false;
}
else if (c->ts.type == BT_CLASS && CLASS_DATA (c)->attr.allocatable)
/* Process class components first, because they always have the
pointer-attribute set which would be caught wrong else. */
if (c->ts.type == BT_CLASS
&& (CLASS_DATA (c)->attr.allocatable
|| CLASS_DATA (c)->attr.class_pointer))
{
/* Allocatable CLASS components. */
comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
@ -8455,7 +8454,8 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
comp = gfc_class_data_get (comp);
if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (comp)))
gfc_conv_descriptor_data_set (&fnblock, comp, null_pointer_node);
gfc_conv_descriptor_data_set (&fnblock, comp,
null_pointer_node);
else
{
tmp = fold_build2_loc (input_location, MODIFY_EXPR,
@ -8465,6 +8465,30 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
}
cmp_has_alloc_comps = false;
}
/* Coarrays need the component to be nulled before the api-call
is made. */
else if (c->attr.pointer || c->attr.allocatable)
{
comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
decl, cdecl, NULL_TREE);
if (c->attr.dimension || c->attr.codimension)
gfc_conv_descriptor_data_set (&fnblock, comp,
null_pointer_node);
else
gfc_add_modify (&fnblock, comp,
build_int_cst (TREE_TYPE (comp), 0));
if (gfc_deferred_strlen (c, &comp))
{
comp = fold_build3_loc (input_location, COMPONENT_REF,
TREE_TYPE (comp),
decl, comp, NULL_TREE);
tmp = fold_build2_loc (input_location, MODIFY_EXPR,
TREE_TYPE (comp), comp,
build_int_cst (TREE_TYPE (comp), 0));
gfc_add_expr_to_block (&fnblock, tmp);
}
cmp_has_alloc_comps = false;
}
if (flag_coarray == GFC_FCOARRAY_LIB
&& (caf_in_coarray (caf_mode) || c->attr.codimension))
@ -8476,6 +8500,9 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
decl, cdecl, NULL_TREE);
if (c->attr.dimension || c->attr.codimension)
{
/* Set the dtype, because caf_register needs it. */
gfc_add_modify (&fnblock, gfc_conv_descriptor_dtype (comp),
gfc_get_dtype (TREE_TYPE (comp)));
tmp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
decl, cdecl, NULL_TREE);
token = gfc_conv_descriptor_token (tmp);
@ -8494,10 +8521,6 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
gfc_add_block_to_block (&fnblock, &se.pre);
}
/* NULL the member-token before registering it or uninitialized
memory accesses may occur. */
gfc_add_modify (&fnblock, token, fold_convert (TREE_TYPE (token),
null_pointer_node));
gfc_allocate_using_caf_lib (&fnblock, comp, size_zero_node,
gfc_build_addr_expr (NULL_TREE,
token),
@ -8711,11 +8734,12 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
nullify allocatable components. */
tree
gfc_nullify_alloc_comp (gfc_symbol * der_type, tree decl, int rank)
gfc_nullify_alloc_comp (gfc_symbol * der_type, tree decl, int rank,
int caf_mode)
{
return structure_alloc_comps (der_type, decl, NULL_TREE, rank,
NULLIFY_ALLOC_COMP,
GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY);
GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY | caf_mode);
}

2
gcc/fortran/trans-array.h
View File

@ -49,7 +49,7 @@ tree gfc_duplicate_allocatable_nocopy (tree, tree, tree, int);
bool gfc_caf_is_dealloc_only (int);
tree gfc_nullify_alloc_comp (gfc_symbol *, tree, int);
tree gfc_nullify_alloc_comp (gfc_symbol *, tree, int, int cm = 0);
tree gfc_deallocate_alloc_comp (gfc_symbol *, tree, int, int cm = 0);
tree gfc_deallocate_alloc_comp_no_caf (gfc_symbol *, tree, int);

7
gcc/fortran/trans-decl.c
View File

@ -5147,6 +5147,13 @@ generate_coarray_sym_init (gfc_symbol *sym)
sym->attr.pointer = 0;
gfc_add_expr_to_block (&caf_init_block, tmp);
}
else if (sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.pointer_comp)
{
tmp = gfc_nullify_alloc_comp (sym->ts.u.derived, decl, sym->as
? sym->as->rank : 0,
GFC_STRUCTURE_CAF_MODE_IN_COARRAY);
gfc_add_expr_to_block (&caf_init_block, tmp);
}
}

54
gcc/fortran/trans-expr.c
View File

@ -7506,7 +7506,8 @@ gfc_trans_structure_assign (tree dest, gfc_expr * expr, bool init, bool coarray)
Register only allocatable components, that are not coarray'ed
components (%comp[*]). Only register when the constructor is not the
null-expression. */
if (coarray && !cm->attr.codimension && cm->attr.allocatable
if (coarray && !cm->attr.codimension
&& (cm->attr.allocatable || cm->attr.pointer)
&& (!c->expr || c->expr->expr_type == EXPR_NULL))
{
tree token, desc, size;
@ -8121,6 +8122,52 @@ trans_class_vptr_len_assignment (stmtblock_t *block, gfc_expr * le,
return lhs_vptr;
}
/* Assign tokens for pointer components. */
static void
trans_caf_token_assign (gfc_se *lse, gfc_se *rse, gfc_expr *expr1,
gfc_expr *expr2)
{
symbol_attribute lhs_attr, rhs_attr;
tree tmp, lhs_tok, rhs_tok;
/* Flag to indicated component refs on the rhs. */
bool rhs_cr;
lhs_attr = gfc_caf_attr (expr1);
if (expr2->expr_type != EXPR_NULL)
{
rhs_attr = gfc_caf_attr (expr2, false, &rhs_cr);
if (lhs_attr.codimension && rhs_attr.codimension)
{
lhs_tok = gfc_get_ultimate_alloc_ptr_comps_caf_token (lse, expr1);
lhs_tok = build_fold_indirect_ref (lhs_tok);
if (rhs_cr)
rhs_tok = gfc_get_ultimate_alloc_ptr_comps_caf_token (rse, expr2);
else
{
tree caf_decl;
caf_decl = gfc_get_tree_for_caf_expr (expr2);
gfc_get_caf_token_offset (rse, &rhs_tok, NULL, caf_decl,
NULL_TREE, NULL);
}
tmp = build2_loc (input_location, MODIFY_EXPR, void_type_node,
lhs_tok,
fold_convert (TREE_TYPE (lhs_tok), rhs_tok));
gfc_prepend_expr_to_block (&lse->post, tmp);
}
}
else if (lhs_attr.codimension)
{
lhs_tok = gfc_get_ultimate_alloc_ptr_comps_caf_token (lse, expr1);
lhs_tok = build_fold_indirect_ref (lhs_tok);
tmp = build2_loc (input_location, MODIFY_EXPR, void_type_node,
lhs_tok, null_pointer_node);
gfc_prepend_expr_to_block (&lse->post, tmp);
}
}
/* Indentify class valued proc_pointer assignments. */
static bool
@ -8241,6 +8288,11 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
gfc_add_modify (&block, lse.expr,
fold_convert (TREE_TYPE (lse.expr), rse.expr));
/* Also set the tokens for pointer components in derived typed
coarrays. */
if (flag_coarray == GFC_FCOARRAY_LIB)
trans_caf_token_assign (&lse, &rse, expr1, expr2);
gfc_add_block_to_block (&block, &rse.post);
gfc_add_block_to_block (&block, &lse.post);
}

26
gcc/fortran/trans-intrinsic.c
View File

@ -1123,7 +1123,8 @@ conv_expr_ref_to_caf_ref (stmtblock_t *block, gfc_expr *expr)
if (expr->symtree)
{
last_component_ref_tree = expr->symtree->n.sym->backend_decl;
ref_static_array = !expr->symtree->n.sym->attr.allocatable;
ref_static_array = !expr->symtree->n.sym->attr.allocatable
&& !expr->symtree->n.sym->attr.pointer;
}
/* Prevent uninit-warning. */
@ -1219,7 +1220,8 @@ conv_expr_ref_to_caf_ref (stmtblock_t *block, gfc_expr *expr)
tmp = fold_build3_loc (input_location, COMPONENT_REF,
TREE_TYPE (field), inner_struct, field,
NULL_TREE);
if (ref->u.c.component->attr.allocatable
if ((ref->u.c.component->attr.allocatable
|| ref->u.c.component->attr.pointer)
&& ref->u.c.component->attr.dimension)
{
tree arr_desc_token_offset;
@ -1243,7 +1245,8 @@ conv_expr_ref_to_caf_ref (stmtblock_t *block, gfc_expr *expr)
/* Remember whether this ref was to a non-allocatable/non-pointer
component so the next array ref can be tailored correctly. */
ref_static_array = !ref->u.c.component->attr.allocatable;
ref_static_array = !ref->u.c.component->attr.allocatable
&& !ref->u.c.component->attr.pointer;
last_component_ref_tree = ref_static_array
? ref->u.c.component->backend_decl : NULL_TREE;
break;
@ -1627,7 +1630,7 @@ gfc_conv_intrinsic_caf_get (gfc_se *se, gfc_expr *expr, tree lhs, tree lhs_kind,
/* Only use the new get_by_ref () where it is necessary. I.e., when the lhs
is reallocatable or the right-hand side has allocatable components. */
if (caf_attr->alloc_comp || may_realloc)
if (caf_attr->alloc_comp || caf_attr->pointer_comp || may_realloc)
{
/* Get using caf_get_by_ref. */
caf_reference = conv_expr_ref_to_caf_ref (&se->pre, array_expr);
@ -1876,7 +1879,8 @@ conv_caf_send (gfc_code *code) {
lhs_se.expr = gfc_conv_scalar_to_descriptor (&lhs_se, lhs_se.expr, attr);
lhs_se.expr = gfc_build_addr_expr (NULL_TREE, lhs_se.expr);
}
else if (lhs_caf_attr.alloc_comp && lhs_caf_attr.codimension)
else if ((lhs_caf_attr.alloc_comp || lhs_caf_attr.pointer_comp)
&& lhs_caf_attr.codimension)
{
lhs_se.want_pointer = 1;
gfc_conv_expr_descriptor (&lhs_se, lhs_expr);
@ -1930,12 +1934,13 @@ conv_caf_send (gfc_code *code) {
temporary and a loop. */
if (!gfc_is_coindexed (lhs_expr)
&& (!lhs_caf_attr.codimension
|| !(lhs_expr->rank > 0 && lhs_caf_attr.allocatable)))
|| !(lhs_expr->rank > 0
&& (lhs_caf_attr.allocatable || lhs_caf_attr.pointer))))
{
bool lhs_may_realloc = lhs_expr->rank > 0 && lhs_caf_attr.allocatable;
gcc_assert (gfc_is_coindexed (rhs_expr));
gfc_init_se (&rhs_se, NULL);
if (lhs_expr->rank == 0 && gfc_expr_attr (lhs_expr).allocatable)
if (lhs_expr->rank == 0 && lhs_caf_attr.allocatable)
{
gfc_se scal_se;
gfc_init_se (&scal_se, NULL);
@ -1997,7 +2002,8 @@ conv_caf_send (gfc_code *code) {
rhs_se.expr = gfc_conv_scalar_to_descriptor (&rhs_se, rhs_se.expr, attr);
rhs_se.expr = gfc_build_addr_expr (NULL_TREE, rhs_se.expr);
}
else if (rhs_caf_attr.alloc_comp && rhs_caf_attr.codimension)
else if ((rhs_caf_attr.alloc_comp || rhs_caf_attr.pointer_comp)
&& rhs_caf_attr.codimension)
{
tree tmp2;
rhs_se.want_pointer = 1;
@ -2065,7 +2071,7 @@ conv_caf_send (gfc_code *code) {
if (!gfc_is_coindexed (rhs_expr))
{
if (lhs_caf_attr.alloc_comp)
if (lhs_caf_attr.alloc_comp || lhs_caf_attr.pointer_comp)
{
tree reference, dst_realloc;
reference = conv_expr_ref_to_caf_ref (&block, lhs_expr);
@ -2100,7 +2106,7 @@ 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)
if (rhs_caf_attr.alloc_comp || rhs_caf_attr.pointer_comp)
{
tmp_stat = gfc_find_stat_co (lhs_expr);

51
gcc/fortran/trans-stmt.c
View File

@ -6299,6 +6299,40 @@ gfc_trans_allocate (gfc_code * code)
gfc_add_expr_to_block (&block, tmp);
}
/* Nullify all pointers in derived type coarrays. This registers a
token for them which allows their allocation. */
if (is_coarray)
{
gfc_symbol *type = NULL;
symbol_attribute caf_attr;
int rank = 0;
if (code->ext.alloc.ts.type == BT_DERIVED
&& code->ext.alloc.ts.u.derived->attr.pointer_comp)
{
type = code->ext.alloc.ts.u.derived;
rank = type->attr.dimension ? type->as->rank : 0;
gfc_clear_attr (&caf_attr);
}
else if (expr->ts.type == BT_DERIVED
&& expr->ts.u.derived->attr.pointer_comp)
{
type = expr->ts.u.derived;
rank = expr->rank;
caf_attr = gfc_caf_attr (expr, true);
}
/* Initialize the tokens of pointer components in derived type
coarrays. */
if (type)
{
tmp = (caf_attr.codimension && !caf_attr.dimension)
? gfc_conv_descriptor_data_get (se.expr) : se.expr;
tmp = gfc_nullify_alloc_comp (type, tmp, rank,
GFC_STRUCTURE_CAF_MODE_IN_COARRAY);
gfc_add_expr_to_block (&block, tmp);
}
}
gfc_free_expr (expr);
} // for-loop
@ -6443,7 +6477,8 @@ gfc_trans_deallocate (gfc_code *code)
se.descriptor_only = 1;
gfc_conv_expr (&se, expr);
if (flag_coarray == GFC_FCOARRAY_LIB)
if (flag_coarray == GFC_FCOARRAY_LIB
|| flag_coarray == GFC_FCOARRAY_SINGLE)
{
bool comp_ref;
symbol_attribute caf_attr = gfc_caf_attr (expr, false, &comp_ref);
@ -6453,15 +6488,15 @@ gfc_trans_deallocate (gfc_code *code)
is_coarray_array = caf_attr.dimension || !comp_ref
|| caf_attr.coarray_comp;
/* When the expression to deallocate is referencing a
component, then only deallocate it, but do not deregister. */
caf_mode = GFC_STRUCTURE_CAF_MODE_IN_COARRAY
| (comp_ref && !caf_attr.coarray_comp
? GFC_STRUCTURE_CAF_MODE_DEALLOC_ONLY : 0);
if (flag_coarray == GFC_FCOARRAY_LIB)
/* When the expression to deallocate is referencing a
component, then only deallocate it, but do not
deregister. */
caf_mode = GFC_STRUCTURE_CAF_MODE_IN_COARRAY
| (comp_ref && !caf_attr.coarray_comp
? GFC_STRUCTURE_CAF_MODE_DEALLOC_ONLY : 0);
}
}
else if (flag_coarray == GFC_FCOARRAY_SINGLE)
is_coarray = is_coarray_array = gfc_caf_attr (expr).codimension;
if (expr->rank || is_coarray_array)
{

52
gcc/fortran/trans-types.c
View File

@ -1050,7 +1050,7 @@ gfc_get_character_type (int kind, gfc_charlen * cl)
/* Convert a basic type. This will be an array for character types. */
tree
gfc_typenode_for_spec (gfc_typespec * spec, bool in_coarray)
gfc_typenode_for_spec (gfc_typespec * spec, int codim)
{
tree basetype;
@ -1103,7 +1103,7 @@ gfc_typenode_for_spec (gfc_typespec * spec, bool in_coarray)
case BT_DERIVED:
case BT_CLASS:
basetype = gfc_get_derived_type (spec->u.derived, in_coarray);
basetype = gfc_get_derived_type (spec->u.derived, codim);
if (spec->type == BT_CLASS)
GFC_CLASS_TYPE_P (basetype) = 1;
@ -1307,7 +1307,7 @@ gfc_is_nodesc_array (gfc_symbol * sym)
static tree
gfc_build_array_type (tree type, gfc_array_spec * as,
enum gfc_array_kind akind, bool restricted,
bool contiguous, bool in_coarray)
bool contiguous, int codim)
{
tree lbound[GFC_MAX_DIMENSIONS];
tree ubound[GFC_MAX_DIMENSIONS];
@ -1315,10 +1315,10 @@ gfc_build_array_type (tree type, gfc_array_spec * as,
/* Assumed-shape arrays do not have codimension information stored in the
descriptor. */
corank = as->corank;
corank = MAX (as->corank, codim);
if (as->type == AS_ASSUMED_SHAPE ||
(as->type == AS_ASSUMED_RANK && akind == GFC_ARRAY_ALLOCATABLE))
corank = 0;
corank = codim;
if (as->type == AS_ASSUMED_RANK)
for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
@ -1356,8 +1356,8 @@ gfc_build_array_type (tree type, gfc_array_spec * as,
: GFC_ARRAY_ASSUMED_RANK;
return gfc_get_array_type_bounds (type, as->rank == -1
? GFC_MAX_DIMENSIONS : as->rank,
corank, lbound,
ubound, 0, akind, restricted, in_coarray);
corank, lbound, ubound, 0, akind,
restricted);
}
/* Returns the struct descriptor_dimension type. */
@ -1719,8 +1719,7 @@ gfc_get_nodesc_array_type (tree etype, gfc_array_spec * as, gfc_packed packed,
/* Return or create the base type for an array descriptor. */
static tree
gfc_get_array_descriptor_base (int dimen, int codimen, bool restricted,
enum gfc_array_kind akind, bool in_coarray)
gfc_get_array_descriptor_base (int dimen, int codimen, bool restricted)
{
tree fat_type, decl, arraytype, *chain = NULL;
char name[16 + 2*GFC_RANK_DIGITS + 1 + 1];
@ -1782,8 +1781,7 @@ gfc_get_array_descriptor_base (int dimen, int codimen, bool restricted,
TREE_NO_WARNING (decl) = 1;
}
if (flag_coarray == GFC_FCOARRAY_LIB && (codimen || in_coarray)
&& akind == GFC_ARRAY_ALLOCATABLE)
if (flag_coarray == GFC_FCOARRAY_LIB && codimen)
{
decl = gfc_add_field_to_struct_1 (fat_type,
get_identifier ("token"),
@ -1795,8 +1793,7 @@ gfc_get_array_descriptor_base (int dimen, int codimen, bool restricted,
gfc_finish_type (fat_type);
TYPE_DECL_SUPPRESS_DEBUG (TYPE_STUB_DECL (fat_type)) = 1;
if (flag_coarray == GFC_FCOARRAY_LIB && codimen
&& akind == GFC_ARRAY_ALLOCATABLE)
if (flag_coarray == GFC_FCOARRAY_LIB && codimen)
gfc_array_descriptor_base_caf[idx] = fat_type;
else
gfc_array_descriptor_base[idx] = fat_type;
@ -1810,21 +1807,18 @@ gfc_get_array_descriptor_base (int dimen, int codimen, bool restricted,
tree
gfc_get_array_type_bounds (tree etype, int dimen, int codimen, tree * lbound,
tree * ubound, int packed,
enum gfc_array_kind akind, bool restricted,
bool in_coarray)
enum gfc_array_kind akind, bool restricted)
{
char name[8 + 2*GFC_RANK_DIGITS + 1 + GFC_MAX_SYMBOL_LEN];
tree fat_type, base_type, arraytype, lower, upper, stride, tmp, rtype;
const char *type_name;
int n;
base_type = gfc_get_array_descriptor_base (dimen, codimen, restricted, akind,
in_coarray);
base_type = gfc_get_array_descriptor_base (dimen, codimen, restricted);
fat_type = build_distinct_type_copy (base_type);
/* Make sure that nontarget and target array type have the same canonical
type (and same stub decl for debug info). */
base_type = gfc_get_array_descriptor_base (dimen, codimen, false, akind,
in_coarray);
base_type = gfc_get_array_descriptor_base (dimen, codimen, false);
TYPE_CANONICAL (fat_type) = base_type;
TYPE_STUB_DECL (fat_type) = TYPE_STUB_DECL (base_type);
@ -2416,7 +2410,7 @@ gfc_get_union_type (gfc_symbol *un)
in a parent namespace, this is used. */
tree
gfc_get_derived_type (gfc_symbol * derived, bool in_coarray)
gfc_get_derived_type (gfc_symbol * derived, int codimen)
{
tree typenode = NULL, field = NULL, field_type = NULL;
tree canonical = NULL_TREE;
@ -2568,9 +2562,11 @@ gfc_get_derived_type (gfc_symbol * derived, bool in_coarray)
if ((!c->attr.pointer && !c->attr.proc_pointer
&& !same_alloc_type)
|| c->ts.u.derived->backend_decl == NULL)
c->ts.u.derived->backend_decl = gfc_get_derived_type (c->ts.u.derived,
in_coarray
|| c->attr.codimension);
{
int local_codim = c->attr.codimension ? c->as->corank: codimen;
c->ts.u.derived->backend_decl = gfc_get_derived_type (c->ts.u.derived,
local_codim);
}
if (c->ts.u.derived->attr.is_iso_c)
{
@ -2629,7 +2625,7 @@ gfc_get_derived_type (gfc_symbol * derived, bool in_coarray)
c->ts.u.cl->backend_decl
= build_int_cst (gfc_charlen_type_node, 0);
field_type = gfc_typenode_for_spec (&c->ts, in_coarray);
field_type = gfc_typenode_for_spec (&c->ts, codimen);
}
/* This returns an array descriptor type. Initialization may be
@ -2650,7 +2646,7 @@ gfc_get_derived_type (gfc_symbol * derived, bool in_coarray)
!c->attr.target
&& !c->attr.pointer,
c->attr.contiguous,
in_coarray);
codimen);
}
else
field_type = gfc_get_nodesc_array_type (field_type, c->as,
@ -2697,9 +2693,9 @@ gfc_get_derived_type (gfc_symbol * derived, bool in_coarray)
c->backend_decl = field;
/* Do not add a caf_token field for classes' data components. */
if (in_coarray && !c->attr.dimension && !c->attr.codimension
&& c->attr.allocatable && c->caf_token == NULL_TREE
&& strcmp ("_data", c->name) != 0)
if (codimen && !c->attr.dimension && !c->attr.codimension
&& (c->attr.allocatable || c->attr.pointer)
&& c->caf_token == NULL_TREE && strcmp ("_data", c->name) != 0)
{
char caf_name[GFC_MAX_SYMBOL_LEN];
snprintf (caf_name, GFC_MAX_SYMBOL_LEN, "_caf_%s", c->name);

5
gcc/fortran/trans-types.h
View File

@ -70,7 +70,7 @@ tree gfc_get_character_type_len (int, tree);
tree gfc_get_character_type_len_for_eltype (tree, tree);
tree gfc_sym_type (gfc_symbol *);
tree gfc_typenode_for_spec (gfc_typespec *, bool in_coarray = false);
tree gfc_typenode_for_spec (gfc_typespec *, int c = 0);
int gfc_copy_dt_decls_ifequal (gfc_symbol *, gfc_symbol *, bool);
tree gfc_get_function_type (gfc_symbol *);
@ -81,8 +81,7 @@ tree gfc_build_uint_type (int);
tree gfc_get_element_type (tree);
tree gfc_get_array_type_bounds (tree, int, int, tree *, tree *, int,
enum gfc_array_kind, bool,
bool in_coarray = false);
enum gfc_array_kind, bool);
tree gfc_get_nodesc_array_type (tree, gfc_array_spec *, gfc_packed, bool);
/* Add a field of given name and type to a UNION_TYPE or RECORD_TYPE. */

5
gcc/fortran/trans.c
View File

@ -1302,8 +1302,7 @@ gfc_deallocate_with_status (tree pointer, tree status, tree errmsg,
pointer = gfc_conv_descriptor_data_get (caf_decl);
caf_type = TREE_TYPE (caf_decl);
STRIP_NOPS (pointer);
if (GFC_DESCRIPTOR_TYPE_P (caf_type)
&& GFC_TYPE_ARRAY_AKIND (caf_type) == GFC_ARRAY_ALLOCATABLE)
if (GFC_DESCRIPTOR_TYPE_P (caf_type))
token = gfc_conv_descriptor_token (caf_decl);
else if (DECL_LANG_SPECIFIC (caf_decl)
&& GFC_DECL_TOKEN (caf_decl) != NULL_TREE)
@ -1552,7 +1551,7 @@ gfc_deallocate_scalar_with_status (tree pointer, tree status, tree label_finish,
gfc_add_expr_to_block (&non_null, tmp);
}
if (!coarray)
if (!coarray || flag_coarray == GFC_FCOARRAY_SINGLE)
{
tmp = build_call_expr_loc (input_location,
builtin_decl_explicit (BUILT_IN_FREE), 1,

10
gcc/testsuite/ChangeLog
View File

@ -1,3 +1,13 @@
2017-01-07 Andre Vehreschild <vehre@gcc.gnu.org>
* gfortran.dg/coarray/ptr_comp_1.f08: New test.
* gfortran.dg/coarray/ptr_comp_2.f08: New test.
* gfortran.dg/coarray/ptr_comp_3.f08: New test.
* gfortran.dg/coarray/ptr_comp_4.f08: New test.
* gfortran.dg/coarray_ptr_comp_1.f08: New test.
* gfortran.dg/coarray_ptr_comp_2.f08: New test.
* gfortran.dg/coarray_ptr_comp_3.f08: New test.
2017-01-06 Aaron Sawdey <acsawdey@linux.vnet.ibm.com>
* gcc.dg/memcmp-1.c: New.
* gcc.dg/strncmp-1.c: New.

36
gcc/testsuite/gfortran.dg/coarray/ptr_comp_1.f08 Normal file
View File

@ -0,0 +1,36 @@
! { dg-do run }
program alloc_comp
type t
integer, pointer :: z
end type
type(t), save :: obj[*]
integer, allocatable, target :: i[:]
if (associated(obj%z)) error stop "'z' should not be associated yet."
allocate (obj%z)
call f(obj)
if (associated(obj%z)) error stop "'z' should not be associated anymore."
allocate(i[*], SOURCE=42)
obj%z => i
if (.not. allocated(i)) error stop "'i' no longer allocated."
i = 15
if (obj%z /= 15) error stop "'obj%z' is deep copy and not pointer."
nullify (obj%z)
if (.not. allocated(i)) error stop "'i' should still be allocated."
if (associated(obj%z)) error stop "'obj%z' should not be associated anymore."
obj%z => i
call f(obj)
! One can not say anything about i here. The memory should be deallocated, but
! the pointer in i is still set.
if (associated(obj%z)) error stop "'obj%z' should not be associated anymore."
contains
subroutine f(x)
type(t) :: x[*]
if ( associated(x%z) ) deallocate(x%z)
end subroutine
end program

36
gcc/testsuite/gfortran.dg/coarray/ptr_comp_2.f08 Normal file
View File

@ -0,0 +1,36 @@
! { dg-do run }
program ptr_comp
type t
integer, pointer :: z(:)
end type
type(t), save :: obj[*]
integer, allocatable, target :: i(:)[:]
if (associated(obj%z)) error stop "'z' should not be associated yet."
allocate (obj%z(5))
call f(obj)
if (associated(obj%z)) error stop "'z' should not be associated anymore."
allocate(i(7)[*], SOURCE=42)
obj%z => i
if (.not. allocated(i)) error stop "'i' no longer allocated."
i = 15
if (any(obj%z(:) /= 15)) error stop "'obj%z' is deep copy and not pointer."
nullify (obj%z)
if (.not. allocated(i)) error stop "'i' should still be allocated."
if (associated(obj%z)) error stop "'obj%z' should not be associated anymore."
obj%z => i
call f(obj)
! One can not say anything about i here. The memory should be deallocated, but
! the pointer in i is still set.
if (associated(obj%z)) error stop "'obj%z' should not be associated anymore."
contains
subroutine f(x)
type(t) :: x[*]
if ( associated(x%z) ) deallocate(x%z)
end subroutine
end program

22
gcc/testsuite/gfortran.dg/coarray/ptr_comp_3.f08 Normal file
View File

@ -0,0 +1,22 @@
! { dg-do run }
! Contributed by Damian Rouson
! Same like coarray/alloc_comp_4
program main
implicit none
type mytype
integer, pointer :: indices(:)
end type
type(mytype), save :: object[*]
integer :: me
me=this_image()
allocate(object%indices(me))
object%indices = 42
if ( any( object[me]%indices(:) /= 42 ) ) call abort()
end program

20
gcc/testsuite/gfortran.dg/coarray/ptr_comp_4.f08 Normal file
View File

@ -0,0 +1,20 @@
! { dg-do run }
! Same like coarray/alloc_comp_5 but for pointer comp.
program Jac
type Domain
integer :: n=64
integer, pointer :: endsi(:)
end type
type(Domain),allocatable :: D[:,:,:]
allocate(D[2,2,*])
allocate(D%endsi(2), source = 0)
! No caf-runtime call needed her.
D%endsi(2) = D%n
if (any(D%endsi /= [ 0, 64])) error stop
deallocate(D%endsi)
deallocate(D)
end program

99
gcc/testsuite/gfortran.dg/coarray_ptr_comp_1.f08 Normal file
View File

@ -0,0 +1,99 @@
! { dg-do run }
! { dg-options "-fcoarray=lib -lcaf_single" }
! { dg-additional-options "-latomic" { target libatomic_available } }
! Contributed by Damian Rouson
! Check the new _caf_get_by_ref()-routine.
! Same like coarray_alloc_comp_1 but for pointers.
program main
implicit none
type :: mytype
integer :: i
integer, pointer :: indices(:)
real, dimension(2,5,3) :: volume
integer, pointer :: scalar
integer :: j
integer, pointer :: matrix(:,:)
real, pointer :: dynvol(:,:,:)
end type
type arrtype
type(mytype), pointer :: vec(:)
type(mytype), pointer :: mat(:,:)
end type arrtype
type(mytype), save :: object[*]
type(arrtype), save :: bar[*]
integer :: i,j,me,neighbor
integer :: idx(5)
real, allocatable :: volume(:,:,:), vol2(:,:,:)
real, target :: vol_static(2,5,3)
idx = (/ 1,2,1,7,5 /)
me=this_image()
allocate(object%indices, source=[(i,i=1,5)])
allocate(object%scalar, object%matrix(10,7))
object%i = 37
object%scalar = 42
vol_static = reshape([(i, i=1, 2*5*3)], [2, 5, 3])
object%volume = vol_static
object%matrix = reshape([(i, i=1, 70)], [10, 7])
object%dynvol => vol_static
sync all
neighbor = merge(1,neighbor,me==num_images())
if (object[neighbor]%scalar /= 42) call abort()
if (object[neighbor]%indices(4) /= 4) call abort()
if (object[neighbor]%matrix(3,6) /= 53) call abort()
if (any( object[neighbor]%indices(:) /= [1,2,3,4,5] )) call abort()
if (any( object[neighbor]%matrix(:,:) /= reshape([(i, i=1, 70)], [10, 7]))) call abort()
if (any( object[neighbor]%matrix(3,:) /= [(i * 10 + 3, i=0, 6)])) call abort()
if (any( object[neighbor]%matrix(:,2) /= [(i + 10, i=1, 10)])) call abort()
if (any( object[neighbor]%matrix(idx,2) /= [11, 12, 11, 17, 15])) call abort()
if (any( object[neighbor]%matrix(3,idx) /= [3, 13, 3, 63, 43])) call abort()
if (any( object[neighbor]%matrix(2:8:4, 5:1:-1) /= reshape([42, 46, 32, 36, 22, 26, 12, 16, 2, 6], [2,5]))) call abort()
if (any( object[neighbor]%matrix(:8:4, 2::2) /= reshape([11, 15, 31, 35, 51, 55], [2,3]))) call abort()
if (any( object[neighbor]%volume /= vol_static)) call abort()
if (any( object[neighbor]%dynvol /= vol_static)) call abort()
if (any( object[neighbor]%volume(:, 2:4, :) /= vol_static(:, 2:4, :))) call abort()
if (any( object[neighbor]%dynvol(:, 2:4, :) /= vol_static(:, 2:4, :))) call abort()
vol2 = vol_static(:, ::2, :)
if (any( object[neighbor]%volume(:, ::2, :) /= vol2)) call abort()
if (any( object[neighbor]%dynvol(:, ::2, :) /= vol2)) call abort()
allocate(bar%vec(-2:2))
bar%vec(1)%volume = vol_static
if (any(bar[neighbor]%vec(1)%volume /= vol_static)) call abort()
i = 15
allocate(bar%vec(1)%scalar, bar%vec(0)%scalar)
bar%vec(1)%scalar = i
if (.not. associated(bar%vec(1)%scalar)) call abort()
if (bar[neighbor]%vec(1)%scalar /= 15) call abort()
bar%vec(0)%scalar = 27
if (.not. associated(bar%vec(0)%scalar)) call abort()
if (bar[neighbor]%vec(0)%scalar /= 27) call abort()
allocate(bar%vec(1)%indices(3), bar%vec(2)%indices(5))
bar%vec(1)%indices = [ 3, 4, 15 ]
bar%vec(2)%indices = 89
if (.not. associated(bar%vec(1)%indices)) call abort()
if (associated(bar%vec(-2)%indices)) call abort()
if (associated(bar%vec(-1)%indices)) call abort()
if (associated(bar%vec( 0)%indices)) call abort()
if (.not. associated(bar%vec( 2)%indices)) call abort()
if (any(bar[me]%vec(2)%indices /= 89)) call abort()
if (any (bar[neighbor]%vec(1)%indices /= [ 3,4,15])) call abort()
deallocate(bar%vec(2)%indices, bar%vec(1)%indices, bar%vec(1)%scalar, bar%vec(0)%scalar)
deallocate(object%indices, object%scalar, object%matrix)
deallocate(bar%vec)
end program

88
gcc/testsuite/gfortran.dg/coarray_ptr_comp_2.f08 Normal file
View File

@ -0,0 +1,88 @@
! { dg-do run }
! { dg-options "-fcoarray=lib -lcaf_single" }
! { dg-additional-options "-latomic" { target libatomic_available } }
! Contributed by Damian Rouson
! Check the new _caf_send_by_ref()-routine.
! Same as coarray_alloc_comp_2 but for pointers.
program main
implicit none
type :: mytype
integer :: i
integer, pointer :: indices(:)
real, dimension(2,5,3) :: volume
integer, pointer :: scalar
integer :: j
integer, pointer :: matrix(:,:)
real, pointer :: dynvol(:,:,:)
end type
type arrtype
type(mytype), pointer :: vec(:)
type(mytype), pointer :: mat(:,:)
end type arrtype
type(mytype), save :: object[*]
type(arrtype), save :: bar[*]
integer :: i,j,me,neighbor
integer :: idx(5)
real, allocatable :: volume(:,:,:), vol2(:,:,:)
real :: vol_static(2,5,3)
idx = (/ 1,2,1,7,5 /)
me=this_image()
neighbor = merge(1,me+1,me==num_images())
allocate(object%indices(5), object%scalar, object%matrix(10,7), object%dynvol(2,5,3))
object[neighbor]%indices=[(i,i=1,5)]
object[neighbor]%i = 37
object[neighbor]%scalar = 42
vol_static = reshape([(i, i=1, 2*5*3)], [2, 5, 3])
object[neighbor]%volume = vol_static
object[neighbor]%matrix = reshape([(i, i=1, 70)], [10, 7])
object[neighbor]%dynvol = vol_static
sync all
if (object%scalar /= 42) call abort()
if (any( object%indices /= [1,2,3,4,5] )) call abort()
if (any( object%matrix /= reshape([(i, i=1, 70)], [10, 7]))) call abort()
if (any( object%volume /= vol_static)) call abort()
if (any( object%dynvol /= vol_static)) call abort()
vol2 = vol_static
vol2(:, ::2, :) = 42
object[neighbor]%volume(:, ::2, :) = 42
object[neighbor]%dynvol(:, ::2, :) = 42
if (any( object%volume /= vol2)) call abort()
if (any( object%dynvol /= vol2)) call abort()
allocate(bar%vec(-2:2))
bar[neighbor]%vec(1)%volume = vol_static
if (any(bar%vec(1)%volume /= vol_static)) call abort()
allocate(bar%vec(1)%scalar, bar%vec(0)%scalar, bar%vec(1)%indices(3))
i = 15
bar[neighbor]%vec(1)%scalar = i
if (.not. associated(bar%vec(1)%scalar)) call abort()
if (bar%vec(1)%scalar /= 15) call abort()
bar[neighbor]%vec(0)%scalar = 27
if (.not. associated(bar%vec(0)%scalar)) call abort()
if (bar%vec(0)%scalar /= 27) call abort()
bar[neighbor]%vec(1)%indices = [ 3, 4, 15 ]
allocate(bar%vec(2)%indices(5))
bar[neighbor]%vec(2)%indices = 89
if (.not. associated(bar%vec(1)%indices)) call abort()
if (associated(bar%vec(-2)%indices)) call abort()
if (associated(bar%vec(-1)%indices)) call abort()
if (associated(bar%vec( 0)%indices)) call abort()
if (.not. associated(bar%vec( 2)%indices)) call abort()
if (any(bar%vec(2)%indices /= 89)) call abort()
if (any (bar%vec(1)%indices /= [ 3,4,15])) call abort()
end program

13
gcc/testsuite/gfortran.dg/coarray_ptr_comp_3.f08 Normal file
View File

@ -0,0 +1,13 @@
! { dg-do compile }
! { dg-options "-fcoarray=lib" }
program ptr_comp
type t
integer, pointer :: z(:)
end type
type(t), save :: obj[*]
integer, allocatable, target :: i(:)[:]
obj%z => i(:)[4] ! { dg-error "shall not have a coindex" }
end program

7
libgfortran/ChangeLog
View File

@ -1,3 +1,10 @@
2017-01-07 Andre Vehreschild <vehre@gcc.gnu.org>
PR fortran/78781
PR fortran/78935
* caf/single.c (send_by_ref): Fix addressing of non-allocatable scalar
destination components.
2017-01-01 Jakub Jelinek <jakub@redhat.com>
Update copyright years.

21
libgfortran/caf/single.c
View File

@ -1953,11 +1953,24 @@ send_by_ref (caf_reference_t *ref, size_t *i, size_t *src_index,
}
else
{
ds = GFC_DESCRIPTOR_DATA (dst);
dst_type = GFC_DESCRIPTOR_TYPE (dst);
single_token = *(caf_single_token_t *)
(ds + ref->u.c.caf_token_offset);
dst = single_token->desc;
if (dst)
{
ds = GFC_DESCRIPTOR_DATA (dst);
dst_type = GFC_DESCRIPTOR_TYPE (dst);
}
else
{
/* When no destination descriptor is present, assume that
source and dest type are identical. */
dst_type = GFC_DESCRIPTOR_TYPE (src);
ds = *(void **)(ds + ref->u.c.offset);
}
}
copy_data (ds, sr, dst_type, GFC_DESCRIPTOR_TYPE (src),
dst_kind, src_kind, ref->item_size, src_size, 1, stat);
dst_kind, src_kind, ref->item_size, src_size, 1, stat);
}
else
copy_data (ds + ref->u.c.offset, sr,
@ -2055,7 +2068,7 @@ send_by_ref (caf_reference_t *ref, size_t *i, size_t *src_index,
return;
}
/* Only when on the left most index switch the data pointer to
the array's data pointer. And only for non-static arrays. */
the array's data pointer. And only for non-static arrays. */
if (dst_dim == 0 && ref->type != CAF_REF_STATIC_ARRAY)
ds = GFC_DESCRIPTOR_DATA (dst);
switch (ref->u.a.mode[dst_dim])