[flang] Allow restricted specific intrinsic functions as implicitly-interfaced procedure pointer targets

[klausler]

Summary

The predicate "CanBeCalledViaImplicitInterface()" was returning false for
restricted specific intrinsic functions (e.g., SIN) because their procedure
characteristics have the elemental attribute; this leads to a bogus semantic
error when one attempts to use them as proc-targets in procedure pointer
assignment statements when the left-hand side of the assignment is a procedure
pointer with an implicit interface. However, these restricted specific intrinsic
functions have always been allowed as special cases for such usage -- it is
as if they are elemental when it is necessary for them to be so, but not
when it's a problem.

[klausler]

Rebase

[jeanPerier]

Build bots is hitting a failure in Semantics/associated.f90

[klausler]

In D130386#3676181, @jeanPerier wrote:

Build bots is hitting a failure in Semantics/associated.f90

It'll clear up after other patches are merged and I rebase.

[jeanPerier]

In D130386#3676552, @klausler wrote:

In D130386#3676181, @jeanPerier wrote:

Build bots is hitting a failure in Semantics/associated.f90

It'll clear up after other patches are merged and I rebase.

OK, the patch looks good otherwise, you do not need me to check the bots.

[klausler]

Rebase

[ekieri]

I am sorry the warning patch (D125804) is taking so long, I have not found much time to work with Flang lately. This patch causes a mismatch between emitted and expected warnings in associated.f90, line 141. Could you please have a look to see if the changed warning message is deliberate or not?

[klausler]

In D130386#3726982, @ekieri wrote:

I am sorry the warning patch (D125804) is taking so long, I have not found much time to work with Flang lately. This patch causes a mismatch between emitted and expected warnings in associated.f90, line 141. Could you please have a look to see if the changed warning message is deliberate or not?

A warning is appropriate there.

[ekieri]

In D130386#3727156, @klausler wrote:

In D130386#3726982, @ekieri wrote:

I am sorry the warning patch (D125804) is taking so long, I have not found much time to work with Flang lately. This patch causes a mismatch between emitted and expected warnings in associated.f90, line 141. Could you please have a look to see if the changed warning message is deliberate or not?

A warning is appropriate there.

Agree. Previously, the warning was about the dummy variable having incompatible attributes (intent(in) and value, respectively) for pointer and target. Now it is about the procedure being elemental when the pointer is not. Can you confirm this change is desired? Sorry if I was unclear.

[klausler]

In D130386#3728999, @ekieri wrote:

In D130386#3727156, @klausler wrote:

In D130386#3726982, @ekieri wrote:

I am sorry the warning patch (D125804) is taking so long, I have not found much time to work with Flang lately. This patch causes a mismatch between emitted and expected warnings in associated.f90, line 141. Could you please have a look to see if the changed warning message is deliberate or not?

A warning is appropriate there.

Agree. Previously, the warning was about the dummy variable having incompatible attributes (intent(in) and value, respectively) for pointer and target. Now it is about the procedure being elemental when the pointer is not. Can you confirm this change is desired? Sorry if I was unclear.

Yes, the current warning is correct.

flang/include/flang/Evaluate/characteristics.h

struct Procedure {
   bool IsElemental() const { return attrs.test(Attr::Elemental); }
   bool IsBindC() const { return attrs.test(Attr::BindC); }
   bool HasExplicitInterface() const {
     return !attrs.test(Attr::ImplicitInterface);
   }
   int FindPassIndex(std::optional<parser::CharBlock>) const;
   bool CanBeCalledViaImplicitInterface() const;
   bool CanOverride(const Procedure &, std::optional<int> passIndex) const;
-  bool IsCompatibleWith(const Procedure &, std::string *whyNot = nullptr) const;
+  bool IsCompatibleWith(const Procedure &, std::string *whyNot = nullptr,
+      const SpecificIntrinsic * = nullptr) const;
 
   llvm::raw_ostream &Dump(llvm::raw_ostream &) const;
 
   std::optional<FunctionResult> functionResult;
   DummyArguments dummyArguments;
   Attrs attrs;
 };
 } // namespace Fortran::evaluate::characteristics
 #endif // FORTRAN_EVALUATE_CHARACTERISTICS_H_

