[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.

3 files changed, 151 insertions, 0 deletions

diff --git a/flang/docs/Extensions.md b/flang/docs/Extensions.md
index 4bd93f6b6d0f..baecfd7c48fd 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 61bf0f2b48ad..a8f2e5b445ed 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 @@ private:
   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 000000000000..03109bc300ca
--- /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