diff --git a/flang/docs/Intrinsics.md b/flang/docs/Intrinsics.md --- a/flang/docs/Intrinsics.md +++ b/flang/docs/Intrinsics.md @@ -746,7 +746,7 @@ | Intrinsic Category | Intrinsic Procedures Lacking Support | | --- | --- | -| Coarray intrinsic functions | LCOBOUND, UCOBOUND, IMAGE_INDEX, COSHAPE | +| Coarray intrinsic functions | IMAGE_INDEX, COSHAPE | | Object characteristic inquiry functions | ALLOCATED, ASSOCIATED, EXTENDS_TYPE_OF, IS_CONTIGUOUS, PRESENT, RANK, SAME_TYPE, STORAGE_SIZE | | Type inquiry intrinsic functions | BIT_SIZE, DIGITS, EPSILON, HUGE, KIND, MAXEXPONENT, MINEXPONENT, NEW_LINE, PRECISION, RADIX, RANGE, TINY| | Non-standard intrinsic functions | AND, OR, XOR, LSHIFT, RSHIFT, SHIFT, ZEXT, IZEXT, COSD, SIND, TAND, ACOSD, ASIND, ATAND, ATAN2D, COMPL, DCMPLX, EQV, NEQV, INT8, JINT, JNINT, KNINT, LOC, QCMPLX, DREAL, DFLOAT, QEXT, QFLOAT, QREAL, DNUM, NUM, JNUM, KNUM, QNUM, RNUM, RAN, RANF, ILEN, SIZEOF, MCLOCK, SECNDS, COTAN, IBCHNG, ISHA, ISHC, ISHL, IXOR, IARG, IARGC, NARGS, NUMARG, BADDRESS, IADDR, CACHESIZE, EOF, FP_CLASS, INT_PTR_KIND, ISNAN, MALLOC | 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 @@ -189,6 +189,7 @@ reduceOperation, // a pure function with constraints for REDUCE dimReduced, // scalar if no DIM= argument, else rank(array)-1 dimRemovedOrScalar, // rank(array)-1 (less DIM) or scalar + scalarIfDim, // scalar if DIM= argument is present, else rank one array locReduced, // vector(1:rank) if no DIM= argument, else rank(array)-1 rankPlus1, // rank(known)+1 shaped, // rank is length of SHAPE vector @@ -517,6 +518,9 @@ KINDInt, Rank::scalar, IntrinsicClass::inquiryFunction}, {"lbound", {{"array", AnyData, Rank::anyOrAssumedRank}, SizeDefaultKIND}, KINDInt, Rank::vector, IntrinsicClass::inquiryFunction}, + {"lcobound", + {{"coarray", AnyData, Rank::coarray}, OptionalDIM, SizeDefaultKIND}, + KINDInt, Rank::scalarIfDim, IntrinsicClass::inquiryFunction}, {"leadz", {{"i", AnyInt}}, DefaultInt}, {"len", {{"string", AnyChar, Rank::anyOrAssumedRank}, DefaultingKIND}, KINDInt, Rank::scalar, IntrinsicClass::inquiryFunction}, @@ -796,6 +800,9 @@ KINDInt, Rank::scalar, IntrinsicClass::inquiryFunction}, {"ubound", {{"array", AnyData, Rank::anyOrAssumedRank}, SizeDefaultKIND}, KINDInt, Rank::vector, IntrinsicClass::inquiryFunction}, + {"ucobound", + {{"coarray", AnyData, Rank::coarray}, OptionalDIM, SizeDefaultKIND}, + KINDInt, Rank::scalarIfDim, IntrinsicClass::inquiryFunction}, {"unpack", {{"vector", SameType, Rank::vector}, {"mask", AnyLogical, Rank::array}, {"field", SameType, Rank::conformable}}, @@ -844,7 +851,7 @@ }; // TODO: Coarray intrinsic functions -// LCOBOUND, UCOBOUND, IMAGE_INDEX, COSHAPE +// IMAGE_INDEX, COSHAPE // TODO: Non-standard intrinsic functions // LSHIFT, RSHIFT, SHIFT, // COMPL, EQV, NEQV, INT8, JINT, JNINT, KNINT, @@ -1616,6 +1623,7 @@ // The reduction function is validated in ApplySpecificChecks(). argOk = true; break; + case Rank::scalarIfDim: case Rank::locReduced: case Rank::rankPlus1: case Rank::shaped: @@ -1800,6 +1808,9 @@ CHECK(shapeArgSize); resultRank = *shapeArgSize; break; + case Rank::scalarIfDim: + resultRank = hasDimArg ? 0 : 1; + break; case Rank::elementalOrBOZ: case Rank::shape: case Rank::array: @@ -2374,6 +2385,27 @@ return ok; } +static bool CheckDimAgainstCorank(SpecificCall &call, FoldingContext &context) { + bool ok{true}; + if (const auto &coarrayArg{call.arguments[0]}) { + if (const auto &dimArg{call.arguments[1]}) { + if (const auto *symbol{ + UnwrapWholeSymbolDataRef(coarrayArg->UnwrapExpr())}) { + const auto corank = symbol->Corank(); + if (const auto dimNum{ToInt64(dimArg->UnwrapExpr())}) { + if (dimNum < 1 || dimNum > corank) { + ok = false; + context.messages().Say(dimArg->sourceLocation(), + "DIM=%jd dimension is out of range for coarray with corank %d"_err_en_US, + static_cast(*dimNum), corank); + } + } + } + } + } + return ok; +} + // Applies any semantic checks peculiar to an intrinsic. static bool ApplySpecificChecks(SpecificCall &call, FoldingContext &context) { bool ok{true}; @@ -2414,6 +2446,8 @@ } } } + } else if (name == "lcobound") { + return CheckDimAgainstCorank(call, context); } else if (name == "loc") { const auto &arg{call.arguments[0]}; ok = @@ -2521,6 +2555,8 @@ } } } + } else if (name == "ucobound") { + return CheckDimAgainstCorank(call, context); } return ok; } diff --git a/flang/test/Semantics/lcobound.f90 b/flang/test/Semantics/lcobound.f90 --- a/flang/test/Semantics/lcobound.f90 +++ b/flang/test/Semantics/lcobound.f90 @@ -1,22 +1,30 @@ ! RUN: %python %S/test_errors.py %s %flang_fc1 -! XFAIL: * ! Check for semantic errors in lcobound() function references program lcobound_tests - use iso_c_binding, only : c_int32_t + use iso_c_binding, only : c_int32_t, c_int64_t implicit none integer n, i, array(1), non_coarray(1), scalar_coarray[*], array_coarray(1)[*], non_constant, scalar - logical non_integer + integer, parameter :: const_out_of_range_dim = 5, const_in_range_dim = 1 + real, allocatable :: coarray_corank3[:,:,:] + logical non_integer, logical_coarray[3,*] + logical, parameter :: const_non_integer = .true. integer, allocatable :: lcobounds(:) !___ standard-conforming statement with no optional arguments present ___ lcobounds = lcobound(scalar_coarray) lcobounds = lcobound(array_coarray) + lcobounds = lcobound(coarray_corank3) + lcobounds = lcobound(logical_coarray) lcobounds = lcobound(coarray=scalar_coarray) !___ standard-conforming statements with optional dim argument present ___ n = lcobound(scalar_coarray, 1) + n = lcobound(coarray_corank3, 1) + n = lcobound(coarray_corank3, 3) + n = lcobound(scalar_coarray, const_in_range_dim) + n = lcobound(logical_coarray, const_in_range_dim) n = lcobound(scalar_coarray, dim=1) n = lcobound(coarray=scalar_coarray, dim=1) n = lcobound( dim=1, coarray=scalar_coarray) @@ -41,37 +49,100 @@ n = lcobound(kind=c_int32_t, dim=1, coarray=scalar_coarray) !___ non-conforming statements ___ - n = lcobound(scalar_coarray, dim=1) + + !ERROR: DIM=0 dimension is out of range for coarray with corank 1 + n = lcobound(scalar_coarray, dim=0) + + !ERROR: DIM=0 dimension is out of range for coarray with corank 3 + n = lcobound(coarray_corank3, dim=0) + + !ERROR: DIM=-1 dimension is out of range for coarray with corank 1 + n = lcobound(scalar_coarray, dim=-1) + + !ERROR: DIM=2 dimension is out of range for coarray with corank 1 n = lcobound(array_coarray, dim=2) + + !ERROR: DIM=2 dimension is out of range for coarray with corank 1 + n = lcobound(array_coarray, 2) + + !ERROR: DIM=4 dimension is out of range for coarray with corank 3 + n = lcobound(coarray_corank3, dim=4) + + !ERROR: DIM=4 dimension is out of range for coarray with corank 3 + n = lcobound(dim=4, coarray=coarray_corank3) + + !ERROR: DIM=5 dimension is out of range for coarray with corank 3 + n = lcobound(coarray_corank3, const_out_of_range_dim) + + !ERROR: No intrinsic or user-defined ASSIGNMENT(=) matches scalar INTEGER(4) and rank 1 array of INTEGER(4) scalar = lcobound(scalar_coarray) + !ERROR: missing mandatory 'coarray=' argument n = lcobound(dim=i) + !ERROR: Actual argument for 'dim=' has bad type 'LOGICAL(4)' n = lcobound(scalar_coarray, non_integer) + !ERROR: Actual argument for 'dim=' has bad type 'LOGICAL(4)' n = lcobound(scalar_coarray, dim=non_integer) - lcobounds = lcobound(scalar_coarray, kind=non_integer) + !ERROR: Actual argument for 'kind=' has bad type 'LOGICAL(4)' + lcobounds = lcobound(scalar_coarray, kind=const_non_integer) + + !ERROR: Actual argument for 'kind=' has bad type 'LOGICAL(4)' + n = lcobound(scalar_coarray, 1, const_non_integer) + + !ERROR: 'kind=' argument must be a constant scalar integer whose value is a supported kind for the intrinsic result type lcobounds = lcobound(scalar_coarray, kind=non_constant) + !ERROR: 'kind=' argument must be a constant scalar integer whose value is a supported kind for the intrinsic result type + n = lcobound(scalar_coarray, dim=1, kind=non_constant) + + !ERROR: 'kind=' argument must be a constant scalar integer whose value is a supported kind for the intrinsic result type + n = lcobound(scalar_coarray, 1, non_constant) + + !ERROR: missing mandatory 'coarray=' argument n = lcobound(dim=i, kind=c_int32_t) n = lcobound(coarray=scalar_coarray, i) + !ERROR: missing mandatory 'coarray=' argument + lcobounds = lcobound() + + !ERROR: 'coarray=' argument must have corank > 0 for intrinsic 'lcobound' lcobounds = lcobound(3.4) + !ERROR: keyword argument to intrinsic 'lcobound' was supplied positionally by an earlier actual argument + n = lcobound(scalar_coarray, 1, coarray=scalar_coarray) + + !ERROR: too many actual arguments for intrinsic 'lcobound' n = lcobound(scalar_coarray, i, c_int32_t, 0) + !ERROR: 'coarray=' argument must have corank > 0 for intrinsic 'lcobound' lcobounds = lcobound(coarray=non_coarray) - n = lcobound(scalar_coarray, i, kind=non_integer) + !ERROR: 'coarray=' argument must have corank > 0 for intrinsic 'lcobound' + n = lcobound(coarray=non_coarray, dim=1) + !ERROR: 'dim=' argument has unacceptable rank 1 n = lcobound(scalar_coarray, array ) + !ERROR: unknown keyword argument to intrinsic 'lcobound' lcobounds = lcobound(c=scalar_coarray) + !ERROR: unknown keyword argument to intrinsic 'lcobound' n = lcobound(scalar_coarray, dims=i) + !ERROR: unknown keyword argument to intrinsic 'lcobound' n = lcobound(scalar_coarray, i, kinds=c_int32_t) + !ERROR: repeated keyword argument to intrinsic 'lcobound' + n = lcobound(scalar_coarray, dim=1, dim=2) + + !ERROR: repeated keyword argument to intrinsic 'lcobound' + lcobounds = lcobound(coarray=scalar_coarray, coarray=array_coarray) + + !ERROR: repeated keyword argument to intrinsic 'lcobound' + lcobounds = lcobound(scalar_coarray, kind=c_int32_t, kind=c_int64_t) + end program lcobound_tests diff --git a/flang/test/Semantics/ucobound.f90 b/flang/test/Semantics/ucobound.f90 --- a/flang/test/Semantics/ucobound.f90 +++ b/flang/test/Semantics/ucobound.f90 @@ -1,23 +1,30 @@ ! RUN: %python %S/test_errors.py %s %flang_fc1 -! XFAIL: * ! Check for semantic errors in ucobound() function references program ucobound_tests - use iso_c_binding, only : c_int32_t + use iso_c_binding, only : c_int32_t, c_int64_t implicit none integer n, i, array(1), non_coarray(1), scalar_coarray[*], array_coarray(1)[*], non_constant, scalar - logical non_integer + integer, parameter :: const_out_of_range_dim = 5, const_in_range_dim = 1 + real, allocatable :: coarray_corank3[:,:,:] + logical non_integer, logical_coarray[3,*] + logical, parameter :: const_non_integer = .true. integer, allocatable :: ucobounds(:) - integer, parameter :: non_existent=2 !___ standard-conforming statement with no optional arguments present ___ ucobounds = ucobound(scalar_coarray) ucobounds = ucobound(array_coarray) + ucobounds = ucobound(coarray_corank3) + ucobounds = ucobound(logical_coarray) ucobounds = ucobound(coarray=scalar_coarray) !___ standard-conforming statements with optional dim argument present ___ n = ucobound(scalar_coarray, 1) + n = ucobound(coarray_corank3, 1) + n = ucobound(coarray_corank3, 3) + n = ucobound(scalar_coarray, const_in_range_dim) + n = ucobound(logical_coarray, const_in_range_dim) n = ucobound(scalar_coarray, dim=1) n = ucobound(coarray=scalar_coarray, dim=1) n = ucobound( dim=1, coarray=scalar_coarray) @@ -42,37 +49,100 @@ n = ucobound(kind=c_int32_t, dim=1, coarray=scalar_coarray) !___ non-conforming statements ___ - n = ucobound(scalar_coarray, dim=1) - n = ucobound(array_coarray, dim=non_existent) + + !ERROR: DIM=0 dimension is out of range for coarray with corank 1 + n = ucobound(scalar_coarray, dim=0) + + !ERROR: DIM=0 dimension is out of range for coarray with corank 3 + n = ucobound(coarray_corank3, dim=0) + + !ERROR: DIM=-1 dimension is out of range for coarray with corank 1 + n = ucobound(scalar_coarray, dim=-1) + + !ERROR: DIM=2 dimension is out of range for coarray with corank 1 + n = ucobound(array_coarray, dim=2) + + !ERROR: DIM=2 dimension is out of range for coarray with corank 1 + n = ucobound(array_coarray, 2) + + !ERROR: DIM=4 dimension is out of range for coarray with corank 3 + n = ucobound(coarray_corank3, dim=4) + + !ERROR: DIM=4 dimension is out of range for coarray with corank 3 + n = ucobound(dim=4, coarray=coarray_corank3) + + !ERROR: DIM=5 dimension is out of range for coarray with corank 3 + n = ucobound(coarray_corank3, const_out_of_range_dim) + + !ERROR: No intrinsic or user-defined ASSIGNMENT(=) matches scalar INTEGER(4) and rank 1 array of INTEGER(4) scalar = ucobound(scalar_coarray) + !ERROR: missing mandatory 'coarray=' argument n = ucobound(dim=i) + !ERROR: Actual argument for 'dim=' has bad type 'LOGICAL(4)' n = ucobound(scalar_coarray, non_integer) + !ERROR: Actual argument for 'dim=' has bad type 'LOGICAL(4)' n = ucobound(scalar_coarray, dim=non_integer) - ucobounds = ucobound(scalar_coarray, kind=non_integer) + !ERROR: Actual argument for 'kind=' has bad type 'LOGICAL(4)' + ucobounds = ucobound(scalar_coarray, kind=const_non_integer) + + !ERROR: Actual argument for 'kind=' has bad type 'LOGICAL(4)' + n = ucobound(scalar_coarray, 1, const_non_integer) + + !ERROR: 'kind=' argument must be a constant scalar integer whose value is a supported kind for the intrinsic result type ucobounds = ucobound(scalar_coarray, kind=non_constant) + !ERROR: 'kind=' argument must be a constant scalar integer whose value is a supported kind for the intrinsic result type + n = ucobound(scalar_coarray, dim=1, kind=non_constant) + + !ERROR: 'kind=' argument must be a constant scalar integer whose value is a supported kind for the intrinsic result type + n = ucobound(scalar_coarray, 1, non_constant) + + !ERROR: missing mandatory 'coarray=' argument n = ucobound(dim=i, kind=c_int32_t) n = ucobound(coarray=scalar_coarray, i) + !ERROR: missing mandatory 'coarray=' argument + ucobounds = ucobound() + + !ERROR: 'coarray=' argument must have corank > 0 for intrinsic 'ucobound' ucobounds = ucobound(3.4) + !ERROR: keyword argument to intrinsic 'ucobound' was supplied positionally by an earlier actual argument + n = ucobound(scalar_coarray, 1, coarray=scalar_coarray) + + !ERROR: too many actual arguments for intrinsic 'ucobound' n = ucobound(scalar_coarray, i, c_int32_t, 0) + !ERROR: 'coarray=' argument must have corank > 0 for intrinsic 'ucobound' ucobounds = ucobound(coarray=non_coarray) - n = ucobound(scalar_coarray, i, kind=non_integer) + !ERROR: 'coarray=' argument must have corank > 0 for intrinsic 'ucobound' + n = ucobound(coarray=non_coarray, dim=1) + !ERROR: 'dim=' argument has unacceptable rank 1 n = ucobound(scalar_coarray, array ) + !ERROR: unknown keyword argument to intrinsic 'ucobound' ucobounds = ucobound(c=scalar_coarray) + !ERROR: unknown keyword argument to intrinsic 'ucobound' n = ucobound(scalar_coarray, dims=i) + !ERROR: unknown keyword argument to intrinsic 'ucobound' n = ucobound(scalar_coarray, i, kinds=c_int32_t) + !ERROR: repeated keyword argument to intrinsic 'ucobound' + n = ucobound(scalar_coarray, dim=1, dim=2) + + !ERROR: repeated keyword argument to intrinsic 'ucobound' + ucobounds = ucobound(coarray=scalar_coarray, coarray=array_coarray) + + !ERROR: repeated keyword argument to intrinsic 'ucobound' + ucobounds = ucobound(scalar_coarray, kind=c_int32_t, kind=c_int64_t) + end program ucobound_tests