[gcc r15-1090] Fix returned type to be allocatable for user-functions.
Andre Vehreschild
vehre@gcc.gnu.org
Fri Jun 7 08:10:50 GMT 2024
https://gcc.gnu.org/g:51046e46ae66ca95bf2b93ae60f0c4d6b338f8af
commit r15-1090-g51046e46ae66ca95bf2b93ae60f0c4d6b338f8af
Author: Andre Vehreschild <vehre@gcc.gnu.org>
Date: Wed Jul 19 11:57:43 2023 +0200
Fix returned type to be allocatable for user-functions.
The returned type of user-defined function returning a
class object was not detected and handled correctly, which
lead to memory leaks.
PR fortran/90072
gcc/fortran/ChangeLog:
* expr.cc (gfc_is_alloc_class_scalar_function): Detect
allocatable class return types also for user-defined
functions.
* trans-expr.cc (gfc_conv_procedure_call): Same.
(trans_class_vptr_len_assignment): Compute vptr len
assignment correctly for user-defined functions.
gcc/testsuite/ChangeLog:
* gfortran.dg/class_77.f90: New test.
Diff:
---
gcc/fortran/expr.cc | 13 ++++--
gcc/fortran/trans-expr.cc | 35 +++++++-------
gcc/testsuite/gfortran.dg/class_77.f90 | 83 ++++++++++++++++++++++++++++++++++
3 files changed, 109 insertions(+), 22 deletions(-)
diff --git a/gcc/fortran/expr.cc b/gcc/fortran/expr.cc
index a162744c719..be138d196a2 100644
--- a/gcc/fortran/expr.cc
+++ b/gcc/fortran/expr.cc
@@ -5573,11 +5573,14 @@ bool
gfc_is_alloc_class_scalar_function (gfc_expr *expr)
{
if (expr->expr_type == EXPR_FUNCTION
- && expr->value.function.esym
- && expr->value.function.esym->result
- && expr->value.function.esym->result->ts.type == BT_CLASS
- && !CLASS_DATA (expr->value.function.esym->result)->attr.dimension
- && CLASS_DATA (expr->value.function.esym->result)->attr.allocatable)
+ && ((expr->value.function.esym
+ && expr->value.function.esym->result
+ && expr->value.function.esym->result->ts.type == BT_CLASS
+ && !CLASS_DATA (expr->value.function.esym->result)->attr.dimension
+ && CLASS_DATA (expr->value.function.esym->result)->attr.allocatable)
+ || (expr->ts.type == BT_CLASS
+ && CLASS_DATA (expr)->attr.allocatable
+ && !CLASS_DATA (expr)->attr.dimension)))
return true;
return false;
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index 9f6cc8f871e..d6f4d6bfe45 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -8301,7 +8301,9 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
}
/* Finalize the result, if necessary. */
- attr = CLASS_DATA (expr->value.function.esym->result)->attr;
+ attr = expr->value.function.esym
+ ? CLASS_DATA (expr->value.function.esym->result)->attr
+ : CLASS_DATA (expr)->attr;
if (!((gfc_is_class_array_function (expr)
|| gfc_is_alloc_class_scalar_function (expr))
&& attr.pointer))
@@ -10085,27 +10087,26 @@ trans_class_vptr_len_assignment (stmtblock_t *block, gfc_expr * le,
if (re->expr_type != EXPR_VARIABLE && re->expr_type != EXPR_NULL
&& 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);
+ if (!DECL_P (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 (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));
+ if (class_expr != NULL_TREE && UNLIMITED_POLY (re))
+ tmp = gfc_evaluate_now (TREE_OPERAND (rse->expr, 0), &rse->pre);
+ else
+ tmp = gfc_evaluate_now (rse->expr, &rse->pre);
+
+ rse->expr = tmp;
}
else
- {
- tmp = gfc_create_var (TREE_TYPE (rse->expr), "rhs");
- gfc_add_modify (&rse->pre, tmp, rse->expr);
- }
+ pre = &rse->pre;
- rse->expr = tmp;
temp_rhs = true;
}
diff --git a/gcc/testsuite/gfortran.dg/class_77.f90 b/gcc/testsuite/gfortran.dg/class_77.f90
new file mode 100644
index 00000000000..ef38dd67743
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/class_77.f90
@@ -0,0 +1,83 @@
+! { dg-do compile }
+! { dg-additional-options "-fdump-tree-original" }
+!
+! PR fortran/90072
+!
+! Contributed by Brad Richardson <everythingfunctional@protonmail.com>
+!
+
+module types
+ implicit none
+
+ type, abstract :: base_returned
+ end type base_returned
+
+ type, extends(base_returned) :: first_returned
+ end type first_returned
+
+ type, extends(base_returned) :: second_returned
+ end type second_returned
+
+ type, abstract :: base_called
+ contains
+ procedure(get_), deferred :: get
+ end type base_called
+
+ type, extends(base_called) :: first_extended
+ contains
+ procedure :: get => getFirst
+ end type first_extended
+
+ type, extends(base_called) :: second_extended
+ contains
+ procedure :: get => getSecond
+ end type second_extended
+
+ abstract interface
+ function get_(self) result(returned)
+ import base_called
+ import base_returned
+ class(base_called), intent(in) :: self
+ class(base_returned), allocatable :: returned
+ end function get_
+ end interface
+contains
+ function getFirst(self) result(returned)
+ class(first_extended), intent(in) :: self
+ class(base_returned), allocatable :: returned
+
+ allocate(returned, source = first_returned())
+ end function getFirst
+
+ function getSecond(self) result(returned)
+ class(second_extended), intent(in) :: self
+ class(base_returned), allocatable :: returned
+
+ allocate(returned, source = second_returned())
+ end function getSecond
+end module types
+
+program dispatch_memory_leak
+ implicit none
+
+ call run()
+contains
+ subroutine run()
+ use types, only: base_returned, base_called, first_extended
+
+ class(base_called), allocatable :: to_call
+ class(base_returned), allocatable :: to_get
+
+ allocate(to_call, source = first_extended())
+ allocate(to_get, source = to_call%get())
+
+ deallocate(to_get)
+ select type(to_call)
+ type is (first_extended)
+ allocate(to_get, source = to_call%get())
+ end select
+ end subroutine run
+end program dispatch_memory_leak
+
+! { dg-final { scan-tree-dump-times "__builtin_free" 5 "original" } }
+
More information about the Gcc-cvs
mailing list