Hi Andre,
Thanks for all these comments, aka early review:
>
> + if (formal->sym->attr.allocatable || formal->sym->attr.allocatable
> + || formal->sym->attr.pointer || formal->sym->attr.pointer
> + || formal->sym->attr.optional || formal->sym->attr.optional
> + || formal->sym->ts.type == BT_CLASS || formal->sym->ts.type ==
> BT_CLASS)
> + {
> + gfc_error ("Each argument of OPERATION at %L shall be a scalar, "
> + "non-allocatable, non-pointer, non-polymorphic and "
> + "nonoptional", &operation->where);
> + return false;
> + }
>
> and then again (in the third next if) in:
>
> + if (formal->sym->attr.optional || formal->next->sym->attr.optional)
> + {
> + gfc_error ("The function passed as OPERATION at %L shall not have
> the "
> + "OPTIONAL attribute for either of the arguments",
> + &operation->where);
> + return false;
> + }
>
> Testing ones should be enough, right?
>
Good spot - thanks.
> I don't like the code repetition in
>
> + if (array->ts.type == BT_CHARACTER)
> + {
> + gfc_charlen *cl;
> + unsigned long actual_size, formal_size1, formal_size2, result_size;
> +
> + cl = array->ts.u.cl;
> + actual_size = cl && cl->length && cl->length->expr_type ==
> EXPR_CONSTANT
> + ? mpz_get_ui (cl->length->value.integer) : 0;
> +
> + cl = formal->sym->ts.u.cl;
> + formal_size1 = cl && cl->length && cl->length->expr_type ==
> EXPR_CONSTANT
> + ? mpz_get_ui (cl->length->value.integer) : 0;
> +
> + cl = formal->next->sym->ts.u.cl;
> + formal_size2 = cl && cl->length && cl->length->expr_type ==
> EXPR_CONSTANT
> + ? mpz_get_ui (cl->length->value.integer) : 0;
> +
> + cl = sym->ts.u.cl;
> + result_size = cl && cl->length && cl->length->expr_type ==
> EXPR_CONSTANT
> + ? mpz_get_ui (cl->length->value.integer) : 0;
> +
>
Copied and pasted directly from elsewhere in check.cc :-)
>
> either use function for evaluating the constant cl or how about this
> modern C++:
>
> + if (array->ts.type == BT_CHARACTER)
> + {
> + unsigned long actual_size, formal_size1, formal_size2, result_size;
> + auto get_cst_cl = [](const gfc_charlen *cl) -> unsigned log {
> + return cl && cl->length && cl->length->expr_type ==
> EXPR_CONSTANT
> + ? mpz_get_ui (cl->length->value.integer) : 0;
> + };
> +
> + actual_size = get_cst_cl (array->ts.u.cl);
> +
> + formal_size1 = get_cst_cl (formal->sym->ts.u.cl);
> +
> + formal_size2 = get_cst_cl (formal->next->sym->ts.u.cl);
> +
> + result_size = get_cst_cl (sym->ts.u.cl);
>
> I think the above is easier to maintain and read. Whether you use the
> lambda or
> a dedicated function I leave to your liking.
>
Thanks for the suggestion - I'll do "elsewhere" as well!
> In
> +static gfc_symtree *
> +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 *name;
> + gfc_namespace *ns;
> +// gfc_gsymbol *gsym = NULL;
>
> ^^^ Is this needed?
>
No, it's one of the commented out bits that I mentioned and will be
eliminated.
>
> @@ -8785,6 +8801,12 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol *
> sym,
> gfc_add_expr_to_block (&se->pre, tmp);
> }
> }
> + else if (scalar_reduce)
> + {
> + gfc_add_expr_to_block (&se->pre, se->expr);
> + se->expr = result;
> +// gfc_add_block_to_block (&se->post, &post);
>
> ^^^ I'd rather uncomment it to be safe in the future, if something is in
> post.
>
That is necessarily removed to deal with an 'array' type with allocatable
components. Adding post causes double frees because the wrapper already
does the job.
>
>
> --- a/gcc/fortran/trans-intrinsic.cc
> +++ b/gcc/fortran/trans-intrinsic.cc
> @@ -4250,6 +4250,20 @@ gfc_get_symbol_for_expr (gfc_expr * expr, bool
> ignore_optional) sym->attr.proc = PROC_INTRINSIC;
> sym->attr.flavor = FL_PROCEDURE;
> sym->result = sym;
> +#if 0
> + if (expr->value.function.isym
> + && expr->value.function.isym->id == GFC_ISYM_REDUCE)
> + {
> + if (expr->value.function.actual
> + && expr->value.function.actual->next
> + && expr->value.function.actual->next->next
> + && expr->value.function.actual->next->next->expr == NULL)
> + expr->rank = 0;
> + else if (expr->value.function.actual
> + && expr->value.function.actual->expr)
> + expr->rank = expr->value.function.actual->expr->rank - 1;
> + }
> +#endif
>
Also to be eliminated - was part of an earlier attempt at implementation.
>
> Er?
>
> Typo in Change.Logs
>
> s/discription/description/
>
:-)
>
> That Changelog looks non-standard.
>
> Ok, I hope this first feedback is valuable to you.
>
> One other question: How does REDUCE() relate to CO_REDUCE()?
>
> That's a good question. CO_REDUCE was already implemented by Tobias(?) but
I am not sure if it is complete, nor have I looked at the definition in the
standard.
Thanks a lot. It's very helpful to have another pair of eyes cast over the
patch at this stage.
Paul
