Skip to content

Commit e84a985

Browse files
authored
[Flang] Support for NULL() and procedure in structure constructor for procedure pointer component. (#85991)
This PR fixes a subset of procedure pointer component initialization in structure constructor. It covers 1. NULL() 2. procedure For example: ``` MODULE M TYPE :: DT !PROCEDURE(Fun), POINTER, NOPASS :: pp1 PROCEDURE(Fun), POINTER :: pp1 END TYPE CONTAINS INTEGER FUNCTION Fun(Arg) class(dt) :: arg END FUNCTION END MODULE PROGRAM MAIN USE M IMPLICIT NONE TYPE (DT), PARAMETER :: v1 = DT(NULL()) TYPE (DT) :: v2 v2 = DT(fun) END ``` Passing a procedure pointer itself or reference to a function that returns a procedure pointer is TODO.
1 parent aa571a1 commit e84a985

File tree

2 files changed

+66
-4
lines changed

2 files changed

+66
-4
lines changed

flang/lib/Lower/ConvertConstant.cpp

Lines changed: 18 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -14,9 +14,12 @@
1414
#include "flang/Evaluate/expression.h"
1515
#include "flang/Lower/AbstractConverter.h"
1616
#include "flang/Lower/BuiltinModules.h"
17+
#include "flang/Lower/ConvertExprToHLFIR.h"
1718
#include "flang/Lower/ConvertType.h"
1819
#include "flang/Lower/ConvertVariable.h"
1920
#include "flang/Lower/Mangler.h"
21+
#include "flang/Lower/StatementContext.h"
22+
#include "flang/Lower/SymbolMap.h"
2023
#include "flang/Optimizer/Builder/Complex.h"
2124
#include "flang/Optimizer/Builder/MutableBox.h"
2225
#include "flang/Optimizer/Builder/Todo.h"
@@ -380,10 +383,21 @@ static mlir::Value genStructureComponentInit(
380383
}
381384

382385
if (Fortran::semantics::IsPointer(sym)) {
383-
if (Fortran::semantics::IsProcedure(sym))
384-
TODO(loc, "procedure pointer component initial value");
385-
mlir::Value initialTarget =
386-
Fortran::lower::genInitialDataTarget(converter, loc, componentTy, expr);
386+
mlir::Value initialTarget;
387+
if (Fortran::semantics::IsProcedure(sym)) {
388+
if (Fortran::evaluate::UnwrapExpr<Fortran::evaluate::NullPointer>(expr))
389+
initialTarget =
390+
fir::factory::createNullBoxProc(builder, loc, componentTy);
391+
else {
392+
Fortran::lower::SymMap globalOpSymMap;
393+
Fortran::lower::StatementContext stmtCtx;
394+
auto box{getBase(Fortran::lower::convertExprToAddress(
395+
loc, converter, expr, globalOpSymMap, stmtCtx))};
396+
initialTarget = builder.createConvert(loc, componentTy, box);
397+
}
398+
} else
399+
initialTarget = Fortran::lower::genInitialDataTarget(converter, loc,
400+
componentTy, expr);
387401
res = builder.create<fir::InsertValueOp>(
388402
loc, recTy, res, initialTarget,
389403
builder.getArrayAttr(field.getAttributes()));
Lines changed: 48 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,48 @@
1+
! Test passing
2+
! 1. NULL(),
3+
! 2. procedure,
4+
! 3. procedure pointer, (pending)
5+
! 4. reference to a function that returns a procedure pointer (pending)
6+
! to a derived type structure constructor.
7+
! RUN: bbc -emit-hlfir -o - %s | FileCheck %s
8+
9+
MODULE M
10+
TYPE :: DT
11+
PROCEDURE(Fun), POINTER, NOPASS :: pp1
12+
END TYPE
13+
14+
CONTAINS
15+
16+
INTEGER FUNCTION Fun(Arg)
17+
INTEGER :: Arg
18+
Fun = Arg
19+
END FUNCTION
20+
21+
END MODULE
22+
23+
PROGRAM MAIN
24+
USE M
25+
IMPLICIT NONE
26+
TYPE (DT), PARAMETER :: v1 = DT(NULL())
27+
TYPE (DT) :: v2
28+
v2 = DT(fun)
29+
END
30+
31+
! CDHECK-LABEL: fir.global internal @_QFECv1 constant : !fir.type<_QMmTdt{pp1:!fir.boxproc<(!fir.ref<i32>) -> i32>}> {
32+
! CHECK: %[[VAL_0:.*]] = fir.undefined !fir.type<_QMmTdt{pp1:!fir.boxproc<(!fir.ref<i32>) -> i32>}>
33+
! CHECK: %[[VAL_1:.*]] = fir.field_index pp1, !fir.type<_QMmTdt{pp1:!fir.boxproc<(!fir.ref<i32>) -> i32>}>
34+
! CHECK: %[[VAL_2:.*]] = fir.zero_bits (!fir.ref<i32>) -> i32
35+
! CHECK: %[[VAL_3:.*]] = fir.emboxproc %[[VAL_2]] : ((!fir.ref<i32>) -> i32) -> !fir.boxproc<(!fir.ref<i32>) -> i32>
36+
! CHECK: %[[VAL_4:.*]] = fir.insert_value %[[VAL_0]], %[[VAL_3]], ["pp1", !fir.type<_QMmTdt{pp1:!fir.boxproc<(!fir.ref<i32>) -> i32>}>] : (!fir.type<_QMmTdt{pp1:!fir.boxproc<(!fir.ref<i32>) -> i32>}>, !fir.boxproc<(!fir.ref<i32>) -> i32>) -> !fir.type<_QMmTdt{pp1:!fir.boxproc<(!fir.ref<i32>) -> i32>}>
37+
! CHECK: fir.has_value %[[VAL_4]] : !fir.type<_QMmTdt{pp1:!fir.boxproc<(!fir.ref<i32>) -> i32>}>
38+
! CHECK: }
39+
40+
! CHECK-LABEL: fir.global internal @_QQro._QMmTdt.0 constant : !fir.type<_QMmTdt{pp1:!fir.boxproc<(!fir.ref<i32>) -> i32>}> {
41+
! CHECK: %[[VAL_0:.*]] = fir.undefined !fir.type<_QMmTdt{pp1:!fir.boxproc<(!fir.ref<i32>) -> i32>}>
42+
! CHECK: %[[VAL_1:.*]] = fir.field_index pp1, !fir.type<_QMmTdt{pp1:!fir.boxproc<(!fir.ref<i32>) -> i32>}>
43+
! CHECK: %[[VAL_2:.*]] = fir.address_of(@_QMmPfun) : (!fir.ref<i32>) -> i32
44+
! CHECK: %[[VAL_3:.*]] = fir.emboxproc %[[VAL_2]] : ((!fir.ref<i32>) -> i32) -> !fir.boxproc<() -> ()>
45+
! CHECK: %[[VAL_4:.*]] = fir.convert %[[VAL_3]] : (!fir.boxproc<() -> ()>) -> !fir.boxproc<(!fir.ref<i32>) -> i32>
46+
! CHECK: %[[VAL_5:.*]] = fir.insert_value %[[VAL_0]], %[[VAL_4]], ["pp1", !fir.type<_QMmTdt{pp1:!fir.boxproc<(!fir.ref<i32>) -> i32>}>] : (!fir.type<_QMmTdt{pp1:!fir.boxproc<(!fir.ref<i32>) -> i32>}>, !fir.boxproc<(!fir.ref<i32>) -> i32>) -> !fir.type<_QMmTdt{pp1:!fir.boxproc<(!fir.ref<i32>) -> i32>}>
47+
! CHECK: fir.has_value %[[VAL_5]] : !fir.type<_QMmTdt{pp1:!fir.boxproc<(!fir.ref<i32>) -> i32>}>
48+
! CHECK: }

0 commit comments

Comments
 (0)