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

[flang] lib/evaluate work for structure constructors 

Original-commit: flang-compiler/f18@76a192f9c9
Reviewed-on: https://github.com/flang-compiler/f18/pull/439
This commit is contained in:
peter klausler 2019-05-03 11:29:15 -07:00
parent c1fa835a71
commit 25e6f03443
23 changed files with 738 additions and 395 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

61
flang/lib/evaluate/call.cc
View File

@ -13,6 +13,7 @@
// limitations under the License.
#include "call.h"
#include "characteristics.h"
#include "expression.h"
#include "tools.h"
#include "../common/idioms.h"
@ -61,9 +62,17 @@ bool ActualArgument::operator==(const ActualArgument &that) const {
isAlternateReturn == that.isAlternateReturn && u_ == that.u_;
}
SpecificIntrinsic::SpecificIntrinsic(
IntrinsicProcedure n, characteristics::Procedure &&chars)
: name{n}, characteristics{new characteristics::Procedure{std::move(chars)}} {
}
DEFINE_DEFAULT_CONSTRUCTORS_AND_ASSIGNMENTS(SpecificIntrinsic)
SpecificIntrinsic::~SpecificIntrinsic() {}
bool SpecificIntrinsic::operator==(const SpecificIntrinsic &that) const {
return name == that.name && type == that.type && rank == that.rank &&
attrs == that.attrs;
return name == that.name && characteristics == that.characteristics;
}
ProcedureDesignator::ProcedureDesignator(Component &&c)
@ -71,10 +80,15 @@ ProcedureDesignator::ProcedureDesignator(Component &&c)
std::optional<DynamicType> ProcedureDesignator::GetType() const {
if (const auto *intrinsic{std::get_if<SpecificIntrinsic>(&u)}) {
return intrinsic->type;
if (const auto &result{intrinsic->characteristics.value().functionResult}) {
if (const auto *typeAndShape{result->GetTypeAndShape()}) {
return typeAndShape->type();
}
}
} else {
return GetSymbolType(GetSymbol());
return DynamicType::From(GetSymbol());
}
return std::nullopt;
}
int ProcedureDesignator::Rank() const {
@ -82,9 +96,14 @@ int ProcedureDesignator::Rank() const {
return symbol->Rank();
}
if (const auto *intrinsic{std::get_if<SpecificIntrinsic>(&u)}) {
return intrinsic->rank;
if (const auto &result{intrinsic->characteristics.value().functionResult}) {
if (const auto *typeAndShape{result->GetTypeAndShape()}) {
CHECK(!typeAndShape->IsAssumedRank());
return typeAndShape->Rank();
}
}
}
CHECK(!"ProcedureDesignator::Rank(): no case");
common::die("ProcedureDesignator::Rank(): no case");
return 0;
}
@ -93,12 +112,25 @@ bool ProcedureDesignator::IsElemental() const {
return symbol->attrs().test(semantics::Attr::ELEMENTAL);
}
if (const auto *intrinsic{std::get_if<SpecificIntrinsic>(&u)}) {
return intrinsic->attrs.test(semantics::Attr::ELEMENTAL);
return intrinsic->characteristics.value().attrs.test(
characteristics::Procedure::Attr::Elemental);
}
CHECK(!"ProcedureDesignator::IsElemental(): no case");
common::die("ProcedureDesignator::IsElemental(): no case");
return 0;
}
const SpecificIntrinsic *ProcedureDesignator::GetSpecificIntrinsic() const {
return std::get_if<SpecificIntrinsic>(&u);
}
const Component *ProcedureDesignator::GetComponent() const {
if (auto *c{std::get_if<common::CopyableIndirection<Component>>(&u)}) {
return &c->value();
} else {
return nullptr;
}
}
const Symbol *ProcedureDesignator::GetSymbol() const {
return std::visit(
common::visitors{
@ -111,6 +143,19 @@ const Symbol *ProcedureDesignator::GetSymbol() const {
u);
}
parser::CharBlock ProcedureDesignator::GetName() const {
return std::visit(
common::visitors{
[](const SpecificIntrinsic &i) -> parser::CharBlock {
return i.name;
},
[](const Symbol *sym) -> parser::CharBlock { return sym->name(); },
[](const common::CopyableIndirection<Component> &c)
-> parser::CharBlock { return c.value().GetLastSymbol().name(); },
},
u);
}
Expr<SubscriptInteger> ProcedureRef::LEN() const {
if (const auto *intrinsic{std::get_if<SpecificIntrinsic>(&proc_.u)}) {
if (intrinsic->name == "repeat") {

35
flang/lib/evaluate/call.h
View File

@ -30,12 +30,20 @@ namespace Fortran::semantics {
class Symbol;
}
// Mutually referential data structures are represented here with forward
// declarations of hitherto undefined class types and a level of indirection.
namespace Fortran::evaluate {
class Component;
class IntrinsicProcTable;
}
namespace Fortran::evaluate::characteristics {
struct Procedure;
}
extern template class Fortran::common::Indirection<Fortran::evaluate::Component,
true>;
extern template class Fortran::common::Indirection<
Fortran::evaluate::characteristics::Procedure, true>;
namespace Fortran::evaluate {
@ -116,22 +124,15 @@ using ActualArguments = std::vector<std::optional<ActualArgument>>;
using IntrinsicProcedure = std::string;
struct SpecificIntrinsic {
explicit SpecificIntrinsic(IntrinsicProcedure n) : name{n} {}
SpecificIntrinsic(IntrinsicProcedure n, std::optional<DynamicType> &&dt,
int r, semantics::Attrs a)
: name{n}, type{std::move(dt)}, rank{r}, attrs{a} {}
SpecificIntrinsic(const SpecificIntrinsic &) = default;
SpecificIntrinsic(SpecificIntrinsic &&) = default;
SpecificIntrinsic &operator=(const SpecificIntrinsic &) = default;
SpecificIntrinsic &operator=(SpecificIntrinsic &&) = default;
SpecificIntrinsic(IntrinsicProcedure, characteristics::Procedure &&);
DECLARE_CONSTRUCTORS_AND_ASSIGNMENTS(SpecificIntrinsic)
~SpecificIntrinsic();
bool operator==(const SpecificIntrinsic &) const;
std::ostream &AsFortran(std::ostream &) const;
IntrinsicProcedure name;
bool isRestrictedSpecific{false}; // if true, can only call it
std::optional<DynamicType> type; // absent if subroutine call or NULL()
int rank{0};
semantics::Attrs attrs; // ELEMENTAL, POINTER
bool isRestrictedSpecific{false}; // if true, can only call it, not pass it
common::CopyableIndirection<characteristics::Procedure> characteristics;
};
struct ProcedureDesignator {
@ -139,11 +140,19 @@ struct ProcedureDesignator {
explicit ProcedureDesignator(SpecificIntrinsic &&i) : u{std::move(i)} {}
explicit ProcedureDesignator(const semantics::Symbol &n) : u{&n} {}
explicit ProcedureDesignator(Component &&);
// Exactly one of these will return a non-null pointer.
const SpecificIntrinsic *GetSpecificIntrinsic() const;
const semantics::Symbol *GetSymbol() const; // symbol or component symbol
// Always null if the procedure is intrinsic.
const Component *GetComponent() const;
parser::CharBlock GetName() const;
std::optional<DynamicType> GetType() const;
int Rank() const;
bool IsElemental() const;
Expr<SubscriptInteger> LEN() const;
const semantics::Symbol *GetSymbol() const;
std::ostream &AsFortran(std::ostream &) const;
// TODO: When calling X%F, pass X as PASS argument unless NOPASS

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

@ -17,12 +17,13 @@
#include "tools.h"
#include "type.h"
#include "../common/indirection.h"
#include "../parser/message.h"
#include "../semantics/symbol.h"
#include <ostream>
#include <sstream>
#include <string>
using namespace std::literals::string_literals;
using namespace Fortran::parser::literals;
namespace Fortran::evaluate::characteristics {
@ -31,6 +32,16 @@ bool TypeAndShape::operator==(const TypeAndShape &that) const {
isAssumedRank_ == that.isAssumedRank_;
}
bool TypeAndShape::IsCompatibleWith(
parser::ContextualMessages &messages, const TypeAndShape &that) const {
if (!type_.IsTypeCompatibleWith(that.type_)) {
messages.Say("Target type '%s' is not compatible with '%s'"_err_en_US,
that.type_.AsFortran().c_str(), type_.AsFortran().c_str());
return false;
}
return CheckConformance(messages, shape_, that.shape_);
}
std::optional<TypeAndShape> TypeAndShape::Characterize(
const semantics::Symbol &symbol) {
if (const auto *object{symbol.detailsIf<semantics::ObjectEntityDetails>()}) {
@ -43,18 +54,9 @@ std::optional<TypeAndShape> TypeAndShape::Characterize(
}
}
std::optional<TypeAndShape> TypeAndShape::Characterize(
const semantics::Symbol *symbol) {
if (symbol != nullptr) {
return Characterize(*symbol);
} else {
return std::nullopt;
}
}
std::optional<TypeAndShape> TypeAndShape::Characterize(
const semantics::ObjectEntityDetails &object) {
if (auto type{AsDynamicType(object.type())}) {
if (auto type{DynamicType::From(object.type())}) {
TypeAndShape result{std::move(*type)};
result.AcquireShape(object);
return result;
@ -79,22 +81,13 @@ std::optional<TypeAndShape> TypeAndShape::Characterize(
std::optional<TypeAndShape> TypeAndShape::Characterize(
const semantics::DeclTypeSpec &spec) {
if (auto type{AsDynamicType(spec)}) {
if (auto type{DynamicType::From(spec)}) {
return TypeAndShape{std::move(*type)};
} else {
return std::nullopt;
}
}
std::optional<TypeAndShape> TypeAndShape::Characterize(
const semantics::DeclTypeSpec *spec) {
if (spec != nullptr) {
return Characterize(*spec);
} else {
return std::nullopt;
}
}
void TypeAndShape::AcquireShape(const semantics::ObjectEntityDetails &object) {
CHECK(shape_.empty() && !isAssumedRank_);
if (object.IsAssumedRank()) {
@ -138,8 +131,8 @@ std::ostream &TypeAndShape::Dump(std::ostream &o) const {
}
bool DummyDataObject::operator==(const DummyDataObject &that) const {
return TypeAndShape::operator==(that) && attrs == that.attrs &&
intent == that.intent && coshape == that.coshape;
return type == that.type && attrs == that.attrs && intent == that.intent &&
coshape == that.coshape;
}
std::ostream &DummyDataObject::Dump(std::ostream &o) const {
@ -147,7 +140,7 @@ std::ostream &DummyDataObject::Dump(std::ostream &o) const {
if (intent != common::Intent::Default) {
o << "INTENT(" << common::EnumToString(intent) << ')';
}
TypeAndShape::Dump(o);
type.Dump(o);
if (!coshape.empty()) {
char sep{'['};
for (const auto &expr : coshape) {
@ -338,6 +331,11 @@ bool FunctionResult::IsAssumedLengthCharacter() const {
}
}
Procedure::Procedure(FunctionResult &&fr, DummyArguments &&args, Attrs a)
: functionResult{std::move(fr)}, dummyArguments{std::move(args)}, attrs{a} {}
Procedure::Procedure(DummyArguments &&args, Attrs a)
: dummyArguments{std::move(args)}, attrs{a} {}
static void SetProcedureAttrs(
Procedure &procedure, const semantics::Symbol &symbol) {
if (symbol.attrs().test(semantics::Attr::PURE)) {
@ -353,8 +351,8 @@ static void SetProcedureAttrs(
std::optional<Procedure> Procedure::Characterize(
const semantics::Symbol &symbol, const IntrinsicProcTable &intrinsics) {
Procedure result;
if (const auto *subp{symbol.detailsIf<semantics::SubprogramDetails>()}) {
Procedure result;
if (subp->isFunction()) {
if (auto maybeResult{
FunctionResult::Characterize(subp->result(), intrinsics)}) {
@ -375,7 +373,7 @@ std::optional<Procedure> Procedure::Characterize(
return std::nullopt;
}
}
return std::move(result);
return result;
} else if (const auto *proc{
symbol.detailsIf<semantics::ProcEntityDetails>()}) {
const semantics::ProcInterface &interface{proc->interface()};
@ -389,7 +387,7 @@ std::optional<Procedure> Procedure::Characterize(
} else {
result.attrs.set(Procedure::Attr::ImplicitInterface);
if (const semantics::DeclTypeSpec * type{interface.type()}) {
if (auto resultType{AsDynamicType(*type)}) {
if (auto resultType{DynamicType::From(*type)}) {
result.functionResult = FunctionResult{*resultType};
} else {
return std::nullopt;
@ -400,6 +398,7 @@ std::optional<Procedure> Procedure::Characterize(
}
SetProcedureAttrs(result, symbol);
// The PASS name, if any, is not a characteristic.
return result;
} else if (const auto *misc{symbol.detailsIf<semantics::MiscDetails>()}) {
if (misc->kind() == semantics::MiscDetails::Kind::SpecificIntrinsic) {
if (auto intrinsic{intrinsics.IsUnrestrictedSpecificIntrinsicFunction(
@ -410,6 +409,7 @@ std::optional<Procedure> Procedure::Characterize(
}
return std::nullopt;
}
DEFINE_DEFAULT_CONSTRUCTORS_AND_ASSIGNMENTS(DummyProcedure)
DEFINE_DEFAULT_CONSTRUCTORS_AND_ASSIGNMENTS(FunctionResult)
DEFINE_DEFAULT_CONSTRUCTORS_AND_ASSIGNMENTS(Procedure)

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

@ -21,6 +21,7 @@
#include "common.h"
#include "expression.h"
#include "shape.h"
#include "type.h"
#include "../common/Fortran.h"
#include "../common/enum-set.h"
@ -43,22 +44,23 @@ extern template class Fortran::common::Indirection<
namespace Fortran::evaluate::characteristics {
// Absent components are deferred or assumed.
using Shape = std::vector<std::optional<Expr<SubscriptInteger>>>;
class TypeAndShape {
public:
explicit TypeAndShape(DynamicType t) : type_{t} {}
TypeAndShape(DynamicType t, int rank) : type_{t}, shape_(rank) {}
TypeAndShape(DynamicType t, Shape &&s) : type_{t}, shape_{std::move(s)} {}
DEFAULT_CONSTRUCTORS_AND_ASSIGNMENTS(TypeAndShape)
DynamicType type() const { return type_; }
const Shape &shape() const { return shape_; }
bool IsAssumedRank() const { return isAssumedRank_; }
bool operator==(const TypeAndShape &) const;
bool IsAssumedRank() const { return isAssumedRank_; }
int Rank() const { return static_cast<int>(shape().size()); }
bool IsCompatibleWith(
parser::ContextualMessages &, const TypeAndShape &) const;
static std::optional<TypeAndShape> Characterize(const semantics::Symbol &);
static std::optional<TypeAndShape> Characterize(const semantics::Symbol *);
static std::optional<TypeAndShape> Characterize(
const semantics::ObjectEntityDetails &);
static std::optional<TypeAndShape> Characterize(
@ -67,8 +69,14 @@ public:
const semantics::ProcInterface &);
static std::optional<TypeAndShape> Characterize(
const semantics::DeclTypeSpec &);
static std::optional<TypeAndShape> Characterize(
const semantics::DeclTypeSpec *);
template<typename A>
static std::optional<TypeAndShape> Characterize(const A *p) {
if (p != nullptr) {
return Characterize(*p);
} else {
return std::nullopt;
}
}
std::ostream &Dump(std::ostream &) const;
@ -82,19 +90,21 @@ protected:
};
// 15.3.2.2
struct DummyDataObject : public TypeAndShape {
struct DummyDataObject {
ENUM_CLASS(Attr, Optional, Allocatable, Asynchronous, Contiguous, Value,
Volatile, Pointer, Target)
using Attrs = common::EnumSet<Attr, Attr_enumSize>;
DEFAULT_CONSTRUCTORS_AND_ASSIGNMENTS(DummyDataObject)
explicit DummyDataObject(const TypeAndShape &t) : TypeAndShape{t} {}
explicit DummyDataObject(TypeAndShape &&t) : TypeAndShape{std::move(t)} {}
explicit DummyDataObject(DynamicType t) : TypeAndShape{t} {}
explicit DummyDataObject(const TypeAndShape &t) : type{t} {}
explicit DummyDataObject(TypeAndShape &&t) : type{std::move(t)} {}
explicit DummyDataObject(DynamicType t) : type{t} {}
bool operator==(const DummyDataObject &) const;
static std::optional<DummyDataObject> Characterize(const semantics::Symbol &);
std::ostream &Dump(std::ostream &) const;
TypeAndShape type;
std::vector<Expr<SubscriptInteger>> coshape;
common::Intent intent{common::Intent::Default};
common::EnumSet<Attr, Attr_enumSize> attrs;
Attrs attrs;
};
// 15.3.2.3
@ -119,6 +129,7 @@ struct AlternateReturn {
// 15.3.2.1
using DummyArgument =
std::variant<DummyDataObject, DummyProcedure, AlternateReturn>;
using DummyArguments = std::vector<DummyArgument>;
bool IsOptional(const DummyArgument &);
std::optional<DummyArgument> CharacterizeDummyArgument(
const semantics::Symbol &, const IntrinsicProcTable &);
@ -145,6 +156,10 @@ struct FunctionResult {
return nullptr;
}
}
const TypeAndShape *GetTypeAndShape() const {
return std::get_if<TypeAndShape>(&u);
}
std::ostream &Dump(std::ostream &) const;
common::EnumSet<Attr, Attr_enumSize> attrs;
@ -153,13 +168,18 @@ struct FunctionResult {
// 15.3.1
struct Procedure {
ENUM_CLASS(Attr, Pure, Elemental, BindC, ImplicitInterface)
Procedure() {}
ENUM_CLASS(Attr, Pure, Elemental, BindC, ImplicitInterface, NullPointer)
using Attrs = common::EnumSet<Attr, Attr_enumSize>;
Procedure(FunctionResult &&, DummyArguments &&, Attrs);
Procedure(DummyArguments &&, Attrs); // for subroutines and NULL()
DECLARE_CONSTRUCTORS_AND_ASSIGNMENTS(Procedure)
bool operator==(const Procedure &) const;
// Characterizes the procedure represented by a symbol, which may be an
// "unrestricted specific intrinsic function".
static std::optional<Procedure> Characterize(
const semantics::Symbol &, const IntrinsicProcTable &);
bool IsFunction() const { return functionResult.has_value(); }
bool IsSubroutine() const { return !IsFunction(); }
bool IsPure() const { return attrs.test(Attr::Pure); }
@ -171,8 +191,13 @@ struct Procedure {
std::ostream &Dump(std::ostream &) const;
std::optional<FunctionResult> functionResult;
std::vector<DummyArgument> dummyArguments;
common::EnumSet<Attr, Attr_enumSize> attrs;
DummyArguments dummyArguments;
Attrs attrs;
// TODO pmk: restore private accessibility after merging
// changes to lib/semantics
// private:
Procedure() {}
};
}
#endif // FORTRAN_EVALUATE_CHARACTERISTICS_H_

11
flang/lib/evaluate/expression.cc
View File

@ -73,13 +73,11 @@ std::optional<DynamicType> ExpressionBase<A>::GetType() const {
return Result::GetType();
} else {
return std::visit(
[](const auto &x) -> std::optional<DynamicType> {
using Ty = std::decay_t<decltype(x)>;
if constexpr (!std::is_same_v<Ty, BOZLiteralConstant> &&
!std::is_same_v<Ty, NullPointer>) {
[&](const auto &x) -> std::optional<DynamicType> {
if constexpr (!common::HasMember<decltype(x), TypelessExpression>) {
return x.GetType();
}
return std::nullopt; // typeless really means "no type"
return std::nullopt;
},
derived().u);
}
@ -88,8 +86,7 @@ std::optional<DynamicType> ExpressionBase<A>::GetType() const {
template<typename A> int ExpressionBase<A>::Rank() const {
return std::visit(
[](const auto &x) {
if constexpr (std::is_same_v<std::decay_t<decltype(x)>,
BOZLiteralConstant>) {
if constexpr (common::HasMember<decltype(x), TypelessExpression>) {
return 0;
} else {
return x.Rank();

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

@ -231,6 +231,8 @@ struct Parentheses : public Operation<Parentheses<A>, A, A> {
using Operand = A;
using Base = Operation<Parentheses, A, A>;
using Base::Base;
static const char *Prefix() { return "("; }
static const char *Suffix() { return ")"; }
};
template<typename A> struct Negate : public Operation<Negate<A>, A, A> {
@ -365,6 +367,9 @@ struct ComplexConstructor
using Operand = Type<TypeCategory::Real, KIND>;
using Base = Operation<ComplexConstructor, Result, Operand, Operand>;
using Base::Base;
static const char *Prefix() { return "("; }
static const char *Infix() { return ","; }
static const char *Suffix() { return ")"; }
};
template<int KIND>
@ -784,6 +789,10 @@ public:
common::MapTemplate<Expr, CategoryTypes<TypeCategory::Character>> u;
};
// A variant comprising the Expr<> instantiations over SomeDerived and
// SomeKind<CATEGORY>.
using CategoryExpression = common::MapTemplate<Expr, SomeCategory>;
// BOZ literal "typeless" constants must be wide enough to hold a numeric
// value of any supported kind of INTEGER or REAL. They must also be
// distinguishable from other integer constants, since they are permitted
@ -796,11 +805,18 @@ struct NullPointer {
constexpr int Rank() const { return 0; }
};
// Procedure pointer targets are treated as if they were typeless.
// They are either procedure designators or values returned from
// function references.
using TypelessExpression = std::variant<BOZLiteralConstant, NullPointer,
ProcedureDesignator, ProcedureRef>;
// A completely generic expression, polymorphic across all of the intrinsic type
// categories and each of their kinds.
template<> class Expr<SomeType> : public ExpressionBase<SomeType> {
public:
using Result = SomeType;
EVALUATE_UNION_CLASS_BOILERPLATE(Expr)
// Owning references to these generic expressions can appear in other
@ -827,12 +843,8 @@ public:
return *this;
}
private:
using Others = std::variant<BOZLiteralConstant, NullPointer>;
using Categories = common::MapTemplate<Expr, SomeCategory>;
public:
common::CombineVariants<Others, Categories> u;
common::CombineVariants<TypelessExpression, CategoryExpression> u;
};
// This wrapper class is used, by means of a forward reference with

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

@ -13,6 +13,7 @@
// limitations under the License.
#include "fold.h"
#include "characteristics.h"
#include "common.h"
#include "constant.h"
#include "expression.h"
@ -401,9 +402,7 @@ Expr<Type<TypeCategory::Integer, KIND>> FoldOperation(FoldingContext &context,
[&](auto &&x) -> Expr<T> {
using From = std::decay_t<decltype(x)>;
if constexpr (std::is_same_v<From, BOZLiteralConstant> ||
std::is_same_v<From, Expr<SomeReal>> ||
std::is_same_v<From, Expr<SomeInteger>> ||
std::is_same_v<From, Expr<SomeComplex>>) {
IsNumericCategoryExpr<From>()) {
return Fold(context, ConvertToType<T>(std::move(x)));
}
common::die("int() argument type not valid");
@ -451,13 +450,7 @@ Expr<Type<TypeCategory::Integer, KIND>> FoldOperation(FoldingContext &context,
} else if (name == "len") {
if (auto *charExpr{UnwrapArgument<SomeCharacter>(args[0])}) {
return std::visit(
[&](auto &kx) {
if constexpr (std::is_same_v<T, SubscriptInteger>) {
return kx.LEN();
} else {
return Fold(context, ConvertToType<T>(kx.LEN()));
}
},
[&](auto &kx) { return Fold(context, ConvertToType<T>(kx.LEN())); },
charExpr->u);
} else {
common::die("len() argument must be of character type");
@ -535,6 +528,36 @@ Expr<Type<TypeCategory::Integer, KIND>> FoldOperation(FoldingContext &context,
return Expr<T>{std::move(funcRef)};
}
template<int KIND>
Expr<Type<TypeCategory::Real, KIND>> ToReal(
FoldingContext &context, Expr<SomeType> &&expr) {
using Result = Type<TypeCategory::Real, KIND>;
std::optional<Expr<Result>> result;
std::visit(
[&](auto &&x) {
using From = std::decay_t<decltype(x)>;
if constexpr (std::is_same_v<From, BOZLiteralConstant>) {
// Move the bits without any integer->real conversion
From original{x};
result = ConvertToType<Result>(std::move(x));
const auto *constant{UnwrapExpr<Constant<Result>>(*result)};
CHECK(constant != nullptr);
const Scalar<Result> &real{**constant};
From converted{From::ConvertUnsigned(real.RawBits()).value};
if (!(original == converted)) { // C1601
context.messages().Say(
"Nonzero bits truncated from BOZ literal constant in REAL intrinsic"_en_US);
}
} else if constexpr (IsNumericCategoryExpr<From>()) {
result = Fold(context, ConvertToType<Result>(std::move(x)));
} else {
common::die("ToReal: bad argument expression");
}
},
std::move(expr.u));
return result.value();
}
template<int KIND>
Expr<Type<TypeCategory::Real, KIND>> FoldOperation(FoldingContext &context,
FunctionRef<Type<TypeCategory::Real, KIND>> &&funcRef) {
@ -655,25 +678,7 @@ Expr<Type<TypeCategory::Real, KIND>> FoldOperation(FoldingContext &context,
return Expr<T>{Constant<T>{Scalar<T>::EPSILON()}};
} else if (name == "real") {
if (auto *expr{args[0].value().GetExpr()}) {
return std::visit(
[&](auto &&x) -> Expr<T> {
using From = std::decay_t<decltype(x)>;
if constexpr (std::is_same_v<From, BOZLiteralConstant>) {
typename T::Scalar::Word::ValueWithOverflow result{
T::Scalar::Word::ConvertUnsigned(x)};
if (result.overflow) { // C1601
context.messages().Say(
"Non null truncated bits of boz literal constant in REAL intrinsic"_en_US);
}
return Expr<T>{Constant<T>{Scalar<T>(std::move(result.value))}};
} else if constexpr (std::is_same_v<From, Expr<SomeReal>> ||
std::is_same_v<From, Expr<SomeInteger>> ||
std::is_same_v<From, Expr<SomeComplex>>) {
return Fold(context, ConvertToType<T>(std::move(x)));
}
common::die("real() argument type not valid");
},
std::move(expr->u));
return ToReal<KIND>(context, std::move(*expr));
}
}
// TODO: anint, cshift, dim, dot_product, eoshift, fraction, huge, matmul,
@ -725,25 +730,14 @@ Expr<Type<TypeCategory::Complex, KIND>> FoldOperation(FoldingContext &context,
} else {
CHECK(args.size() == 3);
using Part = typename T::Part;
Expr<SomeType> re{std::move(*args[0].value().GetExpr())};
Expr<SomeType> im{args[1].has_value()
? std::move(*args[1].value().GetExpr())
: AsGenericExpr(Constant<Part>{Scalar<Part>{}})};
Expr<SomeType> re{std::move(*args[0].value().GetExpr())};
int reRank{re.Rank()};
int imRank{im.Rank()};
semantics::Attrs attrs;
attrs.set(semantics::Attr::ELEMENTAL);
auto reReal{
FunctionRef<Part>{ProcedureDesignator{SpecificIntrinsic{
"real", Part::GetType(), reRank, attrs}},
ActualArguments{ActualArgument{std::move(re)}}}};
auto imReal{
FunctionRef<Part>{ProcedureDesignator{SpecificIntrinsic{
"real", Part::GetType(), imRank, attrs}},
ActualArguments{ActualArgument{std::move(im)}}}};
return Fold(context,
Expr<T>{ComplexConstructor<T::kind>{
Expr<Part>{std::move(reReal)}, Expr<Part>{std::move(imReal)}}});
Expr<T>{
ComplexConstructor<KIND>{ToReal<KIND>(context, std::move(re)),
ToReal<KIND>(context, std::move(im))}});
}
}
// TODO: cshift, dot_product, eoshift, matmul, merge, pack, product,
@ -1080,7 +1074,7 @@ Expr<RESULT> MapOperation(FoldingContext &context,
std::function<Expr<RESULT>(Expr<OPERAND> &&)> &&f, const Shape &shape,
Expr<OPERAND> &&values) {
ArrayConstructor<RESULT> result{values};
if constexpr (IsGenericIntrinsicCategoryType<OPERAND>) {
if constexpr (common::HasMember<OPERAND, AllIntrinsicCategoryTypes>) {
std::visit(
[&](auto &&kindExpr) {
using kindType = ResultType<decltype(kindExpr)>;
@ -1110,7 +1104,7 @@ Expr<RESULT> MapOperation(FoldingContext &context,
const Shape &shape, Expr<LEFT> &&leftValues, Expr<RIGHT> &&rightValues) {
ArrayConstructor<RESULT> result{leftValues};
auto &leftArrConst{std::get<ArrayConstructor<LEFT>>(leftValues.u)};
if constexpr (IsGenericIntrinsicCategoryType<RIGHT>) {
if constexpr (common::HasMember<RIGHT, AllIntrinsicCategoryTypes>) {
std::visit(
[&](auto &&kindExpr) {
using kindType = ResultType<decltype(kindExpr)>;
@ -1167,7 +1161,7 @@ Expr<RESULT> MapOperation(FoldingContext &context,
const Shape &shape, const Expr<LEFT> &leftScalar,
Expr<RIGHT> &&rightValues) {
ArrayConstructor<RESULT> result{leftScalar};
if constexpr (IsGenericIntrinsicCategoryType<RIGHT>) {
if constexpr (common::HasMember<RIGHT, AllIntrinsicCategoryTypes>) {
std::visit(
[&](auto &&kindExpr) {
using kindType = ResultType<decltype(kindExpr)>;
@ -1764,14 +1758,11 @@ Expr<T> ExpressionBase<T>::Rewrite(FoldingContext &context, Expr<T> &&expr) {
return FoldOperation(context, std::move(x));
} else if constexpr (std::is_same_v<T, SomeDerived>) {
return FoldOperation(context, std::move(x));
} else if constexpr (common::HasMember<decltype(x),
TypelessExpression>) {
return std::move(expr);
} else {
using Ty = std::decay_t<decltype(x)>;
if constexpr (std::is_same_v<Ty, BOZLiteralConstant> ||
std::is_same_v<Ty, NullPointer>) {
return std::move(expr);
} else {
return Expr<T>{Fold(context, std::move(x))};
}
return Expr<T>{Fold(context, std::move(x))};
}
},
std::move(expr.u));

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

@ -52,7 +52,7 @@ class FoldingContext;
// Note that typeless (BOZ literal) values don't have a distinct type category.
// These typeless arguments are represented in the tables as if they were
// INTEGER with a special "typeless" kind code. Arguments of intrinsic types
// that can also be be typeless values are encoded with an "elementalOrBOZ"
// that can also be typeless values are encoded with an "elementalOrBOZ"
// rank pattern.
// Assumed-type (TYPE(*)) dummy arguments can be forwarded along to some
// intrinsic functions that accept AnyType + Rank::anyOrAssumedRank.
@ -289,7 +289,8 @@ static const IntrinsicInterface genericIntrinsicFunction[]{
{"cmplx", {{"x", AnyComplex}, DefaultingKIND}, KINDComplex},
{"cmplx",
{{"x", SameIntOrReal, Rank::elementalOrBOZ},
{"y", SameIntOrReal, Rank::elementalOrBOZ}, DefaultingKIND},
{"y", SameIntOrReal, Rank::elementalOrBOZ, Optionality::optional},
DefaultingKIND},
KINDComplex},
{"command_argument_count", {}, DefaultInt, Rank::scalar},
{"conjg", {{"z", SameComplex}}, SameComplex},
@ -878,24 +879,35 @@ std::optional<SpecificCall> IntrinsicInterface::Match(
d.typePattern.kindCode == KindCode::any &&
d.rank == Rank::anyOrAssumedRank) {
continue;
} else {
messages.Say("Assumed type TYPE(*) dummy argument not allowed "
"for '%s=' intrinsic argument"_err_en_US,
d.keyword);
return std::nullopt;
}
messages.Say("Assumed type TYPE(*) dummy argument not allowed "
"for '%s=' intrinsic argument"_err_en_US,
d.keyword);
return std::nullopt;
}
std::optional<DynamicType> type{arg->GetType()};
if (!type.has_value()) {
CHECK(arg->Rank() == 0);
if (d.typePattern.kindCode == KindCode::typeless ||
d.rank == Rank::elementalOrBOZ) {
continue;
const Expr<SomeType> *expr{arg->GetExpr()};
CHECK(expr != nullptr);
if (std::holds_alternative<BOZLiteralConstant>(expr->u)) {
if (d.typePattern.kindCode == KindCode::typeless ||
d.rank == Rank::elementalOrBOZ) {
continue;
} else {
messages.Say(
"Typeless (BOZ) not allowed for '%s=' argument"_err_en_US,
d.keyword);
}
} else {
// NULL(), pointer to subroutine, &c.
messages.Say("Typeless item not allowed for '%s=' argument"_err_en_US,
d.keyword);
}
messages.Say(
"typeless (BOZ) not allowed for '%s=' argument"_err_en_US, d.keyword);
return std::nullopt;
} else if (!d.typePattern.categorySet.test(type->category)) {
messages.Say("actual argument for '%s=' has bad type '%s'"_err_en_US,
messages.Say("Actual argument for '%s=' has bad type '%s'"_err_en_US,
d.keyword, type->AsFortran().data());
return std::nullopt; // argument has invalid type category
}
@ -1048,42 +1060,41 @@ std::optional<SpecificCall> IntrinsicInterface::Match(
// Calculate the characteristics of the function result, if any
std::optional<DynamicType> resultType;
if (result.categorySet.empty()) {
if (!call.isSubroutineCall) {
return std::nullopt;
}
CHECK(result.kindCode == KindCode::none);
} else {
// Determine the result type.
if (auto category{result.categorySet.LeastElement()}) {
// The intrinsic is not a subroutine.
if (call.isSubroutineCall) {
return std::nullopt;
}
resultType = DynamicType{result.categorySet.LeastElement().value(), 0};
switch (result.kindCode) {
case KindCode::defaultIntegerKind:
CHECK(result.categorySet == IntType);
CHECK(resultType->category == TypeCategory::Integer);
resultType->kind = defaults.GetDefaultKind(TypeCategory::Integer);
CHECK(*category == TypeCategory::Integer);
resultType = DynamicType{TypeCategory::Integer,
defaults.GetDefaultKind(TypeCategory::Integer)};
break;
case KindCode::defaultRealKind:
CHECK(result.categorySet == CategorySet{resultType->category});
CHECK(FloatingType.test(resultType->category));
resultType->kind = defaults.GetDefaultKind(TypeCategory::Real);
CHECK(result.categorySet == CategorySet{*category});
CHECK(FloatingType.test(*category));
resultType =
DynamicType{*category, defaults.GetDefaultKind(TypeCategory::Real)};
break;
case KindCode::doublePrecision:
CHECK(result.categorySet == RealType);
CHECK(resultType->category == TypeCategory::Real);
resultType->kind = defaults.doublePrecisionKind();
CHECK(*category == TypeCategory::Real);
resultType =
DynamicType{TypeCategory::Real, defaults.doublePrecisionKind()};
break;
case KindCode::defaultCharKind:
CHECK(result.categorySet == CharType);
CHECK(resultType->category == TypeCategory::Character);
resultType->kind = defaults.GetDefaultKind(TypeCategory::Character);
CHECK(*category == TypeCategory::Character);
resultType = DynamicType{TypeCategory::Character,
defaults.GetDefaultKind(TypeCategory::Character)};
break;
case KindCode::defaultLogicalKind:
CHECK(result.categorySet == LogicalType);
CHECK(resultType->category == TypeCategory::Logical);
resultType->kind = defaults.GetDefaultKind(TypeCategory::Logical);
CHECK(*category == TypeCategory::Logical);
resultType = DynamicType{TypeCategory::Logical,
defaults.GetDefaultKind(TypeCategory::Logical)};
break;
case KindCode::same:
CHECK(sameArg != nullptr);
@ -1091,19 +1102,19 @@ std::optional<SpecificCall> IntrinsicInterface::Match(
if (result.categorySet.test(aType->category)) {
resultType = *aType;
} else {
resultType->kind = aType->kind;
resultType = DynamicType{*category, aType->kind};
}
}
break;
case KindCode::effectiveKind:
CHECK(kindDummyArg != nullptr);
CHECK(result.categorySet == CategorySet{resultType->category});
CHECK(result.categorySet == CategorySet{*category});
if (kindArg != nullptr) {
if (auto *expr{kindArg->GetExpr()}) {
CHECK(expr->Rank() == 0);
if (auto code{ToInt64(*expr)}) {
if (IsValidKindOfIntrinsicType(resultType->category, *code)) {
resultType->kind = *code;
if (IsValidKindOfIntrinsicType(*category, *code)) {
resultType = DynamicType{*category, static_cast<int>(*code)};
break;
}
}
@ -1117,12 +1128,13 @@ std::optional<SpecificCall> IntrinsicInterface::Match(
resultType = *sameArg->GetType();
} else if (kindDummyArg->optionality ==
Optionality::defaultsToSubscriptKind) {
CHECK(resultType->category == TypeCategory::Integer);
resultType->kind = defaults.subscriptIntegerKind();
CHECK(*category == TypeCategory::Integer);
resultType =
DynamicType{TypeCategory::Integer, defaults.subscriptIntegerKind()};
} else {
CHECK(kindDummyArg->optionality ==
Optionality::defaultsToDefaultForResult);
resultType->kind = defaults.GetDefaultKind(resultType->category);
resultType = DynamicType{*category, defaults.GetDefaultKind(*category)};
}
break;
case KindCode::likeMultiply:
@ -1142,6 +1154,11 @@ std::optional<SpecificCall> IntrinsicInterface::Match(
break;
default: CRASH_NO_CASE;
}
} else {
if (!call.isSubroutineCall) {
return std::nullopt;
}
CHECK(result.kindCode == KindCode::none);
}
// At this point, the call is acceptable.
@ -1181,11 +1198,6 @@ std::optional<SpecificCall> IntrinsicInterface::Match(
}
CHECK(resultRank >= 0);
semantics::Attrs attrs;
if (elementalRank > 0) {
attrs.set(semantics::Attr::ELEMENTAL);
}
// Rearrange the actual arguments into dummy argument order.
ActualArguments rearranged(dummies);
for (std::size_t j{0}; j < dummies; ++j) {
@ -1194,9 +1206,57 @@ std::optional<SpecificCall> IntrinsicInterface::Match(
}
}
return std::make_optional<SpecificCall>(
SpecificIntrinsic{name, std::move(resultType), resultRank, attrs},
std::move(rearranged));
// Characterize the specific intrinsic function.
characteristics::TypeAndShape typeAndShape{resultType.value(), resultRank};
characteristics::FunctionResult funcResult{std::move(typeAndShape)};
characteristics::DummyArguments dummyArgs;
std::optional<int> sameDummyArg;
for (std::size_t j{0}; j < dummies; ++j) {
const IntrinsicDummyArgument &d{dummy[std::min(j, dummyArgPatterns - 1)]};
if (const auto &arg{rearranged[j]}) {
const Expr<SomeType> *expr{arg->GetExpr()};
CHECK(expr != nullptr);
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(
characteristics::DummyDataObject{std::move(typeAndShape.value())});
if (d.typePattern.kindCode == KindCode::same &&
!sameDummyArg.has_value()) {
sameDummyArg = j;
}
} else {
// optional argument is absent
CHECK(d.optionality != Optionality::required);
if (d.typePattern.kindCode == KindCode::same) {
dummyArgs.emplace_back(dummyArgs[sameDummyArg.value()]);
} else {
auto category{d.typePattern.categorySet.LeastElement().value()};
characteristics::TypeAndShape typeAndShape{
DynamicType{category, defaults.GetDefaultKind(category)}};
dummyArgs.emplace_back(
characteristics::DummyDataObject{std::move(typeAndShape)});
}
std::get<characteristics::DummyDataObject>(dummyArgs.back())
.attrs.set(characteristics::DummyDataObject::Attr::Optional);
}
}
characteristics::Procedure::Attrs attrs;
if (elementalRank > 0) {
attrs.set(characteristics::Procedure::Attr::Elemental);
}
characteristics::Procedure chars{
std::move(funcResult), std::move(dummyArgs), attrs};
return SpecificCall{
SpecificIntrinsic{name, std::move(chars)}, std::move(rearranged)};
}
class IntrinsicProcTable::Implementation {
@ -1213,8 +1273,8 @@ public:
bool IsIntrinsic(const std::string &) const;
std::optional<SpecificCall> Probe(
const CallCharacteristics &, ActualArguments &, FoldingContext &) const;
std::optional<SpecificCall> Probe(const CallCharacteristics &,
ActualArguments &, FoldingContext &, const IntrinsicProcTable &) const;
std::optional<UnrestrictedSpecificIntrinsicFunctionInterface>
IsUnrestrictedSpecificIntrinsicFunction(const std::string &) const;
@ -1222,11 +1282,13 @@ public:
std::ostream &Dump(std::ostream &) const;
private:
DynamicType GetSpecificType(const TypePattern &) const;
SpecificCall HandleNull(
ActualArguments &, FoldingContext &, const IntrinsicProcTable &) const;
common::IntrinsicTypeDefaultKinds defaults_;
std::multimap<std::string, const IntrinsicInterface *> genericFuncs_;
std::multimap<std::string, const SpecificIntrinsicInterface *> specificFuncs_;
DynamicType GetSpecificType(const TypePattern &) const;
};
bool IntrinsicProcTable::Implementation::IsIntrinsic(
@ -1243,15 +1305,90 @@ bool IntrinsicProcTable::Implementation::IsIntrinsic(
return name == "null"; // TODO more
}
// The NULL() intrinsic is a special case.
SpecificCall IntrinsicProcTable::Implementation::HandleNull(
ActualArguments &arguments, FoldingContext &context,
const IntrinsicProcTable &intrinsics) const {
if (!arguments.empty()) {
if (arguments.size() > 1) {
context.messages().Say("Too many arguments to NULL()"_err_en_US);
} else if (arguments[0].has_value() && arguments[0]->keyword.has_value() &&
arguments[0]->keyword->ToString() != "mold") {
context.messages().Say("Unknown argument '%s' to NULL()"_err_en_US,
arguments[0]->keyword->ToString().data());
} else {
if (Expr<SomeType> * mold{arguments[0]->GetExpr()}) {
if (IsAllocatableOrPointer(*mold)) {
characteristics::DummyArguments args;
std::optional<characteristics::FunctionResult> fResult;
if (IsProcedurePointer(*mold)) {
// MOLD= procedure pointer
const Symbol *last{GetLastSymbol(*mold)};
CHECK(last != nullptr);
auto procPointer{
characteristics::Procedure::Characterize(*last, intrinsics)};
characteristics::DummyProcedure dp{
common::Clone(procPointer.value())};
args.emplace_back(std::move(dp));
fResult.emplace(std::move(procPointer.value()));
} 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(std::move(ddo));
fResult.emplace(std::move(*typeAndShape));
} else {
context.messages().Say(
"MOLD= argument to NULL() lacks type"_err_en_US);
}
fResult->attrs.set(characteristics::FunctionResult::Attr::Pointer);
characteristics::Procedure::Attrs attrs;
attrs.set(characteristics::Procedure::Attr::NullPointer);
characteristics::Procedure chars{
std::move(*fResult), std::move(args), attrs};
return SpecificCall{SpecificIntrinsic{"null"s, std::move(chars)},
std::move(arguments)};
}
}
context.messages().Say(
"MOLD= argument to NULL() must be a pointer or allocatable"_err_en_US);
}
}
characteristics::Procedure::Attrs attrs;
attrs.set(characteristics::Procedure::Attr::NullPointer);
arguments.clear();
return SpecificCall{
SpecificIntrinsic{"null"s,
characteristics::Procedure{characteristics::DummyArguments{}, attrs}},
std::move(arguments)};
}
// Probe the configured intrinsic procedure pattern tables in search of a
// match for a given procedure reference.
std::optional<SpecificCall> IntrinsicProcTable::Implementation::Probe(
const CallCharacteristics &call, ActualArguments &arguments,
FoldingContext &context) const {
FoldingContext &context, const IntrinsicProcTable &intrinsics) const {
if (call.isSubroutineCall) {
return std::nullopt; // TODO
}
parser::Messages *finalBuffer{context.messages().messages()};
// Special case: NULL()
if (call.name.ToString() == "null") {
parser::Messages nullBuffer;
parser::ContextualMessages nullErrors{
call.name, finalBuffer ? &nullBuffer : nullptr};
FoldingContext nullContext{context, nullErrors};
auto result{HandleNull(arguments, nullContext, intrinsics)};
if (finalBuffer != nullptr) {
finalBuffer->Annex(std::move(nullBuffer));
}
return result;
}
// Probe the specific intrinsic function table first.
parser::Messages specificBuffer;
parser::ContextualMessages specificErrors{
@ -1282,31 +1419,7 @@ std::optional<SpecificCall> IntrinsicProcTable::Implementation::Probe(
return specificCall;
}
}
// Special cases of intrinsic functions
if (call.name.ToString() == "null") {
if (arguments.size() == 0) {
return std::make_optional<SpecificCall>(
SpecificIntrinsic{"null"s}, std::move(arguments));
} else if (arguments.size() > 1) {
genericErrors.Say("too many arguments to NULL()"_err_en_US);
} else if (arguments[0].has_value() && arguments[0]->keyword.has_value() &&
arguments[0]->keyword->ToString() != "mold") {
genericErrors.Say("unknown argument '%s' to NULL()"_err_en_US,
arguments[0]->keyword->ToString().data());
} else {
if (Expr<SomeType> * mold{arguments[0]->GetExpr()}) {
if (IsPointerOrAllocatable(*mold)) {
return std::make_optional<SpecificCall>(
SpecificIntrinsic{"null"s, mold->GetType(), mold->Rank(),
semantics::Attrs{semantics::Attr::POINTER}},
std::move(arguments));
}
}
genericErrors.Say("MOLD argument to NULL() must be a pointer "
"or allocatable"_err_en_US);
}
}
// No match
// No match; report the right errors, if any
if (finalBuffer != nullptr) {
if (genericBuffer.empty()) {
finalBuffer->Annex(std::move(specificBuffer));
@ -1324,24 +1437,26 @@ IntrinsicProcTable::Implementation::IsUnrestrictedSpecificIntrinsicFunction(
for (auto iter{specificRange.first}; iter != specificRange.second; ++iter) {
const SpecificIntrinsicInterface &specific{*iter->second};
if (!specific.isRestrictedSpecific) {
UnrestrictedSpecificIntrinsicFunctionInterface result;
std::string genericName{name};
if (specific.generic != nullptr) {
result.genericName = std::string(specific.generic);
} else {
result.genericName = name;
genericName = std::string(specific.generic);
}
result.attrs.set(characteristics::Procedure::Attr::Pure);
result.attrs.set(characteristics::Procedure::Attr::Elemental);
characteristics::FunctionResult fResult{GetSpecificType(specific.result)};
characteristics::DummyArguments args;
int dummies{specific.CountArguments()};
for (int j{0}; j < dummies; ++j) {
characteristics::DummyDataObject dummy{
GetSpecificType(specific.dummy[j].typePattern)};
dummy.intent = common::Intent::In;
result.dummyArguments.emplace_back(std::move(dummy));
args.emplace_back(std::move(dummy));
}
result.functionResult.emplace(
characteristics::FunctionResult{GetSpecificType(specific.result)});
return result;
characteristics::Procedure::Attrs attrs;
attrs.set(characteristics::Procedure::Attr::Pure)
.set(characteristics::Procedure::Attr::Elemental);
characteristics::Procedure chars{
std::move(fResult), std::move(args), attrs};
return UnrestrictedSpecificIntrinsicFunctionInterface{
std::move(chars), genericName};
}
}
return std::nullopt;
@ -1377,7 +1492,7 @@ std::optional<SpecificCall> IntrinsicProcTable::Probe(
const CallCharacteristics &call, ActualArguments &arguments,
FoldingContext &context) const {
CHECK(impl_ != nullptr || !"IntrinsicProcTable: not configured");
return impl_->Probe(call, arguments, context);
return impl_->Probe(call, arguments, context, *this);
}
std::optional<UnrestrictedSpecificIntrinsicFunctionInterface>

6
flang/lib/evaluate/intrinsics.h
View File

@ -42,6 +42,9 @@ struct SpecificCall {
struct UnrestrictedSpecificIntrinsicFunctionInterface
: public characteristics::Procedure {
UnrestrictedSpecificIntrinsicFunctionInterface(
characteristics::Procedure &&p, std::string n)
: characteristics::Procedure{std::move(p)}, genericName{n} {}
std::string genericName;
// N.B. If there are multiple arguments, they all have the same type.
// All argument and result types are intrinsic types with default kinds.
@ -62,7 +65,8 @@ public:
// Probe the intrinsics for a match against a specific call.
// On success, the actual arguments are transferred to the result
// in dummy argument order.
// in dummy argument order; on failure, the actual arguments remain
// untouched.
std::optional<SpecificCall> Probe(
const CallCharacteristics &, ActualArguments &, FoldingContext &) const;

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

@ -324,6 +324,14 @@ std::optional<Shape> GetShapeHelper::GetShape(const ActualArgument &arg) {
}
}
std::optional<Shape> GetShapeHelper::GetShape(const ProcedureDesignator &proc) {
if (const Symbol * symbol{proc.GetSymbol()}) {
return GetShape(*symbol);
} else {
return std::nullopt;
}
}
std::optional<Shape> GetShapeHelper::GetShape(const ProcedureRef &call) {
if (call.Rank() == 0) {
return Shape{};
@ -382,29 +390,31 @@ std::optional<Shape> GetShapeHelper::GetShape(const NullPointer &) {
return {}; // not an object
}
void CheckConformance(parser::ContextualMessages &messages, const Shape &left,
const Shape &right) {
bool CheckConformance(parser::ContextualMessages &messages, const Shape &left,
const Shape &right, const char *leftDesc, const char *rightDesc) {
if (!left.empty() && !right.empty()) {
int n{static_cast<int>(left.size())};
int rn{static_cast<int>(right.size())};
if (n != rn) {
messages.Say(
"Left operand has rank %d, but right operand has rank %d"_err_en_US,
n, rn);
messages.Say("Rank of %s is %d, but %s has rank %d"_err_en_US, leftDesc,
n, rightDesc, rn);
return false;
} else {
for (int j{0}; j < n; ++j) {
if (auto leftDim{ToInt64(left[j])}) {
if (auto rightDim{ToInt64(right[j])}) {
if (*leftDim != *rightDim) {
messages.Say("Dimension %d of left operand has extent %jd, "
"but right operand has extent %jd"_err_en_US,
j + 1, static_cast<std::intmax_t>(*leftDim),
static_cast<std::intmax_t>(*rightDim));
messages.Say("Dimension %d of %s has extent %jd, "
"but %s has extent %jd"_err_en_US,
j + 1, leftDesc, static_cast<std::intmax_t>(*leftDim),
rightDesc, static_cast<std::intmax_t>(*rightDim));
return false;
}
}
}
}
}
}
return true;
}
}

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

@ -22,6 +22,7 @@
#include "tools.h"
#include "type.h"
#include "../common/indirection.h"
#include "../parser/message.h"
#include <optional>
#include <variant>
@ -58,8 +59,9 @@ bool ContainsAnyImpliedDoIndex(const ExtentExpr &);
// Compilation-time shape conformance checking, when corresponding extents
// are known.
void CheckConformance(
parser::ContextualMessages &, const Shape &, const Shape &);
bool CheckConformance(parser::ContextualMessages &, const Shape &,
const Shape &, const char * = "left operand",
const char * = "right operand");
// The implementation of GetShape() is wrapped in a helper class
// so that the member functions may mutually recurse without prototypes.
@ -81,6 +83,7 @@ public:
std::optional<Shape> GetShape(const Substring &);
std::optional<Shape> GetShape(const ComplexPart &);
std::optional<Shape> GetShape(const ActualArgument &);
std::optional<Shape> GetShape(const ProcedureDesignator &);
std::optional<Shape> GetShape(const ProcedureRef &);
std::optional<Shape> GetShape(const ImpliedDoIndex &);
std::optional<Shape> GetShape(const Relational<SomeType> &);
@ -144,8 +147,6 @@ public:
}
private:
MaybeExtent GetLowerBound(const Symbol &, const Component *, int dimension);
template<typename T>
MaybeExtent GetExtent(const ArrayConstructorValue<T> &value) {
return std::visit(
@ -187,6 +188,8 @@ private:
return result;
}
// The dimension here is zero-based, unlike DIM= intrinsic arguments.
MaybeExtent GetLowerBound(const Symbol &, const Component *, int dimension);
MaybeExtent GetExtent(const Symbol &, const Component *, int dimension);
MaybeExtent GetExtent(
const Subscript &, const Symbol &, const Component *, int dimension);

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

@ -13,6 +13,7 @@
// limitations under the License.
#include "tools.h"
#include "traversal.h"
#include "../common/idioms.h"
#include "../parser/message.h"
#include <algorithm>
@ -351,6 +352,14 @@ std::optional<Expr<SomeType>> Negation(
messages.Say("NULL() cannot be negated"_err_en_US);
return NoExpr();
},
[&](ProcedureDesignator &&) {
messages.Say("Subroutine cannot be negated"_err_en_US);
return NoExpr();
},
[&](ProcedureRef &&) {
messages.Say("Pointer to subroutine cannot be negated"_err_en_US);
return NoExpr();
},
[&](Expr<SomeInteger> &&x) { return Package(-std::move(x)); },
[&](Expr<SomeReal> &&x) { return Package(-std::move(x)); },
[&](Expr<SomeComplex> &&x) { return Package(-std::move(x)); },
@ -505,8 +514,7 @@ std::optional<Expr<SomeType>> ConvertToNumeric(int kind, Expr<SomeType> &&x) {
return std::visit(
[=](auto &&cx) -> std::optional<Expr<SomeType>> {
using cxType = std::decay_t<decltype(cx)>;
if constexpr (!std::is_same_v<cxType, BOZLiteralConstant> &&
!std::is_same_v<cxType, NullPointer>) {
if constexpr (!common::HasMember<cxType, TypelessExpression>) {
if constexpr (IsNumericTypeCategory(ResultType<cxType>::category)) {
return std::make_optional(
Expr<SomeType>{ConvertToKind<TO>(kind, std::move(cx))});
@ -573,7 +581,7 @@ std::optional<Expr<SomeType>> ConvertToType(
return std::nullopt;
}
}
if (auto symType{GetSymbolType(symbol)}) {
if (auto symType{DynamicType::From(symbol)}) {
return ConvertToType(*symType, std::move(x));
}
return std::nullopt;
@ -587,4 +595,22 @@ std::optional<Expr<SomeType>> ConvertToType(
return std::nullopt;
}
}
bool IsAssumedRank(const semantics::Symbol &symbol) {
if (const auto *details{symbol.detailsIf<semantics::ObjectEntityDetails>()}) {
return details->IsAssumedRank();
} else {
return false;
}
}
bool IsAssumedRank(const ActualArgument &arg) {
if (const auto *expr{arg.GetExpr()}) {
return IsAssumedRank(*expr);
} else {
const semantics::Symbol *assumedTypeDummy{arg.GetAssumedTypeDummy()};
CHECK(assumedTypeDummy != nullptr);
return IsAssumedRank(*assumedTypeDummy);
}
}
}

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

@ -77,17 +77,16 @@ template<typename A> bool IsVariable(const Expr<A> &expr) {
}
// Predicate: true when an expression is assumed-rank
bool IsAssumedRank(const semantics::Symbol &);
bool IsAssumedRank(const ActualArgument &);
template<typename A> bool IsAssumedRank(const A &) { return false; }
template<typename A> bool IsAssumedRank(const Designator<A> &designator) {
if (const auto *symbolPtr{
if (const auto *symbol{
std::get_if<const semantics::Symbol *>(&designator.u)}) {
if (const auto *details{
(*symbolPtr)
->template detailsIf<semantics::ObjectEntityDetails>()}) {
return details->IsAssumedRank();
}
return IsAssumedRank(*symbol);
} else {
return false;
}
return false;
}
template<typename A> bool IsAssumedRank(const Expr<A> &expr) {
return std::visit([](const auto &x) { return IsAssumedRank(x); }, expr.u);
@ -112,7 +111,11 @@ Expr<SomeKind<CATEGORY>> AsCategoryExpr(Expr<SomeKind<CATEGORY>> &&x) {
template<typename A>
common::IfNoLvalue<Expr<SomeType>, A> AsGenericExpr(A &&x) {
return Expr<SomeType>{AsCategoryExpr(std::move(x))};
if constexpr (common::HasMember<A, TypelessExpression>) {
return Expr<SomeType>{std::move(x)};
} else {
return Expr<SomeType>{AsCategoryExpr(std::move(x))};
}
}
template<typename A>
@ -123,14 +126,6 @@ common::IfNoLvalue<Expr<SomeKind<ResultType<A>::category>>, A> AsCategoryExpr(
inline Expr<SomeType> AsGenericExpr(Expr<SomeType> &&x) { return std::move(x); }
inline Expr<SomeType> AsGenericExpr(BOZLiteralConstant &&x) {
return Expr<SomeType>{std::move(x)};
}
inline Expr<SomeType> AsGenericExpr(NullPointer &&x) {
return Expr<SomeType>{std::move(x)};
}
Expr<SomeReal> GetComplexPart(
const Expr<SomeComplex> &, bool isImaginary = false);
@ -140,6 +135,14 @@ Expr<SomeComplex> MakeComplex(Expr<Type<TypeCategory::Real, KIND>> &&re,
return AsCategoryExpr(ComplexConstructor<KIND>{std::move(re), std::move(im)});
}
template<typename A> constexpr bool IsNumericCategoryExpr() {
if constexpr (common::HasMember<A, TypelessExpression>) {
return false;
} else {
return common::HasMember<ResultType<A>, NumericCategoryTypes>;
}
}
// Specializing extractor. If an Expr wraps some type of object, perhaps
// in several layers, return a pointer to it; otherwise null.
template<typename A, typename B>
@ -147,8 +150,7 @@ auto UnwrapExpr(B &x) -> common::Constify<A, B> * {
using Ty = std::decay_t<B>;
if constexpr (std::is_same_v<A, Ty>) {
return &x;
} else if constexpr (std::is_same_v<Ty, BOZLiteralConstant> ||
std::is_same_v<Ty, NullPointer>) {
} else if constexpr (common::HasMember<Ty, TypelessExpression>) {
return nullptr;
} else if constexpr (std::is_same_v<Ty, Expr<ResultType<A>>>) {
return common::Unwrap<A>(x.u);
@ -226,7 +228,8 @@ template<typename TO> Expr<TO> ConvertToType(BOZLiteralConstant &&x) {
} else {
static_assert(TO::category == TypeCategory::Real);
using Word = typename Value::Word;
return Expr<TO>{Constant<TO>{Word::ConvertUnsigned(std::move(x)).value}};
return Expr<TO>{
Constant<TO>{Value{Word::ConvertUnsigned(std::move(x)).value}}};
}
}
@ -543,6 +546,14 @@ const semantics::Symbol *GetLastSymbol(const Designator<T> &x) {
return x.GetLastSymbol();
}
inline const semantics::Symbol *GetLastSymbol(const ProcedureDesignator &x) {
return x.GetSymbol();
}
inline const semantics::Symbol *GetLastSymbol(const ProcedureRef &x) {
return GetLastSymbol(x.proc());
}
template<typename T> const semantics::Symbol *GetLastSymbol(const Expr<T> &x) {
return std::visit([](const auto &y) { return GetLastSymbol(y); }, x.u);
}
@ -555,9 +566,17 @@ template<typename A> semantics::Attrs GetAttrs(const A &x) {
}
}
template<typename A> bool IsPointerOrAllocatable(const A &x) {
template<typename A> bool IsAllocatableOrPointer(const A &x) {
return GetAttrs(x).HasAny(
semantics::Attrs{semantics::Attr::POINTER, semantics::Attr::ALLOCATABLE});
}
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);
}
}
#endif // FORTRAN_EVALUATE_TOOLS_H_

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

@ -18,6 +18,7 @@
#include "../common/idioms.h"
#include "../semantics/scope.h"
#include "../semantics/symbol.h"
#include "../semantics/tools.h"
#include "../semantics/type.h"
#include <algorithm>
#include <optional>
@ -26,8 +27,8 @@
using namespace std::literals::string_literals;
// TODO there's probably a better place for this predicate than here
// IsDescriptor() predicate
// TODO there's probably a better place for this predicate than here
namespace Fortran::semantics {
static bool IsDescriptor(const ObjectEntityDetails &details) {
if (const auto *type{details.type()}) {
@ -64,19 +65,20 @@ static bool IsDescriptor(const ObjectEntityDetails &details) {
return true;
}
// TODO: Explicit shape component array dependent on length parameter
// TODO: Automatic (adjustable) arrays
// TODO: Automatic (adjustable) arrays - are they descriptors?
return false;
}
static bool IsDescriptor(const ProcEntityDetails &details) {
// A procedure pointer or dummy procedure must be a descriptor if
// A procedure pointer or dummy procedure must be & is a descriptor if
// and only if it requires a static link.
// TODO: refine this placeholder
return details.HasExplicitInterface();
}
bool IsDescriptor(const Symbol &symbol) {
if (const auto *objectDetails{symbol.detailsIf<ObjectEntityDetails>()}) {
return IsDescriptor(*objectDetails);
return IsAllocatableOrPointer(symbol) || IsDescriptor(*objectDetails);
} else if (const auto *procDetails{symbol.detailsIf<ProcEntityDetails>()}) {
if (symbol.attrs().test(Attr::POINTER) ||
symbol.attrs().test(Attr::EXTERNAL)) {
@ -104,7 +106,45 @@ bool DynamicType::IsAssumedLengthCharacter() const {
charLength->isAssumed();
}
std::optional<DynamicType> AsDynamicType(const semantics::DeclTypeSpec &type) {
static const semantics::DerivedTypeSpec *GetParentTypeSpec(
const semantics::DerivedTypeSpec &spec) {
const semantics::Symbol &typeSymbol{spec.typeSymbol()};
if (const semantics::Scope * scope{typeSymbol.scope()}) {
const auto &dtDetails{typeSymbol.get<semantics::DerivedTypeDetails>()};
if (auto extends{dtDetails.GetParentComponentName()}) {
if (auto iter{scope->find(*extends)}; iter != scope->cend()) {
if (const Symbol & symbol{*iter->second};
symbol.test(Symbol::Flag::ParentComp)) {
return &symbol.get<semantics::ObjectEntityDetails>()
.type()
->derivedTypeSpec();
}
}
}
}
return nullptr;
}
static const bool IsAncestorTypeOf(const semantics::DerivedTypeSpec *ancestor,
const semantics::DerivedTypeSpec *spec) {
if (ancestor == nullptr) {
return false;
} else if (spec == nullptr) {
return false;
} else if (spec == ancestor) {
return true;
} else {
return IsAncestorTypeOf(ancestor, GetParentTypeSpec(*spec));
}
}
bool DynamicType::IsTypeCompatibleWith(const DynamicType &that) const {
return *this == that || IsUnlimitedPolymorphic() ||
(isPolymorphic && IsAncestorTypeOf(derived, that.derived));
}
std::optional<DynamicType> DynamicType::From(
const semantics::DeclTypeSpec &type) {
if (const auto *intrinsic{type.AsIntrinsic()}) {
if (auto kind{ToInt64(intrinsic->kind())}) {
TypeCategory category{intrinsic->category()};
@ -121,39 +161,25 @@ std::optional<DynamicType> AsDynamicType(const semantics::DeclTypeSpec &type) {
return DynamicType{
*derived, type.category() == semantics::DeclTypeSpec::ClassDerived};
} else if (type.category() == semantics::DeclTypeSpec::ClassStar) {
DynamicType result;
result.isPolymorphic = true;
return result;
return DynamicType::UnlimitedPolymorphic();
} else {
// Assumed-type dummy arguments (TYPE(*)) do not have dynamic types.
}
return std::nullopt;
}
std::optional<DynamicType> AsDynamicType(const semantics::DeclTypeSpec *type) {
if (type != nullptr) {
return AsDynamicType(*type);
} else {
return std::nullopt;
}
}
std::optional<DynamicType> GetSymbolType(const semantics::Symbol &symbol) {
return AsDynamicType(symbol.GetType());
}
std::optional<DynamicType> GetSymbolType(const semantics::Symbol *symbol) {
if (symbol != nullptr) {
return GetSymbolType(*symbol);
} else {
return std::nullopt;
}
std::optional<DynamicType> DynamicType::From(const semantics::Symbol &symbol) {
return From(symbol.GetType()); // Symbol -> DeclTypeSpec -> DynamicType
}
std::string DynamicType::AsFortran() const {
if (derived != nullptr) {
CHECK(category == TypeCategory::Derived);
return "TYPE("s + derived->typeSymbol().name().ToString() + ')';
if (isPolymorphic) {
return "CLASS("s + derived->typeSymbol().name().ToString() + ')';
} else {
return "TYPE("s + derived->typeSymbol().name().ToString() + ')';
}
} else if (charLength != nullptr) {
std::string result{"CHARACTER(KIND="s + std::to_string(kind) + ",LEN="};
if (charLength->isAssumed()) {
@ -166,6 +192,10 @@ std::string DynamicType::AsFortran() const {
result += ss.str();
}
return result + ')';
} else if (isPolymorphic) {
return "CLASS(*)";
} else if (kind == 0) {
return "(typeless intrinsic function argument)";
} else {
return EnumToString(category) + '(' + std::to_string(kind) + ')';
}

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

@ -57,6 +57,25 @@ using SubscriptInteger = Type<TypeCategory::Integer, 8>;
using LogicalResult = Type<TypeCategory::Logical, 1>;
using LargestReal = Type<TypeCategory::Real, 16>;
// A predicate that is true when a kind value is a kind that could possibly
// be supported for an intrinsic type category on some target instruction
// set architecture.
static constexpr bool IsValidKindOfIntrinsicType(
TypeCategory category, std::int64_t kind) {
switch (category) {
case TypeCategory::Integer:
return kind == 1 || kind == 2 || kind == 4 || kind == 8 || kind == 16;
case TypeCategory::Real:
case TypeCategory::Complex:
return kind == 2 || kind == 3 || kind == 4 || kind == 8 || kind == 10 ||
kind == 16;
case TypeCategory::Character: return kind == 1 || kind == 2 || kind == 4;
case TypeCategory::Logical:
return kind == 1 || kind == 2 || kind == 4 || kind == 8;
default: return false;
}
}
// DynamicType is meant to be suitable for use as the result type for
// GetType() functions and member functions; consequently, it must be
// capable of being used in a constexpr context. So it does *not*
@ -65,15 +84,32 @@ using LargestReal = Type<TypeCategory::Real, 16>;
// via LEN() member functions, packaged elsewhere (e.g. as in
// ArrayConstructor), or copied from a parameter spec in the symbol table
// if one is supplied.
struct DynamicType {
constexpr DynamicType() = default;
constexpr DynamicType(TypeCategory cat, int k) : category{cat}, kind{k} {}
class DynamicType {
public:
constexpr DynamicType(TypeCategory cat, int k) : category{cat}, kind{k} {
CHECK(IsValidKindOfIntrinsicType(category, kind));
}
constexpr DynamicType(int k, const semantics::ParamValue &pv)
: category{TypeCategory::Character}, kind{k}, charLength{&pv} {}
: category{TypeCategory::Character}, kind{k}, charLength{&pv} {
CHECK(IsValidKindOfIntrinsicType(category, kind));
}
explicit constexpr DynamicType(
const semantics::DerivedTypeSpec &dt, bool poly = false)
: category{TypeCategory::Derived}, derived{&dt}, isPolymorphic{poly} {}
// A rare use case used for representing the characteristics of an
// intrinsic function like REAL() that accepts a typeless BOZ literal
// argument, which is something that real user Fortran can't do.
static constexpr DynamicType TypelessIntrinsicArgument() {
return {}; // looks like INTEGER(KIND=0)
}
static constexpr DynamicType UnlimitedPolymorphic() {
DynamicType result;
result.isPolymorphic = true;
return result; // CLASS(*)
}
// Comparison is deep -- type parameters are compared independently.
bool operator==(const DynamicType &) const;
bool operator!=(const DynamicType &that) const { return !(*this == that); }
@ -81,21 +117,53 @@ struct DynamicType {
std::string AsFortran() const;
std::string AsFortran(std::string &&charLenExpr) const;
DynamicType ResultTypeForMultiply(const DynamicType &) const;
bool IsAssumedLengthCharacter() const;
constexpr bool IsUnlimitedPolymorphic() const {
return isPolymorphic && derived == nullptr;
}
// 7.3.2.3 type compatibility.
// x.IsTypeCompatibleWith(y) is true if "x => y" or passing actual y to
// dummy argument x would be valid. Be advised, this is not a reflexive
// relation.
bool IsTypeCompatibleWith(const DynamicType &) const;
// Result will be missing when a symbol is absent or
// has an erroneous type, e.g., REAL(KIND=666).
static std::optional<DynamicType> From(const semantics::DeclTypeSpec &);
static std::optional<DynamicType> From(const semantics::Symbol &);
template<typename A> static std::optional<DynamicType> From(const A &x) {
return x.GetType();
}
template<typename A> static std::optional<DynamicType> From(const A *p) {
if (p == nullptr) {
return std::nullopt;
} else {
return From(*p);
}
}
template<typename A>
static std::optional<DynamicType> From(const std::optional<A> &x) {
if (x.has_value()) {
return From(*x);
} else {
return std::nullopt;
}
}
TypeCategory category{TypeCategory::Integer}; // overridable default
int kind{0}; // set only for intrinsic types
const semantics::ParamValue *charLength{nullptr};
const semantics::DerivedTypeSpec *derived{nullptr}; // TYPE(T), CLASS(T)
bool isPolymorphic{false}; // CLASS(T), CLASS(*)
};
// Result will be missing when a symbol is absent or
// has an erroneous type, e.g., REAL(KIND=666).
std::optional<DynamicType> AsDynamicType(const semantics::DeclTypeSpec &);
std::optional<DynamicType> AsDynamicType(const semantics::DeclTypeSpec *);
std::optional<DynamicType> GetSymbolType(const semantics::Symbol &);
std::optional<DynamicType> GetSymbolType(const semantics::Symbol *);
// TODO pmk: restore private accessibility once changes are
// merged into lib/semantics
// private:
constexpr DynamicType() {}
};
template<TypeCategory CATEGORY, int KIND = 0> struct TypeBase {
static constexpr TypeCategory category{CATEGORY};
@ -207,25 +275,6 @@ using SameKind = Type<CATEGORY, std::decay_t<T>::kind>;
using IndirectSubscriptIntegerExpr =
common::CopyableIndirection<Expr<SubscriptInteger>>;
// A predicate that is true when a kind value is a kind that could possibly
// be supported for an intrinsic type category on some target instruction
// set architecture.
static constexpr bool IsValidKindOfIntrinsicType(
TypeCategory category, std::int64_t kind) {
switch (category) {
case TypeCategory::Integer:
return kind == 1 || kind == 2 || kind == 4 || kind == 8 || kind == 16;
case TypeCategory::Real:
case TypeCategory::Complex:
return kind == 2 || kind == 3 || kind == 4 || kind == 8 || kind == 10 ||
kind == 16;
case TypeCategory::Character: return kind == 1 || kind == 2 || kind == 4;
case TypeCategory::Logical:
return kind == 1 || kind == 2 || kind == 4 || kind == 8;
default: return false;
}
}
// For each intrinsic type category CAT, CategoryTypes<CAT> is an instantiation
// of std::tuple<Type<CAT, K>> that comprises every kind value K in that
// category that could possibly be supported on any target.
@ -271,13 +320,11 @@ template<TypeCategory CATEGORY> struct SomeKind {
constexpr bool operator==(const SomeKind &) const { return true; }
};
using AllGenericIntrinsicCategoryTypes =
std::tuple<SomeKind<TypeCategory::Integer>, SomeKind<TypeCategory::Real>,
SomeKind<TypeCategory::Complex>, SomeKind<TypeCategory::Character>,
SomeKind<TypeCategory::Logical>>;
template<typename T>
constexpr bool IsGenericIntrinsicCategoryType{
common::HasMember<T, AllGenericIntrinsicCategoryTypes>};
using NumericCategoryTypes = std::tuple<SomeKind<TypeCategory::Integer>,
SomeKind<TypeCategory::Real>, SomeKind<TypeCategory::Complex>>;
using AllIntrinsicCategoryTypes = std::tuple<SomeKind<TypeCategory::Integer>,
SomeKind<TypeCategory::Real>, SomeKind<TypeCategory::Complex>,
SomeKind<TypeCategory::Character>, SomeKind<TypeCategory::Logical>>;
// Represents a completely generic type (but not typeless).
struct SomeType {};

8
flang/lib/evaluate/variable.cc
View File

@ -221,14 +221,14 @@ std::optional<Expr<SomeCharacter>> Substring::Fold(FoldingContext &context) {
DescriptorInquiry::DescriptorInquiry(const Symbol &symbol, Field field, int dim)
: base_{&symbol}, field_{field}, dimension_{dim} {
CHECK(IsDescriptor(symbol));
CHECK(dim >= 1 && dim <= symbol.Rank());
CHECK(dim >= 0 && dim < symbol.Rank());
}
DescriptorInquiry::DescriptorInquiry(
Component &&component, Field field, int dim)
: base_{std::move(component)}, field_{field}, dimension_{dim} {
const Symbol &symbol{std::get<Component>(base_).GetLastSymbol()};
CHECK(IsDescriptor(symbol));
CHECK(dim >= 1 && dim <= symbol.Rank());
CHECK(dim >= 0 && dim < symbol.Rank());
}
DescriptorInquiry::DescriptorInquiry(
SymbolOrComponent &&x, Field field, int dim)
@ -240,7 +240,7 @@ DescriptorInquiry::DescriptorInquiry(
},
base_)};
CHECK(symbol != nullptr && IsDescriptor(*symbol));
CHECK(dim >= 1 && dim <= symbol->Rank());
CHECK(dim >= 0 && dim < symbol->Rank());
}
// LEN()
@ -513,7 +513,7 @@ template<typename T> std::optional<DynamicType> Designator<T>::GetType() const {
if constexpr (IsLengthlessIntrinsicType<Result>) {
return {Result::GetType()};
} else {
return GetSymbolType(GetLastSymbol());
return DynamicType::From(GetLastSymbol());
}
}

83
flang/lib/semantics/expression.cc
View File

@ -191,7 +191,7 @@ common::IfNoLvalue<MaybeExpr, WRAPPED> TypedWrapper(
// Wraps a data reference in a typed Designator<>.
static MaybeExpr Designate(DataRef &&ref) {
if (std::optional<DynamicType> dyType{
GetSymbolType(ref.GetLastSymbol().GetUltimate())}) {
DynamicType::From(ref.GetLastSymbol().GetUltimate())}) {
return TypedWrapper<Designator, DataRef>(
std::move(*dyType), std::move(ref));
}
@ -637,7 +637,7 @@ struct TypeParamInquiryVisitor {
static std::optional<Expr<SomeInteger>> MakeTypeParamInquiry(
const Symbol *symbol) {
if (std::optional<DynamicType> dyType{GetSymbolType(symbol)}) {
if (std::optional<DynamicType> dyType{DynamicType::From(symbol)}) {
if (dyType->category == TypeCategory::Integer) {
return common::SearchTypes(TypeParamInquiryVisitor{
dyType->kind, SymbolOrComponent{nullptr}, *symbol});
@ -716,7 +716,7 @@ MaybeExpr ExpressionAnalyzer::Analyze(const parser::Substring &ss) {
std::optional<Expr<SubscriptInteger>> last{
GetSubstringBound(std::get<1>(range.t))};
const Symbol &symbol{checked->GetLastSymbol()};
if (std::optional<DynamicType> dynamicType{GetSymbolType(symbol)}) {
if (std::optional<DynamicType> dynamicType{DynamicType::From(symbol)}) {
if (dynamicType->category == TypeCategory::Character) {
return WrapperHelper<TypeCategory::Character, Designator,
Substring>(dynamicType->kind,
@ -900,7 +900,7 @@ MaybeExpr ExpressionAnalyzer::Analyze(const parser::StructureComponent &sc) {
}
if (sym->detailsIf<semantics::TypeParamDetails>()) {
if (auto *designator{UnwrapExpr<Designator<SomeDerived>>(*dtExpr)}) {
if (std::optional<DynamicType> dyType{GetSymbolType(*sym)}) {
if (std::optional<DynamicType> dyType{DynamicType::From(*sym)}) {
if (dyType->category == TypeCategory::Integer) {
return AsMaybeExpr(
common::SearchTypes(TypeParamInquiryVisitor{dyType->kind,
@ -953,9 +953,8 @@ MaybeExpr ExpressionAnalyzer::Analyze(const parser::StructureComponent &sc) {
} else if (kind == MiscKind::KindParamInquiry ||
kind == MiscKind::LenParamInquiry) {
// Convert x%KIND -> intrinsic KIND(x), x%LEN -> intrinsic LEN(x)
SpecificIntrinsic func{name.ToString()};
func.type = GetDefaultKindOfType(TypeCategory::Integer);
return TypedWrapper<FunctionRef, ProcedureRef>(*func.type,
SpecificIntrinsic func{name.ToString(), characteristics::Procedure{}};
return TypedWrapper<FunctionRef, ProcedureRef>(GetDefaultKindOfType(TypeCategory::Integer),
ProcedureRef{ProcedureDesignator{std::move(func)},
ActualArguments{ActualArgument{std::move(*base)}}});
} else {
@ -1560,29 +1559,30 @@ MaybeExpr ExpressionAnalyzer::Analyze(
// Unary operations
MaybeExpr ExpressionAnalyzer::Analyze(const parser::Expr::Parentheses &x) {
// TODO: C1003: A parenthesized function reference may not return a
// procedure pointer.
if (MaybeExpr operand{Analyze(x.v.value())}) {
if (const semantics::Symbol * symbol{GetLastSymbol(*operand)}) {
if (const semantics::Symbol * result{FindFunctionResult(*symbol)}) {
if (semantics::IsProcedurePointer(*result)) {
Say("A function reference that returns a procedure "
"pointer may not be parenthesized."_err_en_US); // C1003
}
}
}
return std::visit(
common::visitors{
[&](BOZLiteralConstant &&boz) {
return operand; // ignore parentheses around typeless constants
},
[&](NullPointer &&boz) {
return operand; // ignore parentheses around NULL()
},
[&](Expr<SomeDerived> &&) {
// TODO: parenthesized derived type variable
return operand;
},
[](auto &&catExpr) {
return std::visit(
[](auto &&expr) -> MaybeExpr {
using Ty = ResultType<decltype(expr)>;
return {AsGenericExpr(Parentheses<Ty>{std::move(expr)})};
},
std::move(catExpr.u));
},
[&](auto &&x) -> MaybeExpr {
using xTy = std::decay_t<decltype(x)>;
if constexpr (common::HasMember<xTy, TypelessExpression>) {
return operand; // ignore parentheses around typeless
} else if constexpr (std::is_same_v<xTy, Expr<SomeDerived>>) {
return operand; // ignore parentheses around derived type
} else {
return std::visit(
[](auto &&y) -> MaybeExpr {
using Ty = ResultType<decltype(y)>;
return {AsGenericExpr(Parentheses<Ty>{std::move(y)})};
},
std::move(x.u));
}
},
std::move(operand->u));
}
@ -1592,21 +1592,22 @@ MaybeExpr ExpressionAnalyzer::Analyze(const parser::Expr::Parentheses &x) {
MaybeExpr ExpressionAnalyzer::Analyze(const parser::Expr::UnaryPlus &x) {
MaybeExpr value{Analyze(x.v.value())};
if (value.has_value()) {
std::visit(
common::visitors{
[](const BOZLiteralConstant &) {}, // allow +Z'1', it's harmless
[&](const NullPointer &) {
Say("+NULL() is not allowed"_err_en_US);
},
[&](const auto &catExpr) {
TypeCategory cat{ResultType<decltype(catExpr)>::category};
if (cat != TypeCategory::Integer && cat != TypeCategory::Real &&
cat != TypeCategory::Complex) {
Say("operand of unary + must be of a numeric type"_err_en_US);
if (!std::visit(
[&](const auto &y) {
using yTy = std::decay_t<decltype(y)>;
if constexpr (std::is_same_v<yTy, BOZLiteralConstant>) {
// allow and ignore +Z'1', it's harmless
return true;
} else if constexpr (!IsNumericCategoryExpr<yTy>()) {
Say("Operand of unary + must have numeric type"_err_en_US);
return false;
} else {
return true;
}
},
},
value->u);
value->u)) {
return std::nullopt;
}
}
return value;
}

8
flang/lib/semantics/symbol.h
View File

@ -236,6 +236,14 @@ public:
const Symbol *GetParentComponent(const Scope &) const;
std::optional<SourceName> GetParentComponentName() const {
if (componentNames_.empty()) {
return std::nullopt;
} else {
return componentNames_.front();
}
}
private:
// These are (1) the names of the derived type parameters in the order
// in which they appear on the type definition statement(s), and (2) the

16
flang/lib/semantics/tools.cc
View File

@ -125,26 +125,10 @@ bool IsDummy(const Symbol &symbol) {
}
}
bool IsPointer(const Symbol &symbol) {
return symbol.attrs().test(Attr::POINTER);
}
bool IsAllocatable(const Symbol &symbol) {
return symbol.attrs().test(Attr::ALLOCATABLE);
}
bool IsPointerDummy(const Symbol &symbol) {
return IsPointer(symbol) && IsDummy(symbol);
}
bool IsAllocatableOrPointer(const Symbol &symbol) {
return IsPointer(symbol) || IsAllocatable(symbol);
}
bool IsParameter(const Symbol &symbol) {
return symbol.attrs().test(Attr::PARAMETER);
}
// variable-name
bool IsVariableName(const Symbol &symbol) {
return symbol.has<ObjectEntityDetails>() && !IsParameter(symbol);

16
flang/lib/semantics/tools.h
View File

@ -48,7 +48,6 @@ bool DoesScopeContain(const Scope *, const Symbol &);
bool IsUseAssociated(const Symbol *, const Scope &);
bool IsHostAssociated(const Symbol &, const Scope &);
bool IsDummy(const Symbol &);
bool IsPointer(const Symbol &);
bool IsPointerDummy(const Symbol &);
bool IsFunction(const Symbol &);
bool IsPureFunction(const Symbol &);
@ -56,10 +55,21 @@ bool IsPureFunction(const Scope &);
bool IsProcedure(const Symbol &);
bool IsProcName(const Symbol &symbol); // proc-name
bool IsVariableName(const Symbol &symbol); // variable-name
bool IsAllocatable(const Symbol &);
bool IsAllocatableOrPointer(const Symbol &);
bool IsProcedurePointer(const Symbol &);
inline bool IsPointer(const Symbol &symbol) {
return symbol.attrs().test(Attr::POINTER);
}
inline bool IsAllocatable(const Symbol &symbol) {
return symbol.attrs().test(Attr::ALLOCATABLE);
}
inline bool IsAllocatableOrPointer(const Symbol &symbol) {
return IsPointer(symbol) || IsAllocatable(symbol);
}
inline bool IsParameter(const Symbol &symbol) {
return symbol.attrs().test(Attr::PARAMETER);
}
// Determines whether an object might be visible outside a
// PURE function (C1594); returns a non-null Symbol pointer for
// diagnostic purposes if so.

8
flang/lib/semantics/type.cc
View File

@ -293,14 +293,6 @@ const LogicalTypeSpec &DeclTypeSpec::logicalTypeSpec() const {
CHECK(category_ == Logical);
return std::get<LogicalTypeSpec>(typeSpec_);
}
const DerivedTypeSpec &DeclTypeSpec::derivedTypeSpec() const {
CHECK(category_ == TypeDerived || category_ == ClassDerived);
return std::get<DerivedTypeSpec>(typeSpec_);
}
DerivedTypeSpec &DeclTypeSpec::derivedTypeSpec() {
CHECK(category_ == TypeDerived || category_ == ClassDerived);
return std::get<DerivedTypeSpec>(typeSpec_);
}
bool DeclTypeSpec::operator==(const DeclTypeSpec &that) const {
return category_ == that.category_ && typeSpec_ == that.typeSpec_;
}

10
flang/lib/semantics/type.h
View File

@ -289,8 +289,14 @@ public:
CHECK(category_ == Character);
return std::get<CharacterTypeSpec>(typeSpec_);
}
const DerivedTypeSpec &derivedTypeSpec() const;
DerivedTypeSpec &derivedTypeSpec();
const DerivedTypeSpec &derivedTypeSpec() const {
CHECK(category_ == TypeDerived || category_ == ClassDerived);
return std::get<DerivedTypeSpec>(typeSpec_);
}
DerivedTypeSpec &derivedTypeSpec() {
CHECK(category_ == TypeDerived || category_ == ClassDerived);
return std::get<DerivedTypeSpec>(typeSpec_);
}
IntrinsicTypeSpec *AsIntrinsic();
const IntrinsicTypeSpec *AsIntrinsic() const {

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

@ -117,10 +117,19 @@ struct TestCall {
if (resultType.has_value()) {
TEST(si.has_value());
TEST(buffer.empty());
TEST(*resultType == si->specificIntrinsic.type);
MATCH(rank, si->specificIntrinsic.rank);
const auto &proc{si->specificIntrinsic.characteristics.value()};
const auto &fr{proc.functionResult};
TEST(fr.has_value());
if (fr) {
const auto *ts{fr->GetTypeAndShape()};
TEST(ts != nullptr);
if (ts) {
TEST(*resultType == ts->type());
MATCH(rank, ts->Rank());
}
}
MATCH(isElemental,
si->specificIntrinsic.attrs.test(semantics::Attr::ELEMENTAL));
proc.attrs.test(characteristics::Procedure::Attr::Elemental));
} else {
TEST(!si.has_value());
TEST(!buffer.empty() || name == "bad");