[flang-commits] [flang] d9232e3 - [flang] Be more precise about CHARACTER known length discrepancies
Peter Klausler via flang-commits
flang-commits at lists.llvm.org
Mon Oct 31 11:18:28 PDT 2022
Author: Peter Klausler
Date: 2022-10-31T11:18:16-07:00
New Revision: d9232e394e08ecba3d8e4128a11d30d9aa20605d
URL: https://github.com/llvm/llvm-project/commit/d9232e394e08ecba3d8e4128a11d30d9aa20605d
DIFF: https://github.com/llvm/llvm-project/commit/d9232e394e08ecba3d8e4128a11d30d9aa20605d.diff
LOG: [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
Added:
Modified:
flang/include/flang/Evaluate/type.h
flang/lib/Evaluate/intrinsics.cpp
flang/lib/Evaluate/type.cpp
flang/test/Evaluate/folding23.f90
flang/test/Semantics/move_alloc.f90
Removed:
################################################################################
diff --git a/flang/include/flang/Evaluate/type.h b/flang/include/flang/Evaluate/type.h
index 876665bb8958d..47ab714c03970 100644
--- a/flang/include/flang/Evaluate/type.h
+++ b/flang/include/flang/Evaluate/type.h
@@ -186,9 +186,14 @@ class DynamicType {
// 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 9aaaee47876ca..6bb8d7236e7a7 100644
--- 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},
@@ -1687,6 +1692,12 @@ std::optional<SpecificCall> IntrinsicInterface::Match(
argOk = true;
break;
case KindCode::same:
+ if (!sameArg) {
+ sameArg = arg;
+ }
+ argOk = type->IsTkLenCompatibleWith(sameArg->GetType().value());
+ break;
+ case KindCode::sameKind:
if (!sameArg) {
sameArg = arg;
}
@@ -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 2a1cdd23d750d..d06e7323baa73 100644
--- 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 c25d2fc939828..00dfc367ab5f1 100644
--- 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 b1c563750c877..a67fdca9701e5 100644
--- 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
More information about the flang-commits
mailing list