Hi all,
after committing my recent patch for PR 64209, I realized that the
accompanying test case is actually invalid in one aspect and that
there is already a PR (and patch) for that problem: PR 54756. It's
about F08 forbidding polymorphic INTENT(OUT) arguments in pure
procedures. The reason for this restriction is essentially that a
finalizer (if present) would need to be called for such an argument,
and the finalizer could be impure (which in general can not be checked
at compile time). The constraint technically only exists in F08 and
not in F03, but my patch unconditionally rejects such code.
In fact the patch uncovered a good number of cases in the testsuite,
which are invalid in this respect. I fixed all of them by making the
encompassing procedure impure. After that the patch regtests cleanly.
Ok for trunk?
Cheers,
Janus
2014-12-19 Janus Weil <[email protected]>
PR fortran/54756
* resolve.c (resolve_formal_arglist): Reject polymorphic INTENT(OUT)
arguments of pure procedures.
2014-12-19 Janus Weil <[email protected]>
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.
Index: gcc/fortran/resolve.c
===================================================================
--- gcc/fortran/resolve.c (Revision 218978)
+++ gcc/fortran/resolve.c (Arbeitskopie)
@@ -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)
Index: gcc/testsuite/gfortran.dg/class_array_3.f03
===================================================================
--- gcc/testsuite/gfortran.dg/class_array_3.f03 (Revision 218978)
+++ gcc/testsuite/gfortran.dg/class_array_3.f03 (Arbeitskopie)
@@ -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)
Index: gcc/testsuite/gfortran.dg/class_array_7.f03
===================================================================
--- gcc/testsuite/gfortran.dg/class_array_7.f03 (Revision 218978)
+++ gcc/testsuite/gfortran.dg/class_array_7.f03 (Arbeitskopie)
@@ -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
Index: gcc/testsuite/gfortran.dg/class_dummy_4.f03
===================================================================
--- gcc/testsuite/gfortran.dg/class_dummy_4.f03 (Revision 218978)
+++ gcc/testsuite/gfortran.dg/class_dummy_4.f03 (Arbeitskopie)
@@ -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
Index: gcc/testsuite/gfortran.dg/defined_assignment_3.f90
===================================================================
--- gcc/testsuite/gfortran.dg/defined_assignment_3.f90 (Revision 218978)
+++ gcc/testsuite/gfortran.dg/defined_assignment_3.f90 (Arbeitskopie)
@@ -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
Index: gcc/testsuite/gfortran.dg/defined_assignment_5.f90
===================================================================
--- gcc/testsuite/gfortran.dg/defined_assignment_5.f90 (Revision 218978)
+++ gcc/testsuite/gfortran.dg/defined_assignment_5.f90 (Arbeitskopie)
@@ -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
Index: gcc/testsuite/gfortran.dg/elemental_subroutine_10.f90
===================================================================
--- gcc/testsuite/gfortran.dg/elemental_subroutine_10.f90 (Revision
218978)
+++ gcc/testsuite/gfortran.dg/elemental_subroutine_10.f90 (Arbeitskopie)
@@ -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
Index: gcc/testsuite/gfortran.dg/typebound_operator_4.f03
===================================================================
--- gcc/testsuite/gfortran.dg/typebound_operator_4.f03 (Revision 218978)
+++ gcc/testsuite/gfortran.dg/typebound_operator_4.f03 (Arbeitskopie)
@@ -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
Index: gcc/testsuite/gfortran.dg/typebound_proc_16.f03
===================================================================
--- gcc/testsuite/gfortran.dg/typebound_proc_16.f03 (Revision 218978)
+++ gcc/testsuite/gfortran.dg/typebound_proc_16.f03 (Arbeitskopie)
@@ -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
Index: gcc/testsuite/gfortran.dg/unlimited_polymorphic_19.f90
===================================================================
--- gcc/testsuite/gfortran.dg/unlimited_polymorphic_19.f90 (Revision
218978)
+++ gcc/testsuite/gfortran.dg/unlimited_polymorphic_19.f90 (Arbeitskopie)
@@ -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)
! { dg-do compile }
!
! PR 54756: [OOP] [F08] Should reject CLASS, intent(out) in PURE procedures
!
! Contributed by Tobias Burnus <[email protected]>
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" } }
