[flang] Apply definability checks in ALLOCATE/DEALLOCATE statements

The pointers and allocatables that appear in ALLOCATE and DEALLOCATE
statements need to be subject to the general definability checks so
that problems with e.g. PROTECTED objects can be caught.

(Also: regularize the capitalization of the DEALLOCATE error messages
while I'm in here so that they're consistent with the messages that
can come out for ALLOCATE.)

Differential Revision: https://reviews.llvm.org/D140149

diff --git a/flang/lib/Semantics/check-allocate.cpp b/flang/lib/Semantics/check-allocate.cpp
index ce81ca1..c397c9f 100644 (file)
--- a/flang/lib/Semantics/check-allocate.cpp
+++ b/flang/lib/Semantics/check-allocate.cpp
@@ -8,6 +8,7 @@
 
 #include "check-allocate.h"
 #include "assignment.h"
+#include "definable.h"
 #include "flang/Evaluate/fold.h"
 #include "flang/Evaluate/type.h"
 #include "flang/Parser/parse-tree.h"
@@ -532,6 +533,19 @@ bool AllocationCheckerHelper::RunChecks(SemanticsContext &context) {
     return false;
   }
   context.CheckIndexVarRedefine(name_);
+  if (allocateObject_.typedExpr && allocateObject_.typedExpr->v) {
+    if (auto whyNot{
+            WhyNotDefinable(name_.source, context.FindScope(name_.source),
+                {DefinabilityFlag::PointerDefinition,
+                    DefinabilityFlag::AcceptAllocatable},
+                *allocateObject_.typedExpr->v)}) {
+      context
+          .Say(name_.source,
+              "Name in ALLOCATE statement is not definable"_err_en_US)
+          .Attach(std::move(*whyNot));
+      return false;
+    }
+  }
   return RunCoarrayRelatedChecks(context);
 }
 

diff --git a/flang/lib/Semantics/check-deallocate.cpp b/flang/lib/Semantics/check-deallocate.cpp
index 5e46960..db08977 100644 (file)
--- a/flang/lib/Semantics/check-deallocate.cpp
+++ b/flang/lib/Semantics/check-deallocate.cpp
@@ -7,6 +7,7 @@
 //===----------------------------------------------------------------------===//
 
 #include "check-deallocate.h"
+#include "definable.h"
 #include "flang/Evaluate/type.h"
 #include "flang/Parser/message.h"
 #include "flang/Parser/parse-tree.h"
