mirror/gcc
2
0
Fork 0
mirror of git://gcc.gnu.org/git/gcc.git synced 2025-04-03 05:10:26 +08:00
Code Issues Packages Projects Releases Wiki Activity

re PR fortran/29396 (segfault with character pointer association)

Browse Source 
2007-09-16  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 calculate 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-16  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.

From-SVN: r128523
This commit is contained in:
Paul Thomas 2007-09-16 09:17:49 +00:00
parent 1b95f1f634
commit 1d6b7f396a
13 changed files with 502 additions and 77 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

57
gcc/fortran/ChangeLog
View File

@ -1,3 +1,60 @@
2007-09-16 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 calculate 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-13 Thomas Koenig <tkoenig@gcc.gnu.org>
* iresolve.c (resolve_mask_arg): If a mask is an array

32
gcc/fortran/expr.c
View File

@ -792,6 +792,35 @@ gfc_is_constant_expr (gfc_expr *e)
}
/* 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
@ -2802,6 +2831,9 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue)
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)
{

3
gcc/fortran/gfortran.h
View File

@ -578,7 +578,7 @@ typedef struct
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;
implied_index:1, subref_array_pointer:1;
ENUM_BITFIELD (save_state) save:2;
@ -2172,6 +2172,7 @@ void gfc_free_actual_arglist (gfc_actual_arglist *);
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 *);

153
gcc/fortran/trans-array.c
View File

@ -245,7 +245,7 @@ gfc_conv_descriptor_dimension (tree desc, tree dim)
&& 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);
tmp = gfc_build_array_ref (tmp, dim, NULL);
return tmp;
}
@ -961,7 +961,7 @@ gfc_trans_array_ctor_element (stmtblock_t * pblock, tree desc,
/* Store the value. */
tmp = build_fold_indirect_ref (gfc_conv_descriptor_data_get (desc));
tmp = gfc_build_array_ref (tmp, offset);
tmp = gfc_build_array_ref (tmp, offset, NULL);
if (expr->ts.type == BT_CHARACTER)
{
gfc_conv_string_parameter (se);
@ -1181,7 +1181,7 @@ gfc_trans_array_constructor_value (stmtblock_t * pblock, tree type,
/* 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 = gfc_build_array_ref (tmp, *poffset, NULL);
tmp = build_fold_addr_expr (tmp);
init = build_fold_addr_expr (init);
@ -2167,7 +2167,7 @@ gfc_conv_array_index_offset (gfc_se * se, gfc_ss_info * info, int dim, int i,
/* 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_build_array_ref (data, index, NULL);
index = gfc_evaluate_now (index, &se->pre);
/* Do any bounds checking on the final info->descriptor index. */
@ -2219,6 +2219,7 @@ static void
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;
@ -2236,8 +2237,11 @@ gfc_conv_scalarized_array_ref (gfc_se * se, gfc_array_ref * ar)
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);
se->expr = gfc_build_array_ref (tmp, index, decl);
}
@ -2338,11 +2342,11 @@ gfc_conv_array_ref (gfc_se * se, gfc_array_ref * ar, gfc_symbol * sym,
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);
se->expr = gfc_build_array_ref (tmp, index, sym->backend_decl);
}
@ -4336,6 +4340,116 @@ gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc, tree body)
}
/* 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
@ -4373,6 +4487,7 @@ gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss)
tree start;
tree offset;
int full;
bool subref_array_target = false;
gcc_assert (ss != gfc_ss_terminator);
@ -4395,7 +4510,10 @@ gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss)
gfc_conv_ss_descriptor (&se->pre, secss, 0);
desc = info->descriptor;
need_tmp = gfc_ref_needs_temporary_p (expr->ref);
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)))
@ -4416,6 +4534,10 @@ gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss)
{
/* 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)
{
@ -4742,14 +4864,9 @@ gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss)
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);
}
/* 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)
@ -5082,7 +5199,7 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
/* Build the body of the loop. */
gfc_init_block (&loopbody);
vref = gfc_build_array_ref (var, index);
vref = gfc_build_array_ref (var, index, NULL);
if (purpose == COPY_ALLOC_COMP)
{
@ -5090,7 +5207,7 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
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);
dref = gfc_build_array_ref (tmp, index, NULL);
tmp = structure_alloc_comps (der_type, vref, dref, rank, purpose);
}
else

