diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index be5eb89350f..ca90142530c 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -1403,9 +1403,6 @@ gfc_trans_create_temp_array (stmtblock_t * pre, stmtblock_t * post, gfc_ss * ss, desc = gfc_create_var (type, "atmp"); GFC_DECL_PACKED_ARRAY (desc) = 1; - info->descriptor = desc; - size = gfc_index_one_node; - /* Emit a DECL_EXPR for the variable sized array type in GFC_TYPE_ARRAY_DATAPTR_TYPE so the gimplification of its type sizes works correctly. */ @@ -1416,9 +1413,40 @@ gfc_trans_create_temp_array (stmtblock_t * pre, stmtblock_t * post, gfc_ss * ss, gfc_add_expr_to_block (pre, build1 (DECL_EXPR, arraytype, TYPE_NAME (arraytype))); - /* Fill in the array dtype. */ - tmp = gfc_conv_descriptor_dtype (desc); - gfc_add_modify (pre, tmp, gfc_get_dtype (TREE_TYPE (desc))); + if (class_expr != NULL_TREE) + { + tree class_data; + tree dtype; + + /* Create a class temporary. */ + tmp = gfc_create_var (TREE_TYPE (class_expr), "ctmp"); + gfc_add_modify (pre, tmp, class_expr); + + /* Assign the new descriptor to the _data field. This allows the + vptr _copy to be used for scalarized assignment since the class + temporary can be found from the descriptor. */ + class_data = gfc_class_data_get (tmp); + tmp = fold_build1_loc (input_location, VIEW_CONVERT_EXPR, + TREE_TYPE (desc), desc); + gfc_add_modify (pre, class_data, tmp); + + /* Take the dtype from the class expression. */ + dtype = gfc_conv_descriptor_dtype (gfc_class_data_get (class_expr)); + tmp = gfc_conv_descriptor_dtype (class_data); + gfc_add_modify (pre, tmp, dtype); + + /* Point desc to the class _data field. */ + desc = class_data; + } + else + { + /* Fill in the array dtype. */ + tmp = gfc_conv_descriptor_dtype (desc); + gfc_add_modify (pre, tmp, gfc_get_dtype (TREE_TYPE (desc))); + } + + info->descriptor = desc; + size = gfc_index_one_node; /* Fill in the bounds and stride. This is a packed array, so: @@ -3424,134 +3452,73 @@ conv_array_index_offset (gfc_se * se, gfc_ss * ss, int dim, int i, static bool build_class_array_ref (gfc_se *se, tree base, tree index) { - tree type; tree size; - tree offset; tree decl = NULL_TREE; tree tmp; gfc_expr *expr = se->ss->info->expr; - gfc_ref *ref; - gfc_ref *class_ref = NULL; + gfc_expr *class_expr; gfc_typespec *ts; + gfc_symbol *sym; - if (se->expr && DECL_P (se->expr) && DECL_LANG_SPECIFIC (se->expr) - && GFC_DECL_SAVED_DESCRIPTOR (se->expr) - && GFC_CLASS_TYPE_P (TREE_TYPE (GFC_DECL_SAVED_DESCRIPTOR (se->expr)))) - decl = se->expr; + tmp = !VAR_P (base) ? gfc_get_class_from_expr (base) : NULL_TREE; + + if (tmp != NULL_TREE) + decl = tmp; else { - if (expr == NULL + /* The base expression does not contain a class component, either + because it is a temporary array or array descriptor. Class + array functions are correctly resolved above. */ + if (!expr || (expr->ts.type != BT_CLASS - && !gfc_is_class_array_function (expr) && !gfc_is_class_array_ref (expr, NULL))) return false; - if (expr->symtree && expr->symtree->n.sym->ts.type == BT_CLASS) - ts = &expr->symtree->n.sym->ts; - else - ts = NULL; - - for (ref = expr->ref; ref; ref = ref->next) - { - if (ref->type == REF_COMPONENT - && ref->u.c.component->ts.type == BT_CLASS - && ref->next && ref->next->type == REF_COMPONENT - && strcmp (ref->next->u.c.component->name, "_data") == 0 - && ref->next->next - && ref->next->next->type == REF_ARRAY - && ref->next->next->u.ar.type != AR_ELEMENT) - { - ts = &ref->u.c.component->ts; - class_ref = ref; - break; - } - } + /* Obtain the expression for the class entity or component that is + followed by an array reference, which is not an element, so that + the span of the array can be obtained. */ + class_expr = gfc_find_and_cut_at_last_class_ref (expr, false, &ts); - if (ts == NULL) + if (!ts) return false; - } - if (class_ref == NULL && expr && expr->symtree->n.sym->attr.function - && expr->symtree->n.sym == expr->symtree->n.sym->result - && expr->symtree->n.sym->backend_decl == current_function_decl) - { - decl = gfc_get_fake_result_decl (expr->symtree->n.sym, 0); - } - else if (expr && gfc_is_class_array_function (expr)) - { - size = NULL_TREE; - decl = NULL_TREE; - for (tmp = base; tmp; tmp = TREE_OPERAND (tmp, 0)) - { - tree type; - type = TREE_TYPE (tmp); - while (type) - { - if (GFC_CLASS_TYPE_P (type)) - decl = tmp; - if (type != TYPE_CANONICAL (type)) - type = TYPE_CANONICAL (type); - else - type = NULL_TREE; - } - if (VAR_P (tmp)) - break; + sym = (!class_expr && expr) ? expr->symtree->n.sym : NULL; + if (sym && sym->attr.function + && sym == sym->result + && sym->backend_decl == current_function_decl) + /* The temporary is the data field of the class data component + of the current function. */ + decl = gfc_get_fake_result_decl (sym, 0); + else if (sym) + { + if (decl == NULL_TREE) + decl = expr->symtree->n.sym->backend_decl; + /* For class arrays the tree containing the class is stored in + GFC_DECL_SAVED_DESCRIPTOR of the sym's backend_decl. + For all others it's sym's backend_decl directly. */ + if (DECL_LANG_SPECIFIC (decl) && GFC_DECL_SAVED_DESCRIPTOR (decl)) + decl = GFC_DECL_SAVED_DESCRIPTOR (decl); } + else + decl = gfc_get_class_from_gfc_expr (class_expr); - if (decl == NULL_TREE) - return false; + if (POINTER_TYPE_P (TREE_TYPE (decl))) + decl = build_fold_indirect_ref_loc (input_location, decl); - se->class_vptr = gfc_evaluate_now (gfc_class_vptr_get (decl), &se->pre); - } - else if (class_ref == NULL) - { - if (decl == NULL_TREE) - decl = expr->symtree->n.sym->backend_decl; - /* For class arrays the tree containing the class is stored in - GFC_DECL_SAVED_DESCRIPTOR of the sym's backend_decl. - For all others it's sym's backend_decl directly. */ - if (DECL_LANG_SPECIFIC (decl) && GFC_DECL_SAVED_DESCRIPTOR (decl)) - decl = GFC_DECL_SAVED_DESCRIPTOR (decl); - } - else - { - /* Remove everything after the last class reference, convert the - expression and then recover its tailend once more. */ - gfc_se tmpse; - ref = class_ref->next; - class_ref->next = NULL; - gfc_init_se (&tmpse, NULL); - gfc_conv_expr (&tmpse, expr); - gfc_add_block_to_block (&se->pre, &tmpse.pre); - decl = tmpse.expr; - class_ref->next = ref; + if (!GFC_CLASS_TYPE_P (TREE_TYPE (decl))) + return false; } - if (POINTER_TYPE_P (TREE_TYPE (decl))) - decl = build_fold_indirect_ref_loc (input_location, decl); - - if (!GFC_CLASS_TYPE_P (TREE_TYPE (decl))) - return false; + se->class_vptr = gfc_evaluate_now (gfc_class_vptr_get (decl), &se->pre); size = gfc_class_vtab_size_get (decl); - /* For unlimited polymorphic entities then _len component needs to be 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)); - offset = fold_build2_loc (input_location, MULT_EXPR, - gfc_array_index_type, - index, size); - tmp = gfc_build_addr_expr (pvoid_type_node, base); - tmp = fold_build_pointer_plus_loc (input_location, tmp, offset); - tmp = fold_convert (build_pointer_type (type), tmp); - /* Return the element in the se expression. */ - se->expr = build_fold_indirect_ref_loc (input_location, tmp); + se->expr = gfc_build_spanned_array_ref (base, index, size); return true; } @@ -10280,23 +10247,10 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop, } else if (expr1->ts.type == BT_CLASS) { - tmp = expr1->rank ? gfc_get_class_from_expr (desc) : NULL_TREE; - if (tmp == NULL_TREE) - tmp = gfc_get_class_from_gfc_expr (expr1); - - 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)); + /* Unfortunately, the lhs vptr is set too early in many cases. + Play it safe by using the descriptor element length. */ + tmp = gfc_conv_descriptor_elem_len (desc); + elemsize1 = fold_convert (gfc_array_index_type, tmp); } else elemsize1 = NULL_TREE; @@ -10770,11 +10724,11 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop, /* We already set the dtype in the case of deferred character - length arrays and unlimited polymorphic arrays. */ + length arrays and class lvalues. */ if (!(GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)) && ((expr1->ts.type == BT_CHARACTER && expr1->ts.deferred) || coarray)) - && !UNLIMITED_POLY (expr1)) + && expr1->ts.type != BT_CLASS) { tmp = gfc_conv_descriptor_dtype (desc); gfc_add_modify (&alloc_block, tmp, gfc_get_dtype (TREE_TYPE (desc))); diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index 2fa17b36c03..213f32b0a67 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -380,15 +380,20 @@ gfc_vptr_size_get (tree vptr) #undef VTABLE_FINAL_FIELD -/* Search for the last _class ref in the chain of references of this - expression and cut the chain there. Albeit this routine is similiar - to class.c::gfc_add_component_ref (), is there a significant - difference: gfc_add_component_ref () concentrates on an array ref to - be the last ref in the chain. This routine is oblivious to the kind - of refs following. */ +/* IF ts is null (default), search for the last _class ref in the chain + of references of the expression and cut the chain there. Although + this routine is similiar to class.c:gfc_add_component_ref (), there + is a significant difference: gfc_add_component_ref () concentrates + on an array ref that is the last ref in the chain and is oblivious + to the kind of refs following. + ELSE IF ts is non-null the cut is at the class entity or component + that is followed by an array reference, which is not an element. + These calls come from trans-array.c:build_class_array_ref, which + handles scalarized class array references.*/ gfc_expr * -gfc_find_and_cut_at_last_class_ref (gfc_expr *e, bool is_mold) +gfc_find_and_cut_at_last_class_ref (gfc_expr *e, bool is_mold, + gfc_typespec **ts) { gfc_expr *base_expr; gfc_ref *ref, *class_ref, *tail = NULL, *array_ref; @@ -396,27 +401,59 @@ gfc_find_and_cut_at_last_class_ref (gfc_expr *e, bool is_mold) /* Find the last class reference. */ class_ref = NULL; array_ref = NULL; - for (ref = e->ref; ref; ref = ref->next) + + if (ts) { - if (ref->type == REF_ARRAY && ref->u.ar.type != AR_ELEMENT) - array_ref = ref; + if (e->symtree + && e->symtree->n.sym->ts.type == BT_CLASS) + *ts = &e->symtree->n.sym->ts; + else + *ts = NULL; + } - if (ref->type == REF_COMPONENT - && ref->u.c.component->ts.type == BT_CLASS) + for (ref = e->ref; ref; ref = ref->next) + { + if (ts) { - /* Component to the right of a part reference with nonzero rank - must not have the ALLOCATABLE attribute. If attempts are - made to reference such a component reference, an error results - followed by an ICE. */ - if (array_ref && CLASS_DATA (ref->u.c.component)->attr.allocatable) - return NULL; - class_ref = ref; + if (ref->type == REF_COMPONENT + && ref->u.c.component->ts.type == BT_CLASS + && ref->next && ref->next->type == REF_COMPONENT + && !strcmp (ref->next->u.c.component->name, "_data") + && ref->next->next + && ref->next->next->type == REF_ARRAY + && ref->next->next->u.ar.type != AR_ELEMENT) + { + *ts = &ref->u.c.component->ts; + class_ref = ref; + break; + } + + if (ref->next == NULL) + break; } + else + { + if (ref->type == REF_ARRAY && ref->u.ar.type != AR_ELEMENT) + array_ref = ref; - if (ref->next == NULL) - break; + if (ref->type == REF_COMPONENT + && ref->u.c.component->ts.type == BT_CLASS) + { + /* Component to the right of a part reference with nonzero + rank must not have the ALLOCATABLE attribute. If attempts + are made to reference such a component reference, an error + results followed by an ICE. */ + if (array_ref + && CLASS_DATA (ref->u.c.component)->attr.allocatable) + return NULL; + class_ref = ref; + } + } } + if (ts && *ts == NULL) + return NULL; + /* Remove and store all subsequent references after the CLASS reference. */ if (class_ref) @@ -10005,17 +10042,20 @@ gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, gfc_typespec ts, gfc_add_modify (&block, lse->expr, tmp); } /* 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)) + else if (ts.type == BT_CLASS) { 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); + + if (!trans_scalar_class_assign (&block, lse, rse)) + { + /* ...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) { diff --git a/gcc/fortran/trans.c b/gcc/fortran/trans.c index ab53fc5f441..9e8e8619ff8 100644 --- a/gcc/fortran/trans.c +++ b/gcc/fortran/trans.c @@ -422,6 +422,9 @@ get_array_span (tree type, tree decl) return NULL_TREE; } span = gfc_class_vtab_size_get (decl); + /* For unlimited polymorphic entities then _len component needs + to be multiplied with the size. */ + span = gfc_resize_class_size_with_len (NULL, decl, span); } else if (GFC_DECL_PTR_ARRAY_P (decl)) { @@ -439,13 +442,31 @@ get_array_span (tree type, tree decl) } +tree +gfc_build_spanned_array_ref (tree base, tree offset, tree span) +{ + tree type; + tree tmp; + type = TREE_TYPE (TREE_TYPE (base)); + offset = fold_build2_loc (input_location, MULT_EXPR, + gfc_array_index_type, + offset, span); + tmp = gfc_build_addr_expr (pvoid_type_node, base); + tmp = fold_build_pointer_plus_loc (input_location, tmp, offset); + tmp = fold_convert (build_pointer_type (type), tmp); + if ((TREE_CODE (type) != INTEGER_TYPE && TREE_CODE (type) != ARRAY_TYPE) + || !TYPE_STRING_FLAG (type)) + tmp = build_fold_indirect_ref_loc (input_location, tmp); + return tmp; +} + + /* Build an ARRAY_REF with its natural type. */ tree gfc_build_array_ref (tree base, tree offset, tree decl, tree vptr) { tree type = TREE_TYPE (base); - tree tmp; tree span = NULL_TREE; if (GFC_ARRAY_TYPE_P (type) && GFC_TYPE_ARRAY_RANK (type) == 0) @@ -488,18 +509,7 @@ gfc_build_array_ref (tree base, tree offset, tree decl, tree vptr) /* If a non-null span has been generated reference the element with pointer arithmetic. */ if (span != NULL_TREE) - { - offset = fold_build2_loc (input_location, MULT_EXPR, - gfc_array_index_type, - offset, span); - tmp = gfc_build_addr_expr (pvoid_type_node, base); - tmp = fold_build_pointer_plus_loc (input_location, tmp, offset); - tmp = fold_convert (build_pointer_type (type), tmp); - if ((TREE_CODE (type) != INTEGER_TYPE && TREE_CODE (type) != ARRAY_TYPE) - || !TYPE_STRING_FLAG (type)) - tmp = build_fold_indirect_ref_loc (input_location, tmp); - return tmp; - } + return gfc_build_spanned_array_ref (base, offset, span); /* Otherwise use a straightforward array reference. */ else return build4_loc (input_location, ARRAY_REF, type, base, offset, diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h index 44cbfb63f39..8c6f82ff1b1 100644 --- a/gcc/fortran/trans.h +++ b/gcc/fortran/trans.h @@ -424,7 +424,8 @@ 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); +gfc_expr * gfc_find_and_cut_at_last_class_ref (gfc_expr *, bool is_mold = false, + gfc_typespec **ts = NULL); /* Get an accessor to the class' vtab's * field, when a class handle is available. */ tree gfc_class_vtab_hash_get (tree); @@ -622,6 +623,9 @@ tree gfc_build_addr_expr (tree, tree); /* Build an ARRAY_REF. */ tree gfc_build_array_ref (tree, tree, tree, tree vptr = NULL_TREE); +/* Build an array ref using pointer arithmetic. */ +tree gfc_build_spanned_array_ref (tree base, tree offset, tree span); + /* Creates a label. Decl is artificial if label_id == NULL_TREE. */ tree gfc_build_label_decl (tree);