This is the mail archive of the
gcc-patches@gcc.gnu.org
mailing list for the GCC project.
Re: [commited, Patch, Fortran, pr60322, addendum] was: [Patch 1/2, Fortran, pr60322] [OOP] Incorrect bounds on polymorphic dummy array
- From: Andre Vehreschild <vehre at gmx dot de>
- To: Paul Richard Thomas <paul dot richard dot thomas at gmail dot com>
- Cc: Mikael Morin <mikael dot morin at sfr dot fr>, GCC-Fortran-ML <fortran at gcc dot gnu dot org>, GCC-Patches-ML <gcc-patches at gcc dot gnu dot org>, Antony Lewis <antony at cosmologist dot info>, Dominique Dhumieres <dominiq at lps dot ens dot fr>
- Date: Mon, 27 Apr 2015 19:43:20 +0200
- Subject: Re: [commited, Patch, Fortran, pr60322, addendum] was: [Patch 1/2, Fortran, pr60322] [OOP] Incorrect bounds on polymorphic dummy array
- Authentication-results: sourceware.org; auth=none
- References: <20150226181717 dot 480e282c at vepi2> <551006FF dot 1080704 at sfr dot fr> <20150323134357 dot 6af740d1 at vepi2> <CAGkQGiK2sp2wqXLMPvg8bc=vgJyr9jryukvwML9Jc9+yt_9odA at mail dot gmail dot com> <20150324180620 dot 3c72960e at vepi2> <CAGkQGiL+rYEdDzw8RFEr4Abyu6HQV78x8XFCu5-xViMvZrmfFg at mail dot gmail dot com> <CAGkQGiJUxuz-8rYiyOrJ=n3p1gaLrGFE-N8M5mAYukY9VLR_AA at mail dot gmail dot com> <20150409143709 dot 6d33aa8c at vepi2> <20150414190054 dot 473a9bbb at gmx dot de> <CAGkQGiLfO=b6s-xBm-1Ns=T1gHng5hoa4XoiYCAQN-epcshW7g at mail dot gmail dot com> <20150423133416 dot 12210ec4 at gmx dot de>
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 <vehre@gmx.de> wrote:
> Hi Paul, hi all,
>
> Paul, thanks for the review. I have commited this as r222361.
>
> Regards,
> Andre
>
> On Thu, 16 Apr 2015 21:13:31 +0200
> Paul Richard Thomas <paul.richard.thomas@gmail.com> wrote:
>
> > Hi Andre,
> >
> > The delta patch is OK for trunk and eventual backport to 5.2.
> >
> > Thanks for all the hard work
> >
> > Paul
> >
> > On 14 April 2015 at 19:00, Andre Vehreschild <vehre@gmx.de> 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 propose
> > > 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 == 1)
> > > was dereferenced, which lead to an ICE (the patch for this in the delta 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) = 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 then
> > > 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 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?
> > > 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 <vehre@gmx.de> wrote:
> > >
> > >> Hi Paul, hi all,
> > >>
> > >> Paul, thanks for the review. Answers to your questions are inline below:
> > >>
> > >> On Sun, 5 Apr 2015 11:13:05 +0200
> > >> Paul Richard Thomas <paul.richard.thomas@gmail.com> wrote:
> > >> <snip>
> > >> > + /* 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. */
> > >> >
> > >> > What does this mean, please?
> > >>
> > >> The first sentence is about regular arrays and should be unchanged from
> > >> 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 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). */
> > >>
> > >> > + /* 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;
> > >> > + }
> > >> >
> > >> > 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 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 :-)
> > >>
> > >> 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_attr and one with the new code. Albeit I failed to get the
> > >> brain-dead part right and made some mistakes there already, which Mikael
> > >> 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 parts
> > >> more explicitly, like
> > >>
> > >> "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."
> > >>
> > >> (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
> > >> > <paul.richard.thomas@gmail.com> 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 <vehre@gmx.de> 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 would love to see a test similar to that download, but
> > >> > >> couldn't come up with 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 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 <paul.richard.thomas@gmail.com> 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 <vehre@gmx.de> 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
> > >> > >>> > attached.
> > >> > >>> >
> > >> > >>> >> 26/02/2015 18:17, Andre Vehreschild a Ãcrit :
> > >> > >>> >> > 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 = 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 = 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);
> > >> > >>> >>
> > >> > >>> >> This is a change of semantics. Or do you know that
> > >> > >>> >> sym->ts.type != 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 this,
> > >> > >>> > by setting the variable as depending on whether type == 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 == AS_ASSUMED_RANK))
> > >> > >>> >> > + /* Use the array as and attr. */
> > >> > >>> >> > + as = sym->as;
> > >> > >>> >> > + array_attr = &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 == 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
> > >> > >>> > sometimes 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 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 relevant
> > >> > >>> > here. Any idea how to formulate the comment better, to reflect
> > >> > >>> > what I just explained?
> > >> > >>> >
> > >> > >>> > Regards,
> > >> > >>> > Andre
> > >> > >>> > --
> > >> > >>> > Andre Vehreschild * Email: vehre ad gmx dot de
> > >> > >>> >
> > >> > >>> >
> > >> > >>> > ---------- Forwarded message ----------
> > >> > >>> > From: Paul Richard Thomas <paul.richard.thomas@gmail.com>
> > >> > >>> > To: Andre Vehreschild <vehre@gmx.de>, Dominique Dhumieres
> > >> > >>> > <dominiq@lps.ens.fr> 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 attached.
> > >> > >>> >
> > >> > >>> > Note that the scalar allocate fails with MOLD= and so I
> > >> > >>> > substituted SOURCE=.
> > >> > >>> >
> > >> > >>> > Cheers
> > >> > >>> >
> > >> > >>> > Paul
> > >> > >>> >
> > >> > >>> > class(*), allocatable :: a(:), e ! Change 'e' to an array and
> > >> > >>> > second memcpy works correctly
> > >> > >>> > ! Problem is with loc(e),
> > >> > >>> > which returns the address of the
> > >> > >>> > ! class container.
> > >> > >>> > allocate (e, source = 99.0)
> > >> > >>> > allocate (a(2), source = [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="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),source=e) ! mold gives a segfault
> > >> > >>> > 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
> > >> > >>> >
> > >> > >>>
> > >> > >>>
> > >> > >>>
> > >> > >>
> > >> > >>
> > >> > >> --
> > >> > >> 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
> >
> >
> >
>
>
--
Andre Vehreschild * Email: vehre ad gmx dot de
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 <vladimir.fuka@gmail.com>
+
+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 <vehre@gcc.gnu.org>
+
+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 <vehre@gmx.de>
+ 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 <vehre@gmx.de>
+
PR fortran/59678
PR fortran/65841
* gfortran.dg/alloc_comp_deep_copy_1.f03: New test.
- References:
- Re: [Patch, Fortran, pr60322] was: [Patch 1/2, Fortran, pr60322] [OOP] Incorrect bounds on polymorphic dummy array
- From: Paul Richard Thomas
- Re: [Patch, Fortran, pr60322] was: [Patch 1/2, Fortran, pr60322] [OOP] Incorrect bounds on polymorphic dummy array
- Re: [Patch, Fortran, pr60322, addendum] was: [Patch 1/2, Fortran, pr60322] [OOP] Incorrect bounds on polymorphic dummy array
- Re: [Patch, Fortran, pr60322, addendum] was: [Patch 1/2, Fortran, pr60322] [OOP] Incorrect bounds on polymorphic dummy array
- From: Paul Richard Thomas
- Re: [commited, Patch, Fortran, pr60322, addendum] was: [Patch 1/2, Fortran, pr60322] [OOP] Incorrect bounds on polymorphic dummy array