+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
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;
}
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;
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;
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
{
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;
attr.target = target;
attr.save = sym->attr.save;
attr.coarray_comp = coarray_comp;
- attr.alloc_comp = alloc_comp;
return attr;
}
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)
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;
{
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;
}
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);
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)
+ /* 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 scalar components. */
+ /* Allocatable CLASS 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 = gfc_class_data_get (comp);
+ if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (comp)))
+ gfc_conv_descriptor_data_set (&fnblock, comp,
+ null_pointer_node);
+ else
{
- 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,
+ void_type_node, 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)
+ /* Coarrays need the component to be nulled before the api-call
+ is made. */
+ else if (c->attr.pointer || c->attr.allocatable)
{
- /* Allocatable CLASS components. */
comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
decl, cdecl, NULL_TREE);
-
- comp = gfc_class_data_get (comp);
- if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (comp)))
- gfc_conv_descriptor_data_set (&fnblock, comp, null_pointer_node);
+ 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,
- void_type_node, comp,
+ TREE_TYPE (comp), comp,
build_int_cst (TREE_TYPE (comp), 0));
gfc_add_expr_to_block (&fnblock, tmp);
}
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);
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),
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);
}
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);
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);
+ }
}
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;
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
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);
}
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. */
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;
/* 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;
/* 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);
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);
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);
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;
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);
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);
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
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);
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)
{
/* 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;
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;
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];
/* 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++)
: 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);
}
\f
/* Returns the struct descriptor_dimension type. */
/* 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];
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"),
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;
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);
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;
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)
{
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
!c->attr.target
&& !c->attr.pointer,
c->attr.contiguous,
- in_coarray);
+ codimen);
}
else
field_type = gfc_get_nodesc_array_type (field_type, c->as,
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);
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 *);
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. */
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)
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,
+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.
--- /dev/null
+! { 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
+
--- /dev/null
+! { 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
+
--- /dev/null
+! { 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
--- /dev/null
+! { 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
+
--- /dev/null
+! { 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
--- /dev/null
+! { 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
--- /dev/null
+! { 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
+
+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.
}
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,
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])
git://gcc.gnu.org / gcc.git / commitdiff