This is the mail archive of the
fortran@gcc.gnu.org
mailing list for the GNU Fortran project.
[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>
- Date: Sun, 09 Sep 2007 19:57:53 +0200
- Subject: [Patch, fortran] PR29396 PR29606 PR30625 and PR30871 - subreference array pointers.
:ADDPATCH fortran:
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.
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 teh 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 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.
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.
Regtested on Cygwin_NT/amd64 - OK for trunk..... before 09/10 :-) ?
Paul
2007-09-09 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
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 access 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.
For all other references to gfc_build_array_ref, set the third
argument to NULL.
(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.
trans-expr.c (gfc_get_expr_charlen): Use the symbol charlen if
a character subreference gets through.
(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 is_subref_array.
(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 is_subref_array.
* trans-stmt.c : Add NULL for third argument in all references
to gfc_build_array_ref.
* expr.c (is_subref_array): Renamed copy of 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-09 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.
Index: gcc/fortran/trans-array.c
===================================================================
*** gcc/fortran/trans-array.c (revision 128135)
--- 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_conv_expr_descriptor (gfc_se * se, g
*** 4373,4378 ****
--- 4377,4383 ----
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)))
--- 4400,4409 ----
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
*** 4746,4752 ****
/* 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);
}
--- 4754,4802 ----
/* 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, NULL);
!
! /* Offset the data pointer for pointer assignments from arrays with
! subreferences; eg. my_integer => my_type(:)%integer_component. */
! if (subref_array_target)
! {
! gfc_ref *tmp_ref;
! tree field;
! gfc_se start;
!
! /* Go past the array reference. */
! for (tmp_ref = expr->ref; tmp_ref; tmp_ref = tmp_ref->next)
! if (tmp_ref->type == REF_ARRAY)
! {
! tmp_ref = tmp_ref->next;
! break;
! }
!
! /* Calculate the offset for each subreference. */
! for (tmp_ref = expr->ref; tmp_ref; tmp_ref = tmp_ref->next)
! {
! switch (tmp_ref->type)
! {
! case REF_COMPONENT:
! field = tmp_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:
! gfc_init_se (&start, se);
! gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE);
! gfc_conv_expr_type (&start, tmp_ref->u.ss.start, gfc_charlen_type_node);
! gfc_add_block_to_block (&se->pre, &start.pre);
! tmp = gfc_build_array_ref (tmp, start.expr, NULL);
! break;
!
! default:
! break;
! }
! }
! }
!
offset = gfc_build_addr_expr (gfc_array_dataptr_type (desc), tmp);
gfc_conv_descriptor_data_set (&loop.pre, parm, offset);
}
*************** 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)
{
--- 5132,5138 ----
/* 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
--- 5140,5146 ----
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 128135)
--- gcc/fortran/trans-expr.c (working copy)
*************** gfc_get_expr_charlen (gfc_expr *e)
*** 206,212 ****
default:
/* We should never got substring references here. These will be
broken down by the scalarizer. */
! gcc_unreachable ();
}
}
--- 206,214 ----
default:
/* We should never got substring references here. These will be
broken down by the scalarizer. */
! if (is_subref_array (e))
! length = e->symtree->n.sym->ts.cl->backend_decl;
! 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);
}
--- 272,278 ----
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;
--- 1784,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. */
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;
--- 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, 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. */
--- 2005,2010 ----
*************** 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);
--- 2234,2245 ----
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 *
*** 3485,3490 ****
--- 3463,3486 ----
/* Assign directly to the pointer's descriptor. */
lse.direct_byref = 1;
gfc_conv_expr_descriptor (&lse, expr2, rss);
+ if (is_subref_array (expr2))
+ {
+ tree edecl, etmp;
+ if (expr2->ts.type == BT_CHARACTER)
+ {
+ edecl = expr2->symtree->n.sym->ts.cl->backend_decl;
+ etmp = fold_convert (gfc_array_index_type, edecl);
+ }
+ else
+ {
+ edecl = expr2->symtree->n.sym->backend_decl;
+ etmp = fold_convert (gfc_array_index_type,
+ size_in_bytes (gfc_get_element_type (TREE_TYPE (edecl))));
+ }
+
+ edecl = expr1->symtree->n.sym->backend_decl;
+ gfc_add_modify_expr (&lse.post, GFC_DECL_SPAN(edecl), etmp);
+ }
break;
default:
Index: gcc/fortran/gfortran.h
===================================================================
*** gcc/fortran/gfortran.h (revision 128135)
--- 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
*** 2166,2171 ****
--- 2166,2172 ----
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 128135)
--- 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 128135)
--- 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 128135)
--- 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 128135)
--- 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 128135)
--- 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 128135)
--- 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,61 ----
+ ! { 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(t), target :: tar1(2) = (/t(1.0, 2, "abc"), t(3.0, 4, "efg")/)
+ character(4), target :: tar2(2) = (/"abcd","efgh"/)
+
+ integer, pointer :: ptr(:)
+ character(2), pointer :: ptr2(:)
+
+ !_______________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) ! This does not work so far.
+
+ !_______________forall assignment___________
+ ptr2 => tar2(:)(1:2)
+ forall (i = 1:2) ptr2(i)(1:1) = "z"
+ if (any (tar2 .ne. (/"zczd", "zgzh"/))) 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
Index: gcc/testsuite/gfortran.dg/function_kinds_1.f90
===================================================================