Skip to content

R
riscv-gcc-1
Commit 0d87d307 by Tobias Burnus Committed by Tobias Burnus
Options

trans-expr.c (conv_isocbinding_procedure): Generate 

2012-07-12  Tobias Burnus  <burnus@net-b.de>

        * trans-expr.c (conv_isocbinding_procedure): Generate
        * c_f_pointer code
        inline.

2012-07-12  Tobias Burnus  <burnus@net-b.de>

        * gfortran.dg/c_f_pointer_shape_tests_5.f90: New.
        * gfortran.dg/c_f_pointer_tests_3.f90: Update
        scan-tree-dump-times pattern.

From-SVN: r189442
parent e098c169
Showing with 151 additions and 25 deletions
gcc/fortran/ChangeLog
2012-07-12 Tobias Burnus <burnus@net-b.de>
* trans-expr.c (conv_isocbinding_procedure): Generate c_f_pointer code
inline.
2012-07-11 Steven Bosscher <steven@gcc.gnu.org>
* trans.c: Do not include defaults.h.
......
gcc/fortran/trans-expr.c
......@@ -3307,14 +3307,17 @@ conv_isocbinding_procedure (gfc_se * se, gfc_symbol * sym,
return 1;
}
else if ((sym->intmod_sym_id == ISOCBINDING_F_POINTER
&& arg->next->expr->rank == 0)
else if (sym->intmod_sym_id == ISOCBINDING_F_POINTER
|| sym->intmod_sym_id == ISOCBINDING_F_PROCPOINTER)
{
/* Convert c_f_pointer if fptr is a scalar
and convert c_f_procpointer. */
/* Convert c_f_pointer and c_f_procpointer. */
gfc_se cptrse;
gfc_se fptrse;
gfc_se shapese;
gfc_ss *ss, *shape_ss;
tree desc, dim, tmp, stride, offset;
stmtblock_t body, block;
gfc_loopinfo loop;
gfc_init_se (&cptrse, NULL);
gfc_conv_expr (&cptrse, arg->expr);
......@@ -3322,25 +3325,103 @@ conv_isocbinding_procedure (gfc_se * se, gfc_symbol * sym,
gfc_add_block_to_block (&se->post, &cptrse.post);
gfc_init_se (&fptrse, NULL);
if (sym->intmod_sym_id == ISOCBINDING_F_POINTER
|| gfc_is_proc_ptr_comp (arg->next->expr, NULL))
fptrse.want_pointer = 1;
if (arg->next->expr->rank == 0)
{
if (sym->intmod_sym_id == ISOCBINDING_F_POINTER
|| gfc_is_proc_ptr_comp (arg->next->expr, NULL))
fptrse.want_pointer = 1;
gfc_conv_expr (&fptrse, arg->next->expr);
gfc_add_block_to_block (&se->pre, &fptrse.pre);
gfc_add_block_to_block (&se->post, &fptrse.post);
if (arg->next->expr->symtree->n.sym->attr.proc_pointer
&& arg->next->expr->symtree->n.sym->attr.dummy)
fptrse.expr = build_fold_indirect_ref_loc (input_location,
fptrse.expr);
se->expr = fold_build2_loc (input_location, MODIFY_EXPR,
TREE_TYPE (fptrse.expr),
fptrse.expr,
fold_convert (TREE_TYPE (fptrse.expr),
cptrse.expr));
return 1;
}
gfc_conv_expr (&fptrse, arg->next->expr);
gfc_add_block_to_block (&se->pre, &fptrse.pre);
gfc_add_block_to_block (&se->post, &fptrse.post);
if (arg->next->expr->symtree->n.sym->attr.proc_pointer
&& arg->next->expr->symtree->n.sym->attr.dummy)
fptrse.expr = build_fold_indirect_ref_loc (input_location,
fptrse.expr);
se->expr = fold_build2_loc (input_location, MODIFY_EXPR,
TREE_TYPE (fptrse.expr),
fptrse.expr,
fold_convert (TREE_TYPE (fptrse.expr),
cptrse.expr));
gfc_start_block (&block);
/* Get the descriptor of the Fortran pointer. */
ss = gfc_walk_expr (arg->next->expr);
gcc_assert (ss != gfc_ss_terminator);
fptrse.descriptor_only = 1;
gfc_conv_expr_descriptor (&fptrse, arg->next->expr, ss);
gfc_add_block_to_block (&block, &fptrse.pre);
desc = fptrse.expr;
/* Set data value, dtype, and offset. */
tmp = GFC_TYPE_ARRAY_DATAPTR_TYPE (TREE_TYPE (desc));
gfc_conv_descriptor_data_set (&block, desc,
fold_convert (tmp, cptrse.expr));
gfc_add_modify (&block, gfc_conv_descriptor_dtype (desc),
gfc_get_dtype (TREE_TYPE (desc)));
/* Start scalarization of the bounds, using the shape argument. */
shape_ss = gfc_walk_expr (arg->next->next->expr);
gcc_assert (shape_ss != gfc_ss_terminator);
gfc_init_se (&shapese, NULL);
gfc_init_loopinfo (&loop);
gfc_add_ss_to_loop (&loop, shape_ss);
gfc_conv_ss_startstride (&loop);
gfc_conv_loop_setup (&loop, &arg->next->expr->where);
gfc_mark_ss_chain_used (shape_ss, 1);
gfc_copy_loopinfo_to_se (&shapese, &loop);
shapese.ss = shape_ss;
stride = gfc_create_var (gfc_array_index_type, "stride");
offset = gfc_create_var (gfc_array_index_type, "offset");
gfc_add_modify (&block, stride, gfc_index_one_node);
gfc_add_modify (&block, offset, gfc_index_zero_node);
/* Loop body. */
gfc_start_scalarized_body (&loop, &body);
dim = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
loop.loopvar[0], loop.from[0]);
/* Set bounds and stride. */
gfc_conv_descriptor_lbound_set (&body, desc, dim, gfc_index_one_node);
gfc_conv_descriptor_stride_set (&body, desc, dim, stride);
gfc_conv_expr (&shapese, arg->next->next->expr);
gfc_add_block_to_block (&body, &shapese.pre);
gfc_conv_descriptor_ubound_set (&body, desc, dim, shapese.expr);
gfc_add_block_to_block (&body, &shapese.post);
/* Calculate offset. */
gfc_add_modify (&body, offset,
fold_build2_loc (input_location, PLUS_EXPR,
gfc_array_index_type, offset, stride));
/* Update stride. */
gfc_add_modify (&body, stride,
fold_build2_loc (input_location, MULT_EXPR,
gfc_array_index_type, stride,
fold_convert (gfc_array_index_type,
shapese.expr)));
/* Finish scalarization loop. */
gfc_trans_scalarizing_loops (&loop, &body);
gfc_add_block_to_block (&block, &loop.pre);
gfc_add_block_to_block (&block, &loop.post);
gfc_add_block_to_block (&block, &fptrse.post);
gfc_cleanup_loop (&loop);
gfc_free_ss (ss);
gfc_add_modify (&block, offset,
fold_build1_loc (input_location, NEGATE_EXPR,
gfc_array_index_type, offset));
gfc_conv_descriptor_offset_set (&block, desc, offset);
se->expr = gfc_finish_block (&block);
return 1;
}
else if (sym->intmod_sym_id == ISOCBINDING_ASSOCIATED)
......
gcc/testsuite/ChangeLog
2012-07-12 Tobias Burnus <burnus@net-b.de>
* gfortran.dg/c_f_pointer_shape_tests_5.f90: New.
* gfortran.dg/c_f_pointer_tests_3.f90: Update
scan-tree-dump-times pattern.
2012-07-11 Rainer Orth <ro@CeBiTec.Uni-Bielefeld.DE>
* g++.dg/debug/dwarf2/pubnames-2.C: Allow for / comments.
......
gcc/testsuite/gfortran.dg/c_f_pointer_shape_tests_5.f90 0 → 100644
! { dg-do run }
!
! Check that C_F_Pointer works with a noncontiguous SHAPE argument
!
use iso_c_binding
type(c_ptr) :: x
integer, target :: array(3)
integer, pointer :: ptr(:,:)
integer, pointer :: ptr2(:,:,:)
integer :: myshape(5)
array = [22,33,44]
x = c_loc(array)
myshape = [1,2,3,4,1]
call c_f_pointer(x, ptr, shape=myshape(1:4:2))
if (any (lbound(ptr) /= [ 1, 1])) call abort ()
if (any (ubound(ptr) /= [ 1, 3])) call abort ()
if (any (shape(ptr) /= [ 1, 3])) call abort ()
if (any (ptr(1,:) /= array)) call abort()
call c_f_pointer(x, ptr2, shape=myshape([1,3,1]))
if (any (lbound(ptr2) /= [ 1, 1, 1])) call abort ()
if (any (ubound(ptr2) /= [ 1, 3, 1])) call abort ()
if (any (shape(ptr2) /= [ 1, 3, 1])) call abort ()
if (any (ptr2(1,:,1) /= array)) call abort()
end
gcc/testsuite/gfortran.dg/c_f_pointer_tests_3.f90
......@@ -21,14 +21,21 @@ program test
call c_f_procpointer(cfunptr, fprocptr)
end program test
! Make sure there is only a single function call:
! { dg-final { scan-tree-dump-times "c_f" 1 "original" } }
! { dg-final { scan-tree-dump-times "c_f_pointer" 1 "original" } }
! { dg-final { scan-tree-dump-times "c_f_pointer_i4" 1 "original" } }
! Make sure there is no function call:
! { dg-final { scan-tree-dump-times "c_f" 0 "original" } }
! { dg-final { scan-tree-dump-times "c_f_pointer" 0 "original" } }
! { dg-final { scan-tree-dump-times "c_f_pointer_i4" 0 "original" } }
!
! Check scalar c_f_pointer
! { dg-final { scan-tree-dump-times " fptr = .integer.kind=4. .. cptr" 1 "original" } }
!
! Array c_f_pointer:
!
! { dg-final { scan-tree-dump-times " fptr_array.data = cptr;" 1 "original" } }
! { dg-final { scan-tree-dump-times " fptr_array.dim\\\[S..\\\].lbound = 1;" 1 "original" } }
! { dg-final { scan-tree-dump-times " fptr_array.dim\\\[S..\\\].ubound = " 1 "original" } }
! { dg-final { scan-tree-dump-times " fptr_array.dim\\\[S..\\\].stride = " 1 "original" } }
!
! Check c_f_procpointer
! { dg-final { scan-tree-dump-times " fprocptr = .integer.kind=4. .\\*<.*>. ... cfunptr;" 1 "original" } }
!
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment