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 --git a/gcc/fortran/expr.cc b/gcc/fortran/expr.cc
index a162744c71934c12313ead1c4f04ceeec96d0a61..be138d196a23eb89ab05c9bbf946e3899b53606f 100644 (file)
--- 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 9f6cc8f871e246e6260cb525506e9d6b535faaa8..d6f4d6bfe4575372291aa238dee996a123e50fbb 100644 (file)
--- 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 (file)
index 0000000..ef38dd6
--- /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" } }
+