re PR fortran/54756 ([OOP] [F08] Should reject CLASS, intent(out) in PURE procedures)

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-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.

From-SVN: r219085

gcc/fortran/ChangeLog

+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):

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)

gcc/testsuite/ChangeLog

+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):

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)

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

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

gcc/testsuite/gfortran.dg/class_dummy_5.f90

+! { 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" } }

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

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

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

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

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

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)