OpenE2K/gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

Fix keyword name for co_reduce.

Browse Source 
gcc/fortran/ChangeLog:

	* intrinsic.c (add_subroutines): Change keyword "operator"
	to the correct one, "operation".
	* check.c (gfc_check_co_reduce): Change OPERATOR to
	OPERATION in error messages.
	* intrinsic.texi: Change OPERATOR to OPERATION in
	documentation.

gcc/testsuite/ChangeLog:

	* gfortran.dg/co_reduce_2.f90: New test.
	* gfortran.dg/coarray_collectives_14.f90: Change OPERATOR
	to OPERATION.
	* gfortran.dg/coarray_collectives_16.f90: Likewise.
	* gfortran.dg/coarray_collectives_9.f90: Likewise.

	Co-authored by: Steve Kargl <steve@gcc.gnu.org>
This commit is contained in:
Thomas Koenig 2021-11-07 15:38:35 +01:00
parent 87e57378ba
commit 962ff7d284
7 changed files with 46 additions and 31 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

22
gcc/fortran/check.c
View File

@ -2265,7 +2265,7 @@ gfc_check_co_reduce (gfc_expr *a, gfc_expr *op, gfc_expr *result_image,
attr = gfc_expr_attr (op); attr = gfc_expr_attr (op);
if (!attr.pure || !attr.function) 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); &op->where);
return false; return false;
} }
@ -2292,7 +2292,7 @@ gfc_check_co_reduce (gfc_expr *a, gfc_expr *op, gfc_expr *result_image,
if (!formal || !formal->next || formal->next->next) 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); "arguments", &op->where);
return false; return false;
} }
@ -2303,7 +2303,7 @@ gfc_check_co_reduce (gfc_expr *a, gfc_expr *op, gfc_expr *result_image,
if (!gfc_compare_types (&a->ts, &sym->result->ts)) if (!gfc_compare_types (&a->ts, &sym->result->ts))
{ {
gfc_error ("The A argument at %L has type %s but the function passed as " 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, &a->where, gfc_typename (a), &op->where,
gfc_typename (&sym->result->ts)); gfc_typename (&sym->result->ts));
return false; return false;
@ -2311,7 +2311,7 @@ gfc_check_co_reduce (gfc_expr *a, gfc_expr *op, gfc_expr *result_image,
if (!gfc_compare_types (&a->ts, &formal->sym->ts) if (!gfc_compare_types (&a->ts, &formal->sym->ts)
|| !gfc_compare_types (&a->ts, &formal->next->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, "%s and %s but shall have type %s", &op->where,
gfc_typename (&formal->sym->ts), gfc_typename (&formal->sym->ts),
gfc_typename (&formal->next->sym->ts), gfc_typename (a)); gfc_typename (&formal->next->sym->ts), gfc_typename (a));
@ -2322,7 +2322,7 @@ gfc_check_co_reduce (gfc_expr *a, gfc_expr *op, gfc_expr *result_image,
|| formal->next->sym->attr.allocatable || formal->sym->attr.pointer || formal->next->sym->attr.allocatable || formal->sym->attr.pointer
|| formal->next->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 arguments and return a "
"nonallocatable nonpointer scalar", &op->where); "nonallocatable nonpointer scalar", &op->where);
return false; return false;
@ -2330,21 +2330,21 @@ gfc_check_co_reduce (gfc_expr *a, gfc_expr *op, gfc_expr *result_image,
if (formal->sym->attr.value != formal->next->sym->attr.value) 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); "attribute either for none or both arguments", &op->where);
return false; return false;
} }
if (formal->sym->attr.target != formal->next->sym->attr.target) 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); "attribute either for none or both arguments", &op->where);
return false; return false;
} }
if (formal->sym->attr.asynchronous != formal->next->sym->attr.asynchronous) 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", "ASYNCHRONOUS attribute either for none or both arguments",
&op->where); &op->where);
return false; return false;
@ -2352,7 +2352,7 @@ gfc_check_co_reduce (gfc_expr *a, gfc_expr *op, gfc_expr *result_image,
if (formal->sym->attr.optional || formal->next->sym->attr.optional) 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); "OPTIONAL attribute for either of the arguments", &op->where);
return false; return false;
} }
@ -2383,14 +2383,14 @@ gfc_check_co_reduce (gfc_expr *a, gfc_expr *op, gfc_expr *result_image,
|| (formal_size2 && actual_size != formal_size2))) || (formal_size2 && actual_size != formal_size2)))
{ {
gfc_error ("The character length of the A argument at %L and of the " 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); &a->where, &op->where);
return false; return false;
} }
if (actual_size && result_size && actual_size != result_size) if (actual_size && result_size && actual_size != result_size)
{ {
gfc_error ("The character length of the A argument at %L and of the " 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); &a->where, &op->where);
return false; return false;
} }

