aboutsummaryrefslogtreecommitdiff
path: root/flang/lib
diff options
context:
space:
mode:
Diffstat (limited to 'flang/lib')
-rw-r--r--flang/lib/Evaluate/formatting.cpp7
-rw-r--r--flang/lib/Optimizer/Transforms/DebugTypeGenerator.cpp9
-rw-r--r--flang/lib/Parser/prescan.cpp75
-rw-r--r--flang/lib/Parser/program-parsers.cpp2
-rw-r--r--flang/lib/Semantics/check-call.cpp7
-rw-r--r--flang/lib/Semantics/check-call.h11
-rw-r--r--flang/lib/Semantics/check-declarations.cpp6
-rw-r--r--flang/lib/Semantics/expression.cpp114
8 files changed, 146 insertions, 85 deletions
diff --git a/flang/lib/Evaluate/formatting.cpp b/flang/lib/Evaluate/formatting.cpp
index ec5dc0b..5632015 100644
--- a/flang/lib/Evaluate/formatting.cpp
+++ b/flang/lib/Evaluate/formatting.cpp
@@ -252,6 +252,13 @@ llvm::raw_ostream &ActualArgument::AsFortran(llvm::raw_ostream &o) const {
return o;
}
+std::string ActualArgument::AsFortran() const {
+ std::string result;
+ llvm::raw_string_ostream sstream(result);
+ AsFortran(sstream);
+ return result;
+}
+
llvm::raw_ostream &SpecificIntrinsic::AsFortran(llvm::raw_ostream &o) const {
return o << name;
}
diff --git a/flang/lib/Optimizer/Transforms/DebugTypeGenerator.cpp b/flang/lib/Optimizer/Transforms/DebugTypeGenerator.cpp
index 00fdb5a..e1e6125 100644
--- a/flang/lib/Optimizer/Transforms/DebugTypeGenerator.cpp
+++ b/flang/lib/Optimizer/Transforms/DebugTypeGenerator.cpp
@@ -528,13 +528,10 @@ mlir::LLVM::DITypeAttr DebugTypeGenerator::convertSequenceType(
if (dim == seqTy.getUnknownExtent()) {
// This path is taken for both assumed size array or when the size of the
// array is variable. In the case of variable size, we create a variable
- // to use as countAttr. Note that fir has a constant size of -1 for
- // assumed size array. So !optint check makes sure we don't generate
- // variable in that case.
+ // to use as countAttr.
if (declOp && declOp.getShape().size() > index) {
- std::optional<std::int64_t> optint =
- getIntIfConstant(declOp.getShape()[index]);
- if (!optint)
+ if (!llvm::isa_and_nonnull<fir::AssumedSizeExtentOp>(
+ declOp.getShape()[index].getDefiningOp()))
countAttr = generateArtificialVariable(
context, declOp.getShape()[index], fileAttr, scope, declOp);
}
diff --git a/flang/lib/Parser/prescan.cpp b/flang/lib/Parser/prescan.cpp
index df0372b..4739da0 100644
--- a/flang/lib/Parser/prescan.cpp
+++ b/flang/lib/Parser/prescan.cpp
@@ -1380,19 +1380,23 @@ const char *Prescanner::FixedFormContinuationLine(bool atNewline) {
}
}
} else { // Normal case: not in a compiler directive.
- // !$ conditional compilation lines may be continuations when not
+ // Conditional compilation lines may be continuations when not
// just preprocessing.
- if (!preprocessingOnly_ && IsFixedFormCommentChar(col1) &&
- nextLine_[1] == '$' && nextLine_[2] == ' ' && nextLine_[3] == ' ' &&
- nextLine_[4] == ' ' && IsCompilerDirectiveSentinel(&nextLine_[1], 1)) {
- if (const char *col6{nextLine_ + 5};
- *col6 != '\n' && *col6 != '0' && !IsSpaceOrTab(col6)) {
- if (atNewline && !IsSpace(nextLine_ + 6)) {
- brokenToken_ = true;
+ if (!preprocessingOnly_ && IsFixedFormCommentChar(col1)) {
+ if ((nextLine_[1] == '$' && nextLine_[2] == ' ' && nextLine_[3] == ' ' &&
+ nextLine_[4] == ' ' &&
+ IsCompilerDirectiveSentinel(&nextLine_[1], 1)) ||
+ (nextLine_[1] == '@' &&
+ IsCompilerDirectiveSentinel(&nextLine_[1], 4))) {
+ if (const char *col6{nextLine_ + 5};
+ *col6 != '\n' && *col6 != '0' && !IsSpaceOrTab(col6)) {
+ if (atNewline && !IsSpace(nextLine_ + 6)) {
+ brokenToken_ = true;
+ }
+ return nextLine_ + 6;
+ } else {
+ return nullptr;
}
- return nextLine_ + 6;
- } else {
- return nullptr;
}
}
if (col1 == '&' &&
@@ -1427,6 +1431,15 @@ const char *Prescanner::FixedFormContinuationLine(bool atNewline) {
return nullptr; // not a continuation line
}
+constexpr bool IsDirective(const char *match, const char *dir) {
+ for (; *match; ++match) {
+ if (*match != ToLowerCaseLetter(*dir++)) {
+ return false;
+ }
+ }
+ return true;
+}
+
const char *Prescanner::FreeFormContinuationLine(bool ampersand) {
const char *lineStart{nextLine_};
const char *p{lineStart};
@@ -1439,12 +1452,18 @@ const char *Prescanner::FreeFormContinuationLine(bool ampersand) {
if (preprocessingOnly_) {
// in -E mode, don't treat !$ as a continuation
return nullptr;
- } else if (p[0] == '!' && p[1] == '$') {
- // accept but do not require a matching sentinel
- if (p[2] != '&' && !IsSpaceOrTab(&p[2])) {
- return nullptr; // not !$
- }
+ } else if (p[0] == '!' && (p[1] == '$' || p[1] == '@')) {
p += 2;
+ if (InOpenACCOrCUDAConditionalLine()) {
+ if (IsDirective("acc", p) || IsDirective("cuf", p)) {
+ p += 3;
+ } else {
+ return nullptr;
+ }
+ }
+ if (*p != '&' && !IsSpaceOrTab(p)) {
+ return nullptr;
+ }
}
} else if (*p++ == '!') {
for (const char *s{directiveSentinel_}; *s != '\0'; ++p, ++s) {
@@ -1467,10 +1486,17 @@ const char *Prescanner::FreeFormContinuationLine(bool ampersand) {
return nullptr;
}
}
- if (p[0] == '!' && p[1] == '$' && !preprocessingOnly_ &&
- features_.IsEnabled(LanguageFeature::OpenMP)) {
- // !$ conditional line can be a continuation
- p = lineStart = SkipWhiteSpace(p + 2);
+ if (p[0] == '!' && !preprocessingOnly_) {
+ // Conditional lines can be continuations
+ if (p[1] == '$' && features_.IsEnabled(LanguageFeature::OpenMP)) {
+ p = lineStart = SkipWhiteSpace(p + 2);
+ } else if (IsDirective("@acc", p + 1) &&
+ features_.IsEnabled(LanguageFeature::OpenACC)) {
+ p = lineStart = SkipWhiteSpace(p + 5);
+ } else if (IsDirective("@cuf", p + 1) &&
+ features_.IsEnabled(LanguageFeature::CUDA)) {
+ p = lineStart = SkipWhiteSpace(p + 5);
+ }
}
if (*p == '&') {
return p + 1;
@@ -1706,15 +1732,6 @@ Prescanner::IsCompilerDirectiveSentinel(const char *p) const {
return std::nullopt;
}
-constexpr bool IsDirective(const char *match, const char *dir) {
- for (; *match; ++match) {
- if (*match != ToLowerCaseLetter(*dir++)) {
- return false;
- }
- }
- return true;
-}
-
Prescanner::LineClassification Prescanner::ClassifyLine(
const char *start) const {
if (inFixedForm_) {
diff --git a/flang/lib/Parser/program-parsers.cpp b/flang/lib/Parser/program-parsers.cpp
index 92c0a64..740dbbf 100644
--- a/flang/lib/Parser/program-parsers.cpp
+++ b/flang/lib/Parser/program-parsers.cpp
@@ -484,7 +484,7 @@ constexpr auto starOrExpr{
applyFunction(presentOptional<ScalarExpr>, scalarExpr))};
TYPE_PARSER(extension<LanguageFeature::CUDA>(
"<<<" >> construct<CallStmt::Chevrons>(starOrExpr, ", " >> scalarExpr,
- maybe("," >> scalarIntExpr), maybe("," >> scalarIntExpr)) /
+ maybe("," >> scalarExpr), maybe("," >> scalarIntExpr)) /
">>>"))
constexpr auto actualArgSpecList{optionalList(actualArgSpec)};
TYPE_CONTEXT_PARSER("CALL statement"_en_US,
diff --git a/flang/lib/Semantics/check-call.cpp b/flang/lib/Semantics/check-call.cpp
index e4d2a0d..c51d40b 100644
--- a/flang/lib/Semantics/check-call.cpp
+++ b/flang/lib/Semantics/check-call.cpp
@@ -2241,10 +2241,9 @@ static void CheckSpecificIntrinsic(const characteristics::Procedure &proc,
}
}
-static parser::Messages CheckExplicitInterface(
- const characteristics::Procedure &proc, evaluate::ActualArguments &actuals,
- SemanticsContext &context, const Scope *scope,
- const evaluate::SpecificIntrinsic *intrinsic,
+parser::Messages CheckExplicitInterface(const characteristics::Procedure &proc,
+ evaluate::ActualArguments &actuals, SemanticsContext &context,
+ const Scope *scope, const evaluate::SpecificIntrinsic *intrinsic,
bool allowActualArgumentConversions, bool extentErrors,
bool ignoreImplicitVsExplicit) {
evaluate::FoldingContext &foldingContext{context.foldingContext()};
diff --git a/flang/lib/Semantics/check-call.h b/flang/lib/Semantics/check-call.h
index 46bc61a..a69b792 100644
--- a/flang/lib/Semantics/check-call.h
+++ b/flang/lib/Semantics/check-call.h
@@ -12,11 +12,8 @@
#define FORTRAN_SEMANTICS_CHECK_CALL_H_
#include "flang/Evaluate/call.h"
+#include "flang/Parser/message.h"
-namespace Fortran::parser {
-class Messages;
-class ContextualMessages;
-} // namespace Fortran::parser
namespace Fortran::evaluate::characteristics {
struct Procedure;
}
@@ -47,6 +44,12 @@ bool CheckArgumentIsConstantExprInRange(
const evaluate::ActualArguments &actuals, int index, int lowerBound,
int upperBound, parser::ContextualMessages &messages);
+parser::Messages CheckExplicitInterface(
+ const evaluate::characteristics::Procedure &, evaluate::ActualArguments &,
+ SemanticsContext &, const Scope *, const evaluate::SpecificIntrinsic *,
+ bool allowActualArgumentConversions, bool extentErrors,
+ bool ignoreImplicitVsExplicit);
+
// Checks actual arguments for the purpose of resolving a generic interface.
bool CheckInterfaceForGeneric(const evaluate::characteristics::Procedure &,
evaluate::ActualArguments &, SemanticsContext &,
diff --git a/flang/lib/Semantics/check-declarations.cpp b/flang/lib/Semantics/check-declarations.cpp
index 31e246c..549ee83 100644
--- a/flang/lib/Semantics/check-declarations.cpp
+++ b/flang/lib/Semantics/check-declarations.cpp
@@ -472,6 +472,10 @@ void CheckHelper::Check(const Symbol &symbol) {
messages_.Say(
"A function result may not also be a named constant"_err_en_US);
}
+ if (!IsProcedurePointer(symbol) && IsProcedure(symbol)) {
+ messages_.Say(
+ "A function result may not be a procedure unless it is a procedure pointer"_err_en_US);
+ }
}
if (IsAutomatic(symbol)) {
if (const Symbol * common{FindCommonBlockContaining(symbol)}) {
@@ -1781,7 +1785,7 @@ void CheckHelper::CheckExternal(const Symbol &symbol) {
if (auto previousChars{Characterize(previous)}) {
std::string whyNot;
if (!chars->IsCompatibleWith(*previousChars,
- /*ignoreImplicitVsExplicit=*/false, &whyNot)) {
+ /*ignoreImplicitVsExplicit=*/true, &whyNot)) {
if (auto *msg{Warn(common::UsageWarning::ExternalInterfaceMismatch,
"The external interface '%s' is not compatible with an earlier definition (%s)"_warn_en_US,
symbol.name(), whyNot)}) {
diff --git a/flang/lib/Semantics/expression.cpp b/flang/lib/Semantics/expression.cpp
index 4aeb9a4..32aa6b1 100644
--- a/flang/lib/Semantics/expression.cpp
+++ b/flang/lib/Semantics/expression.cpp
@@ -2552,11 +2552,12 @@ auto ExpressionAnalyzer::AnalyzeProcedureComponentRef(
}
return true;
}};
- auto pair{
- ResolveGeneric(generic, arguments, adjustment, isSubroutine)};
- sym = pair.first;
+ auto result{ResolveGeneric(
+ generic, arguments, adjustment, isSubroutine, SymbolVector{})};
+ sym = result.specific;
if (!sym) {
- EmitGenericResolutionError(generic, pair.second, isSubroutine);
+ EmitGenericResolutionError(generic, result.failedDueToAmbiguity,
+ isSubroutine, arguments, result.tried);
return std::nullopt;
}
// re-resolve the name to the specific binding
@@ -2886,10 +2887,10 @@ const Symbol *ExpressionAnalyzer::ResolveForward(const Symbol &symbol) {
// Resolve a call to a generic procedure with given actual arguments.
// adjustActuals is called on procedure bindings to handle pass arg.
-std::pair<const Symbol *, bool> ExpressionAnalyzer::ResolveGeneric(
- const Symbol &symbol, const ActualArguments &actuals,
- const AdjustActuals &adjustActuals, bool isSubroutine,
- bool mightBeStructureConstructor) {
+auto ExpressionAnalyzer::ResolveGeneric(const Symbol &symbol,
+ const ActualArguments &actuals, const AdjustActuals &adjustActuals,
+ bool isSubroutine, SymbolVector &&tried, bool mightBeStructureConstructor)
+ -> GenericResolution {
const Symbol &ultimate{symbol.GetUltimate()};
// Check for a match with an explicit INTRINSIC
const Symbol *explicitIntrinsic{nullptr};
@@ -2948,7 +2949,7 @@ std::pair<const Symbol *, bool> ExpressionAnalyzer::ResolveGeneric(
// cannot be unambiguously distinguished
// Underspecified external procedure actual arguments can
// also lead to ambiguity.
- return {nullptr, true /* due to ambiguity */};
+ return {nullptr, true /* due to ambiguity */, std::move(tried)};
}
}
if (!procedure->IsElemental()) {
@@ -2959,6 +2960,8 @@ std::pair<const Symbol *, bool> ExpressionAnalyzer::ResolveGeneric(
}
crtMatchingDistance = ComputeCudaMatchingDistance(
context_.languageFeatures(), *procedure, localActuals);
+ } else {
+ tried.push_back(*specific);
}
}
}
@@ -3038,11 +3041,12 @@ 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())}) {
- auto pair{ResolveGeneric(
- *extended, actuals, adjustActuals, isSubroutine, false)};
- if (pair.first) {
- return pair;
+ auto result{ResolveGeneric(*extended, actuals, adjustActuals,
+ isSubroutine, std::move(tried), false)};
+ if (result.specific != nullptr) {
+ return result;
}
+ tried = std::move(result.tried);
}
}
// Structure constructor?
@@ -3054,14 +3058,15 @@ std::pair<const Symbol *, bool> ExpressionAnalyzer::ResolveGeneric(
if (!symbol.owner().IsGlobal() && !symbol.owner().IsDerivedType()) {
if (const Symbol *
outer{symbol.owner().parent().FindSymbol(symbol.name())}) {
- auto pair{ResolveGeneric(*outer, actuals, adjustActuals, isSubroutine,
- mightBeStructureConstructor)};
- if (pair.first) {
- return pair;
+ auto result{ResolveGeneric(*outer, actuals, adjustActuals, isSubroutine,
+ std::move(tried), mightBeStructureConstructor)};
+ if (result.specific) {
+ return result;
}
+ tried = std::move(result.tried);
}
}
- return {nullptr, false};
+ return {nullptr, false, std::move(tried)};
}
const Symbol &ExpressionAnalyzer::AccessSpecific(
@@ -3098,16 +3103,39 @@ const Symbol &ExpressionAnalyzer::AccessSpecific(
}
}
-void ExpressionAnalyzer::EmitGenericResolutionError(
- const Symbol &symbol, bool dueToAmbiguity, bool isSubroutine) {
- Say(dueToAmbiguity
- ? "The actual arguments to the generic procedure '%s' matched multiple specific procedures, perhaps due to use of NULL() without MOLD= or an actual procedure with an implicit interface"_err_en_US
- : semantics::IsGenericDefinedOp(symbol)
- ? "No specific procedure of generic operator '%s' matches the actual arguments"_err_en_US
- : isSubroutine
- ? "No specific subroutine of generic '%s' matches the actual arguments"_err_en_US
- : "No specific function of generic '%s' matches the actual arguments"_err_en_US,
- symbol.name());
+void ExpressionAnalyzer::EmitGenericResolutionError(const Symbol &symbol,
+ bool dueToAmbiguity, bool isSubroutine, ActualArguments &arguments,
+ const SymbolVector &tried) {
+ if (auto *msg{Say(dueToAmbiguity
+ ? "The actual arguments to the generic procedure '%s' matched multiple specific procedures, perhaps due to use of NULL() without MOLD= or an actual procedure with an implicit interface"_err_en_US
+ : semantics::IsGenericDefinedOp(symbol)
+ ? "No specific procedure of generic operator '%s' matches the actual arguments"_err_en_US
+ : isSubroutine
+ ? "No specific subroutine of generic '%s' matches the actual arguments"_err_en_US
+ : "No specific function of generic '%s' matches the actual arguments"_err_en_US,
+ symbol.name())}) {
+ parser::ContextualMessages &messages{GetContextualMessages()};
+ semantics::Scope &scope{context_.FindScope(messages.at())};
+ for (const Symbol &specific : tried) {
+ if (auto procChars{characteristics::Procedure::Characterize(
+ specific, GetFoldingContext())}) {
+ if (procChars->HasExplicitInterface()) {
+ if (auto reasons{semantics::CheckExplicitInterface(*procChars,
+ arguments, context_, &scope, /*intrinsic=*/nullptr,
+ /*allocActualArgumentConversions=*/false,
+ /*extentErrors=*/false,
+ /*ignoreImplicitVsExplicit=*/false)};
+ !reasons.empty()) {
+ reasons.AttachTo(
+ msg->Attach(specific.name(),
+ "Specific procedure '%s' does not match the actual arguments because"_en_US,
+ specific.name()),
+ parser::Severity::None);
+ }
+ }
+ }
+ }
+ }
}
auto ExpressionAnalyzer::GetCalleeAndArguments(
@@ -3146,12 +3174,14 @@ auto ExpressionAnalyzer::GetCalleeAndArguments(const parser::Name &name,
bool isGenericInterface{ultimate.has<semantics::GenericDetails>()};
bool isExplicitIntrinsic{ultimate.attrs().test(semantics::Attr::INTRINSIC)};
const Symbol *resolution{nullptr};
+ SymbolVector tried;
if (isGenericInterface || isExplicitIntrinsic) {
ExpressionAnalyzer::AdjustActuals noAdjustment;
- auto pair{ResolveGeneric(*symbol, arguments, noAdjustment, isSubroutine,
- mightBeStructureConstructor)};
- resolution = pair.first;
- dueToAmbiguity = pair.second;
+ auto result{ResolveGeneric(*symbol, arguments, noAdjustment, isSubroutine,
+ SymbolVector{}, mightBeStructureConstructor)};
+ resolution = result.specific;
+ dueToAmbiguity = result.failedDueToAmbiguity;
+ tried = std::move(result.tried);
if (resolution) {
if (context_.GetPPCBuiltinsScope() &&
resolution->name().ToString().rfind("__ppc_", 0) == 0) {
@@ -3182,7 +3212,8 @@ auto ExpressionAnalyzer::GetCalleeAndArguments(const parser::Name &name,
std::move(specificCall->arguments)};
} else {
if (isGenericInterface) {
- EmitGenericResolutionError(*symbol, dueToAmbiguity, isSubroutine);
+ EmitGenericResolutionError(
+ *symbol, dueToAmbiguity, isSubroutine, arguments, tried);
}
return std::nullopt;
}
@@ -4955,8 +4986,10 @@ std::optional<ProcedureRef> ArgumentAnalyzer::GetDefinedAssignmentProc(
auto restorer{context_.GetContextualMessages().DiscardMessages()};
if (const Symbol *symbol{scope.FindSymbol(oprName)}) {
ExpressionAnalyzer::AdjustActuals noAdjustment;
- proc =
- context_.ResolveGeneric(*symbol, actuals_, noAdjustment, true).first;
+ proc = context_
+ .ResolveGeneric(
+ *symbol, actuals_, noAdjustment, true, SymbolVector{})
+ .specific;
if (proc) {
isProcElemental = IsElementalProcedure(*proc);
}
@@ -5105,17 +5138,18 @@ const Symbol *ArgumentAnalyzer::FindBoundOp(parser::CharBlock oprName,
[&](const Symbol &proc, ActualArguments &) {
return passIndex == GetPassIndex(proc).value_or(-1);
}};
- auto pair{
- context_.ResolveGeneric(*generic, actuals_, adjustment, isSubroutine)};
- if (const Symbol *binding{pair.first}) {
+ auto result{context_.ResolveGeneric(
+ *generic, actuals_, adjustment, isSubroutine, SymbolVector{})};
+ if (const Symbol *binding{result.specific}) {
CHECK(binding->has<semantics::ProcBindingDetails>());
// Use the most recent override of the binding, if any
return scope->FindComponent(binding->name());
} else {
if (isAmbiguous) {
- *isAmbiguous = pair.second;
+ *isAmbiguous = result.failedDueToAmbiguity;
}
- context_.EmitGenericResolutionError(*generic, pair.second, isSubroutine);
+ context_.EmitGenericResolutionError(*generic, result.failedDueToAmbiguity,
+ isSubroutine, actuals_, result.tried);
}
}
return nullptr;
generated by cgit v1.1 at 2025-10-26 05:04:10 +0000