[Patch, Fortran] PR52864 - fix actual/formal checks

[Tobias Burnus <burnus at net-b dot de>]

This patch is a kind of follow up to the other one for the same PR - 
though this one is for a separate test case, it is not a regression and 
it's about actual/formal checks.

When trying to fix the rejects-valid bug, I realized that one function 
was never accessed as a call to expr.c's gfc_check_vardef_context is 
done before. I made some cleanup and added some code to ensure pointer 
CLASS are correctly handled. I am not positive that the removed code is 
unreachable, but I failed to produce reachable code and also the test 
suit passed.

Thus, this patch removed a rejects-valid bug, an accepts-invalid bug, 
cleans up the code a bit and adds a test case for existing checks 
(besides testing the bug fixes).

Build and regtested on x86-64-linux.
OK for the trunk?

Tobias
20012-04-12  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.

20012-04-12  Tobias Burnus  <burnus@net-b.de>

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

diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c
index 298ae23..3c8f9cb 100644
--- a/gcc/fortran/interface.c
+++ b/gcc/fortran/interface.c
@@ -2504,7 +2520,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;
@@ -2799,25 +2817,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.  */
@@ -2839,25 +2838,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 && CLASS_DATA (f->sym)
+	       && 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",
@@ -2877,7 +2862,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 && CLASS_DATA (f->sym)
+               && 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",
--- /dev/null	2012-04-12 06:55:49.927755790 +0200
+++ gcc/gcc/testsuite/gfortran.dg/pointer_intent_7.f90	2012-04-12 12:21:37.000000000 +0200
@@ -0,0 +1,45 @@
+! { 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
--- /dev/null	2012-04-12 06:55:49.927755790 +0200
+++ gcc/gcc/testsuite/gfortran.dg/pure_formal_3.f90	2012-04-12 16:05:46.000000000 +0200
@@ -0,0 +1,28 @@
+! { 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