@@ -26,26 +27,44 @@ void DeallocateChecker::Leave(const parser::DeallocateStmt &deallocateStmt) {
                 // already reported an error
               } else if (!IsVariableName(*symbol)) {
                 context_.Say(name.source,
-                    "name in DEALLOCATE statement must be a variable name"_err_en_US);
+                    "Name in DEALLOCATE statement must be a variable name"_err_en_US);
               } else if (!IsAllocatableOrPointer(
                              symbol->GetUltimate())) { // C932
                 context_.Say(name.source,
-                    "name in DEALLOCATE statement must have the ALLOCATABLE or POINTER attribute"_err_en_US);
+                    "Name in DEALLOCATE statement must have the ALLOCATABLE or POINTER attribute"_err_en_US);
+              } else if (auto whyNot{WhyNotDefinable(name.source,
+                             context_.FindScope(name.source),
+                             {DefinabilityFlag::PointerDefinition,
+                                 DefinabilityFlag::AcceptAllocatable},
+                             *symbol)}) {
+                context_
+                    .Say(name.source,
+                        "Name in DEALLOCATE statement is not definable"_err_en_US)
+                    .Attach(std::move(*whyNot));
               } else if (CheckPolymorphism(name.source, *symbol)) {
                 context_.CheckIndexVarRedefine(name);
               }
             },
             [&](const parser::StructureComponent &structureComponent) {
-              // Only perform structureComponent checks it was successfully
-              // analyzed in expression analysis.
-              if (GetExpr(context_, allocateObject)) {
+              // Only perform structureComponent checks if it was successfully
+              // analyzed by expression analysis.
+              if (const auto *expr{GetExpr(context_, allocateObject)}) {
                 if (const Symbol *symbol{structureComponent.component.symbol}) {
+                  auto source{structureComponent.component.source};
                   if (!IsAllocatableOrPointer(*symbol)) { // C932
-                    context_.Say(structureComponent.component.source,
-                        "component in DEALLOCATE statement must have the ALLOCATABLE or POINTER attribute"_err_en_US);
+                    context_.Say(source,
+                        "Component in DEALLOCATE statement must have the ALLOCATABLE or POINTER attribute"_err_en_US);
+                  } else if (auto whyNot{WhyNotDefinable(source,
+                                 context_.FindScope(source),
+                                 {DefinabilityFlag::PointerDefinition,
+                                     DefinabilityFlag::AcceptAllocatable},
+                                 *expr)}) {
+                    context_
+                        .Say(source,
+                            "Name in DEALLOCATE statement is not definable"_err_en_US)
+                        .Attach(std::move(*whyNot));
                   } else {
-                    CheckPolymorphism(
-                        structureComponent.component.source, *symbol);
+                    CheckPolymorphism(source, *symbol);
                   }
                 }
               }

diff --git a/flang/lib/Semantics/definable.cpp b/flang/lib/Semantics/definable.cpp
index 06f96a2..092cfaf 100644 (file)
--- a/flang/lib/Semantics/definable.cpp
+++ b/flang/lib/Semantics/definable.cpp
@@ -70,12 +70,13 @@ static std::optional<parser::Message> CheckDefinabilityInPureScope(
 //   ptr1%ptr2        =  ...     -> ptr2
 //   ptr1%ptr2%nonptr =  ...     -> ptr2
 //   nonptr1%nonptr2  =  ...     -> nonptr1
-static const Symbol &GetRelevantSymbol(
-    const evaluate::DataRef &dataRef, bool isPointerDefinition) {
+static const Symbol &GetRelevantSymbol(const evaluate::DataRef &dataRef,
+    bool isPointerDefinition, bool acceptAllocatable) {
   if (isPointerDefinition) {
     if (const auto *component{std::get_if<evaluate::Component>(&dataRef.u)}) {
-      if (IsPointer(component->GetLastSymbol())) {
-        return GetRelevantSymbol(component->base(), false);
+      if (IsPointer(component->GetLastSymbol()) ||
+          (acceptAllocatable && IsAllocatable(component->GetLastSymbol()))) {
+        return GetRelevantSymbol(component->base(), false, false);
       }
     }
   }
@@ -91,6 +92,7 @@ static std::optional<parser::Message> WhyNotDefinableBase(parser::CharBlock at,
     const Scope &scope, DefinabilityFlags flags, const Symbol &original) {
   const Symbol &ultimate{original.GetUltimate()};
   bool isPointerDefinition{flags.test(DefinabilityFlag::PointerDefinition)};
+  bool acceptAllocatable{flags.test(DefinabilityFlag::AcceptAllocatable)};
   bool isTargetDefinition{!isPointerDefinition && IsPointer(ultimate)};
   if (const auto *association{ultimate.detailsIf<AssocEntityDetails>()}) {
     if (association->rank().has_value()) {
@@ -103,8 +105,8 @@ static std::optional<parser::Message> WhyNotDefinableBase(parser::CharBlock at,
           "Construct association '%s' has a vector subscript"_en_US, original);
     } else if (auto dataRef{evaluate::ExtractDataRef(
                    *association->expr(), true, true)}) {
-      return WhyNotDefinableBase(
-          at, scope, flags, GetRelevantSymbol(*dataRef, isPointerDefinition));
+      return WhyNotDefinableBase(at, scope, flags,
+          GetRelevantSymbol(*dataRef, isPointerDefinition, acceptAllocatable));
     }
   }
   if (isTargetDefinition) {
@@ -139,7 +141,12 @@ static std::optional<parser::Message> WhyNotDefinableLast(parser::CharBlock at,
     const Scope &scope, DefinabilityFlags flags, const Symbol &original) {
   const Symbol &ultimate{original.GetUltimate()};
   if (flags.test(DefinabilityFlag::PointerDefinition)) {
-    if (!IsPointer(ultimate)) {
+    if (flags.test(DefinabilityFlag::AcceptAllocatable)) {
+      if (!IsAllocatableOrPointer(ultimate)) {
+        return BlameSymbol(
+            at, "'%s' is neither a pointer nor an allocatable"_en_US, original);
+      }
+    } else if (!IsPointer(ultimate)) {
       return BlameSymbol(at, "'%s' is not a pointer"_en_US, original);
     }
     return std::nullopt; // pointer assignment - skip following checks
@@ -173,8 +180,9 @@ static std::optional<parser::Message> WhyNotDefinableLast(parser::CharBlock at,
 static std::optional<parser::Message> WhyNotDefinable(parser::CharBlock at,
     const Scope &scope, DefinabilityFlags flags,
     const evaluate::DataRef &dataRef) {
-  const Symbol &base{GetRelevantSymbol(
-      dataRef, flags.test(DefinabilityFlag::PointerDefinition))};
+  const Symbol &base{GetRelevantSymbol(dataRef,
+      flags.test(DefinabilityFlag::PointerDefinition),
+      flags.test(DefinabilityFlag::AcceptAllocatable))};
   if (auto whyNot{WhyNotDefinableBase(at, scope, flags, base)}) {
     return whyNot;
   } else {
@@ -187,7 +195,7 @@ static std::optional<parser::Message> WhyNotDefinable(parser::CharBlock at,
     const Scope &scope, DefinabilityFlags flags,
     const evaluate::Component &component) {
   const evaluate::DataRef &dataRef{component.base()};
-  const Symbol &base{GetRelevantSymbol(dataRef, false)};
+  const Symbol &base{GetRelevantSymbol(dataRef, false, false)};
   DefinabilityFlags baseFlags{flags};
   baseFlags.reset(DefinabilityFlag::PointerDefinition);
   return WhyNotDefinableBase(at, scope, baseFlags, base);

diff --git a/flang/lib/Semantics/definable.h b/flang/lib/Semantics/definable.h
index e4c94e3..374ea38 100644 (file)
--- a/flang/lib/Semantics/definable.h
+++ b/flang/lib/Semantics/definable.h
@@ -28,6 +28,7 @@ class Scope;
 ENUM_CLASS(DefinabilityFlag,
     VectorSubscriptIsOk, // a vector subscript may appear (i.e., assignment)
     PointerDefinition, // a pointer is being defined, not its target
+    AcceptAllocatable, // treat allocatable as if it were a pointer
     PolymorphicOkInPure) // don't check for polymorphic type in pure subprogram
 
 using DefinabilityFlags =

diff --git a/flang/test/Semantics/allocate13.f90 b/flang/test/Semantics/allocate13.f90
index fe23c57..27097ba 100644 (file)
--- a/flang/test/Semantics/allocate13.f90
+++ b/flang/test/Semantics/allocate13.f90
@@ -171,3 +171,23 @@ subroutine C948_b()
   allocate(team[*], SOURCE=teamsrc)
   allocate(lock[*], SOURCE=locksrc)
 end subroutine
+
+module prot
+  real, pointer, protected :: pp
+  real, allocatable, protected :: pa
+end module
+subroutine prottest
+  use prot
+  !ERROR: Name in ALLOCATE statement is not definable
+  !BECAUSE: 'pp' is protected in this scope
+  allocate(pp)
+  !ERROR: Name in ALLOCATE statement is not definable
+  !BECAUSE: 'pa' is protected in this scope
+  allocate(pa)
+  !ERROR: Name in DEALLOCATE statement is not definable
+  !BECAUSE: 'pp' is protected in this scope
+  deallocate(pp)
+  !ERROR: Name in DEALLOCATE statement is not definable
+  !BECAUSE: 'pa' is protected in this scope
+  deallocate(pa)
+end subroutine

diff --git a/flang/test/Semantics/deallocate05.f90 b/flang/test/Semantics/deallocate05.f90
index 7d58350..bdc6998 100644 (file)
--- a/flang/test/Semantics/deallocate05.f90
+++ b/flang/test/Semantics/deallocate05.f90
@@ -32,27 +32,27 @@ Deallocate(rp)
 
 Allocate(x(3))
 
-!ERROR: component in DEALLOCATE statement must have the ALLOCATABLE or POINTER attribute
+!ERROR: Component in DEALLOCATE statement must have the ALLOCATABLE or POINTER attribute
 Deallocate(x(2)%p)
 
-!ERROR: name in DEALLOCATE statement must have the ALLOCATABLE or POINTER attribute
+!ERROR: Name in DEALLOCATE statement must have the ALLOCATABLE or POINTER attribute
 Deallocate(pi)
 
-!ERROR: component in DEALLOCATE statement must have the ALLOCATABLE or POINTER attribute
-!ERROR: name in DEALLOCATE statement must have the ALLOCATABLE or POINTER attribute
+!ERROR: Component in DEALLOCATE statement must have the ALLOCATABLE or POINTER attribute
+!ERROR: Name in DEALLOCATE statement must have the ALLOCATABLE or POINTER attribute
 Deallocate(x(2)%p, pi)
 
-!ERROR: name in DEALLOCATE statement must be a variable name
+!ERROR: Name in DEALLOCATE statement must be a variable name
 Deallocate(prp)
 
-!ERROR: name in DEALLOCATE statement must have the ALLOCATABLE or POINTER attribute
-!ERROR: name in DEALLOCATE statement must be a variable name
+!ERROR: Name in DEALLOCATE statement must have the ALLOCATABLE or POINTER attribute
+!ERROR: Name in DEALLOCATE statement must be a variable name
 Deallocate(pi, prp)
 
-!ERROR: name in DEALLOCATE statement must be a variable name
+!ERROR: Name in DEALLOCATE statement must be a variable name
 Deallocate(maxvalue)
 
-!ERROR: component in DEALLOCATE statement must have the ALLOCATABLE or POINTER attribute
+!ERROR: Component in DEALLOCATE statement must have the ALLOCATABLE or POINTER attribute
 Deallocate(x%p)
 
 !ERROR: STAT may not be duplicated in a DEALLOCATE statement

diff --git a/flang/test/Semantics/deallocate06.f90 b/flang/test/Semantics/deallocate06.f90
index 16ae9f9..dda9ee8 100644 (file)
--- a/flang/test/Semantics/deallocate06.f90
+++ b/flang/test/Semantics/deallocate06.f90
@@ -19,7 +19,7 @@ contains
     deallocate(b)
     deallocate(c)
     deallocate(d)
-    !ERROR: name in DEALLOCATE statement must have the ALLOCATABLE or POINTER attribute
+    !ERROR: Name in DEALLOCATE statement must have the ALLOCATABLE or POINTER attribute
     deallocate(e)
   end subroutine
 end

diff --git a/flang/test/Semantics/dosemantics12.f90 b/flang/test/Semantics/dosemantics12.f90
index fc13aea..3adf310 100644 (file)
--- a/flang/test/Semantics/dosemantics12.f90
+++ b/flang/test/Semantics/dosemantics12.f90
@@ -369,7 +369,7 @@ subroutine s11()
   ! fails because you can only deallocate a variable that's allocatable.
   do concurrent (ivar = 1:10)
     print *, "hello"
-!ERROR: name in DEALLOCATE statement must have the ALLOCATABLE or POINTER attribute
+!ERROR: Name in DEALLOCATE statement must have the ALLOCATABLE or POINTER attribute
     deallocate(ivar)
   end do
 
@@ -429,7 +429,7 @@ subroutine s13()
     jvar = intentOutFunc(ivar)
   end do
 
-  ! Error for passing a DO variable to an INTENT(OUT) dummy, more complex 
+  ! Error for passing a DO variable to an INTENT(OUT) dummy, more complex
   ! expression
   do ivar = 1, 10
 !ERROR: Cannot redefine DO variable 'ivar'