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

via flang-commits flang-commits at lists.llvm.org
Thu Jan 18 09:28:26 PST 2024


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

>From 104d90f58e1f1b184fd19d5056f756c928244148 Mon Sep 17 00:00:00 2001
From: Jean Perier <jperier at nvidia.com>
Date: Thu, 18 Jan 2024 06:57:41 -0800
Subject: [PATCH 1/2] [flang] Expand parent component in procedure pointer
 component references

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.
---
 flang/include/flang/Semantics/expression.h    |  4 +--
 .../lib/Lower/ConvertProcedureDesignator.cpp  |  7 +++--
 flang/lib/Semantics/expression.cpp            | 22 +++++++++-----
 .../HLFIR/proc-pointer-comp-in-parent.f90     | 30 +++++++++++++++++++
 4 files changed, 51 insertions(+), 12 deletions(-)
 create mode 100644 flang/test/Lower/HLFIR/proc-pointer-comp-in-parent.f90

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

>From a19e80818f910557f8b5c2b754ef2b86b5788561 Mon Sep 17 00:00:00 2001
From: Jean Perier <jperier at nvidia.com>
Date: Thu, 18 Jan 2024 09:27:12 -0800
Subject: [PATCH 2/2] add error in fallthrough

---
 flang/include/flang/Semantics/expression.h |  2 +-
 flang/lib/Semantics/expression.cpp         | 11 +++++++----
 2 files changed, 8 insertions(+), 5 deletions(-)

diff --git a/flang/include/flang/Semantics/expression.h b/flang/include/flang/Semantics/expression.h
index 64b4ed6924b7b88..a330e241c2cdaa1 100644
--- a/flang/include/flang/Semantics/expression.h
+++ b/flang/include/flang/Semantics/expression.h
@@ -328,7 +328,7 @@ class ExpressionAnalyzer {
   std::vector<Subscript> AnalyzeSectionSubscripts(
       const std::list<parser::SectionSubscript> &);
   std::optional<Component> CreateComponent(DataRef &&, const Symbol &,
-      const semantics::Scope &, bool C919AlreadyEnforced = false);
+      const semantics::Scope &, bool C919bAlreadyEnforced = false);
   MaybeExpr CompleteSubscripts(ArrayRef &&);
   MaybeExpr ApplySubscripts(DataRef &&, std::vector<Subscript> &&);
   void CheckConstantSubscripts(ArrayRef &);
diff --git a/flang/lib/Semantics/expression.cpp b/flang/lib/Semantics/expression.cpp
index 7f066412b48e9ba..44e16ac9387370e 100644
--- a/flang/lib/Semantics/expression.cpp
+++ b/flang/lib/Semantics/expression.cpp
@@ -1298,8 +1298,8 @@ 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,
-    bool C919AlreadyEnforced) {
-  if (!C919AlreadyEnforced && IsAllocatableOrPointer(component) &&
+    bool C919bAlreadyEnforced) {
+  if (!C919bAlreadyEnforced && IsAllocatableOrPointer(component) &&
       base.Rank() > 0) { // C919b
     Say("An allocatable or pointer component reference must be applied to a scalar base"_err_en_US);
   }
@@ -1315,7 +1315,7 @@ std::optional<Component> ExpressionAnalyzer::CreateComponent(DataRef &&base,
                   parentType->derivedTypeSpec().scope()}) {
             return CreateComponent(
                 DataRef{Component{std::move(base), *parentComponent}},
-                component, *parentScope, C919AlreadyEnforced);
+                component, *parentScope, C919bAlreadyEnforced);
           }
         }
       }
@@ -2396,12 +2396,15 @@ auto ExpressionAnalyzer::AnalyzeProcedureComponentRef(
             const auto *dtSpec{GetDerivedTypeSpec(dtExpr->GetType())};
             if (dtSpec && dtSpec->scope()) {
               if (auto component{CreateComponent(std::move(*dataRef), *sym,
-                      *dtSpec->scope(), /*C919AlreadyEnforced=*/true)}) {
+                      *dtSpec->scope(), /*C919bAlreadyEnforced=*/true)}) {
                 return CalleeAndArguments{
                     ProcedureDesignator{std::move(*component)},
                     std::move(arguments)};
               }
             }
+            Say(sc.component.source,
+                "Component is not in scope of base derived type"_err_en_US);
+            return std::nullopt;
           } else {
             AddPassArg(arguments,
                 Expr<SomeDerived>{Designator<SomeDerived>{std::move(*dataRef)}},



More information about the flang-commits mailing list