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::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 (association->rank().has_value()) {
  99       return std::nullopt; // SELECT RANK always modifiable variable
 100     } else if (!IsVariable(association->expr())) {
 101       return BlameSymbol(at,
 102           "'%s' is construct associated with an expression"_en_US, original);
 103     } else if (evaluate::HasVectorSubscript(association->expr().value())) {
 104       return BlameSymbol(at,
 105           "Construct association '%s' has a vector subscript"_en_US, original);
 106     } else if (auto dataRef{evaluate::ExtractDataRef(
 107                    *association->expr(), true, true)}) {
 108       return WhyNotDefinableBase(at, scope, flags,
 109           GetRelevantSymbol(*dataRef, isPointerDefinition, acceptAllocatable));
 110     }
 111   }
 112   if (isTargetDefinition) {
 113   } else if (!isPointerDefinition && !IsVariableName(ultimate)) {
 114     return BlameSymbol(at, "'%s' is not a variable"_en_US, original);
 115   } else if (IsProtected(ultimate) && IsUseAssociated(original, scope)) {
 116     return BlameSymbol(at, "'%s' is protected in this scope"_en_US, original);
 117   } else if (IsIntentIn(ultimate)) {
 118     return BlameSymbol(
 119         at, "'%s' is an INTENT(IN) dummy argument"_en_US, original);
 120   }
 121   if (const Scope * pure{FindPureProcedureContaining(scope)}) {
 122     // Additional checking for pure subprograms.
 123     if (!isTargetDefinition) {
 124       if (auto msg{CheckDefinabilityInPureScope(
 125               at, original, ultimate, scope, *pure)}) {
 126         return msg;
 127       }
 128     }
 129     if (const Symbol *
 130         visible{FindExternallyVisibleObject(
 131             ultimate, *pure, isPointerDefinition)}) {
 132       return BlameSymbol(at,
 133           "'%s' is externally visible via '%s' and not definable in a pure subprogram"_en_US,
 134           original, visible->name());
 135     }
 136   }
 137   return std::nullopt;
 138 }
 139
 140 static std::optional<parser::Message> WhyNotDefinableLast(parser::CharBlock at,
 141     const Scope &scope, DefinabilityFlags flags, const Symbol &original) {
 142   const Symbol &ultimate{original.GetUltimate()};
 143   if (flags.test(DefinabilityFlag::PointerDefinition)) {
 144     if (flags.test(DefinabilityFlag::AcceptAllocatable)) {
 145       if (!IsAllocatableOrPointer(ultimate)) {
 146         return BlameSymbol(
 147             at, "'%s' is neither a pointer nor an allocatable"_en_US, original);
 148       }
 149     } else if (!IsPointer(ultimate)) {
 150       return BlameSymbol(at, "'%s' is not a pointer"_en_US, original);
 151     }
 152     return std::nullopt; // pointer assignment - skip following checks
 153   }
 154   if (IsOrContainsEventOrLockComponent(ultimate)) {
 155     return BlameSymbol(at,
 156         "'%s' is an entity with either an EVENT_TYPE or LOCK_TYPE"_en_US,
 157         original);
 158   }
 159   if (!flags.test(DefinabilityFlag::PolymorphicOkInPure) &&
 160       FindPureProcedureContaining(scope)) {
 161     if (auto dyType{evaluate::DynamicType::From(ultimate)}) {
 162       if (dyType->IsPolymorphic()) { // C1596
 163         return BlameSymbol(at,
 164             "'%s' is polymorphic in a pure subprogram"_because_en_US, original);
 165       }
 166       if (const DerivedTypeSpec * derived{GetDerivedTypeSpec(dyType)}) {
 167         if (auto bad{FindPolymorphicAllocatableNonCoarrayUltimateComponent(
 168                 *derived)}) {
 169           return BlameSymbol(at,
 170               "'%s' has polymorphic non-coarray component '%s' in a pure subprogram"_because_en_US,
 171               original, bad.BuildResultDesignatorName());
 172         }
 173       }
 174     }
 175   }
 176   return std::nullopt;
 177 }
 178
 179 // Checks a data-ref
 180 static std::optional<parser::Message> WhyNotDefinable(parser::CharBlock at,
 181     const Scope &scope, DefinabilityFlags flags,
 182     const evaluate::DataRef &dataRef) {
 183   const Symbol &base{GetRelevantSymbol(dataRef,
 184       flags.test(DefinabilityFlag::PointerDefinition),
 185       flags.test(DefinabilityFlag::AcceptAllocatable))};
 186   if (auto whyNot{WhyNotDefinableBase(at, scope, flags, base)}) {
 187     return whyNot;
 188   } else {
 189     return WhyNotDefinableLast(at, scope, flags, dataRef.GetLastSymbol());
 190   }
 191 }
 192
 193 // Checks a NOPASS procedure pointer component
 194 static std::optional<parser::Message> WhyNotDefinable(parser::CharBlock at,
 195     const Scope &scope, DefinabilityFlags flags,
 196     const evaluate::Component &component) {
 197   const evaluate::DataRef &dataRef{component.base()};
 198   const Symbol &base{GetRelevantSymbol(dataRef, false, false)};
 199   DefinabilityFlags baseFlags{flags};
 200   baseFlags.reset(DefinabilityFlag::PointerDefinition);
 201   return WhyNotDefinableBase(at, scope, baseFlags, base);
 202 }
 203
 204 std::optional<parser::Message> WhyNotDefinable(parser::CharBlock at,
 205     const Scope &scope, DefinabilityFlags flags, const Symbol &original) {
 206   if (auto base{WhyNotDefinableBase(at, scope, flags, original)}) {
 207     return base;
 208   }
 209   return WhyNotDefinableLast(at, scope, flags, original);
 210 }
 211
 212 std::optional<parser::Message> WhyNotDefinable(parser::CharBlock at,
 213     const Scope &scope, DefinabilityFlags flags,
 214     const evaluate::Expr<evaluate::SomeType> &expr) {
 215   if (auto dataRef{evaluate::ExtractDataRef(expr, true, true)}) {
 216     if (evaluate::HasVectorSubscript(expr)) {
 217       if (flags.test(DefinabilityFlag::VectorSubscriptIsOk)) {
 218         if (auto type{expr.GetType()}) {
 219           if (!type->IsUnlimitedPolymorphic() &&
 220               type->category() == TypeCategory::Derived) {
 221             // Seek the FINAL subroutine that should but cannot be called
 222             // for this definition of an array with a vector-valued subscript.
 223             // If there's an elemental FINAL subroutine, all is well; otherwise,
 224             // if there is a FINAL subroutine with a matching or assumed rank
 225             // dummy argument, there's no way to call it.
 226             int rank{expr.Rank()};
 227             const DerivedTypeSpec *spec{&type->GetDerivedTypeSpec()};
 228             while (spec) {
 229               bool anyElemental{false};
 230               const Symbol *anyRankMatch{nullptr};
 231               for (auto ref : FinalsForDerivedTypeInstantiation(*spec)) {
 232                 const Symbol &ultimate{ref->GetUltimate()};
 233                 anyElemental |= ultimate.attrs().test(Attr::ELEMENTAL);
 234                 if (const auto *subp{ultimate.detailsIf<SubprogramDetails>()}) {
 235                   if (!subp->dummyArgs().empty()) {
 236                     if (const Symbol * arg{subp->dummyArgs()[0]}) {
 237                       const auto *object{arg->detailsIf<ObjectEntityDetails>()};
 238                       if (arg->Rank() == rank ||
 239                           (object && object->IsAssumedRank())) {
 240                         anyRankMatch = &*ref;
 241                       }
 242                     }
 243                   }
 244                 }
 245               }
 246               if (anyRankMatch && !anyElemental) {
 247                 return parser::Message{at,
 248                     "Variable '%s' has a vector subscript and cannot be finalized by non-elemental subroutine '%s'"_because_en_US,
 249                     expr.AsFortran(), anyRankMatch->name()};
 250               }
 251               const auto *parent{FindParentTypeSpec(*spec)};
 252               spec = parent ? parent->AsDerived() : nullptr;
 253             }
 254           }
 255         }
 256       } else {
 257         return parser::Message{at,
 258             "Variable '%s' has a vector subscript"_because_en_US,
 259             expr.AsFortran()};
 260       }
 261     }
 262     if (FindPureProcedureContaining(scope) &&
 263         evaluate::ExtractCoarrayRef(expr)) {
 264       return parser::Message(at,
 265           "A pure subprogram may not define the coindexed object '%s'"_because_en_US,
 266           expr.AsFortran());
 267     }
 268     return WhyNotDefinable(at, scope, flags, *dataRef);
 269   } else if (evaluate::IsNullPointer(expr)) {
 270     return parser::Message{
 271         at, "'%s' is a null pointer"_because_en_US, expr.AsFortran()};
 272   } else if (flags.test(DefinabilityFlag::PointerDefinition)) {
 273     if (const auto *procDesignator{
 274             std::get_if<evaluate::ProcedureDesignator>(&expr.u)}) {
 275       // Defining a procedure pointer
 276       if (const Symbol * procSym{procDesignator->GetSymbol()}) {
 277         if (evaluate::ExtractCoarrayRef(expr)) { // C1027
 278           return BlameSymbol(at,
 279               "Procedure pointer '%s' may not be a coindexed object"_because_en_US,
 280               *procSym, expr.AsFortran());
 281         }
 282         if (const auto *component{procDesignator->GetComponent()}) {
 283           return WhyNotDefinable(at, scope, flags, *component);
 284         } else {
 285           return WhyNotDefinable(at, scope, flags, *procSym);
 286         }
 287       }
 288     }
 289     return parser::Message{
 290         at, "'%s' is not a definable pointer"_because_en_US, expr.AsFortran()};
 291   } else if (!evaluate::IsVariable(expr)) {
 292     return parser::Message{at,
 293         "'%s' is not a variable or pointer"_because_en_US, expr.AsFortran()};
 294   } else {
 295     return std::nullopt;
 296   }
 297 }
 298
 299 } // namespace Fortran::semantics