public inbox for gcc-cvs@sourceware.org
help / color / mirror / Atom feed
* [gcc r14-5931] Fortran: fix reallocation on assignment of polymorphic variables [PR110415]
@ 2023-11-28 15:27 Andrew Jenner
0 siblings, 0 replies; only message in thread
From: Andrew Jenner @ 2023-11-28 15:27 UTC (permalink / raw)
To: gcc-cvs
https://gcc.gnu.org/g:b247e917ff13328298c1eecf8563b12edd7ade04
commit r14-5931-gb247e917ff13328298c1eecf8563b12edd7ade04
Author: Andrew Jenner <andrew@codesourcery.com>
Date: Tue Nov 28 15:27:05 2023 +0000
Fortran: fix reallocation on assignment of polymorphic variables [PR110415]
This patch fixes two bugs related to polymorphic class assignment in the
Fortran front-end. One (described in PR110415) is an issue with the malloc
and realloc calls using the size from the old vptr rather than the new one.
The other is caused by the return value from the realloc call being ignored.
Testcases are added for these issues.
2023-11-28 Andrew Jenner <andrew@codesourcery.com>
gcc/fortran/
PR fortran/110415
* trans-expr.cc (trans_class_vptr_len_assignment): Add
from_vptrp parameter. Populate it. Don't check for DECL_P
when deciding whether to create temporary.
(trans_class_pointer_fcn, gfc_trans_pointer_assignment): Add
NULL argument to trans_class_vptr_len_assignment calls.
(trans_class_assignment): Get rhs_vptr from
trans_class_vptr_len_assignment and use it for determining size
for allocation/reallocation. Use return value from realloc.
gcc/testsuite/
PR fortran/110415
* gfortran.dg/pr110415.f90: New test.
* gfortran.dg/asan/pr110415-2.f90: New test.
* gfortran.dg/asan/pr110415-3.f90: New test.
Co-Authored-By: Tobias Burnus <tobias@codesourcery.com>
Diff:
---
gcc/fortran/trans-expr.cc | 39 +++++++++++++--------
gcc/testsuite/gfortran.dg/asan/pr110415-2.f90 | 45 ++++++++++++++++++++++++
gcc/testsuite/gfortran.dg/asan/pr110415-3.f90 | 49 +++++++++++++++++++++++++++
gcc/testsuite/gfortran.dg/pr110415.f90 | 20 +++++++++++
4 files changed, 139 insertions(+), 14 deletions(-)
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index 50c4604a025..bfe9996ced6 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -9936,7 +9936,8 @@ trans_get_upoly_len (stmtblock_t *block, gfc_expr *expr)
static tree
trans_class_vptr_len_assignment (stmtblock_t *block, gfc_expr * le,
gfc_expr * re, gfc_se *rse,
- tree * to_lenp, tree * from_lenp)
+ tree * to_lenp, tree * from_lenp,
+ tree * from_vptrp)
{
gfc_se se;
gfc_expr * vptr_expr;
@@ -9944,10 +9945,11 @@ trans_class_vptr_len_assignment (stmtblock_t *block, gfc_expr * le,
bool set_vptr = false, temp_rhs = false;
stmtblock_t *pre = block;
tree class_expr = NULL_TREE;
+ tree from_vptr = 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))
+ && rse->expr != NULL_TREE)
{
if (re->ts.type == BT_CLASS && !GFC_CLASS_TYPE_P (TREE_TYPE (rse->expr)))
class_expr = gfc_get_class_from_expr (rse->expr);
@@ -10044,6 +10046,7 @@ trans_class_vptr_len_assignment (stmtblock_t *block, gfc_expr * le,
tmp = rse->expr;
se.expr = gfc_class_vptr_get (tmp);
+ from_vptr = se.expr;
if (UNLIMITED_POLY (re))
from_len = gfc_class_len_get (tmp);
@@ -10065,6 +10068,7 @@ trans_class_vptr_len_assignment (stmtblock_t *block, gfc_expr * le,
gfc_free_expr (vptr_expr);
gfc_add_block_to_block (block, &se.pre);
gcc_assert (se.post.head == NULL_TREE);
+ from_vptr = se.expr;
}
gfc_add_modify (pre, lhs_vptr, fold_convert (TREE_TYPE (lhs_vptr),
se.expr));
@@ -10093,11 +10097,13 @@ trans_class_vptr_len_assignment (stmtblock_t *block, gfc_expr * le,
}
}
- /* Return the _len trees only, when requested. */
+ /* Return the _len and _vptr trees only, when requested. */
if (to_lenp)
*to_lenp = to_len;
if (from_lenp)
*from_lenp = from_len;
+ if (from_vptrp)
+ *from_vptrp = from_vptr;
return lhs_vptr;
}
@@ -10166,7 +10172,7 @@ trans_class_pointer_fcn (stmtblock_t *block, gfc_se *lse, gfc_se *rse,
{
expr1_vptr = trans_class_vptr_len_assignment (block, expr1,
expr2, rse,
- NULL, NULL);
+ NULL, NULL, NULL);
gfc_add_block_to_block (block, &rse->pre);
tmp = gfc_create_var (TREE_TYPE (rse->expr), "ptrtemp");
gfc_add_modify (&lse->pre, tmp, rse->expr);
@@ -10242,7 +10248,7 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
if (non_proc_ptr_assign && expr1->ts.type == BT_CLASS)
{
trans_class_vptr_len_assignment (&block, expr1, expr2, &rse, NULL,
- NULL);
+ NULL, NULL);
lse.expr = gfc_class_data_get (lse.expr);
}
@@ -10371,7 +10377,8 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
if (expr1->ts.type == BT_CLASS)
expr1_vptr = trans_class_vptr_len_assignment (&block, expr1,
expr2, &rse,
- NULL, NULL);
+ NULL, NULL,
+ NULL);
}
}
else if (expr2->expr_type == EXPR_VARIABLE)
@@ -10388,7 +10395,7 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
rse.expr = NULL_TREE;
rse.string_length = strlen_rhs;
trans_class_vptr_len_assignment (&block, expr1, expr2, &rse,
- NULL, NULL);
+ NULL, NULL, NULL);
}
if (remap == NULL)
@@ -10421,7 +10428,7 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
{
expr1_vptr = trans_class_vptr_len_assignment (&block, expr1,
expr2, &rse, NULL,
- NULL);
+ NULL, NULL);
gfc_add_block_to_block (&block, &rse.pre);
tmp = gfc_create_var (TREE_TYPE (rse.expr), "ptrtemp");
gfc_add_modify (&lse.pre, tmp, rse.expr);
@@ -11819,7 +11826,7 @@ 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, old_vptr;
+ tree tmp, fcn, stdcopy, to_len, from_len, vptr, old_vptr, rhs_vptr;
vec<tree, va_gc> *args = NULL;
bool final_expr;
@@ -11843,7 +11850,9 @@ trans_class_assignment (stmtblock_t *block, gfc_expr *lhs, gfc_expr *rhs,
}
vptr = trans_class_vptr_len_assignment (block, lhs, rhs, rse, &to_len,
- &from_len);
+ &from_len, &rhs_vptr);
+ if (rhs_vptr == NULL_TREE)
+ rhs_vptr = vptr;
/* Generate (re)allocation of the lhs. */
if (class_realloc)
@@ -11856,7 +11865,7 @@ trans_class_assignment (stmtblock_t *block, gfc_expr *lhs, gfc_expr *rhs,
else
old_vptr = build_int_cst (TREE_TYPE (vptr), 0);
- size = gfc_vptr_size_get (vptr);
+ size = gfc_vptr_size_get (rhs_vptr);
tmp = lse->expr;
class_han = GFC_CLASS_TYPE_P (TREE_TYPE (tmp))
? gfc_class_data_get (tmp) : tmp;
@@ -11870,12 +11879,14 @@ trans_class_assignment (stmtblock_t *block, gfc_expr *lhs, gfc_expr *rhs,
/* Reallocate if dynamic types are different. */
gfc_init_block (&re_alloc);
+ tmp = fold_convert (pvoid_type_node, class_han);
re = build_call_expr_loc (input_location,
builtin_decl_explicit (BUILT_IN_REALLOC), 2,
- fold_convert (pvoid_type_node, class_han),
- size);
+ tmp, size);
+ re = fold_build2_loc (input_location, MODIFY_EXPR, TREE_TYPE (tmp), tmp,
+ re);
tmp = fold_build2_loc (input_location, NE_EXPR,
- logical_type_node, vptr, old_vptr);
+ logical_type_node, rhs_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);
diff --git a/gcc/testsuite/gfortran.dg/asan/pr110415-2.f90 b/gcc/testsuite/gfortran.dg/asan/pr110415-2.f90
new file mode 100755
index 00000000000..f4ff1823e54
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/asan/pr110415-2.f90
@@ -0,0 +1,45 @@
+! { dg-do run }
+!
+! Contributed by Brad Richardson <everythingfunctional@protonmail.com>
+!
+implicit none
+ type, abstract :: p
+ integer :: a = 4
+ end type p
+
+ type, extends(p) :: c
+ integer :: b = 7
+ character(len=:), allocatable :: str, str2(:)
+ end type c
+
+ type, extends(p) :: d
+ integer :: ef = 7
+ end type d
+
+ class(p), allocatable :: a
+
+ a = func()
+
+ a = func2()
+
+ a = func()
+
+ deallocate(a)
+
+contains
+ function func2() result(a)
+ class(p), allocatable :: a
+ a = d()
+ end function func2
+
+ function func() result(a)
+ class(p), allocatable :: a
+
+ a = c()
+ select type(a)
+ type is (c)
+ a%str = 'abcd'
+ a%str2 = ['abcd','efgh']
+ end select
+ end function func
+end program
diff --git a/gcc/testsuite/gfortran.dg/asan/pr110415-3.f90 b/gcc/testsuite/gfortran.dg/asan/pr110415-3.f90
new file mode 100755
index 00000000000..65c018d805f
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/asan/pr110415-3.f90
@@ -0,0 +1,49 @@
+! { dg-do run }
+!
+! Contributed by Brad Richardson <everythingfunctional@protonmail.com>
+!
+implicit none
+ type, abstract :: p
+ integer :: a = 4
+ end type p
+
+ type, extends(p) :: c
+ integer :: b = 7
+ character(len=:), allocatable :: str, str2(:)
+ end type c
+
+ type, extends(p) :: d
+ integer :: ef = 7
+ end type d
+
+ class(p), allocatable :: a(:)
+
+ a = func()
+
+ a = func2()
+
+ a = func()
+
+ deallocate(a)
+
+contains
+ function func2() result(a)
+ class(p), allocatable :: a(:)
+ a = [d(),d()]
+ end function func2
+
+ function func() result(a)
+ class(p), allocatable :: a(:)
+
+ a = [c(),c(),c()]
+ select type(a)
+ type is (c)
+ a(1)%str = 'abcd'
+ a(2)%str = 'abc'
+ a(3)%str = 'abcd4'
+ a(1)%str2 = ['abcd','efgh']
+ a(2)%str2 = ['bcd','fgh']
+ a(3)%str2 = ['abcd6','efgh7']
+ end select
+ end function func
+end program
diff --git a/gcc/testsuite/gfortran.dg/pr110415.f90 b/gcc/testsuite/gfortran.dg/pr110415.f90
new file mode 100644
index 00000000000..f647cc4c52c
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr110415.f90
@@ -0,0 +1,20 @@
+! { dg-do run }
+!
+! Contributed by Brad Richardson <everythingfunctional@protonmail.com>
+!
+ type, abstract :: p
+ end type p
+
+ type, extends(p) :: c
+ end type c
+
+ class(p), allocatable :: a
+
+ a = func()
+contains
+ function func() result(a)
+ class(p), allocatable :: a
+
+ a = c()
+ end function func
+end program
^ permalink raw reply [flat|nested] only message in thread
only message in thread, other threads:[~2023-11-28 15:27 UTC | newest]
Thread overview: (only message) (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
2023-11-28 15:27 [gcc r14-5931] Fortran: fix reallocation on assignment of polymorphic variables [PR110415] Andrew Jenner
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).