[flang] Failed call to CHECK() for call to ASSOCIATED(NULL())

[PeteSteinfeld]

Summary

Calling "ASSOCATED(NULL()) was causing an internal check of the compiler to
fail.

I fixed this by changing the entry for "ASSOCIATED" in the intrinsics table to
accept "AnyPointer" which contains a new "KindCode" of "pointerType". I also
changed the function "FromActual()" which to return a typeless intrinsic when
called on a pointer, which duplicates its behavior for BOZ literals. This
required changing the analysis of procedure arguments. I wrote additional
tests to cover all of the code. This exposed an additional failing call to
CHECK() that I fixed.

I made several other changes:

• I implemented constant folding for ASSOCIATED().
• I fixed handling of NULL() in relational operations.
• I implemented semantic analysis for ASSOCIATED().
• I noticed that the semantics for ASSOCIATED() are similar to those for pointer assignment. So I extracted the code that pointer assignment uses for procedure pointer compatibility to a place where it could be used by the semantic analysis for ASSOCIATED().
• I couldn't figure out how to make the general semantic analysis for procedure arguments work with ASSOCIATED()'s second argument, which can be either a pointer or a target. So I stopped using normal semantic analysis for arguments for ASSOCIATED().
• I added tests for all of this.

[klausler]

flang/include/flang/Evaluate/characteristics.h

233

Magic flag arguments should be avoided. If you want special-case handling of some input in some situation, consider adding a wrapper function with the magic that defaults to the original function otherwise. But maybe the new special behavior doesn't have to be special -- what would break if you just changed the treatment of NULL for all cases?

flang/include/flang/Evaluate/type.h

204

ASSOCIATED

flang/lib/Evaluate/characteristics.cpp

390

Obsolete comment?

flang/lib/Evaluate/intrinsics.cpp

87

If it's only meant to be used for NULL(), please use a more specific name.

286

Can the optional TARGET= argument be NULL(MOLD=) or even just NULL()?

[PeteSteinfeld]

flang/include/flang/Evaluate/characteristics.h

233

Thanks, Peter.

My first impulse was to change the treatment of NULL for both cases, but that caused problems in the treatment of procedure arguments. I'll take another look at this and see if I can make it work. If not, I'll look at adding a wrapper function.

[PeteSteinfeld]

flang/lib/Evaluate/intrinsics.cpp

286

Good question.

My reading of the standard is that NULL() should be allowed as the TARGET
argument of ASSOCIATED(). The note at the bottom of section 16.9.16
explicitly mentions disassociated pointers. Also, if we're going to allow
NULL() as the first argument, it seems like we're implicitly stating that
null pointers match all pointer types, and thus we should allow NULL() as the
second argument to ASSOCIATED().

I wrote some tests and tried them on several compilers. The only one that
seems to agree with my analysis above is IBM. GNU, pgf90, nagfor, and ifort
all give various compile-time errors when using any form of null() as the
second argument to ASSOCIATED().

[PeteSteinfeld]

I reverted the interface of the FromActual() function. This required redoing
the analysis of procedure arguments. To make sure I covered all the code in
the anslysis of procedure arguments, I added some tests that exposed another
bad call to CHECK() that I fixed. I added tests for all of this.

I also added some tests for passing NULL() as the second argument to
ASSOCIATED().

[klausler]

flang/lib/Evaluate/characteristics.cpp

460

Please use const auto * here.

flang/lib/Evaluate/intrinsics.cpp

286

Will you allow NULL() as the second (TARGET=) argument here?

1729

associated*

[PeteSteinfeld]

flang/lib/Evaluate/intrinsics.cpp

286

Yes. I added a test for this to resolve89.f90. I would think that, if the second argument is NULL() and the first argument evaluates to NULL(), that ASSOCIATED() would evaluate to .TRUE..

[PeteSteinfeld]

Responding to review comments.

[klausler]

flang/lib/Evaluate/intrinsics.cpp

286

I could read the standard either way for the case with two NULL()s. What does XLF do?

[PeteSteinfeld]

flang/lib/Evaluate/intrinsics.cpp

286

xlf is the only compiler I can find that does not have a fatal error when evaluating associated(null(), null()). It gives the warning:

"test.f90", line 2.7: 1516-303 (W) The pointer and target specified for the ASSOCIATED intrinsic are not type compatible or have mismatching type parameters or rank.  The value of ASSOCIATED will be FALSE.

As the message says, it evaluates the call to associated() to false.

[PeteSteinfeld]

flang/lib/Evaluate/intrinsics.cpp

286

nagfor compiles without warnings and also evaluates to false.

[klausler]

flang/lib/Evaluate/intrinsics.cpp

286

Ok, so there's good precedent for .false.. Can you fold associated(null(),null()) to .false. with a warning?

[PeteSteinfeld]

flang/lib/Evaluate/intrinsics.cpp

286

I'll look into folding. There's also the case of folding associated(null()). Note that nagfor is the only compiler that compiles this without error. As expected, it evaluates it to false.

[PeteSteinfeld]

I made several changes:

• I implemented constant folding for ASSOCIATED().
• I fixed handling of NULL() in relational operations.
• I implemented semantic analysis for ASSOCIATED().
• I noticed that the semantics for ASSOCIATED() are similar to those for pointer assignment. So I extracted the code that pointer assignment uses for procedure pointer compatibility to a place where it could be used by the semantic analysis for ASSOCIATED().
• I couldn't figure out how to make the general semantic analysis for procedure arguments work with ASSOCIATED()'s second argument, which can be either a pointer or a target. So I stopped using normal semantic analysis for arguments for ASSOCIATED().
• I added tests for all of this.

[PeteSteinfeld]

Fixed some formatting.

[klausler]

flang/lib/Evaluate/characteristics.cpp

466

Could be

const auto *argObj{...}.
return argObj && argObj->type.type().IsTypelessIntrinsicArgument();

flang/lib/Evaluate/intrinsics.cpp

1965–1966

This block of code has grown to the point that it should be extracted into its own function, I think.

flang/lib/Evaluate/tools.cpp

894

Debugging code needs scrubbing.

[PeteSteinfeld]

Thanks for the comments. New update coming.

flang/lib/Evaluate/characteristics.cpp

466

Thanks. I'll fix this.

flang/lib/Evaluate/intrinsics.cpp

1965–1966

Thanks. I'll do it.

flang/lib/Evaluate/tools.cpp

894

Ay yi yi.

[PeteSteinfeld]

Responses to review comments.

I recoded a function in characteristics.cpp, pulled the semantic checking for
ASSOCIATED() to a separate function in intrinsics.cpp, and removed debug code
from tools.cpp.

