Index: gcc/fortran/expr.c =================================================================== *** gcc/fortran/expr.c (revision 249865) --- gcc/fortran/expr.c (working copy) *************** is_subref_array (gfc_expr * e) *** 984,989 **** --- 984,994 ---- if (e->symtree->n.sym->attr.subref_array_pointer) return true; + if (e->symtree->n.sym->ts.type == BT_CLASS + && e->symtree->n.sym->attr.dummy + && CLASS_DATA (e->symtree->n.sym)->attr.class_pointer) + return true; + seen_array = false; for (ref = e->ref; ref; ref = ref->next) { Index: gcc/fortran/trans-array.c =================================================================== *** gcc/fortran/trans-array.c (revision 249865) --- gcc/fortran/trans-array.c (working copy) *************** gfc_array_dataptr_type (tree desc) *** 125,132 **** #define DATA_FIELD 0 #define OFFSET_FIELD 1 #define DTYPE_FIELD 2 ! #define DIMENSION_FIELD 3 ! #define CAF_TOKEN_FIELD 4 #define STRIDE_SUBFIELD 0 #define LBOUND_SUBFIELD 1 --- 125,133 ---- #define DATA_FIELD 0 #define OFFSET_FIELD 1 #define DTYPE_FIELD 2 ! #define SPAN_FIELD 3 ! #define DIMENSION_FIELD 4 ! #define CAF_TOKEN_FIELD 5 #define STRIDE_SUBFIELD 0 #define LBOUND_SUBFIELD 1 *************** gfc_conv_descriptor_dtype (tree desc) *** 244,249 **** --- 245,280 ---- desc, field, NULL_TREE); } + static tree + gfc_conv_descriptor_span (tree desc) + { + tree type; + tree field; + + type = TREE_TYPE (desc); + gcc_assert (GFC_DESCRIPTOR_TYPE_P (type)); + + field = gfc_advance_chain (TYPE_FIELDS (type), SPAN_FIELD); + gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type); + + return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field), + desc, field, NULL_TREE); + } + + tree + gfc_conv_descriptor_span_get (tree desc) + { + return gfc_conv_descriptor_span (desc); + } + + void + gfc_conv_descriptor_span_set (stmtblock_t *block, tree desc, + tree value) + { + tree t = gfc_conv_descriptor_span (desc); + gfc_add_modify (block, t, fold_convert (TREE_TYPE (t), value)); + } + tree gfc_conv_descriptor_rank (tree desc) *************** gfc_conv_shift_descriptor_lbound (stmtbl *** 466,476 **** --- 497,537 ---- } + /* Obtain offsets for trans-types.c(gfc_get_array_descr_info). */ + + void + gfc_get_descriptor_offsets_for_info (const_tree desc_type, tree *data_off, + tree *dtype_off, tree *dim_off, + tree *dim_size, tree *stride_suboff, + tree *lower_suboff, tree *upper_suboff) + { + tree field; + tree type; + + type = TYPE_MAIN_VARIANT (desc_type); + field = gfc_advance_chain (TYPE_FIELDS (type), OFFSET_FIELD); + *data_off = byte_position (field); + field = gfc_advance_chain (TYPE_FIELDS (type), DTYPE_FIELD); + *dtype_off = byte_position (field); + field = gfc_advance_chain (TYPE_FIELDS (type), DIMENSION_FIELD); + *dim_off = byte_position (field); + type = TREE_TYPE (TREE_TYPE (field)); + *dim_size = TYPE_SIZE_UNIT (type); + field = gfc_advance_chain (TYPE_FIELDS (type), STRIDE_SUBFIELD); + *stride_suboff = byte_position (field); + field = gfc_advance_chain (TYPE_FIELDS (type), LBOUND_SUBFIELD); + *lower_suboff = byte_position (field); + field = gfc_advance_chain (TYPE_FIELDS (type), UBOUND_SUBFIELD); + *upper_suboff = byte_position (field); + } + + /* Cleanup those #defines. */ #undef DATA_FIELD #undef OFFSET_FIELD #undef DTYPE_FIELD + #undef SPAN_FIELD #undef DIMENSION_FIELD #undef CAF_TOKEN_FIELD #undef STRIDE_SUBFIELD *************** gfc_add_ss_to_loop (gfc_loopinfo * loop, *** 720,725 **** --- 781,864 ---- } + /* Returns true if the expression is an array pointer. */ + + static bool + is_pointer_array (tree expr) + { + if (flag_openmp) + return false; + + if (expr == NULL_TREE + || !GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (expr)) + || GFC_CLASS_TYPE_P (TREE_TYPE (expr))) + return false; + + if (TREE_CODE (expr) == VAR_DECL + && GFC_DECL_PTR_ARRAY_P (expr)) + return true; + + if (TREE_CODE (expr) == PARM_DECL + && GFC_DECL_PTR_ARRAY_P (expr)) + return true; + + if (TREE_CODE (expr) == INDIRECT_REF + && GFC_DECL_PTR_ARRAY_P (TREE_OPERAND (expr, 0))) + return true; + + /* The field declaration is marked as an pointer array. */ + if (TREE_CODE (expr) == COMPONENT_REF + && GFC_DECL_PTR_ARRAY_P (TREE_OPERAND (expr, 1)) + && !GFC_CLASS_TYPE_P (TREE_TYPE (TREE_OPERAND (expr, 1)))) + return true; + + return false; + } + + + /* Return the span of an array. */ + + static tree + get_array_span (tree desc, gfc_expr *expr) + { + tree tmp; + + if (is_pointer_array (desc)) + /* This will have the span field set. */ + tmp = gfc_conv_descriptor_span_get (desc); + else if (TREE_CODE (desc) == COMPONENT_REF + && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)) + && GFC_CLASS_TYPE_P (TREE_TYPE (TREE_OPERAND (desc, 0)))) + { + /* The descriptor is a class _data field and so use the vtable + size for the receiving span field. */ + tmp = gfc_get_vptr_from_expr (desc); + tmp = gfc_vptr_size_get (tmp); + } + else if (expr && expr->expr_type == EXPR_VARIABLE + && expr->symtree->n.sym->ts.type == BT_CLASS + && expr->ref->type == REF_COMPONENT + && expr->ref->next->type == REF_ARRAY + && expr->ref->next->next == NULL + && CLASS_DATA (expr->symtree->n.sym)->attr.dimension) + { + /* Dummys come in sometimes with the descriptor detached from + the class field or declaration. */ + tmp = gfc_class_vptr_get (expr->symtree->n.sym->backend_decl); + tmp = gfc_vptr_size_get (tmp); + } + else + { + /* If none of the fancy stuff works, the span is the element + size of the array. */ + tmp = gfc_get_element_type (TREE_TYPE (desc)); + tmp = fold_convert (gfc_array_index_type, + size_in_bytes (tmp)); + } + return tmp; + } + + /* Generate an initializer for a static pointer or allocatable array. */ void *************** gfc_conv_scalarized_array_ref (gfc_se * *** 3239,3249 **** index = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, index, info->offset); ! if (expr && (is_subref_array (expr) || (expr->ts.deferred && (expr->expr_type == EXPR_VARIABLE || expr->expr_type == EXPR_FUNCTION)))) decl = expr->symtree->n.sym->backend_decl; tmp = build_fold_indirect_ref_loc (input_location, info->data); /* Use the vptr 'size' field to access a class the element of a class --- 3378,3407 ---- index = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, index, info->offset); ! if (expr && ((is_subref_array (expr) ! && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (info->descriptor))) || (expr->ts.deferred && (expr->expr_type == EXPR_VARIABLE || expr->expr_type == EXPR_FUNCTION)))) decl = expr->symtree->n.sym->backend_decl; + /* A pointer array component can be detected from its field decl. Fix + the descriptor, mark the resulting variable decl and pass it to + gfc_build_array_ref. */ + if (is_pointer_array (info->descriptor)) + { + if (TREE_CODE (info->descriptor) == COMPONENT_REF) + { + decl = gfc_evaluate_now (info->descriptor, &se->pre); + GFC_DECL_PTR_ARRAY_P (decl) = 1; + TREE_USED (decl) = 1; + } + else if (TREE_CODE (info->descriptor) == INDIRECT_REF) + decl = TREE_OPERAND (info->descriptor, 0); + + if (decl == NULL_TREE) + decl = info->descriptor; + } + tmp = build_fold_indirect_ref_loc (input_location, info->data); /* Use the vptr 'size' field to access a class the element of a class *************** build_array_ref (tree desc, tree offset, *** 3288,3332 **** { tree tmp; tree type; ! tree cdecl; ! bool classarray = false; /* For class arrays the class declaration is stored in the saved descriptor. */ if (INDIRECT_REF_P (desc) && DECL_LANG_SPECIFIC (TREE_OPERAND (desc, 0)) && GFC_DECL_SAVED_DESCRIPTOR (TREE_OPERAND (desc, 0))) ! cdecl = gfc_class_data_get (GFC_DECL_SAVED_DESCRIPTOR ( TREE_OPERAND (desc, 0))); else ! cdecl = desc; /* Class container types do not always have the GFC_CLASS_TYPE_P but the canonical type does. */ ! if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (cdecl)) ! && TREE_CODE (cdecl) == COMPONENT_REF) { ! type = TREE_TYPE (TREE_OPERAND (cdecl, 0)); if (TYPE_CANONICAL (type) && GFC_CLASS_TYPE_P (TYPE_CANONICAL (type))) ! { ! type = TREE_TYPE (desc); ! classarray = true; ! } ! } ! else ! type = NULL; ! ! /* Class array references need special treatment because the assigned ! type size needs to be used to point to the element. */ ! if (classarray) ! { ! type = gfc_get_element_type (type); ! tmp = TREE_OPERAND (cdecl, 0); ! tmp = gfc_get_class_array_ref (offset, tmp, NULL_TREE); ! tmp = fold_convert (build_pointer_type (type), tmp); ! tmp = build_fold_indirect_ref_loc (input_location, tmp); ! return tmp; } tmp = gfc_conv_array_data (desc); --- 3446,3472 ---- { tree tmp; tree type; ! tree cdesc; /* For class arrays the class declaration is stored in the saved descriptor. */ if (INDIRECT_REF_P (desc) && DECL_LANG_SPECIFIC (TREE_OPERAND (desc, 0)) && GFC_DECL_SAVED_DESCRIPTOR (TREE_OPERAND (desc, 0))) ! cdesc = gfc_class_data_get (GFC_DECL_SAVED_DESCRIPTOR ( TREE_OPERAND (desc, 0))); else ! cdesc = desc; /* Class container types do not always have the GFC_CLASS_TYPE_P but the canonical type does. */ ! if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (cdesc)) ! && TREE_CODE (cdesc) == COMPONENT_REF) { ! type = TREE_TYPE (TREE_OPERAND (cdesc, 0)); if (TYPE_CANONICAL (type) && GFC_CLASS_TYPE_P (TYPE_CANONICAL (type))) ! vptr = gfc_class_vptr_get (TREE_OPERAND (cdesc, 0)); } tmp = gfc_conv_array_data (desc); *************** gfc_conv_array_ref (gfc_se * se, gfc_arr *** 3350,3355 **** --- 3490,3496 ---- tree offset, cst_offset; tree tmp; tree stride; + tree decl = NULL_TREE; gfc_se indexse; gfc_se tmpse; gfc_symbol * sym = expr->symtree->n.sym; *************** gfc_conv_array_ref (gfc_se * se, gfc_arr *** 3494,3501 **** offset = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, offset, cst_offset); ! se->expr = build_array_ref (se->expr, offset, sym->ts.type == BT_CLASS ? ! NULL_TREE : sym->backend_decl, se->class_vptr); } --- 3635,3665 ---- offset = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, offset, cst_offset); ! /* A pointer array component can be detected from its field decl. Fix ! the descriptor, mark the resulting variable decl and pass it to ! build_array_ref. */ ! if (!expr->ts.deferred && !sym->attr.codimension ! && is_pointer_array (se->expr)) ! { ! if (TREE_CODE (se->expr) == COMPONENT_REF) ! { ! decl = gfc_evaluate_now (se->expr, &se->pre); ! GFC_DECL_PTR_ARRAY_P (decl) = 1; ! TREE_USED (decl) = 1; ! } ! else if (TREE_CODE (se->expr) == INDIRECT_REF) ! decl = TREE_OPERAND (se->expr, 0); ! else ! decl = se->expr; ! } ! else if (expr->ts.deferred ! || (sym->ts.type == BT_CHARACTER ! && sym->attr.select_type_temporary)) ! decl = sym->backend_decl; ! else if (sym->ts.type == BT_CLASS) ! decl = NULL_TREE; ! ! se->expr = build_array_ref (se->expr, offset, decl, se->class_vptr); } *************** gfc_array_allocate (gfc_se * se, gfc_exp *** 5648,5653 **** --- 5812,5830 ---- if (dimension) gfc_conv_descriptor_offset_set (&set_descriptor_block, se->expr, offset); + /* Pointer arrays need the span field to be set. */ + if (is_pointer_array (se->expr) + || (expr->ts.type == BT_CLASS + && CLASS_DATA (expr)->attr.class_pointer)) + { + if (expr3 && expr3_elem_size != NULL_TREE) + tmp = expr3_elem_size; + else + tmp = TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (se->expr))); + tmp = fold_convert (gfc_array_index_type, tmp); + gfc_conv_descriptor_span_set (&set_descriptor_block, se->expr, tmp); + } + set_descriptor = gfc_finish_block (&set_descriptor_block); if (status != NULL_TREE) { *************** gfc_conv_expr_descriptor (gfc_se *se, gf *** 6851,6856 **** --- 7028,7037 ---- /* Add any offsets from subreferences. */ gfc_get_dataptr_offset (&se->pre, se->expr, desc, NULL_TREE, subref_array_target, expr); + + /* ....and set the span field. */ + tmp = get_array_span (desc, expr); + gfc_conv_descriptor_span_set (&se->pre, se->expr, tmp); } else if (se->want_pointer) { *************** gfc_conv_expr_descriptor (gfc_se *se, gf *** 6886,6893 **** --- 7067,7084 ---- se->ss = ss; else gcc_assert (se->ss == ss); + + if (!is_pointer_array (se->expr)) + { + tmp = gfc_get_element_type (TREE_TYPE (se->expr)); + tmp = fold_convert (gfc_array_index_type, + size_in_bytes (tmp)); + gfc_conv_descriptor_span_set (&se->pre, se->expr, tmp); + } + se->expr = gfc_build_addr_expr (NULL_TREE, se->expr); gfc_conv_expr (se, expr); + gfc_free_ss_chain (ss); return; } *************** gfc_conv_expr_descriptor (gfc_se *se, gf *** 7107,7115 **** desc = info->descriptor; if (se->direct_byref && !se->byref_noassign) { ! /* For pointer assignments we fill in the destination. */ parm = se->expr; parmtype = TREE_TYPE (parm); } else { --- 7298,7310 ---- desc = info->descriptor; if (se->direct_byref && !se->byref_noassign) { ! /* For pointer assignments we fill in the destination.... */ parm = se->expr; parmtype = TREE_TYPE (parm); + + /* ....and set the span field. */ + tmp = get_array_span (desc, expr); + gfc_conv_descriptor_span_set (&loop.pre, parm, tmp); } else { *************** gfc_conv_array_parameter (gfc_se * se, g *** 7582,7587 **** --- 7777,7783 ---- /* Every other type of array. */ se->want_pointer = 1; gfc_conv_expr_descriptor (se, expr); + if (size) array_parameter_size (build_fold_indirect_ref_loc (input_location, se->expr), Index: gcc/fortran/trans-array.h =================================================================== *** gcc/fortran/trans-array.h (revision 249865) --- gcc/fortran/trans-array.h (working copy) *************** tree gfc_conv_array_ubound (tree, int); *** 152,160 **** --- 152,164 ---- void gfc_trans_array_cobounds (tree, stmtblock_t *, const gfc_symbol *); /* Build expressions for accessing components of an array descriptor. */ + void gfc_get_descriptor_offsets_for_info (const_tree, tree *, tree *, tree *, tree *, + tree *, tree *, tree *); + tree gfc_conv_descriptor_data_get (tree); tree gfc_conv_descriptor_data_addr (tree); tree gfc_conv_descriptor_offset_get (tree); + tree gfc_conv_descriptor_span_get (tree); tree gfc_conv_descriptor_dtype (tree); tree gfc_conv_descriptor_rank (tree); tree gfc_get_descriptor_dimension (tree); *************** tree gfc_conv_descriptor_token (tree); *** 165,170 **** --- 169,175 ---- void gfc_conv_descriptor_data_set (stmtblock_t *, tree, tree); void gfc_conv_descriptor_offset_set (stmtblock_t *, tree, tree); + void gfc_conv_descriptor_span_set (stmtblock_t *, tree, tree); void gfc_conv_descriptor_stride_set (stmtblock_t *, tree, tree, tree); void gfc_conv_descriptor_lbound_set (stmtblock_t *, tree, tree, tree); void gfc_conv_descriptor_ubound_set (stmtblock_t *, tree, tree, tree); Index: gcc/fortran/trans-decl.c =================================================================== *** gcc/fortran/trans-decl.c (revision 249865) --- gcc/fortran/trans-decl.c (working copy) *************** gfc_get_symbol_decl (gfc_symbol * sym) *** 1517,1522 **** --- 1517,1525 ---- /* Dummy variables should already have been created. */ gcc_assert (sym->backend_decl); + if (sym->attr.pointer && sym->attr.dimension && sym->ts.type != BT_CLASS) + GFC_DECL_PTR_ARRAY_P (sym->backend_decl) = 1; + /* Create a character length variable. */ if (sym->ts.type == BT_CHARACTER) { *************** gfc_get_symbol_decl (gfc_symbol * sym) *** 1751,1777 **** if (sym->ts.type == BT_CHARACTER) /* Character variables need special handling. */ gfc_allocate_lang_decl (decl); - else if (sym->attr.subref_array_pointer) - /* We need the span for these beasts. */ - gfc_allocate_lang_decl (decl); ! if (sym->attr.subref_array_pointer) ! { ! tree span; ! GFC_DECL_SUBREF_ARRAY_P (decl) = 1; ! span = build_decl (input_location, ! VAR_DECL, create_tmp_var_name ("span"), ! gfc_array_index_type); ! gfc_finish_var_decl (span, sym); ! TREE_STATIC (span) = TREE_STATIC (decl); ! DECL_ARTIFICIAL (span) = 1; ! GFC_DECL_SPAN (decl) = span; ! GFC_TYPE_ARRAY_SPAN (TREE_TYPE (decl)) = span; ! } if (sym->ts.type == BT_CLASS) ! GFC_DECL_CLASS(decl) = 1; sym->backend_decl = decl; --- 1754,1771 ---- if (sym->ts.type == BT_CHARACTER) /* Character variables need special handling. */ gfc_allocate_lang_decl (decl); ! if (sym->assoc && sym->attr.subref_array_pointer) ! sym->attr.pointer = 1; ! if (sym->attr.pointer && sym->attr.dimension ! && !sym->ts.deferred ! && !(sym->attr.select_type_temporary ! && !sym->attr.subref_array_pointer)) ! GFC_DECL_PTR_ARRAY_P (decl) = 1; if (sym->ts.type == BT_CLASS) ! GFC_DECL_CLASS(decl) = 1; sym->backend_decl = decl; *************** gfc_trans_deferred_vars (gfc_symbol * pr *** 4269,4281 **** if (sym->assoc) continue; ! if (sym->attr.subref_array_pointer ! && GFC_DECL_SPAN (sym->backend_decl) ! && !TREE_STATIC (GFC_DECL_SPAN (sym->backend_decl))) { gfc_init_block (&tmpblock); ! gfc_add_modify (&tmpblock, GFC_DECL_SPAN (sym->backend_decl), ! build_int_cst (gfc_array_index_type, 0)); gfc_add_init_cleanup (block, gfc_finish_block (&tmpblock), NULL_TREE); } --- 4263,4277 ---- if (sym->assoc) continue; ! if (sym->attr.pointer && sym->attr.dimension ! && !sym->attr.use_assoc ! && !sym->attr.host_assoc ! && !sym->attr.dummy ! && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (sym->backend_decl))) { gfc_init_block (&tmpblock); ! gfc_conv_descriptor_span_set (&tmpblock, sym->backend_decl, ! build_int_cst (gfc_array_index_type, 0)); gfc_add_init_cleanup (block, gfc_finish_block (&tmpblock), NULL_TREE); } Index: gcc/fortran/trans-expr.c =================================================================== *** gcc/fortran/trans-expr.c (revision 249865) --- gcc/fortran/trans-expr.c (working copy) *************** gfc_conv_procedure_call (gfc_se * se, gf *** 5413,5419 **** } if (e->expr_type == EXPR_VARIABLE ! && is_subref_array (e)) /* The actual argument is a component reference to an array of derived types. In this case, the argument is converted to a temporary, which is passed and then --- 5413,5420 ---- } if (e->expr_type == EXPR_VARIABLE ! && is_subref_array (e) ! && !(fsym && fsym->attr.pointer)) /* The actual argument is a component reference to an array of derived types. In this case, the argument is converted to a temporary, which is passed and then *************** gfc_trans_pointer_assignment (gfc_expr * *** 8223,8229 **** stmtblock_t block; tree desc; tree tmp; - tree decl; bool scalar, non_proc_pointer_assign; gfc_ss *ss; --- 8224,8229 ---- *************** gfc_trans_pointer_assignment (gfc_expr * *** 8412,8435 **** gfc_conv_expr_descriptor (&lse, expr2); strlen_rhs = lse.string_length; ! /* If this is a subreference array pointer assignment, use the rhs ! descriptor element size for the lhs span. */ ! if (expr1->symtree->n.sym->attr.subref_array_pointer) ! { ! decl = expr1->symtree->n.sym->backend_decl; ! gfc_init_se (&rse, NULL); ! rse.descriptor_only = 1; ! gfc_conv_expr (&rse, expr2); ! if (expr1->ts.type == BT_CLASS) ! trans_class_vptr_len_assignment (&block, expr1, expr2, &rse, ! NULL, NULL); ! tmp = gfc_get_element_type (TREE_TYPE (rse.expr)); ! tmp = fold_convert (gfc_array_index_type, size_in_bytes (tmp)); ! if (!INTEGER_CST_P (tmp)) ! gfc_add_block_to_block (&lse.post, &rse.pre); ! gfc_add_modify (&lse.post, GFC_DECL_SPAN(decl), tmp); ! } ! else if (expr1->ts.type == BT_CLASS) { rse.expr = NULL_TREE; rse.string_length = NULL_TREE; --- 8412,8418 ---- gfc_conv_expr_descriptor (&lse, expr2); strlen_rhs = lse.string_length; ! if (expr1->ts.type == BT_CLASS) { rse.expr = NULL_TREE; rse.string_length = NULL_TREE; *************** gfc_trans_pointer_assignment (gfc_expr * *** 8446,8452 **** { rse.expr = gfc_class_data_get (rse.expr); gfc_add_modify (&lse.pre, desc, rse.expr); ! } else { expr1_vptr = trans_class_vptr_len_assignment (&block, expr1, --- 8429,8440 ---- { rse.expr = gfc_class_data_get (rse.expr); gfc_add_modify (&lse.pre, desc, rse.expr); ! /* Set the lhs span. */ ! tmp = TREE_TYPE (rse.expr); ! tmp = TYPE_SIZE_UNIT (gfc_get_element_type (tmp)); ! tmp = fold_convert (gfc_array_index_type, tmp); ! gfc_conv_descriptor_span_set (&lse.pre, desc, tmp); ! } else { expr1_vptr = trans_class_vptr_len_assignment (&block, expr1, *************** gfc_trans_pointer_assignment (gfc_expr * *** 8492,8498 **** converted in rse and now have to build the correct LHS descriptor for it. */ ! tree dtype, data; tree offs, stride; tree lbound, ubound; --- 8480,8486 ---- converted in rse and now have to build the correct LHS descriptor for it. */ ! tree dtype, data, span; tree offs, stride; tree lbound, ubound; *************** gfc_trans_pointer_assignment (gfc_expr * *** 8505,8510 **** --- 8493,8510 ---- data = gfc_conv_descriptor_data_get (rse.expr); gfc_conv_descriptor_data_set (&block, desc, data); + /* Copy the span. */ + if (TREE_CODE (rse.expr) == VAR_DECL + && GFC_DECL_PTR_ARRAY_P (rse.expr)) + span = gfc_conv_descriptor_span_get (rse.expr); + else + { + tmp = TREE_TYPE (rse.expr); + tmp = TYPE_SIZE_UNIT (gfc_get_element_type (tmp)); + span = fold_convert (gfc_array_index_type, tmp); + } + gfc_conv_descriptor_span_set (&block, desc, span); + /* Copy offset but adjust it such that it would correspond to a lbound of zero. */ offs = gfc_conv_descriptor_offset_get (rse.expr); Index: gcc/fortran/trans-intrinsic.c =================================================================== *** gcc/fortran/trans-intrinsic.c (revision 249865) --- gcc/fortran/trans-intrinsic.c (working copy) *************** conv_expr_ref_to_caf_ref (stmtblock_t *b *** 1225,1234 **** && ref->u.c.component->attr.dimension) { tree arr_desc_token_offset; ! /* Get the token from the descriptor. */ ! arr_desc_token_offset = gfc_advance_chain ( ! TYPE_FIELDS (TREE_TYPE (ref->u.c.component->backend_decl)), ! 4 /* CAF_TOKEN_FIELD */); arr_desc_token_offset = compute_component_offset (arr_desc_token_offset, TREE_TYPE (tmp)); --- 1225,1233 ---- && ref->u.c.component->attr.dimension) { tree arr_desc_token_offset; ! /* Get the token field from the descriptor. */ ! arr_desc_token_offset = TREE_OPERAND ( ! gfc_conv_descriptor_token (ref->u.c.component->backend_decl), 1); arr_desc_token_offset = compute_component_offset (arr_desc_token_offset, TREE_TYPE (tmp)); *************** conv_isocbinding_subroutine (gfc_code *c *** 8129,8134 **** --- 8128,8138 ---- gfc_add_block_to_block (&block, &fptrse.pre); desc = fptrse.expr; + /* Set the span field. */ + tmp = TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc))); + tmp = fold_convert (gfc_array_index_type, tmp); + gfc_conv_descriptor_span_set (&block, desc, tmp); + /* Set data value, dtype, and offset. */ tmp = GFC_TYPE_ARRAY_DATAPTR_TYPE (TREE_TYPE (desc)); gfc_conv_descriptor_data_set (&block, desc, fold_convert (tmp, cptrse.expr)); Index: gcc/fortran/trans-io.c =================================================================== *** gcc/fortran/trans-io.c (revision 249865) --- gcc/fortran/trans-io.c (working copy) *************** gfc_trans_transfer (gfc_code * code) *** 2563,2568 **** --- 2563,2574 ---- gcc_assert (ref && ref->type == REF_ARRAY); } + if (expr->ts.type != BT_CLASS + && expr->expr_type == EXPR_VARIABLE + && gfc_expr_attr (expr).pointer) + goto scalarize; + + if (!(gfc_bt_struct (expr->ts.type) || expr->ts.type == BT_CLASS) && ref && ref->next == NULL *************** gfc_trans_transfer (gfc_code * code) *** 2597,2602 **** --- 2603,2609 ---- goto finish_block_label; } + scalarize: /* Initialize the scalarizer. */ ss = gfc_walk_expr (expr); gfc_init_loopinfo (&loop); *************** gfc_trans_transfer (gfc_code * code) *** 2612,2618 **** --- 2619,2627 ---- gfc_copy_loopinfo_to_se (&se, &loop); se.ss = ss; + gfc_conv_expr_reference (&se, expr); + if (expr->ts.type == BT_CLASS) vptr = gfc_get_vptr_from_expr (ss->info->data.array.descriptor); else Index: gcc/fortran/trans-stmt.c =================================================================== *** gcc/fortran/trans-stmt.c (revision 249865) --- gcc/fortran/trans-stmt.c (working copy) *************** trans_associate_var (gfc_symbol *sym, gf *** 1606,1612 **** : e->symtree->n.sym->backend_decl; tmp = gfc_get_element_type (TREE_TYPE (tmp)); tmp = fold_convert (gfc_array_index_type, size_in_bytes (tmp)); ! gfc_add_modify (&se.pre, GFC_DECL_SPAN(desc), tmp); } /* Done, register stuff as init / cleanup code. */ --- 1606,1612 ---- : e->symtree->n.sym->backend_decl; tmp = gfc_get_element_type (TREE_TYPE (tmp)); tmp = fold_convert (gfc_array_index_type, size_in_bytes (tmp)); ! gfc_conv_descriptor_span_set (&se.pre, desc, tmp); } /* Done, register stuff as init / cleanup code. */ Index: gcc/fortran/trans-types.c =================================================================== *** gcc/fortran/trans-types.c (revision 249865) --- gcc/fortran/trans-types.c (working copy) *************** along with GCC; see the file COPYING3. *** 35,40 **** --- 35,41 ---- #include "toplev.h" /* For rest_of_decl_compilation. */ #include "trans-types.h" #include "trans-const.h" + #include "trans-array.h" #include "dwarf2out.h" /* For struct array_descr_info. */ *************** gfc_get_array_descriptor_base (int dimen *** 1782,1787 **** --- 1783,1794 ---- gfc_array_index_type, &chain); TREE_NO_WARNING (decl) = 1; + /* Add the span component. */ + decl = gfc_add_field_to_struct_1 (fat_type, + get_identifier ("span"), + gfc_array_index_type, &chain); + TREE_NO_WARNING (decl) = 1; + /* Build the array type for the stride and bound components. */ if (dimen + codimen > 0) { *************** gfc_get_derived_type (gfc_symbol * deriv *** 2708,2713 **** --- 2715,2725 ---- if (!c->backend_decl) c->backend_decl = field; + if (c->attr.pointer && c->attr.dimension + && !(c->ts.type == BT_DERIVED + && strcmp (c->name, "_data") == 0)) + GFC_DECL_PTR_ARRAY_P (c->backend_decl) = 1; + /* Do not add a caf_token field for classes' data components. */ if (codimen && !c->attr.dimension && !c->attr.codimension && (c->attr.allocatable || c->attr.pointer) *************** gfc_get_array_descr_info (const_tree typ *** 3146,3152 **** { int rank, dim; bool indirect = false; ! tree etype, ptype, field, t, base_decl; tree data_off, dim_off, dtype_off, dim_size, elem_size; tree lower_suboff, upper_suboff, stride_suboff; --- 3158,3164 ---- { int rank, dim; bool indirect = false; ! tree etype, ptype, t, base_decl; tree data_off, dim_off, dtype_off, dim_size, elem_size; tree lower_suboff, upper_suboff, stride_suboff; *************** gfc_get_array_descr_info (const_tree typ *** 3203,3226 **** if (indirect) base_decl = build1 (INDIRECT_REF, ptype, base_decl); ! if (GFC_TYPE_ARRAY_SPAN (type)) ! elem_size = GFC_TYPE_ARRAY_SPAN (type); ! else ! elem_size = fold_convert (gfc_array_index_type, TYPE_SIZE_UNIT (etype)); ! field = TYPE_FIELDS (TYPE_MAIN_VARIANT (type)); ! data_off = byte_position (field); ! field = DECL_CHAIN (field); ! field = DECL_CHAIN (field); ! dtype_off = byte_position (field); ! field = DECL_CHAIN (field); ! dim_off = byte_position (field); ! dim_size = TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (field))); ! field = TYPE_FIELDS (TREE_TYPE (TREE_TYPE (field))); ! stride_suboff = byte_position (field); ! field = DECL_CHAIN (field); ! lower_suboff = byte_position (field); ! field = DECL_CHAIN (field); ! upper_suboff = byte_position (field); t = base_decl; if (!integer_zerop (data_off)) --- 3215,3225 ---- if (indirect) base_decl = build1 (INDIRECT_REF, ptype, base_decl); ! elem_size = fold_convert (gfc_array_index_type, TYPE_SIZE_UNIT (etype)); ! ! gfc_get_descriptor_offsets_for_info (type, &data_off, &dtype_off, &dim_off, ! &dim_size, &stride_suboff, ! &lower_suboff, &upper_suboff); t = base_decl; if (!integer_zerop (data_off)) Index: gcc/fortran/trans.c =================================================================== *** gcc/fortran/trans.c (revision 249865) --- gcc/fortran/trans.c (working copy) *************** gfc_build_addr_expr (tree type, tree t) *** 305,310 **** --- 305,371 ---- } + static tree + get_array_span (tree type, tree decl) + { + tree span; + + /* Return the span for deferred character length array references. */ + if (type && TREE_CODE (type) == ARRAY_TYPE + && TYPE_MAXVAL (TYPE_DOMAIN (type)) != NULL_TREE + && (VAR_P (TYPE_MAXVAL (TYPE_DOMAIN (type))) + || TREE_CODE (TYPE_MAXVAL (TYPE_DOMAIN (type))) == INDIRECT_REF) + && (TREE_CODE (TYPE_MAXVAL (TYPE_DOMAIN (type))) == INDIRECT_REF + || TREE_CODE (decl) == FUNCTION_DECL + || DECL_CONTEXT (TYPE_MAXVAL (TYPE_DOMAIN (type))) + == DECL_CONTEXT (decl))) + { + span = TYPE_MAXVAL (TYPE_DOMAIN (type)); + span = fold_convert (gfc_array_index_type, span); + } + /* Likewise for class array or pointer array references. */ + else if (TREE_CODE (decl) == FIELD_DECL + || VAR_OR_FUNCTION_DECL_P (decl) + || TREE_CODE (decl) == PARM_DECL) + { + if (GFC_DECL_CLASS (decl)) + { + /* When a temporary is in place for the class array, then the + original class' declaration is stored in the saved + descriptor. */ + if (DECL_LANG_SPECIFIC (decl) && GFC_DECL_SAVED_DESCRIPTOR (decl)) + decl = GFC_DECL_SAVED_DESCRIPTOR (decl); + else + { + /* Allow for dummy arguments and other good things. */ + if (POINTER_TYPE_P (TREE_TYPE (decl))) + decl = build_fold_indirect_ref_loc (input_location, decl); + + /* Check if '_data' is an array descriptor. If it is not, + the array must be one of the components of the class + object, so return a null span. */ + if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE ( + gfc_class_data_get (decl)))) + return NULL_TREE; + } + span = gfc_class_vtab_size_get (decl); + } + else if (GFC_DECL_PTR_ARRAY_P (decl)) + { + if (TREE_CODE (decl) == PARM_DECL) + decl = build_fold_indirect_ref_loc (input_location, decl); + span = gfc_conv_descriptor_span_get (decl); + } + else + span = NULL_TREE; + } + else + span = NULL_TREE; + + return span; + } + + /* Build an ARRAY_REF with its natural type. */ tree *************** gfc_build_array_ref (tree base, tree off *** 312,318 **** { tree type = TREE_TYPE (base); tree tmp; ! tree span; if (GFC_ARRAY_TYPE_P (type) && GFC_TYPE_ARRAY_RANK (type) == 0) { --- 373,379 ---- { tree type = TREE_TYPE (base); tree tmp; ! tree span = NULL_TREE; if (GFC_ARRAY_TYPE_P (type) && GFC_TYPE_ARRAY_RANK (type) == 0) { *************** gfc_build_array_ref (tree base, tree off *** 331,407 **** type = TREE_TYPE (type); - /* Use pointer arithmetic for deferred character length array - references. */ - if (type && TREE_CODE (type) == ARRAY_TYPE - && TYPE_MAXVAL (TYPE_DOMAIN (type)) != NULL_TREE - && (VAR_P (TYPE_MAXVAL (TYPE_DOMAIN (type))) - || TREE_CODE (TYPE_MAXVAL (TYPE_DOMAIN (type))) == INDIRECT_REF) - && decl - && (TREE_CODE (TYPE_MAXVAL (TYPE_DOMAIN (type))) == INDIRECT_REF - || TREE_CODE (decl) == FUNCTION_DECL - || DECL_CONTEXT (TYPE_MAXVAL (TYPE_DOMAIN (type))) - == DECL_CONTEXT (decl))) - span = TYPE_MAXVAL (TYPE_DOMAIN (type)); - else - span = NULL_TREE; - if (DECL_P (base)) TREE_ADDRESSABLE (base) = 1; /* Strip NON_LVALUE_EXPR nodes. */ STRIP_TYPE_NOPS (offset); ! /* If the array reference is to a pointer, whose target contains a ! subreference, use the span that is stored with the backend decl ! and reference the element with pointer arithmetic. */ ! if ((decl && (TREE_CODE (decl) == FIELD_DECL ! || VAR_OR_FUNCTION_DECL_P (decl) ! || TREE_CODE (decl) == PARM_DECL) ! && ((GFC_DECL_SUBREF_ARRAY_P (decl) ! && !integer_zerop (GFC_DECL_SPAN (decl))) ! || GFC_DECL_CLASS (decl) ! || span != NULL_TREE)) ! || vptr != NULL_TREE) { - if (decl) - { - if (GFC_DECL_CLASS (decl)) - { - /* When a temporary is in place for the class array, then the - original class' declaration is stored in the saved - descriptor. */ - if (DECL_LANG_SPECIFIC (decl) && GFC_DECL_SAVED_DESCRIPTOR (decl)) - decl = GFC_DECL_SAVED_DESCRIPTOR (decl); - else - { - /* Allow for dummy arguments and other good things. */ - if (POINTER_TYPE_P (TREE_TYPE (decl))) - decl = build_fold_indirect_ref_loc (input_location, decl); - - /* Check if '_data' is an array descriptor. If it is not, - the array must be one of the components of the class - object, so return a normal array reference. */ - if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE ( - gfc_class_data_get (decl)))) - return build4_loc (input_location, ARRAY_REF, type, base, - offset, NULL_TREE, NULL_TREE); - } - - span = gfc_class_vtab_size_get (decl); - } - else if (GFC_DECL_SUBREF_ARRAY_P (decl)) - span = GFC_DECL_SPAN (decl); - else if (span) - span = fold_convert (gfc_array_index_type, span); - else - gcc_unreachable (); - } - else if (vptr) - span = gfc_vptr_size_get (vptr); - else - gcc_unreachable (); - offset = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, offset, span); --- 392,414 ---- type = TREE_TYPE (type); if (DECL_P (base)) TREE_ADDRESSABLE (base) = 1; /* Strip NON_LVALUE_EXPR nodes. */ STRIP_TYPE_NOPS (offset); ! /* If decl or vptr are non-null, pointer arithmetic for the array reference ! is likely. Generate the 'span' for the array reference. */ ! if (vptr) ! span = gfc_vptr_size_get (vptr); ! else if (decl) ! span = get_array_span (type, decl); ! ! /* 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); *************** gfc_build_array_ref (tree base, tree off *** 412,419 **** tmp = build_fold_indirect_ref_loc (input_location, tmp); return tmp; } else - /* Otherwise use a straightforward array reference. */ return build4_loc (input_location, ARRAY_REF, type, base, offset, NULL_TREE, NULL_TREE); } --- 419,426 ---- tmp = build_fold_indirect_ref_loc (input_location, tmp); return tmp; } + /* Otherwise use a straightforward array reference. */ else return build4_loc (input_location, ARRAY_REF, type, base, offset, NULL_TREE, NULL_TREE); } Index: gcc/fortran/trans.h =================================================================== *** gcc/fortran/trans.h (revision 249865) --- gcc/fortran/trans.h (working copy) *************** struct GTY(()) lang_decl { *** 982,988 **** #define GFC_DECL_COMMON_OR_EQUIV(node) DECL_LANG_FLAG_3(node) #define GFC_DECL_CRAY_POINTEE(node) DECL_LANG_FLAG_4(node) #define GFC_DECL_RESULT(node) DECL_LANG_FLAG_5(node) ! #define GFC_DECL_SUBREF_ARRAY_P(node) DECL_LANG_FLAG_6(node) #define GFC_DECL_ASSOCIATE_VAR_P(node) DECL_LANG_FLAG_7(node) #define GFC_DECL_CLASS(node) DECL_LANG_FLAG_8(node) --- 982,988 ---- #define GFC_DECL_COMMON_OR_EQUIV(node) DECL_LANG_FLAG_3(node) #define GFC_DECL_CRAY_POINTEE(node) DECL_LANG_FLAG_4(node) #define GFC_DECL_RESULT(node) DECL_LANG_FLAG_5(node) ! #define GFC_DECL_PTR_ARRAY_P(node) DECL_LANG_FLAG_6(node) #define GFC_DECL_ASSOCIATE_VAR_P(node) DECL_LANG_FLAG_7(node) #define GFC_DECL_CLASS(node) DECL_LANG_FLAG_8(node) Index: gcc/testsuite/gfortran.dg/assumed_type_2.f90 =================================================================== *** gcc/testsuite/gfortran.dg/assumed_type_2.f90 (revision 249865) --- gcc/testsuite/gfortran.dg/assumed_type_2.f90 (working copy) *************** end *** 151,159 **** ! { dg-final { scan-tree-dump-times "sub_scalar .&scalar_t1," 1 "original" } } ! { dg-final { scan-tree-dump-times "sub_scalar .&\\(.\\(real.kind=4..0:. . restrict\\) array_real_alloc.data" 1 "original" } } ! ! { dg-final { scan-tree-dump-times "sub_scalar .&\\(.\\(character.kind=1..0:..1:1. .\\) array_char_ptr.data" 1 "original" } } ! { dg-final { scan-tree-dump-times "sub_scalar .&\\(.\\(struct t2.0:. . restrict\\) array_t2_alloc.data" 1 "original" } } ! ! { dg-final { scan-tree-dump-times "sub_scalar .&\\(.\\(struct t3.0:. .\\) array_t3_ptr.data" 1 "original" } } ! { dg-final { scan-tree-dump-times "sub_scalar .\\(struct t1 .\\) array_class_t1_alloc._data.data" 1 "original" } } ! { dg-final { scan-tree-dump-times "sub_scalar .\\(struct t1 .\\) \\(array_class_t1_ptr._data.dat" 1 "original" } } --- 151,159 ---- ! { dg-final { scan-tree-dump-times "sub_scalar .&scalar_t1," 1 "original" } } ! { dg-final { scan-tree-dump-times "sub_scalar .&\\(.\\(real.kind=4..0:. . restrict\\) array_real_alloc.data" 1 "original" } } ! ! { dg-final { scan-tree-dump-times "sub_scalar .\\(character.kind=1..1:1. .\\) .array_char_ptr.data" 1 "original" } } ! { dg-final { scan-tree-dump-times "sub_scalar .&\\(.\\(struct t2.0:. . restrict\\) array_t2_alloc.data" 1 "original" } } ! ! { dg-final { scan-tree-dump-times "sub_scalar .\\(struct t3 .\\) .array_t3_ptr.data" 1 "original" } } ! { dg-final { scan-tree-dump-times "sub_scalar .\\(struct t1 .\\) array_class_t1_alloc._data.data" 1 "original" } } ! { dg-final { scan-tree-dump-times "sub_scalar .\\(struct t1 .\\) \\(array_class_t1_ptr._data.dat" 1 "original" } } Index: gcc/testsuite/gfortran.dg/goacc/kernels-alias-4.f95 =================================================================== *** gcc/testsuite/gfortran.dg/goacc/kernels-alias-4.f95 (revision 249865) --- gcc/testsuite/gfortran.dg/goacc/kernels-alias-4.f95 (working copy) *************** program main *** 16,20 **** end program main ! Only the omp_data_i related loads should be annotated with cliques. ! ! { dg-final { scan-tree-dump-times "clique 1 base 1" 3 "ealias" } } ! ! { dg-final { scan-tree-dump-times "(?n)clique 1 base 0" 4 "ealias" } } --- 16,20 ---- end program main ! Only the omp_data_i related loads should be annotated with cliques. ! ! { dg-final { scan-tree-dump-times "clique 1 base 1" 4 "ealias" } } ! ! { dg-final { scan-tree-dump-times "(?n)clique 1 base 0" 5 "ealias" } } Index: gcc/testsuite/gfortran.dg/no_arg_check_2.f90 =================================================================== *** gcc/testsuite/gfortran.dg/no_arg_check_2.f90 (revision 249865) --- gcc/testsuite/gfortran.dg/no_arg_check_2.f90 (working copy) *************** end *** 133,141 **** ! { dg-final { scan-tree-dump-times "sub_scalar .&scalar_t1," 1 "original" } } ! { dg-final { scan-tree-dump-times "sub_scalar .&\\(.\\(real.kind=4..0:. . restrict\\) array_real_alloc.data" 1 "original" } } ! ! { dg-final { scan-tree-dump-times "sub_scalar .&\\(.\\(character.kind=1..0:..1:1. .\\) array_char_ptr.data" 1 "original" } } ! { dg-final { scan-tree-dump-times "sub_scalar .&\\(.\\(struct t2.0:. . restrict\\) array_t2_alloc.data" 1 "original" } } ! ! { dg-final { scan-tree-dump-times "sub_scalar .&\\(.\\(struct t3.0:. .\\) array_t3_ptr.data" 1 "original" } } ! { dg-final { scan-tree-dump-times "sub_scalar .\\(struct t1 .\\) array_class_t1_alloc._data.data" 1 "original" } } ! { dg-final { scan-tree-dump-times "sub_scalar .\\(struct t1 .\\) \\(array_class_t1_ptr._data.dat" 1 "original" } } --- 133,141 ---- ! { dg-final { scan-tree-dump-times "sub_scalar .&scalar_t1," 1 "original" } } ! { dg-final { scan-tree-dump-times "sub_scalar .&\\(.\\(real.kind=4..0:. . restrict\\) array_real_alloc.data" 1 "original" } } ! ! { dg-final { scan-tree-dump-times "sub_scalar .\\(character.kind=1..1:1. .\\) .array_char_ptr.data" 1 "original" } } ! { dg-final { scan-tree-dump-times "sub_scalar .&\\(.\\(struct t2.0:. . restrict\\) array_t2_alloc.data" 1 "original" } } ! ! { dg-final { scan-tree-dump-times "sub_scalar .\\(struct t3 .\\) .array_t3_ptr.data" 1 "original" } } ! { dg-final { scan-tree-dump-times "sub_scalar .\\(struct t1 .\\) array_class_t1_alloc._data.data" 1 "original" } } ! { dg-final { scan-tree-dump-times "sub_scalar .\\(struct t1 .\\) \\(array_class_t1_ptr._data.dat" 1 "original" } } Index: gcc/testsuite/gfortran.dg/pointer_array_1.f90 =================================================================== *** gcc/testsuite/gfortran.dg/pointer_array_1.f90 (nonexistent) --- gcc/testsuite/gfortran.dg/pointer_array_1.f90 (working copy) *************** *** 0 **** --- 1,60 ---- + ! { dg-do run } + ! + ! Check the fix for PR34640 comments 1 and 3. + ! + ! This involves passing and returning pointer array components that + ! point to components of arrays of derived types. + ! + MODULE test + IMPLICIT NONE + TYPE :: my_type + INTEGER :: value + integer :: tag + END TYPE + CONTAINS + SUBROUTINE get_values(values, switch) + INTEGER, POINTER :: values(:) + integer :: switch + TYPE(my_type), POINTER :: d(:) + allocate (d, source = [my_type(1,101), my_type(2,102)]) + if (switch .eq. 1) then + values => d(:)%value + if (any (values .ne. [1,2])) print *, values(2) + else + values => d(:)%tag + if (any (values .ne. [101,102])) call abort + end if + END SUBROUTINE + + function return_values(switch) result (values) + INTEGER, POINTER :: values(:) + integer :: switch + TYPE(my_type), POINTER :: d(:) + allocate (d, source = [my_type(1,101), my_type(2,102)]) + if (switch .eq. 1) then + values => d(:)%value + if (any (values .ne. [1,2])) call abort + else + values => d(:)%tag + if (any (values([2,1]) .ne. [102,101])) call abort + end if + END function + END MODULE + + use test + integer, pointer :: x(:) + type :: your_type + integer, pointer :: x(:) + end type + type(your_type) :: y + + call get_values (x, 1) + if (any (x .ne. [1,2])) call abort + call get_values (y%x, 2) + if (any (y%x .ne. [101,102])) call abort + + x => return_values (2) + if (any (x .ne. [101,102])) call abort + y%x => return_values (1) + if (any (y%x .ne. [1,2])) call abort + end Index: gcc/testsuite/gfortran.dg/pointer_array_2.f90 =================================================================== *** gcc/testsuite/gfortran.dg/pointer_array_2.f90 (nonexistent) --- gcc/testsuite/gfortran.dg/pointer_array_2.f90 (working copy) *************** *** 0 **** --- 1,143 ---- + ! { dg-do compile } + ! + ! Test the fix for PR40737 as part of the overall fix for PR34640. + ! + ! Contributed by David Hough + ! + module testmod + + integer, parameter :: standard_integer = 1 + integer, parameter :: int = KIND( standard_integer) + + integer, parameter :: i8 = selected_int_kind(12) + integer, parameter :: i4 = selected_int_kind(8) + integer, parameter :: i2 = selected_int_kind(4) + + integer, parameter :: standard_real = 1. + integer, parameter :: std_real = KIND( standard_real) + + integer, parameter :: r8 = selected_real_kind(12) + integer, parameter :: r4 = selected_real_kind(6) + integer, parameter :: double = selected_real_kind(20) + + integer, parameter :: name_string_length = 40 + integer, parameter :: file_name_length = 60 + integer, parameter :: text_string_length = 80 + integer, parameter :: max_kwd_lgth = file_name_length + + integer(int) :: bytes_per_int = 4 + integer(int) :: bytes_per_real = 8 + integer(int) :: workcomm, spincomm + + integer(int), parameter :: nb_directions = 3, & + direction_x = 1, & + direction_y = 2, & + direction_z = 3, & + nb_ghost_cells = 5 ! might be different for the lagrange step? + + integer(int), parameter :: ends = 4, & + lower_ghost = 1, & + lower_interior = 2, & + upper_interior = 3, & + upper_ghost = 4 + + ! Neighbors + integer(int), parameter :: side = 2, & + lower_end = 1, & + upper_end = 2 + + + integer(int), parameter :: nb_variables = 5, & + ro_var = 1, & + ets_var = 2, & + u_var = 3, & + up1_var = 4, & + up2_var = 5, & + eis_var = 6, & + ecs_var = 7, & + p_var = 8, & + c_var = 9, & + nb_var_sortie = 9 + + type :: VARIABLES_LIGNE + sequence + real, pointer, dimension( :, :) :: l + end type VARIABLES_LIGNE + + type VARIABLES_MAILLE + sequence + real(r8), dimension( nb_variables) :: cell_var + end type VARIABLES_MAILLE + + integer(int), dimension( nb_directions) :: & + first_real_cell, & ! without ghost cells + last_real_cell, & ! + nb_real_cells, & ! + first_work_cell, & ! including ghost cells + last_work_cell, & ! + nb_work_cells, & ! + global_nb_cells ! number of real cells, for the entire grid + + integer(int) :: dim_probleme ! dimension du probleme (1, 2 ou 3) + + integer(int) :: largest_local_size ! the largest of the 3 dimensions of the local grid + + ! Hydro variables of the actual domain + ! There are 3 copies of these, for use according to current work direction + type (VARIABLES_MAILLE), allocatable, target, dimension( :, :, :) :: & + Hydro_vars_XYZ, & + Hydro_vars_YZX, & + Hydro_vars_ZXY + + ! Pointers to current and next Hydro var arrays + type (VARIABLES_MAILLE), pointer, dimension( :, :, :) :: Hydro_vars, & + Hydro_vars_next + + ! Which of these 3 copies of the 3D arrays has been updated last + integer(int) :: last_updated_3D_array = 0 + + real(r8), pointer, dimension( :) :: & + ! Variables "permanentes" (entrant dans la projection) + Ro, & ! densite + Ets, & ! energie totale specifique + Um, & ! vitesse aux mailles, dans la direction de travail + Xn, & ! abscisse en fin de pas de temps + ! Variables en lecture seulement + Um_p1, & ! vitesse aux mailles, dans les directions + Um_p2, & ! orthogonales + Xa, & ! abscisses des noeuds en debut de pas de temps + Dxa, & ! longueur des mailles en debut de pas de temps + U_dxa ! inverses des longueurs des mailles + + end module testmod + + + subroutine TF_AD_SPLITTING_DRIVER_PLANE + + use testmod + + implicit none + save + + real(r8), allocatable, dimension( :) :: & + ! Variables maille recalculees a chaque pas de temps + Eis, & ! energie interne specifique (seulement pour calculer la pression) + Vit_son, & ! comme son nom l'indique + C_f_l, & ! nombre de Courant + Pm, & ! pression aux mailles + ! Variables aux noeuds + Un, & ! vitesse des noeuds + Pn ! pression aux noeuds + + + integer(int) :: i, j, k + integer(int) :: first_cell, last_cell + + Ro => Hydro_vars( first_cell:last_cell, j, k)%cell_var( ro_var) + Ets => Hydro_vars( first_cell:last_cell, j, k)%cell_var( ets_var) + Um => Hydro_vars( first_cell:last_cell, j, k)%cell_var( u_var) + Um_p1 => Hydro_vars( first_cell:last_cell, j, k)%cell_var( up1_var) + Um_p2 => Hydro_vars( first_cell:last_cell, j, k)%cell_var( up2_var) + + end subroutine TF_AD_SPLITTING_DRIVER_PLANE + Index: gcc/testsuite/gfortran.dg/pointer_array_3.f90 =================================================================== *** gcc/testsuite/gfortran.dg/pointer_array_3.f90 (nonexistent) --- gcc/testsuite/gfortran.dg/pointer_array_3.f90 (working copy) *************** *** 0 **** --- 1,51 ---- + ! { dg-do run } + ! + ! Test the fix for PR40737 comment 17 as part of the overall fix for PR34640. + ! + ! Contributed by Josh Hykes + ! + module test_mod + ! + type t1 + character(8) :: string + end type t1 + ! + type t2 + integer :: tab + type(t1), pointer :: fp(:) + end type t2 + ! + type t3 + integer :: tab + type(t2), pointer :: as + end type t3 + ! + type(t3), pointer :: as_typ(:) => null() + ! + character(8), pointer, public :: p(:) + ! + contains + ! + subroutine as_set_alias (i) + ! + implicit none + ! + integer, intent(in) :: i + ! + allocate (as_typ(2)) + allocate (as_typ(1)%as) + allocate (as_typ(1)%as%fp(2), source = [t1("abcdefgh"),t1("ijklmnop")]) + p => as_typ(i)%as%fp(:)%string + ! + end subroutine as_set_alias + ! + end module test_mod + + program test_prog + use test_mod + call as_set_alias(1) + if (any (p .ne. ["abcdefgh","ijklmnop"])) call abort + deallocate (as_typ(1)%as%fp) + deallocate (as_typ(1)%as) + deallocate (as_typ) + end program test_prog Index: gcc/testsuite/gfortran.dg/pointer_array_4.f90 =================================================================== *** gcc/testsuite/gfortran.dg/pointer_array_4.f90 (nonexistent) --- gcc/testsuite/gfortran.dg/pointer_array_4.f90 (working copy) *************** *** 0 **** --- 1,75 ---- + ! { dg-do run } + ! + ! Test the fix for PR57116 as part of the overall fix for PR34640. + ! + ! Contributed by Reinhold Bader + ! + module mod_rtti_ptr + implicit none + type :: foo + real :: v + integer :: i + end type foo + contains + subroutine extract(this, v, ic) + class(*), target :: this(:) + real, pointer :: v(:) + integer :: ic + select type (this) + type is (real) + v => this(ic:) + class is (foo) + v => this(ic:)%v + end select + end subroutine extract + end module + + program prog_rtti_ptr + use mod_rtti_ptr + class(*), allocatable, target :: o(:) + real, pointer :: v(:) + + allocate(o(3), source=[1.0, 2.0, 3.0]) + call extract(o, v, 2) + if (size(v) == 2 .and. all (v == [2.0, 3.0])) then + deallocate(o) + else + call abort + end if + + allocate(o(3), source=[foo(1.0, 1), foo(4.0, 4), foo(5.0, 5)]) + call extract(o, v, 2) + if (size(v) == 2 .and. all (v == [4.0, 5.0])) then + deallocate(o) + else + call abort + end if + + ! The rest tests the case in comment 2 + + call extract1 (v, 1) + if (any (v /= [1.0, 2.0])) call abort + call extract1 (v, 2) ! Call to deallocate pointer. + + contains + subroutine extract1(v, flag) + type :: foo + real :: v + character(4) :: str + end type + class(foo), pointer, save :: this(:) + real, pointer :: v(:) + integer :: flag + + if (flag == 1) then + allocate (this(2), source = [foo (1.0, "one "), foo (2.0, "two ")]) + select type (this) + class is (foo) + v => this(1:2)%v + end select + else + deallocate (this) + end if + end subroutine + + end program prog_rtti_ptr Index: gcc/testsuite/gfortran.dg/pointer_array_5.f90 =================================================================== *** gcc/testsuite/gfortran.dg/pointer_array_5.f90 (nonexistent) --- gcc/testsuite/gfortran.dg/pointer_array_5.f90 (working copy) *************** *** 0 **** --- 1,65 ---- + ! { dg-do run } + ! + ! Test the fix for PR55763 comment 9 as part of the overall fix for PR34640. + ! + ! Contributed by Tobias Burnus + ! + program change_field_type + use, intrinsic :: iso_c_binding + implicit none + REAL(kind=c_float), POINTER :: vector_comp(:) + TYPE, BIND(C) :: scalar_vector + REAL(kind=c_float) :: scalar + REAL(kind=c_float) :: vec(3) + END TYPE + TYPE, BIND(C) :: scalar_vector_matrix + REAL(kind=c_float) :: scalar + REAL(kind=c_float) :: vec(3) + REAL(kind=c_float) :: mat(3,3) + END TYPE + CLASS(*), ALLOCATABLE, TARGET :: one_d_field(:) + real, pointer :: v1(:) + + allocate(one_d_field(3), & + source = (/ scalar_vector( 1.0, (/ -1.0, 0.0, 1.0 /) ), & + scalar_vector( 1.1, (/ -1.2, 0.2, 0.9 /) ), & + scalar_vector( 1.2, (/ -1.4, 0.4, 0.8 /) ) /) ) + + call extract_vec(one_d_field, 1, 2) + if (any (abs (vector_comp - [0.0,0.2,0.4]) .gt. 1e-4)) call abort + deallocate(one_d_field) ! v1 becomes undefined + + allocate(one_d_field(1), & + source = (/ scalar_vector_matrix( 1.0, (/ -1.0, 0.0, 1.0 /), & + reshape( (/ 1.0, 0.0, 0.0, 0.0, 1.0, 0.0, 0.0, 0.0, 1.0 /), & + (/3, 3/) ) ) /) ) + + call extract_vec(one_d_field, 2, 1) + if (abs (vector_comp(1) + 1.0) > 1e-4) call abort + call extract_vec(one_d_field, 2, 3) + if (abs (vector_comp(1) - 1.0) > 1e-4) call abort + deallocate(one_d_field) ! v1 becomes undefined + contains + subroutine extract_vec(field, tag, ic) + use, intrinsic :: iso_c_binding + CLASS(*), TARGET :: field(:) + INTEGER(kind=c_int), value :: tag, ic + + type(scalar_vector), pointer :: sv(:) + type(scalar_vector_matrix), pointer :: svm(:) + + select type (field) + type is (real(c_float)) + vector_comp => field + class default + select case (tag) + case (1) + sv => field + vector_comp => sv(:)%vec(ic) + case (2) + svm => field + vector_comp => svm(:)%vec(ic) + end select + end select + end subroutine + end program Index: gcc/testsuite/gfortran.dg/pointer_array_6.f90 =================================================================== *** gcc/testsuite/gfortran.dg/pointer_array_6.f90 (nonexistent) --- gcc/testsuite/gfortran.dg/pointer_array_6.f90 (working copy) *************** *** 0 **** --- 1,28 ---- + ! { dg-do run } + ! + ! Test the fix for PR57019 comment 4 as part of the overall fix for PR34640. + ! + ! Contributed by + ! + type cParticle + real(4) :: v(3) + endtype cParticle + + type pCItem + type(cParticle) :: Ele + end type pCItem + + type(pCItem), target, dimension(1:1,1:1) :: pCellArray + type(cParticle), pointer, dimension(:,:) :: pArray + real(4), pointer, dimension(:) :: v_pointer + real(4), dimension(3) :: v_real = 99. + + pArray => pCellArray%Ele + v_pointer => pArray(1,1)%v; + v_pointer = v_real !OK %%%%%%%%%%%% + if (any (int (pArray(1,1)%v) .ne. 99)) call abort + + v_real = 88 + pArray(1,1)%v = v_real !SEGFAULT %%%%%%%%%%%%%%%%%%%%%%%% + if (any (int (v_pointer) .ne. 88)) call abort + end Index: gcc/testsuite/gfortran.dg/pointer_array_7.f90 =================================================================== *** gcc/testsuite/gfortran.dg/pointer_array_7.f90 (nonexistent) --- gcc/testsuite/gfortran.dg/pointer_array_7.f90 (working copy) *************** *** 0 **** --- 1,46 ---- + ! { dg-do run } + ! + ! Test for the fix for PR34640. In this case, final testing of the + ! patch revealed that in some cases the actual descriptor was not + ! being passed to procedure dummy pointers. + ! + ! Contributed by Thomas Koenig + ! + module x + use iso_c_binding + implicit none + type foo + complex :: c + integer :: i + end type foo + contains + subroutine printit(c, a) + complex, pointer, dimension(:) :: c + integer :: i + integer(kind=8) :: a + a = transfer(c_loc(c(2)),a) + end subroutine printit + end module x + + program main + use x + use iso_c_binding + implicit none + type(foo), dimension(5), target :: a + integer :: i + complex, dimension(:), pointer :: pc + integer(kind=8) :: s1, s2, s3 + a%i = 0 + do i=1,5 + a(i)%c = cmplx(i**2,i) + end do + pc => a%c + call printit(pc, s3) + + s1 = transfer(c_loc(a(2)%c),s1) + if (s1 /= s3) call abort + + s2 = transfer(c_loc(pc(2)),s2) + if (s2 /= s3) call abort + + end program main Index: gcc/testsuite/gfortran.dg/pointer_array_8.f90 =================================================================== *** gcc/testsuite/gfortran.dg/pointer_array_8.f90 (nonexistent) --- gcc/testsuite/gfortran.dg/pointer_array_8.f90 (working copy) *************** *** 0 **** --- 1,80 ---- + ! { dg-do run } + ! + ! Make sure that the fix for pr34640 works with class pointers. + ! + type :: mytype + real :: r + integer :: i + end type + + type :: thytype + real :: r + integer :: i + type(mytype) :: der + end type + + type(thytype), dimension(0:2), target :: tgt + class(*), dimension(:), pointer :: cptr + class(mytype), dimension(:), pointer :: cptr1 + integer :: i + integer(8) :: s1, s2 + + tgt = [(thytype(int(i), i, mytype(int(2*i), 2*i)), i= 1,3)] + + cptr => tgt%i + + s1 = loc(cptr) + call foo (cptr, s2) ! Check bounds not changed... + if (s1 .ne. s2) Call abort ! ...and that the descriptor is passed. + + select type (cptr) + type is (integer) + if (any (cptr .ne. [1,2,3])) call abort ! Check the the scalarizer works. + if (cptr(1) .ne. 2) call abort ! Check ordinary array indexing. + end select + + cptr(1:3) => tgt%der%r ! Something a tad more complicated! + + select type (cptr) + type is (real) + if (any (int(cptr) .ne. [2,4,6])) call abort + if (any (int(cptr([2,3,1])) .ne. [4,6,2])) call abort + if (int(cptr(3)) .ne. 6) call abort + end select + + cptr1(1:3) => tgt%der + + s1 = loc(cptr1) + call bar(cptr1, s2) + if (s1 .ne. s2) Call abort ! Check that the descriptor is passed. + + select type (cptr1) + type is (mytype) + if (any (cptr1%i .ne. [2,4,6])) call abort + if (cptr1(2)%i .ne. 4) call abort + end select + + contains + + subroutine foo (arg, addr) + class(*), dimension(:), pointer :: arg + integer(8) :: addr + addr = loc(arg) + select type (arg) + type is (integer) + if (any (arg .ne. [1,2,3])) call abort ! Check the the scalarizer works. + if (arg(1) .ne. 2) call abort ! Check ordinary array indexing. + end select + end subroutine + + subroutine bar (arg, addr) + class(mytype), dimension(:), pointer :: arg + integer(8) :: addr + addr = loc(arg) + select type (arg) + type is (mytype) + if (any (arg%i .ne. [2,4,6])) call abort + if (arg(2)%i .ne. 4) call abort + end select + end subroutine + end Index: gcc/testsuite/gfortran.dg/pointer_array_component_1.f90 =================================================================== *** gcc/testsuite/gfortran.dg/pointer_array_component_1.f90 (nonexistent) --- gcc/testsuite/gfortran.dg/pointer_array_component_1.f90 (working copy) *************** *** 0 **** --- 1,47 ---- + ! { dg-do run } + ! + ! Check the fix for PR34640 comment 28. + ! + ! This involves pointer array components that point to components of arrays + ! of derived types. + ! + type var_tables + real, pointer :: rvar(:) + end type + + type real_vars + real r + real :: index + end type + + type(var_tables) :: vtab_r + type(real_vars), target :: x(2) + real, pointer :: z(:) + real :: y(2) + + x = [real_vars (11.0, 1.0), real_vars (42.0, 2.0)] + vtab_r%rvar => x%r + if (any (abs (vtab_r%rvar - [11.0, 42.0]) > 1.0e-5)) call abort ! Check skipping 'index; is OK. + + y = vtab_r%rvar + if (any (abs (y - [11.0, 42.0]) > 1.0e-5)) call abort ! Check that the component is usable in assignment. + + call foobar (vtab_r, [11.0, 42.0]) + + vtab_r = barfoo () + + call foobar (vtab_r, [111.0, 142.0]) + + contains + subroutine foobar (vtab, array) + type(var_tables) :: vtab + real :: array (:) + if (any (abs (vtab%rvar - array) > 1.0e-5)) call abort ! Check passing as a dummy. + if (abs (vtab%rvar(2) - array(2)) > 1.0e-5) call abort ! Check component reference. + end subroutine + + function barfoo () result(res) + type(var_tables) :: res + allocate (res%rvar(2), source = [111.0, 142.0]) ! Check allocation + end function + end Index: gcc/testsuite/gfortran.dg/pointer_array_component_2.f90 =================================================================== *** gcc/testsuite/gfortran.dg/pointer_array_component_2.f90 (nonexistent) --- gcc/testsuite/gfortran.dg/pointer_array_component_2.f90 (working copy) *************** *** 0 **** --- 1,43 ---- + ! { dg-do run } + ! + ! Test the fix for PR34640. In the first version of the fix, the first + ! testcase in PR51218 failed with a segfault. This test extracts the + ! failing part and checks that all is well. + ! + type t_info_block + integer :: n = 0 ! number of elements + end type t_info_block + ! + type t_dec_info + integer :: n = 0 ! number of elements + integer :: n_b = 0 ! number of blocks + type (t_info_block) ,pointer :: b (:) => NULL() ! info blocks + end type t_dec_info + ! + type t_vector_segm + integer :: n = 0 ! number of elements + real ,pointer :: x(:) => NULL() ! coefficients + end type t_vector_segm + ! + type t_vector + type (t_dec_info) ,pointer :: info => NULL() ! decomposition info + integer :: n = 0 ! number of elements + integer :: n_s = 0 ! number of segments + integer :: alloc_l = 0 ! allocation level + type (t_vector_segm) ,pointer :: s (:) => NULL() ! vector blocks + end type t_vector + + + type(t_vector) :: z + type(t_vector_segm), pointer :: ss + + allocate (z%s(2)) + do i = 1, 2 + ss => z%s(i) + allocate (ss%x(2), source = [1.0, 2.0]*real(i)) + end do + + ! These lines would segfault. + if (int (sum (z%s(1)%x)) .ne. 3) call abort + if (int (sum (z%s(1)%x * z%s(2)%x)) .ne. 10) call abort + end Index: gcc/testsuite/gfortran.dg/subref_array_pointer_4.f90 =================================================================== *** gcc/testsuite/gfortran.dg/subref_array_pointer_4.f90 (revision 249865) --- gcc/testsuite/gfortran.dg/subref_array_pointer_4.f90 (working copy) *************** PROGRAM X *** 22,28 **** CONTAINS SUBROUTINE Z(Q) INTEGER, POINTER :: Q(:) ! Q(1:3:2) = 999 END SUBROUTINE Z END PROGRAM X --- 22,30 ---- CONTAINS SUBROUTINE Z(Q) INTEGER, POINTER :: Q(:) ! integer :: off ! off = lbound(Q, 1) - 1 ! Q(1+off : 3+off : 2) = 999 END SUBROUTINE Z END PROGRAM X Index: libgfortran/libgfortran.h =================================================================== *** libgfortran/libgfortran.h (revision 249865) --- libgfortran/libgfortran.h (working copy) *************** struct {\ *** 339,344 **** --- 339,345 ---- type *base_addr;\ size_t offset;\ index_type dtype;\ + index_type span;\ descriptor_dimension dim[r];\ }