aboutsummaryrefslogtreecommitdiff
path: root/flang/lib/Semantics
diff options
context:
space:
mode:
Diffstat (limited to 'flang/lib/Semantics')
-rw-r--r--flang/lib/Semantics/check-call.cpp71
-rw-r--r--flang/lib/Semantics/check-declarations.cpp136
-rw-r--r--flang/lib/Semantics/check-directive-structure.h7
-rw-r--r--flang/lib/Semantics/check-omp-structure.cpp8
-rw-r--r--flang/lib/Semantics/expression.cpp2
-rw-r--r--flang/lib/Semantics/resolve-directives.cpp18
-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
11 files changed, 262 insertions, 198 deletions
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/check-directive-structure.h b/flang/lib/Semantics/check-directive-structure.h
index b1bf3e5..bd78d3c 100644
--- a/flang/lib/Semantics/check-directive-structure.h
+++ b/flang/lib/Semantics/check-directive-structure.h
@@ -383,7 +383,8 @@ protected:
const C &clause, const parser::ScalarIntConstantExpr &i);
void RequiresPositiveParameter(const C &clause,
- const parser::ScalarIntExpr &i, llvm::StringRef paramName = "parameter");
+ const parser::ScalarIntExpr &i, llvm::StringRef paramName = "parameter",
+ bool allowZero = true);
void OptionalConstantPositiveParameter(
const C &clause, const std::optional<parser::ScalarIntConstantExpr> &o);
@@ -657,9 +658,9 @@ void DirectiveStructureChecker<D, C, PC, ClauseEnumSize>::SayNotMatching(
template <typename D, typename C, typename PC, std::size_t ClauseEnumSize>
void DirectiveStructureChecker<D, C, PC,
ClauseEnumSize>::RequiresPositiveParameter(const C &clause,
- const parser::ScalarIntExpr &i, llvm::StringRef paramName) {
+ const parser::ScalarIntExpr &i, llvm::StringRef paramName, bool allowZero) {
if (const auto v{GetIntValue(i)}) {
- if (*v < 0) {
+ if (*v < (allowZero ? 0 : 1)) {
context_.Say(GetContext().clauseSource,
"The %s of the %s clause must be "
"a positive integer expression"_err_en_US,
diff --git a/flang/lib/Semantics/check-omp-structure.cpp b/flang/lib/Semantics/check-omp-structure.cpp
index 1f059f747..c0c41c1 100644
--- a/flang/lib/Semantics/check-omp-structure.cpp
+++ b/flang/lib/Semantics/check-omp-structure.cpp
@@ -3145,6 +3145,13 @@ void OmpStructureChecker::Enter(const parser::OmpClause &x) {
}
}
+void OmpStructureChecker::Enter(const parser::OmpClause::Sizes &c) {
+ CheckAllowedClause(llvm::omp::Clause::OMPC_sizes);
+ for (const parser::Cosubscript &v : c.v)
+ RequiresPositiveParameter(llvm::omp::Clause::OMPC_sizes, v,
+ /*paramName=*/"parameter", /*allowZero=*/false);
+}
+
// Following clauses do not have a separate node in parse-tree.h.
CHECK_SIMPLE_CLAUSE(Absent, OMPC_absent)
CHECK_SIMPLE_CLAUSE(Affinity, OMPC_affinity)
@@ -3186,7 +3193,6 @@ CHECK_SIMPLE_CLAUSE(Notinbranch, OMPC_notinbranch)
CHECK_SIMPLE_CLAUSE(Partial, OMPC_partial)
CHECK_SIMPLE_CLAUSE(ProcBind, OMPC_proc_bind)
CHECK_SIMPLE_CLAUSE(Simd, OMPC_simd)
-CHECK_SIMPLE_CLAUSE(Sizes, OMPC_sizes)
CHECK_SIMPLE_CLAUSE(Permutation, OMPC_permutation)
CHECK_SIMPLE_CLAUSE(Uniform, OMPC_uniform)
CHECK_SIMPLE_CLAUSE(Unknown, OMPC_unknown)
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 624b890..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));
}
}
}
@@ -2421,10 +2421,18 @@ void OmpAttributeVisitor::PrivatizeAssociatedLoopIndexAndCheckLoopLevel(
void OmpAttributeVisitor::CheckAssocLoopLevel(
std::int64_t level, const parser::OmpClause *clause) {
if (clause && level != 0) {
- context_.Say(clause->source,
- "The value of the parameter in the COLLAPSE or ORDERED clause must"
- " not be larger than the number of nested loops"
- " following the construct."_err_en_US);
+ switch (clause->Id()) {
+ case llvm::omp::OMPC_sizes:
+ context_.Say(clause->source,
+ "The SIZES clause has more entries than there are nested canonical loops."_err_en_US);
+ break;
+ default:
+ context_.Say(clause->source,
+ "The value of the parameter in the COLLAPSE or ORDERED clause must"
+ " not be larger than the number of nested loops"
+ " following the construct."_err_en_US);
+ break;
+ }
}
}
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-03 23:17:13 +0000