Dear All,
This is not a fix for the original PR but for the specific case of
pointer array components of derived types that point to components of
arrays of derived types. The original case involving pointer arrays
being passed as actual arguments remains to be done.
The fix is straightforward and reuses the mechanism for deferred
character length components, where a hidden length field is added to
the derived type. Here there is a hidden 'span' component.
The Changelogs and the patch say it all.
I am aware that this is not timely but undertake to remove the patch
if any regressions appear.
Bootstrapped and regtested on FC23/x86_64 - OK for trunk?
Cheers
Paul
2017-04-08 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-08 Paul Thomas <pa...@gcc.gnu.org>
PR fortran/34640
* gfortran.dg/pointer_array_component_1.f90: New test.
--
"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 246783)
--- gcc/fortran/expr.c (working copy)
*************** gfc_check_pointer_assign (gfc_expr *lval
*** 3717,3723 ****
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);
--- 3717,3726 ----
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
*** 5488,5490 ****
--- 5491,5514 ----
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 246783)
--- 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 246783)
--- 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 246783)
--- 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, &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, &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
*** 5648,5654 ****
--- 5681,5703 ----
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))
+ && gfc_pointer_array_comp_ref (expr, &span)
+ && TREE_CODE (se->expr) != VAR_DECL)
+ {
+ tmp = TREE_OPERAND (se->expr, 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. */
--- 6541,6547 ----
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 246783)
--- 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, &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 246783)
--- 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, &tmp))
{
bool seen_vector = false;
Index: gcc/fortran/trans.c
===================================================================
*** gcc/fortran/trans.c (revision 246783)
--- 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,2363 ----
}
! /* 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, 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
! && 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 246783)
--- 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 *, 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
