[flang-commits] [flang] 875c7b7 - [flang] Correct folding of EXTENDS_TYPE_OF()

[Peter Klausler via flang-commits]

Author: Peter Klausler
Date: 2022-12-16T13:45:51-08:00
New Revision: 875c7b7d3968165d5ec9354c367837c96d27cf99

URL: https://github.com/llvm/llvm-project/commit/875c7b7d3968165d5ec9354c367837c96d27cf99
DIFF: https://github.com/llvm/llvm-project/commit/875c7b7d3968165d5ec9354c367837c96d27cf99.diff

LOG: [flang] Correct folding of EXTENDS_TYPE_OF()

There was a falsely known case with a polymorphic type.

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

Added: 
    

Modified: 
    flang/docs/Extensions.md
    flang/lib/Evaluate/type.cpp

Removed: 
    


################################################################################
diff  --git a/flang/docs/Extensions.md b/flang/docs/Extensions.md
index a032052d228ab..86ac6ae876e80 100644
--- a/flang/docs/Extensions.md
+++ b/flang/docs/Extensions.md
@@ -522,3 +522,8 @@ end module
   or `BLOCK DATA` subprogram to also be the name of an local entity in its
   scope, with a portability warning, since that global name is not actually
   capable of being "used" in its scope.
+
+## De Facto Standard Features
+
+* `EXTENDS_TYPE_OF()` returns `.TRUE.` if both of its arguments have the
+  same type, a case that is technically implementation-defined.

diff  --git a/flang/lib/Evaluate/type.cpp b/flang/lib/Evaluate/type.cpp
index 5b356aa8377fe..85e4315de1127 100644
--- a/flang/lib/Evaluate/type.cpp
+++ b/flang/lib/Evaluate/type.cpp
@@ -371,9 +371,23 @@ std::optional<bool> DynamicType::SameTypeAs(const DynamicType &that) const {
 std::optional<bool> DynamicType::ExtendsTypeOf(const DynamicType &that) const {
   if (IsUnlimitedPolymorphic() || that.IsUnlimitedPolymorphic()) {
     return std::nullopt; // unknown
-  } else if (!AreCompatibleDerivedTypes(evaluate::GetDerivedTypeSpec(that),
-                 evaluate::GetDerivedTypeSpec(*this), true)) {
-    return false;
+  }
+  const auto *thisDts{evaluate::GetDerivedTypeSpec(*this)};
+  const auto *thatDts{evaluate::GetDerivedTypeSpec(that)};
+  if (!thisDts || !thatDts) {
+    return std::nullopt;
+  } else if (!AreCompatibleDerivedTypes(thatDts, thisDts, true)) {
+    // Note that I check *thisDts, not its parent, so that EXTENDS_TYPE_OF()
+    // is .true. when they are the same type.  This is technically
+    // an implementation-defined case in the standard, but every other
+    // compiler works this way.
+    if (IsPolymorphic() && AreCompatibleDerivedTypes(thisDts, thatDts, true)) {
+      // 'that' is *this or an extension of *this, and so runtime *this
+      // could be an extension of 'that'
+      return std::nullopt;
+    } else {
+      return false;
+    }
   } else if (that.IsPolymorphic()) {
     return std::nullopt; // unknown
   } else {