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