[PATCH] PR125534 ALLOCATE of parameterized derived-type array, initializes only first element

From 51e3836f39f884bf1b68866e4fcf12a34716716a Mon Sep 17 00:00:00 2001
From: Jerry DeLisle <[email protected]>
Date: Fri, 5 Jun 2026 13:19:58 -0700
Subject: [PATCH] fortran: ALLOCATE of parameterized derived-type array
 initializes only first element

gfc_trans_allocate passed expr->rank to gfc_allocate_pdt_comp and
gfc_deallocate_pdt_comp for array allocations of parameterized derived
types.  For an allocate-shape-spec expression (e.g. "allocate(a(n))"),
expr->rank is 0 even though the symbol is an array; the rank is carried on
the symbol rather than on the allocate expression.  With rank 0 the loop
that initialises each element's allocatable components ran zero times, so
only element zero was initialised.  Subsequent accesses to elements 1..N-1
used garbage pointers and crashed.

Fix: when se.expr is a GFC array descriptor, take the rank from the
descriptor via GFC_TYPE_ARRAY_RANK instead of from expr->rank.  Apply the
same correction to the CLASS path and to the matching deallocate calls in
gfc_trans_deallocate.

PR fortran/125534

Assisted by: Claude Sonnet 4.6

gcc/fortran/ChangeLog:

	PR fortran/125534
	* trans-stmt.cc (gfc_trans_allocate): Use GFC_TYPE_ARRAY_RANK from
	the GFC descriptor type when se.expr is a descriptor, rather than
	expr->rank, for the rank passed to gfc_allocate_pdt_comp.  Apply
	the same fix to the CLASS path.
	(gfc_trans_deallocate): Likewise for gfc_deallocate_pdt_comp.

gcc/testsuite/ChangeLog:

	PR fortran/125534
	* gfortran.dg/pdt_array_alloc_1.f90: New test.
---
 gcc/fortran/trans-stmt.cc                     | 30 +++++++++++++++----
 .../gfortran.dg/pdt_array_alloc_1.f90         | 30 +++++++++++++++++++
 2 files changed, 55 insertions(+), 5 deletions(-)
 create mode 100644 gcc/testsuite/gfortran.dg/pdt_array_alloc_1.f90

diff --git a/gcc/fortran/trans-stmt.cc b/gcc/fortran/trans-stmt.cc
index 00ddb0629cd..35dcfc1cf29 100644
--- a/gcc/fortran/trans-stmt.cc
+++ b/gcc/fortran/trans-stmt.cc
@@ -7695,8 +7695,15 @@ gfc_trans_allocate (gfc_code * code, gfc_omp_namelist *omp_allocate)
 	    param_list = expr->param_list;
 	  else
 	    param_list = expr->symtree->n.sym->param_list;
+	  /* For array allocations the allocate-shape-spec expression has
+	     rank 0 even though the symbol is an array.  Use the rank from
+	     the array descriptor when se.expr is a GFC descriptor so that
+	     gfc_allocate_pdt_comp loops over all elements.  */
+	  int pdt_rank = (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se.expr))
+			  ? GFC_TYPE_ARRAY_RANK (TREE_TYPE (se.expr))
+			  : expr->rank);
 	  tmp = gfc_allocate_pdt_comp (expr->ts.u.derived, se.expr,
-				       expr->rank, param_list);
+				       pdt_rank, param_list);
 	  gfc_add_expr_to_block (&block, tmp);
 	}
       /* Ditto for CLASS expressions.  */
@@ -7708,8 +7715,11 @@ gfc_trans_allocate (gfc_code * code, gfc_omp_namelist *omp_allocate)
 	    param_list = expr->param_list;
 	  else
 	    param_list = expr->symtree->n.sym->param_list;
+	  int pdt_rank = (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se.expr))
+			  ? GFC_TYPE_ARRAY_RANK (TREE_TYPE (se.expr))
+			  : expr->rank);
 	  tmp = gfc_allocate_pdt_comp (CLASS_DATA (expr)->ts.u.derived,
-				       se.expr, expr->rank, param_list);
+				       se.expr, pdt_rank, param_list);
 	  gfc_add_expr_to_block (&block, tmp);
 	}
       else if (code->expr3 && code->expr3->mold
@@ -7965,10 +7975,20 @@ gfc_trans_deallocate (gfc_code *code)
       if (expr->ts.type == BT_DERIVED
 	  && ((expr->ts.u.derived->attr.pdt_type && param_list)
 	      || expr->ts.u.derived->attr.pdt_comp))
-	tmp = gfc_deallocate_pdt_comp (expr->ts.u.derived, se.expr, expr->rank);
+	{
+	  int pdt_rank = (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se.expr))
+			  ? GFC_TYPE_ARRAY_RANK (TREE_TYPE (se.expr))
+			  : expr->rank);
+	  tmp = gfc_deallocate_pdt_comp (expr->ts.u.derived, se.expr, pdt_rank);
+	}
       else if (IS_CLASS_PDT (expr) && expr->symtree->n.sym->param_list)
-	tmp = gfc_deallocate_pdt_comp (CLASS_DATA (expr)->ts.u.derived,
-				       se.expr, expr->rank);
+	{
+	  int pdt_rank = (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se.expr))
+			  ? GFC_TYPE_ARRAY_RANK (TREE_TYPE (se.expr))
+			  : expr->rank);
+	  tmp = gfc_deallocate_pdt_comp (CLASS_DATA (expr)->ts.u.derived,
+					 se.expr, pdt_rank);
+	}
 
       if (tmp)
 	gfc_add_expr_to_block (&se.pre, tmp);
diff --git a/gcc/testsuite/gfortran.dg/pdt_array_alloc_1.f90 b/gcc/testsuite/gfortran.dg/pdt_array_alloc_1.f90
new file mode 100644
index 00000000000..82e745e9ed4
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pdt_array_alloc_1.f90
@@ -0,0 +1,30 @@
+! { dg-do run }
+! Test that allocating an array of parameterized derived type initializes
+! the allocatable components of ALL elements, not just element 0.
+! PR fortran/125534
+
+module m
+  implicit none
+  integer, parameter :: default_real = kind(0.)
+  type :: tensor_t(k)
+    integer, kind :: k = default_real
+    real(k), allocatable :: values_(:)
+  end type
+end module
+
+program pdt_array_alloc
+  use m
+  implicit none
+  integer, parameter :: n = 5
+  type(tensor_t), allocatable :: a(:)
+  integer :: i
+
+  allocate(a(n))
+  ! Without the fix, only a(1)%values_ was initialized (nullified);
+  ! a(2)..a(n) had garbage pointers and the assignment below would crash.
+  do i = 1, n
+    a(i)%values_ = [real(i), real(i*2)]
+  end do
+
+  if (any(a(3)%values_ /= [3., 6.])) stop 1
+end program
-- 
2.54.0