Patchwork [Fortran] PR52864 - fix actual/formal checks

login
register
mail settings
Submitter Tobias Burnus
Date April 12, 2012, 3:23 p.m.
Message ID <4F86F38C.8050702@net-b.de>
Download mbox | patch
Permalink /patch/152095/
State New
Headers show

Comments

Tobias Burnus - April 12, 2012, 3:23 p.m.
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
Tobias Burnus - April 20, 2012, 8:20 a.m.
*ping*

Tobias

PS: I know I should be also faster in reviewing patches of others...

On 04/12/2012 05:23 PM, Tobias Burnus wrote:
> 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
Mikael Morin - April 24, 2012, 7:45 p.m.
On 12/04/2012 17:23, Tobias Burnus wrote:
> 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?
> 

Hello, is there a reason to guard the class_pointer condition with
attr.class_ok in the first conditional and with CLASS_DATA(...) != NULL
in the two other ones?
Not that it matters much, and in fact, I think the patch as is is good
enough for committal (yes, it is a OK).
I'm asking as I never know myself what is the correct, canonical way to
handle the class_* hell...
Thanks

Mikael
Tobias Burnus - April 25, 2012, 6:14 a.m.
Hello Mikael,

thanks for the review. Regarding:

Mikael Morin wrote:
> is there a reason to guard the class_pointer condition with 
> attr.class_ok in the first conditional and with CLASS_DATA(...) != 
> NULL in the two other ones? Not that it matters much, and in fact, I 
> think the patch as is is good enough for committal (yes, it is a OK). 
> I'm asking as I never know myself what is the correct, canonical way 
> to handle the class_* hell...

It's a good question what's more appropriate. My impression is that both 
is nearly identical; I frankly don't know whether what's the exact 
difference. I recall that I once had to use CLASS_DATA() != NULL to 
avoid a segfault. I don't remember whether it was the issue below or 
something different.

For an expression, CLASS_DATA () != NULL has the big advantage that one 
avoids to walk the expression: For an expr, one needs to check 
expr->symtree->n.sym but also the "ref" tree. Thus, CLASS_DATA is much 
simpler than class_ok.

Looking at my patch, I have a dummy argument (i.e. gfc_symbol) - and for 
those, one can simply access fsym->sym->attr.class_ok.

Tobias

Patch

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