[flang] Support INDEX as a procedure interface #83073
Merged
Conversation
This file contains hidden or bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
llvmbot
added
flang
|
@llvm/pr-subscribers-flang-semantics Author: Peter Klausler (klausler) ChangesThe 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 #82397. Full diff: https://github.com/llvm/llvm-project/pull/83073.diff 3 Files Affected:
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
|
psteinfeld
approved these changes
Feb 27, 2024
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 with two arguments (no BACK=). Addresses llvm#82397.
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment
Add this suggestion to a batch that can be applied as a single commit.
This suggestion is invalid because no changes were made to the code.
Suggestions cannot be applied while the pull request is closed.
Suggestions cannot be applied while viewing a subset of changes.
Only one suggestion per line can be applied in a batch.
Add this suggestion to a batch that can be applied as a single commit.
Applying suggestions on deleted lines is not supported.
You must change the existing code in this line in order to create a valid suggestion.
Outdated suggestions cannot be applied.
This suggestion has been applied or marked resolved.
Suggestions cannot be applied from pending reviews.
Suggestions cannot be applied on multi-line comments.
Suggestions cannot be applied while the pull request is queued to merge.
Suggestion cannot be applied right now. Please check back later.
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 #82397.