flang/lib/Semantics/definable.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-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::Error);
  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 // 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
  66 static 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.
  98 static 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
 184 static 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   if (flags.test(DefinabilityFlag::PointerDefinition)) {
 197     if (flags.test(DefinabilityFlag::AcceptAllocatable)) {
 198       if (!IsAllocatableOrObjectPointer(&ultimate)) {
 199         return BlameSymbol(
 200             at, "'%s' is neither a pointer nor an allocatable"_en_US, original);
 201       }
 202     } else if (!IsPointer(ultimate)) {
 203       return BlameSymbol(at, "'%s' is not a pointer"_en_US, original);
 204     }
 205     return std::nullopt; // pointer assignment - skip following checks
 206   }
 207   if (!flags.test(DefinabilityFlag::AllowEventLockOrNotifyType) &&
 208       IsOrContainsEventOrLockComponent(ultimate)) {
 209     return BlameSymbol(at,
 210         "'%s' is an entity with either an EVENT_TYPE or LOCK_TYPE"_en_US,
 211         original);
 212   }
 213   if (FindPureProcedureContaining(scope)) {
 214     if (auto dyType{evaluate::DynamicType::From(ultimate)}) {
 215       if (!flags.test(DefinabilityFlag::PolymorphicOkInPure)) {
 216         if (dyType->IsPolymorphic()) { // C1596
 217           return BlameSymbol(
 218               at, "'%s' is polymorphic in a pure subprogram"_en_US, original);
 219         }
 220       }
 221       if (const Symbol * impure{HasImpureFinal(ultimate)}) {
 222         return BlameSymbol(at, "'%s' has an impure FINAL procedure '%s'"_en_US,
 223             original, impure->name());
 224       }
 225       if (const DerivedTypeSpec * derived{GetDerivedTypeSpec(dyType)}) {
 226         if (!flags.test(DefinabilityFlag::PolymorphicOkInPure)) {
 227           if (auto bad{
 228                   FindPolymorphicAllocatablePotentialComponent(*derived)}) {
 229             return BlameSymbol(at,
 230                 "'%s' has polymorphic component '%s' in a pure subprogram"_en_US,
 231                 original, bad.BuildResultDesignatorName());
 232           }
 233         }
 234       }
 235     }
 236   }
 237   return std::nullopt;
 238 }
 239
 240 // Checks a data-ref
 241 static 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           std::holds_alternative<evaluate::SymbolRef>(dataRef.u),
 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
 259 std::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
 273 class DuplicatedSubscriptFinder
 274     : public evaluate::AnyTraverse<DuplicatedSubscriptFinder, bool> {
 275   using Base = evaluate::AnyTraverse<DuplicatedSubscriptFinder, bool>;
 276
 277 public:
 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
 310 private:
 311   evaluate::FoldingContext &foldingContext_;
 312 };
 313
 314 std::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::IsNullPointer(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