From patchwork Sat Jan 7 17:27:34 2017 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 8bit X-Patchwork-Submitter: Andre Vehreschild X-Patchwork-Id: 90287 Delivered-To: patch@linaro.org Received: by 10.140.20.101 with SMTP id 92csp183632qgi; Sat, 7 Jan 2017 09:28:19 -0800 (PST) X-Received: by 10.98.215.85 with SMTP id v21mr76446914pfl.80.1483810099164; Sat, 07 Jan 2017 09:28:19 -0800 (PST) Return-Path: Received: from sourceware.org (server1.sourceware.org. [209.132.180.131]) by mx.google.com with ESMTPS id 130si83374256pgb.271.2017.01.07.09.28.18 for (version=TLS1_2 cipher=ECDHE-RSA-AES128-GCM-SHA256 bits=128/128); Sat, 07 Jan 2017 09:28:19 -0800 (PST) Received-SPF: pass (google.com: domain of gcc-patches-return-445619-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-445619-patch=linaro.org@gcc.gnu.org designates 209.132.180.131 as permitted sender) smtp.mailfrom=gcc-patches-return-445619-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:cc:subject:message-id:in-reply-to:references :mime-version:content-type; q=dns; s=default; b=NMBdsG3JMkvjG+IM OhPLRWwZoZEjnnZO5NA+QlNN3Qjy3RbkodHLeS9E8Uy1BvNe2o4s+mOcCnabrKTJ NLcQz5HddJPrtrnUGSsXq7VolfxlEAHrYH7YuALwTuBHTr3+3K/6hoxD5N5cupTH mfySO5vJScXYaMzFC4HFE6TBG5g= 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:cc:subject:message-id:in-reply-to:references :mime-version:content-type; s=default; bh=uECmMeDnH/Jw8fPW25TIuI uyMqQ=; b=ZH3uFJj70aL3XU3EnI+VDSCYsiqKoowaQYvLOjkPHvUp1r+FbU2V68 n3IJL43x7xyUK/14mmakTYG8rJfv2rt2cLdpGMAt7Dt3TcrQ/rB0oCJd3P3M8iX3 e8KaVhxCF8DWtPePwfeuELRt9s2MnV9lRq9ftTOSi/fowl8VA4Y6A= Received: (qmail 46802 invoked by alias); 7 Jan 2017 17:27:57 -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 46665 invoked by uid 89); 7 Jan 2017 17:27:56 -0000 Authentication-Results: sourceware.org; auth=none X-Virus-Found: No X-Spam-SWARE-Status: No, score=-1.7 required=5.0 tests=AWL, BAYES_00, FREEMAIL_FROM, KAM_ASCII_DIVIDERS, KAM_STOCKGEN, RCVD_IN_DNSWL_LOW, SPF_PASS autolearn=no version=3.3.2 spammy=nicht, paul.richard.thomas@gmail.com, paulrichardthomasgmailcom, sk:acsawde X-Spam-User: qpsmtpd, 2 recipients X-HELO: mout.gmx.net Received: from mout.gmx.net (HELO mout.gmx.net) (212.227.17.22) by sourceware.org (qpsmtpd/0.93/v0.84-503-g423c35a) with ESMTP; Sat, 07 Jan 2017 17:27:46 +0000 Received: from vepi2 ([92.76.205.227]) by mail.gmx.com (mrgmx101 [212.227.17.168]) with ESMTPSA (Nemesis) id 0M2XkX-1ciXYY34uz-00sOaL; Sat, 07 Jan 2017 18:27:36 +0100 Date: Sat, 7 Jan 2017 18:27:34 +0100 From: Andre Vehreschild To: Paul Richard Thomas Cc: Dominique =?UTF-8?B?ZCdIdW1pw6hyZXM=?= , GCC-Fortran-ML , GCC-Patches-ML Subject: Re: Ping! Re: [PATCH, Fortran, pr78781, v1] [7 Regression] [Coarray] ICE in gfc_deallocate_scalar_with_status, at fortran/trans.c:1588 Message-ID: <20170107182734.015c61ed@vepi2> In-Reply-To: References: MIME-Version: 1.0 X-UI-Out-Filterresults: notjunk:1; V01:K0:kZ8canROFrc=:w9w+5HK23CCJd64E0ynVVS OVmA6sCaDohiEJJu57Gt2SHQ7aQ/ZwovdlDQmdCFF9Aro5DJ9iHWlryKXStCh3pvw1Xv+MGGW myz4f7+PsAypg0e7jFImZUXp4UiO+zGwlw0NbqkKUPzqfcXbXSvGTyaxihWhl/TvhXpg3QKo2 SPipnVUu6XXYkf49txgGCdCX3hSQdZa/imPcz8BsJFC+R27YfKjaqaqlokYqR/icu2MrFUdaJ CSvbYFYK9ey4gsD/emMQKDDQR6pXyarCpjt7hfDMyTo3ZPlKbict7/0HS2ZcmtELyDeifCVMS Hpq9NVUa9zaHQ/M2udSGO3jF5CgCQ2b3zGacwkkj1GAI/KCdRjccfNmeUWqIOoLNMuw80lIDr 3V/FbgVGGkfbseHGWu0x9iRWUn5J9EVfusSaZ20uP5u/m8aVst5WKzEHyMJuihgHRe2kyUJWp LFHXSZFnhZ8hZzi15aRhGjHtNygn++p6mn9je1usJVwEx3uKEkByXkNfw1C1d+6flbZetQXOd Rtn/WdpHqgbBQgmr56+RW05eATh9bhiTBfRqX4KVqtue0DRwExWxpCrHkEcN0Lacz3sy+yPHq tQHH785wwjq0A1pt9IVwv+YRWiCul+s1egvaeAISDV21hd2ybdwosw0o3jibFc06YRSrNMNf9 qGfBDr1skqZdu9nNoX+aaHIahRgRi6gQ0DkTlFWufzOc8JIs8m1UHK7KDK9rhUiXSEHk076p9 J4Q0SICml2uCPAzjLCEI4/afjYIivXtnPQy3fuBQXbusoPltbwvpcKh9bsVutuLJWVGOY3MZn BjgUxdU14GjKjQwFixu7cBAeGKgb6vPZeJo0mYXwtPIim+KMiCklJLAapyLiefrxFfbWEC+HQ R4x4d4jak5DAAYfQT2YZpV6VZC985AtaYbUl7LcEdw7zBeXugaKg2JIwZA3p84iMWu2KxC4vM +FW/a2DH0svFhb6wApEu80BLoPOHLHcWlUqhpntg6PKlJptb1HhDIfiVqWaAZGh8P0NH2m2y7 aw== Hi Paul, thanks for review. Committed as r244196. Best regards and happy new year to you, Andre On Sat, 7 Jan 2017 15:06:20 +0100 Paul Richard Thomas wrote: > Hi Andre and Dominique, > > Apart from s/allows there allocation/allows their allocation/ this is > OK for trunk. > > Given the scale of the patch, can this really be a regression? > > Thanks > > Paul > > > On 7 January 2017 at 13:47, Dominique d'Humières wrote: > > I have this patch in my working tree and it works as expected. > > > >> Also fixes pr78935. > > > > Confirmed. > > > > Thanks for the patch, > > > > Dominique > > > > > -- Andre Vehreschild * Email: vehre ad gmx dot de Index: gcc/fortran/ChangeLog =================================================================== --- gcc/fortran/ChangeLog (Revision 244195) +++ gcc/fortran/ChangeLog (Arbeitskopie) @@ -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 Index: gcc/fortran/expr.c =================================================================== --- gcc/fortran/expr.c (Revision 244195) +++ gcc/fortran/expr.c (Arbeitskopie) @@ -3708,9 +3708,20 @@ 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; } Index: gcc/fortran/gfortran.h =================================================================== --- gcc/fortran/gfortran.h (Revision 244195) +++ gcc/fortran/gfortran.h (Arbeitskopie) @@ -2836,7 +2836,7 @@ 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; Index: gcc/fortran/primary.c =================================================================== --- gcc/fortran/primary.c (Revision 244195) +++ gcc/fortran/primary.c (Arbeitskopie) @@ -2436,8 +2436,7 @@ 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 @@ 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 @@ 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 @@ attr.target = target; attr.save = sym->attr.save; attr.coarray_comp = coarray_comp; - attr.alloc_comp = alloc_comp; return attr; } @@ -2575,6 +2576,8 @@ 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) Index: gcc/fortran/trans-array.c =================================================================== --- gcc/fortran/trans-array.c (Revision 244195) +++ gcc/fortran/trans-array.c (Arbeitskopie) @@ -5469,7 +5469,8 @@ 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 @@ { 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,14 +5607,16 @@ 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) @@ -5613,6 +5623,11 @@ 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,55 +8426,64 @@ 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)) + /* 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, 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 = 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); } @@ -8476,6 +8500,9 @@ 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 @@ 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 @@ 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); } Index: gcc/fortran/trans-array.h =================================================================== --- gcc/fortran/trans-array.h (Revision 244195) +++ gcc/fortran/trans-array.h (Arbeitskopie) @@ -49,7 +49,7 @@ 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); Index: gcc/fortran/trans-decl.c =================================================================== --- gcc/fortran/trans-decl.c (Revision 244195) +++ gcc/fortran/trans-decl.c (Arbeitskopie) @@ -5147,6 +5147,13 @@ 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); + } } Index: gcc/fortran/trans-expr.c =================================================================== --- gcc/fortran/trans-expr.c (Revision 244195) +++ gcc/fortran/trans-expr.c (Arbeitskopie) @@ -7506,7 +7506,8 @@ 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 @@ 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_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); } Index: gcc/fortran/trans-intrinsic.c =================================================================== --- gcc/fortran/trans-intrinsic.c (Revision 244195) +++ gcc/fortran/trans-intrinsic.c (Arbeitskopie) @@ -1123,7 +1123,8 @@ 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 @@ 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 @@ /* 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 @@ /* 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 @@ 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 @@ 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 @@ 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 @@ 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 @@ 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); Index: gcc/fortran/trans-stmt.c =================================================================== --- gcc/fortran/trans-stmt.c (Revision 244195) +++ gcc/fortran/trans-stmt.c (Arbeitskopie) @@ -6299,6 +6299,40 @@ 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 @@ 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 @@ 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) { Index: gcc/fortran/trans-types.c =================================================================== --- gcc/fortran/trans-types.c (Revision 244195) +++ gcc/fortran/trans-types.c (Arbeitskopie) @@ -1050,7 +1050,7 @@ /* 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 @@ 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 @@ 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 @@ /* 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_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 @@ /* 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 @@ 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_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,8 +1807,7 @@ 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; @@ -1818,13 +1814,11 @@ 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 @@ 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 @@ 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 @@ 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 @@ !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 @@ 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); Index: gcc/fortran/trans-types.h =================================================================== --- gcc/fortran/trans-types.h (Revision 244195) +++ gcc/fortran/trans-types.h (Arbeitskopie) @@ -70,7 +70,7 @@ 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_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. */ Index: gcc/fortran/trans.c =================================================================== --- gcc/fortran/trans.c (Revision 244195) +++ gcc/fortran/trans.c (Arbeitskopie) @@ -1302,8 +1302,7 @@ 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_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, Index: gcc/testsuite/ChangeLog =================================================================== --- gcc/testsuite/ChangeLog (Revision 244195) +++ gcc/testsuite/ChangeLog (Arbeitskopie) @@ -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. Index: gcc/testsuite/gfortran.dg/coarray/ptr_comp_1.f08 =================================================================== --- gcc/testsuite/gfortran.dg/coarray/ptr_comp_1.f08 (nicht existent) +++ gcc/testsuite/gfortran.dg/coarray/ptr_comp_1.f08 (Arbeitskopie) @@ -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 + Index: gcc/testsuite/gfortran.dg/coarray/ptr_comp_2.f08 =================================================================== --- gcc/testsuite/gfortran.dg/coarray/ptr_comp_2.f08 (nicht existent) +++ gcc/testsuite/gfortran.dg/coarray/ptr_comp_2.f08 (Arbeitskopie) @@ -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 + Index: gcc/testsuite/gfortran.dg/coarray/ptr_comp_3.f08 =================================================================== --- gcc/testsuite/gfortran.dg/coarray/ptr_comp_3.f08 (nicht existent) +++ gcc/testsuite/gfortran.dg/coarray/ptr_comp_3.f08 (Arbeitskopie) @@ -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 Index: gcc/testsuite/gfortran.dg/coarray/ptr_comp_4.f08 =================================================================== --- gcc/testsuite/gfortran.dg/coarray/ptr_comp_4.f08 (nicht existent) +++ gcc/testsuite/gfortran.dg/coarray/ptr_comp_4.f08 (Arbeitskopie) @@ -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 + Index: gcc/testsuite/gfortran.dg/coarray_ptr_comp_1.f08 =================================================================== --- gcc/testsuite/gfortran.dg/coarray_ptr_comp_1.f08 (nicht existent) +++ gcc/testsuite/gfortran.dg/coarray_ptr_comp_1.f08 (Arbeitskopie) @@ -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 Index: gcc/testsuite/gfortran.dg/coarray_ptr_comp_2.f08 =================================================================== --- gcc/testsuite/gfortran.dg/coarray_ptr_comp_2.f08 (nicht existent) +++ gcc/testsuite/gfortran.dg/coarray_ptr_comp_2.f08 (Arbeitskopie) @@ -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 Index: gcc/testsuite/gfortran.dg/coarray_ptr_comp_3.f08 =================================================================== --- gcc/testsuite/gfortran.dg/coarray_ptr_comp_3.f08 (nicht existent) +++ gcc/testsuite/gfortran.dg/coarray_ptr_comp_3.f08 (Arbeitskopie) @@ -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 + Index: libgfortran/ChangeLog =================================================================== --- libgfortran/ChangeLog (Revision 244195) +++ libgfortran/ChangeLog (Arbeitskopie) @@ -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. Index: libgfortran/caf/single.c =================================================================== --- libgfortran/caf/single.c (Revision 244195) +++ libgfortran/caf/single.c (Arbeitskopie) @@ -1953,11 +1953,24 @@ } 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 @@ 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])