[Fortran,4.6/4.7] PR 50684 - fix intent(in) check

2011-11-29  Tobias Burnus  <burnus@net-b.de>

	PR fortran/50684
	* check.c (variable_check): Fix intent(in) check.

2011-11-29  Tobias Burnus  <burnus@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" } }