2009-06-29 Tobias Burnus <burnus@net-b.de>

        PR fortran/40580
        * trans-expr.c  (gfc_conv_procedure_call): Add -fcheck=pointer
        * check.
        * libgfortran.h: Add GFC_RTCHECK_POINTER.
        * invoke.texi (-fcheck): Document new pointer option.
        * options.c (gfc_handle_runtime_check_option): Handle pointer
        * option.

        * gfortran.texi (C Binding): Improve wording.
        * iso-c-binding.def: Remove obsolete comment.


2009-06-29  Tobias Burnus  <burnus@net-b.de>

        PR fortran/40580
        * pointer_check_1.f90: New test.
        * pointer_check_2.f90: New test.
        * pointer_check_3.f90: New test.
        * pointer_check_4.f90: New test.
        * pointer_check_5.f90: New test.



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

13 files changed, 521 insertions, 10 deletions

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 976a448a3b1..27d47cfed8e 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,14 @@
+2009-06-29  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/40580
+	* trans-expr.c  (gfc_conv_procedure_call): Add -fcheck=pointer check.
+	* libgfortran.h: Add GFC_RTCHECK_POINTER.
+	* invoke.texi (-fcheck): Document new pointer option.
+	* options.c (gfc_handle_runtime_check_option): Handle pointer option.
+
+	* gfortran.texi (C Binding): Improve wording.
+	* iso-c-binding.def: Remove obsolete comment.
+
 2009-06-29  Paul Thomas  <pault@gcc.gnu.org>
 
 	PR fortran/40551
diff --git a/gcc/fortran/gfortran.texi b/gcc/fortran/gfortran.texi
index f0b1c675922..f9e49325b8e 100644
--- a/gcc/fortran/gfortran.texi
+++ b/gcc/fortran/gfortran.texi
@@ -1965,10 +1965,10 @@ a macro. Use the @code{IERRNO} intrinsic (GNU extension) instead.
 Subroutines and functions have to have the @code{BIND(C)} attribute to
 be compatible with C. The dummy argument declaration is relatively
 straightforward. However, one needs to be careful because C uses
-call-by-value by default while GNU Fortran uses call-by-reference.
-Furthermore, strings and pointers are handled differently. Note that
-only explicit size and assumed-size arrays are supported but not
-assumed-shape or allocatable arrays.
+call-by-value by default while Fortran behaves usually similar to
+call-by-reference. Furthermore, strings and pointers are handled
+differently. Note that only explicit size and assumed-size arrays are
+supported but not assumed-shape or allocatable arrays.
 
 To pass a variable by value, use the @code{VALUE} attribute.
 Thus the following C prototype
@@ -2277,7 +2277,7 @@ initialization using @code{_gfortran_set_args}.
 Default: enabled.
 @item @var{option}[6] @tab Enables run-time checking. Possible values
 are (bitwise or-ed): GFC_RTCHECK_BOUNDS (1), GFC_RTCHECK_ARRAY_TEMPS (2),
-GFC_RTCHECK_RECURSION (4), GFC_RTCHECK_DO (16).
+GFC_RTCHECK_RECURSION (4), GFC_RTCHECK_DO (16), GFC_RTCHECK_POINTER (32).
 Default: disabled.
 @item @var{option}[7] @tab If non zero, range checking is enabled.
 Default: enabled. See -frange-check (@pxref{Code Gen Options}).