2
gcc/fortran/intrinsic.c
View File

@ -3806,7 +3806,7 @@ add_subroutines (void)
BT_UNKNOWN, 0, GFC_STD_F2018, BT_UNKNOWN, 0, GFC_STD_F2018,
gfc_check_co_reduce, NULL, NULL, gfc_check_co_reduce, NULL, NULL,
a, BT_REAL, dr, REQUIRED, INTENT_INOUT, 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, result_image, BT_INTEGER, di, OPTIONAL, INTENT_IN,
stat, BT_INTEGER, di, OPTIONAL, INTENT_OUT, stat, BT_INTEGER, di, OPTIONAL, INTENT_OUT,
errmsg, BT_CHARACTER, dc, OPTIONAL, INTENT_INOUT); errmsg, BT_CHARACTER, dc, OPTIONAL, INTENT_INOUT);

10
gcc/fortran/intrinsic.texi
View File

@ -3841,7 +3841,7 @@ end program test
@table @asis @table @asis
@item @emph{Description}: @item @emph{Description}:
@code{CO_REDUCE} determines element-wise the reduction of the value of @var{A} @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 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 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 argument. If @var{A} is an array, the deduction is done element wise. If
@ -3860,7 +3860,7 @@ Technical Specification (TS) 18508 or later
Collective subroutine Collective subroutine
@item @emph{Syntax}: @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}: @item @emph{Arguments}:
@multitable @columnfractions .20 .65 @multitable @columnfractions .20 .65
@ -3869,12 +3869,12 @@ nonpolymorphic. If it is allocatable, it shall be allocated; if it is a pointer,
it shall be associated. @var{A} shall have the same type and type parameters on 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 all images of the team; if it is an array, it shall have the same shape on all
images. 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 arguments, which shall be nonpolymorphic and have the same type and type
parameters as @var{A}. The function shall return a nonallocatable scalar of 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 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 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. it is an intrisic function.
@item @var{RESULT_IMAGE} @tab (optional) a scalar integer expression; if @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 present, it shall have the same value on all images and refer to an
@ -3888,7 +3888,7 @@ image of the current team.
program test program test
integer :: val integer :: val
val = this_image () 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 if (this_image() == 1) then
write(*,*) "Product value", val ! prints num_images() factorial write(*,*) "Product value", val ! prints num_images() factorial
end if end if

15
gcc/testsuite/gfortran.dg/co_reduce_2.f90 Normal file
View File

@ -0,0 +1,15 @@
! { 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

16
gcc/testsuite/gfortran.dg/coarray_collectives_14.f90
View File

@ -63,10 +63,10 @@ program test
call co_reduce(caf, dt%arg3) ! { dg-error "shall have two arguments" } 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, 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, 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, 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 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 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 OPERATOR at .2. returns INTEGER.8." } 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 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 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, 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, 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, ptr) ! { dg-error "scalar nonallocatable nonpointer arguments and return a nonallocatable nonpointer scalar" }
@ -83,10 +83,10 @@ program test
call co_reduce(caf, dt%tgt) ! { dg-error "shall have the TARGET attribute either for none or both arguments" } 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, char44) ! OK
call co_reduce(c4, dt%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, 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 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 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 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 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 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 OPERATION at .2. shall be the same" }
contains contains
pure integer function valid(x,y) pure integer function valid(x,y)

6
gcc/testsuite/gfortran.dg/coarray_collectives_16.f90
View File

@ -15,9 +15,9 @@ program test
character(len=99) :: val3 character(len=99) :: val3
integer :: res integer :: res
call co_reduce(val1, operator=fr, result_image=num_images(), stat=stat1, errmsg=errmesg1) call co_reduce(val1, operation=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(val2, operation=gz, result_image=4, stat=stat2, errmsg=errmesg2)
call co_reduce(val3, operator=hc, result_image=res,stat=stat3, errmsg=errmesg3) call co_reduce(val3, operation=hc, result_image=res,stat=stat3, errmsg=errmesg3)
contains contains
pure real function fr(x,y) pure real function fr(x,y)
real, value :: x, y real, value :: x, y

6
gcc/testsuite/gfortran.dg/coarray_collectives_9.f90
View File

@ -26,10 +26,10 @@ program test
end interface end interface
call co_broadcast("abc") ! { dg-error "Missing actual argument 'source_image' in call to 'co_broadcast'" } 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_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=1, operation=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=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,2]) ! { dg-error "must be a scalar" }
call co_broadcast(val, source_image=1.0) ! { dg-error "must be INTEGER" } call co_broadcast(val, source_image=1.0) ! { dg-error "must be INTEGER" }