[gcc r15-1434] Fortran: Set the vptr of a class typed result.

[Andre Vehreschild]

https://gcc.gnu.org/g:dbb718175d7df89b957b316ba2f5fbea5d21b2b1

commit r15-1434-gdbb718175d7df89b957b316ba2f5fbea5d21b2b1
Author: Andre Vehreschild <vehre@gcc.gnu.org>
Date:   Thu Jun 6 14:01:13 2024 +0200

    Fortran: Set the vptr of a class typed result.
    
            PR fortran/90076
    
    gcc/fortran/ChangeLog:
    
            * trans-decl.cc (gfc_generate_function_code): Set vptr for
            results to declared class type.
            * trans-expr.cc (gfc_reset_vptr): Allow to provide the typespec
            instead of the expression.
            * trans.h (gfc_reset_vptr): Same.
    
    gcc/testsuite/ChangeLog:
    
            * gfortran.dg/class_76.f90: Add declared vtab occurrence.
            * gfortran.dg/class_78.f90: New test.

Diff:
---
 gcc/fortran/trans-decl.cc              | 11 ++++++-----
 gcc/fortran/trans-expr.cc              | 10 ++++++----
 gcc/fortran/trans.h                    |  4 +++-
 gcc/testsuite/gfortran.dg/class_76.f90 |  2 +-
 gcc/testsuite/gfortran.dg/class_78.f90 | 29 +++++++++++++++++++++++++++++
 5 files changed, 45 insertions(+), 11 deletions(-)

diff --git a/gcc/fortran/trans-decl.cc b/gcc/fortran/trans-decl.cc
index dca7779528bb..88538713a02b 100644
--- a/gcc/fortran/trans-decl.cc
+++ b/gcc/fortran/trans-decl.cc
@@ -7926,11 +7926,12 @@ gfc_generate_function_code (gfc_namespace * ns)
 		   && CLASS_DATA (sym)->attr.dimension == 0
 		   && sym->result == sym)
 	    {
-	      tmp = CLASS_DATA (sym)->backend_decl;
-	      tmp = fold_build3_loc (input_location, COMPONENT_REF,
-				     TREE_TYPE (tmp), result, tmp, NULL_TREE);
-	      gfc_add_modify (&init, tmp, fold_convert (TREE_TYPE (tmp),
-							null_pointer_node));
+	      tmp = gfc_class_data_get (result);
+	      gfc_add_modify (&init, tmp,
+			      fold_convert (TREE_TYPE (tmp),
+					    null_pointer_node));
+	      gfc_reset_vptr (&init, nullptr, result,
+			      CLASS_DATA (sym->result)->ts.u.derived);
 	    }
 	  else if (sym->ts.type == BT_DERIVED
 		   && !sym->attr.allocatable)
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index d6f4d6bfe457..558a73805169 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -530,13 +530,14 @@ gfc_find_and_cut_at_last_class_ref (gfc_expr *e, bool is_mold,
   return base_expr;
 }
 
-
 /* Reset the vptr to the declared type, e.g. after deallocation.
    Use the variable in CLASS_CONTAINER if available.  Otherwise, recreate
-   one with E.  The generated assignment code is added at the end of BLOCK.  */
+   one with e or derived.  At least one of the two has to be set.  The generated
+   assignment code is added at the end of BLOCK.  */
 
 void
-gfc_reset_vptr (stmtblock_t *block, gfc_expr *e, tree class_container)
+gfc_reset_vptr (stmtblock_t *block, gfc_expr *e, tree class_container,
+		gfc_symbol *derived)
 {
   tree vptr = NULL_TREE;
 
@@ -546,6 +547,7 @@ gfc_reset_vptr (stmtblock_t *block, gfc_expr *e, tree class_container)
   if (vptr == NULL_TREE)
     {
       gfc_se se;
+      gcc_assert (e);
 
       /* Evaluate the expression and obtain the vptr from it.  */
       gfc_init_se (&se, NULL);
@@ -570,7 +572,7 @@ gfc_reset_vptr (stmtblock_t *block, gfc_expr *e, tree class_container)
       tree vtable;
 
       /* Return the vptr to the address of the declared type.  */
-      vtab = gfc_find_derived_vtab (e->ts.u.derived);
+      vtab = gfc_find_derived_vtab (derived ? derived : e->ts.u.derived);
       vtable = vtab->backend_decl;
       if (vtable == NULL_TREE)
 	vtable = gfc_get_symbol_decl (vtab);
diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h
index f94fa6014004..5e064af5ccbd 100644
--- a/gcc/fortran/trans.h
+++ b/gcc/fortran/trans.h
@@ -451,7 +451,9 @@ tree gfc_vptr_def_init_get (tree);
 tree gfc_vptr_copy_get (tree);
 tree gfc_vptr_final_get (tree);
 tree gfc_vptr_deallocate_get (tree);
-void gfc_reset_vptr (stmtblock_t *, gfc_expr *, tree = NULL_TREE);
+void
+gfc_reset_vptr (stmtblock_t *, gfc_expr *, tree = NULL_TREE,
+		gfc_symbol * = nullptr);
 void gfc_reset_len (stmtblock_t *, gfc_expr *);
 tree gfc_get_class_from_gfc_expr (gfc_expr *);
 tree gfc_get_class_from_expr (tree);
diff --git a/gcc/testsuite/gfortran.dg/class_76.f90 b/gcc/testsuite/gfortran.dg/class_76.f90
index 1ee1e1fc25f2..c9842a15feab 100644
--- a/gcc/testsuite/gfortran.dg/class_76.f90
+++ b/gcc/testsuite/gfortran.dg/class_76.f90
@@ -61,6 +61,6 @@ contains
     end function newContainer
 end program returned_memory_leak
 
-! { dg-final { scan-tree-dump-times "newabstract" 14 "original" } }
+! { dg-final { scan-tree-dump-times "newabstract" 15 "original" } }
 ! { dg-final { scan-tree-dump-times "__builtin_free" 8 "original" } }
 
diff --git a/gcc/testsuite/gfortran.dg/class_78.f90 b/gcc/testsuite/gfortran.dg/class_78.f90
new file mode 100644
index 000000000000..3e2a0245afbf
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/class_78.f90
@@ -0,0 +1,29 @@
+! { dg-do run }
+!
+! PR fortran/90076
+!
+! Contributed by Brad Richardson  <everythingfunctional@protonmail.com>
+! 
+
+program assignment_memory_leak
+    implicit none
+
+    type, abstract :: base
+    end type base
+
+    type, extends(base) :: extended
+    end type extended
+
+    call run()
+contains
+    subroutine run()
+        class(base), allocatable :: var
+
+        var = newVar() ! Crash fixed
+    end subroutine run
+
+    function newVar()
+        class(extended), allocatable :: newVar
+    end function newVar
+end program assignment_memory_leak
+