[flang] Implement cross-set EQUIVALENCE impossibility checking

[klausler]

Summary

Implement cross-set EQUIVALENCE impossibility checking; fixes
an infinite loop on an erroneous test. Also fix substring
reference offset calculations in EQUIVALENCE discovered to
be incorrect during testing.

flang/include/flang/Semantics/scope.h

 using common::ConstantSubscript;
 
 class SemanticsContext;
 
 // An equivalence object is represented by a symbol for the variable name,
 // the indices for an array element, and the lower bound for a substring.
 struct EquivalenceObject {
   EquivalenceObject(Symbol &symbol, std::vector<ConstantSubscript> subscripts,
-      std::optional<ConstantSubscript> substringStart)
-      : symbol{symbol}, subscripts{subscripts}, substringStart{substringStart} {
-  }
+      std::optional<ConstantSubscript> substringStart, parser::CharBlock source)
+      : symbol{symbol}, subscripts{subscripts},
+        substringStart{substringStart}, source{source} {}
+
   bool operator==(const EquivalenceObject &) const;
   bool operator<(const EquivalenceObject &) const;
   std::string AsFortran() const;
 
   Symbol &symbol;
   std::vector<ConstantSubscript> subscripts; // for array elem
   std::optional<ConstantSubscript> substringStart;
