[flang] Semantic check for C708

An entity declared with the CLASS keyword shall be a dummy argument or
have the ALLOCATABLE or POINTER attribute.

Implementing this check revealed a problem in the test resolve44.cpp.
It also showed that we were doing semantic checking on the entities
created by the compiler for LOCAL and LOCAL_INIT locality-specs.  So I
changed the creation of symbols associated with LOCAL and LOCAL_INIT
locality-specs to be host associated with the outer symbol rather than
new object entities.  In the process, I also changed things so that the
`parser::Name` associated with the newly created symbols was set to the
symbol rather than being set to nullptr.

Original-commit: flang-compiler/f18@5dd0b0bbe811a908374b2907bb38c75ca76127d2
Reviewed-on: https://github.com/flang-compiler/f18/pull/981

diff --git a/flang/lib/semantics/check-declarations.cpp b/flang/lib/semantics/check-declarations.cpp
index 7cd81c9..57f4d78 100644 (file)
--- a/flang/lib/semantics/check-declarations.cpp
+++ b/flang/lib/semantics/check-declarations.cpp
@@ -371,6 +371,14 @@ void CheckHelper::CheckObjectEntity(
       }
     }
   }
+  if (const DeclTypeSpec * type{details.type()}) {  // C708
+    if (type->IsPolymorphic() &&
+        !(IsAllocatableOrPointer(symbol) || symbol.IsDummy())) {
+      messages_.Say("CLASS entity '%s' must be a dummy argument or have "
+                    "ALLOCATABLE or POINTER attribute"_err_en_US,
+          symbol.name());
+    }
+  }
 }
 
 // The six different kinds of array-specs:

diff --git a/flang/lib/semantics/resolve-names.cpp b/flang/lib/semantics/resolve-names.cpp
index f075fa3..61e9ed0 100644 (file)
--- a/flang/lib/semantics/resolve-names.cpp
+++ b/flang/lib/semantics/resolve-names.cpp
@@ -4314,12 +4314,8 @@ Symbol *DeclarationVisitor::DeclareLocalEntity(const parser::Name &name) {
   if (!PassesLocalityChecks(name, prev)) {
     return nullptr;
   }
-  name.symbol = nullptr;
-  Symbol &symbol{DeclareEntity<ObjectEntityDetails>(name, {})};
-  if (auto *type{prev.GetType()}) {
-    symbol.SetType(*type);
-    symbol.set(Symbol::Flag::Implicit, prev.test(Symbol::Flag::Implicit));
-  }
+  Symbol &symbol{MakeSymbol(name, HostAssocDetails{prev})};
+  name.symbol = &symbol;
   return &symbol;
 }
 

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

diff --git a/flang/test/semantics/allocate01.f90 b/flang/test/semantics/allocate01.f90
index 137286e..6944e2b 100644 (file)
--- a/flang/test/semantics/allocate01.f90
+++ b/flang/test/semantics/allocate01.f90
@@ -16,7 +16,8 @@ module m
 
 contains
   function mfoo(x)
-    class(a_type) :: foo, x
+    class(a_type) :: x
+    class(a_type), allocatable :: foo
     foo = x
   end function
   subroutine mbar(x)

diff --git a/flang/test/semantics/allocate09.f90 b/flang/test/semantics/allocate09.f90
index 49736f9..e47cd81 100644 (file)
--- a/flang/test/semantics/allocate09.f90
+++ b/flang/test/semantics/allocate09.f90
@@ -24,7 +24,7 @@ subroutine C946(param_ca_4_assumed, param_ta_4_assumed, param_ca_4_deferred)
 
   real(kind=4) srcx, srcx_array(10)
   real(kind=8) srcx8, srcx8_array(10)
-  class(WithParam(4, 2)) src_a_4_2
+  class(WithParam(4, 2)), allocatable :: src_a_4_2
   type(WithParam(8, 2)) src_a_8_2
   class(WithParam(4, :)), allocatable :: src_a_4_def
   class(WithParam(8, :)), allocatable :: src_a_8_def
@@ -33,8 +33,10 @@ subroutine C946(param_ca_4_assumed, param_ta_4_assumed, param_ca_4_deferred)
   type(WithParamExtent(8, 2, 8, 3)) src_b_8_2_8_3
   class(WithParamExtent(8, :, 8, 3)), allocatable :: src_b_8_def_8_3
   type(WithParamExtent2(k1=4, l1=5, k2=5, l2=6, l3=8 )) src_c_4_5_5_6_8_8
-  class(WithParamExtent2(k1=4, l1=2, k2=5, l2=6, k3=5, l3=8)) src_c_4_2_5_6_5_8
-  class(WithParamExtent2(k2=5, l2=6, k3=5, l3=8)) src_c_1_2_5_6_5_8
+  class(WithParamExtent2(k1=4, l1=2, k2=5, l2=6, k3=5, l3=8)), &
+      allocatable :: src_c_4_2_5_6_5_8
+  class(WithParamExtent2(k2=5, l2=6, k3=5, l3=8)), &
+      allocatable :: src_c_1_2_5_6_5_8
   type(WithParamExtent2(k1=5, l1=5, k2=5, l2=6, l3=8 )) src_c_5_5_5_6_8_8
   type(WithParamExtent2(k1=5, l1=2, k2=5, l2=6, k3=5, l3=8)) src_c_5_2_5_6_5_8
 

