diff --git a/flang/runtime/derived-api.cpp b/flang/runtime/derived-api.cpp --- a/flang/runtime/derived-api.cpp +++ b/flang/runtime/derived-api.cpp @@ -87,11 +87,22 @@ } 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 --- a/flang/unittests/Runtime/CMakeLists.txt +++ b/flang/unittests/Runtime/CMakeLists.txt @@ -6,6 +6,7 @@ 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 --- /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)); +}