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 #include "check-data.h"
10 #include "flang/Evaluate/traverse.h"
11 #include "flang/Semantics/expression.h"
12 
13 namespace Fortran::semantics {
14 
15 void DataChecker::Leave(const parser::DataStmtConstant &dataConst) {
16   if (auto *structure{
17           std::get_if<parser::StructureConstructor>(&dataConst.u)}) {
18     for (const auto &component :
19         std::get<std::list<parser::ComponentSpec>>(structure->t)) {
20       const parser::Expr &parsedExpr{
21           std::get<parser::ComponentDataSource>(component.t).v.value()};
22       if (const auto *expr{GetExpr(parsedExpr)}) {
23         if (!evaluate::IsConstantExpr(*expr)) { // C884
24           exprAnalyzer_.Say(parsedExpr.source,
25               "Structure constructor in data value must be a constant expression"_err_en_US);
26         }
27       }
28     }
29   }
30 }
31 
32 // Ensures that references to an implied DO loop control variable are
33 // represented as such in the "body" of the implied DO loop.
34 void DataChecker::Enter(const parser::DataImpliedDo &x) {
35   auto name{std::get<parser::DataImpliedDo::Bounds>(x.t).name.thing.thing};
36   int kind{evaluate::ResultType<evaluate::ImpliedDoIndex>::kind};
37   if (const auto dynamicType{evaluate::DynamicType::From(*name.symbol)}) {
38     kind = dynamicType->kind();
39   }
40   exprAnalyzer_.AddImpliedDo(name.source, kind);
41 }
42 
43 void DataChecker::Leave(const parser::DataImpliedDo &x) {
44   auto name{std::get<parser::DataImpliedDo::Bounds>(x.t).name.thing.thing};
45   exprAnalyzer_.RemoveImpliedDo(name.source);
46 }
47 
48 class DataVarChecker : public evaluate::AllTraverse<DataVarChecker, true> {
49 public:
50   using Base = evaluate::AllTraverse<DataVarChecker, true>;
51   DataVarChecker(SemanticsContext &c, parser::CharBlock src)
52       : Base{*this}, context_{c}, source_{src} {}
53   using Base::operator();
54   bool HasComponentWithoutSubscripts() const {
55     return hasComponent_ && !hasSubscript_;
56   }
57   bool operator()(const evaluate::Component &component) {
58     hasComponent_ = true;
59     const Symbol &lastSymbol{component.GetLastSymbol()};
60     if (isPointerAllowed_) {
61       if (IsPointer(lastSymbol) && hasSubscript_) { // C877
62         context_.Say(source_,
63             "Rightmost data object pointer '%s' must not be subscripted"_err_en_US,
64             lastSymbol.name().ToString());
65         return false;
66       }
67       RestrictPointer();
68     } else {
69       if (IsPointer(lastSymbol)) { // C877
70         context_.Say(source_,
71             "Data object must not contain pointer '%s' as a non-rightmost part"_err_en_US,
72             lastSymbol.name().ToString());
73         return false;
74       }
75     }
76     if (!isFirstSymbolChecked_) {
77       isFirstSymbolChecked_ = true;
78       if (!CheckFirstSymbol(component.GetFirstSymbol())) {
79         return false;
80       }
81     }
82     return (*this)(component.base()) && (*this)(lastSymbol);
83   }
84   bool operator()(const evaluate::ArrayRef &arrayRef) {
85     hasSubscript_ = true;
86     return (*this)(arrayRef.base()) && (*this)(arrayRef.subscript());
87   }
88   bool operator()(const evaluate::Substring &substring) {
89     hasSubscript_ = true;
90     return (*this)(substring.parent()) && (*this)(substring.lower()) &&
91         (*this)(substring.upper());
92   }
93   bool operator()(const evaluate::CoarrayRef &) { // C874
94     hasSubscript_ = true;
95     context_.Say(
96         source_, "Data object must not be a coindexed variable"_err_en_US);
97     return false;
98   }
99   bool operator()(const evaluate::Symbol &symbol) {
100     if (!isFirstSymbolChecked_) {
101       return CheckFirstSymbol(symbol) && CheckAnySymbol(symbol);
102     } else {
103       return CheckAnySymbol(symbol);
104     }
105   }
106   bool operator()(const evaluate::Subscript &subs) {
107     DataVarChecker subscriptChecker{context_, source_};
108     subscriptChecker.RestrictPointer();
109     return std::visit(
110                common::visitors{
111                    [&](const evaluate::IndirectSubscriptIntegerExpr &expr) {
112                      return CheckSubscriptExpr(expr);
113                    },
114                    [&](const evaluate::Triplet &triplet) {
115                      return CheckSubscriptExpr(triplet.lower()) &&
116                          CheckSubscriptExpr(triplet.upper()) &&
117                          CheckSubscriptExpr(triplet.stride());
118                    },
119                },
120                subs.u) &&
121         subscriptChecker(subs.u);
122   }
123   template <typename T>
124   bool operator()(const evaluate::FunctionRef<T> &) const { // C875
125     context_.Say(source_,
126         "Data object variable must not be a function reference"_err_en_US);
127     return false;
128   }
129   void RestrictPointer() { isPointerAllowed_ = false; }
130 
131 private:
132   bool CheckSubscriptExpr(
133       const std::optional<evaluate::IndirectSubscriptIntegerExpr> &x) const {
134     return !x || CheckSubscriptExpr(*x);
135   }
136   bool CheckSubscriptExpr(
137       const evaluate::IndirectSubscriptIntegerExpr &expr) const {
138     return CheckSubscriptExpr(expr.value());
139   }
140   bool CheckSubscriptExpr(
141       const evaluate::Expr<evaluate::SubscriptInteger> &expr) const {
142     if (!evaluate::IsConstantExpr(expr)) { // C875,C881
143       context_.Say(
144           source_, "Data object must have constant subscripts"_err_en_US);
145       return false;
146     } else {
147       return true;
148     }
149   }
150   bool CheckFirstSymbol(const Symbol &symbol);
151   bool CheckAnySymbol(const Symbol &symbol);
152 
153   SemanticsContext &context_;
154   parser::CharBlock source_;
155   bool hasComponent_{false};
156   bool hasSubscript_{false};
157   bool isPointerAllowed_{true};
158   bool isFirstSymbolChecked_{false};
159 };
160 
161 bool DataVarChecker::CheckFirstSymbol(const Symbol &symbol) { // C876
162   const Scope &scope{context_.FindScope(source_)};
163   if (IsDummy(symbol)) {
164     context_.Say(source_,
165         "Data object part '%s' must not be a dummy argument"_err_en_US,
166         symbol.name().ToString());
167   } else if (IsFunction(symbol)) {
168     context_.Say(source_,
169         "Data object part '%s' must not be a function name"_err_en_US,
170         symbol.name().ToString());
171   } else if (symbol.IsFuncResult()) {
172     context_.Say(source_,
173         "Data object part '%s' must not be a function result"_err_en_US,
174         symbol.name().ToString());
175   } else if (IsHostAssociated(symbol, scope)) {
176     context_.Say(source_,
177         "Data object part '%s' must not be accessed by host association"_err_en_US,
178         symbol.name().ToString());
179   } else if (IsUseAssociated(symbol, scope)) {
180     context_.Say(source_,
181         "Data object part '%s' must not be accessed by use association"_err_en_US,
182         symbol.name().ToString());
183   } else if (IsInBlankCommon(symbol)) {
184     context_.Say(source_,
185         "Data object part '%s' must not be in blank COMMON"_err_en_US,
186         symbol.name().ToString());
187   } else {
188     return true;
189   }
190   return false;
191 }
192 
193 bool DataVarChecker::CheckAnySymbol(const Symbol &symbol) { // C876
194   if (IsAutomaticObject(symbol)) {
195     context_.Say(source_,
196         "Data object part '%s' must not be an automatic object"_err_en_US,
197         symbol.name().ToString());
198   } else if (IsAllocatable(symbol)) {
199     context_.Say(source_,
200         "Data object part '%s' must not be an allocatable object"_err_en_US,
201         symbol.name().ToString());
202   } else {
203     return true;
204   }
205   return false;
206 }
207 
208 void DataChecker::Leave(const parser::DataIDoObject &object) {
209   if (const auto *designator{
210           std::get_if<parser::Scalar<common::Indirection<parser::Designator>>>(
211               &object.u)}) {
212     if (MaybeExpr expr{exprAnalyzer_.Analyze(*designator)}) {
213       auto source{designator->thing.value().source};
214       if (evaluate::IsConstantExpr(*expr)) { // C878,C879
215         exprAnalyzer_.Say(
216             source, "Data implied do object must be a variable"_err_en_US);
217       } else {
218         DataVarChecker checker{exprAnalyzer_.context(), source};
219         if (checker(*expr) && checker.HasComponentWithoutSubscripts()) { // C880
220           exprAnalyzer_.Say(source,
221               "Data implied do structure component must be subscripted"_err_en_US);
222         }
223       }
224     }
225   }
226 }
227 
228 void DataChecker::Leave(const parser::DataStmtObject &dataObject) {
229   if (const auto *var{
230           std::get_if<common::Indirection<parser::Variable>>(&dataObject.u)}) {
231     if (auto expr{exprAnalyzer_.Analyze(*var)}) {
232       DataVarChecker{exprAnalyzer_.context(),
233           parser::FindSourceLocation(dataObject)}(expr);
234     }
235   }
236 }
237 
238 void DataChecker::Leave(const parser::DataStmtRepeat &dataRepeat) {
239   if (const auto *designator{parser::Unwrap<parser::Designator>(dataRepeat)}) {
240     if (auto *dataRef{std::get_if<parser::DataRef>(&designator->u)}) {
241       if (MaybeExpr checked{exprAnalyzer_.Analyze(*dataRef)}) {
242         auto expr{evaluate::Fold(
243             exprAnalyzer_.GetFoldingContext(), std::move(checked))};
244         if (auto i64{ToInt64(expr)}) {
245           if (*i64 < 0) { // C882
246             exprAnalyzer_.Say(designator->source,
247                 "Repeat count for data value must not be negative"_err_en_US);
248           }
249         }
250       }
251     }
252   }
253 }
254 } // namespace Fortran::semantics
255