Fortran: Implement the F2018 reduce intrinsic [PR85836]

2025-03-21  Paul Thomas  <pault@gcc.gnu.org>

gcc/fortran
	PR fortran/85836
	* check.cc (get_ul_from_cst_cl): New function used in
	check_operation.
	(check_operation): New function used in check_reduce and
	check_co_reduce.
	(gfc_check_co_reduce): Use it.
	(gfc_check_reduce): New function.
	(gfc_check_rename): Add prototype for intrinsic with 6 arguments.
	* gfortran.h : Add isym id for reduce and prototype for f6.
	* intrinsic.cc (do_check): Add another argument expression and use
	it in the call to the six argument specific check.
	(add_sym_6): New function.
	(add_functions): Add the discription of the reduce intrinsic and
	add it to the intrinsic list.
	* intrinsic.h : Add prototypes for gfc_check_reduce and
	gfc_resolve_reduce.
	* iresolve.cc (generate_reduce_op_wrapper): Generate a wrapper
	subroutine for the 'operation' function to enable the library
	implementation to be type agnostic and use pointer arithmetic
	throughout.
	(gfc_resolve_reduce): New function.
	* trans-expr.cc (gfc_conv_procedure_call): Add flag for scalar
	reduce. Generate a return variable 'sr' for scalar reduce, pass its
	address to the library function and return it as the scalar result.
	* trans-intrinsic.cc (gfc_conv_intrinsic_function): Array valued
	reduce is called in same way as reshape. Fall through for call to
	the scalar version.

gcc/testsuite/
	PR fortran/85836
	* gfortran.dg/reduce_1.f90: New test
	* gfortran.dg/reduce_2.f90: New test

libgfortran/
	PR libfortran/85836
	* Makefile.am : Add reduce.c
	* Makefile.in : Regenerated
	* gfortran.map : Add _gfortran_reduce, _gfortran_reduce_scalar,
	_gfortran_reduce_c and _gfortran_reduce_scalar_c to the list.
	* intrinsics/reduce.c (reduce, reduce_scalar, reduce_c,
	reduce_scalar_c): New functions and prototypes

1 files changed, 29 insertions, 1 deletions

diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index 923d46c..4b90b06 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -6753,6 +6753,12 @@ 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
@@ -8405,6 +8411,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
   byref = (comp && (comp->attr.dimension
 	   || (comp->ts.type == BT_CHARACTER && !sym->attr.is_bind_c)))
 	   || (!comp && gfc_return_by_reference (sym));
+
   if (byref)
     {
       if (se->direct_byref)
@@ -8589,6 +8596,17 @@ 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);
 
   /* We need to glom RETARGS + ARGLIST + STRINGARGS + APPEND_ARGS.  */
@@ -8773,10 +8791,12 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 
       /* Transformational functions of derived types with allocatable
 	 components must have the result allocatable components copied when the
-	 argument is actually given.  */
+	 argument is actually given.  This is unnecessry for REDUCE because the
+	 wrapper for the OPERATION function takes care of this.  */
       arg = expr->value.function.actual;
       if (result && arg && expr->rank
 	  && isym && isym->transformational
+	  && isym->id != GFC_ISYM_REDUCE
 	  && arg->expr
 	  && arg->expr->ts.type == BT_DERIVED
 	  && arg->expr->ts.u.derived->attr.alloc_comp)
@@ -8801,6 +8821,14 @@ 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