aboutsummaryrefslogtreecommitdiff
path: root/flang/lib
diff options
context:
space:
mode:
Diffstat (limited to 'flang/lib')
-rw-r--r--flang/lib/Evaluate/characteristics.cpp14
-rw-r--r--flang/lib/Evaluate/tools.cpp9
-rw-r--r--flang/lib/Lower/OpenACC.cpp3
-rw-r--r--flang/lib/Lower/OpenMP/Utils.cpp53
-rw-r--r--flang/lib/Parser/Fortran-parsers.cpp4
-rw-r--r--flang/lib/Semantics/check-call.cpp71
-rw-r--r--flang/lib/Semantics/check-declarations.cpp136
-rw-r--r--flang/lib/Semantics/expression.cpp2
-rw-r--r--flang/lib/Semantics/resolve-directives.cpp2
-rw-r--r--flang/lib/Semantics/resolve-names.cpp179
-rw-r--r--flang/lib/Semantics/scope.cpp5
-rw-r--r--flang/lib/Semantics/semantics.cpp6
-rw-r--r--flang/lib/Semantics/tools.cpp5
-rw-r--r--flang/lib/Semantics/type.cpp23
14 files changed, 301 insertions, 211 deletions
diff --git a/flang/lib/Evaluate/characteristics.cpp b/flang/lib/Evaluate/characteristics.cpp
index 37c62c9..542f122 100644
--- a/flang/lib/Evaluate/characteristics.cpp
+++ b/flang/lib/Evaluate/characteristics.cpp
@@ -458,7 +458,7 @@ std::optional<DummyDataObject> DummyDataObject::Characterize(
}
bool DummyDataObject::CanBePassedViaImplicitInterface(
- std::string *whyNot) const {
+ std::string *whyNot, bool checkCUDA) const {
if ((attrs &
Attrs{Attr::Allocatable, Attr::Asynchronous, Attr::Optional,
Attr::Pointer, Attr::Target, Attr::Value, Attr::Volatile})
@@ -482,7 +482,7 @@ bool DummyDataObject::CanBePassedViaImplicitInterface(
*whyNot = "a dummy argument is polymorphic";
}
return false; // 15.4.2.2(3)(f)
- } else if (cudaDataAttr) {
+ } else if (checkCUDA && cudaDataAttr) {
if (whyNot) {
*whyNot = "a dummy argument has a CUDA data attribute";
}
@@ -1012,9 +1012,10 @@ common::Intent DummyArgument::GetIntent() const {
u);
}
-bool DummyArgument::CanBePassedViaImplicitInterface(std::string *whyNot) const {
+bool DummyArgument::CanBePassedViaImplicitInterface(
+ std::string *whyNot, bool checkCUDA) const {
if (const auto *object{std::get_if<DummyDataObject>(&u)}) {
- return object->CanBePassedViaImplicitInterface(whyNot);
+ return object->CanBePassedViaImplicitInterface(whyNot, checkCUDA);
} else if (const auto *proc{std::get_if<DummyProcedure>(&u)}) {
return proc->CanBePassedViaImplicitInterface(whyNot);
} else {
@@ -1501,7 +1502,8 @@ std::optional<Procedure> Procedure::FromActuals(const ProcedureDesignator &proc,
return callee;
}
-bool Procedure::CanBeCalledViaImplicitInterface(std::string *whyNot) const {
+bool Procedure::CanBeCalledViaImplicitInterface(
+ std::string *whyNot, bool checkCUDA) const {
if (attrs.test(Attr::Elemental)) {
if (whyNot) {
*whyNot = "the procedure is elemental";
@@ -1524,7 +1526,7 @@ bool Procedure::CanBeCalledViaImplicitInterface(std::string *whyNot) const {
return false;
} else {
for (const DummyArgument &arg : dummyArguments) {
- if (!arg.CanBePassedViaImplicitInterface(whyNot)) {
+ if (!arg.CanBePassedViaImplicitInterface(whyNot, checkCUDA)) {
return false;
}
}
diff --git a/flang/lib/Evaluate/tools.cpp b/flang/lib/Evaluate/tools.cpp
index 3cfad03..b927fa3 100644
--- a/flang/lib/Evaluate/tools.cpp
+++ b/flang/lib/Evaluate/tools.cpp
@@ -1209,6 +1209,15 @@ parser::Message *AttachDeclaration(
message.Attach(use->location(),
"'%s' is USE-associated with '%s' in module '%s'"_en_US, symbol.name(),
unhosted->name(), GetUsedModule(*use).name());
+ } else if (const auto *common{
+ unhosted->detailsIf<semantics::CommonBlockDetails>()}) {
+ parser::CharBlock at{unhosted->name()};
+ if (at.empty()) { // blank COMMON, with or without //
+ at = common->sourceLocation();
+ }
+ if (!at.empty()) {
+ message.Attach(at, "Declaration of /%s/"_en_US, unhosted->name());
+ }
} else {
message.Attach(
unhosted->name(), "Declaration of '%s'"_en_US, unhosted->name());
diff --git a/flang/lib/Lower/OpenACC.cpp b/flang/lib/Lower/OpenACC.cpp
index f9b9b850..4a9e494 100644
--- a/flang/lib/Lower/OpenACC.cpp
+++ b/flang/lib/Lower/OpenACC.cpp
@@ -2222,6 +2222,9 @@ buildACCLoopOp(Fortran::lower::AbstractConverter &converter,
addOperands(operands, operandSegments, tileOperands);
addOperands(operands, operandSegments, cacheOperands);
addOperands(operands, operandSegments, privateOperands);
+ // fill empty firstprivate operands since they are not permitted
+ // from OpenACC language perspective.
+ addOperands(operands, operandSegments, {});
addOperands(operands, operandSegments, reductionOperands);
auto loopOp = createRegionOp<mlir::acc::LoopOp, mlir::acc::YieldOp>(
diff --git a/flang/lib/Lower/OpenMP/Utils.cpp b/flang/lib/Lower/OpenMP/Utils.cpp
index 29cccbd..37b926e 100644
--- a/flang/lib/Lower/OpenMP/Utils.cpp
+++ b/flang/lib/Lower/OpenMP/Utils.cpp
@@ -14,11 +14,12 @@
#include "ClauseFinder.h"
#include "flang/Evaluate/fold.h"
-#include "flang/Lower/OpenMP/Clauses.h"
#include <flang/Lower/AbstractConverter.h>
#include <flang/Lower/ConvertType.h>
#include <flang/Lower/DirectivesCommon.h>
+#include <flang/Lower/OpenMP/Clauses.h>
#include <flang/Lower/PFTBuilder.h>
+#include <flang/Lower/Support/PrivateReductionUtils.h>
#include <flang/Optimizer/Builder/FIRBuilder.h>
#include <flang/Optimizer/Builder/Todo.h>
#include <flang/Parser/openmp-utils.h>
@@ -180,16 +181,11 @@ static void generateArrayIndices(lower::AbstractConverter &converter,
for (auto v : arr->subscript()) {
if (std::holds_alternative<Triplet>(v.u))
TODO(clauseLocation, "Triplet indexing in map clause is unsupported");
-
auto expr = std::get<Fortran::evaluate::IndirectSubscriptIntegerExpr>(v.u);
mlir::Value subscript =
fir::getBase(converter.genExprValue(toEvExpr(expr.value()), stmtCtx));
- mlir::Value one = firOpBuilder.createIntegerConstant(
- clauseLocation, firOpBuilder.getIndexType(), 1);
- subscript = firOpBuilder.createConvert(
- clauseLocation, firOpBuilder.getIndexType(), subscript);
- indices.push_back(mlir::arith::SubIOp::create(firOpBuilder, clauseLocation,
- subscript, one));
+ indices.push_back(firOpBuilder.createConvert(
+ clauseLocation, firOpBuilder.getIndexType(), subscript));
}
}
@@ -322,10 +318,42 @@ mlir::Value createParentSymAndGenIntermediateMaps(
subscriptIndices, objectList[i]);
assert(!subscriptIndices.empty() &&
"missing expected indices for map clause");
- curValue = fir::CoordinateOp::create(
- firOpBuilder, clauseLocation,
- firOpBuilder.getRefType(arrType.getEleTy()), curValue,
- subscriptIndices);
+ if (auto boxTy = llvm::dyn_cast<fir::BaseBoxType>(curValue.getType())) {
+ // To accommodate indexing into box types of all dimensions including
+ // negative dimensions we have to take into consideration the lower
+ // bounds and extents of the data (stored in the box) and convey it
+ // to the ArrayCoorOp so that it can appropriately access the element
+ // utilising the subscript we provide and the runtime sizes stored in
+ // the Box. To do so we need to generate a ShapeShiftOp which combines
+ // both the lb (ShiftOp) and extent (ShapeOp) of the Box, giving the
+ // ArrayCoorOp the spatial information it needs to calculate the
+ // underlying address.
+ mlir::Value shapeShift = Fortran::lower::getShapeShift(
+ firOpBuilder, clauseLocation, curValue);
+ auto addrOp =
+ fir::BoxAddrOp::create(firOpBuilder, clauseLocation, curValue);
+ curValue = fir::ArrayCoorOp::create(
+ firOpBuilder, clauseLocation,
+ firOpBuilder.getRefType(arrType.getEleTy()), addrOp, shapeShift,
+ /*slice=*/mlir::Value{}, subscriptIndices,
+ /*typeparms=*/mlir::ValueRange{});
+ } else {
+ // We're required to negate by one in the non-Box case as I believe
+ // we do not have the shape generated from the dimensions to help
+ // adjust the indexing.
+ // TODO/FIXME: This may need adjusted to support bounds of unusual
+ // dimensions, if that's the case then it is likely best to fold this
+ // branch into the above.
+ mlir::Value one = firOpBuilder.createIntegerConstant(
+ clauseLocation, firOpBuilder.getIndexType(), 1);
+ for (auto &v : subscriptIndices)
+ v = mlir::arith::SubIOp::create(firOpBuilder, clauseLocation, v,
+ one);
+ curValue = fir::CoordinateOp::create(
+ firOpBuilder, clauseLocation,
+ firOpBuilder.getRefType(arrType.getEleTy()), curValue,
+ subscriptIndices);
+ }
}
}
@@ -415,7 +443,6 @@ mlir::Value createParentSymAndGenIntermediateMaps(
currentIndicesIdx++;
}
}
-
return curValue;
}
diff --git a/flang/lib/Parser/Fortran-parsers.cpp b/flang/lib/Parser/Fortran-parsers.cpp
index fbe629a..d33a18f 100644
--- a/flang/lib/Parser/Fortran-parsers.cpp
+++ b/flang/lib/Parser/Fortran-parsers.cpp
@@ -1100,14 +1100,14 @@ TYPE_PARSER(construct<EquivalenceObject>(indirect(designator)))
// R873 common-stmt ->
// COMMON [/ [common-block-name] /] common-block-object-list
// [[,] / [common-block-name] / common-block-object-list]...
-TYPE_PARSER(
+TYPE_PARSER(sourced(
construct<CommonStmt>("COMMON" >> defaulted("/" >> maybe(name) / "/"),
nonemptyList("expected COMMON block objects"_err_en_US,
Parser<CommonBlockObject>{}),
many(maybe(","_tok) >>
construct<CommonStmt::Block>("/" >> maybe(name) / "/",
nonemptyList("expected COMMON block objects"_err_en_US,
- Parser<CommonBlockObject>{})))))
+ Parser<CommonBlockObject>{}))))))
// R874 common-block-object -> variable-name [( array-spec )]
TYPE_PARSER(construct<CommonBlockObject>(name, maybe(arraySpec)))
diff --git a/flang/lib/Semantics/check-call.cpp b/flang/lib/Semantics/check-call.cpp
index 4939d8d..81c53aa 100644
--- a/flang/lib/Semantics/check-call.cpp
+++ b/flang/lib/Semantics/check-call.cpp
@@ -56,28 +56,44 @@ static void CheckImplicitInterfaceArg(evaluate::ActualArgument &arg,
"%VAL argument must be a scalar numeric or logical expression"_err_en_US);
}
if (const auto *expr{arg.UnwrapExpr()}) {
- if (const Symbol * base{GetFirstSymbol(*expr)};
- base && IsFunctionResult(*base)) {
- context.NoteDefinedSymbol(*base);
+ if (const Symbol *base{GetFirstSymbol(*expr)}) {
+ const Symbol &symbol{GetAssociationRoot(*base)};
+ if (IsFunctionResult(symbol)) {
+ context.NoteDefinedSymbol(symbol);
+ }
}
if (IsBOZLiteral(*expr)) {
- messages.Say("BOZ argument requires an explicit interface"_err_en_US);
+ messages.Say("BOZ argument %s requires an explicit interface"_err_en_US,
+ expr->AsFortran());
} else if (evaluate::IsNullPointerOrAllocatable(expr)) {
messages.Say(
- "Null pointer argument requires an explicit interface"_err_en_US);
+ "Null pointer argument '%s' requires an explicit interface"_err_en_US,
+ expr->AsFortran());
} else if (auto named{evaluate::ExtractNamedEntity(*expr)}) {
- const Symbol &symbol{named->GetLastSymbol()};
- if (IsAssumedRank(symbol)) {
+ const Symbol &resolved{ResolveAssociations(named->GetLastSymbol())};
+ if (IsAssumedRank(resolved)) {
messages.Say(
- "Assumed rank argument requires an explicit interface"_err_en_US);
+ "Assumed rank argument '%s' requires an explicit interface"_err_en_US,
+ expr->AsFortran());
}
+ const Symbol &symbol{GetAssociationRoot(resolved)};
if (symbol.attrs().test(Attr::ASYNCHRONOUS)) {
messages.Say(
- "ASYNCHRONOUS argument requires an explicit interface"_err_en_US);
+ "ASYNCHRONOUS argument '%s' requires an explicit interface"_err_en_US,
+ expr->AsFortran());
}
if (symbol.attrs().test(Attr::VOLATILE)) {
messages.Say(
- "VOLATILE argument requires an explicit interface"_err_en_US);
+ "VOLATILE argument '%s' requires an explicit interface"_err_en_US,
+ expr->AsFortran());
+ }
+ if (const auto *object{symbol.detailsIf<ObjectEntityDetails>()}) {
+ if (object->cudaDataAttr()) {
+ messages.Warn(/*inModuleFile=*/false, context.languageFeatures(),
+ common::UsageWarning::CUDAUsage,
+ "Actual argument '%s' with CUDA data attributes should be passed via an explicit interface"_warn_en_US,
+ expr->AsFortran());
+ }
}
} else if (auto argChars{characteristics::DummyArgument::FromActual(
"actual argument", *expr, context.foldingContext(),
@@ -2387,44 +2403,51 @@ bool CheckArguments(const characteristics::Procedure &proc,
evaluate::FoldingContext foldingContext{context.foldingContext()};
parser::ContextualMessages &messages{foldingContext.messages()};
bool allowArgumentConversions{true};
+ parser::Messages implicitBuffer;
if (!explicitInterface || treatingExternalAsImplicit) {
- parser::Messages buffer;
{
- auto restorer{messages.SetMessages(buffer)};
+ auto restorer{messages.SetMessages(implicitBuffer)};
for (auto &actual : actuals) {
if (actual) {
CheckImplicitInterfaceArg(*actual, messages, context);
}
}
}
- if (!buffer.empty()) {
+ if (implicitBuffer.AnyFatalError()) {
if (auto *msgs{messages.messages()}) {
- msgs->Annex(std::move(buffer));
+ msgs->Annex(std::move(implicitBuffer));
}
return false; // don't pile on
}
allowArgumentConversions = false;
}
if (explicitInterface) {
- auto buffer{CheckExplicitInterface(proc, actuals, context, &scope,
+ auto explicitBuffer{CheckExplicitInterface(proc, actuals, context, &scope,
intrinsic, allowArgumentConversions,
/*extentErrors=*/true, ignoreImplicitVsExplicit)};
- if (!buffer.empty()) {
+ if (!explicitBuffer.empty()) {
if (treatingExternalAsImplicit) {
- if (auto *msg{foldingContext.Warn(
+ // Combine all messages into one warning
+ if (auto *warning{messages.Warn(/*inModuleFile=*/false,
+ context.languageFeatures(),
common::UsageWarning::KnownBadImplicitInterface,
"If the procedure's interface were explicit, this reference would be in error"_warn_en_US)}) {
- buffer.AttachTo(*msg, parser::Severity::Because);
- } else {
- buffer.clear();
+ explicitBuffer.AttachTo(*warning, parser::Severity::Because);
}
+ } else if (auto *msgs{messages.messages()}) {
+ msgs->Annex(std::move(explicitBuffer));
}
- if (auto *msgs{messages.messages()}) {
- msgs->Annex(std::move(buffer));
- }
+ // These messages override any in implicitBuffer.
return false;
}
}
- return true;
+ if (!implicitBuffer.empty()) {
+ if (auto *msgs{messages.messages()}) {
+ msgs->Annex(std::move(implicitBuffer));
+ }
+ return false;
+ } else {
+ return true; // no messages
+ }
}
} // namespace Fortran::semantics
diff --git a/flang/lib/Semantics/check-declarations.cpp b/flang/lib/Semantics/check-declarations.cpp
index 7b88100..7593424 100644
--- a/flang/lib/Semantics/check-declarations.cpp
+++ b/flang/lib/Semantics/check-declarations.cpp
@@ -512,39 +512,111 @@ void CheckHelper::Check(const Symbol &symbol) {
}
void CheckHelper::CheckCommonBlock(const Symbol &symbol) {
- auto restorer{messages_.SetLocation(symbol.name())};
CheckGlobalName(symbol);
- if (symbol.attrs().test(Attr::BIND_C)) {
+ const auto &common{symbol.get<CommonBlockDetails>()};
+ SourceName location{symbol.name()};
+ if (location.empty()) {
+ location = common.sourceLocation();
+ }
+ bool isBindCCommon{symbol.attrs().test(Attr::BIND_C)};
+ if (isBindCCommon) {
CheckBindC(symbol);
- for (auto ref : symbol.get<CommonBlockDetails>().objects()) {
- if (ref->has<ObjectEntityDetails>()) {
- if (auto msgs{WhyNotInteroperableObject(*ref,
- /*allowInteroperableType=*/false, /*forCommonBlock=*/true)};
- !msgs.empty()) {
- parser::Message &reason{msgs.messages().front()};
- parser::Message *msg{nullptr};
- if (reason.IsFatal()) {
- msg = messages_.Say(symbol.name(),
- "'%s' may not be a member of BIND(C) COMMON block /%s/"_err_en_US,
- ref->name(), symbol.name());
- } else {
- msg = messages_.Say(symbol.name(),
- "'%s' should not be a member of BIND(C) COMMON block /%s/"_warn_en_US,
- ref->name(), symbol.name());
- }
- if (msg) {
- msg->Attach(
- std::move(reason.set_severity(parser::Severity::Because)));
- }
+ }
+ for (auto ref : symbol.get<CommonBlockDetails>().objects()) {
+ auto restorer{
+ messages_.SetLocation(location.empty() ? ref->name() : location)};
+ if (isBindCCommon && ref->has<ObjectEntityDetails>()) {
+ if (auto msgs{WhyNotInteroperableObject(*ref,
+ /*allowInteroperableType=*/false, /*forCommonBlock=*/true)};
+ !msgs.empty()) {
+ parser::Message &reason{msgs.messages().front()};
+ parser::Message *msg{nullptr};
+ if (reason.IsFatal()) {
+ msg = messages_.Say(
+ "'%s' may not be a member of BIND(C) COMMON block /%s/"_err_en_US,
+ ref->name(), symbol.name());
+ } else {
+ msg = messages_.Say(
+ "'%s' should not be a member of BIND(C) COMMON block /%s/"_warn_en_US,
+ ref->name(), symbol.name());
}
+ if (msg) {
+ msg = &msg->Attach(
+ std::move(reason.set_severity(parser::Severity::Because)));
+ }
+ evaluate::AttachDeclaration(msg, *ref);
}
}
- }
- for (auto ref : symbol.get<CommonBlockDetails>().objects()) {
if (ref->test(Symbol::Flag::CrayPointee)) {
- messages_.Say(ref->name(),
- "Cray pointee '%s' may not be a member of a COMMON block"_err_en_US,
- ref->name());
+ evaluate::AttachDeclaration(
+ messages_.Say(
+ "Cray pointee '%s' may not be a member of COMMON block /%s/"_err_en_US,
+ ref->name(), symbol.name()),
+ *ref);
+ }
+ if (IsAllocatable(*ref)) {
+ evaluate::AttachDeclaration(
+ messages_.Say(
+ "ALLOCATABLE object '%s' may not appear in COMMON block /%s/"_err_en_US,
+ ref->name(), symbol.name()),
+ *ref);
+ }
+ if (ref->attrs().test(Attr::BIND_C)) {
+ evaluate::AttachDeclaration(
+ messages_.Say(
+ "BIND(C) object '%s' may not appear in COMMON block /%s/"_err_en_US,
+ ref->name(), symbol.name()),
+ *ref);
+ }
+ if (IsNamedConstant(*ref)) {
+ evaluate::AttachDeclaration(
+ messages_.Say(
+ "Named constant '%s' may not appear in COMMON block /%s/"_err_en_US,
+ ref->name(), symbol.name()),
+ *ref);
+ }
+ if (IsDummy(*ref)) {
+ evaluate::AttachDeclaration(
+ messages_.Say(
+ "Dummy argument '%s' may not appear in COMMON block /%s/"_err_en_US,
+ ref->name(), symbol.name()),
+ *ref);
+ }
+ if (ref->IsFuncResult()) {
+ evaluate::AttachDeclaration(
+ messages_.Say(
+ "Function result '%s' may not appear in COMMON block /%s/"_err_en_US,
+ ref->name(), symbol.name()),
+ *ref);
+ }
+ if (const auto *type{ref->GetType()}) {
+ if (type->category() == DeclTypeSpec::ClassStar) {
+ evaluate::AttachDeclaration(
+ messages_.Say(
+ "Unlimited polymorphic pointer '%s' may not appear in COMMON block /%s/"_err_en_US,
+ ref->name(), symbol.name()),
+ *ref);
+ } else if (const auto *derived{type->AsDerived()}) {
+ if (!IsSequenceOrBindCType(derived)) {
+ evaluate::AttachDeclaration(
+ evaluate::AttachDeclaration(
+ messages_.Say(
+ "Object '%s' whose derived type '%s' is neither SEQUENCE nor BIND(C) may not appear in COMMON block /%s/"_err_en_US,
+ ref->name(), derived->name(), symbol.name()),
+ derived->typeSymbol()),
+ *ref);
+ } else if (auto componentPath{
+ derived->ComponentWithDefaultInitialization()}) {
+ evaluate::AttachDeclaration(
+ evaluate::AttachDeclaration(
+ messages_.Say(
+ "COMMON block /%s/ may not have the member '%s' whose derived type '%s' has a component '%s' that is ALLOCATABLE or has default initialization"_err_en_US,
+ symbol.name(), ref->name(), derived->name(),
+ *componentPath),
+ derived->typeSymbol()),
+ *ref);
+ }
+ }
}
}
}
@@ -2976,14 +3048,6 @@ static std::optional<std::string> DefinesGlobalName(const Symbol &symbol) {
return std::nullopt;
}
-static bool IsSameSymbolFromHermeticModule(
- const Symbol &symbol, const Symbol &other) {
- return symbol.name() == other.name() && symbol.owner().IsModule() &&
- other.owner().IsModule() && symbol.owner() != other.owner() &&
- symbol.owner().GetName() &&
- symbol.owner().GetName() == other.owner().GetName();
-}
-
// 19.2 p2
void CheckHelper::CheckGlobalName(const Symbol &symbol) {
if (auto global{DefinesGlobalName(symbol)}) {
@@ -3001,7 +3065,7 @@ void CheckHelper::CheckGlobalName(const Symbol &symbol) {
(!IsExternalProcedureDefinition(symbol) ||
!IsExternalProcedureDefinition(other))) {
// both are procedures/BLOCK DATA, not both definitions
- } else if (IsSameSymbolFromHermeticModule(symbol, other)) {
+ } else if (AreSameModuleSymbol(symbol, other)) {
// Both symbols are the same thing.
} else if (symbol.has<ModuleDetails>()) {
Warn(common::LanguageFeature::BenignNameClash, symbol.name(),
diff --git a/flang/lib/Semantics/expression.cpp b/flang/lib/Semantics/expression.cpp
index 8365001..fc26888 100644
--- a/flang/lib/Semantics/expression.cpp
+++ b/flang/lib/Semantics/expression.cpp
@@ -3628,7 +3628,7 @@ std::optional<characteristics::Procedure> ExpressionAnalyzer::CheckCall(
if (chars) {
std::string whyNot;
if (treatExternalAsImplicit &&
- !chars->CanBeCalledViaImplicitInterface(&whyNot)) {
+ !chars->CanBeCalledViaImplicitInterface(&whyNot, /*checkCUDA=*/false)) {
if (auto *msg{Say(callSite,
"References to the procedure '%s' require an explicit interface"_err_en_US,
DEREF(procSymbol).name())};
diff --git a/flang/lib/Semantics/resolve-directives.cpp b/flang/lib/Semantics/resolve-directives.cpp
index 02fcf02..18fc638 100644
--- a/flang/lib/Semantics/resolve-directives.cpp
+++ b/flang/lib/Semantics/resolve-directives.cpp
@@ -625,7 +625,7 @@ public:
for (const parser::OmpObject &obj : x.v) {
auto *name{std::get_if<parser::Name>(&obj.u)};
if (name && !name->symbol) {
- Resolve(*name, currScope().MakeCommonBlock(name->source));
+ Resolve(*name, currScope().MakeCommonBlock(name->source, name->source));
}
}
}
diff --git a/flang/lib/Semantics/resolve-names.cpp b/flang/lib/Semantics/resolve-names.cpp
index 5041a6a..b7c7603d 100644
--- a/flang/lib/Semantics/resolve-names.cpp
+++ b/flang/lib/Semantics/resolve-names.cpp
@@ -1106,8 +1106,9 @@ protected:
// or nullptr on error.
Symbol *DeclareStatementEntity(const parser::DoVariable &,
const std::optional<parser::IntegerTypeSpec> &);
- Symbol &MakeCommonBlockSymbol(const parser::Name &);
- Symbol &MakeCommonBlockSymbol(const std::optional<parser::Name> &);
+ Symbol &MakeCommonBlockSymbol(const parser::Name &, SourceName);
+ Symbol &MakeCommonBlockSymbol(
+ const std::optional<parser::Name> &, SourceName);
bool CheckUseError(const parser::Name &);
void CheckAccessibility(const SourceName &, bool, Symbol &);
void CheckCommonBlocks();
@@ -1244,8 +1245,6 @@ private:
bool OkToAddComponent(const parser::Name &, const Symbol *extends = nullptr);
ParamValue GetParamValue(
const parser::TypeParamValue &, common::TypeParamAttr attr);
- void CheckCommonBlockDerivedType(
- const SourceName &, const Symbol &, UnorderedSymbolSet &);
Attrs HandleSaveName(const SourceName &, Attrs);
void AddSaveName(std::set<SourceName> &, const SourceName &);
bool HandleUnrestrictedSpecificIntrinsicFunction(const parser::Name &);
@@ -3963,8 +3962,26 @@ void ModuleVisitor::DoAddUse(SourceName location, SourceName localName,
}
}
+ auto AreSameModuleProcOrBothInterfaces{[](const Symbol &p1,
+ const Symbol &p2) {
+ if (IsProcedure(p1) && !IsPointer(p1) && IsProcedure(p2) &&
+ !IsPointer(p2)) {
+ auto classification{ClassifyProcedure(p1)};
+ if (classification == ClassifyProcedure(p2)) {
+ if (classification == ProcedureDefinitionClass::External) {
+ const auto *subp1{p1.detailsIf<SubprogramDetails>()};
+ const auto *subp2{p2.detailsIf<SubprogramDetails>()};
+ return subp1 && subp1->isInterface() && subp2 && subp2->isInterface();
+ } else if (classification == ProcedureDefinitionClass::Module) {
+ return AreSameModuleSymbol(p1, p2);
+ }
+ }
+ }
+ return false;
+ }};
+
auto AreSameProcedure{[&](const Symbol &p1, const Symbol &p2) {
- if (&p1 == &p2) {
+ if (&p1.GetUltimate() == &p2.GetUltimate()) {
return true;
} else if (p1.name() != p2.name()) {
return false;
@@ -3972,31 +3989,16 @@ void ModuleVisitor::DoAddUse(SourceName location, SourceName localName,
p2.attrs().test(Attr::INTRINSIC)) {
return p1.attrs().test(Attr::INTRINSIC) &&
p2.attrs().test(Attr::INTRINSIC);
- } else if (!IsProcedure(p1) || !IsProcedure(p2)) {
- return false;
- } else if (IsPointer(p1) || IsPointer(p2)) {
- return false;
- } else if (const auto *subp{p1.detailsIf<SubprogramDetails>()};
- subp && !subp->isInterface()) {
- return false; // defined in module, not an external
- } else if (const auto *subp{p2.detailsIf<SubprogramDetails>()};
- subp && !subp->isInterface()) {
- return false; // defined in module, not an external
+ } else if (AreSameModuleProcOrBothInterfaces(p1, p2)) {
+ // Both are external interfaces, perhaps to the same procedure,
+ // or both are module procedures from modules with the same name.
+ auto p1Chars{evaluate::characteristics::Procedure::Characterize(
+ p1, GetFoldingContext())};
+ auto p2Chars{evaluate::characteristics::Procedure::Characterize(
+ p2, GetFoldingContext())};
+ return p1Chars && p2Chars && *p1Chars == *p2Chars;
} else {
- // Both are external interfaces, perhaps to the same procedure
- auto class1{ClassifyProcedure(p1)};
- auto class2{ClassifyProcedure(p2)};
- if (class1 == ProcedureDefinitionClass::External &&
- class2 == ProcedureDefinitionClass::External) {
- auto chars1{evaluate::characteristics::Procedure::Characterize(
- p1, GetFoldingContext())};
- auto chars2{evaluate::characteristics::Procedure::Characterize(
- p2, GetFoldingContext())};
- // same procedure interface defined identically in two modules?
- return chars1 && chars2 && *chars1 == *chars2;
- } else {
- return false;
- }
+ return false;
}
}};
@@ -4097,13 +4099,32 @@ void ModuleVisitor::DoAddUse(SourceName location, SourceName localName,
localSymbol = &newSymbol;
}
if (useGeneric) {
- // Combine two use-associated generics
+ // Combine two use-associated generics.
localSymbol->attrs() =
useSymbol.attrs() & ~Attrs{Attr::PUBLIC, Attr::PRIVATE};
localSymbol->flags() = useSymbol.flags();
AddGenericUse(*localGeneric, localName, useUltimate);
- localGeneric->clear_derivedType();
- localGeneric->CopyFrom(*useGeneric);
+ // Don't duplicate specific procedures.
+ std::size_t originalLocalSpecifics{localGeneric->specificProcs().size()};
+ std::size_t useSpecifics{useGeneric->specificProcs().size()};
+ CHECK(originalLocalSpecifics == localGeneric->bindingNames().size());
+ CHECK(useSpecifics == useGeneric->bindingNames().size());
+ std::size_t j{0};
+ for (const Symbol &useSpecific : useGeneric->specificProcs()) {
+ SourceName useBindingName{useGeneric->bindingNames()[j++]};
+ bool isDuplicate{false};
+ std::size_t k{0};
+ for (const Symbol &localSpecific : localGeneric->specificProcs()) {
+ if (localGeneric->bindingNames()[k++] == useBindingName &&
+ AreSameProcedure(localSpecific, useSpecific)) {
+ isDuplicate = true;
+ break;
+ }
+ }
+ if (!isDuplicate) {
+ localGeneric->AddSpecificProc(useSpecific, useBindingName);
+ }
+ }
}
localGeneric->clear_derivedType();
if (combinedDerivedType) {
@@ -5564,7 +5585,7 @@ bool DeclarationVisitor::Pre(const parser::BindEntity &x) {
if (kind == parser::BindEntity::Kind::Object) {
symbol = &HandleAttributeStmt(Attr::BIND_C, name);
} else {
- symbol = &MakeCommonBlockSymbol(name);
+ symbol = &MakeCommonBlockSymbol(name, name.source);
SetExplicitAttr(*symbol, Attr::BIND_C);
}
// 8.6.4(1)
@@ -7147,7 +7168,7 @@ bool DeclarationVisitor::Pre(const parser::SaveStmt &x) {
auto kind{std::get<parser::SavedEntity::Kind>(y.t)};
const auto &name{std::get<parser::Name>(y.t)};
if (kind == parser::SavedEntity::Kind::Common) {
- MakeCommonBlockSymbol(name);
+ MakeCommonBlockSymbol(name, name.source);
AddSaveName(specPartState_.saveInfo.commons, name.source);
} else {
HandleAttributeStmt(Attr::SAVE, name);
@@ -7227,59 +7248,22 @@ void DeclarationVisitor::CheckCommonBlocks() {
if (symbol.get<CommonBlockDetails>().objects().empty() &&
symbol.attrs().test(Attr::BIND_C)) {
Say(symbol.name(),
- "'%s' appears as a COMMON block in a BIND statement but not in"
- " a COMMON statement"_err_en_US);
- }
- }
- // check objects in common blocks
- for (const auto &name : specPartState_.commonBlockObjects) {
- const auto *symbol{currScope().FindSymbol(name)};
- if (!symbol) {
- continue;
- }
- const auto &attrs{symbol->attrs()};
- if (attrs.test(Attr::ALLOCATABLE)) {
- Say(name,
- "ALLOCATABLE object '%s' may not appear in a COMMON block"_err_en_US);
- } else if (attrs.test(Attr::BIND_C)) {
- Say(name,
- "Variable '%s' with BIND attribute may not appear in a COMMON block"_err_en_US);
- } else if (IsNamedConstant(*symbol)) {
- Say(name,
- "A named constant '%s' may not appear in a COMMON block"_err_en_US);
- } else if (IsDummy(*symbol)) {
- Say(name,
- "Dummy argument '%s' may not appear in a COMMON block"_err_en_US);
- } else if (symbol->IsFuncResult()) {
- Say(name,
- "Function result '%s' may not appear in a COMMON block"_err_en_US);
- } else if (const DeclTypeSpec * type{symbol->GetType()}) {
- if (type->category() == DeclTypeSpec::ClassStar) {
- Say(name,
- "Unlimited polymorphic pointer '%s' may not appear in a COMMON block"_err_en_US);
- } else if (const auto *derived{type->AsDerived()}) {
- if (!IsSequenceOrBindCType(derived)) {
- Say(name,
- "Derived type '%s' in COMMON block must have the BIND or"
- " SEQUENCE attribute"_err_en_US);
- }
- UnorderedSymbolSet typeSet;
- CheckCommonBlockDerivedType(name, derived->typeSymbol(), typeSet);
- }
+ "'%s' appears as a COMMON block in a BIND statement but not in a COMMON statement"_err_en_US);
}
}
specPartState_.commonBlockObjects = {};
}
-Symbol &DeclarationVisitor::MakeCommonBlockSymbol(const parser::Name &name) {
- return Resolve(name, currScope().MakeCommonBlock(name.source));
+Symbol &DeclarationVisitor::MakeCommonBlockSymbol(
+ const parser::Name &name, SourceName location) {
+ return Resolve(name, currScope().MakeCommonBlock(name.source, location));
}
Symbol &DeclarationVisitor::MakeCommonBlockSymbol(
- const std::optional<parser::Name> &name) {
+ const std::optional<parser::Name> &name, SourceName location) {
if (name) {
- return MakeCommonBlockSymbol(*name);
+ return MakeCommonBlockSymbol(*name, location);
} else {
- return MakeCommonBlockSymbol(parser::Name{});
+ return MakeCommonBlockSymbol(parser::Name{}, location);
}
}
@@ -7287,43 +7271,6 @@ bool DeclarationVisitor::NameIsKnownOrIntrinsic(const parser::Name &name) {
return FindSymbol(name) || HandleUnrestrictedSpecificIntrinsicFunction(name);
}
-// Check if this derived type can be in a COMMON block.
-void DeclarationVisitor::CheckCommonBlockDerivedType(const SourceName &name,
- const Symbol &typeSymbol, UnorderedSymbolSet &typeSet) {
- if (auto iter{typeSet.find(SymbolRef{typeSymbol})}; iter != typeSet.end()) {
- return;
- }
- typeSet.emplace(typeSymbol);
- if (const auto *scope{typeSymbol.scope()}) {
- for (const auto &pair : *scope) {
- const Symbol &component{*pair.second};
- if (component.attrs().test(Attr::ALLOCATABLE)) {
- Say2(name,
- "Derived type variable '%s' may not appear in a COMMON block"
- " due to ALLOCATABLE component"_err_en_US,
- component.name(), "Component with ALLOCATABLE attribute"_en_US);
- return;
- }
- const auto *details{component.detailsIf<ObjectEntityDetails>()};
- if (component.test(Symbol::Flag::InDataStmt) ||
- (details && details->init())) {
- Say2(name,
- "Derived type variable '%s' may not appear in a COMMON block due to component with default initialization"_err_en_US,
- component.name(), "Component with default initialization"_en_US);
- return;
- }
- if (details) {
- if (const auto *type{details->type()}) {
- if (const auto *derived{type->AsDerived()}) {
- const Symbol &derivedTypeSymbol{derived->typeSymbol()};
- CheckCommonBlockDerivedType(name, derivedTypeSymbol, typeSet);
- }
- }
- }
- }
- }
-}
-
bool DeclarationVisitor::HandleUnrestrictedSpecificIntrinsicFunction(
const parser::Name &name) {
if (auto interface{context().intrinsics().IsSpecificIntrinsicFunction(
@@ -9655,7 +9602,7 @@ void ResolveNamesVisitor::CreateCommonBlockSymbols(
const parser::CommonStmt &commonStmt) {
for (const parser::CommonStmt::Block &block : commonStmt.blocks) {
const auto &[name, objects] = block.t;
- Symbol &commonBlock{MakeCommonBlockSymbol(name)};
+ Symbol &commonBlock{MakeCommonBlockSymbol(name, commonStmt.source)};
for (const auto &object : objects) {
Symbol &obj{DeclareObjectEntity(std::get<parser::Name>(object.t))};
if (auto *details{obj.detailsIf<ObjectEntityDetails>()}) {
diff --git a/flang/lib/Semantics/scope.cpp b/flang/lib/Semantics/scope.cpp
index 9c5682b..4af371f 100644
--- a/flang/lib/Semantics/scope.cpp
+++ b/flang/lib/Semantics/scope.cpp
@@ -143,12 +143,13 @@ void Scope::add_crayPointer(const SourceName &name, Symbol &pointer) {
crayPointers_.emplace(name, pointer);
}
-Symbol &Scope::MakeCommonBlock(const SourceName &name) {
+Symbol &Scope::MakeCommonBlock(SourceName name, SourceName location) {
const auto it{commonBlocks_.find(name)};
if (it != commonBlocks_.end()) {
return *it->second;
} else {
- Symbol &symbol{MakeSymbol(name, Attrs{}, CommonBlockDetails{})};
+ Symbol &symbol{MakeSymbol(
+ name, Attrs{}, CommonBlockDetails{name.empty() ? location : name})};
commonBlocks_.emplace(name, symbol);
return symbol;
}
diff --git a/flang/lib/Semantics/semantics.cpp b/flang/lib/Semantics/semantics.cpp
index 6db11aa..bdb5377 100644
--- a/flang/lib/Semantics/semantics.cpp
+++ b/flang/lib/Semantics/semantics.cpp
@@ -313,15 +313,13 @@ private:
/// Return the symbol of an initialized member if a COMMON block
/// is initalized. Otherwise, return nullptr.
static Symbol *CommonBlockIsInitialized(const Symbol &common) {
- const auto &commonDetails =
- common.get<Fortran::semantics::CommonBlockDetails>();
-
+ const auto &commonDetails{
+ common.get<Fortran::semantics::CommonBlockDetails>()};
for (const auto &member : commonDetails.objects()) {
if (IsInitialized(*member)) {
return &*member;
}
}
-
// Common block may be initialized via initialized variables that are in an
// equivalence with the common block members.
for (const Fortran::semantics::EquivalenceSet &set :
diff --git a/flang/lib/Semantics/tools.cpp b/flang/lib/Semantics/tools.cpp
index 28829d3..8eddd03 100644
--- a/flang/lib/Semantics/tools.cpp
+++ b/flang/lib/Semantics/tools.cpp
@@ -1870,4 +1870,9 @@ bool HadUseError(
}
}
+bool AreSameModuleSymbol(const Symbol &symbol, const Symbol &other) {
+ return symbol.name() == other.name() && symbol.owner().IsModule() &&
+ other.owner().IsModule() && symbol.owner().GetName() &&
+ symbol.owner().GetName() == other.owner().GetName();
+}
} // namespace Fortran::semantics
diff --git a/flang/lib/Semantics/type.cpp b/flang/lib/Semantics/type.cpp
index 964a37e..69e6ffa 100644
--- a/flang/lib/Semantics/type.cpp
+++ b/flang/lib/Semantics/type.cpp
@@ -206,14 +206,25 @@ bool DerivedTypeSpec::IsForwardReferenced() const {
return typeSymbol_.get<DerivedTypeDetails>().isForwardReferenced();
}
-bool DerivedTypeSpec::HasDefaultInitialization(
+std::optional<std::string> DerivedTypeSpec::ComponentWithDefaultInitialization(
bool ignoreAllocatable, bool ignorePointer) const {
DirectComponentIterator components{*this};
- return bool{std::find_if(
- components.begin(), components.end(), [&](const Symbol &component) {
- return IsInitialized(component, /*ignoreDataStatements=*/true,
- ignoreAllocatable, ignorePointer);
- })};
+ if (auto it{std::find_if(components.begin(), components.end(),
+ [ignoreAllocatable, ignorePointer](const Symbol &component) {
+ return (!ignoreAllocatable && IsAllocatable(component)) ||
+ (!ignorePointer && IsPointer(component)) ||
+ HasDeclarationInitializer(component);
+ })}) {
+ return it.BuildResultDesignatorName();
+ } else {
+ return std::nullopt;
+ }
+}
+
+bool DerivedTypeSpec::HasDefaultInitialization(
+ bool ignoreAllocatable, bool ignorePointer) const {
+ return ComponentWithDefaultInitialization(ignoreAllocatable, ignorePointer)
+ .has_value();
}
bool DerivedTypeSpec::HasDestruction() const {
generated by cgit v1.1 at 2025-10-04 05:50:18 +0000