[flang] Enforce constraint C911

[klausler]

Summary

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

[PeteSteinfeld]

Builds and tests correctly and looks good.

flang/include/flang/Semantics/expression.h

std::optional<Subscript> AnalyzeSectionSubscript(
       const parser::SectionSubscript &);
   std::vector<Subscript> AnalyzeSectionSubscripts(
       const std::list<parser::SectionSubscript> &);
   std::optional<Component> CreateComponent(
       DataRef &&, const Symbol &, const semantics::Scope &);
   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 &&);
   MaybeExpr FixMisparsedSubstring(const parser::Designator &);
 
   struct CalleeAndArguments {
     // A non-component function reference may constitute a misparsed
     // structure constructor, in which case its derived type's Symbol

flang/lib/Semantics/expression.cpp

return common::visit(
             return true;
           },
           [](const SymbolRef &) { return true; },
           [](const CoarrayRef &) { return true; },
       },
       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.
 static std::optional<parser::Substring> FixMisparsedSubstringDataRef(
     parser::DataRef &dataRef) {
   if (auto *ae{
           std::get_if<common::Indirection<parser::ArrayElement>>(&dataRef.u)}) {
     // ...%a(j:k) and "a" is a character scalar

 
 MaybeExpr ExpressionAnalyzer::Analyze(const parser::Designator &d) {
   auto restorer{GetContextualMessages().SetLocation(d.source)};
   if (auto substringInquiry{FixMisparsedSubstring(d)}) {
     return substringInquiry;
   }
   // 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;
+  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 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;
-      }
-    }
-    return result;
-  }
-  return std::nullopt;
-}
+    if (dataRef && !CheckDataRef(*dataRef)) {
+      result.reset();
 
 // A utility subroutine to repackage optional expressions of various levels
 // of type specificity as fully general MaybeExpr values.
 template <typename A> common::IfNoLvalue<MaybeExpr, A> AsMaybeExpr(A &&x) {
   return AsGenericExpr(std::move(x));
 }
 template <typename A> MaybeExpr AsMaybeExpr(std::optional<A> &&x) {
   if (x) {
if (const Symbol * sym{sc.component.symbol}) {
             // re-resolve the name to the specific binding
             sc.component.symbol = const_cast<Symbol *>(sym);
           } else {
             EmitGenericResolutionError(*sc.component.symbol, pair.second);
             return std::nullopt;
           }
         }
         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 *
             resolution{GetBindingResolution(dtExpr->GetType(), *sym)}) {
           AddPassArg(arguments, std::move(*dtExpr), *sym, false);
           return CalleeAndArguments{
               ProcedureDesignator{*resolution}, std::move(arguments)};
         } else if (dataRef.has_value()) {

flang/test/Semantics/abstract01.f90

+! 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