[flang] Disable extension by default

[klausler]

f18 allows, as an extension, an assumed-rank array to be associated with a dummy argument that is not assumed-rank. This usage is non-conforming and supported by only one other compiler, perhaps unintentionally. Disable the extension by default, but also make it controllable so that we can turn it back on later if it's really needed. (If it turns out to not appear in applications after more exposure, I'll remove it entirely.)

Fixes #114080.

[llvmbot]

@llvm/pr-subscribers-flang-fir-hlfir

@llvm/pr-subscribers-flang-semantics

Author: Peter Klausler (klausler)

Changes

…sion

f18 allows, as an extension, an assumed-rank array to be storage sequence associated with a dummy argument. Document the extension, make it disableable, and add an optional portability warning.

Fixes #114080.

---

Full diff: https://github.com/llvm/llvm-project/pull/114875.diff

4 Files Affected:

• (modified) flang/docs/Extensions.md (+3)
• (modified) flang/include/flang/Common/Fortran-features.h (+1-1)
• (modified) flang/lib/Semantics/check-call.cpp (+26-3)
• (modified) flang/test/Semantics/call38.f90 (+17)

diff --git a/flang/docs/Extensions.md b/flang/docs/Extensions.md
index f85a3eb39ed191..9e0a6af74b4c6f 100644
--- a/flang/docs/Extensions.md
+++ b/flang/docs/Extensions.md
@@ -391,6 +391,9 @@ end
   has the SAVE attribute and was initialized.
 * `PRINT namelistname` is accepted and interpreted as
   `WRITE(*,NML=namelistname)`, a near-universal extension.
+* An assumed-rank array can be storage associated with a non-assumed-rank
+  dummy array if it otherwise meets the requirements for storage association
+  in F'2023 15.5.2.12.
 
 ### Extensions supported when enabled by options
 
diff --git a/flang/include/flang/Common/Fortran-features.h b/flang/include/flang/Common/Fortran-features.h
index 2b57c7ae50642c..7099a383d4e79c 100644
--- a/flang/include/flang/Common/Fortran-features.h
+++ b/flang/include/flang/Common/Fortran-features.h
@@ -53,7 +53,7 @@ ENUM_CLASS(LanguageFeature, BackslashEscapes, OldDebugLines,
     NonBindCInteroperability, CudaManaged, CudaUnified,
     PolymorphicActualAllocatableOrPointerToMonomorphicDummy, RelaxedPureDummy,
     UndefinableAsynchronousOrVolatileActual, AutomaticInMainProgram, PrintCptr,
-    SavedLocalInSpecExpr, PrintNamelist)
+    SavedLocalInSpecExpr, PrintNamelist, AssumedRankSequenceAssociation)
 
 // Portability and suspicious usage warnings
 ENUM_CLASS(UsageWarning, Portability, PointerToUndefinable,
diff --git a/flang/lib/Semantics/check-call.cpp b/flang/lib/Semantics/check-call.cpp
index fa2d59da10f827..ddd9d22b4ece9a 100644
--- a/flang/lib/Semantics/check-call.cpp
+++ b/flang/lib/Semantics/check-call.cpp
@@ -135,6 +135,18 @@ static void CheckCharacterActual(evaluate::Expr<evaluate::SomeType> &actual,
       dummy.type.type().kind() == actualType.type().kind() &&
       !dummy.attrs.test(
           characteristics::DummyDataObject::Attr::DeducedFromActual)) {
+    bool actualIsAssumedRank{evaluate::IsAssumedRank(actual)};
+    if (actualIsAssumedRank) {
+      if (!context.languageFeatures().IsEnabled(
+              common::LanguageFeature::AssumedRankSequenceAssociation)) {
+        messages.Say(
+            "Assumed-rank character array may not be storage sequence associated with a dummy argument"_err_en_US);
+      } else {
+        context.Warn(common::LanguageFeature::AssumedRankSequenceAssociation,
+            messages.at(),
+            "Assumed-rank character array should not be storage sequence associated with a dummy argument"_port_en_US);
+      }
+    }
     if (dummy.type.LEN() && actualType.LEN()) {
       evaluate::FoldingContext &foldingContext{context.foldingContext()};
       auto dummyLength{
@@ -148,7 +160,7 @@ static void CheckCharacterActual(evaluate::Expr<evaluate::SomeType> &actual,
           if (auto dummySize{evaluate::ToInt64(evaluate::Fold(
                   foldingContext, evaluate::GetSize(dummy.type.shape())))}) {
             auto dummyChars{*dummySize * *dummyLength};
-            if (actualType.Rank() == 0) {
+            if (actualType.Rank() == 0 && !actualIsAssumedRank) {
               evaluate::DesignatorFolder folder{
                   context.foldingContext(), /*getLastComponent=*/true};
               if (auto actualOffset{folder.FoldDesignator(actual)}) {
@@ -602,7 +614,18 @@ static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy,
             characteristics::DummyDataObject::Attr::DeducedFromActual)) {
       if (auto dummySize{evaluate::ToInt64(evaluate::Fold(
               foldingContext, evaluate::GetSize(dummy.type.shape())))}) {
-        if (actualRank == 0 && !actualIsAssumedRank) {
+        if (actualIsAssumedRank) {
+          if (!context.languageFeatures().IsEnabled(
+                  common::LanguageFeature::AssumedRankSequenceAssociation)) {
+            messages.Say(
+                "Assumed-rank array may not be storage sequence associated with a dummy argument"_err_en_US);
+          } else {
+            context.Warn(
+                common::LanguageFeature::AssumedRankSequenceAssociation,
+                messages.at(),
+                "Assumed-rank array should not be storage sequence associated with a dummy argument"_port_en_US);
+          }
+        } else if (actualRank == 0) {
           if (evaluate::IsArrayElement(actual)) {
             // Actual argument is a scalar array element
             evaluate::DesignatorFolder folder{
@@ -643,7 +666,7 @@ static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy,
               }
             }
           }
-        } else { // actualRank > 0 || actualIsAssumedRank
+        } else {
           if (auto actualSize{evaluate::ToInt64(evaluate::Fold(
                   foldingContext, evaluate::GetSize(actualType.shape())))};
               actualSize && *actualSize < *dummySize) {
diff --git a/flang/test/Semantics/call38.f90 b/flang/test/Semantics/call38.f90
index 0e7ebcdfe9df53..90e38f427c9ac8 100644
--- a/flang/test/Semantics/call38.f90
+++ b/flang/test/Semantics/call38.f90
@@ -522,3 +522,20 @@ subroutine test
     call scalar('a')
   end
 end
+
+subroutine bug114080(arg)
+  character(*) :: arg(..)
+  interface
+   subroutine sub1(arg1) bind(c)
+     character(1) :: arg1(2,4)
+   end subroutine
+  end interface
+  !WARNING: Assumed-rank character array should not be storage sequence associated with a dummy argument
+  call sub1(arg)
+  !WARNING: Assumed-rank character array should not be storage sequence associated with a dummy argument
+  call sub2(arg)
+  contains
+    subroutine sub2(arg2)
+      character(*) :: arg2(10)
+    end subroutine sub2
+end subroutine

[DanielCChen]

LGTM.
Thanks for the fix.

[klausler]

Thoroughly reworked; please take another look.

[DanielCChen]

Thanks for the update. The changes LGTM.