[PATCH][regression][OpenMP][PR120286] Double free detected when using openmp

From 985517a4dcc92c4d8996b9530b6e1beb2333b8fc Mon Sep 17 00:00:00 2001
From: Christopher Albert <[email protected]>
Date: Tue, 10 Mar 2026 20:59:48 +0100
Subject: [PATCH] fortran: Preserve scalar class pointers in OpenMP
 privatization [PR120286]

OpenMP privatization currently treats scalar class pointers like owned
polymorphic class objects.  In the worker cleanup for private/firstprivate
class pointers, the generated code finalizes and frees ptr._data even though
the clause only copied pointer association status from a shared target.

Fix this in gfc_omp_clause_copy_ctor and gfc_omp_clause_dtor by unwrapping
saved descriptors first and by recognizing class-pointer container types
locally in those hooks.  That keeps scalar class pointers on the
association-only path without changing the broader polymorphic mapping
classification used for OpenMP warnings and deep mapping.

Add a runtime regression test for the original private(ptr) crash plus a
firstprivate(ptr) association check.

gcc/fortran/ChangeLog:

	PR fortran/120286
	* trans-openmp.cc (gfc_is_class_pointer_type): New helper.
	(gfc_omp_clause_copy_ctor): Unwrap saved descriptors before
	deciding whether privatization should preserve only pointer
	association.  Handle scalar class pointers on that path too.
	(gfc_omp_clause_dtor): Likewise.

gcc/testsuite/ChangeLog:

	PR fortran/120286
	* gfortran.dg/pr120286.f90: New test.

Signed-off-by: Christopher Albert <[email protected]>
---
 gcc/fortran/trans-openmp.cc            | 75 +++++++++++++++++++-------
 gcc/testsuite/gfortran.dg/pr120286.f90 | 50 +++++++++++++++++
 2 files changed, 105 insertions(+), 20 deletions(-)
 create mode 100644 gcc/testsuite/gfortran.dg/pr120286.f90

diff --git a/gcc/fortran/trans-openmp.cc b/gcc/fortran/trans-openmp.cc
index 3dd4cf272e5..1224df47b26 100644
--- a/gcc/fortran/trans-openmp.cc
+++ b/gcc/fortran/trans-openmp.cc
@@ -466,8 +466,6 @@ gfc_omp_replace_alloc_by_to_mapping (tree type, tree decl, bool ptr_ok)
 }
 
 
-/* Return true if TYPE is polymorphic but not with pointer attribute.  */
-
 static bool
 gfc_is_polymorphic_nonptr (tree type)
 {
@@ -476,6 +474,30 @@ gfc_is_polymorphic_nonptr (tree type)
   return GFC_CLASS_TYPE_P (type);
 }
 
+/* Return true if TYPE is a class container for a POINTER entity.  */
+
+static bool
+gfc_is_class_pointer_type (tree type)
+{
+  tree name;
+  const char *s;
+
+  if (POINTER_TYPE_P (type))
+    type = TREE_TYPE (type);
+
+  if (!GFC_CLASS_TYPE_P (type))
+    return false;
+
+  name = TYPE_NAME (type);
+  if (name && TREE_CODE (name) == TYPE_DECL)
+    name = DECL_NAME (name);
+  if (!name)
+    return false;
+
+  s = IDENTIFIER_POINTER (name);
+  return startswith (s, "__class_") && s[strlen (s) - 1] == 'p';
+}
+
 /* Return true if TYPE is unlimited polymorphic but not with pointer attribute;
    unlimited means also intrinsic types are handled and _len is used.  */
 
