[flang-commits] [flang] 173e54c - [flang] Align same_type_as result to other compilers

[Valentin Clement via flang-commits]

Author: Valentin Clement
Date: 2023-03-08T09:51:23+01:00
New Revision: 173e54c3677420e5774a120a4bc4208093bd5cc8

URL: https://github.com/llvm/llvm-project/commit/173e54c3677420e5774a120a4bc4208093bd5cc8
DIFF: https://github.com/llvm/llvm-project/commit/173e54c3677420e5774a120a4bc4208093bd5cc8.diff

LOG: [flang] Align same_type_as result to other compilers

Unallocated unlimited polymorphic entities do not have a dynamic type set
and do not have declared type. The standard notes that the result is
processor dependent when one of the arguments of same_type_as is in this
case. Align the result to other compiler (gfortran, nvfortran).

Reviewed By: jeanPerier, PeteSteinfeld

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

Added: 
    flang/unittests/Runtime/Derived.cpp

Modified: 
    flang/runtime/derived-api.cpp
    flang/unittests/Runtime/CMakeLists.txt

Removed: 
    


################################################################################
diff  --git a/flang/runtime/derived-api.cpp b/flang/runtime/derived-api.cpp
index 806a76ac95753..4cceace94c6b0 100644
--- a/flang/runtime/derived-api.cpp
+++ b/flang/runtime/derived-api.cpp
@@ -87,11 +87,22 @@ static const typeInfo::DerivedType *GetDerivedType(const Descriptor &desc) {
 }
 
 bool RTNAME(SameTypeAs)(const Descriptor &a, const Descriptor &b) {
+  // Unlimited polymorphic with intrinsic dynamic type.
+  if (a.raw().type != CFI_type_struct && a.raw().type != CFI_type_other &&
+      b.raw().type != CFI_type_struct && b.raw().type != CFI_type_other)
+    return a.raw().type == b.raw().type;
+
   const typeInfo::DerivedType *derivedTypeA{GetDerivedType(a)};
   const typeInfo::DerivedType *derivedTypeB{GetDerivedType(b)};
-  if (derivedTypeA == nullptr || derivedTypeB == nullptr) {
-    return false;
+
+  // One of the descriptor is an unallocated unlimited polymorphic descriptor.
+  // This is processor depedent according to the standard. Align the result
+  // with other compilers.
+  if ((!a.IsAllocated() && derivedTypeA == nullptr) ||
+      (!b.IsAllocated() && derivedTypeB == nullptr)) {
+    return true;
   }
+
   // Exact match of derived type.
   if (derivedTypeA == derivedTypeB) {
     return true;

diff  --git a/flang/unittests/Runtime/CMakeLists.txt b/flang/unittests/Runtime/CMakeLists.txt
index 40eff5d7d19f8..c4eae6f0f25c2 100644
--- a/flang/unittests/Runtime/CMakeLists.txt
+++ b/flang/unittests/Runtime/CMakeLists.txt
@@ -6,6 +6,7 @@ add_flang_unittest(FlangRuntimeTests
   CommandTest.cpp
   Complex.cpp
   CrashHandlerFixture.cpp
+  Derived.cpp
   ExternalIOTest.cpp
   Format.cpp
   Inquiry.cpp

diff  --git a/flang/unittests/Runtime/Derived.cpp b/flang/unittests/Runtime/Derived.cpp
new file mode 100644
index 0000000000000..7e54367780204
--- /dev/null
+++ b/flang/unittests/Runtime/Derived.cpp
@@ -0,0 +1,44 @@
+//===-- flang/unittests/Runtime/Pointer.cpp--------- -------------*- C++-*-===//
+//
+// Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
+// See https://llvm.org/LICENSE.txt for license information.
+// SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception
+//
+//===----------------------------------------------------------------------===//
+
+#include "gtest/gtest.h"
+#include "tools.h"
+#include "flang/Runtime/derived-api.h"
+#include "flang/Runtime/descriptor.h"
+
+using namespace Fortran::runtime;
+
+TEST(Derived, SameTypeAs) {
+  // INTEGER, POINTER :: i1
+  auto i1{
+      Descriptor::Create(TypeCode{Fortran::common::TypeCategory::Integer, 4}, 4,
+          nullptr, 0, nullptr, CFI_attribute_pointer)};
+  EXPECT_TRUE(RTNAME(SameTypeAs)(*i1, *i1));
+
+  auto r1{Descriptor::Create(TypeCode{Fortran::common::TypeCategory::Real, 4},
+      4, nullptr, 0, nullptr, CFI_attribute_pointer)};
+  EXPECT_FALSE(RTNAME(SameTypeAs)(*i1, *r1));
+
+  // CLASS(*), ALLOCATABLE :: p1
+  auto p1{Descriptor::Create(TypeCode{Fortran::common::TypeCategory::Real, 4},
+      4, nullptr, 0, nullptr, CFI_attribute_allocatable)};
+  p1->raw().elem_len = 0;
+  p1->raw().type = CFI_type_other;
+
+  EXPECT_TRUE(RTNAME(SameTypeAs)(*i1, *p1));
+  EXPECT_TRUE(RTNAME(SameTypeAs)(*p1, *i1));
+  EXPECT_TRUE(RTNAME(SameTypeAs)(*r1, *p1));
+
+  // CLASS(*), ALLOCATABLE :: p2
+  auto p2{Descriptor::Create(TypeCode{Fortran::common::TypeCategory::Real, 4},
+      4, nullptr, 0, nullptr, CFI_attribute_allocatable)};
+  p2->raw().elem_len = 0;
+  p2->raw().type = CFI_type_other;
+
+  EXPECT_TRUE(RTNAME(SameTypeAs)(*p1, *p2));
+}