From b22873b18cd81529623566fd13ef90cdb48c6ee7 Mon Sep 17 00:00:00 2001 From: Peter Klausler Date: Wed, 12 Oct 2022 12:59:48 -0700 Subject: [PATCH] [flang] Always diagnose incompatible function results when associating function pointers 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.) Differential Revision: https://reviews.llvm.org/D136964 --- flang/include/flang/Semantics/symbol.h | 6 +++++- flang/lib/Evaluate/tools.cpp | 6 ++++++ flang/lib/Semantics/resolve-names.cpp | 15 +++++++++++++-- flang/lib/Semantics/symbol.cpp | 6 +++--- flang/test/Semantics/assign03.f90 | 4 +++- flang/test/Semantics/associated.f90 | 4 ++-- flang/test/Semantics/resolve46.f90 | 4 ++-- 7 files changed, 34 insertions(+), 11 deletions(-) diff --git a/flang/include/flang/Semantics/symbol.h b/flang/include/flang/Semantics/symbol.h index c7bd58c..9c3c22c 100644 --- a/flang/include/flang/Semantics/symbol.h +++ b/flang/include/flang/Semantics/symbol.h @@ -187,6 +187,7 @@ 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_; } @@ -247,7 +248,10 @@ private: 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_; } diff --git a/flang/lib/Evaluate/tools.cpp b/flang/lib/Evaluate/tools.cpp index 9d148ba..dce5dda 100644 --- a/flang/lib/Evaluate/tools.cpp +++ b/flang/lib/Evaluate/tools.cpp @@ -1004,6 +1004,12 @@ std::optional CheckProcCompatibility(bool isCall, } 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 diff --git a/flang/lib/Semantics/resolve-names.cpp b/flang/lib/Semantics/resolve-names.cpp index 5612f1f..4daf875 100644 --- a/flang/lib/Semantics/resolve-names.cpp +++ b/flang/lib/Semantics/resolve-names.cpp @@ -671,8 +671,10 @@ protected: const DeclTypeSpec &MakeNumericType( TypeCategory, const std::optional &); + const DeclTypeSpec &MakeNumericType(TypeCategory, int); const DeclTypeSpec &MakeLogicalType( const std::optional &); + const DeclTypeSpec &MakeLogicalType(int); void NotePossibleBadForwardRef(const parser::Name &); std::optional HadForwardRef(const Symbol &) const; bool CheckPossibleBadForwardRef(const Symbol &); @@ -2535,22 +2537,31 @@ const DeclTypeSpec &ScopeHandler::MakeNumericType( TypeCategory category, const std::optional &kind) { KindExpr value{GetKindParamExpr(category, kind)}; if (auto known{evaluate::ToInt64(value)}) { - return context().MakeNumericType(category, static_cast(*known)); + return MakeNumericType(category, static_cast(*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 &kind) { KindExpr value{GetKindParamExpr(TypeCategory::Logical, kind)}; if (auto known{evaluate::ToInt64(value)}) { - return context().MakeLogicalType(static_cast(*known)); + return MakeLogicalType(static_cast(*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()}; diff --git a/flang/lib/Semantics/symbol.cpp b/flang/lib/Semantics/symbol.cpp index 432db34..fe7942b 100644 --- a/flang/lib/Semantics/symbol.cpp +++ b/flang/lib/Semantics/symbol.cpp @@ -136,6 +136,9 @@ void EntityDetails::set_type(const DeclTypeSpec &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) { @@ -363,9 +366,6 @@ bool Symbol::IsFromModFile() const { (!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()); diff --git a/flang/test/Semantics/assign03.f90 b/flang/test/Semantics/assign03.f90 index a5d12be..07e2c49 100644 --- a/flang/test/Semantics/assign03.f90 +++ b/flang/test/Semantics/assign03.f90 @@ -100,8 +100,10 @@ contains !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 diff --git a/flang/test/Semantics/associated.f90 b/flang/test/Semantics/associated.f90 index 09639ad..6774a64 100644 --- a/flang/test/Semantics/associated.f90 +++ b/flang/test/Semantics/associated.f90 @@ -155,9 +155,9 @@ subroutine assoc() 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 diff --git a/flang/test/Semantics/resolve46.f90 b/flang/test/Semantics/resolve46.f90 index e50caaf..56b7fd9 100644 --- a/flang/test/Semantics/resolve46.f90 +++ b/flang/test/Semantics/resolve46.f90 @@ -34,9 +34,9 @@ program main 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 -- 2.7.4