[Patch, fortran] PR34360 (Comment 28) - ICE when assigning item of a derived-component to a pointer
Paul Richard Thomas
paul.richard.thomas@gmail.com
Thu Apr 13 18:27:00 GMT 2017
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 <pault@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 <pault@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 <dominiq@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 <dominiq@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
-------------- next part --------------
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
More information about the Fortran
mailing list