[klausler]

LGTM and thanks!

flang/include/flang/Evaluate/characteristics.h

DummyArgument(std::string &&name, DummyProcedure &&x)
       : name{std::move(name)}, u{std::move(x)} {}
   explicit DummyArgument(AlternateReturn &&x) : u{std::move(x)} {}
   ~DummyArgument();
   bool operator==(const DummyArgument &) const;
   bool operator!=(const DummyArgument &that) const { return !(*this == that); }
   static std::optional<DummyArgument> Characterize(
       const semantics::Symbol &, const IntrinsicProcTable &);
   static std::optional<DummyArgument> FromActual(
       std::string &&, const Expr<SomeType> &, FoldingContext &);
   bool IsOptional() const;
   void SetOptional(bool = true);
   bool CanBePassedViaImplicitInterface() const;
+  bool IsTypelessIntrinsicDummy() const;
   llvm::raw_ostream &Dump(llvm::raw_ostream &) const;
   // name and pass are not characteristics and so does not participate in
   // operator== but are needed to determine if procedures are distinguishable
   std::string name;
   bool pass{false}; // is this the PASS argument of its procedure
   std::variant<DummyDataObject, DummyProcedure, AlternateReturn> u;
 };
 

flang/include/flang/Evaluate/tools.h

struct UnexpandabilityFindingVisitor
   template <typename T> bool operator()(const FunctionRef<T> &) { return true; }
   bool operator()(const CoarrayRef &) { return true; }
 };
 
 template <typename T> bool IsExpandableScalar(const Expr<T> &expr) {
   return !UnexpandabilityFindingVisitor{}(expr);
 }
 
