From 407542b3ecbee9a5cff0a9dd2019d5dfeb783360 Mon Sep 17 00:00:00 2001 From: Peter Klausler Date: Mon, 30 Jun 2025 10:25:00 -0700 Subject: [PATCH] [flang] Process pointer component default initializers sooner (#145601) Name resolution defers the analysis of all object pointer initializers to the end of a specification part, including the default initializers of derived type data pointer components. This deferment allows object pointer initializers to contain forward references to objects whose declarations appear later. However, this deferment has the unfortunate effect of causing NULL default initialization of such object pointer components when they do not appear in structure constructors that are used as default initializers, and their default initializers are required. So handle object pointer default initializers of components as they appear, as before. --- flang/docs/Extensions.md | 7 +++++++ flang/lib/Semantics/resolve-names.cpp | 19 +++++++++---------- flang/test/Semantics/bug1056.f90 | 13 +++++++++++++ flang/test/Semantics/symbol15.f90 | 19 +++++++++++-------- t.f90 | 11 +++++++++++ 5 files changed, 51 insertions(+), 18 deletions(-) create mode 100644 flang/test/Semantics/bug1056.f90 create mode 100644 t.f90 diff --git a/flang/docs/Extensions.md b/flang/docs/Extensions.md index 3503a0dde694..37a49f12f917 100644 --- a/flang/docs/Extensions.md +++ b/flang/docs/Extensions.md @@ -875,6 +875,13 @@ print *, [(j,j=1,10)] compilers) and don't use any defined unformatted WRITE that might have been defined. +* Forward references to target objects are allowed to appear + in the initializers of data pointer declarationss. + Forward references to target objects are not accepted in the default + initializers of derived type component declarations, however, + since these default values need to be available to process incomplete + structure constructors. + ## De Facto Standard Features * `EXTENDS_TYPE_OF()` returns `.TRUE.` if both of its arguments have the diff --git a/flang/lib/Semantics/resolve-names.cpp b/flang/lib/Semantics/resolve-names.cpp index 9e465f8ff3e1..987824f0fcee 100644 --- a/flang/lib/Semantics/resolve-names.cpp +++ b/flang/lib/Semantics/resolve-names.cpp @@ -5383,7 +5383,7 @@ void DeclarationVisitor::Post(const parser::EntityDecl &x) { ConvertToObjectEntity(symbol) || ConvertToProcEntity(symbol); symbol.set( Symbol::Flag::EntryDummyArgument, false); // forestall excessive errors - Initialization(name, *init, false); + Initialization(name, *init, /*inComponentDecl=*/false); } else if (attrs.test(Attr::PARAMETER)) { // C882, C883 Say(name, "Missing initialization for parameter '%s'"_err_en_US); } @@ -6398,7 +6398,7 @@ void DeclarationVisitor::Post(const parser::ComponentDecl &x) { SetCUDADataAttr(name.source, symbol, cudaDataAttr()); if (symbol.has()) { if (auto &init{std::get>(x.t)}) { - Initialization(name, *init, true); + Initialization(name, *init, /*inComponentDecl=*/true); } } currScope().symbol()->get().add_component(symbol); @@ -8933,9 +8933,13 @@ void DeclarationVisitor::Initialization(const parser::Name &name, // Defer analysis to the end of the specification part // so that forward references and attribute checks like SAVE // work better. - auto restorer{common::ScopedSet(deferImplicitTyping_, true)}; - Walk(target); - ultimate.set(Symbol::Flag::InDataStmt); + if (inComponentDecl) { + PointerInitialization(name, target); + } else { + auto restorer{common::ScopedSet(deferImplicitTyping_, true)}; + Walk(target); + ultimate.set(Symbol::Flag::InDataStmt); + } }, [&](const std::list> &values) { // Handled later in data-to-inits conversion @@ -10355,11 +10359,6 @@ public: std::get>(decl.t)); return false; } - bool Pre(const parser::ComponentDecl &decl) { - Init(std::get(decl.t), - std::get>(decl.t)); - return false; - } bool Pre(const parser::ProcDecl &decl) { if (const auto &init{ std::get>(decl.t)}) { diff --git a/flang/test/Semantics/bug1056.f90 b/flang/test/Semantics/bug1056.f90 new file mode 100644 index 000000000000..b32270dab8f7 --- /dev/null +++ b/flang/test/Semantics/bug1056.f90 @@ -0,0 +1,13 @@ +! RUN: %flang_fc1 -fdebug-unparse %s | FileCheck %s +program bug + integer, target :: ita(2) = [1,2], itb(2) = [3,4], itc(2) = [5,6] + type t1 + integer, pointer :: p1(:) => ita, p2(:) => itb + end type + type t2 + !CHECK: TYPE(t1) :: comp = t1(p1=itc,p2=itb) + type(t1) :: comp = t1(itc) + end type + integer, pointer :: p3(:) => itd + integer, target :: itd(2) = [7,8] +end diff --git a/flang/test/Semantics/symbol15.f90 b/flang/test/Semantics/symbol15.f90 index 97dc50a23845..df10942e6af2 100644 --- a/flang/test/Semantics/symbol15.f90 +++ b/flang/test/Semantics/symbol15.f90 @@ -43,6 +43,9 @@ module m !DEF: /m/pp6 EXTERNAL, POINTER, PUBLIC (Subroutine) ProcEntity !DEF: /m/modproc1 PUBLIC (Subroutine) Subprogram procedure(iface), pointer :: pp6 => modproc1 + !DEF: /m/xx PUBLIC, TARGET ObjectEntity REAL(4) + !DEF: /m/yy PUBLIC, TARGET ObjectEntity REAL(4) + real, target :: xx, yy(2) !DEF: /m/t1 PUBLIC DerivedType type :: t1 !DEF: /m/t1/opc1 POINTER ObjectEntity REAL(4) @@ -51,11 +54,11 @@ module m !REF: /m/null real, pointer :: opc2 => null() !DEF: /m/t1/opc3 POINTER ObjectEntity REAL(4) - !REF: /m/x - real, pointer :: opc3 => x + !REF: /m/xx + real, pointer :: opc3 => xx !DEF: /m/t1/opc4 POINTER ObjectEntity REAL(4) - !REF: /m/y - real, pointer :: opc4 => y(1) + !REF: /m/yy + real, pointer :: opc4 => yy(1) !REF: /m/iface !DEF: /m/t1/ppc1 NOPASS, POINTER (Subroutine) ProcEntity procedure(iface), nopass, pointer :: ppc1 @@ -101,12 +104,12 @@ module m !REF: /m/null real, pointer :: opc2 => null() !DEF: /m/pdt1/opc3 POINTER ObjectEntity REAL(4) - !REF: /m/x - real, pointer :: opc3 => x + !REF: /m/xx + real, pointer :: opc3 => xx !DEF: /m/pdt1/opc4 POINTER ObjectEntity REAL(4) - !REF: /m/y + !REF: /m/yy !REF: /m/pdt1/k - real, pointer :: opc4 => y(k) + real, pointer :: opc4 => yy(k) !REF: /m/iface !DEF: /m/pdt1/ppc1 NOPASS, POINTER (Subroutine) ProcEntity procedure(iface), nopass, pointer :: ppc1 diff --git a/t.f90 b/t.f90 new file mode 100644 index 000000000000..2b8f7129ca66 --- /dev/null +++ b/t.f90 @@ -0,0 +1,11 @@ +integer, target :: ita(2) = [1,2], itb(2) = [3,4], itc(2) = [5,6] +type t1 + integer, pointer :: p1(:) => ita, p2(:) => itb +end type +type t2 + type(t1) :: comp = t1(itc) +end type +type(t2) :: var +print *, var%comp%p2 +var%comp = t1(itc) +end