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