[flang-commits] [flang] [flang] Support INDEX as a procedure interface (PR #83073)
Peter Klausler via flang-commits
flang-commits at lists.llvm.org
Mon Feb 26 14:18:59 PST 2024
https://github.com/klausler created https://github.com/llvm/llvm-project/pull/83073
The specific intrinsic function INDEX should work as a PROCEDURE interface in the declaration of a procedure pointer or dummy procedure, and it should be compatible with a user-defined interface.
Fixes https://github.com/llvm/llvm-project/issues/82397.
>From 293bfaf8cffaf11206caeea7f2603608746fb8b4 Mon Sep 17 00:00:00 2001
From: Peter Klausler <pklausler at nvidia.com>
Date: Mon, 26 Feb 2024 14:15:39 -0800
Subject: [PATCH] [flang] Support INDEX as a procedure interface
The specific intrinsic function INDEX should work as a PROCEDURE
interface in the declaration of a procedure pointer or dummy procedure,
and it should be compatible with a user-defined interface.
Fixes https://github.com/llvm/llvm-project/issues/82397.
---
flang/lib/Evaluate/characteristics.cpp | 14 ++-
flang/lib/Evaluate/intrinsics.cpp | 9 +-
flang/test/Semantics/intrinsics03.f90 | 126 +++++++++++++++++++++++++
3 files changed, 144 insertions(+), 5 deletions(-)
create mode 100644 flang/test/Semantics/intrinsics03.f90
diff --git a/flang/lib/Evaluate/characteristics.cpp b/flang/lib/Evaluate/characteristics.cpp
index 80b0f346c32d38..5aa2a429ead1e1 100644
--- a/flang/lib/Evaluate/characteristics.cpp
+++ b/flang/lib/Evaluate/characteristics.cpp
@@ -311,8 +311,9 @@ bool DummyDataObject::IsCompatibleWith(const DummyDataObject &actual,
}
if (type.type().category() == TypeCategory::Character &&
!deducedAssumedLength) {
- if (actual.type.type().IsAssumedLengthCharacter() !=
- type.type().IsAssumedLengthCharacter()) {
+ if (!actual.attrs.test(Attr::DeducedFromActual) &&
+ actual.type.type().IsAssumedLengthCharacter() !=
+ type.type().IsAssumedLengthCharacter()) {
if (whyNot) {
*whyNot = "assumed-length character vs explicit-length character";
}
@@ -336,13 +337,18 @@ bool DummyDataObject::IsCompatibleWith(const DummyDataObject &actual,
}
}
}
- if (!IdenticalSignificantAttrs(attrs, actual.attrs) ||
- type.attrs() != actual.type.attrs()) {
+ if (!IdenticalSignificantAttrs(attrs, actual.attrs)) {
if (whyNot) {
*whyNot = "incompatible dummy data object attributes";
}
return false;
}
+ if (type.attrs() != actual.type.attrs()) {
+ if (whyNot) {
+ *whyNot = "incompatible dummy data object type attributes";
+ }
+ return false;
+ }
if (intent != actual.intent) {
if (whyNot) {
*whyNot = "incompatible dummy data object intents";
diff --git a/flang/lib/Evaluate/intrinsics.cpp b/flang/lib/Evaluate/intrinsics.cpp
index 61bf0f2b48ad88..b63c6ef1206728 100644
--- a/flang/lib/Evaluate/intrinsics.cpp
+++ b/flang/lib/Evaluate/intrinsics.cpp
@@ -1120,7 +1120,9 @@ static const SpecificIntrinsicInterface specificIntrinsicFunction[]{
{{"iiabs", {{"a", TypePattern{IntType, KindCode::exactKind, 2}}},
TypePattern{IntType, KindCode::exactKind, 2}},
"abs"},
- {{"index", {{"string", DefaultChar}, {"substring", DefaultChar}},
+ {{"index",
+ {{"string", DefaultChar}, {"substring", DefaultChar},
+ {"back", AnyLogical, Rank::elemental, Optionality::optional}},
DefaultInt}},
{{"isign", {{"a", DefaultInt}, {"b", DefaultInt}}, DefaultInt}, "sign"},
{{"jiabs", {{"a", TypePattern{IntType, KindCode::exactKind, 4}}},
@@ -3220,6 +3222,11 @@ IntrinsicProcTable::Implementation::IsSpecificIntrinsicFunction(
characteristics::DummyDataObject dummy{
GetSpecificType(specific.dummy[j].typePattern)};
dummy.intent = specific.dummy[j].intent;
+ dummy.attrs.set(
+ characteristics::DummyDataObject::Attr::DeducedFromActual);
+ if (specific.dummy[j].optionality == Optionality::optional) {
+ dummy.attrs.set(characteristics::DummyDataObject::Attr::Optional);
+ }
args.emplace_back(
std::string{specific.dummy[j].keyword}, std::move(dummy));
}
diff --git a/flang/test/Semantics/intrinsics03.f90 b/flang/test/Semantics/intrinsics03.f90
new file mode 100644
index 00000000000000..d6306a3b90a28f
--- /dev/null
+++ b/flang/test/Semantics/intrinsics03.f90
@@ -0,0 +1,126 @@
+! RUN: %python %S/test_errors.py %s %flang_fc1
+! Ensure that INDEX is a usable specific intrinsic procedure
+
+program test
+ interface
+ pure integer function index1(string, substring, back)
+ character(*), intent(in) :: string, substring
+ logical, optional, intent(in) :: back
+ end
+ pure integer function index2(x1, x2, x3)
+ character(*), intent(in) :: x1, x2
+ logical, optional, intent(in) :: x3
+ end
+ pure integer function index3(string, substring)
+ character(*), intent(in) :: string, substring
+ end
+ pure integer function index4(string, substring)
+ character, intent(in) :: string, substring
+ end
+ subroutine s0(ix)
+ procedure(index) :: ix
+ end
+ subroutine s1(ix)
+ import index1
+ procedure(index1) :: ix
+ end
+ subroutine s2(ix)
+ import index2
+ procedure(index2) :: ix
+ end
+ subroutine s3(ix)
+ import index3
+ procedure(index3) :: ix
+ end
+ subroutine s4(ix)
+ import index4
+ procedure(index4) :: ix
+ end
+ end interface
+
+ procedure(index), pointer :: p0
+ procedure(index1), pointer :: p1
+ procedure(index2), pointer :: p2
+ procedure(index3), pointer :: p3
+ procedure(index4), pointer :: p4
+
+ p0 => index ! ok
+ p0 => index1 ! ok
+ p0 => index2 ! ok
+ !ERROR: Procedure pointer 'p0' associated with incompatible procedure designator 'index3': distinct numbers of dummy arguments
+ p0 => index3
+ !ERROR: Procedure pointer 'p0' associated with incompatible procedure designator 'index4': distinct numbers of dummy arguments
+ p0 => index4
+ p1 => index ! ok
+ p1 => index1 ! ok
+ p1 => index2 ! ok
+ !ERROR: Procedure pointer 'p1' associated with incompatible procedure designator 'index3': distinct numbers of dummy arguments
+ p1 => index3
+ !ERROR: Procedure pointer 'p1' associated with incompatible procedure designator 'index4': distinct numbers of dummy arguments
+ p1 => index4
+ p2 => index ! ok
+ p2 => index1 ! ok
+ p2 => index2 ! ok
+ !ERROR: Procedure pointer 'p2' associated with incompatible procedure designator 'index3': distinct numbers of dummy arguments
+ p2 => index3
+ !ERROR: Procedure pointer 'p2' associated with incompatible procedure designator 'index4': distinct numbers of dummy arguments
+ p2 => index4
+ !ERROR: Procedure pointer 'p3' associated with incompatible procedure designator 'index': distinct numbers of dummy arguments
+ p3 => index
+ !ERROR: Procedure pointer 'p3' associated with incompatible procedure designator 'index1': distinct numbers of dummy arguments
+ p3 => index1
+ !ERROR: Procedure pointer 'p3' associated with incompatible procedure designator 'index2': distinct numbers of dummy arguments
+ p3 => index2
+ p3 => index3 ! ok
+ !ERROR: Procedure pointer 'p3' associated with incompatible procedure designator 'index4': incompatible dummy argument #1: assumed-length character vs explicit-length character
+ p3 => index4
+ !ERROR: Procedure pointer 'p4' associated with incompatible procedure designator 'index': distinct numbers of dummy arguments
+ p4 => index
+ !ERROR: Procedure pointer 'p4' associated with incompatible procedure designator 'index1': distinct numbers of dummy arguments
+ p4 => index1
+ !ERROR: Procedure pointer 'p4' associated with incompatible procedure designator 'index2': distinct numbers of dummy arguments
+ p4 => index2
+ !ERROR: Procedure pointer 'p4' associated with incompatible procedure designator 'index3': incompatible dummy argument #1: assumed-length character vs explicit-length character
+ p4 => index3
+ p4 => index4 ! ok
+
+ call s0(index) ! ok
+ call s0(index1) ! ok
+ call s0(index2)
+ !ERROR: Actual procedure argument has interface incompatible with dummy argument 'ix=': distinct numbers of dummy arguments
+ call s0(index3)
+ !ERROR: Actual procedure argument has interface incompatible with dummy argument 'ix=': distinct numbers of dummy arguments
+ call s0(index4)
+ call s1(index) ! ok
+ call s1(index1) ! ok
+ call s1(index2) ! ok
+ !ERROR: Actual procedure argument has interface incompatible with dummy argument 'ix=': distinct numbers of dummy arguments
+ call s1(index3)
+ !ERROR: Actual procedure argument has interface incompatible with dummy argument 'ix=': distinct numbers of dummy arguments
+ call s1(index4)
+ call s2(index) ! ok
+ call s2(index1) ! ok
+ call s2(index2) ! ok
+ !ERROR: Actual procedure argument has interface incompatible with dummy argument 'ix=': distinct numbers of dummy arguments
+ call s2(index3)
+ !ERROR: Actual procedure argument has interface incompatible with dummy argument 'ix=': distinct numbers of dummy arguments
+ call s2(index4)
+ !ERROR: Actual procedure argument has interface incompatible with dummy argument 'ix=': distinct numbers of dummy arguments
+ call s3(index)
+ !ERROR: Actual procedure argument has interface incompatible with dummy argument 'ix=': distinct numbers of dummy arguments
+ call s3(index1)
+ !ERROR: Actual procedure argument has interface incompatible with dummy argument 'ix=': distinct numbers of dummy arguments
+ call s3(index2)
+ call s3(index3) ! ok
+ !ERROR: Actual procedure argument has interface incompatible with dummy argument 'ix=': incompatible dummy argument #1: assumed-length character vs explicit-length character
+ call s3(index4)
+ !ERROR: Actual procedure argument has interface incompatible with dummy argument 'ix=': distinct numbers of dummy arguments
+ call s4(index)
+ !ERROR: Actual procedure argument has interface incompatible with dummy argument 'ix=': distinct numbers of dummy arguments
+ call s4(index1)
+ !ERROR: Actual procedure argument has interface incompatible with dummy argument 'ix=': distinct numbers of dummy arguments
+ call s4(index2)
+ !ERROR: Actual procedure argument has interface incompatible with dummy argument 'ix=': incompatible dummy argument #1: assumed-length character vs explicit-length character
+ call s4(index3)
+ call s4(index4) ! ok
+end
More information about the flang-commits
mailing list