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::Error);
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 } else if (acceptAllocatable && IsAllocatable(ultimate) &&
131 !flags.test(DefinabilityFlag::SourcedAllocation)) {
132 // allocating a function result doesn't count as a def'n
133 // unless there's SOURCE=
134 } else if (!flags.test(DefinabilityFlag::DoNotNoteDefinition)) {
135 scope.context().NoteDefinedSymbol(ultimate);
136 }
137 if (const Scope * pure{FindPureProcedureContaining(scope)}) {
138 // Additional checking for pure subprograms.
139 if (!isTargetDefinition || isComponentPointerTarget) {
140 if (auto msg{CheckDefinabilityInPureScope(
141 at, original, ultimate, scope, *pure)}) {
142 return msg;
143 }
144 }
145 if (const Symbol *
146 visible{FindExternallyVisibleObject(
147 ultimate, *pure, isPointerDefinition)}) {
148 return BlameSymbol(at,
149 "'%s' is externally visible via '%s' and not definable in a pure subprogram"_en_US,
150 original, visible->name());
151 }
152 }
153 if (const Scope * deviceContext{FindCUDADeviceContext(&scope)}) {
154 bool isOwnedByDeviceCode{deviceContext->Contains(ultimate.owner())};
155 if (isPointerDefinition && !acceptAllocatable) {
156 return BlameSymbol(at,
157 "'%s' is a pointer and may not be associated in a device subprogram"_err_en_US,
158 original);
159 } else if (auto cudaDataAttr{GetCUDADataAttr(&ultimate)}) {
160 if (*cudaDataAttr == common::CUDADataAttr::Constant) {
161 return BlameSymbol(at,
162 "'%s' has ATTRIBUTES(CONSTANT) and is not definable in a device subprogram"_err_en_US,
163 original);
164 } else if (acceptAllocatable && !isOwnedByDeviceCode) {
165 return BlameSymbol(at,
166 "'%s' is a host-associated allocatable and is not definable in a device subprogram"_err_en_US,
167 original);
168 } else if (*cudaDataAttr != common::CUDADataAttr::Device &&
169 *cudaDataAttr != common::CUDADataAttr::Managed &&
170 *cudaDataAttr != common::CUDADataAttr::Shared) {
171 return BlameSymbol(at,
172 "'%s' is not device or managed or shared data and is not definable in a device subprogram"_err_en_US,
173 original);
174 }
175 } else if (!isOwnedByDeviceCode) {
176 return BlameSymbol(at,
177 "'%s' is a host variable and is not definable in a device subprogram"_err_en_US,
178 original);
179 }
180 }
181 return std::nullopt;
182}
183
184static std::optional<parser::Message> WhyNotDefinableLast(parser::CharBlock at,
185 const Scope &scope, DefinabilityFlags flags, const Symbol &original) {
186 const Symbol &ultimate{original.GetUltimate()};
187 if (const auto *association{ultimate.detailsIf<AssocEntityDetails>()};
188 association &&
189 (association->rank().has_value() ||
190 !flags.test(DefinabilityFlag::PointerDefinition))) {
191 if (auto dataRef{
192 evaluate::ExtractDataRef(*association->expr(), true, true)}) {
193 return WhyNotDefinableLast(at, scope, flags, dataRef->GetLastSymbol());
194 }
195 }
196 auto dyType{evaluate::DynamicType::From(ultimate)};
197 const auto *inPure{FindPureProcedureContaining(scope)};
198 if (inPure && !flags.test(DefinabilityFlag::PolymorphicOkInPure) &&
199 flags.test(DefinabilityFlag::PotentialDeallocation) && dyType &&
200 dyType->IsPolymorphic()) {
201 return BlameSymbol(at,
202 "'%s' is a whole polymorphic object in a pure subprogram"_en_US,
203 original);
204 }
205 if (flags.test(DefinabilityFlag::PointerDefinition)) {
206 if (flags.test(DefinabilityFlag::AcceptAllocatable)) {
207 if (!IsAllocatableOrObjectPointer(&ultimate)) {
208 return BlameSymbol(
209 at, "'%s' is neither a pointer nor an allocatable"_en_US, original);
210 }
211 } else if (!IsPointer(ultimate)) {
212 return BlameSymbol(at, "'%s' is not a pointer"_en_US, original);
213 }
214 return std::nullopt; // pointer assignment - skip following checks
215 }
216 if (!flags.test(DefinabilityFlag::AllowEventLockOrNotifyType) &&
217 IsOrContainsEventOrLockComponent(ultimate)) {
218 return BlameSymbol(at,
219 "'%s' is an entity with either an EVENT_TYPE or LOCK_TYPE"_en_US,
220 original);
221 }
222 if (dyType && inPure) {
223 if (const Symbol * impure{HasImpureFinal(ultimate)}) {
224 return BlameSymbol(at, "'%s' has an impure FINAL procedure '%s'"_en_US,
225 original, impure->name());
226 }
227 if (!flags.test(DefinabilityFlag::PolymorphicOkInPure)) {
228 if (const DerivedTypeSpec * derived{GetDerivedTypeSpec(dyType)}) {
229 if (auto bad{FindPolymorphicAllocatablePotentialComponent(*derived)}) {
230 return BlameSymbol(at,
231 "'%s' has polymorphic component '%s' in a pure subprogram"_en_US,
232 original, bad.BuildResultDesignatorName());
233 }
234 }
235 }
236 }
237 return std::nullopt;
238}
239
240// Checks a data-ref
241static std::optional<parser::Message> WhyNotDefinable(parser::CharBlock at,
242 const Scope &scope, DefinabilityFlags flags,
243 const evaluate::DataRef &dataRef) {
244 auto whyNotBase{
245 WhyNotDefinableBase(at, scope, flags, dataRef.GetFirstSymbol(),
246 evaluate::UnwrapWholeSymbolDataRef(dataRef) != nullptr,
247 DefinesComponentPointerTarget(dataRef, flags))};
248 if (!whyNotBase || !whyNotBase->IsFatal()) {
249 if (auto whyNotLast{
250 WhyNotDefinableLast(at, scope, flags, dataRef.GetLastSymbol())}) {
251 if (whyNotLast->IsFatal() || !whyNotBase) {
252 return whyNotLast;
253 }
254 }
255 }
256 return whyNotBase;
257}
258
259std::optional<parser::Message> WhyNotDefinable(parser::CharBlock at,
260 const Scope &scope, DefinabilityFlags flags, const Symbol &original) {
261 auto whyNotBase{WhyNotDefinableBase(at, scope, flags, original,
262 /*isWholeSymbol=*/true, /*isComponentPointerTarget=*/false)};
263 if (!whyNotBase || !whyNotBase->IsFatal()) {
264 if (auto whyNotLast{WhyNotDefinableLast(at, scope, flags, original)}) {
265 if (whyNotLast->IsFatal() || !whyNotBase) {
266 return whyNotLast;
267 }
268 }
269 }
270 return whyNotBase;
271}
272
273class DuplicatedSubscriptFinder
274 : public evaluate::AnyTraverse<DuplicatedSubscriptFinder, bool> {
275 using Base = evaluate::AnyTraverse<DuplicatedSubscriptFinder, bool>;
276
277public:
278 explicit DuplicatedSubscriptFinder(evaluate::FoldingContext &foldingContext)
279 : Base{*this}, foldingContext_{foldingContext} {}
280 using Base::operator();
281 bool operator()(const evaluate::ActualArgument &) {
282 return false; // don't descend into argument expressions
283 }
284 bool operator()(const evaluate::ArrayRef &aRef) {
285 bool anyVector{false};
286 for (const auto &ss : aRef.subscript()) {
287 if (ss.Rank() > 0) {
288 anyVector = true;
289 if (const auto *vecExpr{
290 std::get_if<evaluate::IndirectSubscriptIntegerExpr>(&ss.u)}) {
291 auto folded{evaluate::Fold(foldingContext_,
292 evaluate::Expr<evaluate::SubscriptInteger>{vecExpr->value()})};
293 if (const auto *con{
294 evaluate::UnwrapConstantValue<evaluate::SubscriptInteger>(
295 folded)}) {
296 std::set<std::int64_t> values;
297 for (const auto &j : con->values()) {
298 if (auto pair{values.emplace(j.ToInt64())}; !pair.second) {
299 return true; // duplicate
300 }
301 }
302 }
303 return false;
304 }
305 }
306 }
307 return anyVector ? false : (*this)(aRef.base());
308 }
309
310private:
311 evaluate::FoldingContext &foldingContext_;
312};
313
314std::optional<parser::Message> WhyNotDefinable(parser::CharBlock at,
315 const Scope &scope, DefinabilityFlags flags,
316 const evaluate::Expr<evaluate::SomeType> &expr) {
317 std::optional<parser::Message> portabilityWarning;
318 if (auto dataRef{evaluate::ExtractDataRef(expr, true, true)}) {
319 if (evaluate::HasVectorSubscript(expr)) {
320 if (flags.test(DefinabilityFlag::VectorSubscriptIsOk)) {
321 if (auto type{expr.GetType()}) {
322 if (!type->IsUnlimitedPolymorphic() &&
323 type->category() == TypeCategory::Derived) {
324 // Seek the FINAL subroutine that should but cannot be called
325 // for this definition of an array with a vector-valued subscript.
326 // If there's an elemental FINAL subroutine, all is well; otherwise,
327 // if there is a FINAL subroutine with a matching or assumed rank
328 // dummy argument, there's no way to call it.
329 int rank{expr.Rank()};
330 const DerivedTypeSpec *spec{&type->GetDerivedTypeSpec()};
331 while (spec) {
332 bool anyElemental{false};
333 const Symbol *anyRankMatch{nullptr};
334 for (auto ref : FinalsForDerivedTypeInstantiation(*spec)) {
335 const Symbol &ultimate{ref->GetUltimate()};
336 anyElemental |= ultimate.attrs().test(Attr::ELEMENTAL);
337 if (const auto *subp{ultimate.detailsIf<SubprogramDetails>()}) {
338 if (!subp->dummyArgs().empty()) {
339 if (const Symbol * arg{subp->dummyArgs()[0]}) {
340 const auto *object{arg->detailsIf<ObjectEntityDetails>()};
341 if (arg->Rank() == rank ||
342 (object && object->IsAssumedRank())) {
343 anyRankMatch = &*ref;
344 }
345 }
346 }
347 }
348 }
349 if (anyRankMatch && !anyElemental) {
350 if (!portabilityWarning &&
351 scope.context().languageFeatures().ShouldWarn(
352 common::UsageWarning::VectorSubscriptFinalization)) {
353 portabilityWarning = parser::Message{
354 common::UsageWarning::VectorSubscriptFinalization, at,
355 "Variable '%s' has a vector subscript and will be finalized by non-elemental subroutine '%s'"_port_en_US,
356 expr.AsFortran(), anyRankMatch->name()};
357 }
358 break;
359 }
360 const auto *parent{FindParentTypeSpec(*spec)};
361 spec = parent ? parent->AsDerived() : nullptr;
362 }
363 }
364 }
365 if (!flags.test(DefinabilityFlag::DuplicatesAreOk) &&
366 DuplicatedSubscriptFinder{scope.context().foldingContext()}(expr)) {
367 return parser::Message{at,
368 "Variable has a vector subscript with a duplicated element"_err_en_US};
369 }
370 } else {
371 return parser::Message{at,
372 "Variable '%s' has a vector subscript"_err_en_US, expr.AsFortran()};
373 }
374 }
375 if (FindPureProcedureContaining(scope) &&
376 evaluate::ExtractCoarrayRef(expr)) {
377 return parser::Message(at,
378 "A pure subprogram may not define the coindexed object '%s'"_err_en_US,
379 expr.AsFortran());
380 }
381 if (auto whyNotDataRef{WhyNotDefinable(at, scope, flags, *dataRef)}) {
382 return whyNotDataRef;
383 }
384 } else if (evaluate::IsNullPointerOrAllocatable(&expr)) {
385 return parser::Message{
386 at, "'%s' is a null pointer"_err_en_US, expr.AsFortran()};
387 } else if (flags.test(DefinabilityFlag::PointerDefinition)) {
388 if (const auto *procDesignator{
389 std::get_if<evaluate::ProcedureDesignator>(&expr.u)}) {
390 // Defining a procedure pointer
391 if (const Symbol * procSym{procDesignator->GetSymbol()}) {
392 if (evaluate::ExtractCoarrayRef(expr)) { // C1027
393 return BlameSymbol(at,
394 "Procedure pointer '%s' may not be a coindexed object"_err_en_US,
395 *procSym, expr.AsFortran());
396 }
397 if (const auto *component{procDesignator->GetComponent()}) {
398 flags.reset(DefinabilityFlag::PointerDefinition);
399 return WhyNotDefinableBase(at, scope, flags,
400 component->base().GetFirstSymbol(), false,
401 DefinesComponentPointerTarget(component->base(), flags));
402 } else {
403 return WhyNotDefinable(at, scope, flags, *procSym);
404 }
405 }
406 }
407 return parser::Message{
408 at, "'%s' is not a definable pointer"_err_en_US, expr.AsFortran()};
409 } else if (!evaluate::IsVariable(expr)) {
410 return parser::Message{
411 at, "'%s' is not a variable or pointer"_err_en_US, expr.AsFortran()};
412 }
413 return portabilityWarning;
414}
415
416} // namespace Fortran::semantics
417

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