flang/lib/Semantics/check-data.cpp

   1 //===-- lib/Semantics/check-data.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 // DATA statement semantic analysis.
  10 // - Applies static semantic checks to the variables in each data-stmt-set with
  11 //   class DataVarChecker;
  12 // - Invokes conversion of DATA statement values to static initializers
  13
  14 #include "check-data.h"
  15 #include "data-to-inits.h"
  16 #include "flang/Evaluate/traverse.h"
  17 #include "flang/Parser/parse-tree.h"
  18 #include "flang/Parser/tools.h"
  19 #include "flang/Semantics/tools.h"
  20 #include <algorithm>
  21 #include <vector>
  22
  23 namespace Fortran::semantics {
  24
  25 // Ensures that references to an implied DO loop control variable are
  26 // represented as such in the "body" of the implied DO loop.
  27 void DataChecker::Enter(const parser::DataImpliedDo &x) {
  28   auto name{std::get<parser::DataImpliedDo::Bounds>(x.t).name.thing.thing};
  29   int kind{evaluate::ResultType<evaluate::ImpliedDoIndex>::kind};
  30   if (const auto dynamicType{evaluate::DynamicType::From(*name.symbol)}) {
  31     if (dynamicType->category() == TypeCategory::Integer) {
  32       kind = dynamicType->kind();
  33     }
  34   }
  35   exprAnalyzer_.AddImpliedDo(name.source, kind);
  36 }
  37
  38 void DataChecker::Leave(const parser::DataImpliedDo &x) {
  39   auto name{std::get<parser::DataImpliedDo::Bounds>(x.t).name.thing.thing};
  40   exprAnalyzer_.RemoveImpliedDo(name.source);
  41 }
  42
  43 // DataVarChecker applies static checks once to each variable that appears
  44 // in a data-stmt-set.  These checks are independent of the values that
  45 // correspond to the variables.
  46 class DataVarChecker : public evaluate::AllTraverse<DataVarChecker, true> {
  47 public:
  48   using Base = evaluate::AllTraverse<DataVarChecker, true>;
  49   DataVarChecker(SemanticsContext &c, parser::CharBlock src)
  50       : Base{*this}, context_{c}, source_{src} {}
  51   using Base::operator();
  52   bool HasComponentWithoutSubscripts() const {
  53     return hasComponent_ && !hasSubscript_;
  54   }
  55   bool operator()(const Symbol &symbol) { // C876
  56     // 8.6.7p(2) - precludes non-pointers of derived types with
  57     // default component values
  58     const Scope &scope{context_.FindScope(source_)};
  59     bool isFirstSymbol{isFirstSymbol_};
  60     isFirstSymbol_ = false;
  61     if (const char *whyNot{IsAutomatic(symbol) ? "Automatic variable"
  62                 : IsDummy(symbol)              ? "Dummy argument"
  63                 : IsFunctionResult(symbol)     ? "Function result"
  64                 : IsAllocatable(symbol)        ? "Allocatable"
  65                 : IsInitialized(symbol, true /*ignore DATA*/,
  66                       true /*ignore allocatable components*/)
  67                 ? "Default-initialized"
  68                 : IsProcedure(symbol) && !IsPointer(symbol) ? "Procedure"
  69                 // remaining checks don't apply to components
  70                 : !isFirstSymbol                   ? nullptr
  71                 : IsHostAssociated(symbol, scope)  ? "Host-associated object"
  72                 : IsUseAssociated(symbol, scope)   ? "USE-associated object"
  73                 : symbol.has<AssocEntityDetails>() ? "Construct association"
  74                 : IsPointer(symbol) && (hasComponent_ || hasSubscript_)
  75                 ? "Target of pointer"
  76                 : nullptr}) {
  77       context_.Say(source_,
  78           "%s '%s' must not be initialized in a DATA statement"_err_en_US,
  79           whyNot, symbol.name());
  80       return false;
  81     }
  82     if (IsProcedurePointer(symbol)) {
  83       context_.Say(source_,
  84           "Procedure pointer '%s' in a DATA statement is not standard"_port_en_US,
  85           symbol.name());
  86     }
  87     if (IsInBlankCommon(symbol)) {
  88       context_.Say(source_,
  89           "Blank COMMON object '%s' in a DATA statement is not standard"_port_en_US,
  90           symbol.name());
  91     }
  92     return true;
  93   }
  94   bool operator()(const evaluate::Component &component) {
  95     hasComponent_ = true;
  96     const Symbol &lastSymbol{component.GetLastSymbol()};
  97     if (isPointerAllowed_) {
  98       if (IsPointer(lastSymbol) && hasSubscript_) { // C877
  99         context_.Say(source_,
 100             "Rightmost data object pointer '%s' must not be subscripted"_err_en_US,
 101             lastSymbol.name().ToString());
 102         return false;
 103       }
 104       RestrictPointer();
 105     } else {
 106       if (IsPointer(lastSymbol)) { // C877
 107         context_.Say(source_,
 108             "Data object must not contain pointer '%s' as a non-rightmost part"_err_en_US,
 109             lastSymbol.name().ToString());
 110         return false;
 111       }
 112     }
 113     return (*this)(component.base()) && (*this)(lastSymbol);
 114   }
 115   bool operator()(const evaluate::ArrayRef &arrayRef) {
 116     hasSubscript_ = true;
 117     return (*this)(arrayRef.base()) && (*this)(arrayRef.subscript());
 118   }
 119   bool operator()(const evaluate::Substring &substring) {
 120     hasSubscript_ = true;
 121     return (*this)(substring.parent()) && (*this)(substring.lower()) &&
 122         (*this)(substring.upper());
 123   }
 124   bool operator()(const evaluate::CoarrayRef &) { // C874
 125     context_.Say(
 126         source_, "Data object must not be a coindexed variable"_err_en_US);
 127     return false;
 128   }
 129   bool operator()(const evaluate::Subscript &subs) {
 130     DataVarChecker subscriptChecker{context_, source_};
 131     subscriptChecker.RestrictPointer();
 132     return common::visit(
 133                common::visitors{
 134                    [&](const evaluate::IndirectSubscriptIntegerExpr &expr) {
 135                      return CheckSubscriptExpr(expr);
 136                    },
 137                    [&](const evaluate::Triplet &triplet) {
 138                      return CheckSubscriptExpr(triplet.lower()) &&
 139                          CheckSubscriptExpr(triplet.upper()) &&
 140                          CheckSubscriptExpr(triplet.stride());
 141                    },
 142                },
 143                subs.u) &&
 144         subscriptChecker(subs.u);
 145   }
 146   template <typename T>
 147   bool operator()(const evaluate::FunctionRef<T> &) const { // C875
 148     context_.Say(source_,
 149         "Data object variable must not be a function reference"_err_en_US);
 150     return false;
 151   }
 152   void RestrictPointer() { isPointerAllowed_ = false; }
 153
 154 private:
 155   bool CheckSubscriptExpr(
 156       const std::optional<evaluate::IndirectSubscriptIntegerExpr> &x) const {
 157     return !x || CheckSubscriptExpr(*x);
 158   }
 159   bool CheckSubscriptExpr(
 160       const evaluate::IndirectSubscriptIntegerExpr &expr) const {
 161     return CheckSubscriptExpr(expr.value());
 162   }
 163   bool CheckSubscriptExpr(
 164       const evaluate::Expr<evaluate::SubscriptInteger> &expr) const {
 165     if (!evaluate::IsConstantExpr(expr)) { // C875,C881
 166       context_.Say(
 167           source_, "Data object must have constant subscripts"_err_en_US);
 168       return false;
 169     } else {
 170       return true;
 171     }
 172   }
 173
 174   SemanticsContext &context_;
 175   parser::CharBlock source_;
 176   bool hasComponent_{false};
 177   bool hasSubscript_{false};
 178   bool isPointerAllowed_{true};
 179   bool isFirstSymbol_{true};
 180 };
 181
 182 void DataChecker::Leave(const parser::DataIDoObject &object) {
 183   if (const auto *designator{
 184           std::get_if<parser::Scalar<common::Indirection<parser::Designator>>>(
 185               &object.u)}) {
 186     if (MaybeExpr expr{exprAnalyzer_.Analyze(*designator)}) {
 187       auto source{designator->thing.value().source};
 188       if (evaluate::IsConstantExpr(*expr)) { // C878,C879
 189         exprAnalyzer_.context().Say(
 190             source, "Data implied do object must be a variable"_err_en_US);
 191       } else {
 192         DataVarChecker checker{exprAnalyzer_.context(), source};
 193         if (checker(*expr)) {
 194           if (checker.HasComponentWithoutSubscripts()) { // C880
 195             exprAnalyzer_.context().Say(source,
 196                 "Data implied do structure component must be subscripted"_err_en_US);
 197           } else {
 198             return;
 199           }
 200         }
 201       }
 202     }
 203     currentSetHasFatalErrors_ = true;
 204   }
 205 }
 206
 207 void DataChecker::Leave(const parser::DataStmtObject &dataObject) {
 208   common::visit(
 209       common::visitors{
 210           [](const parser::DataImpliedDo &) { // has own Enter()/Leave()
 211           },
 212           [&](const auto &var) {
 213             auto expr{exprAnalyzer_.Analyze(var)};
 214             if (!expr ||
 215                 !DataVarChecker{exprAnalyzer_.context(),
 216                     parser::FindSourceLocation(dataObject)}(*expr)) {
 217               currentSetHasFatalErrors_ = true;
 218             }
 219           },
 220       },
 221       dataObject.u);
 222 }
 223
 224 void DataChecker::Leave(const parser::DataStmtSet &set) {
 225   if (!currentSetHasFatalErrors_) {
 226     AccumulateDataInitializations(inits_, exprAnalyzer_, set);
 227   }
 228   currentSetHasFatalErrors_ = false;
 229 }
 230
 231 // Handle legacy DATA-style initialization, e.g. REAL PI/3.14159/, for
 232 // variables and components (esp. for DEC STRUCTUREs)
 233 template <typename A> void DataChecker::LegacyDataInit(const A &decl) {
 234   if (const auto &init{
 235           std::get<std::optional<parser::Initialization>>(decl.t)}) {
 236     const Symbol *name{std::get<parser::Name>(decl.t).symbol};
 237     const auto *list{
 238         std::get_if<std::list<common::Indirection<parser::DataStmtValue>>>(
 239             &init->u)};
 240     if (name && list) {
 241       AccumulateDataInitializations(inits_, exprAnalyzer_, *name, *list);
 242     }
 243   }
 244 }
 245
 246 void DataChecker::Leave(const parser::ComponentDecl &decl) {
 247   LegacyDataInit(decl);
 248 }
 249
 250 void DataChecker::Leave(const parser::EntityDecl &decl) {
 251   LegacyDataInit(decl);
 252 }
 253
 254 void DataChecker::CompileDataInitializationsIntoInitializers() {
 255   ConvertToInitializers(inits_, exprAnalyzer_);
 256 }
 257
 258 } // namespace Fortran::semantics