[flang-commits] [flang] 463fb9f - [flang] Support INDEX as a procedure interface (#83073)
via flang-commits
flang-commits at lists.llvm.org
Fri Mar 1 16:59:39 PST 2024
Author: Peter Klausler
Date: 2024-03-01T16:59:36-08:00
New Revision: 463fb9f2140a4b37afb2f2a53cc766fac84203e3
URL: https://github.com/llvm/llvm-project/commit/463fb9f2140a4b37afb2f2a53cc766fac84203e3
DIFF: https://github.com/llvm/llvm-project/commit/463fb9f2140a4b37afb2f2a53cc766fac84203e3.diff
LOG: [flang] Support INDEX as a procedure interface (#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.
Added:
flang/test/Semantics/intrinsics03.f90
Modified:
flang/docs/Extensions.md
flang/lib/Evaluate/intrinsics.cpp
Removed:
################################################################################
diff --git a/flang/docs/Extensions.md b/flang/docs/Extensions.md
index 4bd93f6b6d0f2f..baecfd7c48fd06 100644
--- a/flang/docs/Extensions.md
+++ b/flang/docs/Extensions.md
@@ -692,6 +692,20 @@ end
essentially ignored unless there are some unmasked array entries and
*all* of them are NaNs.
+* When `INDEX` is used as an unrestricted specific intrinsic function
+ in the context of an actual procedure, as the explicit interface in
+ a `PROCEDURE` declaration statement, or as the target of a procedure
+ pointer assignment, its interface has exactly two dummy arguments
+ (`STRING=` and `SUBSTRING=`), and includes neither `BACK=` nor
+ `KIND=`.
+ This is how `INDEX` as an unrestricted specific intrinsic function was
+ documented in FORTRAN '77 and Fortran '90; later revisions of the
+ standard deleted the argument information from the section on
+ unrestricted specific intrinsic functions.
+ At least one other compiler (XLF) seems to expect that the interface for
+ `INDEX` include an optional `BACK=` argument, but it doesn't actually
+ work.
+
## De Facto Standard Features
* `EXTENDS_TYPE_OF()` returns `.TRUE.` if both of its arguments have the
diff --git a/flang/lib/Evaluate/intrinsics.cpp b/flang/lib/Evaluate/intrinsics.cpp
index 61bf0f2b48ad88..a8f2e5b445ed2b 100644
--- a/flang/lib/Evaluate/intrinsics.cpp
+++ b/flang/lib/Evaluate/intrinsics.cpp
@@ -1120,6 +1120,12 @@ static const SpecificIntrinsicInterface specificIntrinsicFunction[]{
{{"iiabs", {{"a", TypePattern{IntType, KindCode::exactKind, 2}}},
TypePattern{IntType, KindCode::exactKind, 2}},
"abs"},
+ // The definition of the unrestricted specific intrinsic function INDEX
+ // in F'77 and F'90 has only two arguments; later standards omit the
+ // argument information for all unrestricted specific intrinsic
+ // procedures. No compiler supports an implementation that allows
+ // INDEX with BACK= to work when associated as an actual procedure or
+ // procedure pointer target.
{{"index", {{"string", DefaultChar}, {"substring", DefaultChar}},
DefaultInt}},
{{"isign", {{"a", DefaultInt}, {"b", DefaultInt}}, DefaultInt}, "sign"},
@@ -2505,6 +2511,8 @@ class IntrinsicProcTable::Implementation {
std::multimap<std::string, const IntrinsicInterface *> subroutines_;
const semantics::Scope *builtinsScope_{nullptr};
std::map<std::string, std::string> aliases_;
+ semantics::ParamValue assumedLen_{
+ semantics::ParamValue::Assumed(common::TypeParamAttr::Len)};
};
bool IntrinsicProcTable::Implementation::IsIntrinsicFunction(
@@ -3241,6 +3249,10 @@ DynamicType IntrinsicProcTable::Implementation::GetSpecificType(
TypeCategory category{set.LeastElement().value()};
if (pattern.kindCode == KindCode::doublePrecision) {
return DynamicType{category, defaults_.doublePrecisionKind()};
+ } else if (category == TypeCategory::Character) {
+ // All character arguments to specific intrinsic functions are
+ // assumed-length.
+ return DynamicType{defaults_.GetDefaultKind(category), assumedLen_};
} else {
return DynamicType{category, defaults_.GetDefaultKind(category)};
}
diff --git a/flang/test/Semantics/intrinsics03.f90 b/flang/test/Semantics/intrinsics03.f90
new file mode 100644
index 00000000000000..03109bc300caf3
--- /dev/null
+++ b/flang/test/Semantics/intrinsics03.f90
@@ -0,0 +1,125 @@
+! 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)
+ character(*), intent(in) :: string, substring ! ok
+ end
+ pure integer function index2(x1, x2)
+ character(*), intent(in) :: x1, x2 ! ok
+ end
+ pure integer function index3(string, substring)
+ character, intent(in) :: string, substring ! not assumed length
+ end
+ pure integer function index4(string, substring, back)
+ character(*), intent(in) :: string, substring
+ logical, optional, intent(in) :: back ! not ok
+ 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': incompatible dummy argument #1: assumed-length character vs explicit-length character
+ 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': incompatible dummy argument #1: assumed-length character vs explicit-length character
+ 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': incompatible dummy argument #1: assumed-length character vs explicit-length character
+ 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': incompatible dummy argument #1: assumed-length character vs explicit-length character
+ p3 => index
+ !ERROR: Procedure pointer 'p3' associated with incompatible procedure designator 'index1': incompatible dummy argument #1: assumed-length character vs explicit-length character
+ p3 => index1
+ !ERROR: Procedure pointer 'p3' associated with incompatible procedure designator 'index2': incompatible dummy argument #1: assumed-length character vs explicit-length character
+ p3 => index2
+ p3 => index3 ! ok
+ !ERROR: Procedure pointer 'p3' associated with incompatible procedure designator 'index4': distinct numbers of dummy arguments
+ 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': distinct numbers of dummy arguments
+ 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=': incompatible dummy argument #1: assumed-length character vs explicit-length character
+ 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=': incompatible dummy argument #1: assumed-length character vs explicit-length character
+ 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=': incompatible dummy argument #1: assumed-length character vs explicit-length character
+ 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=': incompatible dummy argument #1: assumed-length character vs explicit-length character
+ call s3(index)
+ !ERROR: Actual procedure argument has interface incompatible with dummy argument 'ix=': incompatible dummy argument #1: assumed-length character vs explicit-length character
+ call s3(index1)
+ !ERROR: Actual procedure argument has interface incompatible with dummy argument 'ix=': incompatible dummy argument #1: assumed-length character vs explicit-length character
+ call s3(index2)
+ call s3(index3) ! ok
+ !ERROR: Actual procedure argument has interface incompatible with dummy argument 'ix=': distinct numbers of dummy arguments
+ 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=': distinct numbers of dummy arguments
+ call s4(index3)
+ call s4(index4) ! ok
+end
More information about the flang-commits
mailing list