[flang] Add semantic check for the RANDOM_SEED intrinsic

[PeteSteinfeld]

Summary

I added the only check that wasn't already tested along with tests for
many valid and invalid arguments.

[klausler]

Thanks!

flang/lib/Evaluate/intrinsics.cpp

static const IntrinsicInterface intrinsicSubroutine[]{
             common::Intent::Out}},
         {}, Rank::elemental, IntrinsicClass::impureSubroutine},
     {"random_seed",
         {{"size", DefaultInt, Rank::scalar, Optionality::optional,
              common::Intent::Out},
             {"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},
             {"count_rate", AnyIntOrReal, Rank::scalar, Optionality::optional,
                 common::Intent::Out},
             {"count_max", AnyInt, Rank::scalar, Optionality::optional,
                 common::Intent::Out}},
         {}, Rank::elemental, IntrinsicClass::impureSubroutine},

 
 // Probe the configured intrinsic procedure pattern tables in search of a
 // match for a given procedure reference.
 std::optional<SpecificCall> IntrinsicProcTable::Implementation::Probe(
     const CallCharacteristics &call, ActualArguments &arguments,
     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) {
     auto subrRange{subroutines_.equal_range(call.name)};
     for (auto iter{subrRange.first}; iter != subrRange.second; ++iter) {
       if (auto specificCall{
               iter->second->Match(call, defaults_, arguments, context)}) {
         return specificCall;

flang/test/Semantics/random-seed.f90

+! 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