[flang] Allow extension cases of EQUIVALENCE with optional warnings

[klausler]

Summary

EQUIVALENCE storage association of objects whose types are not
both default-kind numeric storage sequences, or not both default-kind
character storage sequences, are not standard conformant.
However, most Fortran compilers admit such usage, with warnings
in strict conformance mode. This patch allos EQUIVALENCE of objects
that have sequence types that are either identical, both numeric
sequences (of default kind or not), or both character sequences.
Non-sequence types, and sequences types that are not homogeneously
numeric or character, remain errors.

flang/docs/Extensions.md

   not be known (e.g., `IAND(X'1',X'2')`).
 * BOZ literals can also be used as REAL values in some contexts where the
   type is unambiguous, such as initializations of REAL parameters.
-* EQUIVALENCE of numeric and character sequences (a ubiquitous extension)
+* EQUIVALENCE of numeric and character sequences (a ubiquitous extension),
+  as well as of sequences of non-default kinds of numeric types
+  with each other.
 * Values for whole anonymous parent components in structure constructors
   (e.g., `EXTENDEDTYPE(PARENTTYPE(1,2,3))` rather than `EXTENDEDTYPE(1,2,3)`
    or `EXTENDEDTYPE(PARENTTYPE=PARENTTYPE(1,2,3))`).

flang/include/flang/Common/Fortran-features.h

     OmitFunctionDummies, CrayPointer, Hollerith, ArithmeticIF, Assign,
     AssignedGOTO, Pause, OpenACC, OpenMP, CruftAfterAmpersand, ClassicCComments,
     AdditionalFormats, BigIntLiterals, RealDoControls,
-    EquivalenceNumericWithCharacter, AdditionalIntrinsics, AnonymousParents,
+    EquivalenceNumericWithCharacter, EquivalenceNonDefaultNumeric,
+    EquivalenceSameNonSequence, AdditionalIntrinsics, AnonymousParents,
     OldLabelDoEndStatements, LogicalIntegerAssignment, EmptySourceFile,
     ProgramReturn, ImplicitNoneTypeNever, ImplicitNoneTypeAlways,
     ForwardRefDummyImplicitNone, OpenAccessAppend, BOZAsDefaultInteger,

flang/include/flang/Evaluate/tools.h

 const Symbol &GetUsedModule(const UseDetails &);
 const Symbol *FindFunctionResult(const Symbol &);
 
+// Type compatibility predicate: are x and y effectively the same type?
+// Uses DynamicType::IsTkCompatible(), which handles the case of distinct
+// but identical derived types.
+bool AreTkCompatibleTypes(const DeclTypeSpec *x, const DeclTypeSpec *y);
+
 } // namespace Fortran::semantics
 
 #endif // FORTRAN_EVALUATE_TOOLS_H_

flang/lib/Evaluate/tools.cpp

   return DEREF(owner_).context();
 }
 
+bool AreTkCompatibleTypes(const DeclTypeSpec *x, const DeclTypeSpec *y) {
+  if (x && y) {
+    if (auto xDt{evaluate::DynamicType::From(*x)}) {
+      if (auto yDt{evaluate::DynamicType::From(*y)}) {
+        return xDt->IsTkCompatibleWith(*yDt);
+      }
+    }
+  }
+  return false;
+}
+
 } // namespace Fortran::semantics

flang/lib/Parser/Fortran-parsers.cpp

             "CHARACTER" >> maybe(Parser<CharSelector>{}))),
         construct<IntrinsicTypeSpec>(construct<IntrinsicTypeSpec::Logical>(
             "LOGICAL" >> maybe(kindSelector))),
-        construct<IntrinsicTypeSpec>("DOUBLE COMPLEX" >>
-            extension<LanguageFeature::DoubleComplex>(
-                construct<IntrinsicTypeSpec::DoubleComplex>())),
+        extension<LanguageFeature::DoubleComplex>(construct<IntrinsicTypeSpec>(
+            "DOUBLE COMPLEX" >> construct<IntrinsicTypeSpec::DoubleComplex>())),
         extension<LanguageFeature::Byte>(
             construct<IntrinsicTypeSpec>(construct<IntegerTypeSpec>(
                 "BYTE" >> construct<std::optional<KindSelector>>(pure(1)))))))

