Index: flang/lib/Evaluate/intrinsics.cpp =================================================================== --- flang/lib/Evaluate/intrinsics.cpp +++ 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 @@ -2339,6 +2341,37 @@ } } else if (name == "associated") { return CheckAssociated(call, context); + } else if (name == "image_status") { + if (const auto &arg{call.arguments[0]}) { + if (auto val{ToInt64(arg->UnwrapExpr())}) { + if (val <= 0) { + ok = false; + context.messages().Say(arg->sourceLocation(), + "'image=' argument for intrinsic '%s' must be a positive value"_err_en_US, + name); + } + } + } + } else if (name == "ishftc") { + if (const auto &size_arg{call.arguments[2]}) { + if (auto size_val{ToInt64(size_arg->UnwrapExpr())}) { + if (size_val <= 0) { + ok = false; + context.messages().Say(size_arg->sourceLocation(), + "'size=' argument for intrinsic '%s' must be a positive value"_err_en_US, + name); + } else if (const auto &shift_arg{call.arguments[1]}) { + if (auto shift_val{ToInt64(shift_arg->UnwrapExpr())}) { + if (std::abs(shift_val.value()) > size_val) { + ok = false; + context.messages().Say(shift_arg->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 = Index: flang/test/Semantics/image_status.f90 =================================================================== --- /dev/null +++ flang/test/Semantics/image_status.f90 @@ -0,0 +1,98 @@ +! 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 :: constant_integer = 2 + 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 + n = image_status(-1) + + !ERROR: 'image=' argument for intrinsic 'image_status' must be a positive value + n = image_status(0) + + !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) + + ! keyword argument with incorrect type + !ERROR: Actual argument for 'image=' has bad type 'REAL(4)' + n = image_status(image=3.4) + + ! keyword argument with incorrect type + !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)) + + ! incorrect keyword argument name but valid type + !ERROR: unknown keyword argument to intrinsic 'image_status' + n = image_status(images=1) + + ! incorrect keyword argument name but valid type + !ERROR: unknown keyword argument to intrinsic 'image_status' + n = image_status(1, my_team=home) + + !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 Index: flang/test/Semantics/ishftc.f90 =================================================================== --- /dev/null +++ flang/test/Semantics/ishftc.f90 @@ -0,0 +1,28 @@ +! RUN: %python %S/test_errors.py %s %flang_fc1 +! Check for semantic errors in ishftc() function calls + +program test_ishftc + implicit none + + integer :: n + integer, allocatable :: array_result(:) + + 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 + n = ishftc(3, 2, -3) + !ERROR: 'size=' argument for intrinsic 'ishftc' must be a positive value + 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) + + !uncaught errors + array_result = ishftc([3,3], [2,2], [-3,3]) + array_result = ishftc([3,3], [2,2], [-3,-3]) + array_result = ishftc([3,3], [2,2], [1,1]) + array_result = ishftc([3,3], [-2,-2], [1,1]) + +end program test_ishftc