[flang-commits] [flang] 6ceba01 - [flang] More actual argument warnings
Peter Klausler via flang-commits
flang-commits at lists.llvm.org
Mon Jul 3 12:49:24 PDT 2023
Author: Peter Klausler
Date: 2023-07-03T12:49:17-07:00
New Revision: 6ceba01a4d5c4482885348c71294d89f48579b51
URL: https://github.com/llvm/llvm-project/commit/6ceba01a4d5c4482885348c71294d89f48579b51
DIFF: https://github.com/llvm/llvm-project/commit/6ceba01a4d5c4482885348c71294d89f48579b51.diff
LOG: [flang] More actual argument warnings
Emit warnings when CHARACTER lengths or array sizes of actual
and dummy arguments mismatch in risky ways.
Differential Revision: https://reviews.llvm.org/D154370
Added:
flang/test/Semantics/call37.f90
Modified:
flang/lib/Evaluate/characteristics.cpp
flang/lib/Semantics/check-call.cpp
flang/test/Semantics/ignore_tkr01.f90
Removed:
################################################################################
diff --git a/flang/lib/Evaluate/characteristics.cpp b/flang/lib/Evaluate/characteristics.cpp
index b22025c8844bc1..1bd86664c875f7 100644
--- a/flang/lib/Evaluate/characteristics.cpp
+++ b/flang/lib/Evaluate/characteristics.cpp
@@ -303,6 +303,32 @@ bool DummyDataObject::IsCompatibleWith(
}
return false;
}
+ if (type.type().category() == TypeCategory::Character) {
+ if (actual.type.type().IsAssumedLengthCharacter() !=
+ type.type().IsAssumedLengthCharacter()) {
+ if (whyNot) {
+ *whyNot = "assumed-length character vs explicit-length character";
+ }
+ return false;
+ }
+ if (!type.type().IsAssumedLengthCharacter() && type.LEN() &&
+ actual.type.LEN()) {
+ auto len{ToInt64(*type.LEN())};
+ auto actualLen{ToInt64(*actual.type.LEN())};
+ if (len.has_value() != actualLen.has_value()) {
+ if (whyNot) {
+ *whyNot = "constant-length vs non-constant-length character dummy "
+ "arguments";
+ }
+ return false;
+ } else if (len && *len != *actualLen) {
+ if (whyNot) {
+ *whyNot = "character dummy arguments with distinct lengths";
+ }
+ return false;
+ }
+ }
+ }
if (attrs != actual.attrs) {
if (whyNot) {
*whyNot = "incompatible dummy data object attributes";
diff --git a/flang/lib/Semantics/check-call.cpp b/flang/lib/Semantics/check-call.cpp
index 09ce7dab13e84f..ad6359c356b2cd 100644
--- a/flang/lib/Semantics/check-call.cpp
+++ b/flang/lib/Semantics/check-call.cpp
@@ -196,7 +196,7 @@ static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy,
characteristics::TypeAndShape &actualType, bool isElemental,
SemanticsContext &context, evaluate::FoldingContext &foldingContext,
const Scope *scope, const evaluate::SpecificIntrinsic *intrinsic,
- bool allowActualArgumentConversions,
+ bool allowActualArgumentConversions, bool extentErrors,
const characteristics::Procedure &procedure) {
// Basic type & rank checking
@@ -418,6 +418,24 @@ static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy,
dummyName);
}
}
+ } else if (actualRank > 0 && dummy.type.Rank() > 0 &&
+ actualType.type().category() != TypeCategory::Character) {
+ // Both arrays, dummy is not assumed-shape, not character
+ if (auto dummySize{evaluate::ToInt64(evaluate::Fold(foldingContext,
+ evaluate::GetSize(evaluate::Shape{dummy.type.shape()})))}) {
+ if (auto actualSize{evaluate::ToInt64(evaluate::Fold(foldingContext,
+ evaluate::GetSize(evaluate::Shape{actualType.shape()})))}) {
+ if (*actualSize < *dummySize) {
+ auto msg{
+ "Actual argument array is smaller (%jd element(s)) than %s array (%jd)"_warn_en_US};
+ if (extentErrors) {
+ msg.set_severity(parser::Severity::Error);
+ }
+ messages.Say(std::move(msg), static_cast<std::intmax_t>(*actualSize),
+ dummyName, static_cast<std::intmax_t>(*dummySize));
+ }
+ }
+ }
}
if (actualLastObject && actualLastObject->IsCoarray() &&
IsAllocatable(*actualLastSymbol) && dummy.intent == common::Intent::Out &&
@@ -853,7 +871,7 @@ static void CheckExplicitInterfaceArg(evaluate::ActualArgument &arg,
const characteristics::DummyArgument &dummy,
const characteristics::Procedure &proc, SemanticsContext &context,
const Scope *scope, const evaluate::SpecificIntrinsic *intrinsic,
- bool allowActualArgumentConversions) {
+ bool allowActualArgumentConversions, bool extentErrors) {
evaluate::FoldingContext &foldingContext{context.foldingContext()};
auto &messages{foldingContext.messages()};
std::string dummyName{"dummy argument"};
@@ -885,7 +903,7 @@ static void CheckExplicitInterfaceArg(evaluate::ActualArgument &arg,
object.type.Rank() == 0 && proc.IsElemental()};
CheckExplicitDataArg(object, dummyName, *expr, *type,
isElemental, context, foldingContext, scope, intrinsic,
- allowActualArgumentConversions, proc);
+ allowActualArgumentConversions, extentErrors, proc);
} else if (object.type.type().IsTypelessIntrinsicArgument() &&
IsBOZLiteral(*expr)) {
// ok
@@ -1275,7 +1293,7 @@ static parser::Messages CheckExplicitInterface(
const characteristics::Procedure &proc, evaluate::ActualArguments &actuals,
SemanticsContext &context, const Scope *scope,
const evaluate::SpecificIntrinsic *intrinsic,
- bool allowActualArgumentConversions) {
+ bool allowActualArgumentConversions, bool extentErrors) {
evaluate::FoldingContext &foldingContext{context.foldingContext()};
parser::ContextualMessages &messages{foldingContext.messages()};
parser::Messages buffer;
@@ -1289,7 +1307,7 @@ static parser::Messages CheckExplicitInterface(
const auto &dummy{proc.dummyArguments.at(index++)};
if (actual) {
CheckExplicitInterfaceArg(*actual, dummy, proc, context, scope, intrinsic,
- allowActualArgumentConversions);
+ allowActualArgumentConversions, extentErrors);
} else if (!dummy.IsOptional()) {
if (dummy.name.empty()) {
messages.Say(
@@ -1318,7 +1336,7 @@ bool CheckInterfaceForGeneric(const characteristics::Procedure &proc,
bool allowActualArgumentConversions) {
return proc.HasExplicitInterface() &&
!CheckExplicitInterface(proc, actuals, context, nullptr, nullptr,
- allowActualArgumentConversions)
+ allowActualArgumentConversions, false /*extentErrors*/)
.AnyFatalError();
}
@@ -1399,7 +1417,7 @@ bool CheckArguments(const characteristics::Procedure &proc,
}
if (explicitInterface) {
auto buffer{CheckExplicitInterface(
- proc, actuals, context, &scope, intrinsic, true)};
+ proc, actuals, context, &scope, intrinsic, true, true)};
if (!buffer.empty()) {
if (treatingExternalAsImplicit) {
if (auto *msg{messages.Say(
diff --git a/flang/test/Semantics/call37.f90 b/flang/test/Semantics/call37.f90
new file mode 100644
index 00000000000000..6018b8697ad5fb
--- /dev/null
+++ b/flang/test/Semantics/call37.f90
@@ -0,0 +1,72 @@
+! RUN: %python %S/test_errors.py %s %flang_fc1 -pedantic -Werror
+! Test warnings on mismatching interfaces involvingCHARACTER arguments
+subroutine constLen(s)
+ character(len = 1) s
+end
+subroutine assumedLen(s)
+ character(len = *) s
+end
+subroutine exprLen(s)
+ common n
+ character(len = n) s
+end
+
+module m0
+ interface ! these are all OK
+ subroutine constLen(s)
+ character(len=1) s
+ end
+ subroutine assumedLen(s)
+ character(len=*) s
+ end
+ subroutine exprLen(s)
+ common n
+ character(len=n) s
+ end
+ end interface
+end
+
+module m1
+ interface
+ !WARNING: The global subprogram 'constlen' is not compatible with its local procedure declaration (incompatible dummy argument #1: incompatible dummy data object types: CHARACTER(KIND=1,LEN=1_8) vs CHARACTER(KIND=1,LEN=2_8))
+ subroutine constLen(s)
+ character(len=2) s
+ end
+ !WARNING: The global subprogram 'assumedlen' is not compatible with its local procedure declaration (incompatible dummy argument #1: assumed-length character vs explicit-length character)
+ subroutine assumedLen(s)
+ character(len=2) s
+ end
+ !WARNING: The global subprogram 'exprlen' is not compatible with its local procedure declaration (incompatible dummy argument #1: constant-length vs non-constant-length character dummy arguments)
+ subroutine exprLen(s)
+ character(len=2) s
+ end
+ end interface
+end
+
+module m2
+ interface
+ !WARNING: The global subprogram 'constlen' is not compatible with its local procedure declaration (incompatible dummy argument #1: assumed-length character vs explicit-length character)
+ subroutine constLen(s)
+ character(len=*) s
+ end
+ !WARNING: The global subprogram 'exprlen' is not compatible with its local procedure declaration (incompatible dummy argument #1: assumed-length character vs explicit-length character)
+ subroutine exprLen(s)
+ character(len=*) s
+ end
+ end interface
+end
+
+module m3
+ interface
+ !WARNING: The global subprogram 'constlen' is not compatible with its local procedure declaration (incompatible dummy argument #1: constant-length vs non-constant-length character dummy arguments)
+ subroutine constLen(s)
+ common n
+ character(len=n) s
+ end
+ !WARNING: The global subprogram 'assumedlen' is not compatible with its local procedure declaration (incompatible dummy argument #1: assumed-length character vs explicit-length character)
+ subroutine assumedLen(s)
+ common n
+ character(len=n) s
+ end
+ end interface
+end
diff --git a/flang/test/Semantics/ignore_tkr01.f90 b/flang/test/Semantics/ignore_tkr01.f90
index 72c6bf3334a5e3..39676e8b6129b5 100644
--- a/flang/test/Semantics/ignore_tkr01.f90
+++ b/flang/test/Semantics/ignore_tkr01.f90
@@ -201,6 +201,7 @@ program test
call t4(x)
call t4(m)
call t5(x)
+ !WARNING: Actual argument array is smaller (2 element(s)) than dummy argument 'm=' array (4)
call t5(a)
call t6(1)
More information about the flang-commits
mailing list