[Fortran] PR 46974: Handle C_(FUN)PTR variables in TRANSFER

2010-12-18  Tobias Burnus  <burnus@net-b.de>

	PR fortran/46974
	* target-memory.c (gfc_interpret_derived): Handle C_PTR/C_FUNPTR.
	* trans-expr.c (gfc_trans_structure_assign): Ditto.
	(gfc_conv_expr): Avoid crashes using non-C_NULL_(FUN)PTR const expr.

2010-12-18  Tobias Burnus  <burnus@net-b.de>

	PR fortran/46974
	* gfortran.dg/c_ptr_tests_16.f90: New.

diff --git a/gcc/fortran/target-memory.c b/gcc/fortran/target-memory.c
index 01383c7..878fb29 100644
--- a/gcc/fortran/target-memory.c
+++ b/gcc/fortran/target-memory.c
@@ -442,9 +442,28 @@  gfc_interpret_derived (unsigned char *buffer, size_t buffer_size, gfc_expr *resu
   /* The attributes of the derived type need to be bolted to the floor.  */
   result->expr_type = EXPR_STRUCTURE;
 
-  type = gfc_typenode_for_spec (&result->ts);
   cmp = result->ts.u.derived->components;
 
+  if (result->ts.u.derived->from_intmod == INTMOD_ISO_C_BINDING
+      && (result->ts.u.derived->intmod_sym_id == ISOCBINDING_PTR
+	  || result->ts.u.derived->intmod_sym_id == ISOCBINDING_FUNPTR))
+    {
+      gfc_constructor *c;
+      gfc_expr *e;
+      /* Needed as gfc_typenode_for_spec as gfc_typenode_for_spec
+	 sets this to BT_INTEGER.  */
+      result->ts.type = BT_DERIVED;
+      e = gfc_get_constant_expr (cmp->ts.type, cmp->ts.kind,
+					   &result->where); 
+      c = gfc_constructor_append_expr (&result->value.constructor, e, NULL);
+      c->n.component = cmp;
+      gfc_target_interpret_expr (buffer, buffer_size, e);
+      e->ts.is_iso_c = 1;
+      return int_size_in_bytes (ptr_type_node);
+    }
+
+  type = gfc_typenode_for_spec (&result->ts);
+
   /* Run through the derived type components.  */
   for (;cmp; cmp = cmp->next)
     {
diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index cf2cdb6..3e994aa 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -4514,6 +4514,24 @@  gfc_trans_structure_assign (tree dest, gfc_expr * expr)
 
   gfc_start_block (&block);
   cm = expr->ts.u.derived->components;
+
+  if (expr->ts.u.derived->from_intmod == INTMOD_ISO_C_BINDING
+      && (expr->ts.u.derived->intmod_sym_id == ISOCBINDING_PTR
+          || expr->ts.u.derived->intmod_sym_id == ISOCBINDING_FUNPTR))
+    {
+      gfc_se se, lse;
+
+      gcc_assert (cm->backend_decl == NULL);
+      gfc_init_se (&se, NULL);
+      gfc_init_se (&lse, NULL);
+      gfc_conv_expr (&se, gfc_constructor_first (expr->value.constructor)->expr);
+      lse.expr = dest;
+      gfc_add_modify (&block, lse.expr,
+		      fold_convert (TREE_TYPE (lse.expr), se.expr));
+
+      return gfc_finish_block (&block);
+    } 
+
   for (c = gfc_constructor_first (expr->value.constructor);
        c; c = gfc_constructor_next (c), cm = cm->next)
     {
@@ -4521,20 +4539,6 @@  gfc_trans_structure_assign (tree dest, gfc_expr * expr)
       if (!c->expr)
 	continue;
 
-      /* Handle c_null_(fun)ptr.  */
-      if (c && c->expr && c->expr->ts.is_iso_c)
-	{
-	  field = cm->backend_decl;
-	  tmp = fold_build3_loc (input_location, COMPONENT_REF,
-				 TREE_TYPE (field),
-				 dest, field, NULL_TREE);
-	  tmp = fold_build2_loc (input_location, MODIFY_EXPR, TREE_TYPE (tmp),
-				 tmp, fold_convert (TREE_TYPE (tmp),
-						    null_pointer_node));
-	  gfc_add_expr_to_block (&block, tmp);
-	  continue;
-	}
-
       field = cm->backend_decl;
       tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
 			     dest, field, NULL_TREE);
@@ -4664,8 +4668,10 @@  gfc_conv_expr (gfc_se * se, gfc_expr * expr)
   if (expr->ts.type == BT_DERIVED && expr->ts.u.derived
       && expr->ts.u.derived->attr.is_iso_c)
     {
-      if (expr->symtree->n.sym->intmod_sym_id == ISOCBINDING_NULL_PTR
-          || expr->symtree->n.sym->intmod_sym_id == ISOCBINDING_NULL_FUNPTR)
+      if (expr->expr_type == EXPR_VARIABLE
+	  && (expr->symtree->n.sym->intmod_sym_id == ISOCBINDING_NULL_PTR
+	      || expr->symtree->n.sym->intmod_sym_id
+		 == ISOCBINDING_NULL_FUNPTR))
         {
 	  /* Set expr_type to EXPR_NULL, which will result in
 	     null_pointer_node being used below.  */
diff --git a/gcc/testsuite/gfortran.dg/c_ptr_tests_16.f90 b/gcc/testsuite/gfortran.dg/c_ptr_tests_16.f90
new file mode 100644
index 0000000..eb27171
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/c_ptr_tests_16.f90
@@ -0,0 +1,58 @@ 
+! { dg-do compile }
+! { dg-options "-fdump-tree-optimized -O" }
+!
+! PR fortran/46974
+
+program test
+  use ISO_C_BINDING
+  implicit none
+  type(c_ptr) :: m
+  integer(c_intptr_t) :: a
+  integer(transfer(transfer(4_c_intptr_t, c_null_ptr),1_c_intptr_t)) :: b
+  a = transfer (transfer("ABCE", m), 1_c_intptr_t)
+  if (1162035777 /= a) call i_do_not_exist()
+end program test
+
+! Examples contributed by Steve Kargle and James Van Buskirk
+
+subroutine bug1
+   use ISO_C_BINDING
+   implicit none
+   type(c_ptr) :: m
+   type mytype
+     integer a, b, c
+   end type mytype
+   type(mytype) x
+   print *, transfer(32512, x)  ! Works.
+   print *, transfer(32512, m)  ! Caused ICE.
+end subroutine bug1 
+
+subroutine bug6
+   use ISO_C_BINDING
+   implicit none
+   interface
+      function fun()
+         use ISO_C_BINDING
+         implicit none
+         type(C_FUNPTR) fun
+      end function fun
+   end interface
+   type(C_PTR) array(2)
+   type(C_FUNPTR) result
+   integer(C_INTPTR_T), parameter :: const(*) = [32512,32520]
+
+   result = fun()
+   array = transfer([integer(C_INTPTR_T)::32512,32520],array)
+!   write(*,*) transfer(result,const)
+!   write(*,*) transfer(array,const)
+end subroutine bug6
+
+function fun()
+   use ISO_C_BINDING
+   implicit none
+   type(C_FUNPTR) fun
+   fun = transfer(32512_C_INTPTR_T,fun)
+end function fun 
+
+! { dg-final { scan-tree-dump-times "i_do_not_exist" 0 "optimized" } }
+! { dg-final { cleanup-tree-dump "optimized" } }