Dear all,
gfortran 4.6 and 4.7 have a too tight check whether a variable can be
modified if the actual argument is INTENT(IN). This patch relaxes/fixes
the checking.
Build and regtested on x86-64-linux.
OK for the trunk - and for 4.6 (as it is a regression)?
Tobias
2011-11-29 Tobias Burnus <bur...@net-b.de>
PR fortran/50684
* check.c (variable_check): Fix intent(in) check.
2011-11-29 Tobias Burnus <bur...@net-b.de>
PR fortran/50684
* gfortran.dg/move_alloc_8.f90: New.
diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c
index 832eb64..19e2da5 100644
--- a/gcc/fortran/check.c
+++ b/gcc/fortran/check.c
@@ -476,10 +488,31 @@ variable_check (gfc_expr *e, int n, bool allow_proc)
&& (gfc_current_intrinsic_arg[n]->intent == INTENT_OUT
|| gfc_current_intrinsic_arg[n]->intent == INTENT_INOUT))
{
- gfc_error ("'%s' argument of '%s' intrinsic at %L cannot be INTENT(IN)",
- gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic,
- &e->where);
- return FAILURE;
+ gfc_ref *ref;
+ bool pointer = e->symtree->n.sym->ts.type == BT_CLASS
+ && CLASS_DATA (e->symtree->n.sym)
+ ? CLASS_DATA (e->symtree->n.sym)->attr.class_pointer
+ : e->symtree->n.sym->attr.pointer;
+
+ for (ref = e->ref; ref; ref = ref->next)
+ {
+ if (pointer && ref->type == REF_COMPONENT)
+ break;
+ if (ref->type == REF_COMPONENT
+ && ((ref->u.c.component->ts.type == BT_CLASS
+ && CLASS_DATA (ref->u.c.component)->attr.class_pointer)
+ || (ref->u.c.component->ts.type != BT_CLASS
+ && ref->u.c.component->attr.pointer)))
+ break;
+ }
+
+ if (!ref)
+ {
+ gfc_error ("'%s' argument of '%s' intrinsic at %L cannot be "
+ "INTENT(IN)", gfc_current_intrinsic_arg[n]->name,
+ gfc_current_intrinsic, &e->where);
+ return FAILURE;
+ }
}
if (e->expr_type == EXPR_VARIABLE
--- /dev/null 2011-11-29 07:50:43.475522632 +0100
+++ gcc/gcc/testsuite/gfortran.dg/move_alloc_8.f90 2011-11-29 18:30:18.000000000 +0100
@@ -0,0 +1,106 @@
+! { dg-do compile }
+!
+! PR fortran/50684
+!
+! Module "bug" contributed by Martin Steghöfer.
+!
+
+MODULE BUG
+ TYPE MY_TYPE
+ INTEGER, ALLOCATABLE :: VALUE
+ END TYPE
+CONTAINS
+ SUBROUTINE POINTER_INTENT_IN_BUG_WORKING(POINTER_INTENT_IN_VARIABLE)
+ TYPE(MY_TYPE), POINTER, INTENT(IN) :: POINTER_INTENT_IN_VARIABLE
+ TYPE(MY_TYPE), POINTER :: POINTER_VARIABLE_LOCAL
+ INTEGER, ALLOCATABLE :: LOCAL_VALUE
+
+ POINTER_VARIABLE_LOCAL=>POINTER_INTENT_IN_VARIABLE
+ CALL MOVE_ALLOC(POINTER_VARIABLE_LOCAL%VALUE, LOCAL_VALUE)
+
+ RETURN
+ END SUBROUTINE POINTER_INTENT_IN_BUG_WORKING
+
+ SUBROUTINE POINTER_INTENT_IN_BUG_FAILING(POINTER_INTENT_IN_VARIABLE)
+ TYPE(MY_TYPE), POINTER, INTENT(IN) :: POINTER_INTENT_IN_VARIABLE
+ INTEGER, ALLOCATABLE :: LOCAL_VALUE
+
+ CALL MOVE_ALLOC(POINTER_INTENT_IN_VARIABLE%VALUE, LOCAL_VALUE)
+
+ RETURN
+ END SUBROUTINE POINTER_INTENT_IN_BUG_FAILING
+end module bug
+
+subroutine test1()
+ TYPE MY_TYPE
+ INTEGER, ALLOCATABLE :: VALUE
+ END TYPE
+CONTAINS
+ SUBROUTINE sub (dt)
+ type(MY_TYPE), intent(in) :: dt
+ INTEGER, ALLOCATABLE :: lv
+ call move_alloc(dt%VALUE, lv) ! { dg-error "cannot be INTENT.IN." }
+ END SUBROUTINE
+end subroutine test1
+
+subroutine test2 (x, px)
+ implicit none
+ type t
+ integer, allocatable :: a
+ end type t
+
+ type t2
+ type(t), pointer :: ptr
+ integer, allocatable :: a
+ end type t2
+
+ type(t2), intent(in) :: x
+ type(t2), pointer, intent(in) :: px
+
+ integer, allocatable :: a
+ type(t2), pointer :: ta
+
+ call move_alloc (px, ta) ! { dg-error "cannot be INTENT.IN." }
+ call move_alloc (x%a, a) ! { dg-error "cannot be INTENT.IN." }
+ call move_alloc (x%ptr%a, a) ! OK (3)
+ call move_alloc (px%a, a) ! OK (4)
+ call move_alloc (px%ptr%a, a) ! OK (5)
+end subroutine test2
+
+subroutine test3 (x, px)
+ implicit none
+ type t
+ integer, allocatable :: a
+ end type t
+
+ type t2
+ class(t), pointer :: ptr
+ integer, allocatable :: a
+ end type t2
+
+ type(t2), intent(in) :: x
+ class(t2), pointer, intent(in) :: px
+
+ integer, allocatable :: a
+ class(t2), pointer :: ta
+
+ call move_alloc (px, ta) ! { dg-error "cannot be INTENT.IN." }
+ call move_alloc (x%a, a) ! { dg-error "cannot be INTENT.IN." }
+ call move_alloc (x%ptr%a, a) ! OK (6)
+ call move_alloc (px%a, a) ! OK (7)
+ call move_alloc (px%ptr%a, a) ! OK (8)
+end subroutine test3
+
+subroutine test4()
+ TYPE MY_TYPE
+ INTEGER, ALLOCATABLE :: VALUE
+ END TYPE
+CONTAINS
+ SUBROUTINE sub (dt)
+ CLASS(MY_TYPE), intent(in) :: dt
+ INTEGER, ALLOCATABLE :: lv
+ call move_alloc(dt%VALUE, lv) ! { dg-error "cannot be INTENT.IN." }
+ END SUBROUTINE
+end subroutine test4
+
+! { dg-final { cleanup-modules "bug" } }
