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

5 files changed, 151 insertions, 25 deletions

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 4c25316..f6be5bd 100644
--- 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
--- 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
--- 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
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
--- 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" } }
 !