Fortran: Regression in gfc_convert_to_structure_constructor

This patch is not the prettiest because it jumps across the normal
wrapping up of the actual arguments in gfc_conv_procedure_call. However
the alternatives, which required jumps past existing call and the logic
for adding the pre and post blocks looked even uglier. The testcase has
been checked with valgrind and does not cause memory leaks. The memory
leaks in pr105168, mentioned in this pr, are fixed too.

2026-04-02  Paul Thomas  <pault@gcc.gnu.org>

gcc/fortran
	PR fortran/100155
	* trans-expr.cc (gfc_add_interface_mapping): 'new_sym' dummy
	attribute set to zero.
	(gfc_conv_procedure_call): Deallocate allocatable components of
	a class argument, enclosed in parentheses,wrap up the parmse
	and proceed to the next argument.

gcc/testsuite/
	PR fortran/100155
	* gfortran.dg/pr100155.f90: New test.

diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index 5291896158451f54494e490e21c03ccca969c48f..d6c580f841303b8fc5d4569af3bcc29c4e30fc77 100644 (file)
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -5014,6 +5014,7 @@ gfc_add_interface_mapping (gfc_interface_mapping * mapping,
   new_sym->attr.allocatable = sym->attr.allocatable;
   new_sym->attr.flavor = sym->attr.flavor;
   new_sym->attr.function = sym->attr.function;
+  new_sym->attr.dummy = 0;
 
   /* Ensure that the interface is available and that
      descriptors are passed for array actual arguments.  */
@@ -7835,6 +7836,38 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
                                             : &parmse.pre;
              gfc_add_block_to_block (class_pre_block, &class_se.pre);
              gfc_add_block_to_block (&parmse.post, &class_se.post);
+
+             if (e->expr_type == EXPR_OP
+                 && POINTER_TYPE_P (TREE_TYPE (parmse.expr))
+                 && GFC_CLASS_TYPE_P (TREE_TYPE (TREE_OPERAND (parmse.expr, 0))))
+               {
+                 tree cond;
+                 tree dealloc_expr = gfc_finish_block (&parmse.post);
+                 tmp = TREE_OPERAND (parmse.expr, 0);
+                 gfc_init_block (&parmse.post);
+                 cond = gfc_class_data_get (tmp);
+                 tmp = gfc_deallocate_alloc_comp_no_caf (e->ts.u.derived,
+                                                         tmp, e->rank, true);
+                 gfc_add_expr_to_block (&parmse.post, tmp);
+                 cond = gfc_class_data_get (TREE_OPERAND (parmse.expr, 0));
+                 cond = gfc_conv_descriptor_data_get (cond);
+                 cond = fold_build2_loc (input_location, NE_EXPR,
+                                         logical_type_node, cond,
+                                         build_int_cst (TREE_TYPE (cond), 0));
+                 tmp = build3_v (COND_EXPR, cond, dealloc_expr,
+                                 build_empty_stmt (input_location));
+
+                 /* This specific case should not be processed further and so
+                    bundle everything up and proceed to the next argument.  */
+                 if (fsym && need_interface_mapping && e)
+                   gfc_add_interface_mapping (&mapping, fsym, &parmse, e);
+                 gfc_add_expr_to_block (&parmse.post, tmp);
+                 gfc_add_block_to_block (&se->pre, &parmse.pre);
+                 gfc_add_block_to_block (&post, &parmse.post);
+                 gfc_add_block_to_block (&se->finalblock, &parmse.finalblock);
+                 vec_safe_push (arglist, parmse.expr);
+                 continue;
+               }
            }
          else
            {

diff --git a/gcc/testsuite/gfortran.dg/pr100155.f90 b/gcc/testsuite/gfortran.dg/pr100155.f90
new file mode 100644 (file)
index 0000000..4a77963
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr100155.f90
@@ -0,0 +1,43 @@
+! { dg-do run }
+! Test the fix for PR100155 in which the parentheses caused an ICE
+! in evaluation the specification expression for 'z'. Note that the
+! recursive attribute is not a factor in the ICE (see PR105168).
+! Contributed by Gerhard Steinmetz  <gscfq@t-online.de>
+!
+module m1
+   type t
+     integer, allocatable :: i
+   end type
+   integer :: ctr = 0, vals = 0
+   integer, parameter :: no_calls = 6
+contains
+   recursive function f(x) result(z)
+      class(t) :: x(:)
+      type(t) :: z(size(x)+1)
+      class(t), allocatable :: a(:)
+      type(t), allocatable :: b(:)
+      ctr = ctr + 1
+      allocate (t :: a(1))
+      a(1)%i = ctr
+      if (ctr <= no_calls - 1) then
+          b = f((a)) ! <== parentheses
+      else
+          allocate (b(a(1)%i))
+          b(1)%i = ctr
+      end if
+      vals = vals + b(1)%i
+      z(1) = t(b(1)%i)
+   end 
+end module m1
+
+  use m1
+  type (t) :: dummy(1)
+  type(t), allocatable :: res(:)
+  dummy = t(1)
+  res = f (dummy);
+  if (ctr /= no_calls) stop 1
+  if (vals /= (2 * sum ([(i, i = 1, no_calls)]) - no_calls)) stop 2
+  if (size (res) /= 2) stop 3
+  deallocate (res)
+  deallocate (dummy(1)%i)
+end