}
bool ActualArgument::operator==(const ActualArgument &that) const {
- return keyword == that.keyword &&
- isAlternateReturn == that.isAlternateReturn && u_ == that.u_;
+ return keyword_ == that.keyword_ &&
+ isAlternateReturn_ == that.isAlternateReturn_ && u_ == that.u_;
}
void ActualArgument::Parenthesize() {
- CHECK(!isAlternateReturn);
u_ = evaluate::Parenthesize(std::move(DEREF(UnwrapExpr())));
}
SymbolRef symbol_;
};
+ // A placeholder for the passed-object argument, which will be replaced
+ // with the base object of the Component that constitutes the call's
+ // ProcedureDesignator.
+ struct PassedObject {
+ bool operator==(const PassedObject &) const { return true; }
+ };
+
explicit ActualArgument(Expr<SomeType> &&);
explicit ActualArgument(common::CopyableIndirection<Expr<SomeType>> &&);
explicit ActualArgument(AssumedType);
+ explicit ActualArgument(PassedObject &&) : u_{PassedObject{}} {}
~ActualArgument();
ActualArgument &operator=(Expr<SomeType> &&);
bool operator==(const ActualArgument &) const;
std::ostream &AsFortran(std::ostream &) const;
- std::optional<parser::CharBlock> keyword;
- bool isAlternateReturn{false}; // when true, "value" is a label number
+ std::optional<parser::CharBlock> keyword() const { return keyword_; }
+ void set_keyword(parser::CharBlock x) { keyword_ = x; }
+ bool isAlternateReturn() const { return isAlternateReturn_; }
+ void set_isAlternateReturn() { isAlternateReturn_ = true; }
+ bool IsPassedObject() const {
+ return std::holds_alternative<PassedObject>(u_);
+ }
bool Matches(const characteristics::DummyArgument &) const;
// Wrap this argument in parentheses
// e.g. between X and (X). The parser attempts to parse each argument
// first as a variable, then as an expression, and the distinction appears
// in the parse tree.
- std::variant<common::CopyableIndirection<Expr<SomeType>>, AssumedType> u_;
+ std::variant<common::CopyableIndirection<Expr<SomeType>>, AssumedType,
+ PassedObject>
+ u_;
+ std::optional<parser::CharBlock> keyword_;
+ bool isAlternateReturn_{false}; // whether expr is a "*label" number
};
using ActualArguments = std::vector<std::optional<ActualArgument>>;
std::optional<Expr<SubscriptInteger>> LEN() const;
std::ostream &AsFortran(std::ostream &) const;
- // TODO: When calling X%F, pass X as PASS argument unless NOPASS
std::variant<SpecificIntrinsic, SymbolRef,
common::CopyableIndirection<Component>>
u;
DummyArgument::~DummyArgument() {}
bool DummyArgument::operator==(const DummyArgument &that) const {
- return u == that.u;
+ return u == that.u; // name and passed-object usage are not characteristics
}
std::optional<DummyArgument> DummyArgument::Characterize(
dummyArguments == that.dummyArguments;
}
+int Procedure::FindPassIndex(std::optional<parser::CharBlock> name) const {
+ int argCount{static_cast<int>(dummyArguments.size())};
+ int index{0};
+ if (name) {
+ while (index < argCount && *name != dummyArguments[index].name.c_str()) {
+ ++index;
+ }
+ }
+ CHECK(index < argCount);
+ return index;
+}
+
bool Procedure::CanOverride(
const Procedure &that, std::optional<int> passIndex) const {
// A PURE procedure may override an impure one (7.5.7.3(2))
functionResult != that.functionResult) {
return false;
}
- if (passIndex) {
- int argCount{static_cast<int>(dummyArguments.size())};
- if (argCount != static_cast<int>(that.dummyArguments.size())) {
+ int argCount{static_cast<int>(dummyArguments.size())};
+ if (argCount != static_cast<int>(that.dummyArguments.size())) {
+ return false;
+ }
+ for (int j{0}; j < argCount; ++j) {
+ if ((!passIndex || j != *passIndex) &&
+ dummyArguments[j] != that.dummyArguments[j]) {
return false;
}
- CHECK(*passIndex >= 0 && *passIndex <= argCount);
- for (int j{0}; j < argCount; ++j) {
- if (j != *passIndex && dummyArguments[j] != that.dummyArguments[j]) {
- return false;
- }
- }
- return true;
- } else {
- return dummyArguments == that.dummyArguments;
}
+ return true;
}
std::optional<Procedure> Procedure::Characterize(
},
[&](const semantics::ProcBindingDetails &binding) {
if (auto result{Characterize(binding.symbol(), intrinsics)}) {
- if (const auto passIndex{binding.passIndex()}) {
- auto &passArg{result->dummyArguments.at(*passIndex)};
- passArg.pass = true;
- if (const auto passName{binding.passName()}) {
- CHECK(passArg.name == passName->ToString());
+ if (!symbol.attrs().test(semantics::Attr::NOPASS)) {
+ auto passName{binding.passName()};
+ for (auto &dummy : result->dummyArguments) {
+ if (!passName || dummy.name.c_str() == *passName) {
+ dummy.pass = true;
+ return result;
+ }
}
+ DIE("PASS argument missing");
}
return result;
} else {
#include "../common/enum-set.h"
#include "../common/idioms.h"
#include "../common/indirection.h"
+#include "../parser/char-block.h"
#include "../semantics/symbol.h"
#include <optional>
#include <ostream>
bool HasExplicitInterface() const {
return !attrs.test(Attr::ImplicitInterface);
}
+ int FindPassIndex(std::optional<parser::CharBlock>) const;
bool CanBeCalledViaImplicitInterface() const;
bool CanOverride(const Procedure &, std::optional<int> passIndex) const;
std::ostream &Dump(std::ostream &) const;
}
std::ostream &ActualArgument::AsFortran(std::ostream &o) const {
- if (keyword) {
- o << keyword->ToString() << '=';
+ CHECK(!IsPassedObject());
+ if (keyword_) {
+ o << keyword_->ToString() << '=';
}
- if (isAlternateReturn) {
+ if (isAlternateReturn_) {
o << '*';
}
if (const auto *expr{UnwrapExpr()}) {
proc_.AsFortran(o);
char separator{'('};
for (const auto &arg : arguments_) {
- if (arg) {
+ if (arg && !arg->IsPassedObject()) {
arg->AsFortran(o << separator);
separator = ',';
}
if (!arg) {
++missingActualArguments;
} else {
- if (arg->isAlternateReturn) {
+ if (arg->isAlternateReturn()) {
messages.Say(
"alternate return specifier not acceptable on call to intrinsic '%s'"_err_en_US,
name);
bool found{false};
int slot{missingActualArguments};
for (std::size_t j{0}; j < nonRepeatedDummies && !found; ++j) {
- if (arg->keyword) {
- found = *arg->keyword == dummy[j].keyword;
+ if (arg->keyword()) {
+ found = *arg->keyword() == dummy[j].keyword;
if (found) {
if (const auto *previous{actualForDummy[j]}) {
- if (previous->keyword) {
- messages.Say(*arg->keyword,
+ if (previous->keyword()) {
+ messages.Say(*arg->keyword(),
"repeated keyword argument to intrinsic '%s'"_err_en_US,
name);
} else {
- messages.Say(*arg->keyword,
+ messages.Say(*arg->keyword(),
"keyword argument to intrinsic '%s' was supplied "
"positionally by an earlier actual argument"_err_en_US,
name);
}
}
if (!found) {
- if (repeatLastDummy && !arg->keyword) {
+ if (repeatLastDummy && !arg->keyword()) {
// MAX/MIN argument after the 2nd
actualForDummy.push_back(&*arg);
} else {
- if (arg->keyword) {
- messages.Say(*arg->keyword,
+ if (arg->keyword()) {
+ messages.Say(*arg->keyword(),
"unknown keyword argument to intrinsic '%s'"_err_en_US, name);
} else {
messages.Say(
if (!arguments.empty()) {
if (arguments.size() > 1) {
context.messages().Say("Too many arguments to NULL()"_err_en_US);
- } else if (arguments[0] && arguments[0]->keyword &&
- arguments[0]->keyword->ToString() != "mold") {
+ } else if (arguments[0] && arguments[0]->keyword() &&
+ arguments[0]->keyword()->ToString() != "mold") {
context.messages().Say("Unknown argument '%s' to NULL()"_err_en_US,
- arguments[0]->keyword->ToString());
+ arguments[0]->keyword()->ToString());
} else {
if (Expr<SomeType> * mold{arguments[0]->UnwrapExpr()}) {
if (IsAllocatableOrPointer(*mold)) {
static void CheckImplicitInterfaceArg(
evaluate::ActualArgument &arg, parser::ContextualMessages &messages) {
- if (const auto &kw{arg.keyword}) {
+ if (auto kw{arg.keyword()}) {
messages.Say(*kw,
"Keyword '%s=' may not appear in a reference to a procedure with an implicit interface"_err_en_US,
*kw);
std::map<std::string, evaluate::ActualArgument> kwArgs;
for (auto &x : actuals) {
if (x) {
- if (x->keyword) {
+ if (x->keyword()) {
auto emplaced{
- kwArgs.try_emplace(x->keyword->ToString(), std::move(*x))};
+ kwArgs.try_emplace(x->keyword()->ToString(), std::move(*x))};
if (!emplaced.second) {
- messages.Say(*x->keyword,
+ messages.Say(*x->keyword(),
"Argument keyword '%s=' appears on more than one effective argument in this procedure reference"_err_en_US,
- *x->keyword);
+ *x->keyword());
}
x.reset();
}
if (iter != kwArgs.end()) {
evaluate::ActualArgument &x{iter->second};
if (actuals[index]) {
- messages.Say(*x.keyword,
+ messages.Say(*x.keyword(),
"Keyword argument '%s=' has already been specified positionally (#%d) in this procedure reference"_err_en_US,
- *x.keyword, index + 1);
+ *x.keyword(), index + 1);
} else {
actuals[index] = std::move(x);
}
}
for (auto &bad : kwArgs) {
evaluate::ActualArgument &x{bad.second};
- messages.Say(*x.keyword,
+ messages.Say(*x.keyword(),
"Argument keyword '%s=' is not recognized for this procedure reference"_err_en_US,
- *x.keyword);
+ *x.keyword());
}
}
}
const evaluate::FoldingContext &context, const Scope *scope) {
parser::Messages buffer;
parser::ContextualMessages messages{context.messages().at(), &buffer};
- evaluate::FoldingContext localContext{context, messages};
RearrangeArguments(proc, actuals, messages);
if (buffer.empty()) {
int index{0};
+ evaluate::FoldingContext localContext{context, messages};
for (auto &actual : actuals) {
const auto &dummy{proc.dummyArguments.at(index++)};
if (actual) {
void CheckValue(const Symbol &, const DerivedTypeSpec *);
void CheckVolatile(
const Symbol &, bool isAssociated, const DerivedTypeSpec *);
+ void CheckPassArg(
+ const Symbol &proc, const Symbol *interface, const WithPassArg &);
void CheckProcBinding(const Symbol &, const ProcBindingDetails &);
void CheckObjectEntity(const Symbol &, const ObjectEntityDetails &);
void CheckProcEntity(const Symbol &, const ProcEntityDetails &);
// function SIN as an actual argument.
messages_.Say("A dummy procedure may not be ELEMENTAL"_err_en_US);
}
+ } else if (symbol.owner().IsDerivedType()) {
+ CheckPassArg(symbol, details.interface().symbol(), details);
}
}
}
}
+// C760 constraints on the passed-object dummy argument
+void CheckHelper::CheckPassArg(
+ const Symbol &proc, const Symbol *interface, const WithPassArg &details) {
+ if (proc.attrs().test(Attr::NOPASS)) {
+ return;
+ }
+ const auto &name{proc.name()};
+ if (!interface) {
+ messages_.Say(name,
+ "Procedure component '%s' must have NOPASS attribute or explicit interface"_err_en_US,
+ name);
+ return;
+ }
+ const auto *subprogram{interface->detailsIf<SubprogramDetails>()};
+ if (!subprogram) {
+ messages_.Say(name,
+ "Procedure component '%s' has invalid interface '%s'"_err_en_US, name,
+ interface->name());
+ return;
+ }
+ std::optional<SourceName> passName{details.passName()};
+ const auto &dummyArgs{subprogram->dummyArgs()};
+ if (!passName) {
+ if (dummyArgs.empty()) {
+ messages_.Say(name,
+ proc.has<ProcEntityDetails>()
+ ? "Procedure component '%s' with no dummy arguments"
+ " must have NOPASS attribute"_err_en_US
+ : "Procedure binding '%s' with no dummy arguments"
+ " must have NOPASS attribute"_err_en_US,
+ name);
+ return;
+ }
+ passName = dummyArgs[0]->name();
+ }
+ std::optional<int> passArgIndex{};
+ for (std::size_t i{0}; i < dummyArgs.size(); ++i) {
+ if (dummyArgs[i] && dummyArgs[i]->name() == *passName) {
+ passArgIndex = i;
+ break;
+ }
+ }
+ if (!passArgIndex) {
+ messages_.Say(*passName,
+ "'%s' is not a dummy argument of procedure interface '%s'"_err_en_US,
+ *passName, interface->name());
+ return;
+ }
+ const Symbol &passArg{*dummyArgs[*passArgIndex]};
+ std::optional<parser::MessageFixedText> msg;
+ if (!passArg.has<ObjectEntityDetails>()) {
+ msg = "Passed-object dummy argument '%s' of procedure '%s'"
+ " must be a data object"_err_en_US;
+ } else if (passArg.attrs().test(Attr::POINTER)) {
+ msg = "Passed-object dummy argument '%s' of procedure '%s'"
+ " may not have the POINTER attribute"_err_en_US;
+ } else if (passArg.attrs().test(Attr::ALLOCATABLE)) {
+ msg = "Passed-object dummy argument '%s' of procedure '%s'"
+ " may not have the ALLOCATABLE attribute"_err_en_US;
+ } else if (passArg.attrs().test(Attr::VALUE)) {
+ msg = "Passed-object dummy argument '%s' of procedure '%s'"
+ " may not have the VALUE attribute"_err_en_US;
+ } else if (passArg.Rank() > 0) {
+ msg = "Passed-object dummy argument '%s' of procedure '%s'"
+ " must be scalar"_err_en_US;
+ }
+ if (msg) {
+ messages_.Say(name, std::move(*msg), passName.value(), name);
+ return;
+ }
+ const DeclTypeSpec *type{passArg.GetType()};
+ if (!type) {
+ return; // an error already occurred
+ }
+ const Symbol &typeSymbol{*proc.owner().GetSymbol()};
+ const DerivedTypeSpec *derived{type->AsDerived()};
+ if (!derived || derived->typeSymbol() != typeSymbol) {
+ messages_.Say(name,
+ "Passed-object dummy argument '%s' of procedure '%s'"
+ " must be of type '%s' but is '%s'"_err_en_US,
+ passName.value(), name, typeSymbol.name(), type->AsFortran());
+ return;
+ }
+ if (IsExtensibleType(derived) != type->IsPolymorphic()) {
+ messages_.Say(name,
+ type->IsPolymorphic()
+ ? "Passed-object dummy argument '%s' of procedure '%s'"
+ " may not be polymorphic because '%s' is not extensible"_err_en_US
+ : "Passed-object dummy argument '%s' of procedure '%s'"
+ " must be polymorphic because '%s' is extensible"_err_en_US,
+ passName.value(), name, typeSymbol.name());
+ return;
+ }
+ for (const auto &[paramName, paramValue] : derived->parameters()) {
+ if (paramValue.isLen() && !paramValue.isAssumed()) {
+ messages_.Say(name,
+ "Passed-object dummy argument '%s' of procedure '%s'"
+ " has non-assumed length parameter '%s'"_err_en_US,
+ passName.value(), name, paramName);
+ }
+ }
+}
+
void CheckHelper::CheckProcBinding(
const Symbol &symbol, const ProcBindingDetails &binding) {
const Scope &dtScope{symbol.owner()};
"A type-bound procedure and its override must both, or neither, be ELEMENTAL"_err_en_US);
return;
}
- auto bindingChars{evaluate::characteristics::Procedure::Characterize(
- binding.symbol(), context_.intrinsics())};
- auto overriddenChars{evaluate::characteristics::Procedure::Characterize(
- overriddenBinding->symbol(), context_.intrinsics())};
- if (binding.passIndex()) {
- if (overriddenBinding->passIndex()) {
- int passIndex{*binding.passIndex()};
- if (passIndex == *overriddenBinding->passIndex()) {
- if (!(bindingChars && overriddenChars &&
- bindingChars->CanOverride(*overriddenChars, passIndex))) {
+ bool isNopass{symbol.attrs().test(Attr::NOPASS)};
+ if (isNopass != overridden->attrs().test(Attr::NOPASS)) {
+ SayWithDeclaration(*overridden,
+ isNopass
+ ? "A NOPASS type-bound procedure may not override a passed-argument procedure"_err_en_US
+ : "A passed-argument type-bound procedure may not override a NOPASS procedure"_err_en_US);
+ } else {
+ auto bindingChars{evaluate::characteristics::Procedure::Characterize(
+ binding.symbol(), context_.intrinsics())};
+ auto overriddenChars{evaluate::characteristics::Procedure::Characterize(
+ overriddenBinding->symbol(), context_.intrinsics())};
+ if (bindingChars && overriddenChars) {
+ if (isNopass) {
+ if (!bindingChars->CanOverride(*overriddenChars, std::nullopt)) {
SayWithDeclaration(*overridden,
- "A type-bound procedure and its override must have compatible interfaces apart from their passed argument"_err_en_US);
+ "A type-bound procedure and its override must have compatible interfaces"_err_en_US);
}
} else {
- SayWithDeclaration(*overridden,
- "A type-bound procedure and its override must use the same PASS argument"_err_en_US);
+ int passIndex{bindingChars->FindPassIndex(binding.passName())};
+ int overriddenPassIndex{
+ overriddenChars->FindPassIndex(overriddenBinding->passName())};
+ if (passIndex != overriddenPassIndex) {
+ SayWithDeclaration(*overridden,
+ "A type-bound procedure and its override must use the same PASS argument"_err_en_US);
+ } else if (!bindingChars->CanOverride(
+ *overriddenChars, passIndex)) {
+ SayWithDeclaration(*overridden,
+ "A type-bound procedure and its override must have compatible interfaces apart from their passed argument"_err_en_US);
+ }
}
- } else {
- SayWithDeclaration(*overridden,
- "A passed-argument type-bound procedure may not override a NOPASS procedure"_err_en_US);
}
- } else if (overriddenBinding->passIndex()) {
- SayWithDeclaration(*overridden,
- "A NOPASS type-bound procedure may not override a passed-argument procedure"_err_en_US);
- } else if (!(bindingChars && overriddenChars &&
- bindingChars->CanOverride(
- *overriddenChars, std::nullopt))) {
- SayWithDeclaration(*overridden,
- "A type-bound procedure and its override must have compatible interfaces"_err_en_US);
}
if (symbol.attrs().test(Attr::PRIVATE) &&
overridden->attrs().test(Attr::PUBLIC)) {
"A type-bound procedure binding may not have the same name as a parent component"_err_en_US);
}
}
+ CheckPassArg(symbol, &binding.symbol(), binding);
}
void CheckHelper::Check(const Scope &scope) {
void CheckDeclarations(SemanticsContext &context) {
CheckHelper{context}.Check();
}
-
}
#include <optional>
#include <set>
+#define CRASH_ON_FAILURE 1
// #define DUMP_ON_FAILURE 1
-// #define CRASH_ON_FAILURE 1
#if DUMP_ON_FAILURE
#include "../parser/dump-parse-tree.h"
#include <iostream>
return AsMaybeExpr(Expr<SomeDerived>{std::move(result)});
}
-static const semantics::WithPassArg *GetPassInfo(
- const semantics::Symbol &symbol) {
- if (const auto *binding{symbol.detailsIf<semantics::ProcBindingDetails>()}) {
- return binding;
- } else if (const auto *proc{
- symbol.detailsIf<semantics::ProcEntityDetails>()}) {
- return proc;
- } else {
- return nullptr;
+static std::optional<parser::CharBlock> GetPassName(
+ const semantics::Symbol &proc) {
+ return std::visit(
+ [](const auto &details) {
+ if constexpr (std::is_base_of_v<semantics::WithPassArg,
+ std::decay_t<decltype(details)>>) {
+ return details.passName();
+ } else {
+ return std::optional<parser::CharBlock>{};
+ }
+ },
+ proc.details());
+}
+
+static int GetPassIndex(const semantics::Symbol &proc, parser::CharBlock name) {
+ if (const auto *interface{semantics::FindInterface(proc)}) {
+ if (const auto *subp{
+ interface->detailsIf<semantics::SubprogramDetails>()}) {
+ int index{0};
+ for (const auto *arg : subp->dummyArgs()) {
+ if (arg && arg->name() == name) {
+ return index;
+ }
+ ++index;
+ }
+ DIE("PASS argument name not in dummy argument list");
+ }
}
+ return 0; // first argument is passed-object
}
auto ExpressionAnalyzer::AnalyzeProcedureComponentRef(
if (Symbol * sym{sc.component.symbol}) {
if (auto *dtExpr{UnwrapExpr<Expr<SomeDerived>>(*base)}) {
const semantics::DerivedTypeSpec *dtSpec{nullptr};
+ const auto *binding{sym->detailsIf<semantics::ProcBindingDetails>()};
+ const Symbol *resolution{nullptr};
+ if (binding && sym->attrs().test(semantics::Attr::NON_OVERRIDABLE)) {
+ resolution = &binding->symbol();
+ }
if (std::optional<DynamicType> dtDyTy{dtExpr->GetType()}) {
if (!dtDyTy->IsUnlimitedPolymorphic()) {
dtSpec = &dtDyTy->GetDerivedTypeSpec();
}
+ if (binding && !dtDyTy->IsPolymorphic()) {
+ resolution = &binding->symbol();
+ }
}
if (dtSpec && dtSpec->scope()) {
if (std::optional<DataRef> dataRef{
ExtractDataRef(std::move(*dtExpr))}) {
if (auto component{CreateComponent(
std::move(*dataRef), *sym, *dtSpec->scope())}) {
- if (const auto *pass{GetPassInfo(*sym)}) {
- if (auto passIndex{pass->passIndex()}) {
- // There's a PASS argument by which the base of the procedure
- // component reference must be passed. Append or insert it to
- // the list of effective arguments.
- auto iter{arguments.begin()};
- int at{0};
- while (iter < arguments.end() && at < *passIndex) {
- if (*iter && (*iter)->keyword) {
- iter = arguments.end();
- break;
- }
- ++iter;
- ++at;
+ if (!sym->attrs().test(semantics::Attr::NOPASS)) {
+ // There's a PASS argument by which the base of the procedure
+ // component reference must be passed. Append or insert it to
+ // the list of actual arguments.
+ auto passName{GetPassName(*sym)};
+ int passIndex{passName ? GetPassIndex(*sym, *passName) : 0};
+ auto iter{arguments.begin()};
+ int at{0};
+ while (iter < arguments.end() && at < passIndex) {
+ if (*iter && (*iter)->keyword()) {
+ iter = arguments.end();
+ break;
}
- ActualArgument passed{AsGenericExpr(std::move(*dtExpr))};
- if (iter == arguments.end() && pass->passName()) {
- passed.keyword = *pass->passName();
- }
- arguments.emplace(iter, std::move(passed));
+ ++iter;
+ ++at;
+ }
+ ActualArgument passed{ActualArgument::PassedObject{}};
+ if (resolution) {
+ passed = ActualArgument{AsGenericExpr(std::move(*dtExpr))};
+ }
+ if (iter == arguments.end() && passName) {
+ passed.set_keyword(*passName);
}
+ arguments.emplace(iter, std::move(passed));
}
- return CalleeAndArguments{
- ProcedureDesignator{std::move(*component)},
+ return CalleeAndArguments{resolution
+ ? ProcedureDesignator{*resolution}
+ : ProcedureDesignator{std::move(*component)},
std::move(arguments)};
} else {
Say(name,
return expr && IsProcedurePointer(*expr);
},
[&](const characteristics::AlternateReturn &) {
- return actual.isAlternateReturn;
+ return actual.isAlternateReturn();
},
},
dummy.u);
std::get<parser::ActualArg>(arg.t).u);
if (actual) {
if (const auto &argKW{std::get<std::optional<parser::Keyword>>(arg.t)}) {
- actual->keyword = argKW->v.source;
+ actual->set_keyword(argKW->v.source);
}
actuals_.emplace_back(std::move(*actual));
} else {
void AddSubpNames(const ProgramTree &);
bool BeginScope(const ProgramTree &);
void FinishSpecificationParts(const ProgramTree &);
- void FinishDerivedTypeDefinition(Scope &);
void FinishDerivedTypeInstantiation(Scope &);
- void SetPassArg(const Symbol &, const Symbol *, WithPassArg &);
void ResolveExecutionParts(const ProgramTree &);
};
// in those initializers will resolve to the right symbols.
DeferredCheckVisitor{*this}.Walk(node.spec());
DeferredCheckVisitor{*this}.Walk(node.exec()); // for BLOCK
- // Finish the definitions of derived types and parameterized derived
- // type instantiations. The original derived type definitions need to
- // be finished before the instantiations can be.
- for (Scope &childScope : currScope().children()) {
- if (childScope.IsDerivedType() && childScope.symbol()) {
- FinishDerivedTypeDefinition(childScope);
- }
- }
for (Scope &childScope : currScope().children()) {
if (childScope.IsDerivedType() && !childScope.symbol()) {
FinishDerivedTypeInstantiation(childScope);
}
}
-static int FindIndexOfName(
- const SourceName &name, std::vector<Symbol *> symbols) {
- for (std::size_t i{0}; i < symbols.size(); ++i) {
- if (symbols[i] && symbols[i]->name() == name) {
- return i;
- }
- }
- return -1;
-}
-
-// Perform final checks on a derived type and set the pass arguments.
-void ResolveNamesVisitor::FinishDerivedTypeDefinition(Scope &scope) {
- CHECK(scope.IsDerivedType() && scope.symbol());
- for (auto &pair : scope) {
- Symbol &comp{*pair.second};
- std::visit(
- common::visitors{
- [&](ProcEntityDetails &x) {
- SetPassArg(comp, x.interface().symbol(), x);
- },
- [&](ProcBindingDetails &x) { SetPassArg(comp, &x.symbol(), x); },
- [](auto &) {},
- },
- comp.details());
- }
-}
-
// Fold object pointer initializer designators with the actual
// type parameter values of a particular instantiation.
void ResolveNamesVisitor::FinishDerivedTypeInstantiation(Scope &scope) {
for (auto &pair : scope) {
Symbol &comp{*pair.second};
const Symbol &origComp{DEREF(FindInScope(*origTypeScope, comp.name()))};
- std::visit(
- common::visitors{
- [&](ObjectEntityDetails &x) {
- if (IsPointer(comp)) {
- auto origDetails{origComp.get<ObjectEntityDetails>()};
- if (const MaybeExpr & init{origDetails.init()}) {
- SomeExpr newInit{*init};
- MaybeExpr folded{
- evaluate::Fold(foldingContext, std::move(newInit))};
- x.set_init(std::move(folded));
- }
- }
- },
- [&](ProcEntityDetails &x) {
- auto origDetails{origComp.get<ProcEntityDetails>()};
- if (auto pi{origDetails.passIndex()}) {
- x.set_passIndex(*pi);
- }
- },
- [&](ProcBindingDetails &x) {
- auto origDetails{origComp.get<ProcBindingDetails>()};
- if (auto pi{origDetails.passIndex()}) {
- x.set_passIndex(*pi);
- }
- },
- [](auto &) {},
- },
- comp.details());
+ if (IsPointer(comp)) {
+ if (auto *details{comp.detailsIf<ObjectEntityDetails>()}) {
+ auto origDetails{origComp.get<ObjectEntityDetails>()};
+ if (const MaybeExpr & init{origDetails.init()}) {
+ SomeExpr newInit{*init};
+ MaybeExpr folded{
+ evaluate::Fold(foldingContext, std::move(newInit))};
+ details->set_init(std::move(folded));
+ }
+ }
+ }
}
}
}
}
-// Check C760, constraints on the passed-object dummy argument
-// If they all pass, set the passIndex in details.
-void ResolveNamesVisitor::SetPassArg(
- const Symbol &proc, const Symbol *interface, WithPassArg &details) {
- if (proc.attrs().test(Attr::NOPASS)) {
- return;
- }
- const auto &name{proc.name()};
- if (!interface) {
- Say(name,
- "Procedure component '%s' must have NOPASS attribute or explicit interface"_err_en_US,
- name);
- return;
- }
- const auto *subprogram{interface->detailsIf<SubprogramDetails>()};
- if (!subprogram) {
- Say(name, "Procedure component '%s' has invalid interface '%s'"_err_en_US,
- name, interface->name());
- return;
- }
- std::optional<SourceName> passName{details.passName()};
- const auto &dummyArgs{subprogram->dummyArgs()};
- if (!passName && dummyArgs.empty()) {
- Say(name,
- proc.has<ProcEntityDetails>()
- ? "Procedure component '%s' with no dummy arguments"
- " must have NOPASS attribute"_err_en_US
- : "Procedure binding '%s' with no dummy arguments"
- " must have NOPASS attribute"_err_en_US,
- name);
- return;
- }
- int passArgIndex{0};
- if (!passName) {
- passName = dummyArgs[0]->name();
- } else {
- passArgIndex = FindIndexOfName(*passName, dummyArgs);
- if (passArgIndex < 0) {
- Say(*passName,
- "'%s' is not a dummy argument of procedure interface '%s'"_err_en_US,
- *passName, interface->name());
- return;
- }
- }
- const Symbol &passArg{*dummyArgs[passArgIndex]};
- std::optional<MessageFixedText> msg;
- if (!passArg.has<ObjectEntityDetails>()) {
- msg = "Passed-object dummy argument '%s' of procedure '%s'"
- " must be a data object"_err_en_US;
- } else if (passArg.attrs().test(Attr::POINTER)) {
- msg = "Passed-object dummy argument '%s' of procedure '%s'"
- " may not have the POINTER attribute"_err_en_US;
- } else if (passArg.attrs().test(Attr::ALLOCATABLE)) {
- msg = "Passed-object dummy argument '%s' of procedure '%s'"
- " may not have the ALLOCATABLE attribute"_err_en_US;
- } else if (passArg.attrs().test(Attr::VALUE)) {
- msg = "Passed-object dummy argument '%s' of procedure '%s'"
- " may not have the VALUE attribute"_err_en_US;
- } else if (passArg.Rank() > 0) {
- msg = "Passed-object dummy argument '%s' of procedure '%s'"
- " must be scalar"_err_en_US;
- }
- if (msg) {
- Say(name, std::move(*msg), passName.value(), name);
- return;
- }
- const DeclTypeSpec *type{passArg.GetType()};
- if (!type) {
- return; // an error already occurred
- }
- const Symbol &typeSymbol{*proc.owner().GetSymbol()};
- const DerivedTypeSpec *derived{type->AsDerived()};
- if (!derived || derived->typeSymbol() != typeSymbol) {
- Say(name,
- "Passed-object dummy argument '%s' of procedure '%s'"
- " must be of type '%s' but is '%s'"_err_en_US,
- passName.value(), name, typeSymbol.name(), type->AsFortran());
- return;
- }
- if (IsExtensibleType(derived) != type->IsPolymorphic()) {
- Say(name,
- type->IsPolymorphic()
- ? "Passed-object dummy argument '%s' of procedure '%s'"
- " may not be polymorphic because '%s' is not extensible"_err_en_US
- : "Passed-object dummy argument '%s' of procedure '%s'"
- " must be polymorphic because '%s' is extensible"_err_en_US,
- passName.value(), name, typeSymbol.name());
- return;
- }
- for (const auto &[paramName, paramValue] : derived->parameters()) {
- if (paramValue.isLen() && !paramValue.isAssumed()) {
- Say(name,
- "Passed-object dummy argument '%s' of procedure '%s'"
- " has non-assumed length parameter '%s'"_err_en_US,
- passName.value(), name, paramName);
- }
- }
- details.set_passIndex(passArgIndex);
- details.set_passName(passName.value());
-}
-
// Resolve names in the execution part of this node and its children
void ResolveNamesVisitor::ResolveExecutionParts(const ProgramTree &node) {
if (!node.scope()) {
Fold(foldingContext, std::move(dim.ubound().GetExplicit())));
}
}
+ } else if (!attrs_.test(Attr::NOPASS)) {
+ std::visit(
+ [&result](const auto &x) {
+ using Ty = std::decay_t<decltype(x)>;
+ if constexpr (std::is_base_of_v<WithPassArg, Ty>) {
+ if (auto passName{x.passName()}) {
+ result.get<Ty>().set_passName(*passName);
+ }
+ }
+ },
+ details_);
}
return result;
}
};
// Mixin for details with passed-object dummy argument.
-// passIndex is set based on passName or the PASS attr.
+// If a procedure pointer component or type-bound procedure does not have
+// the NOPASS attribute on its symbol, then PASS is assumed; the name
+// is optional; if it is missing, the first dummy argument of the procedure's
+// interface is the passed-object dummy argument.
class WithPassArg {
public:
- const std::optional<SourceName> &passName() const { return passName_; }
+ std::optional<SourceName> passName() const { return passName_; }
void set_passName(const SourceName &passName) { passName_ = passName; }
- std::optional<int> passIndex() const { return passIndex_; }
- void set_passIndex(int index) { passIndex_ = index; }
private:
std::optional<SourceName> passName_;
- std::optional<int> passIndex_;
};
// A procedure pointer, dummy procedure, or external procedure
std::size_t j{0};
for (auto &kw : keywords) {
if (!kw.empty()) {
- args[j]->keyword = strings(kw);
+ args[j]->set_keyword(strings(kw));
}
++j;
}
subroutine test2
type(t) :: x
real :: a(x%tbp_pure(1)) ! ok
- !ERROR: Invalid specification expression: reference to impure function 'tbp_impure'
+ !ERROR: Invalid specification expression: reference to impure function 'impure'
real :: b(x%tbp_impure(1))
forall (j=1:1)
a(j) = x%tbp_pure(j) ! ok
end forall
forall (j=1:1)
- !ERROR: Impure procedure 'tbp_impure' may not be referenced in a FORALL
+ !ERROR: Impure procedure 'impure' may not be referenced in a FORALL
a(j) = x%tbp_impure(j) ! C1037
end forall
do concurrent (j=1:1, x%tbp_pure(j) /= 0) ! ok
! type::t
! procedure(),nopass,pointer::e
! procedure(real(4)),nopass,pointer::f
-! procedure(s),pass(x),pointer,private::g
+! procedure(s),pointer,private::g
! end type
!contains
! subroutine s(x)
! integer(4)::x
! contains
! final::c
-! procedure,pass(x),non_overridable,private::d
+! procedure,non_overridable,private::d
! end type
! type,abstract::t2a
! contains
! contains
! procedure,nopass::s2
! procedure,nopass::s3
-! procedure,pass(dtv)::r
+! procedure::r
! generic::foo=>s2
! generic::read(formatted)=>r
! end type
!Expect: m.mod
!module m
! type::t
-! procedure(a),pass(x),pointer::c
+! procedure(a),pass,pointer::c
! procedure(a),pass(x),pointer::d
! contains
! procedure,pass(y)::a
projects / platform / upstream / llvm.git / commitdiff