[flang-commits] [flang] [flang] More support for anonymous parent components in struct constr… (PR #102642)

[Peter Klausler via flang-commits]

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

…uctors

A non-conforming extension to Fortran present in a couple other compilers is allowing a anonymous component in a structure constructor to initialize a parent (or greater ancestor) component.  This was working in this compiler only for direct parents, and only when the type was not use-associated.

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

>From 8b5811686c0bcfbd63c662d1999429a12d1fc7c0 Mon Sep 17 00:00:00 2001
From: Peter Klausler <pklausler at nvidia.com>
Date: Fri, 9 Aug 2024 09:28:36 -0700
Subject: [PATCH] [flang] More support for anonymous parent components in
 struct constructors

A non-conforming extension to Fortran present in a couple other compilers
is allowing a anonymous component in a structure constructor to
initialize a parent (or greater ancestor) component.  This was working
in this compiler only for direct parents, and only when the type was
not use-associated.

Fixes https://github.com/llvm/llvm-project/issues/102557.
---
 flang/lib/Semantics/expression.cpp     | 37 +++++++++++++++++---------
 flang/test/Semantics/structconst10.f90 | 25 +++++++++++++++++
 2 files changed, 49 insertions(+), 13 deletions(-)
 create mode 100644 flang/test/Semantics/structconst10.f90

diff --git a/flang/lib/Semantics/expression.cpp b/flang/lib/Semantics/expression.cpp
index 4f1c53f1bb53fc..4f8632a2055d99 100644
--- a/flang/lib/Semantics/expression.cpp
+++ b/flang/lib/Semantics/expression.cpp
@@ -2015,6 +2015,15 @@ MaybeExpr ExpressionAnalyzer::Analyze(
   // initialize X or A by name, but not both.
   auto components{semantics::OrderedComponentIterator{spec}};
   auto nextAnonymous{components.begin()};
+  auto afterLastParentComponentIter{components.end()};
+  if (parentComponent) {
+    for (auto iter{components.begin()}; iter != components.end(); ++iter) {
+      if (iter->test(Symbol::Flag::ParentComp)) {
+        afterLastParentComponentIter = iter;
+        ++afterLastParentComponentIter;
+      }
+    }
+  }
 
   std::set<parser::CharBlock> unavailable;
   bool anyKeyword{false};
@@ -2060,20 +2069,22 @@ MaybeExpr ExpressionAnalyzer::Analyze(
       }
       // Here's a regrettably common extension of the standard: anonymous
       // initialization of parent components, e.g., T(PT(1)) rather than
-      // T(1) or T(PT=PT(1)).
-      if (nextAnonymous == components.begin() && parentComponent &&
-          valueType == DynamicType::From(*parentComponent) &&
+      // T(1) or T(PT=PT(1)).  There may be multiple parent components.
+      if (nextAnonymous == components.begin() && parentComponent && valueType &&
           context().IsEnabled(LanguageFeature::AnonymousParents)) {
-        auto iter{
-            std::find(components.begin(), components.end(), *parentComponent)};
-        if (iter != components.end()) {
-          symbol = parentComponent;
-          nextAnonymous = ++iter;
-          if (context().ShouldWarn(LanguageFeature::AnonymousParents)) {
-            Say(source,
-                "Whole parent component '%s' in structure "
-                "constructor should not be anonymous"_port_en_US,
-                symbol->name());
+        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;
+            if (context().ShouldWarn(LanguageFeature::AnonymousParents)) {
+              Say(source,
+                  "Whole parent component '%s' in structure constructor should not be anonymous"_port_en_US,
+                  symbol->name());
+            }
+            break;
           }
         }
       }
diff --git a/flang/test/Semantics/structconst10.f90 b/flang/test/Semantics/structconst10.f90
new file mode 100644
index 00000000000000..582f8fc15704f4
--- /dev/null
+++ b/flang/test/Semantics/structconst10.f90
@@ -0,0 +1,25 @@
+! RUN: %python %S/test_errors.py %s %flang_fc1 -pedantic -Werror
+module m1
+  type a1
+     integer ::x1=1
+  end type a1
+  type,extends(a1)::a2
+     integer ::x2=3
+  end type a2
+  type,extends(a2)::a3
+     integer   ::x3=3
+  end type a3
+end module m1
+
+program test
+  use m1
+  type(a3) v
+  !PORTABILITY: Whole parent component 'a2' in structure constructor should not be anonymous
+  v=a3(a2(x1=18,x2=6),x3=6)
+  !PORTABILITY: Whole parent component 'a1' in structure constructor should not be anonymous
+  v=a3(a1(x1=18),x2=6,x3=6)
+  !PORTABILITY: Whole parent component 'a2' in structure constructor should not be anonymous
+  !PORTABILITY: Whole parent component 'a1' in structure constructor should not be anonymous
+  v=a3(a2(a1(x1=18),x2=6),x3=6)
+  v=a3(a2=a2(a1=a1(x1=18),x2=6),x3=6) ! ok
+end