[flang-commits] [flang] [flang] Avoid crash in name resolution on erroneous type extension (PR #109312)

[Peter Klausler via flang-commits]

https://github.com/klausler created https://github.com/llvm/llvm-project/pull/109312

Don't crash when a bad Fortran program tries to extend a derived type with previous legitimate forward references but no prior definition.

Fixes https://github.com/llvm/llvm-project/issues/109268.

>From 3fa56a39adaa0dca3c9f96674a8e634d58e94aea Mon Sep 17 00:00:00 2001
From: Peter Klausler <pklausler at nvidia.com>
Date: Thu, 19 Sep 2024 09:52:43 -0700
Subject: [PATCH] [flang] Avoid crash in name resolution on erroneous type
 extension

Don't crash when a bad Fortran program tries to extend a derived
type with previous legitimate forward references but no prior
definition.

Fixes https://github.com/llvm/llvm-project/issues/109268.
---
 flang/lib/Semantics/resolve-names.cpp     | 25 ++++++++++++++---------
 flang/test/Semantics/bad-forward-type.f90 | 15 ++++++++++++++
 2 files changed, 30 insertions(+), 10 deletions(-)

diff --git a/flang/lib/Semantics/resolve-names.cpp b/flang/lib/Semantics/resolve-names.cpp
index 5414787d85f7f7..b105dbdce911aa 100644
--- a/flang/lib/Semantics/resolve-names.cpp
+++ b/flang/lib/Semantics/resolve-names.cpp
@@ -1204,7 +1204,7 @@ class DeclarationVisitor : public ArraySpecVisitor,
       const parser::Name &, const parser::Name *);
   Symbol *MakeTypeSymbol(const SourceName &, Details &&);
   Symbol *MakeTypeSymbol(const parser::Name &, Details &&);
-  bool OkToAddComponent(const parser::Name &, const Symbol * = nullptr);
+  bool OkToAddComponent(const parser::Name &, const Symbol *extends = nullptr);
   ParamValue GetParamValue(
       const parser::TypeParamValue &, common::TypeParamAttr attr);
   void CheckCommonBlockDerivedType(
@@ -5606,7 +5606,7 @@ void DeclarationVisitor::Post(const parser::DerivedTypeStmt &x) {
       comp.set(Symbol::Flag::ParentComp);
       DeclTypeSpec &type{currScope().MakeDerivedType(
           DeclTypeSpec::TypeDerived, std::move(*extendsType))};
-      type.derivedTypeSpec().set_scope(*extendsSymbol.scope());
+      type.derivedTypeSpec().set_scope(DEREF(extendsSymbol.scope()));
       comp.SetType(type);
       DerivedTypeDetails &details{symbol.get<DerivedTypeDetails>()};
       details.add_component(comp);
@@ -6797,15 +6797,20 @@ std::optional<DerivedTypeSpec> DeclarationVisitor::ResolveDerivedType(
 
 std::optional<DerivedTypeSpec> DeclarationVisitor::ResolveExtendsType(
     const parser::Name &typeName, const parser::Name *extendsName) {
-  if (!extendsName) {
-    return std::nullopt;
-  } else if (typeName.source == extendsName->source) {
-    Say(extendsName->source,
-        "Derived type '%s' cannot extend itself"_err_en_US);
-    return std::nullopt;
-  } else {
-    return ResolveDerivedType(*extendsName);
+  if (extendsName) {
+    if (typeName.source == extendsName->source) {
+      Say(extendsName->source,
+          "Derived type '%s' cannot extend itself"_err_en_US);
+    } else if (auto dtSpec{ResolveDerivedType(*extendsName)}) {
+      if (!dtSpec->IsForwardReferenced()) {
+        return dtSpec;
+      }
+      Say(typeName.source,
+          "Derived type '%s' cannot extend type '%s' that has not yet been defined"_err_en_US,
+          typeName.source, extendsName->source);
+    }
   }
+  return std::nullopt;
 }
 
 Symbol *DeclarationVisitor::NoteInterfaceName(const parser::Name &name) {
diff --git a/flang/test/Semantics/bad-forward-type.f90 b/flang/test/Semantics/bad-forward-type.f90
index 27c6045b0059fa..f379b274e1279b 100644
--- a/flang/test/Semantics/bad-forward-type.f90
+++ b/flang/test/Semantics/bad-forward-type.f90
@@ -97,3 +97,18 @@ subroutine s10
     type(undef), pointer :: y
   end type
 end subroutine s10
+
+subroutine s11
+  !ERROR: Derived type 'undef1' not found
+  type(undef1), pointer :: p
+  type t1
+    !ERROR: The derived type 'undef2' has not been defined
+    type(undef2), pointer :: p
+  end type
+  !ERROR: Derived type 'undef1' not found
+  type, extends(undef1) :: t2
+  end type
+  !ERROR: Derived type 't3' cannot extend type 'undef2' that has not yet been defined
+  type, extends(undef2) :: t3
+  end type
+end subroutine s11