Fortran: Fix some problems with the reduce intrinsic [PR119460]

2025-04-09  Paul Thomas  <pault@gcc.gnu.org>
	    and Harald Anlauf  <anlauf@gcc.gnu.org>

gcc/fortran
	PR fortran/119460
	* iresolve.cc (generate_reduce_op_wrapper): Increase the size
	of 'tname'. Change intent of 'a' and 'b' to intent_in.
	* trans-decl.cc (add_argument_checking): Do not test artificial
	formal symbols.
	* trans-expr.cc (gfc_conv_procedure_call): Remove reduce_scalar
	and the blocks triggered by it.
	* trans-intrinsic.cc (gfc_conv_intrinsic_function): Set the
	result of non-character, scalar reduce to be allocatable.

gcc/testsuite/
	PR fortran/119460
	* gfortran.dg/reduce_2.f90: Add test to check that deferred len
	characters cannot slip through.
	* gfortran.dg/reduce_3.f90: New test
	* gfortran.dg/reduce_4.f90: New test

libgfortran/
	PR libfortran/119460
	* intrinsics/reduce.c (reduce): Correct error message about
	mismatch between dim and the rank of array. Output the values
	of both. Correct the evaluation of the result stride and
	extent.
	(reduce_scalar): The front end treats the result as an
	allocatable so eliminate memcpy and free. Return the base-addr
	of the local descriptor.
	(reduce_c): Correct the type of the string lengths.
	(reduce_scalar_c): Correct the type of the string lengths.Test
	to see if 'res' is allocated. If not then return the base_addr
	of the local descriptor.

4 files changed, 11 insertions, 28 deletions

diff --git a/gcc/fortran/iresolve.cc b/gcc/fortran/iresolve.cc
index 8189d7a..858ffb1 100644
--- a/gcc/fortran/iresolve.cc
+++ b/gcc/fortran/iresolve.cc
@@ -2417,7 +2417,7 @@ generate_reduce_op_wrapper (gfc_expr *op)
   gfc_symbol *operation = op->symtree->n.sym;
   gfc_symbol *wrapper, *a, *b, *c;
   gfc_symtree *st;
-  char tname[GFC_MAX_SYMBOL_LEN+1];
+  char tname[2 * GFC_MAX_SYMBOL_LEN + 2];
   char *name;
   gfc_namespace *ns;
   gfc_expr *e;
@@ -2462,7 +2462,7 @@ generate_reduce_op_wrapper (gfc_expr *op)
   a->attr.flavor = FL_VARIABLE;
   a->attr.dummy = 1;
   a->attr.artificial = 1;
-  a->attr.intent = INTENT_INOUT;
+  a->attr.intent = INTENT_IN;
   wrapper->formal = gfc_get_formal_arglist ();
   wrapper->formal->sym = a;
   gfc_set_sym_referenced (a);
@@ -2476,7 +2476,7 @@ generate_reduce_op_wrapper (gfc_expr *op)
   b->attr.dummy = 1;
   b->attr.optional= 1;
   b->attr.artificial = 1;
-  b->attr.intent = INTENT_INOUT;
+  b->attr.intent = INTENT_IN;
   wrapper->formal->next = gfc_get_formal_arglist ();
   wrapper->formal->next->sym = b;
   gfc_set_sym_referenced (b);
diff --git a/gcc/fortran/trans-decl.cc b/gcc/fortran/trans-decl.cc
index 9087221..aea132d 100644
--- a/gcc/fortran/trans-decl.cc
+++ b/gcc/fortran/trans-decl.cc
@@ -6546,7 +6546,7 @@ add_argument_checking (stmtblock_t *block, gfc_symbol *sym)
 	    message = _("Actual string length does not match the declared one"
 			" for dummy argument '%s' (%ld/%ld)");
 	  }
-	else if (fsym->as && fsym->as->rank != 0)
+	else if ((fsym->as && fsym->as->rank != 0) || fsym->attr.artificial)
 	  continue;
 	else
 	  {
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index 4b90b06..6ece39b 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -6753,12 +6753,6 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
   gfc_intrinsic_sym *isym = expr && expr->rank ?
 			    expr->value.function.isym : NULL;
 
-  /* In order that the library function for intrinsic REDUCE be type and kind
-     agnostic, the result is passed by reference.  Allocatable components are
-     handled within the OPERATION wrapper.  */
-  bool reduce_scalar = expr && !expr->rank && expr->value.function.isym
-		       && expr->value.function.isym->id == GFC_ISYM_REDUCE;
-
   comp = gfc_get_proc_ptr_comp (expr);
 
   bool elemental_proc = (comp
@@ -8596,16 +8590,6 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
       else if (ts.type == BT_CHARACTER)
 	vec_safe_push (retargs, len);
     }
-  else if (reduce_scalar)
-    {
-      /* In order that the library function for intrinsic REDUCE be type and
-	 kind agnostic, the result is passed by reference.  Allocatable
-	 components are handled within the OPERATION wrapper.  */
-      type = gfc_typenode_for_spec (&expr->ts);
-      result = gfc_create_var (type, "sr");
-      tmp =  gfc_build_addr_expr (pvoid_type_node, result);
-      vec_safe_push (retargs, tmp);
-    }
 
   gfc_free_interface_mapping (&mapping);
 
@@ -8821,14 +8805,6 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 	  gfc_add_expr_to_block (&se->pre, tmp);
 	}
     }
-  else if (reduce_scalar)
-    {
-      /* Even though the REDUCE intrinsic library function returns the result
-	 by reference, the scalar call passes the result as se->expr.  */
-      gfc_add_expr_to_block (&se->pre, se->expr);
-      se->expr = result;
-      gfc_add_block_to_block (&se->post, &post);
-    }
   else
     {
       /* For a function with a class array result, save the result as
diff --git a/gcc/fortran/trans-intrinsic.cc b/gcc/fortran/trans-intrinsic.cc
index 6b55017..6ffc3e0 100644
--- a/gcc/fortran/trans-intrinsic.cc
+++ b/gcc/fortran/trans-intrinsic.cc
@@ -3883,6 +3883,13 @@ gfc_conv_intrinsic_funcall (gfc_se * se, gfc_expr * expr)
 	  append_args->quick_push (null_pointer_node);
 	}
     }
+  /* Non-character scalar reduce returns a pointer to a result of size set by
+     the element size of 'array'. Setting 'sym' allocatable ensures that the
+     result is deallocated at the appropriate time.  */
+  else if (expr->value.function.isym->id == GFC_ISYM_REDUCE
+      && expr->rank == 0 && expr->ts.type != BT_CHARACTER)
+    sym->attr.allocatable = 1;
+
 
   gfc_conv_procedure_call (se, sym, expr->value.function.actual, expr,
 			  append_args);