Skip to content

Commit

Permalink
[flang] Pad short CHARACTER actual arguments
Browse files Browse the repository at this point in the history 
Original-commit: flang-compiler/f18@b9c890c
Reviewed-on: flang-compiler/f18#782
Tree-same-pre-rewrite: false
  • Loading branch information
@klausler
klausler committed Oct 16, 2019
1 parent 4abdc30 commit ca9d6be
Show file tree
Hide file tree
Showing 7 changed files with 57 additions and 35 deletions.
3 changes: 3 additions & 0 deletions flang/documentation/Extensions.md
View file
Expand Up @@ -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
--------------------------------------------
Expand Down
15 changes: 3 additions & 12 deletions flang/lib/evaluate/characteristics.cc
View file
Expand Up @@ -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);
}
Expand All @@ -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);
}
Expand Down
3 changes: 2 additions & 1 deletion flang/lib/evaluate/characteristics.h
View file
Expand Up @@ -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<Attr, Attr_enumSize>;

explicit TypeAndShape(DynamicType t) : type_{t} { AcquireLEN(); }
Expand Down
2 changes: 2 additions & 0 deletions flang/lib/evaluate/check-expression.cc
View file
Expand Up @@ -275,6 +275,8 @@ class IsSimplyContiguousHelper
return false;
} else if (const auto *details{
symbol.detailsIf<semantics::ObjectEntityDetails>()}) {
// N.B. ALLOCATABLEs are deferred shape, not assumed, and
// are obviously contiguous.
return !details->IsAssumedShape() && !details->IsAssumedRank();
} else {
return false;
Expand Down
37 changes: 31 additions & 6 deletions flang/lib/semantics/check-call.cc
View file
Expand Up @@ -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<evaluate::SomeType> &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<evaluate::SomeType> &actual,
const std::string &dummyName, evaluate::Expr<evaluate::SomeType> &actual,
const characteristics::TypeAndShape &actualType,
const characteristics::Procedure &proc, evaluate::FoldingContext &context,
const Scope &scope) {
Expand All @@ -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);

Expand Down Expand Up @@ -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));
}
}
Expand Down Expand Up @@ -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) {
Expand All @@ -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(
Expand Down
1 change: 1 addition & 0 deletions flang/lib/semantics/symbol.h
View file
Expand Up @@ -585,6 +585,7 @@ class Symbol {
[](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(); },
Expand Down
31 changes: 15 additions & 16 deletions flang/test/semantics/call03.f90
View file
Expand Up @@ -131,14 +131,13 @@ subroutine test05 ! 15.5.2.4(2)
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)
Expand Down Expand Up @@ -194,37 +193,37 @@ subroutine test11(in) ! C15.5.2.4(20)
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

subroutine test12 ! 15.5.2.4(21)
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

Expand Down

0 comments on commit ca9d6be

Please sign in to comment.