diff --git a/gcc/fortran/invoke.texi b/gcc/fortran/invoke.texi
index c471521bd1c..5d0448f3cbe 100644
--- a/gcc/fortran/invoke.texi
+++ b/gcc/fortran/invoke.texi
@@ -166,7 +166,7 @@ and warnings}.
 @gccoptlist{-fno-automatic  -ff2c  -fno-underscoring @gol
 -fwhole-file -fsecond-underscore @gol
 -fbounds-check -fcheck-array-temporaries  -fmax-array-constructor =@var{n} @gol
--fcheck=@var{<all|array-temps|bounds|do|recursion>}
+-fcheck=@var{<all|array-temps|bounds|do|pointer|recursion>}
 -fmax-stack-var-size=@var{n} @gol
 -fpack-derived  -frepack-arrays  -fshort-enums  -fexternal-blas @gol
 -fblas-matmul-limit=@var{n} -frecursive -finit-local-zero @gol
@@ -1203,6 +1203,7 @@ by use of the @option{-ff2c} option.
 @opindex @code{fcheck}
 @cindex array, bounds checking
 @cindex bounds checking
+@cindex pointer checking
 @cindex range checking
 @cindex subscript checking
 @cindex checking subscripts
@@ -1241,6 +1242,9 @@ checking substring references.
 Enable generation of run-time checks for invalid modification of loop
 iteration variables.
 
+@item @samp{pointer}
+Enable generation of run-time checks for pointers and allocatables.
+
 @item @samp{recursion}
 Enable generation of run-time checks for recursively called subroutines and
 functions which are not marked as recursive. See also @option{-frecursive}.
diff --git a/gcc/fortran/iso-c-binding.def b/gcc/fortran/iso-c-binding.def
index aeeb41de298..a529368765c 100644
--- a/gcc/fortran/iso-c-binding.def
+++ b/gcc/fortran/iso-c-binding.def
@@ -160,8 +160,6 @@ PROCEDURE (ISOCBINDING_F_POINTER, "c_f_pointer")
 PROCEDURE (ISOCBINDING_ASSOCIATED, "c_associated")
 PROCEDURE (ISOCBINDING_LOC, "c_loc")
 PROCEDURE (ISOCBINDING_FUNLOC, "c_funloc")
-
-/* Insert c_f_procpointer, though unsupported for now.  */
 PROCEDURE (ISOCBINDING_F_PROCPOINTER, "c_f_procpointer")
 
 #undef NAMED_INTCST
diff --git a/gcc/fortran/libgfortran.h b/gcc/fortran/libgfortran.h
index 839279e413e..a18fdce2e88 100644
--- a/gcc/fortran/libgfortran.h
+++ b/gcc/fortran/libgfortran.h
@@ -47,8 +47,10 @@ along with GCC; see the file COPYING3.  If not see
 #define GFC_RTCHECK_ARRAY_TEMPS (1<<1)
 #define GFC_RTCHECK_RECURSION   (1<<2)
 #define GFC_RTCHECK_DO          (1<<3)
+#define GFC_RTCHECK_POINTER     (1<<4)
 #define GFC_RTCHECK_ALL        (GFC_RTCHECK_BOUNDS | GFC_RTCHECK_ARRAY_TEMPS \
-				| GFC_RTCHECK_RECURSION | GFC_RTCHECK_DO)
+				| GFC_RTCHECK_RECURSION | GFC_RTCHECK_DO \
+				| GFC_RTCHECK_POINTER)
 
 
 /* Possible values for the CONVERT I/O specifier.  */
diff --git a/gcc/fortran/options.c b/gcc/fortran/options.c
index 3654e9261a1..ff0a80983da 100644
--- a/gcc/fortran/options.c
+++ b/gcc/fortran/options.c
@@ -471,10 +471,11 @@ gfc_handle_runtime_check_option (const char *arg)
 {
   int result, pos = 0, n;
   static const char * const optname[] = { "all", "bounds", "array-temps",
-					  "recursion", "do", NULL };
+					  "recursion", "do", "pointer", NULL };
   static const int optmask[] = { GFC_RTCHECK_ALL, GFC_RTCHECK_BOUNDS,
 				 GFC_RTCHECK_ARRAY_TEMPS,
 				 GFC_RTCHECK_RECURSION, GFC_RTCHECK_DO,
+				 GFC_RTCHECK_POINTER,
 				 0 };
  
   while (*arg)
diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index 6a38f10f656..19ac1390f82 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -2772,6 +2772,48 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 	  gfc_add_expr_to_block (&se->post, tmp);
         }
 
