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:
parent
38d7f26e0d
commit
bcb4ad361c
|
@ -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>
|
2012-04-30 Jan Hubicka <jh@suse.cz>
|
||||||
|
|
||||||
* f95-lang.c (gfc_finish): Update comments.
|
* f95-lang.c (gfc_finish): Update comments.
|
||||||
|
|
|
@ -2517,7 +2517,9 @@ compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
|
||||||
? _("actual argument to INTENT = OUT/INOUT")
|
? _("actual argument to INTENT = OUT/INOUT")
|
||||||
: NULL);
|
: 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)
|
&& gfc_check_vardef_context (a->expr, true, false, context)
|
||||||
== FAILURE)
|
== FAILURE)
|
||||||
return 0;
|
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
|
/* Given formal and actual argument lists that correspond to one
|
||||||
another, check that they are compatible in the sense that intents
|
another, check that they are compatible in the sense that intents
|
||||||
are not mismatched. */
|
are not mismatched. */
|
||||||
|
@ -2852,25 +2835,11 @@ check_intents (gfc_formal_arglist *f, gfc_actual_arglist *a)
|
||||||
|
|
||||||
f_intent = f->sym->attr.intent;
|
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 (gfc_pure (NULL) && gfc_impure_variable (a->expr->symtree->n.sym))
|
||||||
{
|
{
|
||||||
if (f_intent == INTENT_INOUT || f_intent == INTENT_OUT)
|
if ((f->sym->ts.type == BT_CLASS && f->sym->attr.class_ok
|
||||||
{
|
&& CLASS_DATA (f->sym)->attr.class_pointer)
|
||||||
gfc_error ("Procedure argument at %L is local to a PURE "
|
|| (f->sym->ts.type != BT_CLASS && f->sym->attr.pointer))
|
||||||
"procedure and is passed to an INTENT(%s) argument",
|
|
||||||
&a->expr->where, gfc_intent_string (f_intent));
|
|
||||||
return FAILURE;
|
|
||||||
}
|
|
||||||
|
|
||||||
if (f->sym->attr.pointer)
|
|
||||||
{
|
{
|
||||||
gfc_error ("Procedure argument at %L is local to a PURE "
|
gfc_error ("Procedure argument at %L is local to a PURE "
|
||||||
"procedure and has the POINTER attribute",
|
"procedure and has the POINTER attribute",
|
||||||
|
@ -2890,7 +2859,9 @@ check_intents (gfc_formal_arglist *f, gfc_actual_arglist *a)
|
||||||
return FAILURE;
|
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 "
|
gfc_error ("Coindexed actual argument at %L in PURE procedure "
|
||||||
"is passed to a POINTER dummy argument",
|
"is passed to a POINTER dummy argument",
|
||||||
|
|
|
@ -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>
|
2012-05-02 Ulrich Weigand <ulrich.weigand@linaro.org>
|
||||||
|
|
||||||
* gcc.target/s390/20030123-1.c: Add missing "volatile".
|
* gcc.target/s390/20030123-1.c: Add missing "volatile".
|
||||||
|
|
|
@ -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
|
|
@ -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
|
Loading…
Reference in New Issue