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 13 using namespace Fortran::parser::literals; 14 15 namespace Fortran::semantics { 16 17 template <typename... A> 18 static 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 26 static 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. 33 const 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 50 static 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(ultimate, 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 // When a DataRef contains pointers, gets the rightmost one (unless it is 64 // the entity being defined, in which case the last pointer above it); 65 // otherwise, returns the leftmost symbol. The resulting symbol is the 66 // relevant base object for definabiliy checking. Examples: 67 // ptr1%ptr2 => ... -> ptr1 68 // nonptr%ptr => ... -> nonptr 69 // nonptr%ptr = ... -> ptr 70 // ptr1%ptr2 = ... -> ptr2 71 // ptr1%ptr2%nonptr = ... -> ptr2 72 // nonptr1%nonptr2 = ... -> nonptr1 73 static const Symbol &GetRelevantSymbol(const evaluate::DataRef &dataRef, 74 bool isPointerDefinition, bool acceptAllocatable) { 75 if (isPointerDefinition) { 76 if (const auto *component{std::get_if<evaluate::Component>(&dataRef.u)}) { 77 if (IsPointer(component->GetLastSymbol()) || 78 (acceptAllocatable && IsAllocatable(component->GetLastSymbol()))) { 79 return GetRelevantSymbol(component->base(), false, false); 80 } 81 } 82 } 83 if (const Symbol * lastPointer{GetLastPointerSymbol(dataRef)}) { 84 return *lastPointer; 85 } else { 86 return dataRef.GetFirstSymbol(); 87 } 88 } 89 90 // Check the leftmost (or only) symbol from a data-ref or expression. 91 static std::optional<parser::Message> WhyNotDefinableBase(parser::CharBlock at, 92 const Scope &scope, DefinabilityFlags flags, const Symbol &original) { 93 const Symbol &ultimate{original.GetUltimate()}; 94 bool isPointerDefinition{flags.test(DefinabilityFlag::PointerDefinition)}; 95 bool acceptAllocatable{flags.test(DefinabilityFlag::AcceptAllocatable)}; 96 bool isTargetDefinition{!isPointerDefinition && IsPointer(ultimate)}; 97 if (const auto *association{ultimate.detailsIf<AssocEntityDetails>()}) { 98 if (!IsVariable(association->expr())) { 99 return BlameSymbol(at, 100 "'%s' is construct associated with an expression"_en_US, original); 101 } else if (evaluate::HasVectorSubscript(association->expr().value())) { 102 return BlameSymbol(at, 103 "Construct association '%s' has a vector subscript"_en_US, original); 104 } else if (auto dataRef{evaluate::ExtractDataRef( 105 *association->expr(), true, true)}) { 106 return WhyNotDefinableBase(at, scope, flags, 107 GetRelevantSymbol(*dataRef, isPointerDefinition, acceptAllocatable)); 108 } 109 } 110 if (isTargetDefinition) { 111 } else if (!isPointerDefinition && !IsVariableName(ultimate)) { 112 return BlameSymbol(at, "'%s' is not a variable"_en_US, original); 113 } else if (IsProtected(ultimate) && IsUseAssociated(original, scope)) { 114 return BlameSymbol(at, "'%s' is protected in this scope"_en_US, original); 115 } else if (IsIntentIn(ultimate)) { 116 return BlameSymbol( 117 at, "'%s' is an INTENT(IN) dummy argument"_en_US, original); 118 } 119 if (const Scope * pure{FindPureProcedureContaining(scope)}) { 120 // Additional checking for pure subprograms. 121 if (!isTargetDefinition) { 122 if (auto msg{CheckDefinabilityInPureScope( 123 at, original, ultimate, scope, *pure)}) { 124 return msg; 125 } 126 } 127 if (const Symbol * 128 visible{FindExternallyVisibleObject( 129 ultimate, *pure, isPointerDefinition)}) { 130 return BlameSymbol(at, 131 "'%s' is externally visible via '%s' and not definable in a pure subprogram"_en_US, 132 original, visible->name()); 133 } 134 } 135 if (const Scope * deviceContext{FindCUDADeviceContext(&scope)}) { 136 bool isOwnedByDeviceCode{deviceContext->Contains(ultimate.owner())}; 137 if (isPointerDefinition && !acceptAllocatable) { 138 return BlameSymbol(at, 139 "'%s' is a pointer and may not be associated in a device subprogram"_err_en_US, 140 original); 141 } else if (auto cudaDataAttr{GetCUDADataAttr(&ultimate)}) { 142 if (*cudaDataAttr == common::CUDADataAttr::Constant) { 143 return BlameSymbol(at, 144 "'%s' has ATTRIBUTES(CONSTANT) and is not definable in a device subprogram"_err_en_US, 145 original); 146 } else if (acceptAllocatable && !isOwnedByDeviceCode) { 147 return BlameSymbol(at, 148 "'%s' is a host-associated allocatable and is not definable in a device subprogram"_err_en_US, 149 original); 150 } else if (*cudaDataAttr != common::CUDADataAttr::Device && 151 *cudaDataAttr != common::CUDADataAttr::Managed) { 152 return BlameSymbol(at, 153 "'%s' is not device or managed data and is not definable in a device subprogram"_err_en_US, 154 original); 155 } 156 } else if (!isOwnedByDeviceCode) { 157 return BlameSymbol(at, 158 "'%s' is a host variable and is not definable in a device subprogram"_err_en_US, 159 original); 160 } 161 } 162 return std::nullopt; 163 } 164 165 static std::optional<parser::Message> WhyNotDefinableLast(parser::CharBlock at, 166 const Scope &scope, DefinabilityFlags flags, const Symbol &original) { 167 const Symbol &ultimate{original.GetUltimate()}; 168 if (flags.test(DefinabilityFlag::PointerDefinition)) { 169 if (flags.test(DefinabilityFlag::AcceptAllocatable)) { 170 if (!IsAllocatableOrObjectPointer(&ultimate)) { 171 return BlameSymbol( 172 at, "'%s' is neither a pointer nor an allocatable"_en_US, original); 173 } 174 } else if (!IsPointer(ultimate)) { 175 return BlameSymbol(at, "'%s' is not a pointer"_en_US, original); 176 } 177 return std::nullopt; // pointer assignment - skip following checks 178 } 179 if (IsOrContainsEventOrLockComponent(ultimate)) { 180 return BlameSymbol(at, 181 "'%s' is an entity with either an EVENT_TYPE or LOCK_TYPE"_en_US, 182 original); 183 } 184 if (FindPureProcedureContaining(scope)) { 185 if (auto dyType{evaluate::DynamicType::From(ultimate)}) { 186 if (!flags.test(DefinabilityFlag::PolymorphicOkInPure)) { 187 if (dyType->IsPolymorphic()) { // C1596 188 return BlameSymbol(at, 189 "'%s' is polymorphic in a pure subprogram"_because_en_US, 190 original); 191 } 192 } 193 if (const Symbol * impure{HasImpureFinal(ultimate)}) { 194 return BlameSymbol(at, 195 "'%s' has an impure FINAL procedure '%s'"_because_en_US, original, 196 impure->name()); 197 } 198 if (const DerivedTypeSpec * derived{GetDerivedTypeSpec(dyType)}) { 199 if (!flags.test(DefinabilityFlag::PolymorphicOkInPure)) { 200 if (auto bad{FindPolymorphicAllocatableUltimateComponent(*derived)}) { 201 return BlameSymbol(at, 202 "'%s' has polymorphic component '%s' in a pure subprogram"_because_en_US, 203 original, bad.BuildResultDesignatorName()); 204 } 205 } 206 } 207 } 208 } 209 return std::nullopt; 210 } 211 212 // Checks a data-ref 213 static std::optional<parser::Message> WhyNotDefinable(parser::CharBlock at, 214 const Scope &scope, DefinabilityFlags flags, 215 const evaluate::DataRef &dataRef) { 216 const Symbol &base{GetRelevantSymbol(dataRef, 217 flags.test(DefinabilityFlag::PointerDefinition), 218 flags.test(DefinabilityFlag::AcceptAllocatable))}; 219 if (auto whyNot{WhyNotDefinableBase(at, scope, flags, base)}) { 220 return whyNot; 221 } else { 222 return WhyNotDefinableLast(at, scope, flags, dataRef.GetLastSymbol()); 223 } 224 } 225 226 // Checks a NOPASS procedure pointer component 227 static std::optional<parser::Message> WhyNotDefinable(parser::CharBlock at, 228 const Scope &scope, DefinabilityFlags flags, 229 const evaluate::Component &component) { 230 const evaluate::DataRef &dataRef{component.base()}; 231 const Symbol &base{GetRelevantSymbol(dataRef, false, false)}; 232 DefinabilityFlags baseFlags{flags}; 233 baseFlags.reset(DefinabilityFlag::PointerDefinition); 234 return WhyNotDefinableBase(at, scope, baseFlags, base); 235 } 236 237 std::optional<parser::Message> WhyNotDefinable(parser::CharBlock at, 238 const Scope &scope, DefinabilityFlags flags, const Symbol &original) { 239 if (auto base{WhyNotDefinableBase(at, scope, flags, original)}) { 240 return base; 241 } 242 return WhyNotDefinableLast(at, scope, flags, original); 243 } 244 245 class DuplicatedSubscriptFinder 246 : public evaluate::AnyTraverse<DuplicatedSubscriptFinder, bool> { 247 using Base = evaluate::AnyTraverse<DuplicatedSubscriptFinder, bool>; 248 249 public: 250 explicit DuplicatedSubscriptFinder(evaluate::FoldingContext &foldingContext) 251 : Base{*this}, foldingContext_{foldingContext} {} 252 using Base::operator(); 253 bool operator()(const evaluate::ActualArgument &) { 254 return false; // don't descend into argument expressions 255 } 256 bool operator()(const evaluate::ArrayRef &aRef) { 257 bool anyVector{false}; 258 for (const auto &ss : aRef.subscript()) { 259 if (ss.Rank() > 0) { 260 anyVector = true; 261 if (const auto *vecExpr{ 262 std::get_if<evaluate::IndirectSubscriptIntegerExpr>(&ss.u)}) { 263 auto folded{evaluate::Fold(foldingContext_, 264 evaluate::Expr<evaluate::SubscriptInteger>{vecExpr->value()})}; 265 if (const auto *con{ 266 evaluate::UnwrapConstantValue<evaluate::SubscriptInteger>( 267 folded)}) { 268 std::set<std::int64_t> values; 269 for (const auto &j : con->values()) { 270 if (auto pair{values.emplace(j.ToInt64())}; !pair.second) { 271 return true; // duplicate 272 } 273 } 274 } 275 return false; 276 } 277 } 278 } 279 return anyVector ? false : (*this)(aRef.base()); 280 } 281 282 private: 283 evaluate::FoldingContext &foldingContext_; 284 }; 285 286 std::optional<parser::Message> WhyNotDefinable(parser::CharBlock at, 287 const Scope &scope, DefinabilityFlags flags, 288 const evaluate::Expr<evaluate::SomeType> &expr) { 289 if (auto dataRef{evaluate::ExtractDataRef(expr, true, true)}) { 290 if (evaluate::HasVectorSubscript(expr)) { 291 if (flags.test(DefinabilityFlag::VectorSubscriptIsOk)) { 292 if (auto type{expr.GetType()}) { 293 if (!type->IsUnlimitedPolymorphic() && 294 type->category() == TypeCategory::Derived) { 295 // Seek the FINAL subroutine that should but cannot be called 296 // for this definition of an array with a vector-valued subscript. 297 // If there's an elemental FINAL subroutine, all is well; otherwise, 298 // if there is a FINAL subroutine with a matching or assumed rank 299 // dummy argument, there's no way to call it. 300 int rank{expr.Rank()}; 301 const DerivedTypeSpec *spec{&type->GetDerivedTypeSpec()}; 302 while (spec) { 303 bool anyElemental{false}; 304 const Symbol *anyRankMatch{nullptr}; 305 for (auto ref : FinalsForDerivedTypeInstantiation(*spec)) { 306 const Symbol &ultimate{ref->GetUltimate()}; 307 anyElemental |= ultimate.attrs().test(Attr::ELEMENTAL); 308 if (const auto *subp{ultimate.detailsIf<SubprogramDetails>()}) { 309 if (!subp->dummyArgs().empty()) { 310 if (const Symbol * arg{subp->dummyArgs()[0]}) { 311 const auto *object{arg->detailsIf<ObjectEntityDetails>()}; 312 if (arg->Rank() == rank || 313 (object && object->IsAssumedRank())) { 314 anyRankMatch = &*ref; 315 } 316 } 317 } 318 } 319 } 320 if (anyRankMatch && !anyElemental) { 321 return parser::Message{at, 322 "Variable '%s' has a vector subscript and cannot be finalized by non-elemental subroutine '%s'"_because_en_US, 323 expr.AsFortran(), anyRankMatch->name()}; 324 } 325 const auto *parent{FindParentTypeSpec(*spec)}; 326 spec = parent ? parent->AsDerived() : nullptr; 327 } 328 } 329 } 330 if (!flags.test(DefinabilityFlag::DuplicatesAreOk) && 331 DuplicatedSubscriptFinder{scope.context().foldingContext()}(expr)) { 332 return parser::Message{at, 333 "Variable has a vector subscript with a duplicated element"_because_en_US}; 334 } 335 } else { 336 return parser::Message{at, 337 "Variable '%s' has a vector subscript"_because_en_US, 338 expr.AsFortran()}; 339 } 340 } 341 if (FindPureProcedureContaining(scope) && 342 evaluate::ExtractCoarrayRef(expr)) { 343 return parser::Message(at, 344 "A pure subprogram may not define the coindexed object '%s'"_because_en_US, 345 expr.AsFortran()); 346 } 347 return WhyNotDefinable(at, scope, flags, *dataRef); 348 } else if (evaluate::IsNullPointer(expr)) { 349 return parser::Message{ 350 at, "'%s' is a null pointer"_because_en_US, expr.AsFortran()}; 351 } else if (flags.test(DefinabilityFlag::PointerDefinition)) { 352 if (const auto *procDesignator{ 353 std::get_if<evaluate::ProcedureDesignator>(&expr.u)}) { 354 // Defining a procedure pointer 355 if (const Symbol * procSym{procDesignator->GetSymbol()}) { 356 if (evaluate::ExtractCoarrayRef(expr)) { // C1027 357 return BlameSymbol(at, 358 "Procedure pointer '%s' may not be a coindexed object"_because_en_US, 359 *procSym, expr.AsFortran()); 360 } 361 if (const auto *component{procDesignator->GetComponent()}) { 362 return WhyNotDefinable(at, scope, flags, *component); 363 } else { 364 return WhyNotDefinable(at, scope, flags, *procSym); 365 } 366 } 367 } 368 return parser::Message{ 369 at, "'%s' is not a definable pointer"_because_en_US, expr.AsFortran()}; 370 } else if (!evaluate::IsVariable(expr)) { 371 return parser::Message{at, 372 "'%s' is not a variable or pointer"_because_en_US, expr.AsFortran()}; 373 } else { 374 return std::nullopt; 375 } 376 } 377 378 } // namespace Fortran::semantics 379