2011-12-03 Tobias Burnus <burnus@net-b.de>

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

2011-12-03  Tobias Burnus  <burnus@net-b.de>

        PR fortran/50684
        * gfortran.dg/move_alloc_8.f90: New.

git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@181967 138bc75d-0d04-0410-961f-82ee72b054a4

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 72a7f74..bec5430 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,8 @@
+2011-12-03  Tobias Burnus  <burnus@net-b.de>                                                                                                           
+
+       PR fortran/50684
+       * check.c (variable_check): Fix intent(in) check.
+
 2011-12-03  Tobias Burnus  <burnus@net-b.de>
 
        * check.c (gfc_check_move_alloc): Allow nonpolymorphic

diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c
index 605c77d..f2c4272 100644 (file)
--- a/gcc/fortran/check.c
+++ b/gcc/fortran/check.c
@@ -476,10 +476,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

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 75cf459..3b03cf7 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,5 +1,10 @@
 2011-12-03  Tobias Burnus  <burnus@net-b.de>
 
+       PR fortran/50684
+       * gfortran.dg/move_alloc_8.f90: New.
+
+2011-12-03  Tobias Burnus  <burnus@net-b.de>
+
        * gfortran.dg/select_type_23.f03: Revert Rev. 181801,
        i.e. remove the dg-error line.
        * gfortran.dg/move_alloc_5.f90: Ditto and change back

diff --git a/gcc/testsuite/gfortran.dg/move_alloc_8.f90 b/gcc/testsuite/gfortran.dg/move_alloc_8.f90
new file mode 100644 (file)
index 0000000..2fa5306
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/move_alloc_8.f90
@@ -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" } }