Dear Dominique, The attached fixes the problem withPR51218 and bootstraps and regtests on FC23/x86_64 - OK for trunk?
Cheers Paul 2017-04-13 Paul Thomas <pa...@gcc.gnu.org> PR fortran/34640 * expr.c (gfc_check_pointer_assign): Exclude pointer array components in test for 'subref_array_pointer' attribute. (gfc_hidden_length_field): New function. * gfortran.h : Prototype for the above. * resolve.c (resolve_component): Call the above for deferred character and pointer array components to provide the hidden field for the character length or span. * trans-array.c (gfc_conv_scalarized_array_ref); Use the hidden span field provided by 'gfc_pointer_array_comp_ref' in the call to 'gfc_build_array_ref'. (build_array_ref): Add the new argument 'passed_span' and pass its to 'gfc_build_array_ref'. (gfc_conv_array_ref): Same as 'gfc_conv_scalarized_array_ref'. (gfc_array_allocate): Set the hidden span field if it is passed by 'gfc_pointer_array_comp_ref'. (gfc_get_dataptr_offset): Pass a null to the 'passed_span' arg. trans-expr.c (gfc_trans_pointer_assignment): Obtain the 'span' for pointer array components and use if applicable. * trans-io.c (gfc_trans_transfer): Scalarize if this is a pointer array component, rather than using the library. trans.c (gfc_build_addr_expr): Use the 'passed_span' arg. (gfc_pointer_array_comp_ref): New function. (hidden_length_field): New function. (gfc_deferred_strlen): Now just calls previous. (gfc_span_field): New function. * trans.h : Add prototypes for 'gfc_pointer_array_comp_ref' and 'gfc_span_field'. 2017-04-13 Paul Thomas <pa...@gcc.gnu.org> PR fortran/34640 * gfortran.dg/pointer_array_component_1.f90: New test. * gfortran.dg/pointer_array_component_2.f90: New test. On 9 April 2017 at 17:14, Dominique d'Humières <domi...@lps.ens.fr> wrote: > The original test in pr51218 is also miscomputed with the patch: > > Before t: > > Program received signal SIGSEGV: Segmentation fault - invalid memory > reference. > > Dominique > >> Le 9 avr. 2017 à 16:41, Dominique d'Humières <domi...@lps.ens.fr> a écrit : >> >> Dear Paul, >> >> Your patch fixes the tests in pr34640 comments 20 and 28 (I didn’t test the >> variants in comment 27) and in pr57733. >> The tests in pr34640 in comments 0, 3, and 5, as well in all the other >> duplicates still fail. >> >> Thanks for working on the issue, >> >> Dominique >> > -- "If you can't explain it simply, you don't understand it well enough" - Albert Einstein
Index: gcc/fortran/expr.c =================================================================== *** gcc/fortran/expr.c (revision 246903) --- gcc/fortran/expr.c (working copy) *************** gfc_check_pointer_assign (gfc_expr *lval *** 3733,3739 **** return false; } ! if (rvalue->expr_type == EXPR_VARIABLE && is_subref_array (rvalue)) lvalue->symtree->n.sym->attr.subref_array_pointer = 1; attr = gfc_expr_attr (rvalue); --- 3733,3742 ---- return false; } ! /* Pointer array components are taken care of using the hidden 'span' ! component. */ ! if (rvalue->expr_type == EXPR_VARIABLE && is_subref_array (rvalue) ! && lvalue->symtree->n.sym->ts.type != BT_DERIVED) lvalue->symtree->n.sym->attr.subref_array_pointer = 1; attr = gfc_expr_attr (rvalue); *************** gfc_check_vardef_context (gfc_expr* e, b *** 5504,5506 **** --- 5507,5530 ---- return true; } + + + gfc_component * + gfc_hidden_length_field (gfc_symbol *sym, gfc_component *c, + bool add_if_missing, const char *postfix) + { + char name[GFC_MAX_SYMBOL_LEN+9]; + gfc_component *strlen; + sprintf (name, "_%s_%s", c->name, postfix); + strlen = gfc_find_component (sym, name, true, true, NULL); + if (strlen == NULL && add_if_missing) + { + if (!gfc_add_component (sym, name, &strlen)) + return NULL; + strlen->ts.type = BT_INTEGER; + strlen->ts.kind = gfc_charlen_int_kind; + strlen->attr.access = ACCESS_PRIVATE; + strlen->attr.artificial = 1; + } + return strlen; + } Index: gcc/fortran/gfortran.h =================================================================== *** gcc/fortran/gfortran.h (revision 246903) --- gcc/fortran/gfortran.h (working copy) *************** gfc_expr* gfc_find_stat_co (gfc_expr *); *** 3157,3162 **** --- 3157,3164 ---- gfc_expr* gfc_build_intrinsic_call (gfc_namespace *, gfc_isym_id, const char*, locus, unsigned, ...); bool gfc_check_vardef_context (gfc_expr*, bool, bool, bool, const char*); + gfc_component* gfc_hidden_length_field (gfc_symbol *, gfc_component *, + bool, const char *); /* st.c */ Index: gcc/fortran/resolve.c =================================================================== *** gcc/fortran/resolve.c (revision 246903) --- gcc/fortran/resolve.c (working copy) *************** resolve_component (gfc_component *c, gfc *** 13551,13571 **** /* Add the hidden deferred length field. */ if (c->ts.type == BT_CHARACTER && c->ts.deferred && !c->attr.function ! && !sym->attr.is_class) { ! char name[GFC_MAX_SYMBOL_LEN+9]; ! gfc_component *strlen; ! sprintf (name, "_%s_length", c->name); ! strlen = gfc_find_component (sym, name, true, true, NULL); ! if (strlen == NULL) ! { ! if (!gfc_add_component (sym, name, &strlen)) ! return false; ! strlen->ts.type = BT_INTEGER; ! strlen->ts.kind = gfc_charlen_int_kind; ! strlen->attr.access = ACCESS_PRIVATE; ! strlen->attr.artificial = 1; ! } } if (c->ts.type == BT_DERIVED --- 13551,13567 ---- /* Add the hidden deferred length field. */ if (c->ts.type == BT_CHARACTER && c->ts.deferred && !c->attr.function ! && !sym->attr.is_class) { ! if (gfc_hidden_length_field (sym, c, true, "length") == NULL) ! return false; ! } ! ! /* Add the hidden pointer array span field. */ ! if (c->attr.pointer && c->attr.dimension && !sym->attr.is_class) ! { ! if (gfc_hidden_length_field (sym, c, true, "span") == NULL) ! return false; } if (c->ts.type == BT_DERIVED Index: gcc/fortran/trans-array.c =================================================================== *** gcc/fortran/trans-array.c (revision 246903) --- gcc/fortran/trans-array.c (working copy) *************** gfc_conv_scalarized_array_ref (gfc_se * *** 3218,3223 **** --- 3218,3224 ---- { gfc_array_info *info; tree decl = NULL_TREE; + tree passed_span = NULL_TREE; tree index; tree tmp; gfc_ss *ss; *************** gfc_conv_scalarized_array_ref (gfc_se * *** 3244,3249 **** --- 3245,3262 ---- || expr->expr_type == EXPR_FUNCTION)))) decl = expr->symtree->n.sym->backend_decl; + /* Use the hidden 'span' field to address the elements of a pointer + array component. */ + if (info->descriptor != NULL_TREE + && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (info->descriptor)) + && expr && gfc_pointer_array_comp_ref (expr, ar ? ar->as : NULL, &passed_span)) + { + tmp = TREE_OPERAND (info->descriptor, 0); + passed_span = fold_build3_loc (input_location, COMPONENT_REF, + TREE_TYPE (passed_span), tmp, + passed_span, NULL_TREE); + } + tmp = build_fold_indirect_ref_loc (input_location, info->data); /* Use the vptr 'size' field to access a class the element of a class *************** gfc_conv_scalarized_array_ref (gfc_se * *** 3251,3257 **** if (build_class_array_ref (se, tmp, index)) return; ! se->expr = gfc_build_array_ref (tmp, index, decl); } --- 3264,3270 ---- if (build_class_array_ref (se, tmp, index)) return; ! se->expr = gfc_build_array_ref (tmp, index, decl, NULL, passed_span); } *************** add_to_offset (tree *cst_offset, tree *o *** 3284,3290 **** static tree ! build_array_ref (tree desc, tree offset, tree decl, tree vptr) { tree tmp; tree type; --- 3297,3304 ---- static tree ! build_array_ref (tree desc, tree offset, tree decl, tree vptr, ! tree passed_span) { tree tmp; tree type; *************** build_array_ref (tree desc, tree offset, *** 3331,3337 **** tmp = gfc_conv_array_data (desc); tmp = build_fold_indirect_ref_loc (input_location, tmp); ! tmp = gfc_build_array_ref (tmp, offset, decl, vptr); return tmp; } --- 3345,3351 ---- tmp = gfc_conv_array_data (desc); tmp = build_fold_indirect_ref_loc (input_location, tmp); ! tmp = gfc_build_array_ref (tmp, offset, decl, vptr, passed_span); return tmp; } *************** gfc_conv_array_ref (gfc_se * se, gfc_arr *** 3350,3355 **** --- 3364,3370 ---- tree offset, cst_offset; tree tmp; tree stride; + tree passed_span = 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); } --- 3509,3533 ---- offset = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, offset, cst_offset); + /* Use the hidden 'span' field to address the elements of a pointer + array component. */ + if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se->expr)) + && expr && gfc_pointer_array_comp_ref (expr, ar ? ar->as : NULL, &passed_span)) + { + if (TREE_CODE (se->expr) != VAR_DECL) + { + tmp = TREE_OPERAND (se->expr, 0); + passed_span = fold_build3_loc (input_location, COMPONENT_REF, + TREE_TYPE (passed_span), tmp, + passed_span, NULL_TREE); + } + else + passed_span = NULL_TREE; + } + se->expr = build_array_ref (se->expr, offset, sym->ts.type == BT_CLASS ? ! NULL_TREE : sym->backend_decl, se->class_vptr, ! passed_span); } *************** gfc_array_allocate (gfc_se * se, gfc_exp *** 5464,5469 **** --- 5496,5502 ---- tree var_overflow = NULL_TREE; tree cond; tree set_descriptor; + tree span; stmtblock_t set_descriptor_block; stmtblock_t elseblock; gfc_expr **lower; *************** gfc_array_allocate (gfc_se * se, gfc_exp *** 5471,5476 **** --- 5504,5510 ---- gfc_ref *ref, *prev_ref = NULL, *coref; bool allocatable, coarray, dimension, alloc_w_e3_arr_spec = false, non_ulimate_coarray_ptr_comp; + bool is_pointer_array_comp_ref; ref = expr->ref; *************** gfc_array_allocate (gfc_se * se, gfc_exp *** 5478,5483 **** --- 5512,5520 ---- if (!retrieve_last_ref (&ref, &prev_ref)) return false; + is_pointer_array_comp_ref = gfc_pointer_array_comp_ref (expr, ref->u.ar.as, + &span); + /* Take the allocatable and coarray properties solely from the expr-ref's attributes and not from source=-expression. */ if (!prev_ref) *************** gfc_array_allocate (gfc_se * se, gfc_exp *** 5648,5654 **** --- 5685,5708 ---- if (dimension) gfc_conv_descriptor_offset_set (&set_descriptor_block, se->expr, offset); + /* Set the hidden 'span' field used to address the elements of a pointer + array component. */ + if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se->expr)) + && is_pointer_array_comp_ref + && TREE_CODE (se->expr) != VAR_DECL) + { + tmp = se->expr; + tmp = TREE_OPERAND (tmp, 0); + span = fold_build3_loc (input_location, COMPONENT_REF, + TREE_TYPE (span), tmp, + span, NULL_TREE); + tmp = TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (se->expr))); + gfc_add_modify (&set_descriptor_block, span, + fold_convert (TREE_TYPE (span), tmp)); + } + set_descriptor = gfc_finish_block (&set_descriptor_block); + if (status != NULL_TREE) { cond = fold_build2_loc (input_location, EQ_EXPR, *************** gfc_get_dataptr_offset (stmtblock_t *blo *** 6492,6498 **** return; } ! tmp = build_array_ref (desc, offset, NULL, NULL); /* Offset the data pointer for pointer assignments from arrays with subreferences; e.g. my_integer => my_type(:)%integer_component. */ --- 6546,6552 ---- return; } ! tmp = build_array_ref (desc, offset, NULL, NULL, NULL); /* Offset the data pointer for pointer assignments from arrays with subreferences; e.g. my_integer => my_type(:)%integer_component. */ Index: gcc/fortran/trans-expr.c =================================================================== *** gcc/fortran/trans-expr.c (revision 246903) --- gcc/fortran/trans-expr.c (working copy) *************** gfc_trans_pointer_assignment (gfc_expr * *** 8395,8411 **** } else if (expr2->expr_type == EXPR_VARIABLE) { /* Assign directly to the LHS's descriptor. */ lse.descriptor_only = 0; lse.direct_byref = 1; 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); --- 8395,8413 ---- } else if (expr2->expr_type == EXPR_VARIABLE) { + tree span = NULL_TREE; + /* Assign directly to the LHS's descriptor. */ lse.descriptor_only = 0; lse.direct_byref = 1; gfc_conv_expr_descriptor (&lse, expr2); strlen_rhs = lse.string_length; ! /* If this is a subreference array or component pointer assignment, ! use the rhs descriptor element size for the lhs span. */ ! if (expr1->symtree->n.sym->attr.subref_array_pointer ! || gfc_pointer_array_comp_ref (expr1, NULL, &span)) { gfc_init_se (&rse, NULL); rse.descriptor_only = 1; gfc_conv_expr (&rse, expr2); *************** gfc_trans_pointer_assignment (gfc_expr * *** 8413,8422 **** 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) { --- 8415,8439 ---- trans_class_vptr_len_assignment (&block, expr1, expr2, &rse, NULL, NULL); tmp = gfc_get_element_type (TREE_TYPE (rse.expr)); if (!INTEGER_CST_P (tmp)) gfc_add_block_to_block (&lse.post, &rse.pre); ! if (span != NULL_TREE) ! { ! decl = TREE_OPERAND (lse.expr, 0); ! span = fold_build3_loc (input_location, COMPONENT_REF, ! TREE_TYPE (span), decl, span, ! NULL_TREE); ! tmp = fold_convert (TREE_TYPE (span), ! size_in_bytes (tmp)); ! gfc_add_modify (&lse.post, span, tmp); ! } ! else ! { ! decl = expr1->symtree->n.sym->backend_decl; ! tmp = fold_convert (gfc_array_index_type, ! size_in_bytes (tmp)); ! gfc_add_modify (&lse.post, GFC_DECL_SPAN(decl), tmp); ! } } else if (expr1->ts.type == BT_CLASS) { Index: gcc/fortran/trans-io.c =================================================================== *** gcc/fortran/trans-io.c (revision 246903) --- gcc/fortran/trans-io.c (working copy) *************** gfc_trans_transfer (gfc_code * code) *** 2555,2561 **** if (!(gfc_bt_struct (expr->ts.type) || expr->ts.type == BT_CLASS) && ref && ref->next == NULL ! && !is_subref_array (expr)) { bool seen_vector = false; --- 2555,2562 ---- if (!(gfc_bt_struct (expr->ts.type) || expr->ts.type == BT_CLASS) && ref && ref->next == NULL ! && !is_subref_array (expr) ! && !gfc_pointer_array_comp_ref (expr, NULL, &tmp)) { bool seen_vector = false; Index: gcc/fortran/trans.c =================================================================== *** gcc/fortran/trans.c (revision 246903) --- gcc/fortran/trans.c (working copy) *************** gfc_build_addr_expr (tree type, tree t) *** 308,314 **** /* 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; --- 308,315 ---- /* Build an ARRAY_REF with its natural type. */ tree ! gfc_build_array_ref (tree base, tree offset, tree decl, tree vptr, ! tree passed_span) { tree type = TREE_TYPE (base); tree tmp; *************** gfc_build_array_ref (tree base, tree off *** 343,348 **** --- 344,351 ---- || DECL_CONTEXT (TYPE_MAXVAL (TYPE_DOMAIN (type))) == DECL_CONTEXT (decl))) span = TYPE_MAXVAL (TYPE_DOMAIN (type)); + else if (decl != NULL_TREE && passed_span != NULL_TREE) + span = passed_span; else span = NULL_TREE; *************** gfc_build_array_ref (tree base, tree off *** 362,368 **** && !integer_zerop (GFC_DECL_SPAN (decl))) || GFC_DECL_CLASS (decl) || span != NULL_TREE)) ! || vptr != NULL_TREE) { if (decl) { --- 365,372 ---- && !integer_zerop (GFC_DECL_SPAN (decl))) || GFC_DECL_CLASS (decl) || span != NULL_TREE)) ! || vptr != NULL_TREE ! || passed_span != NULL_TREE) { if (decl) { *************** gfc_build_array_ref (tree base, tree off *** 399,404 **** --- 403,410 ---- } else if (vptr) span = gfc_vptr_size_get (vptr); + else if (passed_span) + span = fold_convert (gfc_array_index_type, passed_span); else gcc_unreachable (); *************** gfc_likely (tree cond, enum br_predictor *** 2295,2313 **** } ! /* Get the string length for a deferred character length component. */ bool ! gfc_deferred_strlen (gfc_component *c, tree *decl) { ! char name[GFC_MAX_SYMBOL_LEN+9]; ! gfc_component *strlen; ! if (!(c->ts.type == BT_CHARACTER && c->ts.deferred)) return false; ! sprintf (name, "_%s_length", c->name); ! for (strlen = c; strlen; strlen = strlen->next) ! if (strcmp (strlen->name, name) == 0) ! break; ! *decl = strlen ? strlen->backend_decl : NULL_TREE; return strlen != NULL; } --- 2301,2365 ---- } ! /* Returns true if the expression is a reference to a pointer array ! component. The second argument is the backend decl for the hidden ! span component. */ bool ! gfc_pointer_array_comp_ref (gfc_expr *e, gfc_array_spec *as, tree *decl) { ! gfc_ref *ref; ! ! if (e->expr_type != EXPR_VARIABLE) return false; ! ! if (e->symtree->n.sym->ts.type != BT_DERIVED) ! return false; ! ! for (ref = e->ref; ref; ref = ref->next) ! { ! if (ref->type == REF_COMPONENT ! && ref->u.c.component->attr.pointer ! && ref->u.c.component->attr.dimension ! && (ref->u.c.component->as == as ! || as == NULL) ! && gfc_span_field (ref->u.c.component, decl)) ! return true; ! } ! ! return false; ! } ! ! ! /* Get the string length for a deferred character length component and ! the span of a pointer array component. */ ! ! static bool ! hidden_length_field (gfc_component *c, tree *decl, const char *postfix) ! { ! char name[GFC_MAX_SYMBOL_LEN+9]; ! gfc_component *strlen = NULL; ! if ((c->ts.type == BT_CHARACTER && c->ts.deferred) ! || (c->attr.pointer && c->attr.dimension)) ! { ! sprintf (name, "_%s_%s", c->name, postfix); ! for (strlen = c; strlen; strlen = strlen->next) ! if (strcmp (strlen->name, name) == 0) ! break; ! *decl = strlen ? strlen->backend_decl : NULL_TREE; ! } return strlen != NULL; } + + bool + gfc_deferred_strlen (gfc_component *c, tree *decl) + { + return hidden_length_field (c, decl, "length"); + } + + bool + gfc_span_field (gfc_component *c, tree *decl) + { + return hidden_length_field (c, decl, "span"); + } + Index: gcc/fortran/trans.h =================================================================== *** gcc/fortran/trans.h (revision 246903) --- gcc/fortran/trans.h (working copy) *************** tree gfc_get_function_decl (gfc_symbol * *** 587,593 **** tree gfc_build_addr_expr (tree, tree); /* Build an ARRAY_REF. */ ! tree gfc_build_array_ref (tree, tree, tree, tree vptr = NULL_TREE); /* Creates a label. Decl is artificial if label_id == NULL_TREE. */ tree gfc_build_label_decl (tree); --- 587,594 ---- tree gfc_build_addr_expr (tree, tree); /* Build an ARRAY_REF. */ ! tree gfc_build_array_ref (tree, tree, tree, tree vptr = NULL_TREE, ! tree passed_span = NULL_TREE); /* Creates a label. Decl is artificial if label_id == NULL_TREE. */ tree gfc_build_label_decl (tree); *************** bool get_array_ctor_strlen (stmtblock_t *** 683,691 **** --- 684,699 ---- tree gfc_likely (tree, enum br_predictor); tree gfc_unlikely (tree, enum br_predictor); + /* Return the backend decl for the hidden span and true if this is a + pointer array component. */ + bool gfc_pointer_array_comp_ref (gfc_expr *, gfc_array_spec *, tree *); + /* Return the string length of a deferred character length component. */ bool gfc_deferred_strlen (gfc_component *, tree *); + /* Return the span of a pointer array component. */ + bool gfc_span_field (gfc_component *, tree *); + /* Generate a runtime error call. */ tree gfc_trans_runtime_error (bool, locus*, const char*, ...); 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