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

re PR fortran/42309 (Problem with a pointer array passed to a subroutine)

Browse Source 
2010-02-05  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/42309
	* trans-expr.c (gfc_conv_subref_array_arg): Add new argument
	'formal_ptr'. If this is true, give returned descriptor unity
	lbounds, in all dimensions, and the appropriate offset.
	(gfc_conv_procedure_call); If formal is a pointer, set the last
	argument of gfc_conv_subref_array_arg to true.
	* trans.h : Add last argument for gfc_conv_subref_array_arg.
	* trans-io.c (set_internal_unit, gfc_trans_transfer): Set the
	new arg of gfc_conv_subref_array_arg to false.
	* trans-stmt.c (forall_make_variable_temp): The same.

2010-02-05  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/42309
	* gfortran.dg/subref_array_pointer_4.f90 : New test.

From-SVN: r156512
This commit is contained in:
Paul Thomas 2010-02-05 05:28:37 +00:00
parent e7da179e4d
commit 430f2d1f6f
7 changed files with 91 additions and 7 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

13
gcc/fortran/ChangeLog
View File

@ -1,3 +1,16 @@
2010-02-05 Paul Thomas <pault@gcc.gnu.org>
PR fortran/42309
* trans-expr.c (gfc_conv_subref_array_arg): Add new argument
'formal_ptr'. If this is true, give returned descriptor unity
lbounds, in all dimensions, and the appropriate offset.
(gfc_conv_procedure_call); If formal is a pointer, set the last
argument of gfc_conv_subref_array_arg to true.
* trans.h : Add last argument for gfc_conv_subref_array_arg.
* trans-io.c (set_internal_unit, gfc_trans_transfer): Set the
new arg of gfc_conv_subref_array_arg to false.
* trans-stmt.c (forall_make_variable_temp): The same.
2010-02-03 Tobias Burnus <burnus@net-b.de>
PR fortran/42936

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

@ -2294,8 +2294,8 @@ gfc_apply_interface_mapping (gfc_interface_mapping * mapping,
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_conv_subref_array_arg (gfc_se * parmse, gfc_expr * expr, int g77,
sym_intent intent, bool formal_ptr)
{
gfc_se lse;
gfc_se rse;
@ -2308,6 +2308,7 @@ gfc_conv_subref_array_arg (gfc_se * parmse, gfc_expr * expr,
tree tmp_index;
tree tmp;
tree base_type;
tree size;
stmtblock_t body;
int n;
@ -2501,6 +2502,42 @@ gfc_conv_subref_array_arg (gfc_se * parmse, gfc_expr * expr,
if (expr->ts.type == BT_CHARACTER)
parmse->string_length = expr->ts.u.cl->backend_decl;
/* Determine the offset for pointer formal arguments and set the
lbounds to one. */
if (formal_ptr)
{
size = gfc_index_one_node;
offset = gfc_index_zero_node;
for (n = 0; n < info->dimen; n++)
{
tmp = gfc_conv_descriptor_ubound_get (parmse->expr,
gfc_rank_cst[n]);
tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
tmp, gfc_index_one_node);
gfc_conv_descriptor_ubound_set (&parmse->pre,
parmse->expr,
gfc_rank_cst[n],
tmp);
gfc_conv_descriptor_lbound_set (&parmse->pre,
parmse->expr,
gfc_rank_cst[n],
gfc_index_one_node);
size = gfc_evaluate_now (size, &parmse->pre);
offset = fold_build2 (MINUS_EXPR, gfc_array_index_type,
offset, size);
offset = gfc_evaluate_now (offset, &parmse->pre);
tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
rse.loop->to[n], rse.loop->from[n]);
tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
tmp, gfc_index_one_node);
size = fold_build2 (MULT_EXPR, gfc_array_index_type,
size, tmp);
}
gfc_conv_descriptor_offset_set (&parmse->pre, parmse->expr,
offset);
}
/* We want either the address for the data or the address of the descriptor,
depending on the mode of passing array arguments. */
if (g77)
@ -3005,7 +3042,8 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
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);
fsym ? fsym->attr.intent : INTENT_INOUT,
fsym && fsym->attr.pointer);
else
gfc_conv_array_parameter (&parmse, e, argss, f, fsym,
sym->name, NULL);

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

@ -741,7 +741,7 @@ set_internal_unit (stmtblock_t * block, stmtblock_t * post_block,
/* 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);
last_dt == READ ? INTENT_IN : INTENT_OUT, false);
tmp = build_fold_indirect_ref_loc (input_location,
se.expr);
se.expr = gfc_build_addr_expr (pchar_type_node, tmp);
@ -2211,7 +2211,7 @@ gfc_trans_transfer (gfc_code * code)
if (seen_vector && last_dt == READ)
{
/* Create a temp, read to that and copy it back. */
gfc_conv_subref_array_arg (&se, expr, 0, INTENT_OUT);
gfc_conv_subref_array_arg (&se, expr, 0, INTENT_OUT, false);
tmp = se.expr;
}
else

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

@ -1800,7 +1800,7 @@ forall_make_variable_temp (gfc_code *c, stmtblock_t *pre, stmtblock_t *post)
if (old_sym->attr.dimension)
{
gfc_init_se (&tse, NULL);
gfc_conv_subref_array_arg (&tse, e, 0, INTENT_IN);
gfc_conv_subref_array_arg (&tse, e, 0, INTENT_IN, false);
gfc_add_block_to_block (pre, &tse.pre);
gfc_add_block_to_block (post, &tse.post);
tse.expr = build_fold_indirect_ref_loc (input_location, tse.expr);

2
gcc/fortran/trans.h
View File

@ -315,7 +315,7 @@ int gfc_is_intrinsic_libcall (gfc_expr *);
int gfc_conv_procedure_call (gfc_se *, gfc_symbol *, gfc_actual_arglist *,
gfc_expr *, tree);
void gfc_conv_subref_array_arg (gfc_se *, gfc_expr *, int, sym_intent);
void gfc_conv_subref_array_arg (gfc_se *, gfc_expr *, int, sym_intent, bool);
/* gfc_trans_* shouldn't call push/poplevel, use gfc_push/pop_scope */

5
gcc/testsuite/ChangeLog
View File

@ -1,3 +1,8 @@
2010-02-05 Paul Thomas <pault@gcc.gnu.org>
PR fortran/42309
* gfortran.dg/subref_array_pointer_4.f90 : New test.
2010-02-04 Richard Guenther <rguenther@suse.de>
PR rtl-optimization/42952

28
gcc/testsuite/gfortran.dg/subref_array_pointer_4.f90 Normal file
View File

@ -0,0 +1,28 @@
! { dg-do run }
! Tests the fix for PR42309, in which the indexing of 'Q'
! was off by one.
!
! Contributed by Gilbert Scott <gilbert.scott@easynet.co.uk>
!
PROGRAM X
TYPE T
INTEGER :: I
REAL :: X
END TYPE T
TYPE(T), TARGET :: T1(0:3)
INTEGER, POINTER :: P(:)
REAL :: SOURCE(4) = [10., 20., 30., 40.]
T1%I = [1, 2, 3, 4]
T1%X = SOURCE
P => T1%I
CALL Z(P)
IF (ANY (T1%I .NE. [999, 2, 999, 4])) CALL ABORT
IF (ANY (T1%X .NE. SOURCE)) CALL ABORT
CONTAINS
SUBROUTINE Z(Q)
INTEGER, POINTER :: Q(:)
Q(1:3:2) = 999
END SUBROUTINE Z
END PROGRAM X