re PR fortran/52864 (Assignment to pointer component for INTENT(IN) dummy argument)

2012-05-03  Tobias Burnus  <burnus@net-b.de>

        PR fortran/52864
        * interface.c (compare_parameter_intent): Remove.
        (check_intents): Remove call, handle CLASS pointer.
        (compare_actual_formal): Handle CLASS pointer.

2012-05-03  Tobias Burnus  <burnus@net-b.de>

        PR fortran/52864
        * gfortran.dg/pointer_intent_7.f90: New.
        * gfortran.dg/pure_formal_3.f90: New.

From-SVN: r187076

gcc/fortran/ChangeLog

+2012-05-03  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/52864
+	* interface.c (compare_parameter_intent): Remove.
+	(check_intents): Remove call, handle CLASS pointer.
+	(compare_actual_formal): Handle CLASS pointer.
+
 2012-04-30  Jan Hubicka  <jh@suse.cz>
 
 	* f95-lang.c (gfc_finish): Update comments.

gcc/fortran/interface.c

@@ -2517,7 +2517,9 @@ compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
 				 ? _("actual argument to INTENT = OUT/INOUT")
 				 : NULL);
 
-	  if (f->sym->attr.pointer
+	  if (((f->sym->ts.type == BT_CLASS && f->sym->attr.class_ok
+		&& CLASS_DATA (f->sym)->attr.class_pointer)
+	       || (f->sym->ts.type != BT_CLASS && f->sym->attr.pointer))
 	      && gfc_check_vardef_context (a->expr, true, false, context)
 		   == FAILURE)
 	    return 0;
@@ -2812,25 +2814,6 @@ check_some_aliasing (gfc_formal_arglist *f, gfc_actual_arglist *a)
 }
 
 
-/* Given a symbol of a formal argument list and an expression,
-   return nonzero if their intents are compatible, zero otherwise.  */
-
-static int
-compare_parameter_intent (gfc_symbol *formal, gfc_expr *actual)
-{
-  if (actual->symtree->n.sym->attr.pointer && !formal->attr.pointer)
-    return 1;
-
-  if (actual->symtree->n.sym->attr.intent != INTENT_IN)
-    return 1;
-
-  if (formal->attr.intent == INTENT_INOUT || formal->attr.intent == INTENT_OUT)
-    return 0;
-
-  return 1;
-}
-
-
 /* Given formal and actual argument lists that correspond to one
    another, check that they are compatible in the sense that intents
    are not mismatched.  */
@@ -2852,25 +2835,11 @@ check_intents (gfc_formal_arglist *f, gfc_actual_arglist *a)
 
       f_intent = f->sym->attr.intent;
 
-      if (!compare_parameter_intent(f->sym, a->expr))
-	{
-	  gfc_error ("Procedure argument at %L is INTENT(IN) while interface "
-		     "specifies INTENT(%s)", &a->expr->where,
-		     gfc_intent_string (f_intent));
-	  return FAILURE;
-	}
-
       if (gfc_pure (NULL) && gfc_impure_variable (a->expr->symtree->n.sym))
 	{
-	  if (f_intent == INTENT_INOUT || f_intent == INTENT_OUT)
-	    {
-	      gfc_error ("Procedure argument at %L is local to a PURE "
-			 "procedure and is passed to an INTENT(%s) argument",
-			 &a->expr->where, gfc_intent_string (f_intent));
-	      return FAILURE;
-	    }
-
-	  if (f->sym->attr.pointer)
+	  if ((f->sym->ts.type == BT_CLASS && f->sym->attr.class_ok
+	       && CLASS_DATA (f->sym)->attr.class_pointer)
+	      || (f->sym->ts.type != BT_CLASS && f->sym->attr.pointer))
 	    {
 	      gfc_error ("Procedure argument at %L is local to a PURE "
 			 "procedure and has the POINTER attribute",
@@ -2890,7 +2859,9 @@ check_intents (gfc_formal_arglist *f, gfc_actual_arglist *a)
 	      return FAILURE;
 	    }
 
-	  if (f->sym->attr.pointer)
+	  if ((f->sym->ts.type == BT_CLASS && f->sym->attr.class_ok
+               && CLASS_DATA (f->sym)->attr.class_pointer)
+              || (f->sym->ts.type != BT_CLASS && f->sym->attr.pointer))
 	    {
 	      gfc_error ("Coindexed actual argument at %L in PURE procedure "
 			 "is passed to a POINTER dummy argument",

gcc/testsuite/ChangeLog

+2012-05-03  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/52864
+	* gfortran.dg/pointer_intent_7.f90: New.
+	* gfortran.dg/pure_formal_3.f90: New.
+
 2012-05-02  Ulrich Weigand  <ulrich.weigand@linaro.org>
 
 	* gcc.target/s390/20030123-1.c: Add missing "volatile".

gcc/testsuite/gfortran.dg/pointer_intent_7.f90

+! { dg-do compile }
+!
+! PR fortran/
+!
+! Contributed by Neil Carlson
+!
+! Check whether passing an intent(in) pointer
+! to an intent(inout) nonpointer is allowed
+!
+module modA
+  type :: typeA
+    integer, pointer :: ptr
+  end type
+contains
+  subroutine foo (a,b,c)
+    type(typeA), intent(in) :: a
+    type(typeA), intent(in) , pointer :: b
+    class(typeA), intent(in) , pointer :: c
+
+    call bar (a%ptr)
+    call bar2 (b)
+    call bar3 (b)
+    call bar2 (c)
+    call bar3 (c)
+    call bar2p (b) ! { dg-error "INTENT\\(IN\\) in pointer association context \\(actual argument to INTENT = OUT/INOUT" }
+    call bar3p (b) ! { dg-error "INTENT\\(IN\\) in pointer association context \\(actual argument to INTENT = OUT/INOUT" }
+    call bar2p (c) ! { dg-error "INTENT\\(IN\\) in pointer association context \\(actual argument to INTENT = OUT/INOUT" }
+    call bar3p (c) ! { dg-error "INTENT\\(IN\\) in pointer association context \\(actual argument to INTENT = OUT/INOUT" }
+  end subroutine
+  subroutine bar (n)
+    integer, intent(inout) :: n
+  end subroutine
+  subroutine bar2 (n)
+    type(typeA), intent(inout) :: n
+  end subroutine
+  subroutine bar3 (n)
+    class(typeA), intent(inout) :: n
+  end subroutine
+  subroutine bar2p (n)
+    type(typeA), intent(inout), pointer :: n
+  end subroutine
+  subroutine bar3p (n)
+    class(typeA), intent(inout), pointer :: n
+  end subroutine
+end module

gcc/testsuite/gfortran.dg/pure_formal_3.f90

+! { dg-do compile }
+!
+! Clean up, made when working on PR fortran/52864
+!
+! Test some PURE and intent checks - related to pointers.
+module m
+  type t
+  end type t
+  integer, pointer :: x
+  class(t), pointer :: y
+end module m
+
+pure subroutine foo()
+  use m
+  call bar(x) ! { dg-error "can not appear in a variable definition context" }
+  call bar2(x) ! { dg-error "is local to a PURE procedure and has the POINTER attribute" }
+  call bb(y) ! { dg-error "is local to a PURE procedure and has the POINTER attribute" }
+contains
+  pure subroutine bar(x)
+    integer, pointer, intent(inout) :: x
+  end subroutine
+  pure subroutine bar2(x)
+    integer, pointer :: x
+  end subroutine
+  pure subroutine bb(x)
+    class(t), pointer, intent(in) :: x 
+  end subroutine
+end subroutine