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 (IsOrContainsEventOrLockComponent(ultimate)) {
 208     return BlameSymbol(at,
 209         "'%s' is an entity with either an EVENT_TYPE or LOCK_TYPE"_en_US,
 210         original);
 211   }
 212   if (FindPureProcedureContaining(scope)) {
 213     if (auto dyType{evaluate::DynamicType::From(ultimate)}) {
 214       if (!flags.test(DefinabilityFlag::PolymorphicOkInPure)) {
 215         if (dyType->IsPolymorphic()) { // C1596
 216           return BlameSymbol(
 217               at, "'%s' is polymorphic in a pure subprogram"_en_US, original);
 218         }
 219       }
 220       if (const Symbol * impure{HasImpureFinal(ultimate)}) {
 221         return BlameSymbol(at, "'%s' has an impure FINAL procedure '%s'"_en_US,
 222             original, impure->name());
 223       }
 224       if (const DerivedTypeSpec * derived{GetDerivedTypeSpec(dyType)}) {
 225         if (!flags.test(DefinabilityFlag::PolymorphicOkInPure)) {
 226           if (auto bad{
 227                   FindPolymorphicAllocatablePotentialComponent(*derived)}) {
 228             return BlameSymbol(at,
 229                 "'%s' has polymorphic component '%s' in a pure subprogram"_en_US,
 230                 original, bad.BuildResultDesignatorName());
 231           }
 232         }
 233       }
 234     }
 235   }
 236   return std::nullopt;
 237 }
 238
 239 // Checks a data-ref
 240 static std::optional<parser::Message> WhyNotDefinable(parser::CharBlock at,
 241     const Scope &scope, DefinabilityFlags flags,
 242     const evaluate::DataRef &dataRef) {
 243   auto whyNotBase{
 244       WhyNotDefinableBase(at, scope, flags, dataRef.GetFirstSymbol(),
 245           std::holds_alternative<evaluate::SymbolRef>(dataRef.u),
 246           DefinesComponentPointerTarget(dataRef, flags))};
 247   if (!whyNotBase || !whyNotBase->IsFatal()) {
 248     if (auto whyNotLast{
 249             WhyNotDefinableLast(at, scope, flags, dataRef.GetLastSymbol())}) {
 250       if (whyNotLast->IsFatal() || !whyNotBase) {
 251         return whyNotLast;
 252       }
 253     }
 254   }
 255   return whyNotBase;
 256 }
 257
 258 std::optional<parser::Message> WhyNotDefinable(parser::CharBlock at,
 259     const Scope &scope, DefinabilityFlags flags, const Symbol &original) {
 260   auto whyNotBase{WhyNotDefinableBase(at, scope, flags, original,
 261       /*isWholeSymbol=*/true, /*isComponentPointerTarget=*/false)};
 262   if (!whyNotBase || !whyNotBase->IsFatal()) {
 263     if (auto whyNotLast{WhyNotDefinableLast(at, scope, flags, original)}) {
 264       if (whyNotLast->IsFatal() || !whyNotBase) {
 265         return whyNotLast;
 266       }
 267     }
 268   }
 269   return whyNotBase;
 270 }
 271
 272 class DuplicatedSubscriptFinder
 273     : public evaluate::AnyTraverse<DuplicatedSubscriptFinder, bool> {
 274   using Base = evaluate::AnyTraverse<DuplicatedSubscriptFinder, bool>;
 275
 276 public:
 277   explicit DuplicatedSubscriptFinder(evaluate::FoldingContext &foldingContext)
 278       : Base{*this}, foldingContext_{foldingContext} {}
 279   using Base::operator();
 280   bool operator()(const evaluate::ActualArgument &) {
 281     return false; // don't descend into argument expressions
 282   }
 283   bool operator()(const evaluate::ArrayRef &aRef) {
 284     bool anyVector{false};
 285     for (const auto &ss : aRef.subscript()) {
 286       if (ss.Rank() > 0) {
 287         anyVector = true;
 288         if (const auto *vecExpr{
 289                 std::get_if<evaluate::IndirectSubscriptIntegerExpr>(&ss.u)}) {
 290           auto folded{evaluate::Fold(foldingContext_,
 291               evaluate::Expr<evaluate::SubscriptInteger>{vecExpr->value()})};
 292           if (const auto *con{
 293                   evaluate::UnwrapConstantValue<evaluate::SubscriptInteger>(
 294                       folded)}) {
 295             std::set<std::int64_t> values;
 296             for (const auto &j : con->values()) {
 297               if (auto pair{values.emplace(j.ToInt64())}; !pair.second) {
 298                 return true; // duplicate
 299               }
 300             }
 301           }
 302           return false;
 303         }
 304       }
 305     }
 306     return anyVector ? false : (*this)(aRef.base());
 307   }
 308
 309 private:
 310   evaluate::FoldingContext &foldingContext_;
 311 };
 312
 313 std::optional<parser::Message> WhyNotDefinable(parser::CharBlock at,
 314     const Scope &scope, DefinabilityFlags flags,
 315     const evaluate::Expr<evaluate::SomeType> &expr) {
 316   std::optional<parser::Message> portabilityWarning;
 317   if (auto dataRef{evaluate::ExtractDataRef(expr, true, true)}) {
 318     if (evaluate::HasVectorSubscript(expr)) {
 319       if (flags.test(DefinabilityFlag::VectorSubscriptIsOk)) {
 320         if (auto type{expr.GetType()}) {
 321           if (!type->IsUnlimitedPolymorphic() &&
 322               type->category() == TypeCategory::Derived) {
 323             // Seek the FINAL subroutine that should but cannot be called
 324             // for this definition of an array with a vector-valued subscript.
 325             // If there's an elemental FINAL subroutine, all is well; otherwise,
 326             // if there is a FINAL subroutine with a matching or assumed rank
 327             // dummy argument, there's no way to call it.
 328             int rank{expr.Rank()};
 329             const DerivedTypeSpec *spec{&type->GetDerivedTypeSpec()};
 330             while (spec) {
 331               bool anyElemental{false};
 332               const Symbol *anyRankMatch{nullptr};
 333               for (auto ref : FinalsForDerivedTypeInstantiation(*spec)) {
 334                 const Symbol &ultimate{ref->GetUltimate()};
 335                 anyElemental |= ultimate.attrs().test(Attr::ELEMENTAL);
 336                 if (const auto *subp{ultimate.detailsIf<SubprogramDetails>()}) {
 337                   if (!subp->dummyArgs().empty()) {
 338                     if (const Symbol * arg{subp->dummyArgs()[0]}) {
 339                       const auto *object{arg->detailsIf<ObjectEntityDetails>()};
 340                       if (arg->Rank() == rank ||
 341                           (object && object->IsAssumedRank())) {
 342                         anyRankMatch = &*ref;
 343                       }
 344                     }
 345                   }
 346                 }
 347               }
 348               if (anyRankMatch && !anyElemental) {
 349                 if (!portabilityWarning &&
 350                     scope.context().languageFeatures().ShouldWarn(
 351                         common::UsageWarning::VectorSubscriptFinalization)) {
 352                   portabilityWarning = parser::Message{
 353                       common::UsageWarning::VectorSubscriptFinalization, at,
 354                       "Variable '%s' has a vector subscript and will be finalized by non-elemental subroutine '%s'"_port_en_US,
 355                       expr.AsFortran(), anyRankMatch->name()};
 356                 }
 357                 break;
 358               }
 359               const auto *parent{FindParentTypeSpec(*spec)};
 360               spec = parent ? parent->AsDerived() : nullptr;
 361             }
 362           }
 363         }
 364         if (!flags.test(DefinabilityFlag::DuplicatesAreOk) &&
 365             DuplicatedSubscriptFinder{scope.context().foldingContext()}(expr)) {
 366           return parser::Message{at,
 367               "Variable has a vector subscript with a duplicated element"_err_en_US};
 368         }
 369       } else {
 370         return parser::Message{at,
 371             "Variable '%s' has a vector subscript"_err_en_US, expr.AsFortran()};
 372       }
 373     }
 374     if (FindPureProcedureContaining(scope) &&
 375         evaluate::ExtractCoarrayRef(expr)) {
 376       return parser::Message(at,
 377           "A pure subprogram may not define the coindexed object '%s'"_err_en_US,
 378           expr.AsFortran());
 379     }
 380     if (auto whyNotDataRef{WhyNotDefinable(at, scope, flags, *dataRef)}) {
 381       return whyNotDataRef;
 382     }
 383   } else if (evaluate::IsNullPointer(expr)) {
 384     return parser::Message{
 385         at, "'%s' is a null pointer"_err_en_US, expr.AsFortran()};
 386   } else if (flags.test(DefinabilityFlag::PointerDefinition)) {
 387     if (const auto *procDesignator{
 388             std::get_if<evaluate::ProcedureDesignator>(&expr.u)}) {
 389       // Defining a procedure pointer
 390       if (const Symbol * procSym{procDesignator->GetSymbol()}) {
 391         if (evaluate::ExtractCoarrayRef(expr)) { // C1027
 392           return BlameSymbol(at,
 393               "Procedure pointer '%s' may not be a coindexed object"_err_en_US,
 394               *procSym, expr.AsFortran());
 395         }
 396         if (const auto *component{procDesignator->GetComponent()}) {
 397           flags.reset(DefinabilityFlag::PointerDefinition);
 398           return WhyNotDefinableBase(at, scope, flags,
 399               component->base().GetFirstSymbol(), false,
 400               DefinesComponentPointerTarget(component->base(), flags));
 401         } else {
 402           return WhyNotDefinable(at, scope, flags, *procSym);
 403         }
 404       }
 405     }
 406     return parser::Message{
 407         at, "'%s' is not a definable pointer"_err_en_US, expr.AsFortran()};
 408   } else if (!evaluate::IsVariable(expr)) {
 409     return parser::Message{
 410         at, "'%s' is not a variable or pointer"_err_en_US, expr.AsFortran()};
 411   }
 412   return portabilityWarning;
 413 }
 414
 415 } // namespace Fortran::semantics