squiid/llvm
1
0
Fork 0
Code Issues Pull requests Activity

[flang] Allow restricted specific intrinsic functions as implicitly-interfaced procedure pointer targets

Browse source 
The predicate "CanBeCalledViaImplicitInterface()" was returning false for
restricted specific intrinsic functions (e.g., SIN) because their procedure
characteristics have the elemental attribute; this leads to a bogus semantic
error when one attempts to use them as proc-targets in procedure pointer
assignment statements when the left-hand side of the assignment is a procedure
pointer with an implicit interface.  However, these restricted specific intrinsic
functions have always been allowed as special cases for such usage -- it is
as if they are elemental when it is necessary for them to be so, but not
when it's a problem.

Differential Revision: https://reviews.llvm.org/D130386
This commit is contained in:
Peter Klausler 2022-07-22 11:48:07 -07:00
parent ae1d5f4d9d
commit 95f4ca7f5d
13 changed files with 179 additions and 49 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

3
flang/include/flang/Evaluate/characteristics.h
View file

@ -333,7 +333,8 @@ struct Procedure {
int FindPassIndex(std::optional<parser::CharBlock>) const;
bool CanBeCalledViaImplicitInterface() const;
bool CanOverride(const Procedure &, std::optional<int> 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;

2
flang/include/flang/Evaluate/tools.h
View file

@ -1026,7 +1026,7 @@ template <typename T> bool IsExpandableScalar(const Expr<T> &expr) {
std::optional<parser::MessageFixedText> CheckProcCompatibility(bool isCall,
const std::optional<characteristics::Procedure> &lhsProcedure,
const characteristics::Procedure *rhsProcedure,
std::string &whyNotCompatible);
const SpecificIntrinsic *specificIntrinsic, std::string &whyNotCompatible);
// Scalar constant expansion
class ScalarConstantExpander {

20
flang/lib/Evaluate/characteristics.cpp
View file

@ -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 <initializer_list>
@ -440,9 +441,11 @@ static std::optional<Procedure> CharacterizeProcedure(
return std::nullopt;
}
seenProcs.insert(symbol);
if (IsElementalProcedure(symbol)) {
result.attrs.set(Procedure::Attr::Elemental);
}
CopyAttrs<Procedure, Procedure::Attr>(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 @@ static std::optional<Procedure> CharacterizeProcedure(
}
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 @@ bool Procedure::operator==(const Procedure &that) const {
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};

21
flang/lib/Evaluate/intrinsics.cpp
View file

@ -2147,10 +2147,8 @@ IntrinsicProcTable::Implementation::HandleC_F_Pointer(
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 @@ static bool CheckAssociated(SpecificCall &call, FoldingContext &context) {
if (const auto &targetArg{call.arguments[1]}) {
if (const auto *targetExpr{targetArg->UnwrapExpr()}) {
std::optional<characteristics::Procedure> pointerProc, targetProc;
const auto *targetProcDesignator{
UnwrapExpr<ProcedureDesignator>(*targetExpr)};
const Symbol *targetSymbol{GetLastSymbol(*targetExpr)};
bool isCall{false};
std::string targetName;
@ -2243,6 +2243,10 @@ static bool CheckAssociated(SpecificCall &call, FoldingContext &context) {
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 @@ static bool CheckAssociated(SpecificCall &call, FoldingContext &context) {
if (targetProc) {
// procedure pointer and procedure target
std::string whyNot;
const SpecificIntrinsic *specificIntrinsic{nullptr};
if (targetProcDesignator) {
specificIntrinsic =
targetProcDesignator->GetSpecificIntrinsic();
}
if (std::optional<parser::MessageFixedText> 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),

12
flang/lib/Evaluate/tools.cpp
View file

@ -946,7 +946,7 @@ std::optional<std::string> FindImpureCall(
std::optional<parser::MessageFixedText> CheckProcCompatibility(bool isCall,
const std::optional<characteristics::Procedure> &lhsProcedure,
const characteristics::Procedure *rhsProcedure,
std::string &whyNotCompatible) {
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"
@ -954,7 +954,8 @@ std::optional<parser::MessageFixedText> 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 (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 @@ std::optional<parser::MessageFixedText> CheckProcCompatibility(bool isCall,
} 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 @@ std::optional<parser::MessageFixedText> CheckProcCompatibility(bool isCall,
} 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;

11
flang/lib/Semantics/check-call.cpp
View file

@ -192,20 +192,21 @@ static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy,
if (isElemental) {
} else if (dummy.type.attrs().test(
characteristics::TypeAndShape::Attr::AssumedRank)) {
} else if (!dummy.type.attrs().test(
} 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 {

25
flang/lib/Semantics/pointer-assignment.cpp
View file

@ -67,8 +67,9 @@ private:
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 <typename... A> parser::Message *Say(A &&...);
@ -255,11 +256,12 @@ bool PointerAssignmentChecker::Check(const evaluate::Designator<T> &d) {
}
// 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<MessageFixedText> 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(
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

15
flang/test/Semantics/assign03.f90
View file

@ -74,37 +74,42 @@ contains
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'

68
flang/test/Semantics/assign09.f90 Normal file
View file

@ -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

2
flang/test/Semantics/associated.f90
View file

@ -135,7 +135,7 @@ subroutine assoc()
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)

2
flang/test/Semantics/c_f_pointer.f90
View file

@ -19,7 +19,7 @@ program test
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)

22
flang/test/Semantics/call03.f90
View file

@ -59,18 +59,30 @@ module m01
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 @@ module m01
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 @@ module m01
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)

23
flang/test/Semantics/procinterface02.f90 Normal file
View file

@ -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