[flang] Conform with standard (mostly) for character length mismatches on arguments

[klausler]

Summary

Fortran 2018 defines some flavors of dummy arguments to require exact
matching of character lengths between dummy and actual arguments;
these situations tend to be those in which the interface must be
explicit and a descriptor is involved: assumed shape, assumed rank,
allocatable, and pointer.

Fortran allows an actual argument in other cases to have a longer
length than the dummy argument; as a common extension, we support a
shorter actual argument as well by means of blank padding, but should
emit a warning.

[klausler]

Fix bug found during integration testing.

[tschuett]

The web interface says at several places "Context not available.". Did you git diff -U999999 main?
https://llvm.org/docs/DeveloperPolicy.html#id10

[jeanPerier]

LGTM

flang/lib/Evaluate/characteristics.cpp

 bool DummyDataObject::IsCompatibleWith(
     const DummyDataObject &actual, std::string *whyNot) const {
   if (!AreCompatibleDummyDataObjectShapes(type.shape(), actual.type.shape())) {
     if (whyNot) {
       *whyNot = "incompatible dummy data object shapes";
     }
     return false;
   }
-  if (!type.type().IsTkCompatibleWith(actual.type.type())) {
+  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 (attrs != actual.attrs) {
     if (whyNot) {

flang/lib/Semantics/check-call.cpp

if (IsBOZLiteral(*expr)) {
                 argProcSymbol->name());
           }
         }
       }
     }
   }
 }
 
