[flang] Checks for constraints C731 through C740
In most cases, I just added the contraint names to the code and tests.
I implemented the following checks:
- C736 A child type with a coarray ultimate component must have a parent with
a coarray ultimate component.
- C737 A child type with and EVENT_TYPE or LOCK_TYPE component must have a
parent either which is EVENT_TYPE or LOCK_TYPE or a type with an EVENT_TYPE
or LOCK_TYPE component.
- C740 Sequence types must contain at least on component
- C740 Data components of sequence types must either be of an intrinsic type
or a sequenced derived type.
After implementing these checks, some tests had new errors unrelated to their
original purpose, so I fixed them.
Original-commit: flang-compiler/f18@098f01bc474798ae03bd4dc7de6c929deec6f244
Reviewed-on: https://github.com/flang-compiler/f18/pull/1097
diff --git a/flang/include/flang/Semantics/scope.h b/flang/include/flang/Semantics/scope.h
index b55cf50..38b884e 100644
--- a/flang/include/flang/Semantics/scope.h
+++ b/flang/include/flang/Semantics/scope.h
@@ -91,6 +91,7 @@
const Symbol *GetSymbol() const;
const Scope *GetDerivedTypeParent() const;
+ const Scope &GetDerivedTypeBase() const;
std::optional<SourceName> GetName() const;
bool Contains(const Scope &) const;
/// Make a scope nested in this one
diff --git a/flang/include/flang/Semantics/type.h b/flang/include/flang/Semantics/type.h
index 00f38e2..cc20318 100644
--- a/flang/include/flang/Semantics/type.h
+++ b/flang/include/flang/Semantics/type.h
@@ -336,6 +336,7 @@
}
bool IsAssumedType() const { return category_ == TypeStar; }
bool IsNumeric(TypeCategory) const;
+ bool IsSequenceType() const;
const NumericTypeSpec &numericTypeSpec() const;
const LogicalTypeSpec &logicalTypeSpec() const;
const CharacterTypeSpec &characterTypeSpec() const {
diff --git a/flang/lib/Semantics/check-declarations.cpp b/flang/lib/Semantics/check-declarations.cpp
index 15dd782..da02b4f 100644
--- a/flang/lib/Semantics/check-declarations.cpp
+++ b/flang/lib/Semantics/check-declarations.cpp
@@ -679,13 +679,14 @@
void CheckHelper::CheckDerivedType(
const Symbol &symbol, const DerivedTypeDetails &details) {
- if (!symbol.scope()) {
+ const Scope *scope{symbol.scope()};
+ if (!scope) {
CHECK(details.isForwardReferenced());
return;
}
- CHECK(symbol.scope()->symbol() == &symbol);
- CHECK(symbol.scope()->IsDerivedType());
- if (symbol.attrs().test(Attr::ABSTRACT) &&
+ CHECK(scope->symbol() == &symbol);
+ CHECK(scope->IsDerivedType());
+ if (symbol.attrs().test(Attr::ABSTRACT) && // C734
(symbol.attrs().test(Attr::BIND_C) || details.sequence())) {
messages_.Say("An ABSTRACT derived type must be extensible"_err_en_US);
}
@@ -699,7 +700,7 @@
ScopeComponentIterator components{*parentDerived};
for (const Symbol &component : components) {
if (component.attrs().test(Attr::DEFERRED)) {
- if (symbol.scope()->FindComponent(component.name()) == &component) {
+ if (scope->FindComponent(component.name()) == &component) {
SayWithDeclaration(component,
"Non-ABSTRACT extension of ABSTRACT derived type '%s' lacks a binding for DEFERRED procedure '%s'"_err_en_US,
parentDerived->typeSymbol().name(), component.name());
@@ -707,6 +708,26 @@
}
}
}
+ DerivedTypeSpec derived{symbol.name(), symbol};
+ derived.set_scope(*scope);
+ if (FindCoarrayUltimateComponent(derived) && // C736
+ !(parentDerived && FindCoarrayUltimateComponent(*parentDerived))) {
+ messages_.Say(
+ "Type '%s' has a coarray ultimate component so the type at the base "
+ "of its type extension chain ('%s') must be a type that has a "
+ "coarray ultimate component"_err_en_US,
+ symbol.name(), scope->GetDerivedTypeBase().GetSymbol()->name());
+ }
+ if (FindEventOrLockPotentialComponent(derived) && // C737
+ !(FindEventOrLockPotentialComponent(*parentDerived) ||
+ IsEventTypeOrLockType(parentDerived))) {
+ messages_.Say(
+ "Type '%s' has an EVENT_TYPE or LOCK_TYPE component, so the type "
+ "at the base of its type extension chain ('%s') must either have an "
+ "EVENT_TYPE or LOCK_TYPE component, or be EVENT_TYPE or "
+ "LOCK_TYPE"_err_en_US,
+ symbol.name(), scope->GetDerivedTypeBase().GetSymbol()->name());
+ }
}
if (HasIntrinsicTypeName(symbol)) { // C729
messages_.Say("A derived type name cannot be the name of an intrinsic"
@@ -1141,7 +1162,7 @@
CHECK(dtScope.kind() == Scope::Kind::DerivedType);
if (const Symbol * dtSymbol{dtScope.symbol()}) {
if (symbol.attrs().test(Attr::DEFERRED)) {
- if (!dtSymbol->attrs().test(Attr::ABSTRACT)) {
+ if (!dtSymbol->attrs().test(Attr::ABSTRACT)) { // C733
SayWithDeclaration(*dtSymbol,
"Procedure bound to non-ABSTRACT derived type '%s' may not be DEFERRED"_err_en_US,
dtSymbol->name());
diff --git a/flang/lib/Semantics/resolve-names.cpp b/flang/lib/Semantics/resolve-names.cpp
index 805a9c7..ee2db03 100644
--- a/flang/lib/Semantics/resolve-names.cpp
+++ b/flang/lib/Semantics/resolve-names.cpp
@@ -3682,18 +3682,40 @@
}
}
Walk(std::get<std::list<parser::Statement<parser::PrivateOrSequence>>>(x.t));
+ const auto &componentDefs{
+ std::get<std::list<parser::Statement<parser::ComponentDefStmt>>>(x.t)};
+ Walk(componentDefs);
if (derivedTypeInfo_.sequence) {
details.set_sequence(true);
- if (derivedTypeInfo_.extends) {
+ if (componentDefs.empty()) { // C740
Say(stmt.source,
- "A sequence type may not have the EXTENDS attribute"_err_en_US); // C735
+ "A sequence type must have at least one component"_err_en_US);
}
- if (!details.paramNames().empty()) {
+ if (!details.paramNames().empty()) { // C740
Say(stmt.source,
- "A sequence type may not have type parameters"_err_en_US); // C740
+ "A sequence type may not have type parameters"_err_en_US);
+ }
+ if (derivedTypeInfo_.extends) { // C735
+ Say(stmt.source,
+ "A sequence type may not have the EXTENDS attribute"_err_en_US);
+ } else {
+ for (const auto &componentName : details.componentNames()) {
+ const Symbol *componentSymbol{scope.FindComponent(componentName)};
+ if (componentSymbol && componentSymbol->has<ObjectEntityDetails>()) {
+ const auto &componentDetails{
+ componentSymbol->get<ObjectEntityDetails>()};
+ const DeclTypeSpec *componentType{componentDetails.type()};
+ if (componentType && // C740
+ !componentType->AsIntrinsic() &&
+ !componentType->IsSequenceType()) {
+ Say(componentSymbol->name(),
+ "A sequence type data component must either be of an"
+ " intrinsic type or a derived sequence type"_err_en_US);
+ }
+ }
+ }
}
}
- Walk(std::get<std::list<parser::Statement<parser::ComponentDefStmt>>>(x.t));
Walk(std::get<std::optional<parser::TypeBoundProcedurePart>>(x.t));
Walk(std::get<parser::Statement<parser::EndTypeStmt>>(x.t));
derivedTypeInfo_ = {};
@@ -3783,6 +3805,10 @@
return false;
}
bool DeclarationVisitor::Pre(const parser::SequenceStmt &) {
+ if (derivedTypeInfo_.sequence) {
+ Say("SEQUENCE may not appear more than once in"
+ " derived type components"_en_US); // C738
+ }
derivedTypeInfo_.sequence = true;
return false;
}
@@ -3796,7 +3822,7 @@
if (!attrs.HasAny({Attr::POINTER, Attr::ALLOCATABLE})) {
if (const auto *declType{GetDeclTypeSpec()}) {
if (const auto *derived{declType->AsDerived()}) {
- if (derivedTypeInfo_.type == &derived->typeSymbol()) { // C737
+ if (derivedTypeInfo_.type == &derived->typeSymbol()) { // C744
Say("Recursive use of the derived type requires "
"POINTER or ALLOCATABLE"_err_en_US);
}
@@ -4648,7 +4674,7 @@
DerivedTypeDetails details;
details.set_isForwardReferenced();
symbol->set_details(std::move(details));
- } else { // C883
+ } else { // C732
Say(name, "Derived type '%s' not found"_err_en_US);
return std::nullopt;
}
diff --git a/flang/lib/Semantics/scope.cpp b/flang/lib/Semantics/scope.cpp
index dc934a51..85307c2 100644
--- a/flang/lib/Semantics/scope.cpp
+++ b/flang/lib/Semantics/scope.cpp
@@ -362,6 +362,15 @@
return nullptr;
}
+const Scope &Scope::GetDerivedTypeBase() const {
+ const Scope *child{this};
+ for (const Scope *parent{GetDerivedTypeParent()}; parent != nullptr;
+ parent = child->GetDerivedTypeParent()) {
+ child = parent;
+ }
+ return *child;
+}
+
void Scope::InstantiateDerivedTypes(SemanticsContext &context) {
for (DeclTypeSpec &type : declTypeSpecs_) {
if (type.category() == DeclTypeSpec::TypeDerived ||
diff --git a/flang/lib/Semantics/type.cpp b/flang/lib/Semantics/type.cpp
index 108d04a..f4fc7cb 100644
--- a/flang/lib/Semantics/type.cpp
+++ b/flang/lib/Semantics/type.cpp
@@ -472,6 +472,14 @@
bool DeclTypeSpec::IsNumeric(TypeCategory tc) const {
return category_ == Numeric && numericTypeSpec().category() == tc;
}
+bool DeclTypeSpec::IsSequenceType() const {
+ if (const DerivedTypeSpec * derivedType{AsDerived()}) {
+ const auto *typeDetails{
+ derivedType->typeSymbol().detailsIf<DerivedTypeDetails>()};
+ return typeDetails && typeDetails->sequence();
+ }
+ return false;
+}
IntrinsicTypeSpec *DeclTypeSpec::AsIntrinsic() {
return const_cast<IntrinsicTypeSpec *>(
const_cast<const DeclTypeSpec *>(this)->AsIntrinsic());
diff --git a/flang/test/Semantics/assign02.f90 b/flang/test/Semantics/assign02.f90
index c504f7a..91bb845 100644
--- a/flang/test/Semantics/assign02.f90
+++ b/flang/test/Semantics/assign02.f90
@@ -7,6 +7,7 @@
end type
type t2
sequence
+ real :: t2Field
end type
contains
diff --git a/flang/test/Semantics/bad-forward-type.f90 b/flang/test/Semantics/bad-forward-type.f90
index 0c6de01..0fda08f 100644
--- a/flang/test/Semantics/bad-forward-type.f90
+++ b/flang/test/Semantics/bad-forward-type.f90
@@ -1,5 +1,7 @@
! RUN: %B/test/Semantics/test_errors.sh %s %flang %t
! Forward references to derived types (error cases)
+! C732 A parent-type-name shall be the name of a previously defined
+! extensible type (7.5.7).
!ERROR: The derived type 'undef' was forward-referenced but not defined
type(undef) function f1()
diff --git a/flang/test/Semantics/bindings01.f90 b/flang/test/Semantics/bindings01.f90
index 4c517ad..9d15515 100644
--- a/flang/test/Semantics/bindings01.f90
+++ b/flang/test/Semantics/bindings01.f90
@@ -1,6 +1,6 @@
! RUN: %B/test/Semantics/test_errors.sh %s %flang %t
! Confirm enforcement of constraints and restrictions in 7.5.7.3
-! and C779-C785.
+! and C733, C734 and C779, C780, C781, C782, C783, C784, and C785.
module m
!ERROR: An ABSTRACT derived type must be extensible
@@ -9,6 +9,7 @@
!ERROR: An ABSTRACT derived type must be extensible
type, abstract :: badAbstract2
sequence
+ real :: badAbstract2Field
end type
type, abstract :: abstract
contains
@@ -50,6 +51,7 @@
end type
type :: inextensible2
sequence
+ real :: inextensible2Field
end type
!ERROR: The parent type is not extensible
type, extends(inextensible2) :: badExtends2
diff --git a/flang/test/Semantics/label11.f90 b/flang/test/Semantics/label11.f90
index 9243566..71c40cf 100644
--- a/flang/test/Semantics/label11.f90
+++ b/flang/test/Semantics/label11.f90
@@ -11,6 +11,8 @@
! CHECK: derived type definition name mismatch
! CHECK: MODULE PROCEDURE name mismatch
! CHECK: MODULE name mismatch
+! C739 If END TYPE is followed by a type-name, the type-name shall be the
+! same as that in the corresponding derived-type-stmt.
block data t1
end block data t2
diff --git a/flang/test/Semantics/modfile33.f90 b/flang/test/Semantics/modfile33.f90
index d5474c7..361542a 100644
--- a/flang/test/Semantics/modfile33.f90
+++ b/flang/test/Semantics/modfile33.f90
@@ -9,6 +9,7 @@
module m1
type :: t
sequence
+ logical :: x
end type
interface operator(+)
pure integer(8) function add_ll(x, y)
@@ -61,6 +62,7 @@
!module m1
! type :: t
! sequence
+! logical(4) :: x
! end type
! interface operator(+)
! procedure :: add_ll
@@ -136,6 +138,7 @@
module m2
type :: t
sequence
+ logical :: x
end type
interface operator(.And.)
pure integer(8) function and_ti(x, y)
@@ -195,6 +198,7 @@
!module m2
! type :: t
! sequence
+! logical(4) :: x
! end type
! interface operator( .and.)
! procedure :: and_ti
@@ -275,6 +279,7 @@
module m3
type :: t
sequence
+ logical :: x
end type
interface operator(<>)
pure integer(8) function ne_it(x, y)
@@ -317,6 +322,7 @@
!module m3
! type :: t
! sequence
+! logical(4) :: x
! end type
! interface operator(<>)
! procedure :: ne_it
@@ -368,6 +374,7 @@
module m4
type :: t
sequence
+ logical :: x
end type
interface operator(//)
pure integer(8) function concat_12(x, y)
@@ -395,6 +402,7 @@
!module m4
! type :: t
! sequence
+! logical(4) :: x
! end type
! interface operator(//)
! procedure :: concat_12
diff --git a/flang/test/Semantics/resolve31.f90 b/flang/test/Semantics/resolve31.f90
index a1fb7ce..14a7bc9c 100644
--- a/flang/test/Semantics/resolve31.f90
+++ b/flang/test/Semantics/resolve31.f90
@@ -1,4 +1,13 @@
! RUN: %B/test/Semantics/test_errors.sh %s %flang %t
+! C735 If EXTENDS appears, SEQUENCE shall not appear.
+! C738 The same private-or-sequence shall not appear more than once in a
+! given derived-type-def .
+!
+! C740 If SEQUENCE appears,
+! the type shall have at least one component,
+! each data component shall be declared to be of an intrinsic type or of a sequence type,
+! the derived type shall not have any type parameter,
+! and a type-bound-procedure-part shall not appear.
subroutine s1
integer :: t0
!ERROR: 't0' is not a derived type
@@ -41,6 +50,8 @@
private
sequence
private ! not a fatal error
+ sequence ! not a fatal error
+ real :: t1Field
end type
type :: t1a
end type
@@ -55,6 +66,32 @@
!ERROR: A sequence type may not have a CONTAINS statement
contains
end type
+ !ERROR: A sequence type must have at least one component
+ type :: emptyType
+ sequence
+ end type emptyType
+ type :: plainType
+ real :: plainField
+ end type plainType
+ type :: sequenceType
+ sequence
+ real :: sequenceField
+ end type sequenceType
+ type :: testType
+ sequence
+ !ERROR: A sequence type data component must either be of an intrinsic type or a derived sequence type
+ class(*), allocatable :: typeStarField
+ !ERROR: A sequence type data component must either be of an intrinsic type or a derived sequence type
+ type(plainType) :: testField1
+ type(sequenceType) :: testField2
+ procedure(real), nopass :: procField
+ end type testType
+ !ERROR: A sequence type may not have type parameters
+ type :: paramType(param)
+ integer, kind :: param
+ sequence
+ real :: paramField
+ end type paramType
contains
subroutine s3
type :: t1
diff --git a/flang/test/Semantics/resolve33.f90 b/flang/test/Semantics/resolve33.f90
index d4265cd..176404b 100644
--- a/flang/test/Semantics/resolve33.f90
+++ b/flang/test/Semantics/resolve33.f90
@@ -1,5 +1,7 @@
! RUN: %B/test/Semantics/test_errors.sh %s %flang %t
! Derived type parameters
+! C731 The same type-param-name shall not appear more than once in a given
+! derived-type-stmt.
module m
!ERROR: Duplicate type parameter name: 'a'
diff --git a/flang/test/Semantics/resolve86.f90 b/flang/test/Semantics/resolve86.f90
new file mode 100644
index 0000000..0c42bce
--- /dev/null
+++ b/flang/test/Semantics/resolve86.f90
@@ -0,0 +1,44 @@
+! RUN: %B/test/Semantics/test_errors.sh %s %flang %t
+! C736 If EXTENDS appears and the type being defined has a coarray ultimate
+! component, its parent type shall have a coarray ultimate component.
+!
+subroutine s()
+ type coarrayParent
+ real,allocatable, codimension[:] :: parentField
+ end type coarrayParent
+
+ type, extends(coarrayParent) :: goodChildType
+ real, allocatable, codimension[:] :: childField
+ end type goodChildType
+
+ type, extends(coarrayParent) :: brotherType
+ real :: brotherField
+ end type brotherType
+
+ type, extends(brotherType) :: grandChildType
+ real, allocatable, codimension[:] :: grandChildField
+ end type grandChildType
+
+ type plainParent
+ end type plainParent
+
+ !ERROR: Type 'badchildtype' has a coarray ultimate component so the type at the base of its type extension chain ('plainparent') must be a type that has a coarray ultimate component
+ type, extends(plainParent) :: badChildType
+ real, allocatable, codimension[:] :: childField
+ end type badChildType
+
+ type, extends(plainParent) :: plainChild
+ real :: realField
+ end type plainChild
+
+ !ERROR: Type 'badchildtype2' has a coarray ultimate component so the type at the base of its type extension chain ('plainparent') must be a type that has a coarray ultimate component
+ type, extends(plainChild) :: badChildType2
+ real, allocatable, codimension[:] :: childField
+ end type badChildType2
+
+ !ERROR: Type 'badchildtype3' has a coarray ultimate component so the type at the base of its type extension chain ('plainparent') must be a type that has a coarray ultimate component
+ type, extends(plainParent) :: badChildType3
+ type(coarrayParent) :: childField
+ end type badChildType3
+
+end subroutine s
diff --git a/flang/test/Semantics/resolve87.f90 b/flang/test/Semantics/resolve87.f90
new file mode 100644
index 0000000..ad09d81
--- /dev/null
+++ b/flang/test/Semantics/resolve87.f90
@@ -0,0 +1,90 @@
+! RUN: %B/test/Semantics/test_errors.sh %s %flang %t
+! C737 If EXTENDS appears and the type being defined has a potential
+! subobject component of type EVENT_TYPE or LOCK_TYPE from the intrinsic
+! module ISO_FORTRAN_ENV, its parent type shall be EVENT_TYPE or LOCK_TYPE
+! or have a potential subobject component of type EVENT_TYPE or LOCK_TYPE.
+module not_iso_fortran_env
+ type event_type
+ end type
+
+ type lock_type
+ end type
+end module
+
+subroutine C737_a()
+ use iso_fortran_env
+
+ type lockGrandParentType
+ type(lock_type) :: grandParentField
+ end type lockGrandParentType
+
+ type, extends(lockGrandParentType) :: lockParentType
+ real :: parentField
+ end type lockParentType
+
+ type eventParentType
+ type(event_type) :: parentField
+ end type eventParentType
+
+ type noLockParentType
+ end type noLockParentType
+
+ type, extends(lockParentType) :: goodChildType1
+ type(lock_type) :: childField
+ end type goodChildType1
+
+ type, extends(lockParentType) :: goodChildType2
+ type(event_type) :: childField
+ end type goodChildType2
+
+ type, extends(lock_type) :: goodChildType3
+ type(event_type) :: childField
+ end type goodChildType3
+
+ type, extends(event_type) :: goodChildType4
+ type(lock_type) :: childField
+ end type goodChildType4
+
+ !ERROR: Type 'badchildtype1' has an EVENT_TYPE or LOCK_TYPE component, so the type at the base of its type extension chain ('nolockparenttype') must either have an EVENT_TYPE or LOCK_TYPE component, or be EVENT_TYPE or LOCK_TYPE
+ type, extends(noLockParentType) :: badChildType1
+ type(lock_type) :: childField
+ end type badChildType1
+
+ !ERROR: Type 'badchildtype2' has an EVENT_TYPE or LOCK_TYPE component, so the type at the base of its type extension chain ('nolockparenttype') must either have an EVENT_TYPE or LOCK_TYPE component, or be EVENT_TYPE or LOCK_TYPE
+ type, extends(noLockParentType) :: badChildType2
+ type(event_type) :: childField
+ end type badChildType2
+
+ !ERROR: Type 'badchildtype3' has an EVENT_TYPE or LOCK_TYPE component, so the type at the base of its type extension chain ('nolockparenttype') must either have an EVENT_TYPE or LOCK_TYPE component, or be EVENT_TYPE or LOCK_TYPE
+ type, extends(noLockParentType) :: badChildType3
+ type(lockParentType) :: childField
+ end type badChildType3
+
+ !ERROR: Type 'badchildtype4' has an EVENT_TYPE or LOCK_TYPE component, so the type at the base of its type extension chain ('nolockparenttype') must either have an EVENT_TYPE or LOCK_TYPE component, or be EVENT_TYPE or LOCK_TYPE
+ type, extends(noLockParentType) :: badChildType4
+ type(eventParentType) :: childField
+ end type badChildType4
+
+end subroutine C737_a
+
+subroutine C737_b()
+ use not_iso_fortran_env
+
+ type lockParentType
+ type(lock_type) :: parentField
+ end type lockParentType
+
+ type noLockParentType
+ end type noLockParentType
+
+ ! actually OK since this is not the predefined lock_type
+ type, extends(noLockParentType) :: notBadChildType1
+ type(lock_type) :: childField
+ end type notBadChildType1
+
+ ! actually OK since this is not the predefined event_type
+ type, extends(noLockParentType) :: notBadChildType2
+ type(event_type) :: childField
+ end type notBadChildType2
+
+end subroutine C737_b
