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 |
288 | |