[flang] Pad short CHARACTER actual arguments

Original-commit: flang-compiler/f18@b9c890ca9c
Reviewed-on: https://github.com/flang-compiler/f18/pull/782
Tree-same-pre-rewrite: false

flang/documentation/Extensions.md

@@ -103,6 +103,9 @@ Extensions, deletions, and legacy features supported by default
 * Specific intrinsics AMAX0, AMAX1, AMIN0, AMIN1, DMAX1, DMIN1, MAX0, MAX1,
   MIN0, and MIN1 accept more argument types than specified. They are replaced by
   the related generics followed by conversions to the specified result types.
+* When a scalar CHARACTER actual argument of the same kind is known to
+  have a length shorter than the associated dummy argument, it is extended
+  on the right with blanks, similar to assignment.
 
 Extensions supported when enabled by options
 --------------------------------------------

flang/lib/evaluate/characteristics.cc

@@ -136,18 +136,6 @@ bool TypeAndShape::IsCompatibleWith(parser::ContextualMessages &messages,
         type_.AsFortran());
     return false;
   }
-  // When associating with a character scalar, length must not be greater.
-  if (GetRank(that.shape_) == 0) {
-    if (auto myLEN{ToInt64(LEN())}) {
-      if (auto thatLEN{ToInt64(len)}) {
-        if (*thatLEN < *myLEN) {
-          messages.Say(
-              "Actual length '%jd' is less than expected length '%jd'"_err_en_US,
-              *thatLEN, *myLEN);
-        }
-      }
-    }
-  }
   return isElemental ||
       CheckConformance(messages, shape_, that.shape_, thisDesc, thatDesc);
 }
@@ -164,6 +152,9 @@ void TypeAndShape::AcquireShape(const semantics::ObjectEntityDetails &object) {
   if (object.IsAssumedSize()) {
     attrs_.set(Attr::AssumedSize);
   }
+  if (object.IsDeferredShape()) {
+    attrs_.set(Attr::DeferredShape);
+  }
   if (object.IsCoarray()) {
     attrs_.set(Attr::Coarray);
   }

flang/lib/evaluate/characteristics.h

@@ -54,7 +54,8 @@ bool DistinguishableOpOrAssign(const Procedure &, const Procedure &);
 
 class TypeAndShape {
 public:
-  ENUM_CLASS(Attr, AssumedRank, AssumedShape, AssumedSize, Coarray)
+  ENUM_CLASS(
+      Attr, AssumedRank, AssumedShape, AssumedSize, DeferredShape, Coarray)
   using Attrs = common::EnumSet<Attr, Attr_enumSize>;
 
   explicit TypeAndShape(DynamicType t) : type_{t} { AcquireLEN(); }

flang/lib/evaluate/check-expression.cc

@@ -275,6 +275,8 @@ public:
       return false;
     } else if (const auto *details{
                    symbol.detailsIf<semantics::ObjectEntityDetails>()}) {
+      // N.B. ALLOCATABLEs are deferred shape, not assumed, and
+      // are obviously contiguous.
       return !details->IsAssumedShape() && !details->IsAssumedRank();
     } else {
       return false;

flang/lib/semantics/check-call.cc

@@ -110,9 +110,33 @@ static void InspectType(
   }
 }
 
+// When scalar CHARACTER actual arguments are known to be short,
+// we extend them on the right with spaces and a warning.
+static void PadShortCharacterActual(evaluate::Expr<evaluate::SomeType> &actual,
+    const characteristics::TypeAndShape &dummyType,
+    const characteristics::TypeAndShape &actualType,
+    parser::ContextualMessages &messages) {
+  if (dummyType.type().category() == TypeCategory::Character &&
+      actualType.type().category() == TypeCategory::Character &&
+      dummyType.type().kind() == actualType.type().kind() &&
+      GetRank(actualType.shape()) == 0) {
+    if (auto dummyLEN{ToInt64(dummyType.LEN())}) {
+      if (auto actualLEN{ToInt64(actualType.LEN())}) {
+        if (*actualLEN < *dummyLEN) {
+          messages.Say(
+              "Actual length '%jd' is less than expected length '%jd'"_en_US,
+              *actualLEN, *dummyLEN);
+          auto converted{ConvertToType(dummyType.type(), std::move(actual))};
+          CHECK(converted.has_value());
+          actual = std::move(*converted);
+        }
+      }
+    }
+  }
+}
+
 static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy,
-    const std::string &dummyName,
-    const evaluate::Expr<evaluate::SomeType> &actual,
+    const std::string &dummyName, evaluate::Expr<evaluate::SomeType> &actual,
     const characteristics::TypeAndShape &actualType,
     const characteristics::Procedure &proc, evaluate::FoldingContext &context,
     const Scope &scope) {
@@ -122,6 +146,7 @@ static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy,
   int dummyRank{evaluate::GetRank(dummy.type.shape())};
   bool isElemental{dummyRank == 0 &&
       proc.attrs.test(characteristics::Procedure::Attr::Elemental)};
+  PadShortCharacterActual(actual, dummy.type, actualType, messages);
   dummy.type.IsCompatibleWith(
       messages, actualType, "dummy argument", "actual argument", isElemental);
 
@@ -283,8 +308,8 @@ static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy,
         WhyNotModifiable(messages.at(), actual, scope, vectorSubscriptIsOk)};
     if (why.get() != nullptr) {
       if (auto *msg{messages.Say(
-              "Actual argument associated with %s dummy must be definable"_err_en_US,
-              reason)}) {
+              "Actual argument associated with %s %s must be definable"_err_en_US,
+              reason, dummyName)}) {
         msg->Attach(std::move(why));
       }
     }
