RFA: Odd tree-generation issues with a Fortran patch

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

Dear all,

I seriously struggle with the following patch. It replaces a library 
call by inline code for
  C_F_POINTER(C-pointer, Fortran-array-pointer, shape-of-the-array)

(Purpose: (a) The current library version fails for SHAPE with strides. 
(b) For the new array descriptor (fortran-dev branch), the current lib 
function lacks data needed to set the stride multiplier (sm).)

The code works for a single "call c_f_pointer(...)". However, if I use 
call c_f_pointer twice, the dump shows that the assignment to the array 
gets lost - which shouldn't be affected and is before the c_f_pointer 
line! Additionally, some variable declaration get lost, which leads to a 
link error:

/dev/shm/foo.f90:9: undefined reference to `A.0.1881'
/dev/shm/foo.f90:11: undefined reference to `A.1.1884'


I was looking at the code for several hours and tried some other 
versions, but without success. [As the comment for ISOCBINDING_LOC in 
the same function indicates, others had also problems (though of 
slightly different kind and called via other functions).]

My impression is that either I forgot something important - or that 
se.{expr,pre,post} is somehow in a bad state. But I have no idea what 
goes wrong. For c_f_pointer, the call tree is:

* fortran/trans-expr.c (conv_isocbinding_procedure): The procedure in 
question, the relevant source code is shown in t
he patch.
* fortran/trans-expr.c (gfc_conv_procedure_call): Simply calls 
conv_isocbinding_procedure and returns 0.
* fortran/trans-stmt.c (gfc_trans_call): Calls gfc_conv_procedure_call 
(for "ss == gfc_ss_terminator").

I am happy for any suggestion regarding debugging and/or solving this issue.

Tobias
! { dg-do run }
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,5]

call c_f_pointer(x, ptr, shape=myshape(::2))
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 (shape(ptr2) /= [ 1, 3, 1])) call abort ()
if (any (ptr2(1,:,1) /= array)) call abort()
end

diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index 036b55b..4108076 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -3271,14 +3271,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;
+      stmtblock_t body;
+      gfc_loopinfo loop;
 
       gfc_init_se (&cptrse, NULL);
       gfc_conv_expr (&cptrse, arg->expr);
@@ -3286,24 +3289,79 @@ 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);
+      /* Get the descriptor of the Fortran pointer.  */
+      ss = gfc_walk_expr (arg->next->expr);
+      gcc_assert (ss != gfc_ss_terminator);
+      gfc_conv_expr_descriptor (&fptrse, arg->next->expr, ss);
       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));
+      desc = fptrse.expr;
+
+      /* Set data value, dtype, and offset.  */
+      tmp = GFC_TYPE_ARRAY_DATAPTR_TYPE (TREE_TYPE (desc));
+      gfc_conv_descriptor_data_set (&se->pre, desc,
+				    fold_convert (tmp, cptrse.expr));
+      gfc_conv_descriptor_offset_set (&se->pre, desc,
+				      build_int_cst (gfc_array_index_type,
+						     -1*arg->next->expr->rank));
+      gfc_add_modify (&se->pre, 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;
+
+      gfc_start_block (&body);
+      gfc_start_scalarized_body (&loop, &body);
+
+      dim = loop.loopvar[0];
+
+      gfc_conv_descriptor_lbound_set (&body, desc, dim, gfc_index_one_node);
+      gfc_conv_descriptor_stride_set (&body, desc, dim, gfc_index_one_node);
+
+      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);
+ 
+      gfc_trans_scalarizing_loops (&loop, &body);
+      gfc_add_block_to_block (&se->pre, &loop.pre);
+      gfc_add_block_to_block (&se->post, &loop.post);
+      gfc_cleanup_loop (&loop);
+      gfc_free_ss (ss);
+
+      se->expr = build_empty_stmt (input_location);
 
       return 1;
     }