[flang] Apply definability checks in ALLOCATE/DEALLOCATE statements

[klausler]

Summary

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.)

flang/lib/Semantics/check-allocate.cpp

 //===-- lib/Semantics/check-allocate.cpp ----------------------------------===//
 //
 // 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 "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"
 #include "flang/Parser/tools.h"
 #include "flang/Semantics/attr.h"
 #include "flang/Semantics/expression.h"
 #include "flang/Semantics/tools.h"
 #include "flang/Semantics/type.h"
context
             "If SOURCE appears, the related expression must be scalar or have the same rank as each allocatable object in ALLOCATE"_err_en_US)
         .Attach(allocateInfo_.sourceExprLoc.value(),
             "SOURCE expression has rank %d"_en_US, allocateInfo_.sourceExprRank)
         .Attach(symbol_->name(),
             "Allocatable object declared here with rank %d"_en_US, rank_);
     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);
 }
 
 bool AllocationCheckerHelper::RunCoarrayRelatedChecks(
     SemanticsContext &context) const {
   if (!symbol_) {
     CHECK(context.AnyFatalError());
     return false;

flang/lib/Semantics/check-deallocate.cpp

 //===-- lib/Semantics/check-deallocate.cpp --------------------------------===//
 //
 // 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 "check-deallocate.h"
+#include "definable.h"
 #include "flang/Evaluate/type.h"
 #include "flang/Parser/message.h"
 #include "flang/Parser/parse-tree.h"
 #include "flang/Semantics/expression.h"
 #include "flang/Semantics/tools.h"
 
 namespace Fortran::semantics {
 
 void DeallocateChecker::Leave(const parser::DeallocateStmt &deallocateStmt) {
   for (const parser::AllocateObject &allocateObject :
       std::get<std::list<parser::AllocateObject>>(deallocateStmt.t)) {
     common::visit(
         common::visitors{
             [&](const parser::Name &name) {
               auto const *symbol{name.symbol};
               if (context_.HasError(symbol)) {
                 // 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);
                   }
                 }
               }
             },
         },
         allocateObject.u);
   }
   bool gotStat{false}, gotMsg{false};

flang/lib/Semantics/definable.h

 namespace Fortran::semantics {
 
 class Symbol;
 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 =
     common::EnumSet<DefinabilityFlag, DefinabilityFlag_enumSize>;
 
 // Tests a symbol or LHS variable or pointer for definability in a given scope.
 // When the entity is not definable, returns a "because:" Message suitable for
 // attachment to an error message to explain why the entity cannot be defined.

flang/lib/Semantics/definable.cpp

 // otherwise, returns the leftmost symbol.  The resulting symbol is the
 // relevant base object for definabiliy checking.  Examples:
 //   ptr1%ptr2        => ...     -> ptr1
 //   nonptr%ptr       => ...     -> nonptr
 //   nonptr%ptr       =  ...     -> ptr
 //   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);
       }
     }
   }
   if (const Symbol * lastPointer{GetLastPointerSymbol(dataRef)}) {
     return *lastPointer;
   } else {
     return dataRef.GetFirstSymbol();
   }
 }
 
 // Check the leftmost (or only) symbol from a data-ref or expression.
 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()) {
       return std::nullopt; // SELECT RANK always modifiable variable
     } else if (!IsVariable(association->expr())) {
       return BlameSymbol(at,
           "'%s' is construct associated with an expression"_en_US, original);
     } else if (evaluate::HasVectorSubscript(association->expr().value())) {
       return BlameSymbol(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) {
   } else if (!isPointerDefinition && !IsVariableName(ultimate)) {
     return BlameSymbol(at, "'%s' is not a variable"_en_US, original);
   } else if (IsProtected(ultimate) && IsUseAssociated(original, scope)) {
     return BlameSymbol(at, "'%s' is protected in this scope"_en_US, original);
   } else if (IsIntentIn(ultimate)) {
static std::optional<parser::Message> WhyNotDefinableBase(parser::CharBlock at,
   }
   return std::nullopt;
 }
 
 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
   }
   if (IsOrContainsEventOrLockComponent(ultimate)) {
     return BlameSymbol(at,
         "'%s' is an entity with either an EVENT_TYPE or LOCK_TYPE"_en_US,
         original);
static std::optional<parser::Message> WhyNotDefinableLast(parser::CharBlock at,
   }
   return std::nullopt;
 }
 
 // Checks a data-ref
 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 {
     return WhyNotDefinableLast(at, scope, flags, dataRef.GetLastSymbol());
   }
 }
 
 // Checks a NOPASS procedure pointer component
 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);
 }
 
 std::optional<parser::Message> WhyNotDefinable(parser::CharBlock at,
     const Scope &scope, DefinabilityFlags flags, const Symbol &original) {
   if (auto base{WhyNotDefinableBase(at, scope, flags, original)}) {

flang/test/Semantics/allocate13.f90

subroutine C948_b()
   class(event_type), allocatable :: teamsrc[:]
   type(lock_type), allocatable :: locksrc[:]
 
   allocate(okt1[*], SOURCE=okt1src)
   allocate(okt2[*], SOURCE=okt2src)
   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

flang/test/Semantics/deallocate05.f90

 Character(256) :: ee
 Procedure(Real) :: prp
 
 Allocate(rp)
 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
 Deallocate(x, stat=s, stat=s)
 !ERROR: STAT variable 'const_s' is not definable
 !BECAUSE: '13_4' is not a variable or pointer
 Deallocate(x, stat=const_s)
 !ERROR: ERRMSG may not be duplicated in a DEALLOCATE statement
 Deallocate(x, errmsg=ee, errmsg=ee)
 !ERROR: STAT may not be duplicated in a DEALLOCATE statement
 Deallocate(x, stat=s, errmsg=ee, stat=s)
 !ERROR: ERRMSG may not be duplicated in a DEALLOCATE statement
 Deallocate(x, stat=s, errmsg=ee, errmsg=ee)
 
 End Program deallocatetest

flang/test/Semantics/deallocate06.f90

subroutine s1()
   deallocate(a)
   deallocate(b)
 contains
   subroutine s2()
     deallocate(a)
     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

flang/test/Semantics/dosemantics12.f90

!ERROR: Cannot redefine DO variable 'ivar'
   end do
 
   ! This case is not applicable since the version of "ivar" that's inside the
   ! DO CONCURRENT has the scope of the DO CONCURRENT construct.  Within that
   ! scope, it does not have the "allocatable" attribute, so the following test
   ! 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
 
 end subroutine s11
 
 subroutine s12()
 
   Integer :: ivar, jvar
subroutine s13()
   end do
 
   ! Error for passing a DO variable to an INTENT(OUT) dummy
   do ivar = 1, 10
 !ERROR: Cannot redefine DO variable 'ivar'
     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'
     jvar = 83 + intentInFunc(intentOutFunc(ivar))
   end do
 
   do ivar = 1, 10
     !WARNING: Possible redefinition of DO variable 'ivar'