[flang] Check constraint C711 correctly

An assumed-type actual argument that corresponds to an assumed-rank dummy
argument shall be assumed-shape or assumed-rank.

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

diff --git a/flang/lib/Evaluate/shape.cpp b/flang/lib/Evaluate/shape.cpp
index 21db9a4..bb5e6ea 100644 (file)
--- a/flang/lib/Evaluate/shape.cpp
+++ b/flang/lib/Evaluate/shape.cpp
@@ -654,10 +654,11 @@ auto GetShapeHelper::operator()(const ProcedureRef &call) const -> Result {
   } else if (const auto *intrinsic{call.proc().GetSpecificIntrinsic()}) {
     if (intrinsic->name == "shape" || intrinsic->name == "lbound" ||
         intrinsic->name == "ubound") {
-      // These are the array-valued cases for LBOUND and UBOUND (no DIM=).
-      const auto *expr{call.arguments().front().value().UnwrapExpr()};
-      CHECK(expr);
-      return Shape{MaybeExtentExpr{ExtentExpr{expr->Rank()}}};
+      // For LBOUND/UBOUND, these are the array-valued cases (no DIM=)
+      if (!call.arguments().empty() && call.arguments().front()) {
+        return Shape{
+            MaybeExtentExpr{ExtentExpr{call.arguments().front()->Rank()}}};
+      }
     } else if (intrinsic->name == "all" || intrinsic->name == "any" ||
         intrinsic->name == "count" || intrinsic->name == "iall" ||
         intrinsic->name == "iany" || intrinsic->name == "iparity" ||

diff --git a/flang/lib/Semantics/check-call.cpp b/flang/lib/Semantics/check-call.cpp
index 56c4021..d55efa8 100644 (file)
--- a/flang/lib/Semantics/check-call.cpp
+++ b/flang/lib/Semantics/check-call.cpp
@@ -699,14 +699,13 @@ static void CheckExplicitInterfaceArg(evaluate::ActualArgument &arg,
                 messages.Say(
                     "Assumed-type '%s' may be associated only with an assumed-type %s"_err_en_US,
                     assumed.name(), dummyName);
-              } else {
-                const auto *details{assumed.detailsIf<ObjectEntityDetails>()};
-                if (!(IsAssumedShape(assumed) ||
-                        (details && details->IsAssumedRank()))) {
-                  messages.Say( // C711
-                      "Assumed-type '%s' must be either assumed shape or assumed rank to be associated with assumed-type %s"_err_en_US,
-                      assumed.name(), dummyName);
-                }
+              } else if (object.type.attrs().test(evaluate::characteristics::
+                                 TypeAndShape::Attr::AssumedRank) &&
+                  !IsAssumedShape(assumed) &&
+                  !evaluate::IsAssumedRank(assumed)) {
+                messages.Say( // C711
+                    "Assumed-type '%s' must be either assumed shape or assumed rank to be associated with assumed rank %s"_err_en_US,
+                    assumed.name(), dummyName);
               }
             }
           },

diff --git a/flang/test/Semantics/call15.f90 b/flang/test/Semantics/call15.f90
index 842103b..e91a2ec 100644 (file)
--- a/flang/test/Semantics/call15.f90
+++ b/flang/test/Semantics/call15.f90
@@ -1,5 +1,5 @@
 ! RUN: %python %S/test_errors.py %s %flang_fc1
-! C711 An assumed-type actual argument that corresponds to an assumed-rank 
+! C711 An assumed-type actual argument that corresponds to an assumed-rank
 ! dummy argument shall be assumed-shape or assumed-rank.
 subroutine s(arg1, arg2, arg3)
   type(*), dimension(..) :: arg1 ! assumed rank
@@ -8,7 +8,7 @@ subroutine s(arg1, arg2, arg3)
 
   call inner(arg1) ! OK, assumed rank
   call inner(arg2) ! OK, assumed shape
-  !ERROR: Assumed-type 'arg3' must be either assumed shape or assumed rank to be associated with assumed-type dummy argument 'dummy='
+  !ERROR: Assumed-type 'arg3' must be either assumed shape or assumed rank to be associated with assumed rank dummy argument 'dummy='
   call inner(arg3)
 
     contains