[PR,Fortran/90072] Polymorphic Dispatch to Polymophic Return Type Memory Leak

From e79072de7279cc6863914588e4a0457f0c3493fd Mon Sep 17 00:00:00 2001
From: Andre Vehreschild <vehre@gcc.gnu.org>
Date: Wed, 19 Jul 2023 11:57:43 +0200
Subject: [PATCH] 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.
---
 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(-)
 create mode 100644 gcc/testsuite/gfortran.dg/class_77.f90

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" } }
+
--
2.45.1