From a21089a24bdd66347c91fa3638300b90c4dd4039 Mon Sep 17 00:00:00 2001 From: Peter Klausler Date: Thu, 27 Feb 2025 14:27:46 -0800 Subject: [PATCH] [flang] Support COSHAPE() intrinsic function (#125286) Enable COSHAPE in the intrinsics table and enable its test. --- flang/lib/Evaluate/intrinsics.cpp | 4 ++-- flang/test/Semantics/coshape.f90 | 31 +++++++++++++++++++++++++++++-- 2 files changed, 31 insertions(+), 4 deletions(-) diff --git a/flang/lib/Evaluate/intrinsics.cpp b/flang/lib/Evaluate/intrinsics.cpp index 6d8f19388d8b..e55a22dce8e9 100644 --- a/flang/lib/Evaluate/intrinsics.cpp +++ b/flang/lib/Evaluate/intrinsics.cpp @@ -421,6 +421,8 @@ static const IntrinsicInterface genericIntrinsicFunction[]{ {"cos", {{"x", SameFloating}}, SameFloating}, {"cosd", {{"x", SameFloating}}, SameFloating}, {"cosh", {{"x", SameFloating}}, SameFloating}, + {"coshape", {{"coarray", AnyData, Rank::coarray}, SizeDefaultKIND}, KINDInt, + Rank::vector, IntrinsicClass::inquiryFunction}, {"count", {{"mask", AnyLogical, Rank::array}, OptionalDIM, DefaultingKIND}, KINDInt, Rank::dimReduced, IntrinsicClass::transformationalFunction}, {"cshift", @@ -1054,8 +1056,6 @@ static const IntrinsicInterface genericIntrinsicFunction[]{ {"__builtin_numeric_storage_size", {}, DefaultInt}, }; -// TODO: Coarray intrinsic functions -// COSHAPE // TODO: Non-standard intrinsic functions // SHIFT, // COMPL, EQV, NEQV, INT8, JINT, JNINT, KNINT, diff --git a/flang/test/Semantics/coshape.f90 b/flang/test/Semantics/coshape.f90 index 476000b56411..d4fb45df6600 100644 --- a/flang/test/Semantics/coshape.f90 +++ b/flang/test/Semantics/coshape.f90 @@ -1,5 +1,4 @@ ! RUN: %python %S/test_errors.py %s %flang_fc1 -! XFAIL: * ! Check for semantic errors in coshape() function, ! as defined in section 16.9.55 of the Fortran ! 2018 standard @@ -8,18 +7,21 @@ program coshape_tests use iso_c_binding, only : c_int32_t, c_int64_t implicit none + type t + real x + end type integer array(1), non_coarray(1), scalar_coarray[*], array_coarray(1)[*], non_constant, scalar_result real real_coarray[*] complex complex_coarray[*] character char_array(1) logical non_integer, logical_coarray[*] + type(t) derived_scalar_coarray[*], derived_array_coarray(1)[*] integer, allocatable :: codimensions(:) !___ standard-conforming statement with no optional arguments present ___ codimensions = coshape(scalar_coarray) codimensions = coshape(array_coarray) codimensions = coshape(array_coarray(1)) - codimensions = coshape(scalar_coarray[1]) codimensions = coshape(real_coarray) codimensions = coshape(logical_coarray) codimensions = coshape(complex_coarray) @@ -33,54 +35,79 @@ program coshape_tests !___ non-conforming statements ___ ! coarray argument must be a coarray + !ERROR: 'coarray=' argument must have corank > 0 for intrinsic 'coshape' codimensions = coshape(non_coarray) + !ERROR: 'coarray=' argument must have corank > 0 for intrinsic 'coshape' + codimensions = coshape(derived_scalar_coarray[1]%x) + !ERROR: 'coarray=' argument must have corank > 0 for intrinsic 'coshape' + codimensions = coshape(derived_array_coarray[1]%x) + !ERROR: 'coarray=' argument must have corank > 0 for intrinsic 'coshape' + codimensions = coshape(array_coarray[1]) + !ERROR: 'coarray=' argument must have corank > 0 for intrinsic 'coshape' + codimensions = coshape(scalar_coarray[1]) ! kind argument must be an integer + !ERROR: Actual argument for 'kind=' has bad type 'LOGICAL(4)' codimensions = coshape(scalar_coarray, non_integer) ! kind argument must be a constant expression + !ERROR: 'kind=' argument must be a constant scalar integer whose value is a supported kind for the intrinsic result type codimensions = coshape(real_coarray, non_constant) ! kind argument must be an integer scalar + !ERROR: 'kind=' argument has unacceptable rank 1 codimensions = coshape(complex_coarray, array) ! missing all arguments + !ERROR: missing mandatory 'coarray=' argument codimensions = coshape() ! missing mandatory argument + !ERROR: missing mandatory 'coarray=' argument codimensions = coshape(kind=c_int32_t) ! incorrect typing for mandatory argument + !ERROR: 'coarray=' argument must have corank > 0 for intrinsic 'coshape' codimensions = coshape(3.4) ! incorrect typing for coarray argument + !ERROR: 'coarray=' argument must have corank > 0 for intrinsic 'coshape' codimensions = coshape(coarray=3.4) ! too many arguments + !ERROR: too many actual arguments for intrinsic 'coshape' codimensions = coshape(scalar_coarray, c_int32_t, 0) ! incorrect typing with correct keyword for coarray argument + !ERROR: 'coarray=' argument must have corank > 0 for intrinsic 'coshape' codimensions = coshape(coarray=non_coarray) ! correct typing with incorrect keyword for coarray argument + !ERROR: unknown keyword argument to intrinsic 'coshape' codimensions = coshape(c=real_coarray) ! incorrect typing with correct keyword for kind argument + !ERROR: Actual argument for 'kind=' has bad type 'LOGICAL(4)' codimensions = coshape(complex_coarray, kind=non_integer) ! correct typing with incorrect keyword for kind argument + !ERROR: unknown keyword argument to intrinsic 'coshape' codimensions = coshape(logical_coarray, kinds=c_int32_t) ! repeated keyword for coarray argument + !ERROR: repeated keyword argument to intrinsic 'coshape' codimensions = coshape(coarray=scalar_coarray, coarray=real_coarray) ! repeated keyword for kind argument + !ERROR: repeated keyword argument to intrinsic 'coshape' codimensions = coshape(real_coarray, kind=c_int32_t, kind=c_int64_t) ! result must be a rank 1 array + !ERROR: No intrinsic or user-defined ASSIGNMENT(=) matches scalar INTEGER(4) and rank 1 array of INTEGER(4) scalar_result = coshape(scalar_coarray) ! result must be an integer array + !ERROR: No intrinsic or user-defined ASSIGNMENT(=) matches operand types CHARACTER(KIND=1) and INTEGER(4) char_array = coshape(real_coarray) end program coshape_tests