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))`).
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,
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_
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
"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)))))))
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;
}
#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,
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_;
-!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