2010-01-09 Tobias Burnus <burnus@net-b.de>

        PR fortran/41298
        * trans-expr.c (gfc_trans_structure_assign): Handle
        c_null_(fun)ptr.
        * symbol.c (gen_special_c_interop_ptr): Add NULL_EXPR
        to the constructor for c_null_(fun)ptr.
        * resolve.c (resolve_structure_cons): Add special case
        for c_null_(fun)ptr.

2010-01-09  Tobias Burnus  <burnus@net-b.de>

        PR fortran/41298
        * gfortran.dg/c_ptr_tests_14.f90: New test.

git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@155755 138bc75d-0d04-0410-961f-82ee72b054a4

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index cb77adf..321a407 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,13 @@
+2010-01-09  Tobias Burnus  <burnus@net-b.de>
+
+       PR fortran/41298
+       * trans-expr.c (gfc_trans_structure_assign): Handle
+       c_null_(fun)ptr.
+       * symbol.c (gen_special_c_interop_ptr): Add NULL_EXPR
+       to the constructor for c_null_(fun)ptr.
+       * resolve.c (resolve_structure_cons): Add special case
+       for c_null_(fun)ptr.
+
 2010-01-09  Jakub Jelinek  <jakub@redhat.com>
 
        * gfortranspec.c (lang_specific_driver): Update copyright notice

diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 0378d4f..8e8de8d 100644 (file)
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -1,5 +1,5 @@
 /* Perform type resolution on the various structures.
-   Copyright (C) 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009
+   Copyright (C) 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
    Free Software Foundation, Inc.
    Contributed by Andy Vaught
 
@@ -842,13 +842,20 @@ resolve_structure_cons (gfc_expr *expr)
   /* See if the user is trying to invoke a structure constructor for one of
      the iso_c_binding derived types.  */
   if (expr->ts.type == BT_DERIVED && expr->ts.u.derived
-      && expr->ts.u.derived->ts.is_iso_c && cons && cons->expr != NULL)
+      && expr->ts.u.derived->ts.is_iso_c && cons
+      && (cons->expr == NULL || cons->expr->expr_type != EXPR_NULL))
     {
       gfc_error ("Components of structure constructor '%s' at %L are PRIVATE",
                 expr->ts.u.derived->name, &(expr->where));
       return FAILURE;
     }
 
+  /* Return if structure constructor is c_null_(fun)prt.  */
+  if (expr->ts.type == BT_DERIVED && expr->ts.u.derived
+      && expr->ts.u.derived->ts.is_iso_c && cons
+      && cons->expr && cons->expr->expr_type == EXPR_NULL)
+    return SUCCESS;
+
   for (; comp; comp = comp->next, cons = cons->next)
     {
       int rank;

diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c
index 750aa2d..a5787de 100644 (file)
--- a/gcc/fortran/symbol.c
+++ b/gcc/fortran/symbol.c
@@ -1,6 +1,6 @@
 /* Maintain binary trees of symbols.
-   Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009
-   Free Software Foundation, Inc.
+   Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008,
+   2009, 2010 Free Software Foundation, Inc.
    Contributed by Andy Vaught
 
 This file is part of GCC.
@@ -3690,10 +3690,10 @@ gen_special_c_interop_ptr (int ptr_id, const char *ptr_name,
   tmp_sym->value->expr_type = EXPR_STRUCTURE;
   tmp_sym->value->ts.type = BT_DERIVED;
   tmp_sym->value->ts.u.derived = tmp_sym->ts.u.derived;
-  /* Create a constructor with no expr, that way we can recognize if the user
-     tries to call the structure constructor for one of the iso_c_binding
-     derived types during resolution (resolve_structure_cons).  */
   tmp_sym->value->value.constructor = gfc_get_constructor ();
+  tmp_sym->value->value.constructor->expr = gfc_get_expr ();
+  tmp_sym->value->value.constructor->expr->expr_type = EXPR_NULL;
+  tmp_sym->value->value.constructor->expr->ts.is_iso_c = 1;
   /* Must declare c_null_ptr and c_null_funptr as having the
      PARAMETER attribute so they can be used in init expressions.  */
   tmp_sym->attr.flavor = FL_PARAMETER;

diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index e5fce02..5ce5dce 100644 (file)
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -1,5 +1,5 @@
 /* Expression translation
-   Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009
+   Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
    Free Software Foundation, Inc.
    Contributed by Paul Brook <paul@nowt.org>
    and Steven Bosscher <s.bosscher@student.tudelft.nl>
@@ -4214,6 +4214,19 @@ 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 (COMPONENT_REF, TREE_TYPE (field),
+                            dest, field, NULL_TREE);
+         tmp = fold_build2 (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 (COMPONENT_REF, TREE_TYPE (field),
                         dest, field, NULL_TREE);

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 3e992e3..fc9ee83 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,8 @@
+2010-01-09  Tobias Burnus  <burnus@net-b.de>
+
+       PR fortran/41298
+       * gfortran.dg/c_ptr_tests_14.f90: New test.
+
 2010-01-08  Rainer Orth  <ro@CeBiTec.Uni-Bielefeld.DE>
 
        PR ada/41929

diff --git a/gcc/testsuite/gfortran.dg/c_ptr_tests_14.f90 b/gcc/testsuite/gfortran.dg/c_ptr_tests_14.f90
new file mode 100644 (file)
index 0000000..c4101fb
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/c_ptr_tests_14.f90
@@ -0,0 +1,51 @@
+! { dg-do run }
+! { dg-options "-fdump-tree-original" }
+!
+! PR fortran/41298
+!
+! Check that c_null_ptr default initializer is really applied
+
+module m
+  use iso_c_binding
+  type, public :: fgsl_file
+     type(c_ptr)    :: gsl_file = c_null_ptr
+     type(c_funptr) :: gsl_func = c_null_funptr
+     type(c_ptr)    :: NIptr
+     type(c_funptr) :: NIfunptr
+  end type fgsl_file
+contains
+  subroutine sub(aaa,bbb)
+    type(fgsl_file), intent(out)   :: aaa
+    type(fgsl_file), intent(inout) :: bbb
+  end subroutine
+  subroutine proc() bind(C)
+  end subroutine proc
+end module m
+
+program test
+  use m
+  implicit none
+  type(fgsl_file) :: file, noreinit
+  integer, target :: tgt
+
+  call sub(file, noreinit)
+  if(c_associated(file%gsl_file)) call abort()
+  if(c_associated(file%gsl_func)) call abort()
+
+  file%gsl_file = c_loc(tgt)
+  file%gsl_func = c_funloc(proc)
+  call sub(file, noreinit)
+  if(c_associated(file%gsl_file)) call abort()
+  if(c_associated(file%gsl_func)) call abort()
+end program test
+
+! { dg-final { scan-tree-dump-times "gsl_file = 0B" 1 "original" } }
+! { dg-final { scan-tree-dump-times "gsl_func = 0B" 1 "original" } }
+
+! { dg-final { scan-tree-dump-times "NIptr = 0B"    0 "original" } }
+! { dg-final { scan-tree-dump-times "NIfunptr = 0B" 0 "original" } }
+
+! { dg-final { scan-tree-dump-times "bbb =" 0 "original" } }
+
+! { dg-final { cleanup-tree-dump "original" } }
+! { dg-final { cleanup-modules "m" } }