+      /* Add argument checking of passing an unallocated/NULL actual to
+         a nonallocatable/nonpointer dummy.  */
+
+      if (gfc_option.rtcheck & GFC_RTCHECK_POINTER)
+        {
+	  gfc_symbol *sym;
+	  char *msg;
+	  tree cond;
+
+	  if (e->expr_type == EXPR_VARIABLE)
+	    sym = e->symtree->n.sym;
+	  else if (e->expr_type == EXPR_FUNCTION)
+	    sym = e->symtree->n.sym->result;
+	  else
+	    goto end_pointer_check;
+
+	  if (sym->attr.allocatable
+	      && (fsym == NULL || !fsym->attr.allocatable))
+	    asprintf (&msg, "Allocatable actual argument '%s' is not "
+		      "allocated", sym->name);
+	  else if (sym->attr.pointer
+	      && (fsym == NULL || !fsym->attr.pointer))
+	    asprintf (&msg, "Pointer actual argument '%s' is not "
+		      "associated", sym->name);
+          else if (sym->attr.proc_pointer
+	      && (fsym == NULL || !fsym->attr.proc_pointer))
+	    asprintf (&msg, "Proc-pointer actual argument '%s' is not "
+		      "associated", sym->name);
+	  else
+	    goto end_pointer_check;
+
+	  cond  = fold_build2 (EQ_EXPR, boolean_type_node, parmse.expr,
+			       fold_convert (TREE_TYPE (parmse.expr),
+					     null_pointer_node));
+ 
+	  gfc_trans_runtime_check (true, false, cond, &se->pre, &e->where,
+				   msg);
+	  gfc_free (msg);
+        }
+      end_pointer_check:
+
+
       /* Character strings are passed as two parameters, a length and a
          pointer - except for Bind(c) which only passes the pointer.  */
       if (parmse.string_length != NULL_TREE && !sym->attr.is_bind_c)
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index d8ed7cb2090..3adb59d22a3 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,12 @@
+2009-06-29  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/40580
+	* pointer_check_1.f90: New test.
+	* pointer_check_2.f90: New test.
+	* pointer_check_3.f90: New test.
+	* pointer_check_4.f90: New test.
+	* pointer_check_5.f90: New test.
+
 2009-06-29  Paul Thomas  <pault@gcc.gnu.org>
 
 	PR fortran/40551