flang/lib/Parser/basic-parsers.h

     auto at{state.GetLocation()};
     auto result{parser_.Parse(state)};
     if (result) {
-      state.Nonstandard(
-          CharBlock{at, state.GetLocation()}, LF, "nonstandard usage"_en_US);
+      state.Nonstandard(CharBlock{at, std::max(state.GetLocation(), at + 1)},
+          LF, "nonstandard usage"_en_US);
     }
     return result;
   }

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

   bool CheckSubstringBound(const parser::Expr &, bool);
   bool IsCharacterSequenceType(const DeclTypeSpec *);
   bool IsDefaultKindNumericType(const IntrinsicTypeSpec &);
-  bool IsNumericSequenceType(const DeclTypeSpec *);
-  bool IsSequenceType(
+  bool IsDefaultNumericSequenceType(const DeclTypeSpec *);
+  static bool IsAnyNumericSequenceType(const DeclTypeSpec *);
+  static bool IsSequenceType(
       const DeclTypeSpec *, std::function<bool(const IntrinsicTypeSpec &)>);
 
   SemanticsContext &context_;

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

 
 #include "resolve-names-utils.h"
 #include "flang/Common/Fortran-features.h"
+#include "flang/Common/Fortran.h"
 #include "flang/Common/idioms.h"
 #include "flang/Common/indirection.h"
 #include "flang/Evaluate/fold.h"

   currSet_.clear();
 }
 
