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.
Enter(const parser::DataImpliedDo & x)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
Leave(const parser::DataImpliedDo & x)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>;
DataVarChecker(SemanticsContext & c,parser::CharBlock src)49 DataVarChecker(SemanticsContext &c, parser::CharBlock src)
50 : Base{*this}, context_{c}, source_{src} {}
51 using Base::operator();
HasComponentWithoutSubscripts() const52 bool HasComponentWithoutSubscripts() const {
53 return hasComponent_ && !hasSubscript_;
54 }
operator ()(const Symbol & symbol)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 }
operator ()(const evaluate::Component & component)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 }
operator ()(const evaluate::ArrayRef & arrayRef)105 bool operator()(const evaluate::ArrayRef &arrayRef) {
106 hasSubscript_ = true;
107 return (*this)(arrayRef.base()) && (*this)(arrayRef.subscript());
108 }
operator ()(const evaluate::Substring & substring)109 bool operator()(const evaluate::Substring &substring) {
110 hasSubscript_ = true;
111 return (*this)(substring.parent()) && (*this)(substring.lower()) &&
112 (*this)(substring.upper());
113 }
operator ()(const evaluate::CoarrayRef &)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 }
operator ()(const evaluate::Subscript & subs)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>
operator ()(const evaluate::FunctionRef<T> &) const137 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 }
RestrictPointer()142 void RestrictPointer() { isPointerAllowed_ = false; }
143
144 private:
CheckSubscriptExpr(const std::optional<evaluate::IndirectSubscriptIntegerExpr> & x) const145 bool CheckSubscriptExpr(
146 const std::optional<evaluate::IndirectSubscriptIntegerExpr> &x) const {
147 return !x || CheckSubscriptExpr(*x);
148 }
CheckSubscriptExpr(const evaluate::IndirectSubscriptIntegerExpr & expr) const149 bool CheckSubscriptExpr(
150 const evaluate::IndirectSubscriptIntegerExpr &expr) const {
151 return CheckSubscriptExpr(expr.value());
152 }
CheckSubscriptExpr(const evaluate::Expr<evaluate::SubscriptInteger> & expr) const153 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
Leave(const parser::DataIDoObject & object)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
Leave(const parser::DataStmtObject & dataObject)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
Leave(const parser::DataStmtSet & set)213 void DataChecker::Leave(const parser::DataStmtSet &set) {
214 if (!currentSetHasFatalErrors_) {
215 AccumulateDataInitializations(inits_, exprAnalyzer_, set);
216 }
217 currentSetHasFatalErrors_ = false;
218 }
219
CompileDataInitializationsIntoInitializers()220 void DataChecker::CompileDataInitializationsIntoInitializers() {
221 ConvertToInitializers(inits_, exprAnalyzer_);
222 }
223
224 } // namespace Fortran::semantics
225