From patchwork Wed Dec 28 19:31:16 2016 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Andre Vehreschild X-Patchwork-Id: 89200 Delivered-To: patch@linaro.org Received: by 10.140.20.101 with SMTP id 92csp5672061qgi; Wed, 28 Dec 2016 11:31:45 -0800 (PST) X-Received: by 10.84.136.164 with SMTP id 33mr55728635pll.53.1482953505403; Wed, 28 Dec 2016 11:31:45 -0800 (PST) Return-Path: Received: from sourceware.org (server1.sourceware.org. [209.132.180.131]) by mx.google.com with ESMTPS id h26si50975189pfh.56.2016.12.28.11.31.45 for (version=TLS1_2 cipher=ECDHE-RSA-AES128-GCM-SHA256 bits=128/128); Wed, 28 Dec 2016 11:31:45 -0800 (PST) Received-SPF: pass (google.com: domain of gcc-patches-return-445094-patch=linaro.org@gcc.gnu.org designates 209.132.180.131 as permitted sender) client-ip=209.132.180.131; Authentication-Results: mx.google.com; dkim=pass header.i=@gcc.gnu.org; spf=pass (google.com: domain of gcc-patches-return-445094-patch=linaro.org@gcc.gnu.org designates 209.132.180.131 as permitted sender) smtp.mailfrom=gcc-patches-return-445094-patch=linaro.org@gcc.gnu.org DomainKey-Signature: a=rsa-sha1; c=nofws; d=gcc.gnu.org; h=list-id :list-unsubscribe:list-archive:list-post:list-help:sender:date :from:to:subject:message-id:mime-version:content-type; q=dns; s= default; b=ZUqv4BDrOmT/iLCwBJi2rY5qqnbr11Ma/LNeROmkJ7HxHF6LV8goZ 5CGZ6aTbmg94+qe5qwzrQmRrqs9GL+69ZukAN6cd9Zq2hDy30pA/OkuqVGQjyVa1 wHYHwozVmo3T5F/KNitvju/d2yuptgY31jIRZovG6xAkM+Xqdcge+Y= DKIM-Signature: v=1; a=rsa-sha1; c=relaxed; d=gcc.gnu.org; h=list-id :list-unsubscribe:list-archive:list-post:list-help:sender:date :from:to:subject:message-id:mime-version:content-type; s= default; bh=yX4o7WSM2gVBAOIkyapFzA6kp4M=; b=siIgl1Gg7vlr7eiuRu5H 5D0YnmQc/Gjx32V8Olix5QuR4wcbZr8JwKTcNgwfJCFgXVNUk2JnDCAIAdGX+bXd GFgPN7BjdZX1NbnsibMRaoaSejg9gD0RmhmFo5XE5DpDfgTyaxqP4HMW7YZPBz62 4V2wyedvxkq/IX0jEU2UGCI= Received: (qmail 54246 invoked by alias); 28 Dec 2016 19:31:29 -0000 Mailing-List: contact gcc-patches-help@gcc.gnu.org; run by ezmlm Precedence: bulk List-Id: List-Unsubscribe: List-Archive: List-Post: List-Help: Sender: gcc-patches-owner@gcc.gnu.org Delivered-To: mailing list gcc-patches@gcc.gnu.org Received: (qmail 54224 invoked by uid 89); 28 Dec 2016 19:31:28 -0000 Authentication-Results: sourceware.org; auth=none X-Virus-Found: No X-Spam-SWARE-Status: No, score=-0.7 required=5.0 tests=AWL, BAYES_40, FREEMAIL_FROM, KAM_STOCKGEN, RCVD_IN_DNSWL_LOW, SPF_PASS autolearn=ham version=3.3.2 spammy=rtype, Convert, tokens, mat X-Spam-User: qpsmtpd, 2 recipients X-HELO: mout.gmx.net Received: from mout.gmx.net (HELO mout.gmx.net) (212.227.15.18) by sourceware.org (qpsmtpd/0.93/v0.84-503-g423c35a) with ESMTP; Wed, 28 Dec 2016 19:31:22 +0000 Received: from vepi2 ([92.76.205.227]) by mail.gmx.com (mrgmx003 [212.227.17.190]) with ESMTPSA (Nemesis) id 0LwZtX-1cbg9D3qU3-018NEs; Wed, 28 Dec 2016 20:31:17 +0100 Date: Wed, 28 Dec 2016 20:31:16 +0100 From: Andre Vehreschild To: GCC-Patches-ML , GCC-Fortran-ML Subject: [PATCH, Fortran, pr78781, v1] [7 Regression] [Coarray] ICE in gfc_deallocate_scalar_with_status, at fortran/trans.c:1588 Message-ID: <20161228203116.5f0cd2e2@vepi2> MIME-Version: 1.0 X-UI-Out-Filterresults: notjunk:1; V01:K0:7/KMRO6TR1g=:b5vPNnpqHtuLDpgCufvhRn stwQS6WMy7SBIC81SgETMg9XPJQfAiiFCi64oi+fsD8K6ejkvBNUuSJ4ApQ/6eEnvsoyhVB9w AWpu5ybNDzoWCv/b4KIhF6uGVSvKcmNGbINZff1IFwDLytZSJByFZoSt+F9hUS8Bb/sPjz6iX uWC9R8s7/W0Co9QxCLXJGWEed0yZtmrB3CA+MtXNLVv78kvKkwQCKx+f5vlBrCQP+coQ14Wd2 oDWEwzA8oLow0OW2BlBp2qTOXutCJXxuM0IcrvJoHefVG8Sq9ASfCj7Hb+leeecT/J/pypNP/ KMBsI4p/RUP6pDAeD30SHxwa+tmij9KZp4VkZosQ0A13lWQzV4kes+eXpxza0BOgCgXRBwong 804cbH1zRsUMY6wCqsic6D7o/JgD1bldsCxuknhEjwHRWY6g7YeynfVKgL7F4TbQIM+xmi7fa Y49fIUuHgmHOyMTX4w+JhOHZH3H4MbAJcrEpDWsQCS8WN+kXktsZuqHkSookQ+wyQkasXrriq H0zoq507MXJYtOMM8TkQ0VPyhm10WUqNc4U9RTX2JYbM7gitqqoUhC7w9yQCqzp7fy678Ofmb 4srP5M439TR2BGYkpU9dpRqo4WxLBrdu2rOt6jN1+POlQpJMluU3T2FnoQXzIuitYEH/UTDTx EOHde2my3xhI+ZxMygb05nj6sTRjTZYhrzYGQGni1L/RdCo8DuN1fXa4bqYWHwo08u8jYkp0V b8YIgb/ltKH4nP6hOYT6q467qIYyjkKeU70AAMh1RLVn1gdVcEXHv+Zy3Yo= Hi all, attached patch fixes and implements pointer components in derived typed coarrays. The testcase in the description also has a class coarray, which is still not implemented but tracked by pr77961. Therefore only the test in comment #2 now passes. Bootstraps and regtests ok on x86_64-linux/f23. Ok for trunk? Regards, Andre -- Andre Vehreschild * Email: vehre ad gmx dot de diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c index d351d0f..8ed2f23 100644 --- a/gcc/fortran/expr.c +++ b/gcc/fortran/expr.c @@ -3734,9 +3734,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 200b419..39135bf 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -2846,7 +2846,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 f13b0f0..eb3dc0e 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 c559d0e..8a2b80e 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -5468,7 +5468,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; @@ -5482,10 +5483,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; } @@ -5598,20 +5606,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); @@ -8410,55 +8425,64 @@ 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) + /* 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); } @@ -8475,6 +8499,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); @@ -8493,10 +8520,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), @@ -8710,11 +8733,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 ab0a6de..1a7004e 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 fe07038..4965bf8 100644 --- a/gcc/fortran/trans-decl.c +++ b/gcc/fortran/trans-decl.c @@ -5150,6 +5150,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 4032f3c..e212f15 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -7513,7 +7513,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; @@ -8128,6 +8129,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 @@ -8248,6 +8295,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 bd2b212..1e6c2f6 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 6741683..ac128df 100644 --- a/gcc/fortran/trans-stmt.c +++ b/gcc/fortran/trans-stmt.c @@ -6301,6 +6301,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 there 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 @@ -6445,7 +6479,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); @@ -6455,15 +6490,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 8dbc9ce..1417ada 100644 --- a/gcc/fortran/trans-types.c +++ b/gcc/fortran/trans-types.c @@ -1057,7 +1057,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; @@ -1110,7 +1110,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; @@ -1314,7 +1314,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]; @@ -1322,10 +1322,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++) @@ -1363,8 +1363,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. */ @@ -1726,8 +1726,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]; @@ -1789,8 +1788,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"), @@ -1802,8 +1800,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; @@ -1817,21 +1814,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); @@ -2423,7 +2417,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; @@ -2575,9 +2569,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) { @@ -2636,7 +2632,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 @@ -2657,7 +2653,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, @@ -2704,9 +2700,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 6328125..7bb0780 100644 --- a/gcc/fortran/trans-types.h +++ b/gcc/fortran/trans-types.h @@ -71,7 +71,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 *); @@ -82,8 +82,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 4222d3a..6157974 100644 --- a/gcc/fortran/trans.c +++ b/gcc/fortran/trans.c @@ -1304,8 +1304,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) @@ -1554,7 +1553,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/gfortran.dg/coarray/ptr_comp_1.f08 b/gcc/testsuite/gfortran.dg/coarray/ptr_comp_1.f08 new file mode 100644 index 0000000..fe70e63 --- /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 0000000..91977ff --- /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 0000000..ad7137f --- /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 0000000..e618921 --- /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 0000000..f0b51d5 --- /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 0000000..d930a82 --- /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 0000000..efdfb36 --- /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/caf/single.c b/libgfortran/caf/single.c index 6d37965..d363a3f 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])