[PATCH] D83793: [flang] Fix a crash when an array constructor contains an unlimited polymorphic value

[Pete Steinfeld via Phabricator via llvm-commits]

PeteSteinfeld created this revision.
PeteSteinfeld added reviewers: klausler, tskeith.
Herald added a reviewer: DavidTruby.
Herald added a project: LLVM.
Herald added a subscriber: llvm-commits.

C7113 States that "An ac-value shall not be unlimited polymorphic."  We failed
to detect this situation which resulted in a crash when trying to get the
underlying derived type specification of the unlimited polymorphic value.

I added code to avoid the crash, code to emit an error message, and a test.


Repository:
  rG LLVM Github Monorepo

https://reviews.llvm.org/D83793

Files:
  flang/lib/Semantics/expression.cpp
  flang/test/Semantics/resolve70.f90


Index: flang/test/Semantics/resolve70.f90
===================================================================
--- flang/test/Semantics/resolve70.f90
+++ flang/test/Semantics/resolve70.f90
@@ -57,3 +57,19 @@
   !ERROR: Non-extensible derived type 'inextensible' may not be used with CLASS keyword
   class(inextensible), allocatable :: x
 end subroutine s1
+
+subroutine s2()
+  type t
+    integer i
+  end type t
+  type, extends(t) :: t2
+    real x
+  end type t2
+contains
+  function f1(dummy)
+    class(*) dummy
+    type(t) f1(1)
+    !ERROR: Cannot have an unlimited polymorphic value in an array constructor
+    f1 = [ (dummy) ]
+  end function f1
+end subroutine s2
Index: flang/lib/Semantics/expression.cpp
===================================================================
--- flang/lib/Semantics/expression.cpp
+++ flang/lib/Semantics/expression.cpp
@@ -1159,8 +1159,12 @@
   template <typename T> Result Test() {
     if (type_ && type_->category() == T::category) {
       if constexpr (T::category == TypeCategory::Derived) {
-        return AsMaybeExpr(ArrayConstructor<T>{
-            type_->GetDerivedTypeSpec(), MakeSpecific<T>(std::move(values_))});
+        if (type_->IsUnlimitedPolymorphic()) {
+          return std::nullopt;
+        } else {
+          return AsMaybeExpr(ArrayConstructor<T>{type_->GetDerivedTypeSpec(),
+              MakeSpecific<T>(std::move(values_))});
+        }
       } else if (type_->kind() == T::kind) {
         if constexpr (T::category == TypeCategory::Character) {
           if (auto len{type_->LEN()}) {
@@ -1295,6 +1299,13 @@
             auto restorer{exprAnalyzer_.GetContextualMessages().SetLocation(
                 expr.value().source)};
             if (MaybeExpr v{exprAnalyzer_.Analyze(expr.value())}) {
+              if (auto exprType{v->GetType()}) {
+                if (exprType->IsUnlimitedPolymorphic()) {
+                  exprAnalyzer_.Say(
+                      "Cannot have an unlimited polymorphic value in an "
+                      "array constructor"_err_en_US);
+                }
+              }
               Push(std::move(*v));
             }
           },


-------------- next part --------------
A non-text attachment was scrubbed...
Name: D83793.277891.patch
Type: text/x-patch
Size: 2157 bytes
Desc: not available
URL: <http://lists.llvm.org/pipermail/llvm-commits/attachments/20200714/85ff4288/attachment.bin>