[gcc(refs/users/mikael/heads/pr118896_v02)] fortran: Declare virtual tables read-only

[Mikael Morin via Gcc-cvs]

https://gcc.gnu.org/g:5bdd45c4d910c83bb940e173c313aeed23bd183f

commit 5bdd45c4d910c83bb940e173c313aeed23bd183f
Author: Mikael Morin <mik...@gcc.gnu.org>
Date:   Sun Feb 16 22:25:01 2025 +0100

    fortran: Declare virtual tables read-only
    
    Add the read-only flag on the artificial variables we create to hold
    virtual tables.
    
            PR fortran/118896
    
    gcc/fortran/ChangeLog:
    
            * trans-decl.cc (gfc_get_symbol_decl): Set the read-only flag
            on virtual table declarations.
    
    gcc/testsuite/ChangeLog:
    
            * gfortran.dg/class_79.f90: New test.

Diff:
---
 gcc/fortran/trans-decl.cc              |  2 +-
 gcc/testsuite/gfortran.dg/class_79.f90 | 57 ++++++++++++++++++++++++++++++++++
 2 files changed, 58 insertions(+), 1 deletion(-)

diff --git a/gcc/fortran/trans-decl.cc b/gcc/fortran/trans-decl.cc
index 0acf0e9adb78..cce1ae96046b 100644
--- a/gcc/fortran/trans-decl.cc
+++ b/gcc/fortran/trans-decl.cc
@@ -2105,7 +2105,7 @@ gfc_get_symbol_decl (gfc_symbol * sym)
   if (sym->attr.vtab || def_init)
     {
       DECL_ARTIFICIAL (decl) = 1;
-      if (def_init && sym->value)
+      if (sym->attr.vtab || sym->value)
        TREE_READONLY (decl) = 1;
     }
 
diff --git a/gcc/testsuite/gfortran.dg/class_79.f90 
b/gcc/testsuite/gfortran.dg/class_79.f90
new file mode 100644
index 000000000000..393a5cf1c37c
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/class_79.f90
@@ -0,0 +1,57 @@
+! { dg-do compile }
+!
+! PR fortran/118896
+! Check that optimizations devirtualize all the calls to the internal _copy
+! typebound subroutine, and no reference to the virtual table remains.
+!
+! { dg-additional-options {-O2 -fdump-tree-original -fdump-tree-optimized} }
+! { dg-final { scan-tree-dump {__vtab} {original} } }
+! { dg-final { scan-tree-dump-not {__vtab} {optimized} } }
+
+module m
+  implicit none
+  type :: t1
+    integer :: i
+  end type
+end module m
+
+subroutine test_t1
+  use m
+  implicit none
+
+  class(t1), dimension(:), allocatable :: x, y
+
+  x = [t1(3), t1(2), t1(1)]
+
+  x = realloc_t1 (x)
+  if (.not.check_t1 (x, [2,3,1], 1) ) stop 3
+
+contains
+
+  function realloc_t1 (arg) result (res)
+    class(t1), dimension(:), allocatable :: arg
+    class(t1), dimension(:), allocatable :: res
+    select type (arg)
+      type is (t1)
+        allocate (res, source = [t1 (arg(2)%i), t1 (arg(1)%i), t1 (arg(3)%i)])
+    end select
+  end function realloc_t1
+
+  logical function check_t1 (arg, array, t, array2)
+    class(t1) :: arg(:)
+    integer :: array (:), t
+    integer, optional :: array2(:)
+    check_t1 = .true.
+    select type (arg)
+    type is (t1)
+      if (any (arg%i .ne. array)) check_t1 = .false.
+      if (t .eq. 2) check_t1 = .false.
+    class default
+      check_t1 = .false.
+    end select
+  end function check_t1
+
+end subroutine test_t1
+
+  call test_t1
+end