[flang-commits] [flang] [flang] Add structure constructor with allocatable component (PR #77845)
Kelvin Li via flang-commits
flang-commits at lists.llvm.org
Mon Jan 15 18:39:43 PST 2024
https://github.com/kkwli updated https://github.com/llvm/llvm-project/pull/77845
>From f43f9bc59627796f63895d8c516585d18d5398db Mon Sep 17 00:00:00 2001
From: Kelvin Li <kli at ca.ibm.com>
Date: Thu, 26 Oct 2023 08:51:21 -0400
Subject: [PATCH 1/3] [flang] Add structure constructor with allocatable
component
---
flang/lib/Evaluate/check-expression.cpp | 6 +
flang/lib/Evaluate/fold.cpp | 5 +
flang/lib/Lower/ConvertConstant.cpp | 15 ++-
.../structure-constructors-alloc-comp.f90 | 120 ++++++++++++++++++
flang/test/Semantics/structconst06.f90 | 1 +
flang/test/Semantics/structconst07.f90 | 6 +
flang/test/Semantics/structconst08.f90 | 57 +++++++++
7 files changed, 208 insertions(+), 2 deletions(-)
create mode 100644 flang/test/Lower/structure-constructors-alloc-comp.f90
create mode 100644 flang/test/Semantics/structconst08.f90
diff --git a/flang/lib/Evaluate/check-expression.cpp b/flang/lib/Evaluate/check-expression.cpp
index 2f46ed7dccb6455..2e8a6589806c2a5 100644
--- a/flang/lib/Evaluate/check-expression.cpp
+++ b/flang/lib/Evaluate/check-expression.cpp
@@ -188,6 +188,12 @@ struct IsActuallyConstantHelper {
return common::visit([this](const auto &y) { return (*this)(y); }, x.u);
}
bool operator()(const StructureConstructor &x) {
+ // If the comp-spec of a derived-type-spec is a structure constructor that
+ // is not a constant, the derived-type-spec is not a constant
+ if (!UnwrapExpr<Constant<SomeDerived>>(x)) {
+ return false;
+ }
+
for (const auto &pair : x) {
const Expr<SomeType> &y{pair.second.value()};
if (!(*this)(y) && !IsNullPointer(y)) {
diff --git a/flang/lib/Evaluate/fold.cpp b/flang/lib/Evaluate/fold.cpp
index dfcc2599a555e53..ed882958199802f 100644
--- a/flang/lib/Evaluate/fold.cpp
+++ b/flang/lib/Evaluate/fold.cpp
@@ -82,6 +82,11 @@ Expr<SomeDerived> FoldOperation(
} else {
isConstant &= IsInitialDataTarget(expr);
}
+ } else if (IsAllocatable(symbol)) {
+ // F2023: 10.1.12 (3)(a)
+ // If comp-spec is not null() for the allocatable component the
+ // structure constructor is not a constant expression.
+ isConstant &= IsNullPointer(expr);
} else {
isConstant &= IsActuallyConstant(expr) || IsNullPointer(expr);
if (auto valueShape{GetConstantExtents(context, expr)}) {
diff --git a/flang/lib/Lower/ConvertConstant.cpp b/flang/lib/Lower/ConvertConstant.cpp
index d7a4d68f2aaae77..2efacd4e2db9590 100644
--- a/flang/lib/Lower/ConvertConstant.cpp
+++ b/flang/lib/Lower/ConvertConstant.cpp
@@ -18,6 +18,7 @@
#include "flang/Lower/ConvertVariable.h"
#include "flang/Lower/Mangler.h"
#include "flang/Optimizer/Builder/Complex.h"
+#include "flang/Optimizer/Builder/MutableBox.h"
#include "flang/Optimizer/Builder/Todo.h"
#include <algorithm>
@@ -362,8 +363,18 @@ static mlir::Value genStructureComponentInit(
loc, fieldTy, name, recTy,
/*typeParams=*/mlir::ValueRange{} /*TODO*/);
- if (Fortran::semantics::IsAllocatable(sym))
- TODO(loc, "allocatable component in structure constructor");
+ if (Fortran::semantics::IsAllocatable(sym)) {
+ if (Fortran::evaluate::UnwrapExpr<Fortran::evaluate::NullPointer>(expr)) {
+ // Handle NULL() initialization
+ mlir::Value componentValue{fir::factory::createUnallocatedBox(
+ builder, loc, componentTy, std::nullopt)};
+ componentValue = builder.createConvert(loc, componentTy, componentValue);
+
+ return builder.create<fir::InsertValueOp>(
+ loc, recTy, res, componentValue,
+ builder.getArrayAttr(field.getAttributes()));
+ }
+ }
if (Fortran::semantics::IsPointer(sym)) {
if (Fortran::semantics::IsProcedure(sym))
diff --git a/flang/test/Lower/structure-constructors-alloc-comp.f90 b/flang/test/Lower/structure-constructors-alloc-comp.f90
new file mode 100644
index 000000000000000..49270bcd5288a1d
--- /dev/null
+++ b/flang/test/Lower/structure-constructors-alloc-comp.f90
@@ -0,0 +1,120 @@
+! Test lowering of structure constructors of derived types with allocatable component
+! RUN: bbc -emit-hlfir %s -o - | FileCheck --check-prefixes=HLFIR %s
+
+module m_struct_ctor
+ implicit none
+ type t_alloc
+ real :: x
+ integer, allocatable :: a(:)
+ end type
+
+contains
+ subroutine test_alloc1(y)
+ real :: y
+ call print_alloc_comp(t_alloc(x=y, a=null()))
+! HLFIR-LABEL: func.func @_QMm_struct_ctorPtest_alloc1(
+! HLFIR-SAME: %[[ARG_0:.*]]: !fir.ref<f32> {fir.bindc_name = "y"}) {
+! HLFIR: %[[VAL_0:.*]] = fir.alloca !fir.type<_QMm_struct_ctorTt_alloc{x:f32,a:!fir.box<!fir.heap<!fir.array<?xi32>>>}>
+! HLFIR: %[[VAL_1:.*]] = fir.address_of(@_QMm_struct_ctorE.n.x) : !fir.ref<!fir.char<1>>
+! HLFIR: %[[CONS_1:.*]] = arith.constant 1 : index
+! HLFIR: %[[VAL_2:.*]]:2 = hlfir.declare %[[VAL_1]] {{.*}}"_QMm_struct_ctorE.n.x"
+! HLFIR: %[[VAL_3:.*]] = fir.address_of(@_QMm_struct_ctorE.n.a) : !fir.ref<!fir.char<1>>
+! HLFIR: %[[CONS_2:.* ]]= arith.constant 1 : index
+! HLFIR: %[[VAL_4:.*]]:2 = hlfir.declare %[[VAL_3]] {{.*}}"_QMm_struct_ctorE.n.a"
+! HLFIR: %[[VAL_5:.*]] = fir.address_of(@_QMm_struct_ctorE.n.t_alloc) : !fir.ref<!fir.char<1,7>>
+! HLFIR: %[[CONS_3:.*]] = arith.constant 7 : index
+! HLFIR: %[[VAL_6:.*]]:2 = hlfir.declare %[[VAL_5]] {{.*}}"_QMm_struct_ctorE.n.t_alloc"
+! HLFIR: %[[VAL_7:.*]] = fir.address_of(@_QMm_struct_ctorE.c.t_alloc)
+! HLFIR: %[[CONS_4:.*]] = arith.constant 0 : index
+! HLFIR: %[[CONS_5:.*]] = arith.constant 2 : index
+! HLFIR: %[[VAL_8:.*]] = fir.shape_shift %[[CONS_4]], %[[CONS_5]] : (index, index) -> !fir.shapeshift<1>
+! HLFIR: %[[VAL_9:.*]]:2 = hlfir.declare %[[VAL_7]](%[[VAL_8]]) {{.*}}"_QMm_struct_ctorE.c.t_alloc"
+! HLFIR: %[[VAL_10:.*]] = fir.address_of(@_QMm_struct_ctorE.dt.t_alloc)
+! HLFIR: %[[VAL_11:.*]]:2 = hlfir.declare %[[VAL_10]] {{.*}}"_QMm_struct_ctorE.dt.t_alloc"
+! HLFIR: %[[VAL_12:.*]]:2 = hlfir.declare %[[ARG_0]] {uniq_name = "_QMm_struct_ctorFtest_alloc1Ey"} : (!fir.ref<f32>) -> (!fir.ref<f32>, !fir.ref<f32>)
+! HLFIR: %[[VAL_13:.*]]:2 = hlfir.declare %[[VAL_0]] {uniq_name = "ctor.temp"} : (!fir.ref<!fir.type<_QMm_struct_ctorTt_alloc{x:f32,a:!fir.box<!fir.heap<!fir.array<?xi32>>>}>>) -> (!fir.ref<!fir.type<_QMm_struct_ctorTt_alloc{x:f32,a:!fir.box<!fir.heap<!fir.array<?xi32>>>}>>, !fir.ref<!fir.type<_QMm_struct_ctorTt_alloc{x:f32,a:!fir.box<!fir.heap<!fir.array<?xi32>>>}>>)
+! HLFIR: %[[VAL_14:.*]] = fir.embox %[[VAL_13]]#0 : (!fir.ref<!fir.type<_QMm_struct_ctorTt_alloc{x:f32,a:!fir.box<!fir.heap<!fir.array<?xi32>>>}>>) -> !fir.box<!fir.type<_QMm_struct_ctorTt_alloc{x:f32,a:!fir.box<!fir.heap<!fir.array<?xi32>>>}>>
+! HLFIR: %[[VAL_15:.*]] = fir.address_of(@_QQ{{.*}}) : !fir.ref<!fir.char<1,{{.*}}>>
+! HLFIR: %[[CONS_6:.*]] = arith.constant {{.*}} : i32
+! HLFIR: %[[VAL_16:.*]] = fir.convert %[[VAL_14]] : (!fir.box<!fir.type<_QMm_struct_ctorTt_alloc{x:f32,a:!fir.box<!fir.heap<!fir.array<?xi32>>>}>>) -> !fir.box<none>
+! HLFIR: %[[VAL_17:.*]] = fir.convert %[[VAL_15]] : (!fir.ref<!fir.char<1,{{.*}}>>) -> !fir.ref<i8>
+! HLFIR: %{{.*}} = fir.call @_FortranAInitialize(%[[VAL_16]], %[[VAL_17]], %[[CONS_6]]) fastmath<contract> : (!fir.box<none>, !fir.ref<i8>, i32) -> none
+! HLFIR: %[[VAL_18:.*]] = hlfir.designate %[[VAL_13]]#0{"x"} : (!fir.ref<!fir.type<_QMm_struct_ctorTt_alloc{x:f32,a:!fir.box<!fir.heap<!fir.array<?xi32>>>}>>) -> !fir.ref<f32>
+! HLFIR: %[[VAL_19:.*]] = fir.load %[[VAL_12]]#0 : !fir.ref<f32>
+! HLFIR: hlfir.assign %[[VAL_19]] to %[[VAL_18]] temporary_lhs : f32, !fir.ref<f32>
+! HLFIR: fir.call @_QPprint_alloc_comp(%[[VAL_13]]#1) fastmath<contract> : (!fir.ref<!fir.type<_QMm_struct_ctorTt_alloc{x:f32,a:!fir.box<!fir.heap<!fir.array<?xi32>>>}>>) -> ()
+! HLFIR: return
+! HLFIR: }
+ end subroutine
+
+ subroutine test_alloc2(y, b)
+ real :: y
+ integer :: b(5)
+ call print_alloc_comp(t_alloc(x=y, a=b))
+! HLFIR-LABEL: func.func @_QMm_struct_ctorPtest_alloc2
+! HLFIR-SAME: (%[[ARG_0:.*]]: !fir.ref<f32> {fir.bindc_name = "y"}, %[[ARG_1:.*]]: !fir.ref<!fir.array<5xi32>> {fir.bindc_name = "b"}) {
+! HLFIR: %[[VAL_0:.*]] = fir.alloca !fir.type<_QMm_struct_ctorTt_alloc{x:f32,a:!fir.box<!fir.heap<!fir.array<?xi32>>>}>
+! HLFIR: %[[VAL_1:.*]] = fir.address_of(@_QMm_struct_ctorE.n.x) : !fir.ref<!fir.char<1>>
+! HLFIR: %[[CONS_1:.*]] = arith.constant 1 : index
+! HLFIR: %[[VAL_2:.*]]:2 = hlfir.declare %[[VAL_1]] typeparams %[[CONS_1]] {{.*}}"_QMm_struct_ctorE.n.x"
+! HLFIR: %[[VAL_3:.*]] = fir.address_of(@_QMm_struct_ctorE.n.a) : !fir.ref<!fir.char<1>>
+! HLFIR: %[[CONS_2:.*]] = arith.constant 1 : index
+! HLFIR: %[[VAL_4:.*]]:2 = hlfir.declare %[[VAL_3]] typeparams %[[CONS_2]] {{.*}}"_QMm_struct_ctorE.n.a"
+! HLFIR: %[[VAL_5:.*]] = fir.address_of(@_QMm_struct_ctorE.n.t_alloc) : !fir.ref<!fir.char<1,7>>
+! HLFIR: %[[CONS_3:.*]] = arith.constant 7 : index
+! HLFIR: %[[VAL_6:.*]]:2 = hlfir.declare %[[VAL_5]] typeparams %[[CONS_3]] {{.*}}"_QMm_struct_ctorE.n.t_alloc"
+! HLFIR: %[[VAL_7:.*]] = fir.address_of(@_QMm_struct_ctorE.c.t_alloc)
+! HLFIR: %[[CONS_4:.*]] = arith.constant 0 : index
+! HLFIR: %[[CONS_5:.*]] = arith.constant 2 : index
+! HLFIR: %[[VAL_8:.*]] = fir.shape_shift %[[CONS_4]], %[[CONS_5]] : (index, index) -> !fir.shapeshift<1>
+! HLFIR: %[[VAL_9:.*]]:2 = hlfir.declare %[[VAL_7]](%[[VAL_8]]) {{.*}}"_QMm_struct_ctorE.c.t_alloc"
+! HLFIR: %[[VAL_10:.*]] = fir.address_of(@_QMm_struct_ctorE.dt.t_alloc)
+! HLFIR: %[[VAL_11:.*]]:2 = hlfir.declare %[[VAL_10]] {{.*}}"_QMm_struct_ctorE.dt.t_alloc"
+! HLFIR: %[[CONS_6:.*]] = arith.constant 5 : index
+! HLFIR: %[[VAL_12:.*]] = fir.shape %[[CONS_6]] : (index) -> !fir.shape<1>
+! HLFIR: %[[VAL_13:.*]]:2 = hlfir.declare %[[ARG_1]](%[[VAL_12]]) {uniq_name = "_QMm_struct_ctorFtest_alloc2Eb"} : (!fir.ref<!fir.array<5xi32>>, !fir.shape<1>) -> (!fir.ref<!fir.array<5xi32>>, !fir.ref<!fir.array<5xi32>>)
+! HLFIR: %[[VAL_14:.*]]:2 = hlfir.declare %[[ARG_0]] {uniq_name = "_QMm_struct_ctorFtest_alloc2Ey"} : (!fir.ref<f32>) -> (!fir.ref<f32>, !fir.ref<f32>)
+! HLFIR: %[[VAL_15:.*]]:2 = hlfir.declare %[[VAL_0]] {uniq_name = "ctor.temp"} : (!fir.ref<!fir.type<_QMm_struct_ctorTt_alloc{x:f32,a:!fir.box<!fir.heap<!fir.array<?xi32>>>}>>) -> (!fir.ref<!fir.type<_QMm_struct_ctorTt_alloc{x:f32,a:!fir.box<!fir.heap<!fir.array<?xi32>>>}>>, !fir.ref<!fir.type<_QMm_struct_ctorTt_alloc{x:f32,a:!fir.box<!fir.heap<!fir.array<?xi32>>>}>>)
+! HLFIR: %[[VAL_16:.*]] = fir.embox %[[VAL_15]]#0 : (!fir.ref<!fir.type<_QMm_struct_ctorTt_alloc{x:f32,a:!fir.box<!fir.heap<!fir.array<?xi32>>>}>>) -> !fir.box<!fir.type<_QMm_struct_ctorTt_alloc{x:f32,a:!fir.box<!fir.heap<!fir.array<?xi32>>>}>>
+! HLFIR: %[[VAL_17:.*]] = fir.address_of(@_QQ{{.*}}) : !fir.ref<!fir.char<1,{{.*}}>>
+! HLFIR: %[[CONS_7:.*]] = arith.constant {{.*}} : i32
+! HLFIR: %[[VAL_18:.*]] = fir.convert %[[VAL_16]] : (!fir.box<!fir.type<_QMm_struct_ctorTt_alloc{x:f32,a:!fir.box<!fir.heap<!fir.array<?xi32>>>}>>) -> !fir.box<none>
+! HLFIR: %[[VAL_19:.*]] = fir.convert %[[VAL_17]] : (!fir.ref<!fir.char<1,{{.*}}>>) -> !fir.ref<i8>
+! HLFIR: {{.*}} = fir.call @_FortranAInitialize(%[[VAL_18]], %[[VAL_19]], %[[CONS_7]]) fastmath<contract> : (!fir.box<none>, !fir.ref<i8>, i32) -> none
+! HLFIR: %[[VAL_20:.*]] = hlfir.designate %[[VAL_15]]#0{"x"} : (!fir.ref<!fir.type<_QMm_struct_ctorTt_alloc{x:f32,a:!fir.box<!fir.heap<!fir.array<?xi32>>>}>>) -> !fir.ref<f32>
+! HLFIR: %[[VAL_21:.*]] = fir.load %[[VAL_14]]#0 : !fir.ref<f32>
+! HLFIR: hlfir.assign %[[VAL_21]] to %[[VAL_20]] temporary_lhs : f32, !fir.ref<f32>
+! HLFIR: %[[VAL_22:.*]] = hlfir.designate %[[VAL_15]]#0{"a"} {fortran_attrs = #fir.var_attrs<allocatable>} : (!fir.ref<!fir.type<_QMm_struct_ctorTt_alloc{x:f32,a:!fir.box<!fir.heap<!fir.array<?xi32>>>}>>) -> !fir.ref<!fir.box<!fir.heap<!fir.array<?xi32>>>>
+! HLFIR: hlfir.assign %[[VAL_13]]#0 to %[[VAL_22]] realloc temporary_lhs : !fir.ref<!fir.array<5xi32>>, !fir.ref<!fir.box<!fir.heap<!fir.array<?xi32>>>>
+! HLFIR: fir.call @_QPprint_alloc_comp(%[[VAL_15]]#1) fastmath<contract> : (!fir.ref<!fir.type<_QMm_struct_ctorTt_alloc{x:f32,a:!fir.box<!fir.heap<!fir.array<?xi32>>>}>>) -> ()
+! HLFIR: return
+! HLFIR: }
+ end subroutine
+
+ subroutine test_alloc3()
+ type(t_alloc) :: t1 = t_alloc(x=5, a=null())
+! HLFIR-LABEL: func.func @_QMm_struct_ctorPtest_alloc3() {
+! HLFIR: %[[VAL_0:.*]] = fir.address_of(@_QMm_struct_ctorE.n.x) : !fir.ref<!fir.char<1>>
+! HLFIR: %c1 = arith.constant 1 : index
+! HLFIR: %[[VAL_1:.*]]:2 = hlfir.declare %[[VAL_0]] typeparams %c1 {{.*}}"_QMm_struct_ctorE.n.x"
+! HLFIR: %[[VAL_2:.*]] = fir.address_of(@_QMm_struct_ctorE.n.a) : !fir.ref<!fir.char<1>>
+! HLFIR: %c1_0 = arith.constant 1 : index
+! HLFIR: %[[VAL_3:.*]]:2 = hlfir.declare %[[VAL_2]] typeparams %c1_0 {{.*}}"_QMm_struct_ctorE.n.a"
+! HLFIR: %[[VAL_4:.*]] = fir.address_of(@_QMm_struct_ctorE.n.t_alloc) : !fir.ref<!fir.char<1,7>>
+! HLFIR: %c7 = arith.constant 7 : index
+! HLFIR: %[[VAL_5:.*]]:2 = hlfir.declare %[[VAL_4]] typeparams %c7 {{.*}}"_QMm_struct_ctorE.n.t_alloc"
+! HLFIR: %[[VAL_6:.*]] = fir.address_of(@_QMm_struct_ctorE.c.t_alloc)
+! HLFIR: %c0 = arith.constant 0 : index
+! HLFIR: %c2 = arith.constant 2 : index
+! HLFIR: %[[VAL_7:.*]] = fir.shape_shift %c0, %c2 : (index, index) -> !fir.shapeshift<1>
+! HLFIR: %[[VAL_8:.*]]:2 = hlfir.declare %[[VAL_6]](%[[VAL_7]]) {{.*}}"_QMm_struct_ctorE.c.t_alloc"
+! HLFIR: %[[VAL_9:.*]] = fir.address_of(@_QMm_struct_ctorE.dt.t_alloc)
+! HLFIR: %[[VAL_10:.*]]:2 = hlfir.declare %[[VAL_9]] {{.*}}"_QMm_struct_ctorE.dt.t_alloc"
+! HLFIR: %[[VAL_11:.*]] = fir.address_of(@_QMm_struct_ctorFtest_alloc3Et1) : !fir.ref<!fir.type<_QMm_struct_ctorTt_alloc{x:f32,a:!fir.box<!fir.heap<!fir.array<?xi32>>>}>>
+! HLFIR: {{.*}}:2 = hlfir.declare %[[VAL_11]] {uniq_name = "_QMm_struct_ctorFtest_alloc3Et1"}
+! HLFIR: return
+! HLFIR: }
+
+ end subroutine
+
+end module m_struct_ctor
diff --git a/flang/test/Semantics/structconst06.f90 b/flang/test/Semantics/structconst06.f90
index d5a40410ea63a11..45a0fb97842d305 100644
--- a/flang/test/Semantics/structconst06.f90
+++ b/flang/test/Semantics/structconst06.f90
@@ -4,6 +4,7 @@ module m
type t
real, allocatable :: a(:)
end type
+ !ERROR: Must be a constant value
!ERROR: Scalar value cannot be expanded to shape of array component 'a'
type(t) :: x = t(0.)
end module
diff --git a/flang/test/Semantics/structconst07.f90 b/flang/test/Semantics/structconst07.f90
index a34289a817af441..d61c54200dc82d1 100644
--- a/flang/test/Semantics/structconst07.f90
+++ b/flang/test/Semantics/structconst07.f90
@@ -2,8 +2,14 @@
type :: hasPointer
class(*), pointer :: sp
end type
+type :: hasAllocatable
+ class(*), allocatable :: sa
+end type
type(hasPointer) hp
+type(hasAllocatable) ha
!CHECK: hp=haspointer(sp=NULL())
hp = hasPointer()
+!CHECK: ha=hasallocatable(sa=NULL())
+ha = hasAllocatable()
end
diff --git a/flang/test/Semantics/structconst08.f90 b/flang/test/Semantics/structconst08.f90
new file mode 100644
index 000000000000000..211b0e79bf5e444
--- /dev/null
+++ b/flang/test/Semantics/structconst08.f90
@@ -0,0 +1,57 @@
+! RUN: %python %S/test_errors.py %s %flang_fc1 -pedantic
+!
+! Error tests for structure constructors of derived types with allocatable components
+
+module m
+ type parent1
+ integer, allocatable :: pa
+ end type parent1
+ type parent2
+ real, allocatable :: pa(:)
+ end type parent2
+ type child
+ integer :: i
+ type(parent2) :: ca
+ end type
+
+contains
+ subroutine test1()
+ integer :: j
+ real :: arr(5)
+!ERROR: Must be a constant value
+ type(parent1) :: tp1 = parent1(3)
+!ERROR: Must be a constant value
+ type(parent1) :: tp2 = parent1(j)
+ type(parent1) :: tp3 = parent1(null())
+
+!ERROR: Must be a constant value
+ type(parent2) :: tp4 = parent2([1.1,2.1,3.1])
+!ERROR: Must be a constant value
+ type(parent2) :: tp5 = parent2(arr)
+ type(parent2) :: tp6 = parent2(null())
+ end subroutine test1
+
+ subroutine test2()
+ integer :: j
+ real :: arr(5)
+ type(parent1) :: tp1
+ type(parent2) :: tp2
+ tp1 = parent1(3)
+ tp1 = parent1(j)
+ tp1 = parent1(null())
+
+ tp2 = parent2([1.1,2.1,3.1])
+ tp2 = parent2(arr)
+ tp2 = parent2(null())
+ end subroutine test2
+
+ subroutine test3()
+ type(child) :: tc1 = child(5, parent2(null()))
+!ERROR: Must be a constant value
+ type(child) :: tc2 = child(5, parent2([1.1,1.2]))
+ type(child) :: tc3
+
+ tc3 = child(5, parent2(null()))
+ tc3 = child(5, parent2([1.1,1.2]))
+ end subroutine test3
+end module m
>From 9f0a25289098efebd666cdc96093b46ba28024bd Mon Sep 17 00:00:00 2001
From: Kelvin Li <kli at ca.ibm.com>
Date: Thu, 11 Jan 2024 23:08:40 -0500
Subject: [PATCH 2/3] Fix the component check
---
flang/lib/Evaluate/check-expression.cpp | 13 ++++++-------
1 file changed, 6 insertions(+), 7 deletions(-)
diff --git a/flang/lib/Evaluate/check-expression.cpp b/flang/lib/Evaluate/check-expression.cpp
index 2e8a6589806c2a5..14abac5ff9ba801 100644
--- a/flang/lib/Evaluate/check-expression.cpp
+++ b/flang/lib/Evaluate/check-expression.cpp
@@ -188,15 +188,14 @@ struct IsActuallyConstantHelper {
return common::visit([this](const auto &y) { return (*this)(y); }, x.u);
}
bool operator()(const StructureConstructor &x) {
- // If the comp-spec of a derived-type-spec is a structure constructor that
- // is not a constant, the derived-type-spec is not a constant
- if (!UnwrapExpr<Constant<SomeDerived>>(x)) {
- return false;
- }
-
for (const auto &pair : x) {
const Expr<SomeType> &y{pair.second.value()};
- if (!(*this)(y) && !IsNullPointer(y)) {
+ const auto sym{pair.first};
+ const bool compIsConstant{(*this)(y)};
+ // If an allocatable component is initialized by a constant,
+ // the structure constructor is not a constant.
+ if ((!compIsConstant && !IsNullPointer(y)) ||
+ (compIsConstant && IsAllocatable(sym))) {
return false;
}
}
>From 2fd230411796f9b983f112327cd82325f3e021b4 Mon Sep 17 00:00:00 2001
From: Kelvin Li <kli at ca.ibm.com>
Date: Mon, 15 Jan 2024 21:38:27 -0500
Subject: [PATCH 3/3] - update logic to handle the null(mod) case - add more
tests
---
flang/lib/Lower/ConvertConstant.cpp | 4 +-
.../structure-constructors-alloc-comp.f90 | 40 +++++++++++++++++--
flang/test/Semantics/structconst08.f90 | 29 ++++++++++----
3 files changed, 61 insertions(+), 12 deletions(-)
diff --git a/flang/lib/Lower/ConvertConstant.cpp b/flang/lib/Lower/ConvertConstant.cpp
index 2efacd4e2db9590..756eab6da495317 100644
--- a/flang/lib/Lower/ConvertConstant.cpp
+++ b/flang/lib/Lower/ConvertConstant.cpp
@@ -364,7 +364,9 @@ static mlir::Value genStructureComponentInit(
/*typeParams=*/mlir::ValueRange{} /*TODO*/);
if (Fortran::semantics::IsAllocatable(sym)) {
- if (Fortran::evaluate::UnwrapExpr<Fortran::evaluate::NullPointer>(expr)) {
+ if (!Fortran::evaluate::IsNullPointer(expr)) {
+ fir::emitFatalError(loc, "constant structure constructor with an allocatable component value that is not NULL");
+ } else {
// Handle NULL() initialization
mlir::Value componentValue{fir::factory::createUnallocatedBox(
builder, loc, componentTy, std::nullopt)};
diff --git a/flang/test/Lower/structure-constructors-alloc-comp.f90 b/flang/test/Lower/structure-constructors-alloc-comp.f90
index 49270bcd5288a1d..f6dceb8f5e0501b 100644
--- a/flang/test/Lower/structure-constructors-alloc-comp.f90
+++ b/flang/test/Lower/structure-constructors-alloc-comp.f90
@@ -46,7 +46,7 @@ subroutine test_alloc1(y)
! HLFIR: return
! HLFIR: }
end subroutine
-
+
subroutine test_alloc2(y, b)
real :: y
integer :: b(5)
@@ -103,18 +103,50 @@ subroutine test_alloc3()
! HLFIR: %[[VAL_4:.*]] = fir.address_of(@_QMm_struct_ctorE.n.t_alloc) : !fir.ref<!fir.char<1,7>>
! HLFIR: %c7 = arith.constant 7 : index
! HLFIR: %[[VAL_5:.*]]:2 = hlfir.declare %[[VAL_4]] typeparams %c7 {{.*}}"_QMm_struct_ctorE.n.t_alloc"
-! HLFIR: %[[VAL_6:.*]] = fir.address_of(@_QMm_struct_ctorE.c.t_alloc)
+! HLFIR: %[[VAL_6:.*]] = fir.address_of(@_QMm_struct_ctorE.c.t_alloc)
! HLFIR: %c0 = arith.constant 0 : index
! HLFIR: %c2 = arith.constant 2 : index
! HLFIR: %[[VAL_7:.*]] = fir.shape_shift %c0, %c2 : (index, index) -> !fir.shapeshift<1>
! HLFIR: %[[VAL_8:.*]]:2 = hlfir.declare %[[VAL_6]](%[[VAL_7]]) {{.*}}"_QMm_struct_ctorE.c.t_alloc"
-! HLFIR: %[[VAL_9:.*]] = fir.address_of(@_QMm_struct_ctorE.dt.t_alloc)
+! HLFIR: %[[VAL_9:.*]] = fir.address_of(@_QMm_struct_ctorE.dt.t_alloc)
! HLFIR: %[[VAL_10:.*]]:2 = hlfir.declare %[[VAL_9]] {{.*}}"_QMm_struct_ctorE.dt.t_alloc"
! HLFIR: %[[VAL_11:.*]] = fir.address_of(@_QMm_struct_ctorFtest_alloc3Et1) : !fir.ref<!fir.type<_QMm_struct_ctorTt_alloc{x:f32,a:!fir.box<!fir.heap<!fir.array<?xi32>>>}>>
-! HLFIR: {{.*}}:2 = hlfir.declare %[[VAL_11]] {uniq_name = "_QMm_struct_ctorFtest_alloc3Et1"}
+! HLFIR: {{.*}}:2 = hlfir.declare %[[VAL_11]] {uniq_name = "_QMm_struct_ctorFtest_alloc3Et1"}
! HLFIR: return
! HLFIR: }
+ end subroutine
+ subroutine test_alloc4()
+ integer, pointer :: p(:)
+ type(t_alloc) :: t1 = t_alloc(x=5, a=null(p))
+! HLFIR-LABEL: func.func @_QMm_struct_ctorPtest_alloc4() {
+! HLFIR: %[[VAL_0:.*]] = fir.address_of(@_QMm_struct_ctorE.n.x) : !fir.ref<!fir.char<1>>
+! HLFIR: %[[CONS_1:.*]] = arith.constant 1 : index
+! HLFIR: %[[VAL_1:.*]]:2 = hlfir.declare %[[VAL_0]] typeparams %[[CONS_1]] {{.*}}"_QMm_struct_ctorE.n.x"
+! HLFIR: %[[VAL_2:.*]] = fir.address_of(@_QMm_struct_ctorE.n.a) : !fir.ref<!fir.char<1>>
+! HLFIR: %[[CONS_2:.*]] = arith.constant 1 : index
+! HLFIR: %[[VAL_3:.*]]:2 = hlfir.declare %[[VAL_2]] typeparams %[[CONS_2]] {{.*}}"_QMm_struct_ctorE.n.a"
+! HLFIR: %[[VAL_4:.*]] = fir.address_of(@_QMm_struct_ctorE.n.t_alloc) : !fir.ref<!fir.char<1,7>>
+! HLFIR: %[[CONS_3:.*]] = arith.constant 7 : index
+! HLFIR: %[[VAL_5:.*]]:2 = hlfir.declare %[[VAL_4]] typeparams %[[CONS_3]] {{.*}}"_QMm_struct_ctorE.n.t_alloc"
+! HLFIR: %[[VAL_6:.*]] = fir.address_of(@_QMm_struct_ctorE.c.t_alloc)
+! HLFIR: %[[CONS_4:.*]] = arith.constant 0 : index
+! HLFIR: %[[CONS_5:.*]] = arith.constant 2 : index
+! HLFIR: %[[VAL_7:.*]] = fir.shape_shift %[[CONS_4]], %[[CONS_5]] : (index, index) -> !fir.shapeshift<1>
+! HLFIR: %[[VAL_8:.*]]:2 = hlfir.declare %[[VAL_6]](%[[VAL_7]]) {{.*}}"_QMm_struct_ctorE.c.t_alloc"
+! HLFIR: %[[VAL_9:.*]] = fir.address_of(@_QMm_struct_ctorE.dt.t_alloc)
+! HLFIR: %[[VAL_10:.*]]:2 = hlfir.declare %[[VAL_9]] {{.*}}"_QMm_struct_ctorE.dt.t_alloc"
+! HLFIR: %[[VAL_11:.*]] = fir.alloca !fir.box<!fir.ptr<!fir.array<?xi32>>> {bindc_name = "p", uniq_name = "_QMm_struct_ctorFtest_alloc4Ep"}
+! HLFIR: %[[VAL_12:.*]] = fir.zero_bits !fir.ptr<!fir.array<?xi32>>
+! HLFIR: %[[CONS_6:.*]] = arith.constant 0 : index
+! HLFIR: %[[VAL_13:.*]] = fir.shape %[[CONS_6]] : (index) -> !fir.shape<1>
+! HLFIR: %[[VAL_14:.*]] = fir.embox %[[VAL_12]](%[[VAL_13]]) : (!fir.ptr<!fir.array<?xi32>>, !fir.shape<1>) -> !fir.box<!fir.ptr<!fir.array<?xi32>>>
+! HLFIR: fir.store %[[VAL_14]] to %[[VAL_11]] : !fir.ref<!fir.box<!fir.ptr<!fir.array<?xi32>>>>
+! HLFIR: %[[VAL_15:.*]]:2 = hlfir.declare %[[VAL_11]] {fortran_attrs = #fir.var_attrs<pointer>, uniq_name = "_QMm_struct_ctorFtest_alloc4Ep"}
+! HLFIR: %[[VAL_16:.*]] = fir.address_of(@_QMm_struct_ctorFtest_alloc4Et1) : !fir.ref<!fir.type<_QMm_struct_ctorTt_alloc{x:f32,a:!fir.box<!fir.heap<!fir.array<?xi32>>>}>>
+! HLFIR: %[[VAL_17:.*]]:2 = hlfir.declare %[[VAL_16]] {uniq_name = "_QMm_struct_ctorFtest_alloc4Et1"}
+! HLFIR: return
+! HLFIR: }
end subroutine
end module m_struct_ctor
diff --git a/flang/test/Semantics/structconst08.f90 b/flang/test/Semantics/structconst08.f90
index 211b0e79bf5e444..149c898dda9d4d5 100644
--- a/flang/test/Semantics/structconst08.f90
+++ b/flang/test/Semantics/structconst08.f90
@@ -18,40 +18,55 @@ module m
subroutine test1()
integer :: j
real :: arr(5)
+ integer, pointer :: ipp
+ real, pointer :: rpp(:)
!ERROR: Must be a constant value
type(parent1) :: tp1 = parent1(3)
!ERROR: Must be a constant value
type(parent1) :: tp2 = parent1(j)
type(parent1) :: tp3 = parent1(null())
+!PORTABILITY: NULL() with arguments is not standard conforming as the value for allocatable component 'pa'
+ type(parent1) :: tp4 = parent1(null(ipp))
!ERROR: Must be a constant value
- type(parent2) :: tp4 = parent2([1.1,2.1,3.1])
+ type(parent2) :: tp5 = parent2([1.1,2.1,3.1])
!ERROR: Must be a constant value
- type(parent2) :: tp5 = parent2(arr)
- type(parent2) :: tp6 = parent2(null())
+ type(parent2) :: tp6 = parent2(arr)
+ type(parent2) :: tp7 = parent2(null())
+!PORTABILITY: NULL() with arguments is not standard conforming as the value for allocatable component 'pa'
+ type(parent2) :: tp8 = parent2(null(rpp))
end subroutine test1
subroutine test2()
integer :: j
real :: arr(5)
+ integer, pointer :: ipp
+ real, pointer :: rpp(:)
type(parent1) :: tp1
type(parent2) :: tp2
tp1 = parent1(3)
tp1 = parent1(j)
tp1 = parent1(null())
+!PORTABILITY: NULL() with arguments is not standard conforming as the value for allocatable component 'pa'
+ tp1 = parent1(null(ipp))
tp2 = parent2([1.1,2.1,3.1])
tp2 = parent2(arr)
tp2 = parent2(null())
+!PORTABILITY: NULL() with arguments is not standard conforming as the value for allocatable component 'pa'
+ tp2 = parent2(null(rpp))
end subroutine test2
subroutine test3()
+ real, pointer :: pp(:)
type(child) :: tc1 = child(5, parent2(null()))
+!PORTABILITY: NULL() with arguments is not standard conforming as the value for allocatable component 'pa'
+ type(child) :: tc10 = child(5, parent2(null(pp)))
!ERROR: Must be a constant value
- type(child) :: tc2 = child(5, parent2([1.1,1.2]))
- type(child) :: tc3
+ type(child) :: tc3 = child(5, parent2([1.1,1.2]))
+ type(child) :: tc4
- tc3 = child(5, parent2(null()))
- tc3 = child(5, parent2([1.1,1.2]))
+ tc4 = child(5, parent2(null()))
+ tc4 = child(5, parent2([1.1,1.2]))
end subroutine test3
end module m
More information about the flang-commits
mailing list