From: janus Date: Tue, 24 Nov 2009 08:16:32 +0000 (+0000) Subject: 2009-11-24 Janus Weil X-Git-Tag: upstream/4.9.2~32440 X-Git-Url: http://review.tizen.org/git/?a=commitdiff_plain;h=ffe221be5de13e10d034dfec9a01b44aa96ea8b3;p=platform%2Fupstream%2Flinaro-gcc.git 2009-11-24 Janus Weil PR fortran/42045 * resolve.c (resolve_actual_arglist): Make sure procedure pointer actual arguments are resolved correctly. (resolve_function): An EXPR_FUNCTION which is a procedure pointer component, has already been resolved. (resolve_fl_derived): Procedure pointer components should not be implicitly typed. 2009-11-24 Janus Weil PR fortran/42045 * gfortran.dg/proc_ptr_comp_2.f90: Correct invalid test case. * gfortran.dg/proc_ptr_comp_3.f90: Extended test case. * gfortran.dg/proc_ptr_comp_24.f90: New. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@154492 138bc75d-0d04-0410-961f-82ee72b054a4 --- diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 64061e7..862fffa 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,13 @@ +2009-11-24 Janus Weil + + PR fortran/42045 + * resolve.c (resolve_actual_arglist): Make sure procedure pointer + actual arguments are resolved correctly. + (resolve_function): An EXPR_FUNCTION which is a procedure pointer + component, has already been resolved. + (resolve_fl_derived): Procedure pointer components should not be + implicitly typed. + 2009-11-21 Jerry DeLisle PR fortran/41807 diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index bd690a7..740679e 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -1321,6 +1321,8 @@ resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype, e->rank = comp->as->rank; e->expr_type = EXPR_FUNCTION; } + if (gfc_resolve_expr (e) == FAILURE) + return FAILURE; goto argument_list; } @@ -2519,6 +2521,10 @@ resolve_function (gfc_expr *expr) if (expr->symtree) sym = expr->symtree->n.sym; + /* If this is a procedure pointer component, it has already been resolved. */ + if (gfc_is_proc_ptr_comp (expr, NULL)) + return SUCCESS; + if (sym && sym->attr.intrinsic && resolve_intrinsic (sym, &expr->where) == FAILURE) return FAILURE; @@ -10219,8 +10225,9 @@ resolve_fl_derived (gfc_symbol *sym) } else if (c->attr.proc_pointer && c->ts.type == BT_UNKNOWN) { - c->ts = *gfc_get_default_type (c->name, NULL); - c->attr.implicit_type = 1; + /* Since PPCs are not implicitly typed, a PPC without an explicit + interface must be a subroutine. */ + gfc_add_subroutine (&c->attr, c->name, &c->loc); } /* Procedure pointer components: Check PASS arg. */ diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index ccaae0c..50c588c 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,10 @@ +2009-11-24 Janus Weil + + PR fortran/42045 + * gfortran.dg/proc_ptr_comp_2.f90: Correct invalid test case. + * gfortran.dg/proc_ptr_comp_3.f90: Extended test case. + * gfortran.dg/proc_ptr_comp_24.f90: New. + 2009-11-23 Andy Hutchinson * gcc.c-torture/execute/pr40404.c: Use long for bitfield on 16bit diff --git a/gcc/testsuite/gfortran.dg/proc_ptr_comp_2.f90 b/gcc/testsuite/gfortran.dg/proc_ptr_comp_2.f90 index 886e8bf..33e32aa 100644 --- a/gcc/testsuite/gfortran.dg/proc_ptr_comp_2.f90 +++ b/gcc/testsuite/gfortran.dg/proc_ptr_comp_2.f90 @@ -9,7 +9,6 @@ type t procedure(fcn), pointer, nopass :: ppc procedure(abstr), pointer, nopass :: ppc1 - procedure(), nopass, pointer:: iptr3 integer :: i end type @@ -43,11 +42,6 @@ if (base/=12) call abort call foo (f,7) -! Check with implicit interface - obj%iptr3 => iabs - base=obj%iptr3(-9) - if (base/=9) call abort - contains integer function fcn(x) diff --git a/gcc/testsuite/gfortran.dg/proc_ptr_comp_24.f90 b/gcc/testsuite/gfortran.dg/proc_ptr_comp_24.f90 new file mode 100644 index 0000000..8c935c9 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/proc_ptr_comp_24.f90 @@ -0,0 +1,29 @@ +! { dg-do compile } +! +! PR42045: [F03] passing a procedure pointer component to a procedure pointer dummy +! +! Contributed by John McFarland + +PROGRAM prog + TYPE object + PROCEDURE(), POINTER, NOPASS :: f + END TYPE object + TYPE container + TYPE (object), POINTER :: o(:) + END TYPE container + TYPE (container) :: c + TYPE (object) :: o1, o2 + PROCEDURE(), POINTER :: f => NULL() + o1%f => f + CALL set_func(o2,f) + CALL set_func(o2,o1%f) + ALLOCATE( c%o(5) ) + c%o(5)%f => f + CALL set_func(o2,c%o(5)%f) +CONTAINS + SUBROUTINE set_func(o,f) + TYPE (object) :: o + PROCEDURE(), POINTER :: f + o%f => f + END SUBROUTINE set_func +END PROGRAM prog diff --git a/gcc/testsuite/gfortran.dg/proc_ptr_comp_3.f90 b/gcc/testsuite/gfortran.dg/proc_ptr_comp_3.f90 index 74dd4b8..fc8c28d 100644 --- a/gcc/testsuite/gfortran.dg/proc_ptr_comp_3.f90 +++ b/gcc/testsuite/gfortran.dg/proc_ptr_comp_3.f90 @@ -16,6 +16,7 @@ end interface external :: aaargh type :: t + procedure(), pointer, nopass :: ptr1 procedure(real), pointer, nopass :: ptr2 procedure(sub), pointer, nopass :: ptr3 procedure(), pointer, nopass ptr4 ! { dg-error "Expected '::'" } @@ -40,6 +41,7 @@ x%ptr2 => x ! { dg-error "Invalid procedure pointer assignment" } x => x%ptr2 ! { dg-error "Pointer assignment to non-POINTER" } +print *, x%ptr1() ! { dg-error "attribute conflicts with" } call x%ptr2() ! { dg-error "attribute conflicts with" } print *,x%ptr3() ! { dg-error "attribute conflicts with" }