417 lines · cpp
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-exception6//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 both32// 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 fails50static 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// True when the object being defined is not a subobject of the base64// object, e.g. X%PTR = 1., X%PTR%PTR2 => T (but not X%PTR => T).65// F'2023 9.4.2p566static 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'n133 // 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 checks215 }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-ref241static 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 DuplicatedSubscriptFinder274 : 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 expressions283 }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; // duplicate300 }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 called325 // 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 rank328 // 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 pointer391 if (const Symbol * procSym{procDesignator->GetSymbol()}) {392 if (evaluate::ExtractCoarrayRef(expr)) { // C1027393 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::semantics417