From: Janus Weil Date: Mon, 12 Feb 2018 17:11:58 +0000 (+0100) Subject: re PR fortran/84273 ([F03] Reject allocatable passed-object dummy argument (proc_ptr_... X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=24abcc441ab1c0e8705e43189efff80daa36acfb;p=gcc.git re PR fortran/84273 ([F03] Reject allocatable passed-object dummy argument (proc_ptr_47.f90)) 2018-02-12 Janus Weil PR fortran/84273 * resolve.c (resolve_component): Fix checks of passed argument in procedure-pointer components. 2018-02-12 Janus Weil PR fortran/84273 * gfortran.dg/proc_ptr_47.f90: Fix invalid test case. * gfortran.dg/proc_ptr_comp_pass_4.f90: Fix and extend test case. From-SVN: r257590 --- diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 43500f1b873..6f416b31e4f 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,9 @@ +2018-02-12 Janus Weil + + PR fortran/84273 + * resolve.c (resolve_component): Fix checks of passed argument in + procedure-pointer components. + 2018-02-11 Francois-Xavier Coudert PR fortran/35299 diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 429c1c481ca..01e2c38952c 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -13706,8 +13706,8 @@ resolve_component (gfc_component *c, gfc_symbol *sym) return false; } - /* Check for C453. */ - if (me_arg->attr.dimension) + /* Check for F03:C453. */ + if (CLASS_DATA (me_arg)->attr.dimension) { gfc_error ("Argument %qs of %qs with PASS(%s) at %L " "must be scalar", me_arg->name, c->name, me_arg->name, @@ -13716,7 +13716,7 @@ resolve_component (gfc_component *c, gfc_symbol *sym) return false; } - if (me_arg->attr.pointer) + if (CLASS_DATA (me_arg)->attr.class_pointer) { gfc_error ("Argument %qs of %qs with PASS(%s) at %L " "may not have the POINTER attribute", me_arg->name, @@ -13725,7 +13725,7 @@ resolve_component (gfc_component *c, gfc_symbol *sym) return false; } - if (me_arg->attr.allocatable) + if (CLASS_DATA (me_arg)->attr.allocatable) { gfc_error ("Argument %qs of %qs with PASS(%s) at %L " "may not be ALLOCATABLE", me_arg->name, c->name, diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index bf841258f41..c4ae3e34ab6 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,9 @@ +2018-02-12 Janus Weil + + PR fortran/84273 + * gfortran.dg/proc_ptr_47.f90: Fix invalid test case. + * gfortran.dg/proc_ptr_comp_pass_4.f90: Fix and extend test case. + 2018-02-12 Tamar Christina PR target/82641 diff --git a/gcc/testsuite/gfortran.dg/proc_ptr_47.f90 b/gcc/testsuite/gfortran.dg/proc_ptr_47.f90 index 43084f67e40..80a78f3852d 100644 --- a/gcc/testsuite/gfortran.dg/proc_ptr_47.f90 +++ b/gcc/testsuite/gfortran.dg/proc_ptr_47.f90 @@ -21,13 +21,9 @@ contains function foo(A) - class(AA), allocatable :: A + class(AA) :: A type(AA) foo - if (.not.allocated (A)) then - allocate (A, source = AA (2, foo)) - endif - select type (A) type is (AA) foo = AA (3, foo) diff --git a/gcc/testsuite/gfortran.dg/proc_ptr_comp_pass_4.f90 b/gcc/testsuite/gfortran.dg/proc_ptr_comp_pass_4.f90 index b0e7a772723..1632e274821 100644 --- a/gcc/testsuite/gfortran.dg/proc_ptr_comp_pass_4.f90 +++ b/gcc/testsuite/gfortran.dg/proc_ptr_comp_pass_4.f90 @@ -37,22 +37,23 @@ module m type :: t8 procedure(foo8), pass, pointer :: f8 ! { dg-error "must be of the derived type" } + procedure(foo9), pass, pointer :: f9 ! { dg-error "Non-polymorphic passed-object dummy argument" } end type contains subroutine foo1 (x1,y1) - type(t1) :: x1(:) + class(t1) :: x1(:) type(t1) :: y1 end subroutine subroutine foo2 (x2,y2) - type(t2),pointer :: x2 + class(t2),pointer :: x2 type(t2) :: y2 end subroutine subroutine foo3 (x3,y3) - type(t3),allocatable :: x3 + class(t3),allocatable :: x3 type(t3) :: y3 end subroutine @@ -69,4 +70,8 @@ contains integer :: i end function + subroutine foo9(x) + type(t8) :: x + end subroutine + end module m