From f783c9bbbe576ad580aaaf6841ce8f3646cd0824 Mon Sep 17 00:00:00 2001 From: Peixin Qiao Date: Wed, 1 Feb 2023 21:09:02 +0800 Subject: [PATCH] [flang] Support allocate array from scalar source in runtime As Fortran 2018 9.7.1.2(7), the value of each element of allocate object becomes the value of source when the allocate object is array and the source is scalar. Fix #60090. Reviewed By: PeteSteinfeld Differential Revision: https://reviews.llvm.org/D142112 --- flang/lib/Lower/Allocatable.cpp | 2 -- flang/runtime/allocatable.cpp | 3 +-- flang/runtime/assign.cpp | 39 +++++++++++++++++++++++++++++++-- flang/runtime/assign.h | 17 +++++--------- flang/runtime/pointer.cpp | 3 +-- flang/unittests/Runtime/Allocatable.cpp | 20 +++++++++++++++++ flang/unittests/Runtime/Pointer.cpp | 20 +++++++++++++++++ 7 files changed, 84 insertions(+), 20 deletions(-) diff --git a/flang/lib/Lower/Allocatable.cpp b/flang/lib/Lower/Allocatable.cpp index f724d96..9b09061 100644 --- a/flang/lib/Lower/Allocatable.cpp +++ b/flang/lib/Lower/Allocatable.cpp @@ -559,8 +559,6 @@ private: genAllocateObjectInit(box); if (alloc.hasCoarraySpec()) TODO(loc, "coarray allocation"); - if (alloc.getShapeSpecs().size() > 0 && sourceExv.rank() == 0) - TODO(loc, "allocate array object with scalar SOURCE specifier"); // Set length of the allocate object if it has. Otherwise, get the length // from source for the deferred length parameter. if (lenParams.empty() && box.isCharacter() && diff --git a/flang/runtime/allocatable.cpp b/flang/runtime/allocatable.cpp index 3ec9bda..60e1073 100644 --- a/flang/runtime/allocatable.cpp +++ b/flang/runtime/allocatable.cpp @@ -127,8 +127,7 @@ int RTNAME(AllocatableAllocateSource)(Descriptor &alloc, alloc, hasStat, errMsg, sourceFile, sourceLine)}; if (stat == StatOk) { Terminator terminator{sourceFile, sourceLine}; - // 9.7.1.2(7) - Assign(alloc, source, terminator, /*skipRealloc=*/true); + DoFromSourceAssign(alloc, source, terminator); } return stat; } diff --git a/flang/runtime/assign.cpp b/flang/runtime/assign.cpp index 63ec732..741049a 100644 --- a/flang/runtime/assign.cpp +++ b/flang/runtime/assign.cpp @@ -60,8 +60,15 @@ static void DoElementalDefinedAssignment(const Descriptor &to, } } -void Assign(Descriptor &to, const Descriptor &from, Terminator &terminator, - bool skipRealloc) { +// Assigns one object to another via intrinsic assignment (F'2018 10.2.1.3) or +// type-bound (only!) defined assignment (10.2.1.4), as appropriate. Performs +// finalization, scalar expansion, & allocatable (re)allocation as needed. +// Does not perform intrinsic assignment implicit type conversion. Both +// descriptors must be initialized. Recurses as needed to handle components. +// Do not perform allocatable reallocation if \p skipRealloc is true, which is +// used for allocate statement with source specifier. +static void Assign(Descriptor &to, const Descriptor &from, + Terminator &terminator, bool skipRealloc = false) { DescriptorAddendum *toAddendum{to.Addendum()}; const typeInfo::DerivedType *toDerived{ toAddendum ? toAddendum->derivedType() : nullptr}; @@ -276,6 +283,34 @@ void Assign(Descriptor &to, const Descriptor &from, Terminator &terminator, } } +void DoFromSourceAssign( + Descriptor &alloc, const Descriptor &source, Terminator &terminator) { + if (alloc.rank() > 0 && source.rank() == 0) { + // The value of each element of allocate object becomes the value of source. + DescriptorAddendum *allocAddendum{alloc.Addendum()}; + const typeInfo::DerivedType *allocDerived{ + allocAddendum ? allocAddendum->derivedType() : nullptr}; + SubscriptValue allocAt[maxRank]; + alloc.GetLowerBounds(allocAt); + if (allocDerived) { + for (std::size_t n{alloc.Elements()}; n-- > 0; + alloc.IncrementSubscripts(allocAt)) { + Descriptor allocElement{*Descriptor::Create(*allocDerived, + reinterpret_cast(alloc.Element(allocAt)), 0)}; + Assign(allocElement, source, terminator, /*skipRealloc=*/true); + } + } else { // intrinsic type + for (std::size_t n{alloc.Elements()}; n-- > 0; + alloc.IncrementSubscripts(allocAt)) { + std::memmove(alloc.Element(allocAt), source.raw().base_addr, + alloc.ElementBytes()); + } + } + } else { + Assign(alloc, source, terminator, /*skipRealloc=*/true); + } +} + extern "C" { void RTNAME(Assign)(Descriptor &to, const Descriptor &from, const char *sourceFile, int sourceLine) { diff --git a/flang/runtime/assign.h b/flang/runtime/assign.h index 57dd9f3..6b7f442 100644 --- a/flang/runtime/assign.h +++ b/flang/runtime/assign.h @@ -6,9 +6,6 @@ // //===----------------------------------------------------------------------===// -// Internal APIs for data assignment (both intrinsic assignment and TBP defined -// generic ASSIGNMENT(=)). - #ifndef FORTRAN_RUNTIME_ASSIGN_INTERNAL_H_ #define FORTRAN_RUNTIME_ASSIGN_INTERNAL_H_ @@ -16,15 +13,11 @@ namespace Fortran::runtime { class Descriptor; class Terminator; -// Assigns one object to another via intrinsic assignment (F'2018 10.2.1.3) or -// type-bound (only!) defined assignment (10.2.1.4), as appropriate. Performs -// finalization, scalar expansion, & allocatable (re)allocation as needed. -// Does not perform intrinsic assignment implicit type conversion. Both -// descriptors must be initialized. Recurses as needed to handle components. -// Do not perform allocatable reallocation if \p skipRealloc is true, which is -// used for allocate statement with source specifier. -void Assign( - Descriptor &, const Descriptor &, Terminator &, bool skipRealloc = false); +// Assign one object to another via allocate statement from source specifier. +// Note that if allocate object and source expression have the same rank, the +// value of the allocate object becomes the value provided; otherwise the value +// of each element of allocate object becomes the value provided (9.7.1.2(7)). +void DoFromSourceAssign(Descriptor &, const Descriptor &, Terminator &); } // namespace Fortran::runtime #endif // FORTRAN_RUNTIME_ASSIGN_INTERNAL_H_ diff --git a/flang/runtime/pointer.cpp b/flang/runtime/pointer.cpp index 763348d..115e49b 100644 --- a/flang/runtime/pointer.cpp +++ b/flang/runtime/pointer.cpp @@ -142,8 +142,7 @@ int RTNAME(PointerAllocateSource)(Descriptor &pointer, const Descriptor &source, pointer, hasStat, errMsg, sourceFile, sourceLine)}; if (stat == StatOk) { Terminator terminator{sourceFile, sourceLine}; - // 9.7.1.2(7) - Assign(pointer, source, terminator, /*skipRealloc=*/true); + DoFromSourceAssign(pointer, source, terminator); } return stat; } diff --git a/flang/unittests/Runtime/Allocatable.cpp b/flang/unittests/Runtime/Allocatable.cpp index 11cb2f2..b6bc759 100644 --- a/flang/unittests/Runtime/Allocatable.cpp +++ b/flang/unittests/Runtime/Allocatable.cpp @@ -71,3 +71,23 @@ TEST(AllocatableTest, MoveAlloc) { errStr.remove_suffix(errStr.size() - trim_pos - 1); EXPECT_EQ(errStr, "MOVE_ALLOC passed the same address as to and from"); } + +TEST(AllocatableTest, AllocateFromScalarSource) { + using Fortran::common::TypeCategory; + // REAL(4), ALLOCATABLE :: a(:) + auto a{createAllocatable(TypeCategory::Real, 4)}; + // ALLOCATE(a(2:11), SOURCE=3.4) + float sourecStorage{3.4F}; + auto s{Descriptor::Create(TypeCategory::Real, 4, + reinterpret_cast(&sourecStorage), 0, nullptr, + CFI_attribute_pointer)}; + RTNAME(AllocatableSetBounds)(*a, 0, 2, 11); + RTNAME(AllocatableAllocateSource) + (*a, *s, /*hasStat=*/false, /*errMsg=*/nullptr, __FILE__, __LINE__); + EXPECT_TRUE(a->IsAllocated()); + EXPECT_EQ(a->Elements(), 10u); + EXPECT_EQ(a->GetDimension(0).LowerBound(), 2); + EXPECT_EQ(a->GetDimension(0).UpperBound(), 11); + EXPECT_EQ(*a->OffsetElement(), 3.4F); + a->Destroy(); +} diff --git a/flang/unittests/Runtime/Pointer.cpp b/flang/unittests/Runtime/Pointer.cpp index e00fb9b..09ae3c4 100644 --- a/flang/unittests/Runtime/Pointer.cpp +++ b/flang/unittests/Runtime/Pointer.cpp @@ -63,3 +63,23 @@ TEST(Pointer, DeallocatePolymorphic) { RTNAME(PointerDeallocatePolymorphic) (*p, nullptr, /*hasStat=*/false, /*errMsg=*/nullptr, __FILE__, __LINE__); } + +TEST(Pointer, AllocateFromScalarSource) { + // REAL(4), POINTER :: p(:) + auto p{Descriptor::Create(TypeCode{Fortran::common::TypeCategory::Real, 4}, 4, + nullptr, 1, nullptr, CFI_attribute_pointer)}; + // ALLOCATE(p(2:11), SOURCE=3.4) + float sourecStorage{3.4F}; + auto s{Descriptor::Create(Fortran::common::TypeCategory::Real, 4, + reinterpret_cast(&sourecStorage), 0, nullptr, + CFI_attribute_pointer)}; + RTNAME(PointerSetBounds)(*p, 0, 2, 11); + RTNAME(PointerAllocateSource) + (*p, *s, /*hasStat=*/false, /*errMsg=*/nullptr, __FILE__, __LINE__); + EXPECT_TRUE(RTNAME(PointerIsAssociated)(*p)); + EXPECT_EQ(p->Elements(), 10u); + EXPECT_EQ(p->GetDimension(0).LowerBound(), 2); + EXPECT_EQ(p->GetDimension(0).UpperBound(), 11); + EXPECT_EQ(*p->OffsetElement(), 3.4F); + p->Destroy(); +} -- 2.7.4