[flang] Allow forward reference to non-default INTEGER dummy

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 #140941.

Author: klausler

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

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,

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 {
@@ -1119,6 +1131,7 @@ class DeclarationVisitor : public ArraySpecVisitor,
   template <typename T>
   Symbol &DeclareEntity(const parser::Name &name, Attrs attrs) {
     Symbol &symbol{MakeSymbol(name, attrs)};
+    ForgetEarlyDeclaredDummyArgument(symbol);
     if (context().HasError(symbol) || symbol.has<T>()) {
       return symbol; // OK or error already reported
     } else if (symbol.has<UnknownDetails>()) {
@@ -1976,6 +1989,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 &);
@@ -5711,9 +5727,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 {
@@ -8467,6 +8485,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) {
@@ -8488,13 +8511,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 differ)"_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);
@@ -9037,11 +9077,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) {
@@ -9258,6 +9293,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));
           },
@@ -9286,6 +9325,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) {

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

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