[flang-commits] [flang] 59d38f1 - [flang] Check constraint C711 correctly

[Peter Klausler via flang-commits]

Author: Peter Klausler
Date: 2022-03-01T12:22:17-08:00
New Revision: 59d38f1b56d516f844733fe22294de7c78c8fbf6

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

LOG: [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

Added: 
    

Modified: 
    flang/lib/Evaluate/shape.cpp
    flang/lib/Semantics/check-call.cpp
    flang/test/Semantics/call15.f90

Removed: 
    


################################################################################
diff  --git a/flang/lib/Evaluate/shape.cpp b/flang/lib/Evaluate/shape.cpp
index 21db9a4b82b2c..bb5e6ea4cd376 100644
--- 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 56c4021a21e8f..d55efa84a11b1 100644
--- 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 842103b4aca30..e91a2ec282275 100644
--- 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