-// Report an error if sym1 and sym2 cannot be in the same equivalence set.
+// Report an error or warning if sym1 and sym2 cannot be in the same equivalence
+// set.
 bool EquivalenceSets::CheckCanEquivalence(
     const parser::CharBlock &source, const Symbol &sym1, const Symbol &sym2) {
   std::optional<parser::MessageFixedText> msg;
   const DeclTypeSpec *type1{sym1.GetType()};
   const DeclTypeSpec *type2{sym2.GetType()};
-  bool isNum1{IsNumericSequenceType(type1)};
-  bool isNum2{IsNumericSequenceType(type2)};
+  bool isDefaultNum1{IsDefaultNumericSequenceType(type1)};
+  bool isAnyNum1{IsAnyNumericSequenceType(type1)};
+  bool isDefaultNum2{IsDefaultNumericSequenceType(type2)};
+  bool isAnyNum2{IsAnyNumericSequenceType(type2)};
   bool isChar1{IsCharacterSequenceType(type1)};
   bool isChar2{IsCharacterSequenceType(type2)};
   if (sym1.attrs().test(Attr::PROTECTED) &&
       !sym2.attrs().test(Attr::PROTECTED)) { // C8114
     msg = "Equivalence set cannot contain '%s'"
           " with PROTECTED attribute and '%s' without"_err_en_US;
-  } else if (isNum1) {
+  } else if ((isDefaultNum1 && isDefaultNum2) || (isChar1 && isChar2)) {
+    // ok & standard conforming
+  } else if (!(isAnyNum1 || isChar1) &&
+      !(isAnyNum2 || isChar2)) { // C8110 - C8113
+    if (AreTkCompatibleTypes(type1, type2)) {
+      if (context_.ShouldWarn(LanguageFeature::EquivalenceSameNonSequence)) {
+        msg = "nonstandard: Equivalence set contains '%s' and '%s' with same "
+              "type "
+              "that is neither numeric nor character sequence type"_en_US;
+      }
+    } else {
+      msg = "Equivalence set cannot contain '%s' and '%s' with distinct types "
+            "that are not both numeric or character sequence types"_err_en_US;
+    }
+  } else if (isAnyNum1) {
     if (isChar2) {
       if (context_.ShouldWarn(
               LanguageFeature::EquivalenceNumericWithCharacter)) {
-        msg = "Equivalence set contains '%s' that is numeric sequence "
+        msg = "nonstandard: Equivalence set contains '%s' that is numeric "
+              "sequence "
               "type and '%s' that is character"_en_US;
       }
-    } else if (!isNum2) { // C8110
-      msg = "Equivalence set cannot contain '%s'"
-            " that is numeric sequence type and '%s' that is not"_err_en_US;
-    }
-  } else if (isChar1) {
-    if (isNum2) {
-      if (context_.ShouldWarn(
-              LanguageFeature::EquivalenceNumericWithCharacter)) {
-        msg = "Equivalence set contains '%s' that is character sequence "
-              "type and '%s' that is numeric"_en_US;
+    } else if (isAnyNum2 &&
+        context_.ShouldWarn(LanguageFeature::EquivalenceNonDefaultNumeric)) {
+      if (isDefaultNum1) {
+        msg =
+            "nonstandard: Equivalence set contains '%s' that is a default "
+            "numeric "
+            "sequence type and '%s' that is numeric with non-default kind"_en_US;
+      } else if (!isDefaultNum2) {
+        msg = "nonstandard: Equivalence set contains '%s' and '%s' that are "
+              "numeric "
+              "sequence types with non-default kinds"_en_US;
       }
-    } else if (!isChar2) { // C8111
-      msg = "Equivalence set cannot contain '%s'"
-            " that is character sequence type and '%s' that is not"_err_en_US;
     }
-  } else if (!isNum2 && !isChar2 && *type1 != *type2) { // C8112, C8113
-    msg = "Equivalence set cannot contain '%s' and '%s' with different types"
-          " that are neither numeric nor character sequence types"_err_en_US;
   }
   if (msg) {
     context_.Say(source, std::move(*msg), sym1.name(), sym2.name());

 // Numeric or logical type of default kind or DOUBLE PRECISION or DOUBLE COMPLEX
 bool EquivalenceSets::IsDefaultKindNumericType(const IntrinsicTypeSpec &type) {
   if (auto kind{evaluate::ToInt64(type.kind())}) {
-    auto category{type.category()};
-    auto defaultKind{context_.GetDefaultKind(category)};
-    switch (category) {
+    switch (type.category()) {
     case TypeCategory::Integer:
     case TypeCategory::Logical:
-      return *kind == defaultKind;
+      return *kind == context_.GetDefaultKind(TypeCategory::Integer);
     case TypeCategory::Real:
     case TypeCategory::Complex:
-      return *kind == defaultKind || *kind == context_.doublePrecisionKind();
+      return *kind == context_.GetDefaultKind(TypeCategory::Real) ||
+          *kind == context_.doublePrecisionKind();
     default:
       return false;
     }

   return false;
 }
 
-bool EquivalenceSets::IsNumericSequenceType(const DeclTypeSpec *type) {
+bool EquivalenceSets::IsDefaultNumericSequenceType(const DeclTypeSpec *type) {
   return IsSequenceType(type, [&](const IntrinsicTypeSpec &type) {
     return IsDefaultKindNumericType(type);
   });
 }
 
+bool EquivalenceSets::IsAnyNumericSequenceType(const DeclTypeSpec *type) {
+  return IsSequenceType(type, [&](const IntrinsicTypeSpec &type) {
+    return type.category() == TypeCategory::Logical ||
+        common::IsNumericTypeCategory(type.category());
+  });
+}
+
 // Is type an intrinsic type that satisfies predicate or a sequence type
 // whose components do.
 bool EquivalenceSets::IsSequenceType(const DeclTypeSpec *type,

flang/test/Semantics/equivalence01.f90

-!RUN: %python %S/test_errors.py %s %flang_fc1
+!RUN: not %flang_fc1 -pedantic %s 2>&1 | FileCheck %s
 subroutine s1
   integer i, j
   real r(2)
-  !ERROR: Equivalence set must have more than one object
+  !CHECK: error: Equivalence set must have more than one object
   equivalence(i, j),(r(1))
 end
 

     integer :: b(10)
   end type
   type(t) :: x
-  !ERROR: Derived type component 'x%a' is not allowed in an equivalence set
+  !CHECK: error: Derived type component 'x%a' is not allowed in an equivalence set
   equivalence(x%a, i)
-  !ERROR: Derived type component 'x%b(2)' is not allowed in an equivalence set
+  !CHECK: error: Derived type component 'x%b(2)' is not allowed in an equivalence set
   equivalence(i, x%b(2))
 end
 
 integer function f3(x)
   real x
-  !ERROR: Dummy argument 'x' is not allowed in an equivalence set
+  !CHECK: error: Dummy argument 'x' is not allowed in an equivalence set
   equivalence(i, x)
-  !ERROR: Function result 'f3' is not allow in an equivalence set
+  !CHECK: error: Function result 'f3' is not allow in an equivalence set
   equivalence(f3, i)
 end
 
 subroutine s4
   integer :: y
-  !ERROR: Pointer 'x' is not allowed in an equivalence set
-  !ERROR: Allocatable variable 'y' is not allowed in an equivalence set
+  !CHECK: error: Pointer 'x' is not allowed in an equivalence set
+  !CHECK: error: Allocatable variable 'y' is not allowed in an equivalence set
   equivalence(x, y)
   real, pointer :: x
   allocatable :: y

   integer, parameter :: k = 123
   real :: x(10)
   real, save :: y[1:*]
-  !ERROR: Coarray 'y' is not allowed in an equivalence set
+  !CHECK: error: Coarray 'y' is not allowed in an equivalence set
   equivalence(x, y)
-  !ERROR: Variable 'z' with BIND attribute is not allowed in an equivalence set
+  !CHECK: error: Variable 'z' with BIND attribute is not allowed in an equivalence set
   equivalence(x, z)
-  !ERROR: Variable 'z' with BIND attribute is not allowed in an equivalence set
+  !CHECK: error: Variable 'z' with BIND attribute is not allowed in an equivalence set
   equivalence(x(2), z(3))
   real, bind(C) :: z(10)
-  !ERROR: Named constant 'k' is not allowed in an equivalence set
+  !CHECK: error: Named constant 'k' is not allowed in an equivalence set
   equivalence(x(2), k)
-  !ERROR: Variable 'w' in common block with BIND attribute is not allowed in an equivalence set
+  !CHECK: error: Variable 'w' in common block with BIND attribute is not allowed in an equivalence set
   equivalence(x(10), w)
   logical :: w(10)
   bind(C, name="c") /c/
   common /c/ w
   integer, target :: u
-  !ERROR: Variable 'u' with TARGET attribute is not allowed in an equivalence set
+  !CHECK: error: Variable 'u' with TARGET attribute is not allowed in an equivalence set
   equivalence(x(1), u)
 end
 

   real :: x0
   type(t1) :: x1
   type(t2) :: x2
-  !ERROR: Derived type object 'x1' with pointer ultimate component is not allowed in an equivalence set
+  !CHECK: error: Derived type object 'x1' with pointer ultimate component is not allowed in an equivalence set
   equivalence(x0, x1)
-  !ERROR: Derived type object 'x2' with pointer ultimate component is not allowed in an equivalence set
+  !CHECK: error: Derived type object 'x2' with pointer ultimate component is not allowed in an equivalence set
   equivalence(x0, x2)
 end
 

   end type
   real :: x0
   type(t1) :: x1
-  !ERROR: Nonsequence derived type object 'x1' is not allowed in an equivalence set
+  !CHECK: error: Nonsequence derived type object 'x1' is not allowed in an equivalence set
   equivalence(x0, x1)
 end
 

 end
 subroutine s8
   use m8
-  !ERROR: Use-associated variable 'x' is not allowed in an equivalence set
+  !CHECK: error: Use-associated variable 'x' is not allowed in an equivalence set
   equivalence(x, z)
-  !ERROR: Use-associated variable 'y' is not allowed in an equivalence set
+  !CHECK: error: Use-associated variable 'y' is not allowed in an equivalence set
   equivalence(y(1), z)
 end
 

   real :: d(10)
   integer, parameter :: n = 2
   integer :: i, j
-  !ERROR: Substring with nonconstant bound 'n+j' is not allowed in an equivalence set
+  !CHECK: error: Substring with nonconstant bound 'n+j' is not allowed in an equivalence set
   equivalence(c(n+1:n+j), i)
-  !ERROR: Substring with zero length is not allowed in an equivalence set
+  !CHECK: 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
+  !CHECK: 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
+  !CHECK: 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_8)(2_8:2_8)' and 'a(10_8)(1_8:1_8)' cannot have the same first storage unit
+  !CHECK: 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
 

   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
+  !CHECK: error: Array with vector subscript 'i' is not allowed in an equivalence set
   equivalence(x(i), y)
 end
 
 subroutine s11(n)
   integer :: n
   real :: x(n), y
-  !ERROR: Automatic object 'x' is not allowed in an equivalence set
+  !CHECK: error: Automatic object 'x' is not allowed in an equivalence set
   equivalence(x(1), y)
 end
 
 module s12
   real, protected :: a
   integer :: b
-  !ERROR: Equivalence set cannot contain 'a' with PROTECTED attribute and 'b' without
+  !CHECK: error: Equivalence set cannot contain 'a' with PROTECTED attribute and 'b' without
   equivalence(a, b)
-  !ERROR: Equivalence set cannot contain 'a' with PROTECTED attribute and 'b' without
+  !CHECK: error: Equivalence set cannot contain 'a' with PROTECTED attribute and 'b' without
   equivalence(b, a)
 end
 

     type(t1) :: w
   end type
   type(t2) :: c
-  !ERROR: Equivalence set cannot contain 'b' that is character sequence type and 'a' that is not
+  !CHECK: nonstandard: Equivalence set contains 'a' that is numeric sequence type and 'b' that is character
   equivalence(a, b)
-  !ERROR: Equivalence set cannot contain 'c' that is numeric sequence type and 'a' that is not
+  !CHECK: nonstandard: Equivalence set contains 'c' that is a default numeric sequence type and 'a' that is numeric with non-default kind
   equivalence(c, a)
   double precision :: d
   double complex :: e
   !OK: d and e are considered to be a default kind numeric type
   equivalence(c, d, e)
+  type :: t3
+    sequence
+    real :: x
+    character :: ch
+  end type t3
+  type(t3) :: s, r
+  type :: t4
+    sequence
+    character :: ch
+    real :: x
+  end type t4
+  type(t4) :: t
+  !CHECK: nonstandard: Equivalence set contains 's' and 'r' with same type that is neither numeric nor character sequence type
+  equivalence(s, r)
+  !CHECK: error: Equivalence set cannot contain 's' and 't' with distinct types that are not both numeric or character sequence types
+  equivalence(s, t)
 end
 
 module s14
   real :: a(10), b, c, d
-  !ERROR: 'a(2_8)' and 'a(1_8)' cannot have the same first storage unit
+  !CHECK: 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(4_8)' and 'a(3_8)' cannot have the same first storage unit
+  !CHECK: 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
+  !CHECK: error: 'a(6_8)' and 'a(5_8)' cannot have the same first storage unit
   equivalence(a(6), d)
   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
+  !CHECK: error: 'a(3_8)' and 'a(1_8)' cannot have the same first storage unit
   equivalence(b(2),a(1))
 end module
 

   real function f17a()
     implicit none
     real :: y
-    !ERROR: No explicit type declared for 'dupname'
-    equivalence (dupName, y) 
+    !CHECK: error: No explicit type declared for 'dupname'
+    equivalence (dupName, y)
   end function f17a
   real function f17b()
     real :: y
-    ! The following implicitly declares an object called "dupName" local to 
+    ! The following implicitly declares an object called "dupName" local to
     ! the function f17b().  OK since there's no "implicit none
-    equivalence (dupName, y) 
+    equivalence (dupName, y)
   end function f17b
 end module m17