Fortran: Fix an assortment of bugs

2023-05-16  Paul Thomas  <pault@gcc.gnu.org>

gcc/fortran
	PR fortran/105152
	* interface.cc (gfc_compare_actual_formal): Emit an error if an
	unlimited polymorphic actual is not matched either to an
	unlimited or assumed type formal argument.

	PR fortran/100193
	* resolve.cc (resolve_ordinary_assign): Emit an error if the
	var expression of an ordinary assignment is a proc pointer
	component.

	PR fortran/87496
	* trans-array.cc (gfc_walk_array_ref): Provide assumed shape
	arrays coming from interface mapping with a viable arrayspec.

	PR fortran/103389
	* trans-expr.cc (gfc_conv_intrinsic_to_class): Tidy up flagging
	of unlimited polymorphic 'class_ts'.
	(gfc_conv_gfc_desc_to_cfi_desc): Assumed type is unlimited
	polymorphic and should accept any actual type.

	PR fortran/104429
	(gfc_conv_procedure_call): Replace dreadful kludge with a call
	to gfc_finalize_tree_expr. Avoid dereferencing a void pointer
	by giving it the pointer type of the actual argument.

	PR fortran/82774
	(alloc_scalar_allocatable_subcomponent): Shorten the function
	name and replace the symbol argument with the se string length.
	If a deferred length character length is either not present or
	is not a variable, give the typespec a variable and assign the
	string length to that. Use gfc_deferred_strlen to find the
	hidden string length component.
	(gfc_trans_subcomponent_assign): Convert the expression before
	the call to alloc_scalar_allocatable_subcomponent so that a
	good string length is provided.
	(gfc_trans_structure_assign): Remove the unneeded derived type
	symbol from calls to gfc_trans_subcomponent_assign.

gcc/testsuite/
	PR fortran/105152
	* gfortran.dg/pr105152.f90 : New test

	PR fortran/100193
	* gfortran.dg/pr100193.f90 : New test

	PR fortran/87946
	* gfortran.dg/pr87946.f90 : New test

	PR fortran/103389
	* gfortran.dg/pr103389.f90 : New test

	PR fortran/104429
	* gfortran.dg/pr104429.f90 : New test

	PR fortran/82774
	* gfortran.dg/pr82774.f90 : New test

6 files changed, 154 insertions, 0 deletions

