From 94fa9f4d27bac577ecab43379a31fa28b146d6d9 Mon Sep 17 00:00:00 2001 From: Paul Thomas Date: Fri, 21 Mar 2025 16:20:21 +0000 Subject: Fortran: Implement the F2018 reduce intrinsic [PR85836] 2025-03-21 Paul Thomas 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 --- gcc/fortran/trans-expr.cc | 30 +++++++++++++++++++++++++++++- 1 file changed, 29 insertions(+), 1 deletion(-) (limited to 'gcc/fortran/trans-expr.cc') 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 -- cgit v1.1