[gcc r17-3164] Fortran: Fix missing vptrs for class allocations [PR98573]

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

commit r17-3164-gd4a985f88b45bef56a5ad3be00af53dfa8136422
Author: Paul Thomas <[email protected]>
Date:   Sun Aug 9 15:38:50 2026 +0100

    Fortran: Fix missing vptrs for class allocations [PR98573]
    
    2026-08-09  Paul Thomas  <[email protected]>
    
    gcc/fortran
            PR fortran/98573
            * trans-array.cc (gfc_array_init_size): If the expr3_desc is an
            array descriptor, use it for 'type'.
            * trans-stmt.cc (gfc_trans_allocate): Use trans_assignment to
            assign the source for class sources.
    
    gcc/testsuite/
            PR fortran/98573
            * gfortran.dg/allocate_class_5.f90: New test.

Diff:
---
 gcc/fortran/trans-array.cc                     |   8 +-
 gcc/fortran/trans-stmt.cc                      |   3 +-
 gcc/testsuite/gfortran.dg/allocate_class_5.f90 | 134 +++++++++++++++++++++++++
 3 files changed, 143 insertions(+), 2 deletions(-)

diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index 7d23515e5d86..f3c9b815dd6b 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -6022,7 +6022,13 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
   gfc_se se;
   int n;
 
-  type = TREE_TYPE (descriptor);
+  if (expr->ts.type == BT_CLASS
+      && expr3_desc != NULL_TREE
+      && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (expr3_desc)))
+    type = TREE_TYPE (expr3_desc);
+  else
+    type = TREE_TYPE (descriptor);
+
 
   stride = gfc_index_one_node;
   offset = gfc_index_zero_node;
diff --git a/gcc/fortran/trans-stmt.cc b/gcc/fortran/trans-stmt.cc
index 5cffe356f655..2a87176ffa9f 100644
--- a/gcc/fortran/trans-stmt.cc
+++ b/gcc/fortran/trans-stmt.cc
@@ -7501,7 +7501,8 @@ gfc_trans_allocate (gfc_code * code, gfc_omp_namelist *omp_allocate)
 
       /* Set the vptr only when no source= is set.  When source= is set, then
 	 the trans_assignment below will set the vptr.  */
-      if (al_vptr != NULL_TREE && (!code->expr3 || code->expr3->mold))
+      if (al_vptr != NULL_TREE && (!code->expr3 || code->expr3->mold
+				   || code->expr3->ts.type == BT_CLASS))
 	{
 	  if (expr3_vptr != NULL_TREE)
 	    /* The vtab is already known, so just assign it.  */
diff --git a/gcc/testsuite/gfortran.dg/allocate_class_5.f90 b/gcc/testsuite/gfortran.dg/allocate_class_5.f90
new file mode 100644
index 000000000000..6ecaf67a8198
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/allocate_class_5.f90
@@ -0,0 +1,134 @@
+! { dg-do run }
+!
+! Tests the fix of PR98573. Fixed missing vptrs for class allocations.
+!
+! Contributed by Davis Asanza  <[email protected]>
+!
+module counts
+  integer :: integer_count = 0
+  integer :: other_count = 0
+  integer :: alloc_counts = 0
+end module counts
+
+module foo1
+  use counts
+  type, public:: box
+    class(*), allocatable :: val(:)
+  end type
+contains
+  subroutine store1(this, val)
+    class(box), intent(out) :: this
+    class(*), intent(in) :: val(:)
+    this%val = val
+  end subroutine store1
+  subroutine store2(this, val)
+    class(box), intent(out) :: this
+    class(*), intent(in) :: val(:)
+    allocate(this%val, source=val)
+  end subroutine store2
+  subroutine vector_type(val)
+    class(*), intent(in) :: val(:)
+    select type (val)
+    type is (integer)
+      integer_count = integer_count + 1
+    class default
+      other_count = other_count + 1
+    end select
+  end subroutine vector_type
+end module foo1
+
+module foo2
+  use counts
+contains
+  subroutine store1(arr, val)
+    class(*), allocatable, intent(out) :: arr(:)
+    class(*), intent(in) :: val(:)
+    arr = val
+  end subroutine store1
+  subroutine store2(arr, val)
+    class(*), allocatable, intent(out) :: arr(:)
+    class(*), intent(in) :: val(:)
+    allocate(arr, source=val)
+  end subroutine store2
+end module foo2
+
+module foo3
+  use counts
+  type, public:: box
+    class(*), allocatable :: val(:)
+  end type
+contains
+  subroutine store1(this, val)
+    class(box), intent(out) :: this
+    class(*), intent(in) :: val(:)
+    this%val = val
+  end subroutine store1
+  subroutine store2(this, val)
+    class(box), intent(out) :: this
+    class(*), intent(in) :: val(:)
+    allocate(this%val, source=val)
+  end subroutine store2
+  subroutine vector_type(val)
+    class(*), intent(in) :: val(:)
+    select type (val)
+    type is (integer)
+      integer_count = integer_count + 1
+    class default
+      other_count = other_count + 1
+    end select
+  end subroutine vector_type
+end module foo3
+
+program prog
+  use counts
+  implicit none
+  call bar1  ! Test the original problem
+  call bar2  ! Test comment 1
+  call bar3  ! Test comment 3
+  if (integer_count .ne. 6) stop 1
+  if (other_count .ne. 0) stop 2
+  if (alloc_counts .ne. 2) stop 3
+contains
+  subroutine bar1
+    use foo1
+    type(box) :: b
+    call store1(b, [1, 2, 3])
+    call vector_type(b%val)  ! OTHER
+    call store2(b, [1, 2, 3])
+    call vector_type(b%val)  ! INTEGER
+  end subroutine bar1
+
+  subroutine bar2
+    use foo2
+    class(*), allocatable :: arr(:)
+    call store1(arr, [1, 2, 3])  ! SEGFAULT
+    select type (a => arr)
+      type is (integer)
+        if (all (a .eq. [1, 2, 3])) alloc_counts = alloc_counts + 1
+    end select
+    deallocate (arr)
+    call store2(arr, [1, 2, 3])  ! NO PROBLEM
+    select type (a => arr)
+      type is (integer)
+        if (all (a .eq. [1, 2, 3])) alloc_counts = alloc_counts + 1
+    end select
+  end subroutine bar2
+
+  subroutine bar3
+    use foo3
+    type(box) :: b
+    integer, allocatable :: arr1(:)
+    integer, dimension(0) :: arr2
+
+    allocate(arr1(0))
+    call store1(b, arr1)
+    call vector_type(b%val)  ! OTHER
+    call store2(b, arr1)
+    call vector_type(b%val)  ! OTHER
+
+    call store1(b, arr2)
+    call vector_type(b%val)  ! OTHER
+    call store2(b, arr2)
+    call vector_type(b%val)  ! OTHER
+  end subroutine bar3
+end program