From b71355ca1e6e2a10fd99afd54462564a8548ff90 Mon Sep 17 00:00:00 2001 From: peter klausler Date: Tue, 8 Oct 2019 15:21:09 -0700 Subject: [PATCH] [flang] checkpoint checkpoint checkpoint Original-commit: flang-compiler/f18@99d12a7215089b4aefdaef39a2407b84538c29ef Reviewed-on: https://github.com/flang-compiler/f18/pull/782 Tree-same-pre-rewrite: false --- flang/lib/common/idioms.h | 2 +- flang/lib/evaluate/characteristics.cc | 118 ++++++++++++++---- flang/lib/evaluate/characteristics.h | 33 ++--- flang/lib/evaluate/check-call.cc | 169 +++++++++++++++++++++++++- flang/lib/evaluate/common.h | 19 +-- flang/lib/evaluate/fold.cc | 14 +-- flang/lib/evaluate/formatting.cc | 2 +- flang/lib/evaluate/intrinsics.cc | 40 +++--- flang/lib/evaluate/shape.cc | 144 ++++++++++++---------- flang/lib/evaluate/shape.h | 22 ++-- flang/lib/evaluate/tools.cc | 42 +++++++ flang/lib/evaluate/tools.h | 14 +-- flang/lib/evaluate/type.cc | 26 ++-- flang/lib/evaluate/type.h | 7 +- flang/lib/semantics/semantics.cc | 5 +- flang/lib/semantics/semantics.h | 2 +- flang/test/evaluate/expression.cc | 4 +- flang/test/evaluate/folding.cc | 7 +- flang/test/evaluate/intrinsics.cc | 91 ++++++++------ flang/test/semantics/CMakeLists.txt | 1 + flang/test/semantics/call03.f90 | 73 ++++++----- 21 files changed, 569 insertions(+), 266 deletions(-) diff --git a/flang/lib/common/idioms.h b/flang/lib/common/idioms.h index 7611e918ba3c..4a48afdd0c0d 100644 --- a/flang/lib/common/idioms.h +++ b/flang/lib/common/idioms.h @@ -144,7 +144,7 @@ template struct ListItemCount { // Check that a pointer is non-null and dereference it #define DEREF(p) Fortran::common::Deref(p, __FILE__, __LINE__) -template T &Deref(T *p, const char *file, int line) { +template constexpr T &Deref(T *p, const char *file, int line) { if (p == nullptr) { Fortran::common::die("nullptr dereference at %s(%d)", file, line); } diff --git a/flang/lib/evaluate/characteristics.cc b/flang/lib/evaluate/characteristics.cc index 0617bc8206b2..74fa0fec4d23 100644 --- a/flang/lib/evaluate/characteristics.cc +++ b/flang/lib/evaluate/characteristics.cc @@ -98,6 +98,30 @@ std::optional TypeAndShape::Characterize( } } +std::optional TypeAndShape::Characterize( + const Expr &expr, FoldingContext &context) { + if (const auto *symbol{UnwrapWholeSymbolDataRef(expr)}) { + if (const auto *object{ + symbol->detailsIf()}) { + return Characterize(*object); + } + } + if (auto type{expr.GetType()}) { + if (auto shape{GetShape(context, expr)}) { + TypeAndShape result{*type, std::move(*shape)}; + if (type->category() == TypeCategory::Character) { + if (const auto *chExpr{UnwrapExpr>(expr)}) { + if (auto length{chExpr->LEN()}) { + result.set_LEN(Expr{std::move(*length)}); + } + } + } + return result; + } + } + return std::nullopt; +} + bool TypeAndShape::IsCompatibleWith( parser::ContextualMessages &messages, const TypeAndShape &that) const { const auto &len{that.LEN()}; @@ -110,12 +134,15 @@ bool TypeAndShape::IsCompatibleWith( that.type_.AsFortran(lenstr.str()), type_.AsFortran()); return false; } - if (auto myLEN{ToInt64(LEN())}) { - if (auto thatLEN{ToInt64(len)}) { - if (*thatLEN < *myLEN) { - messages.Say( - "Warning: effective length '%jd' is less than expected length '%jd'"_en_US, - *thatLEN, *myLEN); + // 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); + } } } } @@ -310,6 +337,51 @@ std::optional DummyArgument::Characterize( return std::nullopt; } +std::optional DummyArgument::FromActual( + std::string &&name, const Expr &expr, FoldingContext &context) { + return std::visit( + common::visitors{ + [&](const BOZLiteralConstant &) { + return std::make_optional(std::move(name), + DummyDataObject{ + TypeAndShape{DynamicType::TypelessIntrinsicArgument()}}); + }, + [&](const NullPointer &) { return std::optional{}; }, + [&](const ProcedureDesignator &designator) { + if (auto proc{Procedure::Characterize( + designator, context.intrinsics())}) { + return std::make_optional( + std::move(name), DummyProcedure{std::move(*proc)}); + } else { + return std::optional{}; + } + }, + [&](const ProcedureRef &call) { + if (auto proc{ + Procedure::Characterize(call, context.intrinsics())}) { + return std::make_optional( + std::move(name), DummyProcedure{std::move(*proc)}); + } else { + return std::optional{}; + } + }, + [&](const auto &) { + if (auto type{expr.GetType()}) { + if (auto shape{GetShape(context, expr)}) { + return std::make_optional(std::move(name), + DummyDataObject{TypeAndShape{*type, std::move(*shape)}}); + } else { + return std::make_optional( + std::move(name), DummyDataObject{TypeAndShape{*type}}); + } + } else { + return std::optional{}; + } + }, + }, + expr.u); +} + bool DummyArgument::IsOptional() const { return std::visit( common::visitors{ @@ -466,15 +538,6 @@ std::optional Procedure::Characterize( {semantics::Attr::ELEMENTAL, Procedure::Attr::Elemental}, {semantics::Attr::BIND_C, Procedure::Attr::BindC}, }); - auto SetFunctionResult{[&](const semantics::DeclTypeSpec *type) { - if (type != nullptr) { - if (auto resultType{DynamicType::From(*type)}) { - result.functionResult = FunctionResult{*resultType}; - return true; - } - } - return false; - }}; return std::visit( common::visitors{ [&](const semantics::SubprogramDetails &subp) @@ -507,26 +570,26 @@ std::optional Procedure::Characterize( } const semantics::ProcInterface &interface{proc.interface()}; if (const semantics::Symbol * interfaceSymbol{interface.symbol()}) { - auto characterized{Characterize(*interfaceSymbol, intrinsics)}; - if (!characterized) { - return std::nullopt; - } - result = *characterized; + return Characterize(*interfaceSymbol, intrinsics); } else { result.attrs.set(Procedure::Attr::ImplicitInterface); + const semantics::DeclTypeSpec *type{interface.type()}; if (symbol.test(semantics::Symbol::Flag::Function)) { - if (!SetFunctionResult(interface.type())) { + if (type != nullptr) { + if (auto resultType{DynamicType::From(*type)}) { + result.functionResult = FunctionResult{*resultType}; + } + } else { return std::nullopt; } - } else { - // subroutine, not function - if (interface.type() != nullptr) { + } else { // subroutine, not function + if (type != nullptr) { return std::nullopt; } } + // The PASS name, if any, is not a characteristic. + return result; } - // The PASS name, if any, is not a characteristic. - return result; }, [&](const semantics::ProcBindingDetails &binding) { if (auto result{Characterize(binding.symbol(), intrinsics)}) { @@ -538,8 +601,9 @@ std::optional Procedure::Characterize( } } return result; + } else { + return std::optional{}; } - return std::optional{}; }, [&](const semantics::UseDetails &use) { return Characterize(use.symbol(), intrinsics); diff --git a/flang/lib/evaluate/characteristics.h b/flang/lib/evaluate/characteristics.h index 1d84d552884b..a5a6e62eb258 100644 --- a/flang/lib/evaluate/characteristics.h +++ b/flang/lib/evaluate/characteristics.h @@ -64,6 +64,12 @@ public: TypeAndShape(DynamicType t, Shape &&s) : type_{t}, shape_{std::move(s)} { AcquireLEN(); } + TypeAndShape(DynamicType t, std::optional &&s) : type_{t} { + if (s.has_value()) { + shape_ = std::move(*s); + } + AcquireLEN(); + } DEFAULT_CONSTRUCTORS_AND_ASSIGNMENTS(TypeAndShape) bool operator==(const TypeAndShape &) const; @@ -76,6 +82,8 @@ public: const semantics::ProcInterface &); static std::optional Characterize( const semantics::DeclTypeSpec &); + static std::optional Characterize( + const Expr &, FoldingContext &); template static std::optional Characterize(const A *p) { return p ? Characterize(*p) : std::nullopt; @@ -111,25 +119,6 @@ protected: Attrs attrs_; }; -template -std::optional GetTypeAndShape( - const Expr &expr, FoldingContext &context) { - if (auto type{expr.GetType()}) { - if (auto shape{GetShape(context, expr)}) { - TypeAndShape result{*type, std::move(*shape)}; - if (type->category() == TypeCategory::Character) { - if (const auto *chExpr{UnwrapExpr>(expr)}) { - if (auto length{chExpr->LEN()}) { - result.set_LEN(Expr{std::move(*length)}); - } - } - } - return result; - } - } - return std::nullopt; -} - // 15.3.2.2 struct DummyDataObject { ENUM_CLASS(Attr, Optional, Allocatable, Asynchronous, Contiguous, Value, @@ -171,14 +160,16 @@ struct AlternateReturn { // 15.3.2.1 struct DummyArgument { DECLARE_CONSTRUCTORS_AND_ASSIGNMENTS(DummyArgument) - explicit DummyArgument(std::string &&name, DummyDataObject &&x) + DummyArgument(std::string &&name, DummyDataObject &&x) : name{std::move(name)}, u{std::move(x)} {} - explicit DummyArgument(std::string &&name, DummyProcedure &&x) + DummyArgument(std::string &&name, DummyProcedure &&x) : name{std::move(name)}, u{std::move(x)} {} explicit DummyArgument(AlternateReturn &&x) : u{std::move(x)} {} bool operator==(const DummyArgument &) const; static std::optional Characterize( const semantics::Symbol &, const IntrinsicProcTable &); + static std::optional FromActual( + std::string &&, const Expr &, FoldingContext &); bool IsOptional() const; void SetOptional(bool = true); bool CanBePassedViaImplicitInterface() const; diff --git a/flang/lib/evaluate/check-call.cc b/flang/lib/evaluate/check-call.cc index 8955b4e7c0c0..580d28983ad7 100644 --- a/flang/lib/evaluate/check-call.cc +++ b/flang/lib/evaluate/check-call.cc @@ -17,6 +17,7 @@ #include "shape.h" #include "tools.h" #include "../parser/message.h" +#include "../semantics/scope.h" #include #include @@ -72,19 +73,177 @@ static void CheckImplicitInterfaceArg( } } -static bool CheckExplicitInterfaceArg(const ActualArgument &arg, +struct TypeConcerns { + const semantics::Symbol *typeBoundProcedure{nullptr}; + const semantics::Symbol *finalProcedure{nullptr}; + const semantics::Symbol *allocatable{nullptr}; + const semantics::Symbol *coarray{nullptr}; +}; + +static void InspectType( + const semantics::DerivedTypeSpec &derived, TypeConcerns &concerns) { + if (const auto *scope{derived.typeSymbol().scope()}) { + for (const auto &pair : *scope) { + const semantics::Symbol &component{*pair.second}; + if (const auto *object{ + component.detailsIf()}) { + if (component.attrs().test(semantics::Attr::ALLOCATABLE)) { + concerns.allocatable = &component; + } + if (object->IsCoarray()) { + concerns.coarray = &component; + } + if (component.flags().test(semantics::Symbol::Flag::ParentComp)) { + if (const auto *type{object->type()}) { + if (const auto *parent{type->AsDerived()}) { + InspectType(*parent, concerns); + } + } + } + } else if (component.has()) { + concerns.typeBoundProcedure = &component; + } else if (component.has()) { + concerns.finalProcedure = &component; + } + } + } +} + +static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy, + const Expr &actual, + const characteristics::TypeAndShape &actualType, + parser::ContextualMessages &messages) { + dummy.type.IsCompatibleWith(messages, actualType); + bool actualIsPolymorphic{actualType.type().IsPolymorphic()}; + bool dummyIsPolymorphic{dummy.type.type().IsPolymorphic()}; + bool actualIsCoindexed{ExtractCoarrayRef(actual).has_value()}; + bool actualIsAssumedSize{actualType.attrs().test( + characteristics::TypeAndShape::Attr::AssumedSize)}; + bool dummyIsAssumedSize{dummy.type.attrs().test( + characteristics::TypeAndShape::Attr::AssumedSize)}; + if (actualIsPolymorphic && dummyIsPolymorphic && + actualIsCoindexed) { // 15.5.2.4(2) + messages.Say( + "Coindexed polymorphic object may not be associated with a polymorphic dummy argument"_err_en_US); + } + if (actualIsPolymorphic && !dummyIsPolymorphic && + actualIsAssumedSize) { // 15.5.2.4(2) + messages.Say( + "Assumed-size polymorphic array may not be associated with a monomorphic dummy argument"_err_en_US); + } + if (!actualType.type().IsUnlimitedPolymorphic() && + actualType.type().category() == TypeCategory::Derived) { + const auto &derived{actualType.type().GetDerivedTypeSpec()}; + TypeConcerns concerns; + InspectType(derived, concerns); + if (dummy.type.type().IsAssumedType()) { + if (!derived.parameters().empty()) { // 15.5.2.4(2) + messages.Say( + "Actual argument associated with TYPE(*) dummy argument may not have a parameterized derived type"_err_en_US); + } + if (concerns.typeBoundProcedure) { // 15.5.2.4(2) + if (auto *msg{messages.Say( + "Actual argument associated with TYPE(*) dummy argument may not have type-bound procedures"_err_en_US)}) { + msg->Attach(concerns.typeBoundProcedure->name(), + "Declaration of type-bound procedure"_en_US); + } + } + if (concerns.finalProcedure) { // 15.5.2.4(2) + if (auto *msg{messages.Say( + "Actual argument associated with TYPE(*) dummy argument may not have FINAL procedures"_err_en_US)}) { + msg->Attach(concerns.finalProcedure->name(), + "Declaration of FINAL procedure"_en_US); + } + } + } + if (actualIsCoindexed && concerns.allocatable && + dummy.intent != common::Intent::In && + !dummy.attrs.test(characteristics::DummyDataObject::Attr::Value)) { + // 15.5.2.4(6) + if (auto *msg{messages.Say( + "Coindexed actual argument with ALLOCATABLE ultimate component must be associated with a dummy argument with VALUE or INTENT(IN) attributes"_err_en_US)}) { + msg->Attach(concerns.allocatable->name(), + "Declaration of ALLOCATABLE component"_en_US); + } + } + } + const auto *actualLastSymbol{GetLastSymbol(actual)}; + const semantics::ObjectEntityDetails *actualLastObject{actualLastSymbol + ? actualLastSymbol->detailsIf() + : nullptr}; + int actualRank{GetRank(actualType.shape())}; + int dummyRank{GetRank(dummy.type.shape())}; + if (dummy.type.attrs().test( + characteristics::TypeAndShape::Attr::AssumedShape)) { + // 15.5.2.4(16) + if (actualRank != dummyRank) { + messages.Say( + "Rank of actual argument (%d) differs from assumed-shape dummy argument (%d)"_err_en_US, + actualRank, dummyRank); + } + if (actualIsAssumedSize) { + if (auto *msg{messages.Say( + "Assumed-size array cannot be associated with assumed-shape dummy argument"_err_en_US)}) { + msg->Attach(actualLastSymbol->name(), + "Declaration of assumed-size array actual argument"_en_US); + } + } + } else if (actualRank == 0 && dummyRank > 0) { + // Actual is scalar, dummy is an array. 15.5.2.4(14), 15.5.2.11 + if (actualIsCoindexed) { + messages.Say( + "Coindexed scalar actual argument must be associated with a scalar dummy argument"_err_en_US); + } + if (actualLastSymbol && actualLastSymbol->Rank() == 0 && + !(dummy.type.type().IsAssumedType() && dummyIsAssumedSize)) { + messages.Say( + "Whole scalar actual argument may not be associated with a dummy argument array"_err_en_US); + } + if (actualIsPolymorphic) { + messages.Say( + "Element of polymorphic array may not be associated with a dummy argument array"_err_en_US); + } + if (actualLastSymbol && + actualLastSymbol->attrs().test(semantics::Attr::POINTER)) { + messages.Say( + "Element of pointer array may not be associated with a dummy argument array"_err_en_US); + } + if (actualLastObject && actualLastObject->IsAssumedShape()) { + messages.Say( + "Element of assumed-shape array may not be associated with a dummy argument array"_err_en_US); + } + } + // TODO pmk more here +} + +static void CheckExplicitInterfaceArg(const ActualArgument &arg, const characteristics::DummyArgument &dummy, FoldingContext &context) { + auto &messages{context.messages()}; std::visit( common::visitors{ [&](const characteristics::DummyDataObject &object) { if (const auto *expr{arg.UnwrapExpr()}) { - if (auto type{characteristics::GetTypeAndShape(*expr, context)}) { - object.type.IsCompatibleWith(context.messages(), *type); + if (auto type{characteristics::TypeAndShape::Characterize( + *expr, context)}) { + CheckExplicitDataArg(object, *expr, *type, context.messages()); + } else if (object.type.type().IsTypelessIntrinsicArgument() && + std::holds_alternative(expr->u)) { + // ok } else { - // TODO + messages.Say( + "Actual argument is not a variable or typed expression"_err_en_US); + } + } else if (const semantics::Symbol * + assumed{arg.GetAssumedTypeDummy()}) { + // An assumed-type dummy is being forwarded. + if (!object.type.type().IsAssumedType()) { + messages.Say( + "Assumed-type TYPE(*) '%s' may be associated only with an assumed-TYPE(*) dummy argument"_err_en_US, + assumed->name()); } } else { - // TODO + messages.Say( + "Actual argument is not an expression or variable"_err_en_US); } }, [&](const characteristics::DummyProcedure &) { diff --git a/flang/lib/evaluate/common.h b/flang/lib/evaluate/common.h index d8cd33dbba87..45a32f83b5ab 100644 --- a/flang/lib/evaluate/common.h +++ b/flang/lib/evaluate/common.h @@ -32,6 +32,7 @@ class DerivedTypeSpec; } namespace Fortran::evaluate { +class IntrinsicProcTable; using common::ConstantSubscript; using common::RelationalOperator; @@ -207,21 +208,23 @@ template class Expr; class FoldingContext { public: - explicit FoldingContext(const common::IntrinsicTypeDefaultKinds &d) - : defaults_{d} {} + FoldingContext( + const common::IntrinsicTypeDefaultKinds &d, const IntrinsicProcTable &t) + : defaults_{d}, intrinsics_{t} {} FoldingContext(const parser::ContextualMessages &m, - const common::IntrinsicTypeDefaultKinds &d, + const common::IntrinsicTypeDefaultKinds &d, const IntrinsicProcTable &t, Rounding round = defaultRounding, bool flush = false) - : messages_{m}, defaults_{d}, rounding_{round}, flushSubnormalsToZero_{ - flush} {} + : messages_{m}, defaults_{d}, intrinsics_{t}, rounding_{round}, + flushSubnormalsToZero_{flush} {} FoldingContext(const FoldingContext &that) : messages_{that.messages_}, defaults_{that.defaults_}, - rounding_{that.rounding_}, + intrinsics_{that.intrinsics_}, rounding_{that.rounding_}, flushSubnormalsToZero_{that.flushSubnormalsToZero_}, pdtInstance_{that.pdtInstance_}, impliedDos_{that.impliedDos_} {} FoldingContext( const FoldingContext &that, const parser::ContextualMessages &m) - : messages_{m}, defaults_{that.defaults_}, rounding_{that.rounding_}, + : messages_{m}, defaults_{that.defaults_}, + intrinsics_{that.intrinsics_}, rounding_{that.rounding_}, flushSubnormalsToZero_{that.flushSubnormalsToZero_}, pdtInstance_{that.pdtInstance_}, impliedDos_{that.impliedDos_} {} @@ -234,6 +237,7 @@ public: HostIntrinsicProceduresLibrary &hostIntrinsicsLibrary() { return hostIntrinsicsLibrary_; } + const evaluate::IntrinsicProcTable &intrinsics() const { return intrinsics_; } ConstantSubscript &StartImpliedDo(parser::CharBlock, ConstantSubscript = 1); std::optional GetImpliedDo(parser::CharBlock) const; @@ -251,6 +255,7 @@ public: private: parser::ContextualMessages messages_; const common::IntrinsicTypeDefaultKinds &defaults_; + const IntrinsicProcTable &intrinsics_; Rounding rounding_{defaultRounding}; bool flushSubnormalsToZero_{false}; bool bigEndian_{false}; diff --git a/flang/lib/evaluate/fold.cc b/flang/lib/evaluate/fold.cc index 211bf05efdd1..ee185a5c3a20 100644 --- a/flang/lib/evaluate/fold.cc +++ b/flang/lib/evaluate/fold.cc @@ -1213,7 +1213,7 @@ std::optional> GetNamedConstantValue( if (constant->Rank() == 0) { // scalar expansion if (auto symShape{GetShape(context, symbol)}) { - if (auto extents{AsConstantExtents(*symShape)}) { + if (auto extents{AsConstantExtents(context, *symShape)}) { *constant = constant->Reshape(std::move(*extents)); CHECK(constant->Rank() == symbol.Rank()); } @@ -1221,8 +1221,8 @@ std::optional> GetNamedConstantValue( } if (constant->Rank() == symbol.Rank()) { NamedEntity base{symbol}; - if (auto lbounds{ - AsConstantExtents(GetLowerBounds(context, base))}) { + if (auto lbounds{AsConstantExtents( + context, GetLowerBounds(context, base))}) { constant->set_lbounds(*std::move(lbounds)); } } @@ -1803,7 +1803,7 @@ Expr MapOperation(FoldingContext &context, } } return FromArrayConstructor( - context, std::move(result), AsConstantExtents(shape)); + context, std::move(result), AsConstantExtents(context, shape)); } // array * array case @@ -1843,7 +1843,7 @@ Expr MapOperation(FoldingContext &context, } } return FromArrayConstructor( - context, std::move(result), AsConstantExtents(shape)); + context, std::move(result), AsConstantExtents(context, shape)); } // array * scalar case @@ -1860,7 +1860,7 @@ Expr MapOperation(FoldingContext &context, Fold(context, f(std::move(leftScalar), Expr{rightScalar}))); } return FromArrayConstructor( - context, std::move(result), AsConstantExtents(shape)); + context, std::move(result), AsConstantExtents(context, shape)); } // scalar * array case @@ -1892,7 +1892,7 @@ Expr MapOperation(FoldingContext &context, } } return FromArrayConstructor( - context, std::move(result), AsConstantExtents(shape)); + context, std::move(result), AsConstantExtents(context, shape)); } // ApplyElementwise() recursively folds the operand expression(s) of an diff --git a/flang/lib/evaluate/formatting.cc b/flang/lib/evaluate/formatting.cc index 0682831c5016..023c14265910 100644 --- a/flang/lib/evaluate/formatting.cc +++ b/flang/lib/evaluate/formatting.cc @@ -415,7 +415,7 @@ std::string DynamicType::AsFortran() const { return "CLASS(*)"; } else if (IsAssumedType()) { return "TYPE(*)"; - } else if (kind_ == 0) { + } else if (IsTypelessIntrinsicArgument()) { return "(typeless intrinsic function argument)"; } else { return EnumToString(category_) + '(' + std::to_string(kind_) + ')'; diff --git a/flang/lib/evaluate/intrinsics.cc b/flang/lib/evaluate/intrinsics.cc index 69284dadf438..885f74b07473 100644 --- a/flang/lib/evaluate/intrinsics.cc +++ b/flang/lib/evaluate/intrinsics.cc @@ -1209,7 +1209,7 @@ std::optional IntrinsicInterface::Match( CHECK(!shapeArgSize.has_value()); if (rank == 1) { if (auto shape{GetShape(context, *arg)}) { - if (auto constShape{AsConstantShape(*shape)}) { + if (auto constShape{AsConstantShape(context, *shape)}) { shapeArgSize = constShape->At(ConstantSubscripts{1}).ToInt64(); CHECK(shapeArgSize >= 0); argOk = true; @@ -1438,18 +1438,10 @@ std::optional IntrinsicInterface::Match( const IntrinsicDummyArgument &d{dummy[std::min(j, dummyArgPatterns - 1)]}; if (const auto &arg{rearranged[j]}) { if (const Expr *expr{arg->UnwrapExpr()}) { - std::optional typeAndShape; - if (auto type{expr->GetType()}) { - if (auto shape{GetShape(context, *expr)}) { - typeAndShape.emplace(*type, std::move(*shape)); - } else { - typeAndShape.emplace(*type); - } - } else { - typeAndShape.emplace(DynamicType::TypelessIntrinsicArgument()); - } - dummyArgs.emplace_back(std::string{d.keyword}, - characteristics::DummyDataObject{std::move(typeAndShape.value())}); + auto dc{characteristics::DummyArgument::FromActual( + std::string{d.keyword}, *expr, context)}; + CHECK(dc.has_value()); + dummyArgs.emplace_back(std::move(*dc)); if (d.typePattern.kindCode == KindCode::same && !sameDummyArg.has_value()) { sameDummyArg = j; @@ -1569,21 +1561,17 @@ SpecificCall IntrinsicProcTable::Implementation::HandleNull( CHECK(last != nullptr); auto procPointer{ characteristics::Procedure::Characterize(*last, intrinsics)}; - characteristics::DummyProcedure dp{ - common::Clone(procPointer.value())}; - args.emplace_back("mold"s, std::move(dp)); - fResult.emplace(std::move(procPointer.value())); + CHECK(procPointer.has_value()); + args.emplace_back("mold"s, + characteristics::DummyProcedure{common::Clone(*procPointer)}); + fResult.emplace(std::move(*procPointer)); } else if (auto type{mold->GetType()}) { // MOLD= object pointer - std::optional typeAndShape; - if (auto shape{GetShape(context, *mold)}) { - typeAndShape.emplace(*type, std::move(*shape)); - } else { - typeAndShape.emplace(*type); - } - characteristics::DummyDataObject ddo{typeAndShape.value()}; - args.emplace_back("mold"s, std::move(ddo)); - fResult.emplace(std::move(*typeAndShape)); + characteristics::TypeAndShape typeAndShape{ + *type, GetShape(context, *mold)}; + args.emplace_back( + "mold"s, characteristics::DummyDataObject{typeAndShape}); + fResult.emplace(std::move(typeAndShape)); } else { context.messages().Say( "MOLD= argument to NULL() lacks type"_err_en_US); diff --git a/flang/lib/evaluate/shape.cc b/flang/lib/evaluate/shape.cc index f102b6c67c87..a0591f492d40 100644 --- a/flang/lib/evaluate/shape.cc +++ b/flang/lib/evaluate/shape.cc @@ -13,6 +13,7 @@ // limitations under the License. #include "shape.h" +#include "characteristics.h" #include "fold.h" #include "tools.h" #include "type.h" @@ -20,6 +21,9 @@ #include "../common/template.h" #include "../parser/message.h" #include "../semantics/symbol.h" +#include + +using namespace std::placeholders; // _1, _2, &c. for std::bind() namespace Fortran::evaluate { @@ -89,11 +93,10 @@ std::optional AsExtentArrayExpr(const Shape &shape) { return ExtentExpr{ArrayConstructor{std::move(values)}}; } -std::optional> AsConstantShape(const Shape &shape) { +std::optional> AsConstantShape( + FoldingContext &context, const Shape &shape) { if (auto shapeArray{AsExtentArrayExpr(shape)}) { - common::IntrinsicTypeDefaultKinds defaults; - FoldingContext noFoldingContext{defaults}; - auto folded{Fold(noFoldingContext, std::move(*shapeArray))}; + auto folded{Fold(context, std::move(*shapeArray))}; if (auto *p{UnwrapConstantValue(folded)}) { return std::move(*p); } @@ -118,43 +121,44 @@ ConstantSubscripts AsConstantExtents(const Constant &shape) { return result; } -std::optional AsConstantExtents(const Shape &shape) { - if (auto shapeConstant{AsConstantShape(shape)}) { +std::optional AsConstantExtents( + FoldingContext &context, const Shape &shape) { + if (auto shapeConstant{AsConstantShape(context, shape)}) { return AsConstantExtents(*shapeConstant); } else { return std::nullopt; } } -static ExtentExpr ComputeTripCount( - ExtentExpr &&lower, ExtentExpr &&upper, ExtentExpr &&stride) { +static ExtentExpr ComputeTripCount(FoldingContext &context, ExtentExpr &&lower, + ExtentExpr &&upper, ExtentExpr &&stride) { ExtentExpr strideCopy{common::Clone(stride)}; ExtentExpr span{ (std::move(upper) - std::move(lower) + std::move(strideCopy)) / std::move(stride)}; ExtentExpr extent{ Extremum{std::move(span), ExtentExpr{0}, Ordering::Greater}}; - common::IntrinsicTypeDefaultKinds defaults; - FoldingContext noFoldingContext{defaults}; - return Fold(noFoldingContext, std::move(extent)); + return Fold(context, std::move(extent)); } -ExtentExpr CountTrips( - ExtentExpr &&lower, ExtentExpr &&upper, ExtentExpr &&stride) { +ExtentExpr CountTrips(FoldingContext &context, ExtentExpr &&lower, + ExtentExpr &&upper, ExtentExpr &&stride) { return ComputeTripCount( - std::move(lower), std::move(upper), std::move(stride)); + context, std::move(lower), std::move(upper), std::move(stride)); } -ExtentExpr CountTrips(const ExtentExpr &lower, const ExtentExpr &upper, - const ExtentExpr &stride) { - return ComputeTripCount( - common::Clone(lower), common::Clone(upper), common::Clone(stride)); +ExtentExpr CountTrips(FoldingContext &context, const ExtentExpr &lower, + const ExtentExpr &upper, const ExtentExpr &stride) { + return ComputeTripCount(context, common::Clone(lower), common::Clone(upper), + common::Clone(stride)); } -MaybeExtentExpr CountTrips(MaybeExtentExpr &&lower, MaybeExtentExpr &&upper, - MaybeExtentExpr &&stride) { +MaybeExtentExpr CountTrips(FoldingContext &context, MaybeExtentExpr &&lower, + MaybeExtentExpr &&upper, MaybeExtentExpr &&stride) { + std::function bound{ + std::bind(ComputeTripCount, context, _1, _2, _3)}; return common::MapOptional( - ComputeTripCount, std::move(lower), std::move(upper), std::move(stride)); + std::move(bound), std::move(lower), std::move(upper), std::move(stride)); } MaybeExtentExpr GetSize(Shape &&shape) { @@ -275,7 +279,7 @@ MaybeExtentExpr GetExtent(FoldingContext &context, const Subscript &subscript, if (!lower.has_value()) { lower = GetLowerBound(context, base, dimension); } - return CountTrips(std::move(lower), std::move(upper), + return CountTrips(context, std::move(lower), std::move(upper), MaybeExtentExpr{triplet.stride()}); }, [&](const IndirectSubscriptIntegerExpr &subs) -> MaybeExtentExpr { @@ -349,8 +353,28 @@ Shape GetUpperBounds(FoldingContext &context, const NamedEntity &base) { auto GetShapeHelper::operator()(const Symbol &symbol) const -> Result { return std::visit( common::visitors{ - [&](const semantics::ObjectEntityDetails &) { - return (*this)(NamedEntity{symbol}); + [&](const semantics::ObjectEntityDetails &object) { + if (IsImpliedShape(symbol)) { + return (*this)(object.init()); + } else { + Shape shape; + int n{object.shape().Rank()}; + NamedEntity base{symbol}; + for (int dimension{0}; dimension < n; ++dimension) { + shape.emplace_back(GetExtent(context_, base, dimension)); + } + return Result{shape}; + } + }, + [&](const semantics::EntityDetails &) { + return Scalar(); // no dimensions seen + }, + [&](const semantics::ProcEntityDetails &proc) { + if (const Symbol * interface{proc.interface().symbol()}) { + return (*this)(*interface); + } else { + return Scalar(); + } }, [&](const semantics::AssocEntityDetails &assoc) { return (*this)(assoc.expr()); @@ -377,26 +401,17 @@ auto GetShapeHelper::operator()(const Symbol &symbol) const -> Result { } auto GetShapeHelper::operator()(const Component &component) const -> Result { - if (component.GetLastSymbol().Rank() > 0) { - return (*this)(NamedEntity{Component{component}}); - } else { + const Symbol &symbol{component.GetLastSymbol()}; + int rank{symbol.Rank()}; + if (rank == 0) { return (*this)(component.base()); - } -} - -auto GetShapeHelper::operator()(const NamedEntity &base) const -> Result { - const Symbol &symbol{base.GetLastSymbol()}; - if (const auto *object{symbol.detailsIf()}) { - if (IsImpliedShape(symbol)) { - return (*this)(object->init()); - } else { - Shape shape; - int n{object->shape().Rank()}; - for (int dimension{0}; dimension < n; ++dimension) { - shape.emplace_back(GetExtent(context_, base, dimension)); - } - return shape; + } else if (symbol.has()) { + Shape shape; + NamedEntity base{Component{component}}; + for (int dimension{0}; dimension < rank; ++dimension) { + shape.emplace_back(GetExtent(context_, base, dimension)); } + return shape; } else { return (*this)(symbol); } @@ -405,32 +420,34 @@ auto GetShapeHelper::operator()(const NamedEntity &base) const -> Result { auto GetShapeHelper::operator()(const ArrayRef &arrayRef) const -> Result { Shape shape; int dimension{0}; + const NamedEntity &base{arrayRef.base()}; for (const Subscript &ss : arrayRef.subscript()) { - if (ss.Rank() > 0) { - shape.emplace_back(GetExtent(context_, ss, arrayRef.base(), dimension)); - } - ++dimension; - } - if (shape.empty()) { - return (*this)(arrayRef.base()); - } else { - return shape; - } -} - -auto GetShapeHelper::operator()(const CoarrayRef &coarrayRef) const -> Result { - Shape shape; - NamedEntity base{coarrayRef.GetBase()}; - int dimension{0}; - for (const Subscript &ss : coarrayRef.subscript()) { if (ss.Rank() > 0) { shape.emplace_back(GetExtent(context_, ss, base, dimension)); } ++dimension; } if (shape.empty()) { + if (const Component * component{base.UnwrapComponent()}) { + return (*this)(component->base()); + } + } + return shape; +} + +auto GetShapeHelper::operator()(const CoarrayRef &coarrayRef) const -> Result { + NamedEntity base{coarrayRef.GetBase()}; + if (coarrayRef.subscript().empty()) { return (*this)(base); } else { + Shape shape; + int dimension{0}; + for (const Subscript &ss : coarrayRef.subscript()) { + if (ss.Rank() > 0) { + shape.emplace_back(GetExtent(context_, ss, base, dimension)); + } + ++dimension; + } return shape; } } @@ -451,8 +468,7 @@ auto GetShapeHelper::operator()(const ProcedureRef &call) const -> Result { return Scalar(); } else if (const Symbol * symbol{call.proc().GetSymbol()}) { return (*this)(*symbol); - } else if (const auto *intrinsic{ - std::get_if(&call.proc().u)}) { + } else if (const auto *intrinsic{call.proc().GetSpecificIntrinsic()}) { if (intrinsic->name == "shape" || intrinsic->name == "lbound" || intrinsic->name == "ubound") { const auto *expr{call.arguments().front().value().UnwrapExpr()}; @@ -462,10 +478,12 @@ auto GetShapeHelper::operator()(const ProcedureRef &call) const -> Result { if (call.arguments().size() >= 2 && call.arguments().at(1).has_value()) { // SHAPE(RESHAPE(array,shape)) -> shape const auto *shapeExpr{call.arguments().at(1).value().UnwrapExpr()}; - CHECK(shapeExpr != nullptr); - Expr shape{std::get>(shapeExpr->u)}; + auto shape{std::get>(DEREF(shapeExpr).u)}; return AsShape(context_, ConvertToType(std::move(shape))); } + } else if (intrinsic->characteristics.value().attrs.test(characteristics:: + Procedure::Attr::NullPointer)) { // NULL(MOLD=) + return (*this)(call.arguments()); } else { // TODO: shapes of other non-elemental intrinsic results } diff --git a/flang/lib/evaluate/shape.h b/flang/lib/evaluate/shape.h index af0c38d5c9de..e05bd97f1294 100644 --- a/flang/lib/evaluate/shape.h +++ b/flang/lib/evaluate/shape.h @@ -49,11 +49,13 @@ std::optional AsShape(FoldingContext &, ExtentExpr &&); std::optional AsExtentArrayExpr(const Shape &); -std::optional> AsConstantShape(const Shape &); +std::optional> AsConstantShape( + FoldingContext &, const Shape &); Constant AsConstantShape(const ConstantSubscripts &); ConstantSubscripts AsConstantExtents(const Constant &); -std::optional AsConstantExtents(const Shape &); +std::optional AsConstantExtents( + FoldingContext &, const Shape &); inline int GetRank(const Shape &s) { return static_cast(s.size()); } @@ -71,12 +73,12 @@ MaybeExtentExpr GetExtent( FoldingContext &, const Subscript &, const NamedEntity &, int dimension); // Compute an element count for a triplet or trip count for a DO. -ExtentExpr CountTrips( - ExtentExpr &&lower, ExtentExpr &&upper, ExtentExpr &&stride); -ExtentExpr CountTrips( - const ExtentExpr &lower, const ExtentExpr &upper, const ExtentExpr &stride); -MaybeExtentExpr CountTrips( - MaybeExtentExpr &&lower, MaybeExtentExpr &&upper, MaybeExtentExpr &&stride); +ExtentExpr CountTrips(FoldingContext &, ExtentExpr &&lower, ExtentExpr &&upper, + ExtentExpr &&stride); +ExtentExpr CountTrips(FoldingContext &, const ExtentExpr &lower, + const ExtentExpr &upper, const ExtentExpr &stride); +MaybeExtentExpr CountTrips(FoldingContext &, MaybeExtentExpr &&lower, + MaybeExtentExpr &&upper, MaybeExtentExpr &&stride); // Computes SIZE() == PRODUCT(shape) MaybeExtentExpr GetSize(Shape &&); @@ -112,7 +114,6 @@ public: Result operator()(const Symbol &) const; Result operator()(const Component &) const; - Result operator()(const NamedEntity &) const; Result operator()(const ArrayRef &) const; Result operator()(const CoarrayRef &) const; Result operator()(const Substring &) const; @@ -155,7 +156,8 @@ private: !ContainsAnyImpliedDoIndex(ido.stride())) { if (auto nValues{GetArrayConstructorExtent(ido.values())}) { return std::move(*nValues) * - CountTrips(ido.lower(), ido.upper(), ido.stride()); + CountTrips( + context_, ido.lower(), ido.upper(), ido.stride()); } } return std::nullopt; diff --git a/flang/lib/evaluate/tools.cc b/flang/lib/evaluate/tools.cc index 07d1530b0572..a73466a0e0b5 100644 --- a/flang/lib/evaluate/tools.cc +++ b/flang/lib/evaluate/tools.cc @@ -13,6 +13,7 @@ // limitations under the License. #include "tools.h" +#include "characteristics.h" #include "traverse.h" #include "../common/idioms.h" #include "../parser/message.h" @@ -646,6 +647,47 @@ bool IsAssumedRank(const ActualArgument &arg) { } } +// IsProcedurePointer() +bool IsProcedurePointer(const Expr &expr) { + return std::visit( + common::visitors{ + [](const NullPointer &) { return true; }, + [](const ProcedureDesignator &) { return true; }, + [](const ProcedureRef &) { return true; }, + [](const auto &) { return false; }, + }, + expr.u); +} + +// IsNullPointer() +static bool IsNullPointer(const ProcedureRef &call) { + auto *intrinsic{call.proc().GetSpecificIntrinsic()}; + return intrinsic && + intrinsic->characteristics.value().attrs.test( + characteristics::Procedure::Attr::NullPointer); +} +template +bool IsNullPointer(const Expr> &expr) { + const auto *call{std::get_if>>(&expr.u)}; + return call && IsNullPointer(*call); +} +template bool IsNullPointer(const Expr> &expr) { + return std::visit([](const auto &x) { return IsNullPointer(x); }, expr.u); +} +bool IsNullPointer(const Expr &expr) { + const auto *call{std::get_if>(&expr.u)}; + return call && IsNullPointer(*call); +} +bool IsNullPointer(const Expr &expr) { + return std::visit( + common::visitors{ + [](const NullPointer &) { return true; }, + [](const ProcedureRef &call) { return IsNullPointer(call); }, + [](const auto &) { return false; }, + }, + expr.u); +} + // GetLastTarget() auto GetLastTargetHelper::operator()(const semantics::Symbol &x) const -> Result { diff --git a/flang/lib/evaluate/tools.h b/flang/lib/evaluate/tools.h index d9cbc08df380..9755616acf71 100644 --- a/flang/lib/evaluate/tools.h +++ b/flang/lib/evaluate/tools.h @@ -754,17 +754,9 @@ template bool IsAllocatableOrPointer(const A &x) { semantics::Attrs{semantics::Attr::POINTER, semantics::Attr::ALLOCATABLE}); } -// Predicate: IsProcedurePointer() -template bool IsProcedurePointer(const A &) { return false; } -inline bool IsProcedurePointer(const ProcedureDesignator &) { return true; } -inline bool IsProcedurePointer(const ProcedureRef &) { return true; } -inline bool IsProcedurePointer(const Expr &expr) { - return std::visit( - [](const auto &x) { return IsProcedurePointer(x); }, expr.u); -} -template bool IsProcedurePointer(const std::optional &x) { - return x.has_value() && IsProcedurePointer(*x); -} +// Pointer detection predicates +bool IsProcedurePointer(const Expr &); +bool IsNullPointer(const Expr &); // GetLastTarget() returns the rightmost symbol in an object // designator (which has perhaps been wrapped in an Expr<>) that has the diff --git a/flang/lib/evaluate/type.cc b/flang/lib/evaluate/type.cc index f8b2b9ed37ff..d7a758523554 100644 --- a/flang/lib/evaluate/type.cc +++ b/flang/lib/evaluate/type.cc @@ -109,6 +109,10 @@ bool DynamicType::IsAssumedLengthCharacter() const { charLength_->isAssumed(); } +bool DynamicType::IsTypelessIntrinsicArgument() const { + return category_ == TypeCategory::Integer && kind_ == TypelessKind; +} + static const semantics::Symbol *FindParentComponent( const semantics::DerivedTypeSpec &derived) { const semantics::Symbol &typeSymbol{derived.typeSymbol()}; @@ -214,22 +218,24 @@ static bool AreSameComponent(const semantics::Symbol &x, if (x.attrs().test(semantics::Attr::PRIVATE)) { return false; } -#if 0 // TODO +#if 0 // TODO if (const auto *xObject{x.detailsIf()}) { if (const auto *yObject{y.detailsIf()}) { #else if (x.has()) { if (y.has()) { #endif - // TODO: compare types, type parameters, bounds, &c. - return true; - } else { - return false; - } - } else { - // TODO: non-object components - return true; - } + // TODO: compare types, type parameters, bounds, &c. + return true; +} +else { + return false; +} +} +else { + // TODO: non-object components + return true; +} } static bool AreCompatibleDerivedTypes(const semantics::DerivedTypeSpec *x, diff --git a/flang/lib/evaluate/type.h b/flang/lib/evaluate/type.h index 024626af6a22..5906264aa068 100644 --- a/flang/lib/evaluate/type.h +++ b/flang/lib/evaluate/type.h @@ -147,6 +147,7 @@ public: DynamicType ResultTypeForMultiply(const DynamicType &) const; bool IsAssumedLengthCharacter() const; + bool IsTypelessIntrinsicArgument() const; constexpr bool IsAssumedType() const { // TYPE(*) return kind_ == AssumedTypeKind; } @@ -157,8 +158,7 @@ public: return IsPolymorphic() && derived_ == nullptr; } constexpr const semantics::DerivedTypeSpec &GetDerivedTypeSpec() const { - CHECK(derived_ != nullptr); - return *derived_; + return DEREF(derived_); } // 7.3.2.3 & 15.5.2.4 type compatibility. @@ -194,8 +194,7 @@ public: } private: - // Special kind codes are used when category_ == TypeCategory::Derived - // to distinguish the following Fortran types. + // Special kind codes are used to distinguish the following Fortran types. enum SpecialKind { TypelessKind = -1, // BOZ actual argument to intrinsic function ClassKind = -2, // CLASS(T) or CLASS(*) diff --git a/flang/lib/semantics/semantics.cc b/flang/lib/semantics/semantics.cc index d8489d9d031e..0a50e67d3825 100644 --- a/flang/lib/semantics/semantics.cc +++ b/flang/lib/semantics/semantics.cc @@ -134,8 +134,9 @@ SemanticsContext::SemanticsContext( parser::AllSources &allSources) : defaultKinds_{defaultKinds}, languageFeatures_{languageFeatures}, allSources_{allSources}, - intrinsics_{evaluate::IntrinsicProcTable::Configure(defaultKinds)}, - foldingContext_{parser::ContextualMessages{&messages_}, defaultKinds} {} + intrinsics_{evaluate::IntrinsicProcTable::Configure(defaultKinds_)}, + foldingContext_{ + parser::ContextualMessages{&messages_}, defaultKinds_, intrinsics_} {} SemanticsContext::~SemanticsContext() {} diff --git a/flang/lib/semantics/semantics.h b/flang/lib/semantics/semantics.h index b5b9f7033e79..85e208cc7268 100644 --- a/flang/lib/semantics/semantics.h +++ b/flang/lib/semantics/semantics.h @@ -158,7 +158,7 @@ private: const evaluate::IntrinsicProcTable intrinsics_; Scope globalScope_; parser::Messages messages_; - evaluate::FoldingContext foldingContext_{defaultKinds_}; + evaluate::FoldingContext foldingContext_; bool CheckError(bool); ConstructStack constructStack_; diff --git a/flang/test/evaluate/expression.cc b/flang/test/evaluate/expression.cc index 02bff0c0ea84..cb6d96e3f349 100644 --- a/flang/test/evaluate/expression.cc +++ b/flang/test/evaluate/expression.cc @@ -15,6 +15,7 @@ #include "../../lib/evaluate/expression.h" #include "testing.h" #include "../../lib/evaluate/fold.h" +#include "../../lib/evaluate/intrinsics.h" #include "../../lib/evaluate/tools.h" #include "../../lib/parser/message.h" #include @@ -39,8 +40,9 @@ int main() { DefaultIntegerExpr{2} + DefaultIntegerExpr{3} * -DefaultIntegerExpr{4}}; MATCH("2_4+3_4*(-4_4)", AsFortran(ex1)); Fortran::common::IntrinsicTypeDefaultKinds defaults; + auto intrinsics{Fortran::evaluate::IntrinsicProcTable::Configure(defaults)}; FoldingContext context{ - Fortran::parser::ContextualMessages{nullptr}, defaults}; + Fortran::parser::ContextualMessages{nullptr}, defaults, intrinsics}; ex1 = Fold(context, std::move(ex1)); MATCH("-10_4", AsFortran(ex1)); MATCH("1_4/2_4", AsFortran(DefaultIntegerExpr{1} / DefaultIntegerExpr{2})); diff --git a/flang/test/evaluate/folding.cc b/flang/test/evaluate/folding.cc index c4da7f57a691..eb5152e04511 100644 --- a/flang/test/evaluate/folding.cc +++ b/flang/test/evaluate/folding.cc @@ -18,6 +18,7 @@ #include "../../lib/evaluate/fold.h" #include "../../lib/evaluate/host.h" #include "../../lib/evaluate/intrinsics-library-templates.h" +#include "../../lib/evaluate/intrinsics.h" #include "../../lib/evaluate/tools.h" #include @@ -72,9 +73,11 @@ void TestHostRuntimeSubnormalFlushing() { Fortran::parser::CharBlock src; Fortran::parser::ContextualMessages messages{src, nullptr}; Fortran::common::IntrinsicTypeDefaultKinds defaults; - FoldingContext flushingContext{messages, defaults, defaultRounding, true}; + auto intrinsics{Fortran::evaluate::IntrinsicProcTable::Configure(defaults)}; + FoldingContext flushingContext{ + messages, defaults, intrinsics, defaultRounding, true}; FoldingContext noFlushingContext{ - messages, defaults, defaultRounding, false}; + messages, defaults, intrinsics, defaultRounding, false}; HostIntrinsicProceduresLibrary lib; lib.AddProcedure(HostRuntimeIntrinsicProcedure{ diff --git a/flang/test/evaluate/intrinsics.cc b/flang/test/evaluate/intrinsics.cc index 32d2a6503084..9a31b131dfa6 100644 --- a/flang/test/evaluate/intrinsics.cc +++ b/flang/test/evaluate/intrinsics.cc @@ -69,7 +69,9 @@ template static NamedArg Named(std::string kw, A &&x) { } struct TestCall { - TestCall(const IntrinsicProcTable &t, std::string n) : table{t}, name{n} {} + TestCall(const common::IntrinsicTypeDefaultKinds &d, + const IntrinsicProcTable &t, std::string n) + : defaults{d}, table{t}, name{n} {} template TestCall &Push(A &&x) { args.emplace_back(AsGenericExpr(std::move(x))); keywords.push_back(""); @@ -113,8 +115,7 @@ struct TestCall { std::cout << ')' << std::endl; CallCharacteristics call{fName}; auto messages{strings.Messages(buffer)}; - common::IntrinsicTypeDefaultKinds defaults; - FoldingContext context{messages, defaults}; + FoldingContext context{messages, defaults, table}; std::optional si{table.Probe(call, args, context)}; if (resultType.has_value()) { TEST(si.has_value()); @@ -142,6 +143,7 @@ struct TestCall { strings.Emit(std::cout, buffer); } + const common::IntrinsicTypeDefaultKinds &defaults; const IntrinsicProcTable &table; CookedStrings strings; parser::Messages buffer; @@ -167,48 +169,61 @@ void TestIntrinsics() { using Char = Type; using Log4 = Type; - TestCall{table, "bad"} + TestCall{defaults, table, "bad"} .Push(Const(Scalar{})) .DoCall(); // bad intrinsic name - TestCall{table, "abs"} + TestCall{defaults, table, "abs"} .Push(Named("a", Const(Scalar{}))) .DoCall(Int4::GetType()); - TestCall{table, "abs"}.Push(Const(Scalar{})).DoCall(Int4::GetType()); - TestCall{table, "abs"} + TestCall{defaults, table, "abs"} + .Push(Const(Scalar{})) + .DoCall(Int4::GetType()); + TestCall{defaults, table, "abs"} .Push(Named("bad", Const(Scalar{}))) .DoCall(); // bad keyword - TestCall{table, "abs"}.DoCall(); // insufficient args - TestCall{table, "abs"} + TestCall{defaults, table, "abs"}.DoCall(); // insufficient args + TestCall{defaults, table, "abs"} .Push(Const(Scalar{})) .Push(Const(Scalar{})) .DoCall(); // too many args - TestCall{table, "abs"} + TestCall{defaults, table, "abs"} .Push(Const(Scalar{})) .Push(Named("a", Const(Scalar{}))) .DoCall(); - TestCall{table, "abs"} + TestCall{defaults, table, "abs"} .Push(Named("a", Const(Scalar{}))) .Push(Const(Scalar{})) .DoCall(); - TestCall{table, "abs"}.Push(Const(Scalar{})).DoCall(Int1::GetType()); - TestCall{table, "abs"}.Push(Const(Scalar{})).DoCall(Int4::GetType()); - TestCall{table, "abs"}.Push(Const(Scalar{})).DoCall(Int8::GetType()); - TestCall{table, "abs"}.Push(Const(Scalar{})).DoCall(Real4::GetType()); - TestCall{table, "abs"}.Push(Const(Scalar{})).DoCall(Real8::GetType()); - TestCall{table, "abs"} + TestCall{defaults, table, "abs"} + .Push(Const(Scalar{})) + .DoCall(Int1::GetType()); + TestCall{defaults, table, "abs"} + .Push(Const(Scalar{})) + .DoCall(Int4::GetType()); + TestCall{defaults, table, "abs"} + .Push(Const(Scalar{})) + .DoCall(Int8::GetType()); + TestCall{defaults, table, "abs"} + .Push(Const(Scalar{})) + .DoCall(Real4::GetType()); + TestCall{defaults, table, "abs"} + .Push(Const(Scalar{})) + .DoCall(Real8::GetType()); + TestCall{defaults, table, "abs"} .Push(Const(Scalar{})) .DoCall(Real4::GetType()); - TestCall{table, "abs"} + TestCall{defaults, table, "abs"} .Push(Const(Scalar{})) .DoCall(Real8::GetType()); - TestCall{table, "abs"}.Push(Const(Scalar{})).DoCall(); - TestCall{table, "abs"}.Push(Const(Scalar{})).DoCall(); + TestCall{defaults, table, "abs"}.Push(Const(Scalar{})).DoCall(); + TestCall{defaults, table, "abs"}.Push(Const(Scalar{})).DoCall(); // "Ext" in names for calls allowed as extensions - TestCall maxCallR{table, "max"}, maxCallI{table, "min"}, - max0Call{table, "max0"}, max1Call{table, "max1"}, - amin0Call{table, "amin0"}, amin1Call{table, "amin1"}, - max0ExtCall{table, "max0"}, amin1ExtCall{table, "amin1"}; + TestCall maxCallR{defaults, table, "max"}, maxCallI{defaults, table, "min"}, + max0Call{defaults, table, "max0"}, max1Call{defaults, table, "max1"}, + amin0Call{defaults, table, "amin0"}, amin1Call{defaults, table, "amin1"}, + max0ExtCall{defaults, table, "max0"}, + amin1ExtCall{defaults, table, "amin1"}; for (int j{0}; j < 10; ++j) { maxCallR.Push(Const(Scalar{})); maxCallI.Push(Const(Scalar{})); @@ -228,25 +243,33 @@ void TestIntrinsics() { amin1Call.DoCall(Real4::GetType()); amin1ExtCall.DoCall(Real4::GetType()); - TestCall{table, "conjg"} + TestCall{defaults, table, "conjg"} .Push(Const(Scalar{})) .DoCall(Complex4::GetType()); - TestCall{table, "conjg"} + TestCall{defaults, table, "conjg"} .Push(Const(Scalar{})) .DoCall(Complex8::GetType()); - TestCall{table, "dconjg"}.Push(Const(Scalar{})).DoCall(); - TestCall{table, "dconjg"} + TestCall{defaults, table, "dconjg"}.Push(Const(Scalar{})).DoCall(); + TestCall{defaults, table, "dconjg"} .Push(Const(Scalar{})) .DoCall(Complex8::GetType()); - TestCall{table, "float"}.Push(Const(Scalar{})).DoCall(); - TestCall{table, "float"}.Push(Const(Scalar{})).DoCall(Real4::GetType()); - TestCall{table, "idint"}.Push(Const(Scalar{})).DoCall(); - TestCall{table, "idint"}.Push(Const(Scalar{})).DoCall(Int4::GetType()); + TestCall{defaults, table, "float"}.Push(Const(Scalar{})).DoCall(); + TestCall{defaults, table, "float"} + .Push(Const(Scalar{})) + .DoCall(Real4::GetType()); + TestCall{defaults, table, "idint"}.Push(Const(Scalar{})).DoCall(); + TestCall{defaults, table, "idint"} + .Push(Const(Scalar{})) + .DoCall(Int4::GetType()); // Allowed as extensions - TestCall{table, "float"}.Push(Const(Scalar{})).DoCall(Real4::GetType()); - TestCall{table, "idint"}.Push(Const(Scalar{})).DoCall(Int4::GetType()); + TestCall{defaults, table, "float"} + .Push(Const(Scalar{})) + .DoCall(Real4::GetType()); + TestCall{defaults, table, "idint"} + .Push(Const(Scalar{})) + .DoCall(Int4::GetType()); // TODO: test other intrinsics } } diff --git a/flang/test/semantics/CMakeLists.txt b/flang/test/semantics/CMakeLists.txt index 0178833638df..2251fbfc2a84 100644 --- a/flang/test/semantics/CMakeLists.txt +++ b/flang/test/semantics/CMakeLists.txt @@ -170,6 +170,7 @@ set(ERROR_TESTS blockconstruct03.f90 call01.f90 call02.f90 + call03.f90 call13.f90 ) diff --git a/flang/test/semantics/call03.f90 b/flang/test/semantics/call03.f90 index b4aa0d4742c6..e66b78fe0aa3 100644 --- a/flang/test/semantics/call03.f90 +++ b/flang/test/semantics/call03.f90 @@ -48,6 +48,9 @@ module m01 subroutine poly(x) class(t), intent(in) :: x end subroutine + subroutine polyassumedsize(x) + class(t), intent(in) :: x(*) + end subroutine subroutine assumedsize(x) real :: x(*) end subroutine @@ -87,7 +90,7 @@ module m01 subroutine test01(x) ! 15.5.2.4(2) class(t), intent(in) :: x[*] - !ERROR: coindexed polymorphic effective argument cannot be associated with a polymorphic dummy argument + !ERROR: Coindexed polymorphic object may not be associated with a polymorphic dummy argument call poly(x[1]) end subroutine @@ -96,7 +99,7 @@ module m01 end subroutine subroutine test02(x) ! 15.5.2.4(2) class(t), intent(in) :: x(*) - !ERROR: assumed-size polymorphic array cannot be associated with a monomorphic dummy argument + !ERROR: Assumed-size polymorphic array may not be associated with a monomorphic dummy argument call mono(x) end subroutine @@ -105,19 +108,19 @@ module m01 end subroutine subroutine test03 ! 15.5.2.4(2) type(pdt(0)) :: x - !ERROR: effective argument associated with TYPE(*) dummy argument cannot have a parameterized derived type + !ERROR: Actual argument associated with TYPE(*) dummy argument may not have a parameterized derived type call typestar(x) end subroutine subroutine test04 ! 15.5.2.4(2) type(tbp) :: x - !ERROR: effective argument associated with TYPE(*) dummy argument cannot have type-bound procedures + !ERROR: Actual argument associated with TYPE(*) dummy argument may not have type-bound procedures call typestar(x) end subroutine subroutine test05 ! 15.5.2.4(2) type(final) :: x - !ERROR: effective argument associated with TYPE(*) dummy argument cannot have FINAL procedures + !ERROR: Actual argument associated with TYPE(*) dummy argument may not have FINAL procedures call typestar(x) end subroutine @@ -126,9 +129,9 @@ module m01 end subroutine subroutine test06 ! 15.5.2.4(4) character :: ch1 - !ERROR: Length of effective character argument is less than required by dummy argument + !ERROR: Actual length '1' is less than expected length '2' call ch2(ch1) - !ERROR: Length of effective character argument is less than required by dummy argument + !ERROR: Actual length '1' is less than expected length '2' call ch2(' ') end subroutine @@ -137,14 +140,14 @@ module m01 end subroutine subroutine test07(x) ! 15.5.2.4(6) type(alloc) :: x[*] - !ERROR: coindexed effective argument with ALLOCATABLE ultimate component must be associated with a dummy argument with VALUE or INTENT(IN) attributes + !ERROR: Coindexed actual argument with ALLOCATABLE ultimate component must be associated with a dummy argument with VALUE or INTENT(IN) attributes call out01(x[1]) end subroutine subroutine test08(x) ! 15.5.2.4(13) - real :: x[*] - !ERROR: a coindexed scalar argument must be associated with a scalar dummy argument - call assumedsize(x[1]) + real :: x(1)[*] + !ERROR: Coindexed scalar actual argument must be associated with a scalar dummy argument + call assumedsize(x(1)[1]) end subroutine subroutine charray(x) @@ -156,14 +159,14 @@ module m01 real :: ashape(:) class(t) :: polyarray(*) character(10) :: c(:) - !ERROR: whole scalar argument cannot be associated with a dummy argument array + !ERROR: Whole scalar actual argument may not be associated with a dummy argument array call assumedsize(x) - !ERROR: element of pointer array cannot be associated with a dummy argument array + !ERROR: Element of pointer array may not be associated with a dummy argument array call assumedsize(p(1)) - !ERROR: element of assumed-shape array cannot be associated with a dummy argument array + !ERROR: Element of assumed-shape array may not be associated with a dummy argument array call assumedsize(ashape(1)) - !ERROR: element of polymorphic array cannot be associated with a dummy argument array - call poly(polyarray(1)) + !ERROR: Element of polymorphic array may not be associated with a dummy argument array + call polyassumedsize(polyarray(1)) call charray(c(1:1)) ! not an error if character call assumedsize(arr(1)) ! not an error if element in sequence call assumedrank(x) ! not an error @@ -171,33 +174,37 @@ module m01 end subroutine subroutine test10(a) ! 15.5.2.4(16) - real :: scalar, matrix + real :: scalar, matrix(2,3) real :: a(*) - !ERROR: rank of effective argument (0) differs from assumed-shape dummy argument (1) + !ERROR: Rank of actual argument (0) differs from assumed-shape dummy argument (1) call assumedshape(scalar) - !ERROR: rank of effective argument (2) differs from assumed-shape dummy argument (1) + !ERROR: Rank of actual argument (2) differs from assumed-shape dummy argument (1) call assumedshape(matrix) - !ERROR: assumed-size array cannot be associated with assumed-shape dummy argument + !ERROR: Assumed-size array cannot be associated with assumed-shape dummy argument + call assumedshape(a) end subroutine subroutine test11(in) ! C15.5.2.4(20) real, intent(in) :: in real :: x - !ERROR: effective argument associated with INTENT(OUT) dummy must be definable - call intentout(in) - !ERROR: effective argument associated with INTENT(OUT) dummy must be definable - call intentout(3.14159) - !ERROR: effective argument associated with INTENT(OUT) dummy must be definable - call intentout(in + 1.) - !ERROR: effective argument associated with INTENT(IN OUT) dummy must be definable - call intentinout(in) - !ERROR: effective argument associated with INTENT(IN OUT) dummy must be definable - call intentinout(3.14159) - !ERROR: effective argument associated with INTENT(IN OUT) dummy must be definable - call intentinout(in + 1.) x = 0. + !ERROR: Actual argument associated with INTENT(OUT) dummy must be definable + call intentout(in) + !ERROR: Actual argument associated with INTENT(OUT) dummy must be definable + call intentout(3.14159) + !ERROR: Actual argument associated with INTENT(OUT) dummy must be definable + call intentout(in + 1.) + !ERROR: Actual argument associated with INTENT(OUT) dummy must be definable + call intentout(x) ! ok + !ERROR: Actual argument associated with INTENT(OUT) dummy must be definable + call intentout((x)) + call intentinout(in) + !ERROR: Actual argument associated with INTENT(IN OUT) dummy must be definable + call intentinout(3.14159) + !ERROR: Actual argument associated with INTENT(IN OUT) dummy must be definable + call intentinout(in + 1.) call intentinout(x) ! ok - !ERROR: effective argument associated with INTENT(IN OUT) dummy must be definable + !ERROR: Actual argument associated with INTENT(IN OUT) dummy must be definable call intentinout((x)) end subroutine