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

[via flang-commits]

Author: Peter Klausler
Date: 2023-11-13T16:24:43-08:00
New Revision: 94d47e6325fbbccc5adcadd41d4e0ea8ce126fec

URL: https://github.com/llvm/llvm-project/commit/94d47e6325fbbccc5adcadd41d4e0ea8ce126fec
DIFF: https://github.com/llvm/llvm-project/commit/94d47e6325fbbccc5adcadd41d4e0ea8ce126fec.diff

LOG: [flang] Catch nasty order-of-declarations case (#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.

Added: 
    flang/test/Semantics/declarations07.f90

Modified: 
    flang/lib/Semantics/resolve-names.cpp

Removed: 
    


################################################################################
diff  --git a/flang/lib/Semantics/resolve-names.cpp b/flang/lib/Semantics/resolve-names.cpp
index 48522046b145f4d..9b3c0eb8ba93192 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.
@@ -4886,6 +4893,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());
       }
@@ -7635,7 +7645,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