[flang] More actual argument warnings

Emit warnings when CHARACTER lengths or array sizes of actual
and dummy arguments mismatch in risky ways.

Differential Revision: https://reviews.llvm.org/D154370

flang/lib/Evaluate/characteristics.cpp

@@ -303,6 +303,32 @@ bool DummyDataObject::IsCompatibleWith(
     }
     return false;
   }
+  if (type.type().category() == TypeCategory::Character) {
+    if (actual.type.type().IsAssumedLengthCharacter() !=
+        type.type().IsAssumedLengthCharacter()) {
+      if (whyNot) {
+        *whyNot = "assumed-length character vs explicit-length character";
+      }
+      return false;
+    }
+    if (!type.type().IsAssumedLengthCharacter() && type.LEN() &&
+        actual.type.LEN()) {
+      auto len{ToInt64(*type.LEN())};
+      auto actualLen{ToInt64(*actual.type.LEN())};
+      if (len.has_value() != actualLen.has_value()) {
+        if (whyNot) {
+          *whyNot = "constant-length vs non-constant-length character dummy "
+                    "arguments";
+        }
+        return false;
+      } else if (len && *len != *actualLen) {
+        if (whyNot) {
+          *whyNot = "character dummy arguments with distinct lengths";
+        }
+        return false;
+      }
+    }
+  }
   if (attrs != actual.attrs) {
     if (whyNot) {
       *whyNot = "incompatible dummy data object attributes";

flang/lib/Semantics/check-call.cpp

@@ -196,7 +196,7 @@ static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy,
     characteristics::TypeAndShape &actualType, bool isElemental,
     SemanticsContext &context, evaluate::FoldingContext &foldingContext,
     const Scope *scope, const evaluate::SpecificIntrinsic *intrinsic,
-    bool allowActualArgumentConversions,
+    bool allowActualArgumentConversions, bool extentErrors,
     const characteristics::Procedure &procedure) {
 
   // Basic type & rank checking
@@ -418,6 +418,24 @@ static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy,
             dummyName);
       }
     }
