From ca9d6be0e40735d8367657ca3290e5ef86ce4d2b Mon Sep 17 00:00:00 2001 From: peter klausler Date: Wed, 16 Oct 2019 15:36:54 -0700 Subject: [PATCH] [flang] Pad short CHARACTER actual arguments Original-commit: flang-compiler/f18@b9c890ca9cc3e07967ece4dee739ac8059bb9388 Reviewed-on: https://github.com/flang-compiler/f18/pull/782 Tree-same-pre-rewrite: false --- flang/documentation/Extensions.md | 3 +++ flang/lib/evaluate/characteristics.cc | 15 +++-------- flang/lib/evaluate/characteristics.h | 3 ++- flang/lib/evaluate/check-expression.cc | 2 ++ flang/lib/semantics/check-call.cc | 37 +++++++++++++++++++++----- flang/lib/semantics/symbol.h | 1 + flang/test/semantics/call03.f90 | 31 +++++++++++---------- 7 files changed, 57 insertions(+), 35 deletions(-) diff --git a/flang/documentation/Extensions.md b/flang/documentation/Extensions.md index 745a64a0b1fa..d2b82e571543 100644 --- a/flang/documentation/Extensions.md +++ b/flang/documentation/Extensions.md @@ -103,6 +103,9 @@ Extensions, deletions, and legacy features supported by default * Specific intrinsics AMAX0, AMAX1, AMIN0, AMIN1, DMAX1, DMIN1, MAX0, MAX1, MIN0, and MIN1 accept more argument types than specified. They are replaced by the related generics followed by conversions to the specified result types. +* When a scalar CHARACTER actual argument of the same kind is known to + have a length shorter than the associated dummy argument, it is extended + on the right with blanks, similar to assignment. Extensions supported when enabled by options -------------------------------------------- diff --git a/flang/lib/evaluate/characteristics.cc b/flang/lib/evaluate/characteristics.cc index a17789f7911c..f8692c58a49c 100644 --- a/flang/lib/evaluate/characteristics.cc +++ b/flang/lib/evaluate/characteristics.cc @@ -136,18 +136,6 @@ bool TypeAndShape::IsCompatibleWith(parser::ContextualMessages &messages, type_.AsFortran()); return false; } - // When associating with a character scalar, length must not be greater. - if (GetRank(that.shape_) == 0) { - if (auto myLEN{ToInt64(LEN())}) { - if (auto thatLEN{ToInt64(len)}) { - if (*thatLEN < *myLEN) { - messages.Say( - "Actual length '%jd' is less than expected length '%jd'"_err_en_US, - *thatLEN, *myLEN); - } - } - } - } return isElemental || CheckConformance(messages, shape_, that.shape_, thisDesc, thatDesc); } @@ -164,6 +152,9 @@ void TypeAndShape::AcquireShape(const semantics::ObjectEntityDetails &object) { if (object.IsAssumedSize()) { attrs_.set(Attr::AssumedSize); } + if (object.IsDeferredShape()) { + attrs_.set(Attr::DeferredShape); + } if (object.IsCoarray()) { attrs_.set(Attr::Coarray); } diff --git a/flang/lib/evaluate/characteristics.h b/flang/lib/evaluate/characteristics.h index a04779b3b28c..eaeaaa534508 100644 --- a/flang/lib/evaluate/characteristics.h +++ b/flang/lib/evaluate/characteristics.h @@ -54,7 +54,8 @@ bool DistinguishableOpOrAssign(const Procedure &, const Procedure &); class TypeAndShape { public: - ENUM_CLASS(Attr, AssumedRank, AssumedShape, AssumedSize, Coarray) + ENUM_CLASS( + Attr, AssumedRank, AssumedShape, AssumedSize, DeferredShape, Coarray) using Attrs = common::EnumSet; explicit TypeAndShape(DynamicType t) : type_{t} { AcquireLEN(); } diff --git a/flang/lib/evaluate/check-expression.cc b/flang/lib/evaluate/check-expression.cc index d368327c01c2..4b284e71440b 100644 --- a/flang/lib/evaluate/check-expression.cc +++ b/flang/lib/evaluate/check-expression.cc @@ -275,6 +275,8 @@ public: return false; } else if (const auto *details{ symbol.detailsIf()}) { + // N.B. ALLOCATABLEs are deferred shape, not assumed, and + // are obviously contiguous. return !details->IsAssumedShape() && !details->IsAssumedRank(); } else { return false; diff --git a/flang/lib/semantics/check-call.cc b/flang/lib/semantics/check-call.cc index 32edfa289119..77b4ad0ebf7a 100644 --- a/flang/lib/semantics/check-call.cc +++ b/flang/lib/semantics/check-call.cc @@ -110,9 +110,33 @@ static void InspectType( } } +// When scalar CHARACTER actual arguments are known to be short, +// we extend them on the right with spaces and a warning. +static void PadShortCharacterActual(evaluate::Expr &actual, + const characteristics::TypeAndShape &dummyType, + const characteristics::TypeAndShape &actualType, + parser::ContextualMessages &messages) { + if (dummyType.type().category() == TypeCategory::Character && + actualType.type().category() == TypeCategory::Character && + dummyType.type().kind() == actualType.type().kind() && + GetRank(actualType.shape()) == 0) { + if (auto dummyLEN{ToInt64(dummyType.LEN())}) { + if (auto actualLEN{ToInt64(actualType.LEN())}) { + if (*actualLEN < *dummyLEN) { + messages.Say( + "Actual length '%jd' is less than expected length '%jd'"_en_US, + *actualLEN, *dummyLEN); + auto converted{ConvertToType(dummyType.type(), std::move(actual))}; + CHECK(converted.has_value()); + actual = std::move(*converted); + } + } + } + } +} + static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy, - const std::string &dummyName, - const evaluate::Expr &actual, + const std::string &dummyName, evaluate::Expr &actual, const characteristics::TypeAndShape &actualType, const characteristics::Procedure &proc, evaluate::FoldingContext &context, const Scope &scope) { @@ -122,6 +146,7 @@ static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy, int dummyRank{evaluate::GetRank(dummy.type.shape())}; bool isElemental{dummyRank == 0 && proc.attrs.test(characteristics::Procedure::Attr::Elemental)}; + PadShortCharacterActual(actual, dummy.type, actualType, messages); dummy.type.IsCompatibleWith( messages, actualType, "dummy argument", "actual argument", isElemental); @@ -283,8 +308,8 @@ static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy, WhyNotModifiable(messages.at(), actual, scope, vectorSubscriptIsOk)}; if (why.get() != nullptr) { if (auto *msg{messages.Say( - "Actual argument associated with %s dummy must be definable"_err_en_US, - reason)}) { + "Actual argument associated with %s %s must be definable"_err_en_US, + reason, dummyName)}) { msg->Attach(std::move(why)); } } @@ -320,7 +345,7 @@ static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy, } } -static void CheckExplicitInterfaceArg(const evaluate::ActualArgument &arg, +static void CheckExplicitInterfaceArg(evaluate::ActualArgument &arg, const characteristics::DummyArgument &dummy, const characteristics::Procedure &proc, evaluate::FoldingContext &context, const Scope &scope) { @@ -332,7 +357,7 @@ static void CheckExplicitInterfaceArg(const evaluate::ActualArgument &arg, std::visit( common::visitors{ [&](const characteristics::DummyDataObject &object) { - if (const auto *expr{arg.UnwrapExpr()}) { + if (auto *expr{arg.UnwrapExpr()}) { if (auto type{characteristics::TypeAndShape::Characterize( *expr, context)}) { CheckExplicitDataArg( diff --git a/flang/lib/semantics/symbol.h b/flang/lib/semantics/symbol.h index 19e3d88fb649..801158c6e4f9 100644 --- a/flang/lib/semantics/symbol.h +++ b/flang/lib/semantics/symbol.h @@ -585,6 +585,7 @@ public: [](const GenericDetails &) { return 0; /*TODO*/ }, + [](const ProcBindingDetails &x) { return x.symbol().Rank(); }, [](const UseDetails &x) { return x.symbol().Rank(); }, [](const HostAssocDetails &x) { return x.symbol().Rank(); }, [](const ObjectEntityDetails &oed) { return oed.shape().Rank(); }, diff --git a/flang/test/semantics/call03.f90 b/flang/test/semantics/call03.f90 index d8e76d6128ee..c22593be359b 100644 --- a/flang/test/semantics/call03.f90 +++ b/flang/test/semantics/call03.f90 @@ -131,14 +131,13 @@ module m01 end subroutine subroutine ch2(x) - character(2), intent(in) :: x + character(2), intent(in out) :: x end subroutine subroutine test06 ! 15.5.2.4(4) character :: ch1 - !ERROR: Actual length '1' is less than expected length '2' + ! The actual argument is converted to a padded expression. + !ERROR: Actual argument associated with INTENT(IN OUT) dummy argument 'x=' must be definable call ch2(ch1) - !ERROR: Actual length '1' is less than expected length '2' - call ch2(' ') end subroutine subroutine out01(x) @@ -194,23 +193,23 @@ module m01 real, intent(in) :: in real :: x x = 0. - !ERROR: Actual argument associated with INTENT(OUT) dummy must be definable + !ERROR: Actual argument associated with INTENT(OUT) dummy argument 'x=' must be definable call intentout(in) - !ERROR: Actual argument associated with INTENT(OUT) dummy must be definable + !ERROR: Actual argument associated with INTENT(OUT) dummy argument 'x=' must be definable call intentout(3.14159) - !ERROR: Actual argument associated with INTENT(OUT) dummy must be definable + !ERROR: Actual argument associated with INTENT(OUT) dummy argument 'x=' must be definable call intentout(in + 1.) call intentout(x) ! ok - !ERROR: Actual argument associated with INTENT(OUT) dummy must be definable + !ERROR: Actual argument associated with INTENT(OUT) dummy argument 'x=' must be definable call intentout((x)) - !ERROR: Actual argument associated with INTENT(IN OUT) dummy must be definable + !ERROR: Actual argument associated with INTENT(IN OUT) dummy argument 'x=' must be definable call intentinout(in) - !ERROR: Actual argument associated with INTENT(IN OUT) dummy must be definable + !ERROR: Actual argument associated with INTENT(IN OUT) dummy argument 'x=' must be definable call intentinout(3.14159) - !ERROR: Actual argument associated with INTENT(IN OUT) dummy must be definable + !ERROR: Actual argument associated with INTENT(IN OUT) dummy argument 'x=' must be definable call intentinout(in + 1.) call intentinout(x) ! ok - !ERROR: Actual argument associated with INTENT(IN OUT) dummy must be definable + !ERROR: Actual argument associated with INTENT(IN OUT) dummy argument 'x=' must be definable call intentinout((x)) end subroutine @@ -218,13 +217,13 @@ module m01 real :: a(1) integer :: j(1) j(1) = 1 - !ERROR: Actual argument associated with INTENT(OUT) dummy must be definable + !ERROR: Actual argument associated with INTENT(OUT) dummy argument 'x=' must be definable call intentout(a(j)) - !ERROR: Actual argument associated with INTENT(IN OUT) dummy must be definable + !ERROR: Actual argument associated with INTENT(IN OUT) dummy argument 'x=' must be definable call intentinout(a(j)) - !ERROR: Actual argument associated with ASYNCHRONOUS dummy must be definable + !ERROR: Actual argument associated with ASYNCHRONOUS dummy argument 'x=' must be definable call asynchronous(a(j)) - !ERROR: Actual argument associated with VOLATILE dummy must be definable + !ERROR: Actual argument associated with VOLATILE dummy argument 'x=' must be definable call volatile(a(j)) end subroutine