From: Andre Vehreschild <vehre@gmx.de>
To: Paul Richard Thomas <paul.richard.thomas@gmail.com>
Cc: Mikael Morin <mikael.morin@sfr.fr>,
GCC-Fortran-ML <fortran@gcc.gnu.org>,
GCC-Patches-ML <gcc-patches@gcc.gnu.org>,
Antony Lewis <antony@cosmologist.info>,
Dominique Dhumieres <dominiq@lps.ens.fr>
Subject: Re: [Patch, Fortran, pr60322, addendum] was: [Patch 1/2, Fortran, pr60322] [OOP] Incorrect bounds on polymorphic dummy array
Date: Tue, 14 Apr 2015 17:01:00 -0000 [thread overview]
Message-ID: <20150414190054.473a9bbb@gmx.de> (raw)
In-Reply-To: <20150409143709.6d33aa8c@vepi2>
[-- Attachment #1: Type: text/plain, Size: 15798 bytes --]
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
[-- Attachment #2: pr60322_full_6.clog --]
[-- Type: application/octet-stream, Size: 3049 bytes --]
gcc/testsuite/ChangeLog:
2015-04-14 Andre Vehreschild <vehre@gmx.de>
* 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_10.f90: Corrected scan-trees.
* gfortran.dg/finalize_15.f90: Fixing comparision to model
initialization correctly.
* gfortran.dg/finalize_29.f08: New test.
gcc/fortran/ChangeLog:
2015-04-14 Andre Vehreschild <vehre@gmx.de>
PR fortran/60322
* expr.c (gfc_lval_expr_from_sym): Code to select the regular
or class array added.
* gfortran.h: Add IS_CLASS_ARRAY macro.
* trans-array.c (gfc_add_loop_ss_code): Treat class objects
to be referenced always.
(build_class_array_ref): Adapt retrieval of array descriptor.
(build_array_ref): Likewise.
(gfc_conv_array_ref): Hand the vptr or the descriptor to
build_array_ref depending whether the sym is class or not.
(gfc_trans_array_cobounds): Select correct gfc_array_spec for
regular and class arrays.
(gfc_trans_array_bounds): Likewise.
(gfc_trans_dummy_array_bias): Likewise.
(gfc_get_dataptr_offset): Correcting call of build_array_ref.
(gfc_conv_expr_descriptor): Set the array's offset to -1 when
lbound in inner most dim is 1 and symbol non-pointer/assoc.
* trans-decl.c (gfc_build_qualified_array): Select correct
gfc_array_spec for regular and class arrays.
(gfc_build_dummy_array_decl): Likewise.
(gfc_get_symbol_decl): Get a dummy array for class arrays.
(gfc_trans_deferred_vars): Tell conv_expr that the descriptor
is desired.
* trans-expr.c (gfc_class_vptr_get): Get the class descriptor
from the correct location for class arrays.
(gfc_class_len_get): Likewise.
(gfc_conv_intrinsic_to_class): Add handling of _len component.
(gfc_conv_class_to_class): Prevent access to unset array data
when the array is an optional argument. Add handling of _len
component.
(gfc_copy_class_to_class): Check that _def_init is non-NULL
when used in _vptr->copy()
(gfc_trans_class_init_assign): Ensure that the rank of
_def_init is zero.
(gfc_conv_component_ref): Get the _vptr along with _data refs.
(gfc_conv_variable): Make sure the temp array descriptor is
returned for class arrays, too, and that class arrays are
dereferenced correctly.
(gfc_conv_procedure_call): For polymorphic type initialization
the initializer has to be a pointer to _def_init stored in a
dummy variable, which then needs to be used by value.
* trans-intrinsic.c (gfc_conv_intrinsic_sizeof): Use the
temporary array descriptor for class arrays, too.
(gfc_conv_intrinsic_storage_size): Likewise.
(gfc_conv_intrinsic_loc): Add ref to _data for BT_CLASS
expressions.
* trans-stmt.c (trans_associate_var): Use a temporary array for
the associate variable of class arrays, too, making the array
one-based (lbound == 1).
* trans-types.c (gfc_is_nodesc_array): Use the correct
array data.
* trans.c (gfc_build_array_ref): Use the dummy array descriptor
when present.
* trans.h: Add class_vptr to gfc_se for storing a class ref's
vptr.
[-- Attachment #3: pr60322_full_6.patch --]
[-- Type: text/x-patch, Size: 63647 bytes --]
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 <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
+
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 <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
[-- Attachment #4: pr60322_full_delta_5_to_6.patch --]
[-- Type: text/x-patch, Size: 10203 bytes --]
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:
next prev parent reply other threads:[~2015-04-14 17:01 UTC|newest]
Thread overview: 18+ messages / expand[flat|nested] mbox.gz Atom feed top
2015-02-26 17:19 Andre Vehreschild
2015-03-23 12:29 ` Mikael Morin
2015-03-23 12:44 ` Andre Vehreschild
2015-03-23 14:58 ` Mikael Morin
2015-03-23 15:49 ` Andre Vehreschild
2015-03-23 19:28 ` Mikael Morin
2015-03-24 10:13 ` Paul Richard Thomas
2015-03-24 17:06 ` [Patch, Fortran, pr60322] was: " Andre Vehreschild
2015-03-25 9:43 ` Dominique d'Humières
2015-03-25 16:57 ` Andre Vehreschild
2015-03-26 9:27 ` Dominique d'Humières
2015-03-27 12:48 ` Paul Richard Thomas
2015-04-05 9:13 ` Paul Richard Thomas
2015-04-09 12:37 ` Andre Vehreschild
2015-04-14 17:01 ` Andre Vehreschild [this message]
2015-04-16 19:13 ` [Patch, Fortran, pr60322, addendum] " Paul Richard Thomas
2015-04-23 11:34 ` [commited, Patch, " Andre Vehreschild
2015-04-27 17:43 ` Andre Vehreschild
Reply instructions:
You may reply publicly to this message via plain-text email
using any one of the following methods:
* Save the following mbox file, import it into your mail client,
and reply-to-all from there: mbox
Avoid top-posting and favor interleaved quoting:
https://en.wikipedia.org/wiki/Posting_style#Interleaved_style
* Reply using the --to, --cc, and --in-reply-to
switches of git-send-email(1):
git send-email \
--in-reply-to=20150414190054.473a9bbb@gmx.de \
--to=vehre@gmx.de \
--cc=antony@cosmologist.info \
--cc=dominiq@lps.ens.fr \
--cc=fortran@gcc.gnu.org \
--cc=gcc-patches@gcc.gnu.org \
--cc=mikael.morin@sfr.fr \
--cc=paul.richard.thomas@gmail.com \
/path/to/YOUR_REPLY
https://kernel.org/pub/software/scm/git/docs/git-send-email.html
* If your mail client supports setting the In-Reply-To header
via mailto: links, try the mailto: link
Be sure your reply has a Subject: header at the top and a blank line
before the message body.
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).