From 4daa71b06377971c08341ff1664438de55dd5603 Mon Sep 17 00:00:00 2001 From: Paul Thomas Date: Fri, 27 Jan 2012 10:05:56 +0000 Subject: [PATCH] re PR fortran/48705 ([OOP] ALLOCATE with non-trivial SOURCE) 2012-01-27 Paul Thomas Tobias Burnus PR fortran/48705 PR fortran/51870 PR fortran/51943 PR fortran/51946 * trans-array.c (gfc_array_init_size): Add two extra arguments to convey the dynamic element size of a calls object and to return the number of elements that have been allocated. (gfc_array_allocate): Add the same arguments and use them to call gfc_array_init_size. Before the allocation dereference the data pointer, if necessary. Set the allocated array to zero if the class element size or expr3 are non-null. * trans-expr.c (gfc_conv_class_to_class): Give this function global scope. (get_class_array_ref): New function. (gfc_copy_class_to_class): New function. * trans-array.h : Update prototype for gfc_array_allocate. * trans-stmt.c (gfc_trans_allocate): For non-variable class STATUS expressions extract the class object and the dynamic element size. Use the latter to call gfc_array_allocate and the former for setting the vptr and, via gfc_copy_class_to_clasfc_cs, to copy to the allocated data. * trans.h : Prototypes for gfc_get_class_array_ref, gfc_copy_class_to_class and gfc_conv_class_to_class. 2012-01-27 Paul Thomas Tobias Burnus PR fortran/48705 * gfortran.dg/class_allocate_11.f03: New. PR fortran/51870 PR fortran/51943 PR fortran/51946 * gfortran.dg/class_allocate_7.f03: New. * gfortran.dg/class_allocate_8.f03: New. * gfortran.dg/class_allocate_9.f03: New. * gfortran.dg/class_allocate_10.f03: New. Co-Authored-By: Tobias Burnus From-SVN: r183613 --- gcc/fortran/ChangeLog | 27 +++++ gcc/fortran/trans-array.c | 18 ++- gcc/fortran/trans-array.h | 2 +- gcc/fortran/trans-expr.c | 105 +++++++++++++++++- gcc/fortran/trans-stmt.c | 82 ++++++++++---- gcc/fortran/trans.h | 3 + gcc/testsuite/ChangeLog | 14 +++ .../gfortran.dg/class_allocate_10.f03 | 64 +++++++++++ .../gfortran.dg/class_allocate_11.f03 | 62 +++++++++++ .../gfortran.dg/class_allocate_7.f03 | 35 ++++++ .../gfortran.dg/class_allocate_8.f03 | 53 +++++++++ .../gfortran.dg/class_allocate_9.f03 | 36 ++++++ 12 files changed, 473 insertions(+), 28 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/class_allocate_10.f03 create mode 100644 gcc/testsuite/gfortran.dg/class_allocate_11.f03 create mode 100644 gcc/testsuite/gfortran.dg/class_allocate_7.f03 create mode 100644 gcc/testsuite/gfortran.dg/class_allocate_8.f03 create mode 100644 gcc/testsuite/gfortran.dg/class_allocate_9.f03 diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 1e0fa2fa12a..1dcbfeaa0cd 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,30 @@ +2012-01-27 Paul Thomas + Tobias Burnus + + PR fortran/48705 + PR fortran/51870 + PR fortran/51943 + PR fortran/51946 + * trans-array.c (gfc_array_init_size): Add two extra arguments + to convey the dynamic element size of a calls object and to + return the number of elements that have been allocated. + (gfc_array_allocate): Add the same arguments and use them to + call gfc_array_init_size. Before the allocation dereference + the data pointer, if necessary. Set the allocated array to zero + if the class element size or expr3 are non-null. + * trans-expr.c (gfc_conv_class_to_class): Give this function + global scope. + (get_class_array_ref): New function. + (gfc_copy_class_to_class): New function. + * trans-array.h : Update prototype for gfc_array_allocate. + * trans-stmt.c (gfc_trans_allocate): For non-variable class + STATUS expressions extract the class object and the dynamic + element size. Use the latter to call gfc_array_allocate and + the former for setting the vptr and, via + gfc_copy_class_to_clasfc_cs, to copy to the allocated data. + * trans.h : Prototypes for gfc_get_class_array_ref, + gfc_copy_class_to_class and gfc_conv_class_to_class. + 2012-01-25 Tobias Burnus PR fortran/51995 diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index b4ed58fe084..b8516afc534 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -4719,7 +4719,7 @@ static tree gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset, gfc_expr ** lower, gfc_expr ** upper, stmtblock_t * pblock, stmtblock_t * descriptor_block, tree * overflow, - gfc_expr *expr3) + tree expr3_elem_size, tree *nelems, gfc_expr *expr3) { tree type; tree tmp; @@ -4876,7 +4876,9 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset, /* The stride is the number of elements in the array, so multiply by the size of an element to get the total size. Obviously, if there ia a SOURCE expression (expr3) we must use its element size. */ - if (expr3 != NULL) + if (expr3_elem_size != NULL_TREE) + tmp = expr3_elem_size; + else if (expr3 != NULL) { if (expr3->ts.type == BT_CLASS) { @@ -4904,6 +4906,7 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset, if (rank == 0) return element_size; + *nelems = gfc_evaluate_now (stride, pblock); stride = fold_convert (size_type_node, stride); /* First check for overflow. Since an array of type character can @@ -4962,7 +4965,8 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset, bool gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg, - tree errlen, tree label_finish, gfc_expr *expr3) + tree errlen, tree label_finish, tree expr3_elem_size, + tree *nelems, gfc_expr *expr3) { tree tmp; tree pointer; @@ -5047,7 +5051,7 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg, size = gfc_array_init_size (se->expr, ref->u.ar.as->rank, ref->u.ar.as->corank, &offset, lower, upper, &se->pre, &set_descriptor_block, &overflow, - expr3); + expr3_elem_size, nelems, expr3); if (dimension) { @@ -5078,6 +5082,9 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg, gfc_start_block (&elseblock); /* Allocate memory to store the data. */ + if (POINTER_TYPE_P (TREE_TYPE (se->expr))) + se->expr = build_fold_indirect_ref_loc (input_location, se->expr); + pointer = gfc_conv_descriptor_data_get (se->expr); STRIP_NOPS (pointer); @@ -5104,7 +5111,8 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg, gfc_add_expr_to_block (&se->pre, tmp); - if (expr->ts.type == BT_CLASS && expr3) + if (expr->ts.type == BT_CLASS + && (expr3_elem_size != NULL_TREE || expr3)) { tmp = build_int_cst (unsigned_char_type_node, 0); /* With class objects, it is best to play safe and null the diff --git a/gcc/fortran/trans-array.h b/gcc/fortran/trans-array.h index ed922d02814..6ca630e9ed9 100644 --- a/gcc/fortran/trans-array.h +++ b/gcc/fortran/trans-array.h @@ -25,7 +25,7 @@ tree gfc_array_deallocate (tree, tree, tree, tree, tree, gfc_expr*); /* Generate code to initialize and allocate an array. Statements are added to se, which should contain an expression for the array descriptor. */ bool gfc_array_allocate (gfc_se *, gfc_expr *, tree, tree, tree, tree, - gfc_expr *); + tree, tree *, gfc_expr *); /* Allow the bounds of a loop to be set from a callee's array spec. */ void gfc_set_loop_bounds_from_array_spec (gfc_interface_mapping *, diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index 15b6797c12b..250f30fa41b 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -215,7 +215,7 @@ gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e, OOP-TODO: This could be improved by adding code that branched on the dynamic type being the same as the declared type. In this case the original class expression can be passed directly. */ -static void +void gfc_conv_class_to_class (gfc_se *parmse, gfc_expr *e, gfc_typespec class_ts, bool elemental) { @@ -303,6 +303,109 @@ gfc_conv_class_to_class (gfc_se *parmse, gfc_expr *e, } +/* Given a class array declaration and an index, returns the address + of the referenced element. */ + +tree +gfc_get_class_array_ref (tree index, tree class_decl) +{ + tree data = gfc_class_data_get (class_decl); + tree size = gfc_vtable_size_get (class_decl); + tree offset = fold_build2_loc (input_location, MULT_EXPR, + gfc_array_index_type, + index, size); + tree ptr; + data = gfc_conv_descriptor_data_get (data); + ptr = fold_convert (pvoid_type_node, data); + ptr = fold_build_pointer_plus_loc (input_location, ptr, offset); + return fold_convert (TREE_TYPE (data), ptr); +} + + +/* Copies one class expression to another, assuming that if either + 'to' or 'from' are arrays they are packed. Should 'from' be + NULL_TREE, the inialization expression for 'to' is used, assuming + that the _vptr is set. */ + +tree +gfc_copy_class_to_class (tree from, tree to, tree nelems) +{ + tree fcn; + tree fcn_type; + tree from_data; + tree to_data; + tree to_ref; + tree from_ref; + VEC(tree,gc) *args; + tree tmp; + tree index; + stmtblock_t loopbody; + stmtblock_t body; + gfc_loopinfo loop; + + args = NULL; + + if (from != NULL_TREE) + fcn = gfc_vtable_copy_get (from); + else + fcn = gfc_vtable_copy_get (to); + + fcn_type = TREE_TYPE (TREE_TYPE (fcn)); + + if (from != NULL_TREE) + from_data = gfc_class_data_get (from); + else + from_data = gfc_vtable_def_init_get (to); + + to_data = gfc_class_data_get (to); + + if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (to_data))) + { + gfc_init_block (&body); + tmp = fold_build2_loc (input_location, MINUS_EXPR, + gfc_array_index_type, nelems, + gfc_index_one_node); + nelems = gfc_evaluate_now (tmp, &body); + index = gfc_create_var (gfc_array_index_type, "S"); + + if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (from_data))) + { + from_ref = gfc_get_class_array_ref (index, from); + VEC_safe_push (tree, gc, args, from_ref); + } + else + VEC_safe_push (tree, gc, args, from_data); + + to_ref = gfc_get_class_array_ref (index, to); + VEC_safe_push (tree, gc, args, to_ref); + + tmp = build_call_vec (fcn_type, fcn, args); + + /* Build the body of the loop. */ + gfc_init_block (&loopbody); + gfc_add_expr_to_block (&loopbody, tmp); + + /* Build the loop and return. */ + gfc_init_loopinfo (&loop); + loop.dimen = 1; + loop.from[0] = gfc_index_zero_node; + loop.loopvar[0] = index; + loop.to[0] = nelems; + gfc_trans_scalarizing_loops (&loop, &loopbody); + gfc_add_block_to_block (&body, &loop.pre); + tmp = gfc_finish_block (&body); + } + else + { + gcc_assert (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (from_data))); + VEC_safe_push (tree, gc, args, from_data); + VEC_safe_push (tree, gc, args, to_data); + tmp = build_call_vec (fcn_type, fcn, args); + } + + return tmp; +} + static tree gfc_trans_class_array_init_assign (gfc_expr *rhs, gfc_expr *lhs, gfc_expr *obj) { diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c index 16acc33a269..19a8e7af429 100644 --- a/gcc/fortran/trans-stmt.c +++ b/gcc/fortran/trans-stmt.c @@ -4740,6 +4740,10 @@ gfc_trans_allocate (gfc_code * code) stmtblock_t post; gfc_expr *sz; gfc_se se_sz; + tree class_expr; + tree nelems; + tree memsize = NULL_TREE; + tree classexpr = NULL_TREE; if (!code->ext.alloc.list) return NULL_TREE; @@ -4794,13 +4798,39 @@ gfc_trans_allocate (gfc_code * code) se.descriptor_only = 1; gfc_conv_expr (&se, expr); + /* Evaluate expr3 just once if not a variable. */ + if (al == code->ext.alloc.list + && al->expr->ts.type == BT_CLASS + && code->expr3 + && code->expr3->ts.type == BT_CLASS + && code->expr3->expr_type != EXPR_VARIABLE) + { + gfc_init_se (&se_sz, NULL); + gfc_conv_expr_reference (&se_sz, code->expr3); + gfc_conv_class_to_class (&se_sz, code->expr3, + code->expr3->ts, false); + gfc_add_block_to_block (&se.pre, &se_sz.pre); + gfc_add_block_to_block (&se.post, &se_sz.post); + classexpr = build_fold_indirect_ref_loc (input_location, + se_sz.expr); + classexpr = gfc_evaluate_now (classexpr, &se.pre); + memsize = gfc_vtable_size_get (classexpr); + memsize = fold_convert (sizetype, memsize); + } + + memsz = memsize; + class_expr = classexpr; + + nelems = NULL_TREE; if (!gfc_array_allocate (&se, expr, stat, errmsg, errlen, label_finish, - code->expr3)) + memsz, &nelems, code->expr3)) { /* A scalar or derived type. */ /* Determine allocate size. */ - if (al->expr->ts.type == BT_CLASS && code->expr3) + if (al->expr->ts.type == BT_CLASS + && code->expr3 + && memsz == NULL_TREE) { if (code->expr3->ts.type == BT_CLASS) { @@ -4897,7 +4927,7 @@ gfc_trans_allocate (gfc_code * code) } else if (code->ext.alloc.ts.type != BT_UNKNOWN) memsz = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&code->ext.alloc.ts)); - else + else if (memsz == NULL_TREE) memsz = TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (se.expr))); if (expr->ts.type == BT_CHARACTER && memsz == NULL_TREE) @@ -4956,13 +4986,23 @@ gfc_trans_allocate (gfc_code * code) e = gfc_copy_expr (al->expr); if (e->ts.type == BT_CLASS) { - gfc_expr *lhs,*rhs; + gfc_expr *lhs, *rhs; gfc_se lse; lhs = gfc_expr_to_initialize (e); gfc_add_vptr_component (lhs); - rhs = NULL; - if (code->expr3 && code->expr3->ts.type == BT_CLASS) + + if (class_expr != NULL_TREE) + { + /* Polymorphic SOURCE: VPTR must be determined at run time. */ + gfc_init_se (&lse, NULL); + lse.want_pointer = 1; + gfc_conv_expr (&lse, lhs); + tmp = gfc_class_vptr_get (class_expr); + gfc_add_modify (&block, lse.expr, + fold_convert (TREE_TYPE (lse.expr), tmp)); + } + else if (code->expr3 && code->expr3->ts.type == BT_CLASS) { /* Polymorphic SOURCE: VPTR must be determined at run time. */ rhs = gfc_copy_expr (code->expr3); @@ -5011,7 +5051,14 @@ gfc_trans_allocate (gfc_code * code) /* Initialization via SOURCE block (or static default initializer). */ gfc_expr *rhs = gfc_copy_expr (code->expr3); - if (al->expr->ts.type == BT_CLASS) + if (class_expr != NULL_TREE) + { + tree to; + to = TREE_OPERAND (se.expr, 0); + + tmp = gfc_copy_class_to_class (class_expr, to, nelems); + } + else if (al->expr->ts.type == BT_CLASS) { gfc_actual_arglist *actual; gfc_expr *ppc; @@ -5098,25 +5145,18 @@ gfc_trans_allocate (gfc_code * code) gfc_free_expr (rhs); gfc_add_expr_to_block (&block, tmp); } - else if (code->expr3 && code->expr3->mold + else if (code->expr3 && code->expr3->mold && code->expr3->ts.type == BT_CLASS) { - /* Default-initialization via MOLD (polymorphic). */ - gfc_expr *rhs = gfc_copy_expr (code->expr3); - gfc_se dst,src; - gfc_add_vptr_component (rhs); - gfc_add_def_init_component (rhs); - gfc_init_se (&dst, NULL); - gfc_init_se (&src, NULL); - gfc_conv_expr (&dst, expr); - gfc_conv_expr (&src, rhs); - gfc_add_block_to_block (&block, &src.pre); - tmp = gfc_build_memcpy_call (dst.expr, src.expr, memsz); + /* Since the _vptr has already been assigned to the allocate + object, we can use gfc_copy_class_to_class in its + initialization mode. */ + tmp = TREE_OPERAND (se.expr, 0); + tmp = gfc_copy_class_to_class (NULL_TREE, tmp, nelems); gfc_add_expr_to_block (&block, tmp); - gfc_free_expr (rhs); } - gfc_free_expr (expr); + gfc_free_expr (expr); } /* STAT. */ diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h index b7c25b34488..e685a84c388 100644 --- a/gcc/fortran/trans.h +++ b/gcc/fortran/trans.h @@ -346,6 +346,9 @@ tree gfc_vtable_size_get (tree); tree gfc_vtable_extends_get (tree); tree gfc_vtable_def_init_get (tree); tree gfc_vtable_copy_get (tree); +tree gfc_get_class_array_ref (tree, tree); +tree gfc_copy_class_to_class (tree, tree, tree); +void gfc_conv_class_to_class (gfc_se *, gfc_expr *, gfc_typespec, bool); /* Initialize an init/cleanup block. */ void gfc_start_wrapped_block (gfc_wrapped_block* block, tree code); diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index a1844b7cf90..f08fb6c6561 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,17 @@ +2012-01-27 Paul Thomas + Tobias Burnus + + PR fortran/48705 + * gfortran.dg/class_allocate_11.f03: New. + + PR fortran/51870 + PR fortran/51943 + PR fortran/51946 + * gfortran.dg/class_allocate_7.f03: New. + * gfortran.dg/class_allocate_8.f03: New. + * gfortran.dg/class_allocate_9.f03: New. + * gfortran.dg/class_allocate_10.f03: New. + 2012-01-27 Eric Botcazou * gnat.dg/discr34.adb: New test. diff --git a/gcc/testsuite/gfortran.dg/class_allocate_10.f03 b/gcc/testsuite/gfortran.dg/class_allocate_10.f03 new file mode 100644 index 00000000000..d3afa395ec9 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/class_allocate_10.f03 @@ -0,0 +1,64 @@ +! { dg-do run } +! PR51870 - ALLOCATE with class function expression for SOURCE failed. +! This version of the test allocates class arrays with MOLD. +! +! Reported by Tobias Burnus +! +module show_producer_class + implicit none + type integrand + integer :: variable = 1 + end type integrand + + type show_producer + contains + procedure ,nopass :: create_show + procedure ,nopass :: create_show_array + end type +contains + function create_show () result(new_integrand) + class(integrand) ,allocatable :: new_integrand + allocate(new_integrand) + new_integrand%variable = -1 + end function + function create_show_array (n) result(new_integrand) + class(integrand) ,allocatable :: new_integrand(:) + integer :: n, i + allocate(new_integrand(n)) + select type (new_integrand) + type is (integrand); new_integrand%variable = [(i, i= 1, n)] + end select + end function +end module + +program main + use show_producer_class + implicit none + class(integrand) ,allocatable :: kernel1(:), kernel2(:) + type(show_producer) :: executive_producer + + allocate(kernel1(5), kernel2(5),mold=executive_producer%create_show_array (5)) + select type(kernel1) + type is (integrand); if (any (kernel1%variable .ne. 1)) call abort + end select + + deallocate (kernel1) + + allocate(kernel1(3),mold=executive_producer%create_show ()) + select type(kernel1) + type is (integrand); if (any (kernel1%variable .ne. 1)) call abort + end select + + deallocate (kernel1) + + select type(kernel2) + type is (integrand); kernel2%variable = [1,2,3,4,5] + end select + + allocate(kernel1(3),source = kernel2(3:5)) + select type(kernel1) + type is (integrand); if (any (kernel1%variable .ne. [3,4,5])) call abort + end select +end program +! { dg-final { cleanup-modules "show_producer_class" } } + diff --git a/gcc/testsuite/gfortran.dg/class_allocate_11.f03 b/gcc/testsuite/gfortran.dg/class_allocate_11.f03 new file mode 100644 index 00000000000..e36e810aba8 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/class_allocate_11.f03 @@ -0,0 +1,62 @@ +! { dg-do run } +! PR48705 - ALLOCATE with class function expression for SOURCE failed. +! This is the original test in the PR. +! +! Reported by Tobias Burnus +! +module generic_deferred + implicit none + type, abstract :: addable + contains + private + procedure(add), deferred :: a + generic, public :: operator(+) => a + end type addable + abstract interface + function add(x, y) result(res) + import :: addable + class(addable), intent(in) :: x, y + class(addable), allocatable :: res + end function add + end interface + type, extends(addable) :: vec + integer :: i(2) + contains + procedure :: a => a_vec + end type +contains + function a_vec(x, y) result(res) + class(vec), intent(in) :: x + class(addable), intent(in) :: y + class(addable), allocatable :: res + integer :: ii(2) + select type(y) + class is (vec) + ii = y%i + end select + allocate(vec :: res) + select type(res) + type is (vec) + res%i = x%i + ii + end select + end function +end module generic_deferred +program prog + use generic_deferred + implicit none + type(vec) :: x, y + class(addable), allocatable :: z +! x = vec( (/1,2/) ); y = vec( (/2,-2/) ) + x%i = (/1,2/); y%i = (/2,-2/) + allocate(z, source= x + y) + select type(z) + type is(vec) + if (z%i(1) /= 3 .or. z%i(2) /= 0) then + write(*,*) 'FAIL' + else + write(*,*) 'OK' + end if + end select +end program prog +! { dg-final { cleanup-modules "generic_deferred" } } + diff --git a/gcc/testsuite/gfortran.dg/class_allocate_7.f03 b/gcc/testsuite/gfortran.dg/class_allocate_7.f03 new file mode 100644 index 00000000000..ddab4073dec --- /dev/null +++ b/gcc/testsuite/gfortran.dg/class_allocate_7.f03 @@ -0,0 +1,35 @@ +! { dg-do run } +! PR51870 - ALLOCATE with class function expression for SOURCE failed. +! This is the original test in the PR. +! +! Reported by Tobias Burnus +! +module show_producer_class + implicit none + type integrand + integer :: variable = -1 + end type integrand + + type show_producer + contains + procedure ,nopass :: create_show + end type +contains + function create_show () result(new_integrand) + class(integrand) ,allocatable :: new_integrand + allocate(new_integrand) + new_integrand%variable = 99 + end function +end module + +program main + use show_producer_class + implicit none + class(integrand) ,allocatable :: kernel + type(show_producer) :: executive_producer + + allocate(kernel,source=executive_producer%create_show ()) + if (kernel%variable .ne. 99) call abort +end program +! { dg-final { cleanup-modules "show_producer_class" } } + diff --git a/gcc/testsuite/gfortran.dg/class_allocate_8.f03 b/gcc/testsuite/gfortran.dg/class_allocate_8.f03 new file mode 100644 index 00000000000..85094ad1fe0 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/class_allocate_8.f03 @@ -0,0 +1,53 @@ +! { dg-do run } +! PR51870 - ALLOCATE with class function expression for SOURCE failed. +! This version of the test allocates class arrays. +! +! Reported by Tobias Burnus +! +module show_producer_class + implicit none + type integrand + integer :: variable = 0 + end type integrand + + type show_producer + contains + procedure ,nopass :: create_show + procedure ,nopass :: create_show_array + end type +contains + function create_show () result(new_integrand) + class(integrand) ,allocatable :: new_integrand + allocate(new_integrand) + new_integrand%variable = -1 + end function + function create_show_array (n) result(new_integrand) + class(integrand) ,allocatable :: new_integrand(:) + integer :: n, i + allocate(new_integrand(n)) + select type (new_integrand) + type is (integrand); new_integrand%variable = [(i, i= 1, n)] + end select + end function +end module + +program main + use show_producer_class + implicit none + class(integrand) ,allocatable :: kernel(:) + type(show_producer) :: executive_producer + + allocate(kernel(5),source=executive_producer%create_show_array (5)) + select type(kernel) + type is (integrand); if (any (kernel%variable .ne. [1,2,3,4,5])) call abort + end select + + deallocate (kernel) + + allocate(kernel(3),source=executive_producer%create_show ()) + select type(kernel) + type is (integrand); if (any (kernel%variable .ne. -1)) call abort + end select +end program +! { dg-final { cleanup-modules "show_producer_class" } } + diff --git a/gcc/testsuite/gfortran.dg/class_allocate_9.f03 b/gcc/testsuite/gfortran.dg/class_allocate_9.f03 new file mode 100644 index 00000000000..2446ed61413 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/class_allocate_9.f03 @@ -0,0 +1,36 @@ +! { dg-do run } +! PR51870 - ALLOCATE with class function expression for SOURCE failed. +! This is the original test in the PR. +! +! Reported by Tobias Burnus +! +module show_producer_class + implicit none + type integrand + integer :: variable = -1 + end type integrand + + type show_producer + contains + procedure ,nopass :: create_show + end type +contains + function create_show () result(new_integrand) + class(integrand) ,allocatable :: new_integrand + allocate(new_integrand) + new_integrand%variable = 99 + end function +end module + +program main + use show_producer_class + implicit none + class(integrand) ,allocatable :: kernel1, kernel2 + type(show_producer) :: executive_producer + + allocate(kernel1, kernel2,mold=executive_producer%create_show ()) + if (kernel1%variable .ne. -1) call abort + if (kernel2%variable .ne. -1) call abort +end program +! { dg-final { cleanup-modules "show_producer_class" } } +