[flang-commits] [flang] [flang] Add documentation, control, and portability warning for exten… (PR #114875)

[via flang-commits]

llvmbot wrote:


<!--LLVM PR SUMMARY COMMENT-->

@llvm/pr-subscribers-flang-semantics

Author: Peter Klausler (klausler)

<details>
<summary>Changes</summary>

…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 https://github.com/llvm/llvm-project/issues/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
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

``````````

</details>


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