+  parser::CharBlock source;
 };
 using EquivalenceSet = std::vector<EquivalenceObject>;
 
 class Scope {
   using mapType = std::map<SourceName, MutableSymbolRef>;
 
 public:
   ENUM_CLASS(Kind, Global, Module, MainProgram, Subprogram, BlockData,

flang/lib/Semantics/compute-offsets.cpp

 //===-- lib/Semantics/compute-offsets.cpp -----------------------*- C++ -*-===//
 //
 // Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
 // See https://llvm.org/LICENSE.txt for license information.
 // SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception
 //
 //===----------------------------------------------------------------------===//
 
 #include "compute-offsets.h"
 #include "../../runtime/descriptor.h"
+#include "flang/Evaluate/fold-designator.h"
 #include "flang/Evaluate/fold.h"
 #include "flang/Evaluate/shape.h"
 #include "flang/Evaluate/type.h"
 #include "flang/Semantics/scope.h"
 #include "flang/Semantics/semantics.h"
 #include "flang/Semantics/symbol.h"
 #include "flang/Semantics/tools.h"
 #include "flang/Semantics/type.h"
struct SizeAndAlignment {
     SizeAndAlignment() {}
     SizeAndAlignment(std::size_t bytes) : size{bytes}, alignment{bytes} {}
     SizeAndAlignment(std::size_t bytes, std::size_t align)
         : size{bytes}, alignment{align} {}
     std::size_t size{0};
     std::size_t alignment{0};
   };
   struct SymbolAndOffset {
-    Symbol *symbol{nullptr};
-    std::size_t offset{0};
+    SymbolAndOffset(Symbol &s, std::size_t off, const EquivalenceObject &obj)
+        : symbol{&s}, offset{off}, object{&obj} {}
+    SymbolAndOffset(const SymbolAndOffset &) = default;
+    Symbol *symbol;
+    std::size_t offset;
+    const EquivalenceObject *object;
   };
 
   void Compute(Scope &);
   void DoScope(Scope &);
   void DoCommonBlock(Symbol &);
-  void DoEquivalenceSet(EquivalenceSet &);
-  std::size_t GetOffset(SymbolAndOffset &);
+  void DoEquivalenceSet(const EquivalenceSet &);
+  SymbolAndOffset Resolve(const SymbolAndOffset &);
   std::size_t ComputeOffset(const EquivalenceObject &);
   void DoSymbol(Symbol &);
   SizeAndAlignment GetSizeAndAlignment(const Symbol &);
-  SizeAndAlignment GetElementSize(const Symbol &, bool isSubstring = false);
+  SizeAndAlignment GetElementSize(const Symbol &);
   std::size_t CountElements(const Symbol &);
   static std::size_t Align(std::size_t, std::size_t);
   static SizeAndAlignment GetIntrinsicSizeAndAlignment(TypeCategory, int);
 
   SemanticsContext &context_;
   evaluate::FoldingContext &foldingContext_{context_.foldingContext()};
   std::size_t offset_{0};
   std::size_t alignment_{0};
void ComputeOffsetsHelper::DoScope(Scope &scope) {
   if (scope.symbol() && scope.IsParameterizedDerivedType()) {
     return; // only process instantiations of parameterized derived types
   }
   // Symbols in common block get offsets from the beginning of the block
   for (auto &pair : scope.commonBlocks()) {
     DoCommonBlock(*pair.second);
   }
   // Build dependents_ from equivalences: symbol -> symbol+offset
-  for (EquivalenceSet &set : scope.equivalenceSets()) {
+  for (const EquivalenceSet &set : scope.equivalenceSets()) {
     DoEquivalenceSet(set);
   }
   offset_ = 0;
   alignment_ = 0;
   for (auto &symbol : scope.GetSymbols()) {
     if (!InCommonBlock(*symbol) &&
         dependents_.find(symbol) == dependents_.end()) {
       DoSymbol(*symbol);
     }
   }
   for (auto &[symbol, dep] : dependents_) {
     if (symbol->size() == 0) {
       SizeAndAlignment s{GetSizeAndAlignment(*symbol)};
       symbol->set_size(s.size);
-      symbol->set_offset(GetOffset(dep));
+      SymbolAndOffset resolved{Resolve(dep)};
+      symbol->set_offset(dep.symbol->offset() + resolved.offset);
       offset_ = std::max(offset_, symbol->offset() + symbol->size());
     }
   }
   scope.set_size(offset_);
   scope.set_alignment(alignment_);
 }
 
-std::size_t ComputeOffsetsHelper::GetOffset(SymbolAndOffset &dep) {
+auto ComputeOffsetsHelper::Resolve(const SymbolAndOffset &dep)
+    -> SymbolAndOffset {
   auto it{dependents_.find(*dep.symbol)};
   if (it == dependents_.end()) {
-    return dep.symbol->offset() + dep.offset;
+    return dep;
   } else {
-    return GetOffset(it->second) + dep.offset;
+    SymbolAndOffset result{Resolve(it->second)};
+    result.offset += dep.offset;
+    result.object = dep.object;
+    return result;
   }
 }
 
 void ComputeOffsetsHelper::DoCommonBlock(Symbol &commonBlock) {
   auto &details{commonBlock.get<CommonBlockDetails>()};
   offset_ = 0;
   alignment_ = 0;
   for (auto &object : details.objects()) {
     DoSymbol(*object);
   }
   commonBlock.set_size(offset_);
   details.set_alignment(alignment_);
 }
 
-void ComputeOffsetsHelper::DoEquivalenceSet(EquivalenceSet &set) {
+void ComputeOffsetsHelper::DoEquivalenceSet(const EquivalenceSet &set) {
   std::vector<SymbolAndOffset> symbolOffsets;
-  SymbolAndOffset max;
-  for (EquivalenceObject &object : set) {
+  std::optional<std::size_t> representative;
+  for (const EquivalenceObject &object : set) {
     std::size_t offset{ComputeOffset(object)};
-    symbolOffsets.push_back({&object.symbol, offset});
-    if (offset >= max.offset) {
-      max.offset = offset;
-      max.symbol = &object.symbol;
+    SymbolAndOffset resolved{
+        Resolve(SymbolAndOffset{object.symbol, offset, object})};
+    symbolOffsets.push_back(resolved);
+    if (!representative ||
+        resolved.offset >= symbolOffsets[*representative].offset) {
+      // The equivalenced object with the largest offset from its resolved
+      // symbol will be the representative of this set, since the offsets
+      // of the other objects will be positive relative to it.
+      representative = symbolOffsets.size() - 1;
+    }
+  }
+  CHECK(representative);
+  const SymbolAndOffset &base{symbolOffsets[*representative]};
+  for (const auto &[symbol, offset, object] : symbolOffsets) {
+    if (symbol == base.symbol) {
+      if (offset != base.offset) {
+        auto x{evaluate::OffsetToDesignator(
+            context_.foldingContext(), *symbol, base.offset, 1)};
+        auto y{evaluate::OffsetToDesignator(
+            context_.foldingContext(), *symbol, offset, 1)};
+        if (x && y) {
+          context_
+              .Say(base.object->source,
+                  "'%s' and '%s' cannot have the same first storage unit"_err_en_US,
+                  x->AsFortran(), y->AsFortran())
+              .Attach(object->source, "Incompatible reference to '%s'"_en_US,
+                  y->AsFortran());
+        } else { // error recovery
+          context_
+              .Say(base.object->source,
+                  "'%s' (offset %zd bytes and %zd bytes) cannot have the same first storage unit"_err_en_US,
+                  symbol->name(), base.offset, offset)
+              .Attach(object->source,
+                  "Incompatible reference to '%s' offset %zd bytes"_en_US,
+                  symbol->name(), offset);
         }
       }
-  CHECK(max.symbol);
-  for (auto &[symbol, offset] : symbolOffsets) {
-    if (symbol != max.symbol) {
-      dependents_.emplace(
-          *symbol, SymbolAndOffset{max.symbol, max.offset - offset});
+    } else {
+      dependents_.emplace(*symbol,
+          SymbolAndOffset{*base.symbol, base.offset - offset, *object});
     }
   }
 }
 
 // Offset of this equivalence object from the start of its variable.
 std::size_t ComputeOffsetsHelper::ComputeOffset(
     const EquivalenceObject &object) {
   std::size_t offset{0};
-  if (object.substringStart) {
-    offset = *object.substringStart - 1;
-  }
   if (!object.subscripts.empty()) {
     const ArraySpec &shape{object.symbol.get<ObjectEntityDetails>().shape()};
     auto lbound{[&](std::size_t i) {
       return *ToInt64(shape[i].lbound().GetExplicit());
     }};
     auto ubound{[&](std::size_t i) {
       return *ToInt64(shape[i].ubound().GetExplicit());
     }};
     for (std::size_t i{object.subscripts.size() - 1};;) {
       offset += object.subscripts[i] - lbound(i);
       if (i == 0) {
         break;
       }
       --i;
       offset *= ubound(i) - lbound(i) + 1;
     }
   }
-  return offset *
-      GetElementSize(object.symbol, object.substringStart.has_value()).size;
+  auto result{offset * GetElementSize(object.symbol).size};
+  if (object.substringStart) {
+    int kind{context_.defaultKinds().GetDefaultKind(TypeCategory::Character)};
+    if (const DeclTypeSpec * type{object.symbol.GetType()}) {
+      if (const IntrinsicTypeSpec * intrinsic{type->AsIntrinsic()}) {
+        kind = ToInt64(intrinsic->kind()).value_or(kind);
+      }
+    }
+    result += kind * (*object.substringStart - 1);
+  }
+  return result;
 }
 
 void ComputeOffsetsHelper::DoSymbol(Symbol &symbol) {
   if (symbol.has<TypeParamDetails>() || symbol.has<SubprogramDetails>() ||
       symbol.has<UseDetails>() || symbol.has<ProcBindingDetails>()) {
     return; // these have type but no size
   }
   SizeAndAlignment s{GetSizeAndAlignment(symbol)};
auto ComputeOffsetsHelper::GetSizeAndAlignment(const Symbol &symbol)
   std::size_t elements{CountElements(symbol)};
   if (elements > 1) {
     result.size = Align(result.size, result.alignment);
   }
   result.size *= elements;
   return result;
 }
 
-auto ComputeOffsetsHelper::GetElementSize(
-    const Symbol &symbol, bool isSubstring) -> SizeAndAlignment {
+auto ComputeOffsetsHelper::GetElementSize(const Symbol &symbol)
+    -> SizeAndAlignment {
   const DeclTypeSpec *type{symbol.GetType()};
   if (!type) {
     return {};
   }
   // TODO: The size of procedure pointers is not yet known
   // and is independent of rank (and probably also the number
   // of length type parameters).
   if (IsDescriptor(symbol) || IsProcedure(symbol)) {
     int lenParams{0};
     if (const DerivedTypeSpec * derived{type->AsDerived()}) {
       lenParams = CountLenParameters(*derived);
     }
     std::size_t size{
         runtime::Descriptor::SizeInBytes(symbol.Rank(), false, lenParams)};
     return {size, maxAlignment};
   }
   SizeAndAlignment result;
   if (const IntrinsicTypeSpec * intrinsic{type->AsIntrinsic()}) {
     if (auto kind{ToInt64(intrinsic->kind())}) {
       result = GetIntrinsicSizeAndAlignment(intrinsic->category(), *kind);
     }
-    if (!isSubstring && type->category() == DeclTypeSpec::Character) {
+    if (type->category() == DeclTypeSpec::Character) {
       ParamValue length{type->characterTypeSpec().length()};
       CHECK(length.isExplicit()); // else should be descriptor
       if (MaybeIntExpr lengthExpr{length.GetExplicit()}) {
         if (auto lengthInt{ToInt64(*lengthExpr)}) {
           result.size *= *lengthInt;
         }
       }
     }

flang/lib/Semantics/resolve-names-utils.cpp

if (CheckDesignator(designator)) {
     if (subscripts.empty() && symbol.IsObjectArray()) {
       // record a whole array as its first element
       for (const ShapeSpec &spec : symbol.get<ObjectEntityDetails>().shape()) {
         auto &lbound{spec.lbound().GetExplicit().value()};
         subscripts.push_back(evaluate::ToInt64(lbound).value());
       }
     }
     auto substringStart{currObject_.substringStart};
-    currSet_.emplace_back(symbol, subscripts, substringStart);
+    currSet_.emplace_back(
+        symbol, subscripts, substringStart, designator.source);
     PropagateSaveAttr(currSet_.back(), currSet_);
   }
   currObject_ = {};
 }
 
 void EquivalenceSets::FinishSet(const parser::CharBlock &source) {
   std::set<std::size_t> existing; // indices of sets intersecting this one
   for (auto &obj : currSet_) {

 }
 
 // Move objects from src to sets_[dstIndex]
 void EquivalenceSets::MergeInto(const parser::CharBlock &source,
     EquivalenceSet &src, std::size_t dstIndex) {
   EquivalenceSet &dst{sets_[dstIndex]};
   PropagateSaveAttr(dst, src);
   for (const auto &obj : src) {
-    if (const auto *obj2{Find(dst, obj.symbol)}) {
-      if (obj == *obj2) {
-        continue; // already there
-      }
-      context_.Say(source,
-          "'%s' and '%s' cannot have the same first storage unit"_err_en_US,
-          obj2->AsFortran(), obj.AsFortran());
-    } else {
-      dst.push_back(obj);
-    }
     objectToSet_[obj] = dstIndex;
   }
   PropagateSaveAttr(src, dst);
   src.clear();
 }
 
 // If set has an object with this symbol, return it.
 const EquivalenceObject *EquivalenceSets::Find(

flang/test/Semantics/equivalence01.f90

subroutine s9
   !ERROR: Substring with zero length is not allowed in an equivalence set
   equivalence(c(n:1), i)
   !ERROR: Array with nonconstant subscript 'j-1' is not allowed in an equivalence set
   equivalence(d(j-1), i)
   !ERROR: Array section 'd(1:n)' is not allowed in an equivalence set
   equivalence(d(1:n), i)
   character(4) :: a(10)
   equivalence(c, a(10)(1:2))
-  !ERROR: 'a(10)' and 'a(10)(2:)' cannot have the same first storage unit
+  !ERROR: 'a(10_8)(2_8:2_8)' and 'a(10_8)(1_8:1_8)' cannot have the same first storage unit
   equivalence(c, a(10)(2:3))
 end
 
 subroutine s10
   integer, parameter :: i(4) = [1, 2, 3, 4]
   real :: x(10)
   real :: y(4)
   !ERROR: Array with vector subscript 'i' is not allowed in an equivalence set
module s13
   double precision :: d
   double complex :: e
   !OK: d and e are considered to be a default kind numeric type
   equivalence(c, d, e)
 end
 
 module s14
   real :: a(10), b, c, d
-  !ERROR: 'a(1)' and 'a(2)' cannot have the same first storage unit
+  !ERROR: 'a(2_8)' and 'a(1_8)' cannot have the same first storage unit
   equivalence(a(1), a(2))
   equivalence(b, a(3))
-  !ERROR: 'a(3)' and 'a(4)' cannot have the same first storage unit
+  !ERROR: 'a(4_8)' and 'a(3_8)' cannot have the same first storage unit
   equivalence(a(4), b)
   equivalence(c, a(5))
+  !ERROR: 'a(6_8)' and 'a(5_8)' cannot have the same first storage unit
   equivalence(a(6), d)
-  !ERROR: 'a(5)' and 'a(6)' cannot have the same first storage unit
   equivalence(c, d)
 end
+
+module s15
+  real :: a(2), b(2)
+  equivalence(a(2),b(1))
+  !ERROR: 'a(3_8)' and 'a(1_8)' cannot have the same first storage unit
+  equivalence(b(2),a(1))
+end module