+// 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);
+
 } // namespace Fortran::evaluate
 
 namespace Fortran::semantics {
 
 class Scope;
 
 // These functions are used in Evaluate so they are defined here rather than in
 // Semantics to avoid a link-time dependency on Semantics.

flang/include/flang/Evaluate/type.h

explicit constexpr DynamicType(
     if (poly) {
       kind_ = ClassKind;
     }
   }
   CONSTEXPR_CONSTRUCTORS_AND_ASSIGNMENTS(DynamicType)
 
   // A rare use case used for representing the characteristics of an
   // intrinsic function like REAL() that accepts a typeless BOZ literal
-  // argument, which is something that real user Fortran can't do.
+  // argument and for typeless pointers -- things that real user Fortran can't
+  // do.
   static constexpr DynamicType TypelessIntrinsicArgument() {
     DynamicType result;
     result.category_ = TypeCategory::Integer;
     result.kind_ = TypelessKind;
     return result;
   }
 
   static constexpr DynamicType UnlimitedPolymorphic() {
static std::optional<DynamicType> From(const std::optional<A> &x) {
     } else {
       return std::nullopt;
     }
   }
 
 private:
   // Special kind codes are used to distinguish the following Fortran types.
   enum SpecialKind {
-    TypelessKind = -1, // BOZ actual argument to intrinsic function
+    TypelessKind = -1, // BOZ actual argument to intrinsic function or pointer
+                       // argument to ASSOCIATED
     ClassKind = -2, // CLASS(T) or CLASS(*)
     AssumedTypeKind = -3, // TYPE(*)
   };
 
   constexpr DynamicType() {}
 
   TypeCategory category_{TypeCategory::Derived}; // overridable default
   int kind_{0};

flang/lib/Evaluate/characteristics.cpp

std::optional<DummyArgument> DummyArgument::FromActual(
     std::string &&name, const Expr<SomeType> &expr, FoldingContext &context) {
   return std::visit(
       common::visitors{
           [&](const BOZLiteralConstant &) {
             return std::make_optional<DummyArgument>(std::move(name),
                 DummyDataObject{
                     TypeAndShape{DynamicType::TypelessIntrinsicArgument()}});
           },
-          [](const NullPointer &) { return std::optional<DummyArgument>{}; },
+          [&](const NullPointer &) {
+            return std::make_optional<DummyArgument>(std::move(name),
+                DummyDataObject{
+                    TypeAndShape{DynamicType::TypelessIntrinsicArgument()}});
+          },
           [&](const ProcedureDesignator &designator) {
             if (auto proc{Procedure::Characterize(
                     designator, context.intrinsics())}) {
               return std::make_optional<DummyArgument>(
                   std::move(name), DummyProcedure{std::move(*proc)});
             } else {
               return std::optional<DummyArgument>{};
             }
           },
           [&](const ProcedureRef &call) {

 bool DummyArgument::CanBePassedViaImplicitInterface() const {
   if (const auto *object{std::get_if<DummyDataObject>(&u)}) {
     return object->CanBePassedViaImplicitInterface();
   } else {
     return true;
   }
 }
 
+bool DummyArgument::IsTypelessIntrinsicDummy() const {
+  const auto *argObj{std::get_if<characteristics::DummyDataObject>(&u)};
+  return argObj && argObj->type.type().IsTypelessIntrinsicArgument();
+}
+
 llvm::raw_ostream &DummyArgument::Dump(llvm::raw_ostream &o) const {
   if (!name.empty()) {
     o << name << '=';
   }
   if (pass) {
     o << " PASS";
   }
   std::visit([&](const auto &x) { x.Dump(o); }, u);
   return o;
 }
 

flang/lib/Evaluate/fold-logical.cpp

if (!args[1]) { // TODO: ANY(x,DIM=d)
           if (element.IsTrue()) {
             result = true;
             break;
           }
         }
         return Expr<T>{result};
       }
     }
+  } else if (name == "associated") {
+    bool gotConstant{true};
+    const Expr<SomeType> *firstArgExpr{args[0]->UnwrapExpr()};
+    if (!firstArgExpr || !IsNullPointer(*firstArgExpr)) {
+      gotConstant = false;
+    } else if (args[1]) { // There's a second argument
+      const Expr<SomeType> *secondArgExpr{args[1]->UnwrapExpr()};
+      if (!secondArgExpr || !IsNullPointer(*secondArgExpr)) {
+        gotConstant = false;
+      }
+    }
+    return gotConstant ? Expr<T>{false} : Expr<T>{std::move(funcRef)};
   } else if (name == "bge" || name == "bgt" || name == "ble" || name == "blt") {
     using LargestInt = Type<TypeCategory::Integer, 16>;
     static_assert(std::is_same_v<Scalar<LargestInt>, BOZLiteralConstant>);
     // Arguments do not have to be of the same integer type. Convert all
     // arguments to the biggest integer type before comparing them to
     // simplify.
     for (int i{0}; i <= 1; ++i) {
       if (auto *x{UnwrapExpr<Expr<SomeInteger>>(args[i])}) {

flang/lib/Evaluate/intrinsics.cpp

ENUM_CLASS(KindCode, none, defaultIntegerKind,
     teamType, // TEAM_TYPE from module ISO_FORTRAN_ENV (for coarrays)
     kindArg, // this argument is KIND=
     effectiveKind, // for function results: "kindArg" value, possibly defaulted
     dimArg, // this argument is DIM=
     likeMultiply, // for DOT_PRODUCT and MATMUL
     subscript, // address-sized integer
     size, // default KIND= for SIZE(), UBOUND, &c.
     addressable, // for PRESENT(), &c.; anything (incl. procedure) but BOZ
+    nullPointerType, // for ASSOCIATED(NULL())
 )
 
 struct TypePattern {
   CategorySet categorySet;
   KindCode kindCode{KindCode::none};
   llvm::raw_ostream &Dump(llvm::raw_ostream &) const;
 };
 

 
 // Match some kind of some INTEGER or REAL type(s); when argument types
 // &/or kinds differ, their values are converted as if they were operands to
 // an intrinsic operation like addition.  This is a nonstandard but nearly
 // universal extension feature.
 static constexpr TypePattern OperandReal{RealType, KindCode::operand};
 static constexpr TypePattern OperandIntOrReal{IntOrRealType, KindCode::operand};
 
+// For ASSOCIATED, the first argument is a typeless pointer
+static constexpr TypePattern AnyPointer{AnyType, KindCode::nullPointerType};
+
 // For DOT_PRODUCT and MATMUL, the result type depends on the arguments
 static constexpr TypePattern ResultLogical{LogicalType, KindCode::likeMultiply};
 static constexpr TypePattern ResultNumeric{NumericType, KindCode::likeMultiply};
 
 // Result types with known category and KIND=
 static constexpr TypePattern KINDInt{IntType, KindCode::effectiveKind};
 static constexpr TypePattern KINDReal{RealType, KindCode::effectiveKind};
 static constexpr TypePattern KINDComplex{ComplexType, KindCode::effectiveKind};
static const IntrinsicInterface genericIntrinsicFunction[]{
         Rank::elemental, IntrinsicClass::inquiryFunction},
     {"anint", {{"a", SameReal}, MatchingDefaultKIND}, KINDReal},
     {"any", {{"mask", SameLogical, Rank::array}, OptionalDIM}, SameLogical,
         Rank::dimReduced, IntrinsicClass::transformationalFunction},
     {"asin", {{"x", SameFloating}}, SameFloating},
     {"asind", {{"x", SameFloating}}, SameFloating},
     {"asinh", {{"x", SameFloating}}, SameFloating},
     {"associated",
-        {{"pointer", Addressable, Rank::known},
+        {{"pointer", AnyPointer, Rank::known},
             {"target", Addressable, Rank::known, Optionality::optional}},
         DefaultLogical, Rank::elemental, IntrinsicClass::inquiryFunction},
     {"atan", {{"x", SameFloating}}, SameFloating},
     {"atand", {{"x", SameFloating}}, SameFloating},
     {"atan", {{"y", OperandReal}, {"x", OperandReal}}, OperandReal},
     {"atand", {{"y", OperandReal}, {"x", OperandReal}}, OperandReal},
     {"atan2", {{"y", OperandReal}, {"x", OperandReal}}, OperandReal},
     {"atan2d", {{"y", OperandReal}, {"x", OperandReal}}, OperandReal},
     {"atanh", {{"x", SameFloating}}, SameFloating},
if (!type) {
               d.keyword, nextParam.keyword);
         }
       } else {
         // NULL(), procedure, or procedure pointer
         CHECK(IsProcedurePointer(expr));
         if (d.typePattern.kindCode == KindCode::addressable ||
             d.rank == Rank::reduceOperation) {
           continue;
+        } else if (d.typePattern.kindCode == KindCode::nullPointerType) {
+          continue;
         } else {
           messages.Say(
               "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())) {
case KindCode::operand:
       argOk = true;
       break;
     case KindCode::effectiveKind:
       common::die("INTERNAL: KindCode::effectiveKind appears on argument '%s' "
                   "for intrinsic '%s'",
           d.keyword, name);
       break;
     case KindCode::addressable:
+    case KindCode::nullPointerType:
       argOk = true;
       break;
     default:
       CRASH_NO_CASE;
     }
     if (!argOk) {
       messages.Say(
           "Actual argument for '%s=' has bad type or kind '%s'"_err_en_US,
for (std::size_t j{0}; j < dummies; ++j) {
     if (ActualArgument * arg{actualForDummy[j]}) {
       rearranged[j] = std::move(*arg);
     }
   }
 
   // Characterize the specific intrinsic procedure.
   characteristics::DummyArguments dummyArgs;
   std::optional<int> sameDummyArg;
+
   for (std::size_t j{0}; j < dummies; ++j) {
     const IntrinsicDummyArgument &d{dummy[std::min(j, dummyArgPatterns - 1)]};
     if (const auto &arg{rearranged[j]}) {
       if (const Expr<SomeType> *expr{arg->UnwrapExpr()}) {
         auto dc{characteristics::DummyArgument::FromActual(
             std::string{d.keyword}, *expr, context)};
         CHECK(dc);
         dummyArgs.emplace_back(std::move(*dc));

 // The NULL() intrinsic is a special case.
 SpecificCall IntrinsicProcTable::Implementation::HandleNull(
     ActualArguments &arguments, FoldingContext &context,
     const IntrinsicProcTable &intrinsics) const {
   static const char *const keywords[]{"mold", nullptr};
   if (CheckAndRearrangeArguments(arguments, context.messages(), keywords, 1) &&
       arguments[0]) {
     if (Expr<SomeType> * mold{arguments[0]->UnwrapExpr()}) {
+      bool goodProcPointer{true};
       if (IsAllocatableOrPointer(*mold)) {
         characteristics::DummyArguments args;
         std::optional<characteristics::FunctionResult> fResult;
         if (IsProcedurePointer(*mold)) {
           // MOLD= procedure pointer
           const Symbol *last{GetLastSymbol(*mold)};
           CHECK(last);
           auto procPointer{
               characteristics::Procedure::Characterize(*last, intrinsics)};
-          CHECK(procPointer);
+          // procPointer is null if there was an error with the analysis
+          // associated with the procedure pointer
+          if (procPointer) {
             args.emplace_back("mold"s,
                 characteristics::DummyProcedure{common::Clone(*procPointer)});
             fResult.emplace(std::move(*procPointer));
+          } else {
+            goodProcPointer = false;
+          }
         } 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(
               "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)};
+          return SpecificCall{SpecificIntrinsic{"null"s, std::move(chars)},
+              std::move(arguments)};
+        }
       }
     }
     context.messages().Say(
         "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);
return SpecificCall{
         SpecificIntrinsic{"__builtin_c_f_pointer"s,
             characteristics::Procedure{std::move(dummies), attrs}},
         std::move(arguments)};
   } else {
     return std::nullopt;
   }
 }
 
-// Applies any semantic checks peculiar to an intrinsic.
-static bool ApplySpecificChecks(
-    SpecificCall &call, parser::ContextualMessages &messages) {
+static bool CheckAssociated(SpecificCall &call,
+    parser::ContextualMessages &messages,
+    const IntrinsicProcTable &intrinsics) {
   bool ok{true};
-  const std::string &name{call.specificIntrinsic.name};
-  if (name == "allocated") {
-    if (const auto &arg{call.arguments[0]}) {
-      if (const auto *expr{arg->UnwrapExpr()}) {
-        if (const Symbol * symbol{GetLastSymbol(*expr)}) {
-          ok = symbol->attrs().test(semantics::Attr::ALLOCATABLE);
+  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(
+              messages.Say("POINTER= argument of ASSOCIATED() must be a "
+                           "POINTER"_err_en_US),
+              *pointerSymbol);
+        } else {
+          const auto pointerProc{characteristics::Procedure::Characterize(
+              *pointerSymbol, intrinsics)};
+          if (const auto &targetArg{call.arguments[1]}) {
+            if (const auto *targetExpr{targetArg->UnwrapExpr()}) {
+              std::optional<characteristics::Procedure> targetProc{
+                  std::nullopt};
+              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, intrinsics)}) {
+                  targetProc = *targetRefedChars;
+                  targetName = targetProcRef->proc().GetName() + "()";
+                  isCall = true;
+                }
+              } else if (targetSymbol && !targetProc) {
+                // proc that's not a call
+                targetProc = characteristics::Procedure::Characterize(
+                    *targetSymbol, intrinsics);
+                targetName = targetSymbol->name().ToString();
+              }
+
+              if (pointerProc) {
+                if (targetProc) {
+                  // procedure pointer and procedure target
+                  if (std::optional<parser::MessageFixedText> msg{
+                          CheckProcCompatibility(
+                              isCall, pointerProc, &*targetProc)}) {
+                    AttachDeclaration(
+                        messages.Say(std::move(*msg),
+                            "pointer '" + pointerSymbol->name().ToString() +
+                                "'",
+                            targetName),
+                        *pointerSymbol);
+                  }
+                } else {
+                  // procedure pointer and object target
+                  if (!IsNullPointer(*targetExpr)) {
+                    AttachDeclaration(
+                        messages.Say(
+                            "POINTER= argument '%s' is a procedure "
+                            "pointer but the TARGET= argument '%s' is not a "
+                            "procedure or procedure pointer"_err_en_US,
+                            pointerSymbol->name(), targetName),
+                        *pointerSymbol);
+                  }
+                }
+              } else if (targetProc) {
+                // object pointer and procedure target
+                AttachDeclaration(
+                    messages.Say("POINTER= argument '%s' is an object pointer "
+                                 "but the TARGET= argument '%s' is a "
+                                 "procedure designator"_err_en_US,
+                        pointerSymbol->name(), targetName),
+                    *pointerSymbol);
+              } else {
+                // object pointer and target
+                if (const auto pointerType{pointerArg->GetType()}) {
+                  if (const auto targetType{targetArg->GetType()}) {
+                    ok = pointerType->IsTkCompatibleWith(*targetType);
+                  }
                 }
               }
             }
-    if (!ok) {
-      messages.Say(
-          "Argument of ALLOCATED() must be an ALLOCATABLE object or component"_err_en_US);
-    }
-  } else if (name == "associated") {
+          }
+        }
+      }
+    }
+  } else {
+    // No arguments to ASSOCIATED()
+    ok = false;
+  }
+        "Arguments of ASSOCIATED() must be a POINTER and an optional valid target"_err_en_US);
+  return ok;
+}
+
+// Applies any semantic checks peculiar to an intrinsic.
+static bool ApplySpecificChecks(SpecificCall &call,
+    parser::ContextualMessages &messages,
+    const IntrinsicProcTable &intrinsics) {
+  bool ok{true};
+  const std::string &name{call.specificIntrinsic.name};
+  if (name == "allocated") {
     if (const auto &arg{call.arguments[0]}) {
       if (const auto *expr{arg->UnwrapExpr()}) {
         if (const Symbol * symbol{GetLastSymbol(*expr)}) {
-          ok = symbol->attrs().test(semantics::Attr::POINTER);
-          // TODO: validate the TARGET= argument vs. the pointer
+          ok = symbol->attrs().test(semantics::Attr::ALLOCATABLE);
         }
       }
     }
     if (!ok) {
       messages.Say(
-          "Arguments of ASSOCIATED() must be a POINTER and an optional valid target"_err_en_US);
+          "Argument of ALLOCATED() must be an ALLOCATABLE object or component"_err_en_US);
     }
+  } else if (name == "associated") {
+    return CheckAssociated(call, messages, intrinsics);
   } else if (name == "loc") {
     if (const auto &arg{call.arguments[0]}) {
       ok = arg->GetAssumedTypeDummy() || GetLastSymbol(arg->UnwrapExpr());
     }
     if (!ok) {
       messages.Say(
           "Argument of LOC() must be an object or procedure"_err_en_US);
     }
auto matchOrBufferMessages{
       }};
 
   // Probe the generic intrinsic function table first.
   parser::Messages genericBuffer;
   auto genericRange{genericFuncs_.equal_range(call.name)};
   for (auto iter{genericRange.first}; iter != genericRange.second; ++iter) {
     if (auto specificCall{
             matchOrBufferMessages(*iter->second, genericBuffer)}) {
-      ApplySpecificChecks(*specificCall, context.messages());
+      ApplySpecificChecks(*specificCall, context.messages(), intrinsics);
       return specificCall;
     }
   }
 
   // Probe the specific intrinsic function table next.
   parser::Messages specificBuffer;
   auto specificRange{specificFuncs_.equal_range(call.name)};
   for (auto specIter{specificRange.first}; specIter != specificRange.second;

flang/lib/Evaluate/tools.cpp

std::optional<std::string> FindImpureCall(
     const IntrinsicProcTable &intrinsics, const Expr<SomeType> &expr) {
   return FindImpureCallHelper{intrinsics}(expr);
 }
 std::optional<std::string> FindImpureCall(
     const IntrinsicProcTable &intrinsics, const ProcedureRef &proc) {
   return FindImpureCallHelper{intrinsics}(proc);
 }
 
+// Compare procedure characteristics for equality except that lhs may be
+// Pure or Elemental when rhs is not.
+static bool CharacteristicsMatch(const characteristics::Procedure &lhs,
+    const characteristics::Procedure &rhs) {
+  using Attr = characteristics::Procedure::Attr;
+  auto lhsAttrs{rhs.attrs};
+  lhsAttrs.set(
+      Attr::Pure, lhs.attrs.test(Attr::Pure) | rhs.attrs.test(Attr::Pure));
+  lhsAttrs.set(Attr::Elemental,
+      lhs.attrs.test(Attr::Elemental) | rhs.attrs.test(Attr::Elemental));
+  return lhsAttrs == rhs.attrs && lhs.functionResult == rhs.functionResult &&
+      lhs.dummyArguments == rhs.dummyArguments;
+}
+
+// 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::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 (CharacteristicsMatch(*lhsProcedure, *rhsProcedure)) {
+    // OK
+  } else if (isCall) {
+    msg = "Procedure %s associated with result of reference to function '%s'"
+          " that is an incompatible procedure pointer"_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->IsFunction()) {
+    msg = "Function %s may not be associated with subroutine"
+          " designator '%s'"_err_en_US;
+  } else if (!lhsProcedure->IsFunction() && rhsProcedure->IsFunction()) {
+    msg = "Subroutine %s may not be associated with function"
+          " designator '%s'"_err_en_US;
+  } else if (lhsProcedure->HasExplicitInterface() &&
+      !rhsProcedure->HasExplicitInterface()) {
+    msg = "Procedure %s with explicit interface may not be associated with"
+          " procedure designator '%s' with implicit interface"_err_en_US;
+  } else if (!lhsProcedure->HasExplicitInterface() &&
+      rhsProcedure->HasExplicitInterface()) {
+    msg = "Procedure %s with implicit interface may not be associated with"
+          " procedure designator '%s' with explicit interface"_err_en_US;
+  } else {
+    msg = "Procedure %s associated with incompatible procedure"
+          " designator '%s'"_err_en_US;
+  }
+  return msg;
+}
+
 } // namespace Fortran::evaluate
 
 namespace Fortran::semantics {
 
 // When a 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.

flang/lib/Semantics/check-call.cpp

if (const auto *expr{arg.UnwrapExpr()}) {
     bool dummyIsPointer{
         proc.attrs.test(characteristics::DummyProcedure::Attr::Pointer)};
     const auto *argProcDesignator{
         std::get_if<evaluate::ProcedureDesignator>(&expr->u)};
     const auto *argProcSymbol{
         argProcDesignator ? argProcDesignator->GetSymbol() : nullptr};
     if (auto argChars{characteristics::DummyArgument::FromActual(
             "actual argument", *expr, context)}) {
+      if (!argChars->IsTypelessIntrinsicDummy()) {
         if (auto *argProc{
                 std::get_if<characteristics::DummyProcedure>(&argChars->u)}) {
           characteristics::Procedure &argInterface{argProc->procedure.value()};
-        argInterface.attrs.reset(characteristics::Procedure::Attr::NullPointer);
+          argInterface.attrs.reset(
+              characteristics::Procedure::Attr::NullPointer);
           if (!argProcSymbol || argProcSymbol->attrs().test(Attr::INTRINSIC)) {
             // It's ok to pass ELEMENTAL unrestricted intrinsic functions.
-          argInterface.attrs.reset(characteristics::Procedure::Attr::Elemental);
+            argInterface.attrs.reset(
+                characteristics::Procedure::Attr::Elemental);
           } else if (argInterface.attrs.test(
                          characteristics::Procedure::Attr::Elemental)) {
             if (argProcSymbol) { // C1533
               evaluate::SayWithDeclaration(messages, *argProcSymbol,
                   "Non-intrinsic ELEMENTAL procedure '%s' may not be passed as an actual argument"_err_en_US,
                   argProcSymbol->name());
               return; // avoid piling on with checks below
             } else {
               argInterface.attrs.reset(
                   characteristics::Procedure::Attr::NullPointer);
             }
           }
           if (!interface.IsPure()) {
             // 15.5.2.9(1): if dummy is not pure, actual need not be.
             argInterface.attrs.reset(characteristics::Procedure::Attr::Pure);
           }
           if (interface.HasExplicitInterface()) {
             if (interface != argInterface) {
               messages.Say(
                   "Actual argument procedure has interface incompatible with %s"_err_en_US,
                   dummyName);
             }
           } else { // 15.5.2.9(2,3)
             if (interface.IsSubroutine() && argInterface.IsFunction()) {
               messages.Say(
                   "Actual argument associated with procedure %s is a function but must be a subroutine"_err_en_US,
                   dummyName);
             } else if (interface.IsFunction()) {
               if (argInterface.IsFunction()) {
                 if (interface.functionResult != argInterface.functionResult) {
                   messages.Say(
                       "Actual argument function associated with procedure %s has incompatible result type"_err_en_US,
                       dummyName);
                 }
               } else if (argInterface.IsSubroutine()) {
                 messages.Say(
                     "Actual argument associated with procedure %s is a subroutine but must be a function"_err_en_US,
                     dummyName);
               }
             }
           }
         } else {
           messages.Say(
               "Actual argument associated with procedure %s is not a procedure"_err_en_US,
               dummyName);
         }
       } else if (!(dummyIsPointer && IsNullPointer(*expr))) {
         messages.Say(
             "Actual argument associated with procedure %s is not a procedure"_err_en_US,
             dummyName);
       }
+    }
     if (interface.HasExplicitInterface()) {
       if (dummyIsPointer) {
         // 15.5.2.9(5) -- dummy procedure POINTER
         // Interface compatibility has already been checked above by comparison.
         if (proc.intent != common::Intent::In && !IsVariable(*expr)) {
           messages.Say(
               "Actual argument associated with procedure pointer %s must be a POINTER unless INTENT(IN)"_err_en_US,
               dummyName);
std::visit(
                 arg.set_dummyIntent(object.intent);
                 bool isElemental{object.type.Rank() == 0 && proc.IsElemental()};
                 CheckExplicitDataArg(object, dummyName, *expr, *type,
                     isElemental, IsArrayElement(*expr), context, scope);
               } else if (object.type.type().IsTypelessIntrinsicArgument() &&
                   std::holds_alternative<evaluate::BOZLiteralConstant>(
                       expr->u)) {
                 // ok
+              } else if (object.type.type().IsTypelessIntrinsicArgument() &&
+                  evaluate::IsNullPointer(*expr)) {
+                // ok, calling ASSOCIATED(NULL())
               } else {
                 messages.Say(
                     "Actual argument '%s' associated with %s is not a variable or typed expression"_err_en_US,
                     expr->AsFortran(), dummyName);
               }
             } else {
               const Symbol &assumed{DEREF(arg.GetAssumedTypeDummy())};
               if (!object.type.type().IsAssumedType()) {

flang/lib/Semantics/expression.cpp

auto chars{
       characteristics::Procedure::Characterize(proc, context_.intrinsics())};
   if (chars) {
     bool treatExternalAsImplicit{IsExternalCalledImplicitly(callSite, proc)};
     if (treatExternalAsImplicit && !chars->CanBeCalledViaImplicitInterface()) {
       Say(callSite,
           "References to the procedure '%s' require an explicit interface"_en_US,
           DEREF(proc.GetSymbol()).name());
     }
+    // Checks for ASSOCIATED() are done in intrinsic table processing
+    bool procIsAssociated{false};
+    if (const SpecificIntrinsic *
+        specificIntrinsic{proc.GetSpecificIntrinsic()}) {
+      if (specificIntrinsic->name == "associated") {
+        procIsAssociated = true;
+      }
+    }
+    if (!procIsAssociated) {
       semantics::CheckArguments(*chars, arguments, GetFoldingContext(),
           context_.FindScope(callSite), treatExternalAsImplicit);
       const Symbol *procSymbol{proc.GetSymbol()};
       if (procSymbol && !IsPureProcedure(*procSymbol)) {
         if (const semantics::Scope *
             pure{semantics::FindPureProcedureContaining(
                 context_.FindScope(callSite))}) {
           Say(callSite,
               "Procedure '%s' referenced in pure subprogram '%s' must be pure too"_err_en_US,
               procSymbol->name(), DEREF(pure->symbol()).name());
         }
       }
     }
+  }
   return chars;
 }
 
 // Unary operations
 
 MaybeExpr ExpressionAnalyzer::Analyze(const parser::Expr::Parentheses &x) {
   if (MaybeExpr operand{Analyze(x.v.value())}) {
     if (const semantics::Symbol * symbol{GetLastSymbol(*operand)}) {

 MaybeExpr RelationHelper(ExpressionAnalyzer &context, RelationalOperator opr,
     const parser::Expr::IntrinsicBinary &x) {
   ArgumentAnalyzer analyzer{context};
   analyzer.Analyze(std::get<0>(x.t));
   analyzer.Analyze(std::get<1>(x.t));
   if (analyzer.fatalErrors()) {
     return std::nullopt;
   } else {
+    if (IsNullPointer(analyzer.GetExpr(0)) ||
+        IsNullPointer(analyzer.GetExpr(1))) {
+      context.Say("NULL() not allowed as an operand of a relational "
+                  "operator"_err_en_US);
+      return std::nullopt;
+    }
     analyzer.ConvertBOZ(0, analyzer.GetType(1));
     analyzer.ConvertBOZ(1, analyzer.GetType(0));
     if (analyzer.IsIntrinsicRelational(opr)) {
       return AsMaybeExpr(Relate(context.GetContextualMessages(), opr,
           analyzer.MoveExpr(0), analyzer.MoveExpr(1)));
     } else {
       return analyzer.TryDefinedOp(opr,
           "Operands of %s must have comparable types; have %s and %s"_err_en_US);

flang/lib/Semantics/pointer-assignment.cpp

if (msg) {
     } else {
       Say(std::get<MessageFormattedText>(*msg));
     }
     return false;
   }
   return true;
 }
 
-// Compare procedure characteristics for equality except that lhs may be
-// Pure or Elemental when rhs is not.
-static bool CharacteristicsMatch(const Procedure &lhs, const Procedure &rhs) {
-  using Attr = Procedure::Attr;
-  auto lhsAttrs{rhs.attrs};
-  lhsAttrs.set(
-      Attr::Pure, lhs.attrs.test(Attr::Pure) | rhs.attrs.test(Attr::Pure));
-  lhsAttrs.set(Attr::Elemental,
-      lhs.attrs.test(Attr::Elemental) | rhs.attrs.test(Attr::Elemental));
-  return lhsAttrs == rhs.attrs && lhs.functionResult == rhs.functionResult &&
-      lhs.dummyArguments == rhs.dummyArguments;
-}
-
 // Common handling for procedure pointer right-hand sides
 bool PointerAssignmentChecker::Check(
     parser::CharBlock rhsName, bool isCall, const Procedure *rhsProcedure) {
-  std::optional<MessageFixedText> msg;
-  if (!procedure_) {
-    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 (CharacteristicsMatch(*procedure_, *rhsProcedure)) {
-    // OK
-  } else if (isCall) {
-    msg = "Procedure %s associated with result of reference to function '%s'"
-          " that is an incompatible procedure pointer"_err_en_US;
-  } else if (procedure_->IsPure() && !rhsProcedure->IsPure()) {
-    msg = "PURE procedure %s may not be associated with non-PURE"
-          " procedure designator '%s'"_err_en_US;
-  } else if (procedure_->IsElemental() && !rhsProcedure->IsElemental()) {
-    msg = "ELEMENTAL procedure %s may not be associated with non-ELEMENTAL"
-          " procedure designator '%s'"_err_en_US;
-  } else if (procedure_->IsFunction() && !rhsProcedure->IsFunction()) {
-    msg = "Function %s may not be associated with subroutine"
-          " designator '%s'"_err_en_US;
-  } else if (!procedure_->IsFunction() && rhsProcedure->IsFunction()) {
-    msg = "Subroutine %s may not be associated with function"
-          " designator '%s'"_err_en_US;
-  } else if (procedure_->HasExplicitInterface() &&
-      !rhsProcedure->HasExplicitInterface()) {
-    msg = "Procedure %s with explicit interface may not be associated with"
-          " procedure designator '%s' with implicit interface"_err_en_US;
-  } else if (!procedure_->HasExplicitInterface() &&
-      rhsProcedure->HasExplicitInterface()) {
-    msg = "Procedure %s with implicit interface may not be associated with"
-          " procedure designator '%s' with explicit interface"_err_en_US;
-  } else {
-    msg = "Procedure %s associated with incompatible procedure"
-          " designator '%s'"_err_en_US;
-  }
-  if (msg) {
+  if (std::optional<MessageFixedText> msg{
+          evaluate::CheckProcCompatibility(isCall, procedure_, rhsProcedure)}) {
     Say(std::move(*msg), description_, rhsName);
     return false;
   }
   return true;
 }
 
 bool PointerAssignmentChecker::Check(const evaluate::ProcedureDesignator &d) {
   if (auto chars{Procedure::Characterize(d, context_.intrinsics())}) {

flang/test/Evaluate/folding06.f90

 ! RUN: %S/test_folding.sh %s %t %f18
 ! Test transformational intrinsic function folding
 
 module m
 
+  ! Testing ASSOCATED
+  integer, pointer :: int_pointer
+  integer, allocatable :: int_allocatable
+  logical, parameter :: test_Assoc1 = .not.(associated(null()))
+  logical, parameter :: test_Assoc2 = .not.(associated(null(), null()))
+  logical, parameter :: test_Assoc3 = .not.(associated(null(int_pointer)))
+  logical, parameter :: test_Assoc4 = .not.(associated(null(int_allocatable)))
+  logical, parameter :: test_Assoc5 = .not.(associated(null(), null(int_pointer)))
+  logical, parameter :: test_Assoc6 = .not.(associated(null(), null(int_allocatable)))
+
   type A
     real(4) x
     integer(8) i
   end type
 
   integer(8), parameter :: new_shape(*) = [2, 4]
   integer(4), parameter :: order(2) = [2, 1]
 

flang/test/Semantics/associated.f90

+! RUN: %S/test_errors.sh %s %t %f18
+! Tests for the ASSOCIATED() and NULL() intrinsics
+subroutine assoc()
+
+  abstract interface
+    subroutine subrInt(i)
+      integer :: i
+    end subroutine subrInt
+
+    integer function abstractIntFunc(x)
+      integer, intent(in) :: x
+    end function
+  end interface
+
+  contains
+  integer function intFunc(x)
+    integer, intent(in) :: x
+    intFunc = x
+  end function
+
+  real function realFunc(x)
+    real, intent(in) :: x
+    realFunc = x
+  end function
+
+  pure integer function pureFunc()
+    pureFunc = 343
+  end function pureFunc
+
+  elemental integer function elementalFunc()
+    elementalFunc = 343
+  end function elementalFunc
+
+  subroutine subr(i)
+    integer :: i
+  end subroutine subr
+
+  subroutine test()
+    integer :: intVar
+    integer, target :: targetIntVar1
+    integer(kind=2), target :: targetIntVar2
+    real, target :: targetRealVar
+    integer, pointer :: intPointerVar1
+    integer, pointer :: intPointerVar2
+    integer, allocatable :: intAllocVar
+    procedure(intFunc) :: intProc
+    procedure(intFunc), pointer :: intprocPointer1
+    procedure(intFunc), pointer :: intprocPointer2
+    procedure(realFunc) :: realProc
+    procedure(realFunc), pointer :: realprocPointer1
+    procedure(pureFunc), pointer :: pureFuncPointer
+    procedure(elementalFunc) :: elementalProc
+    external :: externalProc
+    procedure(subrInt) :: subProc
+    procedure(subrInt), pointer :: subProcPointer
+    procedure(), pointer :: implicitProcPointer
+    logical :: lVar
+
+    !ERROR: missing mandatory 'pointer=' argument
+    lVar = associated()
+    !ERROR: MOLD= argument to NULL() must be a pointer or allocatable
+    lVar = associated(null(intVar))
+    lVar = associated(null(intAllocVar)) !OK
+    lVar = associated(null()) !OK
+    lVar = associated(null(intPointerVar1)) !OK
+    lVar = associated(null(), null()) !OK
+    lVar = associated(intPointerVar1, null(intPointerVar2)) !OK
+    lVar = associated(intPointerVar1, null()) !OK
+    lVar = associated(null(), null(intPointerVar1)) !OK
+    lVar = associated(null(intPointerVar1), null()) !OK
+    !ERROR: POINTER= argument of ASSOCIATED() must be a POINTER
+    lVar = associated(intVar)
+    !ERROR: POINTER= argument of ASSOCIATED() must be a POINTER
+    lVar = associated(intVar, intVar)
+    !ERROR: POINTER= argument of ASSOCIATED() must be a POINTER
+    lVar = associated(intAllocVar)
+    lVar = associated(intPointerVar1, intVar) !OK
+    !ERROR: Arguments of ASSOCIATED() must be a POINTER and an optional valid target
+    lVar = associated(intPointerVar1, targetRealVar)
+    lVar = associated(intPointerVar1, targetIntVar1) !OK
+    !ERROR: Arguments of ASSOCIATED() must be a POINTER and an optional valid target
+    lVar = associated(intPointerVar1, targetIntVar2)
+    lVar = associated(intPointerVar1) !OK
+    lVar = associated(intPointerVar1, intPointerVar2) !OK
+
+    ! Procedure pointer tests
+    intprocPointer1 => intProc !OK
+    lVar = associated(intprocPointer1, intProc) !OK
+    intprocPointer1 => intProcPointer2 !OK
+    lVar = associated(intprocPointer1, intProcPointer2) !OK
+    intProcPointer1  => null(intProcPointer2) ! ok
+    lvar = associated(intProcPointer1, null(intProcPointer2)) ! ok
+    intProcPointer1 => null() ! ok
+    lvar = associated(intProcPointer1, null()) ! ok
+    intProcPointer1 => intProcPointer2 ! ok
+    lvar = associated(intProcPointer1, intProcPointer2) ! ok
+    intProcPointer1 => null(intProcPointer2) ! ok
+    lvar = associated(intProcPointer1, null(intProcPointer2)) ! ok
+    intProcPointer1 =>null() ! ok
+    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'
+    intProcPointer1 => elementalProc
+    !ERROR: Procedure pointer 'intprocpointer1' associated with incompatible procedure designator 'elementalproc'
+    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
+    intProcPointer1 => targetIntVar1
+    !ERROR: POINTER= argument 'intprocpointer1' is a procedure pointer but the TARGET= argument 'targetintvar1' is not a procedure or procedure pointer
+    lvar = associated (intProcPointer1, targetIntVar1)
+    !ERROR: Procedure pointer 'intprocpointer1' associated with result of reference to function 'null' that is an incompatible procedure pointer
+    intProcPointer1 => null(mold=realProcPointer1)
+    !ERROR: Procedure pointer 'intprocpointer1' associated with result of reference to function 'null()' that is an incompatible procedure pointer
+    lvar = associated(intProcPointer1, null(mold=realProcPointer1))
+    !ERROR: PURE procedure pointer 'purefuncpointer' may not be associated with non-PURE procedure designator 'intproc'
+    pureFuncPointer => intProc
+    !ERROR: PURE procedure pointer 'purefuncpointer' may not be associated with non-PURE procedure designator 'intproc'
+    lvar = associated(pureFuncPointer, intProc)
+    !ERROR: Procedure pointer 'realprocpointer1' associated with incompatible procedure designator 'intproc'
+    realProcPointer1 => intProc
+    !ERROR: Procedure pointer 'realprocpointer1' associated with incompatible procedure designator 'intproc'
+    lvar = associated(realProcPointer1, intProc)
+    !ERROR: Procedure pointer 'subprocpointer' with explicit interface may not be associated with procedure designator 'externalproc' with implicit interface
+    subProcPointer => externalProc
+    !ERROR: Procedure pointer 'subprocpointer' with explicit interface may not be associated with procedure designator 'externalproc' with implicit interface
+    lvar = associated(subProcPointer, externalProc)
+    !ERROR: Subroutine pointer 'subprocpointer' may not be associated with function designator 'intproc'
+    subProcPointer => intProc
+    !ERROR: Subroutine pointer 'subprocpointer' may not be associated with function designator 'intproc'
+    lvar = associated(subProcPointer, intProc)
+    !ERROR: Function pointer 'intprocpointer1' may not be associated with subroutine designator 'subproc'
+    intProcPointer1 => subProc
+    !ERROR: Function pointer 'intprocpointer1' may not be associated with subroutine designator 'subproc'
+    lvar = associated(intProcPointer1, subProc)
+    !ERROR: Procedure pointer 'implicitprocpointer' with implicit interface may not be associated with procedure designator 'subr' with explicit interface
+    implicitProcPointer => subr
+    !ERROR: Procedure pointer 'implicitprocpointer' with implicit interface may not be associated with procedure designator 'subr' with explicit interface
+    lvar = associated(implicitProcPointer, subr)
+  end subroutine test
+end subroutine assoc

flang/test/Semantics/call02.f90

subroutine badsubr(dummy)
       !ERROR: A dummy procedure may not be ELEMENTAL
       procedure(elem) :: dummy
     end subroutine
   end interface
   intrinsic :: cos
   call subr(cos) ! not an error
   !ERROR: Non-intrinsic ELEMENTAL procedure 'elem' may not be passed as an actual argument
   call subr(elem) ! C1533
+  !ERROR: Actual argument associated with procedure dummy argument 'dummy=' is not a procedure
+  !ERROR: Actual argument associated with non-POINTER procedure dummy argument 'dummy=' must be a procedure (and not a procedure pointer)
+  call subr(null())
+  !ERROR: Actual argument associated with procedure dummy argument 'dummy=' is not a procedure
+  !ERROR: Actual argument associated with non-POINTER procedure dummy argument 'dummy=' must be a procedure (and not a procedure pointer)
+  call subr(B"1010")
 end subroutine
 
 module m01
   procedure(sin) :: elem01
   interface
     elemental real function elem02(x)
       real, value :: x
     end function

flang/test/Semantics/call09.f90

function intprocptr()
     procedure(intfunc), pointer :: intprocptr
     intprocptr => intfunc
   end function
 
   subroutine test1 ! 15.5.2.9(5)
     intrinsic :: sin
     procedure(realfunc), pointer :: p
     procedure(intfunc), pointer :: ip
+    integer, pointer :: intPtr
     p => realfunc
     ip => intfunc
     call s01(realfunc) ! ok
     !ERROR: Actual argument procedure has interface incompatible with dummy argument 'p='
     call s01(intfunc)
     call s01(p) ! ok
     call s01(procptr()) ! ok
     !ERROR: Actual argument procedure has interface incompatible with dummy argument 'p='
     call s01(intprocptr())
     call s01(null()) ! ok
     call s01(null(p)) ! ok
     !ERROR: Actual argument procedure has interface incompatible with dummy argument 'p='
     call s01(null(ip))
     call s01(sin) ! ok
+    !ERROR: Actual argument associated with procedure dummy argument 'p=' is not a procedure
+    call s01(null(intPtr))
+    !ERROR: Actual argument associated with procedure dummy argument 'p=' is not a procedure
+    call s01(B"0101")
     !ERROR: Actual argument associated with procedure pointer dummy argument 'p=' must be a POINTER unless INTENT(IN)
     call s02(realfunc)
     call s02(p) ! ok
     !ERROR: Actual argument procedure has interface incompatible with dummy argument 'p='
     call s02(ip)
     !ERROR: Actual argument associated with procedure pointer dummy argument 'p=' must be a POINTER unless INTENT(IN)
     call s02(procptr())
     !ERROR: Actual argument associated with procedure pointer dummy argument 'p=' must be a POINTER unless INTENT(IN)

flang/test/Semantics/resolve63.f90

logical function add(x, y)
       logical, intent(in) :: x
       integer, value :: y
     end
   end interface
 contains
   subroutine s1(x, y) 
     logical :: x
     integer :: y
+    integer, pointer :: px
     logical :: l
     complex :: z
     y = y + z'1'  !OK
     !ERROR: Operands of + must be numeric; have untyped and COMPLEX(4)
     z = z'1' + z
     y = +z'1'  !OK
     !ERROR: Operand of unary - must be numeric; have untyped
     y = -z'1'
     !ERROR: Operands of + must be numeric; have LOGICAL(4) and untyped
     y = x + z'1'
-    !ERROR: Operands of .NE. must have comparable types; have LOGICAL(4) and untyped
+    !ERROR: NULL() not allowed as an operand of a relational operator
     l = x /= null()
+    !ERROR: NULL() not allowed as an operand of a relational operator
+    l = null(px) /= null(px)
+    !ERROR: NULL() not allowed as an operand of a relational operator
+    l = x /= null(px)
+    !ERROR: NULL() not allowed as an operand of a relational operator
+    l = px /= null()
+    !ERROR: NULL() not allowed as an operand of a relational operator
+    l = px /= null(px)
+    !ERROR: NULL() not allowed as an operand of a relational operator
+    l = null() /= null()
   end
 end
 
 ! Test alternate operators. They aren't enabled by default so should be
 ! treated as defined operators, not intrinsic ones.
 module m4
 contains
   subroutine s1(x, y, z)