[flang] definability tests

Original-commit: flang-compiler/f18@4b71f003a9
Reviewed-on: https://github.com/flang-compiler/f18/pull/782
Tree-same-pre-rewrite: false

flang/lib/evaluate/tools.cc

@@ -734,4 +734,20 @@ template SetOfSymbols CollectSymbols(const Expr<SomeType> &);
 template SetOfSymbols CollectSymbols(const Expr<SomeInteger> &);
 template SetOfSymbols CollectSymbols(const Expr<SubscriptInteger> &);
 
+// HasVectorSubscript()
+struct HasVectorSubscriptHelper : public AnyTraverse<HasVectorSubscriptHelper> {
+  using Base = AnyTraverse<HasVectorSubscriptHelper>;
+  HasVectorSubscriptHelper() : Base{*this} {}
+  using Base::operator();
+  bool operator()(const Subscript &ss) const {
+    return !std::holds_alternative<Triplet>(ss.u) && ss.Rank() > 0;
+  }
+  bool operator()(const ProcedureRef &) const {
+    return false;  // don't descend into function call arguments
+  }
+};
+
+bool HasVectorSubscript(const Expr<SomeType> &expr) {
+  return HasVectorSubscriptHelper{}(expr);
+}
 }

flang/lib/evaluate/tools.h

@@ -303,6 +303,14 @@ template<typename A> const Symbol *UnwrapWholeSymbolDataRef(const A &x) {
   return nullptr;
 }
 
+template<typename A> const Symbol *GetFirstSymbol(const A &x) {
+  if (auto dataRef{ExtractDataRef(x)}) {
+    return &dataRef->GetFirstSymbol();
+  } else {
+    return nullptr;
+  }
+}
+
 // Creation of conversion expressions can be done to either a known
 // specific intrinsic type with ConvertToType<T>(x) or by converting
 // one arbitrary expression to the type of another with ConvertTo(to, from).
@@ -788,5 +796,8 @@ template<typename A> SetOfSymbols CollectSymbols(const A &);
 extern template SetOfSymbols CollectSymbols(const Expr<SomeType> &);
 extern template SetOfSymbols CollectSymbols(const Expr<SomeInteger> &);
 extern template SetOfSymbols CollectSymbols(const Expr<SubscriptInteger> &);
+
+// Predicate: does a variable contain a vector-valued subscript (not a triplet)?
+bool HasVectorSubscript(const Expr<SomeType> &);
 }
 #endif  // FORTRAN_EVALUATE_TOOLS_H_

flang/lib/parser/message.cc

@@ -256,6 +256,10 @@ Message &Message::Attach(Message *m) {
   return *this;
 }
 
