[PATCH] D104318: [flang] Add semantic check for the RANDOM_SEED intrinsic

[Pete Steinfeld via Phabricator via llvm-commits]

This revision was landed with ongoing or failed builds.
This revision was automatically updated to reflect the committed changes.
Closed by commit rGbda1f2936e37: [flang] Add semantic check for the RANDOM_SEED intrinsic (authored by PeteSteinfeld).

Repository:
  rG LLVM Github Monorepo

CHANGES SINCE LAST ACTION
  https://reviews.llvm.org/D104318/new/

https://reviews.llvm.org/D104318

Files:
  flang/lib/Evaluate/intrinsics.cpp
  flang/test/Semantics/random-seed.f90


Index: flang/test/Semantics/random-seed.f90
===================================================================
--- /dev/null
+++ 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
Index: flang/lib/Evaluate/intrinsics.cpp
===================================================================
--- flang/lib/Evaluate/intrinsics.cpp
+++ 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) {


-------------- next part --------------
A non-text attachment was scrubbed...
Name: D104318.352331.patch
Type: text/x-patch
Size: 3211 bytes
Desc: not available
URL: <http://lists.llvm.org/pipermail/llvm-commits/attachments/20210616/1b5a5d76/attachment.bin>