From patchwork Thu Aug 22 17:41:22 2019 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Alessandro Fanfarillo X-Patchwork-Id: 1151723 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@bilbo.ozlabs.org Authentication-Results: ozlabs.org; spf=pass (mailfrom) smtp.mailfrom=gcc.gnu.org (client-ip=209.132.180.131; helo=sourceware.org; envelope-from=gcc-patches-return-507538-incoming=patchwork.ozlabs.org@gcc.gnu.org; receiver=) Authentication-Results: ozlabs.org; dmarc=fail (p=none dis=none) header.from=gmail.com Authentication-Results: ozlabs.org; dkim=pass (1024-bit key; unprotected) header.d=gcc.gnu.org header.i=@gcc.gnu.org header.b="dd1XZmzJ"; dkim=fail reason="signature verification failed" (2048-bit key; unprotected) header.d=gmail.com header.i=@gmail.com header.b="USfPhUfR"; dkim-atps=neutral Received: from sourceware.org (server1.sourceware.org [209.132.180.131]) (using TLSv1.2 with cipher ECDHE-RSA-AES256-GCM-SHA384 (256/256 bits)) (No client certificate requested) by ozlabs.org (Postfix) with ESMTPS id 46DsKY1FNsz9sSv for ; Fri, 23 Aug 2019 03:41:51 +1000 (AEST) DomainKey-Signature: a=rsa-sha1; c=nofws; d=gcc.gnu.org; h=list-id :list-unsubscribe:list-archive:list-post:list-help:sender :mime-version:from:date:message-id:subject:to:cc:content-type; q=dns; s=default; b=xZ/jSUFtH2SGK8EETHkiwJ2xwzqo08HPPNSDokx56fj cyVrcy2hYU6XZz23sXrb6DCDZXLZkempKBK8h94V5+vfHb1bJAlAQAg99/S2Kp1w HEstsDoUckmNOQBjQ+EDaWWN8SzYojbgm0FEFQLCgQKvDmfwbVGQXQRhg0zYTSfI = 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 :mime-version:from:date:message-id:subject:to:cc:content-type; s=default; bh=SVxqSy2DY2dk4sLswIsfj+XfW7A=; b=dd1XZmzJF5+rAQW/R 5nzgLfzbfQcQvHY4075UwflL1/epZHbYczyiL6sind+uwSIQKyBd6r+cuGa6lFPm pno9XR+Zt5WkVYSKvxNp8xtBXNCHdsaOAynHxLHnMc7LqO0+mtKPRwasR0JbKuO0 MXJDurOFTvxDj4y9JnKSK+BbSE= Received: (qmail 65361 invoked by alias); 22 Aug 2019 17:41:43 -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 64522 invoked by uid 89); 22 Aug 2019 17:41:38 -0000 Authentication-Results: sourceware.org; auth=none X-Spam-SWARE-Status: No, score=-13.2 required=5.0 tests=AWL, BAYES_00, FREEMAIL_FROM, GIT_PATCH_0, GIT_PATCH_1, GIT_PATCH_2, GIT_PATCH_3, KAM_STOCKGEN, RCVD_IN_DNSWL_NONE, SPF_PASS autolearn=ham version=3.3.1 spammy=sk:gfc_act, caf, UD:is_bind_c, gfc_symbol X-HELO: mail-qk1-f174.google.com Received: from mail-qk1-f174.google.com (HELO mail-qk1-f174.google.com) (209.85.222.174) by sourceware.org (qpsmtpd/0.93/v0.84-503-g423c35a) with ESMTP; Thu, 22 Aug 2019 17:41:35 +0000 Received: by mail-qk1-f174.google.com with SMTP id m2so5855189qkd.10; Thu, 22 Aug 2019 10:41:35 -0700 (PDT) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=gmail.com; s=20161025; h=mime-version:from:date:message-id:subject:to:cc; bh=TqdsxrWXHvsan0f2KmycqYcJvl9FOohgZfcgiYezZg0=; b=USfPhUfR+NKZxa8TwrHEfFAu9JttH1/+3l6YVRb81hlXE+4DJNaG37ps0iEqlZYraI QCp+RZTxatz6N0ob8pGMKx8eEmeoINMnLEfH2aBKheM+D8bMZfdIRto6OzRECI0oW1Od mZu5O2+c1euSFqi1UIQz/sB9Era47T/eEGKJVWMlpizf/MQKmW5fiTocjQSOkC8ebguq oUxFchDUZ2mbs244p+EjmVKH/r7IuNm+K8uL/rGZNa0dx7jDn3HglG/lXANsUCCxF2G6 438EGl/4TIrcZKYFPjSwKwX3lmLg9AJQBXh57HvYHpxrt8Be48xm67Ri0jTvrwpjZ1pO Obmg== MIME-Version: 1.0 From: Alessandro Fanfarillo Date: Thu, 22 Aug 2019 11:41:22 -0600 Message-ID: Subject: [Patch, Fortran] CO_BROADCAST for derived types with allocatable components To: gfortran , gcc-patches Cc: Damian Rouson X-IsSubscribed: yes Dear all, please find in attachment a preliminary patch that adds support to co_broadcast for allocatable components of derived types. The patch is currently ignoring the stat and errmsg arguments, mostly because I am not sure how to handle them properly. I have created a new data structure called used to pass those argument to the preexisting structure_alloc_comps. Suggestions on how to handle them are more than welcome :-) The patch builds correctly on x86_64 and it has been tested with OpenCoarrays and the following test cases: https://github.com/sourceryinstitute/OpenCoarrays/blob/co_broadcast-derived-type/src/tests/unit/collectives/co_broadcast_allocatable_components.f90 https://github.com/sourceryinstitute/OpenCoarrays/blob/co_broadcast-derived-type/src/tests/unit/collectives/co_broadcast_allocatable_components_array.f90 Regards, commit b9458ff4414615263ed92d8965c93fd0a953f4a9 Author: Alessandro Fanfarillo Date: Thu Aug 22 10:50:17 2019 -0600 Co_broadcast derived types with allocatable components diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index c8d74e588dd..005646f1359 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -8571,13 +8571,15 @@ gfc_caf_is_dealloc_only (int caf_mode) enum {DEALLOCATE_ALLOC_COMP = 1, NULLIFY_ALLOC_COMP, COPY_ALLOC_COMP, COPY_ONLY_ALLOC_COMP, REASSIGN_CAF_COMP, - ALLOCATE_PDT_COMP, DEALLOCATE_PDT_COMP, CHECK_PDT_DUMMY}; + ALLOCATE_PDT_COMP, DEALLOCATE_PDT_COMP, CHECK_PDT_DUMMY, + BCAST_ALLOC_COMP}; static gfc_actual_arglist *pdt_param_list; static tree structure_alloc_comps (gfc_symbol * der_type, tree decl, - tree dest, int rank, int purpose, int caf_mode) + tree dest, int rank, int purpose, int caf_mode, + gfc_co_subroutines_args *args) { gfc_component *c; gfc_loopinfo loop; @@ -8663,14 +8665,14 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, && !caf_enabled (caf_mode)) { tmp = build_fold_indirect_ref_loc (input_location, - gfc_conv_array_data (dest)); + gfc_conv_array_data (dest)); dref = gfc_build_array_ref (tmp, index, NULL); tmp = structure_alloc_comps (der_type, vref, dref, rank, - COPY_ALLOC_COMP, 0); + COPY_ALLOC_COMP, 0, args); } else tmp = structure_alloc_comps (der_type, vref, NULL_TREE, rank, purpose, - caf_mode); + caf_mode, args); gfc_add_expr_to_block (&loopbody, tmp); @@ -8704,13 +8706,13 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, if (purpose == DEALLOCATE_ALLOC_COMP && der_type->attr.pdt_type) { tmp = structure_alloc_comps (der_type, decl, NULL_TREE, rank, - DEALLOCATE_PDT_COMP, 0); + DEALLOCATE_PDT_COMP, 0, args); gfc_add_expr_to_block (&fnblock, tmp); } else if (purpose == ALLOCATE_PDT_COMP && der_type->attr.alloc_comp) { tmp = structure_alloc_comps (der_type, decl, NULL_TREE, rank, - NULLIFY_ALLOC_COMP, 0); + NULLIFY_ALLOC_COMP, 0, args); gfc_add_expr_to_block (&fnblock, tmp); } @@ -8732,6 +8734,128 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, switch (purpose) { + + case BCAST_ALLOC_COMP: + + tree ubound; + tree cdesc; + stmtblock_t derived_type_block; + + gfc_init_block (&tmpblock); + + comp = fold_build3_loc (input_location, COMPONENT_REF, ctype, + decl, cdecl, NULL_TREE); + + /* Shortcut to get the attributes of the component. */ + if (c->ts.type == BT_CLASS) + { + attr = &CLASS_DATA (c)->attr; + if (attr->class_pointer) + continue; + } + else + { + attr = &c->attr; + if (attr->pointer) + continue; + } + + add_when_allocated = NULL_TREE; + if (cmp_has_alloc_comps + && !c->attr.pointer && !c->attr.proc_pointer) + { + /* Add checked deallocation of the components. This code is + obviously added because the finalizer is not trusted to free + all memory. */ + if (c->ts.type == BT_CLASS) + { + rank = CLASS_DATA (c)->as ? CLASS_DATA (c)->as->rank : 0; + add_when_allocated + = structure_alloc_comps (CLASS_DATA (c)->ts.u.derived, + comp, NULL_TREE, rank, purpose, + caf_mode, args); + } + else + { + rank = c->as ? c->as->rank : 0; + add_when_allocated = structure_alloc_comps (c->ts.u.derived, + comp, NULL_TREE, + rank, purpose, + caf_mode, args); + } + } + + gfc_init_block (&derived_type_block); + if (add_when_allocated) + gfc_add_expr_to_block (&derived_type_block, add_when_allocated); + tmp = gfc_finish_block (&derived_type_block); + gfc_add_expr_to_block (&tmpblock, tmp); + + /* Convert the component into a rank 1 descriptor type. */ + if (attr->dimension) + { + tmp = gfc_get_element_type (TREE_TYPE (comp)); + ubound = gfc_full_array_size (&tmpblock, comp, + c->ts.type == BT_CLASS + ? CLASS_DATA (c)->as->rank + : c->as->rank); + } + else + { + tmp = TREE_TYPE (comp); + ubound = build_int_cst (gfc_array_index_type, 1); + } + + cdesc = gfc_get_array_type_bounds (tmp, 1, 0, &gfc_index_one_node, + &ubound, 1, + GFC_ARRAY_ALLOCATABLE, false); + + cdesc = gfc_create_var (cdesc, "cdesc"); + DECL_ARTIFICIAL (cdesc) = 1; + + gfc_add_modify (&tmpblock, gfc_conv_descriptor_dtype (cdesc), + gfc_get_dtype_rank_type (1, tmp)); + gfc_conv_descriptor_lbound_set (&tmpblock, cdesc, + gfc_index_zero_node, + gfc_index_one_node); + gfc_conv_descriptor_stride_set (&tmpblock, cdesc, + gfc_index_zero_node, + gfc_index_one_node); + gfc_conv_descriptor_ubound_set (&tmpblock, cdesc, + gfc_index_zero_node, ubound); + + if (attr->dimension) + comp = gfc_conv_descriptor_data_get (comp); + else + { + gfc_se se; + + gfc_init_se (&se, NULL); + + comp = gfc_conv_scalar_to_descriptor (&se, comp, + c->ts.type == BT_CLASS + ? CLASS_DATA (c)->attr + : c->attr); + comp = gfc_build_addr_expr (NULL_TREE, comp); + gfc_add_block_to_block (&tmpblock, &se.pre); + } + + gfc_conv_descriptor_data_set (&tmpblock, cdesc, comp); + + tree fndecl; + + fndecl = build_call_expr_loc (input_location, + gfor_fndecl_co_broadcast, 5, + gfc_build_addr_expr (pvoid_type_node,cdesc), + args->image_index, + null_pointer_node, null_pointer_node, + null_pointer_node); + + gfc_add_expr_to_block (&tmpblock, fndecl); + gfc_add_block_to_block (&fnblock, &tmpblock); + + break; + case DEALLOCATE_ALLOC_COMP: gfc_init_block (&tmpblock); @@ -8782,7 +8906,7 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, add_when_allocated = structure_alloc_comps (CLASS_DATA (c)->ts.u.derived, comp, NULL_TREE, rank, purpose, - caf_mode); + caf_mode, args); } else { @@ -8790,7 +8914,7 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, add_when_allocated = structure_alloc_comps (c->ts.u.derived, comp, NULL_TREE, rank, purpose, - caf_mode); + caf_mode, args); } } @@ -9066,7 +9190,7 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, decl, cdecl, NULL_TREE); rank = c->as ? c->as->rank : 0; tmp = structure_alloc_comps (c->ts.u.derived, comp, NULL_TREE, - rank, purpose, caf_mode); + rank, purpose, caf_mode, args); gfc_add_expr_to_block (&fnblock, tmp); } break; @@ -9101,7 +9225,8 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, { tmp = structure_alloc_comps (c->ts.u.derived, comp, dcmp, rank, purpose, caf_mode - | GFC_STRUCTURE_CAF_MODE_IN_COARRAY); + | GFC_STRUCTURE_CAF_MODE_IN_COARRAY, + args); gfc_add_expr_to_block (&fnblock, tmp); } } @@ -9221,7 +9346,7 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, add_when_allocated = structure_alloc_comps (c->ts.u.derived, comp, dcmp, rank, purpose, - caf_mode); + caf_mode, args); } else add_when_allocated = NULL_TREE; @@ -9585,7 +9710,7 @@ gfc_nullify_alloc_comp (gfc_symbol * der_type, tree decl, int rank, { return structure_alloc_comps (der_type, decl, NULL_TREE, rank, NULLIFY_ALLOC_COMP, - GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY | caf_mode); + GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY | caf_mode, NULL); } @@ -9598,9 +9723,47 @@ gfc_deallocate_alloc_comp (gfc_symbol * der_type, tree decl, int rank, { return structure_alloc_comps (der_type, decl, NULL_TREE, rank, DEALLOCATE_ALLOC_COMP, - GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY | caf_mode); + GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY | caf_mode, NULL); } +tree +gfc_bcast_alloc_comp (gfc_symbol *derived, gfc_expr *expr, int rank, + tree image_index, tree stat, tree errmsg, + tree errmsg_len) +{ + tree tmp, array; + gfc_se argse; + stmtblock_t block, post_block; + gfc_co_subroutines_args args; + + args.image_index = image_index; + args.stat = stat; + args.errmsg = errmsg; + args.errmsg = errmsg_len; + + if (rank == 0) + { + gfc_start_block (&block); + gfc_init_block (&post_block); + gfc_init_se (&argse, NULL); + gfc_conv_expr (&argse, expr); + gfc_add_block_to_block (&block, &argse.pre); + gfc_add_block_to_block (&post_block, &argse.post); + array = argse.expr; + } + else + { + gfc_init_se (&argse, NULL); + argse.want_pointer = 1; + gfc_conv_expr_descriptor (&argse, expr); + array = argse.expr; + } + + tmp = structure_alloc_comps (derived, array, NULL_TREE, rank, + BCAST_ALLOC_COMP, + GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY, &args); + return tmp; +} /* Recursively traverse an object of derived type, generating code to deallocate allocatable components. But do not deallocate coarrays. @@ -9611,7 +9774,7 @@ tree gfc_deallocate_alloc_comp_no_caf (gfc_symbol * der_type, tree decl, int rank) { return structure_alloc_comps (der_type, decl, NULL_TREE, rank, - DEALLOCATE_ALLOC_COMP, 0); + DEALLOCATE_ALLOC_COMP, 0, NULL); } @@ -9619,7 +9782,7 @@ tree gfc_reassign_alloc_comp_caf (gfc_symbol *der_type, tree decl, tree dest) { return structure_alloc_comps (der_type, decl, dest, 0, REASSIGN_CAF_COMP, - GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY); + GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY, NULL); } @@ -9631,7 +9794,7 @@ gfc_copy_alloc_comp (gfc_symbol * der_type, tree decl, tree dest, int rank, int caf_mode) { return structure_alloc_comps (der_type, decl, dest, rank, COPY_ALLOC_COMP, - caf_mode); + caf_mode, NULL); } @@ -9642,7 +9805,7 @@ tree gfc_copy_only_alloc_comp (gfc_symbol * der_type, tree decl, tree dest, int rank) { return structure_alloc_comps (der_type, decl, dest, rank, - COPY_ONLY_ALLOC_COMP, 0); + COPY_ONLY_ALLOC_COMP, 0, NULL); } @@ -9657,7 +9820,7 @@ gfc_allocate_pdt_comp (gfc_symbol * der_type, tree decl, int rank, gfc_actual_arglist *old_param_list = pdt_param_list; pdt_param_list = param_list; res = structure_alloc_comps (der_type, decl, NULL_TREE, rank, - ALLOCATE_PDT_COMP, 0); + ALLOCATE_PDT_COMP, 0, NULL); pdt_param_list = old_param_list; return res; } @@ -9669,7 +9832,7 @@ tree gfc_deallocate_pdt_comp (gfc_symbol * der_type, tree decl, int rank) { return structure_alloc_comps (der_type, decl, NULL_TREE, rank, - DEALLOCATE_PDT_COMP, 0); + DEALLOCATE_PDT_COMP, 0, NULL); } @@ -9684,7 +9847,7 @@ gfc_check_pdt_dummy (gfc_symbol * der_type, tree decl, int rank, gfc_actual_arglist *old_param_list = pdt_param_list; pdt_param_list = param_list; res = structure_alloc_comps (der_type, decl, NULL_TREE, rank, - CHECK_PDT_DUMMY, 0); + CHECK_PDT_DUMMY, 0, NULL); pdt_param_list = old_param_list; return res; } diff --git a/gcc/fortran/trans-array.h b/gcc/fortran/trans-array.h index 8c2d51838d4..5a7eee7e305 100644 --- a/gcc/fortran/trans-array.h +++ b/gcc/fortran/trans-array.h @@ -52,6 +52,8 @@ bool gfc_caf_is_dealloc_only (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_bcast_alloc_comp (gfc_symbol *, gfc_expr *, int, tree, + tree, tree, tree); tree gfc_deallocate_alloc_comp_no_caf (gfc_symbol *, tree, int); tree gfc_reassign_alloc_comp_caf (gfc_symbol *, tree, tree); diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c index 26ea624101d..c2e0533393a 100644 --- a/gcc/fortran/trans-intrinsic.c +++ b/gcc/fortran/trans-intrinsic.c @@ -10786,13 +10786,12 @@ gfc_walk_intrinsic_function (gfc_ss * ss, gfc_expr * expr, } } - static tree conv_co_collective (gfc_code *code) { gfc_se argse; stmtblock_t block, post_block; - tree fndecl, array, strlen, image_index, stat, errmsg, errmsg_len; + tree fndecl, array = NULL_TREE, strlen, image_index, stat, errmsg, errmsg_len; gfc_expr *image_idx_expr, *stat_expr, *errmsg_expr, *opr_expr; gfc_start_block (&block); @@ -10857,6 +10856,7 @@ conv_co_collective (gfc_code *code) gfc_conv_expr_descriptor (&argse, code->ext.actual->expr); array = argse.expr; } + gfc_add_block_to_block (&block, &argse.pre); gfc_add_block_to_block (&post_block, &argse.post); @@ -10915,46 +10915,64 @@ conv_co_collective (gfc_code *code) gcc_unreachable (); } - if (code->resolved_isym->id == GFC_ISYM_CO_SUM - || code->resolved_isym->id == GFC_ISYM_CO_BROADCAST) - fndecl = build_call_expr_loc (input_location, fndecl, 5, array, - image_index, stat, errmsg, errmsg_len); - else if (code->resolved_isym->id != GFC_ISYM_CO_REDUCE) - fndecl = build_call_expr_loc (input_location, fndecl, 6, array, image_index, - stat, errmsg, strlen, errmsg_len); + gfc_symbol *derived = code->ext.actual->expr->ts.type == BT_DERIVED + ? code->ext.actual->expr->ts.u.derived : NULL; + + if (derived && derived->attr.alloc_comp + && code->resolved_isym->id == GFC_ISYM_CO_BROADCAST) + /* The derived type has the attribute 'alloc_comp'. */ + { + tree tmp = gfc_bcast_alloc_comp (derived, code->ext.actual->expr, + code->ext.actual->expr->rank, + image_index, stat, errmsg, errmsg_len); + gfc_add_expr_to_block (&block, tmp); + } else { - tree opr, opr_flags; - - // FIXME: Handle TS29113's bind(C) strings with descriptor. - int opr_flag_int; - if (gfc_is_proc_ptr_comp (opr_expr)) - { - gfc_symbol *sym = gfc_get_proc_ptr_comp (opr_expr)->ts.interface; - opr_flag_int = sym->attr.dimension - || (sym->ts.type == BT_CHARACTER - && !sym->attr.is_bind_c) - ? GFC_CAF_BYREF : 0; - opr_flag_int |= opr_expr->ts.type == BT_CHARACTER - && !sym->attr.is_bind_c - ? GFC_CAF_HIDDENLEN : 0; - opr_flag_int |= sym->formal->sym->attr.value ? GFC_CAF_ARG_VALUE : 0; - } + if (code->resolved_isym->id == GFC_ISYM_CO_SUM + || code->resolved_isym->id == GFC_ISYM_CO_BROADCAST) + fndecl = build_call_expr_loc (input_location, fndecl, 5, array, + image_index, stat, errmsg, errmsg_len); + else if (code->resolved_isym->id != GFC_ISYM_CO_REDUCE) + fndecl = build_call_expr_loc (input_location, fndecl, 6, array, + image_index, stat, errmsg, + strlen, errmsg_len); else { - opr_flag_int = gfc_return_by_reference (opr_expr->symtree->n.sym) - ? GFC_CAF_BYREF : 0; - opr_flag_int |= opr_expr->ts.type == BT_CHARACTER - && !opr_expr->symtree->n.sym->attr.is_bind_c - ? GFC_CAF_HIDDENLEN : 0; - opr_flag_int |= opr_expr->symtree->n.sym->formal->sym->attr.value - ? GFC_CAF_ARG_VALUE : 0; + tree opr, opr_flags; + + // FIXME: Handle TS29113's bind(C) strings with descriptor. + int opr_flag_int; + if (gfc_is_proc_ptr_comp (opr_expr)) + { + gfc_symbol *sym = gfc_get_proc_ptr_comp (opr_expr)->ts.interface; + opr_flag_int = sym->attr.dimension + || (sym->ts.type == BT_CHARACTER + && !sym->attr.is_bind_c) + ? GFC_CAF_BYREF : 0; + opr_flag_int |= opr_expr->ts.type == BT_CHARACTER + && !sym->attr.is_bind_c + ? GFC_CAF_HIDDENLEN : 0; + opr_flag_int |= sym->formal->sym->attr.value + ? GFC_CAF_ARG_VALUE : 0; + } + else + { + opr_flag_int = gfc_return_by_reference (opr_expr->symtree->n.sym) + ? GFC_CAF_BYREF : 0; + opr_flag_int |= opr_expr->ts.type == BT_CHARACTER + && !opr_expr->symtree->n.sym->attr.is_bind_c + ? GFC_CAF_HIDDENLEN : 0; + opr_flag_int |= opr_expr->symtree->n.sym->formal->sym->attr.value + ? GFC_CAF_ARG_VALUE : 0; + } + opr_flags = build_int_cst (integer_type_node, opr_flag_int); + gfc_conv_expr (&argse, opr_expr); + opr = argse.expr; + fndecl = build_call_expr_loc (input_location, fndecl, 8, array, opr, + opr_flags, image_index, stat, errmsg, + strlen, errmsg_len); } - opr_flags = build_int_cst (integer_type_node, opr_flag_int); - gfc_conv_expr (&argse, opr_expr); - opr = argse.expr; - fndecl = build_call_expr_loc (input_location, fndecl, 8, array, opr, opr_flags, - image_index, stat, errmsg, strlen, errmsg_len); } gfc_add_expr_to_block (&block, fndecl); diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h index 8082b414df1..84793dc1df0 100644 --- a/gcc/fortran/trans.h +++ b/gcc/fortran/trans.h @@ -107,6 +107,14 @@ typedef struct gfc_se } gfc_se; +typedef struct gfc_co_subroutines_args +{ + tree image_index; + tree stat; + tree errmsg; + tree errmsg_len; +} +gfc_co_subroutines_args; /* Denotes different types of coarray. Please keep in sync with libgfortran/caf/libcaf.h. */