From: Paul Thomas Date: Sat, 16 Nov 2024 15:56:10 +0000 (+0000) Subject: Fortran: Fix segmentation fault in defined assignment [PR109066] X-Git-Tag: basepoints/gcc-16~4206 X-Git-Url: http://git.ipfire.org/?a=commitdiff_plain;h=27ff8049bbdb0a001ba46835cd6a334c4ac76573;p=thirdparty%2Fgcc.git Fortran: Fix segmentation fault in defined assignment [PR109066] 2024-11-16 Paul Thomas 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 --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 +! +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