[flang-commits] [flang] [flang] Catch nasty order-of-declarations case (PR #71881)

[Peter Klausler via flang-commits]

https://github.com/klausler created https://github.com/llvm/llvm-project/pull/71881

It is possible to declare the rank of an object after that object has been used in the same specification part in a specification function reference whose result or generic resolution may well have depended on the object being apparently a scalar.

Catch this case, and emit a warning -- not an error, yet, due to fear of false positives.

See the new test for examples.

>From aea06c59d855464506301095589a7f23bd612788 Mon Sep 17 00:00:00 2001
From: Peter Klausler <pklausler at nvidia.com>
Date: Thu, 9 Nov 2023 16:15:43 -0800
Subject: [PATCH] [flang] Catch nasty order-of-declarations case

It is possible to declare the rank of an object after that
object has been used in the same specification part in a
specification function reference whose result or generic
resolution may well have depended on the object being
apparently a scalar.

Catch this case, and emit a warning -- not an error, yet,
due to fear of false positives.

See the new test for examples.
---
 flang/lib/Semantics/resolve-names.cpp   | 41 ++++++++++++++++++++++++-
 flang/test/Semantics/declarations07.f90 | 18 +++++++++++
 2 files changed, 58 insertions(+), 1 deletion(-)
 create mode 100644 flang/test/Semantics/declarations07.f90

diff --git a/flang/lib/Semantics/resolve-names.cpp b/flang/lib/Semantics/resolve-names.cpp
index 98773a1b9d6ab45..43d570721567611 100644
--- a/flang/lib/Semantics/resolve-names.cpp
+++ b/flang/lib/Semantics/resolve-names.cpp
@@ -1078,6 +1078,9 @@ class DeclarationVisitor : public ArraySpecVisitor,
   void EndCheckOnIndexUseInOwnBounds(const std::optional<SourceName> &restore) {
     checkIndexUseInOwnBounds_ = restore;
   }
+  void NoteScalarSpecificationArgument(const Symbol &symbol) {
+    mustBeScalar_.emplace(symbol);
+  }
 
 private:
   // The attribute corresponding to the statement containing an ObjectDecl
@@ -1116,6 +1119,7 @@ class DeclarationVisitor : public ArraySpecVisitor,
   std::optional<SourceName> checkIndexUseInOwnBounds_;
   bool hasBindCName_{false};
   bool isVectorType_{false};
+  UnorderedSymbolSet mustBeScalar_;
 
   bool HandleAttributeStmt(Attr, const std::list<parser::Name> &);
   Symbol &HandleAttributeStmt(Attr, const parser::Name &);
@@ -1195,6 +1199,9 @@ class DeclarationVisitor : public ArraySpecVisitor,
     return symbol;
   }
   bool HasCycle(const Symbol &, const Symbol *interface);
+  bool MustBeScalar(const Symbol &symbol) const {
+    return mustBeScalar_.find(symbol) != mustBeScalar_.end();
+  }
 };
 
 // Resolve construct entities and statement entities.
@@ -4879,6 +4886,9 @@ Symbol &DeclarationVisitor::DeclareObjectEntity(
               "The dimensions of '%s' have already been declared"_err_en_US);
           context().SetError(symbol);
         }
+      } else if (MustBeScalar(symbol)) {
+        Say(name,
+            "'%s' appeared earlier as a scalar actual argument to a specification function"_warn_en_US);
       } else {
         details->set_shape(arraySpec());
       }
@@ -7622,7 +7632,36 @@ void ResolveNamesVisitor::HandleCall(
           },
       },
       std::get<parser::ProcedureDesignator>(call.t).u);
-  Walk(std::get<std::list<parser::ActualArgSpec>>(call.t));
+  const auto &arguments{std::get<std::list<parser::ActualArgSpec>>(call.t)};
+  Walk(arguments);
+  // Once an object has appeared in a specification function reference as
+  // a whole scalar actual argument, it cannot be (re)dimensioned later.
+  // The fact that it appeared to be a scalar may determine the resolution
+  // or the result of an inquiry intrinsic function or generic procedure.
+  if (inSpecificationPart_) {
+    for (const auto &argSpec : arguments) {
+      const auto &actual{std::get<parser::ActualArg>(argSpec.t)};
+      if (const auto *expr{
+              std::get_if<common::Indirection<parser::Expr>>(&actual.u)}) {
+        if (const auto *designator{
+                std::get_if<common::Indirection<parser::Designator>>(
+                    &expr->value().u)}) {
+          if (const auto *dataRef{
+                  std::get_if<parser::DataRef>(&designator->value().u)}) {
+            if (const auto *name{std::get_if<parser::Name>(&dataRef->u)};
+                name && name->symbol) {
+              const Symbol &symbol{*name->symbol};
+              const auto *object{symbol.detailsIf<ObjectEntityDetails>()};
+              if (symbol.has<EntityDetails>() ||
+                  (object && !object->IsArray())) {
+                NoteScalarSpecificationArgument(symbol);
+              }
+            }
+          }
+        }
+      }
+    }
+  }
 }
 
 void ResolveNamesVisitor::HandleProcedureName(
diff --git a/flang/test/Semantics/declarations07.f90 b/flang/test/Semantics/declarations07.f90
new file mode 100644
index 000000000000000..8c95c163b043be7
--- /dev/null
+++ b/flang/test/Semantics/declarations07.f90
@@ -0,0 +1,18 @@
+! RUN: %python %S/test_errors.py %s %flang_fc1 -Werror
+! A nasty case of a weird order of declarations - a symbol may appear
+! as an actual argument to a specification function before its rank
+! has been declared.
+program main
+  interface kind
+    pure integer function mykind(x)
+      real, intent(in) :: x(:)
+    end
+  end interface
+  real a, b
+  integer, parameter :: ak = kind(a)
+  integer, parameter :: br = rank(b)
+  !WARNING: 'a' appeared earlier as a scalar actual argument to a specification function
+  dimension a(1)
+  !WARNING: 'b' appeared earlier as a scalar actual argument to a specification function
+  dimension b(1)
+end