This is the mail archive of the
fortran@gcc.gnu.org
mailing list for the GNU Fortran project.
[Patch, Fortran] PR52864 - fix actual/formal checks
- From: Tobias Burnus <burnus at net-b dot de>
- To: gcc patches <gcc-patches at gcc dot gnu dot org>, gfortran <fortran at gcc dot gnu dot org>
- Date: Thu, 12 Apr 2012 17:23:56 +0200
- Subject: [Patch, Fortran] PR52864 - fix actual/formal checks
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