diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 30646921237..f89f9fd9972 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,47 @@ +2017-01-07 Andre Vehreschild + + 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 * simplify.c (simplify_transformation_to_array): Use diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c index 3c221eb67d5..7b95d206c53 100644 --- a/gcc/fortran/expr.c +++ b/gcc/fortran/expr.c @@ -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; } diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index d168138cae9..f01a290e28f 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -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; diff --git a/gcc/fortran/primary.c b/gcc/fortran/primary.c index 25a2829ce3d..d62f6bb1818 100644 --- a/gcc/fortran/primary.c +++ b/gcc/fortran/primary.c @@ -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) diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index 9a755fbf58d..a3aab8e4528 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -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); } diff --git a/gcc/fortran/trans-array.h b/gcc/fortran/trans-array.h index e3df8860aa3..d87a9d88071 100644 --- a/gcc/fortran/trans-array.h +++ b/gcc/fortran/trans-array.h @@ -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); diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c index 979ccdbf6ef..fffb4928f1c 100644 --- a/gcc/fortran/trans-decl.c +++ b/gcc/fortran/trans-decl.c @@ -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); + } } diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index b9c134a11d4..caaee6b42da 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -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); } diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c index a13d3fb3e3f..14781ac4814 100644 --- a/gcc/fortran/trans-intrinsic.c +++ b/gcc/fortran/trans-intrinsic.c @@ -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); diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c index df61bab8304..856008779ba 100644 --- a/gcc/fortran/trans-stmt.c +++ b/gcc/fortran/trans-stmt.c @@ -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) { diff --git a/gcc/fortran/trans-types.c b/gcc/fortran/trans-types.c index a214aae22d8..156c0dac15d 100644 --- a/gcc/fortran/trans-types.c +++ b/gcc/fortran/trans-types.c @@ -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); diff --git a/gcc/fortran/trans-types.h b/gcc/fortran/trans-types.h index 9f1b64f4877..2974e451304 100644 --- a/gcc/fortran/trans-types.h +++ b/gcc/fortran/trans-types.h @@ -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. */ diff --git a/gcc/fortran/trans.c b/gcc/fortran/trans.c index dcbf7c346d3..82ed19ac283 100644 --- a/gcc/fortran/trans.c +++ b/gcc/fortran/trans.c @@ -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, diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 6d2162d547d..0d5aa52cc0a 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,13 @@ +2017-01-07 Andre Vehreschild + + * 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 * gcc.dg/memcmp-1.c: New. * gcc.dg/strncmp-1.c: New. diff --git a/gcc/testsuite/gfortran.dg/coarray/ptr_comp_1.f08 b/gcc/testsuite/gfortran.dg/coarray/ptr_comp_1.f08 new file mode 100644 index 00000000000..fe70e63c32f --- /dev/null +++ b/gcc/testsuite/gfortran.dg/coarray/ptr_comp_1.f08 @@ -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 + diff --git a/gcc/testsuite/gfortran.dg/coarray/ptr_comp_2.f08 b/gcc/testsuite/gfortran.dg/coarray/ptr_comp_2.f08 new file mode 100644 index 00000000000..91977ff1d35 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/coarray/ptr_comp_2.f08 @@ -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 + diff --git a/gcc/testsuite/gfortran.dg/coarray/ptr_comp_3.f08 b/gcc/testsuite/gfortran.dg/coarray/ptr_comp_3.f08 new file mode 100644 index 00000000000..ad7137f009e --- /dev/null +++ b/gcc/testsuite/gfortran.dg/coarray/ptr_comp_3.f08 @@ -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 diff --git a/gcc/testsuite/gfortran.dg/coarray/ptr_comp_4.f08 b/gcc/testsuite/gfortran.dg/coarray/ptr_comp_4.f08 new file mode 100644 index 00000000000..e6189213122 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/coarray/ptr_comp_4.f08 @@ -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 + diff --git a/gcc/testsuite/gfortran.dg/coarray_ptr_comp_1.f08 b/gcc/testsuite/gfortran.dg/coarray_ptr_comp_1.f08 new file mode 100644 index 00000000000..f0b51d5ead1 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/coarray_ptr_comp_1.f08 @@ -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 diff --git a/gcc/testsuite/gfortran.dg/coarray_ptr_comp_2.f08 b/gcc/testsuite/gfortran.dg/coarray_ptr_comp_2.f08 new file mode 100644 index 00000000000..d930a82f8a3 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/coarray_ptr_comp_2.f08 @@ -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 diff --git a/gcc/testsuite/gfortran.dg/coarray_ptr_comp_3.f08 b/gcc/testsuite/gfortran.dg/coarray_ptr_comp_3.f08 new file mode 100644 index 00000000000..efdfb367040 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/coarray_ptr_comp_3.f08 @@ -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 + diff --git a/libgfortran/ChangeLog b/libgfortran/ChangeLog index f86dd33c787..f07dff1b8d6 100644 --- a/libgfortran/ChangeLog +++ b/libgfortran/ChangeLog @@ -1,3 +1,10 @@ +2017-01-07 Andre Vehreschild + + 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 Update copyright years. diff --git a/libgfortran/caf/single.c b/libgfortran/caf/single.c index fa50431db42..cf78a1a48fd 100644 --- a/libgfortran/caf/single.c +++ b/libgfortran/caf/single.c @@ -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])