+2014-12-27 Janus Weil <janus@gcc.gnu.org>
+
+ PR fortran/54756
+ * resolve.c (resolve_formal_arglist): Reject polymorphic INTENT(OUT)
+ arguments of pure procedures.
+
2014-12-22 Tobias Burnus <burnus@net-b.de>
* trans-intrinsic.c (gfc_conv_intrinsic_caf_get, conv_caf_send):
&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)
+2014-12-27 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.
+
2014-12-27 Segher Boessenkool <segher@kernel.crashing.org>
* lib/ubsan-dg.exp (check_effective_target_fsanitize_undefined):
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
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)
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
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
--- /dev/null
+! { dg-do compile }
+!
+! PR 54756: [OOP] [F08] Should reject CLASS, intent(out) in PURE procedures
+!
+! Contributed by Tobias Burnus <burnus@gcc.gnu.org>
+
+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" } }
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
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
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
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
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
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
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
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
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)
projects / gcc.git / commitdiff