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

source code of flang/lib/Semantics/check-data.cpp