attr = gfc_expr_attr (op);
if (!attr.pure || !attr.function)
{
- gfc_error ("OPERATOR argument at %L must be a PURE function",
+ gfc_error ("OPERATION argument at %L must be a PURE function",
&op->where);
return false;
}
if (!formal || !formal->next || formal->next->next)
{
- gfc_error ("The function passed as OPERATOR at %L shall have two "
+ gfc_error ("The function passed as OPERATION at %L shall have two "
"arguments", &op->where);
return false;
}
if (!gfc_compare_types (&a->ts, &sym->result->ts))
{
gfc_error ("The A argument at %L has type %s but the function passed as "
- "OPERATOR at %L returns %s",
+ "OPERATION at %L returns %s",
&a->where, gfc_typename (a), &op->where,
gfc_typename (&sym->result->ts));
return false;
if (!gfc_compare_types (&a->ts, &formal->sym->ts)
|| !gfc_compare_types (&a->ts, &formal->next->sym->ts))
{
- gfc_error ("The function passed as OPERATOR at %L has arguments of type "
+ gfc_error ("The function passed as OPERATION at %L has arguments of type "
"%s and %s but shall have type %s", &op->where,
gfc_typename (&formal->sym->ts),
gfc_typename (&formal->next->sym->ts), gfc_typename (a));
|| formal->next->sym->attr.allocatable || formal->sym->attr.pointer
|| formal->next->sym->attr.pointer)
{
- gfc_error ("The function passed as OPERATOR at %L shall have scalar "
+ gfc_error ("The function passed as OPERATION at %L shall have scalar "
"nonallocatable nonpointer arguments and return a "
"nonallocatable nonpointer scalar", &op->where);
return false;
if (formal->sym->attr.value != formal->next->sym->attr.value)
{
- gfc_error ("The function passed as OPERATOR at %L shall have the VALUE "
+ gfc_error ("The function passed as OPERATION at %L shall have the VALUE "
"attribute either for none or both arguments", &op->where);
return false;
}
if (formal->sym->attr.target != formal->next->sym->attr.target)
{
- gfc_error ("The function passed as OPERATOR at %L shall have the TARGET "
+ gfc_error ("The function passed as OPERATION at %L shall have the TARGET "
"attribute either for none or both arguments", &op->where);
return false;
}
if (formal->sym->attr.asynchronous != formal->next->sym->attr.asynchronous)
{
- gfc_error ("The function passed as OPERATOR at %L shall have the "
+ gfc_error ("The function passed as OPERATION at %L shall have the "
"ASYNCHRONOUS attribute either for none or both arguments",
&op->where);
return false;
if (formal->sym->attr.optional || formal->next->sym->attr.optional)
{
- gfc_error ("The function passed as OPERATOR at %L shall not have the "
+ gfc_error ("The function passed as OPERATION at %L shall not have the "
"OPTIONAL attribute for either of the arguments", &op->where);
return false;
}
|| (formal_size2 && actual_size != formal_size2)))
{
gfc_error ("The character length of the A argument at %L and of the "
- "arguments of the OPERATOR at %L shall be the same",
+ "arguments of the OPERATION at %L shall be the same",
&a->where, &op->where);
return false;
}
if (actual_size && result_size && actual_size != result_size)
{
gfc_error ("The character length of the A argument at %L and of the "
- "function result of the OPERATOR at %L shall be the same",
+ "function result of the OPERATION at %L shall be the same",
&a->where, &op->where);
return false;
}
BT_UNKNOWN, 0, GFC_STD_F2018,
gfc_check_co_reduce, NULL, NULL,
a, BT_REAL, dr, REQUIRED, INTENT_INOUT,
- "operator", BT_INTEGER, di, REQUIRED, INTENT_IN,
+ "operation", BT_INTEGER, di, REQUIRED, INTENT_IN,
result_image, BT_INTEGER, di, OPTIONAL, INTENT_IN,
stat, BT_INTEGER, di, OPTIONAL, INTENT_OUT,
errmsg, BT_CHARACTER, dc, OPTIONAL, INTENT_INOUT);
@table @asis
@item @emph{Description}:
@code{CO_REDUCE} determines element-wise the reduction of the value of @var{A}
-on all images of the current team. The pure function passed as @var{OPERATOR}
+on all images of the current team. The pure function passed as @var{OPERATION}
is used to pairwise reduce the values of @var{A} by passing either the value
of @var{A} of different images or the result values of such a reduction as
argument. If @var{A} is an array, the deduction is done element wise. If
Collective subroutine
@item @emph{Syntax}:
-@code{CALL CO_REDUCE(A, OPERATOR, [, RESULT_IMAGE, STAT, ERRMSG])}
+@code{CALL CO_REDUCE(A, OPERATION, [, RESULT_IMAGE, STAT, ERRMSG])}
@item @emph{Arguments}:
@multitable @columnfractions .20 .65
it shall be associated. @var{A} shall have the same type and type parameters on
all images of the team; if it is an array, it shall have the same shape on all
images.
-@item @var{OPERATOR} @tab pure function with two scalar nonallocatable
+@item @var{OPERATION} @tab pure function with two scalar nonallocatable
arguments, which shall be nonpolymorphic and have the same type and type
parameters as @var{A}. The function shall return a nonallocatable scalar of
the same type and type parameters as @var{A}. The function shall be the same on
all images and with regards to the arguments mathematically commutative and
-associative. Note that @var{OPERATOR} may not be an elemental function, unless
+associative. Note that @var{OPERATION} may not be an elemental function, unless
it is an intrisic function.
@item @var{RESULT_IMAGE} @tab (optional) a scalar integer expression; if
present, it shall have the same value on all images and refer to an
program test
integer :: val
val = this_image ()
- call co_reduce (val, result_image=1, operator=myprod)
+ call co_reduce (val, result_image=1, operation=myprod)
if (this_image() == 1) then
write(*,*) "Product value", val ! prints num_images() factorial
end if
--- /dev/null
+! { dg-do compile }
+! { dg-options "-fcoarray=single" }
+! PR 103054 - wrong keyword name.
+! Original test case by Damian Rouson.
+program main
+ implicit none
+ logical :: co_all= .true.
+ call co_reduce(co_all, operator=both) ! { dg-error "Cannot find keyword" }
+ call co_reduce(co_all, operation=both)
+contains
+ logical pure function both(lhs,rhs)
+ logical, intent(in) :: lhs, rhs
+ both = lhs .and. rhs
+ end function
+end
call co_reduce(caf, dt%arg3) ! { dg-error "shall have two arguments" }
call co_reduce(caf, elem) ! { dg-error "ELEMENTAL non-INTRINSIC procedure 'elem' is not allowed as an actual argument" }
call co_reduce(caf, dt%elem) ! { dg-error "ELEMENTAL procedure pointer component 'elem' is not allowed as an actual argument" }
- call co_reduce(caf, realo) ! { dg-error "A argument at .1. has type INTEGER.4. but the function passed as OPERATOR at .2. returns REAL.4." }
- call co_reduce(caf, dt%realo) ! { dg-error "A argument at .1. has type INTEGER.4. but the function passed as OPERATOR at .2. returns REAL.4." }
- call co_reduce(caf, int8) ! { dg-error "A argument at .1. has type INTEGER.4. but the function passed as OPERATOR at .2. returns INTEGER.8." }
- call co_reduce(caf, dt%int8) ! { dg-error "A argument at .1. has type INTEGER.4. but the function passed as OPERATOR at .2. returns INTEGER.8." }
+ call co_reduce(caf, realo) ! { dg-error "A argument at .1. has type INTEGER.4. but the function passed as OPERATION at .2. returns REAL.4." }
+ call co_reduce(caf, dt%realo) ! { dg-error "A argument at .1. has type INTEGER.4. but the function passed as OPERATION at .2. returns REAL.4." }
+ call co_reduce(caf, int8) ! { dg-error "A argument at .1. has type INTEGER.4. but the function passed as OPERATION at .2. returns INTEGER.8." }
+ call co_reduce(caf, dt%int8) ! { dg-error "A argument at .1. has type INTEGER.4. but the function passed as OPERATION at .2. returns INTEGER.8." }
call co_reduce(caf, arr) ! { dg-error "scalar nonallocatable nonpointer arguments and return a nonallocatable nonpointer scalar" }
call co_reduce(caf, dt%arr) ! { dg-error "scalar nonallocatable nonpointer arguments and return a nonallocatable nonpointer scalar" }
call co_reduce(caf, ptr) ! { dg-error "scalar nonallocatable nonpointer arguments and return a nonallocatable nonpointer scalar" }
call co_reduce(caf, dt%tgt) ! { dg-error "shall have the TARGET attribute either for none or both arguments" }
call co_reduce(c4, char44) ! OK
call co_reduce(c4, dt%char44) ! OK
- call co_reduce(c3, char34) ! { dg-error "character length of the A argument at .1. and of the arguments of the OPERATOR at .2. shall be the same" }
- call co_reduce(c3, dt%char34) ! { dg-error "character length of the A argument at .1. and of the arguments of the OPERATOR at .2. shall be the same" }
- call co_reduce(c4, char34) ! { dg-error "The character length of the A argument at .1. and of the function result of the OPERATOR at .2. shall be the same" }
- call co_reduce(c4, dt%char34) ! { dg-error "The character length of the A argument at .1. and of the function result of the OPERATOR at .2. shall be the same" }
+ call co_reduce(c3, char34) ! { dg-error "character length of the A argument at .1. and of the arguments of the OPERATION at .2. shall be the same" }
+ call co_reduce(c3, dt%char34) ! { dg-error "character length of the A argument at .1. and of the arguments of the OPERATION at .2. shall be the same" }
+ call co_reduce(c4, char34) ! { dg-error "The character length of the A argument at .1. and of the function result of the OPERATION at .2. shall be the same" }
+ call co_reduce(c4, dt%char34) ! { dg-error "The character length of the A argument at .1. and of the function result of the OPERATION at .2. shall be the same" }
contains
pure integer function valid(x,y)
character(len=99) :: val3
integer :: res
- call co_reduce(val1, operator=fr, result_image=num_images(), stat=stat1, errmsg=errmesg1)
- call co_reduce(val2, operator=gz, result_image=4, stat=stat2, errmsg=errmesg2)
- call co_reduce(val3, operator=hc, result_image=res,stat=stat3, errmsg=errmesg3)
+ call co_reduce(val1, operation=fr, result_image=num_images(), stat=stat1, errmsg=errmesg1)
+ call co_reduce(val2, operation=gz, result_image=4, stat=stat2, errmsg=errmesg2)
+ call co_reduce(val3, operation=hc, result_image=res,stat=stat3, errmsg=errmesg3)
contains
pure real function fr(x,y)
real, value :: x, y
end interface
call co_broadcast("abc") ! { dg-error "Missing actual argument 'source_image' in call to 'co_broadcast'" }
- call co_reduce("abc") ! { dg-error "Missing actual argument 'operator' in call to 'co_reduce'" }
+ call co_reduce("abc") ! { dg-error "Missing actual argument 'operation' in call to 'co_reduce'" }
call co_broadcast(1, source_image=1) ! { dg-error "'a' argument of 'co_broadcast' intrinsic at .1. must be a variable" }
- call co_reduce(a=1, operator=red_f) ! { dg-error "'a' argument of 'co_reduce' intrinsic at .1. must be a variable" }
- call co_reduce(a=val, operator=red_f2) ! { dg-error "OPERATOR argument at \\(1\\) must be a PURE function" }
+ call co_reduce(a=1, operation=red_f) ! { dg-error "'a' argument of 'co_reduce' intrinsic at .1. must be a variable" }
+ call co_reduce(a=val, operation=red_f2) ! { dg-error "OPERATION argument at \\(1\\) must be a PURE function" }
call co_broadcast(val, source_image=[1,2]) ! { dg-error "must be a scalar" }
call co_broadcast(val, source_image=1.0) ! { dg-error "must be INTEGER" }