From mboxrd@z Thu Jan 1 00:00:00 1970 Return-Path: Received: (qmail 107466 invoked by alias); 14 May 2015 09:43:27 -0000 Mailing-List: contact gcc-patches-help@gcc.gnu.org; run by ezmlm Precedence: bulk List-Id: List-Archive: List-Post: List-Help: Sender: gcc-patches-owner@gcc.gnu.org Received: (qmail 107441 invoked by uid 89); 14 May 2015 09:43:25 -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,RCVD_IN_DNSWL_NONE,SPF_PASS autolearn=ham version=3.3.2 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 (AES256-GCM-SHA384 encrypted) ESMTPS; Thu, 14 May 2015 09:43:22 +0000 Received: from vepi2 ([88.75.104.20]) by mail.gmx.com (mrgmx003) with ESMTPSA (Nemesis) id 0MTkNU-1Yjvio3ZGC-00QTbK; Thu, 14 May 2015 11:43:19 +0200 Date: Thu, 14 May 2015 09:49:00 -0000 From: Andre Vehreschild To: Mikael Morin Cc: GCC-Patches-ML , GCC-Fortran-ML Subject: Re: [Patch, fortran, pr65548, 2nd take, v4] [5/6 Regression] gfc_conv_procedure_call Message-ID: <20150514114317.3a3efc89@vepi2> In-Reply-To: <20150513111230.73ec0ab0@gmx.de> References: <20150325143554.0343a7a7@vepi2> <20150402122830.4153db9b@vepi2> <551DD96F.2050706@charter.net> <20150407161152.22629ff5@vepi2> <20150429143101.1aa5d0b4@gmx.de> <20150430150728.17a76373@gmx.de> <55527874.1070602@sfr.fr> <20150513111230.73ec0ab0@gmx.de> MIME-Version: 1.0 Content-Type: multipart/mixed; boundary="MP_/G4LyTDtRHnzxTPDadYN5A9o" X-UI-Out-Filterresults: notjunk:1; X-SW-Source: 2015-05/txt/msg01299.txt.bz2 --MP_/G4LyTDtRHnzxTPDadYN5A9o Content-Type: text/plain; charset=US-ASCII Content-Transfer-Encoding: 7bit Content-Disposition: inline Content-length: 950 Hi Mikael, hi all, please find attached the new version of this patch, where most of the source= expression assignment to the object to allocate is handled by gfc_trans_assignment (). To use trans_assignment with temporaries introduced during the preparation of the source= expression, a gfc_expr is created from the temporary identifier in the tree of expr3. This creation is done only, when the tree is an artificial declaration, i.e., a temporary. The gfx_expr is created only once and only for non-class objects, because for the latter gfc_trans_assignment can't cope with class arrays, for which the gfc_trans_allocate () needs the array-descriptor, which is not as easy to transfer to gfc_trans_assignment (). For class objects gfc_trans_allocate () therefore cares about the assignment/data copy itself. Bootstraps and regtests ok on x86_64-linux-gnu/f21. Ok for trunk? Regards, Andre -- Andre Vehreschild * Email: vehre ad gmx dot de --MP_/G4LyTDtRHnzxTPDadYN5A9o Content-Type: text/plain Content-Transfer-Encoding: 7bit Content-Disposition: attachment; filename=pr65548_4.clog Content-length: 494 gcc/fortran/ChangeLog: 2015-05-14 Andre Vehreschild PR fortran/65548 * trans-stmt.c (gfc_trans_allocate): Always retrieve the descriptor or a reference to a source= expression now for arrays and non-arrays, respectively. Use a temporary symbol and gfc_trans_assignment for all source= assignments to allocated objects. gcc/testsuite/ChangeLog: 2015-05-14 Andre Vehreschild PR fortran/65548 * gfortran.dg/allocate_with_source_5.f90: Extend test. --MP_/G4LyTDtRHnzxTPDadYN5A9o Content-Type: text/x-patch Content-Transfer-Encoding: 7bit Content-Disposition: attachment; filename=pr65548_4.patch Content-length: 18004 diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c index 814bdde..9688f71 100644 --- a/gcc/fortran/trans-stmt.c +++ b/gcc/fortran/trans-stmt.c @@ -5088,7 +5088,7 @@ tree gfc_trans_allocate (gfc_code * code) { gfc_alloc *al; - gfc_expr *expr; + gfc_expr *expr, *e3rhs = NULL; gfc_se se, se_sz; tree tmp; tree parm; @@ -5148,14 +5148,11 @@ gfc_trans_allocate (gfc_code * code) TREE_USED (label_finish) = 0; } - /* When an expr3 is present, try to evaluate it only once. In most - cases expr3 is invariant for all elements of the allocation list. - Only exceptions are arrays. Furthermore the standards prevent a - dependency of expr3 on the objects in the allocate list. Therefore - it is safe to pre-evaluate expr3 for complicated expressions, i.e. - everything not a variable or constant. When an array allocation - is wanted, then the following block nevertheless evaluates the - _vptr, _len and element_size for expr3. */ + /* When an expr3 is present evaluate it only once. The standards prevent a + dependency of expr3 on the objects in the allocate list. An expr3 can + be pre-evaluated in all cases. One just has to make sure, to use the + correct way, i.e., to get the descriptor or to get a reference + expression. */ if (code->expr3) { bool vtab_needed = false; @@ -5168,75 +5165,91 @@ gfc_trans_allocate (gfc_code * code) al = al->next) vtab_needed = (al->expr->ts.type == BT_CLASS); - /* A array expr3 needs the scalarizer, therefore do not process it - here. */ - if (code->expr3->expr_type != EXPR_ARRAY - && (code->expr3->rank == 0 - || code->expr3->expr_type == EXPR_FUNCTION) - && (!code->expr3->symtree - || !code->expr3->symtree->n.sym->as) - && !gfc_is_class_array_ref (code->expr3, NULL)) - { - /* When expr3 is a variable, i.e., a very simple expression, + /* When expr3 is a variable, i.e., a very simple expression, then convert it once here. */ - if ((code->expr3->expr_type == EXPR_VARIABLE) - || code->expr3->expr_type == EXPR_CONSTANT) - { - if (!code->expr3->mold - || code->expr3->ts.type == BT_CHARACTER - || vtab_needed) - { - /* Convert expr3 to a tree. */ - gfc_init_se (&se, NULL); - se.want_pointer = 1; - gfc_conv_expr (&se, code->expr3); - if (!code->expr3->mold) - expr3 = se.expr; - else - expr3_tmp = se.expr; - expr3_len = se.string_length; - gfc_add_block_to_block (&block, &se.pre); - gfc_add_block_to_block (&post, &se.post); - } - /* else expr3 = NULL_TREE set above. */ - } - else + if (code->expr3->expr_type == EXPR_VARIABLE + || code->expr3->expr_type == EXPR_ARRAY + || code->expr3->expr_type == EXPR_CONSTANT) + { + if (!code->expr3->mold + || code->expr3->ts.type == BT_CHARACTER + || vtab_needed) { - /* In all other cases evaluate the expr3 and create a - temporary. */ + /* Convert expr3 to a tree. */ gfc_init_se (&se, NULL); - if (code->expr3->rank != 0 - && code->expr3->expr_type == EXPR_FUNCTION - && code->expr3->value.function.isym) + /* For all "simple" expression just get the descriptor or the + reference, respectively, depending on the rank of the expr. */ + if (code->expr3->rank != 0) gfc_conv_expr_descriptor (&se, code->expr3); else gfc_conv_expr_reference (&se, code->expr3); - if (code->expr3->ts.type == BT_CLASS) - gfc_conv_class_to_class (&se, code->expr3, - code->expr3->ts, - false, true, - false, false); + if (!code->expr3->mold) + expr3 = se.expr; + else + expr3_tmp = se.expr; + expr3_len = se.string_length; gfc_add_block_to_block (&block, &se.pre); gfc_add_block_to_block (&post, &se.post); - /* Prevent aliasing, i.e., se.expr may be already a + } + /* else expr3 = NULL_TREE set above. */ + } + else + { + /* In all other cases evaluate the expr3 and create a + temporary. */ + gfc_init_se (&se, NULL); + /* For more complicated expression, the decision when to get the + descriptor and when to get a reference is depending on more + conditions. The descriptor is only retrieved for functions + that are intrinsic, elemental user-defined and known, or neither + of the two, or are a class or type, that has a not deferred type + array_spec. */ + if (code->expr3->rank != 0 + && (code->expr3->expr_type != EXPR_FUNCTION + || code->expr3->value.function.isym + || (code->expr3->value.function.esym && + code->expr3->value.function.esym->attr.elemental) + || (!code->expr3->value.function.isym + && !code->expr3->value.function.esym) + || (code->expr3->ts.type == BT_DERIVED + && code->expr3->ts.u.derived->as + && code->expr3->ts.u.derived->as->type != AS_DEFERRED) + || (code->expr3->ts.type == BT_CLASS + && CLASS_DATA (code->expr3)->as + && CLASS_DATA (code->expr3)->as->type != AS_DEFERRED))) + gfc_conv_expr_descriptor (&se, code->expr3); + else + gfc_conv_expr_reference (&se, code->expr3); + if (code->expr3->ts.type == BT_CLASS) + gfc_conv_class_to_class (&se, code->expr3, + code->expr3->ts, + false, true, + false, false); + gfc_add_block_to_block (&block, &se.pre); + gfc_add_block_to_block (&post, &se.post); + /* Prevent aliasing, i.e., se.expr may be already a variable declaration. */ - if (!VAR_P (se.expr)) - { - tmp = build_fold_indirect_ref_loc (input_location, - se.expr); - tmp = gfc_evaluate_now (tmp, &block); - } - else - tmp = se.expr; - if (!code->expr3->mold) - expr3 = tmp; - else - expr3_tmp = tmp; - /* When he length of a char array is easily available - here, fix it for future use. */ - if (se.string_length) - expr3_len = gfc_evaluate_now (se.string_length, &block); + if (!VAR_P (se.expr)) + { + tree var; + tmp = build_fold_indirect_ref_loc (input_location, + se.expr); + /* We need a regular (non-UID) symbol here, therefore give a + prefix. */ + var = gfc_create_var (TREE_TYPE (tmp), "atmp"); + gfc_add_modify_loc (input_location, &block, var, tmp); + tmp = var; } + else + tmp = se.expr; + if (!code->expr3->mold) + expr3 = tmp; + else + expr3_tmp = tmp; + /* When he length of a char array is easily available + here, fix it for future use. */ + if (se.string_length) + expr3_len = gfc_evaluate_now (se.string_length, &block); } /* Figure how to get the _vtab entry. This also obtains the tree @@ -5246,11 +5259,15 @@ gfc_trans_allocate (gfc_code * code) if (code->expr3->ts.type == BT_CLASS) { gfc_expr *rhs; - /* Polymorphic SOURCE: VPTR must be determined at run time. */ - if (expr3 != NULL_TREE && (VAR_P (expr3) || !code->expr3->ref)) + /* Polymorphic SOURCE: VPTR must be determined at run time. + expr3 may be a temporary array declaration, therefore check for + GFC_CLASS_TYPE_P before trying to get the _vptr component. */ + if (expr3 != NULL_TREE && GFC_CLASS_TYPE_P (TREE_TYPE (expr3)) + && (VAR_P (expr3) || !code->expr3->ref)) tmp = gfc_class_vptr_get (expr3); else if (expr3_tmp != NULL_TREE - && (VAR_P (expr3_tmp) ||!code->expr3->ref)) + && GFC_CLASS_TYPE_P (TREE_TYPE (expr3_tmp)) + && (VAR_P (expr3_tmp) || !code->expr3->ref)) tmp = gfc_class_vptr_get (expr3_tmp); else { @@ -5325,6 +5342,62 @@ gfc_trans_allocate (gfc_code * code) else expr3_esize = TYPE_SIZE_UNIT ( gfc_typenode_for_spec (&code->expr3->ts)); + + /* The routine gfc_trans_assignment () already implements all + techniques needed. Unfortunately we may have a temporary + variable for the source= expression here. When that is the + case convert this variable into a temporary gfc_expr of type + EXPR_VARIABLE and used it as rhs for the assignment. The + advantage is, that we get scalarizer support for free, + don't have to take care about scalar to array treatment and + will benefit of every enhancements gfc_trans_assignment () + gets. */ + e3rhs = gfc_copy_expr (code->expr3); + if (expr3 != NULL_TREE && DECL_P (expr3) && DECL_ARTIFICIAL (expr3)) + { + /* Build a temporary symtree and symbol. Do not add it to + the current namespace to prevent accidently modifying + a colliding symbol's as. */ + gfc_symtree *newsym = XCNEW (gfc_symtree); + /* The name of the symtree should be unique, because + gfc_create_var () took care about generating the + identifier. */ + newsym->name = gfc_get_string (IDENTIFIER_POINTER ( + DECL_NAME (expr3))); + newsym->n.sym = gfc_new_symbol (newsym->name, NULL); + /* The temporary is likely to need no references, but a + full array ref, therefore clear the chain of refs. */ + gfc_free_ref_list (e3rhs->ref); + e3rhs->ref = NULL; + /* The backend_decl is known. It is expr3, which is inserted + here. */ + newsym->n.sym->backend_decl = expr3; + e3rhs->symtree = newsym; + /* Mark the symbol referenced or gfc_trans_assignment will + bug. */ + newsym->n.sym->attr.referenced = 1; + e3rhs->expr_type = EXPR_VARIABLE; + /* Set the symbols type, upto it was BT_UNKNOWN. */ + newsym->n.sym->ts = e3rhs->ts; + /* Check whether the expr3 is array valued. */ + if (e3rhs->rank) + { + gfc_array_spec *arr; + arr = gfc_get_array_spec (); + arr->rank = e3rhs->rank; + arr->type = AS_DEFERRED; + /* Set the dimension and pointer attribute for arrays + to be on the safe side. */ + newsym->n.sym->attr.dimension = 1; + newsym->n.sym->attr.pointer = 1; + newsym->n.sym->as = arr; + gfc_add_full_array_ref (e3rhs, arr); + } + /* The string length is known to. Set it for char arrays. */ + if (code->expr3->ts.type == BT_CHARACTER) + newsym->n.sym->ts.u.cl->backend_decl = expr3_len; + gfc_commit_symbol (newsym->n.sym); + } } gcc_assert (expr3_esize); expr3_esize = fold_convert (sizetype, expr3_esize); @@ -5628,13 +5701,12 @@ gfc_trans_allocate (gfc_code * code) } if (code->expr3 && !code->expr3->mold) { - /* Initialization via SOURCE block - (or static default initializer). */ - gfc_expr *rhs = gfc_copy_expr (code->expr3); + /* Initialization via SOURCE block (or static default initializer). + Classes need some special handling, so catch them first. */ if (expr3 != NULL_TREE && ((POINTER_TYPE_P (TREE_TYPE (expr3)) && TREE_CODE (expr3) != POINTER_PLUS_EXPR) - || VAR_P (expr3)) + || (VAR_P (expr3) && GFC_CLASS_TYPE_P (TREE_TYPE (expr3)))) && code->expr3->ts.type == BT_CLASS && (expr->ts.type == BT_CLASS || expr->ts.type == BT_DERIVED)) @@ -5644,24 +5716,13 @@ gfc_trans_allocate (gfc_code * code) tmp = gfc_copy_class_to_class (expr3, to, nelems, upoly_expr); } - else if (code->expr3->ts.type == BT_CHARACTER) - { - tmp = INDIRECT_REF_P (se.expr) ? - se.expr : - build_fold_indirect_ref_loc (input_location, - se.expr); - gfc_trans_string_copy (&block, al_len, tmp, - code->expr3->ts.kind, - expr3_len, expr3, - code->expr3->ts.kind); - tmp = NULL_TREE; - } else if (al->expr->ts.type == BT_CLASS) { gfc_actual_arglist *actual, *last_arg; gfc_expr *ppc; gfc_code *ppc_code; gfc_ref *ref, *dataref; + gfc_expr *rhs = gfc_copy_expr (code->expr3); /* Do a polymorphic deep copy. */ actual = gfc_get_actual_arglist (); @@ -5688,8 +5749,8 @@ gfc_trans_allocate (gfc_code * code) gfc_ref *ref = dataref->next; ref->u.ar.type = AR_SECTION; /* We have to set up the array reference to give ranges - in all dimensions and ensure that the end and stride - are set so that the copy can be scalarized. */ + in all dimensions and ensure that the end and stride + are set so that the copy can be scalarized. */ dim = 0; for (; dim < dataref->u.c.component->as->rank; dim++) { @@ -5758,8 +5819,8 @@ gfc_trans_allocate (gfc_code * code) gfc_add_len_component (last_arg->expr); } else if (code->expr3->ts.type == BT_CHARACTER) - last_arg->expr = - gfc_copy_expr (code->expr3->ts.u.cl->length); + last_arg->expr = + gfc_copy_expr (code->expr3->ts.u.cl->length); else gcc_unreachable (); @@ -5773,6 +5834,7 @@ gfc_trans_allocate (gfc_code * code) void_type_node, tmp, extcopy, stdcopy); } gfc_free_statements (ppc_code); + gfc_free_expr (rhs); } else { @@ -5781,10 +5843,9 @@ gfc_trans_allocate (gfc_code * code) int realloc_lhs = flag_realloc_lhs; flag_realloc_lhs = 0; tmp = gfc_trans_assignment (gfc_expr_to_initialize (expr), - rhs, false, false); + e3rhs, false, false); flag_realloc_lhs = realloc_lhs; } - gfc_free_expr (rhs); gfc_add_expr_to_block (&block, tmp); } else if (code->expr3 && code->expr3->mold diff --git a/gcc/testsuite/gfortran.dg/allocate_with_source_5.f90 b/gcc/testsuite/gfortran.dg/allocate_with_source_5.f90 index e934e08..500f0f0 100644 --- a/gcc/testsuite/gfortran.dg/allocate_with_source_5.f90 +++ b/gcc/testsuite/gfortran.dg/allocate_with_source_5.f90 @@ -1,16 +1,16 @@ ! { dg-do run } ! +! Contributed by Juergen Reuter ! Check that pr65548 is fixed. -! Contributed by Juergen Reuter - -module allocate_with_source_5_module +! +module selectors type :: selector_t - integer, dimension(:), allocatable :: map - real, dimension(:), allocatable :: weight - contains - procedure :: init => selector_init - end type selector_t + integer, dimension(:), allocatable :: map + real, dimension(:), allocatable :: weight + contains + procedure :: init => selector_init + end type selector_t contains @@ -34,19 +34,126 @@ contains end if end subroutine selector_init -end module allocate_with_source_5_module +end module selectors + +module phs_base + type :: flavor_t + contains + procedure :: get_mass => flavor_get_mass + end type flavor_t + + type :: phs_config_t + integer :: n_in = 0 + type(flavor_t), dimension(:,:), allocatable :: flv + end type phs_config_t + + type :: phs_t + class(phs_config_t), pointer :: config => null () + real, dimension(:), allocatable :: m_in + end type phs_t + +contains + + elemental function flavor_get_mass (flv) result (mass) + real :: mass + class(flavor_t), intent(in) :: flv + mass = 42.0 + end function flavor_get_mass + + subroutine phs_base_init (phs, phs_config) + class(phs_t), intent(out) :: phs + class(phs_config_t), intent(in), target :: phs_config + phs%config => phs_config + allocate (phs%m_in (phs%config%n_in), & + source = phs_config%flv(:phs_config%n_in, 1)%get_mass ()) + end subroutine phs_base_init + +end module phs_base + +module foo + type :: t + integer :: n + real, dimension(:,:), allocatable :: val + contains + procedure :: make => t_make + generic :: get_int => get_int_array, get_int_element + procedure :: get_int_array => t_get_int_array + procedure :: get_int_element => t_get_int_element + end type t + +contains + + subroutine t_make (this) + class(t), intent(inout) :: this + real, dimension(:), allocatable :: int + allocate (int (0:this%n-1), source=this%get_int()) + end subroutine t_make + + pure function t_get_int_array (this) result (array) + class(t), intent(in) :: this + real, dimension(this%n) :: array + array = this%val (0:this%n-1, 4) + end function t_get_int_array + + pure function t_get_int_element (this, set) result (element) + class(t), intent(in) :: this + integer, intent(in) :: set + real :: element + element = this%val (set, 4) + end function t_get_int_element +end module foo +module foo2 + type :: t2 + integer :: n + character(32), dimension(:), allocatable :: md5 + contains + procedure :: init => t2_init + end type t2 + +contains + + subroutine t2_init (this) + class(t2), intent(inout) :: this + character(32), dimension(:), allocatable :: md5 + allocate (md5 (this%n), source=this%md5) + if (md5(1) /= "tst ") call abort() + if (md5(2) /= " ") call abort() + if (md5(3) /= "fooblabar ") call abort() + end subroutine t2_init +end module foo2 + +program test + use selectors + use phs_base + use foo + use foo2 + + type(selector_t) :: sel + type(phs_t) :: phs + type(phs_config_t) :: phs_config + type(t) :: o + type(t2) :: o2 + + call sel%init([2., 0., 3., 0., 4.]) + + if (any(sel%map /= [1, 3, 5])) call abort() + if (any(abs(sel%weight - [2., 3., 4.] / 9.) > 1E-6)) call abort() -program allocate_with_source_5 - use allocate_with_source_5_module + phs_config%n_in = 2 + allocate (phs_config%flv (phs_config%n_in, 1)) + call phs_base_init (phs, phs_config) - class(selector_t), allocatable :: sel; - real, dimension(5) :: w = [ 1, 0, 2, 0, 3]; + if (any(abs(phs%m_in - [42.0, 42.0]) > 1E-6)) call abort() - allocate (sel) - call sel%init(w) + o%n = 2 + allocate (o%val(2,4)) + call o%make() - if (any(sel%map /= [ 1, 3, 5])) call abort() - if (any(abs(sel%weight - [1, 2, 3] / 6) < 1E-6)) call abort() -end program allocate_with_source_5 -! { dg-final { cleanup-modules "allocate_with_source_5_module" } } + o2%n = 3 + allocate(o2%md5(o2%n)) + o2%md5(1) = "tst" + o2%md5(2) = "" + o2%md5(3) = "fooblabar" + call o2%init() +end program test --MP_/G4LyTDtRHnzxTPDadYN5A9o--