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

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()" 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.  While testing processing for
procedure arguments, I found another bad call to `CHECK()` which 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.

Differential Revision: https://reviews.llvm.org/D88313

1 files changed, 2 insertions, 50 deletions

diff --git a/flang/lib/Semantics/pointer-assignment.cpp b/flang/lib/Semantics/pointer-assignment.cpp
index 735e842..761d664 100644
--- a/flang/lib/Semantics/pointer-assignment.cpp
+++ b/flang/lib/Semantics/pointer-assignment.cpp
@@ -250,59 +250,11 @@ bool PointerAssignmentChecker::Check(const evaluate::Designator<T> &d) {
   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;
   }