This patch generates inline code for C_F_POINTER with an array argument.
One reason is that GCC didn't handle SHAPE= arguments which were
noncontiguous.
However, the real motivation is the fortran-dev branch with the new
array-descriptor: C_F_POINTER needs then to set the stride multiplier,
but as it doesn't know the size of a single element, one had either to
pass the value or handle it partially in the front end. Hence, doing it
all in the front-end was simpler. The C_F_Pointer issue is the main
cause for failing test cases on the branch, though several other issues
remain.
Build and regtested on x86-64-linux-
OK for the trunk?
* * *
If you wonder why I had some problems before:
http://gcc.gnu.org/ml/fortran/2012-04/msg00115.html
The reason is that I called pushlevel() twice for "body":
+ gfc_start_block (&body);
+ gfc_start_scalarized_body (&loop, &body);
I removed the first one - and now it works. (Well, there were also some
other issues in the patch, which are now fixed.)
Tobias
PS: After committal, I will update the patch for the branch; let's see
how many failures will remain on the branch.
PPS: The offset handling in gfortran is really complicated. I wonder
whether we have to (or at least should) change it for the new array
descriptor.
2012-06-27 Tobias Burnus <bur...@net-b.de>
* trans-expr.c (conv_isocbinding_procedure): Generate c_f_pointer code
inline.
2012-06-27 Tobias Burnus <bur...@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.
diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index 7d1a6d4..9ebde9d 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -3307,14 +3351,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, ifblock;
+ gfc_loopinfo loop;
gfc_init_se (&cptrse, NULL);
gfc_conv_expr (&cptrse, arg->expr);
@@ -3322,25 +3369,113 @@ 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_one_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_init_block (&ifblock);
+ gfc_add_modify (&ifblock, offset,
+ fold_build2_loc (input_location, PLUS_EXPR,
+ gfc_array_index_type, offset, stride));
+ tmp = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
+ loop.loopvar[0],loop.from[0]);
+ tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, tmp,
+ gfc_finish_block (&ifblock),
+ build_empty_stmt (input_location));
+ gfc_add_expr_to_block (&body, tmp);
+
+ /* 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_build2_loc (input_location, MULT_EXPR,
+ gfc_array_index_type, offset,
+ build_int_cst (gfc_array_index_type,
+ -1)));
+ gfc_conv_descriptor_offset_set (&block, desc, offset);
+ se->expr = gfc_finish_block (&block);
return 1;
}
else if (sym->intmod_sym_id == ISOCBINDING_ASSOCIATED)
diff --git a/gcc/testsuite/gfortran.dg/c_f_pointer_tests_3.f90 b/gcc/testsuite/gfortran.dg/c_f_pointer_tests_3.f90
index f7d6fa7..29072b8 100644
--- a/gcc/testsuite/gfortran.dg/c_f_pointer_tests_3.f90
+++ b/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" } }
!
--- /dev/null 2012-06-26 07:11:42.215802679 +0200
+++ gcc/gcc/testsuite/gfortran.dg/c_f_pointer_shape_tests_5.f90 2012-06-28 08:29:40.000000000 +0200
@@ -0,0 +1,27 @@
+! { 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