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               const Symbol *symbol{
  26                   name.symbol ? &name.symbol->GetUltimate() : nullptr};
  27               ;
  28               if (context_.HasError(symbol)) {
  29                 // already reported an error
  30               } else if (!IsVariableName(*symbol)) {
  31                 context_.Say(name.source,
  32                     "Name in DEALLOCATE statement must be a variable name"_err_en_US);
  33               } else if (!IsAllocatableOrObjectPointer(symbol)) { // C936
  34                 context_.Say(name.source,
  35                     "Name in DEALLOCATE statement must have the ALLOCATABLE or POINTER attribute"_err_en_US);
  36               } else if (auto whyNot{WhyNotDefinable(name.source,
  37                              context_.FindScope(name.source),
  38                              {DefinabilityFlag::PointerDefinition,
  39                                  DefinabilityFlag::AcceptAllocatable},
  40                              *symbol)}) {
  41                 // Catch problems with non-definability of the
  42                 // pointer/allocatable
  43                 context_
  44                     .Say(name.source,
  45                         "Name in DEALLOCATE statement is not definable"_err_en_US)
  46                     .Attach(std::move(
  47                         whyNot->set_severity(parser::Severity::Because)));
  48               } else if (auto whyNot{WhyNotDefinable(name.source,
  49                              context_.FindScope(name.source),
  50                              DefinabilityFlags{}, *symbol)}) {
  51                 // Catch problems with non-definability of the dynamic object
  52                 context_
  53                     .Say(name.source,
  54                         "Object in DEALLOCATE statement is not deallocatable"_err_en_US)
  55                     .Attach(std::move(
  56                         whyNot->set_severity(parser::Severity::Because)));
  57               } else {
  58                 context_.CheckIndexVarRedefine(name);
  59               }
  60             },
  61             [&](const parser::StructureComponent &structureComponent) {
  62               // Only perform structureComponent checks if it was successfully
  63               // analyzed by expression analysis.
  64               auto source{structureComponent.component.source};
  65               if (const auto *expr{GetExpr(context_, allocateObject)}) {
  66                 if (const Symbol *
  67                         symbol{structureComponent.component.symbol
  68                                 ? &structureComponent.component.symbol
  69                                        ->GetUltimate()
  70                                 : nullptr};
  71                     !IsAllocatableOrObjectPointer(symbol)) { // F'2023 C936
  72                   context_.Say(source,
  73                       "Component in DEALLOCATE statement must have the ALLOCATABLE or POINTER attribute"_err_en_US);
  74                 } else if (auto whyNot{WhyNotDefinable(source,
  75                                context_.FindScope(source),
  76                                {DefinabilityFlag::PointerDefinition,
  77                                    DefinabilityFlag::AcceptAllocatable},
  78                                *expr)}) {
  79                   context_
  80                       .Say(source,
  81                           "Name in DEALLOCATE statement is not definable"_err_en_US)
  82                       .Attach(std::move(
  83                           whyNot->set_severity(parser::Severity::Because)));
  84                 } else if (auto whyNot{WhyNotDefinable(source,
  85                                context_.FindScope(source), DefinabilityFlags{},
  86                                *expr)}) {
  87                   context_
  88                       .Say(source,
  89                           "Object in DEALLOCATE statement is not deallocatable"_err_en_US)
  90                       .Attach(std::move(
  91                           whyNot->set_severity(parser::Severity::Because)));
  92                 }
  93               }
  94             },
  95         },
  96         allocateObject.u);
  97   }
  98   bool gotStat{false}, gotMsg{false};
  99   for (const parser::StatOrErrmsg &deallocOpt :
 100       std::get<std::list<parser::StatOrErrmsg>>(deallocateStmt.t)) {
 101     common::visit(
 102         common::visitors{
 103             [&](const parser::StatVariable &) {
 104               if (gotStat) {
 105                 context_.Say(
 106                     "STAT may not be duplicated in a DEALLOCATE statement"_err_en_US);
 107               }
 108               gotStat = true;
 109             },
 110             [&](const parser::MsgVariable &var) {
 111               WarnOnDeferredLengthCharacterScalar(context_,
 112                   GetExpr(context_, var), var.v.thing.thing.GetSource(),
 113                   "ERRMSG=");
 114               if (gotMsg) {
 115                 context_.Say(
 116                     "ERRMSG may not be duplicated in a DEALLOCATE statement"_err_en_US);
 117               }
 118               gotMsg = true;
 119             },
 120         },
 121         deallocOpt.u);
 122   }
 123 }
 124
 125 } // namespace Fortran::semantics