From: burnus Date: Sat, 3 Dec 2011 11:30:18 +0000 (+0000) Subject: 2011-12-03 Tobias Burnus X-Git-Url: http://git.sourceforge.jp/view?a=commitdiff_plain;h=67f65557af20bcb6cfbc34e98c489adf20514980;p=pf3gnuchains%2Fgcc-fork.git 2011-12-03 Tobias Burnus PR fortran/50684 * check.c (variable_check): Fix intent(in) check. 2011-12-03 Tobias Burnus 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 72a7f746e9c..bec5430f8f1 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,8 @@ +2011-12-03 Tobias Burnus + + PR fortran/50684 + * check.c (variable_check): Fix intent(in) check. + 2011-12-03 Tobias Burnus * check.c (gfc_check_move_alloc): Allow nonpolymorphic diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c index 605c77d2b48..f2c4272681e 100644 --- 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 75cf459710e..3b03cf7cd95 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,5 +1,10 @@ 2011-12-03 Tobias Burnus + PR fortran/50684 + * gfortran.dg/move_alloc_8.f90: New. + +2011-12-03 Tobias Burnus + * 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 index 00000000000..2fa53066600 --- /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" } }