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

[flang] Fix problems with passed-object arguments by deferring the 

identification of their index in the dummy argument list,
simplifying their representation, completing the representation
of their actual arguments, and (while I'm here) resolving
calls to type-bound procedures whose bindings are known at
compilation time.

Button up class ActualArgument by making remaining data
members private and adding accessors & mutators.

Original-commit: flang-compiler/f18@5eb60ec419
Reviewed-on: https://github.com/flang-compiler/f18/pull/855
This commit is contained in:
peter klausler 2019-12-05 10:24:18 -08:00
parent 0aa8f5f643
commit f439356f61
18 changed files with 312 additions and 287 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -59,12 +59,11 @@ int ActualArgument::Rank() const {
}
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())));
}

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

@ -72,9 +72,17 @@ public:
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> &&);
@ -108,9 +116,14 @@ public:
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
@ -124,7 +137,11 @@ private:
// 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>>;
@ -167,7 +184,6 @@ struct ProcedureDesignator {
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;

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

@ -352,7 +352,7 @@ std::ostream &AlternateReturn::Dump(std::ostream &o) const { return o << '*'; }
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(
@ -561,6 +561,18 @@ bool Procedure::operator==(const Procedure &that) const {
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))
@ -569,21 +581,17 @@ bool Procedure::CanOverride(
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(
@ -652,12 +660,15 @@ 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 {

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

@ -27,6 +27,7 @@
#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>
@ -260,6 +261,7 @@ struct Procedure {
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;

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

@ -109,10 +109,11 @@ std::ostream &ActualArgument::AssumedType::AsFortran(std::ostream &o) 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()}) {
@ -130,7 +131,7 @@ std::ostream &ProcedureRef::AsFortran(std::ostream &o) const {
proc_.AsFortran(o);
char separator{'('};
for (const auto &arg : arguments_) {
if (arg) {
if (arg && !arg->IsPassedObject()) {
arg->AsFortran(o << separator);
separator = ',';
}

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

@ -990,7 +990,7 @@ std::optional<SpecificCall> IntrinsicInterface::Match(
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);
@ -999,16 +999,16 @@ std::optional<SpecificCall> IntrinsicInterface::Match(
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);
@ -1024,12 +1024,12 @@ std::optional<SpecificCall> IntrinsicInterface::Match(
}
}
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(
@ -1547,10 +1547,10 @@ SpecificCall IntrinsicProcTable::Implementation::HandleNull(
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)) {

20
flang/lib/semantics/check-call.cc
View File

@ -32,7 +32,7 @@ namespace Fortran::semantics {
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);
@ -600,13 +600,13 @@ static void RearrangeArguments(const characteristics::Procedure &proc,
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();
}
@ -620,9 +620,9 @@ static void RearrangeArguments(const characteristics::Procedure &proc,
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);
}
@ -633,9 +633,9 @@ static void RearrangeArguments(const characteristics::Procedure &proc,
}
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());
}
}
}
@ -645,10 +645,10 @@ static parser::Messages CheckExplicitInterface(
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) {

159
flang/lib/semantics/check-declarations.cc
View File

@ -57,6 +57,8 @@ private:
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 &);
@ -365,6 +367,8 @@ void CheckHelper::CheckProcEntity(
// 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);
}
}
@ -693,6 +697,109 @@ void CheckHelper::CheckVolatile(const Symbol &symbol, bool isAssociated,
}
}
// 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()};
@ -731,35 +838,37 @@ void CheckHelper::CheckProcBinding(
"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"_err_en_US);
}
} else {
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 type-bound procedure and its override must use the same PASS 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)) {
@ -771,6 +880,7 @@ void CheckHelper::CheckProcBinding(
"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) {
@ -792,5 +902,4 @@ void CheckHelper::Check(const Scope &scope) {
void CheckDeclarations(SemanticsContext &context) {
CheckHelper{context}.Check();
}
}

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

@ -31,8 +31,8 @@
#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>
@ -1522,16 +1522,35 @@ MaybeExpr ExpressionAnalyzer::Analyze(
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(
@ -1543,40 +1562,52 @@ 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,
@ -1618,7 +1649,7 @@ static bool CheckCompatibleArgument(bool isElemental,
return expr && IsProcedurePointer(*expr);
},
[&](const characteristics::AlternateReturn &) {
return actual.isAlternateReturn;
return actual.isAlternateReturn();
},
},
dummy.u);
@ -2457,7 +2488,7 @@ void ArgumentAnalyzer::Analyze(
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 {

177
flang/lib/semantics/resolve-names.cc
View File

@ -1392,9 +1392,7 @@ private:
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 &);
};
@ -6004,14 +6002,6 @@ void ResolveNamesVisitor::FinishSpecificationParts(const ProgramTree &node) {
// 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);
@ -6022,33 +6012,6 @@ void ResolveNamesVisitor::FinishSpecificationParts(const ProgramTree &node) {
}
}
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) {
@ -6063,140 +6026,22 @@ 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()) {

11
flang/lib/semantics/symbol.cc
View File

@ -669,6 +669,17 @@ Symbol &Symbol::InstantiateComponent(
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;
}

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

@ -182,17 +182,17 @@ private:
};
// 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

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

@ -93,7 +93,7 @@ struct TestCall {
std::size_t j{0};
for (auto &kw : keywords) {
if (!kw.empty()) {
args[j]->keyword = strings(kw);
args[j]->set_keyword(strings(kw));
}
++j;
}

4
flang/test/semantics/call11.f90
View File

@ -55,13 +55,13 @@ module m
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

2
flang/test/semantics/modfile08.f90
View File

@ -45,7 +45,7 @@ end
! 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)

2
flang/test/semantics/modfile10.f90
View File

@ -78,7 +78,7 @@ end module
! integer(4)::x
! contains
! final::c
! procedure,pass(x),non_overridable,private::d
! procedure,non_overridable,private::d
! end type
! type,abstract::t2a
! contains

2
flang/test/semantics/modfile14.f90
View File

@ -51,7 +51,7 @@ end
! contains
! procedure,nopass::s2
! procedure,nopass::s3
! procedure,pass(dtv)::r
! procedure::r
! generic::foo=>s2
! generic::read(formatted)=>r
! end type

2
flang/test/semantics/modfile15.f90
View File

@ -31,7 +31,7 @@ end module
!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