[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@098f01bc47
Reviewed-on: https://github.com/flang-compiler/f18/pull/1097

flang/include/flang/Semantics/scope.h

@@ -91,6 +91,7 @@ public:
 
   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

flang/include/flang/Semantics/type.h

@@ -336,6 +336,7 @@ public:
   }
   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 {

flang/lib/Semantics/check-declarations.cpp

@@ -679,13 +679,14 @@ void CheckHelper::CheckSubprogram(
 
 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 @@ void CheckHelper::CheckDerivedType(
       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 @@ void CheckHelper::CheckDerivedType(
         }
       }
     }
+    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 @@ void CheckHelper::CheckProcBinding(
   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());

flang/lib/Semantics/resolve-names.cpp

@@ -3682,18 +3682,40 @@ bool DeclarationVisitor::Pre(const parser::DerivedTypeDef &x) {
     }
   }
   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 @@ bool DeclarationVisitor::Pre(const parser::PrivateStmt &) {
   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 @@ void DeclarationVisitor::Post(const parser::ComponentDecl &x) {
   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 @@ std::optional<DerivedTypeSpec> DeclarationVisitor::ResolveDerivedType(
       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;
     }

flang/lib/Semantics/scope.cpp

@@ -362,6 +362,15 @@ const Scope *Scope::GetDerivedTypeParent() const {
   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 ||

flang/lib/Semantics/type.cpp

@@ -472,6 +472,14 @@ DeclTypeSpec::DeclTypeSpec(Category category) : category_{category} {
 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());

flang/test/Semantics/assign02.f90

@@ -7,6 +7,7 @@ module m1
   end type
   type t2
     sequence
+    real :: t2Field
   end type
 contains
 

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()

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 @@ module m
   !ERROR: An ABSTRACT derived type must be extensible
   type, abstract :: badAbstract2
     sequence
+    real :: badAbstract2Field
   end type
   type, abstract :: abstract
    contains
@@ -50,6 +51,7 @@ module m
   end type
   type :: inextensible2
     sequence
+    real :: inextensible2Field
   end type
   !ERROR: The parent type is not extensible
   type, extends(inextensible2) :: badExtends2

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

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 @@ end
 !module m1
 ! type :: t
 !  sequence
+!  logical(4) :: x
 ! end type
 ! interface operator(+)
 !  procedure :: add_ll
@@ -136,6 +138,7 @@ end
 module m2
   type :: t
     sequence
+    logical :: x
   end type
   interface operator(.And.)
     pure integer(8) function and_ti(x, y)
@@ -195,6 +198,7 @@ end
 !module m2
 ! type :: t
 !  sequence
+!  logical(4) :: x
 ! end type
 ! interface operator( .and.)
 !  procedure :: and_ti
@@ -275,6 +279,7 @@ end
 module m3
   type :: t
     sequence
+    logical :: x
   end type
   interface operator(<>)
     pure integer(8) function ne_it(x, y)
@@ -317,6 +322,7 @@ end
 !module m3
 ! type :: t
 !  sequence
+!  logical(4) :: x
 ! end type
 ! interface operator(<>)
 !  procedure :: ne_it
@@ -368,6 +374,7 @@ end
 module m4
   type :: t
     sequence
+    logical :: x
   end type
   interface operator(//)
     pure integer(8) function concat_12(x, y)
@@ -395,6 +402,7 @@ end
 !module m4
 ! type :: t
 !  sequence
+!  logical(4) :: x
 ! end type
 ! interface operator(//)
 !  procedure :: concat_12

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 @@ module m4
     private
     sequence
     private  ! not a fatal error
+    sequence ! not a fatal error
+    real :: t1Field
   end type
   type :: t1a
   end type
@@ -55,6 +66,32 @@ module m4
   !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

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'

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

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