[flang] Let double allocation error be catched by AllocatableAllocate

[clementval]

Summary

When doing an allocation, the three following functions can be called
before AllocatableAllocate.

• AllocatableInitIntrinsic
• AllocatableInitCharacter
• AllocatableInitDerived

When the descriptor is allocated, make sure these three function do not
reset it so the double allocation can be caught by AllocatableAllocate
later.

[PeteSteinfeld]

All builds and tests correctly and looks good.

[klausler]

flang/runtime/allocatable.cpp

24

Like Establish functions, these Init functions should make no assumptions about the contents of the descriptor before they are called. I think that your change depends on lowered code initializing the base addresses of new allocatables to null pointers.

[clementval]

flang/runtime/allocatable.cpp

24

If we allocate an already allocated allocatable, these functions will reset the descriptor and therefore the error is not catch in the AllocatableAllocate function. I can also do an inlined check in the lowering before calling these functions if this is preferable.

[klausler]

flang/runtime/allocatable.cpp

24

I understand the problem, yes. My concern is that a descriptor containing random garbage will pass your if (descriptor.IsAllocated()) test and then not become established.

[clementval]

flang/runtime/allocatable.cpp

24

Ok I see your point. I'll do this differently then.

flang/runtime/allocatable.cpp

 #include "flang/Runtime/assign.h"
 #include "flang/Runtime/descriptor.h"
 
 namespace Fortran::runtime {
 extern "C" {
 
 void RTNAME(AllocatableInitIntrinsic)(Descriptor &descriptor,
     TypeCategory category, int kind, int rank, int corank) {
+  if (descriptor.IsAllocated()) {
+    return; // Bypass so AllocatableAllocate can raise the error.
+  }
   INTERNAL_CHECK(corank == 0);
   descriptor.Establish(TypeCode{category, kind},
       Descriptor::BytesFor(category, kind), nullptr, rank, nullptr,
       CFI_attribute_allocatable);
 }
 
 void RTNAME(AllocatableInitCharacter)(Descriptor &descriptor,
     SubscriptValue length, int kind, int rank, int corank) {
+  if (descriptor.IsAllocated()) {
+    return; // Bypass so AllocatableAllocate can raise the error.
+  }
   INTERNAL_CHECK(corank == 0);
   descriptor.Establish(
       kind, length, nullptr, rank, nullptr, CFI_attribute_allocatable);
 }
 
 void RTNAME(AllocatableInitDerived)(Descriptor &descriptor,
     const typeInfo::DerivedType &derivedType, int rank, int corank) {
+  if (descriptor.IsAllocated()) {
+    return; // Bypass so AllocatableAllocate can raise the error.
+  }
   INTERNAL_CHECK(corank == 0);
   descriptor.Establish(
       derivedType, nullptr, rank, nullptr, CFI_attribute_allocatable);
 }
 
 std::int32_t RTNAME(MoveAlloc)(Descriptor &to, Descriptor &from,
     const typeInfo::DerivedType *derivedType, bool hasStat,
     const Descriptor *errMsg, const char *sourceFile, int sourceLine) {

flang/unittests/Runtime/Allocatable.cpp

TEST(AllocatableTest, AllocateFromScalarSource) {
   (*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<float>(), 3.4F);
   a->Destroy();
 }
+
+TEST(AllocatableTest, DoubleAllocation) {
+
+  // CLASS(*), ALLOCATABLE :: r
+  // ALLOCATE(REAL::r)
+  auto r{createAllocatable(TypeCategory::Real, 4, 0)};
+  EXPECT_FALSE(r->IsAllocated());
+  EXPECT_TRUE(r->IsAllocatable());
+  RTNAME(AllocatableAllocate)(*r);
+  EXPECT_TRUE(r->IsAllocated());
+
+  // Make sure AllocatableInitIntrinsic doesn't reset the decsriptor if it is
+  // allocated.
+  // ALLOCATE(INTEGER::r)
+  RTNAME(AllocatableInitIntrinsic)
+  (*r, Fortran::common::TypeCategory::Integer, 4);
+  EXPECT_TRUE(r->IsAllocated());
+}