diff --git a/flang/docs/Extensions.md b/flang/docs/Extensions.md --- a/flang/docs/Extensions.md +++ b/flang/docs/Extensions.md @@ -141,7 +141,9 @@ 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))`). diff --git a/flang/include/flang/Common/Fortran-features.h b/flang/include/flang/Common/Fortran-features.h --- a/flang/include/flang/Common/Fortran-features.h +++ b/flang/include/flang/Common/Fortran-features.h @@ -27,7 +27,8 @@ 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, diff --git a/flang/include/flang/Evaluate/tools.h b/flang/include/flang/Evaluate/tools.h --- a/flang/include/flang/Evaluate/tools.h +++ b/flang/include/flang/Evaluate/tools.h @@ -1106,6 +1106,11 @@ 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_ diff --git a/flang/lib/Evaluate/tools.cpp b/flang/lib/Evaluate/tools.cpp --- a/flang/lib/Evaluate/tools.cpp +++ b/flang/lib/Evaluate/tools.cpp @@ -1518,4 +1518,15 @@ 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 diff --git a/flang/lib/Parser/Fortran-parsers.cpp b/flang/lib/Parser/Fortran-parsers.cpp --- a/flang/lib/Parser/Fortran-parsers.cpp +++ b/flang/lib/Parser/Fortran-parsers.cpp @@ -202,9 +202,8 @@ "CHARACTER" >> maybe(Parser{}))), construct(construct( "LOGICAL" >> maybe(kindSelector))), - construct("DOUBLE COMPLEX" >> - extension( - construct())), + extension(construct( + "DOUBLE COMPLEX" >> construct())), extension( construct(construct( "BYTE" >> construct>(pure(1))))))) diff --git a/flang/lib/Parser/basic-parsers.h b/flang/lib/Parser/basic-parsers.h --- a/flang/lib/Parser/basic-parsers.h +++ b/flang/lib/Parser/basic-parsers.h @@ -855,8 +855,8 @@ 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; } diff --git a/flang/lib/Semantics/resolve-names-utils.h b/flang/lib/Semantics/resolve-names-utils.h --- a/flang/lib/Semantics/resolve-names-utils.h +++ b/flang/lib/Semantics/resolve-names-utils.h @@ -128,8 +128,9 @@ 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); SemanticsContext &context_; diff --git a/flang/lib/Semantics/resolve-names-utils.cpp b/flang/lib/Semantics/resolve-names-utils.cpp --- a/flang/lib/Semantics/resolve-names-utils.cpp +++ b/flang/lib/Semantics/resolve-names-utils.cpp @@ -8,6 +8,7 @@ #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" @@ -412,45 +413,58 @@ 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 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()); @@ -678,15 +692,14 @@ // 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; } @@ -694,12 +707,19 @@ 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, diff --git a/flang/test/Semantics/equivalence01.f90 b/flang/test/Semantics/equivalence01.f90 --- a/flang/test/Semantics/equivalence01.f90 +++ b/flang/test/Semantics/equivalence01.f90 @@ -1,8 +1,8 @@ -!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 @@ -13,24 +13,24 @@ 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 @@ -40,22 +40,22 @@ 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 @@ -71,9 +71,9 @@ 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 @@ -82,7 +82,7 @@ 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 @@ -92,9 +92,9 @@ 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 @@ -103,17 +103,17 @@ 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 @@ -121,23 +121,23 @@ 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 @@ -153,25 +153,41 @@ 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 @@ -179,7 +195,7 @@ 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 @@ -204,13 +220,13 @@ 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