flang/include/flang/Evaluate/tools.h

 }
 
 // Common handling for procedure pointer compatibility of left- and right-hand
 // sides.  Returns nullopt if they're compatible.  Otherwise, it returns a
 // message that needs to be augmented by the names of the left and right sides
 std::optional<parser::MessageFixedText> CheckProcCompatibility(bool isCall,
     const std::optional<characteristics::Procedure> &lhsProcedure,
     const characteristics::Procedure *rhsProcedure,
-    std::string &whyNotCompatible);
+    const SpecificIntrinsic *specificIntrinsic, std::string &whyNotCompatible);
 
 // Scalar constant expansion
 class ScalarConstantExpander {
 public:
   explicit ScalarConstantExpander(ConstantSubscripts &&extents)
       : extents_{std::move(extents)} {}
   ScalarConstantExpander(
       ConstantSubscripts &&extents, std::optional<ConstantSubscripts> &&lbounds)

flang/lib/Evaluate/characteristics.cpp

 #include "flang/Evaluate/check-expression.h"
 #include "flang/Evaluate/fold.h"
 #include "flang/Evaluate/intrinsics.h"
 #include "flang/Evaluate/tools.h"
 #include "flang/Evaluate/type.h"
 #include "flang/Parser/message.h"
 #include "flang/Semantics/scope.h"
 #include "flang/Semantics/symbol.h"
+#include "flang/Semantics/tools.h"
 #include "llvm/Support/raw_ostream.h"
 #include <initializer_list>
 
 using namespace Fortran::parser::literals;
 
 namespace Fortran::evaluate::characteristics {
 
 // Copy attributes from a symbol to dst based on the mapping in pairs.
if (seenProcs.find(symbol) != seenProcs.end()) {
     std::string procsList{GetSeenProcs(seenProcs)};
     context.messages().Say(symbol.name(),
         "Procedure '%s' is recursively defined.  Procedures in the cycle:"
         " %s"_err_en_US,
         symbol.name(), procsList);
     return std::nullopt;
   }
   seenProcs.insert(symbol);
+  if (IsElementalProcedure(symbol)) {
+    result.attrs.set(Procedure::Attr::Elemental);
+  }
   CopyAttrs<Procedure, Procedure::Attr>(symbol, result,
       {
-          {semantics::Attr::ELEMENTAL, Procedure::Attr::Elemental},
           {semantics::Attr::BIND_C, Procedure::Attr::BindC},
       });
   if (IsPureProcedure(symbol) || // works for ENTRY too
       (!symbol.attrs().test(semantics::Attr::IMPURE) &&
           result.attrs.test(Procedure::Attr::Elemental))) {
     result.attrs.set(Procedure::Attr::Pure);
   }
   return common::visit(
return common::visit(
                   symbol.name().ToString())};
               if (intrinsic && intrinsic->isRestrictedSpecific) {
                 intrinsic.reset(); // Exclude intrinsics from table 16.3.
               }
               return intrinsic;
             }
             const semantics::ProcInterface &interface { proc.interface() };
             if (const semantics::Symbol * interfaceSymbol{interface.symbol()}) {
-              return CharacterizeProcedure(
-                  *interfaceSymbol, context, seenProcs);
+              auto interface {
+                CharacterizeProcedure(*interfaceSymbol, context, seenProcs)
+              };
+              if (interface && IsPointer(symbol)) {
+                interface->attrs.reset(Procedure::Attr::Elemental);
+              }
+              return interface;
             } else {
               result.attrs.set(Procedure::Attr::ImplicitInterface);
               const semantics::DeclTypeSpec *type{interface.type()};
               if (symbol.test(semantics::Symbol::Flag::Subroutine)) {
                 // ignore any implicit typing
                 result.attrs.set(Procedure::Attr::Subroutine);
               } else if (type) {
                 if (auto resultType{DynamicType::From(*type)}) {
Procedure::Procedure(DummyArguments &&args, Attrs a)
     : dummyArguments{std::move(args)}, attrs{a} {}
 Procedure::~Procedure() {}
 
 bool Procedure::operator==(const Procedure &that) const {
   return attrs == that.attrs && functionResult == that.functionResult &&
       dummyArguments == that.dummyArguments;
 }
 
-bool Procedure::IsCompatibleWith(
-    const Procedure &actual, std::string *whyNot) const {
+bool Procedure::IsCompatibleWith(const Procedure &actual, std::string *whyNot,
+    const SpecificIntrinsic *specificIntrinsic) const {
   // 15.5.2.9(1): if dummy is not pure, actual need not be.
   // Ditto with elemental.
   Attrs actualAttrs{actual.attrs};
   if (!attrs.test(Attr::Pure)) {
     actualAttrs.reset(Attr::Pure);
   }
-  if (!attrs.test(Attr::Elemental)) {
+  if (!attrs.test(Attr::Elemental) && specificIntrinsic) {
     actualAttrs.reset(Attr::Elemental);
   }
   Attrs differences{attrs ^ actualAttrs};
   differences.reset(Attr::Subroutine); // dealt with specifically later
   if (!differences.empty()) {
     if (whyNot) {
       auto sep{": "s};
       *whyNot = "incompatible procedure attributes";

flang/lib/Evaluate/intrinsics.cpp

IntrinsicProcTable::Implementation::HandleC_F_Pointer(
     ActualArguments &arguments, FoldingContext &context) const {
   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(arguments[0]->sourceLocation(),
-            "CPTR= argument to C_F_POINTER() must be scalar"_err_en_US);
-      }
+      // General semantic checks will catch an actual argument that's not
+      // scalar.
       if (auto type{expr->GetType()}) {
         if (type->category() != TypeCategory::Derived ||
             type->IsPolymorphic() ||
             type->GetDerivedTypeSpec().typeSymbol().name() !=
                 "__builtin_c_ptr") {
           context.messages().Say(arguments[0]->sourceLocation(),
               "CPTR= argument to C_F_POINTER() must be a C_PTR"_err_en_US);
         }
if (const auto *pointerExpr{pointerArg->UnwrapExpr()}) {
           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 auto *targetProcDesignator{
+                  UnwrapExpr<ProcedureDesignator>(*targetExpr)};
               const Symbol *targetSymbol{GetLastSymbol(*targetExpr)};
               bool isCall{false};
               std::string targetName;
               if (const auto *targetProcRef{// target is a function call
                       std::get_if<ProcedureRef>(&targetExpr->u)}) {
                 if (auto targetRefedChars{
                         characteristics::Procedure::Characterize(
                             *targetProcRef, context)}) {
                   targetProc = *targetRefedChars;
                   targetName = targetProcRef->proc().GetName() + "()";
                   isCall = true;
                 }
+              } else if (targetProcDesignator) {
+                targetProc = characteristics::Procedure::Characterize(
+                    *targetProcDesignator, context);
+                targetName = targetProcDesignator->GetName();
               } else if (targetSymbol) {
                 // proc that's not a call
                 if (IsProcedure(*targetSymbol)) {
                   targetProc = characteristics::Procedure::Characterize(
                       *targetSymbol, context);
                 }
                 targetName = targetSymbol->name().ToString();
               }
               if (IsProcedure(*pointerSymbol)) {
                 pointerProc = characteristics::Procedure::Characterize(
                     *pointerSymbol, context);
               }
               if (pointerProc) {
                 if (targetProc) {
                   // procedure pointer and procedure target
                   std::string whyNot;
+                  const SpecificIntrinsic *specificIntrinsic{nullptr};
+                  if (targetProcDesignator) {
+                    specificIntrinsic =
+                        targetProcDesignator->GetSpecificIntrinsic();
+                  }
                   if (std::optional<parser::MessageFixedText> msg{
-                          CheckProcCompatibility(
-                              isCall, pointerProc, &*targetProc, whyNot)}) {
+                          CheckProcCompatibility(isCall, pointerProc,
+                              &*targetProc, specificIntrinsic, whyNot)}) {
                     msg->set_severity(parser::Severity::Warning);
                     AttachDeclaration(
                         context.messages().Say(std::move(*msg),
                             "pointer '" + pointerSymbol->name().ToString() +
                                 "'",
                             targetName, whyNot),
                         *pointerSymbol);
                   }

flang/lib/Evaluate/tools.cpp

 
 // Common handling for procedure pointer compatibility of left- and right-hand
 // sides.  Returns nullopt if they're compatible.  Otherwise, it returns a
 // message that needs to be augmented by the names of the left and right sides
 // and the content of the "whyNotCompatible" string.
 std::optional<parser::MessageFixedText> CheckProcCompatibility(bool isCall,
     const std::optional<characteristics::Procedure> &lhsProcedure,
     const characteristics::Procedure *rhsProcedure,
-    std::string &whyNotCompatible) {
+    const SpecificIntrinsic *specificIntrinsic, std::string &whyNotCompatible) {
   std::optional<parser::MessageFixedText> msg;
   if (!lhsProcedure) {
     msg = "In assignment to object %s, the target '%s' is a procedure"
           " designator"_err_en_US;
   } else if (!rhsProcedure) {
     msg = "In assignment to procedure %s, the characteristics of the target"
           " procedure '%s' could not be determined"_err_en_US;
-  } else if (lhsProcedure->IsCompatibleWith(*rhsProcedure, &whyNotCompatible)) {
+  } else if (lhsProcedure->IsCompatibleWith(
+                 *rhsProcedure, &whyNotCompatible, specificIntrinsic)) {
     // OK
   } else if (isCall) {
     msg = "Procedure %s associated with result of reference to function '%s'"
           " that is an incompatible procedure pointer: %s"_err_en_US;
   } else if (lhsProcedure->IsPure() && !rhsProcedure->IsPure()) {
     msg = "PURE procedure %s may not be associated with non-PURE"
           " procedure designator '%s'"_err_en_US;
   } else if (lhsProcedure->IsFunction() && rhsProcedure->IsSubroutine()) {
     msg = "Function %s may not be associated with subroutine"
           " designator '%s'"_err_en_US;
   } else if (lhsProcedure->IsSubroutine() && rhsProcedure->IsFunction()) {
     msg = "Subroutine %s may not be associated with function"
           " designator '%s'"_err_en_US;
   } else if (lhsProcedure->HasExplicitInterface() &&
       !rhsProcedure->HasExplicitInterface()) {
     // Section 10.2.2.4, paragraph 3 prohibits associating a procedure pointer
-    // with an explicit interface with a procedure whose characteristics don't
-    // match.  That's the case if the target procedure has an implicit
+    // that has an explicit interface with a procedure whose characteristics
+    // don't match.  That's the case if the target procedure has an implicit
     // interface.  But this case is allowed by several other compilers as long
     // as the explicit interface can be called via an implicit interface.
     if (!lhsProcedure->CanBeCalledViaImplicitInterface()) {
       msg = "Procedure %s with explicit interface that cannot be called via "
             "an implicit interface cannot be associated with procedure "
             "designator with an implicit interface"_err_en_US;
     }
   } else if (!lhsProcedure->HasExplicitInterface() &&
       rhsProcedure->HasExplicitInterface()) {
     // OK if the target can be called via an implicit interface
-    if (!rhsProcedure->CanBeCalledViaImplicitInterface()) {
+    if (!rhsProcedure->CanBeCalledViaImplicitInterface() &&
+        !specificIntrinsic) {
       msg = "Procedure %s with implicit interface may not be associated "
             "with procedure designator '%s' with explicit interface that "
             "cannot be called via an implicit interface"_err_en_US;
     }
   } else {
     msg = "Procedure %s associated with incompatible procedure"
           " designator '%s': %s"_err_en_US;
   }

flang/lib/Semantics/check-call.cpp

if (auto converted{
       actualType.type() = dummy.type.type();
       typesCompatible = true;
     }
   }
   if (typesCompatible) {
     if (isElemental) {
     } else if (dummy.type.attrs().test(
                    characteristics::TypeAndShape::Attr::AssumedRank)) {
-    } else if (!dummy.type.attrs().test(
-                   characteristics::TypeAndShape::Attr::AssumedShape) &&
+    } else if (dummy.type.Rank() > 0 &&
+        !dummy.type.attrs().test(
         !dummy.type.attrs().test(
             characteristics::TypeAndShape::Attr::DeferredShape) &&
         (actualType.Rank() > 0 || IsArrayElement(actual))) {
       // Sequence association (15.5.2.11) applies -- rank need not match
       // if the actual argument is an array or array element designator,
-      // and the dummy is not assumed-shape or an INTENT(IN) pointer
-      // that's standing in for an assumed-shape dummy.
+      // and the dummy is an array, but not assumed-shape or an INTENT(IN)
+      // pointer that's standing in for an assumed-shape dummy.
     } else {
-      // Let CheckConformance accept scalars; storage association
+      // Let CheckConformance accept actual scalars; storage association
       // cases are checked here below.
       CheckConformance(messages, dummy.type.shape(), actualType.shape(),
-          evaluate::CheckConformanceFlags::EitherScalarExpandable,
+          evaluate::CheckConformanceFlags::RightScalarExpandable,
           "dummy argument", "actual argument");
     }
   } else {
     const auto &len{actualType.LEN()};
     messages.Say(
         "Actual argument type '%s' is not compatible with dummy argument type '%s'"_err_en_US,
         actualType.type().AsFortran(len ? len->AsFortran() : ""),
         dummy.type.type().AsFortran());

flang/lib/Semantics/pointer-assignment.cpp

private:
   template <typename T> bool Check(const T &);
   template <typename T> bool Check(const evaluate::Expr<T> &);
   template <typename T> bool Check(const evaluate::FunctionRef<T> &);
   template <typename T> bool Check(const evaluate::Designator<T> &);
   bool Check(const evaluate::NullPointer &);
   bool Check(const evaluate::ProcedureDesignator &);
   bool Check(const evaluate::ProcedureRef &);
   // Target is a procedure
-  bool Check(
-      parser::CharBlock rhsName, bool isCall, const Procedure * = nullptr);
+  bool Check(parser::CharBlock rhsName, bool isCall,
+      const Procedure * = nullptr,
+      const evaluate::SpecificIntrinsic *specific = nullptr);
   bool LhsOkForUnlimitedPoly() const;
   template <typename... A> parser::Message *Say(A &&...);
 
   evaluate::FoldingContext &context_;
   const parser::CharBlock source_;
   const std::string description_;
   const Symbol *lhs_{nullptr};
   std::optional<TypeAndShape> lhsType_;
if (auto *m{std::get_if<MessageFixedText>(&*msg)}) {
       Say(std::get<MessageFormattedText>(*msg));
     }
     return false;
   }
   return true;
 }
 
 // Common handling for procedure pointer right-hand sides
-bool PointerAssignmentChecker::Check(
-    parser::CharBlock rhsName, bool isCall, const Procedure *rhsProcedure) {
+bool PointerAssignmentChecker::Check(parser::CharBlock rhsName, bool isCall,
+    const Procedure *rhsProcedure,
+    const evaluate::SpecificIntrinsic *specific) {
   std::string whyNot;
   if (std::optional<MessageFixedText> msg{evaluate::CheckProcCompatibility(
-          isCall, procedure_, rhsProcedure, whyNot)}) {
+          isCall, procedure_, rhsProcedure, specific, whyNot)}) {
     Say(std::move(*msg), description_, rhsName, whyNot);
     return false;
   }
   return true;
 }
 
 bool PointerAssignmentChecker::Check(const evaluate::ProcedureDesignator &d) {
   if (auto chars{Procedure::Characterize(d, context_)}) {
-    return Check(d.GetName(), false, &*chars);
+    return Check(d.GetName(), false, &*chars, d.GetSpecificIntrinsic());
   } else {
     return Check(d.GetName(), false);
   }
 }
 
 bool PointerAssignmentChecker::Check(const evaluate::ProcedureRef &ref) {
-  const Procedure *procedure{nullptr};
-  auto chars{Procedure::Characterize(ref, context_)};
-  if (chars) {
-    procedure = &*chars;
+  if (auto chars{Procedure::Characterize(ref, context_)}) {
     if (chars->functionResult) {
       if (const auto *proc{chars->functionResult->IsProcedurePointer()}) {
-        procedure = proc;
+        return Check(ref.proc().GetName(), true, proc);
       }
     }
+    return Check(ref.proc().GetName(), true, &*chars);
+  } else {
+    return Check(ref.proc().GetName(), true, nullptr);
   }
-  return Check(ref.proc().GetName(), true, procedure);
 }
 
 // The target can be unlimited polymorphic if the pointer is, or if it is
 // a non-extensible derived type.
 bool PointerAssignmentChecker::LhsOkForUnlimitedPoly() const {
   const auto &type{lhsType_->type()};
   if (type.category() != TypeCategory::Derived || type.IsAssumedType()) {
     return false;

flang/test/Semantics/assign03.f90

subroutine s5
     procedure(f_elemental1), pointer :: p_elemental
     procedure(s_impure1), pointer :: sp_impure
     procedure(s_pure1), pointer :: sp_pure
     !ERROR: Procedure pointer 'sp_elemental' may not be ELEMENTAL
     procedure(s_elemental1), pointer :: sp_elemental
 
     p_impure => f_impure1 ! OK, same characteristics
     p_impure => f_pure1 ! OK, target may be pure when pointer is not
-    p_impure => f_elemental1 ! OK, target may be pure elemental
+    !ERROR: Procedure pointer 'p_impure' associated with incompatible procedure designator 'f_elemental1': incompatible procedure attributes: Elemental
+    p_impure => f_elemental1
+    !ERROR: Procedure pointer 'p_impure' associated with incompatible procedure designator 'f_impureelemental1': incompatible procedure attributes: Elemental
     p_impure => f_ImpureElemental1 ! OK, target may be elemental
 
     sp_impure => s_impure1 ! OK, same characteristics
     sp_impure => s_pure1 ! OK, target may be pure when pointer is not
-    sp_impure => s_elemental1 ! OK, target may be elemental when pointer is not
+    !ERROR: Procedure pointer 'sp_impure' associated with incompatible procedure designator 's_elemental1': incompatible procedure attributes: Elemental
+    sp_impure => s_elemental1
 
     !ERROR: PURE procedure pointer 'p_pure' may not be associated with non-PURE procedure designator 'f_impure1'
     p_pure => f_impure1
     p_pure => f_pure1 ! OK, same characteristics
-    p_pure => f_elemental1 ! OK, target may be pure
+    !ERROR: Procedure pointer 'p_pure' associated with incompatible procedure designator 'f_elemental1': incompatible procedure attributes: Elemental
+    p_pure => f_elemental1
     !ERROR: PURE procedure pointer 'p_pure' may not be associated with non-PURE procedure designator 'f_impureelemental1'
     p_pure => f_impureElemental1
 
     !ERROR: PURE procedure pointer 'sp_pure' may not be associated with non-PURE procedure designator 's_impure1'
     sp_pure => s_impure1
     sp_pure => s_pure1 ! OK, same characteristics
+    !ERROR: Procedure pointer 'sp_pure' associated with incompatible procedure designator 's_elemental1': incompatible procedure attributes: Elemental
     sp_pure => s_elemental1 ! OK, target may be elemental when pointer is not
 
     !ERROR: Procedure pointer 'p_impure' associated with incompatible procedure designator 'f_impure2': incompatible dummy argument #1: incompatible dummy data object intents
     p_impure => f_impure2
     !ERROR: Procedure pointer 'p_pure' associated with incompatible procedure designator 'f_pure2': function results have incompatible types: INTEGER(4) vs REAL(4)
     p_pure => f_pure2
-    !ERROR: Procedure pointer 'p_impure' associated with incompatible procedure designator 'f_elemental2': incompatible dummy argument #1: incompatible dummy data object attributes
+    !ERROR: Procedure pointer 'p_impure' associated with incompatible procedure designator 'f_elemental2': incompatible procedure attributes: Elemental
     p_impure => f_elemental2
 
     !ERROR: Procedure pointer 'sp_impure' associated with incompatible procedure designator 's_impure2': incompatible procedure attributes: BindC
     sp_impure => s_impure2
     !ERROR: Procedure pointer 'sp_impure' associated with incompatible procedure designator 's_pure2': incompatible dummy argument #1: incompatible dummy data object intents
     sp_impure => s_pure2
-    !ERROR: Procedure pointer 'sp_pure' associated with incompatible procedure designator 's_elemental2': distinct numbers of dummy arguments
+    !ERROR: Procedure pointer 'sp_pure' associated with incompatible procedure designator 's_elemental2': incompatible procedure attributes: Elemental
     sp_pure => s_elemental2
 
     !ERROR: Function pointer 'p_impure' may not be associated with subroutine designator 's_impure1'
     p_impure => s_impure1
 
     !ERROR: Subroutine pointer 'sp_impure' may not be associated with function designator 'f_impure1'
     sp_impure => f_impure1
 

flang/test/Semantics/assign09.f90

+! RUN: %python %S/test_errors.py %s %flang_fc1
+! Procedure pointer assignments and argument association with intrinsic functions
+program test
+  abstract interface
+    real function realToReal(a)
+      real, intent(in) :: a
+    end function
+    real function intToReal(n)
+      integer, intent(in) :: n
+    end function
+  end interface
+  procedure(), pointer :: noInterfaceProcPtr
+  procedure(realToReal), pointer :: realToRealProcPtr
+  procedure(intToReal), pointer :: intToRealProcPtr
+  intrinsic :: float ! restricted specific intrinsic functions
+  intrinsic :: sqrt ! unrestricted specific intrinsic functions
+  external :: noInterfaceExternal
+  interface
+    elemental real function userElemental(a)
+      real, intent(in) :: a
+    end function
+  end interface
+
+  !ERROR: 'float' is not an unrestricted specific intrinsic procedure
+  noInterfaceProcPtr => float
+  !ERROR: 'float' is not an unrestricted specific intrinsic procedure
+  intToRealProcPtr => float
+  !ERROR: 'float' is not an unrestricted specific intrinsic procedure
+  call sub1(float)
+  !ERROR: 'float' is not an unrestricted specific intrinsic procedure
+  call sub2(float)
+  !ERROR: 'float' is not an unrestricted specific intrinsic procedure
+  call sub3(float)
+
+  noInterfaceProcPtr => sqrt ! ok
+  realToRealProcPtr => sqrt ! ok
+  !ERROR: Procedure pointer 'inttorealprocptr' associated with incompatible procedure designator 'sqrt': incompatible dummy argument #1: incompatible dummy data object types: INTEGER(4) vs REAL(4)
+  intToRealProcPtr => sqrt
+  call sub1(sqrt) ! ok
+  call sub2(sqrt) ! ok
+  !ERROR: Actual procedure argument has interface incompatible with dummy argument 'p=': incompatible dummy argument #1: incompatible dummy data object types: INTEGER(4) vs REAL(4)
+  call sub3(sqrt)
+
+  noInterfaceProcPtr => noInterfaceExternal ! ok
+  realToRealProcPtr => noInterfaceExternal ! ok
+  intToRealProcPtr => noInterfaceExternal !ok
+  call sub1(noInterfaceExternal) ! ok
+  !WARNING: Actual procedure argument has an implicit interface which is not known to be compatible with dummy argument 'p=' which has an explicit interface
+  call sub2(noInterfaceExternal)
+  !WARNING: Actual procedure argument has an implicit interface which is not known to be compatible with dummy argument 'p=' which has an explicit interface
+  call sub3(noInterfaceExternal)
+
+  !ERROR: Procedure pointer 'nointerfaceprocptr' with implicit interface may not be associated with procedure designator 'userelemental' with explicit interface that cannot be called via an implicit interface
+  noInterfaceProcPtr => userElemental
+  !ERROR: Non-intrinsic ELEMENTAL procedure 'userelemental' may not be passed as an actual argument
+  call sub1(userElemental)
+
+ contains
+  subroutine sub1(p)
+    external :: p
+  end subroutine
+  subroutine sub2(p)
+    procedure(realToReal) :: p
+  end subroutine
+  subroutine sub3(p)
+    procedure(intToReal) :: p
+  end subroutine
+end

flang/test/Semantics/associated.f90

subroutine test()
     lvar = associated(intProcPointer1, null()) ! ok
     intPointerVar1 => null(intPointerVar1) ! ok
     lvar = associated (intPointerVar1, null(intPointerVar1)) ! ok
 
     !ERROR: In assignment to procedure pointer 'intprocpointer1', the target is not a procedure or procedure pointer
     intprocPointer1 => intVar
     !ERROR: POINTER= argument 'intprocpointer1' is a procedure pointer but the TARGET= argument 'intvar' is not a procedure or procedure pointer
     lVar = associated(intprocPointer1, intVar)
-    !ERROR: Procedure pointer 'intprocpointer1' associated with incompatible procedure designator 'elementalproc': incompatible dummy argument #1: incompatible dummy data object attributes
+    !ERROR: Procedure pointer 'intprocpointer1' associated with incompatible procedure designator 'elementalproc': incompatible procedure attributes: Elemental
     intProcPointer1 => elementalProc
     !WARNING: Procedure pointer 'intprocpointer1' associated with incompatible procedure designator 'elementalproc': incompatible dummy argument #1: incompatible dummy data object attributes
     lvar = associated(intProcPointer1, elementalProc)
     !ERROR: POINTER= argument 'intpointervar1' is an object pointer but the TARGET= argument 'intfunc' is a procedure designator
     lvar = associated (intPointerVar1, intFunc)
     !ERROR: In assignment to object pointer 'intpointervar1', the target 'intfunc' is a procedure designator
     intPointerVar1 => intFunc
     !ERROR: In assignment to procedure pointer 'intprocpointer1', the target is not a procedure or procedure pointer

flang/test/Semantics/c_f_pointer.f90

program test
   call c_f_pointer(scalarC, scalarIntF) ! ok
   call c_f_pointer(scalarC, arrayIntF, [1_8]) ! ok
   call c_f_pointer(shape=[1_8], cptr=scalarC, fptr=arrayIntF) ! ok
   call c_f_pointer(scalarC, shape=[1_8], fptr=arrayIntF) ! ok
   !ERROR: A positional actual argument may not appear after any keyword arguments
   call c_f_pointer(scalarC, fptr=arrayIntF, [1_8])
   !ERROR: CPTR= argument to C_F_POINTER() must be a C_PTR
   call c_f_pointer(j, scalarIntF)
-  !ERROR: CPTR= argument to C_F_POINTER() must be scalar
+  !ERROR: Rank of dummy argument is 0, but actual argument has rank 1
   call c_f_pointer(arrayC, scalarIntF)
   !ERROR: SHAPE= argument to C_F_POINTER() must appear when FPTR= is an array
   call c_f_pointer(scalarC, arrayIntF)
   !ERROR: SHAPE= argument to C_F_POINTER() may not appear when FPTR= is scalar
   call c_f_pointer(scalarC, scalarIntF, [1_8])
   !ERROR: FPTR= argument to C_F_POINTER() may not have a deferred type parameter
   call c_f_pointer(scalarC, charDeferredF)
   !ERROR: FPTR= argument to C_F_POINTER() may not be a coindexed object
   call c_f_pointer(scalarC, coindexed[0]%p)
   !ERROR: FPTR= argument to C_F_POINTER() must have a type
   call c_f_pointer(scalarC, null())
 end program

flang/test/Semantics/call03.f90

subroutine assumedshape(x)
     real :: x(:)
   end subroutine
   subroutine contiguous(x)
     real, contiguous :: x(:)
   end subroutine
   subroutine intentout(x)
     real, intent(out) :: x
   end subroutine
+  subroutine intentout_arr(x)
+    real, intent(out) :: x(:)
+  end subroutine
   subroutine intentinout(x)
     real, intent(in out) :: x
   end subroutine
+  subroutine intentinout_arr(x)
+    real, intent(in out) :: x(:)
+  end subroutine
   subroutine asynchronous(x)
     real, asynchronous :: x
   end subroutine
+  subroutine asynchronous_arr(x)
+    real, asynchronous :: x(:)
+  end subroutine
   subroutine asynchronousValue(x)
     real, asynchronous, value :: x
   end subroutine
   subroutine volatile(x)
     real, volatile :: x
   end subroutine
+  subroutine volatile_arr(x)
+    real, volatile :: x(:)
+  end subroutine
   subroutine pointer(x)
     real, pointer :: x(:)
   end subroutine
   subroutine valueassumedsize(x)
     real, intent(in) :: x(*)
   end subroutine
   subroutine volatileassumedsize(x)
     real, volatile :: x(*)
   end subroutine
   subroutine volatilecontiguous(x)
     real, volatile :: x(*)
   end subroutine
 
   subroutine test01(x) ! 15.5.2.4(2)
     class(t), intent(in) :: x[*]
     !ERROR: Coindexed polymorphic object may not be associated with a polymorphic dummy argument 'x='
     call poly(x[1])
   end subroutine
 
   subroutine mono(x)
-    type(t), intent(in) :: x
+    type(t), intent(in) :: x(*)
   end subroutine
   subroutine test02(x) ! 15.5.2.4(2)
     class(t), intent(in) :: x(*)
     !ERROR: Assumed-size polymorphic array may not be associated with a monomorphic dummy argument 'x='
     call mono(x)
   end subroutine
 
   subroutine typestar(x)
subroutine test11(in) ! C15.5.2.4(20)
     call execute_command_line(command="echo hello", exitstat=0)
   end subroutine
 
   subroutine test12 ! 15.5.2.4(21)
     real :: a(1)
     integer :: j(1)
     j(1) = 1
     !ERROR: Actual argument associated with INTENT(OUT) dummy argument 'x=' must be definable
-    call intentout(a(j))
+    call intentout_arr(a(j))
     !ERROR: Actual argument associated with INTENT(IN OUT) dummy argument 'x=' must be definable
-    call intentinout(a(j))
+    call intentinout_arr(a(j))
     !ERROR: Actual argument associated with ASYNCHRONOUS dummy argument 'x=' must be definable
-    call asynchronous(a(j))
+    call asynchronous_arr(a(j))
     !ERROR: Actual argument associated with VOLATILE dummy argument 'x=' must be definable
-    call volatile(a(j))
+    call volatile_arr(a(j))
   end subroutine
 
   subroutine coarr(x)
     type(ultimateCoarray):: x
   end subroutine
   subroutine volcoarr(x)
     type(ultimateCoarray), volatile :: x
   end subroutine

flang/test/Semantics/procinterface02.f90

+! RUN: %python %S/test_errors.py %s %flang_fc1
+subroutine foo(A, B, P)
+  interface
+    real elemental function foo_elemental(x)
+      real, intent(in) :: x
+    end function
+    pure real function foo_pure(x)
+      real, intent(in) :: x
+    end function
+    real function foo_nonelemental(x)
+      real, intent(in) :: x
+    end function
+  end interface
+  real :: A(:), B(:)
+  procedure(sqrt), pointer :: P
+  !ERROR: Rank of dummy argument is 0, but actual argument has rank 1
+  A = P(B)
+  !ERROR: Procedure pointer 'p' associated with incompatible procedure designator 'foo_elemental': incompatible procedure attributes: Elemental
+  P => foo_elemental
+  P => foo_pure ! ok
+  !ERROR: PURE procedure pointer 'p' may not be associated with non-PURE procedure designator 'foo_nonelemental'
+  P => foo_nonelemental
+end subroutine