[flang] Rework name resolution of Cray pointer declarations

[klausler]

Summary

The current code has redundancy with the infrastructure for
declaration checking that can be replaced by better usage of
the parse tree walking framework. This also fixes LLVM flang
bug #58971.

[PeteSteinfeld]

Aside fromt the question, all builds and tests correctly and looks good.

flang/test/Semantics/resolve61.f90

73

This error used to have a more accurate message. Now we seem to be treating the appearance of t in a pointer statement as a redeclaration. This seems OK to me, but I just wanted to make sure that this is what you intended.

[klausler]

flang/test/Semantics/resolve61.f90

73

It's good, and it's the right message for situations where a name gets declared more than once in a scope and is not one of the two cases where Fortran allows it.

flang/lib/Semantics/resolve-names.cpp

private:
   std::optional<SourceName> prevImplicitNone_;
   std::optional<SourceName> prevImplicitNoneType_;
   std::optional<SourceName> prevParameterStmt_;
 
   bool HandleImplicitNone(const std::list<ImplicitNoneNameSpec> &nameSpecs);
 };
 
 // Track array specifications. They can occur in AttrSpec, EntityDecl,
-// ObjectDecl, DimensionStmt, CommonBlockObject, BasedPointerStmt, and
+// ObjectDecl, DimensionStmt, CommonBlockObject, BasedPointer, and
 // ComponentDecl.
 // 1. INTEGER, DIMENSION(10) :: x
 // 2. INTEGER :: x(10)
 // 3. ALLOCATABLE :: x(:)
 // 4. DIMENSION :: x(10)
 // 5. COMMON x(10)
-// 6. BasedPointerStmt
+// 6. POINTER(p,x(10))
 class ArraySpecVisitor : public virtual BaseVisitor {
 public:
   void Post(const parser::ArraySpec &);
   void Post(const parser::ComponentArraySpec &);
   void Post(const parser::CoarraySpec &);
   void Post(const parser::AttrSpec &) { PostAttrSpec(); }
   void Post(const parser::ComponentAttrSpec &) { PostAttrSpec(); }
 
public:
   bool Pre(const parser::StructureConstructor &);
   bool Pre(const parser::NamelistStmt::Group &);
   bool Pre(const parser::IoControlSpec &);
   bool Pre(const parser::CommonStmt::Block &);
   bool Pre(const parser::CommonBlockObject &);
   void Post(const parser::CommonBlockObject &);
   bool Pre(const parser::EquivalenceStmt &);
   bool Pre(const parser::SaveStmt &);
-  bool Pre(const parser::BasedPointerStmt &);
+  bool Pre(const parser::BasedPointer &);
+  void Post(const parser::BasedPointer &);
 
   void PointerInitialization(
       const parser::Name &, const parser::InitialDataTarget &);
   void PointerInitialization(
       const parser::Name &, const parser::ProcPointerInit &);
   void NonPointerInitialization(
       const parser::Name &, const parser::ConstantExpr &);
   void CheckExplicitInterface(const parser::Name &);
for (const auto &component :
     Walk(std::get<parser::ComponentDataSource>(component.t));
     if (const auto &kw{std::get<std::optional<parser::Keyword>>(component.t)}) {
       FindInTypeOrParents(*typeScope, kw->v);
     }
   }
   return false;
 }
 