19
gcc/fortran/trans-decl.c
View File

@ -1016,6 +1016,25 @@ gfc_get_symbol_decl (gfc_symbol * sym)
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)

65
gcc/fortran/trans-expr.c
View File

@ -183,6 +183,15 @@ gfc_get_expr_charlen (gfc_expr *e)
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. */
@ -207,6 +216,7 @@ gfc_get_expr_charlen (gfc_expr *e)
/* We should never got substring references here. These will be
broken down by the scalarizer. */
gcc_unreachable ();
break;
}
}
@ -270,7 +280,7 @@ gfc_conv_substring (gfc_se * se, gfc_ref * ref, int kind,
tmp = se->expr;
else
tmp = build_fold_indirect_ref (se->expr);
tmp = gfc_build_array_ref (tmp, start.expr);
tmp = gfc_build_array_ref (tmp, start.expr, NULL);
se->expr = gfc_build_addr_expr (type, tmp);
}
@ -1782,15 +1792,13 @@ gfc_apply_interface_mapping (gfc_interface_mapping * mapping,
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. */
after the function call. */
void
gfc_conv_aliased_arg (gfc_se * parmse, gfc_expr * expr,
int g77, sym_intent intent)
gfc_conv_subref_array_arg (gfc_se * parmse, gfc_expr * expr,
int g77, sym_intent intent)
{
gfc_se lse;
gfc_se rse;
@ -1962,7 +1970,7 @@ gfc_conv_aliased_arg (gfc_se * parmse, gfc_expr * expr,
/* Now use the offset for the reference. */
tmp = build_fold_indirect_ref (info->data);
rse.expr = gfc_build_array_ref (tmp, tmp_index);
rse.expr = gfc_build_array_ref (tmp, tmp_index, NULL);
if (expr->ts.type == BT_CHARACTER)
rse.string_length = expr->ts.cl->backend_decl;
@ -2005,28 +2013,6 @@ gfc_conv_aliased_arg (gfc_se * parmse, gfc_expr * expr,
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. */
@ -2256,12 +2242,12 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
f = f || !sym->attr.always_explicit;
if (e->expr_type == EXPR_VARIABLE
&& is_aliased_array (e))
&& 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_aliased_arg (&parmse, e, f,
gfc_conv_subref_array_arg (&parmse, e, f,
fsym ? fsym->attr.intent : INTENT_INOUT);
else
gfc_conv_array_parameter (&parmse, e, argss, f);
@ -3471,6 +3457,8 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
stmtblock_t block;
tree desc;
tree tmp;
tree decl;
gfc_start_block (&block);
@ -3509,6 +3497,19 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
/* 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:

10
gcc/fortran/trans-io.c
View File

@ -724,11 +724,11 @@ set_internal_unit (stmtblock_t * block, stmtblock_t * post_block,
{
se.ss = gfc_walk_expr (e);
if (is_aliased_array (e))
if (is_subref_array (e))
{
/* Use a temporary for components of arrays of derived types
or substring array references. */
gfc_conv_aliased_arg (&se, e, 0,
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);
@ -1330,7 +1330,7 @@ nml_get_addr_expr (gfc_symbol * sym, gfc_component * c,
a RECORD_TYPE. */
if (array_flagged)
tmp = gfc_build_array_ref (tmp, gfc_index_zero_node);
tmp = gfc_build_array_ref (tmp, gfc_index_zero_node, NULL);
/* Now build the address expression. */
@ -1964,7 +1964,9 @@ gfc_trans_transfer (gfc_code * code)
gcc_assert (ref->type == REF_ARRAY);
}
if (expr->ts.type != BT_DERIVED && ref && ref->next == NULL)
if (expr->ts.type != BT_DERIVED
&& ref && ref->next == NULL
&& !is_subref_array (expr))
{
/* Get the descriptor. */
gfc_conv_expr_descriptor (&se, expr, ss);

34
gcc/fortran/trans-stmt.c
View File

@ -1650,7 +1650,7 @@ gfc_trans_nested_forall_loop (forall_info * nested_forall_info, tree body,
/* If a mask was specified make the assignment conditional. */
if (mask)
{
tmp = gfc_build_array_ref (mask, maskindex);
tmp = gfc_build_array_ref (mask, maskindex, NULL);
body = build3_v (COND_EXPR, tmp, body, build_empty_stmt ());
}
}
@ -1729,7 +1729,7 @@ generate_loop_for_temp_to_lhs (gfc_expr *expr, tree tmp1, tree count3,
gfc_conv_expr (&lse, expr);
/* Form the expression for the temporary. */
tmp = gfc_build_array_ref (tmp1, count1);
tmp = gfc_build_array_ref (tmp1, count1, NULL);
/* Use the scalar assignment as is. */
gfc_add_block_to_block (&block, &lse.pre);
@ -1770,7 +1770,7 @@ generate_loop_for_temp_to_lhs (gfc_expr *expr, tree tmp1, tree count3,
/* Form the expression of the temporary. */
if (lss != gfc_ss_terminator)
rse.expr = gfc_build_array_ref (tmp1, count1);
rse.expr = gfc_build_array_ref (tmp1, count1, NULL);
/* Translate expr. */
gfc_conv_expr (&lse, expr);
@ -1781,7 +1781,7 @@ generate_loop_for_temp_to_lhs (gfc_expr *expr, tree tmp1, tree count3,
/* Form the mask expression according to the mask tree list. */
if (wheremask)
{
wheremaskexpr = gfc_build_array_ref (wheremask, count3);
wheremaskexpr = gfc_build_array_ref (wheremask, count3, NULL);
if (invert)
wheremaskexpr = fold_build1 (TRUTH_NOT_EXPR,
TREE_TYPE (wheremaskexpr),
@ -1843,7 +1843,7 @@ generate_loop_for_rhs_to_temp (gfc_expr *expr2, tree tmp1, tree count3,
{
gfc_init_block (&body1);
gfc_conv_expr (&rse, expr2);
lse.expr = gfc_build_array_ref (tmp1, count1);
lse.expr = gfc_build_array_ref (tmp1, count1, NULL);
}
else
{
@ -1867,7 +1867,7 @@ generate_loop_for_rhs_to_temp (gfc_expr *expr2, tree tmp1, tree count3,
gfc_conv_expr (&rse, expr2);
/* Form the expression of the temporary. */
lse.expr = gfc_build_array_ref (tmp1, count1);
lse.expr = gfc_build_array_ref (tmp1, count1, NULL);
}
/* Use the scalar assignment. */
@ -1878,7 +1878,7 @@ generate_loop_for_rhs_to_temp (gfc_expr *expr2, tree tmp1, tree count3,
/* Form the mask expression according to the mask tree list. */
if (wheremask)
{
wheremaskexpr = gfc_build_array_ref (wheremask, count3);
wheremaskexpr = gfc_build_array_ref (wheremask, count3, NULL);
if (invert)
wheremaskexpr = fold_build1 (TRUTH_NOT_EXPR,
TREE_TYPE (wheremaskexpr),
@ -2251,7 +2251,7 @@ gfc_trans_pointer_assign_need_temp (gfc_expr * expr1, gfc_expr * expr2,
inner_size, NULL, block, &ptemp1);
gfc_start_block (&body);
gfc_init_se (&lse, NULL);
lse.expr = gfc_build_array_ref (tmp1, count);
lse.expr = gfc_build_array_ref (tmp1, count, NULL);
gfc_init_se (&rse, NULL);
rse.want_pointer = 1;
gfc_conv_expr (&rse, expr2);
@ -2278,7 +2278,7 @@ gfc_trans_pointer_assign_need_temp (gfc_expr * expr1, gfc_expr * expr2,
gfc_start_block (&body);
gfc_init_se (&lse, NULL);
gfc_init_se (&rse, NULL);
rse.expr = gfc_build_array_ref (tmp1, count);
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);
@ -2320,7 +2320,7 @@ gfc_trans_pointer_assign_need_temp (gfc_expr * expr1, gfc_expr * expr2,
inner_size, NULL, block, &ptemp1);
gfc_start_block (&body);
gfc_init_se (&lse, NULL);
lse.expr = gfc_build_array_ref (tmp1, count);
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);
@ -2343,7 +2343,7 @@ gfc_trans_pointer_assign_need_temp (gfc_expr * expr1, gfc_expr * expr2,
/* Reset count. */
gfc_add_modify_expr (block, count, gfc_index_zero_node);
parm = gfc_build_array_ref (tmp1, count);
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);
@ -2596,7 +2596,7 @@ gfc_trans_forall_1 (gfc_code * code, forall_info * nested_forall_info)
/* Store the mask. */
se.expr = convert (mask_type, se.expr);
tmp = gfc_build_array_ref (mask, maskindex);
tmp = gfc_build_array_ref (mask, maskindex, NULL);
gfc_add_modify_expr (&body, tmp, se.expr);
/* Advance to the next mask element. */
@ -2795,7 +2795,7 @@ gfc_evaluate_where_mask (gfc_expr * me, forall_info * nested_forall_info,
if (mask && (cmask || pmask))
{
tmp = gfc_build_array_ref (mask, count);
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);
@ -2803,7 +2803,7 @@ gfc_evaluate_where_mask (gfc_expr * me, forall_info * nested_forall_info,
if (cmask)
{
tmp1 = gfc_build_array_ref (cmask, count);
tmp1 = gfc_build_array_ref (cmask, count, NULL);
tmp = cond;
if (mask)
tmp = build2 (TRUTH_AND_EXPR, mask_type, mtmp, tmp);
@ -2812,7 +2812,7 @@ gfc_evaluate_where_mask (gfc_expr * me, forall_info * nested_forall_info,
if (pmask)
{
tmp1 = gfc_build_array_ref (pmask, count);
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);
@ -2971,7 +2971,7 @@ gfc_trans_where_assign (gfc_expr *expr1, gfc_expr *expr2,
/* Form the mask expression according to the mask. */
index = count1;
maskexpr = gfc_build_array_ref (mask, index);
maskexpr = gfc_build_array_ref (mask, index, NULL);
if (invert)
maskexpr = fold_build1 (TRUTH_NOT_EXPR, TREE_TYPE (maskexpr), maskexpr);
@ -3028,7 +3028,7 @@ gfc_trans_where_assign (gfc_expr *expr1, gfc_expr *expr2,
/* Form the mask expression according to the mask tree list. */
index = count2;
maskexpr = gfc_build_array_ref (mask, index);
maskexpr = gfc_build_array_ref (mask, index, NULL);
if (invert)
maskexpr = fold_build1 (TRUTH_NOT_EXPR, TREE_TYPE (maskexpr),
maskexpr);

27
gcc/fortran/trans.c
View File

@ -309,9 +309,11 @@ gfc_build_addr_expr (tree type, tree t)
/* Build an ARRAY_REF with its natural type. */
tree
gfc_build_array_ref (tree base, tree offset)
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);
@ -321,7 +323,28 @@ gfc_build_array_ref (tree base, tree offset)
/* Strip NON_LVALUE_EXPR nodes. */
STRIP_TYPE_NOPS (offset);
return build4 (ARRAY_REF, type, base, offset, NULL_TREE, NULL_TREE);
/* 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);
}

8
gcc/fortran/trans.h
View File

@ -316,8 +316,7 @@ tree gfc_conv_operator_assign (gfc_se *, gfc_se *, gfc_symbol *);
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 *);
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 */
@ -379,7 +378,7 @@ tree gfc_get_function_decl (gfc_symbol *);
tree gfc_build_addr_expr (tree, tree);
/* Build an ARRAY_REF. */
tree gfc_build_array_ref (tree, tree);
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);
@ -593,11 +592,13 @@ struct lang_decl GTY(())
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)
@ -606,6 +607,7 @@ struct lang_decl GTY(())
#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)

9
gcc/testsuite/ChangeLog
View File

@ -1,3 +1,12 @@
2007-09-16 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.
2007-09-15 H.J. Lu <hongjiu.lu@intel.com>
* gfortran.dg/nint_2.f90: Correct last change.

59
gcc/testsuite/gfortran.dg/subref_array_pointer_1.f90 Normal file
View File

@ -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

103
gcc/testsuite/gfortran.dg/subref_array_pointer_2.f90 Normal file
View File

@ -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