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 @@ -1102,9 +1102,7 @@ {"put", DefaultInt, Rank::vector, Optionality::optional}, {"get", DefaultInt, Rank::vector, Optionality::optional, common::Intent::Out}}, - {}, Rank::elemental, - IntrinsicClass::impureSubroutine}, // TODO: at most one argument can be - // present + {}, Rank::elemental, IntrinsicClass::impureSubroutine}, {"system_clock", {{"count", AnyInt, Rank::scalar, Optionality::optional, common::Intent::Out}, @@ -2167,15 +2165,18 @@ FoldingContext &context, const IntrinsicProcTable &intrinsics) const { // All special cases handled here before the table probes below must - // also be recognized as special names in IsIntrinsic(). + // also be recognized as special names in IsIntrinsicSubroutine(). if (call.isSubroutineCall) { if (call.name == "__builtin_c_f_pointer") { return HandleC_F_Pointer(arguments, context); + } else if (call.name == "random_seed") { + if (arguments.size() != 0 && arguments.size() != 1) { + context.messages().Say( + "RANDOM_SEED must have either 1 or no arguments"_err_en_US); + } } - } else { - if (call.name == "null") { - return HandleNull(arguments, context); - } + } else if (call.name == "null") { + return HandleNull(arguments, context); } if (call.isSubroutineCall) { diff --git a/flang/test/Semantics/random-seed.f90 b/flang/test/Semantics/random-seed.f90 new file mode 100644 --- /dev/null +++ b/flang/test/Semantics/random-seed.f90 @@ -0,0 +1,29 @@ +! RUN: %S/test_errors.sh %s %t %flang_fc1 +! REQUIRES: shell +! NULL() intrinsic function error tests +program test_random_seed + integer :: size_arg + integer, parameter :: size_arg_const = 343 + integer, dimension(3), parameter :: put_arg = [9,8,7] + integer :: get_arg_scalar + integer, dimension(3) :: get_arg + integer, dimension(3),parameter :: get_arg_const = [8,7,6] + call random_seed() + call random_seed(size_arg) + call random_seed(size=size_arg) + !ERROR: Actual argument associated with INTENT(OUT) dummy argument 'size=' must be definable + call random_seed(size_arg_const) ! error, size arg must be definable + !ERROR: 'size=' argument has unacceptable rank 1 + call random_seed([1, 2, 3, 4]) ! Error, must be a scalar + call random_seed(put = [1, 2, 3, 4]) + call random_seed(put = put_arg) + !ERROR: 'size=' argument has unacceptable rank 1 + call random_seed(get_arg) ! Error, must be a scalar + call random_seed(get=get_arg) + !ERROR: 'get=' argument has unacceptable rank 0 + call random_seed(get=get_arg_scalar) ! Error, GET arg must be of rank 1 + !ERROR: Actual argument associated with INTENT(OUT) dummy argument 'get=' must be definable + call random_seed(get=get_arg_const) ! Error, GET arg must be definable + !ERROR: RANDOM_SEED must have either 1 or no arguments + call random_seed(size_arg, get_arg) ! Error, only 0 or 1 argument +end program