From 4052c50122a1f7e64a65e1b391cc37b5cccb2662 Mon Sep 17 00:00:00 2001
From: Peter Klausler <pklausler@nvidia.com>
Date: Tue, 11 Oct 2022 12:45:05 -0700
Subject: [PATCH] [flang] Enforce constraint C911

Diagnose attempts to use an non-polymorphic instance of an
abstract derived type.

Differential Revision: https://reviews.llvm.org/D136902
---
 flang/include/flang/Semantics/expression.h |  2 ++
 flang/lib/Semantics/expression.cpp         | 55 ++++++++++++++++++++----------
 flang/test/Semantics/abstract01.f90        | 31 +++++++++++++++++
 3 files changed, 70 insertions(+), 18 deletions(-)
 create mode 100644 flang/test/Semantics/abstract01.f90

diff --git a/flang/include/flang/Semantics/expression.h b/flang/include/flang/Semantics/expression.h
index 042ffec..0b170cf 100644
--- a/flang/include/flang/Semantics/expression.h
+++ b/flang/include/flang/Semantics/expression.h
@@ -324,6 +324,8 @@ private:
   MaybeExpr CompleteSubscripts(ArrayRef &&);
   MaybeExpr ApplySubscripts(DataRef &&, std::vector<Subscript> &&);
   bool CheckRanks(const DataRef &); // Return false if error exists.
+  bool CheckPolymorphic(const DataRef &); // ditto
+  bool CheckDataRef(const DataRef &); // ditto
   std::optional<Expr<SubscriptInteger>> GetSubstringBound(
       const std::optional<parser::ScalarIntExpr> &);
   MaybeExpr AnalyzeDefinedOp(const parser::Name &, ActualArguments &&);
diff --git a/flang/lib/Semantics/expression.cpp b/flang/lib/Semantics/expression.cpp
index fcf3664..6fa4827 100644
--- a/flang/lib/Semantics/expression.cpp
+++ b/flang/lib/Semantics/expression.cpp
@@ -336,6 +336,30 @@ bool ExpressionAnalyzer::CheckRanks(const DataRef &dataRef) {
       dataRef.u);
 }
 
+// C911 - if the last name in a data-ref has an abstract derived type,
+// it must also be polymorphic.
+bool ExpressionAnalyzer::CheckPolymorphic(const DataRef &dataRef) {
+  if (auto type{DynamicType::From(dataRef.GetLastSymbol())}) {
+    if (type->category() == TypeCategory::Derived && !type->IsPolymorphic()) {
+      const Symbol &typeSymbol{
+          type->GetDerivedTypeSpec().typeSymbol().GetUltimate()};
+      if (typeSymbol.attrs().test(semantics::Attr::ABSTRACT)) {
+        AttachDeclaration(
+            Say("Reference to object with abstract derived type '%s' must be polymorphic"_err_en_US,
+                typeSymbol.name()),
+            typeSymbol);
+        return false;
+      }
+    }
+  }
+  return true;
+}
+
+bool ExpressionAnalyzer::CheckDataRef(const DataRef &dataRef) {
+  // '&' here prevents short-circuiting
+  return CheckRanks(dataRef) & CheckPolymorphic(dataRef);
+}
+
 // Parse tree correction after a substring S(j:k) was misparsed as an
 // array section.  Fortran substrings must have a range, not a
 // single index.
@@ -407,26 +431,21 @@ MaybeExpr ExpressionAnalyzer::Analyze(const parser::Designator &d) {
   }
   // These checks have to be deferred to these "top level" data-refs where
   // we can be sure that there are no following subscripts (yet).
-  if (MaybeExpr result{Analyze(d.u)}) {
-    if (std::optional<DataRef> dataRef{ExtractDataRef(std::move(result))}) {
-      if (!CheckRanks(std::move(*dataRef))) {
-        return std::nullopt;
-      }
-      return Designate(std::move(*dataRef));
-    } else if (std::optional<DataRef> dataRef{
-                   ExtractDataRef(std::move(result), /*intoSubstring=*/true)}) {
-      if (!CheckRanks(std::move(*dataRef))) {
-        return std::nullopt;
-      }
-    } else if (std::optional<DataRef> dataRef{ExtractDataRef(std::move(result),
-                   /*intoSubstring=*/false, /*intoComplexPart=*/true)}) {
-      if (!CheckRanks(std::move(*dataRef))) {
-        return std::nullopt;
+  MaybeExpr result{Analyze(d.u)};
+  if (result) {
+    std::optional<DataRef> dataRef{ExtractDataRef(std::move(result))};
+    if (!dataRef) {
+      dataRef = ExtractDataRef(std::move(result), /*intoSubstring=*/true);
+      if (!dataRef) {
+        dataRef = ExtractDataRef(std::move(result),
+            /*intoSubstring=*/false, /*intoComplexPart=*/true);
       }
     }
-    return result;
+    if (dataRef && !CheckDataRef(*dataRef)) {
+      result.reset();
+    }
   }
-  return std::nullopt;
+  return result;
 }
 
 // A utility subroutine to repackage optional expressions of various levels
@@ -2025,7 +2044,7 @@ auto ExpressionAnalyzer::AnalyzeProcedureComponentRef(
           }
         }
         std::optional<DataRef> dataRef{ExtractDataRef(std::move(*dtExpr))};
-        if (dataRef.has_value() && !CheckRanks(std::move(*dataRef))) {
+        if (dataRef && !CheckDataRef(*dataRef)) {
           return std::nullopt;
         }
         if (const Symbol *
diff --git a/flang/test/Semantics/abstract01.f90 b/flang/test/Semantics/abstract01.f90
new file mode 100644
index 0000000..42db4b4
--- /dev/null
+++ b/flang/test/Semantics/abstract01.f90
@@ -0,0 +1,31 @@
+! RUN: %python %S/test_errors.py %s %flang_fc1
+! C911 - abstract derived type can be used only when polymorphic
+program test
+  type, abstract :: abstract
+    integer :: j
+  end type
+  type, extends(abstract) :: concrete
+    integer :: k
+    class(concrete), allocatable :: a(:)
+  end type
+  type(concrete) :: x(2)
+  call sub1(x(1)) ! ok
+  call sub2(x) ! ok
+  call sub1(x(1)%a(1)) ! ok
+  call sub2(x(1)%a) ! ok
+  !ERROR: Reference to object with abstract derived type 'abstract' must be polymorphic
+  call sub1(x(1)%abstract) ! bad
+  !ERROR: Reference to object with abstract derived type 'abstract' must be polymorphic
+  call sub2(x%abstract) ! bad
+  !ERROR: Reference to object with abstract derived type 'abstract' must be polymorphic
+  call sub1(x(1)%a(1)%abstract) ! bad
+  !ERROR: Reference to object with abstract derived type 'abstract' must be polymorphic
+  call sub2(x(1)%a%abstract) ! bad
+ contains
+  subroutine sub1(d)
+    class(abstract) d
+  end subroutine
+  subroutine sub2(d)
+    class(abstract) d(:)
+  end subroutine
+end
-- 
2.7.4