[flang-commits] [flang] 0d58834 - [flang] Check discrepancies between local & available global subprograms
Peter Klausler via flang-commits
flang-commits at lists.llvm.org
Fri Dec 2 11:11:40 PST 2022
Author: Peter Klausler
Date: 2022-12-02T11:11:31-08:00
New Revision: 0d588347000bd8245b8a1824758c6ed005ae5bce
URL: https://github.com/llvm/llvm-project/commit/0d588347000bd8245b8a1824758c6ed005ae5bce
DIFF: https://github.com/llvm/llvm-project/commit/0d588347000bd8245b8a1824758c6ed005ae5bce.diff
LOG: [flang] Check discrepancies between local & available global subprograms
When a scope declares the name and perhaps some characteristics of
an external subprogram using any of the many means that Fortran supplies
for doing such a thing, and that external subprogram's definition is
available, check the local declaration against the external definition.
In particular, if the global definition's interface cannot be called
by means of an implicit interface, ensure that references are via an
explicit and compatible interface.
Further, extend call site checking so that when a local declaration
exists for a known global symbol and the arguments are valid for that
local declaration, the arguments are checked against the global's
interface, just are is already done when no local declaration exists.
Differential Revision: https://reviews.llvm.org/D139042
Added:
flang/test/Semantics/global01.f90
flang/test/Semantics/local-vs-global.f90
Modified:
flang/include/flang/Semantics/symbol.h
flang/include/flang/Semantics/tools.h
flang/lib/Evaluate/tools.cpp
flang/lib/Semantics/check-call.cpp
flang/lib/Semantics/check-call.h
flang/lib/Semantics/check-declarations.cpp
flang/lib/Semantics/expression.cpp
flang/lib/Semantics/symbol.cpp
flang/lib/Semantics/tools.cpp
flang/test/Semantics/procinterface01.f90
flang/test/Semantics/resolve102.f90
flang/test/Semantics/resolve53.f90
flang/test/Semantics/resolve62.f90
Removed:
################################################################################
diff --git a/flang/include/flang/Semantics/symbol.h b/flang/include/flang/Semantics/symbol.h
index ad01b1235c53..bed41040a031 100644
--- a/flang/include/flang/Semantics/symbol.h
+++ b/flang/include/flang/Semantics/symbol.h
@@ -698,7 +698,7 @@ class Symbol {
Details details_;
Symbol() {} // only created in class Symbols
- const std::string GetDetailsName() const;
+ std::string GetDetailsName() const;
friend llvm::raw_ostream &operator<<(llvm::raw_ostream &, const Symbol &);
friend llvm::raw_ostream &DumpForUnparse(
llvm::raw_ostream &, const Symbol &, bool);
diff --git a/flang/include/flang/Semantics/tools.h b/flang/include/flang/Semantics/tools.h
index c1d58fa2c58f..7b2c4bf7aac5 100644
--- a/flang/include/flang/Semantics/tools.h
+++ b/flang/include/flang/Semantics/tools.h
@@ -53,6 +53,7 @@ const Symbol *FindInterface(const Symbol &);
const Symbol *FindSubprogram(const Symbol &);
const Symbol *FindFunctionResult(const Symbol &);
const Symbol *FindOverriddenBinding(const Symbol &);
+const Symbol *FindGlobal(const Symbol &);
const DeclTypeSpec *FindParentTypeSpec(const DerivedTypeSpec &);
const DeclTypeSpec *FindParentTypeSpec(const DeclTypeSpec &);
diff --git a/flang/lib/Evaluate/tools.cpp b/flang/lib/Evaluate/tools.cpp
index dce5dda275e2..1dd6414a4d30 100644
--- a/flang/lib/Evaluate/tools.cpp
+++ b/flang/lib/Evaluate/tools.cpp
@@ -1338,7 +1338,12 @@ bool IsFunction(const Scope &scope) {
bool IsProcedure(const Symbol &symbol) {
return common::visit(common::visitors{
- [](const SubprogramDetails &) { return true; },
+ [&symbol](const SubprogramDetails &) {
+ const Scope *scope{symbol.scope()};
+ // Main programs & BLOCK DATA are not procedures.
+ return !scope ||
+ scope->kind() == Scope::Kind::Subprogram;
+ },
[](const SubprogramNameDetails &) { return true; },
[](const ProcEntityDetails &) { return true; },
[](const GenericDetails &) { return true; },
diff --git a/flang/lib/Semantics/check-call.cpp b/flang/lib/Semantics/check-call.cpp
index 45b5c293cf18..37db60fab7fb 100644
--- a/flang/lib/Semantics/check-call.cpp
+++ b/flang/lib/Semantics/check-call.cpp
@@ -960,7 +960,7 @@ bool CheckInterfaceForGeneric(const characteristics::Procedure &proc,
.AnyFatalError();
}
-void CheckArguments(const characteristics::Procedure &proc,
+bool CheckArguments(const characteristics::Procedure &proc,
evaluate::ActualArguments &actuals, evaluate::FoldingContext &context,
const Scope &scope, bool treatingExternalAsImplicit,
const evaluate::SpecificIntrinsic *intrinsic) {
@@ -980,21 +980,25 @@ void CheckArguments(const characteristics::Procedure &proc,
if (auto *msgs{messages.messages()}) {
msgs->Annex(std::move(buffer));
}
- return; // don't pile on
+ return false; // don't pile on
}
}
if (explicitInterface) {
auto buffer{
CheckExplicitInterface(proc, actuals, context, scope, intrinsic)};
- if (treatingExternalAsImplicit && !buffer.empty()) {
- if (auto *msg{messages.Say(
- "If the procedure's interface were explicit, this reference would be in error"_warn_en_US)}) {
- buffer.AttachTo(*msg, parser::Severity::Because);
+ if (!buffer.empty()) {
+ if (treatingExternalAsImplicit && !buffer.empty()) {
+ if (auto *msg{messages.Say(
+ "If the procedure's interface were explicit, this reference would be in error"_warn_en_US)}) {
+ buffer.AttachTo(*msg, parser::Severity::Because);
+ }
}
- }
- if (auto *msgs{messages.messages()}) {
- msgs->Annex(std::move(buffer));
+ if (auto *msgs{messages.messages()}) {
+ msgs->Annex(std::move(buffer));
+ }
+ return false;
}
}
+ return true;
}
} // namespace Fortran::semantics
diff --git a/flang/lib/Semantics/check-call.h b/flang/lib/Semantics/check-call.h
index f3a26f59249d..cef77f39cc8c 100644
--- a/flang/lib/Semantics/check-call.h
+++ b/flang/lib/Semantics/check-call.h
@@ -30,8 +30,9 @@ class Scope;
// Argument treatingExternalAsImplicit should be true when the called procedure
// does not actually have an explicit interface at the call site, but
// its characteristics are known because it is a subroutine or function
-// defined at the top level in the same source file.
-void CheckArguments(const evaluate::characteristics::Procedure &,
+// defined at the top level in the same source file. Returns false if
+// messages were created, true if all is well.
+bool CheckArguments(const evaluate::characteristics::Procedure &,
evaluate::ActualArguments &, evaluate::FoldingContext &, const Scope &,
bool treatingExternalAsImplicit,
const evaluate::SpecificIntrinsic *intrinsic);
diff --git a/flang/lib/Semantics/check-declarations.cpp b/flang/lib/Semantics/check-declarations.cpp
index 85dbbb14e721..11367c4a61f2 100644
--- a/flang/lib/Semantics/check-declarations.cpp
+++ b/flang/lib/Semantics/check-declarations.cpp
@@ -65,6 +65,7 @@ class CheckHelper {
void CheckArraySpec(const Symbol &, const ArraySpec &);
void CheckProcEntity(const Symbol &, const ProcEntityDetails &);
void CheckSubprogram(const Symbol &, const SubprogramDetails &);
+ void CheckLocalVsGlobal(const Symbol &);
void CheckAssumedTypeEntity(const Symbol &, const ObjectEntityDetails &);
void CheckDerivedType(const Symbol &, const DerivedTypeDetails &);
bool CheckFinal(
@@ -103,12 +104,12 @@ class CheckHelper {
return subp && subp->isInterface();
}
template <typename... A>
- void SayWithDeclaration(const Symbol &symbol, A &&...x) {
- if (parser::Message * msg{messages_.Say(std::forward<A>(x)...)}) {
- if (messages_.at().begin() != symbol.name().begin()) {
- evaluate::AttachDeclaration(*msg, symbol);
- }
+ parser::Message *SayWithDeclaration(const Symbol &symbol, A &&...x) {
+ parser::Message *msg{messages_.Say(std::forward<A>(x)...)};
+ if (msg && messages_.at().begin() != symbol.name().begin()) {
+ evaluate::AttachDeclaration(*msg, symbol);
}
+ return msg;
}
bool IsResultOkToDiffer(const FunctionResult &);
void CheckBindC(const Symbol &);
@@ -199,7 +200,7 @@ void CheckHelper::Check(
const DeclTypeSpec &type, bool canHaveAssumedTypeParameters) {
if (type.category() == DeclTypeSpec::Character) {
Check(type.characterTypeSpec().length(), canHaveAssumedTypeParameters);
- } else if (const DerivedTypeSpec * derived{type.AsDerived()}) {
+ } else if (const DerivedTypeSpec *derived{type.AsDerived()}) {
for (auto &parm : derived->parameters()) {
Check(parm.second, canHaveAssumedTypeParameters);
}
@@ -346,7 +347,7 @@ void CheckHelper::Check(const Symbol &symbol) {
messages_.Say(
"An assumed-length CHARACTER(*) function cannot be PURE"_err_en_US);
}
- if (const Symbol * result{FindFunctionResult(symbol)}) {
+ if (const Symbol *result{FindFunctionResult(symbol)}) {
if (IsPointer(*result)) {
messages_.Say(
"An assumed-length CHARACTER(*) function cannot return a POINTER"_err_en_US);
@@ -449,7 +450,7 @@ void CheckHelper::CheckValue(
void CheckHelper::CheckAssumedTypeEntity( // C709
const Symbol &symbol, const ObjectEntityDetails &details) {
- if (const DeclTypeSpec * type{symbol.GetType()};
+ if (const DeclTypeSpec *type{symbol.GetType()};
type && type->category() == DeclTypeSpec::TypeStar) {
if (!IsDummy(symbol)) {
messages_.Say(
@@ -539,7 +540,7 @@ void CheckHelper::CheckObjectEntity(
symbol.name());
}
}
- if (const DeclTypeSpec * type{details.type()}) {
+ if (const DeclTypeSpec *type{details.type()}) {
if (IsBadCoarrayType(type->AsDerived())) { // C747 & C824
messages_.Say(
"Coarray '%s' may not have type TEAM_TYPE, C_PTR, or C_FUNPTR"_err_en_US,
@@ -567,11 +568,11 @@ void CheckHelper::CheckObjectEntity(
messages_.Say(
"non-POINTER dummy argument of pure function must be INTENT(IN) or VALUE"_err_en_US);
} else if (IsIntentOut(symbol)) {
- if (const DeclTypeSpec * type{details.type()}) {
+ if (const DeclTypeSpec *type{details.type()}) {
if (type && type->IsPolymorphic()) { // C1588
messages_.Say(
"An INTENT(OUT) dummy argument of a pure subroutine may not be polymorphic"_err_en_US);
- } else if (const DerivedTypeSpec * derived{type->AsDerived()}) {
+ } else if (const DerivedTypeSpec *derived{type->AsDerived()}) {
if (FindUltimateComponent(*derived, [](const Symbol &x) {
const DeclTypeSpec *type{x.GetType()};
return type && type->IsPolymorphic();
@@ -661,7 +662,7 @@ void CheckHelper::CheckObjectEntity(
"An initialized variable in BLOCK DATA must be in a COMMON block"_err_en_US);
}
}
- if (const DeclTypeSpec * type{details.type()}) { // C708
+ if (const DeclTypeSpec *type{details.type()}) { // C708
if (type->IsPolymorphic() &&
!(type->IsAssumedType() || IsAllocatableOrPointer(symbol) ||
IsDummy(symbol))) {
@@ -812,7 +813,9 @@ void CheckHelper::CheckProcEntity(
messages_.Say(
"An ELEMENTAL subprogram may not have a dummy procedure"_err_en_US);
}
- const Symbol *interface { details.interface().symbol() };
+ const Symbol *interface {
+ details.interface().symbol()
+ };
if (!symbol.attrs().test(Attr::INTRINSIC) &&
(IsElementalProcedure(symbol) ||
(interface && !interface->attrs().test(Attr::INTRINSIC) &&
@@ -844,7 +847,7 @@ void CheckHelper::CheckProcEntity(
}
if (symbol.attrs().test(Attr::POINTER)) {
CheckPointerInitialization(symbol);
- if (const Symbol * interface{details.interface().symbol()}) {
+ if (const Symbol *interface{details.interface().symbol()}) {
const Symbol &ultimate{interface->GetUltimate()};
if (ultimate.attrs().test(Attr::INTRINSIC)) {
if (const auto intrinsic{
@@ -867,6 +870,7 @@ void CheckHelper::CheckProcEntity(
"Procedure '%s' with SAVE attribute must also have POINTER attribute"_err_en_US,
symbol.name());
}
+ CheckLocalVsGlobal(symbol);
}
// When a module subprogram has the MODULE prefix the following must match
@@ -931,10 +935,10 @@ bool CheckHelper::IsResultOkToDiffer(const FunctionResult &result) {
void CheckHelper::CheckSubprogram(
const Symbol &symbol, const SubprogramDetails &details) {
- if (const Symbol * iface{FindSeparateModuleSubprogramInterface(&symbol)}) {
+ if (const Symbol *iface{FindSeparateModuleSubprogramInterface(&symbol)}) {
SubprogramMatchHelper{*this}.Check(symbol, *iface);
}
- if (const Scope * entryScope{details.entryScope()}) {
+ if (const Scope *entryScope{details.entryScope()}) {
// ENTRY 15.6.2.6, esp. C1571
std::optional<parser::MessageFixedText> error;
const Symbol *subprogram{entryScope->symbol()};
@@ -980,10 +984,56 @@ void CheckHelper::CheckSubprogram(
}
}
}
- if (details.isInterface() && !details.isDummy() && details.isFunction() &&
- IsAssumedLengthCharacter(details.result())) { // C721
- messages_.Say(details.result().name(),
- "A function interface may not declare an assumed-length CHARACTER(*) result"_err_en_US);
+ if (details.isInterface()) {
+ if (!details.isDummy() && details.isFunction() &&
+ IsAssumedLengthCharacter(details.result())) { // C721
+ messages_.Say(details.result().name(),
+ "A function interface may not declare an assumed-length CHARACTER(*) result"_err_en_US);
+ }
+ }
+ CheckLocalVsGlobal(symbol);
+}
+
+void CheckHelper::CheckLocalVsGlobal(const Symbol &symbol) {
+ if (IsProcedure(symbol) && IsExternal(symbol)) {
+ if (const Symbol *global{FindGlobal(symbol)}; global && global != &symbol) {
+ std::string interfaceName{symbol.name().ToString()};
+ if (const auto *bind{symbol.GetBindName()}) {
+ interfaceName = *bind;
+ }
+ std::string definitionName{global->name().ToString()};
+ if (const auto *bind{global->GetBindName()}) {
+ definitionName = *bind;
+ }
+ if (interfaceName == definitionName) {
+ parser::Message *msg{nullptr};
+ if (!IsProcedure(*global)) {
+ if (symbol.flags().test(Symbol::Flag::Function) ||
+ symbol.flags().test(Symbol::Flag::Subroutine)) {
+ msg = messages_.Say(
+ "The global entity '%s' corresponding to the local procedure '%s' is not a callable subprogram"_err_en_US,
+ global->name(), symbol.name());
+ }
+ } else if (auto chars{Characterize(symbol)}) {
+ if (auto globalChars{Characterize(*global)}) {
+ if (chars->HasExplicitInterface()) {
+ std::string whyNot;
+ if (!chars->IsCompatibleWith(*globalChars, &whyNot)) {
+ msg = messages_.Say(
+ "The global subprogram '%s' is not compatible with its local procedure declaration (%s)"_warn_en_US,
+ global->name(), whyNot);
+ }
+ } else if (!globalChars->CanBeCalledViaImplicitInterface()) {
+ msg = messages_.Say(
+ "The global subprogram '%s' may not be referenced via the implicit interface '%s'"_err_en_US,
+ global->name(), symbol.name());
+ }
+ }
+ }
+ evaluate::AttachDeclaration(msg, *global);
+ evaluate::AttachDeclaration(msg, symbol);
+ }
+ }
}
}
@@ -1004,7 +1054,7 @@ void CheckHelper::CheckDerivedType(
(derivedType.attrs().test(Attr::BIND_C) || details.sequence())) {
messages_.Say("An ABSTRACT derived type must be extensible"_err_en_US);
}
- if (const DeclTypeSpec * parent{FindParentTypeSpec(derivedType)}) {
+ if (const DeclTypeSpec *parent{FindParentTypeSpec(derivedType)}) {
const DerivedTypeSpec *parentDerived{parent->AsDerived()};
if (!IsExtensibleType(parentDerived)) { // C705
messages_.Say("The parent type is not extensible"_err_en_US);
@@ -1091,7 +1141,7 @@ bool CheckHelper::CheckFinal(
const Symbol *errSym{&subroutine};
if (const auto *details{subroutine.detailsIf<SubprogramDetails>()}) {
if (!details->dummyArgs().empty()) {
- if (const Symbol * argSym{details->dummyArgs()[0]}) {
+ if (const Symbol *argSym{details->dummyArgs()[0]}) {
errSym = argSym;
}
}
@@ -1230,7 +1280,7 @@ void CheckHelper::CheckSpecificsAreDistinguishable(
}
DistinguishabilityHelper helper{context_};
for (const Symbol &specific : details.specificProcs()) {
- if (const Procedure * procedure{Characterize(specific)}) {
+ if (const Procedure *procedure{Characterize(specific)}) {
if (procedure->HasExplicitInterface()) {
helper.Add(generic, kind, specific, *procedure);
} else {
@@ -1573,7 +1623,9 @@ void CheckHelper::CheckPassArg(
return;
}
const auto &name{proc.name()};
- const Symbol *interface { interface0 ? FindInterface(*interface0) : nullptr };
+ const Symbol *interface {
+ interface0 ? FindInterface(*interface0) : nullptr
+ };
if (!interface) {
messages_.Say(name,
"Procedure component '%s' must have NOPASS attribute or explicit interface"_err_en_US,
@@ -1683,7 +1735,7 @@ void CheckHelper::CheckProcBinding(
const Scope &dtScope{symbol.owner()};
CHECK(dtScope.kind() == Scope::Kind::DerivedType);
if (symbol.attrs().test(Attr::DEFERRED)) {
- if (const Symbol * dtSymbol{dtScope.symbol()}) {
+ if (const Symbol *dtSymbol{dtScope.symbol()}) {
if (!dtSymbol->attrs().test(Attr::ABSTRACT)) { // C733
SayWithDeclaration(*dtSymbol,
"Procedure bound to non-ABSTRACT derived type '%s' may not be DEFERRED"_err_en_US,
@@ -1703,7 +1755,7 @@ void CheckHelper::CheckProcBinding(
"Intrinsic procedure '%s' is not a specific intrinsic permitted for use in the definition of binding '%s'"_err_en_US,
binding.symbol().name(), symbol.name());
}
- if (const Symbol * overridden{FindOverriddenBinding(symbol)}) {
+ if (const Symbol *overridden{FindOverriddenBinding(symbol)}) {
if (overridden->attrs().test(Attr::NON_OVERRIDABLE)) {
SayWithDeclaration(*overridden,
"Override of NON_OVERRIDABLE '%s' is not permitted"_err_en_US,
@@ -1768,7 +1820,7 @@ void CheckHelper::CheckProcBinding(
void CheckHelper::Check(const Scope &scope) {
scope_ = &scope;
common::Restorer<const Symbol *> restorer{innermostSymbol_, innermostSymbol_};
- if (const Symbol * symbol{scope.symbol()}) {
+ if (const Symbol *symbol{scope.symbol()}) {
innermostSymbol_ = symbol;
}
if (scope.IsParameterizedDerivedTypeInstantiation()) {
@@ -1877,7 +1929,7 @@ void CheckHelper::CheckGenericOps(const Scope &scope) {
// Not a generic; ensure characteristics are defined if a function.
auto restorer{messages_.SetLocation(generic.name())};
if (IsFunction(generic) && !context_.HasError(generic)) {
- if (const Symbol * result{FindFunctionResult(generic)};
+ if (const Symbol *result{FindFunctionResult(generic)};
result && !context_.HasError(*result)) {
Characterize(generic);
}
@@ -1893,7 +1945,7 @@ void CheckHelper::CheckGenericOps(const Scope &scope) {
for (std::size_t i{0}; i < specifics.size(); ++i) {
const Symbol &specific{*specifics[i]};
auto restorer{messages_.SetLocation(bindingNames[i])};
- if (const Procedure * proc{Characterize(specific)}) {
+ if (const Procedure *proc{Characterize(specific)}) {
if (kind.IsAssignment()) {
if (!CheckDefinedAssignment(specific, *proc)) {
continue;
@@ -1912,7 +1964,7 @@ void CheckHelper::CheckGenericOps(const Scope &scope) {
addSpecifics(symbol);
const Symbol &ultimate{symbol.GetUltimate()};
if (ultimate.has<DerivedTypeDetails>()) {
- if (const Scope * typeScope{ultimate.scope()}) {
+ if (const Scope *typeScope{ultimate.scope()}) {
for (const auto &pair2 : *typeScope) {
addSpecifics(*pair2.second);
}
@@ -1944,7 +1996,7 @@ void CheckHelper::CheckBindC(const Symbol &symbol) {
"A variable with BIND(C) attribute may only appear in the specification part of a module"_err_en_US);
context_.SetError(symbol);
}
- if (const std::string * name{DefinesBindCName(symbol)}) {
+ if (const std::string *name{DefinesBindCName(symbol)}) {
auto pair{bindC_.emplace(*name, symbol)};
if (!pair.second) {
const Symbol &other{*pair.first->second};
@@ -2056,8 +2108,8 @@ void CheckHelper::CheckAlreadySeenDefinedIo(const DerivedTypeSpec &derivedType,
void CheckHelper::CheckDioDummyIsDerived(const Symbol &subp, const Symbol &arg,
GenericKind::DefinedIo ioKind, const Symbol &generic) {
- if (const DeclTypeSpec * type{arg.GetType()}) {
- if (const DerivedTypeSpec * derivedType{type->AsDerived()}) {
+ if (const DeclTypeSpec *type{arg.GetType()}) {
+ if (const DerivedTypeSpec *derivedType{type->AsDerived()}) {
CheckAlreadySeenDefinedIo(*derivedType, ioKind, subp, generic);
bool isPolymorphic{type->IsPolymorphic()};
if (isPolymorphic != IsExtensibleType(derivedType)) {
@@ -2077,7 +2129,7 @@ void CheckHelper::CheckDioDummyIsDerived(const Symbol &subp, const Symbol &arg,
void CheckHelper::CheckDioDummyIsDefaultInteger(
const Symbol &subp, const Symbol &arg) {
- if (const DeclTypeSpec * type{arg.GetType()};
+ if (const DeclTypeSpec *type{arg.GetType()};
type && type->IsNumeric(TypeCategory::Integer)) {
if (const auto kind{evaluate::ToInt64(type->numericTypeSpec().kind())};
kind && *kind == context_.GetDefaultKind(TypeCategory::Integer)) {
diff --git a/flang/lib/Semantics/expression.cpp b/flang/lib/Semantics/expression.cpp
index 95e4a7446516..9e53d3086718 100644
--- a/flang/lib/Semantics/expression.cpp
+++ b/flang/lib/Semantics/expression.cpp
@@ -64,12 +64,12 @@ std::optional<Expr<SubscriptInteger>> DynamicTypeWithLength::LEN() const {
static std::optional<DynamicTypeWithLength> AnalyzeTypeSpec(
const std::optional<parser::TypeSpec> &spec) {
if (spec) {
- if (const semantics::DeclTypeSpec * typeSpec{spec->declTypeSpec}) {
+ if (const semantics::DeclTypeSpec *typeSpec{spec->declTypeSpec}) {
// Name resolution sets TypeSpec::declTypeSpec only when it's valid
// (viz., an intrinsic type with valid known kind or a non-polymorphic
// & non-ABSTRACT derived type).
- if (const semantics::IntrinsicTypeSpec *
- intrinsic{typeSpec->AsIntrinsic()}) {
+ if (const semantics::IntrinsicTypeSpec *intrinsic{
+ typeSpec->AsIntrinsic()}) {
TypeCategory category{intrinsic->category()};
if (auto optKind{ToInt64(intrinsic->kind())}) {
int kind{static_cast<int>(*optKind)};
@@ -84,8 +84,8 @@ static std::optional<DynamicTypeWithLength> AnalyzeTypeSpec(
return DynamicTypeWithLength{DynamicType{category, kind}};
}
}
- } else if (const semantics::DerivedTypeSpec *
- derived{typeSpec->AsDerived()}) {
+ } else if (const semantics::DerivedTypeSpec *derived{
+ typeSpec->AsDerived()}) {
return DynamicTypeWithLength{DynamicType{*derived}};
}
}
@@ -257,7 +257,7 @@ MaybeExpr ExpressionAnalyzer::CompleteSubscripts(ArrayRef &&ref) {
} else if (const auto *object{
symbol.detailsIf<semantics::ObjectEntityDetails>()}) {
// C928 & C1002
- if (Triplet * last{std::get_if<Triplet>(&ref.subscript().back().u)}) {
+ if (Triplet *last{std::get_if<Triplet>(&ref.subscript().back().u)}) {
if (!last->upper() && object->IsAssumedSize()) {
Say("Assumed-size array '%s' must have explicit final "
"subscript upper bound value"_err_en_US,
@@ -379,10 +379,10 @@ static std::optional<parser::Substring> FixMisparsedSubstringDataRef(
if (auto *triplet{std::get_if<parser::SubscriptTriplet>(
&arrElement.subscripts.front().u)}) {
if (!std::get<2 /*stride*/>(triplet->t).has_value()) {
- if (const Symbol *
- symbol{parser::GetLastName(arrElement.base).symbol}) {
+ if (const Symbol *symbol{
+ parser::GetLastName(arrElement.base).symbol}) {
const Symbol &ultimate{symbol->GetUltimate()};
- if (const semantics::DeclTypeSpec * type{ultimate.GetType()}) {
+ if (const semantics::DeclTypeSpec *type{ultimate.GetType()}) {
if (!ultimate.IsObjectArray() &&
type->category() == semantics::DeclTypeSpec::Character) {
// The ambiguous S(j:k) was parsed as an array section
@@ -805,8 +805,7 @@ MaybeExpr ExpressionAnalyzer::Analyze(const parser::Name &n) {
ultimate, AsGenericExpr(TypeParamInquiry{std::nullopt, ultimate})));
} else {
if (n.symbol->attrs().test(semantics::Attr::VOLATILE)) {
- if (const semantics::Scope *
- pure{semantics::FindPureProcedureContaining(
+ if (const semantics::Scope *pure{semantics::FindPureProcedureContaining(
context_.FindScope(n.source))}) {
SayAt(n,
"VOLATILE variable '%s' may not be referenced in pure subprogram '%s'"_err_en_US,
@@ -1068,7 +1067,7 @@ MaybeExpr ExpressionAnalyzer::Analyze(const parser::ArrayElement &ae) {
if (ae.subscripts.empty()) {
// will be converted to function call later or error reported
} else if (baseExpr->Rank() == 0) {
- if (const Symbol * symbol{GetLastSymbol(*baseExpr)}) {
+ if (const Symbol *symbol{GetLastSymbol(*baseExpr)}) {
if (!context_.HasError(symbol)) {
if (inDataStmtConstant_) {
// Better error for NULL(X) with a MOLD= argument
@@ -1120,14 +1119,13 @@ std::optional<Component> ExpressionAnalyzer::CreateComponent(
if (&component.owner() == &scope) {
return Component{std::move(base), component};
}
- if (const Symbol * typeSymbol{scope.GetSymbol()}) {
- if (const Symbol *
- parentComponent{typeSymbol->GetParentComponent(&scope)}) {
+ if (const Symbol *typeSymbol{scope.GetSymbol()}) {
+ if (const Symbol *parentComponent{typeSymbol->GetParentComponent(&scope)}) {
if (const auto *object{
parentComponent->detailsIf<semantics::ObjectEntityDetails>()}) {
if (const auto *parentType{object->type()}) {
- if (const semantics::Scope *
- parentScope{parentType->derivedTypeSpec().scope()}) {
+ if (const semantics::Scope *parentScope{
+ parentType->derivedTypeSpec().scope()}) {
return CreateComponent(
DataRef{Component{std::move(base), *parentComponent}},
component, *parentScope);
@@ -1227,7 +1225,7 @@ MaybeExpr ExpressionAnalyzer::Analyze(const parser::CoindexedNamedObject &x) {
if (auto *aRef{std::get_if<ArrayRef>(&dataRef->u)}) {
subscripts = std::move(aRef->subscript());
reversed.push_back(aRef->GetLastSymbol());
- if (Component * component{aRef->base().UnwrapComponent()}) {
+ if (Component *component{aRef->base().UnwrapComponent()}) {
dataRef = &component->base();
} else {
dataRef = nullptr;
@@ -1669,7 +1667,7 @@ MaybeExpr ExpressionAnalyzer::Analyze(
auto &parsedType{std::get<parser::DerivedTypeSpec>(structure.t)};
parser::Name structureType{std::get<parser::Name>(parsedType.t)};
parser::CharBlock &typeName{structureType.source};
- if (semantics::Symbol * typeSymbol{structureType.symbol}) {
+ if (semantics::Symbol *typeSymbol{structureType.symbol}) {
if (typeSymbol->has<semantics::DerivedTypeDetails>()) {
semantics::DerivedTypeSpec dtSpec{typeName, typeSymbol->GetUltimate()};
if (!CheckIsValidForwardReference(dtSpec)) {
@@ -1814,9 +1812,9 @@ MaybeExpr ExpressionAnalyzer::Analyze(
} else if (symbol->has<semantics::ObjectEntityDetails>()) {
// C1594(4)
if (const auto *pureProc{FindPureProcedureContaining(innermost)}) {
- if (const Symbol * pointer{FindPointerComponent(*symbol)}) {
- if (const Symbol *
- object{FindExternallyVisibleObject(*value, *pureProc)}) {
+ if (const Symbol *pointer{FindPointerComponent(*symbol)}) {
+ if (const Symbol *object{
+ FindExternallyVisibleObject(*value, *pureProc)}) {
if (auto *msg{Say(expr.source,
"Externally visible object '%s' may not be "
"associated with pointer component '%s' in a "
@@ -1954,7 +1952,9 @@ static std::optional<parser::CharBlock> GetPassName(
static int GetPassIndex(const Symbol &proc) {
CHECK(!proc.attrs().test(semantics::Attr::NOPASS));
std::optional<parser::CharBlock> passName{GetPassName(proc)};
- const auto *interface { semantics::FindInterface(proc) };
+ const auto *interface {
+ semantics::FindInterface(proc)
+ };
if (!passName || !interface) {
return 0; // first argument is passed-object
}
@@ -2019,7 +2019,7 @@ auto ExpressionAnalyzer::AnalyzeProcedureComponentRef(
bool isSubroutine) -> std::optional<CalleeAndArguments> {
const parser::StructureComponent &sc{pcr.v.thing};
if (MaybeExpr base{Analyze(sc.base)}) {
- if (const Symbol * sym{sc.component.symbol}) {
+ if (const Symbol *sym{sc.component.symbol}) {
if (context_.HasError(sym)) {
return std::nullopt;
}
@@ -2053,8 +2053,8 @@ auto ExpressionAnalyzer::AnalyzeProcedureComponentRef(
if (dataRef && !CheckDataRef(*dataRef)) {
return std::nullopt;
}
- if (const Symbol *
- resolution{GetBindingResolution(dtExpr->GetType(), *sym)}) {
+ if (const Symbol *resolution{
+ GetBindingResolution(dtExpr->GetType(), *sym)}) {
AddPassArg(arguments, std::move(*dtExpr), *sym, false);
return CalleeAndArguments{
ProcedureDesignator{*resolution}, std::move(arguments)};
@@ -2231,7 +2231,7 @@ std::pair<const Symbol *, bool> ExpressionAnalyzer::ResolveGeneric(
}
// Check parent derived type
if (const auto *parentScope{symbol.owner().GetDerivedTypeParent()}) {
- if (const Symbol * extended{parentScope->FindComponent(symbol.name())}) {
+ if (const Symbol *extended{parentScope->FindComponent(symbol.name())}) {
auto pair{ResolveGeneric(
*extended, actuals, adjustActuals, isSubroutine, false)};
if (pair.first) {
@@ -2247,7 +2247,7 @@ std::pair<const Symbol *, bool> ExpressionAnalyzer::ResolveGeneric(
// See 15.5.5.2 for details.
if (!symbol.owner().IsGlobal() && !symbol.owner().IsDerivedType()) {
for (const std::string &n : GetAllNames(context_, symbol.name())) {
- if (const Symbol * outer{symbol.owner().parent().FindSymbol(n)}) {
+ if (const Symbol *outer{symbol.owner().parent().FindSymbol(n)}) {
auto pair{ResolveGeneric(*outer, actuals, adjustActuals, isSubroutine,
mightBeStructureConstructor)};
if (pair.first) {
@@ -2451,7 +2451,7 @@ template <typename A> static const Symbol *AssumedTypeDummy(const A &x) {
}
template <>
const Symbol *AssumedTypeDummy<parser::Name>(const parser::Name &name) {
- if (const Symbol * symbol{name.symbol}) {
+ if (const Symbol *symbol{name.symbol}) {
if (const auto *type{symbol->GetType()}) {
if (type->category() == semantics::DeclTypeSpec::TypeStar) {
return symbol;
@@ -2670,21 +2670,22 @@ static bool IsExternalCalledImplicitly(
std::optional<characteristics::Procedure> ExpressionAnalyzer::CheckCall(
parser::CharBlock callSite, const ProcedureDesignator &proc,
ActualArguments &arguments) {
+ bool treatExternalAsImplicit{IsExternalCalledImplicitly(callSite, proc)};
+ const Symbol *procSymbol{proc.GetSymbol()};
auto chars{characteristics::Procedure::Characterize(
proc, context_.foldingContext())};
+ bool ok{true};
if (chars) {
- bool treatExternalAsImplicit{IsExternalCalledImplicitly(callSite, proc)};
if (treatExternalAsImplicit && !chars->CanBeCalledViaImplicitInterface()) {
Say(callSite,
"References to the procedure '%s' require an explicit interface"_err_en_US,
- DEREF(proc.GetSymbol()).name());
+ DEREF(procSymbol).name());
}
// Checks for ASSOCIATED() are done in intrinsic table processing
const SpecificIntrinsic *specificIntrinsic{proc.GetSpecificIntrinsic()};
bool procIsAssociated{
specificIntrinsic && specificIntrinsic->name == "associated"};
if (!procIsAssociated) {
- const Symbol *procSymbol{proc.GetSymbol()};
bool procIsDummy{procSymbol && IsDummy(*procSymbol)};
if (chars->functionResult &&
chars->functionResult->IsAssumedLengthCharacter() &&
@@ -2692,12 +2693,11 @@ std::optional<characteristics::Procedure> ExpressionAnalyzer::CheckCall(
Say(callSite,
"Assumed-length character function must be defined with a length to be called"_err_en_US);
}
- semantics::CheckArguments(*chars, arguments, GetFoldingContext(),
+ ok &= semantics::CheckArguments(*chars, arguments, GetFoldingContext(),
context_.FindScope(callSite), treatExternalAsImplicit,
specificIntrinsic);
if (procSymbol && !IsPureProcedure(*procSymbol)) {
- if (const semantics::Scope *
- pure{semantics::FindPureProcedureContaining(
+ if (const semantics::Scope *pure{semantics::FindPureProcedureContaining(
context_.FindScope(callSite))}) {
Say(callSite,
"Procedure '%s' referenced in pure subprogram '%s' must be pure too"_err_en_US,
@@ -2706,6 +2706,19 @@ std::optional<characteristics::Procedure> ExpressionAnalyzer::CheckCall(
}
}
}
+ if (ok && !treatExternalAsImplicit && procSymbol &&
+ !(chars && chars->HasExplicitInterface())) {
+ if (const Symbol *global{FindGlobal(*procSymbol)};
+ global && global != procSymbol && IsProcedure(*global)) {
+ // Check a known global definition behind a local interface
+ if (auto globalChars{characteristics::Procedure::Characterize(
+ *global, context_.foldingContext())}) {
+ semantics::CheckArguments(*globalChars, arguments, GetFoldingContext(),
+ context_.FindScope(callSite), true,
+ nullptr /*not specific intrinsic*/);
+ }
+ }
+ }
return chars;
}
@@ -2713,8 +2726,8 @@ std::optional<characteristics::Procedure> ExpressionAnalyzer::CheckCall(
MaybeExpr ExpressionAnalyzer::Analyze(const parser::Expr::Parentheses &x) {
if (MaybeExpr operand{Analyze(x.v.value())}) {
- if (const semantics::Symbol * symbol{GetLastSymbol(*operand)}) {
- if (const semantics::Symbol * result{FindFunctionResult(*symbol)}) {
+ 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
@@ -2782,7 +2795,7 @@ MaybeExpr ExpressionAnalyzer::Analyze(const parser::Expr::PercentLoc &x) {
// intrinsic function.
// Use the actual source for the name of the call for error reporting.
std::optional<ActualArgument> arg;
- if (const Symbol * assumedTypeDummy{AssumedTypeDummy(x.v.value())}) {
+ if (const Symbol *assumedTypeDummy{AssumedTypeDummy(x.v.value())}) {
arg = ActualArgument{ActualArgument::AssumedType{*assumedTypeDummy}};
} else if (MaybeExpr argExpr{Analyze(x.v.value())}) {
arg = ActualArgument{std::move(*argExpr)};
@@ -3018,8 +3031,7 @@ static bool CheckFuncRefToArrayElement(semantics::SemanticsContext &context,
if (!name->symbol) {
return false;
} else if (name->symbol->Rank() == 0) {
- if (const Symbol *
- function{
+ if (const Symbol *function{
semantics::IsFunctionResultWithSameNameAsFunction(*name->symbol)}) {
auto &msg{context.Say(funcRef.v.source,
"Recursive call to '%s' requires a distinct RESULT in its declaration"_err_en_US,
@@ -3055,8 +3067,7 @@ static void FixMisparsedFunctionReference(
std::get_if<common::Indirection<parser::FunctionReference>>(&u)}) {
parser::FunctionReference &funcRef{func->value()};
auto &proc{std::get<parser::ProcedureDesignator>(funcRef.v.t)};
- if (Symbol *
- origSymbol{
+ if (Symbol *origSymbol{
common::visit(common::visitors{
[&](parser::Name &name) { return name.symbol; },
[&](parser::ProcComponentRef &pcr) {
@@ -3343,7 +3354,7 @@ MaybeExpr ExpressionAnalyzer::MakeFunctionRef(parser::CharBlock callSite,
return Expr<SomeType>{NullPointer{}};
}
}
- if (const Symbol * symbol{proc.GetSymbol()}) {
+ if (const Symbol *symbol{proc.GetSymbol()}) {
if (!ResolveForward(*symbol)) {
return std::nullopt;
}
@@ -3578,7 +3589,7 @@ MaybeExpr ArgumentAnalyzer::TryDefinedOp(const char *opr,
isUserOp ? std::string{opr} : "operator("s + opr + ')'};
parser::CharBlock oprName{oprNameString};
const auto &scope{context_.context().FindScope(source_)};
- if (Symbol * symbol{scope.FindSymbol(oprName)}) {
+ if (Symbol *symbol{scope.FindSymbol(oprName)}) {
*definedOpSymbolPtr = symbol;
parser::Name name{symbol->name(), symbol};
if (auto result{context_.AnalyzeDefinedOp(name, GetActuals())}) {
@@ -3586,8 +3597,8 @@ MaybeExpr ArgumentAnalyzer::TryDefinedOp(const char *opr,
}
}
for (std::size_t passIndex{0}; passIndex < actuals_.size(); ++passIndex) {
- if (const Symbol *
- symbol{FindBoundOp(oprName, passIndex, *definedOpSymbolPtr)}) {
+ if (const Symbol *symbol{
+ FindBoundOp(oprName, passIndex, *definedOpSymbolPtr)}) {
if (MaybeExpr result{TryBoundOp(*symbol, passIndex)}) {
return result;
}
@@ -3699,7 +3710,7 @@ std::optional<ProcedureRef> ArgumentAnalyzer::GetDefinedAssignmentProc() {
parser::CharBlock oprName{oprNameString};
const Symbol *proc{nullptr};
const auto &scope{context_.context().FindScope(source_)};
- if (const Symbol * symbol{scope.FindSymbol(oprName)}) {
+ if (const Symbol *symbol{scope.FindSymbol(oprName)}) {
ExpressionAnalyzer::AdjustActuals noAdjustment;
auto pair{context_.ResolveGeneric(*symbol, actuals_, noAdjustment, true)};
if (pair.first) {
@@ -3711,9 +3722,9 @@ std::optional<ProcedureRef> ArgumentAnalyzer::GetDefinedAssignmentProc() {
int passedObjectIndex{-1};
const Symbol *definedOpSymbol{nullptr};
for (std::size_t i{0}; i < actuals_.size(); ++i) {
- if (const Symbol * specific{FindBoundOp(oprName, i, definedOpSymbol)}) {
- if (const Symbol *
- resolution{GetBindingResolution(GetType(i), *specific)}) {
+ if (const Symbol *specific{FindBoundOp(oprName, i, definedOpSymbol)}) {
+ if (const Symbol *resolution{
+ GetBindingResolution(GetType(i), *specific)}) {
proc = resolution;
} else {
proc = specific;
@@ -3737,7 +3748,7 @@ void ArgumentAnalyzer::Dump(llvm::raw_ostream &os) {
for (const auto &actual : actuals_) {
if (!actual.has_value()) {
os << "- error\n";
- } else if (const Symbol * symbol{actual->GetAssumedTypeDummy()}) {
+ } else if (const Symbol *symbol{actual->GetAssumedTypeDummy()}) {
os << "- assumed type: " << symbol->name().ToString() << '\n';
} else if (const Expr<SomeType> *expr{actual->UnwrapExpr()}) {
expr->AsFortran(os << "- expr: ") << '\n';
@@ -3750,7 +3761,7 @@ void ArgumentAnalyzer::Dump(llvm::raw_ostream &os) {
std::optional<ActualArgument> ArgumentAnalyzer::AnalyzeExpr(
const parser::Expr &expr) {
source_.ExtendToCover(expr.source);
- if (const Symbol * assumedTypeDummy{AssumedTypeDummy(expr)}) {
+ if (const Symbol *assumedTypeDummy{AssumedTypeDummy(expr)}) {
expr.typedExpr.Reset(new GenericExprWrapper{}, GenericExprWrapper::Deleter);
if (isProcedureCall_) {
ActualArgument arg{ActualArgument::AssumedType{*assumedTypeDummy}};
diff --git a/flang/lib/Semantics/symbol.cpp b/flang/lib/Semantics/symbol.cpp
index 67acf24cd254..9c9fa37f7273 100644
--- a/flang/lib/Semantics/symbol.cpp
+++ b/flang/lib/Semantics/symbol.cpp
@@ -253,9 +253,7 @@ std::string DetailsToString(const Details &details) {
details);
}
-const std::string Symbol::GetDetailsName() const {
- return DetailsToString(details_);
-}
+std::string Symbol::GetDetailsName() const { return DetailsToString(details_); }
void Symbol::set_details(Details &&details) {
CHECK(CanReplaceDetails(details));
diff --git a/flang/lib/Semantics/tools.cpp b/flang/lib/Semantics/tools.cpp
index 7484993d2393..dbe50dfd6f2c 100644
--- a/flang/lib/Semantics/tools.cpp
+++ b/flang/lib/Semantics/tools.cpp
@@ -520,6 +520,36 @@ const Symbol *FindOverriddenBinding(const Symbol &symbol) {
return nullptr;
}
+const Symbol *FindGlobal(const Symbol &original) {
+ const Symbol &ultimate{original.GetUltimate()};
+ if (ultimate.owner().IsGlobal()) {
+ return &ultimate;
+ }
+ bool isLocal{false};
+ if (IsDummy(ultimate)) {
+ } else if (IsPointer(ultimate)) {
+ } else if (ultimate.has<ProcEntityDetails>()) {
+ isLocal = IsExternal(ultimate);
+ } else if (const auto *subp{ultimate.detailsIf<SubprogramDetails>()}) {
+ isLocal = subp->isInterface();
+ }
+ if (isLocal) {
+ const std::string *bind{ultimate.GetBindName()};
+ if (!bind || ultimate.name() == *bind) {
+ const Scope &globalScope{ultimate.owner().context().globalScope()};
+ if (auto iter{globalScope.find(ultimate.name())};
+ iter != globalScope.end()) {
+ const Symbol &global{*iter->second};
+ const std::string *globalBind{global.GetBindName()};
+ if (!globalBind || global.name() == *globalBind) {
+ return &global;
+ }
+ }
+ }
+ }
+ return nullptr;
+}
+
const DeclTypeSpec *FindParentTypeSpec(const DerivedTypeSpec &derived) {
return FindParentTypeSpec(derived.typeSymbol());
}
diff --git a/flang/test/Semantics/global01.f90 b/flang/test/Semantics/global01.f90
new file mode 100644
index 000000000000..5dfa6f6dea60
--- /dev/null
+++ b/flang/test/Semantics/global01.f90
@@ -0,0 +1,45 @@
+! RUN: %python %S/test_errors.py %s %flang_fc1 -Werror
+! Catch discrepancies between a local interface and a global definition
+
+subroutine global1(x)
+ integer, intent(in) :: x
+end subroutine
+
+subroutine global2(x) bind(c,name="xyz")
+ integer, intent(in) :: x
+end subroutine
+
+subroutine global3(x)
+ integer, intent(in) :: x
+end subroutine
+
+pure subroutine global4(x)
+ integer, intent(in) :: x
+end subroutine
+
+subroutine global5(x)
+ integer, intent(in) :: x
+end subroutine
+
+program test
+ interface
+ !WARNING: The global subprogram 'global1' is not compatible with its local procedure declaration (incompatible dummy argument #1: incompatible dummy data object types: REAL(4) vs INTEGER(4))
+ subroutine global1(x)
+ real, intent(in) :: x
+ end subroutine
+ subroutine global2(x)
+ real, intent(in) :: x
+ end subroutine
+ subroutine global3(x) bind(c,name="abc")
+ real, intent(in) :: x
+ end subroutine
+ subroutine global4(x) ! not PURE, but that's ok
+ integer, intent(in) :: x
+ end subroutine
+ !WARNING: The global subprogram 'global5' is not compatible with its local procedure declaration (incompatible procedure attributes: Pure)
+ pure subroutine global5(x)
+ integer, intent(in) :: x
+ end subroutine
+ end interface
+end
+
diff --git a/flang/test/Semantics/local-vs-global.f90 b/flang/test/Semantics/local-vs-global.f90
new file mode 100644
index 000000000000..d903e431f2ae
--- /dev/null
+++ b/flang/test/Semantics/local-vs-global.f90
@@ -0,0 +1,164 @@
+! RUN: %python %S/test_errors.py %s %flang_fc1
+
+module module_before_1
+end
+
+module module_before_2
+end
+
+block data block_data_before_1
+end
+
+block data block_data_before_2
+end
+
+subroutine explicit_before_1(a)
+ real, optional :: a
+end
+
+subroutine explicit_before_2(a)
+ real, optional :: a
+end
+
+subroutine implicit_before_1(a)
+ real :: a
+end
+
+subroutine implicit_before_2(a)
+ real :: a
+end
+
+function explicit_func_before_1(a)
+ real, optional :: a
+end
+
+function explicit_func_before_2(a)
+ real, optional :: a
+end
+
+function implicit_func_before_1(a)
+ real :: a
+end
+
+function implicit_func_before_2(a)
+ real :: a
+end
+
+program test
+ external justfine ! OK to name a BLOCK DATA if not called
+ !ERROR: The global entity 'module_before_1' corresponding to the local procedure 'module_before_1' is not a callable subprogram
+ external module_before_1
+ !ERROR: The global entity 'block_data_before_1' corresponding to the local procedure 'block_data_before_1' is not a callable subprogram
+ external block_data_before_1
+ !ERROR: The global subprogram 'explicit_before_1' may not be referenced via the implicit interface 'explicit_before_1'
+ external explicit_before_1
+ external implicit_before_1
+ !ERROR: The global subprogram 'explicit_func_before_1' may not be referenced via the implicit interface 'explicit_func_before_1'
+ external explicit_func_before_1
+ external implicit_func_before_1
+ !ERROR: The global entity 'module_after_1' corresponding to the local procedure 'module_after_1' is not a callable subprogram
+ external module_after_1
+ !ERROR: The global entity 'block_data_after_1' corresponding to the local procedure 'block_data_after_1' is not a callable subprogram
+ external block_data_after_1
+ !ERROR: The global subprogram 'explicit_after_1' may not be referenced via the implicit interface 'explicit_after_1'
+ external explicit_after_1
+ external implicit_after_1
+ !ERROR: The global subprogram 'explicit_func_after_1' may not be referenced via the implicit interface 'explicit_func_after_1'
+ external explicit_func_after_1
+ external implicit_func_after_1
+ call module_before_1
+ !ERROR: 'module_before_2' is not a callable procedure
+ call module_before_2
+ call block_data_before_1
+ !ERROR: 'block_data_before_2' is not a callable procedure
+ call block_data_before_2
+ call explicit_before_1(1.)
+ !ERROR: References to the procedure 'explicit_before_2' require an explicit interface
+ call explicit_before_2(1.)
+ !WARNING: If the procedure's interface were explicit, this reference would be in error
+ !BECAUSE: Dummy argument 'a=' (#1) is not OPTIONAL and is not associated with an actual argument in this procedure reference
+ call implicit_before_1
+ !WARNING: If the procedure's interface were explicit, this reference would be in error
+ !BECAUSE: Dummy argument 'a=' (#1) is not OPTIONAL and is not associated with an actual argument in this procedure reference
+ call implicit_before_2
+ print *, explicit_func_before_1(1.)
+ !ERROR: References to the procedure 'explicit_func_before_2' require an explicit interface
+ print *, explicit_func_before_2(1.)
+ !WARNING: If the procedure's interface were explicit, this reference would be in error
+ !BECAUSE: Dummy argument 'a=' (#1) is not OPTIONAL and is not associated with an actual argument in this procedure reference
+ print *, implicit_func_before_1()
+ !WARNING: If the procedure's interface were explicit, this reference would be in error
+ !BECAUSE: Dummy argument 'a=' (#1) is not OPTIONAL and is not associated with an actual argument in this procedure reference
+ print *, implicit_func_before_2()
+ call module_after_1
+ call module_after_2
+ call block_data_after_1
+ call block_data_after_2
+ call explicit_after_1(1.)
+ !ERROR: References to the procedure 'explicit_after_2' require an explicit interface
+ call explicit_after_2(1.)
+ !WARNING: If the procedure's interface were explicit, this reference would be in error
+ !BECAUSE: Dummy argument 'a=' (#1) is not OPTIONAL and is not associated with an actual argument in this procedure reference
+ call implicit_after_1
+ !WARNING: If the procedure's interface were explicit, this reference would be in error
+ !BECAUSE: Dummy argument 'a=' (#1) is not OPTIONAL and is not associated with an actual argument in this procedure reference
+ call implicit_after_2
+ print *, explicit_func_after_1(1.)
+ !ERROR: References to the procedure 'explicit_func_after_2' require an explicit interface
+ print *, explicit_func_after_2(1.)
+ !WARNING: If the procedure's interface were explicit, this reference would be in error
+ !BECAUSE: Dummy argument 'a=' (#1) is not OPTIONAL and is not associated with an actual argument in this procedure reference
+ print *, implicit_func_after_1()
+ !WARNING: If the procedure's interface were explicit, this reference would be in error
+ !BECAUSE: Dummy argument 'a=' (#1) is not OPTIONAL and is not associated with an actual argument in this procedure reference
+ print *, implicit_func_after_2()
+end program
+
+block data justfine
+end
+
+module module_after_1
+end
+
+!ERROR: 'module_after_2' is already declared in this scoping unit
+module module_after_2
+end
+
+block data block_data_after_1
+end
+
+!ERROR: BLOCK DATA 'block_data_after_2' has been called
+block data block_data_after_2
+end
+
+subroutine explicit_after_1(a)
+ real, optional :: a
+end
+
+subroutine explicit_after_2(a)
+ real, optional :: a
+end
+
+subroutine implicit_after_1(a)
+ real :: a
+end
+
+subroutine implicit_after_2(a)
+ real :: a
+end
+
+function explicit_func_after_1(a)
+ real, optional :: a
+end
+
+function explicit_func_after_2(a)
+ real, optional :: a
+end
+
+function implicit_func_after_1(a)
+ real :: a
+end
+
+function implicit_func_after_2(a)
+ real :: a
+end
diff --git a/flang/test/Semantics/procinterface01.f90 b/flang/test/Semantics/procinterface01.f90
index ab8f93c292c9..3363fbc69ccc 100644
--- a/flang/test/Semantics/procinterface01.f90
+++ b/flang/test/Semantics/procinterface01.f90
@@ -130,9 +130,9 @@ character function nested5(x)
end function nested5
end module module1
-!DEF: /explicit1 ELEMENTAL (Function) Subprogram REAL(4)
+!DEF: /explicit1 (Function) Subprogram REAL(4)
!DEF: /explicit1/x INTENT(IN) ObjectEntity REAL(4)
-real elemental function explicit1(x)
+real function explicit1(x)
!REF: /explicit1/x
real, intent(in) :: x
!DEF: /explicit1/explicit1 ObjectEntity REAL(4)
@@ -150,14 +150,13 @@ integer function logical(x)
logical = x+3.
end function logical
-!DEF: /tan (Function) Subprogram REAL(4)
+!DEF: /tan (Function) Subprogram CHARACTER(1_8,1)
!DEF: /tan/x INTENT(IN) ObjectEntity REAL(4)
-real function tan(x)
+character*1 function tan(x)
!REF: /tan/x
real, intent(in) :: x
- !DEF: /tan/tan ObjectEntity REAL(4)
- !REF: /tan/x
- tan = x+5.
+ !DEF: /tan/tan ObjectEntity CHARACTER(1_8,1)
+ tan = "?"
end function tan
!DEF: /main MainProgram
diff --git a/flang/test/Semantics/resolve102.f90 b/flang/test/Semantics/resolve102.f90
index 8d34d17ae776..11f2ce9c8ea5 100644
--- a/flang/test/Semantics/resolve102.f90
+++ b/flang/test/Semantics/resolve102.f90
@@ -30,6 +30,7 @@ subroutine iface
!ERROR: Procedure 'p' is recursively defined. Procedures in the cycle: 'p', 'sub', 'p2'
procedure(sub) :: p
interface
+ !ERROR: Procedure 'sub' is recursively defined. Procedures in the cycle: 'p', 'sub', 'p2'
subroutine sub(p2)
import p
procedure(p) :: p2
diff --git a/flang/test/Semantics/resolve53.f90 b/flang/test/Semantics/resolve53.f90
index 4a5e51f27f52..23babfe5b5b1 100644
--- a/flang/test/Semantics/resolve53.f90
+++ b/flang/test/Semantics/resolve53.f90
@@ -97,7 +97,6 @@ subroutine s5(x)
end subroutine
end interface
end
-
! Two procedures that
diff er only by attributes are not distinguishable
module m8
@@ -468,7 +467,7 @@ real function f(x)
end interface
end module
-subroutine s1()
+subroutine subr1()
use m20
interface operator(.not.)
!ERROR: Procedure 'f' from module 'm20' is already specified in generic 'OPERATOR(.NOT.)'
@@ -478,7 +477,7 @@ subroutine s1()
!ERROR: Procedure 'f' from module 'm20' is already specified in generic 'OPERATOR(+)'
procedure f
end interface
-end subroutine s1
+end subroutine subr1
! Extensions for distinguishable allocatable arguments; these should not
! elicit errors from f18
diff --git a/flang/test/Semantics/resolve62.f90 b/flang/test/Semantics/resolve62.f90
index e7d5cd9bd221..ee4049fd61f8 100644
--- a/flang/test/Semantics/resolve62.f90
+++ b/flang/test/Semantics/resolve62.f90
@@ -1,6 +1,6 @@
! RUN: %python %S/test_errors.py %s %flang_fc1
! Resolve generic based on number of arguments
-subroutine s1
+subroutine subr1
interface f
real function f1(x)
optional :: x
@@ -15,7 +15,7 @@ real function f2(x, y)
end
! Elemental and non-element function both match: non-elemental one should be used
-subroutine s2
+subroutine subr2
interface f
logical elemental function f1(x)
intent(in) :: x
@@ -53,10 +53,10 @@ module m4
real, protected :: x
real :: y
interface s
- pure subroutine s1(x)
+ pure subroutine s101(x)
real, intent(out) :: x
end
- subroutine s2(x, y)
+ subroutine s102(x, y)
real :: x, y
end
end interface
More information about the flang-commits
mailing list