-bool DeclarationVisitor::Pre(const parser::BasedPointerStmt &x) {
-  for (const parser::BasedPointer &bp : x.v) {
-    const parser::ObjectName &pointerName{std::get<0>(bp.t)};
-    const parser::ObjectName &pointeeName{std::get<1>(bp.t)};
-    auto *pointer{FindSymbol(pointerName)};
-    if (!pointer) {
-      pointer = &MakeSymbol(pointerName, ObjectEntityDetails{});
-    } else if (!ConvertToObjectEntity(*pointer) || IsNamedConstant(*pointer)) {
-      SayWithDecl(pointerName, *pointer, "'%s' is not a variable"_err_en_US);
-    } else if (pointer->Rank() > 0) {
-      SayWithDecl(pointerName, *pointer,
-          "Cray pointer '%s' must be a scalar"_err_en_US);
-    } else if (pointer->test(Symbol::Flag::CrayPointee)) {
-      Say(pointerName,
-          "'%s' cannot be a Cray pointer as it is already a Cray pointee"_err_en_US);
-    }
-    pointer->set(Symbol::Flag::CrayPointer);
-    const DeclTypeSpec &pointerType{MakeNumericType(TypeCategory::Integer,
-        context().defaultKinds().subscriptIntegerKind())};
-    const auto *type{pointer->GetType()};
-    if (!type) {
-      pointer->SetType(pointerType);
-    } else if (*type != pointerType) {
-      Say(pointerName.source, "Cray pointer '%s' must have type %s"_err_en_US,
-          pointerName.source, pointerType.AsFortran());
-    }
-    // pmk: change parse tree to use DimensionStmt::Declaration in BasedPointerStmt, then change this
-    // routine to a Post()
-    if (ResolveName(pointeeName)) {
-      Symbol &pointee{*pointeeName.symbol};
-      if (pointee.has<UseDetails>()) {
-        Say(pointeeName,
-            "'%s' cannot be a Cray pointee as it is use-associated"_err_en_US);
-        continue;
-      } else if (!ConvertToObjectEntity(pointee) || IsNamedConstant(pointee)) {
-        Say(pointeeName, "'%s' is not a variable"_err_en_US);
-        continue;
-      } else if (pointee.test(Symbol::Flag::CrayPointer)) {
-        Say(pointeeName,
-            "'%s' cannot be a Cray pointee as it is already a Cray pointer"_err_en_US);
-      } else if (pointee.test(Symbol::Flag::CrayPointee)) {
-        Say(pointeeName,
-            "'%s' was already declared as a Cray pointee"_err_en_US);
-      } else {
-        pointee.set(Symbol::Flag::CrayPointee);
-      }
-      if (const auto *pointeeType{pointee.GetType()}) {
-        if (const auto *derived{pointeeType->AsDerived()}) {
-          if (!derived->typeSymbol().get<DerivedTypeDetails>().sequence()) {
-            Say(pointeeName,
-                "Type of Cray pointee '%s' is a non-sequence derived type"_err_en_US);
-          }
-        }
-      }
-      // process the pointee array-spec, if present
-      BeginArraySpec();
-      Walk(std::get<std::optional<parser::ArraySpec>>(bp.t));
-      const auto &spec{arraySpec()};
-      if (!spec.empty()) {
-        auto &details{pointee.get<ObjectEntityDetails>()};
-        if (details.shape().empty()) {
-          details.set_shape(spec);
-        } else {
-          SayWithDecl(pointeeName, pointee,
-              "Array spec was already declared for '%s'"_err_en_US);
-        }
-      }
-      ClearArraySpec();
-      currScope().add_crayPointer(pointeeName.source, *pointer);
-    }
-  }
-  return false;
-}
+bool DeclarationVisitor::Pre(const parser::BasedPointer &) {
+  BeginArraySpec();
+  return true;
+}
+
+void DeclarationVisitor::Post(const parser::BasedPointer &bp) {
+  } else if (!ConvertToObjectEntity(*pointer)) {
+  } else if (IsNamedConstant(*pointer)) {
+        "'%s' is a named constant and may not be a Cray pointer"_err_en_US);
+  } else if (pointer->Rank() > 0) {
+    SayWithDecl(
+        pointerName, *pointer, "Cray pointer '%s' must be a scalar"_err_en_US);
+  const DeclTypeSpec &pointerType{MakeNumericType(
+      TypeCategory::Integer, context().defaultKinds().subscriptIntegerKind())};
+  const parser::ObjectName &pointeeName{std::get<1>(bp.t)};
+  DeclareObjectEntity(pointeeName);
+  if (Symbol * pointee{pointeeName.symbol}) {
+    if (!ConvertToObjectEntity(*pointee)) {
+      return;
+    }
+    if (IsNamedConstant(*pointee)) {
+          "'%s' is a named constant and may not be a Cray pointee"_err_en_US);
+      return;
+    }
+    if (pointee->test(Symbol::Flag::CrayPointer)) {
+    } else if (pointee->test(Symbol::Flag::CrayPointee)) {
+      Say(pointeeName, "'%s' was already declared as a Cray pointee"_err_en_US);
+      pointee->set(Symbol::Flag::CrayPointee);
+    if (const auto *pointeeType{pointee->GetType()}) {
 
 bool DeclarationVisitor::Pre(const parser::NamelistStmt::Group &x) {
   if (!CheckNotInBlock("NAMELIST")) { // C1107
     return false;
   }
   const auto &groupName{std::get<parser::Name>(x.t)};
   auto *groupSymbol{FindInScope(groupName)};
   if (!groupSymbol || !groupSymbol->has<NamelistDetails>()) {

flang/test/Semantics/resolve61.f90

 subroutine p5
   integer(8) a(10)
   !ERROR: Cray pointer 'a' must be a scalar
   pointer(a, b)
 end
 
 subroutine p6
   real b(8)
-  !ERROR: Array spec was already declared for 'b'
+  !ERROR: The dimensions of 'b' have already been declared
   pointer(a, b(4))
 end
 
 subroutine p7
   !ERROR: Cray pointee 'b' must have explicit shape or assumed size
   pointer(a, b(:))
 contains
   subroutine s(x, y)
     real :: x(*)  ! assumed size
     !ERROR: Cray pointee 'y' must have explicit shape or assumed size
     real :: y(:)  ! assumed shape
     pointer(w, y)
   end
 end
 
 subroutine p8
   integer(8), parameter :: k = 2
   type t
   end type
   !ERROR: 't' is not a variable
   pointer(t, a)
   !ERROR: 's' is not a variable
   pointer(s, b)
-  !ERROR: 'k' is not a variable
+  !ERROR: 'k' is a named constant and may not be a Cray pointer
   pointer(k, c)
 contains
   subroutine s
   end
 end
 
 subroutine p9
   integer(8), parameter :: k = 2
   type t
   end type
-  !ERROR: 't' is not a variable
+  !ERROR: 't' is already declared in this scoping unit
   pointer(a, t)
-  !ERROR: 's' is not a variable
+  !ERROR: Declaration of 's' conflicts with its use as internal procedure
   pointer(b, s)
-  !ERROR: 'k' is not a variable
+  !ERROR: 'k' is a named constant and may not be a Cray pointee
   pointer(c, k)
 contains
   subroutine s
   end
 end
 
 module m10
   integer(8) :: a
   real :: b
 end
 subroutine p10
   use m10
-  !ERROR: 'b' cannot be a Cray pointee as it is use-associated
+  !ERROR: 'b' is use-associated from module 'm10' and cannot be re-declared
   pointer(a, c),(d, b)
 end
 
 subroutine p11
   pointer(a, b)
   !ERROR: PARAMETER attribute not allowed on 'a'
   parameter(a=2)
   !ERROR: PARAMETER attribute not allowed on 'b'
type t2
     integer c2
   end type
   type(t1) :: x1
   type(t2) :: x2
   pointer(a, x1)
   !ERROR: Type of Cray pointee 'x2' is a non-sequence derived type
   pointer(b, x2)
 end
+
+subroutine p13
+  pointer(ip, x)
+ contains
+  subroutine s
+    pointer(ip, x) ! ok, local declaration
+  end
+end