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.

7 files changed, 123 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);
diff --git a/gcc/testsuite/gfortran.dg/reduce_2.f90 b/gcc/testsuite/gfortran.dg/reduce_2.f90
index 52d7c68..cacd54a 100644
--- a/gcc/testsuite/gfortran.dg/reduce_2.f90
+++ b/gcc/testsuite/gfortran.dg/reduce_2.f90
@@ -8,6 +8,10 @@
   integer, allocatable :: i(:,:,:)
   integer :: n(2,2)
   Logical :: l1(4), l2(2,3), l3(2,2)
+  type :: string_t
+    character(:), allocatable :: chr(:)
+  end type
+  type(string_t) :: str
 
 ! The ARRAY argument at (1) of REDUCE shall not be polymorphic
   print *, reduce (cstar, add) ! { dg-error "shall not be polymorphic" }
@@ -54,6 +58,10 @@
 ! (2) shall be the same
   print *, reduce ([character(4) :: 'abcd','efgh'], char_three) ! { dg-error "arguments of the OPERATION" }
 
+! The character length of the ARRAY argument at (1) and of the arguments of the OPERATION at (2)
+! shall be the same
+  str = reduce ([character(4) :: 'abcd','efgh'], char_one) ! { dg-error "character length of the ARRAY" }
+
 ! The DIM argument at (1), if present, must be an integer scalar
   print *, reduce (i, add, dim = 2.0) ! { dg-error "must be an integer scalar" }
 
diff --git a/gcc/testsuite/gfortran.dg/reduce_3.f90 b/gcc/testsuite/gfortran.dg/reduce_3.f90
new file mode 100644
index 0000000..c0ed062
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/reduce_3.f90
@@ -0,0 +1,56 @@
+! { dg-do run }
+!
+! PR119460: Scalar reduce was failing with ARRAY elements larger than
+! an address size.
+!
+! Contributed by Rainer Orth  <ro@gcc.gnu.org>
+!
+program test_reduce
+   implicit none
+   integer :: i
+   integer, parameter :: dp = kind(1.0_8), extent = 4
+
+   real(dp) :: rarray(extent,extent,extent), rmat(extent,extent), &
+               rvec (extent), rscl
+
+   type :: t
+      real(dp) :: field(extent)
+   end type t
+
+   type (t) :: tmat(extent, extent), tarray(extent), tscalar
+
+   rarray = reshape ([(real(i, kind = dp), i = 1, size(rarray))], &
+                     shape (rarray))
+
+   rmat = reduce (rarray, add, dim = 1)
+   if (any (rmat /= sum (rarray, 1))) stop 1
+
+   rmat = reduce (rarray, add, dim = 2)
+   if (any (rmat /= sum (rarray, 2))) stop 2
+
+   rmat = reduce (rarray, add, dim = 3)
+   if (any (rmat /= sum (rarray, 3))) stop 3
+
+   rscl = reduce (rarray, add)
+   if (rscl /= sum (rarray)) stop 4
+
+   tmat%field(1) = rmat
+   tarray = reduce (tmat, t_add, dim =1)
+   rvec = reduce (rmat, add, dim = 1)
+   if (any (tarray%field(1) /= rvec)) stop 5
+
+   tscalar = reduce (tmat, t_add)
+   if (tscalar%field(1) /= sum (tmat%field(1))) stop 6
+contains
+
+   pure real(dp) function add (i, j)
+      real(dp), intent(in) :: i, j
+      add = i + j
+   end function add
+
+   pure type(t) function t_add (i, j)
+      type(t), intent(in) :: i, j
+      t_add%field(1) = i%field(1) + j%field(1)
+   end function t_add
+
+end
diff --git a/gcc/testsuite/gfortran.dg/reduce_4.f90 b/gcc/testsuite/gfortran.dg/reduce_4.f90
new file mode 100644
index 0000000..edea931
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/reduce_4.f90
@@ -0,0 +1,48 @@
+! { dg-do run }
+!
+! PR119540 comment2: REDUCE was getting the shape wrong. This testcase also
+! verifies that the longest possible name for the OPERATION wrapper function
+! is catered for.
+!
+! Contributed by Harald Anlauf  <anlauf@gcc.gnu.org>
+!
+program p2345678901234567890123456789012345678901234567890123456789_123
+  implicit none
+  integer, parameter :: n = 3
+  integer, parameter :: vec(n) = [2, 5, 10]
+  integer, parameter :: mat(n,2) = reshape([vec,2*vec],[n,2])
+  integer :: mat_shape(2), reduce_shape(1), r
+  integer, dimension(:), allocatable :: res1
+
+  mat_shape = shape (mat)
+  reduce_shape = shape (reduce (mat, add, 1), 1)
+  if (reduce_shape(1) /= mat_shape(2)) stop 1
+
+  reduce_shape = shape (reduce (mat, add, 1), 1)
+  if (reduce_shape(1) /= mat_shape(2)) stop 2
+
+  res1 = reduce (mat, add, 1)
+  if (any (res1 /= [17, 34])) stop 3
+
+  res1 = reduce (mat, add, 2)
+  if (any (res1 /= [6, 15, 30])) stop 4
+
+  r = reduce (vec, &
+              o2345678901234567890123456789012345678901234567890123456789_123)
+  if (r /= 17) stop 5
+
+  deallocate (res1)
+contains
+  pure function add(i,j) result(sum_ij)
+    integer, intent(in) :: i, j
+    integer             :: sum_ij
+    sum_ij = i + j
+  end function add
+
+  pure function o2345678901234567890123456789012345678901234567890123456789_123 (i, j) &
+       result (sum)
+    integer, intent(in) :: i, j
+    integer             :: sum
+    sum = i + j
+  end function
+end