diff --git a/gcc/testsuite/gfortran.dg/pointer_check_1.f90 b/gcc/testsuite/gfortran.dg/pointer_check_1.f90
new file mode 100644
index 00000000000..6d43bf3029f
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pointer_check_1.f90
@@ -0,0 +1,86 @@
+! { dg-do run }
+! { dg-options "-fcheck=pointer" }
+! { dg-shouldfail "Unassociated/unallocated actual argument" }
+!
+! { dg-output ".*At line 53 .*Allocatable actual argument 'alloc2' is not allocated" }
+!
+! PR fortran/40580
+!
+! Run-time check of passing deallocated/nonassociated actuals
+! to nonallocatable/nonpointer dummies.
+!
+! Check for variable actuals
+!
+
+subroutine test1(a)
+  integer :: a
+  a = 4444
+end subroutine test1
+
+subroutine test2(a)
+  integer :: a(2)
+  a = 4444
+end subroutine test2
+
+subroutine ppTest(f)
+  implicit none
+  external f
+  call f()
+end subroutine ppTest
+
+Program RunTimeCheck
+  implicit none
+  external :: test1, test2, ppTest
+  integer, pointer :: ptr1, ptr2(:)
+  integer, allocatable :: alloc2(:)
+  procedure(), pointer :: pptr
+
+  allocate(ptr1,ptr2(2),alloc2(2))
+  pptr => sub
+  ! OK
+  call test1(ptr1)
+  call test3(ptr1)
+
+  call test2(ptr2)
+  call test2(alloc2)
+  call test4(ptr2)
+  call test4(alloc2)
+  call ppTest(pptr)
+  call ppTest2(pptr)
+
+  ! Invalid 1:
+  deallocate(alloc2)
+  call test2(alloc2)
+!  call test4(alloc2)
+
+  ! Invalid 2:
+   deallocate(ptr1,ptr2)
+   nullify(ptr1,ptr2)
+!   call test1(ptr1)
+!   call test3(ptr1)
+!   call test2(ptr2)
+!   call test4(ptr2)
+
+  ! Invalid 3:
+  nullify(pptr)
+!  call ppTest(pptr)
+  call ppTest2(pptr)
+
+contains
+  subroutine test3(b)
+    integer :: b
+    b = 333
+  end subroutine test3
+  subroutine test4(b)
+    integer :: b(2)
+    b = 333
+  end subroutine test4
+  subroutine sub()
+    print *, 'Hello World'
+  end subroutine sub
+  subroutine ppTest2(f)
+    implicit none
+    procedure(sub) :: f
+    call f()
+  end subroutine ppTest2
+end Program RunTimeCheck
diff --git a/gcc/testsuite/gfortran.dg/pointer_check_2.f90 b/gcc/testsuite/gfortran.dg/pointer_check_2.f90
new file mode 100644
index 00000000000..2359b4ae8d2
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pointer_check_2.f90
@@ -0,0 +1,86 @@
+! { dg-do run }
+! { dg-options "-fcheck=pointer" }
+! { dg-shouldfail "Unassociated/unallocated actual argument" }
+!
+! { dg-output ".*At line 60.*Pointer actual argument 'ptr1' is not associated" }
+!
+! PR fortran/40580
+!
+! Run-time check of passing deallocated/nonassociated actuals
+! to nonallocatable/nonpointer dummies.
+!
+! Check for variable actuals
+!
+
+subroutine test1(a)
+  integer :: a
+  a = 4444
+end subroutine test1
+
+subroutine test2(a)
+  integer :: a(2)
+  a = 4444
+end subroutine test2
+
+subroutine ppTest(f)
+  implicit none
+  external f
+  call f()
+end subroutine ppTest
+
+Program RunTimeCheck
+  implicit none
+  external :: test1, test2, ppTest
+  integer, pointer :: ptr1, ptr2(:)
+  integer, allocatable :: alloc2(:)
+  procedure(), pointer :: pptr
+
+  allocate(ptr1,ptr2(2),alloc2(2))
+  pptr => sub
+  ! OK
+  call test1(ptr1)
+  call test3(ptr1)
+
+  call test2(ptr2)
+  call test2(alloc2)
+  call test4(ptr2)
+  call test4(alloc2)
+  call ppTest(pptr)
+  call ppTest2(pptr)
+
+  ! Invalid 1:
+  deallocate(alloc2)
+!  call test2(alloc2)
+!  call test4(alloc2)
+
+  ! Invalid 2:
+   deallocate(ptr1,ptr2)
+   nullify(ptr1,ptr2)
+!   call test1(ptr1)
+   call test3(ptr1)
+!   call test2(ptr2)
+!   call test4(ptr2)
+
+  ! Invalid 3:
+  nullify(pptr)
+!  call ppTest(pptr)
+  call ppTest2(pptr)
+
+contains
+  subroutine test3(b)
+    integer :: b
+    b = 333
+  end subroutine test3
+  subroutine test4(b)
+    integer :: b(2)
+    b = 333
+  end subroutine test4
+  subroutine sub()
+    print *, 'Hello World'
+  end subroutine sub
+  subroutine ppTest2(f)
+    implicit none
+    procedure(sub) :: f
+    call f()
+  end subroutine ppTest2
+end Program RunTimeCheck
diff --git a/gcc/testsuite/gfortran.dg/pointer_check_3.f90 b/gcc/testsuite/gfortran.dg/pointer_check_3.f90
new file mode 100644
index 00000000000..23596e44e4b
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pointer_check_3.f90
@@ -0,0 +1,86 @@
+! { dg-do run }
+! { dg-options "-fcheck=pointer" }
+! { dg-shouldfail "Unassociated/unallocated actual argument" }
+!
+! { dg-output ".*At line 61.*Pointer actual argument 'ptr2' is not associated" }
+!
+! PR fortran/40580
+!
+! Run-time check of passing deallocated/nonassociated actuals
+! to nonallocatable/nonpointer dummies.
+!
+! Check for variable actuals
+!
+
+subroutine test1(a)
+  integer :: a
+  a = 4444
+end subroutine test1
+
+subroutine test2(a)
+  integer :: a(2)
+  a = 4444
+end subroutine test2
+
+subroutine ppTest(f)
+  implicit none
+  external f
+  call f()
+end subroutine ppTest
+
+Program RunTimeCheck
+  implicit none
+  external :: test1, test2, ppTest
+  integer, pointer :: ptr1, ptr2(:)
+  integer, allocatable :: alloc2(:)
+  procedure(), pointer :: pptr
+
+  allocate(ptr1,ptr2(2),alloc2(2))
+  pptr => sub
+  ! OK
+  call test1(ptr1)
+  call test3(ptr1)
+
+  call test2(ptr2)
+  call test2(alloc2)
+  call test4(ptr2)
+  call test4(alloc2)
+  call ppTest(pptr)
+  call ppTest2(pptr)
+
+  ! Invalid 1:
+  deallocate(alloc2)
+!  call test2(alloc2)
+!  call test4(alloc2)
+
+  ! Invalid 2:
+   deallocate(ptr1,ptr2)
+   nullify(ptr1,ptr2)
+!   call test1(ptr1)
+!   call test3(ptr1)
+   call test2(ptr2)
+!   call test4(ptr2)
+
+  ! Invalid 3:
+  nullify(pptr)
+!  call ppTest(pptr)
+  call ppTest2(pptr)
+
+contains
+  subroutine test3(b)
+    integer :: b
+    b = 333
+  end subroutine test3
+  subroutine test4(b)
+    integer :: b(2)
+    b = 333
+  end subroutine test4
+  subroutine sub()
+    print *, 'Hello World'
+  end subroutine sub
+  subroutine ppTest2(f)
+    implicit none
+    procedure(sub) :: f
+    call f()
+  end subroutine ppTest2
+end Program RunTimeCheck
diff --git a/gcc/testsuite/gfortran.dg/pointer_check_4.f90 b/gcc/testsuite/gfortran.dg/pointer_check_4.f90
new file mode 100644
index 00000000000..97eb6fad51e
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pointer_check_4.f90
@@ -0,0 +1,86 @@
+! { dg-do run }
+! { dg-options "-fcheck=pointer" }
+! { dg-shouldfail "Unassociated/unallocated actual argument" }
+!
+! { dg-output ".*At line 66.*Proc-pointer actual argument 'pptr' is not associated" }
+!
+! PR fortran/40580
+!
+! Run-time check of passing deallocated/nonassociated actuals
+! to nonallocatable/nonpointer dummies.
+!
+! Check for variable actuals
+!
+
+subroutine test1(a)
+  integer :: a
+  a = 4444
+end subroutine test1
+
+subroutine test2(a)
+  integer :: a(2)
+  a = 4444
+end subroutine test2
+
+subroutine ppTest(f)
+  implicit none
+  external f
+  call f()
+end subroutine ppTest
+
+Program RunTimeCheck
+  implicit none
+  external :: test1, test2, ppTest
+  integer, pointer :: ptr1, ptr2(:)
+  integer, allocatable :: alloc2(:)
+  procedure(), pointer :: pptr
+
+  allocate(ptr1,ptr2(2),alloc2(2))
+  pptr => sub
+  ! OK
+  call test1(ptr1)
+  call test3(ptr1)
+
+  call test2(ptr2)
+  call test2(alloc2)
+  call test4(ptr2)
+  call test4(alloc2)
+  call ppTest(pptr)
+  call ppTest2(pptr)
+
+  ! Invalid 1:
+  deallocate(alloc2)
+!  call test2(alloc2)
+!  call test4(alloc2)
+
+  ! Invalid 2:
+   deallocate(ptr1,ptr2)
+   nullify(ptr1,ptr2)
+!   call test1(ptr1)
+!   call test3(ptr1)
+!   call test2(ptr2)
+!   call test4(ptr2)
+
+  ! Invalid 3:
+  nullify(pptr)
+  call ppTest(pptr)
+!  call ppTest2(pptr)
+
+contains
+  subroutine test3(b)
+    integer :: b
+    b = 333
+  end subroutine test3
+  subroutine test4(b)
+    integer :: b(2)
+    b = 333
+  end subroutine test4
+  subroutine sub()
+    print *, 'Hello World'
+  end subroutine sub
+  subroutine ppTest2(f)
+    implicit none
+    procedure(sub) :: f
+    call f()
+  end subroutine ppTest2
+end Program RunTimeCheck
diff --git a/gcc/testsuite/gfortran.dg/pointer_check_5.f90 b/gcc/testsuite/gfortran.dg/pointer_check_5.f90
new file mode 100644
index 00000000000..440d9a879ac
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pointer_check_5.f90
@@ -0,0 +1,100 @@
+! { dg-do run }
+! { dg-options "-fcheck=pointer" }
+! { dg-shouldfail "Unassociated/unallocated actual argument" }
+! 
+! { dg-output ".*At line 46 .*Pointer actual argument 'getptr' is not associated" }
+!
+! PR fortran/40580
+!
+! Run-time check of passing deallocated/nonassociated actuals
+! to nonallocatable/nonpointer dummies.
+!
+! Check for function actuals
+!
+
+subroutine test1(a)
+  integer :: a
+  print *, a
+end subroutine test1
+
+subroutine test2(a)
+  integer :: a(2)
+  print *, a
+end subroutine test2
+
+subroutine ppTest(f)
+  implicit none
+  external f
+  call f()
+end subroutine ppTest
+
+Program RunTimeCheck
+  implicit none
+  external :: test1, test2, ppTest
+  procedure(), pointer :: pptr
+
+  ! OK
+  call test1(getPtr(.true.))
+  call test2(getPtrArray(.true.))
+  call test2(getAlloc(.true.))
+
+  ! OK but fails due to PR 40593
+!  call ppTest(getProcPtr(.true.))
+!  call ppTest2(getProcPtr(.true.))
+
+  ! Invalid:
+  call test1(getPtr(.false.))
+!  call test2(getAlloc(.false.)) - fails because the check is inserted after
+!                                  _gfortran_internal_pack, which fails with out of memory
+!  call ppTest(getProcPtr(.false.)) - fails due to PR 40593
+!  call ppTest2(getProcPtr(.false.)) - fails due to PR 40593
+
+contains
+  function getPtr(alloc)
+    integer, pointer :: getPtr
+    logical, intent(in) :: alloc
+    if (alloc) then
+      allocate (getPtr)
+      getPtr = 1
+    else
+      nullify (getPtr)
+    end if
+  end function getPtr
+  function getPtrArray(alloc)
+    integer, pointer :: getPtrArray(:)
+    logical, intent(in) :: alloc
+    if (alloc) then
+      allocate (getPtrArray(2))
+      getPtrArray = 1
+    else
+      nullify (getPtrArray)
+    end if
+  end function getPtrArray
+  function getAlloc(alloc)
+    integer, allocatable :: getAlloc(:)
+    logical, intent(in) :: alloc
+    if (alloc) then
+      allocate (getAlloc(2))
+      getAlloc = 2
+    else if (allocated(getAlloc)) then
+      deallocate(getAlloc)
+    end if
+  end function getAlloc
+  subroutine sub()
+    print *, 'Hello World'
+  end subroutine sub
+  function getProcPtr(alloc)
+    procedure(sub), pointer :: getProcPtr
+    logical, intent(in) :: alloc
+    if (alloc) then
+      getProcPtr => sub
+    else
+      nullify (getProcPtr)
+    end if
+  end function getProcPtr
+  subroutine ppTest2(f)
+    implicit none
+    procedure(sub) :: f
+    call f()
+  end subroutine ppTest2
+end Program RunTimeCheck