From 7a989fa08ab2b9fa4fc6da69dde07335d3987684 Mon Sep 17 00:00:00 2001
From: Peter Klausler <pklausler@nvidia.com>
Date: Fri, 3 Oct 2025 14:05:41 -0700
Subject: [PATCH] [flang] Don't misinterpret valid component value for ancestor
 type

As a common language extension, this compiler accepts a structure
constructor whose first value has no keyword and whose type matches
an ancestral type as if the constructor had had a keyword whose
name was the ancestral type.  For example, given
  TYPE PARENT; REAL X; END TYPE
  TYPE, EXTENDS(PARENT) :: CHILD; END TYPE
we accept the nonconforming constructor "child(parent(1.))" as if it
had been the conforming "child(1.)" or "child(parent=parent(1.))".

The detection of this case needs to be constrained a bit to avoid
a false positive misinterpretation of conforming code in the case
where the actual first component of the derived type is a POINTER
or ALLOCATABLE whose type and rank would allow it to correspond
with the keywordless first value in the component value list.

Fixes https://github.com/llvm/llvm-project/issues/161887.
---
 flang/lib/Semantics/expression.cpp     | 34 ++++++----
 flang/test/Semantics/structconst11.f90 | 89 ++++++++++++++++++++++++++
 2 files changed, 112 insertions(+), 11 deletions(-)
 create mode 100644 flang/test/Semantics/structconst11.f90

diff --git a/flang/lib/Semantics/expression.cpp b/flang/lib/Semantics/expression.cpp
index fc268886c5feb..126dc4c3c62d0 100644
--- a/flang/lib/Semantics/expression.cpp
+++ b/flang/lib/Semantics/expression.cpp
@@ -2171,17 +2171,29 @@ MaybeExpr ExpressionAnalyzer::CheckStructureConstructor(
       // T(1) or T(PT=PT(1)).  There may be multiple parent components.
       if (nextAnonymous == components.begin() && parentComponent && valueType &&
           context().IsEnabled(LanguageFeature::AnonymousParents)) {
-        for (auto parent{components.begin()};
-             parent != afterLastParentComponentIter; ++parent) {
-          if (auto parentType{DynamicType::From(*parent)}; parentType &&
-              parent->test(Symbol::Flag::ParentComp) &&
-              valueType->IsEquivalentTo(*parentType)) {
-            symbol = &*parent;
-            nextAnonymous = ++parent;
-            Warn(LanguageFeature::AnonymousParents, source,
-                "Whole parent component '%s' in structure constructor should not be anonymous"_port_en_US,
-                symbol->name());
-            break;
+        auto parent{components.begin()};
+        if (!parent->test(Symbol::Flag::ParentComp)) {
+          // Ensure that the first value can't initialize the first actual
+          // component.
+          if (auto firstComponentType{DynamicType::From(*parent)}) {
+            if (firstComponentType->IsTkCompatibleWith(*valueType) &&
+                value.Rank() == parent->Rank()) {
+              parent = afterLastParentComponentIter; // skip next loop
+            }
+          }
+        }
+        for (; parent != afterLastParentComponentIter; ++parent) {
+          if (auto parentType{DynamicType::From(*parent)}) {
+            if (parent->test(Symbol::Flag::ParentComp) &&
+                valueType->IsEquivalentTo(*parentType) &&
+                value.Rank() == 0 /* scalar only */) {
+              symbol = &*parent;
+              nextAnonymous = ++parent;
+              Warn(LanguageFeature::AnonymousParents, source,
+                  "Whole parent component '%s' in structure constructor should not be anonymous"_port_en_US,
+                  symbol->name());
+              break;
+            }
           }
         }
       }
diff --git a/flang/test/Semantics/structconst11.f90 b/flang/test/Semantics/structconst11.f90
new file mode 100644
index 0000000000000..8cf4e6a4cda29
--- /dev/null
+++ b/flang/test/Semantics/structconst11.f90
@@ -0,0 +1,89 @@
+!RUN: %flang_fc1 -fdebug-unparse %s | FileCheck %s
+program test
+
+  type t1p
+    type(t1p), pointer :: arr(:)
+  end type
+  type, extends(t1p) :: t1c
+  end type
+  type t2p
+    type(t2p), pointer :: scalar
+  end type
+  type, extends(t2p) :: t2c
+  end type
+  type t3p
+    type(t3p), allocatable :: arr(:)
+  end type
+  type, extends(t3p) :: t3c
+  end type
+  type t4p
+    type(t4p), allocatable :: scalar
+  end type
+  type, extends(t4p) :: t4c
+  end type
+  type t5p
+    class(*), pointer :: arr(:)
+  end type
+  type, extends(t5p) :: t5c
+  end type
+  type t6p
+    class(*), pointer :: scalar
+  end type
+  type, extends(t6p) :: t6c
+  end type
+  type t7p
+    class(*), allocatable :: arr(:)
+  end type
+  type, extends(t7p) :: t7c
+  end type
+  type t8p
+    class(*), allocatable :: scalar
+  end type
+  type, extends(t8p) :: t8c
+  end type
+
+  type(t1p), target :: t1pt(1)
+  type(t1p), pointer :: t1pp(:)
+  type(t2p), target :: t2pt
+  type(t2p), pointer :: t2pp
+  type(t3p) t3pa(1)
+  type(t4p) t4ps
+
+  type(t1c) x1
+  type(t2c) x2
+  type(t3c) x3
+  type(t4c) x4
+  type(t5c) x5
+  type(t6c) x6
+  type(t7c) x7
+  type(t8c) x8
+
+!CHECK: x1=t1c(arr=t1pt)
+  x1 = t1c(t1pt)
+!CHECK: x1=t1c(arr=t1pp)
+  x1 = t1c(t1pp)
+!CHECK: x2=t2c(scalar=t2pt)
+  x2 = t2c(t2pt)
+!CHECK: x2=t2c(scalar=t2pp)
+  x2 = t2c(t2pp)
+!CHECK: x3=t3c(arr=t3pa)
+  x3 = t3c(t3pa)
+!CHECK: x4=t4c(scalar=t4ps)
+  x4 = t4c(t4ps)
+!CHECK: x4=t4c(scalar=t4p(scalar=NULL()))
+  x4 = t4c(t4p())
+!CHECK: x5=t5c(arr=t1pt)
+  x5 = t5c(t1pt)
+!CHECK: x5=t5c(arr=t1pp)
+  x5 = t5c(t1pp)
+!CHECK: x6=t6c(scalar=t2pt)
+  x6 = t6c(t2pt)
+!CHECK: x6=t6c(scalar=t2pp)
+  x6 = t6c(t2pp)
+!CHECK: x7=t7c(arr=t3pa)
+  x7 = t7c(t3pa)
+!CHECK: x8=t8c(scalar=t4ps)
+  x8 = t8c(t4ps)
+!CHECK: x8=t8c(scalar=t4p(scalar=NULL()))
+  x8 = t8c(t4p())
+end