Fortran: Fix some bugs in associate [PR87477]

2023-06-21  Paul Thomas  <pault@gcc.gnu.org>

gcc/fortran
	PR fortran/87477
	PR fortran/88688
	PR fortran/94380
	PR fortran/107900
	PR fortran/110224
	* decl.cc (char_len_param_value): Fix memory leak.
	(resolve_block_construct): Remove unnecessary static decls.
	* expr.cc (gfc_is_ptr_fcn): New function.
	(gfc_check_vardef_context): Use it to permit pointer function
	result selectors to be used for associate names in variable
	definition context.
	* gfortran.h: Prototype for gfc_is_ptr_fcn.
	* match.cc (build_associate_name): New function.
	(gfc_match_select_type): Use the new function to replace inline
	version and to build a new associate name for the case where
	the supplied associate name is already used for that purpose.
	* resolve.cc (resolve_assoc_var): Call gfc_is_ptr_fcn to allow
	associate names with pointer function targets to be used in
	variable definition context.
	* trans-decl.cc (gfc_get_symbol_decl): Unlimited polymorphic
	variables need deferred initialisation of the vptr.
	(gfc_trans_deferred_vars): Do the vptr initialisation.
	* trans-stmt.cc (trans_associate_var): Ensure that a pointer
	associate name points to the target of the selector and not
	the selector itself.

gcc/testsuite/
	PR fortran/87477
	PR fortran/107900
	* gfortran.dg/pr107900.f90 : New test

	PR fortran/110224
	* gfortran.dg/pr110224.f90 : New test

	PR fortran/88688
	* gfortran.dg/pr88688.f90 : New test

	PR fortran/94380
	* gfortran.dg/pr94380.f90 : New test

	PR fortran/95398
	* gfortran.dg/pr95398.f90 : Set -std=f2008, bump the line
	numbers in the error tests by two and change the text in two.

5 files changed, 163 insertions, 3 deletions

