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 {
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
175private:
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
204static bool IsValidDataObject(const SomeExpr &expr) { // C878, C879
205 return !evaluate::IsConstantExpr(expr) &&
206 (evaluate::IsVariable(expr) || evaluate::IsProcedurePointer(expr));
207}
208
209void 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
232void 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
253void 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)
262template <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
275void DataChecker::Leave(const parser::ComponentDecl &decl) {
276 LegacyDataInit(decl);
277}
278
279void DataChecker::Leave(const parser::EntityDecl &decl) {
280 LegacyDataInit(decl);
281}
282
283void DataChecker::CompileDataInitializationsIntoInitializers() {
284 ConvertToInitializers(inits_, exprAnalyzer_);
285}
286
287} // namespace Fortran::semantics
288

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