From 40474135d8d7cc3275852d7ed5200e1993c362ad Mon Sep 17 00:00:00 2001 From: burnus Date: Thu, 9 Jul 2009 09:42:34 +0000 Subject: [PATCH] 2009-07-09 Tobias Burnus PR fortran/40604 * intrinsic.c (gfc_convert_type_warn): Set sym->result. * trans-expr.c (gfc_conv_procedure_call): Fix -fcheck=pointer for optional arguments. 2009-07-09 Tobias Burnus PR fortran/40604 * gfortran.dg/pointer_check_6.f90: New test. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@149405 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/ChangeLog | 7 ++ gcc/fortran/intrinsic.c | 1 + gcc/fortran/trans-expr.c | 91 +++++++++++++++----- gcc/testsuite/ChangeLog | 5 ++ gcc/testsuite/gfortran.dg/pointer_check_6.f90 | 118 ++++++++++++++++++++++++++ 5 files changed, 201 insertions(+), 21 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/pointer_check_6.f90 diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 77c5f61f533..3f3feec9243 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,10 @@ +2009-07-09 Tobias Burnus + + PR fortran/40604 + * intrinsic.c (gfc_convert_type_warn): Set sym->result. + * trans-expr.c (gfc_conv_procedure_call): Fix -fcheck=pointer + for optional arguments. + 2009-07-08 Tobias Burnus PR fortran/40675 diff --git a/gcc/fortran/intrinsic.c b/gcc/fortran/intrinsic.c index 7bb10ec245b..9402234b034 100644 --- a/gcc/fortran/intrinsic.c +++ b/gcc/fortran/intrinsic.c @@ -3994,6 +3994,7 @@ gfc_convert_type_warn (gfc_expr *expr, gfc_typespec *ts, int eflag, int wflag) new_expr->shape = gfc_copy_shape (shape, rank); gfc_get_ha_sym_tree (sym->name, &new_expr->symtree); + new_expr->symtree->n.sym->result = new_expr->symtree->n.sym; new_expr->symtree->n.sym->ts = *ts; new_expr->symtree->n.sym->attr.flavor = FL_PROCEDURE; new_expr->symtree->n.sym->attr.function = 1; diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index d4ee169d08e..fe33286a402 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -2784,37 +2784,86 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, /* Add argument checking of passing an unallocated/NULL actual to a nonallocatable/nonpointer dummy. */ - if (gfc_option.rtcheck & GFC_RTCHECK_POINTER) + if (gfc_option.rtcheck & GFC_RTCHECK_POINTER && e != NULL) { - gfc_symbol *sym; + symbol_attribute *attr; char *msg; tree cond; if (e->expr_type == EXPR_VARIABLE) - sym = e->symtree->n.sym; + attr = &e->symtree->n.sym->attr; else if (e->expr_type == EXPR_FUNCTION) - sym = e->symtree->n.sym->result; - else - goto end_pointer_check; + { + /* For intrinsic functions, the gfc_attr are not available. */ + if (e->symtree->n.sym->attr.generic && e->value.function.isym) + 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); + if (e->symtree->n.sym->attr.generic) + attr = &e->value.function.esym->attr; + else + attr = &e->symtree->n.sym->result->attr; + } else goto end_pointer_check; - cond = fold_build2 (EQ_EXPR, boolean_type_node, parmse.expr, - fold_convert (TREE_TYPE (parmse.expr), - null_pointer_node)); + if (attr->optional) + { + /* If the actual argument is an optional pointer/allocatable and + the formal argument takes an nonpointer optional value, + it is invalid to pass a non-present argument on, even + though there is no technical reason for this in gfortran. + See Fortran 2003, Section 12.4.1.6 item (7)+(8). */ + tree present, nullptr, type; + + if (attr->allocatable + && (fsym == NULL || !fsym->attr.allocatable)) + asprintf (&msg, "Allocatable actual argument '%s' is not " + "allocated or not present", e->symtree->n.sym->name); + else if (attr->pointer + && (fsym == NULL || !fsym->attr.pointer)) + asprintf (&msg, "Pointer actual argument '%s' is not " + "associated or not present", + e->symtree->n.sym->name); + else if (attr->proc_pointer + && (fsym == NULL || !fsym->attr.proc_pointer)) + asprintf (&msg, "Proc-pointer actual argument '%s' is not " + "associated or not present", + e->symtree->n.sym->name); + else + goto end_pointer_check; + + present = gfc_conv_expr_present (e->symtree->n.sym); + type = TREE_TYPE (present); + present = fold_build2 (EQ_EXPR, boolean_type_node, present, + fold_convert (type, null_pointer_node)); + type = TREE_TYPE (parmse.expr); + nullptr = fold_build2 (EQ_EXPR, boolean_type_node, parmse.expr, + fold_convert (type, null_pointer_node)); + cond = fold_build2 (TRUTH_ORIF_EXPR, boolean_type_node, + present, nullptr); + } + else + { + if (attr->allocatable + && (fsym == NULL || !fsym->attr.allocatable)) + asprintf (&msg, "Allocatable actual argument '%s' is not " + "allocated", e->symtree->n.sym->name); + else if (attr->pointer + && (fsym == NULL || !fsym->attr.pointer)) + asprintf (&msg, "Pointer actual argument '%s' is not " + "associated", e->symtree->n.sym->name); + else if (attr->proc_pointer + && (fsym == NULL || !fsym->attr.proc_pointer)) + asprintf (&msg, "Proc-pointer actual argument '%s' is not " + "associated", e->symtree->n.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); diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 3dcfad3fe3a..63b2df4d0ce 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,8 @@ +2009-07-09 Tobias Burnus + + PR fortran/40604 + * gfortran.dg/pointer_check_6.f90: New test. + 2009-07-08 Adam Nemet * gcc.target/mips/truncate-5.c: New test. diff --git a/gcc/testsuite/gfortran.dg/pointer_check_6.f90 b/gcc/testsuite/gfortran.dg/pointer_check_6.f90 new file mode 100644 index 00000000000..2f7373fe6ba --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pointer_check_6.f90 @@ -0,0 +1,118 @@ +! { dg-do run } +! { dg-options "-fcheck=pointer" } +! +! { dg-shouldfail "pointer check" } +! { dg-output ".*At line 104 of file .*Fortran runtime error: Pointer actual argument 'a' is not associated.*" } +! +! PR fortran/40604 +! +! The following cases are all valid, but were failing +! for one or the other reason. +! +! Contributed by Janus Weil and Tobias Burnus. +! + +subroutine test1() + call test(uec=-1) +contains + subroutine test(str,uec) + implicit none + character*(*), intent(in), optional:: str + integer, intent(in), optional :: uec + end subroutine +end subroutine test1 + +module m + interface matrixMult + Module procedure matrixMult_C2 + End Interface +contains + subroutine test + implicit none + complex, dimension(0:3,0:3) :: m1,m2 + print *,Trace(MatrixMult(m1,m2)) + end subroutine + complex function trace(a) + implicit none + complex, intent(in), dimension(0:3,0:3) :: a + end function trace + function matrixMult_C2(a,b) result(matrix) + implicit none + complex, dimension(0:3,0:3) :: matrix,a,b + end function matrixMult_C2 +end module m + +SUBROUTINE plotdop(amat) + IMPLICIT NONE + REAL, INTENT (IN) :: amat(3,3) + integer :: i1 + real :: pt(3) + i1 = 1 + pt = MATMUL(amat,(/i1,i1,i1/)) +END SUBROUTINE plotdop + + FUNCTION evaluateFirst(s,n)result(number) + IMPLICIT NONE + CHARACTER(len =*), INTENT(inout) :: s + INTEGER,OPTIONAL :: n + REAL :: number + number = 1.1 + end function + +SUBROUTINE rw_inp(scpos) + IMPLICIT NONE + REAL scpos + + interface + FUNCTION evaluateFirst(s,n)result(number) + IMPLICIT NONE + CHARACTER(len =*), INTENT(inout) :: s + INTEGER,OPTIONAL :: n + REAL :: number + end function + end interface + + CHARACTER(len=100) :: line + scpos = evaluatefirst(line) +END SUBROUTINE rw_inp + +program test + integer, pointer :: a +! nullify(a) + allocate(a) + a = 1 + call sub1a(a) + call sub1b(a) + call sub1c() +contains + subroutine sub1a(a) + integer, pointer :: a + call sub2(a) + call sub3(a) + call sub4(a) + end subroutine sub1a + subroutine sub1b(a) + integer, pointer,optional :: a + call sub2(a) + call sub3(a) + call sub4(a) + end subroutine sub1b + subroutine sub1c(a) + integer, pointer,optional :: a + call sub4(a) +! call sub2(a) ! << Invalid - working correctly, but not allowed in F2003 + call sub3(a) ! << INVALID + end subroutine sub1c + subroutine sub4(b) + integer, optional,pointer :: b + end subroutine + subroutine sub2(b) + integer, optional :: b + end subroutine + subroutine sub3(b) + integer :: b + end subroutine +end + + +! { dg-final { cleanup-modules "m" } } -- 2.11.0