From mboxrd@z Thu Jan 1 00:00:00 1970 Return-Path: Received: (qmail 121226 invoked by alias); 27 Apr 2015 17:43:34 -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 121184 invoked by uid 89); 27 Apr 2015 17:43:33 -0000 Authentication-Results: sourceware.org; auth=none X-Virus-Found: No X-Spam-SWARE-Status: No, score=0.1 required=5.0 tests=AWL,BAYES_50,FREEMAIL_FROM,KAM_ASCII_DIVIDERS,RCVD_IN_DNSWL_NONE,SPF_PASS autolearn=no version=3.3.2 X-Spam-User: qpsmtpd, 2 recipients X-HELO: mout.gmx.net Received: from mout.gmx.net (HELO mout.gmx.net) (212.227.15.19) by sourceware.org (qpsmtpd/0.93/v0.84-503-g423c35a) with (AES256-GCM-SHA384 encrypted) ESMTPS; Mon, 27 Apr 2015 17:43:29 +0000 Received: from localhost ([88.75.104.20]) by mail.gmx.com (mrgmx002) with ESMTPSA (Nemesis) id 0MGSDw-1YZXVR3rMW-00DJOG; Mon, 27 Apr 2015 19:43:22 +0200 Date: Mon, 27 Apr 2015 17:43:00 -0000 From: Andre Vehreschild To: Paul Richard Thomas Cc: Mikael Morin , GCC-Fortran-ML , GCC-Patches-ML , Antony Lewis , Dominique Dhumieres Subject: Re: [commited, Patch, Fortran, pr60322, addendum] was: [Patch 1/2, Fortran, pr60322] [OOP] Incorrect bounds on polymorphic dummy array Message-ID: <20150427194320.3e285e83@gmx.de> In-Reply-To: <20150423133416.12210ec4@gmx.de> References: <20150226181717.480e282c@vepi2> <551006FF.1080704@sfr.fr> <20150323134357.6af740d1@vepi2> <20150324180620.3c72960e@vepi2> <20150409143709.6d33aa8c@vepi2> <20150414190054.473a9bbb@gmx.de> <20150423133416.12210ec4@gmx.de> MIME-Version: 1.0 Content-Type: multipart/mixed; boundary="MP_/vl26jQYDVNTc_gn4b_6ecP9" X-UI-Out-Filterresults: notjunk:1; X-SW-Source: 2015-04/txt/msg01665.txt.bz2 --MP_/vl26jQYDVNTc_gn4b_6ecP9 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: quoted-printable Content-Disposition: inline Content-length: 18455 Hi all, sorry, I forgot to svn-add the testcases for the patch of pr60322. I fixed = this with commit r222478. My apologies for the oversight. Regards, Andre On Thu, 23 Apr 2015 13:34:16 +0200 Andre Vehreschild wrote: > Hi Paul, hi all, >=20 > Paul, thanks for the review. I have commited this as r222361. >=20 > Regards, > Andre >=20 > On Thu, 16 Apr 2015 21:13:31 +0200 > Paul Richard Thomas wrote: >=20 > > Hi Andre, > >=20 > > The delta patch is OK for trunk and eventual backport to 5.2. > >=20 > > Thanks for all the hard work > >=20 > > Paul > >=20 > > On 14 April 2015 at 19:00, Andre Vehreschild wrote: > > > 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 prop= ose > > > an extended patch for pr60322. Because Paul has already reviewed most= the > > > extended 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. > > > > > > With the second patch I hope to get a faster review, because it is > > > significantly shorter. > > > > > > 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 del= ta is > > > chunk 5 in gfc_conv_expr_descriptor, and > > > > > > ii. (and this was a severe brain cracker) in chains of references > > > consisting of more then one class-(array)-ref always the _vptr of the > > > first symbol was taken 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 > > > > > > 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 th= en > > > used in array-refs (chunk 2 of trans.c) to get the size of the array > > > elements of the correct level. > > > > > > The other chunks of the delta patch are: > > > - parameter passing fixes, and > > > - documentation fixes as requested for the version 5 of the pr60322 p= atch. > > > > > > 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? > > > 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, > > >> > > >> Paul, thanks for the review. Answers to your questions are inline be= low: > > >> > > >> On Sun, 5 Apr 2015 11:13:05 +0200 > > >> Paul Richard Thomas wrote: > > >> > > >> > + /* The dummy is returned for pointer, allocatable or assumed ra= nk > > >> > arrays. > > >> > + The check for pointerness needs to be repeated here (it is d= one > > >> > in > > >> > + IS_CLASS_ARRAY (), too), because for class arrays that are > > >> > pointers, as > > >> > + is the one of the sym, which is incorrect here. */ > > >> > > > >> > What does this mean, please? > > >> > > >> The first sentence is about regular arrays and should be unchanged f= rom > > >> the original source. Then I have to check for class (arrays) that are > > >> pointers, i.e., independent of whether the sym is a class array or a > > >> regular pointer 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: > > >> > > >> /* The dummy is returned for pointer, allocatable or assumed rank ar= rays. > > >> For class arrays the information if sym is an allocatable or poin= ter > > >> object needs to be checked explicitly (IS_CLASS_ARRAY can be fals= e for > > >> too many reasons to be of use here). */ > > >> > > >> > + /* Returning the descriptor for dummy class arrays is hazar= dous, > > >> > 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 =3D 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 !=3D NULL && decl !=3D sym->backend_d= ecl) > > >> > + DECL_ARTIFICIAL (sym->backend_decl) =3D 1; > > >> > + sym->backend_decl =3D decl; > > >> > + } > > >> > > > >> > 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. > > >> > > >> Er, the document at > > >> > > >> https://gcc.gnu.org/codingconventions.html#C_Formatting > > >> > > >> says that line length is 80, or is there another convention, that I = am > > >> not aware of? > > >> > > >> > In trans-stmt.c s/standart/standard/ > > >> > > >> Fixed. > > >> > > >> > Don't forget to put the PR numbers in the ChangeLogs. > > >> > > >> I won't anymore, already got told off :-) > > >> > > >> > For this submission, I would have appreciated some a description of > > >> > what each chunk in the patch is doing, just because there is so mu= ch > > >> > of it. I suppose that it was good for my imortal soul to sort it o= ut > > >> > for myself but it took a little while :-) > > >> > > >> I initially tried to split the submission in two parts to make it mo= re > > >> manageable. One part with the brain-dead substitutions of as and > > >> array_attr and one with the new code. Albeit I failed to get the > > >> brain-dead part right and made some mistakes there already, which Mi= kael > > >> pointed out. I therefore went for the big submission. > > >> > > >> Now doing a description of what each "chunk" does is quite tedious. I > > >> really would like to spend my time more productive. Would you be > > >> satisfied, when I write a story about the patch, referring to some p= arts > > >> more explicitly, like > > >> > > >> "Chunk 4 of file trans-stmt.c is the heart of the patch and does thi= s and > > >> that. The remaining chunks are more or less putting the data togethe= r." > > >> > > >> (This is not correct for this patch of course. Just an example.) More > > >> elaborate of course, but just to give an idea. > > >> > > >> Thanks again. I will commit as soon as 5.2/6.0 commit window is open. > > >> > > >> Regards, > > >> Andre > > >> > > >> > > > >> > Cheers and many thanks for the patch. > > >> > > > >> > Paul > > >> > > > >> > 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 touch= es > > >> > > 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 wrot= e: > > >> > >> 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 o= ne, > > >> > >> because keeping both in sync was no benefit but only tedious an= d did > > >> > >> not prove to be reviewed faster. > > >> > >> > > >> > >> Paul, Dominique: I have addressed the LOC issue that came up la= tely. > > >> > >> Or rather the patch addressed it already. I feel like this is n= ot > > >> > >> tested very well, not the loc() call nor the sizeof() call as g= iven > > >> > >> in the 57305 second's download. Unfortunately, is that download= not > > >> > >> runable. I would love to see a test similar to that download, b= ut > > >> > >> couldn't come up with one, that satisfied me. Given that the pa= tch's > > >> > >> review will last some days, I still have enough time to come up= with > > >> > >> something beautiful which 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 class container in some places and the address of the data= in > > >> > >>> others. I will put my thinking cap on tonight :-) > > >> > >>> > > >> > >>> Cheers > > >> > >>> > > >> > >>> Paul > > >> > >>> > > >> > >>> On 23 March 2015 at 13:43, Andre Vehreschild wr= ote: > > >> > >>> > Hi Mikael, > > >> > >>> > > > >> > >>> > thanks for looking at the patch. Please note, that Paul has = sent > > >> > >>> > an addendum to the patches for 60322, which I deliberately h= ave > > >> > >>> > attached. > > >> > >>> > > > >> > >>> >> 26/02/2015 18:17, Andre Vehreschild a =C3=A9crit : > > >> > >>> >> > This first patch is only preparatory and does not change = any > > >> > >>> >> > of 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 > > >> > >>> >> > *sym) lval->symtree =3D gfc_find_symtree (sym->ns->sym_ro= ot, > > >> > >>> >> > 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= _CLASS ? > > >> > >>> >> > - 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 > > >> > >>> > tell the truth, I never ran a regtest with only part 1 of the > > >> > >>> > patches applied. The second part of the patch will correct t= his, > > >> > >>> > by setting 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_RAN= K)) > > >> > >>> >> > + /* 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, t= here > > >> > >>> >> is the class_pointer attribute (and it is a pain, I know). > > >> > >>> > > > >> > >>> > Yes, and a good one. Array_attr is sometimes sym->attr and > > >> > >>> > sometimes CLASS_DATA(sym)->attr aka > > >> > >>> > sym->ts.u.derived->components->attr. In the later case .poin= ter > > >> > >>> > is always set to 1 in the _data component's attr. I.e., the > > >> > >>> > above if, would always yield true for a class_array, which is > > >> > >>> > not intended, but rather destructive. I know about the > > >> > >>> > class_pointer attribute, but I figured, that it is not relev= ant > > >> > >>> > here. Any idea how to formulate the comment better, to refle= ct > > >> > >>> > what I just 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 > > >> > >>> > container rather than the _data component for class scalars.= See > > >> > >>> > the source below, which you will recognise! A fix is attache= d. > > >> > >>> > > > >> > >>> > Note that the scalar allocate fails with MOLD=3D and so I > > >> > >>> > substituted SOURCE=3D. > > >> > >>> > > > >> > >>> > Cheers > > >> > >>> > > > >> > >>> > Paul > > >> > >>> > > > >> > >>> > class(*), allocatable :: a(:), e ! Change 'e' to an arra= y and > > >> > >>> > second memcpy works correctly > > >> > >>> > ! Problem is with loc(e= ), > > >> > >>> > which 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") > > >> > >>> > 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=3De) > > >> > >>> > else > > >> > >>> > allocate(tmp(size(a)),source=3Da) > > >> > >>> > deallocate(a) > > >> > >>> > allocate(a(size(tmp)+1),source=3De) ! mold gives a s= egfault > > >> > >>> > 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 > > >> > > > >> > > > >> > > > >> > > >> > > > > > > > > > -- > > > Andre Vehreschild * Email: vehre ad gmx dot de > >=20 > >=20 > >=20 >=20 >=20 --=20 Andre Vehreschild * Email: vehre ad gmx dot de=20 --MP_/vl26jQYDVNTc_gn4b_6ecP9 Content-Type: text/x-patch Content-Transfer-Encoding: 7bit Content-Disposition: attachment; filename=submit.diff Content-length: 16579 Index: gcc/testsuite/gfortran.dg/class_allocate_19.f03 =================================================================== --- gcc/testsuite/gfortran.dg/class_allocate_19.f03 (Revision 0) +++ gcc/testsuite/gfortran.dg/class_allocate_19.f03 (Revision 222478) @@ -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 + Index: gcc/testsuite/gfortran.dg/class_array_20.f03 =================================================================== --- gcc/testsuite/gfortran.dg/class_array_20.f03 (Revision 0) +++ gcc/testsuite/gfortran.dg/class_array_20.f03 (Revision 222478) @@ -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 + Index: gcc/testsuite/gfortran.dg/class_array_21.f03 =================================================================== --- gcc/testsuite/gfortran.dg/class_array_21.f03 (Revision 0) +++ gcc/testsuite/gfortran.dg/class_array_21.f03 (Revision 222478) @@ -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: Index: gcc/testsuite/gfortran.dg/finalize_29.f08 =================================================================== --- gcc/testsuite/gfortran.dg/finalize_29.f08 (Revision 0) +++ gcc/testsuite/gfortran.dg/finalize_29.f08 (Revision 222478) @@ -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 Index: gcc/testsuite/ChangeLog =================================================================== --- gcc/testsuite/ChangeLog (Revision 222477) +++ gcc/testsuite/ChangeLog (Arbeitskopie) @@ -1,5 +1,14 @@ 2015-04-27 Andre Vehreschild + PR fortran/60322 + Add tests forgotten to svn-add. + * gfortran.dg/class_allocate_19.f03: New test. + * gfortran.dg/class_array_20.f03: New test. + * gfortran.dg/class_array_21.f03: New test. + * gfortran.dg/finalize_29.f08: New test. + +2015-04-27 Andre Vehreschild + PR fortran/59678 PR fortran/65841 * gfortran.dg/alloc_comp_deep_copy_1.f03: New test. --MP_/vl26jQYDVNTc_gn4b_6ecP9--