[flang] Extend assumed-size array checking in intrinsic functions

[klausler]

The array argument of a reference to the intrinsic functions SHAPE can't be assumed-size; and for SIZE and UBOUND, it can be assumed-size only if DIM= is present. The checks for thes restrictions don't allow for host association, or for associate entities (ASSOCIATE, SELECT TYPE) that are variables.

Fixes #138926.

[llvmbot]

@llvm/pr-subscribers-flang-semantics

Author: Peter Klausler (klausler)

Changes

The array argument of a reference to the intrinsic functions SHAPE can't be assumed-size; and for SIZE and UBOUND, it can be assumed-size only if DIM= is present. The checks for thes restrictions don't allow for host association, or for associate entities (ASSOCIATE, SELECT TYPE) that are variables.

Fixes #138926.

---

Full diff: https://github.com/llvm/llvm-project/pull/139339.diff

2 Files Affected:

• (modified) flang/lib/Evaluate/intrinsics.cpp (+6-4)
• (modified) flang/test/Semantics/misc-intrinsics.f90 (+33-2)

diff --git a/flang/lib/Evaluate/intrinsics.cpp b/flang/lib/Evaluate/intrinsics.cpp
index 709f2e6c85bb2..389d8e6c57763 100644
--- a/flang/lib/Evaluate/intrinsics.cpp
+++ b/flang/lib/Evaluate/intrinsics.cpp
@@ -2340,7 +2340,7 @@ std::optional<SpecificCall> IntrinsicInterface::Match(
         if (!knownArg) {
           knownArg = arg;
         }
-        if (!dimArg && rank > 0 &&
+        if (rank > 0 &&
             (std::strcmp(name, "shape") == 0 ||
                 std::strcmp(name, "size") == 0 ||
                 std::strcmp(name, "ubound") == 0)) {
@@ -2351,16 +2351,18 @@ std::optional<SpecificCall> IntrinsicInterface::Match(
           // over this one, as this error is caught by the second entry
           // for UBOUND.)
           if (auto named{ExtractNamedEntity(*arg)}) {
-            if (semantics::IsAssumedSizeArray(named->GetLastSymbol())) {
+            if (semantics::IsAssumedSizeArray(ResolveAssociations(
+                    named->GetLastSymbol().GetUltimate()))) {
               if (strcmp(name, "shape") == 0) {
                 messages.Say(arg->sourceLocation(),
                     "The 'source=' argument to the intrinsic function 'shape' may not be assumed-size"_err_en_US);
-              } else {
+                return std::nullopt;
+              } else if (!dimArg) {
                 messages.Say(arg->sourceLocation(),
                     "A dim= argument is required for '%s' when the array is assumed-size"_err_en_US,
                     name);
+                return std::nullopt;
               }
-              return std::nullopt;
             }
           }
         }
diff --git a/flang/test/Semantics/misc-intrinsics.f90 b/flang/test/Semantics/misc-intrinsics.f90
index 14dcdb05ac6c6..a7895f7b7f16f 100644
--- a/flang/test/Semantics/misc-intrinsics.f90
+++ b/flang/test/Semantics/misc-intrinsics.f90
@@ -3,17 +3,37 @@
 program test_size
   real :: scalar
   real, dimension(5, 5) :: array
-  call test(array, array)
+  call test(array, array, array)
  contains
-  subroutine test(arg, assumedRank)
+  subroutine test(arg, assumedRank, poly)
     real, dimension(5, *) :: arg
     real, dimension(..) :: assumedRank
+    class(*) :: poly(5, *)
     !ERROR: A dim= argument is required for 'size' when the array is assumed-size
     print *, size(arg)
+    print *, size(arg, dim=1) ! ok
+    select type (poly)
+     type is (real)
+      !ERROR: A dim= argument is required for 'size' when the array is assumed-size
+      print *, size(poly)
+      print *, size(poly, dim=1) ! ok
+    end select
     !ERROR: A dim= argument is required for 'ubound' when the array is assumed-size
     print *, ubound(arg)
+    print *, ubound(arg, dim=1) ! ok
+    select type (poly)
+     type is (real)
+      !ERROR: A dim= argument is required for 'ubound' when the array is assumed-size
+      print *, ubound(poly)
+      print *, ubound(poly, dim=1) ! ok
+    end select
     !ERROR: The 'source=' argument to the intrinsic function 'shape' may not be assumed-size
     print *, shape(arg)
+    select type (poly)
+     type is (real)
+      !ERROR: The 'source=' argument to the intrinsic function 'shape' may not be assumed-size
+      print *, shape(poly)
+    end select
     !ERROR: The 'harvest=' argument to the intrinsic procedure 'random_number' may not be assumed-size
     call random_number(arg)
     !ERROR: 'array=' argument has unacceptable rank 0
@@ -85,5 +105,16 @@ subroutine test(arg, assumedRank)
       print *, lbound(assumedRank, dim=2)
       print *, ubound(assumedRank, dim=2)
     end select
+   contains
+    subroutine inner
+      !ERROR: A dim= argument is required for 'size' when the array is assumed-size
+      print *, size(arg)
+      print *, size(arg, dim=1) ! ok
+      !ERROR: A dim= argument is required for 'ubound' when the array is assumed-size
+      print *, ubound(arg)
+      print *, ubound(arg, dim=1) ! ok
+      !ERROR: The 'source=' argument to the intrinsic function 'shape' may not be assumed-size
+      print *, shape(arg)
+    end
   end subroutine
 end