diff --git a/flang/lib/Lower/Allocatable.cpp b/flang/lib/Lower/Allocatable.cpp --- a/flang/lib/Lower/Allocatable.cpp +++ b/flang/lib/Lower/Allocatable.cpp @@ -559,8 +559,6 @@ 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 --- a/flang/runtime/allocatable.cpp +++ b/flang/runtime/allocatable.cpp @@ -127,8 +127,7 @@ 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.h b/flang/runtime/assign.h --- 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 @@ 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/assign.cpp b/flang/runtime/assign.cpp --- a/flang/runtime/assign.cpp +++ b/flang/runtime/assign.cpp @@ -60,8 +60,15 @@ } } -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 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/pointer.cpp b/flang/runtime/pointer.cpp --- a/flang/runtime/pointer.cpp +++ b/flang/runtime/pointer.cpp @@ -142,8 +142,7 @@ 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 --- a/flang/unittests/Runtime/Allocatable.cpp +++ b/flang/unittests/Runtime/Allocatable.cpp @@ -71,3 +71,23 @@ 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 --- a/flang/unittests/Runtime/Pointer.cpp +++ b/flang/unittests/Runtime/Pointer.cpp @@ -63,3 +63,23 @@ 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(); +}