diff --git a/flang/include/flang/Evaluate/characteristics.h b/flang/include/flang/Evaluate/characteristics.h --- a/flang/include/flang/Evaluate/characteristics.h +++ b/flang/include/flang/Evaluate/characteristics.h @@ -333,7 +333,8 @@ int FindPassIndex(std::optional) const; bool CanBeCalledViaImplicitInterface() const; bool CanOverride(const Procedure &, std::optional passIndex) const; - bool IsCompatibleWith(const Procedure &, std::string *whyNot = nullptr) const; + bool IsCompatibleWith(const Procedure &, std::string *whyNot = nullptr, + const SpecificIntrinsic * = nullptr) const; llvm::raw_ostream &Dump(llvm::raw_ostream &) const; diff --git a/flang/include/flang/Evaluate/tools.h b/flang/include/flang/Evaluate/tools.h --- a/flang/include/flang/Evaluate/tools.h +++ b/flang/include/flang/Evaluate/tools.h @@ -1026,7 +1026,7 @@ std::optional CheckProcCompatibility(bool isCall, const std::optional &lhsProcedure, const characteristics::Procedure *rhsProcedure, - std::string &whyNotCompatible); + const SpecificIntrinsic *specificIntrinsic, std::string &whyNotCompatible); // Scalar constant expansion class ScalarConstantExpander { diff --git a/flang/lib/Evaluate/characteristics.cpp b/flang/lib/Evaluate/characteristics.cpp --- a/flang/lib/Evaluate/characteristics.cpp +++ b/flang/lib/Evaluate/characteristics.cpp @@ -16,6 +16,7 @@ #include "flang/Parser/message.h" #include "flang/Semantics/scope.h" #include "flang/Semantics/symbol.h" +#include "flang/Semantics/tools.h" #include "llvm/Support/raw_ostream.h" #include @@ -440,9 +441,11 @@ return std::nullopt; } seenProcs.insert(symbol); + if (IsElementalProcedure(symbol)) { + result.attrs.set(Procedure::Attr::Elemental); + } CopyAttrs(symbol, result, { - {semantics::Attr::ELEMENTAL, Procedure::Attr::Elemental}, {semantics::Attr::BIND_C, Procedure::Attr::BindC}, }); if (IsPureProcedure(symbol) || // works for ENTRY too @@ -498,8 +501,13 @@ } const semantics::ProcInterface &interface { proc.interface() }; if (const semantics::Symbol * interfaceSymbol{interface.symbol()}) { - return CharacterizeProcedure( - *interfaceSymbol, context, seenProcs); + auto interface { + CharacterizeProcedure(*interfaceSymbol, context, seenProcs) + }; + if (interface && IsPointer(symbol)) { + interface->attrs.reset(Procedure::Attr::Elemental); + } + return interface; } else { result.attrs.set(Procedure::Attr::ImplicitInterface); const semantics::DeclTypeSpec *type{interface.type()}; @@ -938,15 +946,15 @@ dummyArguments == that.dummyArguments; } -bool Procedure::IsCompatibleWith( - const Procedure &actual, std::string *whyNot) const { +bool Procedure::IsCompatibleWith(const Procedure &actual, std::string *whyNot, + const SpecificIntrinsic *specificIntrinsic) const { // 15.5.2.9(1): if dummy is not pure, actual need not be. // Ditto with elemental. Attrs actualAttrs{actual.attrs}; if (!attrs.test(Attr::Pure)) { actualAttrs.reset(Attr::Pure); } - if (!attrs.test(Attr::Elemental)) { + if (!attrs.test(Attr::Elemental) && specificIntrinsic) { actualAttrs.reset(Attr::Elemental); } Attrs differences{attrs ^ actualAttrs}; diff --git a/flang/lib/Evaluate/intrinsics.cpp b/flang/lib/Evaluate/intrinsics.cpp --- a/flang/lib/Evaluate/intrinsics.cpp +++ b/flang/lib/Evaluate/intrinsics.cpp @@ -2147,10 +2147,8 @@ if (CheckAndRearrangeArguments(arguments, context.messages(), keywords, 1)) { CHECK(arguments.size() == 3); if (const auto *expr{arguments[0].value().UnwrapExpr()}) { - if (expr->Rank() > 0) { - context.messages().Say(arguments[0]->sourceLocation(), - "CPTR= argument to C_F_POINTER() must be scalar"_err_en_US); - } + // General semantic checks will catch an actual argument that's not + // scalar. if (auto type{expr->GetType()}) { if (type->category() != TypeCategory::Derived || type->IsPolymorphic() || @@ -2231,6 +2229,8 @@ if (const auto &targetArg{call.arguments[1]}) { if (const auto *targetExpr{targetArg->UnwrapExpr()}) { std::optional pointerProc, targetProc; + const auto *targetProcDesignator{ + UnwrapExpr(*targetExpr)}; const Symbol *targetSymbol{GetLastSymbol(*targetExpr)}; bool isCall{false}; std::string targetName; @@ -2243,6 +2243,10 @@ targetName = targetProcRef->proc().GetName() + "()"; isCall = true; } + } else if (targetProcDesignator) { + targetProc = characteristics::Procedure::Characterize( + *targetProcDesignator, context); + targetName = targetProcDesignator->GetName(); } else if (targetSymbol) { // proc that's not a call if (IsProcedure(*targetSymbol)) { @@ -2259,9 +2263,14 @@ if (targetProc) { // procedure pointer and procedure target std::string whyNot; + const SpecificIntrinsic *specificIntrinsic{nullptr}; + if (targetProcDesignator) { + specificIntrinsic = + targetProcDesignator->GetSpecificIntrinsic(); + } if (std::optional msg{ - CheckProcCompatibility( - isCall, pointerProc, &*targetProc, whyNot)}) { + CheckProcCompatibility(isCall, pointerProc, + &*targetProc, specificIntrinsic, whyNot)}) { msg->set_severity(parser::Severity::Warning); AttachDeclaration( context.messages().Say(std::move(*msg), 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 @@ -946,7 +946,7 @@ std::optional CheckProcCompatibility(bool isCall, const std::optional &lhsProcedure, const characteristics::Procedure *rhsProcedure, - std::string &whyNotCompatible) { + const SpecificIntrinsic *specificIntrinsic, std::string &whyNotCompatible) { std::optional msg; if (!lhsProcedure) { msg = "In assignment to object %s, the target '%s' is a procedure" @@ -954,7 +954,8 @@ } 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 (lhsProcedure->IsCompatibleWith(*rhsProcedure, &whyNotCompatible)) { + } else if (lhsProcedure->IsCompatibleWith( + *rhsProcedure, &whyNotCompatible, specificIntrinsic)) { // OK } else if (isCall) { msg = "Procedure %s associated with result of reference to function '%s'" @@ -971,8 +972,8 @@ } else if (lhsProcedure->HasExplicitInterface() && !rhsProcedure->HasExplicitInterface()) { // Section 10.2.2.4, paragraph 3 prohibits associating a procedure pointer - // with an explicit interface with a procedure whose characteristics don't - // match. That's the case if the target procedure has an implicit + // that has an explicit interface with a procedure whose characteristics + // don't match. That's the case if the target procedure has an implicit // interface. But this case is allowed by several other compilers as long // as the explicit interface can be called via an implicit interface. if (!lhsProcedure->CanBeCalledViaImplicitInterface()) { @@ -983,7 +984,8 @@ } else if (!lhsProcedure->HasExplicitInterface() && rhsProcedure->HasExplicitInterface()) { // OK if the target can be called via an implicit interface - if (!rhsProcedure->CanBeCalledViaImplicitInterface()) { + if (!rhsProcedure->CanBeCalledViaImplicitInterface() && + !specificIntrinsic) { msg = "Procedure %s with implicit interface may not be associated " "with procedure designator '%s' with explicit interface that " "cannot be called via an implicit interface"_err_en_US; diff --git a/flang/lib/Semantics/check-call.cpp b/flang/lib/Semantics/check-call.cpp --- a/flang/lib/Semantics/check-call.cpp +++ b/flang/lib/Semantics/check-call.cpp @@ -192,20 +192,21 @@ if (isElemental) { } else if (dummy.type.attrs().test( characteristics::TypeAndShape::Attr::AssumedRank)) { - } else if (!dummy.type.attrs().test( - characteristics::TypeAndShape::Attr::AssumedShape) && + } else if (dummy.type.Rank() > 0 && + !dummy.type.attrs().test( + characteristics::TypeAndShape::Attr::AssumedShape) && !dummy.type.attrs().test( characteristics::TypeAndShape::Attr::DeferredShape) && (actualType.Rank() > 0 || IsArrayElement(actual))) { // Sequence association (15.5.2.11) applies -- rank need not match // if the actual argument is an array or array element designator, - // and the dummy is not assumed-shape or an INTENT(IN) pointer - // that's standing in for an assumed-shape dummy. + // and the dummy is an array, but not assumed-shape or an INTENT(IN) + // pointer that's standing in for an assumed-shape dummy. } else { - // Let CheckConformance accept scalars; storage association + // Let CheckConformance accept actual scalars; storage association // cases are checked here below. CheckConformance(messages, dummy.type.shape(), actualType.shape(), - evaluate::CheckConformanceFlags::EitherScalarExpandable, + evaluate::CheckConformanceFlags::RightScalarExpandable, "dummy argument", "actual argument"); } } else { diff --git a/flang/lib/Semantics/pointer-assignment.cpp b/flang/lib/Semantics/pointer-assignment.cpp --- a/flang/lib/Semantics/pointer-assignment.cpp +++ b/flang/lib/Semantics/pointer-assignment.cpp @@ -67,8 +67,9 @@ bool Check(const evaluate::ProcedureDesignator &); bool Check(const evaluate::ProcedureRef &); // Target is a procedure - bool Check( - parser::CharBlock rhsName, bool isCall, const Procedure * = nullptr); + bool Check(parser::CharBlock rhsName, bool isCall, + const Procedure * = nullptr, + const evaluate::SpecificIntrinsic *specific = nullptr); bool LhsOkForUnlimitedPoly() const; template parser::Message *Say(A &&...); @@ -255,11 +256,12 @@ } // Common handling for procedure pointer right-hand sides -bool PointerAssignmentChecker::Check( - parser::CharBlock rhsName, bool isCall, const Procedure *rhsProcedure) { +bool PointerAssignmentChecker::Check(parser::CharBlock rhsName, bool isCall, + const Procedure *rhsProcedure, + const evaluate::SpecificIntrinsic *specific) { std::string whyNot; if (std::optional msg{evaluate::CheckProcCompatibility( - isCall, procedure_, rhsProcedure, whyNot)}) { + isCall, procedure_, rhsProcedure, specific, whyNot)}) { Say(std::move(*msg), description_, rhsName, whyNot); return false; } @@ -268,24 +270,23 @@ bool PointerAssignmentChecker::Check(const evaluate::ProcedureDesignator &d) { if (auto chars{Procedure::Characterize(d, context_)}) { - return Check(d.GetName(), false, &*chars); + return Check(d.GetName(), false, &*chars, d.GetSpecificIntrinsic()); } else { return Check(d.GetName(), false); } } bool PointerAssignmentChecker::Check(const evaluate::ProcedureRef &ref) { - const Procedure *procedure{nullptr}; - auto chars{Procedure::Characterize(ref, context_)}; - if (chars) { - procedure = &*chars; + if (auto chars{Procedure::Characterize(ref, context_)}) { if (chars->functionResult) { if (const auto *proc{chars->functionResult->IsProcedurePointer()}) { - procedure = proc; + return Check(ref.proc().GetName(), true, proc); } } + return Check(ref.proc().GetName(), true, &*chars); + } else { + return Check(ref.proc().GetName(), true, nullptr); } - return Check(ref.proc().GetName(), true, procedure); } // The target can be unlimited polymorphic if the pointer is, or if it is 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 @@ -74,37 +74,42 @@ p_impure => f_impure1 ! OK, same characteristics p_impure => f_pure1 ! OK, target may be pure when pointer is not - p_impure => f_elemental1 ! OK, target may be pure elemental + !ERROR: Procedure pointer 'p_impure' associated with incompatible procedure designator 'f_elemental1': incompatible procedure attributes: Elemental + p_impure => f_elemental1 + !ERROR: Procedure pointer 'p_impure' associated with incompatible procedure designator 'f_impureelemental1': incompatible procedure attributes: Elemental p_impure => f_ImpureElemental1 ! OK, target may be elemental sp_impure => s_impure1 ! OK, same characteristics sp_impure => s_pure1 ! OK, target may be pure when pointer is not - sp_impure => s_elemental1 ! OK, target may be elemental when pointer is not + !ERROR: Procedure pointer 'sp_impure' associated with incompatible procedure designator 's_elemental1': incompatible procedure attributes: Elemental + sp_impure => s_elemental1 !ERROR: PURE procedure pointer 'p_pure' may not be associated with non-PURE procedure designator 'f_impure1' p_pure => f_impure1 p_pure => f_pure1 ! OK, same characteristics - p_pure => f_elemental1 ! OK, target may be pure + !ERROR: Procedure pointer 'p_pure' associated with incompatible procedure designator 'f_elemental1': incompatible procedure attributes: Elemental + p_pure => f_elemental1 !ERROR: PURE procedure pointer 'p_pure' may not be associated with non-PURE procedure designator 'f_impureelemental1' p_pure => f_impureElemental1 !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) p_pure => f_pure2 - !ERROR: Procedure pointer 'p_impure' associated with incompatible procedure designator 'f_elemental2': incompatible dummy argument #1: incompatible dummy data object attributes + !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': distinct numbers of dummy arguments + !ERROR: Procedure pointer 'sp_pure' associated with incompatible procedure designator 's_elemental2': incompatible procedure attributes: Elemental sp_pure => s_elemental2 !ERROR: Function pointer 'p_impure' may not be associated with subroutine designator 's_impure1' diff --git a/flang/test/Semantics/assign09.f90 b/flang/test/Semantics/assign09.f90 new file mode 100644 --- /dev/null +++ b/flang/test/Semantics/assign09.f90 @@ -0,0 +1,68 @@ +! RUN: %python %S/test_errors.py %s %flang_fc1 +! Procedure pointer assignments and argument association with intrinsic functions +program test + abstract interface + real function realToReal(a) + real, intent(in) :: a + end function + real function intToReal(n) + integer, intent(in) :: n + end function + end interface + procedure(), pointer :: noInterfaceProcPtr + procedure(realToReal), pointer :: realToRealProcPtr + procedure(intToReal), pointer :: intToRealProcPtr + intrinsic :: float ! restricted specific intrinsic functions + intrinsic :: sqrt ! unrestricted specific intrinsic functions + external :: noInterfaceExternal + interface + elemental real function userElemental(a) + real, intent(in) :: a + end function + end interface + + !ERROR: 'float' is not an unrestricted specific intrinsic procedure + noInterfaceProcPtr => float + !ERROR: 'float' is not an unrestricted specific intrinsic procedure + intToRealProcPtr => float + !ERROR: 'float' is not an unrestricted specific intrinsic procedure + call sub1(float) + !ERROR: 'float' is not an unrestricted specific intrinsic procedure + call sub2(float) + !ERROR: 'float' is not an unrestricted specific intrinsic procedure + call sub3(float) + + noInterfaceProcPtr => sqrt ! ok + realToRealProcPtr => sqrt ! ok + !ERROR: Procedure pointer 'inttorealprocptr' associated with incompatible procedure designator 'sqrt': incompatible dummy argument #1: incompatible dummy data object types: INTEGER(4) vs REAL(4) + intToRealProcPtr => sqrt + call sub1(sqrt) ! ok + call sub2(sqrt) ! ok + !ERROR: Actual procedure argument has interface incompatible with dummy argument 'p=': incompatible dummy argument #1: incompatible dummy data object types: INTEGER(4) vs REAL(4) + call sub3(sqrt) + + noInterfaceProcPtr => noInterfaceExternal ! ok + realToRealProcPtr => noInterfaceExternal ! ok + intToRealProcPtr => noInterfaceExternal !ok + call sub1(noInterfaceExternal) ! ok + !WARNING: Actual procedure argument has an implicit interface which is not known to be compatible with dummy argument 'p=' which has an explicit interface + call sub2(noInterfaceExternal) + !WARNING: Actual procedure argument has an implicit interface which is not known to be compatible with dummy argument 'p=' which has an explicit interface + call sub3(noInterfaceExternal) + + !ERROR: Procedure pointer 'nointerfaceprocptr' with implicit interface may not be associated with procedure designator 'userelemental' with explicit interface that cannot be called via an implicit interface + noInterfaceProcPtr => userElemental + !ERROR: Non-intrinsic ELEMENTAL procedure 'userelemental' may not be passed as an actual argument + call sub1(userElemental) + + contains + subroutine sub1(p) + external :: p + end subroutine + subroutine sub2(p) + procedure(realToReal) :: p + end subroutine + subroutine sub3(p) + procedure(intToReal) :: p + end subroutine +end 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 @@ -135,7 +135,7 @@ 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': incompatible dummy argument #1: incompatible dummy data object attributes + !ERROR: Procedure pointer 'intprocpointer1' associated with incompatible procedure designator 'elementalproc': incompatible procedure attributes: Elemental intProcPointer1 => elementalProc !WARNING: Procedure pointer 'intprocpointer1' associated with incompatible procedure designator 'elementalproc': incompatible dummy argument #1: incompatible dummy data object attributes lvar = associated(intProcPointer1, elementalProc) diff --git a/flang/test/Semantics/c_f_pointer.f90 b/flang/test/Semantics/c_f_pointer.f90 --- a/flang/test/Semantics/c_f_pointer.f90 +++ b/flang/test/Semantics/c_f_pointer.f90 @@ -19,7 +19,7 @@ call c_f_pointer(scalarC, fptr=arrayIntF, [1_8]) !ERROR: CPTR= argument to C_F_POINTER() must be a C_PTR call c_f_pointer(j, scalarIntF) - !ERROR: CPTR= argument to C_F_POINTER() must be scalar + !ERROR: Rank of dummy argument is 0, but actual argument has rank 1 call c_f_pointer(arrayC, scalarIntF) !ERROR: SHAPE= argument to C_F_POINTER() must appear when FPTR= is an array call c_f_pointer(scalarC, arrayIntF) diff --git a/flang/test/Semantics/call03.f90 b/flang/test/Semantics/call03.f90 --- a/flang/test/Semantics/call03.f90 +++ b/flang/test/Semantics/call03.f90 @@ -59,18 +59,30 @@ subroutine intentout(x) real, intent(out) :: x end subroutine + subroutine intentout_arr(x) + real, intent(out) :: x(:) + end subroutine subroutine intentinout(x) real, intent(in out) :: x end subroutine + subroutine intentinout_arr(x) + real, intent(in out) :: x(:) + end subroutine subroutine asynchronous(x) real, asynchronous :: x end subroutine + subroutine asynchronous_arr(x) + real, asynchronous :: x(:) + end subroutine subroutine asynchronousValue(x) real, asynchronous, value :: x end subroutine subroutine volatile(x) real, volatile :: x end subroutine + subroutine volatile_arr(x) + real, volatile :: x(:) + end subroutine subroutine pointer(x) real, pointer :: x(:) end subroutine @@ -91,7 +103,7 @@ end subroutine subroutine mono(x) - type(t), intent(in) :: x + type(t), intent(in) :: x(*) end subroutine subroutine test02(x) ! 15.5.2.4(2) class(t), intent(in) :: x(*) @@ -269,13 +281,13 @@ integer :: j(1) j(1) = 1 !ERROR: Actual argument associated with INTENT(OUT) dummy argument 'x=' must be definable - call intentout(a(j)) + call intentout_arr(a(j)) !ERROR: Actual argument associated with INTENT(IN OUT) dummy argument 'x=' must be definable - call intentinout(a(j)) + call intentinout_arr(a(j)) !ERROR: Actual argument associated with ASYNCHRONOUS dummy argument 'x=' must be definable - call asynchronous(a(j)) + call asynchronous_arr(a(j)) !ERROR: Actual argument associated with VOLATILE dummy argument 'x=' must be definable - call volatile(a(j)) + call volatile_arr(a(j)) end subroutine subroutine coarr(x) diff --git a/flang/test/Semantics/procinterface02.f90 b/flang/test/Semantics/procinterface02.f90 new file mode 100644 --- /dev/null +++ b/flang/test/Semantics/procinterface02.f90 @@ -0,0 +1,23 @@ +! RUN: %python %S/test_errors.py %s %flang_fc1 +subroutine foo(A, B, P) + interface + real elemental function foo_elemental(x) + real, intent(in) :: x + end function + pure real function foo_pure(x) + real, intent(in) :: x + end function + real function foo_nonelemental(x) + real, intent(in) :: x + end function + end interface + real :: A(:), B(:) + procedure(sqrt), pointer :: P + !ERROR: Rank of dummy argument is 0, but actual argument has rank 1 + A = P(B) + !ERROR: Procedure pointer 'p' associated with incompatible procedure designator 'foo_elemental': incompatible procedure attributes: Elemental + P => foo_elemental + P => foo_pure ! ok + !ERROR: PURE procedure pointer 'p' may not be associated with non-PURE procedure designator 'foo_nonelemental' + P => foo_nonelemental +end subroutine