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