#include "../common/fortran.h"
#include "../common/idioms.h"
#include <map>
+#include <ostream>
+#include <sstream>
#include <string>
#include <utility>
static constexpr CategorySet AnyType{
IntrinsicType | CategorySet{TypeCategory::Derived}};
-enum class KindCode {
- none,
- defaultIntegerKind,
- defaultRealKind, // is also the default COMPLEX kind
- doublePrecision,
- defaultCharKind,
- defaultLogicalKind,
- any, // matches any kind value; each instance is independent
- typeless, // BOZ literals are INTEGER with this kind
- teamType, // TEAM_TYPE from module ISO_FORTRAN_ENV (for coarrays)
- kindArg, // this argument is KIND=
- effectiveKind, // for function results: same "kindArg", possibly defaulted
- dimArg, // this argument is DIM=
- same, // match any kind; all "same" kinds must be equal
- likeMultiply, // for DOT_PRODUCT and MATMUL
-};
+ENUM_CLASS(KindCode, none, defaultIntegerKind,
+ defaultRealKind, // is also the default COMPLEX kind
+ doublePrecision, defaultCharKind, defaultLogicalKind,
+ any, // matches any kind value; each instance is independent
+ typeless, // BOZ literals are INTEGER with this kind
+ teamType, // TEAM_TYPE from module ISO_FORTRAN_ENV (for coarrays)
+ kindArg, // this argument is KIND=
+ effectiveKind, // for function results: same "kindArg", possibly defaulted
+ dimArg, // this argument is DIM=
+ same, // match any kind; all "same" kinds must be equal
+ likeMultiply, // for DOT_PRODUCT and MATMUL
+)
struct TypePattern {
CategorySet categorySet;
KindCode kindCode{KindCode::none};
+ std::ostream &Dump(std::ostream &) const;
};
// Abbreviations for argument and result patterns in the intrinsic prototypes:
// The default rank pattern for dummy arguments and function results is
// "elemental".
-enum class Rank {
- elemental, // scalar, or array that conforms with other array arguments
- elementalOrBOZ, // elemental, or typeless BOZ literal scalar
- scalar,
- vector,
- shape, // INTEGER vector of known length and no negative element
- matrix,
- array, // not scalar, rank is known and greater than zero
- known, // rank is known and can be scalar
- anyOrAssumedRank, // rank can be unknown
- conformable, // scalar, or array of same rank & shape as "array" argument
- reduceOperation, // a pure function with constraints for REDUCE
- dimReduced, // scalar if no DIM= argument, else rank(array)-1
- dimRemoved, // scalar, or rank(array)-1
- rankPlus1, // rank(known)+1
- shaped, // rank is length of SHAPE vector
-};
+ENUM_CLASS(Rank,
+ elemental, // scalar, or array that conforms with other array arguments
+ elementalOrBOZ, // elemental, or typeless BOZ literal scalar
+ scalar, vector,
+ shape, // INTEGER vector of known length and no negative element
+ matrix,
+ array, // not scalar, rank is known and greater than zero
+ known, // rank is known and can be scalar
+ anyOrAssumedRank, // rank can be unknown
+ conformable, // scalar, or array of same rank & shape as "array" argument
+ reduceOperation, // a pure function with constraints for REDUCE
+ dimReduced, // scalar if no DIM= argument, else rank(array)-1
+ dimRemoved, // scalar, or rank(array)-1
+ rankPlus1, // rank(known)+1
+ shaped, // rank is length of SHAPE vector
+)
-enum class Optionality {
- required,
- optional,
- defaultsToSameKind, // for MatchingDefaultKIND
- defaultsToDefaultForResult, // for DefaultingKIND
- repeats, // for MAX/MIN and their several variants
-};
+ENUM_CLASS(Optionality, required, optional,
+ defaultsToSameKind, // for MatchingDefaultKIND
+ defaultsToDefaultForResult, // for DefaultingKIND
+ repeats, // for MAX/MIN and their several variants
+)
struct IntrinsicDummyArgument {
const char *keyword{nullptr};
TypePattern typePattern;
Rank rank{Rank::elemental};
Optionality optionality{Optionality::required};
+ std::ostream &Dump(std::ostream &) const;
};
// constexpr abbreviations for popular arguments:
std::optional<SpecificIntrinsic> Match(const CallCharacteristics &,
const IntrinsicTypeDefaultKinds &,
parser::ContextualMessages &messages) const;
+ std::ostream &Dump(std::ostream &) const;
};
static const IntrinsicInterface genericIntrinsicFunction[]{
if (arg.isAlternateReturn) {
messages.Say(
"alternate return specifier not acceptable on call to intrinsic '%s'"_err_en_US,
- call.name.ToString().data());
+ name);
return std::nullopt;
}
bool found{false};
break;
}
}
- if (!found) {
- if (arg.keyword.has_value()) {
- messages.Say(*arg.keyword,
- "unknown keyword argument to intrinsic '%'"_err_en_US,
- call.name.ToString().data());
- } else {
- messages.Say("too many actual arguments"_err_en_US);
- }
- return std::nullopt;
+ }
+ if (!found) {
+ if (arg.keyword.has_value()) {
+ messages.Say(*arg.keyword,
+ "unknown keyword argument to intrinsic '%s'"_err_en_US, name);
+ } else {
+ messages.Say(
+ "too many actual arguments for intrinsic '%s'"_err_en_US, name);
}
+ return std::nullopt;
}
}
const ActualArgument *arg{actualForDummy[dummyArgIndex]};
if (!arg) {
if (d.optionality == Optionality::required) {
- messages.Say("missing '%s' argument"_err_en_US, d.keyword);
+ messages.Say("missing mandatory '%s=' argument"_err_en_US, d.keyword);
return std::nullopt; // missing non-OPTIONAL argument
} else {
continue;
d.rank == Rank::elementalOrBOZ) {
continue;
}
- messages.Say("typeless (BOZ) not allowed for '%s'"_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->Dump().data());
return std::nullopt; // argument has invalid type category
}
}
if (!argOk) {
messages.Say(
- "actual argument for '%s' has bad type or kind '%s'"_err_en_US,
+ "actual argument for '%s=' has bad type or kind '%s'"_err_en_US,
d.keyword, type->Dump().data());
return std::nullopt;
}
if (const ActualArgument * arg{actualForDummy[dummyArgIndex]}) {
if (arg->isAssumedRank && d.rank != Rank::anyOrAssumedRank) {
messages.Say(
- "assumed-rank array cannot be used for '%s' argument"_err_en_US,
+ "assumed-rank array cannot be used for '%s=' argument"_err_en_US,
d.keyword);
return std::nullopt;
}
default: CRASH_NO_CASE;
}
if (!argOk) {
- messages.Say("'%s' argument has unacceptable rank %d"_err_en_US,
+ messages.Say("'%s=' argument has unacceptable rank %d"_err_en_US,
d.keyword, rank);
return std::nullopt;
}
}
}
}
- messages.Say("'kind' argument must be a constant scalar integer "
+ messages.Say("'kind=' argument must be a constant scalar integer "
"whose value is a supported kind for the "
"intrinsic result type"_err_en_US);
return std::nullopt;
IntrinsicTypeDefaultKinds defaults;
std::multimap<std::string, const IntrinsicInterface *> genericFuncs;
std::multimap<std::string, const SpecificIntrinsicInterface *> specificFuncs;
+ std::ostream &Dump(std::ostream &) const;
};
// Probe the configured intrinsic procedure pattern tables in search of a
if (call.isSubroutineCall) {
return std::nullopt; // TODO
}
- bool wantMessages{messages != nullptr && messages->messages() != nullptr};
+ parser::Messages *finalBuffer{messages ? messages->messages() : nullptr};
// Probe the specific intrinsic function table first.
parser::Messages specificBuffer;
parser::ContextualMessages specificErrors{
messages ? messages->at() : call.name,
- wantMessages ? &specificBuffer : nullptr};
+ finalBuffer ? &specificBuffer : nullptr};
std::string name{call.name.ToString()};
auto specificRange{specificFuncs.equal_range(name)};
for (auto iter{specificRange.first}; iter != specificRange.second; ++iter) {
parser::Messages genericBuffer;
parser::ContextualMessages genericErrors{
messages ? messages->at() : call.name,
- wantMessages ? &genericBuffer : nullptr};
+ finalBuffer ? &genericBuffer : nullptr};
auto genericRange{genericFuncs.equal_range(name)};
for (auto iter{genericRange.first}; iter != genericRange.second; ++iter) {
if (auto specific{iter->second->Match(call, defaults, genericErrors)}) {
}
}
// No match
- if (wantMessages) {
+ if (finalBuffer) {
if (genericBuffer.empty()) {
- CHECK(!specificBuffer.empty());
- messages->messages()->Annex(std::move(specificBuffer));
+ finalBuffer->Annex(std::move(specificBuffer));
} else {
- messages->messages()->Annex(std::move(genericBuffer));
+ finalBuffer->Annex(std::move(genericBuffer));
}
}
return std::nullopt;
std::ostream &SpecificIntrinsic::Dump(std::ostream &o) const {
return o << name;
}
+
+std::ostream &TypePattern::Dump(std::ostream &o) const {
+ if (categorySet == AnyType) {
+ o << "any type";
+ } else {
+ const char *sep = "";
+ auto set{categorySet};
+ while (auto least{set.LeastElement()}) {
+ o << sep << EnumToString(*least);
+ sep = " or ";
+ set.reset(*least);
+ }
+ }
+ o << '(' << EnumToString(kindCode) << ')';
+ return o;
+}
+
+std::ostream &IntrinsicDummyArgument::Dump(std::ostream &o) const {
+ if (keyword) {
+ o << keyword << '=';
+ }
+ return typePattern.Dump(o)
+ << ' ' << EnumToString(rank) << ' ' << EnumToString(optionality);
+}
+
+std::ostream &IntrinsicInterface::Dump(std::ostream &o) const {
+ o << name;
+ char sep{'('};
+ for (const auto &d : dummy) {
+ if (d.typePattern.kindCode == KindCode::none) {
+ break;
+ }
+ d.Dump(o << sep);
+ sep = ',';
+ }
+ if (sep == '(') {
+ o << "()";
+ }
+ return result.Dump(o << " -> ") << ' ' << EnumToString(rank);
+}
+
+std::ostream &IntrinsicProcTable::Implementation::Dump(std::ostream &o) const {
+ o << "generic intrinsic functions:\n";
+ for (const auto &iter : genericFuncs) {
+ iter.second->Dump(o << iter.first << ": ") << '\n';
+ }
+ o << "specific intrinsic functions:\n";
+ for (const auto &iter : specificFuncs) {
+ iter.second->Dump(o << iter.first << ": ");
+ if (const char *g{iter.second->generic}) {
+ o << " -> " << g;
+ }
+ o << '\n';
+ }
+ return o;
+}
+
+std::ostream &IntrinsicProcTable::Dump(std::ostream &o) const {
+ return impl_->Dump(o);
+}
+
} // namespace Fortran::evaluate
#include "../../lib/evaluate/expression.h"
#include "../../lib/evaluate/tools.h"
#include "../../lib/parser/provenance.h"
+#include <initializer_list>
#include <iostream>
+#include <map>
#include <string>
namespace Fortran::evaluate {
+class CookedStrings {
+public:
+ CookedStrings() {}
+ explicit CookedStrings(const std::initializer_list<std::string> &ss) {
+ for (const auto &s : ss) {
+ Save(s);
+ }
+ Marshal();
+ }
+ void Save(const std::string &s) {
+ offsets_[s] = cooked_.Put(s);
+ cooked_.PutProvenance(cooked_.allSources().AddCompilerInsertion(s));
+ }
+ void Marshal() { cooked_.Marshal(); }
+ parser::CharBlock operator()(const std::string &s) {
+ return {cooked_.data().data() + offsets_[s], s.size()};
+ }
+ parser::ContextualMessages Messages(parser::Messages &buffer) {
+ return parser::ContextualMessages{cooked_.data(), &buffer};
+ }
+ void Emit(std::ostream &o, const parser::Messages &messages) {
+ messages.Emit(o, cooked_);
+ }
+
+private:
+ parser::CookedSource cooked_;
+ std::map<std::string, std::size_t> offsets_;
+};
+
template<typename A> auto Const(A &&x) -> Constant<TypeOf<A>> {
return Constant<TypeOf<A>>{std::move(x)};
}
+template<typename A> struct NamedArg {
+ std::string keyword;
+ A value;
+};
+
+template<typename A> static NamedArg<A> Named(std::string kw, A &&x) {
+ return {kw, std::move(x)};
+}
+
+struct TestCall {
+ TestCall(const IntrinsicProcTable &t, std::string n) : table{t}, name{n} {}
+ template<typename A> TestCall &Push(A &&x) {
+ args.emplace_back(AsGenericExpr(std::move(x)));
+ keywords.push_back("");
+ return *this;
+ }
+ template<typename A> TestCall &Push(NamedArg<A> &&x) {
+ args.emplace_back(AsGenericExpr(std::move(x.value)));
+ keywords.push_back(x.keyword);
+ strings.Save(x.keyword);
+ return *this;
+ }
+ template<typename A, typename... As> TestCall &Push(A &&x, As &&... xs) {
+ Push(std::move(x));
+ return Push(std::move(xs)...);
+ }
+ void Marshal() {
+ strings.Save(name);
+ strings.Marshal();
+ std::size_t j{0};
+ for (auto &kw : keywords) {
+ if (!kw.empty()) {
+ args[j].keyword = strings(kw);
+ }
+ ++j;
+ }
+ }
+ void DoCall(std::optional<DynamicType> resultType = std::nullopt,
+ int rank = 0, bool isElemental = false) {
+ Marshal();
+ parser::CharBlock fName{strings(name)};
+ std::cout << "function: " << fName.ToString();
+ char sep{'('};
+ for (const auto &a : args) {
+ std::cout << sep;
+ sep = ',';
+ a.Dump(std::cout);
+ }
+ if (sep == '(') {
+ std::cout << '(';
+ }
+ std::cout << ")\n";
+ CallCharacteristics call{fName, args};
+ auto messages{strings.Messages(buffer)};
+ std::optional<SpecificIntrinsic> si{table.Probe(call, &messages)};
+ if (resultType.has_value()) {
+ TEST(si.has_value());
+ TEST(buffer.empty());
+ TEST(*resultType == si->type);
+ MATCH(rank, si->rank);
+ MATCH(isElemental, si->isElemental);
+ } else {
+ TEST(!si.has_value());
+ TEST(!buffer.empty() || name == "bad");
+ }
+ strings.Emit(std::cout, buffer);
+ }
+
+ const IntrinsicProcTable &table;
+ CookedStrings strings;
+ parser::Messages buffer;
+ Arguments args;
+ std::string name;
+ std::vector<std::string> keywords;
+};
+
template<typename A> void Push(Arguments &args, A &&x) {
args.emplace_back(AsGenericExpr(std::move(x)));
}
MATCH(4, defaults.defaultIntegerKind);
MATCH(4, defaults.defaultRealKind);
IntrinsicProcTable table{IntrinsicProcTable::Configure(defaults)};
+ table.Dump(std::cout);
- parser::CookedSource cooked;
- std::string name{"abs"};
- cooked.Put(name.data(), name.size());
- cooked.PutProvenance(cooked.allSources().AddCompilerInsertion(name));
- cooked.Marshal();
- TEST(cooked.data() == name);
- parser::CharBlock nameCharBlock{cooked.data().data(), name.size()};
- CallCharacteristics call{nameCharBlock, Args(Const(value::Integer<32>{1}))};
- parser::Messages buffer;
- parser::ContextualMessages messages{cooked.data(), &buffer};
- std::optional<SpecificIntrinsic> si{table.Probe(call, &messages)};
- TEST(si.has_value());
- TEST(buffer.empty());
- buffer.Emit(std::cout, cooked);
+ using Int4 = Type<TypeCategory::Integer, 4>;
+
+ TestCall{table, "bad"}
+ .Push(Const(Scalar<Int4>{1}))
+ .DoCall(); // bad intrinsic name
+ TestCall{table, "abs"}
+ .Push(Named("a", Const(Scalar<Int4>{1})))
+ .DoCall(Int4::dynamicType);
+ TestCall{table, "abs"}.Push(Const(Scalar<Int4>{1})).DoCall(Int4::dynamicType);
+ TestCall{table, "abs"}
+ .Push(Named("bad", Const(Scalar<Int4>{1})))
+ .DoCall(); // bad keyword
+ TestCall{table, "abs"}.DoCall(); // insufficient args
+ TestCall{table, "abs"}
+ .Push(Const(Scalar<Int4>{1}))
+ .Push(Const(Scalar<Int4>{2}))
+ .DoCall(); // too many args
+ TestCall{table, "abs"}
+ .Push(Const(Scalar<Int4>{1}))
+ .Push(Named("a", Const(Scalar<Int4>{2})))
+ .DoCall();
+ TestCall{table, "abs"}
+ .Push(Named("a", Const(Scalar<Int4>{1})))
+ .Push(Const(Scalar<Int4>{2}))
+ .DoCall();
}
} // namespace Fortran::evaluate
projects / platform / upstream / llvm.git / commitdiff