[flang] Align same_type_as result to other compilers

[clementval]

Summary

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).

[jeanPerier]

flang/runtime/derived-api.cpp

97–103

Wouldn't this be hit if both A and B are allocated but A or B is an unlimited polymorphic allocated to an intrinsic type? (I do not see where the "unallocated" aspect is tested).

[PeteSteinfeld]

All builds and tests correctly and looks good.

flang/runtime/derived-api.cpp

97

"the descriptor" should be "read descriptors".

[clementval]

flang/runtime/derived-api.cpp

97–103

Yes. I'll add a check at the beginning for non derived type descriptor.

[clementval]

Update test

[jeanPerier]

LGTM

flang/runtime/derived-api.cpp

if (const DescriptorAddendum * addendum{desc.Addendum()}) {
     if (const auto *derived{addendum->derivedType()}) {
       return derived;
     }
   }
   return nullptr;
 }
 
 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;
   }
   // Otherwise compare with the name. Note 16.29 kind type parameters are not
   // considered in the test.
   return CompareDerivedTypeNames(derivedTypeA->name(), derivedTypeB->name());
 }

flang/unittests/Runtime/CMakeLists.txt

 add_flang_unittest(FlangRuntimeTests
   Allocatable.cpp
   ArrayConstructor.cpp
   BufferTest.cpp
   CharacterTest.cpp
   CommandTest.cpp
   Complex.cpp
   CrashHandlerFixture.cpp
+  Derived.cpp
   ExternalIOTest.cpp
   Format.cpp
   Inquiry.cpp
   ListInputTest.cpp
   Matmul.cpp
   MiscIntrinsic.cpp
   Namelist.cpp
   Numeric.cpp

flang/unittests/Runtime/Derived.cpp

+//===-- 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));
+}