diff options
Diffstat (limited to 'gcc')
| -rw-r--r-- | gcc/fortran/resolve.c | 2 | ||||
| -rw-r--r-- | gcc/fortran/trans-array.c | 448 | ||||
| -rw-r--r-- | gcc/fortran/trans-expr.c | 264 | ||||
| -rw-r--r-- | gcc/fortran/trans.c | 16 | ||||
| -rw-r--r-- | gcc/fortran/trans.h | 1 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/class_allocate_25.f90 | 58 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/class_assign_4.f90 | 183 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/dependency_60.f90 | 19 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/unlimited_polymorphic_32.f03 | 59 |
9 files changed, 889 insertions, 161 deletions
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 1da7ba4..cc6173a 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 b2c39aa..9e461f9 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 2167de4..bfe08be 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<tree, va_gc> *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 ca0b10c..7ee2bd1 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 6e417c4..a1613bd 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 0000000..4e5855f --- /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 <dhumieres.dominique@free.fr> +! +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 0000000..517e312 --- /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 <pault@gcc.gnu.org> +! +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 0000000..bf10812 --- /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 0000000..23d0540 --- /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 <damian@sourceryinstitute.org> +! + 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 |