[flang] Make per-argument intrinsic error messages more localized

[klausler]

Summary

A recent patch made it possible to emit more localized error messages
pertaining to actual arguments in non-intrinsic procedure references.
Use these new powers for good and make intrinsic error messages more
precise, too.

flang/include/flang/Parser/message.h

if (messages_ != nullptr) {
         msg.SetContext(contextMessage_.get());
       }
       return &msg;
     } else {
       return nullptr;
     }
   }
 
+  template <typename... A>
+  Message *Say(std::optional<CharBlock> at, A &&...args) {
+    return Say(at.value_or(at_), std::forward<A>(args)...);
+  }
+
   template <typename... A> Message *Say(A &&...args) {
     return Say(at_, std::forward<A>(args)...);
   }
 
 private:
   CharBlock at_;
   Messages *messages_{nullptr};
   Message::Reference contextMessage_;
 };
 } // namespace Fortran::parser
 #endif // FORTRAN_PARSER_MESSAGE_H_

flang/lib/Evaluate/intrinsics.cpp

std::optional<SpecificCall> IntrinsicInterface::Match(
   std::vector<ActualArgument *> actualForDummy(
       isMaxMin ? 0 : dummyArgPatterns, nullptr);
   int missingActualArguments{0};
   std::set<parser::CharBlock> maxMinKeywords;
   for (std::optional<ActualArgument> &arg : arguments) {
     if (!arg) {
       ++missingActualArguments;
     } else if (arg->isAlternateReturn()) {
-      messages.Say(
+      messages.Say(arg->sourceLocation(),
           "alternate return specifier not acceptable on call to intrinsic '%s'"_err_en_US,
           name);
       return std::nullopt;
     } else if (isMaxMin) {
       if (CheckMaxMinArgument(arg->keyword(), maxMinKeywords, name, messages)) {
         actualForDummy.push_back(&*arg);
       } else {
         return std::nullopt;
for (std::size_t j{0}; j < dummies; ++j) {
     if (!arg) {
       if (d.optionality == Optionality::required) {
         messages.Say("missing mandatory '%s=' argument"_err_en_US, d.keyword);
         return std::nullopt; // missing non-OPTIONAL argument
       } else {
         continue;
       }
     } else if (d.optionality == Optionality::missing) {
-      messages.Say("unexpected '%s=' argument"_err_en_US, d.keyword);
+      messages.Say(arg->sourceLocation(), "unexpected '%s=' argument"_err_en_US,
+          d.keyword);
       return std::nullopt;
     }
     if (arg->GetAssumedTypeDummy()) {
       // TYPE(*) assumed-type dummy argument forwarded to intrinsic
       if (d.typePattern.categorySet == AnyType &&
           d.rank == Rank::anyOrAssumedRank &&
           (d.typePattern.kindCode == KindCode::any ||
               d.typePattern.kindCode == KindCode::addressable)) {
         continue;
       } else {
-        messages.Say("Assumed type TYPE(*) dummy argument not allowed "
-                     "for '%s=' intrinsic argument"_err_en_US,
+        messages.Say(arg->sourceLocation(),
+            "Assumed type TYPE(*) dummy argument not allowed for '%s=' intrinsic argument"_err_en_US,
             d.keyword);
         return std::nullopt;
       }
     }
     std::optional<DynamicType> type{arg->GetType()};
     if (!type) {
       CHECK(arg->Rank() == 0);
       const Expr<SomeType> &expr{DEREF(arg->UnwrapExpr())};
       if (IsBOZLiteral(expr)) {
         if (d.typePattern.kindCode == KindCode::typeless ||
             d.rank == Rank::elementalOrBOZ) {
           continue;
         } else {
           const IntrinsicDummyArgument *nextParam{
               j + 1 < dummies ? &dummy[j + 1] : nullptr};
           if (nextParam && nextParam->rank == Rank::elementalOrBOZ) {
-            messages.Say(
+            messages.Say(arg->sourceLocation(),
                 "Typeless (BOZ) not allowed for both '%s=' & '%s=' arguments"_err_en_US, // C7109
                 d.keyword, nextParam->keyword);
           } else {
-            messages.Say(
+            messages.Say(arg->sourceLocation(),
                 "Typeless (BOZ) not allowed for '%s=' argument"_err_en_US,
                 d.keyword);
           }
         }
       } else {
         // NULL(), procedure, or procedure pointer
         CHECK(IsProcedurePointerTarget(expr));
         if (d.typePattern.kindCode == KindCode::addressable ||
             d.rank == Rank::reduceOperation) {
           continue;
         } else if (d.typePattern.kindCode == KindCode::nullPointerType) {
           continue;
         } else {
-          messages.Say(
+          messages.Say(arg->sourceLocation(),
               "Actual argument for '%s=' may not be a procedure"_err_en_US,
               d.keyword);
         }
       }
       return std::nullopt;
     } else if (!d.typePattern.categorySet.test(type->category())) {
-      messages.Say("Actual argument for '%s=' has bad type '%s'"_err_en_US,
-          d.keyword, type->AsFortran());
+      messages.Say(arg->sourceLocation(),
+          "Actual argument for '%s=' has bad type '%s'"_err_en_US, d.keyword,
+          type->AsFortran());
       return std::nullopt; // argument has invalid type category
     }
     bool argOk{false};
     switch (d.typePattern.kindCode) {
     case KindCode::none:
     case KindCode::typeless:
       argOk = false;
       break;
case KindCode::nullPointerType:
       break;
     case KindCode::exactKind:
       argOk = type->kind() == d.typePattern.exactKindValue;
       break;
     default:
       CRASH_NO_CASE;
     }
     if (!argOk) {
-      messages.Say(
+      messages.Say(arg->sourceLocation(),
           "Actual argument for '%s=' has bad type or kind '%s'"_err_en_US,
           d.keyword, type->AsFortran());
       return std::nullopt;
     }
   }
 
   // Check the ranks of the arguments against the intrinsic's interface.
   const ActualArgument *arrayArg{nullptr};
   const char *arrayArgName{nullptr};
   const ActualArgument *knownArg{nullptr};
   std::optional<int> shapeArgSize;
   int elementalRank{0};
   for (std::size_t j{0}; j < dummies; ++j) {
     const IntrinsicDummyArgument &d{dummy[std::min(j, dummyArgPatterns - 1)]};
     if (const ActualArgument * arg{actualForDummy[j]}) {
       bool isAssumedRank{IsAssumedRank(*arg)};
       if (isAssumedRank && d.rank != Rank::anyOrAssumedRank) {
-        messages.Say("Assumed-rank array cannot be forwarded to "
-                     "'%s=' argument"_err_en_US,
+        messages.Say(arg->sourceLocation(),
+            "Assumed-rank array cannot be forwarded to '%s=' argument"_err_en_US,
             d.keyword);
         return std::nullopt;
       }
       int rank{arg->Rank()};
       bool argOk{false};
       switch (d.rank) {
       case Rank::elemental:
       case Rank::elementalOrBOZ:
         if (elementalRank == 0) {
           elementalRank = rank;
         }
         argOk = rank == 0 || rank == elementalRank;
         break;
       case Rank::scalar:
         argOk = rank == 0;
         break;
       case Rank::vector:
         argOk = rank == 1;
         break;
       case Rank::shape:
         CHECK(!shapeArgSize);
         if (rank != 1) {
-          messages.Say(
+          messages.Say(arg->sourceLocation(),
               "'shape=' argument must be an array of rank 1"_err_en_US);
           return std::nullopt;
         } else {
           if (auto shape{GetShape(context, *arg)}) {
             if (auto constShape{AsConstantShape(context, *shape)}) {
               shapeArgSize = constShape->At(ConstantSubscripts{1}).ToInt64();
               CHECK(shapeArgSize >= 0);
               argOk = true;
             }
           }
         }
         if (!argOk) {
-          messages.Say(
+          messages.Say(arg->sourceLocation(),
               "'shape=' argument must be a vector of known size"_err_en_US);
           return std::nullopt;
         }
         break;
       case Rank::matrix:
         argOk = rank == 2;
         break;
       case Rank::array:
         argOk = rank > 0;
         if (!arrayArg) {
           arrayArg = arg;
           arrayArgName = d.keyword;
         }
         break;
       case Rank::coarray:
         argOk = IsCoarray(*arg);
         if (!argOk) {
-          messages.Say(
+          messages.Say(arg->sourceLocation(),
               "'coarray=' argument must have corank > 0 for intrinsic '%s'"_err_en_US,
               name);
           return std::nullopt;
         }
         break;
       case Rank::known:
         if (!knownArg) {
           knownArg = arg;
if (const ActualArgument * arg{actualForDummy[j]}) {
           // These are disallowed for SHAPE, and require DIM= for
           // SIZE and UBOUND.
           // (A previous error message for UBOUND will take precedence
           // over this one, as this error is caught by the second entry
           // for UBOUND.)
           if (std::optional<Shape> shape{GetShape(context, *arg)}) {
             if (!shape->empty() && !shape->back().has_value()) {
               if (strcmp(name, "shape") == 0) {
-                messages.Say(
+                messages.Say(arg->sourceLocation(),
                     "The '%s=' argument to the intrinsic function '%s' may not be assumed-size"_err_en_US,
                     d.keyword, name);
               } else {
-                messages.Say(
+                messages.Say(arg->sourceLocation(),
                     "A dim= argument is required for '%s' when the array is assumed-size"_err_en_US,
                     name);
               }
               return std::nullopt;
             }
           }
         }
         argOk = true;
if (const ActualArgument * arg{actualForDummy[j]}) {
       case Rank::locReduced:
       case Rank::rankPlus1:
       case Rank::shaped:
         common::die("INTERNAL: result-only rank code appears on argument '%s' "
                     "for intrinsic '%s'",
             d.keyword, name);
       }
       if (!argOk) {
-        messages.Say("'%s=' argument has unacceptable rank %d"_err_en_US,
-            d.keyword, rank);
+        messages.Say(arg->sourceLocation(),
+            "'%s=' argument has unacceptable rank %d"_err_en_US, d.keyword,
+            rank);
         return std::nullopt;
       }
     }
   }
 
   // Calculate the characteristics of the function result, if any
   std::optional<DynamicType> resultType;
   if (auto category{result.categorySet.LeastElement()}) {
if (arg && arg->keyword()) {
         }
       }
       if (dummyIndex >= numDummies) {
         messages.Say(*arg->keyword(),
             "Unknown argument keyword '%s='"_err_en_US, *arg->keyword());
         return false;
       }
     } else if (anyKeywords) {
-      messages.Say(
+      messages.Say(arg ? arg->sourceLocation() : messages.at(),
           "A positional actual argument may not appear after any keyword arguments"_err_en_US);
       return false;
     } else {
       dummyIndex = position++;
     }
     if (rearranged[dummyIndex]) {
-      messages.Say("Dummy argument '%s=' appears more than once"_err_en_US,
+      messages.Say(arg ? arg->sourceLocation() : messages.at(),
+          "Dummy argument '%s=' appears more than once"_err_en_US,
           dummyKeywords[dummyIndex]);
       return false;
     }
     rearranged[dummyIndex] = std::move(arg);
     arg.reset();
   }
   bool anyMissing{false};
   for (std::size_t j{0}; j < numDummies - trailingOptionals; ++j) {
if (Expr<SomeType> * mold{arguments[0]->UnwrapExpr()}) {
         } else if (auto type{mold->GetType()}) {
           // MOLD= object pointer
           characteristics::TypeAndShape typeAndShape{
               *type, GetShape(context, *mold)};
           args.emplace_back(
               "mold"s, characteristics::DummyDataObject{typeAndShape});
           fResult.emplace(std::move(typeAndShape));
         } else {
-          context.messages().Say(
+          context.messages().Say(arguments[0]->sourceLocation(),
               "MOLD= argument to NULL() lacks type"_err_en_US);
         }
         if (goodProcPointer) {
           fResult->attrs.set(characteristics::FunctionResult::Attr::Pointer);
           characteristics::Procedure::Attrs attrs;
           attrs.set(characteristics::Procedure::Attr::NullPointer);
           characteristics::Procedure chars{
               std::move(*fResult), std::move(args), attrs};
           return SpecificCall{SpecificIntrinsic{"null"s, std::move(chars)},
               std::move(arguments)};
         }
       }
     }
-    context.messages().Say(
+    context.messages().Say(arguments[0]->sourceLocation(),
         "MOLD= argument to NULL() must be a pointer or allocatable"_err_en_US);
   }
   characteristics::Procedure::Attrs attrs;
   attrs.set(characteristics::Procedure::Attr::NullPointer);
   attrs.set(characteristics::Procedure::Attr::Pure);
   arguments.clear();
   return SpecificCall{
       SpecificIntrinsic{"null"s,
IntrinsicProcTable::Implementation::HandleC_F_Pointer(
   characteristics::Procedure::Attrs attrs;
   attrs.set(characteristics::Procedure::Attr::Subroutine);
   static const char *const keywords[]{"cptr", "fptr", "shape", nullptr};
   characteristics::DummyArguments dummies;
   if (CheckAndRearrangeArguments(arguments, context.messages(), keywords, 1)) {
     CHECK(arguments.size() == 3);
     if (const auto *expr{arguments[0].value().UnwrapExpr()}) {
       if (expr->Rank() > 0) {
-        context.messages().Say(
+        context.messages().Say(arguments[0]->sourceLocation(),
             "CPTR= argument to C_F_POINTER() must be scalar"_err_en_US);
       }
       if (auto type{expr->GetType()}) {
         if (type->category() != TypeCategory::Derived ||
             type->IsPolymorphic() ||
             type->GetDerivedTypeSpec().typeSymbol().name() !=
                 "__builtin_c_ptr") {
-          context.messages().Say(
+          context.messages().Say(arguments[0]->sourceLocation(),
               "CPTR= argument to C_F_POINTER() must be a C_PTR"_err_en_US);
         }
         characteristics::DummyDataObject cptr{
             characteristics::TypeAndShape{*type}};
         cptr.intent = common::Intent::In;
         dummies.emplace_back("cptr"s, std::move(cptr));
       }
     }
     if (const auto *expr{arguments[1].value().UnwrapExpr()}) {
       int fptrRank{expr->Rank()};
       if (auto type{expr->GetType()}) {
         if (type->HasDeferredTypeParameter()) {
-          context.messages().Say(
+          context.messages().Say(arguments[1]->sourceLocation(),
               "FPTR= argument to C_F_POINTER() may not have a deferred type parameter"_err_en_US);
         }
         if (ExtractCoarrayRef(*expr)) {
-          context.messages().Say(
+          context.messages().Say(arguments[1]->sourceLocation(),
               "FPTR= argument to C_F_POINTER() may not be a coindexed object"_err_en_US);
         }
         characteristics::DummyDataObject fptr{
             characteristics::TypeAndShape{*type, fptrRank}};
         fptr.intent = common::Intent::Out;
         fptr.attrs.set(characteristics::DummyDataObject::Attr::Pointer);
         dummies.emplace_back("fptr"s, std::move(fptr));
       } else {
-        context.messages().Say(
+        context.messages().Say(arguments[1]->sourceLocation(),
             "FPTR= argument to C_F_POINTER() must have a type"_err_en_US);
       }
       if (arguments[2] && fptrRank == 0) {
-        context.messages().Say(
+        context.messages().Say(arguments[2]->sourceLocation(),
             "SHAPE= argument to C_F_POINTER() may not appear when FPTR= is scalar"_err_en_US);
       } else if (!arguments[2] && fptrRank > 0) {
         context.messages().Say(
             "SHAPE= argument to C_F_POINTER() must appear when FPTR= is an array"_err_en_US);
       }
     }
   }
   if (dummies.size() == 2) {

 }
 
 static bool CheckAssociated(SpecificCall &call, FoldingContext &context) {
   bool ok{true};
   if (const auto &pointerArg{call.arguments[0]}) {
     if (const auto *pointerExpr{pointerArg->UnwrapExpr()}) {
       if (const Symbol * pointerSymbol{GetLastSymbol(*pointerExpr)}) {
         if (!pointerSymbol->attrs().test(semantics::Attr::POINTER)) {
-          AttachDeclaration(context.messages().Say(
+          AttachDeclaration(context.messages().Say(pointerArg->sourceLocation(),
                                 "POINTER= argument of ASSOCIATED() must be a "
                                 "POINTER"_err_en_US),
               *pointerSymbol);
         } else {
           if (const auto &targetArg{call.arguments[1]}) {
             if (const auto *targetExpr{targetArg->UnwrapExpr()}) {
               std::optional<characteristics::Procedure> pointerProc, targetProc;
               const Symbol *targetSymbol{GetLastSymbol(*targetExpr)};
if (const auto *pointerExpr{pointerArg->UnwrapExpr()}) {
                         pointerSymbol->name(), targetName),
                     *pointerSymbol);
               } else if (targetSymbol) {
                 // object pointer and target
                 SymbolVector symbols{GetSymbolVector(*targetExpr)};
                 CHECK(!symbols.empty());
                 if (!GetLastTarget(symbols)) {
                   parser::Message *msg{context.messages().Say(
+                      targetArg->sourceLocation(),
                       "TARGET= argument '%s' must have either the POINTER or the TARGET attribute"_err_en_US,
                       targetExpr->AsFortran())};
                   for (SymbolRef ref : symbols) {
                     msg = AttachDeclaration(msg, *ref);
                   }
                 }
                 if (const auto pointerType{pointerArg->GetType()}) {
                   if (const auto targetType{targetArg->GetType()}) {
static bool CheckAssociated(SpecificCall &call, FoldingContext &context) {
   return ok;
 }
 
 // Applies any semantic checks peculiar to an intrinsic.
 static bool ApplySpecificChecks(SpecificCall &call, FoldingContext &context) {
   bool ok{true};
   const std::string &name{call.specificIntrinsic.name};
   if (name == "allocated") {
-    if (const auto &arg{call.arguments[0]}) {
+    const auto &arg{call.arguments[0]};
+    if (arg) {
       if (const auto *expr{arg->UnwrapExpr()}) {
         if (const Symbol * symbol{GetLastSymbol(*expr)}) {
           ok = symbol->attrs().test(semantics::Attr::ALLOCATABLE);
         }
       }
     }
     if (!ok) {
       context.messages().Say(
+          arg ? arg->sourceLocation() : context.messages().at(),
           "Argument of ALLOCATED() must be an ALLOCATABLE object or component"_err_en_US);
     }
   } else if (name == "associated") {
     return CheckAssociated(call, context);
   } else if (name == "loc") {
-    if (const auto &arg{call.arguments[0]}) {
-      ok = arg->GetAssumedTypeDummy() || GetLastSymbol(arg->UnwrapExpr());
-    }
+    const auto &arg{call.arguments[0]};
+    ok =
+        arg && (arg->GetAssumedTypeDummy() || GetLastSymbol(arg->UnwrapExpr()));
     if (!ok) {
       context.messages().Say(
+          arg ? arg->sourceLocation() : context.messages().at(),
           "Argument of LOC() must be an object or procedure"_err_en_US);
     }
   } else if (name == "present") {
-    if (const auto &arg{call.arguments[0]}) {
+    const auto &arg{call.arguments[0]};
+    if (arg) {
       if (const auto *expr{arg->UnwrapExpr()}) {
         if (const Symbol * symbol{UnwrapWholeSymbolDataRef(*expr)}) {
           ok = symbol->attrs().test(semantics::Attr::OPTIONAL);
         }
       }
     }
     if (!ok) {
       context.messages().Say(
+          arg ? arg->sourceLocation() : context.messages().at(),
           "Argument of PRESENT() must be the name of an OPTIONAL dummy argument"_err_en_US);
     }
   }
   return ok;
 }
 
 static DynamicType GetReturnType(const SpecificIntrinsicInterface &interface,
     const common::IntrinsicTypeDefaultKinds &defaults) {