===================================================================
@@ -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)
===================================================================
@@ -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)
===================================================================
@@ -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
===================================================================
@@ -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
===================================================================
@@ -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
===================================================================
@@ -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
===================================================================
@@ -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
===================================================================
@@ -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
===================================================================
@@ -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
===================================================================
@@ -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)
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 <janus@gcc.gnu.org> PR fortran/54756 * resolve.c (resolve_formal_arglist): Reject polymorphic INTENT(OUT) arguments of pure procedures. 2014-12-19 Janus Weil <janus@gcc.gnu.org> 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.