From bcb4ad361cdc348f19f290bdb172853cbc50859d Mon Sep 17 00:00:00 2001 From: Tobias Burnus Date: Thu, 3 May 2012 09:18:56 +0200 Subject: [PATCH] re PR fortran/52864 (Assignment to pointer component for INTENT(IN) dummy argument) 2012-05-03 Tobias Burnus 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 PR fortran/52864 * gfortran.dg/pointer_intent_7.f90: New. * gfortran.dg/pure_formal_3.f90: New. From-SVN: r187076 --- gcc/fortran/ChangeLog | 7 +++ gcc/fortran/interface.c | 47 ++++--------------- gcc/testsuite/ChangeLog | 6 +++ .../gfortran.dg/pointer_intent_7.f90 | 45 ++++++++++++++++++ gcc/testsuite/gfortran.dg/pure_formal_3.f90 | 28 +++++++++++ 5 files changed, 95 insertions(+), 38 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/pointer_intent_7.f90 create mode 100644 gcc/testsuite/gfortran.dg/pure_formal_3.f90 diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index ee13c2f94f5..56626518e50 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,10 @@ +2012-05-03 Tobias Burnus + + 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 * f95-lang.c (gfc_finish): Update comments. diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c index 2f1d24e6e33..95439c118e4 100644 --- a/gcc/fortran/interface.c +++ b/gcc/fortran/interface.c @@ -2517,7 +2517,9 @@ compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal, ? _("actual argument to INTENT = OUT/INOUT") : 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) == FAILURE) 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 another, check that they are compatible in the sense that intents are not mismatched. */ @@ -2852,25 +2835,11 @@ check_intents (gfc_formal_arglist *f, gfc_actual_arglist *a) 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 (f_intent == INTENT_INOUT || f_intent == INTENT_OUT) - { - gfc_error ("Procedure argument at %L is local to a PURE " - "procedure and is passed to an INTENT(%s) argument", - &a->expr->where, gfc_intent_string (f_intent)); - 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 ("Procedure argument at %L is local to a PURE " "procedure and has the POINTER attribute", @@ -2890,7 +2859,9 @@ check_intents (gfc_formal_arglist *f, gfc_actual_arglist *a) 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 " "is passed to a POINTER dummy argument", diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 1ed2b0b66e5..08d19b520d7 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,9 @@ +2012-05-03 Tobias Burnus + + PR fortran/52864 + * gfortran.dg/pointer_intent_7.f90: New. + * gfortran.dg/pure_formal_3.f90: New. + 2012-05-02 Ulrich Weigand * gcc.target/s390/20030123-1.c: Add missing "volatile". diff --git a/gcc/testsuite/gfortran.dg/pointer_intent_7.f90 b/gcc/testsuite/gfortran.dg/pointer_intent_7.f90 new file mode 100644 index 00000000000..c09eb2b5ffa --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pointer_intent_7.f90 @@ -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 diff --git a/gcc/testsuite/gfortran.dg/pure_formal_3.f90 b/gcc/testsuite/gfortran.dg/pure_formal_3.f90 new file mode 100644 index 00000000000..5d08057b372 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pure_formal_3.f90 @@ -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