* [Patch 1/2, Fortran, pr60322] [OOP] Incorrect bounds on polymorphic dummy array
@ 2015-02-26 17:19 Andre Vehreschild
2015-03-23 12:29 ` Mikael Morin
0 siblings, 1 reply; 18+ messages in thread
From: Andre Vehreschild @ 2015-02-26 17:19 UTC (permalink / raw)
To: GCC-Fortran-ML, GCC-Patches-ML, Antony Lewis
[-- Attachment #1: Type: text/plain, Size: 680 bytes --]
Hi all,
please find attached the first part of a two parts patch fixing pr/60322. This
first patch is only preparatory and does not change any of the semantics of
gfortran at all. It only modifies the compiler code to have the
symbol_attribute and the gfc_array_spec in a separate variable in the some
routines. The second part of the patch will then initialize these variables with
either the (sym.attr and sym.as) or (CLASS_DATA(sym).attr and
CLASS_DATA(sym).as), respectively, depending on whether the current symbol is
a regular array or a class array.
Bootstraps and regtests ok on x86_64-linux-gnu/F20.
Regards,
Andre
--
Andre Vehreschild * Email: vehre ad gmx dot de
[-- Attachment #2: pr60322_base_1.clog --]
[-- Type: application/octet-stream, Size: 413 bytes --]
gcc/fortran/ChangeLog:
2015-02-26 Andre Vehreschild <vehre@gmx.de>
* expr.c (gfc_lval_expr_from_sym): Added array_attr- and as-
pointer to address the class arrays and regular arrays.
* trans-array.c (gfc_trans_dummy_array_bias): Same.
* trans-decl.c (gfc_build_qualified_array): Same.
(gfc_build_dummy_array_decl): Same.
(gfc_trans_deferred_vars): Same.
* trans-types.c (gfc_is_nodesc_array): Same.
[-- Attachment #3: pr60322_base_1.patch --]
[-- Type: text/x-patch, Size: 11832 bytes --]
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
@@ -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 = 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/trans-array.c b/gcc/fortran/trans-array.c
index 642110d..0d4d7b2 100644
--- a/gcc/fortran/trans-array.c
+++ b/gcc/fortran/trans-array.c
@@ -5898,6 +5898,7 @@ gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc,
int checkparm;
int no_repack;
bool optional_arg;
+ gfc_array_spec *as;
/* Do nothing for pointer and allocatable arrays. */
if (sym->attr.pointer || sym->attr.allocatable)
@@ -5917,13 +5918,14 @@ gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc,
gcc_assert (GFC_ARRAY_TYPE_P (type));
dumdesc = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
dumdesc = build_fold_indirect_ref_loc (input_location, dumdesc);
+ 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)
@@ -5999,9 +6001,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]);
@@ -6017,7 +6019,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);
@@ -6025,13 +6027,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);
@@ -6084,7 +6086,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);
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
@@ -811,8 +811,12 @@ gfc_build_qualified_array (tree decl, gfc_symbol * sym)
int dim;
int nest;
gfc_namespace* procns;
+ symbol_attribute *array_attr;
+ gfc_array_spec *as;
type = TREE_TYPE (decl);
+ array_attr = &sym->attr;
+ as = sym->as;
/* We just use the descriptor, if there is one. */
if (GFC_DESCRIPTOR_TYPE_P (type))
@@ -823,8 +827,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;
@@ -877,8 +881,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;
@@ -919,7 +923,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;
@@ -946,12 +950,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);
@@ -965,7 +969,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);
@@ -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;
- /* 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);
@@ -1047,7 +1059,6 @@ gfc_build_dummy_array_decl (gfc_symbol * sym, tree dummy)
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,7 +1090,7 @@ gfc_build_dummy_array_decl (gfc_symbol * sym, tree dummy)
}
type = gfc_typenode_for_spec (&sym->ts);
- type = gfc_get_nodesc_array_type (type, sym->as, packed,
+ type = gfc_get_nodesc_array_type (type, as, packed,
!sym->attr.target);
}
else
@@ -1109,7 +1120,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;
@@ -3973,16 +3984,25 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block)
}
else if (sym->attr.dimension || sym->attr.codimension)
{
- /* 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)
+ symbol_attribute *array_attr;
+ gfc_array_spec *as;
+ array_type tmp;
+
+ array_attr = &sym->attr;
+ 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)
+ /* In a class array the _data component always has the pointer
+ attribute set. Therefore only check for allocatable in the
+ array attributes and for pointer in the symbol. */
+ else if (sym->attr.pointer || array_attr->allocatable)
{
if (TREE_STATIC (sym->backend_decl))
{
@@ -3997,7 +4017,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),
@@ -4036,7 +4057,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)
diff --git a/gcc/fortran/trans-types.c b/gcc/fortran/trans-types.c
index 53da053..bce4d24 100644
--- a/gcc/fortran/trans-types.c
+++ b/gcc/fortran/trans-types.c
@@ -1288,25 +1288,32 @@ 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;
+
+ array_attr = &sym->attr;
+ 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->attr.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;
}
^ permalink raw reply [flat|nested] 18+ messages in thread
* Re: [Patch 1/2, Fortran, pr60322] [OOP] Incorrect bounds on polymorphic dummy array
2015-02-26 17:19 [Patch 1/2, Fortran, pr60322] [OOP] Incorrect bounds on polymorphic dummy array Andre Vehreschild
@ 2015-03-23 12:29 ` Mikael Morin
2015-03-23 12:44 ` Andre Vehreschild
0 siblings, 1 reply; 18+ messages in thread
From: Mikael Morin @ 2015-03-23 12:29 UTC (permalink / raw)
To: Andre Vehreschild, GCC-Fortran-ML, GCC-Patches-ML, Antony Lewis
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?
> 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?
> 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).
Mikael
^ permalink raw reply [flat|nested] 18+ messages in thread
* Re: [Patch 1/2, Fortran, pr60322] [OOP] Incorrect bounds on polymorphic dummy array
2015-03-23 12:29 ` Mikael Morin
@ 2015-03-23 12:44 ` Andre Vehreschild
2015-03-23 14:58 ` Mikael Morin
2015-03-24 10:13 ` Paul Richard Thomas
0 siblings, 2 replies; 18+ messages in thread
From: Andre Vehreschild @ 2015-03-23 12:44 UTC (permalink / raw)
To: Mikael Morin; +Cc: GCC-Fortran-ML, GCC-Patches-ML, Antony Lewis
[-- Attachment #1: Type: text/plain, Size: 3148 bytes --]
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
[-- Attachment #2: Type: message/rfc822, Size: 6575 bytes --]
[-- Attachment #2.1.1: Type: text/plain, Size: 1632 bytes --]
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
[-- Attachment #2.1.2: loc_patch.diff --]
[-- Type: text/plain, Size: 1043 bytes --]
Index: gcc/fortran/trans-intrinsic.c
===================================================================
*** gcc/fortran/trans-intrinsic.c (revision 221500)
--- gcc/fortran/trans-intrinsic.c (working copy)
*************** gfc_conv_intrinsic_loc (gfc_se * se, gfc
*** 7080,7086 ****
arg_expr = expr->value.function.actual->expr;
if (arg_expr->rank == 0)
! 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);
--- 7080,7091 ----
arg_expr = expr->value.function.actual->expr;
if (arg_expr->rank == 0)
! {
! if (arg_expr->symtree->n.sym->ts.type == BT_CLASS
! && !CLASS_DATA (arg_expr->symtree->n.sym)->as)
! 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);
^ permalink raw reply [flat|nested] 18+ messages in thread
* Re: [Patch 1/2, Fortran, pr60322] [OOP] Incorrect bounds on polymorphic dummy array
2015-03-23 12:44 ` Andre Vehreschild
@ 2015-03-23 14:58 ` Mikael Morin
2015-03-23 15:49 ` Andre Vehreschild
2015-03-24 10:13 ` Paul Richard Thomas
1 sibling, 1 reply; 18+ messages in thread
From: Mikael Morin @ 2015-03-23 14:58 UTC (permalink / raw)
To: Andre Vehreschild; +Cc: GCC-Fortran-ML, GCC-Patches-ML, Antony Lewis
Le 23/03/2015 13:43, Andre Vehreschild a écrit :
> 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?
>
This pointer stuff is very difficult to swallow to me.
I understand that for classes, the CLASS_DATA (sym)->pointer is always
set, but almost everywhere the checks for pointerness are like
(sym->ts.type != BT_CLASS && sym->attr.pointer)
|| (sym->ts.type == BT_CLASS && CLASS_DATA (sym)->attr.class_pointer)
and I don't see a convincing reason to have it different here.
At least gfc_is_nodesc_array should return 0 if sym->ts.type == BT_CLASS
which solves the problem there; for the other cases, I think that
class_pointer should be looked at. gfc_build_class_symbol clears the
sym->attr.pointer flag for class containers so it doesn't make sense to
test that flag.
Mikael
^ permalink raw reply [flat|nested] 18+ messages in thread
* Re: [Patch 1/2, Fortran, pr60322] [OOP] Incorrect bounds on polymorphic dummy array
2015-03-23 14:58 ` Mikael Morin
@ 2015-03-23 15:49 ` Andre Vehreschild
2015-03-23 19:28 ` Mikael Morin
0 siblings, 1 reply; 18+ messages in thread
From: Andre Vehreschild @ 2015-03-23 15:49 UTC (permalink / raw)
To: Mikael Morin; +Cc: GCC-Fortran-ML, GCC-Patches-ML, Antony Lewis
Hi Mikael,
> This pointer stuff is very difficult to swallow to me.
I totally understand. When doing the patch I had to restart twice, because I
mixed up the development on the class arrays so completely, that I couldn't get
it right again.
> I understand that for classes, the CLASS_DATA (sym)->pointer is always
> set, but almost everywhere the checks for pointerness are like
> (sym->ts.type != BT_CLASS && sym->attr.pointer)
> || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)->attr.class_pointer)
> and I don't see a convincing reason to have it different here.
I see your point. Currently I am bootstraping and regtesting some patches for
commit. While this is running, my machine is nearly unusable. I will look into
this as soon, as my machine allows, but probably not before tomorrow.
> At least gfc_is_nodesc_array should return 0 if sym->ts.type == BT_CLASS
> which solves the problem there; for the other cases, I think that
> class_pointer should be looked at. gfc_build_class_symbol clears the
> sym->attr.pointer flag for class containers so it doesn't make sense to
> test that flag.
Completely right again. But I figured, that because sym->attr.pointer is never
set for BT_CLASS there is no harm to check it and furthermore no need to guard
it by checking whether ts.type == BT_CLASS. Fortunately not checking for
class_pointer in _data's attr, didn't throw any regressions. Thinking about it
now, I also think that it is probably safer to add the check for the
class_pointer attribute were attr.pointer is checked on the sym, having the
expression like you pointed out:
> (sym->ts.type != BT_CLASS && sym->attr.pointer)
> || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)->attr.class_pointer)
Regards,
Andre
--
Andre Vehreschild * Email: vehre ad gmx dot de
^ permalink raw reply [flat|nested] 18+ messages in thread
* Re: [Patch 1/2, Fortran, pr60322] [OOP] Incorrect bounds on polymorphic dummy array
2015-03-23 15:49 ` Andre Vehreschild
@ 2015-03-23 19:28 ` Mikael Morin
0 siblings, 0 replies; 18+ messages in thread
From: Mikael Morin @ 2015-03-23 19:28 UTC (permalink / raw)
To: Andre Vehreschild; +Cc: GCC-Fortran-ML, GCC-Patches-ML, Antony Lewis
Le 23/03/2015 16:49, Andre Vehreschild a écrit :
> I see your point. Currently I am bootstraping and regtesting some patches for
> commit. While this is running, my machine is nearly unusable. I will look into
> this as soon, as my machine allows, but probably not before tomorrow.
>
There is no hurry, the patch(es) will probably have to wait for next
stage 1.
^ permalink raw reply [flat|nested] 18+ messages in thread
* Re: [Patch 1/2, Fortran, pr60322] [OOP] Incorrect bounds on polymorphic dummy array
2015-03-23 12:44 ` Andre Vehreschild
2015-03-23 14:58 ` Mikael Morin
@ 2015-03-24 10:13 ` Paul Richard Thomas
2015-03-24 17:06 ` [Patch, Fortran, pr60322] was: " Andre Vehreschild
1 sibling, 1 reply; 18+ messages in thread
From: Paul Richard Thomas @ 2015-03-24 10:13 UTC (permalink / raw)
To: Andre Vehreschild
Cc: Mikael Morin, GCC-Fortran-ML, GCC-Patches-ML, Antony Lewis
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
>
--
Outside of a dog, a book is a man's best friend. Inside of a dog it's
too dark to read.
Groucho Marx
^ permalink raw reply [flat|nested] 18+ messages in thread
* [Patch, Fortran, pr60322] was: [Patch 1/2, Fortran, pr60322] [OOP] Incorrect bounds on polymorphic dummy array
2015-03-24 10:13 ` Paul Richard Thomas
@ 2015-03-24 17:06 ` Andre Vehreschild
2015-03-25 9:43 ` Dominique d'Humières
2015-03-27 12:48 ` Paul Richard Thomas
0 siblings, 2 replies; 18+ messages in thread
From: Andre Vehreschild @ 2015-03-24 17:06 UTC (permalink / raw)
To: Paul Richard Thomas
Cc: Mikael Morin, GCC-Fortran-ML, GCC-Patches-ML, Antony Lewis,
Dominique Dhumieres
[-- Attachment #1: Type: text/plain, Size: 7086 bytes --]
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
[-- Attachment #2: pr60322_4.clog --]
[-- Type: application/octet-stream, Size: 2465 bytes --]
gcc/fortran/ChangeLog:
2015-03-24 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: Added IS_CLASS_ARRAY macro.
* trans-array.c (gfc_add_loop_ss_code): Treat class objects
always to be referenced.
(build_class_array_ref): Adapt retrieval of array descriptor.
(build_array_ref): Likewise.
(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_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, too.
(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_class_to_class): Prevent access to unset array data
when the array is an optional argument.
(gfc_trans_class_init_assign): Ensure that the rank of
_def_init is zero.
(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.
* trans-stmt.c (trans_associate_var): Use a temporary array
descriptor 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.
gcc/testsuite/ChangeLog:
2015-03-24 Andre Vehreschild <vehre@gmx.de>
* gfortran.dg/class_array_20.f03: New test.
* gfortran.dg/finalize_10.f90: Correct scan tree expressions
to cope with temporary array descriptors for class arrays.
* gfortran.dg/finalize_15.f90: Fixing comparision to model
initialization correctly.
* gfortran.dg/finalize_29.f08: New test.
[-- Attachment #3: pr60322_4.patch --]
[-- Type: text/x-patch, Size: 44646 bytes --]
diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c
index 65495d2..7f3a59d 100644
--- a/gcc/fortran/expr.c
+++ b/gcc/fortran/expr.c
@@ -4060,7 +4060,7 @@ 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. */
- as = sym->ts.type == BT_CLASS ? CLASS_DATA (sym)->as : sym->as;
+ 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, as);
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index 8e6595f..901a1c0 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -3206,6 +3206,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 afe73a9..0804d45 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
@@ -3159,26 +3169,41 @@ build_array_ref (tree desc, tree offset, tree decl)
{
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);
@@ -5570,7 +5595,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 +5638,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;
@@ -5901,12 +5926,16 @@ gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc,
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;
@@ -5919,8 +5948,13 @@ 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);
- as = sym->as;
+ 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
@@ -6791,6 +6825,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;
@@ -6932,6 +6967,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);
@@ -6988,13 +7024,27 @@ 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->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 d3fcdd1..895733b 100644
--- a/gcc/fortran/trans-decl.c
+++ b/gcc/fortran/trans-decl.c
@@ -814,10 +814,11 @@ gfc_build_qualified_array (tree decl, gfc_symbol * sym)
gfc_namespace* procns;
symbol_attribute *array_attr;
gfc_array_spec *as;
+ bool is_classarray = IS_CLASS_ARRAY (sym);
type = TREE_TYPE (decl);
- array_attr = &sym->attr;
- as = sym->as;
+ 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))
@@ -1023,14 +1024,19 @@ gfc_build_dummy_array_decl (gfc_symbol * sym, tree dummy)
gfc_packed packed;
int n;
bool known_size;
+ bool is_classarray = IS_CLASS_ARRAY (sym);
/* 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 = 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.
+ 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. */
+ 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;
@@ -1039,24 +1045,27 @@ gfc_build_dummy_array_decl (gfc_symbol * sym, tree dummy)
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. */
@@ -1090,7 +1099,10 @@ gfc_build_dummy_array_decl (gfc_symbol * sym, tree dummy)
packed = PACKED_PARTIAL;
}
- type = gfc_typenode_for_spec (&sym->ts);
+ /* 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);
}
@@ -1440,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)
@@ -3987,14 +4016,16 @@ 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))
{
+ bool is_classarray = IS_CLASS_ARRAY (sym);
symbol_attribute *array_attr;
gfc_array_spec *as;
array_type tmp;
- array_attr = &sym->attr;
- as = sym->as;
+ 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)
@@ -4004,10 +4035,12 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block)
case AS_EXPLICIT:
if (sym->attr.dummy || sym->attr.result)
gfc_trans_dummy_array_bias (sym, sym->backend_decl, block);
- /* In a class array the _data component always has the pointer
- attribute set. Therefore only check for allocatable in the
- array attributes and for pointer in the symbol. */
- else if (sym->attr.pointer || array_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))
{
@@ -4124,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 9bf976a..664c2c6 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)),
@@ -883,7 +893,11 @@ 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);
+ }
else
{
/* Remove everything after the last class reference, convert the
@@ -918,6 +932,13 @@ gfc_conv_class_to_class (gfc_se *parmse, gfc_expr *e, gfc_typespec class_ts,
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)
@@ -1191,6 +1212,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)
@@ -2246,8 +2269,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)
{
@@ -2351,9 +2377,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);
@@ -2365,11 +2406,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
@@ -2377,6 +2419,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;
@@ -2414,6 +2482,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);
@@ -2433,6 +2513,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
@@ -4559,7 +4640,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..cb693c0 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;
}
diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c
index a6fb52c..6ffae6e79e 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 standart 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 1838a2e..b9f662d 100644
--- a/gcc/fortran/trans-types.c
+++ b/gcc/fortran/trans-types.c
@@ -1290,14 +1290,17 @@ gfc_is_nodesc_array (gfc_symbol * sym)
{
symbol_attribute *array_attr;
gfc_array_spec *as;
+ bool is_classarray = IS_CLASS_ARRAY (sym);
- array_attr = &sym->attr;
- as = sym->as;
+ 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 || array_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
diff --git a/gcc/fortran/trans.c b/gcc/fortran/trans.c
index b7ec0e5..394745e 100644
--- a/gcc/fortran/trans.c
+++ b/gcc/fortran/trans.c
@@ -362,16 +362,23 @@ gfc_build_array_ref (tree base, tree offset, tree decl)
{
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);
}
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/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
^ permalink raw reply [flat|nested] 18+ messages in thread
* Re: [Patch, Fortran, pr60322] was: [Patch 1/2, Fortran, pr60322] [OOP] Incorrect bounds on polymorphic dummy array
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-27 12:48 ` Paul Richard Thomas
1 sibling, 1 reply; 18+ messages in thread
From: Dominique d'Humières @ 2015-03-25 9:43 UTC (permalink / raw)
To: Andre Vehreschild
Cc: Paul Richard Thomas, Mikael Morin, GCC-Fortran-ML,
GCC-Patches-ML, Antony Lewis
Hi Andre,
> Le 24 mars 2015 à 18:06, Andre Vehreschild <vehre@gmx.de> a écrit :
>
> 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.
Are you sure that you attached the right patch? It does not apply on a clean tree unless I apply the patch at
https://gcc.gnu.org/ml/fortran/2015-02/msg00105.html
with minor surgery for gcc/fortran/expr.c.
> 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.
The ICE is fixed and the LOC issue seems fixed.
> 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.
I have changed the test to
use iso_c_binding
implicit none
real, target :: e
class(*), allocatable, target :: a(:)
e = 1.0
call add_element_poly(a,e)
print *, size(a)
call add_element_poly(a,e)
print *, size(a)
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
print *, size(a)
allocate(tmp(size(a)),source=a)
print *, size(a), size(tmp) + 1
print *, loc(a(1)),loc(tmp),sizeof(tmp)
deallocate(a)
! allocate(a(size(tmp)+1),mold=e)
allocate(a(size(tmp)+1),source=e)
print *, size(a), size(tmp)
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
As pointed by Paul, I get a segfault at run time if I use the commented line, i.e. ‘mold’ instead of ‘source’.
> Bootstraps and regtests ok on x86_64-linux-gnu/F20.
>
> Regards,
> Andre
Thanks for your work.
Dominique
^ permalink raw reply [flat|nested] 18+ messages in thread
* Re: [Patch, Fortran, pr60322] was: [Patch 1/2, Fortran, pr60322] [OOP] Incorrect bounds on polymorphic dummy array
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
0 siblings, 1 reply; 18+ messages in thread
From: Andre Vehreschild @ 2015-03-25 16:57 UTC (permalink / raw)
To: Dominique d'Humières
Cc: Paul Richard Thomas, Mikael Morin, GCC-Fortran-ML,
GCC-Patches-ML, Antony Lewis
[-- Attachment #1: Type: text/plain, Size: 3650 bytes --]
Hi Dominique, hi all,
you are absolutely right, Dominique: I missed the part of pr60322_base_*.
But this time it is there and furthermore does solve the allocate( mold=e) and
the loc(e) issue.
Paul: I have simplified your patch by only checking whether the
arg_expr.ts.type == BT_CLASS. All tests showed, that this enough to produce the
correct code.
Bootstraps and regtests ok on x86_64-linux-gnu/F20.
Comments, please!
Regards,
Andre
On Wed, 25 Mar 2015 10:43:34 +0100
Dominique d'Humières <dominiq@lps.ens.fr> wrote:
> Hi Andre,
>
> > Le 24 mars 2015 à 18:06, Andre Vehreschild <vehre@gmx.de> a écrit :
> >
> > 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.
>
> Are you sure that you attached the right patch? It does not apply on a clean
> tree unless I apply the patch at
>
> https://gcc.gnu.org/ml/fortran/2015-02/msg00105.html
>
> with minor surgery for gcc/fortran/expr.c.
>
> > 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.
>
> The ICE is fixed and the LOC issue seems fixed.
>
> > 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.
>
> I have changed the test to
>
> use iso_c_binding
> implicit none
> real, target :: e
> class(*), allocatable, target :: a(:)
> e = 1.0
> call add_element_poly(a,e)
> print *, size(a)
> call add_element_poly(a,e)
> print *, size(a)
> 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
> print *, size(a)
> allocate(tmp(size(a)),source=a)
> print *, size(a), size(tmp) + 1
> print *, loc(a(1)),loc(tmp),sizeof(tmp)
> deallocate(a)
> ! allocate(a(size(tmp)+1),mold=e)
> allocate(a(size(tmp)+1),source=e)
> print *, size(a), size(tmp)
> 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
>
> As pointed by Paul, I get a segfault at run time if I use the commented line,
> i.e. ‘mold’ instead of ‘source’.
>
> > Bootstraps and regtests ok on x86_64-linux-gnu/F20.
> >
> > Regards,
> > Andre
>
> Thanks for your work.
>
> Dominique
>
--
Andre Vehreschild * Email: vehre ad gmx dot de
[-- Attachment #2: pr60322_full_5.clog --]
[-- Type: application/octet-stream, Size: 2669 bytes --]
gcc/testsuite/ChangeLog:
2015-03-25 Andre Vehreschild <vehre@gmx.de>
* gfortran.dg/class_allocate_19.f03: New test.
* gfortran.dg/class_array_20.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-03-25 Andre Vehreschild <vehre@gmx.de>
* 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_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_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_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.
[-- Attachment #3: pr60322_full_5.patch --]
[-- Type: text/x-patch, Size: 57025 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 8e6595f..901a1c0 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -3206,6 +3206,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..0804d45 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
@@ -3159,26 +3169,41 @@ build_array_ref (tree desc, tree offset, tree decl)
{
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);
@@ -5570,7 +5595,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 +5638,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 +5925,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 +5948,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 +6037,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 +6055,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 +6063,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 +6122,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);
@@ -6789,6 +6825,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 +6967,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 +7024,27 @@ 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->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..895733b 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.
+ 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. */
+ 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 9bf976a..2da647f 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)),
@@ -766,6 +776,16 @@ gfc_conv_intrinsic_to_class (gfc_se *parmse, gfc_expr *e,
}
}
}
+ 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);
}
@@ -792,6 +812,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;
@@ -883,7 +904,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
@@ -895,6 +921,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);
@@ -913,11 +940,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)
@@ -1004,7 +1058,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);
@@ -1061,7 +1115,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);
@@ -1103,7 +1158,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);
@@ -1118,6 +1174,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;
}
@@ -1191,6 +1259,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)
@@ -2246,8 +2316,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)
{
@@ -2351,9 +2424,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);
@@ -2365,11 +2453,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
@@ -2377,6 +2466,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;
@@ -2414,6 +2529,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);
@@ -2433,6 +2560,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
@@ -4559,7 +4687,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 a6fb52c..6ffae6e79e 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 standart 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..394745e 100644
--- a/gcc/fortran/trans.c
+++ b/gcc/fortran/trans.c
@@ -362,16 +362,23 @@ gfc_build_array_ref (tree base, tree offset, tree decl)
{
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);
}
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/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
^ permalink raw reply [flat|nested] 18+ messages in thread
* Re: [Patch, Fortran, pr60322] was: [Patch 1/2, Fortran, pr60322] [OOP] Incorrect bounds on polymorphic dummy array
2015-03-25 16:57 ` Andre Vehreschild
@ 2015-03-26 9:27 ` Dominique d'Humières
0 siblings, 0 replies; 18+ messages in thread
From: Dominique d'Humières @ 2015-03-26 9:27 UTC (permalink / raw)
To: Andre Vehreschild
Cc: Paul Richard Thomas, Mikael Morin, GCC-Fortran-ML,
GCC-Patches-ML, Antony Lewis
Dear Andre,
Everything works as expected with your new patch.
I have changed the test for pr57305 to
use iso_c_binding
implicit none
integer :: i
real, target :: e
class(*), allocatable, target :: a(:)
do i = 1, 3
e = i
call add_element_poly(a,e)
select type (a)
type is (real)
print *, a
end select
end do
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
and get the expected outputs at run time (it works also if I replace MOLD with SOURCE and remove the second ‘dummy = …’ line).
Thanks for your patience,
Dominique
> Le 25 mars 2015 à 17:56, Andre Vehreschild <vehre@gmx.de> a écrit :
>
> Hi Dominique, hi all,
>
> you are absolutely right, Dominique: I missed the part of pr60322_base_*.
>
> But this time it is there and furthermore does solve the allocate( mold=e) and
> the loc(e) issue.
>
> Paul: I have simplified your patch by only checking whether the
> arg_expr.ts.type == BT_CLASS. All tests showed, that this enough to produce the
> correct code.
>
> Bootstraps and regtests ok on x86_64-linux-gnu/F20.
>
> Comments, please!
>
> Regards,
> Andre
>
> On Wed, 25 Mar 2015 10:43:34 +0100
> Dominique d'Humières <dominiq@lps.ens.fr> wrote:
^ permalink raw reply [flat|nested] 18+ messages in thread
* Re: [Patch, Fortran, pr60322] was: [Patch 1/2, Fortran, pr60322] [OOP] Incorrect bounds on polymorphic dummy array
2015-03-24 17:06 ` [Patch, Fortran, pr60322] was: " Andre Vehreschild
2015-03-25 9:43 ` Dominique d'Humières
@ 2015-03-27 12:48 ` Paul Richard Thomas
2015-04-05 9:13 ` Paul Richard Thomas
1 sibling, 1 reply; 18+ messages in thread
From: Paul Richard Thomas @ 2015-03-27 12:48 UTC (permalink / raw)
To: Andre Vehreschild
Cc: Mikael Morin, GCC-Fortran-ML, GCC-Patches-ML, Antony Lewis,
Dominique Dhumieres
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
^ permalink raw reply [flat|nested] 18+ messages in thread
* Re: [Patch, Fortran, pr60322] was: [Patch 1/2, Fortran, pr60322] [OOP] Incorrect bounds on polymorphic dummy array
2015-03-27 12:48 ` Paul Richard Thomas
@ 2015-04-05 9:13 ` Paul Richard Thomas
2015-04-09 12:37 ` Andre Vehreschild
0 siblings, 1 reply; 18+ messages in thread
From: Paul Richard Thomas @ 2015-04-05 9:13 UTC (permalink / raw)
To: Andre Vehreschild
Cc: Mikael Morin, GCC-Fortran-ML, GCC-Patches-ML, Antony Lewis,
Dominique Dhumieres
Dear Andre,
Well, time passed and it didn't get done. Too much going on at the moment!
As you say, the patch bootstraps and regtests on x86_64, FC21 in my case.
I am now very reluctant to mess around with the gcc-5 release. Thus, I
think that this patch must be committed to 5.2 and 6.0, when the are
open for business.
A few trivial comments:
+ /* 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?
+ /* 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.
In trans-stmt.c s/standart/standard/
Don't forget to put the PR numbers in the ChangeLogs.
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 :-)
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
--
Outside of a dog, a book is a man's best friend. Inside of a dog it's
too dark to read.
Groucho Marx
^ permalink raw reply [flat|nested] 18+ messages in thread
* Re: [Patch, Fortran, pr60322] was: [Patch 1/2, Fortran, pr60322] [OOP] Incorrect bounds on polymorphic dummy array
2015-04-05 9:13 ` Paul Richard Thomas
@ 2015-04-09 12:37 ` Andre Vehreschild
2015-04-14 17:01 ` [Patch, Fortran, pr60322, addendum] " Andre Vehreschild
0 siblings, 1 reply; 18+ messages in thread
From: Andre Vehreschild @ 2015-04-09 12:37 UTC (permalink / raw)
To: Paul Richard Thomas
Cc: Mikael Morin, GCC-Fortran-ML, GCC-Patches-ML, Antony Lewis,
Dominique Dhumieres
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
^ permalink raw reply [flat|nested] 18+ messages in thread
* Re: [Patch, Fortran, pr60322, addendum] was: [Patch 1/2, Fortran, pr60322] [OOP] Incorrect bounds on polymorphic dummy array
2015-04-09 12:37 ` Andre Vehreschild
@ 2015-04-14 17:01 ` Andre Vehreschild
2015-04-16 19:13 ` Paul Richard Thomas
0 siblings, 1 reply; 18+ messages in thread
From: Andre Vehreschild @ 2015-04-14 17:01 UTC (permalink / raw)
To: Paul Richard Thomas
Cc: Mikael Morin, GCC-Fortran-ML, GCC-Patches-ML, Antony Lewis,
Dominique Dhumieres
[-- 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:
^ permalink raw reply [flat|nested] 18+ messages in thread
* Re: [Patch, Fortran, pr60322, addendum] was: [Patch 1/2, Fortran, pr60322] [OOP] Incorrect bounds on polymorphic dummy array
2015-04-14 17:01 ` [Patch, Fortran, pr60322, addendum] " Andre Vehreschild
@ 2015-04-16 19:13 ` Paul Richard Thomas
2015-04-23 11:34 ` [commited, Patch, " Andre Vehreschild
0 siblings, 1 reply; 18+ messages in thread
From: Paul Richard Thomas @ 2015-04-16 19:13 UTC (permalink / raw)
To: Andre Vehreschild
Cc: Mikael Morin, GCC-Fortran-ML, GCC-Patches-ML, Antony Lewis,
Dominique Dhumieres
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
--
Outside of a dog, a book is a man's best friend. Inside of a dog it's
too dark to read.
Groucho Marx
^ permalink raw reply [flat|nested] 18+ messages in thread
* Re: [commited, Patch, Fortran, pr60322, addendum] was: [Patch 1/2, Fortran, pr60322] [OOP] Incorrect bounds on polymorphic dummy array
2015-04-16 19:13 ` Paul Richard Thomas
@ 2015-04-23 11:34 ` Andre Vehreschild
2015-04-27 17:43 ` Andre Vehreschild
0 siblings, 1 reply; 18+ messages in thread
From: Andre Vehreschild @ 2015-04-23 11:34 UTC (permalink / raw)
To: Paul Richard Thomas
Cc: Mikael Morin, GCC-Fortran-ML, GCC-Patches-ML, Antony Lewis,
Dominique Dhumieres
[-- Attachment #1: Type: text/plain, Size: 17524 bytes --]
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
[-- Attachment #2: submit.diff --]
[-- Type: text/x-patch, Size: 48306 bytes --]
Index: gcc/fortran/trans-expr.c
===================================================================
--- gcc/fortran/trans-expr.c (Revision 222360)
+++ gcc/fortran/trans-expr.c (Arbeitskopie)
@@ -149,6 +149,11 @@
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 @@
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_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 @@
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 @@
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_expr (&tmpse, e);
class_ref->next = ref;
tmp = tmpse.expr;
+ slen = tmpse.string_length;
}
gcc_assert (tmp != NULL_TREE);
@@ -951,11 +978,38 @@
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 @@
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_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 @@
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 @@
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 @@
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 @@
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 @@
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 @@
}
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 @@
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 @@
&& (!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 @@
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 @@
gcc_unreachable ();
break;
}
+ first_time = false;
ref = ref->next;
}
/* Pointer assignment, allocation or pass by reference. Arrays are handled
@@ -4597,7 +4735,19 @@
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);
Index: gcc/fortran/ChangeLog
===================================================================
--- gcc/fortran/ChangeLog (Revision 222360)
+++ gcc/fortran/ChangeLog (Arbeitskopie)
@@ -1,3 +1,61 @@
+2015-04-23 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.
+
2015-04-22 Steven G. Kargl <kargl@gcc.gnu.org>
PR fortran/65429
Index: gcc/fortran/trans-types.c
===================================================================
--- gcc/fortran/trans-types.c (Revision 222360)
+++ gcc/fortran/trans-types.c (Arbeitskopie)
@@ -1288,25 +1288,35 @@
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;
}
Index: gcc/fortran/trans-stmt.c
===================================================================
--- gcc/fortran/trans-stmt.c (Revision 222360)
+++ gcc/fortran/trans-stmt.c (Arbeitskopie)
@@ -1390,13 +1390,30 @@
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)
{
/* Recover the dtype, which has been overwritten by the
@@ -1406,7 +1423,7 @@
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));
}
@@ -1449,9 +1466,18 @@
}
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... */
Index: gcc/fortran/gfortran.h
===================================================================
--- gcc/fortran/gfortran.h (Revision 222360)
+++ gcc/fortran/gfortran.h (Arbeitskopie)
@@ -3210,6 +3210,11 @@
&& 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 */
Index: gcc/fortran/trans-intrinsic.c
===================================================================
--- gcc/fortran/trans-intrinsic.c (Revision 222360)
+++ gcc/fortran/trans-intrinsic.c (Arbeitskopie)
@@ -5921,8 +5921,17 @@
}
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_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 @@
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);
Index: gcc/fortran/trans.c
===================================================================
--- gcc/fortran/trans.c (Revision 222360)
+++ gcc/fortran/trans.c (Arbeitskopie)
@@ -321,7 +321,7 @@
/* 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 @@
/* 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);
+ 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);
+ /* 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 ();
Index: gcc/fortran/trans-decl.c
===================================================================
--- gcc/fortran/trans-decl.c (Revision 222360)
+++ gcc/fortran/trans-decl.c (Arbeitskopie)
@@ -812,8 +812,13 @@
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 @@
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 @@
}
/* 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 @@
}
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 @@
}
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 @@
{
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 @@
tree decl;
tree type;
gfc_array_spec *as;
+ symbol_attribute *array_attr;
char *name;
gfc_packed packed;
int n;
bool known_size;
+ bool is_classarray = IS_CLASS_ARRAY (sym);
- if (sym->attr.pointer || sym->attr.allocatable
- || (sym->as && sym->as->type == AS_ASSUMED_RANK))
+ /* 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 @@
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 @@
/* 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,6 +1452,23 @@
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)
{
@@ -1435,7 +1475,7 @@
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_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_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 @@
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 @@
}
else
{
+ se.descriptor_only = 1;
gfc_conv_expr (&se, e);
descriptor = se.expr;
se.expr = gfc_conv_descriptor_data_addr (se.expr);
Index: gcc/fortran/trans.h
===================================================================
--- gcc/fortran/trans.h (Revision 222360)
+++ gcc/fortran/trans.h (Arbeitskopie)
@@ -49,6 +49,10 @@
/* 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_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);
Index: gcc/fortran/trans-array.c
===================================================================
--- gcc/fortran/trans-array.c (Revision 222360)
+++ gcc/fortran/trans-array.c (Arbeitskopie)
@@ -2495,11 +2495,14 @@
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 @@
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,20 +3165,35 @@
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;
@@ -3175,10 +3200,10 @@
/* 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 @@
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 @@
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_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 @@
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 @@
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,7 +5949,13 @@
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
@@ -5925,7 +5962,7 @@
&& 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 @@
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 @@
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 @@
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_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 @@
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 @@
tree from;
tree to;
tree base;
+ bool onebased = false;
ndim = info->ref ? info->ref->u.ar.dimen : ss->dimen;
@@ -6930,6 +6968,7 @@
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_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
Index: gcc/fortran/expr.c
===================================================================
--- gcc/fortran/expr.c (Revision 222360)
+++ gcc/fortran/expr.c (Arbeitskopie)
@@ -4052,6 +4052,7 @@
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 @@
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;
}
Index: gcc/testsuite/gfortran.dg/finalize_10.f90
===================================================================
--- gcc/testsuite/gfortran.dg/finalize_10.f90 (Revision 222360)
+++ gcc/testsuite/gfortran.dg/finalize_10.f90 (Arbeitskopie)
@@ -27,8 +27,8 @@
! 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" } }
Index: gcc/testsuite/gfortran.dg/finalize_15.f90
===================================================================
--- gcc/testsuite/gfortran.dg/finalize_15.f90 (Revision 222360)
+++ gcc/testsuite/gfortran.dg/finalize_15.f90 (Arbeitskopie)
@@ -9,37 +9,37 @@
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 @@
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
Index: gcc/testsuite/ChangeLog
===================================================================
--- gcc/testsuite/ChangeLog (Revision 222360)
+++ gcc/testsuite/ChangeLog (Arbeitskopie)
@@ -1,3 +1,14 @@
+2015-04-23 Andre Vehreschild <vehre@gmx.de>
+
+ PR fortran/60322
+ * 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.
+
2015-04-22 Bill Schmidt <wschmidt@linux.vnet.ibm.com>
* gcc.target/powerpc/swaps-p8-18.c: New test.
^ permalink raw reply [flat|nested] 18+ messages in thread
* Re: [commited, Patch, Fortran, pr60322, addendum] was: [Patch 1/2, Fortran, pr60322] [OOP] Incorrect bounds on polymorphic dummy array
2015-04-23 11:34 ` [commited, Patch, " Andre Vehreschild
@ 2015-04-27 17:43 ` Andre Vehreschild
0 siblings, 0 replies; 18+ messages in thread
From: Andre Vehreschild @ 2015-04-27 17:43 UTC (permalink / raw)
To: Paul Richard Thomas
Cc: Mikael Morin, GCC-Fortran-ML, GCC-Patches-ML, Antony Lewis,
Dominique Dhumieres
[-- Attachment #1: Type: text/plain, Size: 18662 bytes --]
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
[-- Attachment #2: submit.diff --]
[-- Type: text/x-patch, Size: 16579 bytes --]
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.
^ permalink raw reply [flat|nested] 18+ messages in thread
end of thread, other threads:[~2015-04-27 17:43 UTC | newest]
Thread overview: 18+ messages (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
2015-02-26 17:19 [Patch 1/2, Fortran, pr60322] [OOP] Incorrect bounds on polymorphic dummy array 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 ` [Patch, Fortran, pr60322, addendum] " Andre Vehreschild
2015-04-16 19:13 ` Paul Richard Thomas
2015-04-23 11:34 ` [commited, Patch, " Andre Vehreschild
2015-04-27 17:43 ` Andre Vehreschild
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).