[flang] fix flang-compiler/f18#283 - recursive use of derived types

Original-commit: flang-compiler/f18@f8889b83fcca8630c773dc52482b8236a30254c9
Reviewed-on: https://github.com/flang-compiler/f18/pull/291
Tree-same-pre-rewrite: false

diff --git a/flang/lib/semantics/resolve-names.cc b/flang/lib/semantics/resolve-names.cc
index 05b87ec..f159c1f 100644 (file)
--- a/flang/lib/semantics/resolve-names.cc
+++ b/flang/lib/semantics/resolve-names.cc
@@ -664,7 +664,7 @@ public:
   bool Pre(const parser::DeclarationTypeSpec::Class &);
   bool Pre(const parser::DeclarationTypeSpec::Record &);
   void Post(const parser::DerivedTypeSpec &);
-  void Post(const parser::DerivedTypeDef &x);
+  bool Pre(const parser::DerivedTypeDef &);
   bool Pre(const parser::DerivedTypeStmt &x);
   void Post(const parser::DerivedTypeStmt &x);
   bool Pre(const parser::TypeParamDefStmt &x) { return BeginDecl(); }
@@ -674,7 +674,7 @@ public:
   bool Pre(const parser::SequenceStmt &x);
   bool Pre(const parser::ComponentDefStmt &) { return BeginDecl(); }
   void Post(const parser::ComponentDefStmt &) { EndDecl(); }
-  void Post(const parser::ComponentDecl &x);
+  void Post(const parser::ComponentDecl &);
   bool Pre(const parser::ProcedureDeclarationStmt &);
   void Post(const parser::ProcedureDeclarationStmt &);
   bool Pre(const parser::ProcComponentDefStmt &);
@@ -682,6 +682,7 @@ public:
   void Post(const parser::ProcInterface &x);
   void Post(const parser::ProcDecl &x);
   bool Pre(const parser::TypeBoundProcedurePart &);
+  void Post(const parser::ContainsStmt &);
   bool Pre(const parser::TypeBoundProcBinding &) { return BeginAttrs(); }
   void Post(const parser::TypeBoundProcBinding &) { EndAttrs(); }
   void Post(const parser::TypeBoundProcedureStmt::WithoutInterface &);
@@ -725,13 +726,14 @@ private:
     std::optional<ParamValue> length;
     std::optional<KindExpr> kind;
   } charInfo_;