diff --git a/flang/test/semantics/resolve44.f90 b/flang/test/semantics/resolve44.f90
index af6a40d..f6e7a89 100644 (file)
--- a/flang/test/semantics/resolve44.f90
+++ b/flang/test/semantics/resolve44.f90
@@ -7,6 +7,7 @@ program main
     type(recursive1), pointer :: ok1
     type(recursive1), allocatable :: ok2
     !ERROR: Recursive use of the derived type requires POINTER or ALLOCATABLE
+    !ERROR: CLASS entity 'bad2' must be a dummy argument or have ALLOCATABLE or POINTER attribute
     class(recursive1) :: bad2
     class(recursive1), pointer :: ok3
     class(recursive1), allocatable :: ok4
@@ -19,6 +20,7 @@ program main
     type(recursive2(kind,len)), pointer :: ok1
     type(recursive2(kind,len)), allocatable :: ok2
     !ERROR: Recursive use of the derived type requires POINTER or ALLOCATABLE
+    !ERROR: CLASS entity 'bad2' must be a dummy argument or have ALLOCATABLE or POINTER attribute
     class(recursive2(kind,len)) :: bad2
     class(recursive2(kind,len)), pointer :: ok3
     class(recursive2(kind,len)), allocatable :: ok4
@@ -31,6 +33,7 @@ program main
     type(recursive3), pointer :: ok1
     type(recursive3), allocatable :: ok2
     !ERROR: Recursive use of the derived type requires POINTER or ALLOCATABLE
+    !ERROR: CLASS entity 'bad2' must be a dummy argument or have ALLOCATABLE or POINTER attribute
     class(recursive3) :: bad2
     class(recursive3), pointer :: ok3
     class(recursive3), allocatable :: ok4

diff --git a/flang/test/semantics/resolve70.f90 b/flang/test/semantics/resolve70.f90
index b771fd0..8824ea4 100644 (file)
--- a/flang/test/semantics/resolve70.f90
+++ b/flang/test/semantics/resolve70.f90
@@ -51,8 +51,8 @@ subroutine s1()
   end type
 
   ! This one's OK
-  class(extensible) :: y
+  class(extensible), allocatable :: y
 
   !ERROR: Non-extensible derived type 'inextensible' may not be used with CLASS keyword
-  class(inextensible) :: x
+  class(inextensible), allocatable :: x
 end subroutine s1

diff --git a/flang/test/semantics/resolve71.f90 b/flang/test/semantics/resolve71.f90
new file mode 100644 (file)
index 0000000..d570233
--- /dev/null
+++ b/flang/test/semantics/resolve71.f90
@@ -0,0 +1,23 @@
+! C708 An entity declared with the CLASS keyword shall be a dummy argument 
+! or have the ALLOCATABLE or POINTER attribute.
+subroutine s()
+  type :: parentType
+  end type
+
+  class(parentType), pointer :: pvar
+  class(parentType), allocatable :: avar
+  class(*), allocatable :: starAllocatableVar
+  class(*), pointer :: starPointerVar
+  !ERROR: CLASS entity 'barevar' must be a dummy argument or have ALLOCATABLE or POINTER attribute
+  class(parentType) :: bareVar
+  !ERROR: CLASS entity 'starvar' must be a dummy argument or have ALLOCATABLE or POINTER attribute
+  class(*) :: starVar
+
+    contains
+      subroutine inner(arg1, arg2, arg3, arg4, arg5)
+        class (parenttype) :: arg1, arg3
+        type(parentType) :: arg2
+        class (parenttype), pointer :: arg4
+        class (parenttype), allocatable :: arg5
+      end subroutine inner
+end subroutine s

diff --git a/flang/test/semantics/symbol09.f90 b/flang/test/semantics/symbol09.f90
index 480f719..8dca133 100644 (file)
--- a/flang/test/semantics/symbol09.f90
+++ b/flang/test/semantics/symbol09.f90
@@ -104,8 +104,8 @@ subroutine s6
  !DEF: /s6/a ObjectEntity INTEGER(4)
  integer :: a(5) = 1
  !DEF: /s6/Block1/i ObjectEntity INTEGER(4)
- !DEF: /s6/Block1/j (LocalityLocal) ObjectEntity INTEGER(8)
- !DEF: /s6/Block1/k (Implicit, LocalityLocalInit) ObjectEntity INTEGER(4)
+ !DEF: /s6/Block1/j (LocalityLocal) HostAssoc INTEGER(8)
+ !DEF: /s6/Block1/k (LocalityLocalInit) HostAssoc INTEGER(4)
   !DEF: /s6/Block1/a (LocalityShared) HostAssoc INTEGER(4)
  do concurrent(integer::i=1:5)local(j)local_init(k)shared(a)
   !REF: /s6/Block1/a