@@ -905,22 +927,29 @@ gfc_omp_clause_copy_ctor (tree clause, tree dest, tree src)
 {
   tree type = TREE_TYPE (dest), ptr, size, call;
   tree decl_type = TREE_TYPE (OMP_CLAUSE_DECL (clause));
+  tree orig_decl = OMP_CLAUSE_DECL (clause);
   tree cond, then_b, else_b;
   stmtblock_t block, cond_block;
 
   gcc_assert (OMP_CLAUSE_CODE (clause) == OMP_CLAUSE_FIRSTPRIVATE
 	      || OMP_CLAUSE_CODE (clause) == OMP_CLAUSE_LINEAR);
 
-  /* Privatize pointer, only; cf. gfc_omp_predetermined_sharing. */
-  if (DECL_P (OMP_CLAUSE_DECL (clause))
-      && GFC_DECL_ASSOCIATE_VAR_P (OMP_CLAUSE_DECL (clause)))
-    return build2 (MODIFY_EXPR, TREE_TYPE (dest), dest, src);
+  if (DECL_ARTIFICIAL (orig_decl)
+      && DECL_LANG_SPECIFIC (orig_decl)
+      && GFC_DECL_SAVED_DESCRIPTOR (orig_decl))
+    {
+      orig_decl = GFC_DECL_SAVED_DESCRIPTOR (orig_decl);
+      decl_type = TREE_TYPE (orig_decl);
+    }
 
-  if (DECL_ARTIFICIAL (OMP_CLAUSE_DECL (clause))
-      && DECL_LANG_SPECIFIC (OMP_CLAUSE_DECL (clause))
-      && GFC_DECL_SAVED_DESCRIPTOR (OMP_CLAUSE_DECL (clause)))
-    decl_type
-      = TREE_TYPE (GFC_DECL_SAVED_DESCRIPTOR (OMP_CLAUSE_DECL (clause)));
+  /* Privatize pointer association only; cf. gfc_omp_predetermined_sharing.
+     This includes scalar class pointers, whose tree type is still the class
+     record even though the Fortran entity has POINTER semantics.  */
+  if (DECL_P (orig_decl)
+      && (GFC_DECL_ASSOCIATE_VAR_P (orig_decl)
+	  || GFC_DECL_GET_SCALAR_POINTER (orig_decl)
+	  || gfc_is_class_pointer_type (decl_type)))
+    return build2 (MODIFY_EXPR, TREE_TYPE (dest), dest, src);
 
   if (gfc_is_polymorphic_nonptr (decl_type))
     {
@@ -1428,17 +1457,23 @@ gfc_omp_clause_dtor (tree clause, tree decl)
 {
   tree type = TREE_TYPE (decl), tem;
   tree decl_type = TREE_TYPE (OMP_CLAUSE_DECL (clause));
+  tree orig_decl = OMP_CLAUSE_DECL (clause);
 
-  /* Only pointer was privatized; cf. gfc_omp_clause_copy_ctor. */
-  if (DECL_P (OMP_CLAUSE_DECL (clause))
-      && GFC_DECL_ASSOCIATE_VAR_P (OMP_CLAUSE_DECL (clause)))
-    return NULL_TREE;
+  if (DECL_ARTIFICIAL (orig_decl)
+      && DECL_LANG_SPECIFIC (orig_decl)
+      && GFC_DECL_SAVED_DESCRIPTOR (orig_decl))
+    {
+      orig_decl = GFC_DECL_SAVED_DESCRIPTOR (orig_decl);
+      decl_type = TREE_TYPE (orig_decl);
+    }
 
-  if (DECL_ARTIFICIAL (OMP_CLAUSE_DECL (clause))
-      && DECL_LANG_SPECIFIC (OMP_CLAUSE_DECL (clause))
-      && GFC_DECL_SAVED_DESCRIPTOR (OMP_CLAUSE_DECL (clause)))
-    decl_type
-	= TREE_TYPE (GFC_DECL_SAVED_DESCRIPTOR (OMP_CLAUSE_DECL (clause)));
+  /* Only pointer association was privatized; cf. gfc_omp_clause_copy_ctor.
+     Scalar class pointers must not finalize or free their targets here.  */
+  if (DECL_P (orig_decl)
+      && (GFC_DECL_ASSOCIATE_VAR_P (orig_decl)
+	  || GFC_DECL_GET_SCALAR_POINTER (orig_decl)
+	  || gfc_is_class_pointer_type (decl_type)))
+    return NULL_TREE;
   if (gfc_is_polymorphic_nonptr (decl_type))
     {
       if (POINTER_TYPE_P (decl_type))
diff --git a/gcc/testsuite/gfortran.dg/pr120286.f90 b/gcc/testsuite/gfortran.dg/pr120286.f90
new file mode 100644
index 00000000000..99c02a78c9c
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr120286.f90
@@ -0,0 +1,50 @@
+! { dg-do run }
+! { dg-additional-options "-fopenmp" }
+!
+! PR fortran/120286 - scalar class pointers in OpenMP private/firstprivate
+! clauses must preserve association status without taking ownership.
+
+program main
+  implicit none
+
+  type foo_t
+    integer :: dummy
+  end type foo_t
+
+  type fooPtr_t
+    class(foo_t), pointer :: p
+  end type fooPtr_t
+
+  type fooPtrStack_t
+    class(fooPtr_t), allocatable :: list(:)
+  end type fooPtrStack_t
+
+  type(fooPtrStack_t) :: x
+  class(foo_t), pointer :: ptr
+  integer :: it, n
+  logical :: ok
+
+  allocate (x%list(1))
+  allocate (x%list(1)%p)
+  x%list(1)%p%dummy = 7
+
+  do it = 1, 16
+!$omp parallel do default(none) num_threads(2) private(n, ptr) shared(x)
+    do n = 1, 1
+      ptr => x%list(n)%p
+    end do
+!$omp end parallel do
+  end do
+
+  if (.not. associated (x%list(1)%p)) stop 1
+  if (x%list(1)%p%dummy /= 7) stop 2
+
+  ptr => x%list(1)%p
+  ok = .false.
+
+!$omp parallel default(none) num_threads(1) firstprivate(ptr) shared(x, ok)
+  ok = associated (ptr, x%list(1)%p) .and. ptr%dummy == 7
+!$omp end parallel
+
+  if (.not. ok) stop 3
+end program main
-- 
2.53.0