[flang-commits] [flang] 1457125 - [flang] Allow forward reference to non-default INTEGER dummy (#141254)
via flang-commits
flang-commits at lists.llvm.org
Wed May 28 14:01:31 PDT 2025
Author: Peter Klausler
Date: 2025-05-28T14:01:28-07:00
New Revision: 145712555f6cbcfb4c7e07d5ee3459570c2a581a
URL: https://github.com/llvm/llvm-project/commit/145712555f6cbcfb4c7e07d5ee3459570c2a581a
DIFF: https://github.com/llvm/llvm-project/commit/145712555f6cbcfb4c7e07d5ee3459570c2a581a.diff
LOG: [flang] Allow forward reference to non-default INTEGER dummy (#141254)
A dummy argument with an explicit INTEGER type of non-default kind can
be forward-referenced from a specification expression in many Fortran
compilers. Handle by adding type declaration statements to the initial
pass over a specification part's declaration constructs. Emit an
optional warning under -pedantic.
Fixes https://github.com/llvm/llvm-project/issues/140941.
Added:
Modified:
flang/docs/Extensions.md
flang/include/flang/Support/Fortran-features.h
flang/lib/Semantics/resolve-names.cpp
flang/test/Semantics/OpenMP/linear-clause01.f90
flang/test/Semantics/resolve103.f90
Removed:
################################################################################
diff --git a/flang/docs/Extensions.md b/flang/docs/Extensions.md
index 1cc4881438cc1..51969de5ac7fe 100644
--- a/flang/docs/Extensions.md
+++ b/flang/docs/Extensions.md
@@ -291,7 +291,10 @@ end
* DATA statement initialization is allowed for procedure pointers outside
structure constructors.
* Nonstandard intrinsic functions: ISNAN, SIZEOF
-* A forward reference to a default INTEGER scalar dummy argument or
+* A forward reference to an INTEGER dummy argument is permitted to appear
+ in a specification expression, such as an array bound, in a scope with
+ IMPLICIT NONE(TYPE).
+* A forward reference to a default INTEGER scalar
`COMMON` block variable is permitted to appear in a specification
expression, such as an array bound, in a scope with IMPLICIT NONE(TYPE)
if the name of the variable would have caused it to be implicitly typed
diff --git a/flang/include/flang/Support/Fortran-features.h b/flang/include/flang/Support/Fortran-features.h
index 0e18eaedf2139..e696da9042480 100644
--- a/flang/include/flang/Support/Fortran-features.h
+++ b/flang/include/flang/Support/Fortran-features.h
@@ -55,7 +55,7 @@ ENUM_CLASS(LanguageFeature, BackslashEscapes, OldDebugLines,
UndefinableAsynchronousOrVolatileActual, AutomaticInMainProgram, PrintCptr,
SavedLocalInSpecExpr, PrintNamelist, AssumedRankPassedToNonAssumedRank,
IgnoreIrrelevantAttributes, Unsigned, AmbiguousStructureConstructor,
- ContiguousOkForSeqAssociation)
+ ContiguousOkForSeqAssociation, ForwardRefExplicitTypeDummy)
// Portability and suspicious usage warnings
ENUM_CLASS(UsageWarning, Portability, PointerToUndefinable,
diff --git a/flang/lib/Semantics/resolve-names.cpp b/flang/lib/Semantics/resolve-names.cpp
index 93f2150365a1f..57035c57ee16f 100644
--- a/flang/lib/Semantics/resolve-names.cpp
+++ b/flang/lib/Semantics/resolve-names.cpp
@@ -768,10 +768,22 @@ class ScopeHandler : public ImplicitRulesVisitor {
deferImplicitTyping_ = skipImplicitTyping_ = skip;
}
+ void NoteEarlyDeclaredDummyArgument(Symbol &symbol) {
+ earlyDeclaredDummyArguments_.insert(symbol);
+ }
+ bool IsEarlyDeclaredDummyArgument(Symbol &symbol) {
+ return earlyDeclaredDummyArguments_.find(symbol) !=
+ earlyDeclaredDummyArguments_.end();
+ }
+ void ForgetEarlyDeclaredDummyArgument(Symbol &symbol) {
+ earlyDeclaredDummyArguments_.erase(symbol);
+ }
+
private:
Scope *currScope_{nullptr};
FuncResultStack funcResultStack_{*this};
std::map<Scope *, DeferredDeclarationState> deferred_;
+ UnorderedSymbolSet earlyDeclaredDummyArguments_;
};
class ModuleVisitor : public virtual ScopeHandler {
@@ -1970,6 +1982,9 @@ class ResolveNamesVisitor : public virtual ScopeHandler,
Scope &topScope_;
void PreSpecificationConstruct(const parser::SpecificationConstruct &);
+ void EarlyDummyTypeDeclaration(
+ const parser::Statement<common::Indirection<parser::TypeDeclarationStmt>>
+ &);
void CreateCommonBlockSymbols(const parser::CommonStmt &);
void CreateObjectSymbols(const std::list<parser::ObjectDecl> &, Attr);
void CreateGeneric(const parser::GenericSpec &);
@@ -5605,6 +5620,7 @@ Symbol &DeclarationVisitor::DeclareUnknownEntity(
} else {
Symbol &symbol{DeclareEntity<EntityDetails>(name, attrs)};
if (auto *type{GetDeclTypeSpec()}) {
+ ForgetEarlyDeclaredDummyArgument(symbol);
SetType(name, *type);
}
charInfo_.length.reset();
@@ -5681,6 +5697,7 @@ Symbol &DeclarationVisitor::DeclareProcEntity(
symbol.set(Symbol::Flag::Subroutine);
}
} else if (auto *type{GetDeclTypeSpec()}) {
+ ForgetEarlyDeclaredDummyArgument(symbol);
SetType(name, *type);
symbol.set(Symbol::Flag::Function);
}
@@ -5695,6 +5712,7 @@ Symbol &DeclarationVisitor::DeclareObjectEntity(
Symbol &symbol{DeclareEntity<ObjectEntityDetails>(name, attrs)};
if (auto *details{symbol.detailsIf<ObjectEntityDetails>()}) {
if (auto *type{GetDeclTypeSpec()}) {
+ ForgetEarlyDeclaredDummyArgument(symbol);
SetType(name, *type);
}
if (!arraySpec().empty()) {
@@ -5705,9 +5723,11 @@ Symbol &DeclarationVisitor::DeclareObjectEntity(
context().SetError(symbol);
}
} else if (MustBeScalar(symbol)) {
- context().Warn(common::UsageWarning::PreviousScalarUse, name.source,
- "'%s' appeared earlier as a scalar actual argument to a specification function"_warn_en_US,
- name.source);
+ if (!context().HasError(symbol)) {
+ context().Warn(common::UsageWarning::PreviousScalarUse, name.source,
+ "'%s' appeared earlier as a scalar actual argument to a specification function"_warn_en_US,
+ name.source);
+ }
} else if (details->init() || symbol.test(Symbol::Flag::InDataStmt)) {
Say(name, "'%s' was initialized earlier as a scalar"_err_en_US);
} else {
@@ -8461,6 +8481,11 @@ const parser::Name *DeclarationVisitor::ResolveDataRef(
x.u);
}
+static bool TypesMismatchIfNonNull(
+ const DeclTypeSpec *type1, const DeclTypeSpec *type2) {
+ return type1 && type2 && *type1 != *type2;
+}
+
// If implicit types are allowed, ensure name is in the symbol table.
// Otherwise, report an error if it hasn't been declared.
const parser::Name *DeclarationVisitor::ResolveName(const parser::Name &name) {
@@ -8482,13 +8507,30 @@ const parser::Name *DeclarationVisitor::ResolveName(const parser::Name &name) {
symbol->set(Symbol::Flag::ImplicitOrError, false);
if (IsUplevelReference(*symbol)) {
MakeHostAssocSymbol(name, *symbol);
- } else if (IsDummy(*symbol) ||
- (!symbol->GetType() && FindCommonBlockContaining(*symbol))) {
+ } else if (IsDummy(*symbol)) {
CheckEntryDummyUse(name.source, symbol);
+ ConvertToObjectEntity(*symbol);
+ if (IsEarlyDeclaredDummyArgument(*symbol)) {
+ ForgetEarlyDeclaredDummyArgument(*symbol);
+ if (isImplicitNoneType()) {
+ context().Warn(common::LanguageFeature::ForwardRefImplicitNone,
+ name.source,
+ "'%s' was used under IMPLICIT NONE(TYPE) before being explicitly typed"_warn_en_US,
+ name.source);
+ } else if (TypesMismatchIfNonNull(
+ symbol->GetType(), GetImplicitType(*symbol))) {
+ context().Warn(common::LanguageFeature::ForwardRefExplicitTypeDummy,
+ name.source,
+ "'%s' was used before being explicitly typed (and its implicit type would
diff er)"_warn_en_US,
+ name.source);
+ }
+ }
+ ApplyImplicitRules(*symbol);
+ } else if (!symbol->GetType() && FindCommonBlockContaining(*symbol)) {
ConvertToObjectEntity(*symbol);
ApplyImplicitRules(*symbol);
} else if (const auto *tpd{symbol->detailsIf<TypeParamDetails>()};
- tpd && !tpd->attr()) {
+ tpd && !tpd->attr()) {
Say(name,
"Type parameter '%s' was referenced before being declared"_err_en_US,
name.source);
@@ -9031,11 +9073,6 @@ static bool IsLocallyImplicitGlobalSymbol(
return false;
}
-static bool TypesMismatchIfNonNull(
- const DeclTypeSpec *type1, const DeclTypeSpec *type2) {
- return type1 && type2 && *type1 != *type2;
-}
-
// Check and set the Function or Subroutine flag on symbol; false on error.
bool ResolveNamesVisitor::SetProcFlag(
const parser::Name &name, Symbol &symbol, Symbol::Flag flag) {
@@ -9252,6 +9289,10 @@ void ResolveNamesVisitor::PreSpecificationConstruct(
const parser::SpecificationConstruct &spec) {
common::visit(
common::visitors{
+ [&](const parser::Statement<
+ common::Indirection<parser::TypeDeclarationStmt>> &y) {
+ EarlyDummyTypeDeclaration(y);
+ },
[&](const parser::Statement<Indirection<parser::GenericStmt>> &y) {
CreateGeneric(std::get<parser::GenericSpec>(y.statement.value().t));
},
@@ -9280,6 +9321,44 @@ void ResolveNamesVisitor::PreSpecificationConstruct(
spec.u);
}
+void ResolveNamesVisitor::EarlyDummyTypeDeclaration(
+ const parser::Statement<common::Indirection<parser::TypeDeclarationStmt>>
+ &stmt) {
+ context().set_location(stmt.source);
+ const auto &[declTypeSpec, attrs, entities] = stmt.statement.value().t;
+ if (const auto *intrin{
+ std::get_if<parser::IntrinsicTypeSpec>(&declTypeSpec.u)}) {
+ if (const auto *intType{std::get_if<parser::IntegerTypeSpec>(&intrin->u)}) {
+ if (const auto &kind{intType->v}) {
+ if (!parser::Unwrap<parser::KindSelector::StarSize>(*kind) &&
+ !parser::Unwrap<parser::IntLiteralConstant>(*kind)) {
+ return;
+ }
+ }
+ const DeclTypeSpec *type{nullptr};
+ for (const auto &ent : entities) {
+ const auto &objName{std::get<parser::ObjectName>(ent.t)};
+ Resolve(objName, FindInScope(currScope(), objName));
+ if (Symbol * symbol{objName.symbol};
+ symbol && IsDummy(*symbol) && NeedsType(*symbol)) {
+ if (!type) {
+ type = ProcessTypeSpec(declTypeSpec);
+ if (!type || !type->IsNumeric(TypeCategory::Integer)) {
+ break;
+ }
+ }
+ symbol->SetType(*type);
+ NoteEarlyDeclaredDummyArgument(*symbol);
+ // Set the Implicit flag to disable bogus errors from
+ // being emitted later when this declaration is processed
+ // again normally.
+ symbol->set(Symbol::Flag::Implicit);
+ }
+ }
+ }
+ }
+}
+
void ResolveNamesVisitor::CreateCommonBlockSymbols(
const parser::CommonStmt &commonStmt) {
for (const parser::CommonStmt::Block &block : commonStmt.blocks) {
diff --git a/flang/test/Semantics/OpenMP/linear-clause01.f90 b/flang/test/Semantics/OpenMP/linear-clause01.f90
index f95e834c9026c..286def2dba119 100644
--- a/flang/test/Semantics/OpenMP/linear-clause01.f90
+++ b/flang/test/Semantics/OpenMP/linear-clause01.f90
@@ -20,10 +20,8 @@ subroutine linear_clause_02(arg_01, arg_02)
!$omp declare simd linear(val(arg_01))
real, intent(in) :: arg_01(:)
- !ERROR: The list item 'arg_02' specified without the REF 'linear-modifier' must be of INTEGER type
!ERROR: If the `linear-modifier` is REF or UVAL, the list item 'arg_02' must be a dummy argument without the VALUE attribute
!$omp declare simd linear(uval(arg_02))
- !ERROR: The type of 'arg_02' has already been implicitly declared
integer, value, intent(in) :: arg_02
!ERROR: The list item 'var' specified without the REF 'linear-modifier' must be of INTEGER type
diff --git a/flang/test/Semantics/resolve103.f90 b/flang/test/Semantics/resolve103.f90
index 8f55968f43375..0acf2333b9586 100644
--- a/flang/test/Semantics/resolve103.f90
+++ b/flang/test/Semantics/resolve103.f90
@@ -1,8 +1,7 @@
! RUN: not %flang_fc1 -pedantic %s 2>&1 | FileCheck %s
! Test extension: allow forward references to dummy arguments or COMMON
! from specification expressions in scopes with IMPLICIT NONE(TYPE),
-! as long as those symbols are eventually typed later with the
-! same integer type they would have had without IMPLICIT NONE.
+! as long as those symbols are eventually typed later.
!CHECK: warning: 'n1' was used without (or before) being explicitly typed
!CHECK: error: No explicit type declared for dummy argument 'n1'
@@ -19,12 +18,15 @@ subroutine foo2(a, n2)
double precision n2
end
-!CHECK: warning: 'n3' was used without (or before) being explicitly typed
-!CHECK-NOT: error: Dummy argument 'n3'
-subroutine foo3(a, n3)
+!CHECK: warning: 'n3a' was used under IMPLICIT NONE(TYPE) before being explicitly typed
+!CHECK: warning: 'n3b' was used under IMPLICIT NONE(TYPE) before being explicitly typed
+!CHECK-NOT: error: Dummy argument 'n3a'
+!CHECK-NOT: error: Dummy argument 'n3b'
+subroutine foo3(a, n3a, n3b)
implicit none
- real a(n3)
- integer n3
+ integer a(n3a, n3b)
+ integer n3a
+ integer(8) n3b
end
!CHECK: warning: 'n4' was used without (or before) being explicitly typed
More information about the flang-commits
mailing list