From e40ac2fe821bf0c648bf203dc846883cec7ac50b Mon Sep 17 00:00:00 2001 From: janus Date: Fri, 26 Jun 2009 22:11:15 +0000 Subject: [PATCH] 2009-06-26 Janus Weil PR fortran/39997 PR fortran/40541 * decl.c (add_hidden_procptr_result): Copy the typespec to the hidden result. * expr.c (gfc_check_pointer_assign): Enable interface check for procedure pointer assignments where the rhs is a function returning a procedure pointer. * resolve.c (resolve_symbol): If an external procedure with unspecified return type can not be implicitly typed, it must be a subroutine. 2009-06-26 Janus Weil PR fortran/39997 PR fortran/40541 * gfortran.dg/proc_ptr_15.f90: Fixed and extended. * gfortran.dg/proc_ptr_common_1.f90: Fixed invalid test case. * gfortran.dg/proc_ptr_result_1.f90: Ditto. * gfortran.dg/proc_ptr_result_5.f90: New. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@148996 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/ChangeLog | 12 ++++++++++++ gcc/fortran/decl.c | 1 + gcc/fortran/expr.c | 12 ++++++++---- gcc/fortran/resolve.c | 5 +++++ gcc/testsuite/ChangeLog | 9 +++++++++ gcc/testsuite/gfortran.dg/proc_ptr_15.f90 | 3 ++- gcc/testsuite/gfortran.dg/proc_ptr_common_1.f90 | 5 +++-- gcc/testsuite/gfortran.dg/proc_ptr_result_1.f90 | 22 +++++++++++++++------- gcc/testsuite/gfortran.dg/proc_ptr_result_5.f90 | 20 ++++++++++++++++++++ 9 files changed, 75 insertions(+), 14 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/proc_ptr_result_5.f90 diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index d8ea53d587a..2cfbe24316a 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,15 @@ +2009-06-26 Janus Weil + + PR fortran/39997 + PR fortran/40541 + * decl.c (add_hidden_procptr_result): Copy the typespec to the hidden + result. + * expr.c (gfc_check_pointer_assign): Enable interface check for + procedure pointer assignments where the rhs is a function returning a + procedure pointer. + * resolve.c (resolve_symbol): If an external procedure with unspecified + return type can not be implicitly typed, it must be a subroutine. + 2009-06-24 Janus Weil PR fortran/40427 diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c index 021392d427c..179d1e2e61a 100644 --- a/gcc/fortran/decl.c +++ b/gcc/fortran/decl.c @@ -4117,6 +4117,7 @@ add_hidden_procptr_result (gfc_symbol *sym) sym->result->attr.pointer = sym->attr.pointer; sym->result->attr.external = sym->attr.external; sym->result->attr.referenced = sym->attr.referenced; + sym->result->ts = sym->ts; sym->attr.proc_pointer = 0; sym->attr.pointer = 0; sym->attr.external = 0; diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c index d2f73d6d461..2049fa400b1 100644 --- a/gcc/fortran/expr.c +++ b/gcc/fortran/expr.c @@ -3189,10 +3189,14 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue) /* TODO: Enable interface check for PPCs. */ if (is_proc_ptr_comp (rvalue, NULL)) return SUCCESS; - if (rvalue->expr_type == EXPR_VARIABLE - && !gfc_compare_interfaces (lvalue->symtree->n.sym, - rvalue->symtree->n.sym, 0, 1, err, - sizeof(err))) + if ((rvalue->expr_type == EXPR_VARIABLE + && !gfc_compare_interfaces (lvalue->symtree->n.sym, + rvalue->symtree->n.sym, 0, 1, err, + sizeof(err))) + || (rvalue->expr_type == EXPR_FUNCTION + && !gfc_compare_interfaces (lvalue->symtree->n.sym, + rvalue->symtree->n.sym->result, 0, 1, + err, sizeof(err)))) { gfc_error ("Interface mismatch in procedure pointer assignment " "at %L: %s", &rvalue->where, err); diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 9bb6e226d1c..9ea2a2d24d3 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -9551,6 +9551,11 @@ resolve_symbol (gfc_symbol *sym) if (sym->attr.flavor == FL_VARIABLE || sym->attr.flavor == FL_PARAMETER) gfc_set_default_type (sym, 1, NULL); + if (sym->attr.flavor == FL_PROCEDURE && sym->attr.external + && !sym->attr.function && !sym->attr.subroutine + && gfc_get_default_type (sym->name, sym->ns)->type == BT_UNKNOWN) + gfc_add_subroutine (&sym->attr, sym->name, &sym->declared_at); + if (sym->attr.flavor == FL_PROCEDURE && sym->attr.function) { /* The specific case of an external procedure should emit an error diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 4956bfc45a3..cdfe1ff8b97 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,12 @@ +2009-06-26 Janus Weil + + PR fortran/39997 + PR fortran/40541 + * gfortran.dg/proc_ptr_15.f90: Fixed and extended. + * gfortran.dg/proc_ptr_common_1.f90: Fixed invalid test case. + * gfortran.dg/proc_ptr_result_1.f90: Ditto. + * gfortran.dg/proc_ptr_result_5.f90: New. + 2009-06-26 Janis Johnson PR c/39902 diff --git a/gcc/testsuite/gfortran.dg/proc_ptr_15.f90 b/gcc/testsuite/gfortran.dg/proc_ptr_15.f90 index 57269b0ccf0..3d37ee2d995 100644 --- a/gcc/testsuite/gfortran.dg/proc_ptr_15.f90 +++ b/gcc/testsuite/gfortran.dg/proc_ptr_15.f90 @@ -15,7 +15,7 @@ real(4), external, pointer :: p6 ! valid p2 => iabs p3 => sub -p4 => p2 +p4 => p3 p6 => p1 ! invalid @@ -23,6 +23,7 @@ p1 => iabs ! { dg-error "Type/kind mismatch in return value" } p1 => p2 ! { dg-error "Type/kind mismatch in return value" } p1 => p5 ! { dg-error "Type/kind mismatch in return value" } p6 => iabs ! { dg-error "Type/kind mismatch in return value" } +p4 => p2 ! { dg-error "is not a subroutine" } contains diff --git a/gcc/testsuite/gfortran.dg/proc_ptr_common_1.f90 b/gcc/testsuite/gfortran.dg/proc_ptr_common_1.f90 index 0cfdec03d5a..df2ef0b79cc 100644 --- a/gcc/testsuite/gfortran.dg/proc_ptr_common_1.f90 +++ b/gcc/testsuite/gfortran.dg/proc_ptr_common_1.f90 @@ -19,7 +19,7 @@ program main integer :: x,y intrinsic sin,cos procedure(real), pointer :: func1 - external func2 + real, external :: func2 pointer func2 common /com/ func1,func2,x,y x = 5 @@ -27,4 +27,5 @@ program main func1 => cos func2 => sin call one() -end program main +end program main + diff --git a/gcc/testsuite/gfortran.dg/proc_ptr_result_1.f90 b/gcc/testsuite/gfortran.dg/proc_ptr_result_1.f90 index f3f7252a6ad..df830d3b1fc 100644 --- a/gcc/testsuite/gfortran.dg/proc_ptr_result_1.f90 +++ b/gcc/testsuite/gfortran.dg/proc_ptr_result_1.f90 @@ -9,7 +9,7 @@ contains function j() implicit none - procedure(),pointer :: j + procedure(integer),pointer :: j intrinsic iabs j => iabs end function @@ -36,12 +36,20 @@ p => b() if (p(-2)/=2) call abort() p => c() if (p(-3)/=3) call abort() -p => d() -if (p(-4)/=4) call abort() + +ps => d() +x = 4 +call ps(x) +if (x/=16) call abort() + p => dd() if (p(-4)/=4) call abort() -p => e(iabs) -if (p(-5)/=5) call abort() + +ps => e(sub) +x = 5 +call ps(x) +if (x/=25) call abort() + p => ee() if (p(-5)/=5) call abort() p => f() @@ -87,7 +95,7 @@ contains function d() pointer :: d external d - d => iabs + d => sub end function function dd() @@ -157,7 +165,7 @@ contains end function function k(arg) - procedure(),pointer :: k,arg + procedure(integer),pointer :: k,arg k => iabs arg => k end function diff --git a/gcc/testsuite/gfortran.dg/proc_ptr_result_5.f90 b/gcc/testsuite/gfortran.dg/proc_ptr_result_5.f90 new file mode 100644 index 00000000000..0e60cbb2a81 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/proc_ptr_result_5.f90 @@ -0,0 +1,20 @@ +! { dg-do compile } +! +! PR 40541: Assignment checking for proc-pointer => proc-ptr-returning-function() +! +! Contributed by Tobias Burnus + +program test + procedure(real), pointer :: p + p => f() ! { dg-error "Type/kind mismatch in return value" } +contains + function f() + pointer :: f + interface + logical(1) function f() + end function + end interface + f = .true._1 + end function f +end program test + -- 2.11.0