+Message &Message::Attach(std::unique_ptr<Message> &&m) {
+  return Attach(m.release());
+}
+
 bool Message::AtSameLocation(const Message &that) const {
   return std::visit(
       common::visitors{

flang/lib/parser/message.h

@@ -87,7 +87,7 @@ public:
   std::string MoveString() { return std::move(string_); }
 
 private:
-  void Format(const MessageFixedText *text, ...);
+  void Format(const MessageFixedText *, ...);
 
   template<typename A> A Convert(const A &x) {
     static_assert(!std::is_class_v<std::decay_t<A>>);
@@ -185,6 +185,7 @@ public:
     attachmentIsContext_ = true;
   }
   Message &Attach(Message *);
+  Message &Attach(std::unique_ptr<Message> &&);
   template<typename... A> Message &Attach(A &&... args) {
     return Attach(new Message{std::forward<A>(args)...});  // reference-counted
   }

flang/lib/semantics/check-call.cc

@@ -112,7 +112,7 @@ static void InspectType(
 static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy,
     const evaluate::Expr<evaluate::SomeType> &actual,
     const characteristics::TypeAndShape &actualType,
-    parser::ContextualMessages &messages) {
+    parser::ContextualMessages &messages, const Scope &scope) {
   dummy.type.IsCompatibleWith(messages, actualType);
   bool actualIsPolymorphic{actualType.type().IsPolymorphic()};
   bool dummyIsPolymorphic{dummy.type.type().IsPolymorphic()};
@@ -212,12 +212,35 @@ static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy,
           "Element of assumed-shape array may not be associated with a dummy argument array"_err_en_US);
     }
   }
+  const char *reason{nullptr};
+  if (dummy.intent == common::Intent::Out) {
+    reason = "INTENT(OUT)";
+  } else if (dummy.intent == common::Intent::InOut) {
+    reason = "INTENT(IN OUT)";
+  } else if (dummy.attrs.test(
+                 characteristics::DummyDataObject::Attr::Asynchronous)) {
+    reason = "ASYNCHRONOUS";
+  } else if (dummy.attrs.test(
+                 characteristics::DummyDataObject::Attr::Volatile)) {
+    reason = "VOLATILE";
+  }
+  if (reason != nullptr) {
+    std::unique_ptr<parser::Message> why{
+        WhyNotModifiable(messages.at(), actual, scope)};
+    if (why.get() != nullptr) {
+      if (auto *msg{messages.Say(
+              "Actual argument associated with %s dummy must be definable"_err_en_US,
+              reason)}) {
+        msg->Attach(std::move(why));
+      }
+    }
+  }
   // TODO pmk more here
 }
 
 static void CheckExplicitInterfaceArg(const evaluate::ActualArgument &arg,
     const characteristics::DummyArgument &dummy,
-    evaluate::FoldingContext &context) {
+    evaluate::FoldingContext &context, const Scope &scope) {
   auto &messages{context.messages()};
   std::visit(
       common::visitors{
@@ -225,7 +248,8 @@ static void CheckExplicitInterfaceArg(const evaluate::ActualArgument &arg,
             if (const auto *expr{arg.UnwrapExpr()}) {
               if (auto type{characteristics::TypeAndShape::Characterize(
                       *expr, context)}) {
-                CheckExplicitDataArg(object, *expr, *type, context.messages());
+                CheckExplicitDataArg(
+                    object, *expr, *type, context.messages(), scope);
               } else if (object.type.type().IsTypelessIntrinsicArgument() &&
                   std::holds_alternative<evaluate::BOZLiteralConstant>(
                       expr->u)) {
@@ -316,7 +340,7 @@ static void RearrangeArguments(const characteristics::Procedure &proc,
 }
 
 bool CheckExplicitInterface(const characteristics::Procedure &proc,
-    ActualArguments &actuals, FoldingContext &context) {
+    ActualArguments &actuals, FoldingContext &context, const Scope &scope) {
   if (!RearrangeArguments(proc, actuals, context.messages())) {
     return false;
   }
@@ -324,19 +348,19 @@ bool CheckExplicitInterface(const characteristics::Procedure &proc,
   for (auto &actual : actuals) {
     const auto &dummy{proc.dummyArguments[index++]};
     if (actual.has_value()) {
-      if (!CheckExplicitInterfaceArg(*actual, dummy, context)) {
+      if (!CheckExplicitInterfaceArg(*actual, dummy, context, scope)) {
         return false;
       }
     } else if (!dummy.IsOptional()) {
       if (dummy.name.empty()) {
         context.messages().Say(
             "Dummy argument #%d is not OPTIONAL and is not associated with an "
-            "effective argument in this procedure reference"_err_en_US,
+            "actual argument in this procedure reference"_err_en_US,
             index);
       } else {
         context.messages().Say(
             "Dummy argument '%s' (#%d) is not OPTIONAL and is not associated "
-            "with an effective argument in this procedure reference"_err_en_US,
+            "with an actual argument in this procedure reference"_err_en_US,
             dummy.name, index);
       }
       return false;
@@ -347,27 +371,28 @@ bool CheckExplicitInterface(const characteristics::Procedure &proc,
 
 void CheckArguments(const characteristics::Procedure &proc,
     evaluate::ActualArguments &actuals, evaluate::FoldingContext &context,
-    bool treatingExternalAsImplicit) {
-  parser::Messages buffer;
-  parser::ContextualMessages messages{context.messages().at(), &buffer};
-  if (proc.HasExplicitInterface() && !treatingExternalAsImplicit) {
-    evaluate::FoldingContext localContext{context, messages};
-    CheckExplicitInterface(proc, actuals, localContext);
-  } else {
+    const Scope &scope, bool treatingExternalAsImplicit) {
+  bool explicitInterface{proc.HasExplicitInterface()};
+  if (explicitInterface()) {
+    CheckExplicitInterface(proc, actuals, context, scope);
+  }
+  if (!explicitInterface || treatingExternalAsImplicit) {
+    parser::Messages buffer;
+    parser::ContextualMessages messages{context.messages().at(), &buffer};
     for (auto &actual : actuals) {
       if (actual.has_value()) {
         CheckImplicitInterfaceArg(*actual, messages);
       }
     }
-  }
-  if (!buffer.empty()) {
-    if (treatingExternalAsImplicit) {
-      if (auto *msg{context.messages().Say(
-              "Warning: if the procedure's interface were explicit, this reference would be in error:"_en_US)}) {
-        buffer.AttachTo(*msg);
+    if (!buffer.empty()) {
+      if (treatingExternalAsImplicit) {
+        if (auto *msg{context.messages().Say(
+                "Warning: if the procedure's interface were explicit, this reference would be in error:"_en_US)}) {
+          buffer.AttachTo(*msg);
+        }
+      } else if (auto *msgs{context.messages().messages()}) {
+        msgs->Merge(std::move(buffer));
       }
-    } else if (auto *msgs{context.messages().messages()}) {
-      msgs->Merge(std::move(buffer));
     }
   }
 }

flang/lib/semantics/check-call.h

@@ -30,12 +30,14 @@ class FoldingContext;
 }
 
 namespace Fortran::semantics {
+class Scope;
+
 // The Boolean flag argument should be true when the called procedure
 // does not actually have an explicit interface at the call site, but
 // its characteristics are known because it is a subroutine or function
 // defined at the top level in the same source file.
 void CheckArguments(const evaluate::characteristics::Procedure &,
-    evaluate::ActualArguments &, evaluate::FoldingContext &,
+    evaluate::ActualArguments &, evaluate::FoldingContext &, const Scope &,
     bool treatingExternalAsImplicit = false);
 
 // Check actual arguments against a procedure with an explicit interface.

flang/lib/semantics/expression.cc

@@ -1800,8 +1800,8 @@ std::optional<characteristics::Procedure> ExpressionAnalyzer::CheckCall(
           "References to the procedure '%s' require an explicit interface"_en_US,
           DEREF(proc.GetSymbol()).name());
     }
-    semantics::CheckArguments(
-        *chars, arguments, GetFoldingContext(), treatExternalAsImplicit);
+    semantics::CheckArguments(*chars, arguments, GetFoldingContext(),
+        context_.FindScope(callSite), treatExternalAsImplicit);
   }
   return chars;
 }

flang/lib/semantics/tools.cc

@@ -331,10 +331,14 @@ const Symbol *FindFunctionResult(const Symbol &symbol) {
   return nullptr;
 }
 
+// When an construct association maps to a variable, and that variable
+// is not an array with a vector-valued subscript, return the base
+// Symbol of that variable, else nullptr.  Descends into other construct
+// associations when one associations maps to another.
 static const Symbol *GetAssociatedVariable(const AssocEntityDetails &details) {
   if (const MaybeExpr & expr{details.expr()}) {
-    if (evaluate::IsVariable(*expr)) {
-      if (const Symbol * varSymbol{evaluate::GetLastSymbol(*expr)}) {
+    if (evaluate::IsVariable(*expr) && !evaluate::HasVectorSubscript(*expr)) {
+      if (const Symbol * varSymbol{evaluate::GetFirstSymbol(*expr)}) {
         return GetAssociationRoot(*varSymbol);
       }
     }
@@ -485,8 +489,7 @@ bool InProtectedContext(const Symbol &symbol, const Scope &currentScope) {
 }
 
 // C1101 and C1158
-// TODO Need to check for the case of a variable that has a vector subscript
-// that is construct associated, also need to check for a coindexed object
+// TODO Need to check for a coindexed object (why? C1103?)
 std::optional<parser::MessageFixedText> WhyNotModifiable(
     const Symbol &symbol, const Scope &scope) {
   const Symbol *root{GetAssociationRoot(symbol)};
@@ -508,6 +511,31 @@ std::optional<parser::MessageFixedText> WhyNotModifiable(
   }
 }
 
+std::unique_ptr<parser::Message> WhyNotModifiable(
+    parser::CharBlock at, const SomeExpr &expr, const Scope &scope) {
+  if (evaluate::IsVariable(expr)) {
+    if (auto dataRef{evaluate::ExtractDataRef(expr)}) {
+      if (evaluate::HasVectorSubscript(expr)) {
+        return std::make_unique<parser::Message>(
+            at, "variable has a vector subscript"_en_US);
+      } else {
+        const Symbol &symbol{dataRef->GetFirstSymbol()};
+        if (auto maybeWhy{WhyNotModifiable(symbol, scope)}) {
+          return std::make_unique<parser::Message>(symbol.name(),
+              parser::MessageFormattedText{
+                  std::move(*maybeWhy), symbol.name()});
+        }
+      }
+    } else {
+      // reference to function returning POINTER
+    }
+  } else {
+    return std::make_unique<parser::Message>(
+        at, "expression is not a variable"_en_US);
+  }
+  return {};
+}
+
 static const DeclTypeSpec &InstantiateIntrinsicType(Scope &scope,
     const DeclTypeSpec &spec, SemanticsContext &semanticsContext) {
   const IntrinsicTypeSpec *intrinsic{spec.AsIntrinsic()};

flang/lib/semantics/tools.h

@@ -114,7 +114,9 @@ inline bool IsAssumedSizeArray(const Symbol &symbol) {
 bool IsAssumedLengthCharacter(const Symbol &);
 bool IsAssumedLengthCharacterFunction(const Symbol &);
 std::optional<parser::MessageFixedText> WhyNotModifiable(
-    const Symbol &symbol, const Scope &scope);
+    const Symbol &, const Scope &);
+std::unique_ptr<parser::Message> WhyNotModifiable(
+    SourceName, const SomeExpr &, const Scope &);
 // Is the symbol modifiable in this scope
 bool IsExternalInPureContext(const Symbol &symbol, const Scope &scope);
 

flang/test/semantics/call03.f90

@@ -194,10 +194,10 @@ module m01
     call intentout(3.14159)
     !ERROR: Actual argument associated with INTENT(OUT) dummy must be definable
     call intentout(in + 1.)
-    !ERROR: Actual argument associated with INTENT(OUT) dummy must be definable
     call intentout(x) ! ok
     !ERROR: Actual argument associated with INTENT(OUT) dummy must be definable
     call intentout((x))
+    !ERROR: Actual argument associated with INTENT(IN OUT) dummy must be definable
     call intentinout(in)
     !ERROR: Actual argument associated with INTENT(IN OUT) dummy must be definable
     call intentinout(3.14159)
@@ -212,13 +212,13 @@ module m01
     real :: a(1)
     integer :: j(1)
     j(1) = 1
-    !ERROR: array section with vector subscript cannot be associated with a dummy argument that must be definable
+    !ERROR: Actual argument associated with INTENT(OUT) dummy must be definable
     call intentout(a(j))
-    !ERROR: array section with vector subscript cannot be associated with a dummy argument that must be definable
+    !ERROR: Actual argument associated with INTENT(IN OUT) dummy must be definable
     call intentinout(a(j))
-    !ERROR: array section with vector subscript cannot be associated with a dummy argument that must be definable
+    !ERROR: Actual argument associated with ASYNCHRONOUS dummy must be definable
     call asynchronous(a(j))
-    !ERROR: array section with vector subscript cannot be associated with a dummy argument that must be definable
+    !ERROR: Actual argument associated with VOLATILE dummy must be definable
     call volatile(a(j))
   end subroutine