From mboxrd@z Thu Jan 1 00:00:00 1970 Return-Path: Received: (qmail 11205 invoked by alias); 19 Oct 2016 17:37:55 -0000 Mailing-List: contact fortran-help@gcc.gnu.org; run by ezmlm Precedence: bulk List-Id: List-Subscribe: List-Post: List-Help: , Sender: fortran-owner@gcc.gnu.org Received: (qmail 11172 invoked by uid 89); 19 Oct 2016 17:37:53 -0000 Authentication-Results: sourceware.org; auth=none X-Virus-Found: No X-Spam-SWARE-Status: No, score=0.0 required=5.0 tests=AWL,BAYES_50,FREEMAIL_FROM,RCVD_IN_DNSWL_LOW,SPF_PASS autolearn=ham version=3.3.2 spammy=harm, *code, joining, rss X-Spam-User: qpsmtpd, 2 recipients X-HELO: mout.gmx.net Received: from mout.gmx.net (HELO mout.gmx.net) (212.227.15.18) by sourceware.org (qpsmtpd/0.93/v0.84-503-g423c35a) with ESMTP; Wed, 19 Oct 2016 17:37:42 +0000 Received: from vepi2 ([84.63.206.51]) by mail.gmx.com (mrgmx001) with ESMTPSA (Nemesis) id 0Likl3-1cWmqw1uBB-00d0zm; Wed, 19 Oct 2016 19:37:36 +0200 Date: Wed, 19 Oct 2016 18:02:00 -0000 From: Andre Vehreschild To: GCC-Patches-ML , GCC-Fortran-ML , Dominique Dhumieres Subject: Re: [Fortran, Patch, PR{43366, 57117, 61337, 61376}, v1] Assign to polymorphic objects. Message-ID: <20161019193734.6bb6c039@vepi2> In-Reply-To: <20161013144200.05b61b66@vepi2> References: <20161013144200.05b61b66@vepi2> MIME-Version: 1.0 Content-Type: multipart/mixed; boundary="MP_/X4kPMHdmsD5O9BBE3_zaRHF" X-UI-Out-Filterresults: notjunk:1;V01:K0:cuXeqgbr1mY=:IumZv4Tac1RwgVoWhTeyD0 2IbxaZNC8eIc3FiJaqFxPriT5dlFou0jlpM0jIsZ+V9rlA4wlUJMJ69Dj7ovAjdgapCV40ESY kdlRNAg3vZgpojhhWAkvLKsUxVESgo6xakjEf1FQKJgV1Ju6xftCq1+0cYIMWqGlFqjy3z7/V fnuSHcK74M8Lu2/RWdIeYONh67RI3YMBaHFPp/G7TQQyBXlW8I6Z4qshDfBZe+be+NhMlSrQt e7poIrFGOKrmpzU9KgLeGgy7Jc5w6z59i0Nu5R3tlGBXYkMYNJRvfNXn3drePCbMpDLb9XEo9 uqlaJZ6gILLlt4uK7LDiAt771uuVkRNE7cEQD7DTr5lSbIw5bCM/qOMkjTR0hQmGfl/mAPJH0 p+l+DquFwpk+UcLOyPSBIb5RHnt2Zc61oH8sNmtwrwKr7YqWylXR6fjirVJfAOiqIy7GUI6Ie skMriChm6T+QO01DB6c9wwrn/60UOwfICZh6zJv3kWAqJbz+095DWyaZ0+gInpmTPESyTFJHL f6GKpk+Idpe6oD4G9pK+zTMO/poxHQNb6VpTXv8+8KkUCsltB9cjZH44C+ZK6VkHUaYzs3YD2 Q7yolaA4Tcg9QctKYlhITJywWQ2w62JAmIN1USpwu9ObgLLhJwqNvUbLswp/BiSD3L118mVpj KXGWPI6iiAg6RTgudRh0DPyguy/nVgjwxHPgx7b2L/1aCJE44sKtNEWTngjWN2s8Hge7e5ET4 cfK7w/I5GEN+ZvwTqGCMAOD5F+qHUU9bxgoZUErRnofnMXK6LFwc1xFXTyk= X-IsSubscribed: yes X-SW-Source: 2016-10/txt/msg00142.txt.bz2 --MP_/X4kPMHdmsD5O9BBE3_zaRHF Content-Type: text/plain; charset=US-ASCII Content-Transfer-Encoding: 7bit Content-Disposition: inline Content-length: 2708 Hi all, attached is an enhanced version of the patch, which now catches all of the testcases in the comments of pr61337. Thanks for reporting that I missed them, Dominique. For a detailed description see below. PR61337 needed just some more pre-code joining and correct handling of class-typed array constructors. Bootstraps and regtests ok on x86_64-linux/F23. Ok for trunk? Regards, Andre On Thu, 13 Oct 2016 14:42:00 +0200 Andre Vehreschild wrote: > Hi all, > > attached patch fixes the PRs (as to my knowledge): > > PR43366 - [OOP][F08] Intrinsic assign to polymorphic variable > PR57117 - [OOP] ICE for sourced allocation of a polymorphic entity using > TRANSPOSE > PR61337 - Wrong indexing and runtime crash with unlimited polymorphic array. > PR61378 - Error using private statement in polymorphic derived type > > The latter two are more or less fixed by accident or have been fixed by > previous patches, but have not been identified as such. Anyway, they are fixed > now and will be closed once the patch hits trunk. > > As for PR43366: I did not indent to fix this one, but when going for PR57117 I > once again stumbled over the deficiencies of gfc_trans_assigment's handling of > class objects. Therefore I figured what would be needed to complete PR43366 > and this is it now. > > As for PR57117: The issue was that ALLOCATE () used gfc_copy_class_to_class () > when a class object was allocated. The function gfc_copy_class_to_class () > does not use the scalarizer correctly. I.e., a transpose of the source= > expression would not be respected. I therefore decided to remove all this > special casing for class objects in ALLOCATE () and let gfc_trans_assignment > do the trick. This way ensuring, that any improvements of the scalarizer will > benefit class objects, too. Unfortunately did this mean to add more logic to > gfc_trans_assignment. While doing so, I learned that existing wrappers for > class assignments were obsoleted by the work I did, so I removed them. > > I tried to get rid of the malicious copy_class_to_class, too, but at the > moment it is still used at one location where components of derived types are > assigned. I was not bold enough to replace this occurrence with > trans_assignment yet. > > This patch shall make our lives easier, because now there is one routine to > assign all sorts of objects and no special casing for class objects is needed > anymore. I expect that some other parts of gfortran's code base may benefit > from the changes and have their complexity reduced. > > Bootstrapped and regtested ok on x86_64-linux/F23. Ok for trunk? > > Regards, > Andre -- Andre Vehreschild * Email: vehre ad gmx dot de --MP_/X4kPMHdmsD5O9BBE3_zaRHF Content-Type: application/octet-stream; name=pr43366_v2.clog Content-Transfer-Encoding: base64 Content-Disposition: attachment; filename=pr43366_v2.clog Content-length: 3437 Z2NjL2ZvcnRyYW4vQ2hhbmdlTG9nOgoKMjAxNi0xMC0xOSAgQW5kcmUgVmVo cmVzY2hpbGQgIDx2ZWhyZUBnY2MuZ251Lm9yZz4KCglQUiBmb3J0cmFuLzQz MzY2CglQUiBmb3J0cmFuLzUxODY0CglQUiBmb3J0cmFuLzU3MTE3CglQUiBm b3J0cmFuLzYxMzM3CglQUiBmb3J0cmFuLzYxMzc2CgkqIHByaW1hcnkuYyAo Z2ZjX2V4cHJfYXR0cik6IEZvciB0cmFuc2Zvcm1hdGlvbmFsIGZ1bmN0aW9u cyBvbiBjbGFzc2VzCglnZXQgdGhlIGF0dHJzIGZyb20gdGhlIGNsYXNzIGFy Z3VtZW50LgoJKiByZXNvbHZlLmMgKHJlc29sdmVfb3JkaW5hcnlfYXNzaWdu KTogUmVtb3ZlIGVycm9yIG1lc3NhZ2UgZHVlIHRvCglmZWF0dXJlIGltcGxl bWVudGF0aW9uLiAgUmV3cml0ZSBQT0lOVEVSX0FTU0lHTlMgdG8gb3JkaW5h cnkgb25lcyB3aGVuCgl0aGUgcmlnaHQtaGFuZCBzaWRlIGlzIHNjYWxhciBj bGFzcyBvYmplY3QgKHdpdGggc29tZSByZXN0cmljdGlvbnMpLgoJKiB0cmFu cy1hcnJheS5jICh0cmFuc19hcnJheV9jb25zdHJ1Y3Rvcik6IENyZWF0ZSB0 aGUgdGVtcG9yYXJ5IGZyb20KCWNsYXNzJyBpbm5lciB0eXBlLCBpLmUuLCB0 aGUgZGVyaXZlZCB0eXBlLgoJKGJ1aWxkX2NsYXNzX2FycmF5X3JlZik6IEFk ZCBzdXBwb3J0IGZvciBjbGFzcyBhcnJheSdzIHN0b3JhZ2Ugb2YgdGhlCglj bGFzcyBvYmplY3Qgb3IgdGhlIGFycmF5IGRlc2NyaXB0b3IgaW4gdGhlIGRl Y2wgc2F2ZWQgZGVzY3JpcHRvci4KCShnZmNfY29udl9leHByX2Rlc2NyaXB0 b3IpOiBXaGVuIGNyZWF0aW5nIHRlbXBvcmFyaWVzIGZvciBjbGFzcyBvYmpl Y3RzCglhZGQgdGhlIGNsYXNzIG9iamVjdCdzIGhhbmRsZSBpbnRvIHRoZSBk ZWNsIHNhdmVkIGRlc2NyaXB0b3IuCgkoc3RydWN0dXJlX2FsbG9jX2NvbXBz KTogVXNlIHRoZSBjb21tb24gd2F5IHRvIGdldCB0aGUgX2RhdGEgY29tcG9u ZW50LgoJKGdmY19pc19yZWFsbG9jYXRhYmxlX2xocyk6IEFkZCBub3Rpb24g b2YgYWxsb2NhdGFibGUgY2xhc3Mgb2JqZWN0cy4KCSogdHJhbnMtZXhwci5j IChnZmNfZmluZF9hbmRfY3V0X2F0X2xhc3RfY2xhc3NfcmVmKTogUmVtb3Zl IHRoZSBvbmx5IHJlZgoJb25seSB3aGVuIHRoZSBleHByZXNzaW9uJ3MgdHlw ZSBpcyBCVF9DTEFTUy4KCShnZmNfdHJhbnNfY2xhc3NfaW5pdF9hc3NpZ24p OiBDb3JyZWN0bHkgaGFuZGxlIGNsYXNzIGFycmF5cy4KCShnZmNfdHJhbnNf Y2xhc3NfYXNzaWduKTogSm9pbmVkIGludG8gZ2ZjX3RyYW5zX2Fzc2lnbm1l bnRfMS4KCShnZmNfY29udl9wcm9jZWR1cmVfY2FsbCk6IFN1cHBvcnQgZm9y IGNsYXNzIHR5cGVzIGFzIGFyZ3VtZW50cy4KCSh0cmFuc19nZXRfdXBvbHlf bGVuKTogRm9yIHVubGltaXRlZCBwb2x5bW9ycGhpY3MgcmV0cmlldmUgdGhl IF9sZW4KCWNvbXBvbmVudCdzIHRyZWUuCgkodHJhbnNfY2xhc3NfdnB0cl9s ZW5fYXNzaWdubWVudCk6IENhdGNoIGFsbCB3YXlzIHRvIGFzc2lnbiB0aGUg X3ZwdHIKCWFuZCBfbGVuIGNvbXBvbmVudHMgb2YgYSBjbGFzcyBvYmplY3Qg Y29ycmVjdGx5LgoJKHBvaW50ZXJfYXNzaWdubWVudF9pc19wcm9jX3BvaW50 ZXIpOiBJZGVudGlmeSBhc3NpZ25tZW50cyBvZgoJcHJvY2VkdXJlIHBvaW50 ZXJzLgoJKGdmY190cmFuc19wb2ludGVyX2Fzc2lnbm1lbnQpOiBFbmhhbmNl IHN1cHBvcnQgZm9yIGNsYXNzIG9iamVjdCBwb2ludGVyCglhc3NpZ25tZW50 cy4KCShnZmNfdHJhbnNfc2NhbGFyX2Fzc2lnbik6IFJlbW92ZWQgYXNzZXJ0 LgoJKHRyYW5zX2NsYXNzX2Fzc2lnbm1lbnQpOiBBc3NpZ24gdG8gYSBjbGFz cyBvYmplY3QuCgkoZ2ZjX3RyYW5zX2Fzc2lnbm1lbnRfMSk6IFRyZWF0IGNs YXNzIG9iamVjdHMgY29ycmVjdGx5LgoJKGdmY190cmFuc19hc3NpZ25tZW50 KTogUHJvcGFnYXRlIGZsYWdzIHRvIHRyYW5zX2Fzc2lnbm1lbnRfMS4KCSog dHJhbnMtc3RtdC5jIChnZmNfdHJhbnNfYWxsb2NhdGUpOiBVc2UgZ2ZjX3Ry YW5zX2Fzc2lnbm1lbnQgbm93CglpbnN0ZWFkIG9mIGNvcHlfY2xhc3NfdG9f Y2xhc3MuCgkqIHRyYW5zLXN0bXQuaDogRnVuY3Rpb24gcHJvdG90eXBlIHJl bW92ZWQuCgkqIHRyYW5zLmMgKHRyYW5zX2NvZGUpOiBMZXNzIHNwZWNpYWwg Y2FzaW5nIGZvciBjbGFzcyBvYmplY3RzLgoJKiB0cmFucy5oOiBBZGRlZCBm bGFncyB0byBnZmNfdHJhbnNfYXNzaWdubWVudCAoKSBwcm90b3R5cGUuCgpn Y2MvdGVzdHN1aXRlL0NoYW5nZUxvZzoKCjIwMTYtMTAtMTkgIEFuZHJlIFZl aHJlc2NoaWxkICA8dmVocmVAZ2NjLmdudS5vcmc+CgoJUFIgZm9ydHJhbi80 MzM2NgoJUFIgZm9ydHJhbi81NzExNwoJUFIgZm9ydHJhbi82MTMzNwoJKiBn Zm9ydHJhbi5kZy9hbGxvY19jb21wX2NsYXNzXzUuZjAzOiBOZXcgdGVzdC4K CSogZ2ZvcnRyYW4uZGcvY2xhc3NfYWxsb2NhdGVfMjEuZjkwOiBOZXcgdGVz dC4KCSogZ2ZvcnRyYW4uZGcvY2xhc3NfYWxsb2NhdGVfMjIuZjkwOiBOZXcg dGVzdC4KCSogZ2ZvcnRyYW4uZGcvcmVhbGxvY19vbl9hc3NpZ25fMjcuZjA4 OiBOZXcgdGVzdC4KCgo= --MP_/X4kPMHdmsD5O9BBE3_zaRHF Content-Type: text/x-patch Content-Transfer-Encoding: 7bit Content-Disposition: attachment; filename=pr43366_v2.patch Content-length: 57546 diff --git a/gcc/fortran/primary.c b/gcc/fortran/primary.c index 85589ee..3803b88 100644 --- a/gcc/fortran/primary.c +++ b/gcc/fortran/primary.c @@ -2359,6 +2359,10 @@ gfc_expr_attr (gfc_expr *e) attr.allocatable = CLASS_DATA (sym)->attr.allocatable; } } + else if (e->value.function.isym + && e->value.function.isym->transformational + && e->ts.type == BT_CLASS) + attr = CLASS_DATA (e)->attr; else attr = gfc_variable_attr (e, NULL); diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 87178a4..3bb057d 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -9834,10 +9834,6 @@ resolve_ordinary_assign (gfc_code *code, gfc_namespace *ns) "requires %<-frealloc-lhs%>", &lhs->where); return false; } - /* See PR 43366. */ - gfc_error ("Assignment to an allocatable polymorphic variable at %L " - "is not yet supported", &lhs->where); - return false; } else if (lhs->ts.type == BT_CLASS) { @@ -10740,6 +10736,19 @@ start: break; gfc_check_pointer_assign (code->expr1, code->expr2); + + /* Assigning a class object always is a regular assign. */ + if (code->expr2->ts.type == BT_CLASS + && !CLASS_DATA (code->expr2)->attr.dimension + && !(UNLIMITED_POLY (code->expr2) + && code->expr1->ts.type == BT_DERIVED + && (code->expr1->ts.u.derived->attr.sequence + || code->expr1->ts.u.derived->attr.is_bind_c)) + && !(gfc_expr_attr (code->expr1).proc_pointer + && code->expr2->expr_type == EXPR_VARIABLE + && code->expr2->symtree->n.sym->attr.flavor + == FL_PROCEDURE)) + code->op = EXEC_ASSIGN; break; } diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index 37cca79..c59e872 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -2292,7 +2292,8 @@ trans_array_constructor (gfc_ss * ss, locus * where) type = build_pointer_type (type); } else - type = gfc_typenode_for_spec (&expr->ts); + type = gfc_typenode_for_spec (expr->ts.type == BT_CLASS + ? &CLASS_DATA (expr)->ts : &expr->ts); /* See if the constructor determines the loop bounds. */ dynamic = false; @@ -3036,50 +3037,57 @@ build_class_array_ref (gfc_se *se, tree base, tree index) tree type; tree size; tree offset; - tree decl; + tree decl = NULL_TREE; tree tmp; gfc_expr *expr = se->ss->info->expr; gfc_ref *ref; - gfc_ref *class_ref; + gfc_ref *class_ref = NULL; gfc_typespec *ts; - if (expr == NULL - || (expr->ts.type != BT_CLASS - && !gfc_is_alloc_class_array_function (expr))) - return false; - - if (expr->symtree && expr->symtree->n.sym->ts.type == BT_CLASS) - ts = &expr->symtree->n.sym->ts; + if (se->expr && DECL_P (se->expr) && DECL_LANG_SPECIFIC (se->expr) + && GFC_DECL_SAVED_DESCRIPTOR (se->expr) + && GFC_CLASS_TYPE_P (TREE_TYPE (GFC_DECL_SAVED_DESCRIPTOR (se->expr)))) + decl = se->expr; else - ts = NULL; - class_ref = NULL; - - for (ref = expr->ref; ref; ref = ref->next) { - if (ref->type == REF_COMPONENT - && ref->u.c.component->ts.type == BT_CLASS - && ref->next && ref->next->type == REF_COMPONENT - && strcmp (ref->next->u.c.component->name, "_data") == 0 - && ref->next->next - && ref->next->next->type == REF_ARRAY - && ref->next->next->u.ar.type != AR_ELEMENT) + if (expr == NULL + || (expr->ts.type != BT_CLASS + && !gfc_is_alloc_class_array_function (expr) + && !gfc_is_class_array_ref (expr, NULL))) + return false; + + if (expr->symtree && expr->symtree->n.sym->ts.type == BT_CLASS) + ts = &expr->symtree->n.sym->ts; + else + ts = NULL; + + for (ref = expr->ref; ref; ref = ref->next) { - ts = &ref->u.c.component->ts; - class_ref = ref; - break; + if (ref->type == REF_COMPONENT + && ref->u.c.component->ts.type == BT_CLASS + && ref->next && ref->next->type == REF_COMPONENT + && strcmp (ref->next->u.c.component->name, "_data") == 0 + && ref->next->next + && ref->next->next->type == REF_ARRAY + && ref->next->next->u.ar.type != AR_ELEMENT) + { + ts = &ref->u.c.component->ts; + class_ref = ref; + break; + } } - } - if (ts == NULL) - return false; + if (ts == NULL) + return false; + } - if (class_ref == NULL && expr->symtree->n.sym->attr.function + if (class_ref == NULL && expr && expr->symtree->n.sym->attr.function && expr->symtree->n.sym == expr->symtree->n.sym->result) { gcc_assert (expr->symtree->n.sym->backend_decl == current_function_decl); decl = gfc_get_fake_result_decl (expr->symtree->n.sym, 0); } - else if (gfc_is_alloc_class_array_function (expr)) + else if (expr && gfc_is_alloc_class_array_function (expr)) { size = NULL_TREE; decl = NULL_TREE; @@ -3105,7 +3113,8 @@ build_class_array_ref (gfc_se *se, tree base, tree index) } else if (class_ref == NULL) { - decl = expr->symtree->n.sym->backend_decl; + if (decl == NULL_TREE) + decl = expr->symtree->n.sym->backend_decl; /* For class arrays the tree containing the class is stored in GFC_DECL_SAVED_DESCRIPTOR of the sym's backend_decl. For all others it's sym's backend_decl directly. */ @@ -3121,6 +3130,7 @@ build_class_array_ref (gfc_se *se, tree base, tree index) class_ref->next = NULL; gfc_init_se (&tmpse, NULL); gfc_conv_expr (&tmpse, expr); + gfc_add_block_to_block (&se->pre, &tmpse.pre); decl = tmpse.expr; class_ref->next = ref; } @@ -7094,6 +7104,28 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr) loop.from, loop.to, 0, GFC_ARRAY_UNKNOWN, false); parm = gfc_create_var (parmtype, "parm"); + + /* When expression is a class object, then add the class' handle to + the parm_decl. */ + if (expr->ts.type == BT_CLASS && expr->expr_type == EXPR_VARIABLE) + { + gfc_expr *class_expr = gfc_find_and_cut_at_last_class_ref (expr); + gfc_se classse; + + /* class_expr can be NULL, when no _class ref is in expr. + We must not fix this here with a gfc_fix_class_ref (). */ + if (class_expr) + { + gfc_init_se (&classse, NULL); + gfc_conv_expr (&classse, class_expr); + gfc_free_expr (class_expr); + + gcc_assert (classse.pre.head == NULL_TREE + && classse.post.head == NULL_TREE); + gfc_allocate_lang_decl (parm); + GFC_DECL_SAVED_DESCRIPTOR (parm) = classse.expr; + } + } } offset = gfc_index_zero_node; @@ -7255,6 +7287,13 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr) : base; gfc_conv_descriptor_offset_set (&loop.pre, parm, tmp); } + else if (IS_CLASS_ARRAY (expr) && !se->data_not_needed + && (!rank_remap || se->use_offset) + && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc))) + { + gfc_conv_descriptor_offset_set (&loop.pre, parm, + gfc_conv_descriptor_offset_get (desc)); + } else if (onebased && (!rank_remap || se->use_offset) && expr->symtree && !(expr->symtree->n.sym && expr->symtree->n.sym->ts.type == BT_CLASS @@ -7290,6 +7329,18 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr) GFC_DECL_SAVED_DESCRIPTOR (expr->symtree->n.sym->backend_decl) : expr->symtree->n.sym->backend_decl; } + else if (expr->expr_type == EXPR_ARRAY && VAR_P (desc) + && IS_CLASS_ARRAY (expr)) + { + tree vtype; + gfc_allocate_lang_decl (desc); + tmp = gfc_create_var (expr->ts.u.derived->backend_decl, "class"); + GFC_DECL_SAVED_DESCRIPTOR (desc) = tmp; + vtype = gfc_class_vptr_get (tmp); + gfc_add_modify (&se->pre, vtype, + gfc_build_addr_expr (TREE_TYPE (vtype), + gfc_find_vtab (&expr->ts)->backend_decl)); + } if (!se->direct_byref || se->byref_noassign) { /* Get a pointer to the new descriptor. */ @@ -8200,10 +8251,8 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, /* Allocatable CLASS components. */ comp = fold_build3_loc (input_location, COMPONENT_REF, ctype, decl, cdecl, NULL_TREE); - /* Add reference to '_data' component. */ - tmp = CLASS_DATA (c)->backend_decl; - comp = fold_build3_loc (input_location, COMPONENT_REF, - TREE_TYPE (tmp), comp, tmp, NULL_TREE); + + comp = gfc_class_data_get (comp); if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (comp))) gfc_conv_descriptor_data_set (&fnblock, comp, null_pointer_node); else @@ -8541,6 +8590,14 @@ gfc_is_reallocatable_lhs (gfc_expr *expr) if (!expr->ref) return false; + /* An allocatable class variable with no reference. */ + if (expr->symtree->n.sym->ts.type == BT_CLASS + && CLASS_DATA (expr->symtree->n.sym)->attr.allocatable + && expr->ref && expr->ref->type == REF_COMPONENT + && strcmp (expr->ref->u.c.component->name, "_data") == 0 + && expr->ref->next == NULL) + return true; + /* An allocatable variable. */ if (expr->symtree->n.sym->attr.allocatable && expr->ref diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index 6b974db..10fe9b9 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -350,7 +350,7 @@ gfc_expr * gfc_find_and_cut_at_last_class_ref (gfc_expr *e) { gfc_expr *base_expr; - gfc_ref *ref, *class_ref, *tail, *array_ref; + gfc_ref *ref, *class_ref, *tail = NULL, *array_ref; /* Find the last class reference. */ class_ref = NULL; @@ -383,7 +383,7 @@ gfc_find_and_cut_at_last_class_ref (gfc_expr *e) tail = class_ref->next; class_ref->next = NULL; } - else + else if (e->symtree && e->symtree->n.sym->ts.type == BT_CLASS) { tail = e->ref; e->ref = NULL; @@ -397,7 +397,7 @@ gfc_find_and_cut_at_last_class_ref (gfc_expr *e) gfc_free_ref_list (class_ref->next); class_ref->next = tail; } - else + else if (e->symtree && e->symtree->n.sym->ts.type == BT_CLASS) { gfc_free_ref_list (e->ref); e->ref = tail; @@ -1453,7 +1453,12 @@ gfc_trans_class_init_assign (gfc_code *code) if (code->expr1->ts.type == BT_CLASS && CLASS_DATA (code->expr1)->attr.dimension) - tmp = gfc_trans_class_array_init_assign (rhs, lhs, code->expr1); + { + gfc_array_spec *tmparr = gfc_get_array_spec (); + *tmparr = *CLASS_DATA (code->expr1)->as; + gfc_add_full_array_ref (lhs, tmparr); + tmp = gfc_trans_class_array_init_assign (rhs, lhs, code->expr1); + } else { sz = gfc_copy_expr (code->expr1); @@ -1498,114 +1503,6 @@ gfc_trans_class_init_assign (gfc_code *code) } -/* Translate an assignment to a CLASS object - (pointer or ordinary assignment). */ - -tree -gfc_trans_class_assign (gfc_expr *expr1, gfc_expr *expr2, gfc_exec_op op) -{ - stmtblock_t block; - tree tmp; - gfc_expr *lhs; - gfc_expr *rhs; - gfc_ref *ref; - - gfc_start_block (&block); - - ref = expr1->ref; - while (ref && ref->next) - ref = ref->next; - - /* Class valued proc_pointer assignments do not need any further - preparation. */ - if (ref && ref->type == REF_COMPONENT - && ref->u.c.component->attr.proc_pointer - && expr2->expr_type == EXPR_VARIABLE - && expr2->symtree->n.sym->attr.flavor == FL_PROCEDURE - && op == EXEC_POINTER_ASSIGN) - goto assign; - - if (expr2->ts.type != BT_CLASS) - { - /* Insert an additional assignment which sets the '_vptr' field. */ - gfc_symbol *vtab = NULL; - gfc_symtree *st; - - lhs = gfc_copy_expr (expr1); - gfc_add_vptr_component (lhs); - - if (UNLIMITED_POLY (expr1) - && expr2->expr_type == EXPR_NULL && expr2->ts.type == BT_UNKNOWN) - { - rhs = gfc_get_null_expr (&expr2->where); - goto assign_vptr; - } - - if (expr2->expr_type == EXPR_NULL) - vtab = gfc_find_vtab (&expr1->ts); - else - vtab = gfc_find_vtab (&expr2->ts); - gcc_assert (vtab); - - rhs = gfc_get_expr (); - rhs->expr_type = EXPR_VARIABLE; - gfc_find_sym_tree (vtab->name, vtab->ns, 1, &st); - rhs->symtree = st; - rhs->ts = vtab->ts; -assign_vptr: - tmp = gfc_trans_pointer_assignment (lhs, rhs); - gfc_add_expr_to_block (&block, tmp); - - gfc_free_expr (lhs); - gfc_free_expr (rhs); - } - else if (expr1->ts.type == BT_DERIVED && UNLIMITED_POLY (expr2)) - { - /* F2003:C717 only sequence and bind-C types can come here. */ - gcc_assert (expr1->ts.u.derived->attr.sequence - || expr1->ts.u.derived->attr.is_bind_c); - gfc_add_data_component (expr2); - goto assign; - } - else if (CLASS_DATA (expr2)->attr.dimension && expr2->expr_type != EXPR_FUNCTION) - { - /* Insert an additional assignment which sets the '_vptr' field. */ - lhs = gfc_copy_expr (expr1); - gfc_add_vptr_component (lhs); - - rhs = gfc_copy_expr (expr2); - gfc_add_vptr_component (rhs); - - tmp = gfc_trans_pointer_assignment (lhs, rhs); - gfc_add_expr_to_block (&block, tmp); - - gfc_free_expr (lhs); - gfc_free_expr (rhs); - } - - /* Do the actual CLASS assignment. */ - if (expr2->ts.type == BT_CLASS - && !CLASS_DATA (expr2)->attr.dimension) - op = EXEC_ASSIGN; - else if (expr2->expr_type != EXPR_FUNCTION || expr2->ts.type != BT_CLASS - || !CLASS_DATA (expr2)->attr.dimension) - gfc_add_data_component (expr1); - -assign: - - if (op == EXEC_ASSIGN) - tmp = gfc_trans_assignment (expr1, expr2, false, true); - else if (op == EXEC_POINTER_ASSIGN) - tmp = gfc_trans_pointer_assignment (expr1, expr2); - else - gcc_unreachable(); - - gfc_add_expr_to_block (&block, tmp); - - return gfc_finish_block (&block); -} - - /* End of prototype trans-class.c */ @@ -5903,6 +5800,8 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, if (comp) ts = comp->ts; + else if (sym->ts.type == BT_CLASS) + ts = CLASS_DATA (sym)->ts; else ts = sym->ts; @@ -5973,7 +5872,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr))))) se->expr = build_fold_indirect_ref_loc (input_location, - se->expr); + se->expr); /* If the lhs of an assignment x = f(..) is allocatable and f2003 is allowed, we must do the automatic reallocation. @@ -6259,6 +6158,26 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, } } + /* Associate the rhs class object's meta-data with the result, when the + result is a temporary. */ + if (args && args->expr && args->expr->ts.type == BT_CLASS + && sym->ts.type == BT_CLASS && result != NULL_TREE && DECL_P (result) + && !GFC_CLASS_TYPE_P (TREE_TYPE (result))) + { + gfc_se parmse; + gfc_expr *class_expr = gfc_find_and_cut_at_last_class_ref (args->expr); + + gfc_init_se (&parmse, NULL); + parmse.data_not_needed = 1; + gfc_conv_expr (&parmse, class_expr); + if (!DECL_LANG_SPECIFIC (result)) + gfc_allocate_lang_decl (result); + GFC_DECL_SAVED_DESCRIPTOR (result) = parmse.expr; + gfc_free_expr (class_expr); + gcc_assert (parmse.pre.head == NULL_TREE + && parmse.post.head == NULL_TREE); + } + /* Follow the function call with the argument post block. */ if (byref) { @@ -7881,6 +7800,201 @@ gfc_conv_expr_reference (gfc_se * se, gfc_expr * expr) } +/* Get the _len component for an unlimited polymorphic expression. */ + +static tree +trans_get_upoly_len (stmtblock_t *block, gfc_expr *expr) +{ + gfc_se se; + gfc_ref *ref = expr->ref; + + gfc_init_se (&se, NULL); + while (ref && ref->next) + ref = ref->next; + gfc_add_len_component (expr); + gfc_conv_expr (&se, expr); + gfc_add_block_to_block (block, &se.pre); + gcc_assert (se.post.head == NULL_TREE); + if (ref) + { + gfc_free_ref_list (ref->next); + ref->next = NULL; + } + else + { + gfc_free_ref_list (expr->ref); + expr->ref = NULL; + } + return se.expr; +} + + +/* Assign _vptr and _len components as appropriate. BLOCK should be a + statement-list outside of the scalarizer-loop. When code is generated, that + depends on the scalarized expression, it is added to RSE.PRE. + Returns le's _vptr tree and when set the len expressions in to_lenp and + from_lenp to form a le%_vptr%_copy (re, le, [from_lenp, to_lenp]) + expression. */ + +static tree +trans_class_vptr_len_assignment (stmtblock_t *block, gfc_expr * le, + gfc_expr * re, gfc_se *rse, + tree * to_lenp, tree * from_lenp) +{ + gfc_se se; + gfc_expr * vptr_expr; + tree tmp, to_len = NULL_TREE, from_len = NULL_TREE, lhs_vptr; + bool set_vptr = false, temp_rhs = false; + stmtblock_t *pre = block; + + /* Create a temporary for complicated expressions. */ + if (re->expr_type != EXPR_VARIABLE && re->expr_type != EXPR_NULL + && rse->expr != NULL_TREE && !DECL_P (rse->expr)) + { + tmp = gfc_create_var (TREE_TYPE (rse->expr), "rhs"); + pre = &rse->pre; + gfc_add_modify (&rse->pre, tmp, rse->expr); + rse->expr = tmp; + temp_rhs = true; + } + + /* Get the _vptr for the left-hand side expression. */ + gfc_init_se (&se, NULL); + vptr_expr = gfc_find_and_cut_at_last_class_ref (le); + if (vptr_expr != NULL && gfc_expr_attr (vptr_expr).class_ok) + { + /* Care about _len for unlimited polymorphic entities. */ + if (UNLIMITED_POLY (vptr_expr) + || (vptr_expr->ts.type == BT_DERIVED + && vptr_expr->ts.u.derived->attr.unlimited_polymorphic)) + to_len = trans_get_upoly_len (block, vptr_expr); + gfc_add_vptr_component (vptr_expr); + set_vptr = true; + } + else + vptr_expr = gfc_lval_expr_from_sym (gfc_find_vtab (&le->ts)); + se.want_pointer = 1; + gfc_conv_expr (&se, vptr_expr); + gfc_free_expr (vptr_expr); + gfc_add_block_to_block (block, &se.pre); + gcc_assert (se.post.head == NULL_TREE); + lhs_vptr = se.expr; + STRIP_NOPS (lhs_vptr); + + /* Set the _vptr only when the left-hand side of the assignment is a + class-object. */ + if (set_vptr) + { + /* Get the vptr from the rhs expression only, when it is variable. + Functions are expected to be assigned to a temporary beforehand. */ + vptr_expr = re->expr_type == EXPR_VARIABLE + ? gfc_find_and_cut_at_last_class_ref (re) + : NULL; + if (vptr_expr != NULL && vptr_expr->ts.type == BT_CLASS) + { + if (to_len != NULL_TREE) + { + /* Get the _len information from the rhs. */ + if (UNLIMITED_POLY (vptr_expr) + || (vptr_expr->ts.type == BT_DERIVED + && vptr_expr->ts.u.derived->attr.unlimited_polymorphic)) + from_len = trans_get_upoly_len (block, vptr_expr); + } + gfc_add_vptr_component (vptr_expr); + } + else + { + if (re->expr_type == EXPR_VARIABLE + && DECL_P (re->symtree->n.sym->backend_decl) + && DECL_LANG_SPECIFIC (re->symtree->n.sym->backend_decl) + && GFC_DECL_SAVED_DESCRIPTOR (re->symtree->n.sym->backend_decl) + && GFC_CLASS_TYPE_P (TREE_TYPE (GFC_DECL_SAVED_DESCRIPTOR ( + re->symtree->n.sym->backend_decl)))) + { + vptr_expr = NULL; + se.expr = gfc_class_vptr_get (GFC_DECL_SAVED_DESCRIPTOR ( + re->symtree->n.sym->backend_decl)); + if (to_len) + from_len = gfc_class_len_get (GFC_DECL_SAVED_DESCRIPTOR ( + re->symtree->n.sym->backend_decl)); + } + else if (temp_rhs && re->ts.type == BT_CLASS) + { + vptr_expr = NULL; + se.expr = gfc_class_vptr_get (rse->expr); + } + else if (re->expr_type != EXPR_NULL) + /* Only when rhs is non-NULL use its declared type for vptr + initialisation. */ + vptr_expr = gfc_lval_expr_from_sym (gfc_find_vtab (&re->ts)); + else + /* When the rhs is NULL use the vtab of lhs' declared type. */ + vptr_expr = gfc_lval_expr_from_sym (gfc_find_vtab (&le->ts)); + } + + if (vptr_expr) + { + gfc_init_se (&se, NULL); + se.want_pointer = 1; + gfc_conv_expr (&se, vptr_expr); + gfc_free_expr (vptr_expr); + gfc_add_block_to_block (block, &se.pre); + gcc_assert (se.post.head == NULL_TREE); + } + gfc_add_modify (pre, lhs_vptr, fold_convert (TREE_TYPE (lhs_vptr), + se.expr)); + + if (to_len != NULL_TREE) + { + /* The _len component needs to be set. Figure how to get the + value of the right-hand side. */ + if (from_len == NULL_TREE) + { + if (rse->string_length != NULL_TREE) + from_len = rse->string_length; + else if (re->ts.type == BT_CHARACTER && re->ts.u.cl->length) + { + from_len = gfc_get_expr_charlen (re); + gfc_init_se (&se, NULL); + gfc_conv_expr (&se, re->ts.u.cl->length); + gfc_add_block_to_block (block, &se.pre); + gcc_assert (se.post.head == NULL_TREE); + from_len = gfc_evaluate_now (se.expr, block); + } + else + from_len = integer_zero_node; + } + gfc_add_modify (pre, to_len, fold_convert (TREE_TYPE (to_len), + from_len)); + } + } + + /* Return the _len trees only, when requested. */ + if (to_lenp) + *to_lenp = to_len; + if (from_lenp) + *from_lenp = from_len; + return lhs_vptr; +} + +/* Indentify class valued proc_pointer assignments. */ + +static bool +pointer_assignment_is_proc_pointer (gfc_expr * expr1, gfc_expr * expr2) +{ + gfc_ref * ref; + + ref = expr1->ref; + while (ref && ref->next) + ref = ref->next; + + return ref && ref->type == REF_COMPONENT + && ref->u.c.component->attr.proc_pointer + && expr2->expr_type == EXPR_VARIABLE + && expr2->symtree->n.sym->attr.flavor == FL_PROCEDURE; +} + + tree gfc_trans_pointer_assign (gfc_code * code) { @@ -7893,20 +8007,22 @@ gfc_trans_pointer_assign (gfc_code * code) tree gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2) { - gfc_expr *expr1_vptr = NULL; gfc_se lse; gfc_se rse; stmtblock_t block; tree desc; tree tmp; tree decl; - bool scalar; + bool scalar, non_proc_pointer_assign; gfc_ss *ss; gfc_start_block (&block); gfc_init_se (&lse, NULL); + /* Usually testing whether this is not a proc pointer assignment. */ + non_proc_pointer_assign = !pointer_assignment_is_proc_pointer (expr1, expr2); + /* Check whether the expression is a scalar or not; we cannot use expr1->rank as it can be nonzero for proc pointers. */ ss = gfc_walk_expr (expr1); @@ -7915,7 +8031,7 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2) gfc_free_ss_chain (ss); if (expr1->ts.type == BT_DERIVED && expr2->ts.type == BT_CLASS - && expr2->expr_type != EXPR_FUNCTION) + && expr2->expr_type != EXPR_FUNCTION && non_proc_pointer_assign) { gfc_add_data_component (expr2); /* The following is required as gfc_add_data_component doesn't @@ -7932,6 +8048,13 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2) rse.want_pointer = 1; gfc_conv_expr (&rse, expr2); + if (non_proc_pointer_assign && expr1->ts.type == BT_CLASS) + { + trans_class_vptr_len_assignment (&block, expr1, expr2, &rse, NULL, + NULL); + lse.expr = gfc_class_data_get (lse.expr); + } + if (expr1->symtree->n.sym->attr.proc_pointer && expr1->symtree->n.sym->attr.dummy) lse.expr = build_fold_indirect_ref_loc (input_location, @@ -7945,27 +8068,6 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2) gfc_add_block_to_block (&block, &lse.pre); gfc_add_block_to_block (&block, &rse.pre); - /* For string assignments to unlimited polymorphic pointers add an - assignment of the string_length to the _len component of the - pointer. */ - if ((expr1->ts.type == BT_CLASS || expr1->ts.type == BT_DERIVED) - && expr1->ts.u.derived->attr.unlimited_polymorphic - && (expr2->ts.type == BT_CHARACTER || - ((expr2->ts.type == BT_DERIVED || expr2->ts.type == BT_CLASS) - && expr2->ts.u.derived->attr.unlimited_polymorphic))) - { - gfc_expr *len_comp; - gfc_se se; - len_comp = gfc_get_len_component (expr1); - gfc_init_se (&se, NULL); - gfc_conv_expr (&se, len_comp); - - /* ptr % _len = len (str) */ - gfc_add_modify (&block, se.expr, rse.string_length); - lse.string_length = se.expr; - gfc_free_expr (len_comp); - } - /* Check character lengths if character expression. The test is only really added if -fbounds-check is enabled. Exclude deferred character length lefthand sides. */ @@ -7992,9 +8094,6 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2) build_int_cst (gfc_charlen_type_node, 0)); } - if (expr1->ts.type == BT_DERIVED && expr2->ts.type == BT_CLASS) - rse.expr = gfc_class_data_get (rse.expr); - gfc_add_modify (&block, lse.expr, fold_convert (TREE_TYPE (lse.expr), rse.expr)); @@ -8005,6 +8104,7 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2) { gfc_ref* remap; bool rank_remap; + tree expr1_vptr = NULL_TREE; tree strlen_lhs; tree strlen_rhs = NULL_TREE; @@ -8021,9 +8121,6 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2) gfc_init_se (&lse, NULL); if (remap) lse.descriptor_only = 1; - if (expr2->expr_type == EXPR_FUNCTION && expr2->ts.type == BT_CLASS - && expr1->ts.type == BT_CLASS) - expr1_vptr = gfc_copy_expr (expr1); gfc_conv_expr_descriptor (&lse, expr1); strlen_lhs = lse.string_length; desc = lse.expr; @@ -8049,16 +8146,15 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2) rse.expr = gfc_class_data_get (rse.expr); else { + expr1_vptr = trans_class_vptr_len_assignment (&block, expr1, + expr2, &rse, + NULL, NULL); gfc_add_block_to_block (&block, &rse.pre); tmp = gfc_create_var (TREE_TYPE (rse.expr), "ptrtemp"); gfc_add_modify (&lse.pre, tmp, rse.expr); - gfc_add_vptr_component (expr1_vptr); - gfc_init_se (&rse, NULL); - rse.want_pointer = 1; - gfc_conv_expr (&rse, expr1_vptr); - gfc_add_modify (&lse.pre, rse.expr, - fold_convert (TREE_TYPE (rse.expr), + gfc_add_modify (&lse.pre, expr1_vptr, + fold_convert (TREE_TYPE (expr1_vptr), gfc_class_vptr_get (tmp))); rse.expr = gfc_class_data_get (tmp); } @@ -8086,6 +8182,10 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2) { gfc_conv_expr_descriptor (&rse, expr2); strlen_rhs = rse.string_length; + if (expr1->ts.type == BT_CLASS) + expr1_vptr = trans_class_vptr_len_assignment (&block, expr1, + expr2, &rse, + NULL, NULL); } } else if (expr2->expr_type == EXPR_VARIABLE) @@ -8104,12 +8204,22 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2) gfc_init_se (&rse, NULL); rse.descriptor_only = 1; gfc_conv_expr (&rse, expr2); + if (expr1->ts.type == BT_CLASS) + trans_class_vptr_len_assignment (&block, expr1, expr2, &rse, + NULL, NULL); tmp = gfc_get_element_type (TREE_TYPE (rse.expr)); tmp = fold_convert (gfc_array_index_type, size_in_bytes (tmp)); if (!INTEGER_CST_P (tmp)) gfc_add_block_to_block (&lse.post, &rse.pre); gfc_add_modify (&lse.post, GFC_DECL_SPAN(decl), tmp); } + else if (expr1->ts.type == BT_CLASS) + { + rse.expr = NULL_TREE; + rse.string_length = NULL_TREE; + trans_class_vptr_len_assignment (&block, expr1, expr2, &rse, + NULL, NULL); + } } else if (expr2->expr_type == EXPR_FUNCTION && expr2->ts.type == BT_CLASS) { @@ -8123,16 +8233,15 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2) } else { + expr1_vptr = trans_class_vptr_len_assignment (&block, expr1, + expr2, &rse, NULL, + NULL); gfc_add_block_to_block (&block, &rse.pre); tmp = gfc_create_var (TREE_TYPE (rse.expr), "ptrtemp"); gfc_add_modify (&lse.pre, tmp, rse.expr); - gfc_add_vptr_component (expr1_vptr); - gfc_init_se (&rse, NULL); - rse.want_pointer = 1; - gfc_conv_expr (&rse, expr1_vptr); - gfc_add_modify (&lse.pre, rse.expr, - fold_convert (TREE_TYPE (rse.expr), + gfc_add_modify (&lse.pre, expr1_vptr, + fold_convert (TREE_TYPE (expr1_vptr), gfc_class_vptr_get (tmp))); rse.expr = gfc_class_data_get (tmp); gfc_add_modify (&lse.pre, desc, rse.expr); @@ -8151,9 +8260,6 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2) gfc_add_modify (&lse.pre, desc, tmp); } - if (expr1_vptr) - gfc_free_expr (expr1_vptr); - gfc_add_block_to_block (&block, &lse.pre); if (rank_remap) gfc_add_block_to_block (&block, &rse.pre); @@ -8403,7 +8509,6 @@ gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, gfc_typespec ts, if (rse->string_length != NULL_TREE) { - gcc_assert (rse->string_length != NULL_TREE); gfc_conv_string_parameter (rse); gfc_add_block_to_block (&block, &rse->pre); rlen = rse->string_length; @@ -9359,14 +9464,101 @@ is_runtime_conformable (gfc_expr *expr1, gfc_expr *expr2) return false; } + +static tree +trans_class_assignment (stmtblock_t *block, gfc_expr *lhs, gfc_expr *rhs, + gfc_se *lse, gfc_se *rse, bool use_vptr_copy) +{ + tree tmp; + tree fcn; + tree stdcopy, to_len, from_len; + vec *args = NULL; + + tmp = trans_class_vptr_len_assignment (block, lhs, rhs, rse, &to_len, + &from_len); + + fcn = gfc_vptr_copy_get (tmp); + + tmp = GFC_CLASS_TYPE_P (TREE_TYPE (rse->expr)) + ? gfc_class_data_get (rse->expr) : rse->expr; + if (use_vptr_copy) + { + if (!POINTER_TYPE_P (TREE_TYPE (tmp)) + || INDIRECT_REF_P (tmp) + || (rhs->ts.type == BT_DERIVED + && rhs->ts.u.derived->attr.unlimited_polymorphic + && !rhs->ts.u.derived->attr.pointer + && !rhs->ts.u.derived->attr.allocatable) + || (UNLIMITED_POLY (rhs) + && !CLASS_DATA (rhs)->attr.pointer + && !CLASS_DATA (rhs)->attr.allocatable)) + vec_safe_push (args, gfc_build_addr_expr (NULL_TREE, tmp)); + else + vec_safe_push (args, tmp); + tmp = GFC_CLASS_TYPE_P (TREE_TYPE (lse->expr)) + ? gfc_class_data_get (lse->expr) : lse->expr; + if (!POINTER_TYPE_P (TREE_TYPE (tmp)) + || INDIRECT_REF_P (tmp) + || (lhs->ts.type == BT_DERIVED + && lhs->ts.u.derived->attr.unlimited_polymorphic + && !lhs->ts.u.derived->attr.pointer + && !lhs->ts.u.derived->attr.allocatable) + || (UNLIMITED_POLY (lhs) + && !CLASS_DATA (lhs)->attr.pointer + && !CLASS_DATA (lhs)->attr.allocatable)) + vec_safe_push (args, gfc_build_addr_expr (NULL_TREE, tmp)); + else + vec_safe_push (args, tmp); + + stdcopy = build_call_vec (TREE_TYPE (TREE_TYPE (fcn)), fcn, args); + + if (to_len != NULL_TREE && !integer_zerop (from_len)) + { + tree extcopy; + vec_safe_push (args, from_len); + vec_safe_push (args, to_len); + extcopy = build_call_vec (TREE_TYPE (TREE_TYPE (fcn)), fcn, args); + + tmp = fold_build2_loc (input_location, GT_EXPR, + boolean_type_node, from_len, + integer_zero_node); + return fold_build3_loc (input_location, COND_EXPR, + void_type_node, tmp, + extcopy, stdcopy); + } + else + return stdcopy; + } + else + { + tree rhst = GFC_CLASS_TYPE_P (TREE_TYPE (lse->expr)) + ? gfc_class_data_get (lse->expr) : lse->expr; + stmtblock_t tblock; + gfc_init_block (&tblock); + if (!POINTER_TYPE_P (TREE_TYPE (tmp))) + tmp = gfc_build_addr_expr (NULL_TREE, tmp); + if (!POINTER_TYPE_P (TREE_TYPE (rhst))) + rhst = gfc_build_addr_expr (NULL_TREE, rhst); + /* When coming from a ptr_copy lhs and rhs are swapped. */ + gfc_add_modify_loc (input_location, &tblock, rhst, + fold_convert (TREE_TYPE (rhst), tmp)); + return gfc_finish_block (&tblock); + } +} + /* Subroutine of gfc_trans_assignment that actually scalarizes the assignment. EXPR1 is the destination/LHS and EXPR2 is the source/RHS. init_flag indicates initialization expressions and dealloc that no - deallocate prior assignment is needed (if in doubt, set true). */ + deallocate prior assignment is needed (if in doubt, set true). + When PTR_COPY is set and expr1 is a class type, then use the _vptr-copy + routine instead of a pointer assignment. Alias resolution is only done, + when MAY_ALIAS is set (the default). This flag is used by ALLOCATE() + where it is known, that newly allocated memory on the lhs can never be + an alias of the rhs. */ static tree gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag, - bool dealloc) + bool dealloc, bool use_vptr_copy, bool may_alias) { gfc_se lse; gfc_se rse; @@ -9382,7 +9574,7 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag, tree string_length; int n; bool maybe_workshare = false; - symbol_attribute lhs_caf_attr, rhs_caf_attr; + symbol_attribute lhs_caf_attr, rhs_caf_attr, lhs_attr; /* Assignment of the form lhs = rhs. */ gfc_start_block (&block); @@ -9403,8 +9595,13 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag, || gfc_is_alloc_class_scalar_function (expr2))) expr2->must_finalize = 1; - lhs_caf_attr = gfc_caf_attr (expr1); - rhs_caf_attr = gfc_caf_attr (expr2); + /* Only analyze the expressions for coarray properties, when in coarray-lib + mode. */ + if (flag_coarray == GFC_FCOARRAY_LIB) + { + lhs_caf_attr = gfc_caf_attr (expr1); + rhs_caf_attr = gfc_caf_attr (expr2); + } if (lss != gfc_ss_terminator) { @@ -9437,7 +9634,8 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag, for (n = 0; n < GFC_MAX_DIMENSIONS; n++) loop.reverse[n] = GFC_ENABLE_REVERSE; /* Resolve any data dependencies in the statement. */ - gfc_conv_resolve_dependencies (&loop, lss, rss); + if (may_alias) + gfc_conv_resolve_dependencies (&loop, lss, rss); /* Setup the scalarizing loops. */ gfc_conv_loop_setup (&loop, &expr2->where); @@ -9584,9 +9782,26 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag, gfc_add_block_to_block (&loop.post, &rse.post); } - if (flag_coarray == GFC_FCOARRAY_LIB - && lhs_caf_attr.codimension && rhs_caf_attr.codimension - && lhs_caf_attr.alloc_comp && rhs_caf_attr.alloc_comp) + lhs_attr = gfc_expr_attr (expr1); + if ((use_vptr_copy || lhs_attr.pointer + || (lhs_attr.allocatable && !lhs_attr.dimension)) + && (expr1->ts.type == BT_CLASS + || (gfc_is_class_array_ref (expr1, NULL) + || gfc_is_class_scalar_expr (expr1)) + || (gfc_is_class_array_ref (expr2, NULL) + || gfc_is_class_scalar_expr (expr2)))) + { + tmp = trans_class_assignment (&body, expr1, expr2, &lse, &rse, + use_vptr_copy || (lhs_attr.allocatable + && !lhs_attr.dimension)); + /* Modify the expr1 after the assignment, to allow the realloc below. + Therefore only needed, when realloc_lhs is enabled. */ + if (flag_realloc_lhs && !lhs_attr.pointer) + gfc_add_data_component (expr1); + } + else if (flag_coarray == GFC_FCOARRAY_LIB + && lhs_caf_attr.codimension && rhs_caf_attr.codimension + && lhs_caf_attr.alloc_comp && rhs_caf_attr.alloc_comp) { gfc_code code; gfc_actual_arglist a1, a2; @@ -9604,7 +9819,13 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag, || scalar_to_array || expr2->expr_type == EXPR_ARRAY, !(l_is_temp || init_flag) && dealloc); + /* Add the pre blocks to the body. */ + gfc_add_block_to_block (&body, &rse.pre); + gfc_add_block_to_block (&body, &lse.pre); gfc_add_expr_to_block (&body, tmp); + /* Add the post blocks to the body. */ + gfc_add_block_to_block (&body, &rse.post); + gfc_add_block_to_block (&body, &lse.post); if (lss == gfc_ss_terminator) { @@ -9719,7 +9940,7 @@ copyable_array_p (gfc_expr * expr) tree gfc_trans_assignment (gfc_expr * expr1, gfc_expr * expr2, bool init_flag, - bool dealloc) + bool dealloc, bool use_vptr_copy, bool may_alias) { tree tmp; @@ -9762,7 +9983,8 @@ gfc_trans_assignment (gfc_expr * expr1, gfc_expr * expr2, bool init_flag, } /* Fallback to the scalarizer to generate explicit loops. */ - return gfc_trans_assignment_1 (expr1, expr2, init_flag, dealloc); + return gfc_trans_assignment_1 (expr1, expr2, init_flag, dealloc, + use_vptr_copy, may_alias); } tree diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c index ef5153e..4280b77 100644 --- a/gcc/fortran/trans-stmt.c +++ b/gcc/fortran/trans-stmt.c @@ -5439,7 +5439,10 @@ gfc_trans_allocate (gfc_code * code) if (code->expr3->rank != 0 && ((!attr.allocatable && !attr.pointer) || (code->expr3->expr_type == EXPR_FUNCTION - && code->expr3->ts.type != BT_CLASS))) + && (code->expr3->ts.type != BT_CLASS + || (code->expr3->value.function.isym + && code->expr3->value.function.isym + ->transformational))))) gfc_conv_expr_descriptor (&se, code->expr3); else gfc_conv_expr_reference (&se, code->expr3); @@ -5623,73 +5626,6 @@ 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. - No need to check whether e3_is is E3_UNSET, because that is - done by expr3 != NULL_TREE. - Exclude variables since the following block does not handle - array sections. In any case, there is no harm in sending - variables to gfc_trans_assignment because there is no - evaluation of variables. */ - if (code->expr3->expr_type != EXPR_VARIABLE - && e3_is != E3_MOLD && 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. */ - 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 backend_decl is known. It is expr3, which is inserted - here. */ - newsym->n.sym->backend_decl = expr3; - e3rhs = gfc_get_expr (); - e3rhs->ts = code->expr3->ts; - e3rhs->rank = code->expr3->rank; - e3rhs->symtree = newsym; - /* Mark the symbol referenced or gfc_trans_assignment will - bug. */ - newsym->n.sym->attr.referenced = 1; - e3rhs->expr_type = EXPR_VARIABLE; - e3rhs->where = code->expr3->where; - /* 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); - } - else if (POINTER_TYPE_P (TREE_TYPE (expr3))) - newsym->n.sym->attr.pointer = 1; - /* The string length is known to. Set it for char arrays. */ - if (e3rhs->ts.type == BT_CHARACTER) - newsym->n.sym->ts.u.cl->backend_decl = expr3_len; - gfc_commit_symbol (newsym->n.sym); - } - else - e3rhs = gfc_copy_expr (code->expr3); } gcc_assert (expr3_esize); expr3_esize = fold_convert (sizetype, expr3_esize); @@ -5723,6 +5659,95 @@ gfc_trans_allocate (gfc_code * code) } } + /* 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. + No need to check whether e3_is is E3_UNSET, because that is + done by expr3 != NULL_TREE. + Exclude variables since the following block does not handle + array sections. In any case, there is no harm in sending + variables to gfc_trans_assignment because there is no + evaluation of variables. */ + if (code->expr3) + { + if (code->expr3->expr_type != EXPR_VARIABLE + && e3_is != E3_MOLD && 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. */ + 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 backend_decl is known. It is expr3, which is inserted + here. */ + newsym->n.sym->backend_decl = expr3; + e3rhs = gfc_get_expr (); + e3rhs->rank = code->expr3->rank; + e3rhs->symtree = newsym; + /* Mark the symbol referenced or gfc_trans_assignment will bug. */ + newsym->n.sym->attr.referenced = 1; + e3rhs->expr_type = EXPR_VARIABLE; + e3rhs->where = code->expr3->where; + /* Set the symbols type, upto it was BT_UNKNOWN. */ + if (IS_CLASS_ARRAY (code->expr3) + && code->expr3->expr_type == EXPR_FUNCTION + && code->expr3->value.function.isym + && code->expr3->value.function.isym->transformational) + { + e3rhs->ts = CLASS_DATA (code->expr3)->ts; + } + else if (code->expr3->ts.type == BT_CLASS + && !GFC_CLASS_TYPE_P (TREE_TYPE (expr3))) + e3rhs->ts = CLASS_DATA (code->expr3)->ts; + else + e3rhs->ts = code->expr3->ts; + 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; + if (IS_CLASS_ARRAY (code->expr3) + && code->expr3->expr_type == EXPR_FUNCTION + && code->expr3->value.function.isym + && code->expr3->value.function.isym->transformational) + { + gfc_array_spec *tarr; + tarr = gfc_get_array_spec (); + *tarr = *arr; + e3rhs->ts.u.derived->as = tarr; + } + gfc_add_full_array_ref (e3rhs, arr); + } + else if (POINTER_TYPE_P (TREE_TYPE (expr3))) + newsym->n.sym->attr.pointer = 1; + /* The string length is known to. Set it for char arrays. */ + if (e3rhs->ts.type == BT_CHARACTER) + newsym->n.sym->ts.u.cl->backend_decl = expr3_len; + gfc_commit_symbol (newsym->n.sym); + } + else + e3rhs = gfc_copy_expr (code->expr3); + } + /* Loop over all objects to allocate. */ for (al = code->ext.alloc.list; al != NULL; al = al->next) { @@ -5960,8 +5985,9 @@ gfc_trans_allocate (gfc_code * code) gfc_add_expr_to_block (&block, tmp); } - /* Set the vptr. */ - if (al_vptr != NULL_TREE) + /* Set the vptr only when no source= is set. When source= is set, then + the trans_assignment below will set the vptr. */ + if (al_vptr != NULL_TREE && (!code->expr3 || code->expr3->mold)) { if (expr3_vptr != NULL_TREE) /* The vtab is already known, so just assign it. */ @@ -6046,153 +6072,34 @@ gfc_trans_allocate (gfc_code * code) if (code->expr3 && !code->expr3->mold && e3_is != E3_MOLD) { /* Initialization via SOURCE block (or static default initializer). - Classes need some special handling, so catch them first. */ - if (expr3 != NULL_TREE - && TREE_CODE (expr3) != POINTER_PLUS_EXPR - && code->expr3->ts.type == BT_CLASS - && (expr->ts.type == BT_CLASS - || expr->ts.type == BT_DERIVED)) - { - /* copy_class_to_class can be used for class arrays, too. - It just needs to be ensured, that the decl_saved_descriptor - has a way to get to the vptr. */ - tree to; - 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 (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 = e3rhs ? e3rhs : gfc_copy_expr (code->expr3); - - /* Do a polymorphic deep copy. */ - actual = gfc_get_actual_arglist (); - actual->expr = gfc_copy_expr (rhs); - if (rhs->ts.type == BT_CLASS) - gfc_add_data_component (actual->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 = last_arg->expr->ref; ref; ref = ref->next) - if (ref->type == REF_COMPONENT - && strcmp (ref->u.c.component->name, "_data") == 0) - dataref = ref; - - if (dataref && dataref->u.c.component->as) - { - gfc_array_spec *as = dataref->u.c.component->as; - gfc_free_ref_list (dataref->next); - dataref->next = NULL; - gfc_add_full_array_ref (last_arg->expr, as); - gfc_resolve_expr (last_arg->expr); - gcc_assert (last_arg->expr->ts.type == BT_CLASS - || last_arg->expr->ts.type == BT_DERIVED); - last_arg->expr->ts.type = BT_CLASS; - } - if (rhs->ts.type == BT_CLASS) - { - 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 - ppc = gfc_lval_expr_from_sym (gfc_find_vtab (&rhs->ts)); - gfc_add_component_ref (ppc, "_copy"); - - 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; - ppc_code->ext.actual = actual; - ppc_code->expr1 = ppc; - /* 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 lengths - 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); - if (rhs != e3rhs) - gfc_free_expr (rhs); - } - else - { - /* Switch off automatic reallocation since we have just - done the ALLOCATE. */ - int realloc_lhs = flag_realloc_lhs; - gfc_expr *init_expr = gfc_expr_to_initialize (expr); - flag_realloc_lhs = 0; - tmp = gfc_trans_assignment (init_expr, e3rhs, false, false); - flag_realloc_lhs = realloc_lhs; - /* Free the expression allocated for init_expr. */ - gfc_free_expr (init_expr); - } + Switch off automatic reallocation since we have just done the + ALLOCATE. */ + int realloc_lhs = flag_realloc_lhs; + gfc_expr *init_expr = gfc_expr_to_initialize (expr); + gfc_expr *rhs = e3rhs ? e3rhs : gfc_copy_expr (code->expr3); + flag_realloc_lhs = 0; + tmp = gfc_trans_assignment (init_expr, rhs, false, false, true, + false); + flag_realloc_lhs = realloc_lhs; + /* Free the expression allocated for init_expr. */ + gfc_free_expr (init_expr); + if (rhs != e3rhs) + gfc_free_expr (rhs); gfc_add_expr_to_block (&block, tmp); } - else if (code->expr3 && code->expr3->mold - && code->expr3->ts.type == BT_CLASS) + else if (code->expr3 && code->expr3->mold + && code->expr3->ts.type == BT_CLASS) { - /* Since the _vptr has already been assigned to the allocate - 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, - upoly_expr); + /* Use class_init_assign to initialize expr. */ + gfc_code *ini; + ini = gfc_get_code (EXEC_INIT_ASSIGN); + ini->expr1 = gfc_find_and_cut_at_last_class_ref (expr); + tmp = gfc_trans_class_init_assign (ini); + gfc_free_statements (ini); gfc_add_expr_to_block (&block, tmp); } - gfc_free_expr (expr); + gfc_free_expr (expr); } // for-loop if (e3rhs) diff --git a/gcc/fortran/trans-stmt.h b/gcc/fortran/trans-stmt.h index f9c8e74..e4d4a67 100644 --- a/gcc/fortran/trans-stmt.h +++ b/gcc/fortran/trans-stmt.h @@ -32,7 +32,6 @@ tree gfc_trans_assign (gfc_code *); tree gfc_trans_pointer_assign (gfc_code *); tree gfc_trans_init_assign (gfc_code *); tree gfc_trans_class_init_assign (gfc_code *); -tree gfc_trans_class_assign (gfc_expr *, gfc_expr *, gfc_exec_op); /* trans-stmt.c */ tree gfc_trans_cycle (gfc_code *); diff --git a/gcc/fortran/trans.c b/gcc/fortran/trans.c index 9210e0f..fba0d9a 100644 --- a/gcc/fortran/trans.c +++ b/gcc/fortran/trans.c @@ -1704,10 +1704,7 @@ trans_code (gfc_code * code, tree cond) break; case EXEC_ASSIGN: - if (code->expr1->ts.type == BT_CLASS) - res = gfc_trans_class_assign (code->expr1, code->expr2, code->op); - else - res = gfc_trans_assign (code); + res = gfc_trans_assign (code); break; case EXEC_LABEL_ASSIGN: @@ -1715,16 +1712,7 @@ trans_code (gfc_code * code, tree cond) break; case EXEC_POINTER_ASSIGN: - if (code->expr1->ts.type == BT_CLASS) - res = gfc_trans_class_assign (code->expr1, code->expr2, code->op); - else if (UNLIMITED_POLY (code->expr2) - && code->expr1->ts.type == BT_DERIVED - && (code->expr1->ts.u.derived->attr.sequence - || code->expr1->ts.u.derived->attr.is_bind_c)) - /* F2003: C717 */ - res = gfc_trans_class_assign (code->expr1, code->expr2, code->op); - else - res = gfc_trans_pointer_assign (code); + res = gfc_trans_pointer_assign (code); break; case EXEC_INIT_ASSIGN: diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h index 4d3d207..f76fff8 100644 --- a/gcc/fortran/trans.h +++ b/gcc/fortran/trans.h @@ -699,7 +699,8 @@ tree gfc_call_realloc (stmtblock_t *, tree, tree); tree gfc_trans_structure_assign (tree, gfc_expr *, bool); /* Generate code for an assignment, includes scalarization. */ -tree gfc_trans_assignment (gfc_expr *, gfc_expr *, bool, bool); +tree gfc_trans_assignment (gfc_expr *, gfc_expr *, bool, bool, bool p = false, + bool a = true); /* Generate code for a pointer assignment. */ tree gfc_trans_pointer_assignment (gfc_expr *, gfc_expr *); diff --git a/gcc/testsuite/gfortran.dg/alloc_comp_class_5.f03 b/gcc/testsuite/gfortran.dg/alloc_comp_class_5.f03 new file mode 100644 index 0000000..1d9450f --- /dev/null +++ b/gcc/testsuite/gfortran.dg/alloc_comp_class_5.f03 @@ -0,0 +1,74 @@ +! { dg-do run } +! +! Contributed by Vladimir Fuka +! Check that pr61337 is fixed. + +module array_list + + type container + class(*), allocatable :: items(:) + end type + +contains + + subroutine add_item(a, e) + type(container),allocatable,intent(inout) :: a(:) + class(*),intent(in) :: e(:) + type(container),allocatable :: tmp(:) + + if (.not.allocated(a)) then + allocate(a(1)) + allocate(a(1)%items(size(e)), source = e) + else + call move_alloc(a,tmp) + allocate(a(size(tmp)+1)) + a(1:size(tmp)) = tmp + allocate(a(size(tmp)+1)%items(size(e)), source=e) + end if + end subroutine + +end module + +program test_pr61337 + + use array_list + + type(container), allocatable :: a_list(:) + integer(kind = 8) :: i + + call add_item(a_list, [1, 2]) + call add_item(a_list, [3.0_8, 4.0_8]) + call add_item(a_list, [.true., .false.]) +! call add_item(a_list, ["bar", "foo", "bla"]) + + if (size(a_list) /= 3) call abort() + do i = 1, size(a_list) + call checkarr(a_list(i)) + end do + + deallocate(a_list) + +contains + + subroutine checkarr(c) + type(container) :: c + + if (allocated(c%items)) then + select type (x=>c%items) + type is (integer) + if (any(x /= [1, 2])) call abort() + type is (real(kind=8)) + if (any(x /= [3.0_8, 4.0_8])) call abort() + type is (logical) + if (any(x .neqv. [.true., .false.])) call abort() +! TODO: ICE when the next line is present, pr??? +! type is (character(len=:)) +! if (any(x /= ["bar", "foo", "bla"])) call abort() + class default + call abort() + end select + else + call abort() + end if + end subroutine +end diff --git a/gcc/testsuite/gfortran.dg/class_allocate_21.f90 b/gcc/testsuite/gfortran.dg/class_allocate_21.f90 new file mode 100644 index 0000000..a8ed291 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/class_allocate_21.f90 @@ -0,0 +1,21 @@ +! { dg-do run } +! +! Testcase for pr57117 + +implicit none + + type :: ti + integer :: i + end type + + class(ti), allocatable :: x(:,:), z(:) + integer :: i + + allocate(x(3,3)) + x%i = reshape([( i, i = 1, 9 )], [3, 3]) + allocate(z(9), source=reshape(x, (/ 9 /))) + + if (any( z%i /= [( i, i = 1, 9 )])) call abort() + deallocate (x, z) +end + diff --git a/gcc/testsuite/gfortran.dg/class_allocate_22.f90 b/gcc/testsuite/gfortran.dg/class_allocate_22.f90 new file mode 100644 index 0000000..5fec72f --- /dev/null +++ b/gcc/testsuite/gfortran.dg/class_allocate_22.f90 @@ -0,0 +1,26 @@ +! { dg-do run } +! +! Check pr57117 is fixed. + +program pr57117 + implicit none + + type :: ti + integer :: i + end type + + class(ti), allocatable :: x(:,:), y(:,:) + integer :: i + + allocate(x(2,6)) + select type (x) + class is (ti) + x%i = reshape([(i,i=1, 12)],[2,6]) + end select + allocate(y, source=transpose(x)) + + if (any( ubound(y) /= [6,2])) call abort() + if (any(reshape(y(:,:)%i, [12]) /= [ 1,3,5,7,9,11, 2,4,6,8,10,12])) call abort() + deallocate (x,y) +end + diff --git a/gcc/testsuite/gfortran.dg/realloc_on_assign_27.f08 b/gcc/testsuite/gfortran.dg/realloc_on_assign_27.f08 new file mode 100644 index 0000000..53b8330 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/realloc_on_assign_27.f08 @@ -0,0 +1,24 @@ +! { dg-do run } + + type :: t + integer :: i + end type + + type, extends(t) :: r + real :: r + end type + + class(t), allocatable :: x + class(r), allocatable :: foo ! Need this declared of copy_R is not generated. + type(r) :: y = r (3, 42) + + x = y + if (x%i /= 3) call abort() + select type(x) + class is (r) + if (x%r /= 42.0) call abort() + class default + call abort() + end select +end + --MP_/X4kPMHdmsD5O9BBE3_zaRHF--