maxjhandsome
/
llvm-project
forked from OSchip/llvm-project
1
0
Fork 0
Code Issues Pull Requests Packages Releases Wiki Activity

[flang] checkpoint 

checkpoint

checkpoint

Original-commit: flang-compiler/f18@99d12a7215
Reviewed-on: https://github.com/flang-compiler/f18/pull/782
Tree-same-pre-rewrite: false
This commit is contained in:
peter klausler 2019-10-08 15:21:09 -07:00
parent ea7240c3de
commit b71355ca1e
21 changed files with 569 additions and 266 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
flang/lib/common/idioms.h
View File

@ -144,7 +144,7 @@ template<typename A> struct ListItemCount {
// Check that a pointer is non-null and dereference it
#define DEREF(p) Fortran::common::Deref(p, __FILE__, __LINE__)
template<typename T> T &Deref(T *p, const char *file, int line) {
template<typename T> constexpr T &Deref(T *p, const char *file, int line) {
if (p == nullptr) {
Fortran::common::die("nullptr dereference at %s(%d)", file, line);
}

118
flang/lib/evaluate/characteristics.cc
View File

@ -98,6 +98,30 @@ std::optional<TypeAndShape> TypeAndShape::Characterize(
}
}
std::optional<TypeAndShape> TypeAndShape::Characterize(
const Expr<SomeType> &expr, FoldingContext &context) {
if (const auto *symbol{UnwrapWholeSymbolDataRef(expr)}) {
if (const auto *object{
symbol->detailsIf<semantics::ObjectEntityDetails>()}) {
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<SomeCharacter>>(expr)}) {
if (auto length{chExpr->LEN()}) {
result.set_LEN(Expr<SomeInteger>{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> DummyArgument::Characterize(
return std::nullopt;
}
std::optional<DummyArgument> DummyArgument::FromActual(
std::string &&name, const Expr<SomeType> &expr, FoldingContext &context) {
return std::visit(
common::visitors{
[&](const BOZLiteralConstant &) {
return std::make_optional<DummyArgument>(std::move(name),
DummyDataObject{
TypeAndShape{DynamicType::TypelessIntrinsicArgument()}});
},
[&](const NullPointer &) { return std::optional<DummyArgument>{}; },
[&](const ProcedureDesignator &designator) {
if (auto proc{Procedure::Characterize(
designator, context.intrinsics())}) {
return std::make_optional<DummyArgument>(
std::move(name), DummyProcedure{std::move(*proc)});
} else {
return std::optional<DummyArgument>{};
}
},
[&](const ProcedureRef &call) {
if (auto proc{
Procedure::Characterize(call, context.intrinsics())}) {
return std::make_optional<DummyArgument>(
std::move(name), DummyProcedure{std::move(*proc)});
} else {
return std::optional<DummyArgument>{};
}
},
[&](const auto &) {
if (auto type{expr.GetType()}) {
if (auto shape{GetShape(context, expr)}) {
return std::make_optional<DummyArgument>(std::move(name),
DummyDataObject{TypeAndShape{*type, std::move(*shape)}});
} else {
return std::make_optional<DummyArgument>(
std::move(name), DummyDataObject{TypeAndShape{*type}});
}
} else {
return std::optional<DummyArgument>{};
}
},
},
expr.u);
}
bool DummyArgument::IsOptional() const {
return std::visit(
common::visitors{
@ -466,15 +538,6 @@ std::optional<Procedure> 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> 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> Procedure::Characterize(
}
}
return result;
} else {
return std::optional<Procedure>{};
}
return std::optional<Procedure>{};
},
[&](const semantics::UseDetails &use) {
return Characterize(use.symbol(), intrinsics);

33
flang/lib/evaluate/characteristics.h
View File

@ -64,6 +64,12 @@ public:
TypeAndShape(DynamicType t, Shape &&s) : type_{t}, shape_{std::move(s)} {
AcquireLEN();
}
TypeAndShape(DynamicType t, std::optional<Shape> &&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<TypeAndShape> Characterize(
const semantics::DeclTypeSpec &);
static std::optional<TypeAndShape> Characterize(
const Expr<SomeType> &, FoldingContext &);
template<typename A>
static std::optional<TypeAndShape> Characterize(const A *p) {
return p ? Characterize(*p) : std::nullopt;
@ -111,25 +119,6 @@ protected:
Attrs attrs_;
};
template<typename T>
std::optional<TypeAndShape> GetTypeAndShape(
const Expr<T> &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<SomeCharacter>>(expr)}) {
if (auto length{chExpr->LEN()}) {
result.set_LEN(Expr<SomeInteger>{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<DummyArgument> Characterize(
const semantics::Symbol &, const IntrinsicProcTable &);
static std::optional<DummyArgument> FromActual(
std::string &&, const Expr<SomeType> &, FoldingContext &);
bool IsOptional() const;
void SetOptional(bool = true);
bool CanBePassedViaImplicitInterface() const;

169
flang/lib/evaluate/check-call.cc
View File

@ -17,6 +17,7 @@
#include "shape.h"
#include "tools.h"
#include "../parser/message.h"
#include "../semantics/scope.h"
#include <map>
#include <string>
@ -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<semantics::ObjectEntityDetails>()}) {
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<semantics::ProcBindingDetails>()) {
concerns.typeBoundProcedure = &component;
} else if (component.has<semantics::FinalProcDetails>()) {
concerns.finalProcedure = &component;
}
}
}
}
static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy,
const Expr<SomeType> &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<semantics::ObjectEntityDetails>()
: 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<BOZLiteralConstant>(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 &) {

19
flang/lib/evaluate/common.h
View File

@ -32,6 +32,7 @@ class DerivedTypeSpec;
}
namespace Fortran::evaluate {
class IntrinsicProcTable;
using common::ConstantSubscript;
using common::RelationalOperator;
@ -207,21 +208,23 @@ template<typename A> 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<ConstantSubscript> 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};

14
flang/lib/evaluate/fold.cc
View File

@ -1213,7 +1213,7 @@ std::optional<Expr<T>> 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<Expr<T>> 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<RESULT> 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<RESULT> 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<RESULT> MapOperation(FoldingContext &context,
Fold(context, f(std::move(leftScalar), Expr<RIGHT>{rightScalar})));
}
return FromArrayConstructor(
context, std::move(result), AsConstantExtents(shape));
context, std::move(result), AsConstantExtents(context, shape));
}
// scalar * array case
@ -1892,7 +1892,7 @@ Expr<RESULT> 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

2
flang/lib/evaluate/formatting.cc
View File

@ -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_) + ')';

40
flang/lib/evaluate/intrinsics.cc
View File

@ -1209,7 +1209,7 @@ std::optional<SpecificCall> 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<SpecificCall> IntrinsicInterface::Match(
const IntrinsicDummyArgument &d{dummy[std::min(j, dummyArgPatterns - 1)]};
if (const auto &arg{rearranged[j]}) {
if (const Expr<SomeType> *expr{arg->UnwrapExpr()}) {
std::optional<characteristics::TypeAndShape> 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<characteristics::TypeAndShape> 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);

144
flang/lib/evaluate/shape.cc
View File

@ -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 <functional>
using namespace std::placeholders; // _1, _2, &c. for std::bind()
namespace Fortran::evaluate {
@ -89,11 +93,10 @@ std::optional<ExtentExpr> AsExtentArrayExpr(const Shape &shape) {
return ExtentExpr{ArrayConstructor<ExtentType>{std::move(values)}};
}
std::optional<Constant<ExtentType>> AsConstantShape(const Shape &shape) {
std::optional<Constant<ExtentType>> 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<ExtentType>(folded)}) {
return std::move(*p);
}
@ -118,43 +121,44 @@ ConstantSubscripts AsConstantExtents(const Constant<ExtentType> &shape) {
return result;
}
std::optional<ConstantSubscripts> AsConstantExtents(const Shape &shape) {
if (auto shapeConstant{AsConstantShape(shape)}) {
std::optional<ConstantSubscripts> 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<ExtentType>{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<ExtentExpr(ExtentExpr &&, ExtentExpr &&, ExtentExpr &&)> 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<semantics::ObjectEntityDetails>()}) {
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<semantics::ObjectEntityDetails>()) {
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<SpecificIntrinsic>(&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<SomeInteger> shape{std::get<Expr<SomeInteger>>(shapeExpr->u)};
auto shape{std::get<Expr<SomeInteger>>(DEREF(shapeExpr).u)};
return AsShape(context_, ConvertToType<ExtentType>(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
}

22
flang/lib/evaluate/shape.h
View File

@ -49,11 +49,13 @@ std::optional<Shape> AsShape(FoldingContext &, ExtentExpr &&);
std::optional<ExtentExpr> AsExtentArrayExpr(const Shape &);
std::optional<Constant<ExtentType>> AsConstantShape(const Shape &);
std::optional<Constant<ExtentType>> AsConstantShape(
FoldingContext &, const Shape &);
Constant<ExtentType> AsConstantShape(const ConstantSubscripts &);
ConstantSubscripts AsConstantExtents(const Constant<ExtentType> &);
std::optional<ConstantSubscripts> AsConstantExtents(const Shape &);
std::optional<ConstantSubscripts> AsConstantExtents(
FoldingContext &, const Shape &);
inline int GetRank(const Shape &s) { return static_cast<int>(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;

42
flang/lib/evaluate/tools.cc
View File

@ -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<SomeType> &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<TypeCategory CAT, int KIND>
bool IsNullPointer(const Expr<Type<CAT, KIND>> &expr) {
const auto *call{std::get_if<FunctionRef<Type<CAT, KIND>>>(&expr.u)};
return call && IsNullPointer(*call);
}
template<TypeCategory CAT> bool IsNullPointer(const Expr<SomeKind<CAT>> &expr) {
return std::visit([](const auto &x) { return IsNullPointer(x); }, expr.u);
}
bool IsNullPointer(const Expr<SomeDerived> &expr) {
const auto *call{std::get_if<FunctionRef<SomeDerived>>(&expr.u)};
return call && IsNullPointer(*call);
}
bool IsNullPointer(const Expr<SomeType> &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 {

14
flang/lib/evaluate/tools.h
View File

@ -754,17 +754,9 @@ template<typename A> bool IsAllocatableOrPointer(const A &x) {
semantics::Attrs{semantics::Attr::POINTER, semantics::Attr::ALLOCATABLE});
}
// Predicate: IsProcedurePointer()
template<typename A> 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<SomeType> &expr) {
return std::visit(
[](const auto &x) { return IsProcedurePointer(x); }, expr.u);
}
template<typename A> bool IsProcedurePointer(const std::optional<A> &x) {
return x.has_value() && IsProcedurePointer(*x);
}
// Pointer detection predicates
bool IsProcedurePointer(const Expr<SomeType> &);
bool IsNullPointer(const Expr<SomeType> &);
// GetLastTarget() returns the rightmost symbol in an object
// designator (which has perhaps been wrapped in an Expr<>) that has the

26
flang/lib/evaluate/type.cc
View File

@ -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<semantics::ObjectEntityDetails>()}) {
if (const auto *yObject{y.detailsIf<semantics::ObjectEntityDetails>()}) {
#else
if (x.has<semantics::ObjectEntityDetails>()) {
if (y.has<semantics::ObjectEntityDetails>()) {
#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,

7
flang/lib/evaluate/type.h
View File

@ -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(*)

5
flang/lib/semantics/semantics.cc
View File

@ -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() {}

2
flang/lib/semantics/semantics.h
View File

@ -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_;

4
flang/test/evaluate/expression.cc
View File

@ -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 <cstdio>
@ -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}));

7
flang/test/evaluate/folding.cc
View File

@ -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 <tuple>
@ -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{

91
flang/test/evaluate/intrinsics.cc
View File

@ -69,7 +69,9 @@ template<typename A> static NamedArg<A> 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<typename A> 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<SpecificCall> 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<TypeCategory::Character, 1>;
using Log4 = Type<TypeCategory::Logical, 4>;
TestCall{table, "bad"}
TestCall{defaults, table, "bad"}
.Push(Const(Scalar<Int4>{}))
.DoCall(); // bad intrinsic name
TestCall{table, "abs"}
TestCall{defaults, table, "abs"}
.Push(Named("a", Const(Scalar<Int4>{})))
.DoCall(Int4::GetType());
TestCall{table, "abs"}.Push(Const(Scalar<Int4>{})).DoCall(Int4::GetType());
TestCall{table, "abs"}
TestCall{defaults, table, "abs"}
.Push(Const(Scalar<Int4>{}))
.DoCall(Int4::GetType());
TestCall{defaults, table, "abs"}
.Push(Named("bad", Const(Scalar<Int4>{})))
.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<Int4>{}))
.Push(Const(Scalar<Int4>{}))
.DoCall(); // too many args
TestCall{table, "abs"}
TestCall{defaults, table, "abs"}
.Push(Const(Scalar<Int4>{}))
.Push(Named("a", Const(Scalar<Int4>{})))
.DoCall();
TestCall{table, "abs"}
TestCall{defaults, table, "abs"}
.Push(Named("a", Const(Scalar<Int4>{})))
.Push(Const(Scalar<Int4>{}))
.DoCall();
TestCall{table, "abs"}.Push(Const(Scalar<Int1>{})).DoCall(Int1::GetType());
TestCall{table, "abs"}.Push(Const(Scalar<Int4>{})).DoCall(Int4::GetType());
TestCall{table, "abs"}.Push(Const(Scalar<Int8>{})).DoCall(Int8::GetType());
TestCall{table, "abs"}.Push(Const(Scalar<Real4>{})).DoCall(Real4::GetType());
TestCall{table, "abs"}.Push(Const(Scalar<Real8>{})).DoCall(Real8::GetType());
TestCall{table, "abs"}
TestCall{defaults, table, "abs"}
.Push(Const(Scalar<Int1>{}))
.DoCall(Int1::GetType());
TestCall{defaults, table, "abs"}
.Push(Const(Scalar<Int4>{}))
.DoCall(Int4::GetType());
TestCall{defaults, table, "abs"}
.Push(Const(Scalar<Int8>{}))
.DoCall(Int8::GetType());
TestCall{defaults, table, "abs"}
.Push(Const(Scalar<Real4>{}))
.DoCall(Real4::GetType());
TestCall{defaults, table, "abs"}
.Push(Const(Scalar<Real8>{}))
.DoCall(Real8::GetType());
TestCall{defaults, table, "abs"}
.Push(Const(Scalar<Complex4>{}))
.DoCall(Real4::GetType());
TestCall{table, "abs"}
TestCall{defaults, table, "abs"}
.Push(Const(Scalar<Complex8>{}))
.DoCall(Real8::GetType());
TestCall{table, "abs"}.Push(Const(Scalar<Char>{})).DoCall();
TestCall{table, "abs"}.Push(Const(Scalar<Log4>{})).DoCall();
TestCall{defaults, table, "abs"}.Push(Const(Scalar<Char>{})).DoCall();
TestCall{defaults, table, "abs"}.Push(Const(Scalar<Log4>{})).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<Real4>{}));
maxCallI.Push(Const(Scalar<Int4>{}));
@ -228,25 +243,33 @@ void TestIntrinsics() {
amin1Call.DoCall(Real4::GetType());
amin1ExtCall.DoCall(Real4::GetType());
TestCall{table, "conjg"}
TestCall{defaults, table, "conjg"}
.Push(Const(Scalar<Complex4>{}))
.DoCall(Complex4::GetType());
TestCall{table, "conjg"}
TestCall{defaults, table, "conjg"}
.Push(Const(Scalar<Complex8>{}))
.DoCall(Complex8::GetType());
TestCall{table, "dconjg"}.Push(Const(Scalar<Complex4>{})).DoCall();
TestCall{table, "dconjg"}
TestCall{defaults, table, "dconjg"}.Push(Const(Scalar<Complex4>{})).DoCall();
TestCall{defaults, table, "dconjg"}
.Push(Const(Scalar<Complex8>{}))
.DoCall(Complex8::GetType());
TestCall{table, "float"}.Push(Const(Scalar<Real4>{})).DoCall();
TestCall{table, "float"}.Push(Const(Scalar<Int4>{})).DoCall(Real4::GetType());
TestCall{table, "idint"}.Push(Const(Scalar<Int4>{})).DoCall();
TestCall{table, "idint"}.Push(Const(Scalar<Real8>{})).DoCall(Int4::GetType());
TestCall{defaults, table, "float"}.Push(Const(Scalar<Real4>{})).DoCall();
TestCall{defaults, table, "float"}
.Push(Const(Scalar<Int4>{}))
.DoCall(Real4::GetType());
TestCall{defaults, table, "idint"}.Push(Const(Scalar<Int4>{})).DoCall();
TestCall{defaults, table, "idint"}
.Push(Const(Scalar<Real8>{}))
.DoCall(Int4::GetType());
// Allowed as extensions
TestCall{table, "float"}.Push(Const(Scalar<Int8>{})).DoCall(Real4::GetType());
TestCall{table, "idint"}.Push(Const(Scalar<Real4>{})).DoCall(Int4::GetType());
TestCall{defaults, table, "float"}
.Push(Const(Scalar<Int8>{}))
.DoCall(Real4::GetType());
TestCall{defaults, table, "idint"}
.Push(Const(Scalar<Real4>{}))
.DoCall(Int4::GetType());
// TODO: test other intrinsics
}
}

1
flang/test/semantics/CMakeLists.txt
View File

@ -170,6 +170,7 @@ set(ERROR_TESTS
blockconstruct03.f90
call01.f90
call02.f90
call03.f90
call13.f90
)

73
flang/test/semantics/call03.f90
View File

@ -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