https://gcc.gnu.org/g:27ff8049bbdb0a001ba46835cd6a334c4ac76573
commit r15-5347-g27ff8049bbdb0a001ba46835cd6a334c4ac76573
Author: Paul Thomas <pa...@gcc.gnu.org>
Date: Sat Nov 16 15:56:10 2024 +0000
Fortran: Fix segmentation fault in defined assignment [PR109066]
2024-11-16 Paul Thomas <pa...@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.
Diff:
---
gcc/fortran/resolve.cc | 5 ++
.../gfortran.dg/defined_assignment_12.f90 | 61 ++++++++++++++++++++++
2 files changed, 66 insertions(+)
diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc
index b8c908b51e92..e8f780d1ef96 100644
--- a/gcc/fortran/resolve.cc
+++ b/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);
diff --git a/gcc/testsuite/gfortran.dg/defined_assignment_12.f90
b/gcc/testsuite/gfortran.dg/defined_assignment_12.f90
new file mode 100644
index 000000000000..57445abe25c4
--- /dev/null
+++ b/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 <abenso...@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
