From: Paul Thomas <pault@gcc.gnu.org>
Date: Sun, 24 Nov 2024 12:01:32 +0000 (+0000)
Subject: Fortran: Fix segfault in allocation of unlimited poly array [PR85869]
X-Git-Tag: basepoints/gcc-16~3924
X-Git-Url: http://git.ipfire.org/cgi-bin/gitweb.cgi?a=commitdiff_plain;h=470ebd31843db58fc503ccef38b82d0da93c65e4;p=thirdparty%2Fgcc.git

Fortran: Fix segfault in allocation of unlimited poly array [PR85869]

2024-11-24  Paul Thomas  <pault@gcc.gnu.org>

gcc/fortran/ChangeLog

	PR fortran/85869
	* trans-expr.cc (trans_class_vptr_len_assignment): To access
	the '_len' field, re must be unlimited polymorphic.

gcc/testsuite/
	PR fortran/85869
	* gfortran.dg/pr85869.f90: Comment out test of component refs.
---

diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index 7013dd3a4119..bc1d5a87307d 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -21,6 +21,7 @@ along with GCC; see the file COPYING3.  If not see
 
 /* trans-expr.cc-- generate GENERIC trees for gfc_expr.  */
 
+#define INCLUDE_MEMORY
 #include "config.h"
 #include "system.h"
 #include "coretypes.h"
@@ -10421,7 +10422,7 @@ trans_class_vptr_len_assignment (stmtblock_t *block, gfc_expr * le,
 	      vptr_expr = NULL;
 	      se.expr = gfc_class_vptr_get (GFC_DECL_SAVED_DESCRIPTOR (
 					     re->symtree->n.sym->backend_decl));
-	      if (to_len)
+	      if (to_len && UNLIMITED_POLY (re))
 		from_len = gfc_class_len_get (GFC_DECL_SAVED_DESCRIPTOR (
 					     re->symtree->n.sym->backend_decl));
 	    }
diff --git a/gcc/testsuite/gfortran.dg/pr85869.f90 b/gcc/testsuite/gfortran.dg/pr85869.f90
new file mode 100644
index 000000000000..24caeb486f23
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr85869.f90
@@ -0,0 +1,25 @@
+! { dg-do compile }
+!
+! Test the fix for PR85869, where line 19 segfaulted.
+!
+! Contributed by Gerhard Steinmetz  <gscfq@t-online.de>
+!
+program p
+   type t
+     integer :: i
+   end type
+   call s
+contains
+   function f()
+      class(t), allocatable :: f(:)
+      f = [(t(i), i = 1, 10)]
+   end
+   subroutine s
+      class(*), allocatable :: z(:)
+      allocate (z, source = f ()) ! Segfault in gfc_class_len_get.
+      select type (z)
+        type is (t)
+          if (any (z%i /= [(i, i = 1,10)])) stop 1
+      end select
+   end
+end