diff --git a/gcc/testsuite/gfortran.dg/pr100193.f90 b/gcc/testsuite/gfortran.dg/pr100193.f90
new file mode 100644
index 00000000000..07a3634cb06
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr100193.f90
@@ -0,0 +1,20 @@
+! { dg-do compile }
+!
+! Contributed by Gerhard Steinmetz  <gscfq@t-online.de>
+!
+module m
+   implicit none
+   type t
+      procedure(f), pointer, nopass :: g
+   end type
+contains
+   function f()
+      character(:), allocatable :: f
+      f = 'abc'
+   end
+   subroutine s
+      type(t) :: z
+      z%g = 'x'  ! { dg-error "is a procedure pointer" }
+      if ( z%g() /= 'abc' ) stop
+   end
+end
diff --git a/gcc/testsuite/gfortran.dg/pr103389.f90 b/gcc/testsuite/gfortran.dg/pr103389.f90
new file mode 100644
index 00000000000..565551564e3
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr103389.f90
@@ -0,0 +1,23 @@
+! { dg-do run }
+!
+! Contributed by Gerhard Steinmetz  <gscfq@t-online.de>
+!
+program p
+   type t
+      integer, allocatable :: a(:)
+   end type
+   type(t) :: y
+   y%a = [1,2]
+   call s((y))
+   if (any (y%a .ne. [3,4])) stop 1
+contains
+   subroutine s(x)
+      class(*) :: x
+      select type (x)
+        type is (t)
+          x%a = x%a + 2
+        class default
+          stop 2
+      end select
+   end
+end
diff --git a/gcc/testsuite/gfortran.dg/pr104429.f90 b/gcc/testsuite/gfortran.dg/pr104429.f90
new file mode 100644
index 00000000000..39761fd59fa
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr104429.f90
@@ -0,0 +1,35 @@
+! { dg-do run }
+!
+! Contributed by Gerhard Steinmetz  <gscfq@t-online.de>
+!
+module m
+   type t
+      real :: r
+   contains
+      procedure :: op
+      procedure :: assign
+      generic :: operator(*) => op
+      generic :: assignment(=) => assign
+   end type
+contains
+   function op (x, y)
+      class(t), allocatable :: op
+      class(t), intent(in) :: x
+      real, intent(in) :: y
+      allocate (op, source = t (x%r * y))
+   end
+   subroutine assign (z, x)
+      type(t), intent(in) :: x
+      class(t), intent(out) :: z
+      z%r = x%r
+   end
+end
+program p
+   use m
+   class(t), allocatable :: x
+   real :: y = 2
+   allocate (x, source = t (2.0))
+   x = x * y
+   if (int (x%r) .ne. 4) stop 1
+   if (allocated (x)) deallocate (x)
+end
diff --git a/gcc/testsuite/gfortran.dg/pr105152.f90 b/gcc/testsuite/gfortran.dg/pr105152.f90
new file mode 100644
index 00000000000..561b2a6c75d
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr105152.f90
@@ -0,0 +1,19 @@
+! { dg-do compile }
+!
+! Contributed by Gerhard Steinmetz  <gscfq@t-online.de>
+!
+program p
+   use iso_c_binding
+   type, bind(c) :: t
+      integer(c_int) :: a
+   end type
+   interface
+      function f(x) bind(c) result(z)
+         import :: c_int, t
+         type(t) :: x(:)
+         integer(c_int) :: z
+      end
+   end interface
+   class(*), allocatable :: y(:)
+   n = f(y) ! { dg-error "either an unlimited polymorphic or assumed type" }
+end
diff --git a/gcc/testsuite/gfortran.dg/pr82774.f90 b/gcc/testsuite/gfortran.dg/pr82774.f90
new file mode 100644
index 00000000000..81c22ab3828
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr82774.f90
@@ -0,0 +1,15 @@
+! { dg-do run }
+!
+! Contributed by Steve Kargl  <kargl@gcc.gnu.org>
+!
+program main
+   implicit none
+   type stuff
+      character(:), allocatable :: key
+   end type stuff
+   type(stuff) nonsense, total
+   nonsense = stuff('Xe')
+   total = stuff(nonsense%key) ! trim nonsense%key made this work
+   if (nonsense%key /= total%key) call abort
+   if (len(total%key) /= 2) call abort
+end program main
diff --git a/gcc/testsuite/gfortran.dg/pr87946.f90 b/gcc/testsuite/gfortran.dg/pr87946.f90
new file mode 100644
index 00000000000..793d37a7f39
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr87946.f90
@@ -0,0 +1,42 @@
+! { dg-do run }
+!
+! Contributed by Gerhard Steinmetz  <gscfq@t-online.de>
+!
+module m
+   type t
+   contains
+      generic :: h => g
+      procedure, private :: g
+   end type
+contains
+   function g(x, y) result(z)
+      class(t), intent(in) :: x
+      real, intent(in) :: y(:, :)
+      real :: z(size(y, 2))
+      integer :: i
+      do i = 1, size(y, 2)
+        z(i) = i
+      end do
+   end
+end
+module m2
+   use m
+   type t2
+      class(t), allocatable :: u(:)
+   end type
+end
+   use m2
+   type(t2) :: x
+   real :: y(1,5)
+   allocate (x%u(1))
+   if (any (int(f (x, y)) .ne. [1,2,3,4,5])) stop 1
+   deallocate (x%u)
+contains
+   function f(x, y) result(z)
+      use m2
+      type(t2) :: x
+      real :: y(:, :)
+      real :: z(size(y, 2))
+      z = x%u(1)%h(y)          ! Used to segfault here
+   end
+end