From: Paul Thomas <pault@gcc.gnu.org>
Date: Mon, 27 Jan 2025 09:55:26 +0000 (+0000)
Subject: Fortran: ICE in gfc_conv_expr_present w. defined assignment [PR118640]
X-Git-Tag: basepoints/gcc-16~2329
X-Git-Url: http://git.ipfire.org/?a=commitdiff_plain;h=3600b1ff14a459e84bb40bdfea7cd8d2ffd73d8d;p=thirdparty%2Fgcc.git

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.
---

diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc
index 124f4ac4edc..7f73d53e31e 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 00000000000..8f74dbff067
--- /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