[flang] Always diagnose incompatible function results when associating function pointers

[klausler]

Summary

There are some exceptional cases where the compiler permits association of
procedure pointers or dummy arguments with slightly incompatible procedure
targets, but they should not override any incompatibilty of function
result types.

(Includes a second fix to resolve the original motivating test failure, in
which a COMPLEX intrinsic function was getting its result kind divided by
two due to an implicit C++ conversion of the kind to a "*kind" parse tree
node, and those legacy "COMPLEX*size" type designators' values are twice
the type kind value.)

[klausler]

Resolve merge difference in test.

[jeanPerier]

LGTM

flang/include/flang/Semantics/symbol.h

 };
 llvm::raw_ostream &operator<<(llvm::raw_ostream &, const AssocEntityDetails &);
 
 // An entity known to be an object.
 class ObjectEntityDetails : public EntityDetails {
 public:
   explicit ObjectEntityDetails(EntityDetails &&);
   ObjectEntityDetails(const ObjectEntityDetails &) = default;
+  ObjectEntityDetails(ObjectEntityDetails &&) = default;
   ObjectEntityDetails &operator=(const ObjectEntityDetails &) = default;
   ObjectEntityDetails(bool isDummy = false) : EntityDetails(isDummy) {}
   MaybeExpr &init() { return init_; }
   const MaybeExpr &init() const { return init_; }
   void set_init(MaybeExpr &&expr) { init_ = std::move(expr); }
   const parser::Expr *unanalyzedPDTComponentInit() const {
     return unanalyzedPDTComponentInit_;
   }

 };
 
 // A procedure pointer (other than one defined with POINTER and an
 // INTERFACE block), a dummy procedure (without an INTERFACE but with
 // EXTERNAL or use in a procedure reference), or external procedure.
 class ProcEntityDetails : public EntityDetails, public WithPassArg {
 public:
   ProcEntityDetails() = default;
-  explicit ProcEntityDetails(EntityDetails &&d);
+  explicit ProcEntityDetails(EntityDetails &&);
+  ProcEntityDetails(const ProcEntityDetails &) = default;
+  ProcEntityDetails(ProcEntityDetails &&) = default;
+  ProcEntityDetails &operator=(const ProcEntityDetails &) = default;
 
   const ProcInterface &interface() const { return interface_; }
   ProcInterface &interface() { return interface_; }
   void set_interface(const ProcInterface &interface) { interface_ = interface; }
   bool IsInterfaceSet() {
     return interface_.symbol() != nullptr || interface_.type() != nullptr;
   }
   inline bool HasExplicitInterface() const;

flang/lib/Evaluate/tools.cpp

std::optional<parser::MessageFixedText> CheckProcCompatibility(bool isCall,
     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 (!isCall && lhsProcedure->functionResult &&
+      rhsProcedure->functionResult &&
+      !lhsProcedure->functionResult->IsCompatibleWith(
+          *rhsProcedure->functionResult, &whyNotCompatible)) {
+    msg =
+        "Function %s associated with incompatible function designator '%s': %s"_err_en_US;
   } 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"

flang/lib/Semantics/resolve-names.cpp

protected:
   void AcquireIntrinsicProcedureFlags(Symbol &);
   const DeclTypeSpec *GetImplicitType(
       Symbol &, bool respectImplicitNoneType = true);
   bool ConvertToObjectEntity(Symbol &);
   bool ConvertToProcEntity(Symbol &);
 
   const DeclTypeSpec &MakeNumericType(
       TypeCategory, const std::optional<parser::KindSelector> &);
+  const DeclTypeSpec &MakeNumericType(TypeCategory, int);
   const DeclTypeSpec &MakeLogicalType(
       const std::optional<parser::KindSelector> &);
+  const DeclTypeSpec &MakeLogicalType(int);
   void NotePossibleBadForwardRef(const parser::Name &);
   std::optional<SourceName> HadForwardRef(const Symbol &) const;
   bool CheckPossibleBadForwardRef(const Symbol &);
 
   bool inSpecificationPart_{false};
   bool inEquivalenceStmt_{false};
 
   // Some information is collected from a specification part for deferred
bool ScopeHandler::ConvertToProcEntity(Symbol &symbol) {
   }
   return true;
 }
 
 const DeclTypeSpec &ScopeHandler::MakeNumericType(
     TypeCategory category, const std::optional<parser::KindSelector> &kind) {
   KindExpr value{GetKindParamExpr(category, kind)};
   if (auto known{evaluate::ToInt64(value)}) {
-    return context().MakeNumericType(category, static_cast<int>(*known));
+    return MakeNumericType(category, static_cast<int>(*known));
   } else {
     return currScope_->MakeNumericType(category, std::move(value));
   }
 }
 
+const DeclTypeSpec &ScopeHandler::MakeNumericType(
+    TypeCategory category, int kind) {
+  return context().MakeNumericType(category, kind);
+}
+
 const DeclTypeSpec &ScopeHandler::MakeLogicalType(
     const std::optional<parser::KindSelector> &kind) {
   KindExpr value{GetKindParamExpr(TypeCategory::Logical, kind)};
   if (auto known{evaluate::ToInt64(value)}) {
-    return context().MakeLogicalType(static_cast<int>(*known));
+    return MakeLogicalType(static_cast<int>(*known));
   } else {
     return currScope_->MakeLogicalType(std::move(value));
   }
 }
 
+const DeclTypeSpec &ScopeHandler::MakeLogicalType(int kind) {
+  return context().MakeLogicalType(kind);
+}
+
 void ScopeHandler::NotePossibleBadForwardRef(const parser::Name &name) {
   if (inSpecificationPart_ && name.symbol) {
     auto kind{currScope().kind()};
     if ((kind == Scope::Kind::Subprogram && !currScope().IsStmtFunction()) ||
         kind == Scope::Kind::BlockConstruct) {
       bool isHostAssociated{&name.symbol->owner() == &currScope()
               ? name.symbol->has<HostAssocDetails>()
               : name.symbol->owner().Contains(currScope())};

flang/lib/Semantics/symbol.cpp

 void EntityDetails::set_type(const DeclTypeSpec &type) {
   CHECK(!type_);
   type_ = &type;
 }
 
 void AssocEntityDetails::set_rank(int rank) { rank_ = rank; }
 void EntityDetails::ReplaceType(const DeclTypeSpec &type) { type_ = &type; }
 
+ObjectEntityDetails::ObjectEntityDetails(EntityDetails &&d)
+    : EntityDetails(d) {}
+
 void ObjectEntityDetails::set_shape(const ArraySpec &shape) {
   CHECK(shape_.empty());
   for (const auto &shapeSpec : shape) {
     shape_.push_back(shapeSpec);
   }
 }
 void ObjectEntityDetails::set_coshape(const ArraySpec &coshape) {
   CHECK(coshape_.empty());
return common::visit(
       details_);
 }
 
 bool Symbol::IsFromModFile() const {
   return test(Flag::ModFile) ||
       (!owner_->IsTopLevel() && owner_->symbol()->IsFromModFile());
 }
 
-ObjectEntityDetails::ObjectEntityDetails(EntityDetails &&d)
-    : EntityDetails(d) {}
-
 llvm::raw_ostream &operator<<(llvm::raw_ostream &os, const EntityDetails &x) {
   DumpBool(os, "dummy", x.isDummy());
   DumpBool(os, "funcResult", x.isFuncResult());
   if (x.type()) {
     os << " type: " << *x.type();
   }
   DumpOptional(os, "bindName", x.bindName());
   return os;

flang/test/Semantics/assign03.f90

subroutine s5
     !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)
+    !ERROR: Function pointer 'p_pure' associated with incompatible function designator 'f_pure2': function results have incompatible types: INTEGER(4) vs REAL(4)
     p_pure => f_pure2
+    !ERROR: Function pointer 'p_pure' associated with incompatible function designator 'ccos': function results have incompatible types: INTEGER(4) vs COMPLEX(4)
+    p_pure => ccos
     !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': incompatible procedure attributes: Elemental

flang/test/Semantics/associated.f90

subroutine test()
     !ERROR: Procedure pointer 'intprocpointer1' associated with result of reference to function 'null' that is an incompatible procedure pointer: function results have incompatible types: INTEGER(4) vs REAL(4)
     intProcPointer1 => null(mold=realProcPointer1)
     !WARNING: Procedure pointer 'intprocpointer1' associated with result of reference to function 'null()' that is an incompatible procedure pointer: function results have incompatible types: INTEGER(4) vs REAL(4)
     lvar = associated(intProcPointer1, null(mold=realProcPointer1))
     !ERROR: PURE procedure pointer 'purefuncpointer' may not be associated with non-PURE procedure designator 'intproc'
     pureFuncPointer => intProc
     !WARNING: 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': function results have incompatible types: REAL(4) vs INTEGER(4)
+    !ERROR: Function pointer 'realprocpointer1' associated with incompatible function designator 'intproc': function results have incompatible types: REAL(4) vs INTEGER(4)
     realProcPointer1 => intProc
-    !WARNING: Procedure pointer 'realprocpointer1' associated with incompatible procedure designator 'intproc': function results have incompatible types: REAL(4) vs INTEGER(4)
+    !WARNING: Function pointer 'realprocpointer1' associated with incompatible function designator 'intproc': function results have incompatible types: REAL(4) vs INTEGER(4)
     lvar = associated(realProcPointer1, intProc)
     subProcPointer => externalProc ! OK to associate a procedure pointer  with an explicit interface to a procedure with an implicit interface
     lvar = associated(subProcPointer, externalProc) ! OK to associate a procedure pointer with an explicit interface to a procedure with an implicit interface
     !ERROR: Subroutine pointer 'subprocpointer' may not be associated with function designator 'intproc'
     subProcPointer => intProc
     !WARNING: 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'

flang/test/Semantics/resolve46.f90

program main
   procedure(chrcmp), pointer :: s => llt
   !ERROR: Intrinsic procedure 'bessel_j0' is not an unrestricted specific intrinsic permitted for use as the initializer for procedure pointer 't'
   procedure(cos), pointer :: t => bessel_j0
   procedure(chrcmp), pointer :: u
   p => alog ! valid use of an unrestricted specific intrinsic
   p => alog10 ! ditto, but already declared intrinsic
   p => cos ! ditto, but also generic
   p => tan ! a generic & an unrestricted specific, not already declared
-  !ERROR: Procedure pointer 'p' associated with incompatible procedure designator 'mod': function results have incompatible types: REAL(4) vs INTEGER(4)
+  !ERROR: Function pointer 'p' associated with incompatible function designator 'mod': function results have incompatible types: REAL(4) vs INTEGER(4)
   p => mod
-  !ERROR: Procedure pointer 'p' associated with incompatible procedure designator 'index': function results have incompatible types: REAL(4) vs INTEGER(4)
+  !ERROR: Function pointer 'p' associated with incompatible function designator 'index': function results have incompatible types: REAL(4) vs INTEGER(4)
   p => index
   !ERROR: 'bessel_j0' is not an unrestricted specific intrinsic procedure
   p => bessel_j0
   !ERROR: 'llt' is not an unrestricted specific intrinsic procedure
   u => llt
 end program main