This is the mail archive of the
gcc-patches@gcc.gnu.org
mailing list for the GCC project.
Re: [Patch, fortran] PR29396 PR29606 PR30625 and PR30871 - subreference array pointers.
- From: Paul Thomas <paulthomas2 at wanadoo dot fr>
- To: Fortran List <fortran at gcc dot gnu dot org>, gcc-patches <gcc-patches at gcc dot gnu dot org>, Paul Brook <paul at codesourcery dot com>, Tobias Burnus <burnus at net-b dot de>, FX Coudert <fxcoudert at gmail dot com>
- Date: Sat, 15 Sep 2007 16:26:30 +0200
- Subject: Re: [Patch, fortran] PR29396 PR29606 PR30625 and PR30871 - subreference array pointers.
- References: <46E43421.4010605@wanadoo.fr>
Well, here at last is the resubmission. It cures all the problems that
were identified by Tobias and FX and more besides.....
This is a first stab at fixing these beasts. I would be the first to
admit that this might not be the most efficient way of going about
the job but it does leave the rest of gfortran's functionality
untouched. Also, the patch is incomplete. Pointer references to
substrings of components of arrays of derived types do not work and,
without having tried it, I am sure that WHERE and FORALL masks will do
odd things if they are such pointers. The former is something that I
will work on right away, after writing a PR, and the latter is a
longer term TODO.
Pointer references to substrings of components of arrays of derived
types now work fine. The WHERE and FORALL masks remain as TODOs.
In addition to substrings, I fixed a problem that came up with full
array references and subreferences that included an array element. This
latter is lacking any bounds checking, which is indicated as a TODO.
One reason for this was my surprise at not finding a helper function
that did this array reference for me - ie. where the descriptor is not
available and the strides have to be built up. If there is already a
function to do this, could somebody point me to it, please?
The patch functions by adding a 'span' field to the lang_decl
structure, which stores the size of the target array elements. The
rhs of a pointer assignment is converted to a descriptor, whose data
pointer is to the subreference of the first element of the array.
gfc_build_array_ref has then been modified to take a look at the
declaration for the array; if it is a pointer to a subreference array,
the offset is calculated in bytes and the element extracted by
explicit pointer arithmetic. The treatment of these pointers as
actual arguments is very conservative - they are always
copy-in/copy-out. Doubtless cleverer things can be done in the
fullness of time.
At present, very few references to gfc_build_array_ref have been
updated to supply the variable declaration. However, these are
sufficient to provide the basic functionality. I am rather sure that
the problem with substrings of components, mentioned above, lies in
resolve.c. However, I just do not have time to deal with it now.
The mention of resolve.c turned out to be wrong. I had handled
substrings completely incorrectly.
The testcase is an amalgam of the PR testcases, together with some
testing that the target is modified as it should be and that various
forms of pointer reference work correctly.
The first testcase contains all four PR testcases, whilst the second
exercises the functionality quite thoroughly; tests are made that not
only does the pointer reference the right values but, when it is
assigned to, only the pointed to parts of the target are changed. Also,
what was an issue in the first patch is checked: The
subref_array_pointer needs to be checked that it functions as an
ordinary pointer too!
It is my opinion that this patch is ready for 4.3 simply because it
provides an extra functionality that is ringfenced by specific tests.
Such pointer assignements, at present, either lead to ICEs or wrong
code. Hence, even if it is not in its final form, it will not break
anything, whilst filling in the missing f95 feature.
I think that this is more true than ever, since it is now more or less
fully functioning.
Bootstrapped and regtested on x86_ia64/FC5 - OK for trunk?
Paul
2007-09-15 Paul Thomas <pault@gcc.gnu.org>
PR fortran/29396
PR fortran/29606
PR fortran/30625
PR fortran/30871
* trans.h : Add extra argument to gfc_build_array_ref. Rename
gfc_conv_aliased_arg to gfc_conv_subref_array_arg. Move
prototype of is_aliased_array to gfortran.h and rename it
gfc_is_subref_array. Add field span to lang_decl, add a new
decl lang specific flag accessed by GFC_DECL_SUBREF_ARRAY_P
and a new type flag GFC_DECL_SUBREF_ARRAY_P.
* trans.c (gfc_build_array_ref): Add the new argument, decl.
If this is a subreference array pointer, use the lang_decl
field 'span' to claculate the offset in bytes and use pointer
arithmetic to address the element.
* trans-array.c (gfc_conv_scalarized_array_ref,
gfc_conv_array_ref): Add the backend declaration as the third
field, if it is likely to be a subreference array pointer.
(gfc_conv_descriptor_dimension, gfc_trans_array_ctor_element,
gfc_trans_array_constructor_element, structure_alloc_comps,
gfc_conv_array_index_offset): For all other references to
gfc_build_array_ref, set the third argument to NULL.
(gfc_get_dataptr_offset): New function.
(gfc_conv_expr_descriptor): If the rhs of a pointer assignment
is a subreference array, then calculate the offset to the
subreference of the first element and set the descriptor data
pointer to this, using gfc_get_dataptr_offset.
trans-expr.c (gfc_get_expr_charlen): Use the expression for the
character length for a character subreference.
(gfc_conv_substring, gfc_conv_subref_array_arg): Add NULL for
third argument in call to gfc_build_array_ref.
(gfc_conv_aliased_arg): Rename to gfc_conv_subref_array_arg.
(is_aliased_array): Remove.
(gfc_conv_function_call): Change reference to is_aliased_array
to gfc_is_subref_array and reference to gfc_conv_aliased_arg to
gfc_conv_subref_array_arg.
(gfc_trans_pointer_assignment): Add the array element length to
the lang_decl 'span' field.
* gfortran.h : Add subref_array_pointer to symbol_attribute and
add the prototype for gfc_is_subref_array.
* trans-stmt.c : Add NULL for third argument in all references
to gfc_build_array_ref.
* expr.c (gfc_is_subref_array): Renamed is_aliased_array.
If this is a subreference array pointer, return true.
(gfc_check_pointer_assign): If the rhs is a subreference array,
set the lhs subreference_array_pointer attribute.
* trans-decl.c (gfc_get_symbol_decl): Allocate the lang_decl
field if the symbol is a subreference array pointer and set an
initial value of zero for the 'span' field.
* trans-io.c (set_internal_unit): Refer to is_subref_array and
gfc_conv_subref_array_arg.
(nml_get_addr_expr): Add NULL third argument to
gfc_build_array_ref.
(gfc_trans_transfer): Use the scalarizer for a subreference
array.
2007-09-15 Paul Thomas <pault@gcc.gnu.org>
PR fortran/29396
PR fortran/29606
PR fortran/30625
PR fortran/30871
* gfortran.dg/subref_array_pointer_1.f90: New test.
* gfortran.dg/subref_array_pointer_2.f90: New test.
Index: gcc/fortran/trans-array.c
===================================================================
*** gcc/fortran/trans-array.c (revision 128437)
--- gcc/fortran/trans-array.c (working copy)
*************** gfc_conv_descriptor_dimension (tree desc
*** 245,251 ****
&& TREE_CODE (TREE_TYPE (TREE_TYPE (field))) == RECORD_TYPE);
tmp = build3 (COMPONENT_REF, TREE_TYPE (field), desc, field, NULL_TREE);
! tmp = gfc_build_array_ref (tmp, dim);
return tmp;
}
--- 245,251 ----
&& TREE_CODE (TREE_TYPE (TREE_TYPE (field))) == RECORD_TYPE);
tmp = build3 (COMPONENT_REF, TREE_TYPE (field), desc, field, NULL_TREE);
! tmp = gfc_build_array_ref (tmp, dim, NULL);
return tmp;
}
*************** gfc_trans_array_ctor_element (stmtblock_
*** 961,967 ****
/* Store the value. */
tmp = build_fold_indirect_ref (gfc_conv_descriptor_data_get (desc));
! tmp = gfc_build_array_ref (tmp, offset);
if (expr->ts.type == BT_CHARACTER)
{
gfc_conv_string_parameter (se);
--- 961,967 ----
/* Store the value. */
tmp = build_fold_indirect_ref (gfc_conv_descriptor_data_get (desc));
! tmp = gfc_build_array_ref (tmp, offset, NULL);
if (expr->ts.type == BT_CHARACTER)
{
gfc_conv_string_parameter (se);
*************** gfc_trans_array_constructor_value (stmtb
*** 1181,1187 ****
/* Use BUILTIN_MEMCPY to assign the values. */
tmp = gfc_conv_descriptor_data_get (desc);
tmp = build_fold_indirect_ref (tmp);
! tmp = gfc_build_array_ref (tmp, *poffset);
tmp = build_fold_addr_expr (tmp);
init = build_fold_addr_expr (init);
--- 1181,1187 ----
/* Use BUILTIN_MEMCPY to assign the values. */
tmp = gfc_conv_descriptor_data_get (desc);
tmp = build_fold_indirect_ref (tmp);
! tmp = gfc_build_array_ref (tmp, *poffset, NULL);
tmp = build_fold_addr_expr (tmp);
init = build_fold_addr_expr (init);
*************** gfc_conv_array_index_offset (gfc_se * se
*** 2167,2173 ****
/* Read the vector to get an index into info->descriptor. */
data = build_fold_indirect_ref (gfc_conv_array_data (desc));
! index = gfc_build_array_ref (data, index);
index = gfc_evaluate_now (index, &se->pre);
/* Do any bounds checking on the final info->descriptor index. */
--- 2167,2173 ----
/* Read the vector to get an index into info->descriptor. */
data = build_fold_indirect_ref (gfc_conv_array_data (desc));
! index = gfc_build_array_ref (data, index, NULL);
index = gfc_evaluate_now (index, &se->pre);
/* Do any bounds checking on the final info->descriptor index. */
*************** static void
*** 2219,2224 ****
--- 2219,2225 ----
gfc_conv_scalarized_array_ref (gfc_se * se, gfc_array_ref * ar)
{
gfc_ss_info *info;
+ tree decl = NULL_TREE;
tree index;
tree tmp;
int n;
*************** gfc_conv_scalarized_array_ref (gfc_se *
*** 2236,2243 ****
if (!integer_zerop (info->offset))
index = fold_build2 (PLUS_EXPR, gfc_array_index_type, index, info->offset);
tmp = build_fold_indirect_ref (info->data);
! se->expr = gfc_build_array_ref (tmp, index);
}
--- 2237,2247 ----
if (!integer_zerop (info->offset))
index = fold_build2 (PLUS_EXPR, gfc_array_index_type, index, info->offset);
+ if (se->ss->expr && is_subref_array (se->ss->expr))
+ decl = se->ss->expr->symtree->n.sym->backend_decl;
+
tmp = build_fold_indirect_ref (info->data);
! se->expr = gfc_build_array_ref (tmp, index, decl);
}
*************** gfc_conv_array_ref (gfc_se * se, gfc_arr
*** 2338,2348 ****
tmp = gfc_conv_array_offset (se->expr);
if (!integer_zerop (tmp))
index = fold_build2 (PLUS_EXPR, gfc_array_index_type, index, tmp);
!
/* Access the calculated element. */
tmp = gfc_conv_array_data (se->expr);
tmp = build_fold_indirect_ref (tmp);
! se->expr = gfc_build_array_ref (tmp, index);
}
--- 2342,2352 ----
tmp = gfc_conv_array_offset (se->expr);
if (!integer_zerop (tmp))
index = fold_build2 (PLUS_EXPR, gfc_array_index_type, index, tmp);
!
/* Access the calculated element. */
tmp = gfc_conv_array_data (se->expr);
tmp = build_fold_indirect_ref (tmp);
! se->expr = gfc_build_array_ref (tmp, index, sym->backend_decl);
}
*************** gfc_trans_dummy_array_bias (gfc_symbol *
*** 4336,4341 ****
--- 4340,4455 ----
}
+ /* Calculate the overall offset, including subreferences. */
+ static void
+ gfc_get_dataptr_offset (stmtblock_t *block, tree parm, tree desc, tree offset,
+ bool subref, gfc_expr *expr)
+ {
+ tree tmp;
+ tree field;
+ tree stride;
+ tree index;
+ gfc_ref *ref;
+ gfc_se start;
+ int n;
+
+ /* If offset is NULL and this is not a subreferenced array, there is
+ nothing to do. */
+ if (offset == NULL_TREE)
+ {
+ if (subref)
+ offset = gfc_index_zero_node;
+ else
+ return;
+ }
+
+ tmp = gfc_conv_array_data (desc);
+ tmp = build_fold_indirect_ref (tmp);
+ tmp = gfc_build_array_ref (tmp, offset, NULL);
+
+ /* Offset the data pointer for pointer assignments from arrays with
+ subreferences; eg. my_integer => my_type(:)%integer_component. */
+ if (subref)
+ {
+ /* Go past the array reference. */
+ for (ref = expr->ref; ref; ref = ref->next)
+ if (ref->type == REF_ARRAY &&
+ ref->u.ar.type != AR_ELEMENT)
+ {
+ ref = ref->next;
+ break;
+ }
+
+ /* Calculate the offset for each subsequent subreference. */
+ for (; ref; ref = ref->next)
+ {
+ switch (ref->type)
+ {
+ case REF_COMPONENT:
+ field = ref->u.c.component->backend_decl;
+ gcc_assert (field && TREE_CODE (field) == FIELD_DECL);
+ tmp = build3 (COMPONENT_REF, TREE_TYPE (field), tmp, field, NULL_TREE);
+ break;
+
+ case REF_SUBSTRING:
+ gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE);
+ gfc_init_se (&start, NULL);
+ gfc_conv_expr_type (&start, ref->u.ss.start, gfc_charlen_type_node);
+ gfc_add_block_to_block (block, &start.pre);
+ tmp = gfc_build_array_ref (tmp, start.expr, NULL);
+ break;
+
+ case REF_ARRAY:
+ gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE
+ && ref->u.ar.type == AR_ELEMENT);
+
+ /* TODO - Add bounds checking. */
+ stride = gfc_index_one_node;
+ index = gfc_index_zero_node;
+ for (n = 0; n < ref->u.ar.dimen; n++)
+ {
+ tree itmp;
+ tree jtmp;
+
+ /* Update the index. */
+ gfc_init_se (&start, NULL);
+ gfc_conv_expr_type (&start, ref->u.ar.start[n], gfc_array_index_type);
+ itmp = gfc_evaluate_now (start.expr, block);
+ gfc_init_se (&start, NULL);
+ gfc_conv_expr_type (&start, ref->u.ar.as->lower[n], gfc_array_index_type);
+ jtmp = gfc_evaluate_now (start.expr, block);
+ itmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, itmp, jtmp);
+ itmp = fold_build2 (MULT_EXPR, gfc_array_index_type, itmp, stride);
+ index = fold_build2 (PLUS_EXPR, gfc_array_index_type, itmp, index);
+ index = gfc_evaluate_now (index, block);
+
+ /* Update the stride. */
+ gfc_init_se (&start, NULL);
+ gfc_conv_expr_type (&start, ref->u.ar.as->upper[n], gfc_array_index_type);
+ itmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, start.expr, jtmp);
+ itmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
+ gfc_index_one_node, itmp);
+ stride = fold_build2 (MULT_EXPR, gfc_array_index_type, stride, itmp);
+ stride = gfc_evaluate_now (stride, block);
+ }
+
+ /* Apply the index to obtain the array element. */
+ tmp = gfc_build_array_ref (tmp, index, NULL);
+ break;
+
+ default:
+ gcc_unreachable ();
+ break;
+ }
+ }
+ }
+
+ /* Set the target data pointer. */
+ offset = gfc_build_addr_expr (gfc_array_dataptr_type (desc), tmp);
+ gfc_conv_descriptor_data_set (block, parm, offset);
+ }
+
+
/* Convert an array for passing as an actual argument. Expressions and
vector subscripts are evaluated and stored in a temporary, which is then
passed. For whole arrays the descriptor is passed. For array sections
*************** gfc_conv_expr_descriptor (gfc_se * se, g
*** 4373,4378 ****
--- 4487,4493 ----
tree start;
tree offset;
int full;
+ bool subref_array_target = false;
gcc_assert (ss != gfc_ss_terminator);
*************** gfc_conv_expr_descriptor (gfc_se * se, g
*** 4395,4401 ****
gfc_conv_ss_descriptor (&se->pre, secss, 0);
desc = info->descriptor;
! need_tmp = gfc_ref_needs_temporary_p (expr->ref);
if (need_tmp)
full = 0;
else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
--- 4510,4519 ----
gfc_conv_ss_descriptor (&se->pre, secss, 0);
desc = info->descriptor;
! subref_array_target = se->direct_byref && is_subref_array (expr);
! need_tmp = gfc_ref_needs_temporary_p (expr->ref)
! && !subref_array_target;
!
if (need_tmp)
full = 0;
else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
*************** gfc_conv_expr_descriptor (gfc_se * se, g
*** 4416,4421 ****
--- 4534,4543 ----
{
/* Copy the descriptor for pointer assignments. */
gfc_add_modify_expr (&se->pre, se->expr, desc);
+
+ /* Add any offsets from subreferences. */
+ gfc_get_dataptr_offset (&se->pre, se->expr, desc, NULL_TREE,
+ subref_array_target, expr);
}
else if (se->want_pointer)
{
*************** gfc_conv_expr_descriptor (gfc_se * se, g
*** 4742,4755 ****
if (se->data_not_needed)
gfc_conv_descriptor_data_set (&loop.pre, parm, gfc_index_zero_node);
else
! {
! /* Point the data pointer at the first element in the section. */
! tmp = gfc_conv_array_data (desc);
! tmp = build_fold_indirect_ref (tmp);
! tmp = gfc_build_array_ref (tmp, offset);
! offset = gfc_build_addr_expr (gfc_array_dataptr_type (desc), tmp);
! gfc_conv_descriptor_data_set (&loop.pre, parm, offset);
! }
if ((se->direct_byref || GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
&& !se->data_not_needed)
--- 4864,4872 ----
if (se->data_not_needed)
gfc_conv_descriptor_data_set (&loop.pre, parm, gfc_index_zero_node);
else
! /* Point the data pointer at the first element in the section. */
! gfc_get_dataptr_offset (&loop.pre, parm, desc, offset,
! subref_array_target, expr);
if ((se->direct_byref || GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
&& !se->data_not_needed)
*************** structure_alloc_comps (gfc_symbol * der_
*** 5082,5088 ****
/* Build the body of the loop. */
gfc_init_block (&loopbody);
! vref = gfc_build_array_ref (var, index);
if (purpose == COPY_ALLOC_COMP)
{
--- 5199,5205 ----
/* Build the body of the loop. */
gfc_init_block (&loopbody);
! vref = gfc_build_array_ref (var, index, NULL);
if (purpose == COPY_ALLOC_COMP)
{
*************** structure_alloc_comps (gfc_symbol * der_
*** 5090,5096 ****
gfc_add_expr_to_block (&fnblock, tmp);
tmp = build_fold_indirect_ref (gfc_conv_descriptor_data_get (dest));
! dref = gfc_build_array_ref (tmp, index);
tmp = structure_alloc_comps (der_type, vref, dref, rank, purpose);
}
else
--- 5207,5213 ----
gfc_add_expr_to_block (&fnblock, tmp);
tmp = build_fold_indirect_ref (gfc_conv_descriptor_data_get (dest));
! dref = gfc_build_array_ref (tmp, index, NULL);
tmp = structure_alloc_comps (der_type, vref, dref, rank, purpose);
}
else
Index: gcc/fortran/trans-expr.c
===================================================================
*** gcc/fortran/trans-expr.c (revision 128437)
--- gcc/fortran/trans-expr.c (working copy)
*************** gfc_get_expr_charlen (gfc_expr *e)
*** 183,188 ****
--- 183,197 ----
length = NULL; /* To silence compiler warning. */
+ if (is_subref_array (e) && e->ts.cl->length)
+ {
+ gfc_se tmpse;
+ gfc_init_se (&tmpse, NULL);
+ gfc_conv_expr_type (&tmpse, e->ts.cl->length, gfc_charlen_type_node);
+ e->ts.cl->backend_decl = tmpse.expr;
+ return tmpse.expr;
+ }
+
/* First candidate: if the variable is of type CHARACTER, the
expression's length could be the length of the character
variable. */
*************** gfc_get_expr_charlen (gfc_expr *e)
*** 207,212 ****
--- 216,222 ----
/* We should never got substring references here. These will be
broken down by the scalarizer. */
gcc_unreachable ();
+ break;
}
}
*************** gfc_conv_substring (gfc_se * se, gfc_ref
*** 270,276 ****
tmp = se->expr;
else
tmp = build_fold_indirect_ref (se->expr);
! tmp = gfc_build_array_ref (tmp, start.expr);
se->expr = gfc_build_addr_expr (type, tmp);
}
--- 280,286 ----
tmp = se->expr;
else
tmp = build_fold_indirect_ref (se->expr);
! tmp = gfc_build_array_ref (tmp, start.expr, NULL);
se->expr = gfc_build_addr_expr (type, tmp);
}
*************** gfc_apply_interface_mapping (gfc_interfa
*** 1782,1796 ****
gfc_free_expr (expr);
}
/* Returns a reference to a temporary array into which a component of
an actual argument derived type array is copied and then returned
! after the function call.
! TODO Get rid of this kludge, when array descriptors are capable of
! handling arrays with a bigger stride in bytes than size. */
!
void
! gfc_conv_aliased_arg (gfc_se * parmse, gfc_expr * expr,
! int g77, sym_intent intent)
{
gfc_se lse;
gfc_se rse;
--- 1792,1804 ----
gfc_free_expr (expr);
}
+
/* Returns a reference to a temporary array into which a component of
an actual argument derived type array is copied and then returned
! after the function call. */
void
! gfc_conv_subref_array_arg (gfc_se * parmse, gfc_expr * expr,
! int g77, sym_intent intent)
{
gfc_se lse;
gfc_se rse;
*************** gfc_conv_aliased_arg (gfc_se * parmse, g
*** 1962,1968 ****
/* Now use the offset for the reference. */
tmp = build_fold_indirect_ref (info->data);
! rse.expr = gfc_build_array_ref (tmp, tmp_index);
if (expr->ts.type == BT_CHARACTER)
rse.string_length = expr->ts.cl->backend_decl;
--- 1970,1976 ----
/* Now use the offset for the reference. */
tmp = build_fold_indirect_ref (info->data);
! rse.expr = gfc_build_array_ref (tmp, tmp_index, NULL);
if (expr->ts.type == BT_CHARACTER)
rse.string_length = expr->ts.cl->backend_decl;
*************** gfc_conv_aliased_arg (gfc_se * parmse, g
*** 2005,2032 ****
return;
}
- /* Is true if an array reference is followed by a component or substring
- reference. */
-
- bool
- is_aliased_array (gfc_expr * e)
- {
- gfc_ref * ref;
- bool seen_array;
-
- seen_array = false;
- for (ref = e->ref; ref; ref = ref->next)
- {
- if (ref->type == REF_ARRAY
- && ref->u.ar.type != AR_ELEMENT)
- seen_array = true;
-
- if (seen_array
- && ref->type != REF_ARRAY)
- return seen_array;
- }
- return false;
- }
/* Generate the code for argument list functions. */
--- 2013,2018 ----
*************** gfc_conv_function_call (gfc_se * se, gfc
*** 2256,2267 ****
f = f || !sym->attr.always_explicit;
if (e->expr_type == EXPR_VARIABLE
! && is_aliased_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
written back after the procedure call. */
! gfc_conv_aliased_arg (&parmse, e, f,
fsym ? fsym->attr.intent : INTENT_INOUT);
else
gfc_conv_array_parameter (&parmse, e, argss, f);
--- 2242,2253 ----
f = f || !sym->attr.always_explicit;
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
written back after the procedure call. */
! gfc_conv_subref_array_arg (&parmse, e, f,
fsym ? fsym->attr.intent : INTENT_INOUT);
else
gfc_conv_array_parameter (&parmse, e, argss, f);
*************** gfc_trans_pointer_assignment (gfc_expr *
*** 3471,3476 ****
--- 3457,3464 ----
stmtblock_t block;
tree desc;
tree tmp;
+ tree decl;
+
gfc_start_block (&block);
*************** gfc_trans_pointer_assignment (gfc_expr *
*** 3509,3514 ****
--- 3497,3515 ----
/* Assign directly to the pointer's descriptor. */
lse.direct_byref = 1;
gfc_conv_expr_descriptor (&lse, expr2, rss);
+
+ /* If this is a subreference array pointer assignment, use the rhs
+ element size for the lhs span. */
+ if (expr1->symtree->n.sym->attr.subref_array_pointer)
+ {
+ decl = expr1->symtree->n.sym->backend_decl;
+ tmp = rss->data.info.descriptor;
+ tmp = gfc_get_element_type (TREE_TYPE (tmp));
+ tmp = size_in_bytes (tmp);
+ tmp = fold_convert (gfc_array_index_type, tmp);
+ gfc_add_modify_expr (&lse.post, GFC_DECL_SPAN(decl), tmp);
+ }
+
break;
default:
Index: gcc/fortran/gfortran.h
===================================================================
*** gcc/fortran/gfortran.h (revision 128437)
--- gcc/fortran/gfortran.h (working copy)
*************** typedef struct
*** 578,584 ****
unsigned allocatable:1, dimension:1, external:1, intrinsic:1,
optional:1, pointer:1, target:1, value:1, volatile_:1,
dummy:1, result:1, assign:1, threadprivate:1, not_always_present:1,
! implied_index:1;
ENUM_BITFIELD (save_state) save:2;
--- 578,584 ----
unsigned allocatable:1, dimension:1, external:1, intrinsic:1,
optional:1, pointer:1, target:1, value:1, volatile_:1,
dummy:1, result:1, assign:1, threadprivate:1, not_always_present:1,
! implied_index:1, subref_array_pointer:1;
ENUM_BITFIELD (save_state) save:2;
*************** void gfc_free_actual_arglist (gfc_actual
*** 2172,2177 ****
--- 2172,2178 ----
gfc_actual_arglist *gfc_copy_actual_arglist (gfc_actual_arglist *);
const char *gfc_extract_int (gfc_expr *, int *);
gfc_expr *gfc_expr_to_initialize (gfc_expr *);
+ bool is_subref_array (gfc_expr *);
gfc_expr *gfc_build_conversion (gfc_expr *);
void gfc_free_ref_list (gfc_ref *);
Index: gcc/fortran/trans-stmt.c
===================================================================
*** gcc/fortran/trans-stmt.c (revision 128437)
--- gcc/fortran/trans-stmt.c (working copy)
*************** gfc_trans_nested_forall_loop (forall_inf
*** 1650,1656 ****
/* If a mask was specified make the assignment conditional. */
if (mask)
{
! tmp = gfc_build_array_ref (mask, maskindex);
body = build3_v (COND_EXPR, tmp, body, build_empty_stmt ());
}
}
--- 1650,1656 ----
/* If a mask was specified make the assignment conditional. */
if (mask)
{
! tmp = gfc_build_array_ref (mask, maskindex, NULL);
body = build3_v (COND_EXPR, tmp, body, build_empty_stmt ());
}
}
*************** generate_loop_for_temp_to_lhs (gfc_expr
*** 1729,1735 ****
gfc_conv_expr (&lse, expr);
/* Form the expression for the temporary. */
! tmp = gfc_build_array_ref (tmp1, count1);
/* Use the scalar assignment as is. */
gfc_add_block_to_block (&block, &lse.pre);
--- 1729,1735 ----
gfc_conv_expr (&lse, expr);
/* Form the expression for the temporary. */
! tmp = gfc_build_array_ref (tmp1, count1, NULL);
/* Use the scalar assignment as is. */
gfc_add_block_to_block (&block, &lse.pre);
*************** generate_loop_for_temp_to_lhs (gfc_expr
*** 1770,1776 ****
/* Form the expression of the temporary. */
if (lss != gfc_ss_terminator)
! rse.expr = gfc_build_array_ref (tmp1, count1);
/* Translate expr. */
gfc_conv_expr (&lse, expr);
--- 1770,1776 ----
/* Form the expression of the temporary. */
if (lss != gfc_ss_terminator)
! rse.expr = gfc_build_array_ref (tmp1, count1, NULL);
/* Translate expr. */
gfc_conv_expr (&lse, expr);
*************** generate_loop_for_temp_to_lhs (gfc_expr
*** 1781,1787 ****
/* Form the mask expression according to the mask tree list. */
if (wheremask)
{
! wheremaskexpr = gfc_build_array_ref (wheremask, count3);
if (invert)
wheremaskexpr = fold_build1 (TRUTH_NOT_EXPR,
TREE_TYPE (wheremaskexpr),
--- 1781,1787 ----
/* Form the mask expression according to the mask tree list. */
if (wheremask)
{
! wheremaskexpr = gfc_build_array_ref (wheremask, count3, NULL);
if (invert)
wheremaskexpr = fold_build1 (TRUTH_NOT_EXPR,
TREE_TYPE (wheremaskexpr),
*************** generate_loop_for_rhs_to_temp (gfc_expr
*** 1843,1849 ****
{
gfc_init_block (&body1);
gfc_conv_expr (&rse, expr2);
! lse.expr = gfc_build_array_ref (tmp1, count1);
}
else
{
--- 1843,1849 ----
{
gfc_init_block (&body1);
gfc_conv_expr (&rse, expr2);
! lse.expr = gfc_build_array_ref (tmp1, count1, NULL);
}
else
{
*************** generate_loop_for_rhs_to_temp (gfc_expr
*** 1867,1873 ****
gfc_conv_expr (&rse, expr2);
/* Form the expression of the temporary. */
! lse.expr = gfc_build_array_ref (tmp1, count1);
}
/* Use the scalar assignment. */
--- 1867,1873 ----
gfc_conv_expr (&rse, expr2);
/* Form the expression of the temporary. */
! lse.expr = gfc_build_array_ref (tmp1, count1, NULL);
}
/* Use the scalar assignment. */
*************** generate_loop_for_rhs_to_temp (gfc_expr
*** 1878,1884 ****
/* Form the mask expression according to the mask tree list. */
if (wheremask)
{
! wheremaskexpr = gfc_build_array_ref (wheremask, count3);
if (invert)
wheremaskexpr = fold_build1 (TRUTH_NOT_EXPR,
TREE_TYPE (wheremaskexpr),
--- 1878,1884 ----
/* Form the mask expression according to the mask tree list. */
if (wheremask)
{
! wheremaskexpr = gfc_build_array_ref (wheremask, count3, NULL);
if (invert)
wheremaskexpr = fold_build1 (TRUTH_NOT_EXPR,
TREE_TYPE (wheremaskexpr),
*************** gfc_trans_pointer_assign_need_temp (gfc_
*** 2251,2257 ****
inner_size, NULL, block, &ptemp1);
gfc_start_block (&body);
gfc_init_se (&lse, NULL);
! lse.expr = gfc_build_array_ref (tmp1, count);
gfc_init_se (&rse, NULL);
rse.want_pointer = 1;
gfc_conv_expr (&rse, expr2);
--- 2251,2257 ----
inner_size, NULL, block, &ptemp1);
gfc_start_block (&body);
gfc_init_se (&lse, NULL);
! lse.expr = gfc_build_array_ref (tmp1, count, NULL);
gfc_init_se (&rse, NULL);
rse.want_pointer = 1;
gfc_conv_expr (&rse, expr2);
*************** gfc_trans_pointer_assign_need_temp (gfc_
*** 2278,2284 ****
gfc_start_block (&body);
gfc_init_se (&lse, NULL);
gfc_init_se (&rse, NULL);
! rse.expr = gfc_build_array_ref (tmp1, count);
lse.want_pointer = 1;
gfc_conv_expr (&lse, expr1);
gfc_add_block_to_block (&body, &lse.pre);
--- 2278,2284 ----
gfc_start_block (&body);
gfc_init_se (&lse, NULL);
gfc_init_se (&rse, NULL);
! rse.expr = gfc_build_array_ref (tmp1, count, NULL);
lse.want_pointer = 1;
gfc_conv_expr (&lse, expr1);
gfc_add_block_to_block (&body, &lse.pre);
*************** gfc_trans_pointer_assign_need_temp (gfc_
*** 2320,2326 ****
inner_size, NULL, block, &ptemp1);
gfc_start_block (&body);
gfc_init_se (&lse, NULL);
! lse.expr = gfc_build_array_ref (tmp1, count);
lse.direct_byref = 1;
rss = gfc_walk_expr (expr2);
gfc_conv_expr_descriptor (&lse, expr2, rss);
--- 2320,2326 ----
inner_size, NULL, block, &ptemp1);
gfc_start_block (&body);
gfc_init_se (&lse, NULL);
! lse.expr = gfc_build_array_ref (tmp1, count, NULL);
lse.direct_byref = 1;
rss = gfc_walk_expr (expr2);
gfc_conv_expr_descriptor (&lse, expr2, rss);
*************** gfc_trans_pointer_assign_need_temp (gfc_
*** 2343,2349 ****
/* Reset count. */
gfc_add_modify_expr (block, count, gfc_index_zero_node);
! parm = gfc_build_array_ref (tmp1, count);
lss = gfc_walk_expr (expr1);
gfc_init_se (&lse, NULL);
gfc_conv_expr_descriptor (&lse, expr1, lss);
--- 2343,2349 ----
/* Reset count. */
gfc_add_modify_expr (block, count, gfc_index_zero_node);
! parm = gfc_build_array_ref (tmp1, count, NULL);
lss = gfc_walk_expr (expr1);
gfc_init_se (&lse, NULL);
gfc_conv_expr_descriptor (&lse, expr1, lss);
*************** gfc_trans_forall_1 (gfc_code * code, for
*** 2596,2602 ****
/* Store the mask. */
se.expr = convert (mask_type, se.expr);
! tmp = gfc_build_array_ref (mask, maskindex);
gfc_add_modify_expr (&body, tmp, se.expr);
/* Advance to the next mask element. */
--- 2596,2602 ----
/* Store the mask. */
se.expr = convert (mask_type, se.expr);
! tmp = gfc_build_array_ref (mask, maskindex, NULL);
gfc_add_modify_expr (&body, tmp, se.expr);
/* Advance to the next mask element. */
*************** gfc_evaluate_where_mask (gfc_expr * me,
*** 2795,2801 ****
if (mask && (cmask || pmask))
{
! tmp = gfc_build_array_ref (mask, count);
if (invert)
tmp = fold_build1 (TRUTH_NOT_EXPR, mask_type, tmp);
gfc_add_modify_expr (&body1, mtmp, tmp);
--- 2795,2801 ----
if (mask && (cmask || pmask))
{
! tmp = gfc_build_array_ref (mask, count, NULL);
if (invert)
tmp = fold_build1 (TRUTH_NOT_EXPR, mask_type, tmp);
gfc_add_modify_expr (&body1, mtmp, tmp);
*************** gfc_evaluate_where_mask (gfc_expr * me,
*** 2803,2809 ****
if (cmask)
{
! tmp1 = gfc_build_array_ref (cmask, count);
tmp = cond;
if (mask)
tmp = build2 (TRUTH_AND_EXPR, mask_type, mtmp, tmp);
--- 2803,2809 ----
if (cmask)
{
! tmp1 = gfc_build_array_ref (cmask, count, NULL);
tmp = cond;
if (mask)
tmp = build2 (TRUTH_AND_EXPR, mask_type, mtmp, tmp);
*************** gfc_evaluate_where_mask (gfc_expr * me,
*** 2812,2818 ****
if (pmask)
{
! tmp1 = gfc_build_array_ref (pmask, count);
tmp = build1 (TRUTH_NOT_EXPR, mask_type, cond);
if (mask)
tmp = build2 (TRUTH_AND_EXPR, mask_type, mtmp, tmp);
--- 2812,2818 ----
if (pmask)
{
! tmp1 = gfc_build_array_ref (pmask, count, NULL);
tmp = build1 (TRUTH_NOT_EXPR, mask_type, cond);
if (mask)
tmp = build2 (TRUTH_AND_EXPR, mask_type, mtmp, tmp);
*************** gfc_trans_where_assign (gfc_expr *expr1,
*** 2971,2977 ****
/* Form the mask expression according to the mask. */
index = count1;
! maskexpr = gfc_build_array_ref (mask, index);
if (invert)
maskexpr = fold_build1 (TRUTH_NOT_EXPR, TREE_TYPE (maskexpr), maskexpr);
--- 2971,2977 ----
/* Form the mask expression according to the mask. */
index = count1;
! maskexpr = gfc_build_array_ref (mask, index, NULL);
if (invert)
maskexpr = fold_build1 (TRUTH_NOT_EXPR, TREE_TYPE (maskexpr), maskexpr);
*************** gfc_trans_where_assign (gfc_expr *expr1,
*** 3028,3034 ****
/* Form the mask expression according to the mask tree list. */
index = count2;
! maskexpr = gfc_build_array_ref (mask, index);
if (invert)
maskexpr = fold_build1 (TRUTH_NOT_EXPR, TREE_TYPE (maskexpr),
maskexpr);
--- 3028,3034 ----
/* Form the mask expression according to the mask tree list. */
index = count2;
! maskexpr = gfc_build_array_ref (mask, index, NULL);
if (invert)
maskexpr = fold_build1 (TRUTH_NOT_EXPR, TREE_TYPE (maskexpr),
maskexpr);
Index: gcc/fortran/expr.c
===================================================================
*** gcc/fortran/expr.c (revision 128437)
--- gcc/fortran/expr.c (working copy)
*************** gfc_is_constant_expr (gfc_expr *e)
*** 792,797 ****
--- 792,826 ----
}
+ /* Is true if an array reference is followed by a component or substring
+ reference. */
+ bool
+ is_subref_array (gfc_expr * e)
+ {
+ gfc_ref * ref;
+ bool seen_array;
+
+ if (e->expr_type != EXPR_VARIABLE)
+ return false;
+
+ if (e->symtree->n.sym->attr.subref_array_pointer)
+ return true;
+
+ seen_array = false;
+ for (ref = e->ref; ref; ref = ref->next)
+ {
+ if (ref->type == REF_ARRAY
+ && ref->u.ar.type != AR_ELEMENT)
+ seen_array = true;
+
+ if (seen_array
+ && ref->type != REF_ARRAY)
+ return seen_array;
+ }
+ return false;
+ }
+
+
/* Try to collapse intrinsic expressions. */
static try
*************** gfc_check_pointer_assign (gfc_expr *lval
*** 2802,2807 ****
--- 2831,2839 ----
return FAILURE;
}
+ if (rvalue->expr_type == EXPR_VARIABLE && is_subref_array (rvalue))
+ lvalue->symtree->n.sym->attr.subref_array_pointer = 1;
+
attr = gfc_expr_attr (rvalue);
if (!attr.target && !attr.pointer)
{
Index: gcc/fortran/trans.c
===================================================================
*** gcc/fortran/trans.c (revision 128437)
--- gcc/fortran/trans.c (working copy)
*************** gfc_build_addr_expr (tree type, tree t)
*** 309,317 ****
/* Build an ARRAY_REF with its natural type. */
tree
! gfc_build_array_ref (tree base, tree offset)
{
tree type = TREE_TYPE (base);
gcc_assert (TREE_CODE (type) == ARRAY_TYPE);
type = TREE_TYPE (type);
--- 309,319 ----
/* Build an ARRAY_REF with its natural type. */
tree
! gfc_build_array_ref (tree base, tree offset, tree decl)
{
tree type = TREE_TYPE (base);
+ tree tmp;
+
gcc_assert (TREE_CODE (type) == ARRAY_TYPE);
type = TREE_TYPE (type);
*************** gfc_build_array_ref (tree base, tree off
*** 321,327 ****
/* Strip NON_LVALUE_EXPR nodes. */
STRIP_TYPE_NOPS (offset);
! return build4 (ARRAY_REF, type, base, offset, NULL_TREE, NULL_TREE);
}
--- 323,350 ----
/* 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
! || TREE_CODE (decl) == VAR_DECL
! || TREE_CODE (decl) == PARM_DECL)
! && GFC_DECL_SUBREF_ARRAY_P (decl)
! && !integer_zerop (GFC_DECL_SPAN(decl)))
! {
! offset = fold_build2 (MULT_EXPR, gfc_array_index_type,
! offset, GFC_DECL_SPAN(decl));
! tmp = gfc_build_addr_expr (pvoid_type_node, base);
! tmp = fold_build2 (POINTER_PLUS_EXPR, pvoid_type_node,
! tmp, fold_convert (sizetype, offset));
! tmp = fold_convert (build_pointer_type (type), tmp);
! if (!TYPE_STRING_FLAG (type))
! tmp = build_fold_indirect_ref (tmp);
! return tmp;
! }
! else
! /* Otherwise use a straightforward array reference. */
! return build4 (ARRAY_REF, type, base, offset, NULL_TREE, NULL_TREE);
}
Index: gcc/fortran/trans.h
===================================================================
*** gcc/fortran/trans.h (revision 128437)
--- gcc/fortran/trans.h (working copy)
*************** tree gfc_conv_operator_assign (gfc_se *,
*** 316,323 ****
int gfc_conv_function_call (gfc_se *, gfc_symbol *, gfc_actual_arglist *,
tree);
! void gfc_conv_aliased_arg (gfc_se *, gfc_expr *, int, sym_intent);
! bool is_aliased_array (gfc_expr *);
/* gfc_trans_* shouldn't call push/poplevel, use gfc_push/pop_scope */
--- 316,322 ----
int gfc_conv_function_call (gfc_se *, gfc_symbol *, gfc_actual_arglist *,
tree);
! void gfc_conv_subref_array_arg (gfc_se *, gfc_expr *, int, sym_intent);
/* gfc_trans_* shouldn't call push/poplevel, use gfc_push/pop_scope */
*************** tree gfc_get_function_decl (gfc_symbol *
*** 379,385 ****
tree gfc_build_addr_expr (tree, tree);
/* Build an ARRAY_REF. */
! tree gfc_build_array_ref (tree, tree);
/* Creates a label. Decl is artificial if label_id == NULL_TREE. */
tree gfc_build_label_decl (tree);
--- 378,384 ----
tree gfc_build_addr_expr (tree, tree);
/* Build an ARRAY_REF. */
! tree gfc_build_array_ref (tree, tree, tree);
/* Creates a label. Decl is artificial if label_id == NULL_TREE. */
tree gfc_build_label_decl (tree);
*************** struct lang_decl GTY(())
*** 593,603 ****
--- 592,604 ----
address of target label. */
tree stringlen;
tree addr;
+ tree span;
};
#define GFC_DECL_ASSIGN_ADDR(node) DECL_LANG_SPECIFIC(node)->addr
#define GFC_DECL_STRING_LEN(node) DECL_LANG_SPECIFIC(node)->stringlen
+ #define GFC_DECL_SPAN(node) DECL_LANG_SPECIFIC(node)->span
#define GFC_DECL_SAVED_DESCRIPTOR(node) \
(DECL_LANG_SPECIFIC(node)->saved_descriptor)
#define GFC_DECL_PACKED_ARRAY(node) DECL_LANG_FLAG_0(node)
*************** struct lang_decl GTY(())
*** 606,611 ****
--- 607,613 ----
#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)
/* An array descriptor. */
#define GFC_DESCRIPTOR_TYPE_P(node) TYPE_LANG_FLAG_1(node)
Index: gcc/fortran/trans-decl.c
===================================================================
*** gcc/fortran/trans-decl.c (revision 128437)
--- gcc/fortran/trans-decl.c (working copy)
*************** gfc_get_symbol_decl (gfc_symbol * sym)
*** 1016,1021 ****
--- 1016,1040 ----
gcc_assert (!sym->value);
}
}
+ 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 (VAR_DECL, create_tmp_var_name ("span"),
+ gfc_array_index_type);
+ gfc_finish_var_decl (span, sym);
+ TREE_STATIC (span) = 1;
+ DECL_INITIAL (span) = build_int_cst (NULL_TREE, 0);
+
+ GFC_DECL_SPAN (decl) = span;
+ }
+
sym->backend_decl = decl;
if (sym->attr.assign)
Index: gcc/fortran/trans-io.c
===================================================================
*** gcc/fortran/trans-io.c (revision 128437)
--- gcc/fortran/trans-io.c (working copy)
*************** set_internal_unit (stmtblock_t * block,
*** 724,734 ****
{
se.ss = gfc_walk_expr (e);
! if (is_aliased_array (e))
{
/* Use a temporary for components of arrays of derived types
or substring array references. */
! gfc_conv_aliased_arg (&se, e, 0,
last_dt == READ ? INTENT_IN : INTENT_OUT);
tmp = build_fold_indirect_ref (se.expr);
se.expr = gfc_build_addr_expr (pchar_type_node, tmp);
--- 724,734 ----
{
se.ss = gfc_walk_expr (e);
! if (is_subref_array (e))
{
/* Use a temporary for components of arrays of derived types
or substring array references. */
! gfc_conv_subref_array_arg (&se, e, 0,
last_dt == READ ? INTENT_IN : INTENT_OUT);
tmp = build_fold_indirect_ref (se.expr);
se.expr = gfc_build_addr_expr (pchar_type_node, tmp);
*************** nml_get_addr_expr (gfc_symbol * sym, gfc
*** 1330,1336 ****
a RECORD_TYPE. */
if (array_flagged)
! tmp = gfc_build_array_ref (tmp, gfc_index_zero_node);
/* Now build the address expression. */
--- 1330,1336 ----
a RECORD_TYPE. */
if (array_flagged)
! tmp = gfc_build_array_ref (tmp, gfc_index_zero_node, NULL);
/* Now build the address expression. */
*************** gfc_trans_transfer (gfc_code * code)
*** 1964,1970 ****
gcc_assert (ref->type == REF_ARRAY);
}
! if (expr->ts.type != BT_DERIVED && ref && ref->next == NULL)
{
/* Get the descriptor. */
gfc_conv_expr_descriptor (&se, expr, ss);
--- 1964,1972 ----
gcc_assert (ref->type == REF_ARRAY);
}
! if (expr->ts.type != BT_DERIVED
! && ref && ref->next == NULL
! && !is_subref_array (expr))
{
/* Get the descriptor. */
gfc_conv_expr_descriptor (&se, expr, ss);
Index: gcc/testsuite/gfortran.dg/subref_array_pointer_1.f90
===================================================================
*** gcc/testsuite/gfortran.dg/subref_array_pointer_1.f90 (revision 0)
--- gcc/testsuite/gfortran.dg/subref_array_pointer_1.f90 (revision 0)
***************
*** 0 ****
--- 1,59 ----
+ ! { dg-do run }
+ ! Test the fix for PRs29396, 29606, 30625 and 30871, in which pointers
+ ! to arrays with subreferences did not work.
+ !
+ call pr29396
+ call pr29606
+ call pr30625
+ call pr30871
+ contains
+ subroutine pr29396
+ ! Contributed by Francois-Xavier Coudert <fxcoudert@gcc.gnu.org>
+ CHARACTER(LEN=2), DIMENSION(:), POINTER :: a
+ CHARACTER(LEN=4), DIMENSION(3), TARGET :: b
+ b=(/"bbbb","bbbb","bbbb"/)
+ a=>b(:)(2:3)
+ a="aa"
+ IF (ANY(b.NE.(/"baab","baab","baab"/))) CALL ABORT()
+ END subroutine
+
+ subroutine pr29606
+ ! Contributed by Daniel Franke <franke.daniel@gmail.com>
+ TYPE foo
+ INTEGER :: value
+ END TYPE
+ TYPE foo_array
+ TYPE(foo), DIMENSION(:), POINTER :: array
+ END TYPE
+ TYPE(foo_array) :: array_holder
+ INTEGER, DIMENSION(:), POINTER :: array_ptr
+ ALLOCATE( array_holder%array(3) )
+ array_holder%array = (/ foo(1), foo(2), foo(3) /)
+ array_ptr => array_holder%array%value
+ if (any (array_ptr .ne. (/1,2,3/))) call abort ()
+ END subroutine
+
+ subroutine pr30625
+ ! Contributed by Paul Thomas <pault@gcc.gnu.org>
+ type :: a
+ real :: r = 3.14159
+ integer :: i = 42
+ end type a
+ type(a), target :: dt(2)
+ integer, pointer :: ip(:)
+ ip => dt%i
+ if (any (ip .ne. 42)) call abort ()
+ end subroutine
+
+ subroutine pr30871
+ ! Contributed by Joost VandeVondele <jv244@cam.ac.uk>
+ TYPE data
+ CHARACTER(LEN=3) :: A
+ END TYPE
+ TYPE(data), DIMENSION(10), TARGET :: Z
+ CHARACTER(LEN=1), DIMENSION(:), POINTER :: ptr
+ Z(:)%A="123"
+ ptr=>Z(:)%A(2:2)
+ if (any (ptr .ne. "2")) call abort ()
+ END subroutine
+ end
Index: gcc/testsuite/gfortran.dg/subref_array_pointer_2.f90
===================================================================
*** gcc/testsuite/gfortran.dg/subref_array_pointer_2.f90 (revision 0)
--- gcc/testsuite/gfortran.dg/subref_array_pointer_2.f90 (revision 0)
***************
*** 0 ****
--- 1,103 ----
+ ! { dg-do run }
+ ! Test the fix for PRs29396, 29606, 30625 and 30871, in which pointers
+ ! to arrays with subreferences did not work.
+ !
+ type :: t
+ real :: r
+ integer :: i
+ character(3) :: chr
+ end type t
+
+ type :: t2
+ real :: r(2, 2)
+ integer :: i
+ character(3) :: chr
+ end type t2
+
+ type :: s
+ type(t), pointer :: t(:)
+ end type s
+
+ integer, parameter :: sh(2) = (/2,2/)
+ real, parameter :: a1(2,2) = reshape ((/1.0,2.0,3.0,4.0/),sh)
+ real, parameter :: a2(2,2) = reshape ((/5.0,6.0,7.0,8.0/),sh)
+
+ type(t), target :: tar1(2) = (/t(1.0, 2, "abc"), t(3.0, 4, "efg")/)
+ character(4), target :: tar2(2) = (/"abcd","efgh"/)
+ type(s), target :: tar3
+ character(2), target :: tar4(2) = (/"ab","cd"/)
+ type(t2), target :: tar5(2) = (/t2(a1, 2, "abc"), t2(a2, 4, "efg")/)
+
+ integer, pointer :: ptr(:)
+ character(2), pointer :: ptr2(:)
+ real, pointer :: ptr3(:)
+
+ !_______________component subreference___________
+ ptr => tar1%i
+ ptr = ptr + 1 ! check the scalarizer is OK
+
+ if (any (ptr .ne. (/3, 5/))) call abort ()
+ if (any ((/ptr(1), ptr(2)/) .ne. (/3, 5/))) call abort ()
+ if (any (tar1%i .ne. (/3, 5/))) call abort ()
+
+ ! Make sure that the other components are not touched.
+ if (any (tar1%r .ne. (/1.0, 3.0/))) call abort ()
+ if (any (tar1%chr .ne. (/"abc", "efg"/))) call abort ()
+
+ ! Check that the pointer is passed correctly as an actual argument.
+ call foo (ptr)
+ if (any (tar1%i .ne. (/2, 4/))) call abort ()
+
+ ! And that dummy pointers are OK too.
+ call bar (ptr)
+ if (any (tar1%i .ne. (/101, 103/))) call abort ()
+
+ !_______________substring subreference___________
+ ptr2 => tar2(:)(2:3)
+ ptr2 = ptr2(:)(2:2)//"z" ! again, check the scalarizer
+
+ if (any (ptr2 .ne. (/"cz", "gz"/))) call abort ()
+ if (any ((/ptr2(1), ptr2(2)/) .ne. (/"cz", "gz"/))) call abort ()
+ if (any (tar2 .ne. (/"aczd", "egzh"/))) call abort ()
+
+ !_______________substring component subreference___________
+ ptr2 => tar1(:)%chr(1:2)
+ ptr2 = ptr2(:)(2:2)//"q" ! yet again, check the scalarizer
+ if (any (ptr2 .ne. (/"bq","fq"/))) call abort ()
+ if (any (tar1%chr .ne. (/"bqc","fqg"/))) call abort ()
+
+ !_______________trailing array element subreference___________
+ ptr3 => tar5%r(1,2)
+ ptr3 = (/99.0, 999.0/)
+ if (any (tar5(1)%r .ne. reshape ((/1.0,2.0,99.0,4.0/), sh))) call abort ()
+ if (any (tar5(2)%r .ne. reshape ((/5.0,6.0,999.0,8.0/), sh))) call abort ()
+
+ !_______________forall assignment___________
+ ptr2 => tar2(:)(1:2)
+ forall (i = 1:2) ptr2(i)(1:1) = "z"
+ if (any (tar2 .ne. (/"zczd", "zgzh"/))) call abort ()
+
+ !_______________something more complicated___________
+ tar3%t => tar1
+ ptr3 => tar3%t%r
+ ptr3 = cos (ptr3)
+ if (any (ptr3 .ne. (/cos(1.0_4), cos(3.0_4)/))) call abort ()
+
+ ptr2 => tar3%t(:)%chr(2:3)
+ ptr2 = " x"
+ if (any (tar1%chr .ne. (/"b x", "f x"/))) call abort ()
+
+ !_______________check non-subref works still___________
+ ptr2 => tar4
+ if (any (ptr2 .ne. (/"ab","cd"/))) call abort ()
+
+ contains
+ subroutine foo (arg)
+ integer :: arg(:)
+ arg = arg - 1
+ end subroutine
+ subroutine bar (arg)
+ integer, pointer :: arg(:)
+ arg = arg + 99
+ end subroutine
+ end