From: burnus Date: Mon, 29 Jun 2009 21:02:17 +0000 (+0000) Subject: 2009-06-29 Tobias Burnus X-Git-Url: http://git.sourceforge.jp/view?p=pf3gnuchains%2Fgcc-fork.git;a=commitdiff_plain;h=91cf6ba3f39e8d8ae45283cb3af328c1583eeb75 2009-06-29 Tobias Burnus 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 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 --- 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 + + 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 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{} +-fcheck=@var{} -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 + + 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 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