diff --git a/flang/include/flang/Common/Fortran-features.h b/flang/include/flang/Common/Fortran-features.h index 74edbe44fdbb1c..c6ab846cce2fc0 100644 --- a/flang/include/flang/Common/Fortran-features.h +++ b/flang/include/flang/Common/Fortran-features.h @@ -53,7 +53,7 @@ ENUM_CLASS(LanguageFeature, BackslashEscapes, OldDebugLines, NonBindCInteroperability, CudaManaged, CudaUnified, PolymorphicActualAllocatableOrPointerToMonomorphicDummy, RelaxedPureDummy, UndefinableAsynchronousOrVolatileActual, AutomaticInMainProgram, PrintCptr, - SavedLocalInSpecExpr, PrintNamelist) + SavedLocalInSpecExpr, PrintNamelist, AssumedRankPassedToNonAssumedRank) // Portability and suspicious usage warnings ENUM_CLASS(UsageWarning, Portability, PointerToUndefinable, diff --git a/flang/lib/Common/Fortran-features.cpp b/flang/lib/Common/Fortran-features.cpp index fff796e42552a5..f47a4f17a6ba48 100644 --- a/flang/lib/Common/Fortran-features.cpp +++ b/flang/lib/Common/Fortran-features.cpp @@ -30,6 +30,8 @@ LanguageFeatureControl::LanguageFeatureControl() { disable_.set(LanguageFeature::LogicalAbbreviations); disable_.set(LanguageFeature::XOROperator); disable_.set(LanguageFeature::OldStyleParameter); + // Possibly an accidental "feature" of nvfortran. + disable_.set(LanguageFeature::AssumedRankPassedToNonAssumedRank); // These warnings are enabled by default, but only because they used // to be unconditional. TODO: prune this list warnLanguage_.set(LanguageFeature::ExponentMatchingKindParam); diff --git a/flang/lib/Semantics/check-call.cpp b/flang/lib/Semantics/check-call.cpp index a161d2bdf9dbb8..597c280a6df8bc 100644 --- a/flang/lib/Semantics/check-call.cpp +++ b/flang/lib/Semantics/check-call.cpp @@ -135,6 +135,20 @@ static void CheckCharacterActual(evaluate::Expr &actual, dummy.type.type().kind() == actualType.type().kind() && !dummy.attrs.test( characteristics::DummyDataObject::Attr::DeducedFromActual)) { + bool actualIsAssumedRank{evaluate::IsAssumedRank(actual)}; + if (actualIsAssumedRank && + !dummy.type.attrs().test( + characteristics::TypeAndShape::Attr::AssumedRank)) { + if (!context.languageFeatures().IsEnabled( + common::LanguageFeature::AssumedRankPassedToNonAssumedRank)) { + messages.Say( + "Assumed-rank character array may not be associated with a dummy argument that is not assumed-rank"_err_en_US); + } else { + context.Warn(common::LanguageFeature::AssumedRankPassedToNonAssumedRank, + messages.at(), + "Assumed-rank character array should not be associated with a dummy argument that is not assumed-rank"_port_en_US); + } + } if (dummy.type.LEN() && actualType.LEN()) { evaluate::FoldingContext &foldingContext{context.foldingContext()}; auto dummyLength{ @@ -148,7 +162,7 @@ static void CheckCharacterActual(evaluate::Expr &actual, if (auto dummySize{evaluate::ToInt64(evaluate::Fold( foldingContext, evaluate::GetSize(dummy.type.shape())))}) { auto dummyChars{*dummySize * *dummyLength}; - if (actualType.Rank() == 0) { + if (actualType.Rank() == 0 && !actualIsAssumedRank) { evaluate::DesignatorFolder folder{ context.foldingContext(), /*getLastComponent=*/true}; if (auto actualOffset{folder.FoldDesignator(actual)}) { @@ -602,7 +616,18 @@ static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy, characteristics::DummyDataObject::Attr::DeducedFromActual)) { if (auto dummySize{evaluate::ToInt64(evaluate::Fold( foldingContext, evaluate::GetSize(dummy.type.shape())))}) { - if (actualRank == 0 && !actualIsAssumedRank) { + if (actualIsAssumedRank) { + if (!context.languageFeatures().IsEnabled( + common::LanguageFeature::AssumedRankPassedToNonAssumedRank)) { + messages.Say( + "Assumed-rank array may not be associated with a dummy argument that is not assumed-rank"_err_en_US); + } else { + context.Warn( + common::LanguageFeature::AssumedRankPassedToNonAssumedRank, + messages.at(), + "Assumed-rank array should not be associated with a dummy argument that is not assumed-rank"_port_en_US); + } + } else if (actualRank == 0) { if (evaluate::IsArrayElement(actual)) { // Actual argument is a scalar array element evaluate::DesignatorFolder folder{ @@ -643,7 +668,7 @@ static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy, } } } - } else { // actualRank > 0 || actualIsAssumedRank + } else { if (auto actualSize{evaluate::ToInt64(evaluate::Fold( foldingContext, evaluate::GetSize(actualType.shape())))}; actualSize && *actualSize < *dummySize) { diff --git a/flang/test/Semantics/call38.f90 b/flang/test/Semantics/call38.f90 index 0e7ebcdfe9df53..34aae6b8b18357 100644 --- a/flang/test/Semantics/call38.f90 +++ b/flang/test/Semantics/call38.f90 @@ -522,3 +522,25 @@ subroutine test call scalar('a') end end + +subroutine bug114080(arg, contigArg) + character(*) :: arg(..) + character(*), contiguous :: contigArg(..) + interface + subroutine sub1(arg1) bind(c) + character(1) :: arg1(2,4) + end subroutine + end interface + !ERROR: Assumed-rank character array may not be associated with a dummy argument that is not assumed-rank + call sub1(arg) + !ERROR: Assumed-rank character array may not be associated with a dummy argument that is not assumed-rank + call sub1(contigArg) + !ERROR: Assumed-rank character array may not be associated with a dummy argument that is not assumed-rank + call sub2(arg) + !ERROR: Assumed-rank character array may not be associated with a dummy argument that is not assumed-rank + call sub2(contigArg) + contains + subroutine sub2(arg2) + character(*) :: arg2(10) + end subroutine sub2 +end subroutine