[flang-commits] [flang] 03e50c4 - [flang] Emit warning when Hollerith actual passed to CLASS(*) (#84084)

[via flang-commits]

Author: Peter Klausler
Date: 2024-03-13T14:11:45-07:00
New Revision: 03e50c451427d908bbf8cf2d455de3ebba49fe4f

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

LOG: [flang] Emit warning when Hollerith actual passed to CLASS(*) (#84084)

When a Hollerith actual argument is associated with an unlimited
polymorphic dummy argument, it's treated as if it were CHARACTER. Some
other compilers treat it as if it had been BOZ, so emit a portability
warning.

Resolves https://github.com/llvm/llvm-project/issues/83548.

Added: 
    flang/test/Semantics/call41.f90

Modified: 
    flang/include/flang/Evaluate/constant.h
    flang/lib/Semantics/check-call.cpp
    flang/lib/Semantics/expression.cpp

Removed: 
    


################################################################################
diff  --git a/flang/include/flang/Evaluate/constant.h b/flang/include/flang/Evaluate/constant.h
index ee83d9fc04f3b9..71be7906d2fe2a 100644
--- a/flang/include/flang/Evaluate/constant.h
+++ b/flang/include/flang/Evaluate/constant.h
@@ -186,6 +186,8 @@ class Constant<Type<TypeCategory::Character, KIND>> : public ConstantBounds {
 
   const Scalar<Result> &values() const { return values_; }
   ConstantSubscript LEN() const { return length_; }
+  bool wasHollerith() const { return wasHollerith_; }
+  void set_wasHollerith(bool yes = true) { wasHollerith_ = yes; }
 
   std::optional<Scalar<Result>> GetScalarValue() const {
     if (Rank() == 0) {
@@ -210,6 +212,7 @@ class Constant<Type<TypeCategory::Character, KIND>> : public ConstantBounds {
 private:
   Scalar<Result> values_; // one contiguous string
   ConstantSubscript length_;
+  bool wasHollerith_{false};
 };
 
 class StructureConstructor;

diff  --git a/flang/lib/Semantics/check-call.cpp b/flang/lib/Semantics/check-call.cpp
index 3adbd7cc41774d..d625f8c2f7fc11 100644
--- a/flang/lib/Semantics/check-call.cpp
+++ b/flang/lib/Semantics/check-call.cpp
@@ -332,7 +332,15 @@ static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy,
   bool typesCompatible{typesCompatibleWithIgnoreTKR ||
       dummy.type.type().IsTkCompatibleWith(actualType.type())};
   int dummyRank{dummy.type.Rank()};
-  if (!typesCompatible && dummyRank == 0 && allowActualArgumentConversions) {
+  if (typesCompatible) {
+    if (const auto *constantChar{
+            evaluate::UnwrapConstantValue<evaluate::Ascii>(actual)};
+        constantChar && constantChar->wasHollerith() &&
+        dummy.type.type().IsUnlimitedPolymorphic()) {
+      messages.Say(
+          "passing Hollerith to unlimited polymorphic as if it were CHARACTER"_port_en_US);
+    }
+  } else if (dummyRank == 0 && allowActualArgumentConversions) {
     // Extension: pass Hollerith literal to scalar as if it had been BOZ
     if (auto converted{evaluate::HollerithToBOZ(
             foldingContext, actual, dummy.type.type())}) {

diff  --git a/flang/lib/Semantics/expression.cpp b/flang/lib/Semantics/expression.cpp
index 54bfe0f2e1563d..1015a9e6efcef8 100644
--- a/flang/lib/Semantics/expression.cpp
+++ b/flang/lib/Semantics/expression.cpp
@@ -875,8 +875,11 @@ MaybeExpr ExpressionAnalyzer::Analyze(const parser::CharLiteralConstant &x) {
 MaybeExpr ExpressionAnalyzer::Analyze(
     const parser::HollerithLiteralConstant &x) {
   int kind{GetDefaultKind(TypeCategory::Character)};
-  auto value{x.v};
-  return AnalyzeString(std::move(value), kind);
+  auto result{AnalyzeString(std::string{x.v}, kind)};
+  if (auto *constant{UnwrapConstantValue<Ascii>(result)}) {
+    constant->set_wasHollerith(true);
+  }
+  return result;
 }
 
 // .TRUE. and .FALSE. of various kinds

diff  --git a/flang/test/Semantics/call41.f90 b/flang/test/Semantics/call41.f90
new file mode 100644
index 00000000000000..a4c7514d99ba5e
--- /dev/null
+++ b/flang/test/Semantics/call41.f90
@@ -0,0 +1,12 @@
+! RUN: %python %S/test_errors.py %s %flang_fc1 -Werror
+module m
+ contains
+  subroutine unlimited(x)
+    class(*), intent(in) :: x
+  end
+  subroutine test
+    !PORTABILITY: passing Hollerith to unlimited polymorphic as if it were CHARACTER
+    call unlimited(6HHERMAN)
+    call unlimited('abc') ! ok
+  end
+end