OpenE2K
/
gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

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
This commit is contained in:
Tobias Burnus 2012-05-03 09:18:56 +02:00 committed by Tobias Burnus
parent 38d7f26e0d
commit bcb4ad361c
5 changed files with 95 additions and 38 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
gcc/fortran/ChangeLog
View File

@ -1,3 +1,10 @@
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.

47
gcc/fortran/interface.c
View File

@ -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",

6
gcc/testsuite/ChangeLog
View File

@ -1,3 +1,9 @@
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".

45
gcc/testsuite/gfortran.dg/pointer_intent_7.f90 Normal file
View File

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

28
gcc/testsuite/gfortran.dg/pure_formal_3.f90 Normal file
View File

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