diff --git a/flang/lib/Evaluate/intrinsics.cpp b/flang/lib/Evaluate/intrinsics.cpp --- a/flang/lib/Evaluate/intrinsics.cpp +++ b/flang/lib/Evaluate/intrinsics.cpp @@ -65,6 +65,7 @@ static constexpr CategorySet CharType{TypeCategory::Character}; static constexpr CategorySet LogicalType{TypeCategory::Logical}; static constexpr CategorySet IntOrRealType{IntType | RealType}; +static constexpr CategorySet IntOrRealOrCharType{IntType | RealType | CharType}; static constexpr CategorySet FloatingType{RealType | ComplexType}; static constexpr CategorySet NumericType{IntType | RealType | ComplexType}; static constexpr CategorySet RelatableType{IntType | RealType | CharType}; @@ -121,6 +122,8 @@ static constexpr TypePattern AnyInt{IntType, KindCode::any}; static constexpr TypePattern AnyReal{RealType, KindCode::any}; static constexpr TypePattern AnyIntOrReal{IntOrRealType, KindCode::any}; +static constexpr TypePattern AnyIntOrRealOrChar{ + IntOrRealOrCharType, KindCode::any}; static constexpr TypePattern AnyComplex{ComplexType, KindCode::any}; static constexpr TypePattern AnyFloating{FloatingType, KindCode::any}; static constexpr TypePattern AnyNumeric{NumericType, KindCode::any}; @@ -1084,6 +1087,26 @@ static const IntrinsicInterface intrinsicSubroutine[]{ {"abort", {}, {}, Rank::elemental, IntrinsicClass::impureSubroutine}, + {"co_max", + {{"a", AnyIntOrRealOrChar, Rank::anyOrAssumedRank, + Optionality::required, common::Intent::InOut}, + {"result_image", AnyInt, Rank::scalar, Optionality::optional, + common::Intent::In}, + {"stat", AnyInt, Rank::scalar, Optionality::optional, + common::Intent::Out}, + {"errmsg", DefaultChar, Rank::scalar, Optionality::optional, + common::Intent::InOut}}, + {}, Rank::elemental, IntrinsicClass::collectiveSubroutine}, + {"co_min", + {{"a", AnyIntOrRealOrChar, Rank::anyOrAssumedRank, + Optionality::required, common::Intent::InOut}, + {"result_image", AnyInt, Rank::scalar, Optionality::optional, + common::Intent::In}, + {"stat", AnyInt, Rank::scalar, Optionality::optional, + common::Intent::Out}, + {"errmsg", DefaultChar, Rank::scalar, Optionality::optional, + common::Intent::InOut}}, + {}, Rank::elemental, IntrinsicClass::collectiveSubroutine}, {"co_sum", {{"a", AnyNumeric, Rank::anyOrAssumedRank, Optionality::required, common::Intent::InOut}, @@ -2449,7 +2472,7 @@ } } else if (name == "associated") { return CheckAssociated(call, context); - } else if (name == "co_sum") { + } else if (name == "co_max" || name == "co_min" || name == "co_sum") { bool aOk{CheckForCoindexedObject(context, call.arguments[0], name, "a")}; bool statOk{ CheckForCoindexedObject(context, call.arguments[2], name, "stat")}; diff --git a/flang/test/Semantics/collectives02.f90 b/flang/test/Semantics/collectives02.f90 --- a/flang/test/Semantics/collectives02.f90 +++ b/flang/test/Semantics/collectives02.f90 @@ -1,19 +1,17 @@ ! RUN: %python %S/test_errors.py %s %flang_fc1 -! XFAIL: * ! This test checks for semantic errors in co_min subroutine calls based on ! the co_min interface defined in section 16.9.48 of the Fortran 2018 standard. -! To Do: add co_min to the list of intrinsics program test_co_min implicit none - integer i, integer_array(1), coindexed_integer[*], status - character(len=1) c, character_array(1), coindexed_character[*], message + integer i, integer_array(1), coindexed_integer[*], status, coindexed_result_image[*], repeated_status + character(len=1) c, character_array(1), coindexed_character[*], message, repeated_message double precision d, double_precision_array(1) real r, real_array(1), coindexed_real[*] complex complex_type logical bool - + !___ standard-conforming calls with no keyword arguments ___ call co_min(i) call co_min(c) @@ -31,82 +29,104 @@ !___ standard-conforming calls with keyword arguments ___ ! all arguments present - call co_min(a=i, result_image=1, stat=status, errmsg=message) - call co_min(result_image=1, a=i, errmsg=message, stat=status) + call co_min(a=i, result_image=1, stat=status, errmsg=message) + call co_min(result_image=1, a=i, errmsg=message, stat=status) ! one optional argument not present - call co_min(a=i, stat=status, errmsg=message) + call co_min(a=i, stat=status, errmsg=message) call co_min(a=i, result_image=1, errmsg=message) call co_min(a=i, result_image=1, stat=status ) ! two optional arguments not present - call co_min(a=i, result_image=1 ) + call co_min(a=i, result_image=1 ) call co_min(a=i, stat=status ) - call co_min(a=i, errmsg=message) + call co_min(a=i, errmsg=message) + call co_min(a=i, result_image=coindexed_result_image[1] ) ! no optional arguments present - call co_min(a=i) + call co_min(a=i) !___ non-standard-conforming calls ___ + !ERROR: missing mandatory 'a=' argument + call co_min() + + !ERROR: repeated keyword argument to intrinsic 'co_min' + call co_min(a=i, a=c) + + !ERROR: repeated keyword argument to intrinsic 'co_min' + call co_min(d, result_image=1, result_image=3) + + !ERROR: repeated keyword argument to intrinsic 'co_min' + call co_min(d, 1, stat=status, stat=repeated_status) + + !ERROR: repeated keyword argument to intrinsic 'co_min' + call co_min(d, 1, status, errmsg=message, errmsg=repeated_message) + + !ERROR: keyword argument to intrinsic 'co_min' was supplied positionally by an earlier actual argument + call co_min(i, 1, a=c) + + !ERROR: keyword argument to intrinsic 'co_min' was supplied positionally by an earlier actual argument + call co_min(i, 1, status, result_image=1) + + !ERROR: keyword argument to intrinsic 'co_min' was supplied positionally by an earlier actual argument + call co_min(i, 1, status, stat=repeated_status) + + !ERROR: keyword argument to intrinsic 'co_min' was supplied positionally by an earlier actual argument + call co_min(i, 1, status, message, errmsg=repeated_message) + ! argument 'a' shall be of numeric type !ERROR: Actual argument for 'a=' has bad type 'LOGICAL(4)' call co_min(bool) - + ! argument 'a' shall be of numeric type !ERROR: Actual argument for 'a=' has bad type 'COMPLEX(4)' call co_min(complex_type) - - ! argument 'a' is intent(inout) + !ERROR: Actual argument associated with INTENT(IN OUT) dummy argument 'a=' must be definable call co_min(a=1+1) - - ! argument 'a' shall not be a coindexed object - !ERROR: to be determined + + !ERROR: 'a' argument to 'co_min' may not be a coindexed object call co_min(a=coindexed_real[1]) - - ! 'result_image' argument shall be a scalar - !ERROR: too many actual arguments for intrinsic 'co_min' + + !ERROR: Actual argument for 'result_image=' has bad type 'LOGICAL(4)' call co_min(i, result_image=bool) - - ! 'result_image' argument shall be an integer scalar - !ERROR: too many actual arguments for intrinsic 'co_min' + + !ERROR: 'result_image=' argument has unacceptable rank 1 call co_min(c, result_image=integer_array) - - ! 'stat' argument shall be noncoindexed - !ERROR: to be determined + + !ERROR: 'stat' argument to 'co_min' may not be a coindexed object call co_min(d, stat=coindexed_integer[1]) - + ! 'stat' argument shall be an integer !ERROR: Actual argument for 'stat=' has bad type 'CHARACTER(KIND=1,LEN=1_8)' call co_min(r, stat=message) - - ! 'stat' argument shall be an integer scalar + !ERROR: 'stat=' argument has unacceptable rank 1 call co_min(i, stat=integer_array) - ! 'errmsg' argument shall be intent(inout) !ERROR: Actual argument associated with INTENT(IN OUT) dummy argument 'errmsg=' must be definable call co_min(a=i, result_image=1, stat=status, errmsg='c') - ! 'errmsg' argument shall be noncoindexed - !ERROR: to be determined + !ERROR: 'errmsg' argument to 'co_min' may not be a coindexed object call co_min(c, errmsg=coindexed_character[1]) ! 'errmsg' argument shall be a character - !ERROR: to be determined + !ERROR: Actual argument for 'errmsg=' has bad type 'INTEGER(4)' call co_min(c, errmsg=i) - ! 'errmsg' argument shall be character scalar !ERROR: 'errmsg=' argument has unacceptable rank 1 call co_min(d, errmsg=character_array) - - ! the error is seen as too many arguments to the co_min() call + !ERROR: too many actual arguments for intrinsic 'co_min' call co_min(r, result_image=1, stat=status, errmsg=message, 3.4) - - ! keyword argument with incorrect name + !ERROR: unknown keyword argument to intrinsic 'co_min' call co_min(fake=3.4) - + + !ERROR: 'a' argument to 'co_min' may not be a coindexed object + !ERROR: 'errmsg' argument to 'co_min' may not be a coindexed object + !ERROR: 'stat' argument to 'co_min' may not be a coindexed object + call co_min(result_image=coindexed_result_image[1], a=coindexed_real[1], errmsg=coindexed_character[1], stat=coindexed_integer[1]) + end program test_co_min diff --git a/flang/test/Semantics/collectives03.f90 b/flang/test/Semantics/collectives03.f90 --- a/flang/test/Semantics/collectives03.f90 +++ b/flang/test/Semantics/collectives03.f90 @@ -1,19 +1,17 @@ ! RUN: %python %S/test_errors.py %s %flang_fc1 -! XFAIL: * ! This test checks for semantic errors in co_max subroutine calls based on ! the co_max interface defined in section 16.9.47 of the Fortran 2018 standard. -! To Do: add co_max to the list of intrinsics program test_co_max implicit none - integer i, integer_array(1), coindexed_integer[*], status - character(len=1) c, character_array(1), coindexed_character[*], message + integer i, integer_array(1), coindexed_integer[*], status, coindexed_result_image[*], repeated_status + character(len=1) c, character_array(1), coindexed_character[*], message, repeated_message double precision d, double_precision_array(1) real r, real_array(1), coindexed_real[*] complex complex_type logical bool - + !___ standard-conforming calls with no keyword arguments ___ call co_max(i) call co_max(c) @@ -31,82 +29,104 @@ !___ standard-conforming calls with keyword arguments ___ ! all arguments present - call co_max(a=i, result_image=1, stat=status, errmsg=message) - call co_max(result_image=1, a=i, errmsg=message, stat=status) + call co_max(a=i, result_image=1, stat=status, errmsg=message) + call co_max(result_image=1, a=i, errmsg=message, stat=status) ! one optional argument not present - call co_max(a=i, stat=status, errmsg=message) + call co_max(a=i, stat=status, errmsg=message) call co_max(a=i, result_image=1, errmsg=message) call co_max(a=i, result_image=1, stat=status ) ! two optional arguments not present - call co_max(a=i, result_image=1 ) + call co_max(a=i, result_image=1 ) call co_max(a=i, stat=status ) - call co_max(a=i, errmsg=message) + call co_max(a=i, errmsg=message) + call co_max(a=i, result_image=coindexed_result_image[1] ) ! no optional arguments present - call co_max(a=i) + call co_max(a=i) !___ non-standard-conforming calls ___ + !ERROR: missing mandatory 'a=' argument + call co_max() + + !ERROR: repeated keyword argument to intrinsic 'co_max' + call co_max(a=i, a=c) + + !ERROR: repeated keyword argument to intrinsic 'co_max' + call co_max(d, result_image=1, result_image=3) + + !ERROR: repeated keyword argument to intrinsic 'co_max' + call co_max(d, 1, stat=status, stat=repeated_status) + + !ERROR: repeated keyword argument to intrinsic 'co_max' + call co_max(d, 1, status, errmsg=message, errmsg=repeated_message) + + !ERROR: keyword argument to intrinsic 'co_max' was supplied positionally by an earlier actual argument + call co_max(i, 1, a=c) + + !ERROR: keyword argument to intrinsic 'co_max' was supplied positionally by an earlier actual argument + call co_max(i, 1, status, result_image=1) + + !ERROR: keyword argument to intrinsic 'co_max' was supplied positionally by an earlier actual argument + call co_max(i, 1, status, stat=repeated_status) + + !ERROR: keyword argument to intrinsic 'co_max' was supplied positionally by an earlier actual argument + call co_max(i, 1, status, message, errmsg=repeated_message) + ! argument 'a' shall be of numeric type !ERROR: Actual argument for 'a=' has bad type 'LOGICAL(4)' call co_max(bool) - + ! argument 'a' shall be of numeric type !ERROR: Actual argument for 'a=' has bad type 'COMPLEX(4)' call co_max(complex_type) - - ! argument 'a' is intent(inout) + !ERROR: Actual argument associated with INTENT(IN OUT) dummy argument 'a=' must be definable call co_max(a=1+1) - - ! argument 'a' shall not be a coindexed object - !ERROR: to be determined + + !ERROR: 'a' argument to 'co_max' may not be a coindexed object call co_max(a=coindexed_real[1]) - - ! 'result_image' argument shall be a scalar - !ERROR: too many actual arguments for intrinsic 'co_max' + + !ERROR: Actual argument for 'result_image=' has bad type 'LOGICAL(4)' call co_max(i, result_image=bool) - - ! 'result_image' argument shall be an integer scalar - !ERROR: too many actual arguments for intrinsic 'co_max' + + !ERROR: 'result_image=' argument has unacceptable rank 1 call co_max(c, result_image=integer_array) - - ! 'stat' argument shall be noncoindexed - !ERROR: to be determined + + !ERROR: 'stat' argument to 'co_max' may not be a coindexed object call co_max(d, stat=coindexed_integer[1]) - + ! 'stat' argument shall be an integer !ERROR: Actual argument for 'stat=' has bad type 'CHARACTER(KIND=1,LEN=1_8)' call co_max(r, stat=message) - - ! 'stat' argument shall be an integer scalar + !ERROR: 'stat=' argument has unacceptable rank 1 call co_max(i, stat=integer_array) - - ! 'errmsg' argument shall be intent(inout) + !ERROR: Actual argument associated with INTENT(IN OUT) dummy argument 'errmsg=' must be definable call co_max(a=i, result_image=1, stat=status, errmsg='c') - ! 'errmsg' argument shall be noncoindexed - !ERROR: to be determined + !ERROR: 'errmsg' argument to 'co_max' may not be a coindexed object call co_max(c, errmsg=coindexed_character[1]) ! 'errmsg' argument shall be a character - !ERROR: to be determined + !ERROR: Actual argument for 'errmsg=' has bad type 'INTEGER(4)' call co_max(c, errmsg=i) - ! 'errmsg' argument shall be character scalar !ERROR: 'errmsg=' argument has unacceptable rank 1 call co_max(d, errmsg=character_array) - - ! the error is seen as too many arguments to the co_max() call + !ERROR: too many actual arguments for intrinsic 'co_max' call co_max(r, result_image=1, stat=status, errmsg=message, 3.4) - - ! keyword argument with incorrect name + !ERROR: unknown keyword argument to intrinsic 'co_max' call co_max(fake=3.4) - + + !ERROR: 'a' argument to 'co_max' may not be a coindexed object + !ERROR: 'errmsg' argument to 'co_max' may not be a coindexed object + !ERROR: 'stat' argument to 'co_max' may not be a coindexed object + call co_max(result_image=coindexed_result_image[1], a=coindexed_real[1], errmsg=coindexed_character[1], stat=coindexed_integer[1]) + end program test_co_max