1//===-- lib/Semantics/definable.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 "definable.h"
10#include "flang/Evaluate/tools.h"
11#include "flang/Semantics/tools.h"
12
13using namespace Fortran::parser::literals;
14
15namespace Fortran::semantics {
16
17template <typename... A>
18static parser::Message BlameSymbol(parser::CharBlock at,
19 const parser::MessageFixedText &text, const Symbol &original, A &&...x) {
20 parser::Message message{at, text, original.name(), std::forward<A>(x)...};
21 message.set_severity(parser::Severity::Because);
22 evaluate::AttachDeclaration(message, original);
23 return message;
24}
25
26static bool IsPointerDummyOfPureFunction(const Symbol &x) {
27 return IsPointerDummy(x) && FindPureProcedureContaining(x.owner()) &&
28 x.owner().symbol() && IsFunction(*x.owner().symbol());
29}
30
31// See C1594, first paragraph. These conditions enable checks on both
32// left-hand and right-hand sides in various circumstances.
33const char *WhyBaseObjectIsSuspicious(const Symbol &x, const Scope &scope) {
34 if (IsHostAssociatedIntoSubprogram(x, scope)) {
35 return "host-associated";
36 } else if (IsUseAssociated(x, scope)) {
37 return "USE-associated";
38 } else if (IsPointerDummyOfPureFunction(x)) {
39 return "a POINTER dummy argument of a pure function";
40 } else if (IsIntentIn(x)) {
41 return "an INTENT(IN) dummy argument";
42 } else if (FindCommonBlockContaining(x)) {
43 return "in a COMMON block";
44 } else {
45 return nullptr;
46 }
47}
48
49// Checks C1594(1,2); false if check fails
50static std::optional<parser::Message> CheckDefinabilityInPureScope(
51 SourceName at, const Symbol &original, const Symbol &ultimate,
52 const Scope &context, const Scope &pure) {
53 if (pure.symbol()) {
54 if (const char *why{WhyBaseObjectIsSuspicious(x: ultimate, scope: context)}) {
55 return BlameSymbol(at,
56 "'%s' may not be defined in pure subprogram '%s' because it is %s"_en_US,
57 original, pure.symbol()->name(), why);
58 }
59 }
60 return std::nullopt;
61}
62
63// True when the object being defined is not a subobject of the base
64// object, e.g. X%PTR = 1., X%PTR%PTR2 => T (but not X%PTR => T).
65// F'2023 9.4.2p5
66static bool DefinesComponentPointerTarget(
67 const evaluate::DataRef &dataRef, DefinabilityFlags flags) {
68 if (const evaluate::Component *
69 component{common::visit(
70 common::visitors{
71 [](const SymbolRef &) -> const evaluate::Component * {
72 return nullptr;
73 },
74 [](const evaluate::Component &component) { return &component; },
75 [](const evaluate::ArrayRef &aRef) {
76 return aRef.base().UnwrapComponent();
77 },
78 [](const evaluate::CoarrayRef &aRef)
79 -> const evaluate::Component * { return nullptr; },
80 },
81 dataRef.u)}) {
82 const Symbol &compSym{component->GetLastSymbol()};
83 if (IsPointer(compSym) ||
84 (flags.test(DefinabilityFlag::AcceptAllocatable) &&
85 IsAllocatable(compSym))) {
86 if (!flags.test(DefinabilityFlag::PointerDefinition)) {
87 return true;
88 }
89 }
90 flags.reset(DefinabilityFlag::PointerDefinition);
91 return DefinesComponentPointerTarget(component->base(), flags);
92 } else {
93 return false;
94 }
95}
96
97// Check the leftmost (or only) symbol from a data-ref or expression.
98static std::optional<parser::Message> WhyNotDefinableBase(parser::CharBlock at,
99 const Scope &scope, DefinabilityFlags flags, const Symbol &original,
100 bool isWholeSymbol, bool isComponentPointerTarget) {
101 const Symbol &ultimate{original.GetUltimate()};
102 bool isPointerDefinition{flags.test(DefinabilityFlag::PointerDefinition)};
103 bool acceptAllocatable{flags.test(DefinabilityFlag::AcceptAllocatable)};
104 bool isTargetDefinition{!isPointerDefinition && IsPointer(ultimate)};
105 if (const auto *association{ultimate.detailsIf<AssocEntityDetails>()}) {
106 if (!IsVariable(association->expr())) {
107 return BlameSymbol(at,
108 "'%s' is construct associated with an expression"_en_US, original);
109 } else if (evaluate::HasVectorSubscript(association->expr().value())) {
110 return BlameSymbol(at,
111 "Construct association '%s' has a vector subscript"_en_US, original);
112 } else if (auto dataRef{evaluate::ExtractDataRef(
113 *association->expr(), true, true)}) {
114 return WhyNotDefinableBase(at, scope, flags, dataRef->GetFirstSymbol(),
115 isWholeSymbol &&
116 std::holds_alternative<evaluate::SymbolRef>(dataRef->u),
117 isComponentPointerTarget ||
118 DefinesComponentPointerTarget(*dataRef, flags));
119 }
120 }
121 if (isTargetDefinition || isComponentPointerTarget) {
122 } else if (!isPointerDefinition && !IsVariableName(ultimate)) {
123 return BlameSymbol(at, "'%s' is not a variable"_en_US, original);
124 } else if (IsProtected(ultimate) && IsUseAssociated(original, scope)) {
125 return BlameSymbol(at, "'%s' is protected in this scope"_en_US, original);
126 } else if (IsIntentIn(ultimate) &&
127 (!IsPointer(ultimate) || (isWholeSymbol && isPointerDefinition))) {
128 return BlameSymbol(
129 at, "'%s' is an INTENT(IN) dummy argument"_en_US, original);
130 }
131 if (const Scope * pure{FindPureProcedureContaining(scope)}) {
132 // Additional checking for pure subprograms.
133 if (!isTargetDefinition || isComponentPointerTarget) {
134 if (auto msg{CheckDefinabilityInPureScope(
135 at, original, ultimate, scope, *pure)}) {
136 return msg;
137 }
138 }
139 if (const Symbol *
140 visible{FindExternallyVisibleObject(
141 ultimate, *pure, isPointerDefinition)}) {
142 return BlameSymbol(at,
143 "'%s' is externally visible via '%s' and not definable in a pure subprogram"_en_US,
144 original, visible->name());
145 }
146 }
147 if (const Scope * deviceContext{FindCUDADeviceContext(&scope)}) {
148 bool isOwnedByDeviceCode{deviceContext->Contains(ultimate.owner())};
149 if (isPointerDefinition && !acceptAllocatable) {
150 return BlameSymbol(at,
151 "'%s' is a pointer and may not be associated in a device subprogram"_err_en_US,
152 original);
153 } else if (auto cudaDataAttr{GetCUDADataAttr(&ultimate)}) {
154 if (*cudaDataAttr == common::CUDADataAttr::Constant) {
155 return BlameSymbol(at,
156 "'%s' has ATTRIBUTES(CONSTANT) and is not definable in a device subprogram"_err_en_US,
157 original);
158 } else if (acceptAllocatable && !isOwnedByDeviceCode) {
159 return BlameSymbol(at,
160 "'%s' is a host-associated allocatable and is not definable in a device subprogram"_err_en_US,
161 original);
162 } else if (*cudaDataAttr != common::CUDADataAttr::Device &&
163 *cudaDataAttr != common::CUDADataAttr::Managed &&
164 *cudaDataAttr != common::CUDADataAttr::Shared) {
165 return BlameSymbol(at,
166 "'%s' is not device or managed or shared data and is not definable in a device subprogram"_err_en_US,
167 original);
168 }
169 } else if (!isOwnedByDeviceCode) {
170 return BlameSymbol(at,
171 "'%s' is a host variable and is not definable in a device subprogram"_err_en_US,
172 original);
173 }
174 }
175 return std::nullopt;
176}
177
178static std::optional<parser::Message> WhyNotDefinableLast(parser::CharBlock at,
179 const Scope &scope, DefinabilityFlags flags, const Symbol &original) {
180 const Symbol &ultimate{original.GetUltimate()};
181 if (const auto *association{ultimate.detailsIf<AssocEntityDetails>()}) {
182 if (auto dataRef{
183 evaluate::ExtractDataRef(*association->expr(), true, true)}) {
184 return WhyNotDefinableLast(at, scope, flags, dataRef->GetLastSymbol());
185 }
186 }
187 if (flags.test(DefinabilityFlag::PointerDefinition)) {
188 if (flags.test(DefinabilityFlag::AcceptAllocatable)) {
189 if (!IsAllocatableOrObjectPointer(&ultimate)) {
190 return BlameSymbol(
191 at, "'%s' is neither a pointer nor an allocatable"_en_US, original);
192 }
193 } else if (!IsPointer(ultimate)) {
194 return BlameSymbol(at, "'%s' is not a pointer"_en_US, original);
195 }
196 return std::nullopt; // pointer assignment - skip following checks
197 }
198 if (IsOrContainsEventOrLockComponent(ultimate)) {
199 return BlameSymbol(at,
200 "'%s' is an entity with either an EVENT_TYPE or LOCK_TYPE"_en_US,
201 original);
202 }
203 if (FindPureProcedureContaining(scope)) {
204 if (auto dyType{evaluate::DynamicType::From(ultimate)}) {
205 if (!flags.test(DefinabilityFlag::PolymorphicOkInPure)) {
206 if (dyType->IsPolymorphic()) { // C1596
207 return BlameSymbol(at,
208 "'%s' is polymorphic in a pure subprogram"_because_en_US,
209 original);
210 }
211 }
212 if (const Symbol * impure{HasImpureFinal(ultimate)}) {
213 return BlameSymbol(at,
214 "'%s' has an impure FINAL procedure '%s'"_because_en_US, original,
215 impure->name());
216 }
217 if (const DerivedTypeSpec * derived{GetDerivedTypeSpec(dyType)}) {
218 if (!flags.test(DefinabilityFlag::PolymorphicOkInPure)) {
219 if (auto bad{FindPolymorphicAllocatableUltimateComponent(*derived)}) {
220 return BlameSymbol(at,
221 "'%s' has polymorphic component '%s' in a pure subprogram"_because_en_US,
222 original, bad.BuildResultDesignatorName());
223 }
224 }
225 }
226 }
227 }
228 return std::nullopt;
229}
230
231// Checks a data-ref
232static std::optional<parser::Message> WhyNotDefinable(parser::CharBlock at,
233 const Scope &scope, DefinabilityFlags flags,
234 const evaluate::DataRef &dataRef) {
235 if (auto whyNot{
236 WhyNotDefinableBase(at, scope, flags, dataRef.GetFirstSymbol(),
237 std::holds_alternative<evaluate::SymbolRef>(dataRef.u),
238 DefinesComponentPointerTarget(dataRef, flags))}) {
239 return whyNot;
240 } else {
241 return WhyNotDefinableLast(at, scope, flags, dataRef.GetLastSymbol());
242 }
243}
244
245std::optional<parser::Message> WhyNotDefinable(parser::CharBlock at,
246 const Scope &scope, DefinabilityFlags flags, const Symbol &original) {
247 if (auto base{WhyNotDefinableBase(at, scope, flags, original,
248 /*isWholeSymbol=*/true, /*isComponentPointerTarget=*/false)}) {
249 return base;
250 } else {
251 return WhyNotDefinableLast(at, scope, flags, original);
252 }
253}
254
255class DuplicatedSubscriptFinder
256 : public evaluate::AnyTraverse<DuplicatedSubscriptFinder, bool> {
257 using Base = evaluate::AnyTraverse<DuplicatedSubscriptFinder, bool>;
258
259public:
260 explicit DuplicatedSubscriptFinder(evaluate::FoldingContext &foldingContext)
261 : Base{*this}, foldingContext_{foldingContext} {}
262 using Base::operator();
263 bool operator()(const evaluate::ActualArgument &) {
264 return false; // don't descend into argument expressions
265 }
266 bool operator()(const evaluate::ArrayRef &aRef) {
267 bool anyVector{false};
268 for (const auto &ss : aRef.subscript()) {
269 if (ss.Rank() > 0) {
270 anyVector = true;
271 if (const auto *vecExpr{
272 std::get_if<evaluate::IndirectSubscriptIntegerExpr>(&ss.u)}) {
273 auto folded{evaluate::Fold(foldingContext_,
274 evaluate::Expr<evaluate::SubscriptInteger>{vecExpr->value()})};
275 if (const auto *con{
276 evaluate::UnwrapConstantValue<evaluate::SubscriptInteger>(
277 folded)}) {
278 std::set<std::int64_t> values;
279 for (const auto &j : con->values()) {
280 if (auto pair{values.emplace(j.ToInt64())}; !pair.second) {
281 return true; // duplicate
282 }
283 }
284 }
285 return false;
286 }
287 }
288 }
289 return anyVector ? false : (*this)(aRef.base());
290 }
291
292private:
293 evaluate::FoldingContext &foldingContext_;
294};
295
296std::optional<parser::Message> WhyNotDefinable(parser::CharBlock at,
297 const Scope &scope, DefinabilityFlags flags,
298 const evaluate::Expr<evaluate::SomeType> &expr) {
299 if (auto dataRef{evaluate::ExtractDataRef(expr, true, true)}) {
300 if (evaluate::HasVectorSubscript(expr)) {
301 if (flags.test(DefinabilityFlag::VectorSubscriptIsOk)) {
302 if (auto type{expr.GetType()}) {
303 if (!type->IsUnlimitedPolymorphic() &&
304 type->category() == TypeCategory::Derived) {
305 // Seek the FINAL subroutine that should but cannot be called
306 // for this definition of an array with a vector-valued subscript.
307 // If there's an elemental FINAL subroutine, all is well; otherwise,
308 // if there is a FINAL subroutine with a matching or assumed rank
309 // dummy argument, there's no way to call it.
310 int rank{expr.Rank()};
311 const DerivedTypeSpec *spec{&type->GetDerivedTypeSpec()};
312 while (spec) {
313 bool anyElemental{false};
314 const Symbol *anyRankMatch{nullptr};
315 for (auto ref : FinalsForDerivedTypeInstantiation(*spec)) {
316 const Symbol &ultimate{ref->GetUltimate()};
317 anyElemental |= ultimate.attrs().test(Attr::ELEMENTAL);
318 if (const auto *subp{ultimate.detailsIf<SubprogramDetails>()}) {
319 if (!subp->dummyArgs().empty()) {
320 if (const Symbol * arg{subp->dummyArgs()[0]}) {
321 const auto *object{arg->detailsIf<ObjectEntityDetails>()};
322 if (arg->Rank() == rank ||
323 (object && object->IsAssumedRank())) {
324 anyRankMatch = &*ref;
325 }
326 }
327 }
328 }
329 }
330 if (anyRankMatch && !anyElemental) {
331 return parser::Message{at,
332 "Variable '%s' has a vector subscript and cannot be finalized by non-elemental subroutine '%s'"_because_en_US,
333 expr.AsFortran(), anyRankMatch->name()};
334 }
335 const auto *parent{FindParentTypeSpec(*spec)};
336 spec = parent ? parent->AsDerived() : nullptr;
337 }
338 }
339 }
340 if (!flags.test(DefinabilityFlag::DuplicatesAreOk) &&
341 DuplicatedSubscriptFinder{scope.context().foldingContext()}(expr)) {
342 return parser::Message{at,
343 "Variable has a vector subscript with a duplicated element"_because_en_US};
344 }
345 } else {
346 return parser::Message{at,
347 "Variable '%s' has a vector subscript"_because_en_US,
348 expr.AsFortran()};
349 }
350 }
351 if (FindPureProcedureContaining(scope) &&
352 evaluate::ExtractCoarrayRef(expr)) {
353 return parser::Message(at,
354 "A pure subprogram may not define the coindexed object '%s'"_because_en_US,
355 expr.AsFortran());
356 }
357 return WhyNotDefinable(at, scope, flags, *dataRef);
358 } else if (evaluate::IsNullPointer(expr)) {
359 return parser::Message{
360 at, "'%s' is a null pointer"_because_en_US, expr.AsFortran()};
361 } else if (flags.test(DefinabilityFlag::PointerDefinition)) {
362 if (const auto *procDesignator{
363 std::get_if<evaluate::ProcedureDesignator>(&expr.u)}) {
364 // Defining a procedure pointer
365 if (const Symbol * procSym{procDesignator->GetSymbol()}) {
366 if (evaluate::ExtractCoarrayRef(expr)) { // C1027
367 return BlameSymbol(at,
368 "Procedure pointer '%s' may not be a coindexed object"_because_en_US,
369 *procSym, expr.AsFortran());
370 }
371 if (const auto *component{procDesignator->GetComponent()}) {
372 flags.reset(DefinabilityFlag::PointerDefinition);
373 return WhyNotDefinableBase(at, scope, flags,
374 component->base().GetFirstSymbol(), false,
375 DefinesComponentPointerTarget(component->base(), flags));
376 } else {
377 return WhyNotDefinable(at, scope, flags, *procSym);
378 }
379 }
380 }
381 return parser::Message{
382 at, "'%s' is not a definable pointer"_because_en_US, expr.AsFortran()};
383 } else if (!evaluate::IsVariable(expr)) {
384 return parser::Message{at,
385 "'%s' is not a variable or pointer"_because_en_US, expr.AsFortran()};
386 } else {
387 return std::nullopt;
388 }
389}
390
391} // namespace Fortran::semantics
392

source code of flang/lib/Semantics/definable.cpp