diff --git a/flang/lib/Evaluate/characteristics.cpp b/flang/lib/Evaluate/characteristics.cpp --- a/flang/lib/Evaluate/characteristics.cpp +++ b/flang/lib/Evaluate/characteristics.cpp @@ -303,6 +303,32 @@ } 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 --- a/flang/lib/Semantics/check-call.cpp +++ b/flang/lib/Semantics/check-call.cpp @@ -196,7 +196,7 @@ 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 @@ 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(*actualSize), + dummyName, static_cast(*dummySize)); + } + } + } } if (actualLastObject && actualLastObject->IsCoarray() && IsAllocatable(*actualLastSymbol) && dummy.intent == common::Intent::Out && @@ -853,7 +871,7 @@ 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 @@ 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 @@ 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 @@ 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 allowActualArgumentConversions) { return proc.HasExplicitInterface() && !CheckExplicitInterface(proc, actuals, context, nullptr, nullptr, - allowActualArgumentConversions) + allowActualArgumentConversions, false /*extentErrors*/) .AnyFatalError(); } @@ -1399,7 +1417,7 @@ } 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 --- /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 --- a/flang/test/Semantics/ignore_tkr01.f90 +++ b/flang/test/Semantics/ignore_tkr01.f90 @@ -201,6 +201,7 @@ 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)