-  // Info about current derived type while walking DerivedTypeStmt
+  // Info about current derived type while walking DerivedTypeDef
   struct {
     const parser::Name *extends{nullptr};  // EXTENDS(name)
     bool privateComps{false};  // components are private by default
     bool privateBindings{false};  // bindings are private by default
     bool sawContains{false};  // currently processing bindings
     bool sequence{false};  // is a sequence type
+    const Symbol *type{nullptr};  // derived type being defined
   } derivedTypeInfo_;
   // Info about common blocks in the current scope
   struct {
@@ -2809,13 +2811,18 @@ void DeclarationVisitor::Post(const parser::DerivedTypeSpec &x) {
   x.derivedTypeSpec = &GetDeclTypeSpec()->derivedTypeSpec();
 }
 
-void DeclarationVisitor::Post(const parser::DerivedTypeDef &x) {
-  std::set<SourceName> paramNames;
+// The descendents of DerivedTypeDef in the parse tree are visited directly
+// in this Pre() routine so that recursive use of the derived type can be
+// supported in the components.
+bool DeclarationVisitor::Pre(const parser::DerivedTypeDef &x) {
+  Walk(std::get<parser::Statement<parser::DerivedTypeStmt>>(x.t));
+  Walk(std::get<std::list<parser::Statement<parser::TypeParamDefStmt>>>(x.t));
   auto &scope{currScope()};
   CHECK(scope.symbol() != nullptr);
   CHECK(scope.symbol()->scope() == &scope);
   auto &details{scope.symbol()->get<DerivedTypeDetails>()};
   auto &stmt{std::get<parser::Statement<parser::DerivedTypeStmt>>(x.t)};
+  std::set<SourceName> paramNames;
   for (auto &paramName : std::get<std::list<parser::Name>>(stmt.statement.t)) {
     details.add_paramName(paramName.source);
     auto *symbol{FindInScope(scope, paramName)};
@@ -2838,6 +2845,7 @@ void DeclarationVisitor::Post(const parser::DerivedTypeDef &x) {
           currScope());  // C742
     }
   }
+  Walk(std::get<std::list<parser::Statement<parser::PrivateOrSequence>>>(x.t));
   if (derivedTypeInfo_.sequence) {
     details.set_sequence(true);
     if (derivedTypeInfo_.extends) {
@@ -2848,13 +2856,13 @@ void DeclarationVisitor::Post(const parser::DerivedTypeDef &x) {
       Say(stmt.source,
           "A sequence type may not have type parameters"_err_en_US);  // C740
     }
-    if (derivedTypeInfo_.sawContains) {
-      Say(stmt.source,
-          "A sequence type may not have a CONTAINS statement"_err_en_US);  // C740
-    }
   }
+  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_ = {};
   PopScope();
+  return false;
 }
 bool DeclarationVisitor::Pre(const parser::DerivedTypeStmt &x) {
   return BeginAttrs();
@@ -2862,6 +2870,7 @@ bool DeclarationVisitor::Pre(const parser::DerivedTypeStmt &x) {
 void DeclarationVisitor::Post(const parser::DerivedTypeStmt &x) {
   auto &name{std::get<parser::Name>(x.t)};
   auto &symbol{MakeSymbol(name, GetAttrs(), DerivedTypeDetails{})};
+  derivedTypeInfo_.type = &symbol;
   PushScope(Scope::Kind::DerivedType, &symbol);
   if (auto *extendsName{derivedTypeInfo_.extends}) {
     if (const Symbol * extends{ResolveDerivedType(*extendsName)}) {
@@ -2931,6 +2940,16 @@ void DeclarationVisitor::Post(const parser::ComponentDecl &x) {
       !attrs.HasAny({Attr::PUBLIC, Attr::PRIVATE})) {
     attrs.set(Attr::PRIVATE);
   }
+  if (!attrs.HasAny({Attr::POINTER, Attr::ALLOCATABLE})) {
+    if (const auto *declType{GetDeclTypeSpec()}) {
+      if (const auto *derived{declType->AsDerived()}) {
+        if (derivedTypeInfo_.type == &derived->typeSymbol()) {  // C737
+          Say("Recursive use of the derived type requires "
+              "POINTER or ALLOCATABLE"_err_en_US);
+        }
+      }
+    }
+  }
   if (OkToAddComponent(name)) {
     auto &symbol{DeclareObjectEntity(name, attrs)};
     if (auto *details{symbol.detailsIf<ObjectEntityDetails>()}) {
@@ -2987,6 +3006,12 @@ bool DeclarationVisitor::Pre(const parser::TypeBoundProcedurePart &x) {
   return true;
 }
 
+void DeclarationVisitor::Post(const parser::ContainsStmt &) {
+  if (derivedTypeInfo_.sequence) {
+    Say("A sequence type may not have a CONTAINS statement"_err_en_US);  // C740
+  }
+}
+
 void DeclarationVisitor::Post(
     const parser::TypeBoundProcedureStmt::WithoutInterface &x) {
   if (GetAttrs().test(Attr::DEFERRED)) {  // C783

diff --git a/flang/test/semantics/CMakeLists.txt b/flang/test/semantics/CMakeLists.txt
index c275160..016ac62 100644 (file)
--- a/flang/test/semantics/CMakeLists.txt
+++ b/flang/test/semantics/CMakeLists.txt
@@ -69,6 +69,7 @@ set(ERROR_TESTS
   resolve41.f90
   resolve42.f90
   resolve43.f90
+  resolve44.f90
   structconst01.f90
 )
 

diff --git a/flang/test/semantics/resolve31.f90 b/flang/test/semantics/resolve31.f90
index 9e3f800..b0d745d 100644 (file)
--- a/flang/test/semantics/resolve31.f90
+++ b/flang/test/semantics/resolve31.f90
@@ -60,10 +60,10 @@ module m4
     sequence
     integer i
   end type
-  !ERROR: A sequence type may not have a CONTAINS statement
   type :: t3
     sequence
     integer i
+  !ERROR: A sequence type may not have a CONTAINS statement
   contains
   end type
 contains

diff --git a/flang/test/semantics/resolve33.f90 b/flang/test/semantics/resolve33.f90
index f5bc58b..833580d 100644 (file)
--- a/flang/test/semantics/resolve33.f90
+++ b/flang/test/semantics/resolve33.f90
@@ -25,7 +25,7 @@ module m
     integer, kind :: a
     integer, len :: c
   end type
-  !ERROR: 'b' is not defined as a type parameter
+  !ERROR: No definition found for type parameter 'b'
   type t3(a, b)
     integer, kind :: a
     integer :: b

diff --git a/flang/test/semantics/resolve44.f90 b/flang/test/semantics/resolve44.f90
new file mode 100644 (file)
index 0000000..13bdf06
--- /dev/null
+++ b/flang/test/semantics/resolve44.f90
@@ -0,0 +1,40 @@
+! Copyright (c) 2019, NVIDIA CORPORATION.  All rights reserved.
+!
+! Licensed under the Apache License, Version 2.0 (the "License");
+! you may not use this file except in compliance with the License.
+! You may obtain a copy of the License at
+!
+!     http://www.apache.org/licenses/LICENSE-2.0
+!
+! Unless required by applicable law or agreed to in writing, software
+! distributed under the License is distributed on an "AS IS" BASIS,
+! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+! See the License for the specific language governing permissions and
+! limitations under the License.
+
+! Error tests for recursive use of derived types.
+
+program main
+  type :: recursive1
+    !ERROR: Recursive use of the derived type requires POINTER or ALLOCATABLE
+    type(recursive1) :: bad
+    type(recursive1), pointer :: ok1
+    type(recursive1), allocatable :: ok2
+  end type recursive1
+  type :: recursive2(kind,len)
+    integer, kind :: kind
+    integer, len :: len
+    !ERROR: Recursive use of the derived type requires POINTER or ALLOCATABLE
+    type(recursive2(kind,len)) :: bad
+    type(recursive2(kind,len)), pointer :: ok1
+    type(recursive2(kind,len)), allocatable :: ok2
+  end type recursive2
+  type :: recursive3(kind,len)
+    integer, kind :: kind = 1
+    integer, len :: len = 2
+    !ERROR: Recursive use of the derived type requires POINTER or ALLOCATABLE
+    type(recursive3) :: bad
+    type(recursive3), pointer :: ok1
+    type(recursive3), allocatable :: ok2
+  end type recursive3
+end program main