flang/lib/Semantics/check-deallocate.cpp

   1 //===-- lib/Semantics/check-deallocate.cpp --------------------------------===//
   2 //
   3 // Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
   4 // See https://llvm.org/LICENSE.txt for license information.
   5 // SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception
   6 //
   7 //===----------------------------------------------------------------------===//
   8
   9 #include "check-deallocate.h"
  10 #include "definable.h"
  11 #include "flang/Evaluate/type.h"
  12 #include "flang/Parser/message.h"
  13 #include "flang/Parser/parse-tree.h"
  14 #include "flang/Semantics/expression.h"
  15 #include "flang/Semantics/tools.h"
  16
  17 namespace Fortran::semantics {
  18
  19 void DeallocateChecker::Leave(const parser::DeallocateStmt &deallocateStmt) {
  20   for (const parser::AllocateObject &allocateObject :
  21       std::get<std::list<parser::AllocateObject>>(deallocateStmt.t)) {
  22     common::visit(
  23         common::visitors{
  24             [&](const parser::Name &name) {
  25               auto const *symbol{name.symbol};
  26               if (context_.HasError(symbol)) {
  27                 // already reported an error
  28               } else if (!IsVariableName(*symbol)) {
  29                 context_.Say(name.source,
  30                     "Name in DEALLOCATE statement must be a variable name"_err_en_US);
  31               } else if (!IsAllocatableOrPointer(
  32                              symbol->GetUltimate())) { // C932
  33                 context_.Say(name.source,
  34                     "Name in DEALLOCATE statement must have the ALLOCATABLE or POINTER attribute"_err_en_US);
  35               } else if (auto whyNot{WhyNotDefinable(name.source,
  36                              context_.FindScope(name.source),
  37                              {DefinabilityFlag::PointerDefinition,
  38                                  DefinabilityFlag::AcceptAllocatable},
  39                              *symbol)}) {
  40                 context_
  41                     .Say(name.source,
  42                         "Name in DEALLOCATE statement is not definable"_err_en_US)
  43                     .Attach(std::move(*whyNot));
  44               } else if (CheckPolymorphism(name.source, *symbol)) {
  45                 context_.CheckIndexVarRedefine(name);
  46               }
  47             },
  48             [&](const parser::StructureComponent &structureComponent) {
  49               // Only perform structureComponent checks if it was successfully
  50               // analyzed by expression analysis.
  51               if (const auto *expr{GetExpr(context_, allocateObject)}) {
  52                 if (const Symbol *symbol{structureComponent.component.symbol}) {
  53                   auto source{structureComponent.component.source};
  54                   if (!IsAllocatableOrPointer(*symbol)) { // C932
  55                     context_.Say(source,
  56                         "Component in DEALLOCATE statement must have the ALLOCATABLE or POINTER attribute"_err_en_US);
  57                   } else if (auto whyNot{WhyNotDefinable(source,
  58                                  context_.FindScope(source),
  59                                  {DefinabilityFlag::PointerDefinition,
  60                                      DefinabilityFlag::AcceptAllocatable},
  61                                  *expr)}) {
  62                     context_
  63                         .Say(source,
  64                             "Name in DEALLOCATE statement is not definable"_err_en_US)
  65                         .Attach(std::move(*whyNot));
  66                   } else {
  67                     CheckPolymorphism(source, *symbol);
  68                   }
  69                 }
  70               }
  71             },
  72         },
  73         allocateObject.u);
  74   }
  75   bool gotStat{false}, gotMsg{false};
  76   for (const parser::StatOrErrmsg &deallocOpt :
  77       std::get<std::list<parser::StatOrErrmsg>>(deallocateStmt.t)) {
  78     common::visit(
  79         common::visitors{
  80             [&](const parser::StatVariable &) {
  81               if (gotStat) {
  82                 context_.Say(
  83                     "STAT may not be duplicated in a DEALLOCATE statement"_err_en_US);
  84               }
  85               gotStat = true;
  86             },
  87             [&](const parser::MsgVariable &) {
  88               if (gotMsg) {
  89                 context_.Say(
  90                     "ERRMSG may not be duplicated in a DEALLOCATE statement"_err_en_US);
  91               }
  92               gotMsg = true;
  93             },
  94         },
  95         deallocOpt.u);
  96   }
  97 }
  98
  99 bool DeallocateChecker::CheckPolymorphism(
 100     parser::CharBlock source, const Symbol &symbol) {
 101   if (FindPureProcedureContaining(context_.FindScope(source))) {
 102     if (auto type{evaluate::DynamicType::From(symbol)}) {
 103       if (type->IsPolymorphic()) {
 104         context_.Say(source,
 105             "'%s' may not be deallocated in a pure procedure because it is polymorphic"_err_en_US,
 106             source);
 107         return false;
 108       }
 109       if (!type->IsUnlimitedPolymorphic() &&
 110           type->category() == TypeCategory::Derived) {
 111         if (auto iter{FindPolymorphicAllocatableUltimateComponent(
 112                 type->GetDerivedTypeSpec())}) {
 113           context_.Say(source,
 114               "'%s' may not be deallocated in a pure procedure because its type has a polymorphic allocatable ultimate component '%s'"_err_en_US,
 115               source, iter->name());
 116           return false;
 117         }
 118       }
 119     }
 120   }
 121   return true;
 122 }
 123 } // namespace Fortran::semantics