[flang] Name resolution for Cray pointers

Resolve the pointer and pointee names in a `BasedPointerStmt` and
enforce some of the constraints on them. There are still some
constraints to be implemented, mainly about what kind of attributes
the pointers and pointees can have.

The rules for these are a little vague. I mostly followed
- Cray Fortran Reference Manual section 9.3.2
- https://gcc.gnu.org/onlinedocs/gfortran/Cray-pointers.html
- VSI Fortran for OpenVMS Language Reference Manual section B.11

Note that the first two use the term "Cray pointer" but the last does
not. That is confusing because you have to know from context whether
it is referring to Cray pointers or Fortran pointers, so I used
"Cray pointer" and "Cray pointee" in error messages to refer to the
two names in the pointer statement.

Original-commit: flang-compiler/f18@cabb112be2
Reviewed-on: https://github.com/flang-compiler/f18/pull/697

flang/lib/semantics/resolve-names.cc

@@ -383,7 +383,7 @@ private:
 // 3. ALLOCATABLE :: x(:)
 // 4. DIMENSION :: x(10)
 // 5. COMMON x(10)
-// 6. TODO: BasedPointerStmt
+// 6. BasedPointerStmt
 class ArraySpecVisitor : public virtual BaseVisitor {
 public:
   void Post(const parser::ArraySpec &);
@@ -768,6 +768,7 @@ public:
   void Post(const parser::CommonBlockObject &);
   bool Pre(const parser::EquivalenceStmt &);
   bool Pre(const parser::SaveStmt &);
+  bool Pre(const parser::BasedPointerStmt &);
 
   void PointerInitialization(
       const parser::Name &, const parser::InitialDataTarget &);
@@ -2696,7 +2697,9 @@ bool DeclarationVisitor::Pre(const parser::BindEntity &x) {
 bool DeclarationVisitor::Pre(const parser::NamedConstantDef &x) {
   auto &name{std::get<parser::NamedConstant>(x.t).v};
   auto &symbol{HandleAttributeStmt(Attr::PARAMETER, name)};
-  if (!ConvertToObjectEntity(symbol)) {
+  if (!ConvertToObjectEntity(symbol) ||
+      symbol.test(Symbol::Flag::CrayPointer) ||
+      symbol.test(Symbol::Flag::CrayPointee)) {
     SayWithDecl(
         name, symbol, "PARAMETER attribute not allowed on '%s'"_err_en_US);
     return false;
@@ -2969,13 +2972,20 @@ Symbol &DeclarationVisitor::DeclareObjectEntity(
 // - A single "*" or "lb:*" might be assumed-size or implied-shape-list
 bool DeclarationVisitor::CheckArraySpec(const parser::Name &name,
     const Symbol &symbol, const ArraySpec &arraySpec) {
-  CHECK(arraySpec.Rank() > 0);
+  if (arraySpec.Rank() == 0) {
+    return true;
+  }
   bool isExplicit{arraySpec.IsExplicitShape()};
   bool isDeferred{arraySpec.IsDeferredShape()};
   bool isImplied{arraySpec.IsImpliedShape()};
   bool isAssumedShape{arraySpec.IsAssumedShape()};
   bool isAssumedSize{arraySpec.IsAssumedSize()};
   bool isAssumedRank{arraySpec.IsAssumedRank()};
+  if (symbol.test(Symbol::Flag::CrayPointee) && !isExplicit && !isAssumedSize) {
+    Say(name,
+        "Cray pointee '%s' must have must have explicit shape or assumed size"_err_en_US);
+    return false;
+  }
   if (IsAllocatableOrPointer(symbol) && !isDeferred && !isAssumedRank) {
     if (symbol.owner().IsDerivedType()) {  // C745
       if (IsAllocatable(symbol)) {
@@ -3639,6 +3649,79 @@ bool DeclarationVisitor::Pre(const parser::StructureConstructor &x) {
   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());
+    }
+    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()) {
+        // No array spec
+        CheckArraySpec(
+            pointeeName, pointee, pointee.get<ObjectEntityDetails>().shape());
+      } else if (pointee.Rank() > 0) {
+        SayWithDecl(pointeeName, pointee,
+            "Array spec was already declared for '%s'"_err_en_US);
+      } else if (CheckArraySpec(pointeeName, pointee, spec)) {
+        pointee.get<ObjectEntityDetails>().set_shape(spec);
+      }
+      ClearArraySpec();
+      currScope().add_crayPointer(pointeeName.source, *pointer);
+    }
+  }
+  return false;
+}
+
 bool DeclarationVisitor::Pre(const parser::NamelistStmt::Group &x) {
   if (!CheckNotInBlock("NAMELIST")) {  // C1107
     return false;

flang/lib/semantics/scope.cc

@@ -92,6 +92,11 @@ void Scope::add_equivalenceSet(EquivalenceSet &&set) {
   equivalenceSets_.emplace_back(std::move(set));
 }
 
+void Scope::add_crayPointer(const SourceName &name, Symbol &pointer) {
+  CHECK(pointer.test(Symbol::Flag::CrayPointer));
+  crayPointers_.emplace(name, &pointer);
+}
+
 Symbol &Scope::MakeCommonBlock(const SourceName &name) {
   const auto it{commonBlocks_.find(name)};
   if (it != commonBlocks_.end()) {

flang/lib/semantics/scope.h

@@ -143,6 +143,9 @@ public:
 
   const std::list<EquivalenceSet> &equivalenceSets() const;
   void add_equivalenceSet(EquivalenceSet &&);
+  // Cray pointers are saved as map of pointee name -> pointer symbol
+  const mapType &crayPointers() const { return crayPointers_; }
+  void add_crayPointer(const SourceName &, Symbol &);
   mapType &commonBlocks() { return commonBlocks_; }
   const mapType &commonBlocks() const { return commonBlocks_; }
   Symbol &MakeCommonBlock(const SourceName &);
@@ -219,6 +222,7 @@ private:
   mapType symbols_;
   mapType commonBlocks_;
   std::list<EquivalenceSet> equivalenceSets_;
+  mapType crayPointers_;
   std::map<SourceName, Scope *> submodules_;
   std::list<DeclTypeSpec> declTypeSpecs_;
   std::string chars_;

flang/lib/semantics/semantics.cc

@@ -188,7 +188,7 @@ void DoDumpSymbols(std::ostream &os, const Scope &scope, int indent) {
   PutIndent(os, indent);
   os << Scope::EnumToString(scope.kind()) << " scope:";
   if (const auto *symbol{scope.symbol()}) {
-    os << ' ' << symbol->name().ToString();
+    os << ' ' << symbol->name();
   }
   os << '\n';
   ++indent;
@@ -217,6 +217,13 @@ void DoDumpSymbols(std::ostream &os, const Scope &scope, int indent) {
     }
     os << '\n';
   }
+  if (!scope.crayPointers().empty()) {
+    PutIndent(os, indent);
+    os << "Cray Pointers:";
+    for (const auto &[pointee, pointer] : scope.crayPointers()) {
+      os << " (" << pointer->name() << ',' << pointee << ')';
+    }
+  }
   for (const auto &pair : scope.commonBlocks()) {
     const auto &symbol{*pair.second};
     PutIndent(os, indent);

flang/lib/semantics/symbol.h

@@ -447,6 +447,7 @@ public:
       Implicit,  // symbol is implicitly typed
       ModFile,  // symbol came from .mod file
       ParentComp,  // symbol is the "parent component" of an extended type
+      CrayPointer, CrayPointee,
       LocalityLocal,  // named in LOCAL locality-spec
       LocalityLocalInit,  // named in LOCAL_INIT locality-spec
       LocalityShared  // named in SHARED locality-spec

flang/test/semantics/CMakeLists.txt

@@ -97,6 +97,7 @@ set(ERROR_TESTS
   resolve58.f90
   resolve59.f90
   resolve60.f90
+  resolve61.f90
   stop01.f90
   structconst01.f90
   structconst02.f90

flang/test/semantics/resolve61.f90

@@ -0,0 +1,128 @@
+! Copyright (c) 2019, NVIDIA CORPORATION.  All rights reserved.
+!
+! Licensed under the Apache License, Version 2.0 (the "License");
+! you may not use this file except in compliance with the License.
+! You may obtain a copy of the License at
+!
+!     http://www.apache.org/licenses/LICENSE-2.0
+!
+! Unless required by applicable law or agreed to in writing, software
+! distributed under the License is distributed on an "AS IS" BASIS,
+! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+! See the License for the specific language governing permissions and
+! limitations under the License.
+
+program p1
+  integer(8) :: a, b, c, d
+  pointer(a, b)
+  !ERROR: 'b' cannot be a Cray pointer as it is already a Cray pointee
+  pointer(b, c)
+  !ERROR: 'a' cannot be a Cray pointee as it is already a Cray pointer
+  pointer(d, a)
+end
+
+program p2
+  pointer(a, c)
+  !ERROR: 'c' was already declared as a Cray pointee
+  pointer(b, c)
+end
+
+program p3
+  real a
+  !ERROR: Cray pointer 'a' must have type INTEGER(8)
+  pointer(a, b)
+end
+
+program p4
+  implicit none
+  real b
+  !ERROR: No explicit type declared for 'd'
+  pointer(a, b), (c, d)
+end
+
+program p5
+  integer(8) a(10)
+  !ERROR: Cray pointer 'a' must be a scalar
+  pointer(a, b)
+end
+
+program p6
+  real b(8)
+  !ERROR: Array spec was already declared for 'b'
+  pointer(a, b(4))
+end
+
+program p7
+  !ERROR: Cray pointee 'b' must have must have explicit shape or assumed size
+  pointer(a, b(:))
+contains
+  subroutine s(x, y)
+    real :: x(*)  ! assumed size
+    real :: y(:)  ! assumed shape
+    !ERROR: Cray pointee 'y' must have must have explicit shape or assumed size
+    pointer(w, y)
+  end
+end
+
+program 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
+  pointer(k, c)
+contains
+  subroutine s
+  end
+end
+
+program p9
+  integer(8), parameter :: k = 2
+  type t
+  end type
+  !ERROR: 't' is not a variable
+  pointer(a, t)
+  !ERROR: 's' is not a variable
+  pointer(b, s)
+  !ERROR: 'k' is not a variable
+  pointer(c, k)
+contains
+  subroutine s
+  end
+end
+
+module m10
+  integer(8) :: a
+  real :: b
+end
+program p10
+  use m10
+  !ERROR: 'b' cannot be a Cray pointee as it is use-associated
+  pointer(a, c),(d, b)
+end
+
+program p11
+  pointer(a, b)
+  !ERROR: PARAMETER attribute not allowed on 'a'
+  parameter(a=2)
+  !ERROR: PARAMETER attribute not allowed on 'b'
+  parameter(b=3)
+end
+
+program p12
+  type t1
+    sequence
+    real c1
+  end type
+  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