[flang] Semantic checks for constraints on types

I implemented and added tests for constraints C703, C704, C705, C706,
and C796.  In some cases, the code and/or test already existed, and all
I did was add a notation indicating the associated constraint.

Original-commit: flang-compiler/f18@49a64c4c2374e930f6890b270289a6f49ba63edd
Reviewed-on: https://github.com/flang-compiler/f18/pull/978

diff --git a/flang/lib/semantics/check-declarations.cpp b/flang/lib/semantics/check-declarations.cpp
index a96bc6f..7cd81c9 100644 (file)
--- a/flang/lib/semantics/check-declarations.cpp
+++ b/flang/lib/semantics/check-declarations.cpp
@@ -495,7 +495,7 @@ void CheckHelper::CheckDerivedType(
   }
   if (const DeclTypeSpec * parent{FindParentTypeSpec(symbol)}) {
     const DerivedTypeSpec *parentDerived{parent->AsDerived()};
-    if (!IsExtensibleType(parentDerived)) {
+    if (!IsExtensibleType(parentDerived)) {  // C705
       messages_.Say("The parent type is not extensible"_err_en_US);
     }
     if (!symbol.attrs().test(Attr::ABSTRACT) && parentDerived &&

diff --git a/flang/lib/semantics/resolve-names.cpp b/flang/lib/semantics/resolve-names.cpp
index 197a32b..f075fa3 100644 (file)
--- a/flang/lib/semantics/resolve-names.cpp
+++ b/flang/lib/semantics/resolve-names.cpp
@@ -343,6 +343,7 @@ protected:
   }
   KindExpr GetKindParamExpr(
       TypeCategory, const std::optional<parser::KindSelector> &);
+  void CheckForAbstractType(const Symbol &typeSymbol);
 
 private:
   State state_;
@@ -731,7 +732,9 @@ public:
   void Post(const parser::LengthSelector &);
   bool Pre(const parser::KindParam &);
   bool Pre(const parser::DeclarationTypeSpec::Type &);
+  void Post(const parser::DeclarationTypeSpec::Type &);
   bool Pre(const parser::DeclarationTypeSpec::Class &);
+  void Post(const parser::DeclarationTypeSpec::Class &);
   bool Pre(const parser::DeclarationTypeSpec::Record &);
   void Post(const parser::DerivedTypeSpec &);
   bool Pre(const parser::DerivedTypeDef &);
@@ -1590,9 +1593,7 @@ void DeclTypeSpecVisitor::Post(const parser::TypeSpec &typeSpec) {
     case DeclTypeSpec::Character: typeSpec.declTypeSpec = spec; break;
     case DeclTypeSpec::TypeDerived:
       if (const DerivedTypeSpec * derived{spec->AsDerived()}) {
-        if (derived->typeSymbol().attrs().test(Attr::ABSTRACT)) {
-          Say("ABSTRACT derived type may not be used here"_err_en_US);
-        }
+        CheckForAbstractType(derived->typeSymbol());  // C703
         typeSpec.declTypeSpec = spec;
       }
       break;
@@ -1613,6 +1614,12 @@ void DeclTypeSpecVisitor::MakeNumericType(TypeCategory category, int kind) {
   SetDeclTypeSpec(context().MakeNumericType(category, kind));
 }
 
+void DeclTypeSpecVisitor::CheckForAbstractType(const Symbol &typeSymbol) {
+  if (typeSymbol.attrs().test(Attr::ABSTRACT)) {
+    Say("ABSTRACT derived type may not be used here"_err_en_US);
+  }
+}
+
 void DeclTypeSpecVisitor::Post(const parser::DeclarationTypeSpec::ClassStar &) {
   SetDeclTypeSpec(context().globalScope().MakeClassStarType());
 }
@@ -3287,11 +3294,29 @@ bool DeclarationVisitor::Pre(const parser::DeclarationTypeSpec::Type &) {
   return true;
 }
 
+void DeclarationVisitor::Post(const parser::DeclarationTypeSpec::Type &type) {
+  const parser::Name &derivedName{std::get<parser::Name>(type.derived.t)};
+  if (const Symbol * derivedSymbol{derivedName.symbol}) {
+    CheckForAbstractType(*derivedSymbol);  // C706
+  }
+}
+
 bool DeclarationVisitor::Pre(const parser::DeclarationTypeSpec::Class &) {
   SetDeclTypeSpecCategory(DeclTypeSpec::Category::ClassDerived);
   return true;
 }
 
+void DeclarationVisitor::Post(
+    const parser::DeclarationTypeSpec::Class &parsedClass) {
+  const auto &typeName{std::get<parser::Name>(parsedClass.derived.t)};
+  if (auto spec{ResolveDerivedType(typeName)};
+      spec && !IsExtensibleType(&*spec)) {  // C705
+    SayWithDecl(typeName, *typeName.symbol,
+        "Non-extensible derived type '%s' may not be used with CLASS"
+        " keyword"_err_en_US);
+  }
+}
+
 bool DeclarationVisitor::Pre(const parser::DeclarationTypeSpec::Record &) {
   // TODO
   return true;
@@ -4501,7 +4526,7 @@ ParamValue DeclarationVisitor::GetParamValue(
     const parser::TypeParamValue &x, common::TypeParamAttr attr) {
   return std::visit(
       common::visitors{
-          [=](const parser::ScalarIntExpr &x) {
+          [=](const parser::ScalarIntExpr &x) {  // C704
             return ParamValue{EvaluateIntExpr(x), attr};
           },
           [=](const parser::Star &) { return ParamValue::Assumed(attr); },

diff --git a/flang/test/semantics/CMakeLists.txt b/flang/test/semantics/CMakeLists.txt
index c69569b..4873a0f 100644 (file)
--- a/flang/test/semantics/CMakeLists.txt
+++ b/flang/test/semantics/CMakeLists.txt
@@ -100,6 +100,7 @@ set(ERROR_TESTS
   resolve67.f90
   resolve68.f90
   resolve69.f90
+  resolve70.f90
   stop01.f90
   structconst01.f90
   structconst02.f90

diff --git a/flang/test/semantics/allocate04.f90 b/flang/test/semantics/allocate04.f90
index 4ccf014..3b7ce25 100644 (file)
--- a/flang/test/semantics/allocate04.f90
+++ b/flang/test/semantics/allocate04.f90
@@ -47,7 +47,7 @@ subroutine C933_b(n)
   allocate(p3%y)
   !ERROR: Either type-spec or source-expr must appear in ALLOCATE when allocatable object is of abstract type
   allocate(p4(2)%y)
-  !WRONG allocate(Base:: u1) !C703
+  !WRONG allocate(Base:: u1)
 
   ! No error expected
   allocate(real:: u1, u2(2))

diff --git a/flang/test/semantics/resolve52.f90 b/flang/test/semantics/resolve52.f90
index 3df7f7f..3ee41dd 100644 (file)
--- a/flang/test/semantics/resolve52.f90
+++ b/flang/test/semantics/resolve52.f90
@@ -114,6 +114,7 @@ module m7
   end type
 contains
   subroutine s(x)
+    !ERROR: Non-extensible derived type 't' may not be used with CLASS keyword
     class(t) :: x
   end
 end

diff --git a/flang/test/semantics/resolve69.f90 b/flang/test/semantics/resolve69.f90
index 5950f66..bf08c3a 100644 (file)
--- a/flang/test/semantics/resolve69.f90
+++ b/flang/test/semantics/resolve69.f90
@@ -1,8 +1,14 @@
 subroutine s1()
   ! C701 (R701) The type-param-value for a kind type parameter shall be a
   ! constant expression.
+  !
   ! C702 (R701) A colon shall not be used as a type-param-value except in the 
   ! declaration of an entity that has the POINTER or ALLOCATABLE attribute.
+  !
+  ! C704 (R703) In a declaration-type-spec, every type-param-value that is 
+  ! not a colon or an asterisk shall be a specification expression.
+  !   Section 10.1.11 defines specification expressions
+  !
   integer, parameter :: constVal = 1
   integer :: nonConstVal = 1
 !ERROR: Invalid specification expression: reference to local entity 'nonconstval'
@@ -20,6 +26,9 @@ subroutine s1()
   !OK because of the allocatable attribute
   character(:), allocatable :: colonString3
 
+!ERROR: Must have INTEGER type, but is REAL(4)
+  character(3.5) :: badParamValue
+
   type derived(typeKind, typeLen)
     integer, kind :: typeKind
     integer, len :: typeLen

diff --git a/flang/test/semantics/resolve70.f90 b/flang/test/semantics/resolve70.f90
new file mode 100644 (file)
index 0000000..b771fd0
--- /dev/null
+++ b/flang/test/semantics/resolve70.f90
@@ -0,0 +1,58 @@
+! C703 (R702) The derived-type-spec shall not specify an abstract type (7.5.7).
+! This constraint refers to the derived-type-spec in a type-spec.  A type-spec
+! can appear in an ALLOCATE statement, an ac-spec for an array constructor, and
+! in the type specifier of a TYPE GUARD statement
+!
+! C706 TYPE(derived-type-spec) shall not specify an abstract type (7.5.7).
+!   This is for a declaration-type-spec
+!
+! C796 (R756) The derived-type-spec shall not specify an abstract type (7.5.7).
+!
+! C705 (R703) In a declaration-type-spec that uses the CLASS keyword, 
+! derived-type-spec shall specify an extensible type (7.5.7).
+subroutine s()
+  type, abstract :: abstractType
+  end type abstractType
+
+  type, extends(abstractType) :: concreteType
+  end type concreteType
+
+  ! declaration-type-spec
+  !ERROR: ABSTRACT derived type may not be used here
+  type (abstractType), allocatable :: abstractVar
+
+  ! ac-spec for an array constructor
+  !ERROR: ABSTRACT derived type may not be used here
+  !ERROR: ABSTRACT derived type may not be used here
+  type (abstractType), parameter :: abstractArray(*) = (/ abstractType :: /)
+
+  class(*), allocatable :: selector
+
+  ! Structure constructor
+  !ERROR: ABSTRACT derived type may not be used here
+  !ERROR: ABSTRACT derived type 'abstracttype' may not be used in a structure constructor
+  type (abstractType) :: abstractVar1 = abstractType()
+
+  ! Allocate statement
+  !ERROR: ABSTRACT derived type may not be used here
+  allocate(abstractType :: abstractVar)
+
+  select type(selector)
+    ! Type specifier for a type guard statement
+    !ERROR: ABSTRACT derived type may not be used here
+    type is (abstractType)
+  end select
+end subroutine s
+
+subroutine s1()
+  type :: extensible
+  end type
+  type, bind(c) :: inextensible
+  end type
+
+  ! This one's OK
+  class(extensible) :: y
+
+  !ERROR: Non-extensible derived type 'inextensible' may not be used with CLASS keyword
+  class(inextensible) :: x
+end subroutine s1

diff --git a/flang/test/semantics/structconst01.f90 b/flang/test/semantics/structconst01.f90
index 5a4bd7b..a83286c 100644 (file)
--- a/flang/test/semantics/structconst01.f90
+++ b/flang/test/semantics/structconst01.f90
@@ -3,6 +3,8 @@
 ! errors meant to be caught by expression semantic analysis, as well as
 ! acceptable use cases.
 ! Type parameters are used here to make the parses unambiguous.
+! C796 (R756) The derived-type-spec shall not specify an abstract type (7.5.7).
+!   This refers to a derived-type-spec used in a structure constructor
 
 module module1
   type :: type1(j)
@@ -29,7 +31,7 @@ module module1
     type(type2(0,0)), intent(in) :: x
   end subroutine type2arg
   subroutine abstractarg(x)
-    type(abstract(0)), intent(in) :: x
+    class(abstract(0)), intent(in) :: x
   end subroutine abstractarg
   subroutine errors
     call type1arg(type1(0)())