[flang] Be more precise about CHARACTER known length discrepancies

Many intrinsic functions in Fortran require that two or more of their
arguments have types that agree in the values of all of their type
parameters, while others only require the same type category and kind
type parameters but not lengths, including the important case of
CHARACTER.  The intrinsic procedure tables need to be adjusted in
some cases so that discrepancies in character lengths that are known
at compilation time can be diagnosed as errors where they should be,
as in for example MOVE_ALLOC().

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

diff --git a/flang/include/flang/Evaluate/type.h b/flang/include/flang/Evaluate/type.h
index 876665b..47ab714 100644 (file)
--- a/flang/include/flang/Evaluate/type.h
+++ b/flang/include/flang/Evaluate/type.h
@@ -186,9 +186,14 @@ public:
   // 7.3.2.3 & 15.5.2.4 type compatibility.
   // x.IsTkCompatibleWith(y) is true if "x => y" or passing actual y to
   // dummy argument x would be valid.  Be advised, this is not a reflexive
-  // relation.  Kind type parameters must match.
+  // relation.  Kind type parameters must match, but CHARACTER lengths
+  // need not do so.
   bool IsTkCompatibleWith(const DynamicType &) const;
 
+  // A stronger compatibility check that does not allow distinct known
+  // values for CHARACTER lengths for e.g. MOVE_ALLOC().
+  bool IsTkLenCompatibleWith(const DynamicType &) const;
+
   // EXTENDS_TYPE_OF (16.9.76); ignores type parameter values
   std::optional<bool> ExtendsTypeOf(const DynamicType &) const;
   // SAME_TYPE_AS (16.9.165); ignores type parameter values

