Fortran: Fix segmentation fault in defined assignment [PR109066]

2024-11-16  Paul Thomas  <pault@gcc.gnu.org>

gcc/fortran
	PR fortran/109066
	* resolve.cc (generate_component_assignments): If the temporary
	for 'var' is a pointer and 'expr' is neither a constant or
	a variable, change its attribute from pointer to allocatable.
	This avoids assignment to a temporary point that has neither
	been allocated or associated.

gcc/testsuite/
	PR fortran/109066
	* gfortran.dg/defined_assignment_12.f90: New test.

gcc/fortran/resolve.cc

@@ -12404,6 +12404,11 @@ generate_component_assignments (gfc_code **code, gfc_namespace *ns)
     {
       /* Assign the rhs to the temporary.  */
       tmp_expr = get_temp_from_expr ((*code)->expr1, ns);
+      if (tmp_expr->symtree->n.sym->attr.pointer)
+	{
+	  tmp_expr->symtree->n.sym->attr.pointer = 0;
+	  tmp_expr->symtree->n.sym->attr.allocatable = 1;
+	}
       this_code = build_assignment (EXEC_ASSIGN,
 				    tmp_expr, (*code)->expr2,
 				    NULL, NULL, (*code)->loc);

gcc/testsuite/gfortran.dg/defined_assignment_12.f90

@@ -0,0 +1,61 @@
+! { dg-do run }
+!
+! Test fix of PR109066, which caused segfaults as below
+!
+! Contributed by Andrew Benson  <abensonca@gcc.gnu.org>
+!
+module bugMod
+
+  type :: rm
+     integer :: c=0
+   contains
+     procedure :: rma
+     generic   :: assignment(=) => rma
+  end type rm
+
+  type :: lc
+     type(rm) :: lm
+  end type lc
+
+contains
+
+  impure elemental subroutine rma(to,from)
+    implicit none
+    class(rm), intent(out) :: to
+    class(rm), intent(in) :: from
+    to%c = -from%c
+    return
+  end subroutine rma
+
+end module bugMod
+
+program bug
+  use bugMod
+  implicit none
+  type(lc), pointer :: i, j(:)
+
+  allocate (i)
+  i = lc (rm (1))                      ! Segmentation fault
+  if (i%lm%c .ne. -1) stop 1
+  i = i_ptr ()                         ! Segmentation fault
+  if (i%lm%c .ne. 1) stop 2
+
+  allocate (j(2))
+  j = [lc (rm (2)), lc (rm (3))]       ! Segmentation fault
+  if (any (j%lm%c .ne. [-2,-3])) stop 3
+  j = j_ptr ()                         ! Worked!
+  if (any (j%lm%c .ne. [2,3])) stop 4
+
+contains
+
+  function i_ptr () result(res)
+    type(lc), pointer :: res
+    res => i
+  end function
+
+  function j_ptr () result(res)
+    type(lc), pointer :: res (:)
+    res => j
+  end function
+
+end program bug