[flang-commits] [flang] 95f4ca7 - [flang] Allow restricted specific intrinsic functions as implicitly-interfaced procedure pointer targets
Peter Klausler via flang-commits
flang-commits at lists.llvm.org
Mon Jul 25 12:20:18 PDT 2022
Author: Peter Klausler
Date: 2022-07-25T12:19:49-07:00
New Revision: 95f4ca7f5db623bacc2e34548d39fe5b28d47bad
URL: https://github.com/llvm/llvm-project/commit/95f4ca7f5db623bacc2e34548d39fe5b28d47bad
DIFF: https://github.com/llvm/llvm-project/commit/95f4ca7f5db623bacc2e34548d39fe5b28d47bad.diff
LOG: [flang] Allow restricted specific intrinsic functions as implicitly-interfaced procedure pointer targets
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
Added:
flang/test/Semantics/assign09.f90
flang/test/Semantics/procinterface02.f90
Modified:
flang/include/flang/Evaluate/characteristics.h
flang/include/flang/Evaluate/tools.h
flang/lib/Evaluate/characteristics.cpp
flang/lib/Evaluate/intrinsics.cpp
flang/lib/Evaluate/tools.cpp
flang/lib/Semantics/check-call.cpp
flang/lib/Semantics/pointer-assignment.cpp
flang/test/Semantics/assign03.f90
flang/test/Semantics/associated.f90
flang/test/Semantics/c_f_pointer.f90
flang/test/Semantics/call03.f90
Removed:
################################################################################
diff --git a/flang/include/flang/Evaluate/characteristics.h b/flang/include/flang/Evaluate/characteristics.h
index 0b8f7c2cecbd5..e6a394ce66a21 100644
--- a/flang/include/flang/Evaluate/characteristics.h
+++ b/flang/include/flang/Evaluate/characteristics.h
@@ -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;
diff --git a/flang/include/flang/Evaluate/tools.h b/flang/include/flang/Evaluate/tools.h
index 93dd98c273b4c..fe8645b5b2ab9 100644
--- a/flang/include/flang/Evaluate/tools.h
+++ b/flang/include/flang/Evaluate/tools.h
@@ -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 {
diff --git a/flang/lib/Evaluate/characteristics.cpp b/flang/lib/Evaluate/characteristics.cpp
index 3443866a31e86..89d794f2c0819 100644
--- 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 <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
diff erences{attrs ^ actualAttrs};
diff --git a/flang/lib/Evaluate/intrinsics.cpp b/flang/lib/Evaluate/intrinsics.cpp
index 8638b1dc6d1f3..51690b5327f9d 100644
--- a/flang/lib/Evaluate/intrinsics.cpp
+++ b/flang/lib/Evaluate/intrinsics.cpp
@@ -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),
diff --git a/flang/lib/Evaluate/tools.cpp b/flang/lib/Evaluate/tools.cpp
index 258795118c0fd..84417cd18418f 100644
--- a/flang/lib/Evaluate/tools.cpp
+++ b/flang/lib/Evaluate/tools.cpp
@@ -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;
diff --git a/flang/lib/Semantics/check-call.cpp b/flang/lib/Semantics/check-call.cpp
index 1667ac3dd792a..77db690518435 100644
--- a/flang/lib/Semantics/check-call.cpp
+++ b/flang/lib/Semantics/check-call.cpp
@@ -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(
- 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
index cfb5159d92ebf..71b7387495dcb 100644
--- a/flang/lib/Semantics/pointer-assignment.cpp
+++ b/flang/lib/Semantics/pointer-assignment.cpp
@@ -67,8 +67,9 @@ class PointerAssignmentChecker {
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
diff --git a/flang/test/Semantics/assign03.f90 b/flang/test/Semantics/assign03.f90
index 58ae7f193483a..46de668a706ac 100644
--- a/flang/test/Semantics/assign03.f90
+++ b/flang/test/Semantics/assign03.f90
@@ -74,37 +74,42 @@ subroutine s5
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
index 0000000000000..ab581eee04515
--- /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
index 6a4d1af7316b6..e9254a04ba32c 100644
--- a/flang/test/Semantics/associated.f90
+++ b/flang/test/Semantics/associated.f90
@@ -135,7 +135,7 @@ subroutine test()
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
index 87975146f5138..2d780334e2e0b 100644
--- a/flang/test/Semantics/c_f_pointer.f90
+++ b/flang/test/Semantics/c_f_pointer.f90
@@ -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)
diff --git a/flang/test/Semantics/call03.f90 b/flang/test/Semantics/call03.f90
index 51b51b86f52f8..7627608de36b3 100644
--- a/flang/test/Semantics/call03.f90
+++ b/flang/test/Semantics/call03.f90
@@ -59,18 +59,30 @@ subroutine contiguous(x)
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 @@ subroutine test01(x) ! 15.5.2.4(2)
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 @@ subroutine test12 ! 15.5.2.4(21)
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
index 0000000000000..3f73e2e75f8db
--- /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
More information about the flang-commits
mailing list