[flang] More actual argument warnings

[klausler]

Summary

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

[PeteSteinfeld]

All builds and tests correctly and looks good.

flang/lib/Evaluate/characteristics.cpp

bool DummyDataObject::IsCompatibleWith(
   }
   if (!type.type().IsTkLenCompatibleWith(actual.type.type())) {
     if (whyNot) {
       *whyNot = "incompatible dummy data object types: "s +
           type.type().AsFortran() + " vs " + actual.type.type().AsFortran();
     }
     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";
     }
     return false;
   }
   if (intent != actual.intent) {
     if (whyNot) {

flang/lib/Semantics/check-call.cpp

static bool DefersSameTypeParameters(
   return true;
 }
 
 static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy,
     const std::string &dummyName, evaluate::Expr<evaluate::SomeType> &actual,
     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
   parser::ContextualMessages &messages{foldingContext.messages()};
   CheckCharacterActual(actual, dummy, actualType, context, messages);
   bool dummyIsAllocatable{
       dummy.attrs.test(characteristics::DummyDataObject::Attr::Allocatable)};
   bool dummyIsPointer{
if (!actualIsCKindCharacter) {
             dummyName);
       }
       if (actualLastSymbol && IsAssumedShape(*actualLastSymbol)) {
         messages.Say(
             "Element of assumed-shape array may not be associated with a %s array"_err_en_US,
             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 &&
       !(intrinsic &&
           evaluate::AcceptsIntentOutAllocatableCoarray(
               intrinsic->name))) { // C846
     messages.Say(
         "ALLOCATABLE coarray '%s' may not be associated with INTENT(OUT) %s"_err_en_US,
if (auto *expr{arg.UnwrapExpr()}) {
     }
   }
 }
 
 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"};
   if (!dummy.name.empty()) {
     dummyName += " '"s + parser::ToLowerCaseLetters(dummy.name) + "='";
   }
   auto restorer{
       messages.SetLocation(arg.sourceLocation().value_or(messages.at()))};
common::visit(
               if (auto *expr{arg.UnwrapExpr()}) {
                 if (auto type{characteristics::TypeAndShape::Characterize(
                         *expr, foldingContext)}) {
                   arg.set_dummyIntent(object.intent);
                   bool isElemental{
                       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
                 } else if (object.type.type().IsTypelessIntrinsicArgument() &&
                     evaluate::IsNullObjectPointer(*expr)) {
                   // ok, ASSOCIATED(NULL())
                 } else if ((object.attrs.test(characteristics::DummyDataObject::
                                     Attr::Pointer) ||
if (intrinsic.name == "associated") {
     CheckTransfer(arguments, context, scope);
   }
 }
 
 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;
   auto restorer{messages.SetMessages(buffer)};
   RearrangeArguments(proc, actuals, messages);
   if (!buffer.empty()) {
     return buffer;
   }
   int index{0};
   for (auto &actual : actuals) {
     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(
             "Dummy argument #%d is not OPTIONAL and is not associated with "
             "an actual argument in this procedure reference"_err_en_US,
             index);
       } else {
         messages.Say("Dummy argument '%s=' (#%d) is not OPTIONAL and is not "
static parser::Messages CheckExplicitInterface(
   return buffer;
 }
 
 bool CheckInterfaceForGeneric(const characteristics::Procedure &proc,
     evaluate::ActualArguments &actuals, SemanticsContext &context,
     bool allowActualArgumentConversions) {
   return proc.HasExplicitInterface() &&
       !CheckExplicitInterface(proc, actuals, context, nullptr, nullptr,
-          allowActualArgumentConversions)
+          allowActualArgumentConversions, false /*extentErrors*/)
            .AnyFatalError();
 }
 
 bool CheckArgumentIsConstantExprInRange(
     const evaluate::ActualArguments &actuals, int index, int lowerBound,
     int upperBound, parser::ContextualMessages &messages) {
   CHECK(index >= 0 && static_cast<unsigned>(index) < actuals.size());
 
if (!buffer.empty()) {
       if (auto *msgs{messages.messages()}) {
         msgs->Annex(std::move(buffer));
       }
       return false; // don't pile on
     }
   }
   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(
                 "If the procedure's interface were explicit, this reference would be in error"_warn_en_US)}) {
           buffer.AttachTo(*msg, parser::Severity::Because);
         }
       }
       if (auto *msgs{messages.messages()}) {
         msgs->Annex(std::move(buffer));
       }
       return false;
     }
   }
   return true;
 }
 } // namespace Fortran::semantics

flang/test/Semantics/call37.f90

+! 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

!dir$ ignore_tkr
   !ERROR: Actual argument type 'COMPLEX(4)' is not compatible with dummy argument type 'REAL(4)'
   call t3((1.,2.))
   !ERROR: Actual argument type 'LOGICAL(4)' is not compatible with dummy argument type 'REAL(4)'
   call t3(.true.)
 
   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)
   call t6(dx)
   call t6('a')
   call t6((1.,2.))
   call t6(.true.)
   call t6(a)