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

[Peter Klausler via flang-commits]

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

>From 620d39cbc9ecfd23c0971290ee00b0645e46c515 Mon Sep 17 00:00:00 2001
From: Peter Klausler <pklausler at nvidia.com>
Date: Mon, 4 Nov 2024 13:41:17 -0800
Subject: [PATCH] [flang] Disable extension by default

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 https://github.com/llvm/llvm-project/issues/114080.
---
 flang/include/flang/Common/Fortran-features.h |  2 +-
 flang/lib/Common/Fortran-features.cpp         |  2 ++
 flang/lib/Semantics/check-call.cpp            | 31 +++++++++++++++++--
 flang/test/Semantics/call38.f90               | 22 +++++++++++++
 4 files changed, 53 insertions(+), 4 deletions(-)

diff --git a/flang/include/flang/Common/Fortran-features.h b/flang/include/flang/Common/Fortran-features.h
index 74edbe44fdbb1c..c6ab846cce2fc0 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, AssumedRankPassedToNonAssumedRank)
 
 // Portability and suspicious usage warnings
 ENUM_CLASS(UsageWarning, Portability, PointerToUndefinable,
diff --git a/flang/lib/Common/Fortran-features.cpp b/flang/lib/Common/Fortran-features.cpp
index fff796e42552a5..f47a4f17a6ba48 100644
--- a/flang/lib/Common/Fortran-features.cpp
+++ b/flang/lib/Common/Fortran-features.cpp
@@ -30,6 +30,8 @@ LanguageFeatureControl::LanguageFeatureControl() {
   disable_.set(LanguageFeature::LogicalAbbreviations);
   disable_.set(LanguageFeature::XOROperator);
   disable_.set(LanguageFeature::OldStyleParameter);
+  // Possibly an accidental "feature" of nvfortran.
+  disable_.set(LanguageFeature::AssumedRankPassedToNonAssumedRank);
   // These warnings are enabled by default, but only because they used
   // to be unconditional.  TODO: prune this list
   warnLanguage_.set(LanguageFeature::ExponentMatchingKindParam);
diff --git a/flang/lib/Semantics/check-call.cpp b/flang/lib/Semantics/check-call.cpp
index a161d2bdf9dbb8..597c280a6df8bc 100644
--- a/flang/lib/Semantics/check-call.cpp
+++ b/flang/lib/Semantics/check-call.cpp
@@ -135,6 +135,20 @@ 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 &&
+        !dummy.type.attrs().test(
+            characteristics::TypeAndShape::Attr::AssumedRank)) {
+      if (!context.languageFeatures().IsEnabled(
+              common::LanguageFeature::AssumedRankPassedToNonAssumedRank)) {
+        messages.Say(
+            "Assumed-rank character array may not be associated with a dummy argument that is not assumed-rank"_err_en_US);
+      } else {
+        context.Warn(common::LanguageFeature::AssumedRankPassedToNonAssumedRank,
+            messages.at(),
+            "Assumed-rank character array should not be associated with a dummy argument that is not assumed-rank"_port_en_US);
+      }
+    }
     if (dummy.type.LEN() && actualType.LEN()) {
       evaluate::FoldingContext &foldingContext{context.foldingContext()};
       auto dummyLength{
@@ -148,7 +162,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 +616,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::AssumedRankPassedToNonAssumedRank)) {
+            messages.Say(
+                "Assumed-rank array may not be associated with a dummy argument that is not assumed-rank"_err_en_US);
+          } else {
+            context.Warn(
+                common::LanguageFeature::AssumedRankPassedToNonAssumedRank,
+                messages.at(),
+                "Assumed-rank array should not be associated with a dummy argument that is not assumed-rank"_port_en_US);
+          }
+        } else if (actualRank == 0) {
           if (evaluate::IsArrayElement(actual)) {
             // Actual argument is a scalar array element
             evaluate::DesignatorFolder folder{
@@ -643,7 +668,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..34aae6b8b18357 100644
--- a/flang/test/Semantics/call38.f90
+++ b/flang/test/Semantics/call38.f90
@@ -522,3 +522,25 @@ subroutine test
     call scalar('a')
   end
 end
+
+subroutine bug114080(arg, contigArg)
+  character(*) :: arg(..)
+  character(*), contiguous :: contigArg(..)
+  interface
+   subroutine sub1(arg1) bind(c)
+     character(1) :: arg1(2,4)
+   end subroutine
+  end interface
+  !ERROR: Assumed-rank character array may not be associated with a dummy argument that is not assumed-rank
+  call sub1(arg)
+  !ERROR: Assumed-rank character array may not be associated with a dummy argument that is not assumed-rank
+  call sub1(contigArg)
+  !ERROR: Assumed-rank character array may not be associated with a dummy argument that is not assumed-rank
+  call sub2(arg)
+  !ERROR: Assumed-rank character array may not be associated with a dummy argument that is not assumed-rank
+  call sub2(contigArg)
+  contains
+    subroutine sub2(arg2)
+      character(*) :: arg2(10)
+    end subroutine sub2
+end subroutine