Fortran: ICE in gfc_conv_expr_present w. defined assignment [PR118640]

2025-01-27  Paul Thomas  <pault@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.

(cherry picked from commit 3600b1ff14a459e84bb40bdfea7cd8d2ffd73d8d)

diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc
index 71cb3d75801642baf760455f61665319b5c38860..7df879bf1585318ebacf1add7ebea6a5a4cfcee5 100644 (file)
--- a/gcc/fortran/resolve.cc
+++ b/gcc/fortran/resolve.cc
@@ -12159,7 +12159,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 (file)
index 0000000..8f74dbf
--- /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  <jakub@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