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 @@ -10,6 +10,7 @@ #include "flang/Common/Fortran.h" #include "flang/Common/enum-set.h" #include "flang/Common/idioms.h" +#include "flang/Evaluate/check-expression.h" #include "flang/Evaluate/common.h" #include "flang/Evaluate/expression.h" #include "flang/Evaluate/fold.h" @@ -20,6 +21,7 @@ #include "flang/Semantics/tools.h" #include "llvm/Support/raw_ostream.h" #include +#include #include #include #include @@ -2322,6 +2324,45 @@ return ok; } +static bool CheckForNonPositiveValues(FoldingContext &context, + const ActualArgument &arg, const std::string &procName, + const std::string &argName) { + bool ok{true}; + if (arg.Rank() > 0) { + if (const Expr *expr{arg.UnwrapExpr()}) { + if (const auto *intExpr{std::get_if>(&expr->u)}) { + std::visit( + [&](const auto &kindExpr) { + using IntType = typename std::decay_t::Result; + if (const auto *constArray{ + UnwrapConstantValue(kindExpr)}) { + for (std::size_t j{0}; j < constArray->size(); ++j) { + auto arrayExpr{constArray->values().at(j)}; + if (arrayExpr.IsNegative() || arrayExpr.IsZero()) { + ok = false; + context.messages().Say(arg.sourceLocation(), + "'%s=' argument for intrinsic '%s' must contain all positive values"_err_en_US, + argName, procName); + } + } + } + }, + intExpr->u); + } + } + } else { + if (auto val{ToInt64(arg.UnwrapExpr())}) { + if (*val <= 0) { + ok = false; + context.messages().Say(arg.sourceLocation(), + "'%s=' argument for intrinsic '%s' must be a positive value, but is %jd"_err_en_US, + argName, procName, static_cast(*val)); + } + } + } + return ok; +} + // Applies any semantic checks peculiar to an intrinsic. static bool ApplySpecificChecks(SpecificCall &call, FoldingContext &context) { bool ok{true}; @@ -2340,6 +2381,28 @@ } } else if (name == "associated") { return CheckAssociated(call, context); + } else if (name == "image_status") { + if (const auto &arg{call.arguments[0]}) { + ok = CheckForNonPositiveValues(context, *arg, name, "image"); + } + } else if (name == "ishftc") { + if (const auto &sizeArg{call.arguments[2]}) { + ok = CheckForNonPositiveValues(context, *sizeArg, name, "size"); + if (ok) { + if (auto sizeVal{ToInt64(sizeArg->UnwrapExpr())}) { + if (const auto &shiftArg{call.arguments[1]}) { + if (auto shiftVal{ToInt64(shiftArg->UnwrapExpr())}) { + if (std::abs(*shiftVal) > *sizeVal) { + ok = false; + context.messages().Say(shiftArg->sourceLocation(), + "The absolute value of the 'shift=' argument for intrinsic '%s' must be less than or equal to the 'size=' argument"_err_en_US, + name); + } + } + } + } + } + } } else if (name == "loc") { const auto &arg{call.arguments[0]}; ok = diff --git a/flang/test/Semantics/image_status.f90 b/flang/test/Semantics/image_status.f90 new file mode 100644 --- /dev/null +++ b/flang/test/Semantics/image_status.f90 @@ -0,0 +1,114 @@ +! RUN: %python %S/test_errors.py %s %flang_fc1 +! Check for semantic errors in image_status(), as defined in +! section 16.9.98 of the Fortran 2018 standard + +program test_image_status + use iso_fortran_env, only : team_type, stat_failed_image, stat_stopped_image + implicit none + + type(team_type) home, league(2) + integer n, image_num, array(5), coindexed[*], non_array_result, array_2d(10, 10), not_team_type + integer, parameter :: array_with_negative(2) = [-2, 1] + integer, parameter :: array_with_zero(2) = [1, 0] + integer, parameter :: constant_integer = 2, constant_negative = -4, constant_zero = 0 + integer, allocatable :: result_array(:), result_array_2d(:,:), wrong_rank_result(:) + logical wrong_arg_type_logical + real wrong_arg_type_real + character wrong_result_type + + !___ standard-conforming statements ___ + n = image_status(1) + n = image_status(constant_integer) + n = image_status(image_num) + n = image_status(array(1)) + n = image_status(coindexed[1]) + n = image_status(image=1) + result_array = image_status(array) + result_array_2d = image_status(array_2d) + + n = image_status(2, home) + n = image_status(2, league(1)) + n = image_status(image=2, team=home) + n = image_status(team=home, image=2) + + if (image_status(1) .eq. stat_failed_image .or. image_status(1) .eq. stat_stopped_image) then + error stop + else if (image_status(1) .eq. 0) then + continue + end if + + !___ non-conforming statements ___ + + !ERROR: 'image=' argument for intrinsic 'image_status' must be a positive value, but is -1 + n = image_status(-1) + + !ERROR: 'image=' argument for intrinsic 'image_status' must be a positive value, but is 0 + n = image_status(0) + + !ERROR: 'image=' argument for intrinsic 'image_status' must be a positive value, but is -4 + n = image_status(constant_negative) + + !ERROR: 'image=' argument for intrinsic 'image_status' must be a positive value, but is 0 + n = image_status(constant_zero) + + !ERROR: 'team=' argument has unacceptable rank 1 + n = image_status(1, team=league) + + !ERROR: Actual argument for 'image=' has bad type 'REAL(4)' + n = image_status(3.4) + + !ERROR: Actual argument for 'image=' has bad type 'LOGICAL(4)' + n = image_status(wrong_arg_type_logical) + + !ERROR: Actual argument for 'image=' has bad type 'REAL(4)' + n = image_status(wrong_arg_type_real) + + !ERROR: Actual argument for 'team=' has bad type 'INTEGER(4)' + n = image_status(1, not_team_type) + + !ERROR: Actual argument for 'team=' has bad type 'INTEGER(4)' + n = image_status(1, 1) + + !ERROR: Actual argument for 'image=' has bad type 'REAL(4)' + n = image_status(image=3.4) + + !ERROR: Actual argument for 'team=' has bad type 'INTEGER(4)' + n = image_status(1, team=1) + + !ERROR: too many actual arguments for intrinsic 'image_status' + n = image_status(1, home, 2) + + !ERROR: repeated keyword argument to intrinsic 'image_status' + n = image_status(image=1, image=2) + + !ERROR: repeated keyword argument to intrinsic 'image_status' + n = image_status(image=1, team=home, team=league(1)) + + !ERROR: unknown keyword argument to intrinsic 'image_status' + n = image_status(images=1) + + !ERROR: unknown keyword argument to intrinsic 'image_status' + n = image_status(1, my_team=home) + + !ERROR: 'image=' argument for intrinsic 'image_status' must contain all positive values + result_array = image_status(image=array_with_negative) + + !ERROR: 'image=' argument for intrinsic 'image_status' must contain all positive values + result_array = image_status(image=[-2, 1]) + + !ERROR: 'image=' argument for intrinsic 'image_status' must contain all positive values + result_array = image_status(image=array_with_zero) + + !ERROR: 'image=' argument for intrinsic 'image_status' must contain all positive values + result_array = image_status(image=[1, 0]) + + !ERROR: No intrinsic or user-defined ASSIGNMENT(=) matches scalar INTEGER(4) and rank 1 array of INTEGER(4) + non_array_result = image_status(image=array) + + !ERROR: No intrinsic or user-defined ASSIGNMENT(=) matches rank 1 array of INTEGER(4) and rank 2 array of INTEGER(4) + wrong_rank_result = image_status(array_2d) + + !ERROR: No intrinsic or user-defined ASSIGNMENT(=) matches operand types CHARACTER(KIND=1) and INTEGER(4) + wrong_result_type = image_status(1) + +end program test_image_status diff --git a/flang/test/Semantics/ishftc.f90 b/flang/test/Semantics/ishftc.f90 new file mode 100644 --- /dev/null +++ b/flang/test/Semantics/ishftc.f90 @@ -0,0 +1,48 @@ +! RUN: %python %S/test_errors.py %s %flang_fc1 +! Check for semantic errors in ishftc() function calls + +program test_ishftc + use iso_fortran_env, only: int8, int16, int32, int64 + implicit none + + integer :: n + integer, allocatable :: array_result(:) + integer, parameter :: const_arr1(2) = [-3,3] + integer, parameter :: const_arr2(2) = [3,0] + integer(kind=8), parameter :: const_arr3(2) = [0,4] + integer(kind=int8), parameter :: const_arr4(2) = [0,4] + integer(kind=int16), parameter :: const_arr5(2) = [0,4] + integer(kind=int32), parameter :: const_arr6(2) = [0,4] + integer(kind=int64), parameter :: const_arr7(2) = [0,4] + + n = ishftc(3, 2, 3) + array_result = ishftc([3,3], [2,2], [3,3]) + + !ERROR: 'size=' argument for intrinsic 'ishftc' must be a positive value, but is -3 + n = ishftc(3, 2, -3) + !ERROR: 'size=' argument for intrinsic 'ishftc' must be a positive value, but is 0 + n = ishftc(3, 2, 0) + !ERROR: The absolute value of the 'shift=' argument for intrinsic 'ishftc' must be less than or equal to the 'size=' argument + n = ishftc(3, 2, 1) + !ERROR: The absolute value of the 'shift=' argument for intrinsic 'ishftc' must be less than or equal to the 'size=' argument + n = ishftc(3, -2, 1) + !ERROR: 'size=' argument for intrinsic 'ishftc' must contain all positive values + array_result = ishftc([3,3], [2,2], [-3,3]) + !ERROR: 'size=' argument for intrinsic 'ishftc' must contain all positive values + array_result = ishftc([3,3], [2,2], [-3,-3]) + !ERROR: 'size=' argument for intrinsic 'ishftc' must contain all positive values + array_result = ishftc([3,3], [-2,-2], const_arr1) + !ERROR: 'size=' argument for intrinsic 'ishftc' must contain all positive values + array_result = ishftc([3,3], [-2,-2], const_arr2) + !ERROR: 'size=' argument for intrinsic 'ishftc' must contain all positive values + array_result = ishftc([3,3], [-2,-2], const_arr3) + !ERROR: 'size=' argument for intrinsic 'ishftc' must contain all positive values + array_result = ishftc([3,3], [-2,-2], const_arr4) + !ERROR: 'size=' argument for intrinsic 'ishftc' must contain all positive values + array_result = ishftc([3,3], [-2,-2], const_arr5) + !ERROR: 'size=' argument for intrinsic 'ishftc' must contain all positive values + array_result = ishftc([3,3], [-2,-2], const_arr6) + !ERROR: 'size=' argument for intrinsic 'ishftc' must contain all positive values + array_result = ishftc([3,3], [-2,-2], const_arr7) + +end program test_ishftc