[flang-commits] [flang] f28c1a9 - [flang] Conform with standard (mostly) for character length mismatches on arguments
Peter Klausler via flang-commits
flang-commits at lists.llvm.org
Mon Feb 13 15:07:54 PST 2023
Author: Peter Klausler
Date: 2023-02-13T15:07:40-08:00
New Revision: f28c1a9df2e3a940fa72c2890a965cbbe2433967
URL: https://github.com/llvm/llvm-project/commit/f28c1a9df2e3a940fa72c2890a965cbbe2433967
DIFF: https://github.com/llvm/llvm-project/commit/f28c1a9df2e3a940fa72c2890a965cbbe2433967.diff
LOG: [flang] Conform with standard (mostly) for character length mismatches on arguments
Fortran 2018 defines some flavors of dummy arguments to require exact
matching of character lengths between dummy and actual arguments;
these situations tend to be those in which the interface must be
explicit and a descriptor is involved: assumed shape, assumed rank,
allocatable, and pointer.
Fortran allows an actual argument in other cases to have a longer
length than the dummy argument; as a common extension, we support a
shorter actual argument as well by means of blank padding, but should
emit a warning.
Differential Revision: https://reviews.llvm.org/D143821
Added:
flang/test/Semantics/call33.f90
Modified:
flang/lib/Evaluate/characteristics.cpp
flang/lib/Semantics/check-call.cpp
flang/test/Lower/character-substrings.f90
Removed:
################################################################################
diff --git a/flang/lib/Evaluate/characteristics.cpp b/flang/lib/Evaluate/characteristics.cpp
index ada7b18b6afd3..cdd746d771aa5 100644
--- a/flang/lib/Evaluate/characteristics.cpp
+++ b/flang/lib/Evaluate/characteristics.cpp
@@ -275,7 +275,7 @@ bool DummyDataObject::IsCompatibleWith(
}
return false;
}
- if (!type.type().IsTkCompatibleWith(actual.type.type())) {
+ if (!type.type().IsTkLenCompatibleWith(actual.type.type())) {
if (whyNot) {
*whyNot = "incompatible dummy data object types: "s +
type.type().AsFortran() + " vs " + actual.type.type().AsFortran();
diff --git a/flang/lib/Semantics/check-call.cpp b/flang/lib/Semantics/check-call.cpp
index 697dbc7d34eae..6228950cc1ef3 100644
--- a/flang/lib/Semantics/check-call.cpp
+++ b/flang/lib/Semantics/check-call.cpp
@@ -98,34 +98,48 @@ static void CheckImplicitInterfaceArg(evaluate::ActualArgument &arg,
}
}
-// 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.
+// When a CHARACTER actual argument is known to be short,
+// we extend it on the right with spaces and a warning if
+// possible. When it is long, and not required to be equal,
+// the usage conforms to the standard and no warning is needed.
static void CheckCharacterActual(evaluate::Expr<evaluate::SomeType> &actual,
- const characteristics::TypeAndShape &dummyType,
+ const characteristics::DummyDataObject &dummy,
characteristics::TypeAndShape &actualType,
evaluate::FoldingContext &context, parser::ContextualMessages &messages) {
- if (dummyType.type().category() == TypeCategory::Character &&
+ if (dummy.type.type().category() == TypeCategory::Character &&
actualType.type().category() == TypeCategory::Character &&
- dummyType.type().kind() == actualType.type().kind() &&
- GetRank(actualType.shape()) == 0) {
- if (dummyType.LEN() && actualType.LEN()) {
- auto dummyLength{ToInt64(Fold(context, common::Clone(*dummyType.LEN())))};
+ dummy.type.type().kind() == actualType.type().kind()) {
+ if (dummy.type.LEN() && actualType.LEN()) {
+ auto dummyLength{
+ ToInt64(Fold(context, common::Clone(*dummy.type.LEN())))};
auto actualLength{
ToInt64(Fold(context, common::Clone(*actualType.LEN())))};
- if (dummyLength && actualLength && *actualLength < *dummyLength) {
- if (evaluate::IsVariable(actual)) {
- messages.Say(
- "Actual argument variable length '%jd' is less than expected length '%jd'"_err_en_US,
- *actualLength, *dummyLength);
- } else {
+ if (dummyLength && actualLength && *actualLength != *dummyLength) {
+ if (dummy.attrs.test(
+ characteristics::DummyDataObject::Attr::Allocatable) ||
+ dummy.attrs.test(characteristics::DummyDataObject::Attr::Pointer) ||
+ dummy.type.attrs().test(
+ characteristics::TypeAndShape::Attr::AssumedRank) ||
+ dummy.type.attrs().test(
+ characteristics::TypeAndShape::Attr::AssumedShape)) {
+ // See 15.5.2.4 paragraph 4., 15.5.2.5.
messages.Say(
- "Actual argument expression length '%jd' is less than expected length '%jd'"_warn_en_US,
+ "Actual argument variable length '%jd' does not match the expected length '%jd'"_err_en_US,
*actualLength, *dummyLength);
- auto converted{ConvertToType(dummyType.type(), std::move(actual))};
- CHECK(converted);
- actual = std::move(*converted);
- actualType.set_LEN(SubscriptIntExpr{*dummyLength});
+ } else if (*actualLength < *dummyLength) {
+ if (evaluate::IsVariable(actual)) {
+ messages.Say(
+ "Actual argument variable length '%jd' is less than expected length '%jd'"_warn_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(dummy.type.type(), std::move(actual))};
+ CHECK(converted);
+ actual = std::move(*converted);
+ actualType.set_LEN(SubscriptIntExpr{*dummyLength});
+ }
}
}
}
@@ -180,7 +194,7 @@ static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy,
// Basic type & rank checking
parser::ContextualMessages &messages{context.messages()};
- CheckCharacterActual(actual, dummy.type, actualType, context, messages);
+ CheckCharacterActual(actual, dummy, actualType, context, messages);
if (allowActualArgumentConversions) {
ConvertIntegerActual(actual, dummy.type, actualType, messages);
}
@@ -1154,7 +1168,7 @@ bool CheckArguments(const characteristics::Procedure &proc,
auto buffer{CheckExplicitInterface(
proc, actuals, context, &scope, intrinsic, true)};
if (!buffer.empty()) {
- if (treatingExternalAsImplicit && !buffer.empty()) {
+ if (treatingExternalAsImplicit) {
if (auto *msg{messages.Say(
"If the procedure's interface were explicit, this reference would be in error"_warn_en_US)}) {
buffer.AttachTo(*msg, parser::Severity::Because);
diff --git a/flang/test/Lower/character-substrings.f90 b/flang/test/Lower/character-substrings.f90
index ad07eda29d2ab..9015af1258b8e 100644
--- a/flang/test/Lower/character-substrings.f90
+++ b/flang/test/Lower/character-substrings.f90
@@ -40,7 +40,7 @@ end subroutine scalar_substring_embox
! CHECK: %[[VAL_8:.*]] = arith.subi %[[VAL_7]], %[[VAL_4]] : index
! CHECK: %[[VAL_9:.*]] = fir.shape %[[VAL_3]] : (index) -> !fir.shape<1>
! CHECK: %[[VAL_10:.*]] = arith.constant 5 : i64
-! CHECK: %[[VAL_11:.*]] = arith.constant 7 : i64
+! CHECK: %[[VAL_11:.*]] = arith.constant 5 : i64
! CHECK: %[[VAL_12:.*]] = arith.constant 1 : i64
! CHECK: %[[VAL_13:.*]] = arith.subi %[[VAL_10]], %[[VAL_12]] : i64
! CHECK: %[[VAL_14:.*]] = arith.constant 0 : i64
@@ -63,7 +63,7 @@ end subroutine s
character(7) arr(4)
- call s(arr(:)(5:7))
+ call s(arr(:)(5:5))
end subroutine array_substring_embox
! CHECK-LABEL: func @_QPsubstring_assignment(
diff --git a/flang/test/Semantics/call33.f90 b/flang/test/Semantics/call33.f90
new file mode 100644
index 0000000000000..7fad50cbbe7fa
--- /dev/null
+++ b/flang/test/Semantics/call33.f90
@@ -0,0 +1,54 @@
+! RUN: %python %S/test_errors.py %s %flang_fc1 -Werror
+module m
+ contains
+ subroutine s1(x)
+ character(3) :: x
+ end
+ subroutine s2(x)
+ character(3) :: x(1)
+ end
+ subroutine s3(x)
+ character(3) :: x(:)
+ end
+ subroutine s4(x)
+ character(3) :: x(..)
+ end
+ subroutine s5(x)
+ character(3), allocatable :: x
+ end
+ subroutine s6(x)
+ character(3), pointer :: x
+ end
+end
+
+program test
+ use m
+ character(2) short, shortarr(1)
+ character(2), allocatable :: shortalloc
+ character(2), pointer :: shortptr
+ character(4) long, longarr(1)
+ character(4), allocatable :: longalloc
+ character(4), pointer :: longptr
+ !WARNING: Actual argument variable length '2' is less than expected length '3'
+ call s1(short)
+ !WARNING: Actual argument variable length '2' is less than expected length '3'
+ call s2(shortarr)
+ !ERROR: Actual argument variable length '2' does not match the expected length '3'
+ call s3(shortarr)
+ !ERROR: Actual argument variable length '2' does not match the expected length '3'
+ call s4(shortarr)
+ !ERROR: Actual argument variable length '2' does not match the expected length '3'
+ call s5(shortalloc)
+ !ERROR: Actual argument variable length '2' does not match the expected length '3'
+ call s6(shortptr)
+ call s1(long) ! ok
+ call s2(longarr) ! ok
+ !ERROR: Actual argument variable length '4' does not match the expected length '3'
+ call s3(longarr)
+ !ERROR: Actual argument variable length '4' does not match the expected length '3'
+ call s4(longarr)
+ !ERROR: Actual argument variable length '4' does not match the expected length '3'
+ call s5(longalloc)
+ !ERROR: Actual argument variable length '4' does not match the expected length '3'
+ call s6(longptr)
+end
More information about the flang-commits
mailing list