[Patch, Fortran] Handle C_F_POINTER with a noncontiguous SHAPE=

[Tobias Burnus <burnus at net-b dot de>]

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  <burnus@net-b.de>

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

2012-06-27  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.

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