From mboxrd@z Thu Jan 1 00:00:00 1970 Return-Path: Received: (qmail 130236 invoked by alias); 14 Apr 2015 17:01:16 -0000 Mailing-List: contact gcc-patches-help@gcc.gnu.org; run by ezmlm Precedence: bulk List-Id: List-Archive: List-Post: List-Help: Sender: gcc-patches-owner@gcc.gnu.org Received: (qmail 130213 invoked by uid 89); 14 Apr 2015 17:01:15 -0000 Authentication-Results: sourceware.org; auth=none X-Virus-Found: No X-Spam-SWARE-Status: No, score=-0.4 required=5.0 tests=AWL,BAYES_50,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.17.21) by sourceware.org (qpsmtpd/0.93/v0.84-503-g423c35a) with (AES256-GCM-SHA384 encrypted) ESMTPS; Tue, 14 Apr 2015 17:01:05 +0000 Received: from localhost ([88.75.104.20]) by mail.gmx.com (mrgmx103) with ESMTPSA (Nemesis) id 0LcSWg-1Z852E1UkI-00jt65; Tue, 14 Apr 2015 19:00:57 +0200 Date: Tue, 14 Apr 2015 17:01:00 -0000 From: Andre Vehreschild To: Paul Richard Thomas Cc: Mikael Morin , GCC-Fortran-ML , GCC-Patches-ML , Antony Lewis , Dominique Dhumieres Subject: Re: [Patch, Fortran, pr60322, addendum] was: [Patch 1/2, Fortran, pr60322] [OOP] Incorrect bounds on polymorphic dummy array Message-ID: <20150414190054.473a9bbb@gmx.de> In-Reply-To: <20150409143709.6d33aa8c@vepi2> References: <20150226181717.480e282c@vepi2> <551006FF.1080704@sfr.fr> <20150323134357.6af740d1@vepi2> <20150324180620.3c72960e@vepi2> <20150409143709.6d33aa8c@vepi2> MIME-Version: 1.0 Content-Type: multipart/mixed; boundary="MP_/rQS.DZ4y5A68vmX5eExNh.v" X-UI-Out-Filterresults: notjunk:1; X-SW-Source: 2015-04/txt/msg00691.txt.bz2 --MP_/rQS.DZ4y5A68vmX5eExNh.v Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: quoted-printable Content-Disposition: inline Content-length: 15661 Hi all, during further testing of a big Fortran software I encounter two bugs with class arrays, that are somehow connected to pr60322. I therefore propose an extended patch for pr60322. Because Paul has already reviewed most the exte= nded patch, I give you two patches: 1. a full patch, fixing all the issues connected to pr60322, and 2. a delta patch to get from the reviewed patch to the latest version.=20 With the second patch I hope to get a faster review, because it is significantly shorter.=20 Now what was the issue? To be precise there were two issues: i. a pointer to a class array (CLASS_DATA(sym).attr.class_pointer =3D=3D 1)= was dereferenced, which lead to an ICE (the patch for this in the delta is chun= k 5 in gfc_conv_expr_descriptor, and ii. (and this was a severe brain cracker) in chains of references consistin= g of more then one class-(array)-ref always the _vptr of the first symbol was ta= ken and not the _vptr of the currently dereferenced class object. This occurred when fortran code similiar to this was executed: type innerT integer, allocatable :: arr(:) end type type T class(innerT) :: mat(:,:) end type class(T) :: o allocate(o%mat(2,2)) allocate(o%mat(:,:)%arr(10)) ! This is obviously pseudo code, ! but I think you get what is meant. o%mat(1,1)%arr(1) =3D 1=20=20 In the last line the address to get to arr(1) was computed using the _vptr->size of o and not of o%mat(1,1). To fix this gfc_component_ref () now computes the class' _vptr-ref whenever it does a _data-ref (chunk 1 of trans-expr.c in the delta patch). The _vptr-ref is stored in gfc_se, where I added the new member class_vptr. The gfc_se->class_vptr is then used in array-refs (chunk 2 of trans.c) to get the size of the array elements of the correct level.=20 The other chunks of the delta patch are: - parameter passing fixes, and=20 - documentation fixes as requested for the version 5 of the pr60322 patch. I hope this helps in getting the patch reviewed quickly. Bootstraps and regtests ok on x86_64-linux-gnu/F21. Ok for trunk -> 6.0?=20 Ok, for backport to 5.2, once available? Note, the patches may apply with shifts, as I forgot to update before taking the diffs. Regards, Andre On Thu, 9 Apr 2015 14:37:09 +0200 Andre Vehreschild wrote: > Hi Paul, hi all, >=20 > Paul, thanks for the review. Answers to your questions are inline below: >=20 > On Sun, 5 Apr 2015 11:13:05 +0200 > Paul Richard Thomas wrote: > > > + /* The dummy is returned for pointer, allocatable or assumed rank ar= rays. > > + The check for pointerness needs to be repeated here (it is done in > > + IS_CLASS_ARRAY (), too), because for class arrays that are pointe= rs, > > as > > + is the one of the sym, which is incorrect here. */ > >=20 > > What does this mean, please? >=20 > The first sentence is about regular arrays and should be unchanged from t= he > original source. Then I have to check for class (arrays) that are pointer= s, > i.e., independent of whether the sym is a class array or a regular pointe= r to > a class object. (The latter shouldn't make it into the routine anyway.) > IS_CLASS_ARRAY () returns false for too many reasons to be of use here. I= have > to apologize and confess that the comment was a mere note to myself to not > return to use is_classarray in the if below. Let me rephrase the comment = to > be: >=20 > /* The dummy is returned for pointer, allocatable or assumed rank arrays. > For class arrays the information if sym is an allocatable or pointer > object needs to be checked explicitly (IS_CLASS_ARRAY can be false for > too many reasons to be of use here). */ >=20 > > + /* Returning the descriptor for dummy class arrays is hazardous, > > because > > + some caller is expecting an expression to apply the component ref= s to. > > + Therefore the descriptor is only created and stored in > > + sym->backend_decl's GFC_DECL_SAVED_DESCRIPTOR. The caller is then > > + responsible to extract it from there, when the descriptor is > > + desired. */ > > + if (IS_CLASS_ARRAY (sym) > > + && (!DECL_LANG_SPECIFIC (sym->backend_decl) > > + || !GFC_DECL_SAVED_DESCRIPTOR (sym->backend_decl))) > > + { > > + decl =3D gfc_build_dummy_array_decl (sym, sym->backend_decl); > > + /* Prevent the dummy from being detected as unused if it is copi= ed. > > */ > > + if (sym->backend_decl !=3D NULL && decl !=3D sym->backend_decl) > > + DECL_ARTIFICIAL (sym->backend_decl) =3D 1; > > + sym->backend_decl =3D decl; > > + } > >=20 > > The comments, such as the above are often going well beyond column 72, > > into the 80's. I know that much of the existing code violates this > > style requirement but there is no need to do so if clarity is not > > reduced thereby. >=20 > Er, the document at=20 >=20 > https://gcc.gnu.org/codingconventions.html#C_Formatting=20 >=20 > says that line length is 80, or is there another convention, that I am not > aware of? >=20 > > In trans-stmt.c s/standart/standard/ >=20 > Fixed. >=20 > > Don't forget to put the PR numbers in the ChangeLogs. >=20 > I won't anymore, already got told off :-) >=20 > > For this submission, I would have appreciated some a description of > > what each chunk in the patch is doing, just because there is so much > > of it. I suppose that it was good for my imortal soul to sort it out > > for myself but it took a little while :-) >=20 > I initially tried to split the submission in two parts to make it more > manageable. One part with the brain-dead substitutions of as and array_at= tr > and one with the new code. Albeit I failed to get the brain-dead part rig= ht > and made some mistakes there already, which Mikael pointed out. I therefo= re > went for the big submission.=20 >=20 > Now doing a description of what each "chunk" does is quite tedious. I rea= lly > would like to spend my time more productive. Would you be satisfied, when= I > write a story about the patch, referring to some parts more explicitly, l= ike >=20 > "Chunk 4 of file trans-stmt.c is the heart of the patch and does this and > that. The remaining chunks are more or less putting the data together." >=20 > (This is not correct for this patch of course. Just an example.) More > elaborate of course, but just to give an idea. >=20 > Thanks again. I will commit as soon as 5.2/6.0 commit window is open. >=20 > Regards, > Andre >=20 > >=20 > > Cheers and many thanks for the patch. > >=20 > > Paul > >=20 > > On 27 March 2015 at 13:48, Paul Richard Thomas > > wrote: > > > Dear Andre, > > > > > > I am in the UK as of last night. Before leaving, I bootstrapped and > > > regtested your patch and all was well. I must drive to Cambridge this > > > afternoon to see my mother and will try to get to it either this > > > evening or tomorrow morning. There is so much of it and it touches > > > many places; so I must give it a very careful looking over before > > > giving the green light. Bear with me please. > > > > > > Great work though! > > > > > > Paul > > > > > > On 24 March 2015 at 18:06, Andre Vehreschild wrote: > > >> Hi all, > > >> > > >> I have worked on the comments Mikael gave me. I am now checking for > > >> class_pointer in the way he pointed out. > > >> > > >> Furthermore did I *join the two parts* of the patch into this one, > > >> because keeping both in sync was no benefit but only tedious and did= not > > >> prove to be reviewed faster. > > >> > > >> Paul, Dominique: I have addressed the LOC issue that came up lately.= Or > > >> rather the patch addressed it already. I feel like this is not tested > > >> very well, not the loc() call nor the sizeof() call as given in the = 57305 > > >> second's download. Unfortunately, is that download not runable. I wo= uld > > >> love to see a test similar to that download, but couldn't come up wi= th > > >> one, that satisfied me. Given that the patch's review will last some > > >> days, I still have enough time to come up with something beautiful w= hich > > >> I will add then. > > >> > > >> Bootstraps and regtests ok on x86_64-linux-gnu/F20. > > >> > > >> Regards, > > >> Andre > > >> > > >> > > >> On Tue, 24 Mar 2015 11:13:27 +0100 > > >> Paul Richard Thomas wrote: > > >> > > >>> Dear Andre, > > >>> > > >>> Dominique pointed out to me that the 'loc' patch causes a ICE in the > > >>> testsuite. It seems that 'loc' should provide the address of the cl= ass > > >>> container in some places and the address of the data in others. I w= ill > > >>> put my thinking cap on tonight :-) > > >>> > > >>> Cheers > > >>> > > >>> Paul > > >>> > > >>> On 23 March 2015 at 13:43, Andre Vehreschild wrote: > > >>> > Hi Mikael, > > >>> > > > >>> > thanks for looking at the patch. Please note, that Paul has sent = an > > >>> > addendum to the patches for 60322, which I deliberately have atta= ched. > > >>> > > > >>> >> 26/02/2015 18:17, Andre Vehreschild a =C3=A9crit : > > >>> >> > This first patch is only preparatory and does not change any o= f the > > >>> >> > semantics of gfortran at all. > > >>> >> Sure? > > >>> > > > >>> > With the counterexample you found below, this of course is a wrong > > >>> > statement. > > >>> > > > >>> >> > diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c > > >>> >> > index ab6f7a5..d28cf77 100644 > > >>> >> > --- a/gcc/fortran/expr.c > > >>> >> > +++ b/gcc/fortran/expr.c > > >>> >> > @@ -4059,10 +4060,10 @@ gfc_lval_expr_from_sym (gfc_symbol *sy= m) > > >>> >> > lval->symtree =3D gfc_find_symtree (sym->ns->sym_root, sym-= >name); > > >>> >> > > > >>> >> > /* It will always be a full array. */ > > >>> >> > - lval->rank =3D sym->as ? sym->as->rank : 0; > > >>> >> > + as =3D sym->as; > > >>> >> > + lval->rank =3D as ? as->rank : 0; > > >>> >> > if (lval->rank) > > >>> >> > - gfc_add_full_array_ref (lval, sym->ts.type =3D=3D BT_CLAS= S ? > > >>> >> > - CLASS_DATA (sym)->as : sym->as); > > >>> >> > + gfc_add_full_array_ref (lval, as); > > >>> >> > > >>> >> This is a change of semantics. Or do you know that sym->ts.type= !=3D > > >>> >> BT_CLASS? > > >>> > > > >>> > You are completely right. I have made a mistake here. I have to t= ell > > >>> > the truth, I never ran a regtest with only part 1 of the patches > > >>> > applied. The second part of the patch will correct this, by setti= ng > > >>> > the variable as depending on whether type =3D=3D BT_CLASS or not.= Sorry > > >>> > for the mistake. > > >>> > > > >>> >> > diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl= .c > > >>> >> > index 3664824..e571a17 100644 > > >>> >> > --- a/gcc/fortran/trans-decl.c > > >>> >> > +++ b/gcc/fortran/trans-decl.c > > >>> >> > @@ -1013,16 +1017,24 @@ gfc_build_dummy_array_decl (gfc_symbol= * > > >>> >> > sym, tree dummy) tree decl; > > >>> >> > tree type; > > >>> >> > gfc_array_spec *as; > > >>> >> > + symbol_attribute *array_attr; > > >>> >> > char *name; > > >>> >> > gfc_packed packed; > > >>> >> > int n; > > >>> >> > bool known_size; > > >>> >> > > > >>> >> > - if (sym->attr.pointer || sym->attr.allocatable > > >>> >> > - || (sym->as && sym->as->type =3D=3D AS_ASSUMED_RANK)) > > >>> >> > + /* Use the array as and attr. */ > > >>> >> > + as =3D sym->as; > > >>> >> > + array_attr =3D &sym->attr; > > >>> >> > + > > >>> >> > + /* The pointer attribute is always set on a _data component, > > >>> >> > therefore check > > >>> >> > + the sym's attribute only. */ > > >>> >> > + if (sym->attr.pointer || array_attr->allocatable > > >>> >> > + || (as && as->type =3D=3D AS_ASSUMED_RANK)) > > >>> >> > return dummy; > > >>> >> > > > >>> >> Any reason to sometimes use array_attr, sometimes not, like here? > > >>> >> By the way, the comment is misleading: for classes, there is the > > >>> >> class_pointer attribute (and it is a pain, I know). > > >>> > > > >>> > Yes, and a good one. Array_attr is sometimes sym->attr and someti= mes > > >>> > CLASS_DATA(sym)->attr aka sym->ts.u.derived->components->attr. In= the > > >>> > later case .pointer is always set to 1 in the _data component's a= ttr. > > >>> > I.e., the above if, would always yield true for a class_array, wh= ich > > >>> > is not intended, but rather destructive. I know about the > > >>> > class_pointer attribute, but I figured, that it is not relevant h= ere. > > >>> > Any idea how to formulate the comment better, to reflect what I j= ust > > >>> > explained? > > >>> > > > >>> > Regards, > > >>> > Andre > > >>> > -- > > >>> > Andre Vehreschild * Email: vehre ad gmx dot de > > >>> > > > >>> > > > >>> > ---------- Forwarded message ---------- > > >>> > From: Paul Richard Thomas > > >>> > To: Andre Vehreschild , Dominique Dhumieres > > >>> > Cc: > > >>> > Date: Sun, 22 Mar 2015 21:20:20 +0100 > > >>> > Subject: Bug in intrinsic LOC for scalar class objects > > >>> > Dear Andre and Dominique, > > >>> > > > >>> > I have found that LOC is returning the address of the class conta= iner > > >>> > rather than the _data component for class scalars. See the source > > >>> > below, which you will recognise! A fix is attached. > > >>> > > > >>> > Note that the scalar allocate fails with MOLD=3D and so I substit= uted > > >>> > SOURCE=3D. > > >>> > > > >>> > Cheers > > >>> > > > >>> > Paul > > >>> > > > >>> > class(*), allocatable :: a(:), e ! Change 'e' to an array and > > >>> > second memcpy works correctly > > >>> > ! Problem is with loc(e), wh= ich > > >>> > returns the address of the > > >>> > ! class container. > > >>> > allocate (e, source =3D 99.0) > > >>> > allocate (a(2), source =3D [1.0, 2.0]) > > >>> > call add_element_poly (a,e) > > >>> > select type (a) > > >>> > type is (real) > > >>> > print *, a > > >>> > end select > > >>> > > > >>> > contains > > >>> > > > >>> > subroutine add_element_poly(a,e) > > >>> > use iso_c_binding > > >>> > class(*),allocatable,intent(inout),target :: a(:) > > >>> > class(*),intent(in),target :: e > > >>> > class(*),allocatable,target :: tmp(:) > > >>> > type(c_ptr) :: dummy > > >>> > > > >>> > interface > > >>> > function memcpy(dest,src,n) bind(C,name=3D"memcpy") resul= t(res) > > >>> > import > > >>> > type(c_ptr) :: res > > >>> > integer(c_intptr_t),value :: dest > > >>> > integer(c_intptr_t),value :: src > > >>> > integer(c_size_t),value :: n > > >>> > end function > > >>> > end interface > > >>> > > > >>> > if (.not.allocated(a)) then > > >>> > allocate(a(1), source=3De) > > >>> > else > > >>> > allocate(tmp(size(a)),source=3Da) > > >>> > deallocate(a) > > >>> > allocate(a(size(tmp)+1),source=3De) ! mold gives a segfau= lt > > >>> > dummy =3D memcpy(loc(a(1)),loc(tmp),sizeof(tmp)) > > >>> > dummy =3D memcpy(loc(a(size(tmp)+1)),loc(e),sizeof(e)) > > >>> > end if > > >>> > end subroutine > > >>> > end > > >>> > > > >>> > > >>> > > >>> > > >> > > >> > > >> -- > > >> Andre Vehreschild * Email: vehre ad gmx dot de > > > > > > > > > > > > -- > > > Outside of a dog, a book is a man's best friend. Inside of a dog it's > > > too dark to read. > > > > > > Groucho Marx > >=20 > >=20 > >=20 >=20 >=20 --=20 Andre Vehreschild * Email: vehre ad gmx dot de=20 --MP_/rQS.DZ4y5A68vmX5eExNh.v Content-Type: application/octet-stream; name=pr60322_full_6.clog Content-Transfer-Encoding: base64 Content-Disposition: attachment; filename=pr60322_full_6.clog Content-length: 4136 Z2NjL3Rlc3RzdWl0ZS9DaGFuZ2VMb2c6CgoyMDE1LTA0LTE0ICBBbmRyZSBW ZWhyZXNjaGlsZCAgPHZlaHJlQGdteC5kZT4KCgkqIGdmb3J0cmFuLmRnL2Ns YXNzX2FsbG9jYXRlXzE5LmYwMzogTmV3IHRlc3QuCgkqIGdmb3J0cmFuLmRn L2NsYXNzX2FycmF5XzIwLmYwMzogTmV3IHRlc3QuCgkqIGdmb3J0cmFuLmRn L2NsYXNzX2FycmF5XzIxLmYwMzogTmV3IHRlc3QuCgkqIGdmb3J0cmFuLmRn L2ZpbmFsaXplXzEwLmY5MDogQ29ycmVjdGVkIHNjYW4tdHJlZXMuCgkqIGdm b3J0cmFuLmRnL2ZpbmFsaXplXzE1LmY5MDogRml4aW5nIGNvbXBhcmlzaW9u IHRvIG1vZGVsCglpbml0aWFsaXphdGlvbiBjb3JyZWN0bHkuCgkqIGdmb3J0 cmFuLmRnL2ZpbmFsaXplXzI5LmYwODogTmV3IHRlc3QuCgoKZ2NjL2ZvcnRy YW4vQ2hhbmdlTG9nOgoKMjAxNS0wNC0xNCAgQW5kcmUgVmVocmVzY2hpbGQg IDx2ZWhyZUBnbXguZGU+CgoJUFIgZm9ydHJhbi82MDMyMgoJKiBleHByLmMg KGdmY19sdmFsX2V4cHJfZnJvbV9zeW0pOiBDb2RlIHRvIHNlbGVjdCB0aGUg cmVndWxhcgoJb3IgY2xhc3MgYXJyYXkgYWRkZWQuCgkqIGdmb3J0cmFuLmg6 IEFkZCBJU19DTEFTU19BUlJBWSBtYWNyby4KCSogdHJhbnMtYXJyYXkuYyAo Z2ZjX2FkZF9sb29wX3NzX2NvZGUpOiBUcmVhdCBjbGFzcyBvYmplY3RzCgl0 byBiZSByZWZlcmVuY2VkIGFsd2F5cy4KCShidWlsZF9jbGFzc19hcnJheV9y ZWYpOiBBZGFwdCByZXRyaWV2YWwgb2YgYXJyYXkgZGVzY3JpcHRvci4KCShi dWlsZF9hcnJheV9yZWYpOiBMaWtld2lzZS4KCShnZmNfY29udl9hcnJheV9y ZWYpOiBIYW5kIHRoZSB2cHRyIG9yIHRoZSBkZXNjcmlwdG9yIHRvIAoJYnVp bGRfYXJyYXlfcmVmIGRlcGVuZGluZyB3aGV0aGVyIHRoZSBzeW0gaXMgY2xh c3Mgb3Igbm90LgoJKGdmY190cmFuc19hcnJheV9jb2JvdW5kcyk6ICBTZWxl Y3QgY29ycmVjdCBnZmNfYXJyYXlfc3BlYyBmb3IKCXJlZ3VsYXIgYW5kIGNs YXNzIGFycmF5cy4KCShnZmNfdHJhbnNfYXJyYXlfYm91bmRzKTogTGlrZXdp c2UuCgkoZ2ZjX3RyYW5zX2R1bW15X2FycmF5X2JpYXMpOiBMaWtld2lzZS4g CgkoZ2ZjX2dldF9kYXRhcHRyX29mZnNldCk6IENvcnJlY3RpbmcgY2FsbCBv ZiBidWlsZF9hcnJheV9yZWYuCgkoZ2ZjX2NvbnZfZXhwcl9kZXNjcmlwdG9y KTogU2V0IHRoZSBhcnJheSdzIG9mZnNldCB0byAtMSB3aGVuCglsYm91bmQg aW4gaW5uZXIgbW9zdCBkaW0gaXMgMSBhbmQgc3ltYm9sIG5vbi1wb2ludGVy L2Fzc29jLgoJKiB0cmFucy1kZWNsLmMgKGdmY19idWlsZF9xdWFsaWZpZWRf YXJyYXkpOiBTZWxlY3QgY29ycmVjdAoJZ2ZjX2FycmF5X3NwZWMgZm9yIHJl Z3VsYXIgYW5kIGNsYXNzIGFycmF5cy4KCShnZmNfYnVpbGRfZHVtbXlfYXJy YXlfZGVjbCk6IExpa2V3aXNlLgoJKGdmY19nZXRfc3ltYm9sX2RlY2wpOiBH ZXQgYSBkdW1teSBhcnJheSBmb3IgY2xhc3MgYXJyYXlzLgoJKGdmY190cmFu c19kZWZlcnJlZF92YXJzKTogVGVsbCBjb252X2V4cHIgdGhhdCB0aGUgZGVz Y3JpcHRvcgoJaXMgZGVzaXJlZC4KCSogdHJhbnMtZXhwci5jIChnZmNfY2xh c3NfdnB0cl9nZXQpOiBHZXQgdGhlIGNsYXNzIGRlc2NyaXB0b3IKCWZyb20g dGhlIGNvcnJlY3QgbG9jYXRpb24gZm9yIGNsYXNzIGFycmF5cy4KCShnZmNf Y2xhc3NfbGVuX2dldCk6IExpa2V3aXNlLgoJKGdmY19jb252X2ludHJpbnNp Y190b19jbGFzcyk6IEFkZCBoYW5kbGluZyBvZiBfbGVuIGNvbXBvbmVudC4K CShnZmNfY29udl9jbGFzc190b19jbGFzcyk6ICBQcmV2ZW50IGFjY2VzcyB0 byB1bnNldCBhcnJheSBkYXRhCgl3aGVuIHRoZSBhcnJheSBpcyBhbiBvcHRp b25hbCBhcmd1bWVudC4gQWRkIGhhbmRsaW5nIG9mIF9sZW4KCWNvbXBvbmVu dC4KCShnZmNfY29weV9jbGFzc190b19jbGFzcyk6IENoZWNrIHRoYXQgX2Rl Zl9pbml0IGlzIG5vbi1OVUxMCgl3aGVuIHVzZWQgaW4gX3ZwdHItPmNvcHko KQoJKGdmY190cmFuc19jbGFzc19pbml0X2Fzc2lnbik6IEVuc3VyZSB0aGF0 IHRoZSByYW5rIG9mCglfZGVmX2luaXQgaXMgemVyby4KCShnZmNfY29udl9j b21wb25lbnRfcmVmKTogR2V0IHRoZSBfdnB0ciBhbG9uZyB3aXRoIF9kYXRh IHJlZnMuCgkoZ2ZjX2NvbnZfdmFyaWFibGUpOiBNYWtlIHN1cmUgdGhlIHRl bXAgYXJyYXkgZGVzY3JpcHRvciBpcwoJcmV0dXJuZWQgZm9yIGNsYXNzIGFy cmF5cywgdG9vLCBhbmQgdGhhdCBjbGFzcyBhcnJheXMgYXJlCglkZXJlZmVy ZW5jZWQgY29ycmVjdGx5LgoJKGdmY19jb252X3Byb2NlZHVyZV9jYWxsKTog Rm9yIHBvbHltb3JwaGljIHR5cGUgaW5pdGlhbGl6YXRpb24KCXRoZSBpbml0 aWFsaXplciBoYXMgdG8gYmUgYSBwb2ludGVyIHRvIF9kZWZfaW5pdCBzdG9y ZWQgaW4gYQoJZHVtbXkgdmFyaWFibGUsIHdoaWNoIHRoZW4gbmVlZHMgdG8g YmUgdXNlZCBieSB2YWx1ZS4KCSogdHJhbnMtaW50cmluc2ljLmMgKGdmY19j b252X2ludHJpbnNpY19zaXplb2YpOiBVc2UgdGhlCgl0ZW1wb3JhcnkgYXJy YXkgZGVzY3JpcHRvciBmb3IgY2xhc3MgYXJyYXlzLCB0b28uCgkoZ2ZjX2Nv bnZfaW50cmluc2ljX3N0b3JhZ2Vfc2l6ZSk6IExpa2V3aXNlLgoJKGdmY19j b252X2ludHJpbnNpY19sb2MpOiBBZGQgcmVmIHRvIF9kYXRhIGZvciBCVF9D TEFTUwoJZXhwcmVzc2lvbnMuCgkqIHRyYW5zLXN0bXQuYyAodHJhbnNfYXNz b2NpYXRlX3Zhcik6IFVzZSBhIHRlbXBvcmFyeSBhcnJheSBmb3IKCXRoZSBh c3NvY2lhdGUgdmFyaWFibGUgb2YgY2xhc3MgYXJyYXlzLCB0b28sIG1ha2lu ZyB0aGUgYXJyYXkKCW9uZS1iYXNlZCAobGJvdW5kID09IDEpLgoJKiB0cmFu cy10eXBlcy5jIChnZmNfaXNfbm9kZXNjX2FycmF5KTogVXNlIHRoZSBjb3Jy ZWN0CglhcnJheSBkYXRhLgoJKiB0cmFucy5jIChnZmNfYnVpbGRfYXJyYXlf cmVmKTogVXNlIHRoZSBkdW1teSBhcnJheSBkZXNjcmlwdG9yCgl3aGVuIHBy ZXNlbnQuCgkqIHRyYW5zLmg6IEFkZCBjbGFzc192cHRyIHRvIGdmY19zZSBm b3Igc3RvcmluZyBhIGNsYXNzIHJlZidzCgl2cHRyLgoKCg== --MP_/rQS.DZ4y5A68vmX5eExNh.v Content-Type: text/x-patch Content-Transfer-Encoding: 7bit Content-Disposition: attachment; filename=pr60322_full_6.patch Content-length: 63647 diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c index ab6f7a5..7f3a59d 100644 --- a/gcc/fortran/expr.c +++ b/gcc/fortran/expr.c @@ -4052,6 +4052,7 @@ gfc_expr * gfc_lval_expr_from_sym (gfc_symbol *sym) { gfc_expr *lval; + gfc_array_spec *as; lval = gfc_get_expr (); lval->expr_type = EXPR_VARIABLE; lval->where = sym->declared_at; @@ -4059,10 +4060,10 @@ gfc_lval_expr_from_sym (gfc_symbol *sym) lval->symtree = gfc_find_symtree (sym->ns->sym_root, sym->name); /* It will always be a full array. */ - lval->rank = sym->as ? sym->as->rank : 0; + as = IS_CLASS_ARRAY (sym) ? CLASS_DATA (sym)->as : sym->as; + lval->rank = as ? as->rank : 0; if (lval->rank) - gfc_add_full_array_ref (lval, sym->ts.type == BT_CLASS ? - CLASS_DATA (sym)->as : sym->as); + gfc_add_full_array_ref (lval, as); return lval; } diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index 24d56c0..643cd6a 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -3209,6 +3209,11 @@ bool gfc_is_finalizable (gfc_symbol *, gfc_expr **); && CLASS_DATA (sym) \ && CLASS_DATA (sym)->ts.u.derived \ && CLASS_DATA (sym)->ts.u.derived->attr.unlimited_polymorphic) +#define IS_CLASS_ARRAY(sym) \ + (sym->ts.type == BT_CLASS \ + && CLASS_DATA (sym) \ + && CLASS_DATA (sym)->attr.dimension \ + && !CLASS_DATA (sym)->attr.class_pointer) /* frontend-passes.c */ diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index 1768974..3803cf8 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -2495,11 +2495,14 @@ gfc_add_loop_ss_code (gfc_loopinfo * loop, gfc_ss * ss, bool subscript, case GFC_SS_REFERENCE: /* Scalar argument to elemental procedure. */ gfc_init_se (&se, NULL); - if (ss_info->can_be_null_ref) + if (ss_info->can_be_null_ref || (expr->symtree + && (expr->symtree->n.sym->ts.type == BT_DERIVED + || expr->symtree->n.sym->ts.type == BT_CLASS))) { /* If the actual argument can be absent (in other words, it can be a NULL reference), don't try to evaluate it; pass instead - the reference directly. */ + the reference directly. The reference is also needed when + expr is of type class or derived. */ gfc_conv_expr_reference (&se, expr); } else @@ -3046,7 +3049,14 @@ build_class_array_ref (gfc_se *se, tree base, tree index) return false; } else if (class_ref == NULL) - decl = expr->symtree->n.sym->backend_decl; + { + 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. */ + if (DECL_LANG_SPECIFIC (decl) && GFC_DECL_SAVED_DESCRIPTOR (decl)) + decl = GFC_DECL_SAVED_DESCRIPTOR (decl); + } else { /* Remove everything after the last class reference, convert the @@ -3155,30 +3165,45 @@ add_to_offset (tree *cst_offset, tree *offset, tree t) static tree -build_array_ref (tree desc, tree offset, tree decl) +build_array_ref (tree desc, tree offset, tree decl, tree vptr) { tree tmp; tree type; + tree cdecl; + bool classarray = false; + + /* For class arrays the class declaration is stored in the saved + descriptor. */ + if (INDIRECT_REF_P (desc) + && DECL_LANG_SPECIFIC (TREE_OPERAND (desc, 0)) + && GFC_DECL_SAVED_DESCRIPTOR (TREE_OPERAND (desc, 0))) + cdecl = gfc_class_data_get (GFC_DECL_SAVED_DESCRIPTOR ( + TREE_OPERAND (desc, 0))); + else + cdecl = desc; /* Class container types do not always have the GFC_CLASS_TYPE_P but the canonical type does. */ - if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)) - && TREE_CODE (desc) == COMPONENT_REF) + if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (cdecl)) + && TREE_CODE (cdecl) == COMPONENT_REF) { - type = TREE_TYPE (TREE_OPERAND (desc, 0)); + type = TREE_TYPE (TREE_OPERAND (cdecl, 0)); if (TYPE_CANONICAL (type) && GFC_CLASS_TYPE_P (TYPE_CANONICAL (type))) - type = TYPE_CANONICAL (type); + { + type = TREE_TYPE (desc); + classarray = true; + } } else type = NULL; /* Class array references need special treatment because the assigned type size needs to be used to point to the element. */ - if (type && GFC_CLASS_TYPE_P (type)) + if (classarray) { - type = gfc_get_element_type (TREE_TYPE (desc)); - tmp = TREE_OPERAND (desc, 0); + type = gfc_get_element_type (type); + tmp = TREE_OPERAND (cdecl, 0); tmp = gfc_get_class_array_ref (offset, tmp); tmp = fold_convert (build_pointer_type (type), tmp); tmp = build_fold_indirect_ref_loc (input_location, tmp); @@ -3187,7 +3212,7 @@ build_array_ref (tree desc, tree offset, tree decl) tmp = gfc_conv_array_data (desc); tmp = build_fold_indirect_ref_loc (input_location, tmp); - tmp = gfc_build_array_ref (tmp, offset, decl); + tmp = gfc_build_array_ref (tmp, offset, decl, vptr); return tmp; } @@ -3350,7 +3375,8 @@ gfc_conv_array_ref (gfc_se * se, gfc_array_ref * ar, gfc_expr *expr, offset = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, offset, cst_offset); - se->expr = build_array_ref (se->expr, offset, sym->backend_decl); + se->expr = build_array_ref (se->expr, offset, sym->ts.type == BT_CLASS ? + NULL_TREE : sym->backend_decl, se->class_vptr); } @@ -5570,7 +5596,7 @@ gfc_trans_array_cobounds (tree type, stmtblock_t * pblock, gfc_se se; gfc_array_spec *as; - as = sym->as; + as = IS_CLASS_ARRAY (sym) ? CLASS_DATA (sym)->as : sym->as; for (dim = as->rank; dim < as->rank + as->corank; dim++) { @@ -5613,7 +5639,7 @@ gfc_trans_array_bounds (tree type, gfc_symbol * sym, tree * poffset, int dim; - as = sym->as; + as = IS_CLASS_ARRAY (sym) ? CLASS_DATA (sym)->as : sym->as; size = gfc_index_one_node; offset = gfc_index_zero_node; @@ -5900,12 +5926,17 @@ gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc, int checkparm; int no_repack; bool optional_arg; + gfc_array_spec *as; + bool is_classarray = IS_CLASS_ARRAY (sym); /* Do nothing for pointer and allocatable arrays. */ - if (sym->attr.pointer || sym->attr.allocatable) + if ((sym->ts.type != BT_CLASS && sym->attr.pointer) + || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)->attr.class_pointer) + || sym->attr.allocatable + || (is_classarray && CLASS_DATA (sym)->attr.allocatable)) return; - if (sym->attr.dummy && gfc_is_nodesc_array (sym)) + if (!is_classarray && sym->attr.dummy && gfc_is_nodesc_array (sym)) { gfc_trans_g77_array (sym, block); return; @@ -5918,14 +5949,20 @@ gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc, type = TREE_TYPE (tmpdesc); gcc_assert (GFC_ARRAY_TYPE_P (type)); dumdesc = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc); - dumdesc = build_fold_indirect_ref_loc (input_location, dumdesc); + if (is_classarray) + /* For a class array the dummy array descriptor is in the _class + component. */ + dumdesc = gfc_class_data_get (dumdesc); + else + dumdesc = build_fold_indirect_ref_loc (input_location, dumdesc); + as = IS_CLASS_ARRAY (sym) ? CLASS_DATA (sym)->as : sym->as; gfc_start_block (&init); if (sym->ts.type == BT_CHARACTER && TREE_CODE (sym->ts.u.cl->backend_decl) == VAR_DECL) gfc_conv_string_length (sym->ts.u.cl, NULL, &init); - checkparm = (sym->as->type == AS_EXPLICIT + checkparm = (as->type == AS_EXPLICIT && (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)); no_repack = !(GFC_DECL_PACKED_ARRAY (tmpdesc) @@ -6001,9 +6038,9 @@ gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc, size = gfc_index_one_node; /* Evaluate the bounds of the array. */ - for (n = 0; n < sym->as->rank; n++) + for (n = 0; n < as->rank; n++) { - if (checkparm || !sym->as->upper[n]) + if (checkparm || !as->upper[n]) { /* Get the bounds of the actual parameter. */ dubound = gfc_conv_descriptor_ubound_get (dumdesc, gfc_rank_cst[n]); @@ -6019,7 +6056,7 @@ gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc, if (!INTEGER_CST_P (lbound)) { gfc_init_se (&se, NULL); - gfc_conv_expr_type (&se, sym->as->lower[n], + gfc_conv_expr_type (&se, as->lower[n], gfc_array_index_type); gfc_add_block_to_block (&init, &se.pre); gfc_add_modify (&init, lbound, se.expr); @@ -6027,13 +6064,13 @@ gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc, ubound = GFC_TYPE_ARRAY_UBOUND (type, n); /* Set the desired upper bound. */ - if (sym->as->upper[n]) + if (as->upper[n]) { /* We know what we want the upper bound to be. */ if (!INTEGER_CST_P (ubound)) { gfc_init_se (&se, NULL); - gfc_conv_expr_type (&se, sym->as->upper[n], + gfc_conv_expr_type (&se, as->upper[n], gfc_array_index_type); gfc_add_block_to_block (&init, &se.pre); gfc_add_modify (&init, ubound, se.expr); @@ -6086,7 +6123,7 @@ gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc, gfc_array_index_type, offset, tmp); /* The size of this dimension, and the stride of the next. */ - if (n + 1 < sym->as->rank) + if (n + 1 < as->rank) { stride = GFC_TYPE_ARRAY_STRIDE (type, n + 1); @@ -6234,7 +6271,7 @@ gfc_get_dataptr_offset (stmtblock_t *block, tree parm, tree desc, tree offset, return; } - tmp = build_array_ref (desc, offset, NULL); + tmp = build_array_ref (desc, offset, NULL, NULL); /* Offset the data pointer for pointer assignments from arrays with subreferences; e.g. my_integer => my_type(:)%integer_component. */ @@ -6789,6 +6826,7 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr) tree from; tree to; tree base; + bool onebased = false; ndim = info->ref ? info->ref->u.ar.dimen : ss->dimen; @@ -6930,6 +6968,7 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr) gfc_array_index_type, to, tmp); from = gfc_index_one_node; } + onebased = integer_onep (from); gfc_conv_descriptor_lbound_set (&loop.pre, parm, gfc_rank_cst[dim], from); @@ -6986,13 +7025,29 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr) gfc_get_dataptr_offset (&loop.pre, parm, desc, offset, subref_array_target, expr); - if (((se->direct_byref || GFC_ARRAY_TYPE_P (TREE_TYPE (desc))) - && !se->data_not_needed) - || (se->use_offset && base != NULL_TREE)) + /* Force the offset to be -1, when the lower bound of the highest + dimension is one and the symbol is present and is not a + pointer/allocatable or associated. */ + if (onebased && se->use_offset + && expr->symtree + && !(expr->symtree->n.sym && expr->symtree->n.sym->ts.type == BT_CLASS + && !CLASS_DATA (expr->symtree->n.sym)->attr.class_pointer) + && !expr->symtree->n.sym->attr.allocatable + && !expr->symtree->n.sym->attr.pointer + && !expr->symtree->n.sym->attr.host_assoc + && !expr->symtree->n.sym->attr.use_assoc) { - /* Set the offset. */ - gfc_conv_descriptor_offset_set (&loop.pre, parm, base); + /* Set the offset to -1. */ + mpz_t minus_one; + mpz_init_set_si (minus_one, -1); + tmp = gfc_conv_mpz_to_tree (minus_one, gfc_index_integer_kind); + gfc_conv_descriptor_offset_set (&loop.pre, parm, tmp); } + else if (((se->direct_byref || GFC_ARRAY_TYPE_P (TREE_TYPE (desc))) + && !se->data_not_needed) + || (se->use_offset && base != NULL_TREE)) + /* Set the offset depending on base. */ + gfc_conv_descriptor_offset_set (&loop.pre, parm, base); else { /* Only the callee knows what the correct offset it, so just set diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c index 769d487..4c18920 100644 --- a/gcc/fortran/trans-decl.c +++ b/gcc/fortran/trans-decl.c @@ -812,8 +812,13 @@ gfc_build_qualified_array (tree decl, gfc_symbol * sym) int dim; int nest; gfc_namespace* procns; + symbol_attribute *array_attr; + gfc_array_spec *as; + bool is_classarray = IS_CLASS_ARRAY (sym); type = TREE_TYPE (decl); + array_attr = is_classarray ? &CLASS_DATA (sym)->attr : &sym->attr; + as = is_classarray ? CLASS_DATA (sym)->as : sym->as; /* We just use the descriptor, if there is one. */ if (GFC_DESCRIPTOR_TYPE_P (type)) @@ -824,8 +829,8 @@ gfc_build_qualified_array (tree decl, gfc_symbol * sym) nest = (procns->proc_name->backend_decl != current_function_decl) && !sym->attr.contained; - if (sym->attr.codimension && flag_coarray == GFC_FCOARRAY_LIB - && sym->as->type != AS_ASSUMED_SHAPE + if (array_attr->codimension && flag_coarray == GFC_FCOARRAY_LIB + && as->type != AS_ASSUMED_SHAPE && GFC_TYPE_ARRAY_CAF_TOKEN (type) == NULL_TREE) { tree token; @@ -878,8 +883,8 @@ gfc_build_qualified_array (tree decl, gfc_symbol * sym) } /* Don't try to use the unknown bound for assumed shape arrays. */ if (GFC_TYPE_ARRAY_UBOUND (type, dim) == NULL_TREE - && (sym->as->type != AS_ASSUMED_SIZE - || dim < GFC_TYPE_ARRAY_RANK (type) - 1)) + && (as->type != AS_ASSUMED_SIZE + || dim < GFC_TYPE_ARRAY_RANK (type) - 1)) { GFC_TYPE_ARRAY_UBOUND (type, dim) = create_index_var ("ubound", nest); TREE_NO_WARNING (GFC_TYPE_ARRAY_UBOUND (type, dim)) = 1; @@ -920,7 +925,7 @@ gfc_build_qualified_array (tree decl, gfc_symbol * sym) } if (GFC_TYPE_ARRAY_SIZE (type) == NULL_TREE - && sym->as->type != AS_ASSUMED_SIZE) + && as->type != AS_ASSUMED_SIZE) { GFC_TYPE_ARRAY_SIZE (type) = create_index_var ("size", nest); TREE_NO_WARNING (GFC_TYPE_ARRAY_SIZE (type)) = 1; @@ -947,12 +952,12 @@ gfc_build_qualified_array (tree decl, gfc_symbol * sym) } if (TYPE_NAME (type) != NULL_TREE - && GFC_TYPE_ARRAY_UBOUND (type, sym->as->rank - 1) != NULL_TREE - && TREE_CODE (GFC_TYPE_ARRAY_UBOUND (type, sym->as->rank - 1)) == VAR_DECL) + && GFC_TYPE_ARRAY_UBOUND (type, as->rank - 1) != NULL_TREE + && TREE_CODE (GFC_TYPE_ARRAY_UBOUND (type, as->rank - 1)) == VAR_DECL) { tree gtype = DECL_ORIGINAL_TYPE (TYPE_NAME (type)); - for (dim = 0; dim < sym->as->rank - 1; dim++) + for (dim = 0; dim < as->rank - 1; dim++) { gcc_assert (TREE_CODE (gtype) == ARRAY_TYPE); gtype = TREE_TYPE (gtype); @@ -966,7 +971,7 @@ gfc_build_qualified_array (tree decl, gfc_symbol * sym) { tree gtype = TREE_TYPE (type), rtype, type_decl; - for (dim = sym->as->rank - 1; dim >= 0; dim--) + for (dim = as->rank - 1; dim >= 0; dim--) { tree lbound, ubound; lbound = GFC_TYPE_ARRAY_LBOUND (type, dim); @@ -1014,41 +1019,56 @@ gfc_build_dummy_array_decl (gfc_symbol * sym, tree dummy) tree decl; tree type; gfc_array_spec *as; + symbol_attribute *array_attr; char *name; gfc_packed packed; int n; bool known_size; - - if (sym->attr.pointer || sym->attr.allocatable - || (sym->as && sym->as->type == AS_ASSUMED_RANK)) + bool is_classarray = IS_CLASS_ARRAY (sym); + + /* Use the array as and attr. */ + as = is_classarray ? CLASS_DATA (sym)->as : sym->as; + array_attr = is_classarray ? &CLASS_DATA (sym)->attr : &sym->attr; + + /* The dummy is returned for pointer, allocatable or assumed rank arrays. + For class arrays the information if sym is an allocatable or pointer + object needs to be checked explicitly (IS_CLASS_ARRAY can be false for + too many reasons to be of use here). */ + if ((sym->ts.type != BT_CLASS && sym->attr.pointer) + || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)->attr.class_pointer) + || array_attr->allocatable + || (as && as->type == AS_ASSUMED_RANK)) return dummy; - /* Add to list of variables if not a fake result variable. */ + /* Add to list of variables if not a fake result variable. + These symbols are set on the symbol only, not on the class component. */ if (sym->attr.result || sym->attr.dummy) gfc_defer_symbol_init (sym); - type = TREE_TYPE (dummy); + /* For a class array the array descriptor is in the _data component, while + for a regular array the TREE_TYPE of the dummy is a pointer to the + descriptor. */ + type = TREE_TYPE (is_classarray ? gfc_class_data_get (dummy) + : TREE_TYPE (dummy)); + /* type now is the array descriptor w/o any indirection. */ gcc_assert (TREE_CODE (dummy) == PARM_DECL - && POINTER_TYPE_P (type)); + && POINTER_TYPE_P (TREE_TYPE (dummy))); /* Do we know the element size? */ known_size = sym->ts.type != BT_CHARACTER || INTEGER_CST_P (sym->ts.u.cl->backend_decl); - if (known_size && !GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (type))) + if (known_size && !GFC_DESCRIPTOR_TYPE_P (type)) { /* For descriptorless arrays with known element size the actual argument is sufficient. */ - gcc_assert (GFC_ARRAY_TYPE_P (type)); gfc_build_qualified_array (dummy, sym); return dummy; } - type = TREE_TYPE (type); if (GFC_DESCRIPTOR_TYPE_P (type)) { /* Create a descriptorless array pointer. */ - as = sym->as; packed = PACKED_NO; /* Even when -frepack-arrays is used, symbols with TARGET attribute @@ -1079,8 +1099,11 @@ gfc_build_dummy_array_decl (gfc_symbol * sym, tree dummy) packed = PACKED_PARTIAL; } - type = gfc_typenode_for_spec (&sym->ts); - type = gfc_get_nodesc_array_type (type, sym->as, packed, + /* For classarrays the element type is required, but + gfc_typenode_for_spec () returns the array descriptor. */ + type = is_classarray ? gfc_get_element_type (type) + : gfc_typenode_for_spec (&sym->ts); + type = gfc_get_nodesc_array_type (type, as, packed, !sym->attr.target); } else @@ -1110,7 +1133,7 @@ gfc_build_dummy_array_decl (gfc_symbol * sym, tree dummy) /* We should never get deferred shape arrays here. We used to because of frontend bugs. */ - gcc_assert (sym->as->type != AS_DEFERRED); + gcc_assert (as->type != AS_DEFERRED); if (packed == PACKED_PARTIAL) GFC_DECL_PARTIAL_PACKED_ARRAY (decl) = 1; @@ -1429,13 +1452,30 @@ gfc_get_symbol_decl (gfc_symbol * sym) sym->backend_decl = decl; } + /* Returning the descriptor for dummy class arrays is hazardous, because + some caller is expecting an expression to apply the component refs to. + Therefore the descriptor is only created and stored in + sym->backend_decl's GFC_DECL_SAVED_DESCRIPTOR. The caller is then + responsible to extract it from there, when the descriptor is + desired. */ + if (IS_CLASS_ARRAY (sym) + && (!DECL_LANG_SPECIFIC (sym->backend_decl) + || !GFC_DECL_SAVED_DESCRIPTOR (sym->backend_decl))) + { + decl = gfc_build_dummy_array_decl (sym, sym->backend_decl); + /* Prevent the dummy from being detected as unused if it is copied. */ + if (sym->backend_decl != NULL && decl != sym->backend_decl) + DECL_ARTIFICIAL (sym->backend_decl) = 1; + sym->backend_decl = decl; + } + TREE_USED (sym->backend_decl) = 1; if (sym->attr.assign && GFC_DECL_ASSIGN (sym->backend_decl) == 0) { gfc_add_assign_aux_vars (sym); } - if (sym->attr.dimension + if ((sym->attr.dimension || IS_CLASS_ARRAY (sym)) && DECL_LANG_SPECIFIC (sym->backend_decl) && GFC_DECL_SAVED_DESCRIPTOR (sym->backend_decl) && DECL_CONTEXT (sym->backend_decl) != current_function_decl) @@ -3976,18 +4016,31 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block) = gfc_class_set_static_fields (sym->backend_decl, vptr, tmp); TREE_CONSTANT (DECL_INITIAL (sym->backend_decl)) = 1; } - else if (sym->attr.dimension || sym->attr.codimension) + else if (sym->attr.dimension || sym->attr.codimension + || (IS_CLASS_ARRAY (sym) && !CLASS_DATA (sym)->attr.allocatable)) { - /* Assumed-size Cray pointees need to be treated as AS_EXPLICIT. */ - array_type tmp = sym->as->type; - if (tmp == AS_ASSUMED_SIZE && sym->as->cp_was_assumed) - tmp = AS_EXPLICIT; - switch (tmp) + bool is_classarray = IS_CLASS_ARRAY (sym); + symbol_attribute *array_attr; + gfc_array_spec *as; + array_type tmp; + + array_attr = is_classarray ? &CLASS_DATA (sym)->attr : &sym->attr; + as = is_classarray ? CLASS_DATA (sym)->as : sym->as; + /* Assumed-size Cray pointees need to be treated as AS_EXPLICIT. */ + tmp = as->type; + if (tmp == AS_ASSUMED_SIZE && as->cp_was_assumed) + tmp = AS_EXPLICIT; + switch (tmp) { case AS_EXPLICIT: if (sym->attr.dummy || sym->attr.result) gfc_trans_dummy_array_bias (sym, sym->backend_decl, block); - else if (sym->attr.pointer || sym->attr.allocatable) + /* Allocatable and pointer arrays need to processed + explicitly. */ + else if ((sym->ts.type != BT_CLASS && sym->attr.pointer) + || (sym->ts.type == BT_CLASS + && CLASS_DATA (sym)->attr.class_pointer) + || array_attr->allocatable) { if (TREE_STATIC (sym->backend_decl)) { @@ -4002,7 +4055,8 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block) gfc_trans_deferred_array (sym, block); } } - else if (sym->attr.codimension && TREE_STATIC (sym->backend_decl)) + else if (sym->attr.codimension + && TREE_STATIC (sym->backend_decl)) { gfc_init_block (&tmpblock); gfc_trans_array_cobounds (TREE_TYPE (sym->backend_decl), @@ -4041,7 +4095,7 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block) case AS_ASSUMED_SIZE: /* Must be a dummy parameter. */ - gcc_assert (sym->attr.dummy || sym->as->cp_was_assumed); + gcc_assert (sym->attr.dummy || as->cp_was_assumed); /* We should always pass assumed size arrays the g77 way. */ if (sym->attr.dummy) @@ -4103,6 +4157,7 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block) } else { + se.descriptor_only = 1; gfc_conv_expr (&se, e); descriptor = se.expr; se.expr = gfc_conv_descriptor_data_addr (se.expr); diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index 88f1af8..81b72273 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -149,6 +149,11 @@ tree gfc_class_vptr_get (tree decl) { tree vptr; + /* For class arrays decl may be a temporary descriptor handle, the vptr is + then available through the saved descriptor. */ + if (TREE_CODE (decl) == VAR_DECL && DECL_LANG_SPECIFIC (decl) + && GFC_DECL_SAVED_DESCRIPTOR (decl)) + decl = GFC_DECL_SAVED_DESCRIPTOR (decl); if (POINTER_TYPE_P (TREE_TYPE (decl))) decl = build_fold_indirect_ref_loc (input_location, decl); vptr = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (decl)), @@ -163,6 +168,11 @@ tree gfc_class_len_get (tree decl) { tree len; + /* For class arrays decl may be a temporary descriptor handle, the len is + then available through the saved descriptor. */ + if (TREE_CODE (decl) == VAR_DECL && DECL_LANG_SPECIFIC (decl) + && GFC_DECL_SAVED_DESCRIPTOR (decl)) + decl = GFC_DECL_SAVED_DESCRIPTOR (decl); if (POINTER_TYPE_P (TREE_TYPE (decl))) decl = build_fold_indirect_ref_loc (input_location, decl); len = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (decl)), @@ -804,6 +814,16 @@ gfc_conv_intrinsic_to_class (gfc_se *parmse, gfc_expr *e, gfc_add_modify (&parmse->pre, ctree, tmp); } + else if (class_ts.type == BT_CLASS + && class_ts.u.derived->components + && class_ts.u.derived->components->ts.u + .derived->attr.unlimited_polymorphic) + { + ctree = gfc_class_len_get (var); + gfc_add_modify (&parmse->pre, ctree, + fold_convert (TREE_TYPE (ctree), + integer_zero_node)); + } /* Pass the address of the class object. */ parmse->expr = gfc_build_addr_expr (NULL_TREE, var); } @@ -830,6 +850,7 @@ gfc_conv_class_to_class (gfc_se *parmse, gfc_expr *e, gfc_typespec class_ts, tree tmp; tree vptr; tree cond = NULL_TREE; + tree slen = NULL_TREE; gfc_ref *ref; gfc_ref *class_ref; stmtblock_t block; @@ -921,7 +942,12 @@ gfc_conv_class_to_class (gfc_se *parmse, gfc_expr *e, gfc_typespec class_ts, tmp = NULL_TREE; if (class_ref == NULL && e->symtree && e->symtree->n.sym->ts.type == BT_CLASS) - tmp = e->symtree->n.sym->backend_decl; + { + tmp = e->symtree->n.sym->backend_decl; + if (DECL_LANG_SPECIFIC (tmp) && GFC_DECL_SAVED_DESCRIPTOR (tmp)) + tmp = GFC_DECL_SAVED_DESCRIPTOR (tmp); + slen = integer_zero_node; + } else { /* Remove everything after the last class reference, convert the @@ -933,6 +959,7 @@ gfc_conv_class_to_class (gfc_se *parmse, gfc_expr *e, gfc_typespec class_ts, gfc_conv_expr (&tmpse, e); class_ref->next = ref; tmp = tmpse.expr; + slen = tmpse.string_length; } gcc_assert (tmp != NULL_TREE); @@ -951,11 +978,38 @@ gfc_conv_class_to_class (gfc_se *parmse, gfc_expr *e, gfc_typespec class_ts, gfc_add_modify (&parmse->post, vptr, fold_convert (TREE_TYPE (vptr), ctree)); + /* For unlimited polymorphic objects also set the _len component. */ + if (class_ts.type == BT_CLASS + && class_ts.u.derived->components + && class_ts.u.derived->components->ts.u + .derived->attr.unlimited_polymorphic) + { + ctree = gfc_class_len_get (var); + if (UNLIMITED_POLY (e)) + tmp = gfc_class_len_get (tmp); + else if (e->ts.type == BT_CHARACTER) + { + gcc_assert (slen != NULL_TREE); + tmp = slen; + } + else + tmp = integer_zero_node; + gfc_add_modify (&parmse->pre, ctree, + fold_convert (TREE_TYPE (ctree), tmp)); + } + if (optional) { tree tmp2; cond = gfc_conv_expr_present (e->symtree->n.sym); + /* parmse->pre may contain some preparatory instructions for the + temporary array descriptor. Those may only be executed when the + optional argument is set, therefore add parmse->pre's instructions + to block, which is later guarded by an if (optional_arg_given). */ + gfc_add_block_to_block (&parmse->pre, &block); + block.head = parmse->pre.head; + parmse->pre.head = NULL_TREE; tmp = gfc_finish_block (&block); if (optional_alloc_ptr) @@ -1042,7 +1096,7 @@ gfc_copy_class_to_class (tree from, tree to, tree nelems, bool unlimited) 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); @@ -1099,7 +1153,8 @@ gfc_copy_class_to_class (tree from, tree to, tree nelems, bool unlimited) gfc_init_block (&ifbody); gfc_add_block_to_block (&ifbody, &loop.pre); stdcopy = gfc_finish_block (&ifbody); - if (unlimited) + /* In initialization mode from_len is a constant zero. */ + if (unlimited && !integer_zerop (from_len)) { vec_safe_push (args, from_len); vec_safe_push (args, to_len); @@ -1141,7 +1196,8 @@ gfc_copy_class_to_class (tree from, tree to, tree nelems, bool unlimited) vec_safe_push (args, to_data); stdcopy = build_call_vec (fcn_type, fcn, args); - if (unlimited) + /* In initialization mode from_len is a constant zero. */ + if (unlimited && !integer_zerop (from_len)) { vec_safe_push (args, from_len); vec_safe_push (args, to_len); @@ -1156,6 +1212,18 @@ gfc_copy_class_to_class (tree from, tree to, tree nelems, bool unlimited) tmp = stdcopy; } + /* Only copy _def_init to to_data, when it is not a NULL-pointer. */ + if (from == NULL_TREE) + { + tree cond; + cond = fold_build2_loc (input_location, NE_EXPR, + boolean_type_node, + from_data, null_pointer_node); + tmp = fold_build3_loc (input_location, COND_EXPR, + void_type_node, cond, + tmp, build_empty_stmt (input_location)); + } + return tmp; } @@ -1229,6 +1297,8 @@ gfc_trans_class_init_assign (gfc_code *code) been referenced. */ gfc_get_derived_type (rhs->ts.u.derived); gfc_add_def_init_component (rhs); + /* The _def_init is always scalar. */ + rhs->rank = 0; if (code->expr1->ts.type == BT_CLASS && CLASS_DATA (code->expr1)->attr.dimension) @@ -2203,6 +2273,16 @@ gfc_conv_component_ref (gfc_se * se, gfc_ref * ref) field = f2; } + if (ref->u.c.sym && ref->u.c.sym->ts.type == BT_CLASS + && strcmp ("_data", c->name) == 0) + { + /* Found a ref to the _data component. Store the associated ref to + the vptr in se->class_vptr. */ + se->class_vptr = gfc_class_vptr_get (decl); + } + else + se->class_vptr = NULL_TREE; + tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field), decl, field, NULL_TREE); @@ -2284,8 +2364,11 @@ gfc_conv_variable (gfc_se * se, gfc_expr * expr) bool return_value; bool alternate_entry; bool entry_master; + bool is_classarray; + bool first_time = true; sym = expr->symtree->n.sym; + is_classarray = IS_CLASS_ARRAY (sym); ss = se->ss; if (ss != NULL) { @@ -2389,9 +2472,24 @@ gfc_conv_variable (gfc_se * se, gfc_expr * expr) } else if (!sym->attr.value) { + /* Dereference temporaries for class array dummy arguments. */ + if (sym->attr.dummy && is_classarray + && GFC_ARRAY_TYPE_P (TREE_TYPE (se->expr))) + { + if (!se->descriptor_only) + se->expr = GFC_DECL_SAVED_DESCRIPTOR (se->expr); + + se->expr = build_fold_indirect_ref_loc (input_location, + se->expr); + } + /* Dereference non-character scalar dummy arguments. */ if (sym->attr.dummy && !sym->attr.dimension - && !(sym->attr.codimension && sym->attr.allocatable)) + && !(sym->attr.codimension && sym->attr.allocatable) + && (sym->ts.type != BT_CLASS + || (!CLASS_DATA (sym)->attr.dimension + && !(CLASS_DATA (sym)->attr.codimension + && CLASS_DATA (sym)->attr.allocatable)))) se->expr = build_fold_indirect_ref_loc (input_location, se->expr); @@ -2403,11 +2501,12 @@ gfc_conv_variable (gfc_se * se, gfc_expr * expr) se->expr = build_fold_indirect_ref_loc (input_location, se->expr); - /* Dereference non-character pointer variables. + /* Dereference non-character, non-class pointer variables. These must be dummies, results, or scalars. */ - if ((sym->attr.pointer || sym->attr.allocatable - || gfc_is_associate_pointer (sym) - || (sym->as && sym->as->type == AS_ASSUMED_RANK)) + if (!is_classarray + && (sym->attr.pointer || sym->attr.allocatable + || gfc_is_associate_pointer (sym) + || (sym->as && sym->as->type == AS_ASSUMED_RANK)) && (sym->attr.dummy || sym->attr.function || sym->attr.result @@ -2415,6 +2514,32 @@ gfc_conv_variable (gfc_se * se, gfc_expr * expr) && (!sym->attr.codimension || !sym->attr.allocatable)))) se->expr = build_fold_indirect_ref_loc (input_location, se->expr); + /* Now treat the class array pointer variables accordingly. */ + else if (sym->ts.type == BT_CLASS + && sym->attr.dummy + && (CLASS_DATA (sym)->attr.dimension + || CLASS_DATA (sym)->attr.codimension) + && ((CLASS_DATA (sym)->as + && CLASS_DATA (sym)->as->type == AS_ASSUMED_RANK) + || CLASS_DATA (sym)->attr.allocatable + || CLASS_DATA (sym)->attr.class_pointer)) + se->expr = build_fold_indirect_ref_loc (input_location, + se->expr); + /* And the case where a non-dummy, non-result, non-function, + non-allotable and non-pointer classarray is present. This case was + previously covered by the first if, but with introducing the + condition !is_classarray there, that case has to be covered + explicitly. */ + else if (sym->ts.type == BT_CLASS + && !sym->attr.dummy + && !sym->attr.function + && !sym->attr.result + && (CLASS_DATA (sym)->attr.dimension + || CLASS_DATA (sym)->attr.codimension) + && !CLASS_DATA (sym)->attr.allocatable + && !CLASS_DATA (sym)->attr.class_pointer) + se->expr = build_fold_indirect_ref_loc (input_location, + se->expr); } ref = expr->ref; @@ -2452,6 +2577,18 @@ gfc_conv_variable (gfc_se * se, gfc_expr * expr) break; case REF_COMPONENT: + if (first_time && is_classarray && sym->attr.dummy + && se->descriptor_only + && !CLASS_DATA (sym)->attr.allocatable + && !CLASS_DATA (sym)->attr.class_pointer + && CLASS_DATA (sym)->as + && CLASS_DATA (sym)->as->type != AS_ASSUMED_RANK + && strcmp ("_data", ref->u.c.component->name) == 0) + /* Skip the first ref of a _data component, because for class + arrays that one is already done by introducing a temporary + array descriptor. */ + break; + if (ref->u.c.sym->attr.extension) conv_parent_component_references (se, ref); @@ -2471,6 +2608,7 @@ gfc_conv_variable (gfc_se * se, gfc_expr * expr) gcc_unreachable (); break; } + first_time = false; ref = ref->next; } /* Pointer assignment, allocation or pass by reference. Arrays are handled @@ -4597,7 +4735,19 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, gfc_init_se (&parmse, se); parm_kind = ELEMENTAL; - if (fsym && fsym->attr.value) + /* For all value functions or polymorphic scalar non-pointer + non-allocatable variables use the expression in e directly. This + ensures, that initializers of polymorphic entities are correctly + copied. */ + if (fsym && (fsym->attr.value + || (e->expr_type == EXPR_VARIABLE + && fsym->ts.type == BT_DERIVED + && e->ts.type == BT_DERIVED + && !e->ts.u.derived->attr.dimension + && !e->rank + && (!e->symtree + || (!e->symtree->n.sym->attr.allocatable + && !e->symtree->n.sym->attr.pointer))))) gfc_conv_expr (&parmse, e); else gfc_conv_expr_reference (&parmse, e); diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c index c4ccb7b..20e5b37 100644 --- a/gcc/fortran/trans-intrinsic.c +++ b/gcc/fortran/trans-intrinsic.c @@ -5921,8 +5921,17 @@ gfc_conv_intrinsic_sizeof (gfc_se *se, gfc_expr *expr) } else if (arg->ts.type == BT_CLASS) { - if (arg->rank) + /* For deferred length arrays, conv_expr_descriptor returns an + indirect_ref to the component. */ + if (arg->rank < 0 + || (arg->rank > 0 && !VAR_P (argse.expr) + && GFC_DECL_CLASS (TREE_OPERAND (argse.expr, 0)))) byte_size = gfc_class_vtab_size_get (TREE_OPERAND (argse.expr, 0)); + else if (arg->rank > 0) + /* The scalarizer added an additional temp. To get the class' vptr + one has to look at the original backend_decl. */ + byte_size = gfc_class_vtab_size_get ( + GFC_DECL_SAVED_DESCRIPTOR (arg->symtree->n.sym->backend_decl)); else byte_size = gfc_class_vtab_size_get (argse.expr); } @@ -6053,7 +6062,11 @@ gfc_conv_intrinsic_storage_size (gfc_se *se, gfc_expr *expr) gfc_conv_expr_descriptor (&argse, arg); if (arg->ts.type == BT_CLASS) { - tmp = gfc_class_vtab_size_get (TREE_OPERAND (argse.expr, 0)); + if (arg->rank > 0) + tmp = gfc_class_vtab_size_get ( + GFC_DECL_SAVED_DESCRIPTOR (arg->symtree->n.sym->backend_decl)); + else + tmp = gfc_class_vtab_size_get (TREE_OPERAND (argse.expr, 0)); tmp = fold_convert (result_type, tmp); goto done; } @@ -7080,7 +7093,11 @@ gfc_conv_intrinsic_loc (gfc_se * se, gfc_expr * expr) arg_expr = expr->value.function.actual->expr; if (arg_expr->rank == 0) - gfc_conv_expr_reference (se, arg_expr); + { + if (arg_expr->ts.type == BT_CLASS) + gfc_add_component_ref (arg_expr, "_data"); + gfc_conv_expr_reference (se, arg_expr); + } else gfc_conv_array_parameter (se, arg_expr, true, NULL, NULL, NULL); se->expr = convert (gfc_get_int_type (gfc_index_integer_kind), se->expr); diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c index 619564b..88dd31f 100644 --- a/gcc/fortran/trans-stmt.c +++ b/gcc/fortran/trans-stmt.c @@ -1260,12 +1260,29 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block) gfc_init_se (&se, NULL); se.descriptor_only = 1; - gfc_conv_expr (&se, e); + /* In a select type the (temporary) associate variable shall point to + a standard fortran array (lower bound == 1), but conv_expr () + just maps to the input array in the class object, whose lbound may + be arbitrary. conv_expr_descriptor solves this by inserting a + temporary array descriptor. */ + gfc_conv_expr_descriptor (&se, e); - gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se.expr))); + gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se.expr)) + || GFC_ARRAY_TYPE_P (TREE_TYPE (se.expr))); gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (sym->backend_decl))); - gfc_add_modify (&se.pre, sym->backend_decl, se.expr); + if (GFC_ARRAY_TYPE_P (TREE_TYPE (se.expr))) + { + if (INDIRECT_REF_P (se.expr)) + tmp = TREE_OPERAND (se.expr, 0); + else + tmp = se.expr; + + gfc_add_modify (&se.pre, sym->backend_decl, + gfc_class_data_get (GFC_DECL_SAVED_DESCRIPTOR (tmp))); + } + else + gfc_add_modify (&se.pre, sym->backend_decl, se.expr); if (unlimited) { @@ -1276,7 +1293,7 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block) gfc_get_dtype (TREE_TYPE (sym->backend_decl))); } - gfc_add_init_cleanup (block, gfc_finish_block( &se.pre), + gfc_add_init_cleanup (block, gfc_finish_block (&se.pre), gfc_finish_block (&se.post)); } @@ -1319,9 +1336,18 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block) } if (need_len_assign) { - /* Get the _len comp from the target expr by stripping _data - from it and adding component-ref to _len. */ - tmp = gfc_class_len_get (TREE_OPERAND (target_expr, 0)); + if (e->symtree + && DECL_LANG_SPECIFIC (e->symtree->n.sym->backend_decl) + && GFC_DECL_SAVED_DESCRIPTOR (e->symtree->n.sym->backend_decl)) + /* Use the original class descriptor stored in the saved + descriptor to get the target_expr. */ + target_expr = + GFC_DECL_SAVED_DESCRIPTOR (e->symtree->n.sym->backend_decl); + else + /* Strip the _data component from the target_expr. */ + target_expr = TREE_OPERAND (target_expr, 0); + /* Add a reference to the _len comp to the target expr. */ + tmp = gfc_class_len_get (target_expr); /* Get the component-ref for the temp structure's _len comp. */ charlen = gfc_class_len_get (se.expr); /* Add the assign to the beginning of the the block... */ diff --git a/gcc/fortran/trans-types.c b/gcc/fortran/trans-types.c index 708289f..b9f662d 100644 --- a/gcc/fortran/trans-types.c +++ b/gcc/fortran/trans-types.c @@ -1288,25 +1288,35 @@ gfc_get_element_type (tree type) int gfc_is_nodesc_array (gfc_symbol * sym) { - gcc_assert (sym->attr.dimension || sym->attr.codimension); + symbol_attribute *array_attr; + gfc_array_spec *as; + bool is_classarray = IS_CLASS_ARRAY (sym); + + array_attr = is_classarray ? &CLASS_DATA (sym)->attr : &sym->attr; + as = is_classarray ? CLASS_DATA (sym)->as : sym->as; + + gcc_assert (array_attr->dimension || array_attr->codimension); /* We only want local arrays. */ - if (sym->attr.pointer || sym->attr.allocatable) + if ((sym->ts.type != BT_CLASS && sym->attr.pointer) + || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)->attr.class_pointer) + || array_attr->allocatable) return 0; /* We want a descriptor for associate-name arrays that do not have an - explicitly known shape already. */ - if (sym->assoc && sym->as->type != AS_EXPLICIT) + explicitly known shape already. */ + if (sym->assoc && as->type != AS_EXPLICIT) return 0; + /* The dummy is stored in sym and not in the component. */ if (sym->attr.dummy) - return sym->as->type != AS_ASSUMED_SHAPE - && sym->as->type != AS_ASSUMED_RANK; + return as->type != AS_ASSUMED_SHAPE + && as->type != AS_ASSUMED_RANK; if (sym->attr.result || sym->attr.function) return 0; - gcc_assert (sym->as->type == AS_EXPLICIT || sym->as->cp_was_assumed); + gcc_assert (as->type == AS_EXPLICIT || as->cp_was_assumed); return 1; } diff --git a/gcc/fortran/trans.c b/gcc/fortran/trans.c index b7ec0e5..6da464a 100644 --- a/gcc/fortran/trans.c +++ b/gcc/fortran/trans.c @@ -321,7 +321,7 @@ gfc_build_addr_expr (tree type, tree t) /* Build an ARRAY_REF with its natural type. */ tree -gfc_build_array_ref (tree base, tree offset, tree decl) +gfc_build_array_ref (tree base, tree offset, tree decl, tree vptr) { tree type = TREE_TYPE (base); tree tmp; @@ -353,30 +353,47 @@ gfc_build_array_ref (tree base, tree offset, tree decl) /* If the array reference is to a pointer, whose target contains a subreference, use the span that is stored with the backend decl and reference the element with pointer arithmetic. */ - if (decl && (TREE_CODE (decl) == FIELD_DECL - || TREE_CODE (decl) == VAR_DECL - || TREE_CODE (decl) == PARM_DECL) - && ((GFC_DECL_SUBREF_ARRAY_P (decl) - && !integer_zerop (GFC_DECL_SPAN(decl))) + if ((decl && (TREE_CODE (decl) == FIELD_DECL + || TREE_CODE (decl) == VAR_DECL + || TREE_CODE (decl) == PARM_DECL) + && ((GFC_DECL_SUBREF_ARRAY_P (decl) + && !integer_zerop (GFC_DECL_SPAN (decl))) || GFC_DECL_CLASS (decl))) + || vptr) { - if (GFC_DECL_CLASS (decl)) + if (decl) { - /* Allow for dummy arguments and other good things. */ - if (POINTER_TYPE_P (TREE_TYPE (decl))) - decl = build_fold_indirect_ref_loc (input_location, decl); - - /* Check if '_data' is an array descriptor. If it is not, - the array must be one of the components of the class object, - so return a normal array reference. */ - if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (gfc_class_data_get (decl)))) - return build4_loc (input_location, ARRAY_REF, type, base, - offset, NULL_TREE, NULL_TREE); - - span = gfc_class_vtab_size_get (decl); + if (GFC_DECL_CLASS (decl)) + { + /* When a temporary is in place for the class array, then the + original class' declaration is stored in the saved + descriptor. */ + if (DECL_LANG_SPECIFIC (decl) && GFC_DECL_SAVED_DESCRIPTOR (decl)) + decl = GFC_DECL_SAVED_DESCRIPTOR (decl); + else + { + /* Allow for dummy arguments and other good things. */ + if (POINTER_TYPE_P (TREE_TYPE (decl))) + decl = build_fold_indirect_ref_loc (input_location, decl); + + /* Check if '_data' is an array descriptor. If it is not, + the array must be one of the components of the class + object, so return a normal array reference. */ + if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE ( + gfc_class_data_get (decl)))) + return build4_loc (input_location, ARRAY_REF, type, base, + offset, NULL_TREE, NULL_TREE); + } + + span = gfc_class_vtab_size_get (decl); + } + else if (GFC_DECL_SUBREF_ARRAY_P (decl)) + span = GFC_DECL_SPAN (decl); + else + gcc_unreachable (); } - else if (GFC_DECL_SUBREF_ARRAY_P (decl)) - span = GFC_DECL_SPAN(decl); + else if (vptr) + span = gfc_vptr_size_get (vptr); else gcc_unreachable (); diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h index 1998358..e2a1fea 100644 --- a/gcc/fortran/trans.h +++ b/gcc/fortran/trans.h @@ -49,6 +49,10 @@ typedef struct gfc_se /* The length of a character string value. */ tree string_length; + /* When expr is a reference to a class object, store its vptr access + here. */ + tree class_vptr; + /* If set gfc_conv_variable will return an expression for the array descriptor. When set, want_pointer should also be set. If not set scalarizing variables will be substituted. */ @@ -528,7 +532,7 @@ tree gfc_get_function_decl (gfc_symbol *); tree gfc_build_addr_expr (tree, tree); /* Build an ARRAY_REF. */ -tree gfc_build_array_ref (tree, tree, tree); +tree gfc_build_array_ref (tree, tree, tree, tree vptr = NULL_TREE); /* Creates a label. Decl is artificial if label_id == NULL_TREE. */ tree gfc_build_label_decl (tree); diff --git a/gcc/testsuite/gfortran.dg/class_allocate_19.f03 b/gcc/testsuite/gfortran.dg/class_allocate_19.f03 new file mode 100644 index 0000000..719be3e --- /dev/null +++ b/gcc/testsuite/gfortran.dg/class_allocate_19.f03 @@ -0,0 +1,47 @@ +! { dg-do run } +! +! Contributed by: Vladimir Fuka + +use iso_c_binding +implicit none +real, target :: e +class(*), allocatable, target :: a(:) +e = 1.0 +call add_element_poly(a,e) +if (size(a) /= 1) call abort() +call add_element_poly(a,e) +if (size(a) /= 2) call abort() +select type (a) + type is (real) + if (any (a /= [ 1, 1])) call abort() +end select +contains + subroutine add_element_poly(a,e) + use iso_c_binding + class(*),allocatable,intent(inout),target :: a(:) + class(*),intent(in),target :: e + class(*),allocatable,target :: tmp(:) + type(c_ptr) :: dummy + + interface + function memcpy(dest,src,n) bind(C,name="memcpy") result(res) + import + type(c_ptr) :: res + integer(c_intptr_t),value :: dest + integer(c_intptr_t),value :: src + integer(c_size_t),value :: n + end function + end interface + + if (.not.allocated(a)) then + allocate(a(1), source=e) + else + allocate(tmp(size(a)),source=a) + deallocate(a) + allocate(a(size(tmp)+1),mold=e) + dummy = memcpy(loc(a(1)),loc(tmp),sizeof(tmp)) + dummy = memcpy(loc(a(size(tmp)+1)),loc(e),sizeof(e)) + end if + end subroutine +end + diff --git a/gcc/testsuite/gfortran.dg/class_array_20.f03 b/gcc/testsuite/gfortran.dg/class_array_20.f03 new file mode 100644 index 0000000..c49f7d2 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/class_array_20.f03 @@ -0,0 +1,100 @@ +! {dg-do run} +! +! Test contributed by Thomas L. Clune via pr60322 +! and Antony Lewis via pr64692 + +program class_array_20 + implicit none + + type Foo + end type + + type(foo), dimension(2:3) :: arg + integer :: oneDarr(2) + integer :: twoDarr(2,3) + integer :: x, y + double precision :: P(2, 2) + + ! Checking for PR/60322 + call copyFromClassArray([Foo(), Foo()]) + call copyFromClassArray(arg) + call copyFromClassArray(arg(:)) + + x= 3 + y= 4 + oneDarr = [x, y] + call W([x, y]) + call W(oneDarr) + call W([3, 4]) + + twoDarr = reshape([3, 4, 5, 5, 6, 7], [2, 3]) + call WtwoD(twoDarr) + call WtwoD(reshape([3, 4, 5, 5, 6, 7], [2, 3])) + + ! Checking for PR/64692 + P(1:2, 1) = [1.d0, 2.d0] + P(1:2, 2) = [3.d0, 4.d0] + call AddArray(P(1:2, 2)) + +contains + + subroutine copyFromClassArray(classarray) + class (Foo), intent(in) :: classarray(:) + + if (lbound(classarray, 1) .ne. 1) call abort() + if (ubound(classarray, 1) .ne. 2) call abort() + if (size(classarray) .ne. 2) call abort() + end subroutine + + subroutine AddArray(P) + class(*), target, intent(in) :: P(:) + class(*), pointer :: Pt(:) + + allocate(Pt(1:size(P)), source= P) + + select type (P) + type is (double precision) + if (abs(P(1)-3.d0) .gt. 1.d-8) call abort() + if (abs(P(2)-4.d0) .gt. 1.d-8) call abort() + class default + call abort() + end select + + select type (Pt) + type is (double precision) + if (abs(Pt(1)-3.d0) .gt. 1.d-8) call abort() + if (abs(Pt(2)-4.d0) .gt. 1.d-8) call abort() + class default + call abort() + end select + end subroutine + + subroutine W(ar) + class(*), intent(in) :: ar(:) + + if (lbound(ar, 1) /= 1) call abort() + select type (ar) + type is (integer) + ! The indeces 1:2 are essential here, or else one would not + ! note, that the array internally starts at 0, although the + ! check for the lbound above went fine. + if (any (ar(1:2) .ne. [3, 4])) call abort() + class default + call abort() + end select + end subroutine + + subroutine WtwoD(ar) + class(*), intent(in) :: ar(:,:) + + if (any (lbound(ar) /= [1, 1])) call abort() + select type (ar) + type is (integer) + if (any (reshape(ar(1:2,1:3), [6]) .ne. [3, 4, 5, 5, 6, 7])) & + call abort() + class default + call abort() + end select + end subroutine +end program class_array_20 + diff --git a/gcc/testsuite/gfortran.dg/class_array_21.f03 b/gcc/testsuite/gfortran.dg/class_array_21.f03 new file mode 100644 index 0000000..1e89d38 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/class_array_21.f03 @@ -0,0 +1,97 @@ +! {dg-do run} +! +! Contributed by Andre Vehreschild +! Check more elaborate class array addressing. + +module m1 + + type InnerBaseT + integer, allocatable :: a(:) + end type InnerBaseT + + type, extends(InnerBaseT) :: InnerT + integer :: i + end type InnerT + + type BaseT + class(InnerT), allocatable :: arr(:,:) + contains + procedure P + end type BaseT + +contains + + subroutine indir(this, mat) + class(BaseT) :: this + class(InnerT), intent(inout) :: mat(:,:) + + call this%P(mat) + end subroutine indir + + subroutine P(this, mat) + class(BaseT) :: this + class(InnerT), intent(inout) :: mat(:,:) + integer :: i,j + + mat%i = 42 + do i= 1, ubound(mat, 1) + do j= 1, ubound(mat, 2) + if (.not. allocated(mat(i,j)%a)) then + allocate(mat(i,j)%a(10), source = 72) + end if + end do + end do + mat(1,1)%i = 9 + mat(1,1)%a(5) = 1 + end subroutine + +end module m1 + +program test + use m1 + + class(BaseT), allocatable, target :: o + class(InnerT), pointer :: i_p(:,:) + class(InnerBaseT), allocatable :: i_a(:,:) + integer i,j,l + + allocate(o) + allocate(o%arr(2,2)) + allocate(InnerT::i_a(2,2)) + o%arr%i = 1 + + i_p => o%arr + call o%P(i_p) + if (any(o%arr%i /= reshape([9,42,42,42],[2,2]))) call abort() + do l= 1, 10 + do i= 1, 2 + do j= 1,2 + if ((i == 1 .and. j == 1 .and. l == 5 .and. & + o%arr(i,j)%a(5) /= 1) & + .or. (.not. (i == 1 .and. j == 1 .and. l == 5) & + .and. o%arr(i,j)%a(l) /= 72)) call abort() + end do + end do + end do + + select type (i_a) + type is (InnerT) + call o%P(i_a) + do l= 1, 10 + do i= 1, 2 + do j= 1,2 + if ((i == 1 .and. j == 1 .and. l == 5 .and. & + i_a(i,j)%a(5) /= 1) & + .or. (.not. (i == 1 .and. j == 1 .and. l == 5) & + .and. i_a(i,j)%a(l) /= 72)) call abort() + end do + end do + end do + end select + + i_p%i = 4 + call indir(o, i_p) + if (any(o%arr%i /= reshape([9,42,42,42],[2,2]))) call abort() +end program test + +! vim:ts=2:sts=2:cindent:sw=2:tw=80: diff --git a/gcc/testsuite/gfortran.dg/finalize_10.f90 b/gcc/testsuite/gfortran.dg/finalize_10.f90 index e042f11..32386ce 100644 --- a/gcc/testsuite/gfortran.dg/finalize_10.f90 +++ b/gcc/testsuite/gfortran.dg/finalize_10.f90 @@ -27,8 +27,8 @@ end subroutine foo ! Finalize CLASS + set default init ! { dg-final { scan-tree-dump-times "y->_vptr->_final \\(&desc.\[0-9\]+, y->_vptr->_size, 0\\);" 1 "original" } } ! { dg-final { scan-tree-dump "__builtin_memcpy \\(\\(void .\\) y->_data, \\(void .\\) y->_vptr->_def_init, \\((unsigned long|unsigned int|character\\(kind=4\\))\\) y->_vptr->_size\\);" "original" } } -! { dg-final { scan-tree-dump-times "x->_vptr->_final \\(&x->_data, x->_vptr->_size, 0\\);" 1 "original" } } -! { dg-final { scan-tree-dump-times "x->_vptr->_copy \\(x->_vptr->_def_init, &x->_data\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "x->_vptr->_final \\(&parm.\[0-9\]+, x->_vptr->_size, 0\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "x->_vptr->_copy \\(" 1 "original" } } ! FINALIZE TYPE: ! { dg-final { scan-tree-dump-times "parm.\[0-9\]+.data = \\(void \\*\\) &\\(\\*aa.\[0-9\]+\\)\\\[0\\\];" 1 "original" } } diff --git a/gcc/testsuite/gfortran.dg/finalize_15.f90 b/gcc/testsuite/gfortran.dg/finalize_15.f90 index 3c18b2a..d5ba28f 100644 --- a/gcc/testsuite/gfortran.dg/finalize_15.f90 +++ b/gcc/testsuite/gfortran.dg/finalize_15.f90 @@ -9,37 +9,37 @@ module m implicit none type t1 - integer :: i + integer :: i = 1 contains final :: fini_elem end type t1 type, extends(t1) :: t1e - integer :: j + integer :: j = 11 contains final :: fini_elem2 end type t1e type t2 - integer :: i + integer :: i = 2 contains final :: fini_shape end type t2 type, extends(t2) :: t2e - integer :: j + integer :: j = 22 contains final :: fini_shape2 end type t2e type t3 - integer :: i + integer :: i = 3 contains final :: fini_explicit end type t3 type, extends(t3) :: t3e - integer :: j + integer :: j = 33 contains final :: fini_explicit2 end type t3e @@ -204,31 +204,31 @@ program test select type(x) type is (t1e) - call check_val(x%i, 1) - call check_val(x%j, 100) + call check_val(x%i, 1, 1) + call check_val(x%j, 100, 11) end select select type(y) type is (t2e) - call check_val(y%i, 1) - call check_val(y%j, 100) + call check_val(y%i, 1, 2) + call check_val(y%j, 100, 22) end select select type(z) type is (t3e) - call check_val(z%i, 1) - call check_val(z%j, 100) + call check_val(z%i, 1, 3) + call check_val(z%j, 100, 33) end select contains - subroutine check_val(x, factor) + subroutine check_val(x, factor, val) integer :: x(:,:) - integer, value :: factor + integer, value :: factor, val integer :: i, j do i = 1, 10 do j = 1, 10 if (mod (j-1, 2) == 0 .and. mod (i-1, 3) == 0) then - if (x(j,i) /= (j + 100*i)*factor*(-13)) call abort () + if (x(j,i) /= val) call abort () else if (x(j,i) /= (j + 100*i)*factor) call abort () end if diff --git a/gcc/testsuite/gfortran.dg/finalize_29.f08 b/gcc/testsuite/gfortran.dg/finalize_29.f08 new file mode 100644 index 0000000..1f5f7424 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/finalize_29.f08 @@ -0,0 +1,289 @@ +! {dg-do run} +! +! Testcase contributed by Andre Vehreschild + +module module_finalize_29 + implicit none + + ! The type name is encoding the state of its finalizer being + ! elemental (second letter 'e'), or non-element (second letter 'n') + ! or array shaped (second letter 'a'), or shape-specific routine + ! (generic; second letter 'g'), + ! and whether the init-routine is elemental or not (third letter + ! either 'e' or 'n'). + type ten + integer :: i = 40 + contains + final :: ten_fin + end type ten + + type tee + integer :: i = 41 + contains + final :: tee_fin + end type tee + + type tne + integer :: i = 42 + contains + final :: tne_fin + end type tne + + type tnn + integer :: i = 43 + contains + final :: tnn_fin + end type tnn + + type tae + integer :: i = 44 + contains + final :: tae_fin + end type tae + + type tan + integer :: i = 45 + contains + final :: tan_fin + end type tan + + type tge + integer :: i = 46 + contains + final :: tge_scalar_fin, tge_array_fin + end type tge + + type tgn + integer :: i = 47 + contains + final :: tgn_scalar_fin, tgn_array_fin + end type tgn + + integer :: ten_fin_counts, tee_fin_counts, tne_fin_counts, tnn_fin_counts + integer :: tae_fin_counts, tan_fin_counts + integer :: tge_scalar_fin_counts, tge_array_fin_counts + integer :: tgn_scalar_fin_counts, tgn_array_fin_counts +contains + impure elemental subroutine ten_fin(x) + type(ten), intent(inout) :: x + x%i = -10 * x%i + ten_fin_counts = ten_fin_counts + 1 + end subroutine ten_fin + + impure elemental subroutine tee_fin(x) + type(tee), intent(inout) :: x + x%i = -11 * x%i + tee_fin_counts = tee_fin_counts + 1 + end subroutine tee_fin + + subroutine tne_fin(x) + type(tne), intent(inout) :: x + x%i = -12 * x%i + tne_fin_counts = tne_fin_counts + 1 + end subroutine tne_fin + + subroutine tnn_fin(x) + type(tnn), intent(inout) :: x + x%i = -13 * x%i + tnn_fin_counts = tnn_fin_counts + 1 + end subroutine tnn_fin + + subroutine tae_fin(x) + type(tae), intent(inout) :: x(:,:) + x%i = -14 * x%i + tae_fin_counts = tae_fin_counts + 1 + end subroutine tae_fin + + subroutine tan_fin(x) + type(tan), intent(inout) :: x(:,:) + x%i = -15 * x%i + tan_fin_counts = tan_fin_counts + 1 + end subroutine tan_fin + + subroutine tge_scalar_fin(x) + type(tge), intent(inout) :: x + x%i = -16 * x%i + tge_scalar_fin_counts = tge_scalar_fin_counts + 1 + end subroutine tge_scalar_fin + + subroutine tge_array_fin(x) + type(tge), intent(inout) :: x(:,:) + x%i = -17 * x%i + tge_array_fin_counts = tge_array_fin_counts + 1 + end subroutine tge_array_fin + + subroutine tgn_scalar_fin(x) + type(tgn), intent(inout) :: x + x%i = -18 * x%i + tgn_scalar_fin_counts = tgn_scalar_fin_counts + 1 + end subroutine tgn_scalar_fin + + subroutine tgn_array_fin(x) + type(tgn), intent(inout) :: x(:,:) + x%i = -19 * x%i + tgn_array_fin_counts = tgn_array_fin_counts + 1 + end subroutine tgn_array_fin + + ! The finalizer/initializer call producer + subroutine ten_init(x) + class(ten), intent(out) :: x(:,:) + end subroutine ten_init + + impure elemental subroutine tee_init(x) + class(tee), intent(out) :: x + end subroutine tee_init + + impure elemental subroutine tne_init(x) + class(tne), intent(out) :: x + end subroutine tne_init + + subroutine tnn_init(x) + class(tnn), intent(out) :: x(:,:) + end subroutine tnn_init + + impure elemental subroutine tae_init(x) + class(tae), intent(out) :: x + end subroutine tae_init + + subroutine tan_init(x) + class(tan), intent(out) :: x(:,:) + end subroutine tan_init + + impure elemental subroutine tge_init(x) + class(tge), intent(out) :: x + end subroutine tge_init + + subroutine tgn_init(x) + class(tgn), intent(out) :: x(:,:) + end subroutine tgn_init +end module module_finalize_29 + +program finalize_29 + use module_finalize_29 + implicit none + + type(ten), allocatable :: x_ten(:,:) + type(tee), allocatable :: x_tee(:,:) + type(tne), allocatable :: x_tne(:,:) + type(tnn), allocatable :: x_tnn(:,:) + type(tae), allocatable :: x_tae(:,:) + type(tan), allocatable :: x_tan(:,:) + type(tge), allocatable :: x_tge(:,:) + type(tgn), allocatable :: x_tgn(:,:) + + ! Set the global counts to zero. + ten_fin_counts = 0 + tee_fin_counts = 0 + tne_fin_counts = 0 + tnn_fin_counts = 0 + tae_fin_counts = 0 + tan_fin_counts = 0 + tge_scalar_fin_counts = 0 + tge_array_fin_counts = 0 + tgn_scalar_fin_counts = 0 + tgn_array_fin_counts = 0 + + allocate(ten :: x_ten(5,5)) + allocate(tee :: x_tee(5,5)) + allocate(tne :: x_tne(5,5)) + allocate(tnn :: x_tnn(5,5)) + allocate(tae :: x_tae(5,5)) + allocate(tan :: x_tan(5,5)) + allocate(tge :: x_tge(5,5)) + allocate(tgn :: x_tgn(5,5)) + + x_ten%i = 1 + x_tee%i = 2 + x_tne%i = 3 + x_tnn%i = 4 + x_tae%i = 5 + x_tan%i = 6 + x_tge%i = 7 + x_tgn%i = 8 + + call ten_init(x_ten(::2, ::3)) + + if (ten_fin_counts /= 6) call abort() + if (tee_fin_counts + tne_fin_counts + tnn_fin_counts + tae_fin_counts + & + tan_fin_counts + tge_scalar_fin_counts + tge_array_fin_counts + & + tgn_scalar_fin_counts + tgn_array_fin_counts /= 0) call abort() + ten_fin_counts = 0 + + call tee_init(x_tee(::2, ::3)) + + if (tee_fin_counts /= 6) call abort() + if (ten_fin_counts + tne_fin_counts + tnn_fin_counts + tae_fin_counts + & + tan_fin_counts + tge_scalar_fin_counts + tge_array_fin_counts + & + tgn_scalar_fin_counts + tgn_array_fin_counts /= 0) call abort() + tee_fin_counts = 0 + + call tne_init(x_tne(::2, ::3)) + + if (tne_fin_counts /= 6) call abort() + if (ten_fin_counts + tee_fin_counts + tnn_fin_counts + tae_fin_counts + & + tan_fin_counts + tge_scalar_fin_counts + tge_array_fin_counts + & + tgn_scalar_fin_counts + tgn_array_fin_counts /= 0) call abort() + tne_fin_counts = 0 + + call tnn_init(x_tnn(::2, ::3)) + + if (tnn_fin_counts /= 0) call abort() + if (ten_fin_counts + tee_fin_counts + tne_fin_counts + tae_fin_counts + & + tan_fin_counts + tge_scalar_fin_counts + tge_array_fin_counts + & + tgn_scalar_fin_counts + tgn_array_fin_counts /= 0) call abort() + + call tae_init(x_tae(::2, ::3)) + + if (tae_fin_counts /= 0) call abort() + if (ten_fin_counts + tee_fin_counts + tne_fin_counts + tnn_fin_counts + & + tan_fin_counts + tge_scalar_fin_counts + tge_array_fin_counts + & + tgn_scalar_fin_counts + tgn_array_fin_counts /= 0) call abort() + + call tan_init(x_tan(::2, ::3)) + + if (tan_fin_counts /= 1) call abort() + if (ten_fin_counts + tee_fin_counts + tne_fin_counts + tnn_fin_counts + & + tae_fin_counts + tge_scalar_fin_counts + tge_array_fin_counts + & + tgn_scalar_fin_counts + tgn_array_fin_counts /= 0) call abort() + tan_fin_counts = 0 + + call tge_init(x_tge(::2, ::3)) + + if (tge_scalar_fin_counts /= 6) call abort() + if (ten_fin_counts + tee_fin_counts + tne_fin_counts + tnn_fin_counts + & + tae_fin_counts + tan_fin_counts + tgn_array_fin_counts + & + tgn_scalar_fin_counts + tgn_array_fin_counts /= 0) call abort() + tge_scalar_fin_counts = 0 + + call tgn_init(x_tgn(::2, ::3)) + + if (tgn_array_fin_counts /= 1) call abort() + if (ten_fin_counts + tee_fin_counts + tne_fin_counts + tnn_fin_counts + & + tae_fin_counts + tan_fin_counts + tge_scalar_fin_counts + & + tge_array_fin_counts + tgn_scalar_fin_counts /= 0) call abort() + tgn_array_fin_counts = 0 + + if (any (reshape (x_ten%i, [25]) /= [[40, 1, 40, 1, 40], [1, 1, 1, 1, 1],& + [1, 1, 1, 1, 1], [40, 1, 40, 1, 40], [1, 1, 1, 1, 1]])) call abort() + + if (any (reshape (x_tee%i, [25]) /= [[41, 2, 41, 2, 41], [2, 2, 2, 2, 2],& + [2, 2, 2, 2, 2], [41, 2, 41, 2, 41], [2, 2, 2, 2, 2]])) call abort() + + if (any (reshape (x_tne%i, [25]) /= [[42, 3, 42, 3, 42], [3, 3, 3, 3, 3],& + [3, 3, 3, 3, 3], [42, 3, 42, 3, 42], [3, 3, 3, 3, 3]])) call abort() + + if (any (reshape (x_tnn%i, [25]) /= [[43, 4, 43, 4, 43], [4, 4, 4, 4, 4],& + [4, 4, 4, 4, 4], [43, 4, 43, 4, 43], [4, 4, 4, 4, 4]])) call abort() + + if (any (reshape (x_tae%i, [25]) /= [[44, 5, 44, 5, 44], [5, 5, 5, 5, 5],& + [5, 5, 5, 5, 5], [44, 5, 44, 5, 44], [5, 5, 5, 5, 5]])) call abort() + + if (any (reshape (x_tan%i, [25]) /= [[45, 6, 45, 6, 45], [6, 6, 6, 6, 6],& + [6, 6, 6, 6, 6], [45, 6, 45, 6, 45], [6, 6, 6, 6, 6]])) call abort() + + if (any (reshape (x_tge%i, [25]) /= [[46, 7, 46, 7, 46], [7, 7, 7, 7, 7],& + [7, 7, 7, 7, 7], [46, 7, 46, 7, 46], [7, 7, 7, 7, 7]])) call abort() + + if (any (reshape (x_tgn%i, [25]) /= [[47, 8, 47, 8, 47], [8, 8, 8, 8, 8],& + [8, 8, 8, 8, 8], [47, 8, 47, 8, 47], [8, 8, 8, 8, 8]])) call abort() +end program finalize_29 --MP_/rQS.DZ4y5A68vmX5eExNh.v Content-Type: text/x-patch Content-Transfer-Encoding: 7bit Content-Disposition: attachment; filename=pr60322_full_delta_5_to_6.patch Content-length: 10203 diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index 0804d45..3803cf8 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -3165,7 +3165,7 @@ add_to_offset (tree *cst_offset, tree *offset, tree t) static tree -build_array_ref (tree desc, tree offset, tree decl) +build_array_ref (tree desc, tree offset, tree decl, tree vptr) { tree tmp; tree type; @@ -3212,7 +3212,7 @@ build_array_ref (tree desc, tree offset, tree decl) tmp = gfc_conv_array_data (desc); tmp = build_fold_indirect_ref_loc (input_location, tmp); - tmp = gfc_build_array_ref (tmp, offset, decl); + tmp = gfc_build_array_ref (tmp, offset, decl, vptr); return tmp; } @@ -3375,7 +3375,8 @@ gfc_conv_array_ref (gfc_se * se, gfc_array_ref * ar, gfc_expr *expr, offset = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, offset, cst_offset); - se->expr = build_array_ref (se->expr, offset, sym->backend_decl); + se->expr = build_array_ref (se->expr, offset, sym->ts.type == BT_CLASS ? + NULL_TREE : sym->backend_decl, se->class_vptr); } @@ -6270,7 +6271,7 @@ gfc_get_dataptr_offset (stmtblock_t *block, tree parm, tree desc, tree offset, return; } - tmp = build_array_ref (desc, offset, NULL); + tmp = build_array_ref (desc, offset, NULL, NULL); /* Offset the data pointer for pointer assignments from arrays with subreferences; e.g. my_integer => my_type(:)%integer_component. */ @@ -7029,6 +7030,8 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr) pointer/allocatable or associated. */ if (onebased && se->use_offset && expr->symtree + && !(expr->symtree->n.sym && expr->symtree->n.sym->ts.type == BT_CLASS + && !CLASS_DATA (expr->symtree->n.sym)->attr.class_pointer) && !expr->symtree->n.sym->attr.allocatable && !expr->symtree->n.sym->attr.pointer && !expr->symtree->n.sym->attr.host_assoc diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c index 895733b..4c18920 100644 --- a/gcc/fortran/trans-decl.c +++ b/gcc/fortran/trans-decl.c @@ -1031,9 +1031,9 @@ gfc_build_dummy_array_decl (gfc_symbol * sym, tree dummy) array_attr = is_classarray ? &CLASS_DATA (sym)->attr : &sym->attr; /* The dummy is returned for pointer, allocatable or assumed rank arrays. - The check for pointerness needs to be repeated here (it is done in - IS_CLASS_ARRAY (), too), because for class arrays that are pointers, as - is the one of the sym, which is incorrect here. */ + For class arrays the information if sym is an allocatable or pointer + object needs to be checked explicitly (IS_CLASS_ARRAY can be false for + too many reasons to be of use here). */ if ((sym->ts.type != BT_CLASS && sym->attr.pointer) || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)->attr.class_pointer) || array_attr->allocatable diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index 790d537..81b72273 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -2273,6 +2273,16 @@ gfc_conv_component_ref (gfc_se * se, gfc_ref * ref) field = f2; } + if (ref->u.c.sym && ref->u.c.sym->ts.type == BT_CLASS + && strcmp ("_data", c->name) == 0) + { + /* Found a ref to the _data component. Store the associated ref to + the vptr in se->class_vptr. */ + se->class_vptr = gfc_class_vptr_get (decl); + } + else + se->class_vptr = NULL_TREE; + tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field), decl, field, NULL_TREE); diff --git a/gcc/fortran/trans.c b/gcc/fortran/trans.c index 394745e..6da464a 100644 --- a/gcc/fortran/trans.c +++ b/gcc/fortran/trans.c @@ -321,7 +321,7 @@ gfc_build_addr_expr (tree type, tree t) /* Build an ARRAY_REF with its natural type. */ tree -gfc_build_array_ref (tree base, tree offset, tree decl) +gfc_build_array_ref (tree base, tree offset, tree decl, tree vptr) { tree type = TREE_TYPE (base); tree tmp; @@ -353,37 +353,47 @@ gfc_build_array_ref (tree base, tree offset, tree decl) /* If the array reference is to a pointer, whose target contains a subreference, use the span that is stored with the backend decl and reference the element with pointer arithmetic. */ - if (decl && (TREE_CODE (decl) == FIELD_DECL - || TREE_CODE (decl) == VAR_DECL - || TREE_CODE (decl) == PARM_DECL) - && ((GFC_DECL_SUBREF_ARRAY_P (decl) - && !integer_zerop (GFC_DECL_SPAN(decl))) + if ((decl && (TREE_CODE (decl) == FIELD_DECL + || TREE_CODE (decl) == VAR_DECL + || TREE_CODE (decl) == PARM_DECL) + && ((GFC_DECL_SUBREF_ARRAY_P (decl) + && !integer_zerop (GFC_DECL_SPAN (decl))) || GFC_DECL_CLASS (decl))) + || vptr) { - if (GFC_DECL_CLASS (decl)) + if (decl) { - /* When a temporary is in place for the class array, then the original - class' declaration is stored in the saved descriptor. */ - if (DECL_LANG_SPECIFIC (decl) && GFC_DECL_SAVED_DESCRIPTOR (decl)) - decl = GFC_DECL_SAVED_DESCRIPTOR (decl); - else + if (GFC_DECL_CLASS (decl)) { - /* Allow for dummy arguments and other good things. */ - if (POINTER_TYPE_P (TREE_TYPE (decl))) - decl = build_fold_indirect_ref_loc (input_location, decl); - - /* Check if '_data' is an array descriptor. If it is not, - the array must be one of the components of the class object, - so return a normal array reference. */ - if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (gfc_class_data_get (decl)))) - return build4_loc (input_location, ARRAY_REF, type, base, - offset, NULL_TREE, NULL_TREE); + /* When a temporary is in place for the class array, then the + original class' declaration is stored in the saved + descriptor. */ + if (DECL_LANG_SPECIFIC (decl) && GFC_DECL_SAVED_DESCRIPTOR (decl)) + decl = GFC_DECL_SAVED_DESCRIPTOR (decl); + else + { + /* Allow for dummy arguments and other good things. */ + if (POINTER_TYPE_P (TREE_TYPE (decl))) + decl = build_fold_indirect_ref_loc (input_location, decl); + + /* Check if '_data' is an array descriptor. If it is not, + the array must be one of the components of the class + object, so return a normal array reference. */ + if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE ( + gfc_class_data_get (decl)))) + return build4_loc (input_location, ARRAY_REF, type, base, + offset, NULL_TREE, NULL_TREE); + } + + span = gfc_class_vtab_size_get (decl); } - - span = gfc_class_vtab_size_get (decl); + else if (GFC_DECL_SUBREF_ARRAY_P (decl)) + span = GFC_DECL_SPAN (decl); + else + gcc_unreachable (); } - else if (GFC_DECL_SUBREF_ARRAY_P (decl)) - span = GFC_DECL_SPAN(decl); + else if (vptr) + span = gfc_vptr_size_get (vptr); else gcc_unreachable (); diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h index 1998358..e2a1fea 100644 --- a/gcc/fortran/trans.h +++ b/gcc/fortran/trans.h @@ -49,6 +49,10 @@ typedef struct gfc_se /* The length of a character string value. */ tree string_length; + /* When expr is a reference to a class object, store its vptr access + here. */ + tree class_vptr; + /* If set gfc_conv_variable will return an expression for the array descriptor. When set, want_pointer should also be set. If not set scalarizing variables will be substituted. */ @@ -528,7 +532,7 @@ tree gfc_get_function_decl (gfc_symbol *); tree gfc_build_addr_expr (tree, tree); /* Build an ARRAY_REF. */ -tree gfc_build_array_ref (tree, tree, tree); +tree gfc_build_array_ref (tree, tree, tree, tree vptr = NULL_TREE); /* Creates a label. Decl is artificial if label_id == NULL_TREE. */ tree gfc_build_label_decl (tree); diff --git a/gcc/testsuite/gfortran.dg/class_array_21.f03 b/gcc/testsuite/gfortran.dg/class_array_21.f03 new file mode 100644 index 0000000..1e89d38 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/class_array_21.f03 @@ -0,0 +1,97 @@ +! {dg-do run} +! +! Contributed by Andre Vehreschild +! Check more elaborate class array addressing. + +module m1 + + type InnerBaseT + integer, allocatable :: a(:) + end type InnerBaseT + + type, extends(InnerBaseT) :: InnerT + integer :: i + end type InnerT + + type BaseT + class(InnerT), allocatable :: arr(:,:) + contains + procedure P + end type BaseT + +contains + + subroutine indir(this, mat) + class(BaseT) :: this + class(InnerT), intent(inout) :: mat(:,:) + + call this%P(mat) + end subroutine indir + + subroutine P(this, mat) + class(BaseT) :: this + class(InnerT), intent(inout) :: mat(:,:) + integer :: i,j + + mat%i = 42 + do i= 1, ubound(mat, 1) + do j= 1, ubound(mat, 2) + if (.not. allocated(mat(i,j)%a)) then + allocate(mat(i,j)%a(10), source = 72) + end if + end do + end do + mat(1,1)%i = 9 + mat(1,1)%a(5) = 1 + end subroutine + +end module m1 + +program test + use m1 + + class(BaseT), allocatable, target :: o + class(InnerT), pointer :: i_p(:,:) + class(InnerBaseT), allocatable :: i_a(:,:) + integer i,j,l + + allocate(o) + allocate(o%arr(2,2)) + allocate(InnerT::i_a(2,2)) + o%arr%i = 1 + + i_p => o%arr + call o%P(i_p) + if (any(o%arr%i /= reshape([9,42,42,42],[2,2]))) call abort() + do l= 1, 10 + do i= 1, 2 + do j= 1,2 + if ((i == 1 .and. j == 1 .and. l == 5 .and. & + o%arr(i,j)%a(5) /= 1) & + .or. (.not. (i == 1 .and. j == 1 .and. l == 5) & + .and. o%arr(i,j)%a(l) /= 72)) call abort() + end do + end do + end do + + select type (i_a) + type is (InnerT) + call o%P(i_a) + do l= 1, 10 + do i= 1, 2 + do j= 1,2 + if ((i == 1 .and. j == 1 .and. l == 5 .and. & + i_a(i,j)%a(5) /= 1) & + .or. (.not. (i == 1 .and. j == 1 .and. l == 5) & + .and. i_a(i,j)%a(l) /= 72)) call abort() + end do + end do + end do + end select + + i_p%i = 4 + call indir(o, i_p) + if (any(o%arr%i /= reshape([9,42,42,42],[2,2]))) call abort() +end program test + +! vim:ts=2:sts=2:cindent:sw=2:tw=80: --MP_/rQS.DZ4y5A68vmX5eExNh.v--