diff --git a/flang/include/flang/Semantics/expression.h b/flang/include/flang/Semantics/expression.h index 790d0a4d6d064..a330e241c2cda 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 AnalyzeSectionSubscripts( const std::list &); - std::optional CreateComponent( - DataRef &&, const Symbol &, const semantics::Scope &); + std::optional CreateComponent(DataRef &&, const Symbol &, + const semantics::Scope &, bool C919bAlreadyEnforced = false); MaybeExpr CompleteSubscripts(ArrayRef &&); MaybeExpr ApplySubscripts(DataRef &&, std::vector &&); void CheckConstantSubscripts(ArrayRef &); diff --git a/flang/lib/Lower/ConvertProcedureDesignator.cpp b/flang/lib/Lower/ConvertProcedureDesignator.cpp index 0806f78450dd6..2446be3a1908b 100644 --- a/flang/lib/Lower/ConvertProcedureDesignator.cpp +++ b/flang/lib/Lower/ConvertProcedureDesignator.cpp @@ -113,10 +113,10 @@ static hlfir::EntityWithAttributes designateProcedurePointerComponent( auto recordType = hlfir::getFortranElementType(base.getType()).cast(); 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"); + TODO(loc, "passing type bound procedure (extension)"); mlir::Type designatorType = fir::ReferenceType::get(fieldType); mlir::Value compRef = builder.create( loc, designatorType, base, fieldName, diff --git a/flang/lib/Semantics/expression.cpp b/flang/lib/Semantics/expression.cpp index bfc380183e23f..44e16ac938737 100644 --- a/flang/lib/Semantics/expression.cpp +++ b/flang/lib/Semantics/expression.cpp @@ -1296,9 +1296,11 @@ static NamedEntity IgnoreAnySubscripts(Designator &&designator) { } // Components of parent derived types are explicitly represented as such. -std::optional ExpressionAnalyzer::CreateComponent( - DataRef &&base, const Symbol &component, const semantics::Scope &scope) { - if (IsAllocatableOrPointer(component) && base.Rank() > 0) { // C919b +std::optional ExpressionAnalyzer::CreateComponent(DataRef &&base, + const Symbol &component, const semantics::Scope &scope, + 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); } if (&component.owner() == &scope) { @@ -1313,7 +1315,7 @@ std::optional ExpressionAnalyzer::CreateComponent( parentType->derivedTypeSpec().scope()}) { return CreateComponent( DataRef{Component{std::move(base), *parentComponent}}, - component, *parentScope); + component, *parentScope, C919bAlreadyEnforced); } } } @@ -2391,9 +2393,18 @@ 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(), /*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{Designator{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 0000000000000..5b37b6a8651dd --- /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