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     // Ordered so that most egregious errors are first
  62     if (const char *whyNot{IsProcedure(symbol) && !IsPointer(symbol)
  63                 ? "Procedure"
  64                 : isFirstSymbol && IsHostAssociated(symbol, scope)
  65                 ? "Host-associated object"
  66                 : isFirstSymbol && IsUseAssociated(symbol, scope)
  67                 ? "USE-associated object"
  68                 : IsDummy(symbol)          ? "Dummy argument"
  69                 : IsFunctionResult(symbol) ? "Function result"
  70                 : IsAutomatic(symbol)      ? "Automatic variable"
  71                 : IsAllocatable(symbol)    ? "Allocatable"
  72                 : IsInitialized(symbol, true /*ignore DATA*/,
  73                       true /*ignore allocatable components*/,
  74                       true /*ignore uninitialized pointer components*/)
  75                 ? "Default-initialized"
  76                 : symbol.has<AssocEntityDetails>() ? "Construct association"
  77                 : isFirstSymbol && IsPointer(symbol) &&
  78                     (hasComponent_ || hasSubscript_)
  79                 ? "Target of pointer"
  80                 : nullptr}) {
  81       context_.Say(source_,
  82           "%s '%s' must not be initialized in a DATA statement"_err_en_US,
  83           whyNot, symbol.name());
  84       return false;
  85     }
  86     if (IsProcedurePointer(symbol)) {
  87       if (!context_.IsEnabled(common::LanguageFeature::DataStmtExtensions)) {
  88         context_.Say(source_,
  89             "Procedure pointer '%s' may not appear in a DATA statement"_err_en_US,
  90             symbol.name());
  91         return false;
  92       } else {
  93         context_.Warn(common::LanguageFeature::DataStmtExtensions, source_,
  94             "Procedure pointer '%s' in a DATA statement is not standard"_port_en_US,
  95             symbol.name());
  96       }
  97     }
  98     if (IsInBlankCommon(symbol)) {
  99       if (!context_.IsEnabled(common::LanguageFeature::DataStmtExtensions)) {
 100         context_.Say(source_,
 101             "Blank COMMON object '%s' may not appear in a DATA statement"_err_en_US,
 102             symbol.name());
 103         return false;
 104       } else {
 105         context_.Warn(common::LanguageFeature::DataStmtExtensions, source_,
 106             "Blank COMMON object '%s' in a DATA statement is not standard"_port_en_US,
 107             symbol.name());
 108       }
 109     }
 110     return true;
 111   }
 112   bool operator()(const evaluate::Component &component) {
 113     hasComponent_ = true;
 114     const Symbol &lastSymbol{component.GetLastSymbol()};
 115     if (isPointerAllowed_) {
 116       if (IsPointer(lastSymbol) && hasSubscript_) { // C877
 117         context_.Say(source_,
 118             "Rightmost data object pointer '%s' must not be subscripted"_err_en_US,
 119             lastSymbol.name().ToString());
 120         return false;
 121       }
 122       auto restorer{common::ScopedSet(isPointerAllowed_, false)};
 123       return (*this)(component.base()) && (*this)(lastSymbol);
 124     } else if (IsPointer(lastSymbol)) { // C877
 125       context_.Say(source_,
 126           "Data object must not contain pointer '%s' as a non-rightmost part"_err_en_US,
 127           lastSymbol.name().ToString());
 128       return false;
 129     } else {
 130       return (*this)(component.base()) && (*this)(lastSymbol);
 131     }
 132   }
 133   bool operator()(const evaluate::ArrayRef &arrayRef) {
 134     hasSubscript_ = true;
 135     return (*this)(arrayRef.base()) && (*this)(arrayRef.subscript());
 136   }
 137   bool operator()(const evaluate::Substring &substring) {
 138     hasSubscript_ = true;
 139     return (*this)(substring.parent()) && (*this)(substring.lower()) &&
 140         (*this)(substring.upper());
 141   }
 142   bool operator()(const evaluate::CoarrayRef &) { // C874
 143     context_.Say(
 144         source_, "Data object must not be a coindexed variable"_err_en_US);
 145     return false;
 146   }
 147   bool operator()(const evaluate::Subscript &subs) {
 148     auto restorer1{common::ScopedSet(isPointerAllowed_, false)};
 149     auto restorer2{common::ScopedSet(isFunctionAllowed_, true)};
 150     return common::visit(
 151         common::visitors{
 152             [&](const evaluate::IndirectSubscriptIntegerExpr &expr) {
 153               return CheckSubscriptExpr(expr);
 154             },
 155             [&](const evaluate::Triplet &triplet) {
 156               return CheckSubscriptExpr(triplet.lower()) &&
 157                   CheckSubscriptExpr(triplet.upper()) &&
 158                   CheckSubscriptExpr(triplet.stride());
 159             },
 160         },
 161         subs.u);
 162   }
 163   template <typename T>
 164   bool operator()(const evaluate::FunctionRef<T> &) const { // C875
 165     if (isFunctionAllowed_) {
 166       // Must have been validated as a constant expression
 167       return true;
 168     } else {
 169       context_.Say(source_,
 170           "Data object variable must not be a function reference"_err_en_US);
 171       return false;
 172     }
 173   }
 174
 175 private:
 176   bool CheckSubscriptExpr(
 177       const std::optional<evaluate::IndirectSubscriptIntegerExpr> &x) const {
 178     return !x || CheckSubscriptExpr(*x);
 179   }
 180   bool CheckSubscriptExpr(
 181       const evaluate::IndirectSubscriptIntegerExpr &expr) const {
 182     return CheckSubscriptExpr(expr.value());
 183   }
 184   bool CheckSubscriptExpr(
 185       const evaluate::Expr<evaluate::SubscriptInteger> &expr) const {
 186     if (!evaluate::IsConstantExpr(expr)) { // C875,C881
 187       context_.Say(
 188           source_, "Data object must have constant subscripts"_err_en_US);
 189       return false;
 190     } else {
 191       return true;
 192     }
 193   }
 194
 195   SemanticsContext &context_;
 196   parser::CharBlock source_;
 197   bool hasComponent_{false};
 198   bool hasSubscript_{false};
 199   bool isPointerAllowed_{true};
 200   bool isFirstSymbol_{true};
 201   bool isFunctionAllowed_{false};
 202 };
 203
 204 static bool IsValidDataObject(const SomeExpr &expr) { // C878, C879
 205   return !evaluate::IsConstantExpr(expr) &&
 206       (evaluate::IsVariable(expr) || evaluate::IsProcedurePointer(expr));
 207 }
 208
 209 void DataChecker::Leave(const parser::DataIDoObject &object) {
 210   if (const auto *designator{
 211           std::get_if<parser::Scalar<common::Indirection<parser::Designator>>>(
 212               &object.u)}) {
 213     if (MaybeExpr expr{exprAnalyzer_.Analyze(*designator)}) {
 214       auto source{designator->thing.value().source};
 215       DataVarChecker checker{exprAnalyzer_.context(), source};
 216       if (checker(*expr)) {
 217         if (checker.HasComponentWithoutSubscripts()) { // C880
 218           exprAnalyzer_.context().Say(source,
 219               "Data implied do structure component must be subscripted"_err_en_US);
 220         } else if (!IsValidDataObject(*expr)) {
 221           exprAnalyzer_.context().Say(
 222               source, "Data implied do object must be a variable"_err_en_US);
 223         } else {
 224           return;
 225         }
 226       }
 227     }
 228     currentSetHasFatalErrors_ = true;
 229   }
 230 }
 231
 232 void DataChecker::Leave(const parser::DataStmtObject &dataObject) {
 233   common::visit(
 234       common::visitors{
 235           [](const parser::DataImpliedDo &) { // has own Enter()/Leave()
 236           },
 237           [&](const auto &var) {
 238             auto expr{exprAnalyzer_.Analyze(var)};
 239             auto source{parser::FindSourceLocation(dataObject)};
 240             if (!expr ||
 241                 !DataVarChecker{exprAnalyzer_.context(), source}(*expr)) {
 242               currentSetHasFatalErrors_ = true;
 243             } else if (!IsValidDataObject(*expr)) {
 244               exprAnalyzer_.context().Say(
 245                   source, "Data statement object must be a variable"_err_en_US);
 246               currentSetHasFatalErrors_ = true;
 247             }
 248           },
 249       },
 250       dataObject.u);
 251 }
 252
 253 void DataChecker::Leave(const parser::DataStmtSet &set) {
 254   if (!currentSetHasFatalErrors_) {
 255     AccumulateDataInitializations(inits_, exprAnalyzer_, set);
 256   }
 257   currentSetHasFatalErrors_ = false;
 258 }
 259
 260 // Handle legacy DATA-style initialization, e.g. REAL PI/3.14159/, for
 261 // variables and components (esp. for DEC STRUCTUREs)
 262 template <typename A> void DataChecker::LegacyDataInit(const A &decl) {
 263   if (const auto &init{
 264           std::get<std::optional<parser::Initialization>>(decl.t)}) {
 265     const Symbol *name{std::get<parser::Name>(decl.t).symbol};
 266     const auto *list{
 267         std::get_if<std::list<common::Indirection<parser::DataStmtValue>>>(
 268             &init->u)};
 269     if (name && list) {
 270       AccumulateDataInitializations(inits_, exprAnalyzer_, *name, *list);
 271     }
 272   }
 273 }
 274
 275 void DataChecker::Leave(const parser::ComponentDecl &decl) {
 276   LegacyDataInit(decl);
 277 }
 278
 279 void DataChecker::Leave(const parser::EntityDecl &decl) {
 280   LegacyDataInit(decl);
 281 }
 282
 283 void DataChecker::CompileDataInitializationsIntoInitializers() {
 284   ConvertToInitializers(inits_, exprAnalyzer_);
 285 }
 286
 287 } // namespace Fortran::semantics