https://gcc.gnu.org/g:3600b1ff14a459e84bb40bdfea7cd8d2ffd73d8d
commit r15-7224-g3600b1ff14a459e84bb40bdfea7cd8d2ffd73d8d
Author: Paul Thomas <pa...@gcc.gnu.org>
Date: Mon Jan 27 09:55:26 2025 +0000
Fortran: ICE in gfc_conv_expr_present w. defined assignment [PR118640]
2025-01-27 Paul Thomas <pa...@gcc.gnu.org>
gcc/fortran
PR fortran/118640
* resolve.cc (generate_component_assignments): Make sure that
the rhs temporary does not pick up the optional attribute from
the lhs.
gcc/testsuite/
PR fortran/118640
* gfortran.dg/pr118640.f90: New test.
Diff:
---
gcc/fortran/resolve.cc | 5 +++++
gcc/testsuite/gfortran.dg/pr118640.f90 | 38 ++++++++++++++++++++++++++++++++++
2 files changed, 43 insertions(+)
diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc
index 124f4ac4edcd..7f73d53e31ef 100644
--- a/gcc/fortran/resolve.cc
+++ b/gcc/fortran/resolve.cc
@@ -13383,7 +13383,12 @@ generate_component_assignments (gfc_code **code,
gfc_namespace *ns)
tmp_expr = get_temp_from_expr ((*code)->expr1, ns);
if (tmp_expr->symtree->n.sym->attr.pointer)
{
+ /* Use allocate on assignment for the sake of simplicity. The
+ temporary must not take on the optional attribute. Assume
+ that the assignment is guarded by a PRESENT condition if the
+ lhs is optional. */
tmp_expr->symtree->n.sym->attr.pointer = 0;
+ tmp_expr->symtree->n.sym->attr.optional = 0;
tmp_expr->symtree->n.sym->attr.allocatable = 1;
}
this_code = build_assignment (EXEC_ASSIGN,
diff --git a/gcc/testsuite/gfortran.dg/pr118640.f90
b/gcc/testsuite/gfortran.dg/pr118640.f90
new file mode 100644
index 000000000000..8f74dbff0679
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr118640.f90
@@ -0,0 +1,38 @@
+! { dg-do compile }
+!
+! Check the fix for an ICE in gfc_conv_expr_present, which resulted from
+! the rhs temporary picking up the optional attribute from the lhs in a
+! defined assignment.
+!
+! Contributed by Jakub Jelenik <ja...@gcc.gnu.org>
+!
+module foo
+ type t1
+ contains
+ procedure bar
+ generic :: assignment(=) => bar
+ end type
+ type t2
+ type(t1) m
+ end type
+contains
+ subroutine bar (x, y)
+ intent(in) y
+ class(t1), intent(out) :: x
+ end subroutine
+end module
+subroutine baz (x, y)
+ use foo
+ integer y
+ type(t2), pointer, optional :: x
+ interface
+ function qux (x)
+ use foo
+ integer x
+ type(t2) qux
+ end function
+ end interface
+ if (present (x)) then
+ x = qux (y) ! ICE was here
+ end if
+end subroutine