+  } else if (actualRank > 0 && dummy.type.Rank() > 0 &&
+      actualType.type().category() != TypeCategory::Character) {
+    // Both arrays, dummy is not assumed-shape, not character
+    if (auto dummySize{evaluate::ToInt64(evaluate::Fold(foldingContext,
+            evaluate::GetSize(evaluate::Shape{dummy.type.shape()})))}) {
+      if (auto actualSize{evaluate::ToInt64(evaluate::Fold(foldingContext,
+              evaluate::GetSize(evaluate::Shape{actualType.shape()})))}) {
+        if (*actualSize < *dummySize) {
+          auto msg{
+              "Actual argument array is smaller (%jd element(s)) than %s array (%jd)"_warn_en_US};
+          if (extentErrors) {
+            msg.set_severity(parser::Severity::Error);
+          }
+          messages.Say(std::move(msg), static_cast<std::intmax_t>(*actualSize),
+              dummyName, static_cast<std::intmax_t>(*dummySize));
+        }
+      }
+    }
   }
   if (actualLastObject && actualLastObject->IsCoarray() &&
       IsAllocatable(*actualLastSymbol) && dummy.intent == common::Intent::Out &&
@@ -853,7 +871,7 @@ static void CheckExplicitInterfaceArg(evaluate::ActualArgument &arg,
     const characteristics::DummyArgument &dummy,
     const characteristics::Procedure &proc, SemanticsContext &context,
     const Scope *scope, const evaluate::SpecificIntrinsic *intrinsic,
-    bool allowActualArgumentConversions) {
+    bool allowActualArgumentConversions, bool extentErrors) {
   evaluate::FoldingContext &foldingContext{context.foldingContext()};
   auto &messages{foldingContext.messages()};
   std::string dummyName{"dummy argument"};
@@ -885,7 +903,7 @@ static void CheckExplicitInterfaceArg(evaluate::ActualArgument &arg,
                       object.type.Rank() == 0 && proc.IsElemental()};
                   CheckExplicitDataArg(object, dummyName, *expr, *type,
                       isElemental, context, foldingContext, scope, intrinsic,
-                      allowActualArgumentConversions, proc);
+                      allowActualArgumentConversions, extentErrors, proc);
                 } else if (object.type.type().IsTypelessIntrinsicArgument() &&
                     IsBOZLiteral(*expr)) {
                   // ok
@@ -1275,7 +1293,7 @@ static parser::Messages CheckExplicitInterface(
     const characteristics::Procedure &proc, evaluate::ActualArguments &actuals,
     SemanticsContext &context, const Scope *scope,
     const evaluate::SpecificIntrinsic *intrinsic,
-    bool allowActualArgumentConversions) {
+    bool allowActualArgumentConversions, bool extentErrors) {
   evaluate::FoldingContext &foldingContext{context.foldingContext()};
   parser::ContextualMessages &messages{foldingContext.messages()};
   parser::Messages buffer;
@@ -1289,7 +1307,7 @@ static parser::Messages CheckExplicitInterface(
     const auto &dummy{proc.dummyArguments.at(index++)};
     if (actual) {
       CheckExplicitInterfaceArg(*actual, dummy, proc, context, scope, intrinsic,
-          allowActualArgumentConversions);
+          allowActualArgumentConversions, extentErrors);
     } else if (!dummy.IsOptional()) {
       if (dummy.name.empty()) {
         messages.Say(
@@ -1318,7 +1336,7 @@ bool CheckInterfaceForGeneric(const characteristics::Procedure &proc,
     bool allowActualArgumentConversions) {
   return proc.HasExplicitInterface() &&
       !CheckExplicitInterface(proc, actuals, context, nullptr, nullptr,
-          allowActualArgumentConversions)
+          allowActualArgumentConversions, false /*extentErrors*/)
            .AnyFatalError();
 }
 
@@ -1399,7 +1417,7 @@ bool CheckArguments(const characteristics::Procedure &proc,
   }
   if (explicitInterface) {
     auto buffer{CheckExplicitInterface(
-        proc, actuals, context, &scope, intrinsic, true)};
+        proc, actuals, context, &scope, intrinsic, true, true)};
     if (!buffer.empty()) {
       if (treatingExternalAsImplicit) {
         if (auto *msg{messages.Say(

flang/test/Semantics/call37.f90

@@ -0,0 +1,72 @@
+! RUN: %python %S/test_errors.py %s %flang_fc1 -pedantic -Werror
+! Test warnings on mismatching interfaces involvingCHARACTER arguments
+subroutine constLen(s)
+  character(len = 1) s
+end
+subroutine assumedLen(s)
+  character(len = *) s
+end
+subroutine exprLen(s)
+  common n
+  character(len = n) s
+end
+
+module m0
+  interface ! these are all OK
+    subroutine constLen(s)
+      character(len=1) s
+    end
+    subroutine assumedLen(s)
+      character(len=*) s
+    end
+    subroutine exprLen(s)
+      common n
+      character(len=n) s
+    end
+  end interface
+end
+
+module m1
+  interface
+    !WARNING: The global subprogram 'constlen' is not compatible with its local procedure declaration (incompatible dummy argument #1: incompatible dummy data object types: CHARACTER(KIND=1,LEN=1_8) vs CHARACTER(KIND=1,LEN=2_8))
+    subroutine constLen(s)
+      character(len=2) s
+    end
+    !WARNING: The global subprogram 'assumedlen' is not compatible with its local procedure declaration (incompatible dummy argument #1: assumed-length character vs explicit-length character)
+    subroutine assumedLen(s)
+      character(len=2) s
+    end
+    !WARNING: The global subprogram 'exprlen' is not compatible with its local procedure declaration (incompatible dummy argument #1: constant-length vs non-constant-length character dummy arguments)
+    subroutine exprLen(s)
+      character(len=2) s
+    end
+  end interface
+end
+
+module m2
+  interface
+    !WARNING: The global subprogram 'constlen' is not compatible with its local procedure declaration (incompatible dummy argument #1: assumed-length character vs explicit-length character)
+    subroutine constLen(s)
+      character(len=*) s
+    end
+    !WARNING: The global subprogram 'exprlen' is not compatible with its local procedure declaration (incompatible dummy argument #1: assumed-length character vs explicit-length character)
+    subroutine exprLen(s)
+      character(len=*) s
+    end
+  end interface
+end
+
+module m3
+  interface
+    !WARNING: The global subprogram 'constlen' is not compatible with its local procedure declaration (incompatible dummy argument #1: constant-length vs non-constant-length character dummy arguments)
+    subroutine constLen(s)
+      common n
+      character(len=n) s
+    end
+    !WARNING: The global subprogram 'assumedlen' is not compatible with its local procedure declaration (incompatible dummy argument #1: assumed-length character vs explicit-length character)
+    subroutine assumedLen(s)
+      common n
+      character(len=n) s
+    end
+  end interface
+end

flang/test/Semantics/ignore_tkr01.f90

@@ -201,6 +201,7 @@ program test
   call t4(x)
   call t4(m)
   call t5(x)
+  !WARNING: Actual argument array is smaller (2 element(s)) than dummy argument 'm=' array (4)
   call t5(a)
 
   call t6(1)