-// When a scalar CHARACTER actual argument is known to be short,
-// we extend it on the right with spaces and a warning if it is an
-// expression, and emit an error if it is a variable.
+// When a CHARACTER actual argument is known to be short,
+// we extend it on the right with spaces and a warning if
+// possible.  When it is long, and not required to be equal,
+// the usage conforms to the standard and no warning is needed.
 static void CheckCharacterActual(evaluate::Expr<evaluate::SomeType> &actual,
-    const characteristics::TypeAndShape &dummyType,
+    const characteristics::DummyDataObject &dummy,
     characteristics::TypeAndShape &actualType,
     evaluate::FoldingContext &context, parser::ContextualMessages &messages) {
-  if (dummyType.type().category() == TypeCategory::Character &&
+  if (dummy.type.type().category() == TypeCategory::Character &&
       actualType.type().category() == TypeCategory::Character &&
-      dummyType.type().kind() == actualType.type().kind() &&
-      GetRank(actualType.shape()) == 0) {
-    if (dummyType.LEN() && actualType.LEN()) {
-      auto dummyLength{ToInt64(Fold(context, common::Clone(*dummyType.LEN())))};
+      dummy.type.type().kind() == actualType.type().kind()) {
+    if (dummy.type.LEN() && actualType.LEN()) {
+      auto dummyLength{
+          ToInt64(Fold(context, common::Clone(*dummy.type.LEN())))};
       auto actualLength{
           ToInt64(Fold(context, common::Clone(*actualType.LEN())))};
-      if (dummyLength && actualLength && *actualLength < *dummyLength) {
+      if (dummyLength && actualLength && *actualLength != *dummyLength) {
+        if (dummy.attrs.test(
+                characteristics::DummyDataObject::Attr::Allocatable) ||
+            dummy.attrs.test(characteristics::DummyDataObject::Attr::Pointer) ||
+            dummy.type.attrs().test(
+                characteristics::TypeAndShape::Attr::AssumedRank) ||
+            dummy.type.attrs().test(
+                characteristics::TypeAndShape::Attr::AssumedShape)) {
+          // See 15.5.2.4 paragraph 4., 15.5.2.5.
+          messages.Say(
+              "Actual argument variable length '%jd' does not match the expected length '%jd'"_err_en_US,
+              *actualLength, *dummyLength);
+        } else if (*actualLength < *dummyLength) {
           if (evaluate::IsVariable(actual)) {
             messages.Say(
-              "Actual argument variable length '%jd' is less than expected length '%jd'"_err_en_US,
+                "Actual argument variable length '%jd' is less than expected length '%jd'"_warn_en_US,
                 *actualLength, *dummyLength);
           } else {
             messages.Say(
                 "Actual argument expression length '%jd' is less than expected length '%jd'"_warn_en_US,
                 *actualLength, *dummyLength);
-          auto converted{ConvertToType(dummyType.type(), std::move(actual))};
+            auto converted{ConvertToType(dummy.type.type(), std::move(actual))};
             CHECK(converted);
             actual = std::move(*converted);
             actualType.set_LEN(SubscriptIntExpr{*dummyLength});
           }
         }
       }
     }
   }
+}
 
 // Automatic conversion of different-kind INTEGER scalar actual
 // argument expressions (not variables) to INTEGER scalar dummies.
 // We return nonstandard INTEGER(8) results from intrinsic functions
 // like SIZE() by default in order to facilitate the use of large
 // arrays.  Emit a warning when downconverting.
 static void ConvertIntegerActual(evaluate::Expr<evaluate::SomeType> &actual,
     const characteristics::TypeAndShape &dummyType,
static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy,
     const std::string &dummyName, evaluate::Expr<evaluate::SomeType> &actual,
     characteristics::TypeAndShape &actualType, bool isElemental,
     evaluate::FoldingContext &context, const Scope *scope,
     const evaluate::SpecificIntrinsic *intrinsic,
     bool allowActualArgumentConversions) {
 
   // Basic type & rank checking
   parser::ContextualMessages &messages{context.messages()};
-  CheckCharacterActual(actual, dummy.type, actualType, context, messages);
+  CheckCharacterActual(actual, dummy, actualType, context, messages);
   if (allowActualArgumentConversions) {
     ConvertIntegerActual(actual, dummy.type, actualType, messages);
   }
   bool typesCompatible{dummy.type.type().IsTkCompatibleWith(actualType.type())};
   if (!typesCompatible && dummy.type.Rank() == 0 &&
       allowActualArgumentConversions) {
     // Extension: pass Hollerith literal to scalar as if it had been BOZ
     if (auto converted{
if (!buffer.empty()) {
       }
       return false; // don't pile on
     }
   }
   if (explicitInterface) {
     auto buffer{CheckExplicitInterface(
         proc, actuals, context, &scope, intrinsic, true)};
     if (!buffer.empty()) {
-      if (treatingExternalAsImplicit && !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/Lower/character-substrings.f90

 ! CHECK:         %[[VAL_3:.*]] = arith.constant 4 : index
 ! CHECK:         %[[VAL_4:.*]] = arith.constant 1 : index
 ! CHECK:         %[[VAL_5:.*]] = arith.constant 1 : i64
 ! CHECK:         %[[VAL_6:.*]] = fir.convert %[[VAL_5]] : (i64) -> index
 ! CHECK:         %[[VAL_7:.*]] = arith.addi %[[VAL_4]], %[[VAL_3]] : index
 ! CHECK:         %[[VAL_8:.*]] = arith.subi %[[VAL_7]], %[[VAL_4]] : index
 ! CHECK:         %[[VAL_9:.*]] = fir.shape %[[VAL_3]] : (index) -> !fir.shape<1>
 ! CHECK:         %[[VAL_10:.*]] = arith.constant 5 : i64
-! CHECK:         %[[VAL_11:.*]] = arith.constant 7 : i64
+! CHECK:         %[[VAL_11:.*]] = arith.constant 5 : i64
 ! CHECK:         %[[VAL_12:.*]] = arith.constant 1 : i64
 ! CHECK:         %[[VAL_13:.*]] = arith.subi %[[VAL_10]], %[[VAL_12]] : i64
 ! CHECK:         %[[VAL_14:.*]] = arith.constant 0 : i64
 ! CHECK:         %[[VAL_15:.*]] = arith.subi %[[VAL_11]], %[[VAL_13]] : i64
 ! CHECK:         %[[VAL_16:.*]] = arith.cmpi sgt, %[[VAL_15]], %[[VAL_14]] : i64
 ! CHECK:         %[[VAL_17:.*]] = arith.select %[[VAL_16]], %[[VAL_15]], %[[VAL_14]] : i64
 ! CHECK:         %[[VAL_18:.*]] = fir.slice %[[VAL_4]], %[[VAL_8]], %[[VAL_6]] substr %[[VAL_13]], %[[VAL_17]] : (index, index, index, i64, i64) -> !fir.slice<1>
 ! CHECK:         %[[VAL_19:.*]] = fir.embox %[[VAL_2]](%[[VAL_9]]) {{\[}}%[[VAL_18]]] : (!fir.ref<!fir.array<4x!fir.char<1,7>>>, !fir.shape<1>, !fir.slice<1>) -> !fir.box<!fir.array<?x!fir.char<1,?>>>
 ! CHECK:         %[[VAL_20:.*]] = fir.convert %[[VAL_19]] : (!fir.box<!fir.array<?x!fir.char<1,?>>>) -> !fir.box<!fir.array<?x!fir.char<1>>>
 ! CHECK:         fir.call @_QPs(%[[VAL_20]]) {{.*}}: (!fir.box<!fir.array<?x!fir.char<1>>>) -> ()
 ! CHECK:         return
 ! CHECK:       }
 
 subroutine array_substring_embox(arr)
   interface
     subroutine s(a)
      character(1) :: a(:)
     end subroutine s
   end interface
 
   character(7) arr(4)
 
-  call s(arr(:)(5:7))
+  call s(arr(:)(5:5))
 end subroutine array_substring_embox
 
 ! CHECK-LABEL: func @_QPsubstring_assignment(
 ! CHECK-SAME:        %[[VAL_0:.*]]: !fir.boxchar<1>{{.*}}, %[[VAL_1:.*]]: !fir.boxchar<1>{{.*}}) {
 subroutine substring_assignment(a,b)
   ! CHECK:         %[[VAL_2:.*]]:2 = fir.unboxchar %[[VAL_0]] : (!fir.boxchar<1>) -> (!fir.ref<!fir.char<1,?>>, index)
   ! CHECK:         %[[VAL_3:.*]]:2 = fir.unboxchar %[[VAL_1]] : (!fir.boxchar<1>) -> (!fir.ref<!fir.char<1,?>>, index)
   ! CHECK:         %[[VAL_4:.*]] = arith.constant 3 : i64

flang/test/Semantics/call33.f90

+! RUN: %python %S/test_errors.py %s %flang_fc1 -Werror
+module m
+ contains
+  subroutine s1(x)
+    character(3) :: x
+  end
+  subroutine s2(x)
+    character(3) :: x(1)
+  end
+  subroutine s3(x)
+    character(3) :: x(:)
+  end
+  subroutine s4(x)
+    character(3) :: x(..)
+  end
+  subroutine s5(x)
+    character(3), allocatable :: x
+  end
+  subroutine s6(x)
+    character(3), pointer :: x
+  end
+end
+
+program test
+  use m
+  character(2) short, shortarr(1)
+  character(2), allocatable :: shortalloc
+  character(2), pointer :: shortptr
+  character(4) long, longarr(1)
+  character(4), allocatable :: longalloc
+  character(4), pointer :: longptr
+  !WARNING: Actual argument variable length '2' is less than expected length '3'
+  call s1(short)
+  !WARNING: Actual argument variable length '2' is less than expected length '3'
+  call s2(shortarr)
+  !ERROR: Actual argument variable length '2' does not match the expected length '3'
+  call s3(shortarr)
+  !ERROR: Actual argument variable length '2' does not match the expected length '3'
+  call s4(shortarr)
+  !ERROR: Actual argument variable length '2' does not match the expected length '3'
+  call s5(shortalloc)
+  !ERROR: Actual argument variable length '2' does not match the expected length '3'
+  call s6(shortptr)
+  call s1(long) ! ok
+  call s2(longarr) ! ok
+  !ERROR: Actual argument variable length '4' does not match the expected length '3'
+  call s3(longarr)
+  !ERROR: Actual argument variable length '4' does not match the expected length '3'
+  call s4(longarr)
+  !ERROR: Actual argument variable length '4' does not match the expected length '3'
+  call s5(longalloc)
+  !ERROR: Actual argument variable length '4' does not match the expected length '3'
+  call s6(longptr)
+end