diff --git a/flang/lib/Evaluate/intrinsics.cpp b/flang/lib/Evaluate/intrinsics.cpp
index 9aaaee4..6bb8d72 100644 (file)
--- a/flang/lib/Evaluate/intrinsics.cpp
+++ b/flang/lib/Evaluate/intrinsics.cpp
@@ -82,8 +82,8 @@ ENUM_CLASS(KindCode, none, defaultIntegerKind,
     // match any kind, but all "same" kinds must be equal. For characters, also
     // implies that lengths must be equal.
     same,
-    // for character results, take "same" argument kind but not length
-    sameKindButNotLength,
+    // for characters that only require the same kind, not length
+    sameKind,
     operand, // match any kind, with promotion (non-standard)
     typeless, // BOZ literals are INTEGER with this kind
     teamType, // TEAM_TYPE from module ISO_FORTRAN_ENV (for coarrays)
@@ -157,8 +157,7 @@ static constexpr TypePattern SameComplex{ComplexType, KindCode::same};
 static constexpr TypePattern SameFloating{FloatingType, KindCode::same};
 static constexpr TypePattern SameNumeric{NumericType, KindCode::same};
 static constexpr TypePattern SameChar{CharType, KindCode::same};
-static constexpr TypePattern SameCharNewLen{
-    CharType, KindCode::sameKindButNotLength};
+static constexpr TypePattern SameCharNoLen{CharType, KindCode::sameKind};
 static constexpr TypePattern SameLogical{LogicalType, KindCode::same};
 static constexpr TypePattern SameRelatable{RelatableType, KindCode::same};
 static constexpr TypePattern SameIntrinsic{IntrinsicType, KindCode::same};
@@ -471,13 +470,15 @@ static const IntrinsicInterface genericIntrinsicFunction[]{
             {"back", AnyLogical, Rank::scalar, Optionality::optional}},
         KINDInt, Rank::vector, IntrinsicClass::transformationalFunction},
     {"findloc",
-        {{"array", SameChar, Rank::array}, {"value", SameChar, Rank::scalar},
-            RequiredDIM, OptionalMASK, SizeDefaultKIND,
+        {{"array", SameCharNoLen, Rank::array},
+            {"value", SameCharNoLen, Rank::scalar}, RequiredDIM, OptionalMASK,
+            SizeDefaultKIND,
             {"back", AnyLogical, Rank::scalar, Optionality::optional}},
         KINDInt, Rank::locReduced, IntrinsicClass::transformationalFunction},
     {"findloc",
-        {{"array", SameChar, Rank::array}, {"value", SameChar, Rank::scalar},
-            MissingDIM, OptionalMASK, SizeDefaultKIND,
+        {{"array", SameCharNoLen, Rank::array},
+            {"value", SameCharNoLen, Rank::scalar}, MissingDIM, OptionalMASK,
+            SizeDefaultKIND,
             {"back", AnyLogical, Rank::scalar, Optionality::optional}},
         KINDInt, Rank::vector, IntrinsicClass::transformationalFunction},
     {"findloc",
@@ -525,7 +526,7 @@ static const IntrinsicInterface genericIntrinsicFunction[]{
     {"ieor", {{"i", BOZ}, {"j", SameInt}}, SameInt},
     {"image_status", {{"image", SameInt}, OptionalTEAM}, DefaultInt},
     {"index",
-        {{"string", SameChar}, {"substring", SameChar},
+        {{"string", SameCharNoLen}, {"substring", SameCharNoLen},
             {"back", AnyLogical, Rank::elemental, Optionality::optional},
             DefaultingKIND},
         KINDInt},
@@ -565,10 +566,14 @@ static const IntrinsicInterface genericIntrinsicFunction[]{
             DefaultingKIND},
         KINDInt, Rank::scalar, IntrinsicClass::inquiryFunction},
     {"len_trim", {{"string", AnyChar}, DefaultingKIND}, KINDInt},
-    {"lge", {{"string_a", SameChar}, {"string_b", SameChar}}, DefaultLogical},
-    {"lgt", {{"string_a", SameChar}, {"string_b", SameChar}}, DefaultLogical},
-    {"lle", {{"string_a", SameChar}, {"string_b", SameChar}}, DefaultLogical},
-    {"llt", {{"string_a", SameChar}, {"string_b", SameChar}}, DefaultLogical},
+    {"lge", {{"string_a", SameCharNoLen}, {"string_b", SameCharNoLen}},
+        DefaultLogical},
+    {"lgt", {{"string_a", SameCharNoLen}, {"string_b", SameCharNoLen}},
+        DefaultLogical},
+    {"lle", {{"string_a", SameCharNoLen}, {"string_b", SameCharNoLen}},
+        DefaultLogical},
+    {"llt", {{"string_a", SameCharNoLen}, {"string_b", SameCharNoLen}},
+        DefaultLogical},
     {"loc", {{"loc_argument", Addressable, Rank::anyOrAssumedRank}},
         SubscriptInt, Rank::scalar},
     {"log", {{"x", SameFloating}}, SameFloating},
@@ -606,9 +611,9 @@ static const IntrinsicInterface genericIntrinsicFunction[]{
             {"a3", OperandIntOrReal, Rank::elemental, Optionality::repeats}},
         OperandIntOrReal},
     {"max",
-        {{"a1", SameChar}, {"a2", SameChar},
-            {"a3", SameChar, Rank::elemental, Optionality::repeats}},
-        SameChar},
+        {{"a1", SameCharNoLen}, {"a2", SameCharNoLen},
+            {"a3", SameCharNoLen, Rank::elemental, Optionality::repeats}},
+        SameCharNoLen},
     {"maxexponent",
         {{"x", AnyReal, Rank::anyOrAssumedRank, Optionality::required,
             common::Intent::In, {ArgFlag::canBeNull}}},
@@ -645,9 +650,9 @@ static const IntrinsicInterface genericIntrinsicFunction[]{
             {"a3", OperandIntOrReal, Rank::elemental, Optionality::repeats}},
         OperandIntOrReal},
     {"min",
-        {{"a1", SameChar}, {"a2", SameChar},
-            {"a3", SameChar, Rank::elemental, Optionality::repeats}},
-        SameChar},
+        {{"a1", SameCharNoLen}, {"a2", SameCharNoLen},
+            {"a3", SameCharNoLen, Rank::elemental, Optionality::repeats}},
+        SameCharNoLen},
     {"minexponent",
         {{"x", AnyReal, Rank::anyOrAssumedRank, Optionality::required,
             common::Intent::In, {ArgFlag::canBeNull}}},
@@ -675,9 +680,9 @@ static const IntrinsicInterface genericIntrinsicFunction[]{
         OperandIntOrReal},
     {"nearest", {{"x", SameReal}, {"s", AnyReal}}, SameReal},
     {"new_line",
-        {{"a", SameChar, Rank::anyOrAssumedRank, Optionality::required,
+        {{"a", SameCharNoLen, Rank::anyOrAssumedRank, Optionality::required,
             common::Intent::In, {ArgFlag::canBeNull}}},
-        SameChar, Rank::scalar, IntrinsicClass::inquiryFunction},
+        SameCharNoLen, Rank::scalar, IntrinsicClass::inquiryFunction},
     {"nint", {{"a", AnyReal}, DefaultingKIND}, KINDInt},
     {"norm2", {{"x", SameReal, Rank::array}, OptionalDIM}, SameReal,
         Rank::dimReduced, IntrinsicClass::transformationalFunction},
@@ -748,8 +753,8 @@ static const IntrinsicInterface genericIntrinsicFunction[]{
             {"identity", SameType, Rank::scalar, Optionality::optional},
             {"ordered", AnyLogical, Rank::scalar, Optionality::optional}},
         SameType, Rank::scalar, IntrinsicClass::transformationalFunction},
-    {"repeat", {{"string", SameChar, Rank::scalar}, {"ncopies", AnyInt}},
-        SameCharNewLen, Rank::scalar, IntrinsicClass::transformationalFunction},
+    {"repeat", {{"string", SameCharNoLen, Rank::scalar}, {"ncopies", AnyInt}},
+        SameCharNoLen, Rank::scalar, IntrinsicClass::transformationalFunction},
     {"reshape",
         {{"source", SameType, Rank::array}, {"shape", AnyInt, Rank::shape},
             {"pad", SameType, Rank::array, Optionality::optional},
@@ -762,7 +767,7 @@ static const IntrinsicInterface genericIntrinsicFunction[]{
         DefaultLogical, Rank::scalar, IntrinsicClass::inquiryFunction},
     {"scale", {{"x", SameReal}, {"i", AnyInt}}, SameReal}, // == IEEE_SCALB()
     {"scan",
-        {{"string", SameChar}, {"set", SameChar},
+        {{"string", SameCharNoLen}, {"set", SameCharNoLen},
             {"back", AnyLogical, Rank::elemental, Optionality::optional},
             DefaultingKIND},
         KINDInt},
@@ -851,8 +856,8 @@ static const IntrinsicInterface genericIntrinsicFunction[]{
         SameType, Rank::vector, IntrinsicClass::transformationalFunction},
     {"transpose", {{"matrix", SameType, Rank::matrix}}, SameType, Rank::matrix,
         IntrinsicClass::transformationalFunction},
-    {"trim", {{"string", SameChar, Rank::scalar}}, SameCharNewLen, Rank::scalar,
-        IntrinsicClass::transformationalFunction},
+    {"trim", {{"string", SameCharNoLen, Rank::scalar}}, SameCharNoLen,
+        Rank::scalar, IntrinsicClass::transformationalFunction},
     {"ubound",
         {{"array", AnyData, Rank::anyOrAssumedRank}, RequiredDIM,
             SizeDefaultKIND},
@@ -867,7 +872,7 @@ static const IntrinsicInterface genericIntrinsicFunction[]{
             {"field", SameType, Rank::conformable}},
         SameType, Rank::conformable, IntrinsicClass::transformationalFunction},
     {"verify",
-        {{"string", SameChar}, {"set", SameChar},
+        {{"string", SameCharNoLen}, {"set", SameCharNoLen},
             {"back", AnyLogical, Rank::elemental, Optionality::optional},
             DefaultingKIND},
         KINDInt},
@@ -1690,6 +1695,12 @@ std::optional<SpecificCall> IntrinsicInterface::Match(
       if (!sameArg) {
         sameArg = arg;
       }
+      argOk = type->IsTkLenCompatibleWith(sameArg->GetType().value());
+      break;
+    case KindCode::sameKind:
+      if (!sameArg) {
+        sameArg = arg;
+      }
       argOk = type->IsTkCompatibleWith(sameArg->GetType().value());
       break;
     case KindCode::operand:
@@ -1958,7 +1969,7 @@ std::optional<SpecificCall> IntrinsicInterface::Match(
         }
       }
       break;
-    case KindCode::sameKindButNotLength:
+    case KindCode::sameKind:
       CHECK(sameArg);
       if (std::optional<DynamicType> aType{sameArg->GetType()}) {
         resultType = DynamicType{*category, aType->kind()};
@@ -2868,7 +2879,7 @@ static bool ApplySpecificChecks(SpecificCall &call, FoldingContext &context) {
         context.messages().Say(at,
             "OPERATION= argument of REDUCE() must be a scalar function"_err_en_US);
       } else if (result->type().IsPolymorphic() ||
-          !arrayType->IsTkCompatibleWith(result->type())) {
+          !arrayType->IsTkLenCompatibleWith(result->type())) {
         ok = false;
         context.messages().Say(at,
             "OPERATION= argument of REDUCE() must have the same type as ARRAY="_err_en_US);

diff --git a/flang/lib/Evaluate/type.cpp b/flang/lib/Evaluate/type.cpp
index 2a1cdd2..d06e732 100644 (file)
--- a/flang/lib/Evaluate/type.cpp
+++ b/flang/lib/Evaluate/type.cpp
@@ -318,13 +318,18 @@ static bool AreCompatibleDerivedTypes(const semantics::DerivedTypeSpec *x,
 }
 
 static bool AreCompatibleTypes(const DynamicType &x, const DynamicType &y,
-    bool ignoreTypeParameterValues) {
+    bool ignoreTypeParameterValues, bool ignoreLengths) {
   if (x.IsUnlimitedPolymorphic()) {
     return true;
   } else if (y.IsUnlimitedPolymorphic()) {
     return false;
   } else if (x.category() != y.category()) {
     return false;
+  } else if (x.category() == TypeCategory::Character) {
+    const auto xLen{x.knownLength()};
+    const auto yLen{y.knownLength()};
+    return x.kind() == y.kind() &&
+        (ignoreLengths || !xLen || !yLen || *xLen == *yLen);
   } else if (x.category() != TypeCategory::Derived) {
     return x.kind() == y.kind();
   } else {
@@ -338,13 +343,17 @@ static bool AreCompatibleTypes(const DynamicType &x, const DynamicType &y,
 
 // See 7.3.2.3 (5) & 15.5.2.4
 bool DynamicType::IsTkCompatibleWith(const DynamicType &that) const {
-  return AreCompatibleTypes(*this, that, false);
+  return AreCompatibleTypes(*this, that, false, true);
+}
+
+bool DynamicType::IsTkLenCompatibleWith(const DynamicType &that) const {
+  return AreCompatibleTypes(*this, that, false, false);
 }
 
 // 16.9.165
 std::optional<bool> DynamicType::SameTypeAs(const DynamicType &that) const {
-  bool x{AreCompatibleTypes(*this, that, true)};
-  bool y{AreCompatibleTypes(that, *this, true)};
+  bool x{AreCompatibleTypes(*this, that, true, true)};
+  bool y{AreCompatibleTypes(that, *this, true, true)};
   if (x == y) {
     return x;
   } else {

diff --git a/flang/test/Evaluate/folding23.f90 b/flang/test/Evaluate/folding23.f90
index c25d2fc..00dfc36 100644 (file)
--- a/flang/test/Evaluate/folding23.f90
+++ b/flang/test/Evaluate/folding23.f90
@@ -7,7 +7,7 @@ module m
   logical, parameter :: test_eoshift_1 = all(eoshift([1, 2, 3], 1) == [2, 3, 0])
   logical, parameter :: test_eoshift_2 = all(eoshift([1, 2, 3], -1) == [0, 1, 2])
   logical, parameter :: test_eoshift_3 = all(eoshift([1., 2., 3.], 1) == [2., 3., 0.])
-  logical, parameter :: test_eoshift_4 = all(eoshift(['ab', 'cd', 'ef'], -1, 'x') == ['x ', 'ab', 'cd'])
+  logical, parameter :: test_eoshift_4 = all(eoshift(['ab', 'cd', 'ef'], -1, 'x ') == ['x ', 'ab', 'cd'])
   logical, parameter :: test_eoshift_5 = all([eoshift(arr, 1, dim=1)] == [2, 0, 4, 0, 6, 0])
   logical, parameter :: test_eoshift_6 = all([eoshift(arr, 1, dim=2)] == [3, 4, 5, 6, 0, 0])
   logical, parameter :: test_eoshift_7 = all([eoshift(arr, [1, -1, 0])] == [2, 0, 0, 3, 5, 6])

diff --git a/flang/test/Semantics/move_alloc.f90 b/flang/test/Semantics/move_alloc.f90
index b1c5637..a67fdca 100644 (file)
--- a/flang/test/Semantics/move_alloc.f90
+++ b/flang/test/Semantics/move_alloc.f90
@@ -11,6 +11,7 @@ program main
   end type
   class(t), allocatable :: t1
   type(t), allocatable :: t2
+  character, allocatable :: ca*2, cb*3
 
   ! standards conforming
   allocate(a(3)[*])
@@ -63,4 +64,7 @@ program main
   call move_alloc(t1, t2)
   call move_alloc(t2, t1) ! ok
 
+  !ERROR: Actual argument for 'to=' has bad type or kind 'CHARACTER(KIND=1,LEN=3_8)'
+  call move_alloc(ca, cb)
+
 end program main