@@ -320,7 +345,7 @@ static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy,
   }
 }
 
-static void CheckExplicitInterfaceArg(const evaluate::ActualArgument &arg,
+static void CheckExplicitInterfaceArg(evaluate::ActualArgument &arg,
     const characteristics::DummyArgument &dummy,
     const characteristics::Procedure &proc, evaluate::FoldingContext &context,
     const Scope &scope) {
@@ -332,7 +357,7 @@ static void CheckExplicitInterfaceArg(const evaluate::ActualArgument &arg,
   std::visit(
       common::visitors{
           [&](const characteristics::DummyDataObject &object) {
-            if (const auto *expr{arg.UnwrapExpr()}) {
+            if (auto *expr{arg.UnwrapExpr()}) {
               if (auto type{characteristics::TypeAndShape::Characterize(
                       *expr, context)}) {
                 CheckExplicitDataArg(

flang/lib/semantics/symbol.h

@@ -585,6 +585,7 @@ public:
             [](const GenericDetails &) {
               return 0; /*TODO*/
             },
+            [](const ProcBindingDetails &x) { return x.symbol().Rank(); },
             [](const UseDetails &x) { return x.symbol().Rank(); },
             [](const HostAssocDetails &x) { return x.symbol().Rank(); },
             [](const ObjectEntityDetails &oed) { return oed.shape().Rank(); },

flang/test/semantics/call03.f90

@@ -131,14 +131,13 @@ module m01
   end subroutine
 
   subroutine ch2(x)
-    character(2), intent(in) :: x
+    character(2), intent(in out) :: x
   end subroutine
   subroutine test06 ! 15.5.2.4(4)
     character :: ch1
-    !ERROR: Actual length '1' is less than expected length '2'
+    ! The actual argument is converted to a padded expression.
+    !ERROR: Actual argument associated with INTENT(IN OUT) dummy argument 'x=' must be definable
     call ch2(ch1)
-    !ERROR: Actual length '1' is less than expected length '2'
-    call ch2(' ')
   end subroutine
 
   subroutine out01(x)
@@ -194,23 +193,23 @@ module m01
     real, intent(in) :: in
     real :: x
     x = 0.
-    !ERROR: Actual argument associated with INTENT(OUT) dummy must be definable
+    !ERROR: Actual argument associated with INTENT(OUT) dummy argument 'x=' must be definable
     call intentout(in)
-    !ERROR: Actual argument associated with INTENT(OUT) dummy must be definable
+    !ERROR: Actual argument associated with INTENT(OUT) dummy argument 'x=' must be definable
     call intentout(3.14159)
-    !ERROR: Actual argument associated with INTENT(OUT) dummy must be definable
+    !ERROR: Actual argument associated with INTENT(OUT) dummy argument 'x=' must be definable
     call intentout(in + 1.)
     call intentout(x) ! ok
-    !ERROR: Actual argument associated with INTENT(OUT) dummy must be definable
+    !ERROR: Actual argument associated with INTENT(OUT) dummy argument 'x=' must be definable
     call intentout((x))
-    !ERROR: Actual argument associated with INTENT(IN OUT) dummy must be definable
+    !ERROR: Actual argument associated with INTENT(IN OUT) dummy argument 'x=' must be definable
     call intentinout(in)
-    !ERROR: Actual argument associated with INTENT(IN OUT) dummy must be definable
+    !ERROR: Actual argument associated with INTENT(IN OUT) dummy argument 'x=' must be definable
     call intentinout(3.14159)
-    !ERROR: Actual argument associated with INTENT(IN OUT) dummy must be definable
+    !ERROR: Actual argument associated with INTENT(IN OUT) dummy argument 'x=' must be definable
     call intentinout(in + 1.)
     call intentinout(x) ! ok
-    !ERROR: Actual argument associated with INTENT(IN OUT) dummy must be definable
+    !ERROR: Actual argument associated with INTENT(IN OUT) dummy argument 'x=' must be definable
     call intentinout((x))
   end subroutine
 
@@ -218,13 +217,13 @@ module m01
     real :: a(1)
     integer :: j(1)
     j(1) = 1
-    !ERROR: Actual argument associated with INTENT(OUT) dummy must be definable
+    !ERROR: Actual argument associated with INTENT(OUT) dummy argument 'x=' must be definable
     call intentout(a(j))
-    !ERROR: Actual argument associated with INTENT(IN OUT) dummy must be definable
+    !ERROR: Actual argument associated with INTENT(IN OUT) dummy argument 'x=' must be definable
     call intentinout(a(j))
-    !ERROR: Actual argument associated with ASYNCHRONOUS dummy must be definable
+    !ERROR: Actual argument associated with ASYNCHRONOUS dummy argument 'x=' must be definable
     call asynchronous(a(j))
-    !ERROR: Actual argument associated with VOLATILE dummy must be definable
+    !ERROR: Actual argument associated with VOLATILE dummy argument 'x=' must be definable
     call volatile(a(j))
   end subroutine