[flang-commits] [flang] [flang] Expand parent component in procedure pointer component refere… (PR #78593)

[via flang-commits]

llvmbot wrote:


<!--LLVM PR SUMMARY COMMENT-->

@llvm/pr-subscribers-flang-fir-hlfir

Author: None (jeanPerier)

<details>
<summary>Changes</summary>

…nces

For simplicity, lowering relies on semantics expansion of parent components in designators.

This was not done in `call x%p()` where `p` is a procedure component pointer of a parent component of `x`.

Do it and turn lowering TODO into fatal error.

---
Full diff: https://github.com/llvm/llvm-project/pull/78593.diff


4 Files Affected:

- (modified) flang/include/flang/Semantics/expression.h (+2-2) 
- (modified) flang/lib/Lower/ConvertProcedureDesignator.cpp (+4-3) 
- (modified) flang/lib/Semantics/expression.cpp (+15-7) 
- (added) flang/test/Lower/HLFIR/proc-pointer-comp-in-parent.f90 (+30) 


``````````diff
diff --git a/flang/include/flang/Semantics/expression.h b/flang/include/flang/Semantics/expression.h
index 790d0a4d6d06414..64b4ed6924b7b88 100644
--- a/flang/include/flang/Semantics/expression.h
+++ b/flang/include/flang/Semantics/expression.h
@@ -327,8 +327,8 @@ class ExpressionAnalyzer {
       const parser::SectionSubscript &);
   std::vector<Subscript> AnalyzeSectionSubscripts(
       const std::list<parser::SectionSubscript> &);
-  std::optional<Component> CreateComponent(
-      DataRef &&, const Symbol &, const semantics::Scope &);
+  std::optional<Component> CreateComponent(DataRef &&, const Symbol &,
+      const semantics::Scope &, bool C919AlreadyEnforced = false);
   MaybeExpr CompleteSubscripts(ArrayRef &&);
   MaybeExpr ApplySubscripts(DataRef &&, std::vector<Subscript> &&);
   void CheckConstantSubscripts(ArrayRef &);
diff --git a/flang/lib/Lower/ConvertProcedureDesignator.cpp b/flang/lib/Lower/ConvertProcedureDesignator.cpp
index 0806f78450dd6f1..5dd1d85cb9d2876 100644
--- a/flang/lib/Lower/ConvertProcedureDesignator.cpp
+++ b/flang/lib/Lower/ConvertProcedureDesignator.cpp
@@ -113,10 +113,11 @@ static hlfir::EntityWithAttributes designateProcedurePointerComponent(
   auto recordType =
       hlfir::getFortranElementType(base.getType()).cast<fir::RecordType>();
   mlir::Type fieldType = recordType.getType(fieldName);
-  // FIXME: semantics is not expanding intermediate parent components in:
-  // call x%p() where p is a component of a parent type of x type.
+  // Note: semantics turns x%p() into x%t%p() when the procedure pointer
+  // component is part of parent component t.
   if (!fieldType)
-    TODO(loc, "reference to procedure pointer component from parent type");
+    fir::emitFatalError(loc,
+                        "procedure pointer component not found in FIR type");
   mlir::Type designatorType = fir::ReferenceType::get(fieldType);
   mlir::Value compRef = builder.create<hlfir::DesignateOp>(
       loc, designatorType, base, fieldName,
diff --git a/flang/lib/Semantics/expression.cpp b/flang/lib/Semantics/expression.cpp
index bfc380183e23f55..7f066412b48e9ba 100644
--- a/flang/lib/Semantics/expression.cpp
+++ b/flang/lib/Semantics/expression.cpp
@@ -1296,9 +1296,11 @@ static NamedEntity IgnoreAnySubscripts(Designator<SomeDerived> &&designator) {
 }
 
 // Components of parent derived types are explicitly represented as such.
-std::optional<Component> ExpressionAnalyzer::CreateComponent(
-    DataRef &&base, const Symbol &component, const semantics::Scope &scope) {
-  if (IsAllocatableOrPointer(component) && base.Rank() > 0) { // C919b
+std::optional<Component> ExpressionAnalyzer::CreateComponent(DataRef &&base,
+    const Symbol &component, const semantics::Scope &scope,
+    bool C919AlreadyEnforced) {
+  if (!C919AlreadyEnforced && IsAllocatableOrPointer(component) &&
+      base.Rank() > 0) { // C919b
     Say("An allocatable or pointer component reference must be applied to a scalar base"_err_en_US);
   }
   if (&component.owner() == &scope) {
@@ -1313,7 +1315,7 @@ std::optional<Component> ExpressionAnalyzer::CreateComponent(
                   parentType->derivedTypeSpec().scope()}) {
             return CreateComponent(
                 DataRef{Component{std::move(base), *parentComponent}},
-                component, *parentScope);
+                component, *parentScope, C919AlreadyEnforced);
           }
         }
       }
@@ -2391,9 +2393,15 @@ auto ExpressionAnalyzer::AnalyzeProcedureComponentRef(
               ProcedureDesignator{*resolution}, std::move(arguments)};
         } else if (dataRef.has_value()) {
           if (sym->attrs().test(semantics::Attr::NOPASS)) {
-            return CalleeAndArguments{
-                ProcedureDesignator{Component{std::move(*dataRef), *sym}},
-                std::move(arguments)};
+            const auto *dtSpec{GetDerivedTypeSpec(dtExpr->GetType())};
+            if (dtSpec && dtSpec->scope()) {
+              if (auto component{CreateComponent(std::move(*dataRef), *sym,
+                      *dtSpec->scope(), /*C919AlreadyEnforced=*/true)}) {
+                return CalleeAndArguments{
+                    ProcedureDesignator{std::move(*component)},
+                    std::move(arguments)};
+              }
+            }
           } else {
             AddPassArg(arguments,
                 Expr<SomeDerived>{Designator<SomeDerived>{std::move(*dataRef)}},
diff --git a/flang/test/Lower/HLFIR/proc-pointer-comp-in-parent.f90 b/flang/test/Lower/HLFIR/proc-pointer-comp-in-parent.f90
new file mode 100644
index 000000000000000..5b37b6a8651ddde
--- /dev/null
+++ b/flang/test/Lower/HLFIR/proc-pointer-comp-in-parent.f90
@@ -0,0 +1,30 @@
+! Test that parent components are made explicit in reference to
+! procedure pointer from parent type.
+! RUN: bbc -emit-hlfir -o - %s | FileCheck %s
+
+module type_defs
+ interface
+  subroutine s1
+  end subroutine
+  real function s2()
+  end function
+ end interface
+ type :: t
+  procedure(s1), pointer, nopass :: p1
+  procedure(s2), pointer, nopass :: p2
+ end type
+ type, extends(t) :: t2
+ end type
+end module
+
+! CHECK-LABEL: func.func @_QPtest(
+subroutine test (x)
+use type_defs, only : t2
+type(t2) :: x
+call x%p1()
+! CHECK: %[[T_REF1:.*]] = hlfir.designate %{{.*}}{"t"}
+! CHECK: hlfir.designate %[[T_REF1]]{"p1"}
+print *, x%p2()
+! CHECK: %[[T_REF2:.*]] = hlfir.designate %{{.*}}{"t"}
+! CHECK: hlfir.designate %[[T_REF2]]{"p2"}
+end subroutine

``````````

</details>


https://github.com/llvm/llvm-project/pull/78593