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

[Peter Klausler via flang-commits]

https://github.com/klausler created https://github.com/llvm/llvm-project/pull/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.

>From fab04fe2c4d587f0b5ddf9e4efdb0d404096620c Mon Sep 17 00:00:00 2001
From: Peter Klausler <pklausler at nvidia.com>
Date: Tue, 5 Mar 2024 14:38:10 -0800
Subject: [PATCH] [flang] Emit warning when Hollerith actual passed to CLASS(*)

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.
---
 flang/include/flang/Evaluate/constant.h |  3 +++
 flang/lib/Semantics/check-call.cpp      | 10 +++++++++-
 flang/lib/Semantics/expression.cpp      |  7 +++++--
 flang/test/Semantics/call41.f90         | 12 ++++++++++++
 4 files changed, 29 insertions(+), 3 deletions(-)
 create mode 100644 flang/test/Semantics/call41.f90

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