From patchwork Thu Mar 19 13:03:44 2015 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Andre Vehreschild X-Patchwork-Id: 451979 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@bilbo.ozlabs.org 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 2BB41140083 for ; Fri, 20 Mar 2015 00:04:16 +1100 (AEDT) Authentication-Results: ozlabs.org; dkim=pass reason="1024-bit key; unprotected key" header.d=gcc.gnu.org header.i=@gcc.gnu.org header.b=PmO+ki2G; dkim-adsp=none (unprotected policy); dkim-atps=neutral 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=s5/UPJQWNmQ6YvBk knW91I6UDvaJTaETfbQ3I3S24HIdrtQwDBQ48ozXg6f3HOUFnnmSpl4aLuXSLGg+ 60Ydzw+NLvJzWU7RapCazYV2FGGZYqjo2g/oFEW6AhTiJAnuWGirslbyQRd58NeD uEb9V/FnSp7Ac2IMKUZTSwFjA+8= 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=zyEOeKJI5AaPPh3D+Pl56n oQ4Vc=; b=PmO+ki2GxRCos+Wu/fQBGjdByzub6/EdOupZfbspB5TWd7YKpeC7Fk pArRLel+ccogfA5n/FdON2L/p8aCbrQ/BNggIq4ronrzZ4wgXlyfqcrSwvsoUD5l HmGeNc7RCUnizajspZ3wFFY4sXpcP7/nJBhxxwe6xfdqJ803mmqKg= Received: (qmail 61897 invoked by alias); 19 Mar 2015 13:04:06 -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 61880 invoked by uid 89); 19 Mar 2015 13:04:05 -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.15) by sourceware.org (qpsmtpd/0.93/v0.84-503-g423c35a) with (AES256-GCM-SHA384 encrypted) ESMTPS; Thu, 19 Mar 2015 13:03:55 +0000 Received: from vepi2 ([88.75.104.20]) by mail.gmx.com (mrgmx001) with ESMTPSA (Nemesis) id 0LzskF-1Zc9Ja2VdL-014yfA; Thu, 19 Mar 2015 14:03:46 +0100 Date: Thu, 19 Mar 2015 14:03:44 +0100 From: Andre Vehreschild To: GCC-Patches-ML , GCC-Fortran-ML Cc: Dominique Dhumieres Subject: Re: [Patch, Fortran, PR 64787 a.o., v2] Invalid code on sourced allocation of class(*) character string Message-ID: <20150319140344.2e71bc69@vepi2> In-Reply-To: <20150317090435.200A5F7@mailhost.lps.ens.fr> References: <20150317090435.200A5F7@mailhost.lps.ens.fr> MIME-Version: 1.0 X-UI-Out-Filterresults: notjunk:1; Hi Dominique, Hi all, please find attached a new version of the patch to fix pr64787 after processing Dominique's comments. Thank you very much for your work, Dominique. The patch now also fixes: pr63230 - allocation of deferred length character as derived type component causes internal compiler error pr51550 - ICE in gfc_get_derived_type, at fortran/trans-types.c:2401 (I believe the fortran code in the pr is not legal and fixed it; the fixed one now runs.) It partially fixes: pr55901 - [OOP] type is (character(len=*)) misinterpreted as array (The codes compile and run, but valgrind reports accesses to uninitialized memory; I am looking into this.) pr54070 - [4.8/4.9/5 Regression] Wrong code with allocatable deferred-length (array) function results (Compiles again (didn't with the first version of the patch for 64787), but still segfaults at runtime; -> agenda) This patch needs my previous patches as stated in: https://gcc.gnu.org/ml/fortran/2015-03/msg00076.html Bootstraps and regtests ok on x86_64-linux-gnu/F20. Reviews and comments welcome. Regards, Andre diff --git a/gcc/fortran/class.c b/gcc/fortran/class.c index 786876c..455aa69 100644 --- a/gcc/fortran/class.c +++ b/gcc/fortran/class.c @@ -234,6 +234,9 @@ gfc_add_component_ref (gfc_expr *e, const char *name) } if (*tail != NULL && strcmp (name, "_data") == 0) next = *tail; + else + /* Avoid losing memory. */ + gfc_free_ref_list (*tail); (*tail) = gfc_get_ref(); (*tail)->next = next; (*tail)->type = REF_COMPONENT; @@ -2562,13 +2565,19 @@ find_intrinsic_vtab (gfc_typespec *ts) c->attr.access = ACCESS_PRIVATE; /* Build a minimal expression to make use of - target-memory.c/gfc_element_size for 'size'. */ + target-memory.c/gfc_element_size for 'size'. Special handling + for character arrays, that are not constant sized: to support + len(str)*kind, only the kind information is stored in the + vtab. */ e = gfc_get_expr (); e->ts = *ts; e->expr_type = EXPR_VARIABLE; c->initializer = gfc_get_int_expr (gfc_default_integer_kind, NULL, - (int)gfc_element_size (e)); + ts->type == BT_CHARACTER + && charlen == 0 ? + ts->kind : + (int)gfc_element_size (e)); gfc_free_expr (e); /* Add component _extends. */ diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index f55c691..f4fa9c8 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -3168,6 +3168,7 @@ void gfc_add_component_ref (gfc_expr *, const char *); void gfc_add_class_array_ref (gfc_expr *); #define gfc_add_data_component(e) gfc_add_component_ref(e,"_data") #define gfc_add_vptr_component(e) gfc_add_component_ref(e,"_vptr") +#define gfc_add_len_component(e) gfc_add_component_ref(e,"_len") #define gfc_add_hash_component(e) gfc_add_component_ref(e,"_hash") #define gfc_add_size_component(e) gfc_add_component_ref(e,"_size") #define gfc_add_def_init_component(e) gfc_add_component_ref(e,"_def_init") diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index 54f8f4a..697a17a 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -4975,8 +4975,7 @@ static tree gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset, gfc_expr ** lower, gfc_expr ** upper, stmtblock_t * pblock, stmtblock_t * descriptor_block, tree * overflow, - tree expr3_elem_size, tree *nelems, gfc_expr *expr3, - gfc_typespec *ts) + tree expr3_elem_size, tree *nelems, gfc_expr *expr3) { tree type; tree tmp; @@ -5002,7 +5001,7 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset, /* Set the dtype. */ tmp = gfc_conv_descriptor_dtype (descriptor); - gfc_add_modify (descriptor_block, tmp, gfc_get_dtype (TREE_TYPE (descriptor))); + gfc_add_modify (descriptor_block, tmp, gfc_get_dtype (type)); or_expr = boolean_false_node; @@ -5156,9 +5155,6 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset, tmp = TYPE_SIZE_UNIT (tmp); } } - else if (ts->type != BT_UNKNOWN && ts->type != BT_CHARACTER) - /* FIXME: Properly handle characters. See PR 57456. */ - tmp = TYPE_SIZE_UNIT (gfc_typenode_for_spec (ts)); else tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type)); @@ -5230,7 +5226,7 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset, bool gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg, tree errlen, tree label_finish, tree expr3_elem_size, - tree *nelems, gfc_expr *expr3, gfc_typespec *ts) + tree *nelems, gfc_expr *expr3) { tree tmp; tree pointer; @@ -5315,7 +5311,7 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg, size = gfc_array_init_size (se->expr, ref->u.ar.as->rank, ref->u.ar.as->corank, &offset, lower, upper, &se->pre, &set_descriptor_block, &overflow, - expr3_elem_size, nelems, expr3, ts); + expr3_elem_size, nelems, expr3); if (dimension) { @@ -8022,7 +8018,8 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, fold_convert (TREE_TYPE (dst_data), tmp)); } - tmp = gfc_copy_class_to_class (comp, dcmp, nelems); + tmp = gfc_copy_class_to_class (comp, dcmp, nelems, + UNLIMITED_POLY (c)); gfc_add_expr_to_block (&tmpblock, tmp); tmp = gfc_finish_block (&tmpblock); diff --git a/gcc/fortran/trans-array.h b/gcc/fortran/trans-array.h index 583000e..8544534 100644 --- a/gcc/fortran/trans-array.h +++ b/gcc/fortran/trans-array.h @@ -24,7 +24,7 @@ tree gfc_array_deallocate (tree, tree, tree, tree, tree, gfc_expr*); /* Generate code to initialize and allocate an array. Statements are added to se, which should contain an expression for the array descriptor. */ bool gfc_array_allocate (gfc_se *, gfc_expr *, tree, tree, tree, tree, - tree, tree *, gfc_expr *, gfc_typespec *); + tree, tree *, gfc_expr *); /* Allow the bounds of a loop to be set from a callee's array spec. */ void gfc_set_loop_bounds_from_array_spec (gfc_interface_mapping *, diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index 0866faf..7d3f3be 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -268,6 +268,61 @@ gfc_vptr_size_get (tree vptr) #undef VTABLE_FINAL_FIELD +/* Search for the last _class ref in the chain of references of this expression + and cut the chain there. Albeit this routine is similiar to + class.c::gfc_add_component_ref (), is there a significant difference: + gfc_add_component_ref () concentrates on an array ref to be the last + ref in the chain. This routine is oblivious to the kind of refs + following. */ + +gfc_expr * +gfc_find_and_cut_at_last_class_ref (gfc_expr *e) +{ + gfc_expr *base_expr; + gfc_ref *ref, *class_ref, *tail; + + /* Find the last class reference. */ + class_ref = NULL; + for (ref = e->ref; ref; ref = ref->next) + { + if (ref->type == REF_COMPONENT + && ref->u.c.component->ts.type == BT_CLASS) + class_ref = ref; + + if (ref->next == NULL) + break; + } + + /* Remove and store all subsequent references after the + CLASS reference. */ + if (class_ref) + { + tail = class_ref->next; + class_ref->next = NULL; + } + else + { + tail = e->ref; + e->ref = NULL; + } + + base_expr = gfc_expr_to_initialize (e); + + /* Restore the original tail expression. */ + if (class_ref) + { + gfc_free_ref_list (class_ref->next); + class_ref->next = tail; + } + else + { + gfc_free_ref_list (e->ref); + e->ref = tail; + } + return base_expr; +} + + /* Reset the vptr to the declared type, e.g. after deallocation. */ void @@ -317,6 +372,22 @@ gfc_reset_vptr (stmtblock_t *block, gfc_expr *e) } +/* Reset the len for unlimited polymorphic objects. */ + +void +gfc_reset_len (stmtblock_t *block, gfc_expr *expr) +{ + gfc_expr *e; + gfc_se se_len; + e = gfc_find_and_cut_at_last_class_ref (expr); + gfc_add_len_component (e); + gfc_init_se (&se_len, NULL); + gfc_conv_expr (&se_len, e); + gfc_add_modify (block, se_len.expr, + fold_convert (TREE_TYPE (se_len.expr), integer_zero_node)); + gfc_free_expr (e); +} + /* Obtain the vptr of the last class reference in an expression. Return NULL_TREE if no class reference is found. */ @@ -925,22 +996,25 @@ gfc_get_class_array_ref (tree index, tree class_decl) that the _vptr is set. */ tree -gfc_copy_class_to_class (tree from, tree to, tree nelems) +gfc_copy_class_to_class (tree from, tree to, tree nelems, bool unlimited) { tree fcn; tree fcn_type; tree from_data; + tree from_len; tree to_data; + tree to_len; tree to_ref; tree from_ref; vec *args; tree tmp; + tree stdcopy; + tree extcopy; tree index; - stmtblock_t loopbody; - stmtblock_t body; - gfc_loopinfo loop; args = NULL; + /* To prevent warnings on uninitialized variables. */ + from_len = to_len = NULL_TREE; if (from != NULL_TREE) fcn = gfc_class_vtab_copy_get (from); @@ -950,14 +1024,29 @@ gfc_copy_class_to_class (tree from, tree to, tree nelems) fcn_type = TREE_TYPE (TREE_TYPE (fcn)); if (from != NULL_TREE) - from_data = gfc_class_data_get (from); + from_data = gfc_class_data_get (from); else from_data = gfc_class_vtab_def_init_get (to); + if (unlimited) + { + if (from != NULL_TREE && unlimited) + from_len = gfc_class_len_get (from); + else + from_len = integer_zero_node; + } + to_data = gfc_class_data_get (to); + if (unlimited) + to_len = gfc_class_len_get (to); if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (to_data))) { + stmtblock_t loopbody; + stmtblock_t body; + stmtblock_t ifbody; + gfc_loopinfo loop; + gfc_init_block (&body); tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type, nelems, @@ -989,8 +1078,41 @@ gfc_copy_class_to_class (tree from, tree to, tree nelems) loop.loopvar[0] = index; loop.to[0] = nelems; gfc_trans_scalarizing_loops (&loop, &loopbody); - gfc_add_block_to_block (&body, &loop.pre); - tmp = gfc_finish_block (&body); + gfc_init_block (&ifbody); + gfc_add_block_to_block (&ifbody, &loop.pre); + stdcopy = gfc_finish_block (&ifbody); + if (unlimited) + { + vec_safe_push (args, from_len); + vec_safe_push (args, to_len); + tmp = build_call_vec (fcn_type, fcn, args); + /* Build the body of the loop. */ + gfc_init_block (&loopbody); + gfc_add_expr_to_block (&loopbody, tmp); + + /* Build the loop and return. */ + gfc_init_loopinfo (&loop); + loop.dimen = 1; + loop.from[0] = gfc_index_zero_node; + loop.loopvar[0] = index; + loop.to[0] = nelems; + gfc_trans_scalarizing_loops (&loop, &loopbody); + gfc_init_block (&ifbody); + gfc_add_block_to_block (&ifbody, &loop.pre); + extcopy = gfc_finish_block (&ifbody); + + tmp = fold_build2_loc (input_location, GT_EXPR, boolean_type_node, + from_len, integer_zero_node); + tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, + tmp, extcopy, stdcopy); + gfc_add_expr_to_block (&body, tmp); + tmp = gfc_finish_block (&body); + } + else + { + gfc_add_expr_to_block (&body, stdcopy); + tmp = gfc_finish_block (&body); + } gfc_cleanup_loop (&loop); } else @@ -998,7 +1120,20 @@ gfc_copy_class_to_class (tree from, tree to, tree nelems) gcc_assert (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (from_data))); vec_safe_push (args, from_data); vec_safe_push (args, to_data); - tmp = build_call_vec (fcn_type, fcn, args); + stdcopy = build_call_vec (fcn_type, fcn, args); + + if (unlimited) + { + vec_safe_push (args, from_len); + vec_safe_push (args, to_len); + extcopy = build_call_vec (fcn_type, fcn, args); + tmp = fold_build2_loc (input_location, GT_EXPR, boolean_type_node, + from_len, integer_zero_node); + tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, + tmp, extcopy, stdcopy); + } + else + tmp = stdcopy; } return tmp; @@ -8580,7 +8715,7 @@ alloc_scalar_allocatable_for_assignment (stmtblock_t *block, if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred) { cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, - expr1->ts.u.cl->backend_decl, size); + lse.string_length, size); /* Jump past the realloc if the lengths are the same. */ tmp = build3_v (COND_EXPR, cond, build1_v (GOTO_EXPR, jump_label2), @@ -8597,10 +8732,7 @@ alloc_scalar_allocatable_for_assignment (stmtblock_t *block, /* Update the lhs character length. */ size = string_length; - if (TREE_CODE (expr1->ts.u.cl->backend_decl) == VAR_DECL) - gfc_add_modify (block, expr1->ts.u.cl->backend_decl, size); - else - gfc_add_modify (block, lse.string_length, size); + gfc_add_modify (block, lse.string_length, size); } } @@ -8890,7 +9022,7 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag, { /* F2003: Add the code for reallocation on assignment. */ if (flag_realloc_lhs && is_scalar_reallocatable_lhs (expr1)) - alloc_scalar_allocatable_for_assignment (&block, rse.string_length, + alloc_scalar_allocatable_for_assignment (&block, string_length, expr1, expr2); /* Use the scalar assignment as is. */ diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c index 225b0f3..809f621 100644 --- a/gcc/fortran/trans-stmt.c +++ b/gcc/fortran/trans-stmt.c @@ -4958,9 +4958,8 @@ tree gfc_trans_allocate (gfc_code * code) { gfc_alloc *al; - gfc_expr *e; gfc_expr *expr; - gfc_se se; + gfc_se se, se_sz; tree tmp; tree parm; tree stat; @@ -4969,21 +4968,23 @@ gfc_trans_allocate (gfc_code * code) tree label_errmsg; tree label_finish; tree memsz; - tree expr3; - tree slen3; + tree al_vptr, al_len; + /* If an expr3 is present, then store the tree for accessing its _vptr, + and _len components in the variables, respectively. The element size, + i.e. _vptr%size, is stored in expr3_esize and the expression to compute + the memsz in expr3_memsz. Any of the trees may be the NULL_TREE + indicating that this is not available for expr3's type. */ + tree expr3, expr3_vptr, expr3_len, expr3_esize; stmtblock_t block; stmtblock_t post; - gfc_expr *sz; - gfc_se se_sz; - tree class_expr; tree nelems; - tree memsize = NULL_TREE; - tree classexpr = NULL_TREE; + bool upoly_expr, tmp_expr3_len_flag = false, al_len_needs_set; if (!code->ext.alloc.list) return NULL_TREE; - stat = tmp = memsz = NULL_TREE; + stat = tmp = memsz = al_vptr = al_len = NULL_TREE; + expr3 = expr3_vptr = expr3_len = expr3_esize = NULL_TREE; label_errmsg = label_finish = errmsg = errlen = NULL_TREE; gfc_init_block (&block); @@ -5017,201 +5018,344 @@ gfc_trans_allocate (gfc_code * code) TREE_USED (label_finish) = 0; } - expr3 = NULL_TREE; - slen3 = NULL_TREE; + /* When an expr3 is given, try to evaluate it only once. In most cases + expr3 is invariant for all elements of the allocation list. Exceptions are + only arrays. Furthermore do(es) the standard(s) prevent a dependency of + expr3 on the objects to allocate. Therefore it is save 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. */ + if (code->expr3) + { + bool vtab_needed = false; + /* expr3_tmp gets the tree when code->expr3.mold is set, i.e., + the expression is only needed to get the _vptr, _len a.s.o. */ + tree expr3_tmp = NULL_TREE; + + /* Figure whether we need the vtab from expr3. */ + for (al = code->ext.alloc.list; !vtab_needed && al != NULL; 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, 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 + { + /* In all other cases evaluate the expr3 and create a + temporary. */ + gfc_init_se (&se, NULL); + 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, get + and store it for future reference. */ + if (se.string_length) + expr3_len = gfc_evaluate_now (se.string_length, &block); + } + } + + /* Figure how to get the _vtab entry. This also retrieves the tree for + accessing the _len component, because only unlimited polymorphic + objects, which are a subcategory of class types, have a _len + component. */ + 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)) + tmp = gfc_class_vptr_get (expr3); + else if (expr3_tmp != NULL_TREE + && (VAR_P (expr3_tmp) ||!code->expr3->ref)) + tmp = gfc_class_vptr_get (expr3_tmp); + else + { + rhs = gfc_find_and_cut_at_last_class_ref (code->expr3); + gfc_add_vptr_component (rhs); + gfc_init_se (&se, NULL); + se.want_pointer = 1; + gfc_conv_expr (&se, rhs); + tmp = se.expr; + gfc_free_expr (rhs); + } + /* Set the element size. */ + expr3_esize = gfc_vptr_size_get (tmp); + if (vtab_needed) + expr3_vptr = tmp; + /* Initialize the ref to the _len component. */ + if (expr3_len == NULL_TREE && UNLIMITED_POLY (code->expr3)) + { + /* Same like for retrieving the _vptr. */ + if (expr3 != NULL_TREE && !code->expr3->ref) + expr3_len = gfc_class_len_get (expr3); + else if (expr3_tmp != NULL_TREE && !code->expr3->ref) + expr3_len = gfc_class_len_get (expr3_tmp); + else + { + rhs = gfc_find_and_cut_at_last_class_ref (code->expr3); + gfc_add_len_component (rhs); + gfc_init_se (&se, NULL); + gfc_conv_expr (&se, rhs); + expr3_len = se.expr; + gfc_free_expr (rhs); + } + } + } + else + { + /* When the object to allocate is polymorphic type, then it needs its + vtab set correctly, so deduce the required _vtab and _len from the + source expression. */ + if (vtab_needed) + { + /* VPTR is fixed at compile time. */ + gfc_symbol *vtab; + vtab = gfc_find_vtab (&code->expr3->ts); + gcc_assert (vtab); + expr3_vptr = gfc_build_addr_expr (NULL_TREE, + gfc_get_symbol_decl (vtab)); + } + /* _len component needs to be set, when ts is a character + array. */ + if (expr3_len == NULL_TREE && code->expr3->ts.type == BT_CHARACTER) + { + if (code->expr3->ts.u.cl + && code->expr3->ts.u.cl->length) + { + gfc_init_se (&se, NULL); + gfc_conv_expr (&se, code->expr3->ts.u.cl->length); + gfc_add_block_to_block (&block, &se.pre); + expr3_len = gfc_evaluate_now (se.expr, &block); + } + gcc_assert (expr3_len); + } + /* For character arrays only the kind's size is needed, because the + array mem_size is computed to be _len * (elem_size = kind_size). + For all other get the element size in the common way. */ + if (code->expr3->ts.type == BT_CHARACTER) + expr3_esize = TYPE_SIZE_UNIT ( + gfc_get_char_type (code->expr3->ts.kind)); + else + expr3_esize = TYPE_SIZE_UNIT ( + gfc_typenode_for_spec (&code->expr3->ts)); + } + gcc_assert (expr3_esize); + expr3_esize = fold_convert (sizetype, expr3_esize); + } + else if (code->ext.alloc.ts.type != BT_UNKNOWN) + { + /* Compute the explicit typespec given only once for all objects to + allocate. */ + if (code->ext.alloc.ts.type != BT_CHARACTER) + expr3_esize = TYPE_SIZE_UNIT ( + gfc_typenode_for_spec (&code->ext.alloc.ts)); + else + { + gfc_expr *sz; + gcc_assert (code->ext.alloc.ts.u.cl->length != NULL); + sz = gfc_copy_expr (code->ext.alloc.ts.u.cl->length); + gfc_init_se (&se_sz, NULL); + gfc_conv_expr (&se_sz, sz); + gfc_free_expr (sz); + tmp = TYPE_SIZE_UNIT (gfc_get_char_type (code->ext.alloc.ts.kind)); + expr3_esize = fold_build2_loc (input_location, MULT_EXPR, + TREE_TYPE (se_sz.expr), + fold_convert (TREE_TYPE (se_sz.expr), + tmp), + se_sz.expr); + } + } + + /* Loop over all objects to allocate. */ for (al = code->ext.alloc.list; al != NULL; al = al->next) { expr = gfc_copy_expr (al->expr); + /* UNLIMITED_POLY () needs the _data component to be set, when expr is a + unlimited polymorphic object. But the _data component has not been set + yet, so check the derived type's attr for the unlimited polymorphic + flag to be safe. */ + upoly_expr = UNLIMITED_POLY (expr) + || (expr->ts.type == BT_DERIVED + && expr->ts.u.derived->attr.unlimited_polymorphic); + gfc_init_se (&se, NULL); + /* For class types prepare the expressions to ref the _vptr + and the _len component. The latter for unlimited polymorphic types + only. */ if (expr->ts.type == BT_CLASS) - gfc_add_data_component (expr); - - gfc_init_se (&se, NULL); + { + gfc_expr *expr_ref_vptr, *expr_ref_len; + gfc_add_data_component (expr); + /* Prep the vptr handle. */ + expr_ref_vptr = gfc_copy_expr (al->expr); + gfc_add_vptr_component (expr_ref_vptr); + se.want_pointer = 1; + gfc_conv_expr (&se, expr_ref_vptr); + al_vptr = se.expr; + se.want_pointer = 0; + gfc_free_expr (expr_ref_vptr); + /* Allocated unlimited polymorphic objects always have a _len + component. */ + if (upoly_expr) + { + expr_ref_len = gfc_copy_expr (al->expr); + gfc_add_len_component (expr_ref_len); + gfc_conv_expr (&se, expr_ref_len); + al_len = se.expr; + gfc_free_expr (expr_ref_len); + } + else + /* In a loop ensure that all loop variable dependent variables are + initialized at the same spot in all execution paths. */ + al_len = NULL_TREE; + } + else + al_vptr = al_len = NULL_TREE; se.want_pointer = 1; se.descriptor_only = 1; gfc_conv_expr (&se, expr); - - /* Evaluate expr3 just once if not a variable. */ - if (al == code->ext.alloc.list - && al->expr->ts.type == BT_CLASS - && code->expr3 - && code->expr3->ts.type == BT_CLASS - && code->expr3->expr_type != EXPR_VARIABLE) - { - gfc_init_se (&se_sz, NULL); - gfc_conv_expr_reference (&se_sz, code->expr3); - gfc_conv_class_to_class (&se_sz, code->expr3, - code->expr3->ts, false, true, false, false); - gfc_add_block_to_block (&se.pre, &se_sz.pre); - gfc_add_block_to_block (&se.post, &se_sz.post); - classexpr = build_fold_indirect_ref_loc (input_location, - se_sz.expr); - classexpr = gfc_evaluate_now (classexpr, &se.pre); - memsize = gfc_class_vtab_size_get (classexpr); - memsize = fold_convert (sizetype, memsize); - } - - memsz = memsize; - class_expr = classexpr; - + if (expr->ts.type == BT_CHARACTER && expr->ts.deferred) + /* se.string_length now stores the .string_length variable of expr + needed to allocate character(len=:) arrays. */ + al_len = se.string_length; + + al_len_needs_set = al_len != NULL_TREE; + /* When allocating an array one can not use much of the pre-evaluated + expr3 expressions, because for most of them the scalarizer is needed + which is not available in the pre-evaluation step. Therefore + gfc_array_allocate () is responsible (and able) to handle the + complete array allocation. Only the element size needs to be provided, + which is done most of the time by the pre-evaluation step. */ nelems = NULL_TREE; + if (expr3_len && code->expr3->ts.type == BT_CHARACTER) + /* When al is an array, then the element size for each element in the + array is needed, which is the product of the len and esize for + char arrays. */ + tmp = fold_build2_loc (input_location, MULT_EXPR, + TREE_TYPE (expr3_esize), expr3_esize, + fold_convert (TREE_TYPE (expr3_esize), + expr3_len)); + else + tmp = expr3_esize; if (!gfc_array_allocate (&se, expr, stat, errmsg, errlen, label_finish, - memsz, &nelems, code->expr3, &code->ext.alloc.ts)) + tmp, &nelems, code->expr3)) { - bool unlimited_char; + /* A scalar or derived type. First compute the size to allocate. */ - unlimited_char = UNLIMITED_POLY (al->expr) - && ((code->expr3 && code->expr3->ts.type == BT_CHARACTER) - || (code->ext.alloc.ts.type == BT_CHARACTER - && code->ext.alloc.ts.u.cl - && code->ext.alloc.ts.u.cl->length)); - - /* A scalar or derived type. */ - - /* Determine allocate size. */ - if (al->expr->ts.type == BT_CLASS - && !unlimited_char - && code->expr3 - && memsz == NULL_TREE) - { - if (code->expr3->ts.type == BT_CLASS) - { - sz = gfc_copy_expr (code->expr3); - gfc_add_vptr_component (sz); - gfc_add_size_component (sz); - gfc_init_se (&se_sz, NULL); - gfc_conv_expr (&se_sz, sz); - gfc_free_expr (sz); - memsz = se_sz.expr; - } - else - memsz = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&code->expr3->ts)); - } - else if (((al->expr->ts.type == BT_CHARACTER && al->expr->ts.deferred) - || unlimited_char) && code->expr3) + /* expr3_len is set when expr3 is unlimited polymorphic object or + a deferred length string. */ + if (expr3_len != NULL_TREE) { - if (!code->expr3->ts.u.cl->backend_decl) - { - /* Convert and use the length expression. */ - gfc_init_se (&se_sz, NULL); - if (code->expr3->expr_type == EXPR_VARIABLE - || code->expr3->expr_type == EXPR_CONSTANT) - { - gfc_conv_expr (&se_sz, code->expr3); - gfc_add_block_to_block (&se.pre, &se_sz.pre); - se_sz.string_length - = gfc_evaluate_now (se_sz.string_length, &se.pre); - gfc_add_block_to_block (&se.pre, &se_sz.post); - memsz = se_sz.string_length; - } - else if (code->expr3->mold - && code->expr3->ts.u.cl - && code->expr3->ts.u.cl->length) - { - gfc_conv_expr (&se_sz, code->expr3->ts.u.cl->length); - gfc_add_block_to_block (&se.pre, &se_sz.pre); - se_sz.expr = gfc_evaluate_now (se_sz.expr, &se.pre); - gfc_add_block_to_block (&se.pre, &se_sz.post); - memsz = se_sz.expr; - } - else - { - /* This is would be inefficient and possibly could - generate wrong code if the result were not stored - in expr3/slen3. */ - if (slen3 == NULL_TREE) - { - gfc_conv_expr (&se_sz, code->expr3); - gfc_add_block_to_block (&se.pre, &se_sz.pre); - expr3 = gfc_evaluate_now (se_sz.expr, &se.pre); - gfc_add_block_to_block (&post, &se_sz.post); - slen3 = gfc_evaluate_now (se_sz.string_length, - &se.pre); - } - memsz = slen3; - } - } + tmp = fold_build2_loc (input_location, MULT_EXPR, + TREE_TYPE (expr3_esize), expr3_esize, + fold_convert (TREE_TYPE (expr3_esize), + expr3_len)); + if (code->expr3->ts.type != BT_CLASS) + /* expr3 is a deferred length string, i.e., we are done. */ + memsz = tmp; else - /* Otherwise use the stored string length. */ - memsz = code->expr3->ts.u.cl->backend_decl; - tmp = al->expr->ts.u.cl->backend_decl; - - /* Store the string length. */ - if (tmp && TREE_CODE (tmp) == VAR_DECL) - gfc_add_modify (&se.pre, tmp, fold_convert (TREE_TYPE (tmp), - memsz)); - else if (al->expr->ts.type == BT_CHARACTER - && al->expr->ts.deferred && se.string_length) - gfc_add_modify (&se.pre, se.string_length, - fold_convert (TREE_TYPE (se.string_length), - memsz)); - else if ((al->expr->ts.type == BT_DERIVED - || al->expr->ts.type == BT_CLASS) - && expr->ts.u.derived->attr.unlimited_polymorphic) { - tmp = gfc_class_len_get (al->expr->symtree->n.sym->backend_decl); - gfc_add_modify (&se.pre, tmp, - fold_convert (TREE_TYPE (tmp), - memsz)); + /* For unlimited polymorphic enties build + (len > 0) ? element_size * len : element_size + to compute the number of bytes to allocate. This allows + allocating of unlimited polymorphic objects from an expr3 + that is unlimited polymorphic, too, and stores a _len + dependent object, e.g., a string. */ + memsz = fold_build2_loc (input_location, GT_EXPR, + boolean_type_node, expr3_len, + integer_zero_node); + memsz = fold_build3_loc (input_location, COND_EXPR, + TREE_TYPE (expr3_esize), + memsz, tmp, expr3_esize); } - - /* Convert to size in bytes, using the character KIND. */ - if (unlimited_char) - tmp = TREE_TYPE (gfc_typenode_for_spec (&code->expr3->ts)); - else - tmp = TREE_TYPE (gfc_typenode_for_spec (&al->expr->ts)); - tmp = TYPE_SIZE_UNIT (tmp); - memsz = fold_build2_loc (input_location, MULT_EXPR, - TREE_TYPE (tmp), tmp, - fold_convert (TREE_TYPE (tmp), memsz)); } - else if ((al->expr->ts.type == BT_CHARACTER && al->expr->ts.deferred) - || unlimited_char) + else if (expr3_esize != NULL_TREE) + /* Any other object in expr3 just needs element size bytes. */ + memsz = expr3_esize; + else if ((expr->ts.type == BT_CHARACTER && expr->ts.deferred) + || (upoly_expr && code->ext.alloc.ts.type == BT_CHARACTER)) { - gcc_assert (code->ext.alloc.ts.u.cl && code->ext.alloc.ts.u.cl->length); + /* Allocating deferred length char arrays need the length to + allocate in the alloc_type_spec. But also unlimited + polymorphic objects may be allocated as char arrays. Both are + handled here. */ gfc_init_se (&se_sz, NULL); gfc_conv_expr (&se_sz, code->ext.alloc.ts.u.cl->length); gfc_add_block_to_block (&se.pre, &se_sz.pre); se_sz.expr = gfc_evaluate_now (se_sz.expr, &se.pre); gfc_add_block_to_block (&se.pre, &se_sz.post); - /* Store the string length. */ - if ((expr->symtree->n.sym->ts.type == BT_CLASS - || expr->symtree->n.sym->ts.type == BT_DERIVED) - && expr->ts.u.derived->attr.unlimited_polymorphic) - /* For unlimited polymorphic entities get the backend_decl of - the _len component for that. */ - tmp = gfc_class_len_get (gfc_get_symbol_decl ( - expr->symtree->n.sym)); - else - /* Else use what is stored in the charlen->backend_decl. */ - tmp = al->expr->ts.u.cl->backend_decl; - gfc_add_modify (&se.pre, tmp, fold_convert (TREE_TYPE (tmp), - se_sz.expr)); - tmp = TREE_TYPE (gfc_typenode_for_spec (&code->ext.alloc.ts)); - tmp = TYPE_SIZE_UNIT (tmp); + expr3_len = se_sz.expr; + tmp_expr3_len_flag = true; + tmp = TYPE_SIZE_UNIT ( + gfc_get_char_type (code->ext.alloc.ts.kind)); memsz = fold_build2_loc (input_location, MULT_EXPR, - TREE_TYPE (tmp), tmp, - fold_convert (TREE_TYPE (se_sz.expr), - se_sz.expr)); + TREE_TYPE (tmp), + fold_convert (TREE_TYPE (tmp), + expr3_len), + tmp); } - else if (code->ext.alloc.ts.type != BT_UNKNOWN) - memsz = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&code->ext.alloc.ts)); - else if (memsz == NULL_TREE) - memsz = TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (se.expr))); - - if (expr->ts.type == BT_CHARACTER && memsz == NULL_TREE) + else if (expr->ts.type == BT_CHARACTER) { - memsz = se.string_length; - - /* Convert to size in bytes, using the character KIND. */ - tmp = TREE_TYPE (gfc_typenode_for_spec (&code->ext.alloc.ts)); - tmp = TYPE_SIZE_UNIT (tmp); + /* Compute the number of bytes needed to allocate a fixed length + char array. */ + gcc_assert (se.string_length != NULL_TREE); + tmp = TYPE_SIZE_UNIT (gfc_get_char_type (expr->ts.kind)); memsz = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (tmp), tmp, - fold_convert (TREE_TYPE (tmp), memsz)); + fold_convert (TREE_TYPE (tmp), + se.string_length)); } + else if (code->ext.alloc.ts.type != BT_UNKNOWN) + /* Handle all types, where the alloc_type_spec is set. */ + memsz = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&code->ext.alloc.ts)); + else + /* Handle size computation of the type declared to alloc. */ + memsz = TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (se.expr)));; /* Allocate - for non-pointers with re-alloc checking. */ if (gfc_expr_attr (expr).allocatable) @@ -5228,6 +5372,19 @@ gfc_trans_allocate (gfc_code * code) gfc_add_expr_to_block (&se.pre, tmp); } } + else + { + if (expr->ts.type == BT_CHARACTER && al_len != NULL_TREE + && expr3_len != NULL_TREE) + { + /* Arrays need to have a _len set before the array descriptor is + filled. */ + gfc_add_modify (&block, al_len, fold_convert (TREE_TYPE (al_len), + expr3_len)); + /* Prevent setting the length twice. */ + al_len_needs_set = false; + } + } gfc_add_block_to_block (&block, &se.pre); @@ -5244,124 +5401,106 @@ gfc_trans_allocate (gfc_code * code) gfc_add_expr_to_block (&block, tmp); } - /* We need the vptr of CLASS objects to be initialized. */ - e = gfc_copy_expr (al->expr); - if (e->ts.type == BT_CLASS) + /* Set the vptr. */ + if (al_vptr != NULL_TREE) { - gfc_expr *lhs, *rhs; - gfc_se lse; - gfc_ref *ref, *class_ref, *tail; - - /* Find the last class reference. */ - class_ref = NULL; - for (ref = e->ref; ref; ref = ref->next) - { - if (ref->type == REF_COMPONENT - && ref->u.c.component->ts.type == BT_CLASS) - class_ref = ref; - - if (ref->next == NULL) - break; - } - - /* Remove and store all subsequent references after the - CLASS reference. */ - if (class_ref) - { - tail = class_ref->next; - class_ref->next = NULL; - } - else - { - tail = e->ref; - e->ref = NULL; - } - - lhs = gfc_expr_to_initialize (e); - gfc_add_vptr_component (lhs); - - /* Remove the _vptr component and restore the original tail - references. */ - if (class_ref) - { - gfc_free_ref_list (class_ref->next); - class_ref->next = tail; - } - else - { - gfc_free_ref_list (e->ref); - e->ref = tail; - } - - if (class_expr != NULL_TREE) - { - /* Polymorphic SOURCE: VPTR must be determined at run time. */ - gfc_init_se (&lse, NULL); - lse.want_pointer = 1; - gfc_conv_expr (&lse, lhs); - tmp = gfc_class_vptr_get (class_expr); - gfc_add_modify (&block, lse.expr, - fold_convert (TREE_TYPE (lse.expr), tmp)); - } - else if (code->expr3 && code->expr3->ts.type == BT_CLASS) - { - /* Polymorphic SOURCE: VPTR must be determined at run time. */ - rhs = gfc_copy_expr (code->expr3); - gfc_add_vptr_component (rhs); - tmp = gfc_trans_pointer_assignment (lhs, rhs); - gfc_add_expr_to_block (&block, tmp); - gfc_free_expr (rhs); - rhs = gfc_expr_to_initialize (e); - } + if (expr3_vptr != NULL_TREE) + /* The vtab is already known, so just assign it. */ + gfc_add_modify (&block, al_vptr, + fold_convert (TREE_TYPE (al_vptr), expr3_vptr)); else { /* VPTR is fixed at compile time. */ gfc_symbol *vtab; gfc_typespec *ts; + if (code->expr3) + /* Although expr3 is pre-evaluated above, it may happen, that + for arrays or in mold= cases the pre-evaluation was not + successful. In these rare cases take the vtab from the + typespec of expr3 here. */ ts = &code->expr3->ts; - else if (e->ts.type == BT_DERIVED) - ts = &e->ts; - else if (code->ext.alloc.ts.type == BT_DERIVED || UNLIMITED_POLY (al->expr)) + else if (code->ext.alloc.ts.type == BT_DERIVED || upoly_expr) + /* The alloc_type_spec gives the type to allocate or the + al is unlimited polymorphic, which enforces the use of an + alloc_type_spec that is not necessarily a BT_DERIVED. */ ts = &code->ext.alloc.ts; - else if (e->ts.type == BT_CLASS) - ts = &CLASS_DATA (e)->ts; else - ts = &e->ts; - - if (ts->type == BT_DERIVED || UNLIMITED_POLY (e)) - { - vtab = gfc_find_vtab (ts); - gcc_assert (vtab); - gfc_init_se (&lse, NULL); - lse.want_pointer = 1; - gfc_conv_expr (&lse, lhs); - tmp = gfc_build_addr_expr (NULL_TREE, - gfc_get_symbol_decl (vtab)); - gfc_add_modify (&block, lse.expr, - fold_convert (TREE_TYPE (lse.expr), tmp)); - } + /* Prepare for setting the vtab as declared. */ + ts = &expr->ts; + + vtab = gfc_find_vtab (ts); + gcc_assert (vtab); + tmp = gfc_build_addr_expr (NULL_TREE, + gfc_get_symbol_decl (vtab)); + gfc_add_modify (&block, al_vptr, + fold_convert (TREE_TYPE (al_vptr), tmp)); } - gfc_free_expr (lhs); } - gfc_free_expr (e); - + /* Add assignment for string length. */ + if (al_len != NULL_TREE && al_len_needs_set) + { + if (expr3_len != NULL_TREE) + { + gfc_add_modify (&block, al_len, fold_convert (TREE_TYPE (al_len), + expr3_len)); + /* When tmp_expr3_len_flag is set, then expr3_len is abused to + carry the length information from the alloc_type. Clear it to + prevent setting incorrect len information in future loop + iterations. */ + if (tmp_expr3_len_flag) + /* No need to reset tmp_expr3_len_flag, because the presence of + an expr3 can not change within in the loop. */ + expr3_len = NULL_TREE; + } + else if (code->ext.alloc.ts.type == BT_CHARACTER + && code->ext.alloc.ts.u.cl->length) + { + /* The length of the string in characters is needed. expr3_esize + contains the number of bytes needed for the string to pass + to gfc_array_allocate (), therefore can not be resused + here. */ + gfc_init_se (&se_sz, NULL); + gfc_conv_expr (&se_sz, code->ext.alloc.ts.u.cl->length); + gfc_add_modify (&block, al_len, + fold_convert (TREE_TYPE (al_len), se_sz.expr)); + } + else + /* No length information needed, because type to allocate has no + length. Set _len to 0. */ + gfc_add_modify (&block, al_len, + fold_convert (TREE_TYPE (al_len), + integer_zero_node)); + } if (code->expr3 && !code->expr3->mold) { /* Initialization via SOURCE block (or static default initializer). */ gfc_expr *rhs = gfc_copy_expr (code->expr3); - if (class_expr != NULL_TREE) + if (expr3 != NULL_TREE + && ((POINTER_TYPE_P (TREE_TYPE (expr3)) + && TREE_CODE (expr3) != POINTER_PLUS_EXPR) + || VAR_P (expr3)) + && code->expr3->ts.type == BT_CLASS + && (expr->ts.type == BT_CLASS || expr->ts.type == BT_DERIVED)) { tree to; - to = TREE_OPERAND (se.expr, 0); - - tmp = gfc_copy_class_to_class (class_expr, to, nelems); + to = VAR_P (se.expr) ? se.expr : TREE_OPERAND (se.expr, 0); + 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; + gfc_actual_arglist *actual, *last_arg; gfc_expr *ppc; gfc_code *ppc_code; gfc_ref *ref, *dataref; @@ -5371,15 +5510,15 @@ gfc_trans_allocate (gfc_code * code) actual->expr = gfc_copy_expr (rhs); if (rhs->ts.type == BT_CLASS) gfc_add_data_component (actual->expr); - actual->next = gfc_get_actual_arglist (); - actual->next->expr = gfc_copy_expr (al->expr); - actual->next->expr->ts.type = BT_CLASS; - gfc_add_data_component (actual->next->expr); + last_arg = actual->next = gfc_get_actual_arglist (); + last_arg->expr = gfc_copy_expr (al->expr); + last_arg->expr->ts.type = BT_CLASS; + gfc_add_data_component (last_arg->expr); dataref = NULL; /* Make sure we go up through the reference chain to the _data reference, where the arrayspec is found. */ - for (ref = actual->next->expr->ref; ref; ref = ref->next) + for (ref = last_arg->expr->ref; ref; ref = ref->next) if (ref->type == REF_COMPONENT && strcmp (ref->u.c.component->name, "_data") == 0) dataref = ref; @@ -5413,7 +5552,10 @@ gfc_trans_allocate (gfc_code * code) } if (rhs->ts.type == BT_CLASS) { - ppc = gfc_copy_expr (rhs); + if (rhs->ref) + ppc = gfc_find_and_cut_at_last_class_ref (rhs); + else + ppc = gfc_copy_expr (rhs); gfc_add_vptr_component (ppc); } else @@ -5422,6 +5564,7 @@ gfc_trans_allocate (gfc_code * code) ppc_code = gfc_get_code (EXEC_CALL); ppc_code->resolved_sym = ppc->symtree->n.sym; + ppc_code->loc = al->expr->where; /* Although '_copy' is set to be elemental in class.c, it is not staying that way. Find out why, sometime.... */ ppc_code->resolved_sym->attr.elemental = 1; @@ -5430,15 +5573,49 @@ gfc_trans_allocate (gfc_code * code) /* Since '_copy' is elemental, the scalarizer will take care of arrays in gfc_trans_call. */ tmp = gfc_trans_call (ppc_code, true, NULL, NULL, false); + /* We need to add the + if (al_len > 0) + al_vptr->copy (expr3_data, al_data, expr3_len, al_len); + else + al_vptr->copy (expr3_data, al_data); + block, because al is unlimited polymorphic or a deferred length + char array, whose copy routine needs the array length's as + third and fourth arguments. */ + if (al_len && UNLIMITED_POLY (code->expr3)) + { + tree stdcopy, extcopy; + /* Add al%_len. */ + last_arg->next = gfc_get_actual_arglist (); + last_arg = last_arg->next; + last_arg->expr = gfc_find_and_cut_at_last_class_ref ( + al->expr); + gfc_add_len_component (last_arg->expr); + /* Add expr3's length. */ + last_arg->next = gfc_get_actual_arglist (); + last_arg = last_arg->next; + if (code->expr3->ts.type == BT_CLASS) + { + last_arg->expr = + gfc_find_and_cut_at_last_class_ref (code->expr3); + 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); + else + gcc_unreachable (); + + stdcopy = tmp; + extcopy = gfc_trans_call (ppc_code, true, NULL, NULL, false); + + tmp = fold_build2_loc (input_location, GT_EXPR, + boolean_type_node, expr3_len, + integer_zero_node); + tmp = fold_build3_loc (input_location, COND_EXPR, + void_type_node, tmp, extcopy, stdcopy); + } gfc_free_statements (ppc_code); } - else if (expr3 != NULL_TREE) - { - tmp = build_fold_indirect_ref_loc (input_location, se.expr); - gfc_trans_string_copy (&block, slen3, tmp, code->expr3->ts.kind, - slen3, expr3, code->expr3->ts.kind); - tmp = NULL_TREE; - } else { /* Switch off automatic reallocation since we have just done @@ -5459,12 +5636,13 @@ gfc_trans_allocate (gfc_code * code) object, we can use gfc_copy_class_to_class in its initialization mode. */ tmp = TREE_OPERAND (se.expr, 0); - tmp = gfc_copy_class_to_class (NULL_TREE, tmp, nelems); + tmp = gfc_copy_class_to_class (NULL_TREE, tmp, nelems, + upoly_expr); gfc_add_expr_to_block (&block, tmp); } gfc_free_expr (expr); - } + } // for-loop /* STAT. */ if (code->expr1) @@ -5642,7 +5820,14 @@ gfc_trans_deallocate (gfc_code *code) } if (al->expr->ts.type == BT_CLASS) - gfc_reset_vptr (&se.pre, al->expr); + { + gfc_reset_vptr (&se.pre, al->expr); + if (UNLIMITED_POLY (al->expr) + || (al->expr->ts.type == BT_DERIVED + && al->expr->ts.u.derived->attr.unlimited_polymorphic)) + /* Clear _len, too. */ + gfc_reset_len (&se.pre, al->expr); + } } else { @@ -5657,7 +5842,14 @@ gfc_trans_deallocate (gfc_code *code) gfc_add_expr_to_block (&se.pre, tmp); if (al->expr->ts.type == BT_CLASS) - gfc_reset_vptr (&se.pre, al->expr); + { + gfc_reset_vptr (&se.pre, al->expr); + if (UNLIMITED_POLY (al->expr) + || (al->expr->ts.type == BT_DERIVED + && al->expr->ts.u.derived->attr.unlimited_polymorphic)) + /* Clear _len, too. */ + gfc_reset_len (&se.pre, al->expr); + } } if (code->expr1) diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h index d7e5bb0..2eeffa3 100644 --- a/gcc/fortran/trans.h +++ b/gcc/fortran/trans.h @@ -350,6 +350,7 @@ tree gfc_class_set_static_fields (tree, tree, tree); tree gfc_class_data_get (tree); tree gfc_class_vptr_get (tree); tree gfc_class_len_get (tree); +gfc_expr * gfc_find_and_cut_at_last_class_ref (gfc_expr *); /* Get an accessor to the class' vtab's * field, when a class handle is available. */ tree gfc_class_vtab_hash_get (tree); @@ -366,9 +367,10 @@ tree gfc_vptr_def_init_get (tree); tree gfc_vptr_copy_get (tree); tree gfc_vptr_final_get (tree); void gfc_reset_vptr (stmtblock_t *, gfc_expr *); +void gfc_reset_len (stmtblock_t *, gfc_expr *); tree gfc_get_vptr_from_expr (tree); tree gfc_get_class_array_ref (tree, tree); -tree gfc_copy_class_to_class (tree, tree, tree); +tree gfc_copy_class_to_class (tree, tree, tree, bool); bool gfc_add_finalizer_call (stmtblock_t *, gfc_expr *); bool gfc_add_comp_finalizer_call (stmtblock_t *, tree, gfc_component *, bool); diff --git a/gcc/testsuite/gfortran.dg/allocate_alloc_opt_13.f90 b/gcc/testsuite/gfortran.dg/allocate_alloc_opt_13.f90 index 462b121..f9e199c 100644 --- a/gcc/testsuite/gfortran.dg/allocate_alloc_opt_13.f90 +++ b/gcc/testsuite/gfortran.dg/allocate_alloc_opt_13.f90 @@ -12,6 +12,9 @@ class(t), pointer :: b, d(:) allocate (a, b, source=c(1)) allocate (c(4), d(6), source=e) +allocate (a, b, mold=f()) +allocate (c(1), d(6), mold=g()) + allocate (a, b, source=f()) allocate (c(1), d(6), source=g()) diff --git a/gcc/testsuite/gfortran.dg/allocate_class_4.f90 b/gcc/testsuite/gfortran.dg/allocate_class_4.f90 new file mode 100644 index 0000000..23c9d53 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/allocate_class_4.f90 @@ -0,0 +1,36 @@ +! { dg-do compile } +! +! Part of PR 51946, but breaks easily, therefore introduce its own test +! Authors: Damian Rouson , +! Dominique Pelletier +! Contributed by: Andre Vehreschild + +module integrable_model_module + + implicit none + + type, abstract, public :: integrable_model + contains + procedure(default_constructor), deferred :: empty_instance + end type + + abstract interface + function default_constructor(this) result(blank_slate) + import :: integrable_model + class(integrable_model), intent(in) :: this + class(integrable_model), allocatable :: blank_slate + end function + end interface + + contains + + subroutine integrate(this) + class(integrable_model), intent(inout) :: this + class(integrable_model), allocatable :: residual + allocate(residual, source=this%empty_instance()) + end subroutine + +end module integrable_model_module + +! { dg-final { cleanup-modules "integrable_model_module" } } + diff --git a/gcc/testsuite/gfortran.dg/unlimited_polymorphic_20.f90 b/gcc/testsuite/gfortran.dg/unlimited_polymorphic_20.f90 index c6c6d29..49d35c8 100644 --- a/gcc/testsuite/gfortran.dg/unlimited_polymorphic_20.f90 +++ b/gcc/testsuite/gfortran.dg/unlimited_polymorphic_20.f90 @@ -23,12 +23,14 @@ program test implicit none character(LEN=:), allocatable, target :: S character(LEN=100) :: res - class(*), pointer :: ucp + class(*), pointer :: ucp, ucp2 call sub1 ("long test string", 16) call sub2 () S = "test" ucp => S call sub3 (ucp) + allocate (ucp2, source=ucp) + call sub3 (ucp2) call sub4 (S, 4) call sub4 ("This is a longer string.", 24) call bar (S, res) diff --git a/gcc/testsuite/gfortran.dg/unlimited_polymorphic_22.f90 b/gcc/testsuite/gfortran.dg/unlimited_polymorphic_22.f90 index 0753fe0..d0ef663 100644 --- a/gcc/testsuite/gfortran.dg/unlimited_polymorphic_22.f90 +++ b/gcc/testsuite/gfortran.dg/unlimited_polymorphic_22.f90 @@ -5,52 +5,211 @@ program test implicit none - class(*), pointer :: P + class(*), pointer :: P1, P2, P3 + class(*), pointer, dimension(:) :: PA1 + class(*), allocatable :: A1, A2 integer :: string_len = 10 *2 + character(len=:), allocatable, target :: str + character(len=:,kind=4), allocatable :: str4 + type T + class(*), pointer :: content + end type + type(T) :: o1, o2 + + str = "string for test" + str4 = 4_"string for test" + + allocate(character(string_len)::P1) + + select type(P1) + type is (character(*)) + P1 ="some test string" + if (P1 .ne. "some test string") call abort () + if (len(P1) .ne. 20) call abort () + if (len(P1) .eq. len("some test string")) call abort () + class default + call abort () + end select + + allocate(A1, source = P1) - allocate(character(string_len)::P) + select type(A1) + type is (character(*)) + if (A1 .ne. "some test string") call abort () + if (len(A1) .ne. 20) call abort () + if (len(A1) .eq. len("some test string")) call abort () + class default + call abort () + end select + + allocate(A2, source = convertType(P1)) - select type(P) + select type(A2) type is (character(*)) - P ="some test string" - if (P .ne. "some test string") then - call abort () - end if - if (len(P) .ne. 20) then - call abort () - end if - if (len(P) .eq. len("some test string")) then - call abort () - end if + if (A2 .ne. "some test string") call abort () + if (len(A2) .ne. 20) call abort () + if (len(A2) .eq. len("some test string")) call abort () class default call abort () end select - deallocate(P) + allocate(P2, source = str) + + select type(P2) + type is (character(*)) + if (P2 .ne. "string for test") call abort () + if (len(P2) .eq. 20) call abort () + if (len(P2) .ne. len("string for test")) call abort () + class default + call abort () + end select + + allocate(P3, source = "string for test") + + select type(P3) + type is (character(*)) + if (P3 .ne. "string for test") call abort () + if (len(P3) .eq. 20) call abort () + if (len(P3) .ne. len("string for test")) call abort () + class default + call abort () + end select + + allocate(character(len=10)::PA1(3)) + + select type(PA1) + type is (character(*)) + PA1(1) = "string 10 " + if (PA1(1) .ne. "string 10 ") call abort () + if (any(len(PA1(:)) .ne. [10,10,10])) call abort () + class default + call abort () + end select + + deallocate(PA1) + deallocate(P3) +! if (len(P3) .ne. 0) call abort() ! Can't check, because select +! type would be needed, which needs the vptr, which is 0 now. + deallocate(P2) + deallocate(A2) + deallocate(A1) + deallocate(P1) ! Now for kind=4 chars. - allocate(character(len=20,kind=4)::P) + allocate(character(len=20,kind=4)::P1) - select type(P) + select type(P1) type is (character(len=*,kind=4)) - P ="some test string" - if (P .ne. 4_"some test string") then - call abort () - end if - if (len(P) .ne. 20) then - call abort () - end if - if (len(P) .eq. len("some test string")) then - call abort () - end if + P1 ="some test string" + if (P1 .ne. 4_"some test string") call abort () + if (len(P1) .ne. 20) call abort () + if (len(P1) .eq. len("some test string")) call abort () type is (character(len=*,kind=1)) call abort () class default call abort () end select - deallocate(P) + allocate(A1, source=P1) + select type(A1) + type is (character(len=*,kind=4)) + if (A1 .ne. 4_"some test string") call abort () + if (len(A1) .ne. 20) call abort () + if (len(A1) .eq. len("some test string")) call abort () + type is (character(len=*,kind=1)) + call abort () + class default + call abort () + end select + + allocate(A2, source = convertType(P1)) + + select type(A2) + type is (character(len=*, kind=4)) + if (A2 .ne. 4_"some test string") call abort () + if (len(A2) .ne. 20) call abort () + if (len(A2) .eq. len("some test string")) call abort () + class default + call abort () + end select + + allocate(P2, source = str4) + + select type(P2) + type is (character(len=*,kind=4)) + if (P2 .ne. 4_"string for test") call abort () + if (len(P2) .eq. 20) call abort () + if (len(P2) .ne. len("string for test")) call abort () + class default + call abort () + end select + + allocate(P3, source = convertType(P2)) + + select type(P3) + type is (character(len=*, kind=4)) + if (P3 .ne. 4_"string for test") call abort () + if (len(P3) .eq. 20) call abort () + if (len(P3) .ne. len("string for test")) call abort () + class default + call abort () + end select + + allocate(character(kind=4, len=10)::PA1(3)) + + select type(PA1) + type is (character(len=*, kind=4)) + PA1(1) = 4_"string 10 " + if (PA1(1) .ne. 4_"string 10 ") call abort () + if (any(len(PA1(:)) .ne. [10,10,10])) call abort () + class default + call abort () + end select + + deallocate(PA1) + deallocate(P3) + deallocate(P2) + deallocate(A2) + deallocate(P1) + deallocate(A1) + + allocate(o1%content, source='test string') + allocate(o2%content, source=o1%content) + select type (c => o1%content) + type is (character(*)) + if (c /= 'test string') call abort () + class default + call abort() + end select + select type (d => o2%content) + type is (character(*)) + if (d /= 'test string') call abort () + class default + end select + + call AddCopy ('test string') + +contains + + function convertType(in) + class(*), pointer, intent(in) :: in + class(*), pointer :: convertType + + convertType => in + end function + + subroutine AddCopy(C) + class(*), intent(in) :: C + class(*), pointer :: P + allocate(P, source=C) + select type (P) + type is (character(*)) + if (P /= 'test string') call abort() + class default + call abort() + end select + end subroutine end program test