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

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 4c25316..f6be5bd 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,8 @@
+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.

diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index 7d1a6d4..34e0f69 100644 (file)
--- a/gcc/fortran/trans-expr.c
+++ b/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)

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 12e4fcd..8cb337b 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,9 @@
+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.

diff --git a/gcc/testsuite/gfortran.dg/c_f_pointer_shape_tests_5.f90 b/gcc/testsuite/gfortran.dg/c_f_pointer_shape_tests_5.f90
new file mode 100644 (file)
index 0000000..f3e1789
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/c_f_pointer_shape_tests_5.f90
@@ -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

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 (file)
--- 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" } }
 !