[flang-commits] [flang] bda1f29 - [flang] Add semantic check for the RANDOM_SEED intrinsic

[Peter Steinfeld via flang-commits]

Author: Peter Steinfeld
Date: 2021-06-15T21:27:54-07:00
New Revision: bda1f2936e379e418156444d8d9f3fba2c60687c

URL: https://github.com/llvm/llvm-project/commit/bda1f2936e379e418156444d8d9f3fba2c60687c
DIFF: https://github.com/llvm/llvm-project/commit/bda1f2936e379e418156444d8d9f3fba2c60687c.diff

LOG: [flang] Add semantic check for the RANDOM_SEED intrinsic

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

Differential Revision: https://reviews.llvm.org/D104318

Added: 
    flang/test/Semantics/random-seed.f90

Modified: 
    flang/lib/Evaluate/intrinsics.cpp

Removed: 
    


################################################################################
diff  --git a/flang/lib/Evaluate/intrinsics.cpp b/flang/lib/Evaluate/intrinsics.cpp
index 962ca68e22319..a63f845c03e0a 100644
--- a/flang/lib/Evaluate/intrinsics.cpp
+++ b/flang/lib/Evaluate/intrinsics.cpp
@@ -1102,9 +1102,7 @@ static const IntrinsicInterface intrinsicSubroutine[]{
             {"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 @@ std::optional<SpecificCall> IntrinsicProcTable::Implementation::Probe(
     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
index 0000000000000..defc0afda5449
--- /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