* Re: [Patch, fortran] PR83118 - [8/9/10/11 Regression] Bad intrinsic assignment of class(*) array component of derived type
@ 2020-11-11 16:42 dhumieres.dominique
2020-11-11 17:11 ` Paul Richard Thomas
2020-12-05 10:19 ` Paul Richard Thomas
0 siblings, 2 replies; 18+ messages in thread
From: dhumieres.dominique @ 2020-11-11 16:42 UTC (permalink / raw)
To: paul.richard.thomas; +Cc: tobias, vehre, fortran
Hi Paul,
I am absolutely unable to review the patch, but I can apply it and test
it.
I have found several regressions giving the following ICE
internal compiler error: in gfc_trans_create_temp_array, at
fortran/trans-array.c:1304
For instance (pr51864)
type t
integer :: i = 5
end type t
type, extends(t) :: t2
integer :: j = 6
end type t2
class(t), allocatable :: a(:), b(:), c(:)
allocate(t2 :: a(3))
allocate(t2 :: b(5))
!allocate(c, source=[ a, b ]) ! F2008, PR 44672
allocate(c(8), source=[ a, b ])
! c = [ a, b ] ! F2008, PR 43366
select type(c)
type is(t)
print '(8(i2))', c%i
type is(t2)
print '(8(i2))', c%i
print '(8(i2))', c%j
end select
end
I also see
% gfc realloc_3.f90
Undefined symbols for architecture x86_64:
"___copy_MAIN___T2.2", referenced from:
___vtab_MAIN___T2.5 in ccUFYzUc.o
ld: symbol(s) not found for architecture x86_64
collect2: error: ld returned 1 exit status
for
type t
integer :: x
end type t
type, extends(t) :: t2
integer :: j(4)
end type t2
class(t), allocatable :: y(:)
y = [ t2(x=3,j=[1,2,3,4]) ]
end
The patch also seems to fix pr96012.
Cheers,
Dominique
^ permalink raw reply [flat|nested] 18+ messages in thread
* Re: [Patch, fortran] PR83118 - [8/9/10/11 Regression] Bad intrinsic assignment of class(*) array component of derived type
2020-11-11 16:42 [Patch, fortran] PR83118 - [8/9/10/11 Regression] Bad intrinsic assignment of class(*) array component of derived type dhumieres.dominique
@ 2020-11-11 17:11 ` Paul Richard Thomas
2020-11-15 8:59 ` Paul Richard Thomas
2020-12-05 10:19 ` Paul Richard Thomas
1 sibling, 1 reply; 18+ messages in thread
From: Paul Richard Thomas @ 2020-11-11 17:11 UTC (permalink / raw)
To: dhumieres.dominique; +Cc: Tobias Burnus, Andre Vehreschild, fortran
Hi Dominique,
Many thanks for these failing testcases.
If I remove the assertion at trans-array.c:1304 (part of the patch) the
first testcase compiles and runs but is producing wrong code. Clearly the
extraction of the class information in the new function
'get_class_info_from_ss' is incomplete because the class wrapper itself is
used as the element type for the temporary array, when the allocation of
'c' is used. On the other hand, the assignment works fine.
The second testcase fails because 't2' is never referenced in any statement
where a check is made for its vtable.
I have generated a third testcase, where a dependency generates wrong code
and wrong results.
I will retire the patch to fix these problems. I would like both class
assignment and allocation with source to give both correct code and correct
results!
Regards
Paul
On Wed, 11 Nov 2020 at 16:42, <dhumieres.dominique@free.fr> wrote:
> Hi Paul,
>
> I am absolutely unable to review the patch, but I can apply it and test
> it.
>
> I have found several regressions giving the following ICE
>
> internal compiler error: in gfc_trans_create_temp_array, at
> fortran/trans-array.c:1304
>
> For instance (pr51864)
>
> type t
> integer :: i = 5
> end type t
> type, extends(t) :: t2
> integer :: j = 6
> end type t2
>
> class(t), allocatable :: a(:), b(:), c(:)
> allocate(t2 :: a(3))
> allocate(t2 :: b(5))
> !allocate(c, source=[ a, b ]) ! F2008, PR 44672
> allocate(c(8), source=[ a, b ])
> ! c = [ a, b ] ! F2008, PR 43366
> select type(c)
> type is(t)
> print '(8(i2))', c%i
> type is(t2)
> print '(8(i2))', c%i
> print '(8(i2))', c%j
> end select
> end
>
> I also see
>
> % gfc realloc_3.f90
> Undefined symbols for architecture x86_64:
> "___copy_MAIN___T2.2", referenced from:
> ___vtab_MAIN___T2.5 in ccUFYzUc.o
> ld: symbol(s) not found for architecture x86_64
> collect2: error: ld returned 1 exit status
>
> for
>
> type t
> integer :: x
> end type t
> type, extends(t) :: t2
> integer :: j(4)
> end type t2
> class(t), allocatable :: y(:)
> y = [ t2(x=3,j=[1,2,3,4]) ]
> end
>
> The patch also seems to fix pr96012.
>
> Cheers,
>
> Dominique
>
--
"If you can't explain it simply, you don't understand it well enough" -
Albert Einstein
^ permalink raw reply [flat|nested] 18+ messages in thread
* Re: [Patch, fortran] PR83118 - [8/9/10/11 Regression] Bad intrinsic assignment of class(*) array component of derived type
2020-11-11 17:11 ` Paul Richard Thomas
@ 2020-11-15 8:59 ` Paul Richard Thomas
[not found] ` <7f560751852d070b03db7480d59642c8@free.fr>
0 siblings, 1 reply; 18+ messages in thread
From: Paul Richard Thomas @ 2020-11-15 8:59 UTC (permalink / raw)
To: dhumieres.dominique; +Cc: Tobias Burnus, Andre Vehreschild, fortran
Hi Dominique,
On Wed, 11 Nov 2020 at 17:11, Paul Richard Thomas <
paul.richard.thomas@gmail.com> wrote:
> Hi Dominique,
>
> Many thanks for these failing testcases.
>
> If I remove the assertion at trans-array.c:1304 (part of the patch) the
> first testcase compiles and runs but is producing wrong code. Clearly the
> extraction of the class information in the new function
> 'get_class_info_from_ss' is incomplete because the class wrapper itself is
> used as the element type for the temporary array, when the allocation of
> 'c' is used. On the other hand, the assignment works fine.
>
> The second testcase fails because 't2' is never referenced in any
> statement where a check is made for its vtable.
>
> I have generated a third testcase, where a dependency generates wrong code
> and wrong results.
>
> I will retire the patch to fix these problems. I would like both class
> assignment and allocation with source to give both correct code and correct
> results!
>
> Regards
>
> Paul
>
>
> On Wed, 11 Nov 2020 at 16:42, <dhumieres.dominique@free.fr> wrote:
>
>> Hi Paul,
>>
>> I am absolutely unable to review the patch, but I can apply it and test
>> it.
>>
>> I have found several regressions giving the following ICE
>>
>> internal compiler error: in gfc_trans_create_temp_array, at
>> fortran/trans-array.c:1304
>>
>> For instance (pr51864)
>>
>> type t
>> integer :: i = 5
>> end type t
>> type, extends(t) :: t2
>> integer :: j = 6
>> end type t2
>>
>> class(t), allocatable :: a(:), b(:), c(:)
>> allocate(t2 :: a(3))
>> allocate(t2 :: b(5))
>> !allocate(c, source=[ a, b ]) ! F2008, PR 44672
>> allocate(c(8), source=[ a, b ])
>> ! c = [ a, b ] ! F2008, PR 43366
>> select type(c)
>> type is(t)
>> print '(8(i2))', c%i
>> type is(t2)
>> print '(8(i2))', c%i
>> print '(8(i2))', c%j
>> end select
>> end
>>
>> I also see
>>
>> % gfc realloc_3.f90
>> Undefined symbols for architecture x86_64:
>> "___copy_MAIN___T2.2", referenced from:
>> ___vtab_MAIN___T2.5 in ccUFYzUc.o
>> ld: symbol(s) not found for architecture x86_64
>> collect2: error: ld returned 1 exit status
>>
>> for
>>
>> type t
>> integer :: x
>> end type t
>> type, extends(t) :: t2
>> integer :: j(4)
>> end type t2
>> class(t), allocatable :: y(:)
>> y = [ t2(x=3,j=[1,2,3,4]) ]
>> end
>>
>> The patch also seems to fix pr96012.
>>
>> Cheers,
>>
>> Dominique
>>
>
>
> --
> "If you can't explain it simply, you don't understand it well enough" -
> Albert Einstein
>
--
"If you can't explain it simply, you don't understand it well enough" -
Albert Einstein
^ permalink raw reply [flat|nested] 18+ messages in thread
* Re: [Patch, fortran] PR83118 - [8/9/10/11 Regression] Bad intrinsic assignment of class(*) array component of derived type
2020-11-11 16:42 [Patch, fortran] PR83118 - [8/9/10/11 Regression] Bad intrinsic assignment of class(*) array component of derived type dhumieres.dominique
2020-11-11 17:11 ` Paul Richard Thomas
@ 2020-12-05 10:19 ` Paul Richard Thomas
2020-12-12 18:31 ` Thomas Koenig
1 sibling, 1 reply; 18+ messages in thread
From: Paul Richard Thomas @ 2020-12-05 10:19 UTC (permalink / raw)
To: dhumieres.dominique; +Cc: Tobias Burnus, Andre Vehreschild, fortran
[-- Attachment #1: Type: text/plain, Size: 6312 bytes --]
Dear All,
The failures that Dominique found have sent me on something of a long
chase! The patch now looks rather more formidable than it actually is.
The largest chunks are:
trans-array.c (get_class_info_from_ss) - this does everything possible to
obtain the dynamic size of a class array temporary from the ss chain. An
underlying bug has been fixed, where the temporary type was cast as the
class itself rather than the data. This led to rather odd element lengths
for the temporary array. This is tested in class_allocate_25.f90.
trans-array.c (gfc_alloc_allocatable_for_assignment) - This looks
especially weighty but is primarily a rearrangement to ensure that the
array element sizes are available from the start so that they can be tested
together with the match in shape. This answers Tobias's comment to the
first version of the patch. The temporaries are cast to a character of
length of the dynamic size.
trans-expr.c (gfc_resize_class_size_with_len) - This gathers together some
common code.
trans-expr.c(trans_scalar_class_assign) - This is called from
gfc_trans_scalar_assign to make maximum use of the vptr _copy function in
assignments, thereby preserving the dynamic type. The change in
gfc_conv_ss_descriptor enables this for variable expressions since fixing
the data element renders the class object inaccessible. Note the use of
VIEW_CONVERT_EXPR on the LHS of class assignments. I have understood that
this gives the desired result as long as the LHS and RHS sizes are the
same. I believe that this is guaranteed to be the case and have found no
exceptions as yet. Note also that the temporaries cast as characters appear
here on the RHS. Class assignments have been separated from structure
assignments in gfc_trans_scalar_assign so that there are no side effects
from the patch on all other assignments.
The rest of the patch consists of some minor tidying up and correcting of
missed opportunities to extract the dynamic size of class expressions.
Regtests on x86_64/FC31 - OK for master and 10-branch?
Paul
As well as the PR this patch fixes problems in handling class objects;
most importantly class array temporaries, required when dependences
occur in class assignment, and a correct implementation of reallocation
on assignment.
2020-12-05 Paul Thomas <pault@gcc.gnu.org>
gcc/fortran
PR fortran/83118
PR fortran/96012
* resolve.c (resolve_ordinary_assign): Generate a vtable if
necessary for scalar non-polymorphic rhs's to unlimited lhs's.
* trans-array.c (get_class_info_from_ss): New function.
(gfc_trans_allocate_array_storage): Defer obtaining class
element type until all sources of class exprs are tried. Use
class API rather than TREE_OPERAND. Look for class expressions
in ss->info by calling get_class_info_from_ss. After, obtain
the element size for class descriptors. Where the element type
is unknown, cast the data as character(len=size) to overcome
unlimited polymorphic problems.
(gfc_conv_ss_descriptor): Do not fix class variable refs.
(build_class_array_ref, structure_alloc_comps): Replace code
replicating the new function gfc_resize_class_size_with_len.
(gfc_alloc_allocatable_for_assignment): Obtain element size
for lhs in cases of deferred characters and class enitities.
Move code for the element size of rhs to start of block. Clean
up extraction of class parameters throughout this function.
After the shape check test whether or not the lhs and rhs
element sizes are the same. Use earlier evaluation of
'cond_null'. Reallocation of lhs only to happen if size changes
or element size changes.
* trans-expr.c (gfc_resize_class_size_with_len): New function.
(gfc_get_class_from_expr): If a constant expression is
encountered, return NULL_TREE;
(trans_scalar_class_assign): New function.
(gfc_conv_procedure_call): Ensure the vtable is present for
passing a non-class actual to an unlimited formal.
(trans_class_vptr_len_assignment): For expressions of type
BT_CLASS, extract the class expression if necessary. Use a
statement block outside the loop body. Ensure that 'rhs' is
of the correct type. Obtain rhs vptr in all circumstances.
(gfc_trans_scalar_assign): Call trans_scalar_class_assign to
make maximum use of the vptr copy in place of assignment.
(trans_class_assignment): Actually do reallocation if needed.
(gfc_trans_assignment_1): Simplify some of the logic with
'realloc_flag'. Set 'vptr_copy' for all array assignments to
unlimited polymorphic lhs.
* trans-c (gfc_build_array_ref): Call gfc_resize_class_size_
with_len to correct span for unlimited polymorphic decls.
* trans.h : Add prototype for gfc_resize_class_size_with_len.
gcc/testsuite/
PR fortran/83118
PR fortran/96012
* gfortran.dg/dependency_57.f90: Change to dg-run and test
for correct result.
* gfortran.dg/class_allocate_25.f90: New test.
* gfortran.dg/class_assign_4.f90: New test.
* gfortran.dg/unlimited_polymorphic_32.f03: New test.
On Wed, 11 Nov 2020 at 16:42, <dhumieres.dominique@free.fr> wrote:
> Hi Paul,
>
> I am absolutely unable to review the patch, but I can apply it and test
> it.
>
> I have found several regressions giving the following ICE
>
> internal compiler error: in gfc_trans_create_temp_array, at
> fortran/trans-array.c:1304
>
> For instance (pr51864)
>
> type t
> integer :: i = 5
> end type t
> type, extends(t) :: t2
> integer :: j = 6
> end type t2
>
> class(t), allocatable :: a(:), b(:), c(:)
> allocate(t2 :: a(3))
> allocate(t2 :: b(5))
> !allocate(c, source=[ a, b ]) ! F2008, PR 44672
> allocate(c(8), source=[ a, b ])
> ! c = [ a, b ] ! F2008, PR 43366
> select type(c)
> type is(t)
> print '(8(i2))', c%i
> type is(t2)
> print '(8(i2))', c%i
> print '(8(i2))', c%j
> end select
> end
>
> I also see
>
> % gfc realloc_3.f90
> Undefined symbols for architecture x86_64:
> "___copy_MAIN___T2.2", referenced from:
> ___vtab_MAIN___T2.5 in ccUFYzUc.o
> ld: symbol(s) not found for architecture x86_64
> collect2: error: ld returned 1 exit status
>
> for
>
> type t
> integer :: x
> end type t
> type, extends(t) :: t2
> integer :: j(4)
> end type t2
> class(t), allocatable :: y(:)
> y = [ t2(x=3,j=[1,2,3,4]) ]
> end
>
> The patch also seems to fix pr96012.
>
> Cheers,
>
> Dominique
>
--
"If you can't explain it simply, you don't understand it well enough" -
Albert Einstein
[-- Attachment #2: fix2.diff --]
[-- Type: text/x-patch, Size: 38671 bytes --]
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 1641eb6ca10..cccc077c42f 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -11054,7 +11054,7 @@ resolve_ordinary_assign (gfc_code *code, gfc_namespace *ns)
/* Make sure there is a vtable and, in particular, a _copy for the
rhs type. */
- if (UNLIMITED_POLY (lhs) && lhs->rank && rhs->ts.type != BT_CLASS)
+ if (lhs->ts.type == BT_CLASS && rhs->ts.type != BT_CLASS)
gfc_find_vtab (&rhs->ts);
bool caf_convert_to_send = flag_coarray == GFC_FCOARRAY_LIB
diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c
index b2c39aa32de..9e461f94536 100644
--- a/gcc/fortran/trans-array.c
+++ b/gcc/fortran/trans-array.c
@@ -1030,7 +1030,6 @@ gfc_trans_allocate_array_storage (stmtblock_t * pre, stmtblock_t * post,
gcc_assert (TREE_CODE (tmp) == POINTER_TYPE);
tmp = TREE_TYPE (tmp); /* The descriptor itself. */
tmp = gfc_get_element_type (tmp);
- gcc_assert (tmp == gfc_get_element_type (TREE_TYPE (desc)));
packed = gfc_create_var (build_pointer_type (tmp), "data");
tmp = build_call_expr_loc (input_location,
@@ -1139,6 +1138,123 @@ get_array_ref_dim_for_loop_dim (gfc_ss *ss, int loop_dim)
}
+/* Use the information in the ss to obtain the required information about
+ the type and size of an array temporary, when the lhs in an assignment
+ is a class expression. */
+
+static tree
+get_class_info_from_ss (stmtblock_t * pre, gfc_ss *ss, tree *eltype)
+{
+ gfc_ss *lhs_ss;
+ gfc_ss *rhs_ss;
+ tree tmp;
+ tree tmp2;
+ tree vptr;
+ tree rhs_class_expr = NULL_TREE;
+ tree lhs_class_expr = NULL_TREE;
+ bool unlimited_rhs = false;
+ bool unlimited_lhs = false;
+ bool rhs_function = false;
+ gfc_symbol *vtab;
+
+ /* The second element in the loop chain contains the source for the
+ temporary; ie. the rhs of the assignment. */
+ rhs_ss = ss->loop->ss->loop_chain;
+
+ if (rhs_ss != gfc_ss_terminator
+ && rhs_ss->info
+ && rhs_ss->info->expr
+ && rhs_ss->info->expr->ts.type == BT_CLASS
+ && rhs_ss->info->data.array.descriptor)
+ {
+ rhs_class_expr
+ = gfc_get_class_from_expr (rhs_ss->info->data.array.descriptor);
+ unlimited_rhs = UNLIMITED_POLY (rhs_ss->info->expr);
+ if (rhs_ss->info->expr->expr_type == EXPR_FUNCTION)
+ rhs_function = true;
+ }
+
+ /* For an assignment the lhs is the next element in the loop chain.
+ If we have a class rhs, this had better be a class variable
+ expression! */
+ lhs_ss = rhs_ss->loop_chain;
+ if (lhs_ss != gfc_ss_terminator
+ && lhs_ss->info
+ && lhs_ss->info->expr
+ && lhs_ss->info->expr->expr_type ==EXPR_VARIABLE
+ && lhs_ss->info->expr->ts.type == BT_CLASS)
+ {
+ tmp = lhs_ss->info->data.array.descriptor;
+ unlimited_lhs = UNLIMITED_POLY (rhs_ss->info->expr);
+ }
+ else
+ tmp = NULL_TREE;
+
+ /* Get the lhs class expression. */
+ if (tmp != NULL_TREE && lhs_ss->loop_chain == gfc_ss_terminator)
+ lhs_class_expr = gfc_get_class_from_expr (tmp);
+ else
+ return rhs_class_expr;
+
+ gcc_assert (GFC_CLASS_TYPE_P (TREE_TYPE (lhs_class_expr)));
+
+ /* Set the lhs vptr and, if necessary, the _len field. */
+ if (rhs_class_expr)
+ {
+ /* Both lhs and rhs are class expressions. */
+ tmp = gfc_class_vptr_get (lhs_class_expr);
+ gfc_add_modify (pre, tmp,
+ fold_convert (TREE_TYPE (tmp),
+ gfc_class_vptr_get (rhs_class_expr)));
+ if (unlimited_lhs)
+ {
+ tmp = gfc_class_len_get (lhs_class_expr);
+ if (unlimited_rhs)
+ tmp2 = gfc_class_len_get (rhs_class_expr);
+ else
+ tmp2 = build_int_cst (TREE_TYPE (tmp), 0);
+ gfc_add_modify (pre, tmp, tmp2);
+ }
+
+ if (rhs_function)
+ {
+ tmp = gfc_class_data_get (rhs_class_expr);
+ gfc_conv_descriptor_offset_set (pre, tmp, gfc_index_zero_node);
+ }
+ }
+ else
+ {
+ /* lhs is class and rhs is intrinsic or derived type. */
+ *eltype = TREE_TYPE (rhs_ss->info->data.array.descriptor);
+ *eltype = gfc_get_element_type (*eltype);
+ vtab = gfc_find_vtab (&rhs_ss->info->expr->ts);
+ vptr = vtab->backend_decl;
+ if (vptr == NULL_TREE)
+ vptr = gfc_get_symbol_decl (vtab);
+ vptr = gfc_build_addr_expr (NULL_TREE, vptr);
+ tmp = gfc_class_vptr_get (lhs_class_expr);
+ gfc_add_modify (pre, tmp,
+ fold_convert (TREE_TYPE (tmp), vptr));
+
+ if (unlimited_lhs)
+ {
+ tmp = gfc_class_len_get (lhs_class_expr);
+ if (rhs_ss->info
+ && rhs_ss->info->expr
+ && rhs_ss->info->expr->ts.type == BT_CHARACTER)
+ tmp2 = build_int_cst (TREE_TYPE (tmp),
+ rhs_ss->info->expr->ts.kind);
+ else
+ tmp2 = build_int_cst (TREE_TYPE (tmp), 0);
+ gfc_add_modify (pre, tmp, tmp2);
+ }
+ }
+
+ return rhs_class_expr;
+}
+
+
+
/* Generate code to create and initialize the descriptor for a temporary
array. This is used for both temporaries needed by the scalarizer, and
functions returning arrays. Adjusts the loop variables to be
@@ -1184,13 +1300,46 @@ gfc_trans_create_temp_array (stmtblock_t * pre, stmtblock_t * post, gfc_ss * ss,
{
gcc_assert (POINTER_TYPE_P (TREE_TYPE (initial)));
class_expr = build_fold_indirect_ref_loc (input_location, initial);
- eltype = TREE_TYPE (class_expr);
- eltype = gfc_get_element_type (eltype);
/* Obtain the structure (class) expression. */
- class_expr = TREE_OPERAND (class_expr, 0);
+ class_expr = gfc_get_class_from_expr (class_expr);
gcc_assert (class_expr);
}
+ /* Otherwise, some expressions, such as class functions, arising from
+ dependency checking in assignments come here with class element type.
+ The descriptor can be obtained from the ss->info and then converted
+ to the class object. */
+ if (class_expr == NULL_TREE && GFC_CLASS_TYPE_P (eltype))
+ class_expr = get_class_info_from_ss (pre, ss, &eltype);
+
+ /* If the dynamic type is not available, use the declared type. */
+ if (eltype && GFC_CLASS_TYPE_P (eltype))
+ eltype = gfc_get_element_type (TREE_TYPE (TYPE_FIELDS (eltype)));
+
+ if (class_expr == NULL_TREE)
+ elemsize = fold_convert (gfc_array_index_type,
+ TYPE_SIZE_UNIT (eltype));
+ else
+ {
+ /* Unlimited polymorphic entities are initialised with NULL vptr. They
+ can be tested for by checking if the len field is present. If so
+ test the vptr before using the vtable size. */
+ tmp = gfc_class_vptr_get (class_expr);
+ tmp = fold_build2_loc (input_location, NE_EXPR,
+ logical_type_node,
+ tmp, build_int_cst (TREE_TYPE (tmp), 0));
+ elemsize = fold_build3_loc (input_location, COND_EXPR,
+ gfc_array_index_type,
+ tmp,
+ gfc_class_vtab_size_get (class_expr),
+ gfc_index_zero_node);
+ elemsize = gfc_evaluate_now (elemsize, pre);
+ elemsize = gfc_resize_class_size_with_len (pre, class_expr, elemsize);
+ /* Casting the data as a character of the dynamic length ensures that
+ assignment of elements works when needed. */
+ eltype = gfc_get_character_type_len (1, elemsize);
+ }
+
memset (from, 0, sizeof (from));
memset (to, 0, sizeof (to));
@@ -1339,12 +1488,6 @@ gfc_trans_create_temp_array (stmtblock_t * pre, stmtblock_t * post, gfc_ss * ss,
}
}
- if (class_expr == NULL_TREE)
- elemsize = fold_convert (gfc_array_index_type,
- TYPE_SIZE_UNIT (gfc_get_element_type (type)));
- else
- elemsize = gfc_class_vtab_size_get (class_expr);
-
/* Get the size of the array. */
if (size && !callee_alloc)
{
@@ -2910,13 +3053,16 @@ gfc_conv_ss_descriptor (stmtblock_t * block, gfc_ss * ss, int base)
}
/* Also the data pointer. */
tmp = gfc_conv_array_data (se.expr);
- /* If this is a variable or address of a variable we use it directly.
+ /* If this is a variable or address or a class array, use it directly.
Otherwise we must evaluate it now to avoid breaking dependency
analysis by pulling the expressions for elemental array indices
inside the loop. */
if (!(DECL_P (tmp)
|| (TREE_CODE (tmp) == ADDR_EXPR
- && DECL_P (TREE_OPERAND (tmp, 0)))))
+ && DECL_P (TREE_OPERAND (tmp, 0)))
+ || (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se.expr))
+ && TREE_CODE (se.expr) == COMPONENT_REF
+ && GFC_CLASS_TYPE_P (TREE_TYPE (TREE_OPERAND (se.expr, 0))))))
tmp = gfc_evaluate_now (tmp, block);
info->data = tmp;
@@ -3373,18 +3519,10 @@ build_class_array_ref (gfc_se *se, tree base, tree index)
size = gfc_class_vtab_size_get (decl);
/* For unlimited polymorphic entities then _len component needs to be
- multiplied with the size. If no _len component is present, then
- gfc_class_len_or_zero_get () return a zero_node. */
- tmp = gfc_class_len_or_zero_get (decl);
- if (!integer_zerop (tmp))
- size = fold_build2 (MULT_EXPR, TREE_TYPE (index),
- fold_convert (TREE_TYPE (index), size),
- fold_build2 (MAX_EXPR, TREE_TYPE (index),
- fold_convert (TREE_TYPE (index), tmp),
- fold_convert (TREE_TYPE (index),
- integer_one_node)));
- else
- size = fold_convert (TREE_TYPE (index), size);
+ multiplied with the size. */
+ size = gfc_resize_class_size_with_len (&se->pre, decl, size);
+
+ size = fold_convert (TREE_TYPE (index), size);
/* Build the address of the element. */
type = TREE_TYPE (TREE_TYPE (base));
@@ -9233,21 +9371,9 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
for the malloc call. */
if (UNLIMITED_POLY (c))
{
- tree ctmp;
gfc_add_modify (&tmpblock, gfc_class_len_get (dcmp),
gfc_class_len_get (comp));
-
- size = gfc_evaluate_now (size, &tmpblock);
- tmp = gfc_class_len_get (comp);
- ctmp = fold_build2_loc (input_location, MULT_EXPR,
- size_type_node, size,
- fold_convert (size_type_node, tmp));
- tmp = fold_build2_loc (input_location, GT_EXPR,
- logical_type_node, tmp,
- build_zero_cst (TREE_TYPE (tmp)));
- size = fold_build3_loc (input_location, COND_EXPR,
- size_type_node, tmp, ctmp, size);
- size = gfc_evaluate_now (size, &tmpblock);
+ size = gfc_resize_class_size_with_len (&tmpblock, comp, size);
}
/* Coarray component have to have the same allocation status and
@@ -10033,6 +10159,8 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop,
tree alloc_expr;
tree size1;
tree size2;
+ tree elemsize1;
+ tree elemsize2;
tree array1;
tree cond_null;
tree cond;
@@ -10112,6 +10240,108 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop,
gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)));
array1 = gfc_conv_descriptor_data_get (desc);
+ if (expr2)
+ desc2 = rss->info->data.array.descriptor;
+ else
+ desc2 = NULL_TREE;
+
+ /* Get the old lhs element size for deferred character and class expr1. */
+ if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
+ {
+ if (expr1->ts.u.cl->backend_decl
+ && VAR_P (expr1->ts.u.cl->backend_decl))
+ elemsize1 = expr1->ts.u.cl->backend_decl;
+ else
+ elemsize1 = lss->info->string_length;
+ }
+ else if (expr1->ts.type == BT_CLASS)
+ {
+ tmp = expr1->rank ? gfc_get_class_from_expr (desc) : NULL_TREE;
+ if (tmp != NULL_TREE)
+ {
+ tmp2 = gfc_class_vptr_get (tmp);
+ cond = fold_build2_loc (input_location, NE_EXPR,
+ logical_type_node, tmp2,
+ build_int_cst (TREE_TYPE (tmp2), 0));
+ elemsize1 = gfc_class_vtab_size_get (tmp);
+ elemsize1 = fold_build3_loc (input_location, COND_EXPR,
+ gfc_array_index_type, cond,
+ elemsize1, gfc_index_zero_node);
+ }
+ else
+ elemsize1 = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&CLASS_DATA (expr1)->ts));
+ }
+ else
+ elemsize1 = NULL_TREE;
+ if (elemsize1 != NULL_TREE)
+ elemsize1 = gfc_evaluate_now (elemsize1, &fblock);
+
+ /* Get the new lhs size in bytes. */
+ if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
+ {
+ if (expr2->ts.deferred)
+ {
+ if (expr2->ts.u.cl->backend_decl
+ && VAR_P (expr2->ts.u.cl->backend_decl))
+ tmp = expr2->ts.u.cl->backend_decl;
+ else
+ tmp = rss->info->string_length;
+ }
+ else
+ {
+ tmp = expr2->ts.u.cl->backend_decl;
+ if (!tmp && expr2->expr_type == EXPR_OP
+ && expr2->value.op.op == INTRINSIC_CONCAT)
+ {
+ tmp = concat_str_length (expr2);
+ expr2->ts.u.cl->backend_decl = gfc_evaluate_now (tmp, &fblock);
+ }
+ else if (!tmp && expr2->ts.u.cl->length)
+ {
+ gfc_se tmpse;
+ gfc_init_se (&tmpse, NULL);
+ gfc_conv_expr_type (&tmpse, expr2->ts.u.cl->length,
+ gfc_charlen_type_node);
+ tmp = tmpse.expr;
+ expr2->ts.u.cl->backend_decl = gfc_evaluate_now (tmp, &fblock);
+ }
+ tmp = fold_convert (TREE_TYPE (expr1->ts.u.cl->backend_decl), tmp);
+ }
+
+ if (expr1->ts.u.cl->backend_decl
+ && VAR_P (expr1->ts.u.cl->backend_decl))
+ gfc_add_modify (&fblock, expr1->ts.u.cl->backend_decl, tmp);
+ else
+ gfc_add_modify (&fblock, lss->info->string_length, tmp);
+
+ if (expr1->ts.kind > 1)
+ tmp = fold_build2_loc (input_location, MULT_EXPR,
+ TREE_TYPE (tmp),
+ tmp, build_int_cst (TREE_TYPE (tmp),
+ expr1->ts.kind));
+ }
+ else if (expr1->ts.type == BT_CHARACTER && expr1->ts.u.cl->backend_decl)
+ {
+ tmp = TYPE_SIZE_UNIT (TREE_TYPE (gfc_typenode_for_spec (&expr1->ts)));
+ tmp = fold_build2_loc (input_location, MULT_EXPR,
+ gfc_array_index_type, tmp,
+ expr1->ts.u.cl->backend_decl);
+ }
+ else if (UNLIMITED_POLY (expr1) && expr2->ts.type != BT_CLASS)
+ tmp = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr2->ts));
+ else if (expr1->ts.type == BT_CLASS && expr2->ts.type == BT_CLASS)
+ {
+ tmp = expr2->rank ? gfc_get_class_from_expr (desc2) : NULL_TREE;
+ if (tmp != NULL_TREE)
+ tmp = gfc_class_vtab_size_get (tmp);
+ else
+ tmp = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&CLASS_DATA (expr2)->ts));
+ }
+ else
+ tmp = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr2->ts));
+ elemsize2 = fold_convert (gfc_array_index_type, tmp);
+ elemsize2 = gfc_evaluate_now (elemsize2, &fblock);
+
/* 7.4.1.3 "If variable is an allocated allocatable variable, it is
deallocated if expr is an array of different shape or any of the
corresponding length type parameter values of variable and expr
@@ -10131,6 +10361,7 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop,
rss->info->string_length);
cond_null = fold_build2_loc (input_location, TRUTH_OR_EXPR,
logical_type_node, tmp, cond_null);
+ cond_null= gfc_evaluate_now (cond_null, &fblock);
}
else
cond_null= gfc_evaluate_now (cond_null, &fblock);
@@ -10179,6 +10410,19 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop,
gfc_add_expr_to_block (&fblock, tmp);
}
+ /* ...else if the element lengths are not the same also go to
+ setting the bounds and doing the reallocation.... */
+ if (elemsize1 != NULL_TREE)
+ {
+ cond = fold_build2_loc (input_location, NE_EXPR,
+ logical_type_node,
+ elemsize1, elemsize2);
+ tmp = build3_v (COND_EXPR, cond,
+ build1_v (GOTO_EXPR, jump_label1),
+ build_empty_stmt (input_location));
+ gfc_add_expr_to_block (&fblock, tmp);
+ }
+
/* ....else jump past the (re)alloc code. */
tmp = build1_v (GOTO_EXPR, jump_label2);
gfc_add_expr_to_block (&fblock, tmp);
@@ -10201,11 +10445,6 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop,
gfc_add_expr_to_block (&fblock, tmp);
/* Get the rhs size and fix it. */
- if (expr2)
- desc2 = rss->info->data.array.descriptor;
- else
- desc2 = NULL_TREE;
-
size2 = gfc_index_one_node;
for (n = 0; n < expr2->rank; n++)
{
@@ -10320,69 +10559,12 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop,
gfc_add_modify (&fblock, linfo->delta[dim], tmp);
}
- /* Get the new lhs size in bytes. */
- if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
- {
- if (expr2->ts.deferred)
- {
- if (expr2->ts.u.cl->backend_decl
- && VAR_P (expr2->ts.u.cl->backend_decl))
- tmp = expr2->ts.u.cl->backend_decl;
- else
- tmp = rss->info->string_length;
- }
- else
- {
- tmp = expr2->ts.u.cl->backend_decl;
- if (!tmp && expr2->expr_type == EXPR_OP
- && expr2->value.op.op == INTRINSIC_CONCAT)
- {
- tmp = concat_str_length (expr2);
- expr2->ts.u.cl->backend_decl = gfc_evaluate_now (tmp, &fblock);
- }
- else if (!tmp && expr2->ts.u.cl->length)
- {
- gfc_se tmpse;
- gfc_init_se (&tmpse, NULL);
- gfc_conv_expr_type (&tmpse, expr2->ts.u.cl->length,
- gfc_charlen_type_node);
- tmp = tmpse.expr;
- expr2->ts.u.cl->backend_decl = gfc_evaluate_now (tmp, &fblock);
- }
- tmp = fold_convert (TREE_TYPE (expr1->ts.u.cl->backend_decl), tmp);
- }
-
- if (expr1->ts.u.cl->backend_decl
- && VAR_P (expr1->ts.u.cl->backend_decl))
- gfc_add_modify (&fblock, expr1->ts.u.cl->backend_decl, tmp);
- else
- gfc_add_modify (&fblock, lss->info->string_length, tmp);
-
- if (expr1->ts.kind > 1)
- tmp = fold_build2_loc (input_location, MULT_EXPR,
- TREE_TYPE (tmp),
- tmp, build_int_cst (TREE_TYPE (tmp),
- expr1->ts.kind));
- }
- else if (expr1->ts.type == BT_CHARACTER && expr1->ts.u.cl->backend_decl)
- {
- tmp = TYPE_SIZE_UNIT (TREE_TYPE (gfc_typenode_for_spec (&expr1->ts)));
- tmp = fold_build2_loc (input_location, MULT_EXPR,
- gfc_array_index_type, tmp,
- expr1->ts.u.cl->backend_decl);
- }
- else if (UNLIMITED_POLY (expr1) && expr2->ts.type != BT_CLASS)
- tmp = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr2->ts));
- else
- tmp = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr1->ts));
- tmp = fold_convert (gfc_array_index_type, tmp);
-
if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
- gfc_conv_descriptor_span_set (&fblock, desc, tmp);
+ gfc_conv_descriptor_span_set (&fblock, desc, elemsize2);
size2 = fold_build2_loc (input_location, MULT_EXPR,
gfc_array_index_type,
- tmp, size2);
+ elemsize2, size2);
size2 = fold_convert (size_type_node, size2);
size2 = fold_build2_loc (input_location, MAX_EXPR, size_type_node,
size2, size_one_node);
@@ -10403,27 +10585,45 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop,
gfc_add_modify (&fblock, tmp,
gfc_get_dtype_rank_type (expr1->rank,type));
}
- else if (UNLIMITED_POLY (expr1) && expr2->ts.type != BT_CLASS)
+ else if (expr1->ts.type == BT_CLASS)
{
tree type;
tmp = gfc_conv_descriptor_dtype (desc);
- type = gfc_typenode_for_spec (&expr2->ts);
+
+ if (expr2->ts.type != BT_CLASS)
+ type = gfc_typenode_for_spec (&expr2->ts);
+ else
+ type = gfc_get_character_type_len (1, elemsize2);
+
gfc_add_modify (&fblock, tmp,
gfc_get_dtype_rank_type (expr2->rank,type));
/* Set the _len field as well... */
- tmp = gfc_class_len_get (TREE_OPERAND (desc, 0));
- if (expr2->ts.type == BT_CHARACTER)
- gfc_add_modify (&fblock, tmp,
- fold_convert (TREE_TYPE (tmp),
- TYPE_SIZE_UNIT (type)));
- else
- gfc_add_modify (&fblock, tmp,
- build_int_cst (TREE_TYPE (tmp), 0));
+ if (UNLIMITED_POLY (expr1))
+ {
+ tmp = gfc_class_len_get (TREE_OPERAND (desc, 0));
+ if (expr2->ts.type == BT_CHARACTER)
+ gfc_add_modify (&fblock, tmp,
+ fold_convert (TREE_TYPE (tmp),
+ TYPE_SIZE_UNIT (type)));
+ else
+ gfc_add_modify (&fblock, tmp,
+ build_int_cst (TREE_TYPE (tmp), 0));
+ }
/* ...and the vptr. */
tmp = gfc_class_vptr_get (TREE_OPERAND (desc, 0));
- tmp2 = gfc_get_symbol_decl (gfc_find_vtab (&expr2->ts));
- tmp2 = gfc_build_addr_expr (TREE_TYPE (tmp), tmp2);
- gfc_add_modify (&fblock, tmp, tmp2);
+ if (expr2->ts.type == BT_CLASS && !VAR_P (desc2)
+ && TREE_CODE (desc2) == COMPONENT_REF)
+ {
+ tmp2 = gfc_get_class_from_expr (desc2);
+ tmp2 = gfc_class_vptr_get (tmp2);
+ }
+ else
+ {
+ tmp2 = gfc_get_symbol_decl (gfc_find_vtab (&expr2->ts));
+ tmp2 = gfc_build_addr_expr (TREE_TYPE (tmp), tmp2);
+ }
+
+ gfc_add_modify (&fblock, tmp, fold_convert (TREE_TYPE (tmp), tmp2));
}
else if (coarray && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
{
@@ -10499,11 +10699,19 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop,
gfc_add_block_to_block (&realloc_block, &caf_se.post);
realloc_expr = gfc_finish_block (&realloc_block);
- /* Only reallocate if sizes are different. */
+ /* Reallocate if sizes or dynamic types are different. */
+ if (elemsize1)
+ {
+ tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
+ elemsize1, elemsize2);
+ tmp = gfc_evaluate_now (tmp, &fblock);
+ neq_size = fold_build2_loc (input_location, TRUTH_OR_EXPR,
+ logical_type_node, neq_size, tmp);
+ }
tmp = build3_v (COND_EXPR, neq_size, realloc_expr,
build_empty_stmt (input_location));
- realloc_expr = tmp;
+ realloc_expr = tmp;
/* Malloc expression. */
gfc_init_block (&alloc_block);
@@ -10550,11 +10758,7 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop,
alloc_expr = gfc_finish_block (&alloc_block);
/* Malloc if not allocated; realloc otherwise. */
- tmp = build_int_cst (TREE_TYPE (array1), 0);
- cond = fold_build2_loc (input_location, EQ_EXPR,
- logical_type_node,
- array1, tmp);
- tmp = build3_v (COND_EXPR, cond, alloc_expr, realloc_expr);
+ tmp = build3_v (COND_EXPR, cond_null, alloc_expr, realloc_expr);
gfc_add_expr_to_block (&fblock, tmp);
/* Make sure that the scalarizer data pointer is updated. */
@@ -10564,7 +10768,7 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop,
gfc_add_modify (&fblock, linfo->data, tmp);
}
- /* Add the exit label. */
+ /* Add the label for same shape lhs and rhs. */
tmp = build1_v (LABEL_EXPR, jump_label2);
gfc_add_expr_to_block (&fblock, tmp);
diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index 2167de455b8..bfe08be2a94 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -257,6 +257,42 @@ gfc_class_len_or_zero_get (tree decl)
}
+tree
+gfc_resize_class_size_with_len (stmtblock_t * block, tree class_expr, tree size)
+{
+ tree tmp;
+ tree tmp2;
+ tree type;
+
+ tmp = gfc_class_len_or_zero_get (class_expr);
+
+ /* Include the len value in the element size if present. */
+ if (!integer_zerop (tmp))
+ {
+ type = TREE_TYPE (size);
+ if (block)
+ {
+ size = gfc_evaluate_now (size, block);
+ tmp = gfc_evaluate_now (fold_convert (type , tmp), block);
+ }
+ tmp2 = fold_build2_loc (input_location, MULT_EXPR,
+ type, size, tmp);
+ tmp = fold_build2_loc (input_location, GT_EXPR,
+ logical_type_node, tmp,
+ build_zero_cst (type));
+ size = fold_build3_loc (input_location, COND_EXPR,
+ type, tmp, tmp2, size);
+ }
+ else
+ return size;
+
+ if (block)
+ size = gfc_evaluate_now (size, block);
+
+ return size;
+}
+
+
/* Get the specified FIELD from the VPTR. */
static tree
@@ -483,6 +519,9 @@ gfc_get_class_from_expr (tree expr)
for (tmp = expr; tmp; tmp = TREE_OPERAND (tmp, 0))
{
+ if (CONSTANT_CLASS_P (tmp))
+ return NULL_TREE;
+
type = TREE_TYPE (tmp);
while (type)
{
@@ -1606,6 +1645,111 @@ gfc_trans_class_init_assign (gfc_code *code)
}
+/* Class valued elemental function calls or class array elements arriving
+ in gfc_trans_scalar_assign come here. Wherever possible the vptr copy
+ is used to ensure that the rhs dynamic type is assigned to the lhs. */
+
+static bool
+trans_scalar_class_assign (stmtblock_t *block, gfc_se *lse, gfc_se *rse)
+{
+ tree fcn;
+ tree rse_expr;
+ tree class_data;
+ tree tmp;
+ tree zero;
+ tree cond;
+ tree final_cond;
+ stmtblock_t inner_block;
+ bool is_descriptor;
+ bool not_call_expr = TREE_CODE (rse->expr) != CALL_EXPR;
+ bool not_lhs_array_type;
+
+ /* Temporaries arising from depencies in assignment get cast as a
+ character type of the dynamic size of the rhs. Use the vptr copy
+ for this case. */
+ tmp = TREE_TYPE (lse->expr);
+ not_lhs_array_type = !(tmp && TREE_CODE (tmp) == ARRAY_TYPE
+ && TYPE_MAX_VALUE (TYPE_DOMAIN (tmp)) != NULL_TREE);
+
+ /* Use ordinary assignment if the rhs is not a call expression or
+ the lhs is not a class entity or an array(ie. character) type. */
+ if ((not_call_expr && gfc_get_class_from_expr (lse->expr) == NULL_TREE)
+ && not_lhs_array_type)
+ return false;
+
+ /* Ordinary assignment can be used if both sides are class expressions
+ since the dynamic type is preserved by copying the vptr. This
+ should only occur, where temporaries are involved. */
+ if (GFC_CLASS_TYPE_P (TREE_TYPE (lse->expr))
+ && GFC_CLASS_TYPE_P (TREE_TYPE (rse->expr)))
+ return false;
+
+ /* Fix the class expression and the class data of the rhs. */
+ if (!GFC_CLASS_TYPE_P (TREE_TYPE (rse->expr))
+ || not_call_expr)
+ {
+ tmp = gfc_get_class_from_expr (rse->expr);
+ if (tmp == NULL_TREE)
+ return false;
+ rse_expr = gfc_evaluate_now (tmp, block);
+ }
+ else
+ rse_expr = gfc_evaluate_now (rse->expr, block);
+
+ class_data = gfc_class_data_get (rse_expr);
+
+ /* Check that the rhs data is not null. */
+ is_descriptor = GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (class_data));
+ if (is_descriptor)
+ class_data = gfc_conv_descriptor_data_get (class_data);
+ class_data = gfc_evaluate_now (class_data, block);
+
+ zero = build_int_cst (TREE_TYPE (class_data), 0);
+ cond = fold_build2_loc (input_location, NE_EXPR,
+ logical_type_node,
+ class_data, zero);
+
+ /* Copy the rhs to the lhs. */
+ fcn = gfc_vptr_copy_get (gfc_class_vptr_get (rse_expr));
+ fcn = build_fold_indirect_ref_loc (input_location, fcn);
+ tmp = gfc_evaluate_now (gfc_build_addr_expr (NULL, rse->expr), block);
+ tmp = is_descriptor ? tmp : class_data;
+ tmp = build_call_expr_loc (input_location, fcn, 2, tmp,
+ gfc_build_addr_expr (NULL, lse->expr));
+ gfc_add_expr_to_block (block, tmp);
+
+ /* Only elemental function results need to be finalised and freed. */
+ if (not_call_expr)
+ return true;
+
+ /* Finalize the class data if needed. */
+ gfc_init_block (&inner_block);
+ fcn = gfc_vptr_final_get (gfc_class_vptr_get (rse_expr));
+ zero = build_int_cst (TREE_TYPE (fcn), 0);
+ final_cond = fold_build2_loc (input_location, NE_EXPR,
+ logical_type_node, fcn, zero);
+ fcn = build_fold_indirect_ref_loc (input_location, fcn);
+ tmp = build_call_expr_loc (input_location, fcn, 1, class_data);
+ tmp = build3_v (COND_EXPR, final_cond,
+ tmp, build_empty_stmt (input_location));
+ gfc_add_expr_to_block (&inner_block, tmp);
+
+ /* Free the class data. */
+ tmp = gfc_call_free (class_data);
+ tmp = build3_v (COND_EXPR, cond, tmp,
+ build_empty_stmt (input_location));
+ gfc_add_expr_to_block (&inner_block, tmp);
+
+ /* Finish the inner block and subject it to the condition on the
+ class data being non-zero. */
+ tmp = gfc_finish_block (&inner_block);
+ tmp = build3_v (COND_EXPR, cond, tmp,
+ build_empty_stmt (input_location));
+ gfc_add_expr_to_block (block, tmp);
+
+ return true;
+}
+
/* End of prototype trans-class.c */
@@ -5613,8 +5757,10 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
{
/* The intrinsic type needs to be converted to a temporary
CLASS object for the unlimited polymorphic formal. */
+ gfc_find_vtab (&e->ts);
gfc_init_se (&parmse, se);
gfc_conv_intrinsic_to_class (&parmse, e, fsym->ts);
+
}
else if (se->ss && se->ss->info->useflags)
{
@@ -8926,14 +9072,32 @@ trans_class_vptr_len_assignment (stmtblock_t *block, gfc_expr * le,
tree tmp, to_len = NULL_TREE, from_len = NULL_TREE, lhs_vptr;
bool set_vptr = false, temp_rhs = false;
stmtblock_t *pre = block;
+ tree class_expr = NULL_TREE;
/* Create a temporary for complicated expressions. */
if (re->expr_type != EXPR_VARIABLE && re->expr_type != EXPR_NULL
&& rse->expr != NULL_TREE && !DECL_P (rse->expr))
{
- tmp = gfc_create_var (TREE_TYPE (rse->expr), "rhs");
- pre = &rse->pre;
- gfc_add_modify (&rse->pre, tmp, rse->expr);
+ if (re->ts.type == BT_CLASS && !GFC_CLASS_TYPE_P (TREE_TYPE (rse->expr)))
+ class_expr = gfc_get_class_from_expr (rse->expr);
+
+ if (rse->loop)
+ pre = &rse->loop->pre;
+ else
+ pre = &rse->pre;
+
+ if (class_expr != NULL_TREE && UNLIMITED_POLY (re))
+ {
+ tmp = TREE_OPERAND (rse->expr, 0);
+ tmp = gfc_create_var (TREE_TYPE (tmp), "rhs");
+ gfc_add_modify (&rse->pre, tmp, TREE_OPERAND (rse->expr, 0));
+ }
+ else
+ {
+ tmp = gfc_create_var (TREE_TYPE (rse->expr), "rhs");
+ gfc_add_modify (&rse->pre, tmp, rse->expr);
+ }
+
rse->expr = tmp;
temp_rhs = true;
}
@@ -9001,9 +9165,17 @@ trans_class_vptr_len_assignment (stmtblock_t *block, gfc_expr * le,
else if (temp_rhs && re->ts.type == BT_CLASS)
{
vptr_expr = NULL;
- se.expr = gfc_class_vptr_get (rse->expr);
+ if (class_expr)
+ tmp = class_expr;
+ else if (!GFC_CLASS_TYPE_P (TREE_TYPE (rse->expr)))
+ tmp = gfc_get_class_from_expr (rse->expr);
+ else
+ tmp = rse->expr;
+
+ se.expr = gfc_class_vptr_get (tmp);
if (UNLIMITED_POLY (re))
- from_len = gfc_class_len_get (rse->expr);
+ from_len = gfc_class_len_get (tmp);
+
}
else if (re->expr_type != EXPR_NULL)
/* Only when rhs is non-NULL use its declared type for vptr
@@ -9750,7 +9922,7 @@ gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, gfc_typespec ts,
gfc_add_expr_to_block (&block, tmp);
}
}
- else if (gfc_bt_struct (ts.type) || ts.type == BT_CLASS)
+ else if (gfc_bt_struct (ts.type))
{
gfc_add_block_to_block (&block, &lse->pre);
gfc_add_block_to_block (&block, &rse->pre);
@@ -9758,7 +9930,20 @@ gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, gfc_typespec ts,
TREE_TYPE (lse->expr), rse->expr);
gfc_add_modify (&block, lse->expr, tmp);
}
- else
+ /* If possible use the rhs vptr copy with trans_scalar_class_assign.... */
+ else if (ts.type == BT_CLASS
+ && !trans_scalar_class_assign (&block, lse, rse))
+ {
+ gfc_add_block_to_block (&block, &lse->pre);
+ gfc_add_block_to_block (&block, &rse->pre);
+ /* ...otherwise assignment suffices. Note the use of VIEW_CONVERT_EXPR
+ for the lhs which ensures that class data rhs cast as a string assigns
+ correctly. */
+ tmp = fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
+ TREE_TYPE (rse->expr), lse->expr);
+ gfc_add_modify (&block, tmp, rse->expr);
+ }
+ else if (ts.type != BT_CLASS)
{
gfc_add_block_to_block (&block, &lse->pre);
gfc_add_block_to_block (&block, &rse->pre);
@@ -10666,23 +10851,53 @@ trans_class_assignment (stmtblock_t *block, gfc_expr *lhs, gfc_expr *rhs,
gfc_se *lse, gfc_se *rse, bool use_vptr_copy,
bool class_realloc)
{
- tree tmp, fcn, stdcopy, to_len, from_len, vptr;
+ tree tmp, fcn, stdcopy, to_len, from_len, vptr, old_vptr;
vec<tree, va_gc> *args = NULL;
+ /* Store the old vptr so that dynamic types can be compared for
+ reallocation to occur or not. */
+ if (class_realloc)
+ {
+ tmp = lse->expr;
+ if (!GFC_CLASS_TYPE_P (TREE_TYPE (tmp)))
+ tmp = gfc_get_class_from_expr (tmp);
+ }
+
vptr = trans_class_vptr_len_assignment (block, lhs, rhs, rse, &to_len,
&from_len);
- /* Generate allocation of the lhs. */
+ /* Generate (re)allocation of the lhs. */
if (class_realloc)
{
- stmtblock_t alloc;
- tree class_han;
+ stmtblock_t alloc, re_alloc;
+ tree class_han, re, size;
- tmp = gfc_vptr_size_get (vptr);
+ if (tmp && GFC_CLASS_TYPE_P (TREE_TYPE (tmp)))
+ old_vptr = gfc_evaluate_now (gfc_class_vptr_get (tmp), block);
+ else
+ old_vptr = build_int_cst (TREE_TYPE (vptr), 0);
+
+ size = gfc_vptr_size_get (vptr);
class_han = GFC_CLASS_TYPE_P (TREE_TYPE (lse->expr))
? gfc_class_data_get (lse->expr) : lse->expr;
+
+ /* Allocate block. */
gfc_init_block (&alloc);
- gfc_allocate_using_malloc (&alloc, class_han, tmp, NULL_TREE);
+ gfc_allocate_using_malloc (&alloc, class_han, size, NULL_TREE);
+
+ /* Reallocate if dynamic types are different. */
+ gfc_init_block (&re_alloc);
+ re = build_call_expr_loc (input_location,
+ builtin_decl_explicit (BUILT_IN_REALLOC), 2,
+ fold_convert (pvoid_type_node, class_han),
+ size);
+ tmp = fold_build2_loc (input_location, NE_EXPR,
+ logical_type_node, vptr, old_vptr);
+ re = fold_build3_loc (input_location, COND_EXPR, void_type_node,
+ tmp, re, build_empty_stmt (input_location));
+ gfc_add_expr_to_block (&re_alloc, re);
+
+ /* Allocate if _data is NULL, reallocate otherwise. */
tmp = fold_build2_loc (input_location, EQ_EXPR,
logical_type_node, class_han,
build_int_cst (prvoid_type_node, 0));
@@ -10690,7 +10905,7 @@ trans_class_assignment (stmtblock_t *block, gfc_expr *lhs, gfc_expr *rhs,
gfc_unlikely (tmp,
PRED_FORTRAN_FAIL_ALLOC),
gfc_finish_block (&alloc),
- build_empty_stmt (input_location));
+ gfc_finish_block (&re_alloc));
gfc_add_expr_to_block (&lse->pre, tmp);
}
@@ -10793,6 +11008,7 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
bool maybe_workshare = false, lhs_refs_comp = false, rhs_refs_comp = false;
symbol_attribute lhs_caf_attr, rhs_caf_attr, lhs_attr;
bool is_poly_assign;
+ bool realloc_flag;
/* Assignment of the form lhs = rhs. */
gfc_start_block (&block);
@@ -10833,6 +11049,10 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
|| gfc_is_class_array_ref (expr2, NULL)
|| gfc_is_class_scalar_expr (expr2));
+ realloc_flag = flag_realloc_lhs
+ && gfc_is_reallocatable_lhs (expr1)
+ && expr2->rank
+ && !is_runtime_conformable (expr1, expr2);
/* Only analyze the expressions for coarray properties, when in coarray-lib
mode. */
@@ -11077,8 +11297,9 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
if (is_poly_assign)
tmp = trans_class_assignment (&body, expr1, expr2, &lse, &rse,
use_vptr_copy || (lhs_attr.allocatable
- && !lhs_attr.dimension),
- flag_realloc_lhs && !lhs_attr.pointer);
+ && !lhs_attr.dimension),
+ !realloc_flag && flag_realloc_lhs
+ && !lhs_attr.pointer);
else if (flag_coarray == GFC_FCOARRAY_LIB
&& lhs_caf_attr.codimension && rhs_caf_attr.codimension
&& ((lhs_caf_attr.allocatable && lhs_refs_comp)
@@ -11108,7 +11329,8 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
{
/* This case comes about when the scalarizer provides array element
references. Use the vptr copy function, since this does a deep
- copy of allocatable components, without which the finalizer call */
+ copy of allocatable components, without which the finalizer call
+ will deallocate the components. */
tmp = gfc_get_vptr_from_expr (rse.expr);
if (tmp != NULL_TREE)
{
@@ -11183,10 +11405,7 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
}
/* F2003: Allocate or reallocate lhs of allocatable array. */
- if (flag_realloc_lhs
- && gfc_is_reallocatable_lhs (expr1)
- && expr2->rank
- && !is_runtime_conformable (expr1, expr2))
+ if (realloc_flag)
{
realloc_lhs_warning (expr1->ts.type, true, &expr1->where);
ompws_flags &= ~OMPWS_SCALARIZER_WS;
@@ -11295,8 +11514,7 @@ gfc_trans_assignment (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
return tmp;
}
- if (UNLIMITED_POLY (expr1) && expr1->rank
- && expr2->ts.type != BT_CLASS)
+ if (UNLIMITED_POLY (expr1) && expr1->rank)
use_vptr_copy = true;
/* Fallback to the scalarizer to generate explicit loops. */
diff --git a/gcc/fortran/trans.c b/gcc/fortran/trans.c
index 025abe38985..a1239ec2b53 100644
--- a/gcc/fortran/trans.c
+++ b/gcc/fortran/trans.c
@@ -435,21 +435,7 @@ gfc_build_array_ref (tree base, tree offset, tree decl, tree vptr)
/* Check if this is an unlimited polymorphic object carrying a character
payload. In this case, the 'len' field is non-zero. */
if (decl && GFC_CLASS_TYPE_P (TREE_TYPE (decl)))
- {
- tmp = gfc_class_len_or_zero_get (decl);
- if (!integer_zerop (tmp))
- {
- tree cond;
- tree stype = TREE_TYPE (span);
- tmp = fold_convert (stype, tmp);
- cond = fold_build2_loc (input_location, EQ_EXPR,
- logical_type_node, tmp,
- build_int_cst (stype, 0));
- tmp = fold_build2 (MULT_EXPR, stype, span, tmp);
- span = fold_build3_loc (input_location, COND_EXPR, stype,
- cond, span, tmp);
- }
- }
+ span = gfc_resize_class_size_with_len (NULL, decl, span);
}
else if (decl)
span = get_array_span (type, decl);
diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h
index 16b4215605e..437a570c484 100644
--- a/gcc/fortran/trans.h
+++ b/gcc/fortran/trans.h
@@ -423,6 +423,7 @@ tree gfc_class_data_get (tree);
tree gfc_class_vptr_get (tree);
tree gfc_class_len_get (tree);
tree gfc_class_len_or_zero_get (tree);
+tree gfc_resize_class_size_with_len (stmtblock_t *, tree, tree);
gfc_expr * gfc_find_and_cut_at_last_class_ref (gfc_expr *, bool is_mold = false);
/* Get an accessor to the class' vtab's * field, when a class handle is
available. */
diff --git a/gcc/testsuite/gfortran.dg/dependency_57.f90 b/gcc/testsuite/gfortran.dg/dependency_57.f90
index fdf95b24c63..e8aab334b62 100644
--- a/gcc/testsuite/gfortran.dg/dependency_57.f90
+++ b/gcc/testsuite/gfortran.dg/dependency_57.f90
@@ -1,12 +1,18 @@
-! { dg-do compile }
+! { dg-do run }
! PR 92755 - this used to cause an ICE.
! Original test case by Gerhard Steinmetz
program p
type t
+ integer :: i
end type
type t2
class(t), allocatable :: a(:)
end type
type(t2) :: z
+ z%a = [t(1),t(2),t(3)]
z%a = [z%a]
+ select type (y => z%a)
+ type is (t)
+ if (any (y%i .ne. [1, 2, 3])) stop 1
+ end select
end
[-- Attachment #3: class_assign_4.f90 --]
[-- Type: text/x-fortran, Size: 4569 bytes --]
! { dg-do run }
!
! In the course of fixing PR83118, lots of issues came up with class array
! assignment, where temporaries are generated. This testcase checks that
! it all works correctly.
!
! Contributed by Paul Thomas <pault@gcc.gnu.org>
!
module m
implicit none
type :: t1
integer :: i
CONTAINS
PROCEDURE :: add_t1
GENERIC :: OPERATOR(+) => add_t1
end type
type, extends(t1) :: t2
real :: r
end type
contains
impure elemental function add_t1 (a, b) result (c)
class(t1), intent(in) :: a, b
class(t1), allocatable :: c
allocate (c, source = a)
c%i = a%i + b%i
select type (c)
type is (t2)
select type (b)
type is (t2)
c%r = c%r + b%r
end select
end select
end function add_t1
end module m
subroutine test_t1
use m
implicit none
class(t1), dimension(:), allocatable :: x, y
x = [t2(1,10.0),t2(2,20.0),t2(3,30.0)]
if (.not.check_t1 (x, [1,2,3], 2, [10, 20, 30]) ) stop 1
y = x
x = realloc_t1 (y)
if (.not.check_t1 (x, [3,2,1], 1) ) stop 2
x = realloc_t1 (x)
if (.not.check_t1 (x, [2,3,1], 1) ) stop 3
x = x([3,1,2])
if (.not.check_t1 (x, [1,2,3], 1) ) stop 4
x = x(3:1:-1) + y
if (.not.check_t1 (x, [4,4,4], 1) ) stop 5
x = y + x(3:1:-1)
if (.not.check_t1 (x, [5,6,7], 2) ) stop 6
! Now check that the dynamic type survives assignments.
x = [t2(1,10.0),t2(2,20.0),t2(3,30.0)]
y = x
x = y(3:1:-1)
if (.not.check_t1 (x, [3,2,1], 2, [30,20,10]) ) stop 7
x = x(3:1:-1) + y
if (.not.check_t1 (x, [2,4,6], 2, [20,40,60]) ) stop 8
x = x(3:1:-1)
if (.not.check_t1 (x, [6,4,2], 2, [60,40,20]) ) stop 9
x = x([3,2,1])
if (.not.check_t1 (x, [2,4,6], 2, [20,40,60]) ) stop 10
contains
function realloc_t1 (arg) result (res)
class(t1), dimension(:), allocatable :: arg
class(t1), dimension(:), allocatable :: res
select type (arg)
type is (t2)
allocate (res, source = [t1 (arg(3)%i), t1 (arg(2)%i), t1 (arg(1)%i)])
type is (t1)
allocate (res, source = [t1 (arg(2)%i), t1 (arg(1)%i), t1 (arg(3)%i)])
end select
end function realloc_t1
logical function check_t1 (arg, array, t, array2)
class(t1) :: arg(:)
integer :: array (:), t
integer, optional :: array2(:)
check_t1 = .true.
select type (arg)
type is (t1)
if (any (arg%i .ne. array)) check_t1 = .false.
if (t .eq. 2) check_t1 = .false.
type is (t2)
if (any (arg%i .ne. array)) check_t1 = .false.
if (t .eq. 1) check_t1 = .false.
if (present (array2)) then
if (any(int (arg%r) .ne. array2)) check_t1 = .false.
end if
class default
check_t1 = .false.
end select
end function check_t1
end subroutine test_t1
subroutine test_star
use m
implicit none
class(*), dimension(:), allocatable :: x, y
x = [t2(1,10.0),t2(2,20.0),t2(3,30.0)]
if (.not.check_star (x, [1,2,3], 2) ) stop 11
y = x
x = realloc_star (y)
if (.not.check_star (x, [3,2,1], 1) ) stop 12
x = realloc_star (x)
if (.not.check_star (x, [2,3,1], 1) ) stop 13
x = x([3,1,2])
if (.not.check_star (x, [1,2,3], 1) ) stop 14
x = x(3:1:-1)
if (.not.check_star (x, [3,2,1], 1) ) stop 15
! Make sure that all is similarly well with type t2.
x = [t2(1,10.0),t2(2,20.0),t2(3,30.0)]
x = x([3,1,2])
if (.not.check_star (x, [3,1,2], 2, [30,10,20]) ) stop 16
x = x(3:1:-1)
if (.not.check_star (x, [2,1,3], 2, [20,10,30]) ) stop 17
contains
function realloc_star (arg) result (res)
class(*), dimension(:), allocatable :: arg
class(*), dimension(:), allocatable :: res
select type (arg)
type is (t2)
allocate (res, source = [t1 (arg(3)%i), t1 (arg(2)%i), t1 (arg(1)%i)])
type is (t1)
allocate (res, source = [t1 (arg(2)%i), t1 (arg(1)%i), t1 (arg(3)%i)])
end select
end function realloc_star
logical function check_star (arg, array, t, array2)
class(*) :: arg(:)
integer :: array (:), t
integer, optional :: array2(:)
check_star = .true.
select type (arg)
type is (t1)
if (any (arg%i .ne. array)) check_star = .false.
if (t .eq. 2) check_star = .false.
type is (t2)
if (any (arg%i .ne. array)) check_star = .false.
if (t .eq. 1) check_star = .false.
if (present (array2)) then
if (any (int(arg%r) .ne. array2)) check_star = .false.
endif
class default
check_star = .false.
end select
end function check_star
end subroutine test_star
call test_t1
call test_star
end
[-- Attachment #4: class_allocate_25.f90 --]
[-- Type: text/x-fortran, Size: 1667 bytes --]
! { dg-do run }
! { dg-options "-fdump-tree-original" }
!
! In the course of fixing PR83118, lots of issues came up with class array
! assignment, where temporaries are generated. This testcase checks that
! the use of assignment by allocate with source is OK, especially with array
! constructors using class arrays. While this test did run previously, the
! temporaries for such arrays were malformed with the class as the type and
! element lengths of 72 bytes rather than the 4 bytes of the decalred type.
!
! Contributed by Dominique d'Humieres <dhumieres.dominique@free.fr>
!
type t1
integer :: i = 5
end type t1
type, extends(t1) :: t2
integer :: j = 6
end type t2
class(t1), allocatable :: a(:), b(:), c(:)
integer :: i
allocate(t2 :: a(3))
allocate(t2 :: b(5))
if (.not.check_t1 (a, [(5, i = 1, 3)], 2)) stop 1
allocate(c, source=[a, b ]) ! F2008, PR 44672
if (.not.check_t1 (c, [(5, i = 1, 8)], 1)) stop 2
deallocate(c)
allocate(c(8), source=[ a, b ])
if (.not.check_t1 (c, [(5, i = 1, 8)], 1)) stop 3
deallocate(c)
c = [t1 :: a, b ] ! F2008, PR 43366
if (.not.check_t1 (c, [(5, i = 1, 8)], 1)) stop 4
deallocate(a, b, c)
contains
logical function check_t1 (arg, array, t)
class(t1) :: arg(:)
integer :: array (:), t
check_t1 = .true.
select type (arg)
type is (t1)
if (any (arg%i .ne. array)) check_t1 = .false.
if (t .eq. 2) check_t1 = .false.
type is (t2)
if (any (arg%i .ne. array)) check_t1 = .false.
if (t .eq. 1) check_t1 = .false.
class default
check_t1 = .false.
end select
end function check_t1
end
! { dg-final { scan-tree-dump-times "elem_len=72" 0 "original" } }
[-- Attachment #5: unlimited_polymorphic_32.f03 --]
[-- Type: application/octet-stream, Size: 1608 bytes --]
! { dg-do run }
!
! Test the fix of the test case referenced in comment 17 of PR83118.
!
! Contributed by Damian Rouson <damian@sourceryinstitute.org>
!
implicit none
type Wrapper
class(*), allocatable :: elements(:)
end type
type Mytype
real(4) :: r = 42.0
end type
call driver
contains
subroutine driver
class(*), allocatable :: obj
type(Wrapper) w
integer(4) :: expected4(2) = [42_4, 43_4]
integer(8) :: expected8(3) = [42_8, 43_8, 44_8]
w = new_wrapper (expected4)
obj = w
call test (obj, 0)
obj = new_wrapper (expected8) ! Used to generate a linker error
call test (obj, 10)
obj = new_wrapper ([mytype (99.0)])
call test (obj, 100)
obj = Mytype (42.0) ! Used to generate a linker error
call test (obj, 1000)
end subroutine
function new_wrapper(array) result (res)
class(*) :: array(:)
type(Wrapper) :: res
res%elements = array ! Used to runtime segfault
end function
subroutine test (arg, idx)
class(*) :: arg
integer :: idx
select type (arg)
type is (wrapper)
select type (z => arg%elements)
type is (integer(4))
if (any (z .ne. [42_4, 43_4])) stop 1 + idx
type is (integer(8))
if (any (z .ne. [42_8, 43_8, 44_8])) stop 1 + idx
type is (Mytype)
if (abs (z(1)%r - 99.0) .ge. 1e-6) stop 1 + idx
class default
stop 2 + idx
end select
type is (Mytype)
if (abs (arg%r - 42.0) .ge. 1e-6) stop 1 + idx
class default
stop 3 + idx
end select
end subroutine
end
^ permalink raw reply [flat|nested] 18+ messages in thread
* Re: [Patch, fortran] PR83118 - [8/9/10/11 Regression] Bad intrinsic assignment of class(*) array component of derived type
[not found] ` <CAGkQGiLv3tMGpOrQ8Cj7hLgbKNG+seiLG8de3VLufwg47SPD3g@mail.gmail.com>
@ 2020-12-06 17:14 ` dhumieres.dominique
0 siblings, 0 replies; 18+ messages in thread
From: dhumieres.dominique @ 2020-12-06 17:14 UTC (permalink / raw)
To: Paul Richard Thomas; +Cc: fortran
Hi Paul,
Your new patch regrets cleanly and fixes all the issues I have reported.
So far I didn't spot any new problem.
Thanks for the work,
Dominique
^ permalink raw reply [flat|nested] 18+ messages in thread
* Re: [Patch, fortran] PR83118 - [8/9/10/11 Regression] Bad intrinsic assignment of class(*) array component of derived type
2020-12-05 10:19 ` Paul Richard Thomas
@ 2020-12-12 18:31 ` Thomas Koenig
2020-12-18 14:04 ` Paul Richard Thomas
0 siblings, 1 reply; 18+ messages in thread
From: Thomas Koenig @ 2020-12-12 18:31 UTC (permalink / raw)
To: Paul Richard Thomas, dhumieres.dominique; +Cc: Tobias Burnus, fortran
Hi Paul,
> Regtests on x86_64/FC31 - OK for master and 10-branch?
Based on reading your patch and Dominique's tests, I'd say
OK for both, with the minor nit of leaving dependency_57.f90 as
is and creating a new test case from what you have in there
(and maybe wait for a week or so for backport to 10-branch).
Thanks a lot for that patch. That certainly was a hard nut to crack,
or rather a succession of several hard nuts :-)
I also would not be surprised if other bugs are fixed by this patch
as well, but time will tell.
Thanks a lot for taking this on!
Best regards
Thomas
^ permalink raw reply [flat|nested] 18+ messages in thread
* Re: [Patch, fortran] PR83118 - [8/9/10/11 Regression] Bad intrinsic assignment of class(*) array component of derived type
2020-12-12 18:31 ` Thomas Koenig
@ 2020-12-18 14:04 ` Paul Richard Thomas
2020-12-23 17:36 ` Paul Richard Thomas
0 siblings, 1 reply; 18+ messages in thread
From: Paul Richard Thomas @ 2020-12-18 14:04 UTC (permalink / raw)
To: Thomas Koenig; +Cc: dhumieres.dominique, Tobias Burnus, fortran
Hi Dominique and Thomas,
Thanks for testing and reviewing this patch.
Pushed to master in r11-6253-gce8dcc9105cbd4043d575d8b2c91309a423951a9
Paul
On Sat, 12 Dec 2020 at 18:31, Thomas Koenig <tkoenig@netcologne.de> wrote:
>
> Hi Paul,
>
> > Regtests on x86_64/FC31 - OK for master and 10-branch?
>
> Based on reading your patch and Dominique's tests, I'd say
> OK for both, with the minor nit of leaving dependency_57.f90 as
> is and creating a new test case from what you have in there
> (and maybe wait for a week or so for backport to 10-branch).
>
> Thanks a lot for that patch. That certainly was a hard nut to crack,
> or rather a succession of several hard nuts :-)
>
> I also would not be surprised if other bugs are fixed by this patch
> as well, but time will tell.
>
> Thanks a lot for taking this on!
>
> Best regards
>
> Thomas
>
--
"If you can't explain it simply, you don't understand it well enough" -
Albert Einstein
^ permalink raw reply [flat|nested] 18+ messages in thread
* [Patch, fortran] PR83118 - [8/9/10/11 Regression] Bad intrinsic assignment of class(*) array component of derived type
2020-12-18 14:04 ` Paul Richard Thomas
@ 2020-12-23 17:36 ` Paul Richard Thomas
2020-12-25 11:04 ` Thomas Koenig
0 siblings, 1 reply; 18+ messages in thread
From: Paul Richard Thomas @ 2020-12-23 17:36 UTC (permalink / raw)
To: Thomas Koenig; +Cc: dhumieres.dominique, Tobias Burnus, fortran, skpandey
[-- Attachment #1: Type: text/plain, Size: 1475 bytes --]
Hi All,
Sunil reported failures of unlimited_polymorphic_32.f03 with -m32. The
attached patch fixes these failures through the chunks in trans-array.c and
the new function. It turned out that the vptr being used was that of the
unlimited polymorphic object, rather than the dynamic type. It was an
unfortunate coincidence that the testcase worked with -m64.
In the course of investigating this problem, I found two kinds of memory
leak in the execution of the testcase. The first is due to the allocatable
components in the result for new_wrapper not being freed and is fixed by
the chunk in gfc_trans_assignment_1. The second is due to the allocatable
components of the unlimited polymorphic lhs, 'obj'. This will be the
subject of a later fix.
Regtests on FC33/x86_64 and the testcase is fixed with -m32. OK for master?
Paul
Fix failures with -m32 and some memory leaks.
2020-12-23 Paul Thomas <pault@gcc.gnu.org>
gcc/fortran
PR fortran/83118
* trans-array.c (gfc_alloc_allocatable_for_assignment): Make
sure that class expressions are captured for dummy arguments by
use of gfc_get_class_from_gfc_expr otherwise the wrong vptr is
used.
* trans-expr.c (gfc_get_class_from_gfc_expr): New function.
(gfc_get_class_from_expr): If a constant expression is
encountered, return NULL_TREE;
(gfc_trans_assignment_1): Deallocate rhs allocatable components
after passing derived type function results to class lhs.
* trans.h : Add prototype for gfc_get_class_from_gfc_expr.
[-- Attachment #2: repair1.diff --]
[-- Type: text/x-patch, Size: 4064 bytes --]
diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c
index 9e461f94536..2c6be710ac8 100644
--- a/gcc/fortran/trans-array.c
+++ b/gcc/fortran/trans-array.c
@@ -10176,6 +10176,7 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop,
tree jump_label2;
tree neq_size;
tree lbd;
+ tree class_expr2 = NULL_TREE;
int n;
int dim;
gfc_array_spec * as;
@@ -10257,6 +10258,9 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop,
else if (expr1->ts.type == BT_CLASS)
{
tmp = expr1->rank ? gfc_get_class_from_expr (desc) : NULL_TREE;
+ if (tmp == NULL_TREE)
+ tmp = gfc_get_class_from_gfc_expr (expr1);
+
if (tmp != NULL_TREE)
{
tmp2 = gfc_class_vptr_get (tmp);
@@ -10332,6 +10336,9 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop,
else if (expr1->ts.type == BT_CLASS && expr2->ts.type == BT_CLASS)
{
tmp = expr2->rank ? gfc_get_class_from_expr (desc2) : NULL_TREE;
+ if (tmp == NULL_TREE && expr2->expr_type == EXPR_VARIABLE)
+ tmp = class_expr2 = gfc_get_class_from_gfc_expr (expr2);
+
if (tmp != NULL_TREE)
tmp = gfc_class_vtab_size_get (tmp);
else
@@ -10617,6 +10624,8 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop,
tmp2 = gfc_get_class_from_expr (desc2);
tmp2 = gfc_class_vptr_get (tmp2);
}
+ else if (expr2->ts.type == BT_CLASS && class_expr2 != NULL_TREE)
+ tmp2 = gfc_class_vptr_get (class_expr2);
else
{
tmp2 = gfc_get_symbol_decl (gfc_find_vtab (&expr2->ts));
diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index bfe08be2a94..08c21509c85 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -508,6 +508,25 @@ gfc_reset_len (stmtblock_t *block, gfc_expr *expr)
}
+/* Obtain the last class reference in a gfc_expr. Return NULL_TREE if no class
+ reference is found. Note that it is up to the caller to avoid using this
+ for expressions other than variables. */
+
+tree
+gfc_get_class_from_gfc_expr (gfc_expr *e)
+{
+ gfc_expr *class_expr;
+ gfc_se cse;
+ class_expr = gfc_find_and_cut_at_last_class_ref (e);
+ if (class_expr == NULL)
+ return NULL_TREE;
+ gfc_init_se (&cse, NULL);
+ gfc_conv_expr (&cse, class_expr);
+ gfc_free_expr (class_expr);
+ return cse.expr;
+}
+
+
/* Obtain the last class reference in an expression.
Return NULL_TREE if no class reference is found. */
@@ -11295,11 +11314,24 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
tmp = NULL_TREE;
if (is_poly_assign)
- tmp = trans_class_assignment (&body, expr1, expr2, &lse, &rse,
- use_vptr_copy || (lhs_attr.allocatable
- && !lhs_attr.dimension),
- !realloc_flag && flag_realloc_lhs
- && !lhs_attr.pointer);
+ {
+ tmp = trans_class_assignment (&body, expr1, expr2, &lse, &rse,
+ use_vptr_copy || (lhs_attr.allocatable
+ && !lhs_attr.dimension),
+ !realloc_flag && flag_realloc_lhs
+ && !lhs_attr.pointer);
+ if (expr2->expr_type == EXPR_FUNCTION
+ && expr2->ts.type == BT_DERIVED
+ && expr2->ts.u.derived->attr.alloc_comp)
+ {
+ tree tmp2 = gfc_deallocate_alloc_comp (expr2->ts.u.derived,
+ rse.expr, expr2->rank);
+ if (lss == gfc_ss_terminator)
+ gfc_add_expr_to_block (&rse.post, tmp2);
+ else
+ gfc_add_expr_to_block (&loop.post, tmp2);
+ }
+ }
else if (flag_coarray == GFC_FCOARRAY_LIB
&& lhs_caf_attr.codimension && rhs_caf_attr.codimension
&& ((lhs_caf_attr.allocatable && lhs_refs_comp)
diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h
index a1613bd02f3..9ef9b964e10 100644
--- a/gcc/fortran/trans.h
+++ b/gcc/fortran/trans.h
@@ -443,6 +443,7 @@ tree gfc_vptr_final_get (tree);
tree gfc_vptr_deallocate_get (tree);
void gfc_reset_vptr (stmtblock_t *, gfc_expr *);
void gfc_reset_len (stmtblock_t *, gfc_expr *);
+tree gfc_get_class_from_gfc_expr (gfc_expr *);
tree gfc_get_class_from_expr (tree);
tree gfc_get_vptr_from_expr (tree);
tree gfc_get_class_array_ref (tree, tree, tree, bool);
^ permalink raw reply [flat|nested] 18+ messages in thread
* Re: [Patch, fortran] PR83118 - [8/9/10/11 Regression] Bad intrinsic assignment of class(*) array component of derived type
2020-12-23 17:36 ` Paul Richard Thomas
@ 2020-12-25 11:04 ` Thomas Koenig
2020-12-26 9:04 ` Paul Richard Thomas
0 siblings, 1 reply; 18+ messages in thread
From: Thomas Koenig @ 2020-12-25 11:04 UTC (permalink / raw)
To: Paul Richard Thomas; +Cc: dhumieres.dominique, Tobias Burnus, fortran, skpandey
First of all, merry Christmas everybody!
Regarding the patch:
> Regtests on FC33/x86_64 and the testcase is fixed with -m32. OK for master?
It's OK by me.
There is just one piece of code that I don't understand:
+ if (expr2->expr_type == EXPR_FUNCTION
+ && expr2->ts.type == BT_DERIVED
+ && expr2->ts.u.derived->attr.alloc_comp)
+ {
+ tree tmp2 = gfc_deallocate_alloc_comp (expr2->ts.u.derived,
+ rse.expr, expr2->rank);
+ if (lss == gfc_ss_terminator)
+ gfc_add_expr_to_block (&rse.post, tmp2);
+ else
+ gfc_add_expr_to_block (&loop.post, tmp2);
+ }
+ }
This part appears to do the right thing, but I do have one request.
Could you maybe (for my personal education, and that of others who read
this code) add a comment what "lss = gfc_ss_terminator" tests, and why
it that one or the other post block is selected for adding the
deallocation? I simply don't know what this idiom means.
Thanks for the patch!
Best regards
Thomas
> Paul
>
> Fix failures with -m32 and some memory leaks.
>
> 2020-12-23 Paul Thomas <pault@gcc.gnu.org <mailto:pault@gcc.gnu.org>>
>
> gcc/fortran
> PR fortran/83118
> * trans-array.c (gfc_alloc_allocatable_for_assignment): Make
> sure that class expressions are captured for dummy arguments by
> use of gfc_get_class_from_gfc_expr otherwise the wrong vptr is
> used.
> * trans-expr.c (gfc_get_class_from_gfc_expr): New function.
> (gfc_get_class_from_expr): If a constant expression is
> encountered, return NULL_TREE;
> (gfc_trans_assignment_1): Deallocate rhs allocatable components
> after passing derived type function results to class lhs.
> * trans.h : Add prototype for gfc_get_class_from_gfc_expr.
>
^ permalink raw reply [flat|nested] 18+ messages in thread
* Re: [Patch, fortran] PR83118 - [8/9/10/11 Regression] Bad intrinsic assignment of class(*) array component of derived type
2020-12-25 11:04 ` Thomas Koenig
@ 2020-12-26 9:04 ` Paul Richard Thomas
2020-12-26 15:13 ` Paul Richard Thomas
0 siblings, 1 reply; 18+ messages in thread
From: Paul Richard Thomas @ 2020-12-26 9:04 UTC (permalink / raw)
To: Thomas Koenig; +Cc: dhumieres.dominique, Tobias Burnus, fortran, skpandey
Hi Thomas,
Thanks for the review. You'll find answers to the questions below:
On Fri, 25 Dec 2020 at 11:04, Thomas Koenig <tkoenig@netcologne.de> wrote:
> First of all, merry Christmas everybody!
>
> Regarding the patch:
>
> > Regtests on FC33/x86_64 and the testcase is fixed with -m32. OK for
> master?
>
> It's OK by me.
>
> There is just one piece of code that I don't understand:
> ....snip....
>
> Could you maybe (for my personal education, and that of others who read
> this code) add a comment what "lss = gfc_ss_terminator" tests, and why
> it that one or the other post block is selected for adding the
> deallocation? I simply don't know what this idiom means.
>
lss == gfc_ss_terminator tells us that the lhs is a scalar and so the
scalarizer will not have generated a loop. Placing the deallocation of
allocatable components inside a scalarizer loop will generally cause
unintended outcomes :-)
Look at the end of the section "Using pre-generated expressions" in
https://gcc.gnu.org/wiki/GFortranScalarizer
Regards
Paul
^ permalink raw reply [flat|nested] 18+ messages in thread
* Re: [Patch, fortran] PR83118 - [8/9/10/11 Regression] Bad intrinsic assignment of class(*) array component of derived type
2020-12-26 9:04 ` Paul Richard Thomas
@ 2020-12-26 15:13 ` Paul Richard Thomas
0 siblings, 0 replies; 18+ messages in thread
From: Paul Richard Thomas @ 2020-12-26 15:13 UTC (permalink / raw)
To: Thomas Koenig; +Cc: dhumieres.dominique, Tobias Burnus, fortran, skpandey
Pushed to master as r11-6341-g0175d45d14b1f9ebc4c15ea5bafcda655c37fc35
I'll try to deal with the rest of the memory leaks over the next days.
Thanks
Paul
On Sat, 26 Dec 2020 at 09:04, Paul Richard Thomas <
paul.richard.thomas@gmail.com> wrote:
> Hi Thomas,
>
> Thanks for the review. You'll find answers to the questions below:
>
> On Fri, 25 Dec 2020 at 11:04, Thomas Koenig <tkoenig@netcologne.de> wrote:
>
>> First of all, merry Christmas everybody!
>>
>> Regarding the patch:
>>
>> > Regtests on FC33/x86_64 and the testcase is fixed with -m32. OK for
>> master?
>>
>> It's OK by me.
>>
>> There is just one piece of code that I don't understand:
>> ....snip....
>>
>
>
>> Could you maybe (for my personal education, and that of others who read
>> this code) add a comment what "lss = gfc_ss_terminator" tests, and why
>> it that one or the other post block is selected for adding the
>> deallocation? I simply don't know what this idiom means.
>>
>
> lss == gfc_ss_terminator tells us that the lhs is a scalar and so the
> scalarizer will not have generated a loop. Placing the deallocation of
> allocatable components inside a scalarizer loop will generally cause
> unintended outcomes :-)
>
> Look at the end of the section "Using pre-generated expressions" in
> https://gcc.gnu.org/wiki/GFortranScalarizer
>
> Regards
>
> Paul
>
>
--
"If you can't explain it simply, you don't understand it well enough" -
Albert Einstein
^ permalink raw reply [flat|nested] 18+ messages in thread
* Re: [Patch, fortran] PR83118 - [8/9/10/11 Regression] Bad intrinsic assignment of class(*) array component of derived type
2020-11-10 13:25 ` Paul Richard Thomas
2020-11-10 22:16 ` Thomas Koenig
@ 2020-11-11 11:58 ` Tobias Burnus
1 sibling, 0 replies; 18+ messages in thread
From: Tobias Burnus @ 2020-11-11 11:58 UTC (permalink / raw)
To: Paul Richard Thomas, fortran, gcc-patches, Thomas Koenig,
Andre Vehreschild
Hi Paul,
thanks for the patch.
On 10.11.20 14:25, Paul Richard Thomas via Fortran wrote:
> ...
unlimited_polymorphic_32.f03:
> if (any (z .ne. [42_4, 43_4])) stop 1 + idx
If you already use an offset for the stop codes, can you enumerate those?
Currently all are 'stop 1'.
In resolve.c: Typo 'ie.' → 'i.e.' (or, if really needed: 'ie')
> + temporary; ie. the rhs of the assignment. */
> +get_class_info_from_ss (stmtblock_t * pre, gfc_ss *ss, tree *eltype)
> ...
> + /* lhs is class and rhs is intrinsic or derived type. */
> ...
> + if (unlimited_lhs)
> + {
> + tmp = gfc_class_len_get (lhs_class_expr);
> + if (rhs_ss->info
> + && rhs_ss->info->expr
> + && rhs_ss->info->expr->ts.type == BT_CHARACTER)
> + tmp2 = build_int_cst (TREE_TYPE (tmp),
> + rhs_ss->info->expr->ts.kind);
The last part looks incomplete. Unless I am mistaken:
The length for BT_CHARACTER is the character kind times the string length,
not just the character kind.
Otherwise: LGTM, but I do not want to rule out that I missed something!
Tobias
-----------------
Mentor Graphics (Deutschland) GmbH, Arnulfstraße 201, 80634 München / Germany
Registergericht München HRB 106955, Geschäftsführer: Thomas Heurung, Alexander Walter
^ permalink raw reply [flat|nested] 18+ messages in thread
* Re: [Patch, fortran] PR83118 - [8/9/10/11 Regression] Bad intrinsic assignment of class(*) array component of derived type
2020-11-10 22:16 ` Thomas Koenig
@ 2020-11-11 9:47 ` Paul Richard Thomas
0 siblings, 0 replies; 18+ messages in thread
From: Paul Richard Thomas @ 2020-11-11 9:47 UTC (permalink / raw)
To: Thomas Koenig; +Cc: fortran, gcc-patches, Andre Vehreschild
Hi Thomas,
Yes, it did grow into a bit of a monster patch. I kept noticing rather
flakey bits of existing code, especially where matching of dtype element
lengths to the actual payload was concerned.
Waiting for the others to comment gives me a chance to write a more
comprehensive testcase for the handling of temporaries. Note also that
PR96012 is fixed by this patch and will require an additional test.
I am happy to leave dependency_57.f90 as it is and add an additional test.
I will post the tests as soon as they are available.
Thanks for taking a look at it.
Paul
Paul
On Tue, 10 Nov 2020 at 22:16, Thomas Koenig <tkoenig@netcologne.de> wrote:
> Hi Paul,
>
> > This all bootstraps and regtests on FC31/x86_64 - OK for master?
>
> This is a sizable patch, and from what I can see, it all looks
> plausible. So, I's say OK for master (with one nit, below),
> but maybe you could wait a day or so to give others the chance
> to look it over, too.
>
> The nit:
>
> > PR fortran/83118
> > * gfortran.dg/dependency_57.f90: Change to dg-run and test for correct
> > result.
>
> I'd rather not change a test case unless it is needed; if something
> breaks it, it is better to leave it as is for bisection.
>
> Could you just make a new test from the run-time version?
>
> Thanks a lot for tackling this thorny issue!
>
> Best regards
>
> Thomas
>
>
>
--
"If you can't explain it simply, you don't understand it well enough" -
Albert Einstein
^ permalink raw reply [flat|nested] 18+ messages in thread
* Re: [Patch, fortran] PR83118 - [8/9/10/11 Regression] Bad intrinsic assignment of class(*) array component of derived type
2020-11-10 13:25 ` Paul Richard Thomas
@ 2020-11-10 22:16 ` Thomas Koenig
2020-11-11 9:47 ` Paul Richard Thomas
2020-11-11 11:58 ` Tobias Burnus
1 sibling, 1 reply; 18+ messages in thread
From: Thomas Koenig @ 2020-11-10 22:16 UTC (permalink / raw)
To: Paul Richard Thomas, fortran, gcc-patches, Andre Vehreschild
Hi Paul,
> This all bootstraps and regtests on FC31/x86_64 - OK for master?
This is a sizable patch, and from what I can see, it all looks
plausible. So, I's say OK for master (with one nit, below),
but maybe you could wait a day or so to give others the chance
to look it over, too.
The nit:
> PR fortran/83118
> * gfortran.dg/dependency_57.f90: Change to dg-run and test for correct
> result.
I'd rather not change a test case unless it is needed; if something
breaks it, it is better to leave it as is for bisection.
Could you just make a new test from the run-time version?
Thanks a lot for tackling this thorny issue!
Best regards
Thomas
^ permalink raw reply [flat|nested] 18+ messages in thread
* [Patch, fortran] PR83118 - [8/9/10/11 Regression] Bad intrinsic assignment of class(*) array component of derived type
2020-10-29 15:59 Paul Richard Thomas
2020-11-03 8:42 ` Paul Richard Thomas
2020-11-06 17:48 ` Tobias Burnus
@ 2020-11-10 13:25 ` Paul Richard Thomas
2020-11-10 22:16 ` Thomas Koenig
2020-11-11 11:58 ` Tobias Burnus
2 siblings, 2 replies; 18+ messages in thread
From: Paul Richard Thomas @ 2020-11-10 13:25 UTC (permalink / raw)
To: fortran, gcc-patches, Thomas Koenig, Andre Vehreschild
[-- Attachment #1: Type: text/plain, Size: 4689 bytes --]
Hi Everyone,
I am afraid that this is a rather long sad story, mainly due to my efforts
with gfortran being interrupted by daytime work. I posted the first version
of the patch nearly a year ago but this was derailed by Tobias's question
at: https://gcc.gnu.org/legacy-ml/fortran/2019-11/msg00098.html
My recent attempt to post this patch were disrupted by the patch itself
disappearing from the posting. Thanks to Andre and Thomas for pointing this
out. Since then, I have been working on downstream PRs and this has led to
a reworking of the unposted version.
(i) The attached fixes the original problem and is tested by
gfortran.dg/unlimited_polymorphic_32.f03.
(ii) In fixing the original problem, a fair amount of effort was required
to get the element length correct for class temporaries produced by
dependencies in class assignment. This is reflected in the changes to
trans_array.c(gfc_alloc_allocatable_for_assignment) and the new function
get_class_info_from_ss.
(iii) Tobias's testcase in the above posting to the list didn't address
itself to class arrays of the original problem. However, it revealed that
reallocation was not occuring at all for scalar assignments. This is fixed
by the large chunk in trans-expr.c(trans_class_assignment). The array case
is 'fixed' by testing for unequal element sizes between lhs and rhs before
reallocation in gfc_alloc_allocatable_for_assignment. This is difficult to
test for since, in most cases, the system returns that same address after
reallocation.
(iv) dependency_57.f90 segfaulted at runtime. The other work in
trans_class_assignment was required to fix this.
(v) A number of minor tidy ups were done including the new function
gfc_resize_class_size_with_len to eliminate some repeated code.
Note: Chunks of code are coming within scalarization loops that should be
outside:
x->_vptr = (struct __vtype__STAR * {ref-all})
&__vtab_INTEGER_4_;
x->_len = 0;
D.3977 = x->_vptr->_size;
D.3978 = x->_len;
D.3979 = D.3978 > 0 ? D.3977 * D.3978 : D.3977;
also in many cases of class assignment, the lhs vptr is being set more than
once outside the loop when temporaries are involved. I will try to iron out
these issues later on.
This all bootstraps and regtests on FC31/x86_64 - OK for master?
Cheers
Paul
As well as the PR this patch fixes problems in handling class objects;
most importantly class array temporaries, required when dependences
occur in class assignment, and a correct implementation of reallocation
on assignment.
2020-11-10 Paul Thomas <pault@gcc.gnu.org>
gcc/fortran
PR fortran/83118
* resolve.c (resolve_ordinary_assign): Generate a vtable if
necessary for scalar non-polymorphic rhs's to unlimited lhs's.
* trans-array.c (get_class_info_from_ss): New function.
(gfc_trans_allocate_array_storage): Defer obtaining class
element type until all sources of class exprs are tried. Use
class API rather than TREE_OPERAND. Look for class expressions
in ss->info by calling get_class_info_from_ss. After obtain
the element size for class descriptors. Where the element type
is unknown, cast the data as character(len=size) to overcome
unlimited polymorphic problems.
(structure_alloc_comps): Replace code that replicates the new
function gfc_resize_class_size_with_len.
(gfc_alloc_allocatable_for_assignment): Obtain element size
for lhs in cases of deferred characters and class enitities.
Move code for the element size of rhs to start of block. Clean
up extraction of class parameters throughout this function.
After the shape check test whether or not the lhs and rhs
element sizes are the same. Use earlier evaluation of
'cond_null'. Reallocation of lhs only to happen if size changes
or element size changes.
* trans-expr.c (gfc_resize_class_size_with_len): New function.
(gfc_conv_procedure_call): Ensure the vtable is present for
passing a non-class actual to an unlimited formal.
(trans_class_vptr_len_assignment): For expressions of type
BT_CLASS, extract the class expression if necessary. Use a
statement block outside the loop body. Ensure that 'rhs' is
of the correct type. Obtain rhs vptr in all circumstances.
(gfc_trans_assignment_1): Simplify some of the logic with
'realloc_flag'. Set 'vptr_copy' for all array assignments to
unlimited polymorphic lhs.
* trans-c (gfc_build_array_ref): Call gfc_resize_class_size_
with_len to correct span for unlimited polymorphic decls.
* trans.h : Add prototype for gfc_resize_class_size_with_len.
gcc/testsuite/
PR fortran/83118
* gfortran.dg/dependency_57.f90: Change to dg-run and test for correct
result.
* gfortran.dg/unlimited_polymorphic_32.f03: New test.
[-- Attachment #2: unlimited_polymorphic_32.f03 --]
[-- Type: application/octet-stream, Size: 1608 bytes --]
! { dg-do run }
!
! Test the fix of the test case referenced in comment 17 of PR83118.
!
! Contributed by Damian Rouson <damian@sourceryinstitute.org>
!
implicit none
type Wrapper
class(*), allocatable :: elements(:)
end type
type Mytype
real(4) :: r = 42.0
end type
call driver
contains
subroutine driver
class(*), allocatable :: obj
type(Wrapper) w
integer(4) :: expected4(2) = [42_4, 43_4]
integer(8) :: expected8(3) = [42_8, 43_8, 44_8]
w = new_wrapper (expected4)
obj = w
call test (obj, 0)
obj = new_wrapper (expected8) ! Used to generate a linker error
call test (obj, 10)
obj = new_wrapper ([mytype (99.0)])
call test (obj, 100)
obj = Mytype (42.0) ! Used to generate a linker error
call test (obj, 1000)
end subroutine
function new_wrapper(array) result (res)
class(*) :: array(:)
type(Wrapper) :: res
res%elements = array ! Used to runtime segfault
end function
subroutine test (arg, idx)
class(*) :: arg
integer :: idx
select type (arg)
type is (wrapper)
select type (z => arg%elements)
type is (integer(4))
if (any (z .ne. [42_4, 43_4])) stop 1 + idx
type is (integer(8))
if (any (z .ne. [42_8, 43_8, 44_8])) stop 1 + idx
type is (Mytype)
if (abs (z(1)%r - 99.0) .ge. 1e-6) stop 1 + idx
class default
stop 2 + idx
end select
type is (Mytype)
if (abs (arg%r - 42.0) .ge. 1e-6) stop 1 + idx
class default
stop 3 + idx
end select
end subroutine
end
[-- Attachment #3: resubmit.diff --]
[-- Type: text/x-patch, Size: 31671 bytes --]
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 1641eb6ca10..daa947af9d1 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -11054,7 +11054,7 @@ resolve_ordinary_assign (gfc_code *code, gfc_namespace *ns)
/* Make sure there is a vtable and, in particular, a _copy for the
rhs type. */
- if (UNLIMITED_POLY (lhs) && lhs->rank && rhs->ts.type != BT_CLASS)
+ if (UNLIMITED_POLY (lhs) && rhs->ts.type != BT_CLASS)
gfc_find_vtab (&rhs->ts);
bool caf_convert_to_send = flag_coarray == GFC_FCOARRAY_LIB
diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c
index b2c39aa32de..0abebfdc937 100644
--- a/gcc/fortran/trans-array.c
+++ b/gcc/fortran/trans-array.c
@@ -1030,7 +1030,6 @@ gfc_trans_allocate_array_storage (stmtblock_t * pre, stmtblock_t * post,
gcc_assert (TREE_CODE (tmp) == POINTER_TYPE);
tmp = TREE_TYPE (tmp); /* The descriptor itself. */
tmp = gfc_get_element_type (tmp);
- gcc_assert (tmp == gfc_get_element_type (TREE_TYPE (desc)));
packed = gfc_create_var (build_pointer_type (tmp), "data");
tmp = build_call_expr_loc (input_location,
@@ -1139,6 +1138,112 @@ get_array_ref_dim_for_loop_dim (gfc_ss *ss, int loop_dim)
}
+/* Use the information in the ss to obtain the required information about
+ the type and size of an array temporary, when the lhs in an assignment
+ is a class expression. */
+
+static tree
+get_class_info_from_ss (stmtblock_t * pre, gfc_ss *ss, tree *eltype)
+{
+ gfc_ss *lhs_ss;
+ gfc_ss *rhs_ss;
+ tree tmp;
+ tree tmp2;
+ tree vptr;
+ tree rhs_class_expr = NULL_TREE;
+ tree lhs_class_expr = NULL_TREE;
+ bool unlimited_rhs = false;
+ bool unlimited_lhs = false;
+ gfc_symbol *vtab;
+
+ /* The second element in the loop chain contains the source for the
+ temporary; ie. the rhs of the assignment. */
+ rhs_ss = ss->loop->ss->loop_chain;
+ if (rhs_ss != gfc_ss_terminator
+ && rhs_ss->info
+ && rhs_ss->info->expr
+ && rhs_ss->info->expr->ts.type == BT_CLASS
+ && rhs_ss->info->data.array.descriptor)
+ {
+ rhs_class_expr
+ = gfc_get_class_from_expr (rhs_ss->info->data.array.descriptor);
+ unlimited_rhs = UNLIMITED_POLY (rhs_ss->info->expr);
+ }
+
+ /* For an assignment the lhs is the next element in the loop chain.
+ If we have a class rhs, this had better be a class variable
+ expression! */
+ lhs_ss = rhs_ss->loop_chain;
+ if (lhs_ss->info
+ && lhs_ss->info->expr
+ && lhs_ss->info->expr->expr_type ==EXPR_VARIABLE
+ && lhs_ss->info->expr->ts.type == BT_CLASS)
+ {
+ tmp = lhs_ss->info->data.array.descriptor;
+ unlimited_lhs = UNLIMITED_POLY (rhs_ss->info->expr);
+ }
+ else
+ tmp = NULL_TREE;
+
+ /* Get the lhs class expression. */
+ if (tmp != NULL_TREE)
+ lhs_class_expr = gfc_get_class_from_expr (tmp);
+ else
+ return NULL_TREE;
+
+ gcc_assert (GFC_CLASS_TYPE_P (TREE_TYPE (lhs_class_expr)));
+
+ /* Set the lhs vptr and, if necessary, the _len field. */
+ if (rhs_class_expr)
+ {
+ /* Both lhs and rhs are class expressions. */
+ tmp = gfc_class_vptr_get (lhs_class_expr);
+ gfc_add_modify (pre, tmp,
+ fold_convert (TREE_TYPE (tmp),
+ gfc_class_vptr_get (rhs_class_expr)));
+ if (unlimited_lhs)
+ {
+ tmp = gfc_class_len_get (lhs_class_expr);
+ if (unlimited_rhs)
+ tmp2 = gfc_class_len_get (rhs_class_expr);
+ else
+ tmp2 = build_int_cst (TREE_TYPE (tmp), 0);
+ gfc_add_modify (pre, tmp, tmp2);
+ }
+ }
+ else
+ {
+ /* lhs is class and rhs is intrinsic or derived type. */
+ *eltype = TREE_TYPE (rhs_ss->info->data.array.descriptor);
+ *eltype = gfc_get_element_type (*eltype);
+ vtab = gfc_find_vtab (&rhs_ss->info->expr->ts);
+ vptr = vtab->backend_decl;
+ if (vptr == NULL_TREE)
+ vptr = gfc_get_symbol_decl (vtab);
+ vptr = gfc_build_addr_expr (NULL_TREE, vptr);
+ tmp = gfc_class_vptr_get (lhs_class_expr);
+ gfc_add_modify (pre, tmp,
+ fold_convert (TREE_TYPE (tmp), vptr));
+
+ if (unlimited_lhs)
+ {
+ tmp = gfc_class_len_get (lhs_class_expr);
+ if (rhs_ss->info
+ && rhs_ss->info->expr
+ && rhs_ss->info->expr->ts.type == BT_CHARACTER)
+ tmp2 = build_int_cst (TREE_TYPE (tmp),
+ rhs_ss->info->expr->ts.kind);
+ else
+ tmp2 = build_int_cst (TREE_TYPE (tmp), 0);
+ gfc_add_modify (pre, tmp, tmp2);
+ }
+ }
+
+ return rhs_class_expr;
+}
+
+
+
/* Generate code to create and initialize the descriptor for a temporary
array. This is used for both temporaries needed by the scalarizer, and
functions returning arrays. Adjusts the loop variables to be
@@ -1184,13 +1289,44 @@ gfc_trans_create_temp_array (stmtblock_t * pre, stmtblock_t * post, gfc_ss * ss,
{
gcc_assert (POINTER_TYPE_P (TREE_TYPE (initial)));
class_expr = build_fold_indirect_ref_loc (input_location, initial);
- eltype = TREE_TYPE (class_expr);
- eltype = gfc_get_element_type (eltype);
/* Obtain the structure (class) expression. */
- class_expr = TREE_OPERAND (class_expr, 0);
+ class_expr = gfc_get_class_from_expr (class_expr);
gcc_assert (class_expr);
}
+ /* Otherwise, some expressions, such as class functions, arising from
+ dependency checking in assignments come here with class element type.
+ The descriptor can be obtained from the ss->info and then converted
+ to the class object. */
+ if (class_expr == NULL_TREE && GFC_CLASS_TYPE_P (eltype))
+ {
+ class_expr = get_class_info_from_ss (pre, ss, &eltype);
+ gcc_assert ((class_expr != NULL_TREE)
+ || !GFC_CLASS_TYPE_P (eltype));
+ }
+
+ if (class_expr == NULL_TREE)
+ elemsize = fold_convert (gfc_array_index_type,
+ TYPE_SIZE_UNIT (eltype));
+ else
+ {
+ /* Unlimited polymorphic entities are initialised with NULL vptr. They
+ can be tested for by checking if the len field is present. If so
+ test the vptr before using the vtable size. */
+ tmp = gfc_class_vptr_get (class_expr);
+ tmp = fold_build2_loc (input_location, NE_EXPR,
+ logical_type_node,
+ tmp, build_int_cst (TREE_TYPE (tmp), 0));
+ elemsize = fold_build3_loc (input_location, COND_EXPR,
+ gfc_array_index_type,
+ tmp,
+ gfc_class_vtab_size_get (class_expr),
+ gfc_index_zero_node);
+ elemsize = gfc_evaluate_now (elemsize, pre);
+ elemsize = gfc_resize_class_size_with_len (pre, class_expr, elemsize);
+ eltype = gfc_get_character_type_len (1, elemsize);
+ }
+
memset (from, 0, sizeof (from));
memset (to, 0, sizeof (to));
@@ -1339,12 +1475,6 @@ gfc_trans_create_temp_array (stmtblock_t * pre, stmtblock_t * post, gfc_ss * ss,
}
}
- if (class_expr == NULL_TREE)
- elemsize = fold_convert (gfc_array_index_type,
- TYPE_SIZE_UNIT (gfc_get_element_type (type)));
- else
- elemsize = gfc_class_vtab_size_get (class_expr);
-
/* Get the size of the array. */
if (size && !callee_alloc)
{
@@ -3373,18 +3503,10 @@ build_class_array_ref (gfc_se *se, tree base, tree index)
size = gfc_class_vtab_size_get (decl);
/* For unlimited polymorphic entities then _len component needs to be
- multiplied with the size. If no _len component is present, then
- gfc_class_len_or_zero_get () return a zero_node. */
- tmp = gfc_class_len_or_zero_get (decl);
- if (!integer_zerop (tmp))
- size = fold_build2 (MULT_EXPR, TREE_TYPE (index),
- fold_convert (TREE_TYPE (index), size),
- fold_build2 (MAX_EXPR, TREE_TYPE (index),
- fold_convert (TREE_TYPE (index), tmp),
- fold_convert (TREE_TYPE (index),
- integer_one_node)));
- else
- size = fold_convert (TREE_TYPE (index), size);
+ multiplied with the size. */
+ size = gfc_resize_class_size_with_len (&se->pre, decl, size);
+
+ size = fold_convert (TREE_TYPE (index), size);
/* Build the address of the element. */
type = TREE_TYPE (TREE_TYPE (base));
@@ -9233,21 +9355,9 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
for the malloc call. */
if (UNLIMITED_POLY (c))
{
- tree ctmp;
gfc_add_modify (&tmpblock, gfc_class_len_get (dcmp),
gfc_class_len_get (comp));
-
- size = gfc_evaluate_now (size, &tmpblock);
- tmp = gfc_class_len_get (comp);
- ctmp = fold_build2_loc (input_location, MULT_EXPR,
- size_type_node, size,
- fold_convert (size_type_node, tmp));
- tmp = fold_build2_loc (input_location, GT_EXPR,
- logical_type_node, tmp,
- build_zero_cst (TREE_TYPE (tmp)));
- size = fold_build3_loc (input_location, COND_EXPR,
- size_type_node, tmp, ctmp, size);
- size = gfc_evaluate_now (size, &tmpblock);
+ size = gfc_resize_class_size_with_len (&tmpblock, comp, size);
}
/* Coarray component have to have the same allocation status and
@@ -10033,6 +10143,8 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop,
tree alloc_expr;
tree size1;
tree size2;
+ tree elemsize1;
+ tree elemsize2;
tree array1;
tree cond_null;
tree cond;
@@ -10112,6 +10224,108 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop,
gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)));
array1 = gfc_conv_descriptor_data_get (desc);
+ if (expr2)
+ desc2 = rss->info->data.array.descriptor;
+ else
+ desc2 = NULL_TREE;
+
+ /* Get the old lhs element size for deferred character and class expr1. */
+ if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
+ {
+ if (expr1->ts.u.cl->backend_decl
+ && VAR_P (expr1->ts.u.cl->backend_decl))
+ elemsize1 = expr1->ts.u.cl->backend_decl;
+ else
+ elemsize1 = lss->info->string_length;
+ }
+ else if (expr1->ts.type == BT_CLASS)
+ {
+ tmp = expr1->rank ? gfc_get_class_from_expr (desc) : NULL_TREE;
+ if (tmp != NULL_TREE)
+ {
+ tmp2 = gfc_class_vptr_get (tmp);
+ cond = fold_build2_loc (input_location, NE_EXPR,
+ logical_type_node, tmp2,
+ build_int_cst (TREE_TYPE (tmp2), 0));
+ elemsize1 = gfc_class_vtab_size_get (tmp);
+ elemsize1 = fold_build3_loc (input_location, COND_EXPR,
+ gfc_array_index_type, cond,
+ elemsize1, gfc_index_zero_node);
+ }
+ else
+ elemsize1 = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&CLASS_DATA (expr1)->ts));
+ }
+ else
+ elemsize1 = NULL_TREE;
+ if (elemsize1 != NULL_TREE)
+ elemsize1 = gfc_evaluate_now (elemsize1, &fblock);
+
+ /* Get the new lhs size in bytes. */
+ if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
+ {
+ if (expr2->ts.deferred)
+ {
+ if (expr2->ts.u.cl->backend_decl
+ && VAR_P (expr2->ts.u.cl->backend_decl))
+ tmp = expr2->ts.u.cl->backend_decl;
+ else
+ tmp = rss->info->string_length;
+ }
+ else
+ {
+ tmp = expr2->ts.u.cl->backend_decl;
+ if (!tmp && expr2->expr_type == EXPR_OP
+ && expr2->value.op.op == INTRINSIC_CONCAT)
+ {
+ tmp = concat_str_length (expr2);
+ expr2->ts.u.cl->backend_decl = gfc_evaluate_now (tmp, &fblock);
+ }
+ else if (!tmp && expr2->ts.u.cl->length)
+ {
+ gfc_se tmpse;
+ gfc_init_se (&tmpse, NULL);
+ gfc_conv_expr_type (&tmpse, expr2->ts.u.cl->length,
+ gfc_charlen_type_node);
+ tmp = tmpse.expr;
+ expr2->ts.u.cl->backend_decl = gfc_evaluate_now (tmp, &fblock);
+ }
+ tmp = fold_convert (TREE_TYPE (expr1->ts.u.cl->backend_decl), tmp);
+ }
+
+ if (expr1->ts.u.cl->backend_decl
+ && VAR_P (expr1->ts.u.cl->backend_decl))
+ gfc_add_modify (&fblock, expr1->ts.u.cl->backend_decl, tmp);
+ else
+ gfc_add_modify (&fblock, lss->info->string_length, tmp);
+
+ if (expr1->ts.kind > 1)
+ tmp = fold_build2_loc (input_location, MULT_EXPR,
+ TREE_TYPE (tmp),
+ tmp, build_int_cst (TREE_TYPE (tmp),
+ expr1->ts.kind));
+ }
+ else if (expr1->ts.type == BT_CHARACTER && expr1->ts.u.cl->backend_decl)
+ {
+ tmp = TYPE_SIZE_UNIT (TREE_TYPE (gfc_typenode_for_spec (&expr1->ts)));
+ tmp = fold_build2_loc (input_location, MULT_EXPR,
+ gfc_array_index_type, tmp,
+ expr1->ts.u.cl->backend_decl);
+ }
+ else if (UNLIMITED_POLY (expr1) && expr2->ts.type != BT_CLASS)
+ tmp = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr2->ts));
+ else if (expr1->ts.type == BT_CLASS && expr2->ts.type == BT_CLASS)
+ {
+ tmp = expr2->rank ? gfc_get_class_from_expr (desc2) : NULL_TREE;
+ if (tmp != NULL_TREE)
+ tmp = gfc_class_vtab_size_get (tmp);
+ else
+ tmp = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&CLASS_DATA (expr2)->ts));
+ }
+ else
+ tmp = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr2->ts));
+ elemsize2 = fold_convert (gfc_array_index_type, tmp);
+ elemsize2 = gfc_evaluate_now (elemsize2, &fblock);
+
/* 7.4.1.3 "If variable is an allocated allocatable variable, it is
deallocated if expr is an array of different shape or any of the
corresponding length type parameter values of variable and expr
@@ -10131,6 +10345,7 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop,
rss->info->string_length);
cond_null = fold_build2_loc (input_location, TRUTH_OR_EXPR,
logical_type_node, tmp, cond_null);
+ cond_null= gfc_evaluate_now (cond_null, &fblock);
}
else
cond_null= gfc_evaluate_now (cond_null, &fblock);
@@ -10179,6 +10394,19 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop,
gfc_add_expr_to_block (&fblock, tmp);
}
+ /* ...else if the element lengths are not the same also go to
+ setting the bounds and doing the reallocation.... */
+ if (elemsize1 != NULL_TREE)
+ {
+ cond = fold_build2_loc (input_location, NE_EXPR,
+ logical_type_node,
+ elemsize1, elemsize2);
+ tmp = build3_v (COND_EXPR, cond,
+ build1_v (GOTO_EXPR, jump_label1),
+ build_empty_stmt (input_location));
+ gfc_add_expr_to_block (&fblock, tmp);
+ }
+
/* ....else jump past the (re)alloc code. */
tmp = build1_v (GOTO_EXPR, jump_label2);
gfc_add_expr_to_block (&fblock, tmp);
@@ -10201,11 +10429,6 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop,
gfc_add_expr_to_block (&fblock, tmp);
/* Get the rhs size and fix it. */
- if (expr2)
- desc2 = rss->info->data.array.descriptor;
- else
- desc2 = NULL_TREE;
-
size2 = gfc_index_one_node;
for (n = 0; n < expr2->rank; n++)
{
@@ -10320,69 +10543,12 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop,
gfc_add_modify (&fblock, linfo->delta[dim], tmp);
}
- /* Get the new lhs size in bytes. */
- if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
- {
- if (expr2->ts.deferred)
- {
- if (expr2->ts.u.cl->backend_decl
- && VAR_P (expr2->ts.u.cl->backend_decl))
- tmp = expr2->ts.u.cl->backend_decl;
- else
- tmp = rss->info->string_length;
- }
- else
- {
- tmp = expr2->ts.u.cl->backend_decl;
- if (!tmp && expr2->expr_type == EXPR_OP
- && expr2->value.op.op == INTRINSIC_CONCAT)
- {
- tmp = concat_str_length (expr2);
- expr2->ts.u.cl->backend_decl = gfc_evaluate_now (tmp, &fblock);
- }
- else if (!tmp && expr2->ts.u.cl->length)
- {
- gfc_se tmpse;
- gfc_init_se (&tmpse, NULL);
- gfc_conv_expr_type (&tmpse, expr2->ts.u.cl->length,
- gfc_charlen_type_node);
- tmp = tmpse.expr;
- expr2->ts.u.cl->backend_decl = gfc_evaluate_now (tmp, &fblock);
- }
- tmp = fold_convert (TREE_TYPE (expr1->ts.u.cl->backend_decl), tmp);
- }
-
- if (expr1->ts.u.cl->backend_decl
- && VAR_P (expr1->ts.u.cl->backend_decl))
- gfc_add_modify (&fblock, expr1->ts.u.cl->backend_decl, tmp);
- else
- gfc_add_modify (&fblock, lss->info->string_length, tmp);
-
- if (expr1->ts.kind > 1)
- tmp = fold_build2_loc (input_location, MULT_EXPR,
- TREE_TYPE (tmp),
- tmp, build_int_cst (TREE_TYPE (tmp),
- expr1->ts.kind));
- }
- else if (expr1->ts.type == BT_CHARACTER && expr1->ts.u.cl->backend_decl)
- {
- tmp = TYPE_SIZE_UNIT (TREE_TYPE (gfc_typenode_for_spec (&expr1->ts)));
- tmp = fold_build2_loc (input_location, MULT_EXPR,
- gfc_array_index_type, tmp,
- expr1->ts.u.cl->backend_decl);
- }
- else if (UNLIMITED_POLY (expr1) && expr2->ts.type != BT_CLASS)
- tmp = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr2->ts));
- else
- tmp = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr1->ts));
- tmp = fold_convert (gfc_array_index_type, tmp);
-
if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
- gfc_conv_descriptor_span_set (&fblock, desc, tmp);
+ gfc_conv_descriptor_span_set (&fblock, desc, elemsize2);
size2 = fold_build2_loc (input_location, MULT_EXPR,
gfc_array_index_type,
- tmp, size2);
+ elemsize2, size2);
size2 = fold_convert (size_type_node, size2);
size2 = fold_build2_loc (input_location, MAX_EXPR, size_type_node,
size2, size_one_node);
@@ -10403,7 +10569,7 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop,
gfc_add_modify (&fblock, tmp,
gfc_get_dtype_rank_type (expr1->rank,type));
}
- else if (UNLIMITED_POLY (expr1) && expr2->ts.type != BT_CLASS)
+ else if (expr1->ts.type == BT_CLASS)
{
tree type;
tmp = gfc_conv_descriptor_dtype (desc);
@@ -10411,19 +10577,32 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop,
gfc_add_modify (&fblock, tmp,
gfc_get_dtype_rank_type (expr2->rank,type));
/* Set the _len field as well... */
- tmp = gfc_class_len_get (TREE_OPERAND (desc, 0));
- if (expr2->ts.type == BT_CHARACTER)
- gfc_add_modify (&fblock, tmp,
- fold_convert (TREE_TYPE (tmp),
- TYPE_SIZE_UNIT (type)));
- else
- gfc_add_modify (&fblock, tmp,
- build_int_cst (TREE_TYPE (tmp), 0));
+ if (UNLIMITED_POLY (expr1))
+ {
+ tmp = gfc_class_len_get (TREE_OPERAND (desc, 0));
+ if (expr2->ts.type == BT_CHARACTER)
+ gfc_add_modify (&fblock, tmp,
+ fold_convert (TREE_TYPE (tmp),
+ TYPE_SIZE_UNIT (type)));
+ else
+ gfc_add_modify (&fblock, tmp,
+ build_int_cst (TREE_TYPE (tmp), 0));
+ }
/* ...and the vptr. */
tmp = gfc_class_vptr_get (TREE_OPERAND (desc, 0));
- tmp2 = gfc_get_symbol_decl (gfc_find_vtab (&expr2->ts));
- tmp2 = gfc_build_addr_expr (TREE_TYPE (tmp), tmp2);
- gfc_add_modify (&fblock, tmp, tmp2);
+ if (expr2->ts.type == BT_CLASS && !VAR_P (desc2)
+ && TREE_CODE (desc2) == COMPONENT_REF)
+ {
+ tmp2 = gfc_get_class_from_expr (desc2);
+ tmp2 = gfc_class_vptr_get (tmp2);
+ }
+ else
+ {
+ tmp2 = gfc_get_symbol_decl (gfc_find_vtab (&expr2->ts));
+ tmp2 = gfc_build_addr_expr (TREE_TYPE (tmp), tmp2);
+ }
+
+ gfc_add_modify (&fblock, tmp, fold_convert (TREE_TYPE (tmp), tmp2));
}
else if (coarray && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
{
@@ -10499,11 +10678,19 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop,
gfc_add_block_to_block (&realloc_block, &caf_se.post);
realloc_expr = gfc_finish_block (&realloc_block);
- /* Only reallocate if sizes are different. */
+ /* Reallocate if sizes or dynamic types are different. */
+ if (elemsize1)
+ {
+ tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
+ elemsize1, elemsize2);
+ tmp = gfc_evaluate_now (tmp, &fblock);
+ neq_size = fold_build2_loc (input_location, TRUTH_OR_EXPR,
+ logical_type_node, neq_size, tmp);
+ }
tmp = build3_v (COND_EXPR, neq_size, realloc_expr,
build_empty_stmt (input_location));
- realloc_expr = tmp;
+ realloc_expr = tmp;
/* Malloc expression. */
gfc_init_block (&alloc_block);
@@ -10550,11 +10737,7 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop,
alloc_expr = gfc_finish_block (&alloc_block);
/* Malloc if not allocated; realloc otherwise. */
- tmp = build_int_cst (TREE_TYPE (array1), 0);
- cond = fold_build2_loc (input_location, EQ_EXPR,
- logical_type_node,
- array1, tmp);
- tmp = build3_v (COND_EXPR, cond, alloc_expr, realloc_expr);
+ tmp = build3_v (COND_EXPR, cond_null, alloc_expr, realloc_expr);
gfc_add_expr_to_block (&fblock, tmp);
/* Make sure that the scalarizer data pointer is updated. */
@@ -10564,7 +10747,7 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop,
gfc_add_modify (&fblock, linfo->data, tmp);
}
- /* Add the exit label. */
+ /* Add the label for same shape lhs and rhs. */
tmp = build1_v (LABEL_EXPR, jump_label2);
gfc_add_expr_to_block (&fblock, tmp);
diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index 2167de455b8..0489e397cea 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -257,6 +257,42 @@ gfc_class_len_or_zero_get (tree decl)
}
+tree
+gfc_resize_class_size_with_len (stmtblock_t * block, tree class_expr, tree size)
+{
+ tree tmp;
+ tree tmp2;
+ tree type;
+
+ tmp = gfc_class_len_or_zero_get (class_expr);
+
+ /* Include the len value in the element size if present. */
+ if (!integer_zerop (tmp))
+ {
+ type = TREE_TYPE (size);
+ if (block)
+ {
+ size = gfc_evaluate_now (size, block);
+ tmp = gfc_evaluate_now (fold_convert (type , tmp), block);
+ }
+ tmp2 = fold_build2_loc (input_location, MULT_EXPR,
+ type, size, tmp);
+ tmp = fold_build2_loc (input_location, GT_EXPR,
+ logical_type_node, tmp,
+ build_zero_cst (type));
+ size = fold_build3_loc (input_location, COND_EXPR,
+ type, tmp, tmp2, size);
+ }
+ else
+ return size;
+
+ if (block)
+ size = gfc_evaluate_now (size, block);
+
+ return size;
+}
+
+
/* Get the specified FIELD from the VPTR. */
static tree
@@ -5613,8 +5649,10 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
{
/* The intrinsic type needs to be converted to a temporary
CLASS object for the unlimited polymorphic formal. */
+ gfc_find_vtab (&e->ts);
gfc_init_se (&parmse, se);
gfc_conv_intrinsic_to_class (&parmse, e, fsym->ts);
+
}
else if (se->ss && se->ss->info->useflags)
{
@@ -8926,14 +8964,32 @@ trans_class_vptr_len_assignment (stmtblock_t *block, gfc_expr * le,
tree tmp, to_len = NULL_TREE, from_len = NULL_TREE, lhs_vptr;
bool set_vptr = false, temp_rhs = false;
stmtblock_t *pre = block;
+ tree class_expr = NULL_TREE;
/* Create a temporary for complicated expressions. */
if (re->expr_type != EXPR_VARIABLE && re->expr_type != EXPR_NULL
&& rse->expr != NULL_TREE && !DECL_P (rse->expr))
{
- tmp = gfc_create_var (TREE_TYPE (rse->expr), "rhs");
- pre = &rse->pre;
- gfc_add_modify (&rse->pre, tmp, rse->expr);
+ if (re->ts.type == BT_CLASS && !GFC_CLASS_TYPE_P (TREE_TYPE (rse->expr)))
+ class_expr = gfc_get_class_from_expr (rse->expr);
+
+ if (rse->loop)
+ pre = &rse->loop->pre;
+ else
+ pre = &rse->pre;
+
+ if (class_expr != NULL_TREE && UNLIMITED_POLY (re))
+ {
+ tmp = TREE_OPERAND (rse->expr, 0);
+ tmp = gfc_create_var (TREE_TYPE (tmp), "rhs");
+ gfc_add_modify (&rse->pre, tmp, TREE_OPERAND (rse->expr, 0));
+ }
+ else
+ {
+ tmp = gfc_create_var (TREE_TYPE (rse->expr), "rhs");
+ gfc_add_modify (&rse->pre, tmp, rse->expr);
+ }
+
rse->expr = tmp;
temp_rhs = true;
}
@@ -9001,9 +9057,17 @@ trans_class_vptr_len_assignment (stmtblock_t *block, gfc_expr * le,
else if (temp_rhs && re->ts.type == BT_CLASS)
{
vptr_expr = NULL;
- se.expr = gfc_class_vptr_get (rse->expr);
+ if (class_expr)
+ tmp = class_expr;
+ else if (!GFC_CLASS_TYPE_P (TREE_TYPE (rse->expr)))
+ tmp = gfc_get_class_from_expr (rse->expr);
+ else
+ tmp = rse->expr;
+
+ se.expr = gfc_class_vptr_get (tmp);
if (UNLIMITED_POLY (re))
- from_len = gfc_class_len_get (rse->expr);
+ from_len = gfc_class_len_get (tmp);
+
}
else if (re->expr_type != EXPR_NULL)
/* Only when rhs is non-NULL use its declared type for vptr
@@ -9810,8 +9874,12 @@ arrayfunc_assign_needs_temporary (gfc_expr * expr1, gfc_expr * expr2)
return true;
/* Functions returning pointers or allocatables need temporaries. */
- if (gfc_expr_attr (expr2).pointer
- || gfc_expr_attr (expr2).allocatable)
+ c = expr2->value.function.esym
+ ? (expr2->value.function.esym->attr.pointer
+ || expr2->value.function.esym->attr.allocatable)
+ : (expr2->symtree->n.sym->attr.pointer
+ || expr2->symtree->n.sym->attr.allocatable);
+ if (c)
return true;
/* Character array functions need temporaries unless the
@@ -10666,23 +10734,53 @@ trans_class_assignment (stmtblock_t *block, gfc_expr *lhs, gfc_expr *rhs,
gfc_se *lse, gfc_se *rse, bool use_vptr_copy,
bool class_realloc)
{
- tree tmp, fcn, stdcopy, to_len, from_len, vptr;
+ tree tmp, fcn, stdcopy, to_len, from_len, vptr, old_vptr;
vec<tree, va_gc> *args = NULL;
+ /* Store the old vptr so that dynamic types can be compared for
+ reallocation to occur or not. */
+ if (class_realloc)
+ {
+ tmp = lse->expr;
+ if (!GFC_CLASS_TYPE_P (TREE_TYPE (tmp)))
+ tmp = gfc_get_class_from_expr (tmp);
+ }
+
vptr = trans_class_vptr_len_assignment (block, lhs, rhs, rse, &to_len,
&from_len);
- /* Generate allocation of the lhs. */
+ /* Generate (re)allocation of the lhs. */
if (class_realloc)
{
- stmtblock_t alloc;
- tree class_han;
+ stmtblock_t alloc, re_alloc;
+ tree class_han, re, size;
- tmp = gfc_vptr_size_get (vptr);
+ if (tmp && GFC_CLASS_TYPE_P (TREE_TYPE (tmp)))
+ old_vptr = gfc_evaluate_now (gfc_class_vptr_get (tmp), block);
+ else
+ old_vptr = build_int_cst (TREE_TYPE (vptr), 0);
+
+ size = gfc_vptr_size_get (vptr);
class_han = GFC_CLASS_TYPE_P (TREE_TYPE (lse->expr))
? gfc_class_data_get (lse->expr) : lse->expr;
+
+ /* Allocate block. */
gfc_init_block (&alloc);
- gfc_allocate_using_malloc (&alloc, class_han, tmp, NULL_TREE);
+ gfc_allocate_using_malloc (&alloc, class_han, size, NULL_TREE);
+
+ /* Reallocate if dynamic types are different. */
+ gfc_init_block (&re_alloc);
+ re = build_call_expr_loc (input_location,
+ builtin_decl_explicit (BUILT_IN_REALLOC), 2,
+ fold_convert (pvoid_type_node, class_han),
+ size);
+ tmp = fold_build2_loc (input_location, NE_EXPR,
+ logical_type_node, vptr, old_vptr);
+ re = fold_build3_loc (input_location, COND_EXPR, void_type_node,
+ tmp, re, build_empty_stmt (input_location));
+ gfc_add_expr_to_block (&re_alloc, re);
+
+ /* Allocate if _data is NULL, reallocate otherwise. */
tmp = fold_build2_loc (input_location, EQ_EXPR,
logical_type_node, class_han,
build_int_cst (prvoid_type_node, 0));
@@ -10690,7 +10788,7 @@ trans_class_assignment (stmtblock_t *block, gfc_expr *lhs, gfc_expr *rhs,
gfc_unlikely (tmp,
PRED_FORTRAN_FAIL_ALLOC),
gfc_finish_block (&alloc),
- build_empty_stmt (input_location));
+ gfc_finish_block (&re_alloc));
gfc_add_expr_to_block (&lse->pre, tmp);
}
@@ -10793,6 +10891,7 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
bool maybe_workshare = false, lhs_refs_comp = false, rhs_refs_comp = false;
symbol_attribute lhs_caf_attr, rhs_caf_attr, lhs_attr;
bool is_poly_assign;
+ bool realloc_flag;
/* Assignment of the form lhs = rhs. */
gfc_start_block (&block);
@@ -10833,6 +10932,10 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
|| gfc_is_class_array_ref (expr2, NULL)
|| gfc_is_class_scalar_expr (expr2));
+ realloc_flag = flag_realloc_lhs
+ && gfc_is_reallocatable_lhs (expr1)
+ && expr2->rank
+ && !is_runtime_conformable (expr1, expr2);
/* Only analyze the expressions for coarray properties, when in coarray-lib
mode. */
@@ -11077,8 +11180,9 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
if (is_poly_assign)
tmp = trans_class_assignment (&body, expr1, expr2, &lse, &rse,
use_vptr_copy || (lhs_attr.allocatable
- && !lhs_attr.dimension),
- flag_realloc_lhs && !lhs_attr.pointer);
+ && !lhs_attr.dimension),
+ !realloc_flag && flag_realloc_lhs
+ && !lhs_attr.pointer);
else if (flag_coarray == GFC_FCOARRAY_LIB
&& lhs_caf_attr.codimension && rhs_caf_attr.codimension
&& ((lhs_caf_attr.allocatable && lhs_refs_comp)
@@ -11183,10 +11287,7 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
}
/* F2003: Allocate or reallocate lhs of allocatable array. */
- if (flag_realloc_lhs
- && gfc_is_reallocatable_lhs (expr1)
- && expr2->rank
- && !is_runtime_conformable (expr1, expr2))
+ if (realloc_flag)
{
realloc_lhs_warning (expr1->ts.type, true, &expr1->where);
ompws_flags &= ~OMPWS_SCALARIZER_WS;
@@ -11295,8 +11396,7 @@ gfc_trans_assignment (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
return tmp;
}
- if (UNLIMITED_POLY (expr1) && expr1->rank
- && expr2->ts.type != BT_CLASS)
+ if (UNLIMITED_POLY (expr1) && expr1->rank)
use_vptr_copy = true;
/* Fallback to the scalarizer to generate explicit loops. */
diff --git a/gcc/fortran/trans.c b/gcc/fortran/trans.c
index 025abe38985..a1239ec2b53 100644
--- a/gcc/fortran/trans.c
+++ b/gcc/fortran/trans.c
@@ -435,21 +435,7 @@ gfc_build_array_ref (tree base, tree offset, tree decl, tree vptr)
/* Check if this is an unlimited polymorphic object carrying a character
payload. In this case, the 'len' field is non-zero. */
if (decl && GFC_CLASS_TYPE_P (TREE_TYPE (decl)))
- {
- tmp = gfc_class_len_or_zero_get (decl);
- if (!integer_zerop (tmp))
- {
- tree cond;
- tree stype = TREE_TYPE (span);
- tmp = fold_convert (stype, tmp);
- cond = fold_build2_loc (input_location, EQ_EXPR,
- logical_type_node, tmp,
- build_int_cst (stype, 0));
- tmp = fold_build2 (MULT_EXPR, stype, span, tmp);
- span = fold_build3_loc (input_location, COND_EXPR, stype,
- cond, span, tmp);
- }
- }
+ span = gfc_resize_class_size_with_len (NULL, decl, span);
}
else if (decl)
span = get_array_span (type, decl);
diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h
index 16b4215605e..437a570c484 100644
--- a/gcc/fortran/trans.h
+++ b/gcc/fortran/trans.h
@@ -423,6 +423,7 @@ tree gfc_class_data_get (tree);
tree gfc_class_vptr_get (tree);
tree gfc_class_len_get (tree);
tree gfc_class_len_or_zero_get (tree);
+tree gfc_resize_class_size_with_len (stmtblock_t *, tree, tree);
gfc_expr * gfc_find_and_cut_at_last_class_ref (gfc_expr *, bool is_mold = false);
/* Get an accessor to the class' vtab's * field, when a class handle is
available. */
diff --git a/gcc/testsuite/gfortran.dg/dependency_57.f90 b/gcc/testsuite/gfortran.dg/dependency_57.f90
index fdf95b24c63..e8aab334b62 100644
--- a/gcc/testsuite/gfortran.dg/dependency_57.f90
+++ b/gcc/testsuite/gfortran.dg/dependency_57.f90
@@ -1,12 +1,18 @@
-! { dg-do compile }
+! { dg-do run }
! PR 92755 - this used to cause an ICE.
! Original test case by Gerhard Steinmetz
program p
type t
+ integer :: i
end type
type t2
class(t), allocatable :: a(:)
end type
type(t2) :: z
+ z%a = [t(1),t(2),t(3)]
z%a = [z%a]
+ select type (y => z%a)
+ type is (t)
+ if (any (y%i .ne. [1, 2, 3])) stop 1
+ end select
end
^ permalink raw reply [flat|nested] 18+ messages in thread
* Re: [Patch, fortran] PR83118 - [8/9/10/11 Regression] Bad intrinsic assignment of class(*) array component of derived type
2020-10-29 15:59 Paul Richard Thomas
2020-11-03 8:42 ` Paul Richard Thomas
@ 2020-11-06 17:48 ` Tobias Burnus
2020-11-10 13:25 ` Paul Richard Thomas
2 siblings, 0 replies; 18+ messages in thread
From: Tobias Burnus @ 2020-11-06 17:48 UTC (permalink / raw)
To: Paul Richard Thomas, fortran, gcc-patches
Hi Paul,
sorry for the belated attempt to review your patch.
Attempt as both via @gcc.gnu.org as in the direct email,
I did not see the attached patch.
(Matches what Andre mentioned to you today at IRC #gfortran.)
I only see:
* Content-Type: multipart/alternative
Content-Type: text/plain; charset="UTF-8"
* Content-Type: text/html; charset="UTF-8"
(Side remark: I did not know that GCC now accepts
text/html multipart emails. Still, it is better to
avoid this.)
* Content-Type: application/octet-stream; name="Change2.Logs"
* Content-Type: application/octet-stream; name="unlimited_polymorphic_32.f03
Regarding the changelog: There first line got he git commit is missing.
That should be a single (not too long) line, which "git log --oneline"
shows, followed by an empty line.
If possible, it is a substring of the email subject (if that makes sense).
For this thread, it helps if "PR83118" is present in that line, which is
also in the thread name.
Additionally spotted:
"Reallocation of lhs only to happen if siz changes"
Typo "siz"? Or is this a badly named variable name?
Tobias
-----------------
Mentor Graphics (Deutschland) GmbH, Arnulfstraße 201, 80634 München / Germany
Registergericht München HRB 106955, Geschäftsführer: Thomas Heurung, Alexander Walter
^ permalink raw reply [flat|nested] 18+ messages in thread
* Re: [Patch, fortran] PR83118 - [8/9/10/11 Regression] Bad intrinsic assignment of class(*) array component of derived type
2020-10-29 15:59 Paul Richard Thomas
@ 2020-11-03 8:42 ` Paul Richard Thomas
2020-11-06 17:48 ` Tobias Burnus
2020-11-10 13:25 ` Paul Richard Thomas
2 siblings, 0 replies; 18+ messages in thread
From: Paul Richard Thomas @ 2020-11-03 8:42 UTC (permalink / raw)
To: fortran, gcc-patches; +Cc: Damian Rouson, Tobias Burnus
Ping!
On Thu, 29 Oct 2020 at 15:59, Paul Richard Thomas <
paul.richard.thomas@gmail.com> wrote:
> Hi Everyone,
>
> I am afraid that this is a rather long sad story, mainly due to my efforts
> with gfortran being interrupted by daytime work. I posted the first version
> of the patch nearly a year ago but this was derailed by Tobias's question
> at: https://gcc.gnu.org/legacy-ml/fortran/2019-11/msg00098.html
>
> (i) The attached fixes the original problem and is tested by
> gfortran.dg/unlimited_polymorphic_32.f03.
> (ii) In fixing the original problem, a fair amount of effort was required
> to get the element length correct for class temporaries produced by
> dependencies in class assignment (see footnote). This is reflected in the
> changes to trans_array.c(gfc_alloc_allocatable_for_assignment).
> (iii) Tobias's testcase in the above posting to the list didn't address
> itself to class arrays of the original problem. However, it revealed that
> reallocation was not occuring at all for scalar assignments. This is fixed
> by the large chunk in trans-expr.c(trans_class_assignment). The array case
> is 'fixed' by testing for unequal element sizes between lhs and rhs before
> reallocation in gfc_alloc_allocatable_for_assignment. This is difficult to
> test for since, in most cases, the system returns that same address after
> reallocation.
> (iv) dependency_57.f90 segfaulted at runtime. The other work in
> trans_class_assignment was required to fix this.
> (v) A number of minor tidy ups were done including the new function
> gfc_resize_class_size_with_len to eliminate some repeated code.
>
> This all bootstraps and regtests on FC31/x86_64 - OK for master?
>
> Cheers
>
> Paul
>
> This patch fixes PR83118 and fixes one or two other niggles in handling
> class objects - most importantly class array temporaries required, where
> dependences occur in class assignment, and a correct implementation of
> reallocation on assignment.
>
> 2020-10-29 Paul Thomas <pault@gcc.gnu.org>
>
> gcc/fortran
> PR fortran/83118
> * resolve.c (resolve_ordinary_assign): Generate a vtable if
> necessary for scalar non-polymorphic rhs's to unlimited lhs's.
> * trans-array.c (gfc_trans_allocate_array_storage): Defer
> obtaining class element type until all sources of class exprs.
> are tried. Use class API rather than TREE_OPERAND. Look for
> class expressions in ss->info. After this, obtain the element
> size for class payloads. Cast the data as character(len=size)
> to overcome unlimited polymorphic problems.
> (structure_alloc_comps): Replace code that replicates the new
> function gfc_resize_class_size_with_len.
> (gfc_alloc_allocatable_for_assignment): Obtain element size
> for lhs in cases of deferred characters and class enitities.
> Move code for the element size of rhs to start of block. Clean
> up extraction of class parmateres throughout this function.
> After the shape check test whether or not the lhs and rhs
> element sizes are the same. Use earlier evaluation of
> 'cond_null'. Reallocation of lhs only to happen if siz changes
> or element size changes.
> * trans-expr.c (gfc_resize_class_size_with_len): New function.
> (gfc_conv_procedure_call): Ensure the vtable is present for
> passing a non-class actual to an unlimited formal.
> (trans_class_vptr_len_assignment): For expressions of type
> BT_CLASS, extract the class expression if necessary. Use a
> statement block outside the loop body. Ensure that 'rhs' is
> of the correct type. Obtain rhs vptr in all circumstances.
> (gfc_trans_assignment_1): Simplify some of the logic with
> 'realloc_flag'. Set 'vptr_copy' for all array assignments to
> unlimited polymorphic lhs.
> * trans-c (gfc_build_array_ref): Call gfc_resize_class_size_
> with_len to correct span for unlimited polymorphic decls.
> * trans.h : Add prototype for gfc_resize_class_size_with_len.
>
> gcc/testsuite/
> PR fortran/83118
> * gfortran.dg/dependency_57.f90: Change to dg-run and test
> for correct result.
> * gfortran.dg/unlimited_polymorphic_32.f03: New test.
>
> Footnote: I have come to the conclusion that
> gfc_trans_allocate_array_storage is the last place that we should be
> dealing with class array temporaries, or directly at least. I will give
> some thought as to how to do it better. Also, chunks of code are coming
> within scalarization loops that should be outside:
> x->_vptr = (struct __vtype__STAR * {ref-all})
> &__vtab_INTEGER_4_;
> x->_len = 0;
> D.3977 = x->_vptr->_size;
> D.3978 = x->_len;
> D.3979 = D.3978 > 0 ? D.3977 * D.3978 : D.3977;
>
>
>
--
"If you can't explain it simply, you don't understand it well enough" -
Albert Einstein
^ permalink raw reply [flat|nested] 18+ messages in thread
* [Patch, fortran] PR83118 - [8/9/10/11 Regression] Bad intrinsic assignment of class(*) array component of derived type
@ 2020-10-29 15:59 Paul Richard Thomas
2020-11-03 8:42 ` Paul Richard Thomas
` (2 more replies)
0 siblings, 3 replies; 18+ messages in thread
From: Paul Richard Thomas @ 2020-10-29 15:59 UTC (permalink / raw)
To: fortran, gcc-patches; +Cc: Damian Rouson, Tobias Burnus
[-- Attachment #1: Type: text/plain, Size: 4362 bytes --]
Hi Everyone,
I am afraid that this is a rather long sad story, mainly due to my efforts
with gfortran being interrupted by daytime work. I posted the first version
of the patch nearly a year ago but this was derailed by Tobias's question
at: https://gcc.gnu.org/legacy-ml/fortran/2019-11/msg00098.html
(i) The attached fixes the original problem and is tested by
gfortran.dg/unlimited_polymorphic_32.f03.
(ii) In fixing the original problem, a fair amount of effort was required
to get the element length correct for class temporaries produced by
dependencies in class assignment (see footnote). This is reflected in the
changes to trans_array.c(gfc_alloc_allocatable_for_assignment).
(iii) Tobias's testcase in the above posting to the list didn't address
itself to class arrays of the original problem. However, it revealed that
reallocation was not occuring at all for scalar assignments. This is fixed
by the large chunk in trans-expr.c(trans_class_assignment). The array case
is 'fixed' by testing for unequal element sizes between lhs and rhs before
reallocation in gfc_alloc_allocatable_for_assignment. This is difficult to
test for since, in most cases, the system returns that same address after
reallocation.
(iv) dependency_57.f90 segfaulted at runtime. The other work in
trans_class_assignment was required to fix this.
(v) A number of minor tidy ups were done including the new function
gfc_resize_class_size_with_len to eliminate some repeated code.
This all bootstraps and regtests on FC31/x86_64 - OK for master?
Cheers
Paul
This patch fixes PR83118 and fixes one or two other niggles in handling
class objects - most importantly class array temporaries required, where
dependences occur in class assignment, and a correct implementation of
reallocation on assignment.
2020-10-29 Paul Thomas <pault@gcc.gnu.org>
gcc/fortran
PR fortran/83118
* resolve.c (resolve_ordinary_assign): Generate a vtable if
necessary for scalar non-polymorphic rhs's to unlimited lhs's.
* trans-array.c (gfc_trans_allocate_array_storage): Defer
obtaining class element type until all sources of class exprs.
are tried. Use class API rather than TREE_OPERAND. Look for
class expressions in ss->info. After this, obtain the element
size for class payloads. Cast the data as character(len=size)
to overcome unlimited polymorphic problems.
(structure_alloc_comps): Replace code that replicates the new
function gfc_resize_class_size_with_len.
(gfc_alloc_allocatable_for_assignment): Obtain element size
for lhs in cases of deferred characters and class enitities.
Move code for the element size of rhs to start of block. Clean
up extraction of class parmateres throughout this function.
After the shape check test whether or not the lhs and rhs
element sizes are the same. Use earlier evaluation of
'cond_null'. Reallocation of lhs only to happen if siz changes
or element size changes.
* trans-expr.c (gfc_resize_class_size_with_len): New function.
(gfc_conv_procedure_call): Ensure the vtable is present for
passing a non-class actual to an unlimited formal.
(trans_class_vptr_len_assignment): For expressions of type
BT_CLASS, extract the class expression if necessary. Use a
statement block outside the loop body. Ensure that 'rhs' is
of the correct type. Obtain rhs vptr in all circumstances.
(gfc_trans_assignment_1): Simplify some of the logic with
'realloc_flag'. Set 'vptr_copy' for all array assignments to
unlimited polymorphic lhs.
* trans-c (gfc_build_array_ref): Call gfc_resize_class_size_
with_len to correct span for unlimited polymorphic decls.
* trans.h : Add prototype for gfc_resize_class_size_with_len.
gcc/testsuite/
PR fortran/83118
* gfortran.dg/dependency_57.f90: Change to dg-run and test
for correct result.
* gfortran.dg/unlimited_polymorphic_32.f03: New test.
Footnote: I have come to the conclusion that
gfc_trans_allocate_array_storage is the last place that we should be
dealing with class array temporaries, or directly at least. I will give
some thought as to how to do it better. Also, chunks of code are coming
within scalarization loops that should be outside:
x->_vptr = (struct __vtype__STAR * {ref-all})
&__vtab_INTEGER_4_;
x->_len = 0;
D.3977 = x->_vptr->_size;
D.3978 = x->_len;
D.3979 = D.3978 > 0 ? D.3977 * D.3978 : D.3977;
[-- Attachment #2: Change2.Logs --]
[-- Type: application/octet-stream, Size: 2279 bytes --]
This patch fixes PR83118 and fixes one or two other niggles in handling
class objects - most importantly class array temporaries required, where
dependences occur in class assignment, and a correct implementation of
reallocation on assignment.
2020-10-29 Paul Thomas <pault@gcc.gnu.org>
gcc/fortran
PR fortran/83118
* resolve.c (resolve_ordinary_assign): Generate a vtable if
necessary for scalar non-polymorphic rhs's to unlimited lhs's.
* trans-array.c (gfc_trans_allocate_array_storage): Defer
obtaining class element type until all sources of class exprs.
are tried. Use class API rather than TREE_OPERAND. Look for
class expressions in ss->info. After this, obtain the element
size for class payloads. Cast the data as character(len=size)
to overcome unlimited polymorphic problems.
(structure_alloc_comps): Replace code that replicates the new
function gfc_resize_class_size_with_len.
(gfc_alloc_allocatable_for_assignment): Obtain element size
for lhs in cases of deferred characters and class enitities.
Move code for the element size of rhs to start of block. Clean
up extraction of class parmateres throughout this function.
After the shape check test whether or not the lhs and rhs
element sizes are the same. Use earlier evaluation of
'cond_null'. Reallocation of lhs only to happen if siz changes
or element size changes.
* trans-expr.c (gfc_resize_class_size_with_len): New function.
(gfc_conv_procedure_call): Ensure the vtable is present for
passing a non-class actual to an unlimited formal.
(trans_class_vptr_len_assignment): For expressions of type
BT_CLASS, extract the class expression if necessary. Use a
statement block outside the loop body. Ensure that 'rhs' is
of the correct type. Obtain rhs vptr in all circumstances.
(gfc_trans_assignment_1): Simplify some of the logic with
'realloc_flag'. Set 'vptr_copy' for all array assignments to
unlimited polymorphic lhs.
* trans-c (gfc_build_array_ref): Call gfc_resize_class_size_
with_len to correct span for unlimited polymorphic decls.
* trans.h : Add prototype for gfc_resize_class_size_with_len.
gcc/testsuite/
PR fortran/83118
* gfortran.dg/dependency_57.f90: Change to dg-run and test
for correct result.
* gfortran.dg/unlimited_polymorphic_31.f03: New test.
[-- Attachment #3: unlimited_polymorphic_32.f03 --]
[-- Type: application/octet-stream, Size: 1608 bytes --]
! { dg-do run }
!
! Test the fix of the test case referenced in comment 17 of PR83118.
!
! Contributed by Damian Rouson <damian@sourceryinstitute.org>
!
implicit none
type Wrapper
class(*), allocatable :: elements(:)
end type
type Mytype
real(4) :: r = 42.0
end type
call driver
contains
subroutine driver
class(*), allocatable :: obj
type(Wrapper) w
integer(4) :: expected4(2) = [42_4, 43_4]
integer(8) :: expected8(3) = [42_8, 43_8, 44_8]
w = new_wrapper (expected4)
obj = w
call test (obj, 0)
obj = new_wrapper (expected8) ! Used to generate a linker error
call test (obj, 10)
obj = new_wrapper ([mytype (99.0)])
call test (obj, 100)
obj = Mytype (42.0) ! Used to generate a linker error
call test (obj, 1000)
end subroutine
function new_wrapper(array) result (res)
class(*) :: array(:)
type(Wrapper) :: res
res%elements = array ! Used to runtime segfault
end function
subroutine test (arg, idx)
class(*) :: arg
integer :: idx
select type (arg)
type is (wrapper)
select type (z => arg%elements)
type is (integer(4))
if (any (z .ne. [42_4, 43_4])) stop 1 + idx
type is (integer(8))
if (any (z .ne. [42_8, 43_8, 44_8])) stop 1 + idx
type is (Mytype)
if (abs (z(1)%r - 99.0) .ge. 1e-6) stop 1 + idx
class default
stop 2 + idx
end select
type is (Mytype)
if (abs (arg%r - 42.0) .ge. 1e-6) stop 1 + idx
class default
stop 3 + idx
end select
end subroutine
end
^ permalink raw reply [flat|nested] 18+ messages in thread
end of thread, other threads:[~2020-12-26 15:13 UTC | newest]
Thread overview: 18+ messages (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
2020-11-11 16:42 [Patch, fortran] PR83118 - [8/9/10/11 Regression] Bad intrinsic assignment of class(*) array component of derived type dhumieres.dominique
2020-11-11 17:11 ` Paul Richard Thomas
2020-11-15 8:59 ` Paul Richard Thomas
[not found] ` <7f560751852d070b03db7480d59642c8@free.fr>
[not found] ` <CAGkQGiLv3tMGpOrQ8Cj7hLgbKNG+seiLG8de3VLufwg47SPD3g@mail.gmail.com>
2020-12-06 17:14 ` dhumieres.dominique
2020-12-05 10:19 ` Paul Richard Thomas
2020-12-12 18:31 ` Thomas Koenig
2020-12-18 14:04 ` Paul Richard Thomas
2020-12-23 17:36 ` Paul Richard Thomas
2020-12-25 11:04 ` Thomas Koenig
2020-12-26 9:04 ` Paul Richard Thomas
2020-12-26 15:13 ` Paul Richard Thomas
-- strict thread matches above, loose matches on Subject: below --
2020-10-29 15:59 Paul Richard Thomas
2020-11-03 8:42 ` Paul Richard Thomas
2020-11-06 17:48 ` Tobias Burnus
2020-11-10 13:25 ` Paul Richard Thomas
2020-11-10 22:16 ` Thomas Koenig
2020-11-11 9:47 ` Paul Richard Thomas
2020-11-11 11:58 ` Tobias Burnus
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).