From ce8dcc9105cbd4043d575d8b2c91309a423951a9 Mon Sep 17 00:00:00 2001 From: Paul Thomas Date: Fri, 18 Dec 2020 14:00:11 +0000 Subject: [PATCH] As well as the PR this patch fixes problems in handling class objects 2020-12-18 Paul Thomas gcc/fortran PR fortran/83118 PR fortran/96012 * resolve.c (resolve_ordinary_assign): Generate a vtable if necessary for scalar non-polymorphic rhs's to unlimited lhs's. * trans-array.c (get_class_info_from_ss): New function. (gfc_trans_allocate_array_storage): Defer obtaining class element type until all sources of class exprs are tried. Use class API rather than TREE_OPERAND. Look for class expressions in ss->info by calling get_class_info_from_ss. After, obtain the element size for class descriptors. Where the element type is unknown, cast the data as character(len=size) to overcome unlimited polymorphic problems. (gfc_conv_ss_descriptor): Do not fix class variable refs. (build_class_array_ref, structure_alloc_comps): Replace code replicating the new function gfc_resize_class_size_with_len. (gfc_alloc_allocatable_for_assignment): Obtain element size for lhs in cases of deferred characters and class enitities. Move code for the element size of rhs to start of block. Clean up extraction of class parameters throughout this function. After the shape check test whether or not the lhs and rhs element sizes are the same. Use earlier evaluation of 'cond_null'. Reallocation of lhs only to happen if size changes or element size changes. * trans-expr.c (gfc_resize_class_size_with_len): New function. (gfc_get_class_from_expr): If a constant expression is encountered, return NULL_TREE; (trans_scalar_class_assign): New function. (gfc_conv_procedure_call): Ensure the vtable is present for passing a non-class actual to an unlimited formal. (trans_class_vptr_len_assignment): For expressions of type BT_CLASS, extract the class expression if necessary. Use a statement block outside the loop body. Ensure that 'rhs' is of the correct type. Obtain rhs vptr in all circumstances. (gfc_trans_scalar_assign): Call trans_scalar_class_assign to make maximum use of the vptr copy in place of assignment. (trans_class_assignment): Actually do reallocation if needed. (gfc_trans_assignment_1): Simplify some of the logic with 'realloc_flag'. Set 'vptr_copy' for all array assignments to unlimited polymorphic lhs. * trans.c (gfc_build_array_ref): Call gfc_resize_class_size_ with_len to correct span for unlimited polymorphic decls. * trans.h : Add prototype for gfc_resize_class_size_with_len. gcc/testsuite/ PR fortran/83118 PR fortran/96012 * gfortran.dg/dependency_60.f90: New test. * gfortran.dg/class_allocate_25.f90: New test. * gfortran.dg/class_assign_4.f90: New test. * gfortran.dg/unlimited_polymorphic_32.f03: New test. --- gcc/fortran/resolve.c | 2 +- gcc/fortran/trans-array.c | 448 +++++++++++++----- gcc/fortran/trans-expr.c | 264 ++++++++++- gcc/fortran/trans.c | 16 +- gcc/fortran/trans.h | 1 + .../gfortran.dg/class_allocate_25.f90 | 58 +++ gcc/testsuite/gfortran.dg/class_assign_4.f90 | 183 +++++++ gcc/testsuite/gfortran.dg/dependency_60.f90 | 19 + .../gfortran.dg/unlimited_polymorphic_32.f03 | 59 +++ 9 files changed, 889 insertions(+), 161 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/class_allocate_25.f90 create mode 100644 gcc/testsuite/gfortran.dg/class_assign_4.f90 create mode 100644 gcc/testsuite/gfortran.dg/dependency_60.f90 create mode 100644 gcc/testsuite/gfortran.dg/unlimited_polymorphic_32.f03 diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 1da7ba4d031..cc6173a6221 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -11054,7 +11054,7 @@ resolve_ordinary_assign (gfc_code *code, gfc_namespace *ns) /* Make sure there is a vtable and, in particular, a _copy for the rhs type. */ - if (UNLIMITED_POLY (lhs) && lhs->rank && rhs->ts.type != BT_CLASS) + if (lhs->ts.type == BT_CLASS && rhs->ts.type != BT_CLASS) gfc_find_vtab (&rhs->ts); bool caf_convert_to_send = flag_coarray == GFC_FCOARRAY_LIB diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index b2c39aa32de..9e461f94536 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -1030,7 +1030,6 @@ gfc_trans_allocate_array_storage (stmtblock_t * pre, stmtblock_t * post, gcc_assert (TREE_CODE (tmp) == POINTER_TYPE); tmp = TREE_TYPE (tmp); /* The descriptor itself. */ tmp = gfc_get_element_type (tmp); - gcc_assert (tmp == gfc_get_element_type (TREE_TYPE (desc))); packed = gfc_create_var (build_pointer_type (tmp), "data"); tmp = build_call_expr_loc (input_location, @@ -1139,6 +1138,123 @@ get_array_ref_dim_for_loop_dim (gfc_ss *ss, int loop_dim) } +/* Use the information in the ss to obtain the required information about + the type and size of an array temporary, when the lhs in an assignment + is a class expression. */ + +static tree +get_class_info_from_ss (stmtblock_t * pre, gfc_ss *ss, tree *eltype) +{ + gfc_ss *lhs_ss; + gfc_ss *rhs_ss; + tree tmp; + tree tmp2; + tree vptr; + tree rhs_class_expr = NULL_TREE; + tree lhs_class_expr = NULL_TREE; + bool unlimited_rhs = false; + bool unlimited_lhs = false; + bool rhs_function = false; + gfc_symbol *vtab; + + /* The second element in the loop chain contains the source for the + temporary; ie. the rhs of the assignment. */ + rhs_ss = ss->loop->ss->loop_chain; + + if (rhs_ss != gfc_ss_terminator + && rhs_ss->info + && rhs_ss->info->expr + && rhs_ss->info->expr->ts.type == BT_CLASS + && rhs_ss->info->data.array.descriptor) + { + rhs_class_expr + = gfc_get_class_from_expr (rhs_ss->info->data.array.descriptor); + unlimited_rhs = UNLIMITED_POLY (rhs_ss->info->expr); + if (rhs_ss->info->expr->expr_type == EXPR_FUNCTION) + rhs_function = true; + } + + /* For an assignment the lhs is the next element in the loop chain. + If we have a class rhs, this had better be a class variable + expression! */ + lhs_ss = rhs_ss->loop_chain; + if (lhs_ss != gfc_ss_terminator + && lhs_ss->info + && lhs_ss->info->expr + && lhs_ss->info->expr->expr_type ==EXPR_VARIABLE + && lhs_ss->info->expr->ts.type == BT_CLASS) + { + tmp = lhs_ss->info->data.array.descriptor; + unlimited_lhs = UNLIMITED_POLY (rhs_ss->info->expr); + } + else + tmp = NULL_TREE; + + /* Get the lhs class expression. */ + if (tmp != NULL_TREE && lhs_ss->loop_chain == gfc_ss_terminator) + lhs_class_expr = gfc_get_class_from_expr (tmp); + else + return rhs_class_expr; + + gcc_assert (GFC_CLASS_TYPE_P (TREE_TYPE (lhs_class_expr))); + + /* Set the lhs vptr and, if necessary, the _len field. */ + if (rhs_class_expr) + { + /* Both lhs and rhs are class expressions. */ + tmp = gfc_class_vptr_get (lhs_class_expr); + gfc_add_modify (pre, tmp, + fold_convert (TREE_TYPE (tmp), + gfc_class_vptr_get (rhs_class_expr))); + if (unlimited_lhs) + { + tmp = gfc_class_len_get (lhs_class_expr); + if (unlimited_rhs) + tmp2 = gfc_class_len_get (rhs_class_expr); + else + tmp2 = build_int_cst (TREE_TYPE (tmp), 0); + gfc_add_modify (pre, tmp, tmp2); + } + + if (rhs_function) + { + tmp = gfc_class_data_get (rhs_class_expr); + gfc_conv_descriptor_offset_set (pre, tmp, gfc_index_zero_node); + } + } + else + { + /* lhs is class and rhs is intrinsic or derived type. */ + *eltype = TREE_TYPE (rhs_ss->info->data.array.descriptor); + *eltype = gfc_get_element_type (*eltype); + vtab = gfc_find_vtab (&rhs_ss->info->expr->ts); + vptr = vtab->backend_decl; + if (vptr == NULL_TREE) + vptr = gfc_get_symbol_decl (vtab); + vptr = gfc_build_addr_expr (NULL_TREE, vptr); + tmp = gfc_class_vptr_get (lhs_class_expr); + gfc_add_modify (pre, tmp, + fold_convert (TREE_TYPE (tmp), vptr)); + + if (unlimited_lhs) + { + tmp = gfc_class_len_get (lhs_class_expr); + if (rhs_ss->info + && rhs_ss->info->expr + && rhs_ss->info->expr->ts.type == BT_CHARACTER) + tmp2 = build_int_cst (TREE_TYPE (tmp), + rhs_ss->info->expr->ts.kind); + else + tmp2 = build_int_cst (TREE_TYPE (tmp), 0); + gfc_add_modify (pre, tmp, tmp2); + } + } + + return rhs_class_expr; +} + + + /* Generate code to create and initialize the descriptor for a temporary array. This is used for both temporaries needed by the scalarizer, and functions returning arrays. Adjusts the loop variables to be @@ -1184,13 +1300,46 @@ gfc_trans_create_temp_array (stmtblock_t * pre, stmtblock_t * post, gfc_ss * ss, { gcc_assert (POINTER_TYPE_P (TREE_TYPE (initial))); class_expr = build_fold_indirect_ref_loc (input_location, initial); - eltype = TREE_TYPE (class_expr); - eltype = gfc_get_element_type (eltype); /* Obtain the structure (class) expression. */ - class_expr = TREE_OPERAND (class_expr, 0); + class_expr = gfc_get_class_from_expr (class_expr); gcc_assert (class_expr); } + /* Otherwise, some expressions, such as class functions, arising from + dependency checking in assignments come here with class element type. + The descriptor can be obtained from the ss->info and then converted + to the class object. */ + if (class_expr == NULL_TREE && GFC_CLASS_TYPE_P (eltype)) + class_expr = get_class_info_from_ss (pre, ss, &eltype); + + /* If the dynamic type is not available, use the declared type. */ + if (eltype && GFC_CLASS_TYPE_P (eltype)) + eltype = gfc_get_element_type (TREE_TYPE (TYPE_FIELDS (eltype))); + + if (class_expr == NULL_TREE) + elemsize = fold_convert (gfc_array_index_type, + TYPE_SIZE_UNIT (eltype)); + else + { + /* Unlimited polymorphic entities are initialised with NULL vptr. They + can be tested for by checking if the len field is present. If so + test the vptr before using the vtable size. */ + tmp = gfc_class_vptr_get (class_expr); + tmp = fold_build2_loc (input_location, NE_EXPR, + logical_type_node, + tmp, build_int_cst (TREE_TYPE (tmp), 0)); + elemsize = fold_build3_loc (input_location, COND_EXPR, + gfc_array_index_type, + tmp, + gfc_class_vtab_size_get (class_expr), + gfc_index_zero_node); + elemsize = gfc_evaluate_now (elemsize, pre); + elemsize = gfc_resize_class_size_with_len (pre, class_expr, elemsize); + /* Casting the data as a character of the dynamic length ensures that + assignment of elements works when needed. */ + eltype = gfc_get_character_type_len (1, elemsize); + } + memset (from, 0, sizeof (from)); memset (to, 0, sizeof (to)); @@ -1339,12 +1488,6 @@ gfc_trans_create_temp_array (stmtblock_t * pre, stmtblock_t * post, gfc_ss * ss, } } - if (class_expr == NULL_TREE) - elemsize = fold_convert (gfc_array_index_type, - TYPE_SIZE_UNIT (gfc_get_element_type (type))); - else - elemsize = gfc_class_vtab_size_get (class_expr); - /* Get the size of the array. */ if (size && !callee_alloc) { @@ -2910,13 +3053,16 @@ gfc_conv_ss_descriptor (stmtblock_t * block, gfc_ss * ss, int base) } /* Also the data pointer. */ tmp = gfc_conv_array_data (se.expr); - /* If this is a variable or address of a variable we use it directly. + /* If this is a variable or address or a class array, use it directly. Otherwise we must evaluate it now to avoid breaking dependency analysis by pulling the expressions for elemental array indices inside the loop. */ if (!(DECL_P (tmp) || (TREE_CODE (tmp) == ADDR_EXPR - && DECL_P (TREE_OPERAND (tmp, 0))))) + && DECL_P (TREE_OPERAND (tmp, 0))) + || (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se.expr)) + && TREE_CODE (se.expr) == COMPONENT_REF + && GFC_CLASS_TYPE_P (TREE_TYPE (TREE_OPERAND (se.expr, 0)))))) tmp = gfc_evaluate_now (tmp, block); info->data = tmp; @@ -3373,18 +3519,10 @@ build_class_array_ref (gfc_se *se, tree base, tree index) size = gfc_class_vtab_size_get (decl); /* For unlimited polymorphic entities then _len component needs to be - multiplied with the size. If no _len component is present, then - gfc_class_len_or_zero_get () return a zero_node. */ - tmp = gfc_class_len_or_zero_get (decl); - if (!integer_zerop (tmp)) - size = fold_build2 (MULT_EXPR, TREE_TYPE (index), - fold_convert (TREE_TYPE (index), size), - fold_build2 (MAX_EXPR, TREE_TYPE (index), - fold_convert (TREE_TYPE (index), tmp), - fold_convert (TREE_TYPE (index), - integer_one_node))); - else - size = fold_convert (TREE_TYPE (index), size); + multiplied with the size. */ + size = gfc_resize_class_size_with_len (&se->pre, decl, size); + + size = fold_convert (TREE_TYPE (index), size); /* Build the address of the element. */ type = TREE_TYPE (TREE_TYPE (base)); @@ -9233,21 +9371,9 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, for the malloc call. */ if (UNLIMITED_POLY (c)) { - tree ctmp; gfc_add_modify (&tmpblock, gfc_class_len_get (dcmp), gfc_class_len_get (comp)); - - size = gfc_evaluate_now (size, &tmpblock); - tmp = gfc_class_len_get (comp); - ctmp = fold_build2_loc (input_location, MULT_EXPR, - size_type_node, size, - fold_convert (size_type_node, tmp)); - tmp = fold_build2_loc (input_location, GT_EXPR, - logical_type_node, tmp, - build_zero_cst (TREE_TYPE (tmp))); - size = fold_build3_loc (input_location, COND_EXPR, - size_type_node, tmp, ctmp, size); - size = gfc_evaluate_now (size, &tmpblock); + size = gfc_resize_class_size_with_len (&tmpblock, comp, size); } /* Coarray component have to have the same allocation status and @@ -10033,6 +10159,8 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop, tree alloc_expr; tree size1; tree size2; + tree elemsize1; + tree elemsize2; tree array1; tree cond_null; tree cond; @@ -10112,6 +10240,108 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop, gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc))); array1 = gfc_conv_descriptor_data_get (desc); + if (expr2) + desc2 = rss->info->data.array.descriptor; + else + desc2 = NULL_TREE; + + /* Get the old lhs element size for deferred character and class expr1. */ + if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred) + { + if (expr1->ts.u.cl->backend_decl + && VAR_P (expr1->ts.u.cl->backend_decl)) + elemsize1 = expr1->ts.u.cl->backend_decl; + else + elemsize1 = lss->info->string_length; + } + else if (expr1->ts.type == BT_CLASS) + { + tmp = expr1->rank ? gfc_get_class_from_expr (desc) : NULL_TREE; + if (tmp != NULL_TREE) + { + tmp2 = gfc_class_vptr_get (tmp); + cond = fold_build2_loc (input_location, NE_EXPR, + logical_type_node, tmp2, + build_int_cst (TREE_TYPE (tmp2), 0)); + elemsize1 = gfc_class_vtab_size_get (tmp); + elemsize1 = fold_build3_loc (input_location, COND_EXPR, + gfc_array_index_type, cond, + elemsize1, gfc_index_zero_node); + } + else + elemsize1 = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&CLASS_DATA (expr1)->ts)); + } + else + elemsize1 = NULL_TREE; + if (elemsize1 != NULL_TREE) + elemsize1 = gfc_evaluate_now (elemsize1, &fblock); + + /* Get the new lhs size in bytes. */ + if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred) + { + if (expr2->ts.deferred) + { + if (expr2->ts.u.cl->backend_decl + && VAR_P (expr2->ts.u.cl->backend_decl)) + tmp = expr2->ts.u.cl->backend_decl; + else + tmp = rss->info->string_length; + } + else + { + tmp = expr2->ts.u.cl->backend_decl; + if (!tmp && expr2->expr_type == EXPR_OP + && expr2->value.op.op == INTRINSIC_CONCAT) + { + tmp = concat_str_length (expr2); + expr2->ts.u.cl->backend_decl = gfc_evaluate_now (tmp, &fblock); + } + else if (!tmp && expr2->ts.u.cl->length) + { + gfc_se tmpse; + gfc_init_se (&tmpse, NULL); + gfc_conv_expr_type (&tmpse, expr2->ts.u.cl->length, + gfc_charlen_type_node); + tmp = tmpse.expr; + expr2->ts.u.cl->backend_decl = gfc_evaluate_now (tmp, &fblock); + } + tmp = fold_convert (TREE_TYPE (expr1->ts.u.cl->backend_decl), tmp); + } + + if (expr1->ts.u.cl->backend_decl + && VAR_P (expr1->ts.u.cl->backend_decl)) + gfc_add_modify (&fblock, expr1->ts.u.cl->backend_decl, tmp); + else + gfc_add_modify (&fblock, lss->info->string_length, tmp); + + if (expr1->ts.kind > 1) + tmp = fold_build2_loc (input_location, MULT_EXPR, + TREE_TYPE (tmp), + tmp, build_int_cst (TREE_TYPE (tmp), + expr1->ts.kind)); + } + else if (expr1->ts.type == BT_CHARACTER && expr1->ts.u.cl->backend_decl) + { + tmp = TYPE_SIZE_UNIT (TREE_TYPE (gfc_typenode_for_spec (&expr1->ts))); + tmp = fold_build2_loc (input_location, MULT_EXPR, + gfc_array_index_type, tmp, + expr1->ts.u.cl->backend_decl); + } + else if (UNLIMITED_POLY (expr1) && expr2->ts.type != BT_CLASS) + tmp = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr2->ts)); + else if (expr1->ts.type == BT_CLASS && expr2->ts.type == BT_CLASS) + { + tmp = expr2->rank ? gfc_get_class_from_expr (desc2) : NULL_TREE; + if (tmp != NULL_TREE) + tmp = gfc_class_vtab_size_get (tmp); + else + tmp = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&CLASS_DATA (expr2)->ts)); + } + else + tmp = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr2->ts)); + elemsize2 = fold_convert (gfc_array_index_type, tmp); + elemsize2 = gfc_evaluate_now (elemsize2, &fblock); + /* 7.4.1.3 "If variable is an allocated allocatable variable, it is deallocated if expr is an array of different shape or any of the corresponding length type parameter values of variable and expr @@ -10131,6 +10361,7 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop, rss->info->string_length); cond_null = fold_build2_loc (input_location, TRUTH_OR_EXPR, logical_type_node, tmp, cond_null); + cond_null= gfc_evaluate_now (cond_null, &fblock); } else cond_null= gfc_evaluate_now (cond_null, &fblock); @@ -10179,6 +10410,19 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop, gfc_add_expr_to_block (&fblock, tmp); } + /* ...else if the element lengths are not the same also go to + setting the bounds and doing the reallocation.... */ + if (elemsize1 != NULL_TREE) + { + cond = fold_build2_loc (input_location, NE_EXPR, + logical_type_node, + elemsize1, elemsize2); + tmp = build3_v (COND_EXPR, cond, + build1_v (GOTO_EXPR, jump_label1), + build_empty_stmt (input_location)); + gfc_add_expr_to_block (&fblock, tmp); + } + /* ....else jump past the (re)alloc code. */ tmp = build1_v (GOTO_EXPR, jump_label2); gfc_add_expr_to_block (&fblock, tmp); @@ -10201,11 +10445,6 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop, gfc_add_expr_to_block (&fblock, tmp); /* Get the rhs size and fix it. */ - if (expr2) - desc2 = rss->info->data.array.descriptor; - else - desc2 = NULL_TREE; - size2 = gfc_index_one_node; for (n = 0; n < expr2->rank; n++) { @@ -10320,69 +10559,12 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop, gfc_add_modify (&fblock, linfo->delta[dim], tmp); } - /* Get the new lhs size in bytes. */ - if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred) - { - if (expr2->ts.deferred) - { - if (expr2->ts.u.cl->backend_decl - && VAR_P (expr2->ts.u.cl->backend_decl)) - tmp = expr2->ts.u.cl->backend_decl; - else - tmp = rss->info->string_length; - } - else - { - tmp = expr2->ts.u.cl->backend_decl; - if (!tmp && expr2->expr_type == EXPR_OP - && expr2->value.op.op == INTRINSIC_CONCAT) - { - tmp = concat_str_length (expr2); - expr2->ts.u.cl->backend_decl = gfc_evaluate_now (tmp, &fblock); - } - else if (!tmp && expr2->ts.u.cl->length) - { - gfc_se tmpse; - gfc_init_se (&tmpse, NULL); - gfc_conv_expr_type (&tmpse, expr2->ts.u.cl->length, - gfc_charlen_type_node); - tmp = tmpse.expr; - expr2->ts.u.cl->backend_decl = gfc_evaluate_now (tmp, &fblock); - } - tmp = fold_convert (TREE_TYPE (expr1->ts.u.cl->backend_decl), tmp); - } - - if (expr1->ts.u.cl->backend_decl - && VAR_P (expr1->ts.u.cl->backend_decl)) - gfc_add_modify (&fblock, expr1->ts.u.cl->backend_decl, tmp); - else - gfc_add_modify (&fblock, lss->info->string_length, tmp); - - if (expr1->ts.kind > 1) - tmp = fold_build2_loc (input_location, MULT_EXPR, - TREE_TYPE (tmp), - tmp, build_int_cst (TREE_TYPE (tmp), - expr1->ts.kind)); - } - else if (expr1->ts.type == BT_CHARACTER && expr1->ts.u.cl->backend_decl) - { - tmp = TYPE_SIZE_UNIT (TREE_TYPE (gfc_typenode_for_spec (&expr1->ts))); - tmp = fold_build2_loc (input_location, MULT_EXPR, - gfc_array_index_type, tmp, - expr1->ts.u.cl->backend_decl); - } - else if (UNLIMITED_POLY (expr1) && expr2->ts.type != BT_CLASS) - tmp = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr2->ts)); - else - tmp = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr1->ts)); - tmp = fold_convert (gfc_array_index_type, tmp); - if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc))) - gfc_conv_descriptor_span_set (&fblock, desc, tmp); + gfc_conv_descriptor_span_set (&fblock, desc, elemsize2); size2 = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, - tmp, size2); + elemsize2, size2); size2 = fold_convert (size_type_node, size2); size2 = fold_build2_loc (input_location, MAX_EXPR, size_type_node, size2, size_one_node); @@ -10403,27 +10585,45 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop, gfc_add_modify (&fblock, tmp, gfc_get_dtype_rank_type (expr1->rank,type)); } - else if (UNLIMITED_POLY (expr1) && expr2->ts.type != BT_CLASS) + else if (expr1->ts.type == BT_CLASS) { tree type; tmp = gfc_conv_descriptor_dtype (desc); - type = gfc_typenode_for_spec (&expr2->ts); + + if (expr2->ts.type != BT_CLASS) + type = gfc_typenode_for_spec (&expr2->ts); + else + type = gfc_get_character_type_len (1, elemsize2); + gfc_add_modify (&fblock, tmp, gfc_get_dtype_rank_type (expr2->rank,type)); /* Set the _len field as well... */ - tmp = gfc_class_len_get (TREE_OPERAND (desc, 0)); - if (expr2->ts.type == BT_CHARACTER) - gfc_add_modify (&fblock, tmp, - fold_convert (TREE_TYPE (tmp), - TYPE_SIZE_UNIT (type))); - else - gfc_add_modify (&fblock, tmp, - build_int_cst (TREE_TYPE (tmp), 0)); + if (UNLIMITED_POLY (expr1)) + { + tmp = gfc_class_len_get (TREE_OPERAND (desc, 0)); + if (expr2->ts.type == BT_CHARACTER) + gfc_add_modify (&fblock, tmp, + fold_convert (TREE_TYPE (tmp), + TYPE_SIZE_UNIT (type))); + else + gfc_add_modify (&fblock, tmp, + build_int_cst (TREE_TYPE (tmp), 0)); + } /* ...and the vptr. */ tmp = gfc_class_vptr_get (TREE_OPERAND (desc, 0)); - tmp2 = gfc_get_symbol_decl (gfc_find_vtab (&expr2->ts)); - tmp2 = gfc_build_addr_expr (TREE_TYPE (tmp), tmp2); - gfc_add_modify (&fblock, tmp, tmp2); + if (expr2->ts.type == BT_CLASS && !VAR_P (desc2) + && TREE_CODE (desc2) == COMPONENT_REF) + { + tmp2 = gfc_get_class_from_expr (desc2); + tmp2 = gfc_class_vptr_get (tmp2); + } + else + { + tmp2 = gfc_get_symbol_decl (gfc_find_vtab (&expr2->ts)); + tmp2 = gfc_build_addr_expr (TREE_TYPE (tmp), tmp2); + } + + gfc_add_modify (&fblock, tmp, fold_convert (TREE_TYPE (tmp), tmp2)); } else if (coarray && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc))) { @@ -10499,11 +10699,19 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop, gfc_add_block_to_block (&realloc_block, &caf_se.post); realloc_expr = gfc_finish_block (&realloc_block); - /* Only reallocate if sizes are different. */ + /* Reallocate if sizes or dynamic types are different. */ + if (elemsize1) + { + tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node, + elemsize1, elemsize2); + tmp = gfc_evaluate_now (tmp, &fblock); + neq_size = fold_build2_loc (input_location, TRUTH_OR_EXPR, + logical_type_node, neq_size, tmp); + } tmp = build3_v (COND_EXPR, neq_size, realloc_expr, build_empty_stmt (input_location)); - realloc_expr = tmp; + realloc_expr = tmp; /* Malloc expression. */ gfc_init_block (&alloc_block); @@ -10550,11 +10758,7 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop, alloc_expr = gfc_finish_block (&alloc_block); /* Malloc if not allocated; realloc otherwise. */ - tmp = build_int_cst (TREE_TYPE (array1), 0); - cond = fold_build2_loc (input_location, EQ_EXPR, - logical_type_node, - array1, tmp); - tmp = build3_v (COND_EXPR, cond, alloc_expr, realloc_expr); + tmp = build3_v (COND_EXPR, cond_null, alloc_expr, realloc_expr); gfc_add_expr_to_block (&fblock, tmp); /* Make sure that the scalarizer data pointer is updated. */ @@ -10564,7 +10768,7 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop, gfc_add_modify (&fblock, linfo->data, tmp); } - /* Add the exit label. */ + /* Add the label for same shape lhs and rhs. */ tmp = build1_v (LABEL_EXPR, jump_label2); gfc_add_expr_to_block (&fblock, tmp); diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index 2167de455b8..bfe08be2a94 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -257,6 +257,42 @@ gfc_class_len_or_zero_get (tree decl) } +tree +gfc_resize_class_size_with_len (stmtblock_t * block, tree class_expr, tree size) +{ + tree tmp; + tree tmp2; + tree type; + + tmp = gfc_class_len_or_zero_get (class_expr); + + /* Include the len value in the element size if present. */ + if (!integer_zerop (tmp)) + { + type = TREE_TYPE (size); + if (block) + { + size = gfc_evaluate_now (size, block); + tmp = gfc_evaluate_now (fold_convert (type , tmp), block); + } + tmp2 = fold_build2_loc (input_location, MULT_EXPR, + type, size, tmp); + tmp = fold_build2_loc (input_location, GT_EXPR, + logical_type_node, tmp, + build_zero_cst (type)); + size = fold_build3_loc (input_location, COND_EXPR, + type, tmp, tmp2, size); + } + else + return size; + + if (block) + size = gfc_evaluate_now (size, block); + + return size; +} + + /* Get the specified FIELD from the VPTR. */ static tree @@ -483,6 +519,9 @@ gfc_get_class_from_expr (tree expr) for (tmp = expr; tmp; tmp = TREE_OPERAND (tmp, 0)) { + if (CONSTANT_CLASS_P (tmp)) + return NULL_TREE; + type = TREE_TYPE (tmp); while (type) { @@ -1606,6 +1645,111 @@ gfc_trans_class_init_assign (gfc_code *code) } +/* Class valued elemental function calls or class array elements arriving + in gfc_trans_scalar_assign come here. Wherever possible the vptr copy + is used to ensure that the rhs dynamic type is assigned to the lhs. */ + +static bool +trans_scalar_class_assign (stmtblock_t *block, gfc_se *lse, gfc_se *rse) +{ + tree fcn; + tree rse_expr; + tree class_data; + tree tmp; + tree zero; + tree cond; + tree final_cond; + stmtblock_t inner_block; + bool is_descriptor; + bool not_call_expr = TREE_CODE (rse->expr) != CALL_EXPR; + bool not_lhs_array_type; + + /* Temporaries arising from depencies in assignment get cast as a + character type of the dynamic size of the rhs. Use the vptr copy + for this case. */ + tmp = TREE_TYPE (lse->expr); + not_lhs_array_type = !(tmp && TREE_CODE (tmp) == ARRAY_TYPE + && TYPE_MAX_VALUE (TYPE_DOMAIN (tmp)) != NULL_TREE); + + /* Use ordinary assignment if the rhs is not a call expression or + the lhs is not a class entity or an array(ie. character) type. */ + if ((not_call_expr && gfc_get_class_from_expr (lse->expr) == NULL_TREE) + && not_lhs_array_type) + return false; + + /* Ordinary assignment can be used if both sides are class expressions + since the dynamic type is preserved by copying the vptr. This + should only occur, where temporaries are involved. */ + if (GFC_CLASS_TYPE_P (TREE_TYPE (lse->expr)) + && GFC_CLASS_TYPE_P (TREE_TYPE (rse->expr))) + return false; + + /* Fix the class expression and the class data of the rhs. */ + if (!GFC_CLASS_TYPE_P (TREE_TYPE (rse->expr)) + || not_call_expr) + { + tmp = gfc_get_class_from_expr (rse->expr); + if (tmp == NULL_TREE) + return false; + rse_expr = gfc_evaluate_now (tmp, block); + } + else + rse_expr = gfc_evaluate_now (rse->expr, block); + + class_data = gfc_class_data_get (rse_expr); + + /* Check that the rhs data is not null. */ + is_descriptor = GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (class_data)); + if (is_descriptor) + class_data = gfc_conv_descriptor_data_get (class_data); + class_data = gfc_evaluate_now (class_data, block); + + zero = build_int_cst (TREE_TYPE (class_data), 0); + cond = fold_build2_loc (input_location, NE_EXPR, + logical_type_node, + class_data, zero); + + /* Copy the rhs to the lhs. */ + fcn = gfc_vptr_copy_get (gfc_class_vptr_get (rse_expr)); + fcn = build_fold_indirect_ref_loc (input_location, fcn); + tmp = gfc_evaluate_now (gfc_build_addr_expr (NULL, rse->expr), block); + tmp = is_descriptor ? tmp : class_data; + tmp = build_call_expr_loc (input_location, fcn, 2, tmp, + gfc_build_addr_expr (NULL, lse->expr)); + gfc_add_expr_to_block (block, tmp); + + /* Only elemental function results need to be finalised and freed. */ + if (not_call_expr) + return true; + + /* Finalize the class data if needed. */ + gfc_init_block (&inner_block); + fcn = gfc_vptr_final_get (gfc_class_vptr_get (rse_expr)); + zero = build_int_cst (TREE_TYPE (fcn), 0); + final_cond = fold_build2_loc (input_location, NE_EXPR, + logical_type_node, fcn, zero); + fcn = build_fold_indirect_ref_loc (input_location, fcn); + tmp = build_call_expr_loc (input_location, fcn, 1, class_data); + tmp = build3_v (COND_EXPR, final_cond, + tmp, build_empty_stmt (input_location)); + gfc_add_expr_to_block (&inner_block, tmp); + + /* Free the class data. */ + tmp = gfc_call_free (class_data); + tmp = build3_v (COND_EXPR, cond, tmp, + build_empty_stmt (input_location)); + gfc_add_expr_to_block (&inner_block, tmp); + + /* Finish the inner block and subject it to the condition on the + class data being non-zero. */ + tmp = gfc_finish_block (&inner_block); + tmp = build3_v (COND_EXPR, cond, tmp, + build_empty_stmt (input_location)); + gfc_add_expr_to_block (block, tmp); + + return true; +} + /* End of prototype trans-class.c */ @@ -5613,8 +5757,10 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, { /* The intrinsic type needs to be converted to a temporary CLASS object for the unlimited polymorphic formal. */ + gfc_find_vtab (&e->ts); gfc_init_se (&parmse, se); gfc_conv_intrinsic_to_class (&parmse, e, fsym->ts); + } else if (se->ss && se->ss->info->useflags) { @@ -8926,14 +9072,32 @@ trans_class_vptr_len_assignment (stmtblock_t *block, gfc_expr * le, tree tmp, to_len = NULL_TREE, from_len = NULL_TREE, lhs_vptr; bool set_vptr = false, temp_rhs = false; stmtblock_t *pre = block; + tree class_expr = NULL_TREE; /* Create a temporary for complicated expressions. */ if (re->expr_type != EXPR_VARIABLE && re->expr_type != EXPR_NULL && rse->expr != NULL_TREE && !DECL_P (rse->expr)) { - tmp = gfc_create_var (TREE_TYPE (rse->expr), "rhs"); - pre = &rse->pre; - gfc_add_modify (&rse->pre, tmp, rse->expr); + if (re->ts.type == BT_CLASS && !GFC_CLASS_TYPE_P (TREE_TYPE (rse->expr))) + class_expr = gfc_get_class_from_expr (rse->expr); + + if (rse->loop) + pre = &rse->loop->pre; + else + pre = &rse->pre; + + if (class_expr != NULL_TREE && UNLIMITED_POLY (re)) + { + tmp = TREE_OPERAND (rse->expr, 0); + tmp = gfc_create_var (TREE_TYPE (tmp), "rhs"); + gfc_add_modify (&rse->pre, tmp, TREE_OPERAND (rse->expr, 0)); + } + else + { + tmp = gfc_create_var (TREE_TYPE (rse->expr), "rhs"); + gfc_add_modify (&rse->pre, tmp, rse->expr); + } + rse->expr = tmp; temp_rhs = true; } @@ -9001,9 +9165,17 @@ trans_class_vptr_len_assignment (stmtblock_t *block, gfc_expr * le, else if (temp_rhs && re->ts.type == BT_CLASS) { vptr_expr = NULL; - se.expr = gfc_class_vptr_get (rse->expr); + if (class_expr) + tmp = class_expr; + else if (!GFC_CLASS_TYPE_P (TREE_TYPE (rse->expr))) + tmp = gfc_get_class_from_expr (rse->expr); + else + tmp = rse->expr; + + se.expr = gfc_class_vptr_get (tmp); if (UNLIMITED_POLY (re)) - from_len = gfc_class_len_get (rse->expr); + from_len = gfc_class_len_get (tmp); + } else if (re->expr_type != EXPR_NULL) /* Only when rhs is non-NULL use its declared type for vptr @@ -9750,7 +9922,7 @@ gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, gfc_typespec ts, gfc_add_expr_to_block (&block, tmp); } } - else if (gfc_bt_struct (ts.type) || ts.type == BT_CLASS) + else if (gfc_bt_struct (ts.type)) { gfc_add_block_to_block (&block, &lse->pre); gfc_add_block_to_block (&block, &rse->pre); @@ -9758,7 +9930,20 @@ gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, gfc_typespec ts, TREE_TYPE (lse->expr), rse->expr); gfc_add_modify (&block, lse->expr, tmp); } - else + /* If possible use the rhs vptr copy with trans_scalar_class_assign.... */ + else if (ts.type == BT_CLASS + && !trans_scalar_class_assign (&block, lse, rse)) + { + gfc_add_block_to_block (&block, &lse->pre); + gfc_add_block_to_block (&block, &rse->pre); + /* ...otherwise assignment suffices. Note the use of VIEW_CONVERT_EXPR + for the lhs which ensures that class data rhs cast as a string assigns + correctly. */ + tmp = fold_build1_loc (input_location, VIEW_CONVERT_EXPR, + TREE_TYPE (rse->expr), lse->expr); + gfc_add_modify (&block, tmp, rse->expr); + } + else if (ts.type != BT_CLASS) { gfc_add_block_to_block (&block, &lse->pre); gfc_add_block_to_block (&block, &rse->pre); @@ -10666,23 +10851,53 @@ trans_class_assignment (stmtblock_t *block, gfc_expr *lhs, gfc_expr *rhs, gfc_se *lse, gfc_se *rse, bool use_vptr_copy, bool class_realloc) { - tree tmp, fcn, stdcopy, to_len, from_len, vptr; + tree tmp, fcn, stdcopy, to_len, from_len, vptr, old_vptr; vec *args = NULL; + /* Store the old vptr so that dynamic types can be compared for + reallocation to occur or not. */ + if (class_realloc) + { + tmp = lse->expr; + if (!GFC_CLASS_TYPE_P (TREE_TYPE (tmp))) + tmp = gfc_get_class_from_expr (tmp); + } + vptr = trans_class_vptr_len_assignment (block, lhs, rhs, rse, &to_len, &from_len); - /* Generate allocation of the lhs. */ + /* Generate (re)allocation of the lhs. */ if (class_realloc) { - stmtblock_t alloc; - tree class_han; + stmtblock_t alloc, re_alloc; + tree class_han, re, size; - tmp = gfc_vptr_size_get (vptr); + if (tmp && GFC_CLASS_TYPE_P (TREE_TYPE (tmp))) + old_vptr = gfc_evaluate_now (gfc_class_vptr_get (tmp), block); + else + old_vptr = build_int_cst (TREE_TYPE (vptr), 0); + + size = gfc_vptr_size_get (vptr); class_han = GFC_CLASS_TYPE_P (TREE_TYPE (lse->expr)) ? gfc_class_data_get (lse->expr) : lse->expr; + + /* Allocate block. */ gfc_init_block (&alloc); - gfc_allocate_using_malloc (&alloc, class_han, tmp, NULL_TREE); + gfc_allocate_using_malloc (&alloc, class_han, size, NULL_TREE); + + /* Reallocate if dynamic types are different. */ + gfc_init_block (&re_alloc); + re = build_call_expr_loc (input_location, + builtin_decl_explicit (BUILT_IN_REALLOC), 2, + fold_convert (pvoid_type_node, class_han), + size); + tmp = fold_build2_loc (input_location, NE_EXPR, + logical_type_node, vptr, old_vptr); + re = fold_build3_loc (input_location, COND_EXPR, void_type_node, + tmp, re, build_empty_stmt (input_location)); + gfc_add_expr_to_block (&re_alloc, re); + + /* Allocate if _data is NULL, reallocate otherwise. */ tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, class_han, build_int_cst (prvoid_type_node, 0)); @@ -10690,7 +10905,7 @@ trans_class_assignment (stmtblock_t *block, gfc_expr *lhs, gfc_expr *rhs, gfc_unlikely (tmp, PRED_FORTRAN_FAIL_ALLOC), gfc_finish_block (&alloc), - build_empty_stmt (input_location)); + gfc_finish_block (&re_alloc)); gfc_add_expr_to_block (&lse->pre, tmp); } @@ -10793,6 +11008,7 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag, bool maybe_workshare = false, lhs_refs_comp = false, rhs_refs_comp = false; symbol_attribute lhs_caf_attr, rhs_caf_attr, lhs_attr; bool is_poly_assign; + bool realloc_flag; /* Assignment of the form lhs = rhs. */ gfc_start_block (&block); @@ -10833,6 +11049,10 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag, || gfc_is_class_array_ref (expr2, NULL) || gfc_is_class_scalar_expr (expr2)); + realloc_flag = flag_realloc_lhs + && gfc_is_reallocatable_lhs (expr1) + && expr2->rank + && !is_runtime_conformable (expr1, expr2); /* Only analyze the expressions for coarray properties, when in coarray-lib mode. */ @@ -11077,8 +11297,9 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag, if (is_poly_assign) tmp = trans_class_assignment (&body, expr1, expr2, &lse, &rse, use_vptr_copy || (lhs_attr.allocatable - && !lhs_attr.dimension), - flag_realloc_lhs && !lhs_attr.pointer); + && !lhs_attr.dimension), + !realloc_flag && flag_realloc_lhs + && !lhs_attr.pointer); else if (flag_coarray == GFC_FCOARRAY_LIB && lhs_caf_attr.codimension && rhs_caf_attr.codimension && ((lhs_caf_attr.allocatable && lhs_refs_comp) @@ -11108,7 +11329,8 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag, { /* This case comes about when the scalarizer provides array element references. Use the vptr copy function, since this does a deep - copy of allocatable components, without which the finalizer call */ + copy of allocatable components, without which the finalizer call + will deallocate the components. */ tmp = gfc_get_vptr_from_expr (rse.expr); if (tmp != NULL_TREE) { @@ -11183,10 +11405,7 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag, } /* F2003: Allocate or reallocate lhs of allocatable array. */ - if (flag_realloc_lhs - && gfc_is_reallocatable_lhs (expr1) - && expr2->rank - && !is_runtime_conformable (expr1, expr2)) + if (realloc_flag) { realloc_lhs_warning (expr1->ts.type, true, &expr1->where); ompws_flags &= ~OMPWS_SCALARIZER_WS; @@ -11295,8 +11514,7 @@ gfc_trans_assignment (gfc_expr * expr1, gfc_expr * expr2, bool init_flag, return tmp; } - if (UNLIMITED_POLY (expr1) && expr1->rank - && expr2->ts.type != BT_CLASS) + if (UNLIMITED_POLY (expr1) && expr1->rank) use_vptr_copy = true; /* Fallback to the scalarizer to generate explicit loops. */ diff --git a/gcc/fortran/trans.c b/gcc/fortran/trans.c index ca0b10ca73d..7ee2bd159fc 100644 --- a/gcc/fortran/trans.c +++ b/gcc/fortran/trans.c @@ -477,21 +477,7 @@ gfc_build_array_ref (tree base, tree offset, tree decl, tree vptr) /* Check if this is an unlimited polymorphic object carrying a character payload. In this case, the 'len' field is non-zero. */ if (decl && GFC_CLASS_TYPE_P (TREE_TYPE (decl))) - { - tmp = gfc_class_len_or_zero_get (decl); - if (!integer_zerop (tmp)) - { - tree cond; - tree stype = TREE_TYPE (span); - tmp = fold_convert (stype, tmp); - cond = fold_build2_loc (input_location, EQ_EXPR, - logical_type_node, tmp, - build_int_cst (stype, 0)); - tmp = fold_build2 (MULT_EXPR, stype, span, tmp); - span = fold_build3_loc (input_location, COND_EXPR, stype, - cond, span, tmp); - } - } + span = gfc_resize_class_size_with_len (NULL, decl, span); } else if (decl) span = get_array_span (type, decl); diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h index 6e417c43e8c..a1613bd02f3 100644 --- a/gcc/fortran/trans.h +++ b/gcc/fortran/trans.h @@ -423,6 +423,7 @@ tree gfc_class_data_get (tree); tree gfc_class_vptr_get (tree); tree gfc_class_len_get (tree); tree gfc_class_len_or_zero_get (tree); +tree gfc_resize_class_size_with_len (stmtblock_t *, tree, tree); gfc_expr * gfc_find_and_cut_at_last_class_ref (gfc_expr *, bool is_mold = false); /* Get an accessor to the class' vtab's * field, when a class handle is available. */ diff --git a/gcc/testsuite/gfortran.dg/class_allocate_25.f90 b/gcc/testsuite/gfortran.dg/class_allocate_25.f90 new file mode 100644 index 00000000000..4e5855f8fb8 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/class_allocate_25.f90 @@ -0,0 +1,58 @@ +! { dg-do run } +! { dg-options "-fdump-tree-original" } +! +! In the course of fixing PR83118, lots of issues came up with class array +! assignment, where temporaries are generated. This testcase checks that +! the use of assignment by allocate with source is OK, especially with array +! constructors using class arrays. While this test did run previously, the +! temporaries for such arrays were malformed with the class as the type and +! element lengths of 72 bytes rather than the 4 bytes of the decalred type. +! +! Contributed by Dominique d'Humieres +! +type t1 + integer :: i = 5 +end type t1 +type, extends(t1) :: t2 + integer :: j = 6 +end type t2 + +class(t1), allocatable :: a(:), b(:), c(:) +integer :: i + +allocate(t2 :: a(3)) +allocate(t2 :: b(5)) +if (.not.check_t1 (a, [(5, i = 1, 3)], 2)) stop 1 + +allocate(c, source=[a, b ]) ! F2008, PR 44672 +if (.not.check_t1 (c, [(5, i = 1, 8)], 1)) stop 2 + +deallocate(c) +allocate(c(8), source=[ a, b ]) +if (.not.check_t1 (c, [(5, i = 1, 8)], 1)) stop 3 + +deallocate(c) +c = [t1 :: a, b ] ! F2008, PR 43366 +if (.not.check_t1 (c, [(5, i = 1, 8)], 1)) stop 4 +deallocate(a, b, c) + +contains + + logical function check_t1 (arg, array, t) + class(t1) :: arg(:) + integer :: array (:), t + check_t1 = .true. + select type (arg) + type is (t1) + if (any (arg%i .ne. array)) check_t1 = .false. + if (t .eq. 2) check_t1 = .false. + type is (t2) + if (any (arg%i .ne. array)) check_t1 = .false. + if (t .eq. 1) check_t1 = .false. + class default + check_t1 = .false. + end select + end function check_t1 + +end +! { dg-final { scan-tree-dump-times "elem_len=72" 0 "original" } } diff --git a/gcc/testsuite/gfortran.dg/class_assign_4.f90 b/gcc/testsuite/gfortran.dg/class_assign_4.f90 new file mode 100644 index 00000000000..517e3121cc8 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/class_assign_4.f90 @@ -0,0 +1,183 @@ +! { dg-do run } +! +! In the course of fixing PR83118, lots of issues came up with class array +! assignment, where temporaries are generated. This testcase checks that +! it all works correctly. +! +! Contributed by Paul Thomas +! +module m + implicit none + type :: t1 + integer :: i + CONTAINS + PROCEDURE :: add_t1 + GENERIC :: OPERATOR(+) => add_t1 + end type + type, extends(t1) :: t2 + real :: r + end type + +contains + impure elemental function add_t1 (a, b) result (c) + class(t1), intent(in) :: a, b + class(t1), allocatable :: c + allocate (c, source = a) + c%i = a%i + b%i + select type (c) + type is (t2) + select type (b) + type is (t2) + c%r = c%r + b%r + end select + end select + end function add_t1 + +end module m + +subroutine test_t1 + use m + implicit none + + class(t1), dimension(:), allocatable :: x, y + + x = [t2(1,10.0),t2(2,20.0),t2(3,30.0)] + if (.not.check_t1 (x, [1,2,3], 2, [10, 20, 30]) ) stop 1 + + y = x + x = realloc_t1 (y) + if (.not.check_t1 (x, [3,2,1], 1) ) stop 2 + + x = realloc_t1 (x) + if (.not.check_t1 (x, [2,3,1], 1) ) stop 3 + + x = x([3,1,2]) + if (.not.check_t1 (x, [1,2,3], 1) ) stop 4 + + x = x(3:1:-1) + y + if (.not.check_t1 (x, [4,4,4], 1) ) stop 5 + + x = y + x(3:1:-1) + if (.not.check_t1 (x, [5,6,7], 2) ) stop 6 + +! Now check that the dynamic type survives assignments. + x = [t2(1,10.0),t2(2,20.0),t2(3,30.0)] + y = x + + x = y(3:1:-1) + if (.not.check_t1 (x, [3,2,1], 2, [30,20,10]) ) stop 7 + + x = x(3:1:-1) + y + if (.not.check_t1 (x, [2,4,6], 2, [20,40,60]) ) stop 8 + + x = x(3:1:-1) + if (.not.check_t1 (x, [6,4,2], 2, [60,40,20]) ) stop 9 + + x = x([3,2,1]) + if (.not.check_t1 (x, [2,4,6], 2, [20,40,60]) ) stop 10 + +contains + + function realloc_t1 (arg) result (res) + class(t1), dimension(:), allocatable :: arg + class(t1), dimension(:), allocatable :: res + select type (arg) + type is (t2) + allocate (res, source = [t1 (arg(3)%i), t1 (arg(2)%i), t1 (arg(1)%i)]) + type is (t1) + allocate (res, source = [t1 (arg(2)%i), t1 (arg(1)%i), t1 (arg(3)%i)]) + end select + end function realloc_t1 + + logical function check_t1 (arg, array, t, array2) + class(t1) :: arg(:) + integer :: array (:), t + integer, optional :: array2(:) + check_t1 = .true. + select type (arg) + type is (t1) + if (any (arg%i .ne. array)) check_t1 = .false. + if (t .eq. 2) check_t1 = .false. + type is (t2) + if (any (arg%i .ne. array)) check_t1 = .false. + if (t .eq. 1) check_t1 = .false. + if (present (array2)) then + if (any(int (arg%r) .ne. array2)) check_t1 = .false. + end if + class default + check_t1 = .false. + end select + end function check_t1 + +end subroutine test_t1 + +subroutine test_star + use m + implicit none + + class(*), dimension(:), allocatable :: x, y + + x = [t2(1,10.0),t2(2,20.0),t2(3,30.0)] + if (.not.check_star (x, [1,2,3], 2) ) stop 11 + + y = x + x = realloc_star (y) + if (.not.check_star (x, [3,2,1], 1) ) stop 12 + + x = realloc_star (x) + if (.not.check_star (x, [2,3,1], 1) ) stop 13 + + x = x([3,1,2]) + if (.not.check_star (x, [1,2,3], 1) ) stop 14 + + x = x(3:1:-1) + if (.not.check_star (x, [3,2,1], 1) ) stop 15 + +! Make sure that all is similarly well with type t2. + x = [t2(1,10.0),t2(2,20.0),t2(3,30.0)] + + x = x([3,1,2]) + if (.not.check_star (x, [3,1,2], 2, [30,10,20]) ) stop 16 + + x = x(3:1:-1) + if (.not.check_star (x, [2,1,3], 2, [20,10,30]) ) stop 17 + +contains + + function realloc_star (arg) result (res) + class(*), dimension(:), allocatable :: arg + class(*), dimension(:), allocatable :: res + select type (arg) + type is (t2) + allocate (res, source = [t1 (arg(3)%i), t1 (arg(2)%i), t1 (arg(1)%i)]) + type is (t1) + allocate (res, source = [t1 (arg(2)%i), t1 (arg(1)%i), t1 (arg(3)%i)]) + end select + end function realloc_star + + logical function check_star (arg, array, t, array2) + class(*) :: arg(:) + integer :: array (:), t + integer, optional :: array2(:) + check_star = .true. + select type (arg) + type is (t1) + if (any (arg%i .ne. array)) check_star = .false. + if (t .eq. 2) check_star = .false. + type is (t2) + if (any (arg%i .ne. array)) check_star = .false. + if (t .eq. 1) check_star = .false. + if (present (array2)) then + if (any (int(arg%r) .ne. array2)) check_star = .false. + endif + class default + check_star = .false. + end select + end function check_star + +end subroutine test_star + + + call test_t1 + call test_star +end diff --git a/gcc/testsuite/gfortran.dg/dependency_60.f90 b/gcc/testsuite/gfortran.dg/dependency_60.f90 new file mode 100644 index 00000000000..bf108122f3e --- /dev/null +++ b/gcc/testsuite/gfortran.dg/dependency_60.f90 @@ -0,0 +1,19 @@ +! { dg-do run } +! PR 92755 - this used to cause an ICE (see dependency_57.f90) +! PR83118 - fixed so that it would run :-) +! Original test case by Gerhard Steinmetz +program p + type t + integer :: i + end type + type t2 + class(t), allocatable :: a(:) + end type + type(t2) :: z + z%a = [t(1),t(2),t(3)] + z%a = [z%a] + select type (y => z%a) + type is (t) + if (any (y%i .ne. [1, 2, 3])) stop 1 + end select +end diff --git a/gcc/testsuite/gfortran.dg/unlimited_polymorphic_32.f03 b/gcc/testsuite/gfortran.dg/unlimited_polymorphic_32.f03 new file mode 100644 index 00000000000..23d0540526d --- /dev/null +++ b/gcc/testsuite/gfortran.dg/unlimited_polymorphic_32.f03 @@ -0,0 +1,59 @@ +! { dg-do run } +! +! Test the fix of the test case referenced in comment 17 of PR83118. +! +! Contributed by Damian Rouson +! + implicit none + type Wrapper + class(*), allocatable :: elements(:) + end type + type Mytype + real(4) :: r = 42.0 + end type + + call driver +contains + subroutine driver + class(*), allocatable :: obj + type(Wrapper) w + integer(4) :: expected4(2) = [42_4, 43_4] + integer(8) :: expected8(3) = [42_8, 43_8, 44_8] + + w = new_wrapper (expected4) + obj = w + call test (obj, 0) + obj = new_wrapper (expected8) ! Used to generate a linker error + call test (obj, 10) + obj = new_wrapper ([mytype (99.0)]) + call test (obj, 100) + obj = Mytype (42.0) ! Used to generate a linker error + call test (obj, 1000) + end subroutine + function new_wrapper(array) result (res) + class(*) :: array(:) + type(Wrapper) :: res + res%elements = array ! Used to runtime segfault + end function + subroutine test (arg, idx) + class(*) :: arg + integer :: idx + select type (arg) + type is (wrapper) + select type (z => arg%elements) + type is (integer(4)) + if (any (z .ne. [42_4, 43_4])) stop 1 + idx + type is (integer(8)) + if (any (z .ne. [42_8, 43_8, 44_8])) stop 1 + idx + type is (Mytype) + if (abs (z(1)%r - 99.0) .ge. 1e-6) stop 1 + idx + class default + stop 2 + idx + end select + type is (Mytype) + if (abs (arg%r - 42.0) .ge. 1e-6) stop 1 + idx + class default + stop 3 + idx + end select + end subroutine +end -- 2.30.2