From c19a00337aa1cd579cb51ce5aa71a81261b97fe3 Mon Sep 17 00:00:00 2001 From: Janus Weil Date: Sat, 27 Dec 2014 23:40:21 +0100 Subject: [PATCH] re PR fortran/54756 ([OOP] [F08] Should reject CLASS, intent(out) in PURE procedures) 2014-12-27 Janus Weil PR fortran/54756 * resolve.c (resolve_formal_arglist): Reject polymorphic INTENT(OUT) arguments of pure procedures. 2014-12-27 Janus Weil PR fortran/54756 * gfortran.dg/class_array_3.f03: Fixed invalid test case. * gfortran.dg/class_array_7.f03: Ditto. * gfortran.dg/class_dummy_4.f03: Ditto. * gfortran.dg/defined_assignment_3.f90: Ditto. * gfortran.dg/defined_assignment_5.f90: Ditto. * gfortran.dg/elemental_subroutine_10.f90: Ditto. * gfortran.dg/typebound_operator_4.f03: Ditto. * gfortran.dg/typebound_proc_16.f03: Ditto. * gfortran.dg/unlimited_polymorphic_19.f90: Ditto. * gfortran.dg/class_dummy_5.f90: New test. From-SVN: r219085 --- gcc/fortran/ChangeLog | 6 ++++ gcc/fortran/resolve.c | 9 ++++++ gcc/testsuite/ChangeLog | 14 +++++++++ gcc/testsuite/gfortran.dg/class_array_3.f03 | 4 +-- gcc/testsuite/gfortran.dg/class_array_7.f03 | 2 +- gcc/testsuite/gfortran.dg/class_dummy_4.f03 | 2 +- gcc/testsuite/gfortran.dg/class_dummy_5.f90 | 30 +++++++++++++++++++ .../gfortran.dg/defined_assignment_3.f90 | 2 +- .../gfortran.dg/defined_assignment_5.f90 | 2 +- .../gfortran.dg/elemental_subroutine_10.f90 | 4 +-- .../gfortran.dg/typebound_operator_4.f03 | 3 +- .../gfortran.dg/typebound_proc_16.f03 | 2 +- .../gfortran.dg/unlimited_polymorphic_19.f90 | 4 +-- 13 files changed, 71 insertions(+), 13 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/class_dummy_5.f90 diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 58b2554334b..6912797a456 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,9 @@ +2014-12-27 Janus Weil + + PR fortran/54756 + * resolve.c (resolve_formal_arglist): Reject polymorphic INTENT(OUT) + arguments of pure procedures. + 2014-12-22 Tobias Burnus * trans-intrinsic.c (gfc_conv_intrinsic_caf_get, conv_caf_send): diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 3b8b8695bc1..05a948b749d 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -414,6 +414,15 @@ resolve_formal_arglist (gfc_symbol *proc) &sym->declared_at); } } + + /* F08:C1278a. */ + if (sym->ts.type == BT_CLASS && sym->attr.intent == INTENT_OUT) + { + gfc_error ("INTENT(OUT) argument '%s' of pure procedure %qs at %L" + " may not be polymorphic", sym->name, proc->name, + &sym->declared_at); + continue; + } } if (proc->attr.implicit_pure) diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index ec4d75ea948..4422c960deb 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,17 @@ +2014-12-27 Janus Weil + + PR fortran/54756 + * gfortran.dg/class_array_3.f03: Fixed invalid test case. + * gfortran.dg/class_array_7.f03: Ditto. + * gfortran.dg/class_dummy_4.f03: Ditto. + * gfortran.dg/defined_assignment_3.f90: Ditto. + * gfortran.dg/defined_assignment_5.f90: Ditto. + * gfortran.dg/elemental_subroutine_10.f90: Ditto. + * gfortran.dg/typebound_operator_4.f03: Ditto. + * gfortran.dg/typebound_proc_16.f03: Ditto. + * gfortran.dg/unlimited_polymorphic_19.f90: Ditto. + * gfortran.dg/class_dummy_5.f90: New test. + 2014-12-27 Segher Boessenkool * lib/ubsan-dg.exp (check_effective_target_fsanitize_undefined): diff --git a/gcc/testsuite/gfortran.dg/class_array_3.f03 b/gcc/testsuite/gfortran.dg/class_array_3.f03 index 6db375c9425..cab2b1be874 100644 --- a/gcc/testsuite/gfortran.dg/class_array_3.f03 +++ b/gcc/testsuite/gfortran.dg/class_array_3.f03 @@ -29,7 +29,7 @@ module m_qsort end function lt_cmp end interface interface - elemental subroutine assign(a,b) + impure elemental subroutine assign(a,b) import class(sort_t), intent(out) :: a class(sort_t), intent(in) :: b @@ -100,7 +100,7 @@ contains class(sort_int_t), intent(in) :: a disp_int = a%i end function disp_int - elemental subroutine assign_int (a, b) + impure elemental subroutine assign_int (a, b) class(sort_int_t), intent(out) :: a class(sort_t), intent(in) :: b ! TODO: gfortran does not throw 'class(sort_int_t)' select type (b) diff --git a/gcc/testsuite/gfortran.dg/class_array_7.f03 b/gcc/testsuite/gfortran.dg/class_array_7.f03 index 5c9673ff72b..e6d79d8f6ef 100644 --- a/gcc/testsuite/gfortran.dg/class_array_7.f03 +++ b/gcc/testsuite/gfortran.dg/class_array_7.f03 @@ -19,7 +19,7 @@ module realloc contains - elemental subroutine assign (a, b) + impure elemental subroutine assign (a, b) class(base_type), intent(out) :: a type(base_type), intent(in) :: b a%i = b%i diff --git a/gcc/testsuite/gfortran.dg/class_dummy_4.f03 b/gcc/testsuite/gfortran.dg/class_dummy_4.f03 index fa302bf1ada..24841305bf5 100644 --- a/gcc/testsuite/gfortran.dg/class_dummy_4.f03 +++ b/gcc/testsuite/gfortran.dg/class_dummy_4.f03 @@ -11,7 +11,7 @@ module m1 procedure, pass(x) :: source end type c_stv contains - pure subroutine source(y,x) + subroutine source(y,x) class(c_stv), intent(in) :: x class(c_stv), allocatable, intent(out) :: y end subroutine source diff --git a/gcc/testsuite/gfortran.dg/class_dummy_5.f90 b/gcc/testsuite/gfortran.dg/class_dummy_5.f90 new file mode 100644 index 00000000000..8da19af1ee6 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/class_dummy_5.f90 @@ -0,0 +1,30 @@ +! { dg-do compile } +! +! PR 54756: [OOP] [F08] Should reject CLASS, intent(out) in PURE procedures +! +! Contributed by Tobias Burnus + +module m + type t + contains + final :: fnl ! impure finalizer + end type t +contains + impure subroutine fnl(x) + type(t) :: x + print *,"finalized!" + end subroutine +end + +program test + use m + type(t) :: x + call foo(x) +contains + pure subroutine foo(x) ! { dg-error "may not be polymorphic" } + ! pure subroutine would call impure finalizer + class(t), intent(out) :: x + end subroutine +end + +! { dg-final { cleanup-modules "m" } } diff --git a/gcc/testsuite/gfortran.dg/defined_assignment_3.f90 b/gcc/testsuite/gfortran.dg/defined_assignment_3.f90 index 81a9841434f..ce58cee6359 100644 --- a/gcc/testsuite/gfortran.dg/defined_assignment_3.f90 +++ b/gcc/testsuite/gfortran.dg/defined_assignment_3.f90 @@ -17,7 +17,7 @@ module m0 integer :: j end type contains - elemental subroutine assign0(lhs,rhs) + impure elemental subroutine assign0(lhs,rhs) class(component), intent(out) :: lhs class(component), intent(in) :: rhs lhs%i = 20 diff --git a/gcc/testsuite/gfortran.dg/defined_assignment_5.f90 b/gcc/testsuite/gfortran.dg/defined_assignment_5.f90 index faf38298e42..ca5a9262698 100644 --- a/gcc/testsuite/gfortran.dg/defined_assignment_5.f90 +++ b/gcc/testsuite/gfortran.dg/defined_assignment_5.f90 @@ -38,7 +38,7 @@ module m1 integer :: j = 7 end type contains - elemental subroutine assign1(lhs,rhs) + impure elemental subroutine assign1(lhs,rhs) class(component1), intent(out) :: lhs class(component1), intent(in) :: rhs lhs%i = 30 diff --git a/gcc/testsuite/gfortran.dg/elemental_subroutine_10.f90 b/gcc/testsuite/gfortran.dg/elemental_subroutine_10.f90 index be343e6ff25..011a7046e3a 100644 --- a/gcc/testsuite/gfortran.dg/elemental_subroutine_10.f90 +++ b/gcc/testsuite/gfortran.dg/elemental_subroutine_10.f90 @@ -15,7 +15,7 @@ module m_assertion_character procedure :: write => assertion_array_write end type t_assertion_character contains - elemental subroutine assertion_character( ast, name ) + impure elemental subroutine assertion_character( ast, name ) class(t_assertion_character), intent(out) :: ast character(len=*), intent(in) :: name ast%name = name @@ -37,7 +37,7 @@ module m_assertion_array_character procedure :: write => assertion_array_character_write end type t_assertion_array_character contains - pure subroutine assertion_array_character( ast, name, nast ) + subroutine assertion_array_character( ast, name, nast ) class(t_assertion_array_character), intent(out) :: ast character(len=*), intent(in) :: name integer, intent(in) :: nast diff --git a/gcc/testsuite/gfortran.dg/typebound_operator_4.f03 b/gcc/testsuite/gfortran.dg/typebound_operator_4.f03 index f9a2612530c..836505bba3d 100644 --- a/gcc/testsuite/gfortran.dg/typebound_operator_4.f03 +++ b/gcc/testsuite/gfortran.dg/typebound_operator_4.f03 @@ -34,7 +34,7 @@ CONTAINS add_int = myint (a%value + b) END FUNCTION add_int - PURE SUBROUTINE assign_int (dest, from) + SUBROUTINE assign_int (dest, from) CLASS(myint), INTENT(OUT) :: dest INTEGER, INTENT(IN) :: from dest%value = from @@ -62,7 +62,6 @@ CONTAINS PURE SUBROUTINE iampure () TYPE(myint) :: x - x = 0 ! { dg-bogus "is not PURE" } x = x + 42 ! { dg-bogus "to a impure procedure" } x = x .PLUS. 5 ! { dg-bogus "to a impure procedure" } END SUBROUTINE iampure diff --git a/gcc/testsuite/gfortran.dg/typebound_proc_16.f03 b/gcc/testsuite/gfortran.dg/typebound_proc_16.f03 index e43b3f8065f..33e3579a3c8 100644 --- a/gcc/testsuite/gfortran.dg/typebound_proc_16.f03 +++ b/gcc/testsuite/gfortran.dg/typebound_proc_16.f03 @@ -27,7 +27,7 @@ MODULE rational_numbers r = REAL(this%n)/this%d END FUNCTION - ELEMENTAL SUBROUTINE rat_asgn_i(a,b) + impure ELEMENTAL SUBROUTINE rat_asgn_i(a,b) CLASS(rational),INTENT(OUT) :: a INTEGER,INTENT(IN) :: b a%n = b diff --git a/gcc/testsuite/gfortran.dg/unlimited_polymorphic_19.f90 b/gcc/testsuite/gfortran.dg/unlimited_polymorphic_19.f90 index a2dbaef2e4d..51359d1461c 100644 --- a/gcc/testsuite/gfortran.dg/unlimited_polymorphic_19.f90 +++ b/gcc/testsuite/gfortran.dg/unlimited_polymorphic_19.f90 @@ -12,7 +12,7 @@ MODULE m PROCEDURE :: copy END TYPE t INTERFACE - PURE SUBROUTINE copy_proc_intr(a,b) + SUBROUTINE copy_proc_intr(a,b) CLASS(*), INTENT(IN) :: a CLASS(*), INTENT(OUT) :: b END SUBROUTINE copy_proc_intr @@ -40,7 +40,7 @@ PROGRAM main CALL test%copy(copy_int,copy_x) ! PRINT '(*(I0,:2X))', copy_x CONTAINS - PURE SUBROUTINE copy_int(a,b) + SUBROUTINE copy_int(a,b) CLASS(*), INTENT(IN) :: a CLASS(*), INTENT(OUT) :: b SELECT TYPE(a); TYPE IS(integer) -- 2.30.2