diff --git a/gcc/testsuite/gfortran.dg/pr107900.f90 b/gcc/testsuite/gfortran.dg/pr107900.f90
new file mode 100644
index 0000000..2bd80a7
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr107900.f90
@@ -0,0 +1,49 @@
+! { dg-do run }
+!
+! Contributed by Karl Kaiser  <kaiserkarl31@yahoo.com>
+!
+program test
+
+   class(*), pointer :: ptr1, ptr2(:)
+   integer, target :: i = 42
+   integer :: check = 0
+! First with associate name and no selector in select types
+   associate (c => ptr1)
+        select type (c)  ! Segfault - vptr not set
+           type is (integer)
+              stop 1
+           class default
+              check = 1
+        end select
+   end associate
+! Now do the same with the array version
+   associate (c => ptr2)
+        select type (d =>c)  ! Segfault - vptr not set
+           type is (integer)
+              stop 2
+           class default
+              check = check + 10
+        end select
+   end associate
+
+! And now with the associate name and selector
+   associate (c => ptr1)
+        select type (d => c)  ! Segfault - vptr not set
+           type is (integer)
+              stop 3
+           class default
+              check = check + 100
+        end select
+   end associate
+! Now do the same with the array version
+!   ptr2 => NULL()            !This did not fix the problem
+   associate (c => ptr2)
+        select type (d => c)  ! Segfault - vptr not set
+           type is (integer)
+              stop 4
+           class default
+              check = check + 1000
+        end select
+   end associate
+   if (check .ne. 1111) stop 5
+end program test
diff --git a/gcc/testsuite/gfortran.dg/pr110224.f90 b/gcc/testsuite/gfortran.dg/pr110224.f90
new file mode 100644
index 0000000..186bbf5
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr110224.f90
@@ -0,0 +1,29 @@
+! { dg-do compile }
+!
+! Contributed by Neil Carlson  <neil.n.carlson@gmail.com>
+!
+module mod
+  type :: foo
+    real, pointer :: var
+  contains
+    procedure :: var_ptr
+  end type
+contains
+  function var_ptr(this) result(ref)
+    class(foo) :: this
+    real, pointer :: ref
+    ref => this%var
+  end function
+end module
+program main
+  use mod
+  type(foo) :: x
+  allocate (x%var, source = 2.0)
+  associate (var => x%var_ptr())
+    var = 1.0
+  end associate
+  if (x%var .ne. 1.0) stop 1
+  x%var_ptr() = 2.0
+  if (x%var .ne. 2.0) stop 2
+  deallocate (x%var)
+end program
diff --git a/gcc/testsuite/gfortran.dg/pr88688.f90 b/gcc/testsuite/gfortran.dg/pr88688.f90
new file mode 100644
index 0000000..3d65118
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr88688.f90
@@ -0,0 +1,62 @@
+! { dg-do run }
+!
+! Contributed by Thomas Fanning <thfanning@gmail.com>
+!
+!
+module mod
+
+    type test
+        class(*), pointer :: ptr
+    contains
+        procedure :: setref
+    end type
+
+contains
+
+    subroutine setref(my,ip)
+    implicit none
+        class(test) :: my
+        integer, pointer :: ip
+        my%ptr => ip
+    end subroutine
+
+    subroutine set7(ptr)
+    implicit none
+        class(*), pointer :: ptr
+        select type (ptr)
+            type is (integer)
+                ptr = 7
+        end select
+    end subroutine
+
+end module
+!---------------------------------------
+
+!---------------------------------------
+program bug
+use mod
+implicit none
+
+    integer, pointer :: i, j
+    type(test) :: tp
+    class(*), pointer :: lp
+
+    allocate(i,j)
+    i = 3; j = 4
+
+    call tp%setref(i)
+    select type (ap => tp%ptr)
+        class default
+            call tp%setref(j)
+            lp => ap
+            call set7(lp)
+    end select
+
+! gfortran used to give i=3 and j=7 because the associate name was not pointing
+! to the target of tp%ptr as required by F2018:19.5.1.6 but, rather, to the
+! selector itself.
+    if (i .ne. 7) stop 1
+    if (j .ne. 4) stop 2
+
+end program
+!---------------------------------------
diff --git a/gcc/testsuite/gfortran.dg/pr94380.f90 b/gcc/testsuite/gfortran.dg/pr94380.f90
new file mode 100644
index 0000000..e29594f
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr94380.f90
@@ -0,0 +1,18 @@
+! { dg-do compile }
+!
+! Contributed by Vladimir Nikishkin  <lockywolf@gmail.com>
+!
+module test
+  type testtype
+     class(*), allocatable :: t
+  end type testtype
+contains
+  subroutine testproc( x )
+    class(testtype) :: x
+    associate ( temp => x%t)
+      select type (temp)
+         type is (integer)
+      end select
+    end associate
+  end subroutine testproc
+end module test
diff --git a/gcc/testsuite/gfortran.dg/pr95398.f90 b/gcc/testsuite/gfortran.dg/pr95398.f90
index 81cc076..7576f38 100644
--- a/gcc/testsuite/gfortran.dg/pr95398.f90
+++ b/gcc/testsuite/gfortran.dg/pr95398.f90
@@ -1,5 +1,7 @@
 ! { dg-do compile }
 
+! { dg-options "-std=f2008" }
+
 program test
    implicit none
 
@@ -46,8 +48,8 @@ program test
 
 end
 
-! { dg-error "cannot be used in a variable definition context .assignment."  " " { target *-*-* } 21 }
-! { dg-error "cannot be used in a variable definition context .actual argument to INTENT = OUT.INOUT."  " " { target *-*-* } 23 }
-! { dg-error "Pointer assignment target is neither TARGET nor POINTER" " " { target *-*-* } 35 }
+! { dg-error "being used in a variable definition context .assignment."  " " { target *-*-* } 23 }
+! { dg-error "being used in a variable definition context .actual argument to INTENT = OUT.INOUT."  " " { target *-*-* } 25 }
 ! { dg-error "Pointer assignment target is neither TARGET nor POINTER" " " { target *-*-* } 37 }
+! { dg-error "Pointer assignment target is neither TARGET nor POINTER" " " { target *-*-* } 39 }