diff --git a/flang/include/flang/Semantics/symbol.h b/flang/include/flang/Semantics/symbol.h --- a/flang/include/flang/Semantics/symbol.h +++ b/flang/include/flang/Semantics/symbol.h @@ -187,6 +187,7 @@ 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 @@ 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 --- a/flang/lib/Evaluate/tools.cpp +++ b/flang/lib/Evaluate/tools.cpp @@ -1004,6 +1004,12 @@ } 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 --- a/flang/lib/Semantics/resolve-names.cpp +++ b/flang/lib/Semantics/resolve-names.cpp @@ -671,8 +671,10 @@ 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 @@ 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 --- a/flang/lib/Semantics/symbol.cpp +++ b/flang/lib/Semantics/symbol.cpp @@ -136,6 +136,9 @@ 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 @@ (!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 --- a/flang/test/Semantics/assign03.f90 +++ b/flang/test/Semantics/assign03.f90 @@ -100,8 +100,10 @@ !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 --- a/flang/test/Semantics/associated.f90 +++ b/flang/test/Semantics/associated.f90 @@ -155,9 +155,9 @@ 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 --- a/flang/test/Semantics/resolve46.f90 +++ b/flang/test/Semantics/resolve46.f90 @@ -34,9 +34,9 @@ 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