[flang-commits] [flang] be76816 - [flang] Refine handling of short character actual arguments

[Peter Klausler via flang-commits]

Author: Peter Klausler
Date: 2022-05-09T15:39:48-07:00
New Revision: be768164a7837bcb87cb6409731d23dc2c00dcfe

URL: https://github.com/llvm/llvm-project/commit/be768164a7837bcb87cb6409731d23dc2c00dcfe
DIFF: https://github.com/llvm/llvm-project/commit/be768164a7837bcb87cb6409731d23dc2c00dcfe.diff

LOG: [flang] Refine handling of short character actual arguments

Actual arguments whose lengths are less than the expected length
of their corresponding dummy argument are errors; but this needs
to be refined.  Short actual arguments that are variables remain
errors, but those that are expressions can be (again) extended on
the right with blanks.

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

Added: 
    

Modified: 
    flang/lib/Semantics/check-call.cpp
    flang/test/Semantics/call03.f90

Removed: 
    


################################################################################
diff  --git a/flang/lib/Semantics/check-call.cpp b/flang/lib/Semantics/check-call.cpp
index ab1b5e7adf16b..8f49953f4b143 100644
--- a/flang/lib/Semantics/check-call.cpp
+++ b/flang/lib/Semantics/check-call.cpp
@@ -89,8 +89,9 @@ static void CheckImplicitInterfaceArg(evaluate::ActualArgument &arg,
   }
 }
 
-// When scalar CHARACTER actual arguments are known to be short,
-// we extend them on the right with spaces and a warning.
+// 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.
 static void CheckCharacterActual(evaluate::Expr<evaluate::SomeType> &actual,
     const characteristics::TypeAndShape &dummyType,
     characteristics::TypeAndShape &actualType,
@@ -104,15 +105,19 @@ static void CheckCharacterActual(evaluate::Expr<evaluate::SomeType> &actual,
       auto actualLength{
           ToInt64(Fold(context, common::Clone(*actualType.LEN())))};
       if (dummyLength && actualLength && *actualLength < *dummyLength) {
-        messages.Say(
-            "Actual length '%jd' is less than expected length '%jd'"_err_en_US,
-            *actualLength, *dummyLength);
-#if 0 // We used to just emit a warning, and padded the actual argument
-        auto converted{ConvertToType(dummyType.type(), std::move(actual))};
-        CHECK(converted);
-        actual = std::move(*converted);
-        actualType.set_LEN(SubscriptIntExpr{*dummyLength});
-#endif
+        if (evaluate::IsVariable(actual)) {
+          messages.Say(
+              "Actual argument variable length '%jd' is less than expected length '%jd'"_err_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))};
+          CHECK(converted);
+          actual = std::move(*converted);
+          actualType.set_LEN(SubscriptIntExpr{*dummyLength});
+        }
       }
     }
   }

diff  --git a/flang/test/Semantics/call03.f90 b/flang/test/Semantics/call03.f90
index 17d185bd9f8e4..51b51b86f52f8 100644
--- a/flang/test/Semantics/call03.f90
+++ b/flang/test/Semantics/call03.f90
@@ -121,7 +121,7 @@ subroutine test05 ! 15.5.2.4(2)
   end subroutine
 
   subroutine ch2(x)
-    character(2), intent(in out) :: x
+    character(2), intent(in) :: x
   end subroutine
   subroutine pdtdefault (derivedArg)
     !ERROR: Type parameter 'n' lacks a value and has no default
@@ -151,8 +151,10 @@ subroutine test06 ! 15.5.2.4(4)
     type(pdtWithDefault(3)) :: defaultVar3
     type(pdtWithDefault(4)) :: defaultVar4
     character :: ch1
-    !ERROR: Actual length '1' is less than expected length '2'
+    !ERROR: Actual argument variable length '1' is less than expected length '2'
     call ch2(ch1)
+    !WARN: Actual argument expression length '0' is less than expected length '2'
+    call ch2("")
     call pdtdefault(vardefault)
     call pdtdefault(var3)
     call pdtdefault(var4) ! error