From 2bec85dcfa9cc6740deec823018c072a605f3b90 Mon Sep 17 00:00:00 2001 From: burnus Date: Fri, 5 Jan 2007 09:08:37 +0000 Subject: [PATCH] fortran/ 2007-01-05 Tobias Burnus PR fortran/29624 * interface.c (compare_parameter_intent): New function. (check_intents): Support pointer intents. * symbol.c (check_conflict): Support pointer intents, better conflict_std message. * expr.c (gfc_check_assign,gfc_check_pointer_assign): Support pointer intents. * resolve.c (resolve_deallocate_expr,resolve_allocate_expr): Support pointer intents. testsuite/ 2006-01-05 Tobias Burnus PR fortran/29624 * gfortran.dg/alloc_alloc_expr_1.f90: Add check for invalid deallocate. * gfortran.dg/allocatable_dummy_2.f90: Update dg-error. * gfortran.dg/protected_4.f90: Add pointer intent check. * gfortran.dg/protected_6.f90: Add pointer intent check. * gfortran.dg/pointer_intent_1.f90: New test. * gfortran.dg/pointer_intent_2.f90: New test. * gfortran.dg/pointer_intent_3.f90: New test. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@120472 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/ChangeLog | 12 +++ gcc/fortran/expr.c | 44 ++++++++- gcc/fortran/interface.c | 28 +++++- gcc/fortran/resolve.c | 106 +++++++++++++--------- gcc/fortran/symbol.c | 9 +- gcc/testsuite/ChangeLog | 14 ++- gcc/testsuite/gfortran.dg/alloc_alloc_expr_1.f90 | 4 +- gcc/testsuite/gfortran.dg/allocatable_dummy_2.f90 | 4 +- gcc/testsuite/gfortran.dg/pointer_intent_1.f90 | 71 +++++++++++++++ gcc/testsuite/gfortran.dg/pointer_intent_2.f90 | 19 ++++ gcc/testsuite/gfortran.dg/pointer_intent_3.f90 | 41 +++++++++ gcc/testsuite/gfortran.dg/protected_4.f90 | 12 ++- gcc/testsuite/gfortran.dg/protected_6.f90 | 5 +- 13 files changed, 304 insertions(+), 65 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/pointer_intent_1.f90 create mode 100644 gcc/testsuite/gfortran.dg/pointer_intent_2.f90 create mode 100644 gcc/testsuite/gfortran.dg/pointer_intent_3.f90 diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index c18d9ba8744..be3a9b5ebd6 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,15 @@ +2007-01-05 Tobias Burnus + + PR fortran/29624 + * interface.c (compare_parameter_intent): New function. + (check_intents): Support pointer intents. + * symbol.c (check_conflict): Support pointer intents, + better conflict_std message. + * expr.c (gfc_check_assign,gfc_check_pointer_assign): + Support pointer intents. + * resolve.c (resolve_deallocate_expr,resolve_allocate_expr): + Support pointer intents. + 2007-01-03 Brooks Moses PR 30371 diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c index 7f6c699de59..7c2069c340b 100644 --- a/gcc/fortran/expr.c +++ b/gcc/fortran/expr.c @@ -2188,12 +2188,25 @@ try gfc_check_assign (gfc_expr * lvalue, gfc_expr * rvalue, int conform) { gfc_symbol *sym; + gfc_ref *ref; + int has_pointer; sym = lvalue->symtree->n.sym; - if (sym->attr.intent == INTENT_IN) + /* Check INTENT(IN), unless the object itself is the component or + sub-component of a pointer. */ + has_pointer = sym->attr.pointer; + + for (ref = lvalue->ref; ref; ref = ref->next) + if (ref->type == REF_COMPONENT && ref->u.c.component->pointer) + { + has_pointer = 1; + break; + } + + if (!has_pointer && sym->attr.intent == INTENT_IN) { - gfc_error ("Can't assign to INTENT(IN) variable '%s' at %L", + gfc_error ("Cannot assign to INTENT(IN) variable '%s' at %L", sym->name, &lvalue->where); return FAILURE; } @@ -2318,7 +2331,9 @@ try gfc_check_pointer_assign (gfc_expr * lvalue, gfc_expr * rvalue) { symbol_attribute attr; + gfc_ref *ref; int is_pure; + int pointer, check_intent_in; if (lvalue->symtree->n.sym->ts.type == BT_UNKNOWN) { @@ -2336,8 +2351,29 @@ gfc_check_pointer_assign (gfc_expr * lvalue, gfc_expr * rvalue) return FAILURE; } - attr = gfc_variable_attr (lvalue, NULL); - if (!attr.pointer) + + /* Check INTENT(IN), unless the object itself is the component or + sub-component of a pointer. */ + check_intent_in = 1; + pointer = lvalue->symtree->n.sym->attr.pointer; + + for (ref = lvalue->ref; ref; ref = ref->next) + { + if (pointer) + check_intent_in = 0; + + if (ref->type == REF_COMPONENT && ref->u.c.component->pointer) + pointer = 1; + } + + if (check_intent_in && lvalue->symtree->n.sym->attr.intent == INTENT_IN) + { + gfc_error ("Cannot assign to INTENT(IN) variable '%s' at %L", + lvalue->symtree->n.sym->name, &lvalue->where); + return FAILURE; + } + + if (!pointer) { gfc_error ("Pointer assignment to non-POINTER at %L", &lvalue->where); return FAILURE; diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c index 7b0c4231b0e..8a1987dc6ec 100644 --- a/gcc/fortran/interface.c +++ b/gcc/fortran/interface.c @@ -1664,6 +1664,27 @@ check_some_aliasing (gfc_formal_arglist * f, gfc_actual_arglist * a) } +/* Given a symbol of a formal argument list and an expression, + return non-zero 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. */ @@ -1671,7 +1692,7 @@ check_some_aliasing (gfc_formal_arglist * f, gfc_actual_arglist * a) static try check_intents (gfc_formal_arglist * f, gfc_actual_arglist * a) { - sym_intent a_intent, f_intent; + sym_intent f_intent; for (;; f = f->next, a = a->next) { @@ -1683,12 +1704,9 @@ check_intents (gfc_formal_arglist * f, gfc_actual_arglist * a) if (a->expr == NULL || a->expr->expr_type != EXPR_VARIABLE) continue; - a_intent = a->expr->symtree->n.sym->attr.intent; f_intent = f->sym->attr.intent; - if (a_intent == INTENT_IN - && (f_intent == INTENT_INOUT - || f_intent == INTENT_OUT)) + if (!compare_parameter_intent(f->sym, a->expr)) { gfc_error ("Procedure argument at %L is INTENT(IN) while interface " diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 650a5a22c91..3c28d452ee4 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -3446,48 +3446,57 @@ static try resolve_deallocate_expr (gfc_expr * e) { symbol_attribute attr; - int allocatable; + int allocatable, pointer, check_intent_in; gfc_ref *ref; + /* Check INTENT(IN), unless the object is a sub-component of a pointer. */ + check_intent_in = 1; + if (gfc_resolve_expr (e) == FAILURE) return FAILURE; - attr = gfc_expr_attr (e); - if (attr.pointer) - return SUCCESS; - if (e->expr_type != EXPR_VARIABLE) goto bad; allocatable = e->symtree->n.sym->attr.allocatable; + pointer = e->symtree->n.sym->attr.pointer; for (ref = e->ref; ref; ref = ref->next) - switch (ref->type) - { - case REF_ARRAY: - if (ref->u.ar.type != AR_FULL) - allocatable = 0; - break; + { + if (pointer) + check_intent_in = 0; - case REF_COMPONENT: - allocatable = (ref->u.c.component->as != NULL - && ref->u.c.component->as->type == AS_DEFERRED); - break; + switch (ref->type) + { + case REF_ARRAY: + if (ref->u.ar.type != AR_FULL) + allocatable = 0; + break; - case REF_SUBSTRING: - allocatable = 0; - break; - } + case REF_COMPONENT: + allocatable = (ref->u.c.component->as != NULL + && ref->u.c.component->as->type == AS_DEFERRED); + pointer = ref->u.c.component->pointer; + break; - if (allocatable == 0) + case REF_SUBSTRING: + allocatable = 0; + break; + } + } + + attr = gfc_expr_attr (e); + + if (allocatable == 0 && attr.pointer == 0) { bad: gfc_error ("Expression in DEALLOCATE statement at %L must be " "ALLOCATABLE or a POINTER", &e->where); } - if (e->symtree->n.sym->attr.intent == INTENT_IN) + if (check_intent_in + && e->symtree->n.sym->attr.intent == INTENT_IN) { - gfc_error ("Can't deallocate INTENT(IN) variable '%s' at %L", + gfc_error ("Cannot deallocate INTENT(IN) variable '%s' at %L", e->symtree->n.sym->name, &e->where); return FAILURE; } @@ -3609,7 +3618,7 @@ expr_to_initialize (gfc_expr * e) static try resolve_allocate_expr (gfc_expr * e, gfc_code * code) { - int i, pointer, allocatable, dimension; + int i, pointer, allocatable, dimension, check_intent_in; symbol_attribute attr; gfc_ref *ref, *ref2; gfc_array_ref *ar; @@ -3618,6 +3627,9 @@ resolve_allocate_expr (gfc_expr * e, gfc_code * code) gfc_symbol *sym; gfc_alloc *a; + /* Check INTENT(IN), unless the object is a sub-component of a pointer. */ + check_intent_in = 1; + if (gfc_resolve_expr (e) == FAILURE) return FAILURE; @@ -3655,26 +3667,31 @@ resolve_allocate_expr (gfc_expr * e, gfc_code * code) } for (ref = e->ref; ref; ref2 = ref, ref = ref->next) - switch (ref->type) - { - case REF_ARRAY: - if (ref->next != NULL) - pointer = 0; - break; - - case REF_COMPONENT: - allocatable = (ref->u.c.component->as != NULL - && ref->u.c.component->as->type == AS_DEFERRED); - - pointer = ref->u.c.component->pointer; - dimension = ref->u.c.component->dimension; - break; + { + if (pointer) + check_intent_in = 0; - case REF_SUBSTRING: - allocatable = 0; - pointer = 0; - break; - } + switch (ref->type) + { + case REF_ARRAY: + if (ref->next != NULL) + pointer = 0; + break; + + case REF_COMPONENT: + allocatable = (ref->u.c.component->as != NULL + && ref->u.c.component->as->type == AS_DEFERRED); + + pointer = ref->u.c.component->pointer; + dimension = ref->u.c.component->dimension; + break; + + case REF_SUBSTRING: + allocatable = 0; + pointer = 0; + break; + } + } } if (allocatable == 0 && pointer == 0) @@ -3684,9 +3701,10 @@ resolve_allocate_expr (gfc_expr * e, gfc_code * code) return FAILURE; } - if (e->symtree->n.sym->attr.intent == INTENT_IN) + if (check_intent_in + && e->symtree->n.sym->attr.intent == INTENT_IN) { - gfc_error ("Can't allocate INTENT(IN) variable '%s' at %L", + gfc_error ("Cannot allocate INTENT(IN) variable '%s' at %L", e->symtree->n.sym->name, &e->where); return FAILURE; } diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c index 12c5749acec..a1aaae8fddf 100644 --- a/gcc/fortran/symbol.c +++ b/gcc/fortran/symbol.c @@ -288,7 +288,8 @@ check_conflict (symbol_attribute * attr, const char * name, locus * where) { a1 = pointer; a2 = intent; - goto conflict; + standard = GFC_STD_F2003; + goto conflict_std; } /* Check for attributes not allowed in a BLOCK DATA. */ @@ -571,14 +572,14 @@ conflict: conflict_std: if (name == NULL) { - return gfc_notify_std (standard, "In the selected standard, %s attribute " + return gfc_notify_std (standard, "Fortran 2003: %s attribute " "conflicts with %s attribute at %L", a1, a2, where); } else { - return gfc_notify_std (standard, "In the selected standard, %s attribute " - "conflicts with %s attribute in '%s' at %L", + return gfc_notify_std (standard, "Fortran 2003: %s attribute " + "with %s attribute in '%s' at %L", a1, a2, name, where); } } diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 0309fad98f5..aae1b7a35bb 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,4 +1,16 @@ -2006-01-04 Brooks Moses +2006-01-05 Tobias Burnus + + PR fortran/29624 + * gfortran.dg/alloc_alloc_expr_1.f90: Add check for + invalid deallocate. + * gfortran.dg/allocatable_dummy_2.f90: Update dg-error. + * gfortran.dg/protected_4.f90: Add pointer intent check. + * gfortran.dg/protected_6.f90: Add pointer intent check. + * gfortran.dg/pointer_intent_1.f90: New test. + * gfortran.dg/pointer_intent_2.f90: New test. + * gfortran.dg/pointer_intent_3.f90: New test. + +2007-01-04 Brooks Moses PR 30235 * gfortran.dg/altreturn_2.f90: new test. diff --git a/gcc/testsuite/gfortran.dg/alloc_alloc_expr_1.f90 b/gcc/testsuite/gfortran.dg/alloc_alloc_expr_1.f90 index 477643855a2..5545b0dce6c 100644 --- a/gcc/testsuite/gfortran.dg/alloc_alloc_expr_1.f90 +++ b/gcc/testsuite/gfortran.dg/alloc_alloc_expr_1.f90 @@ -24,6 +24,8 @@ program fc011 ALLOCATE(PTR,ALLOCS(PTR)) ! { dg-error "same ALLOCATE statement" } - print *, 'This program has three errors', PTR, ALLOC(1) + deallocate(ALLOCS(1)) ! { dg-error "must be ALLOCATABLE or a POINTER" } + + print *, 'This program has four errors', PTR, ALLOC(1) end program fc011 diff --git a/gcc/testsuite/gfortran.dg/allocatable_dummy_2.f90 b/gcc/testsuite/gfortran.dg/allocatable_dummy_2.f90 index 46a6f4fa671..c33ad13b8c5 100644 --- a/gcc/testsuite/gfortran.dg/allocatable_dummy_2.f90 +++ b/gcc/testsuite/gfortran.dg/allocatable_dummy_2.f90 @@ -16,13 +16,13 @@ contains subroutine init2(x) integer, allocatable, intent(in) :: x(:) - allocate(x(3)) ! { dg-error "Can't allocate" } + allocate(x(3)) ! { dg-error "Cannot allocate" } end subroutine init2 subroutine kill(x) integer, allocatable, intent(in) :: x(:) - deallocate(x) ! { dg-error "Can't deallocate" } + deallocate(x) ! { dg-error "Cannot deallocate" } end subroutine kill end program alloc_dummy diff --git a/gcc/testsuite/gfortran.dg/pointer_intent_1.f90 b/gcc/testsuite/gfortran.dg/pointer_intent_1.f90 new file mode 100644 index 00000000000..882c6a5f903 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pointer_intent_1.f90 @@ -0,0 +1,71 @@ +! { dg-run } +! { dg-options "-std=f2003 -fall-intrinsics" } +! Pointer intent test +! PR fortran/29624 +! +! Valid program +program test + implicit none + type myT + integer :: x + integer, pointer :: point + end type myT + integer, pointer :: p + type(myT), pointer :: t + type(myT) :: t2 + allocate(p,t) + allocate(t%point) + t%point = 55 + p = 33 + call a(p,t) + deallocate(p) + nullify(p) + call a(p,t) + call nonpointer(t2) +contains + subroutine a(p,t) + integer, pointer,intent(in) :: p + type(myT), pointer, intent(in) :: t + integer, pointer :: tmp + if(.not.associated(p)) return + if(p /= 33) call abort() + p = 7 + if (associated(t)) then + ! allocating is valid as we don't change the status + ! of the pointer "t", only of it's target + t%x = -15 + if(.not.associated(t%point)) call abort() + if(t%point /= 55) call abort() + nullify(t%point) + allocate(tmp) + t%point => tmp + deallocate(t%point) + t%point => null(t%point) + tmp => null(tmp) + allocate(t%point) + t%point = 27 + if(t%point /= 27) call abort() + if(t%x /= -15) call abort() + call foo(t) + if(t%x /= 32) call abort() + if(t%point /= -98) call abort() + end if + call b(p) + if(p /= 5) call abort() + end subroutine + subroutine b(v) + integer, intent(out) :: v + v = 5 + end subroutine b + subroutine foo(comp) + type(myT), intent(inout) :: comp + if(comp%x /= -15) call abort() + !if(comp%point /= 27) call abort() + comp%x = 32 + comp%point = -98 + end subroutine foo + subroutine nonpointer(t) + type(myT), intent(in) :: t + t%point = 7 + end subroutine nonpointer +end program diff --git a/gcc/testsuite/gfortran.dg/pointer_intent_2.f90 b/gcc/testsuite/gfortran.dg/pointer_intent_2.f90 new file mode 100644 index 00000000000..247016bdab0 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pointer_intent_2.f90 @@ -0,0 +1,19 @@ +! { dg-compile } +! { dg-options "-std=f95" } +! { dg-shouldfail "Fortran 2003 feature with -std=f95" } +! +! Pointer intent test +! PR fortran/29624 +! +! Fortran 2003 features in Fortran 95 +program test + implicit none + integer, pointer :: p + allocate(p) + p = 33 + call a(p) ! { dg-error "Type/rank mismatch in argument" } +contains + subroutine a(p)! { dg-error "has no IMPLICIT type" } + integer, pointer,intent(in) :: p ! { dg-error "POINTER attribute with INTENT attribute" } + end subroutine +end program diff --git a/gcc/testsuite/gfortran.dg/pointer_intent_3.f90 b/gcc/testsuite/gfortran.dg/pointer_intent_3.f90 new file mode 100644 index 00000000000..e7ce590b117 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pointer_intent_3.f90 @@ -0,0 +1,41 @@ +! { dg-compile } +! { dg-options "-std=f2003 -fall-intrinsics" } +! { dg-shouldfail "Invalid code" } +! +! Pointer intent test +! PR fortran/29624 +! +! Valid program +program test + implicit none + type myT + integer :: j = 5 + integer, pointer :: jp => null() + end type myT + integer, pointer :: p + type(myT) :: t + call a(p) + call b(t) +contains + subroutine a(p) + integer, pointer,intent(in) :: p + p => null(p)! { dg-error "Cannot assign to INTENT\\(IN\\) variable" } + nullify(p) ! { dg-error "Cannot assign to INTENT\\(IN\\) variable" } + allocate(p) ! { dg-error "Cannot allocate INTENT\\(IN\\) variable" } + call c(p) ! { dg-error "is INTENT\\(IN\\) while interface specifies INTENT\\(INOUT\\)" } + deallocate(p) ! { dg-error "Cannot deallocate INTENT\\(IN\\) variable" } + end subroutine + subroutine c(p) + integer, pointer, intent(inout) :: p + nullify(p) + end subroutine c + subroutine b(t) + type(myT),intent(in) :: t + t%jp = 5 + t%jp => null(t%jp) ! { dg-error "Cannot assign to INTENT\\(IN\\) variable" } + nullify(t%jp) ! { dg-error "Cannot assign to INTENT\\(IN\\) variable" } + t%j = 7 ! { dg-error "Cannot assign to INTENT\\(IN\\) variable" } + allocate(t%jp) ! { dg-error "Cannot allocate INTENT\\(IN\\) variable" } + deallocate(t%jp) ! { dg-error "Cannot deallocate INTENT\\(IN\\) variable" } + end subroutine b +end program diff --git a/gcc/testsuite/gfortran.dg/protected_4.f90 b/gcc/testsuite/gfortran.dg/protected_4.f90 index be35b6bf60b..7d2238e2ffd 100644 --- a/gcc/testsuite/gfortran.dg/protected_4.f90 +++ b/gcc/testsuite/gfortran.dg/protected_4.f90 @@ -21,6 +21,7 @@ program main use protmod implicit none integer :: j + logical :: asgnd protected :: j ! { dg-error "only allowed in specification part of a module" } a = 43 ! { dg-error "Assigning to PROTECTED variable" } ap => null() ! { dg-error "Assigning to PROTECTED variable" } @@ -30,6 +31,8 @@ program main allocate(ap) ! { dg-error "Assigning to PROTECTED variable" } ap = 73 ! { dg-error "Assigning to PROTECTED variable" } call increment(a,at) ! { dg-error "use-associated with PROTECTED attribute" } + call pointer_assignments(ap) ! { dg-error "is use-associated with PROTECTED attribute" } + asgnd = pointer_check(ap) contains subroutine increment(a1,a3) integer, intent(inout) :: a1, a3 @@ -37,9 +40,14 @@ contains a3 = a3 + 1 end subroutine increment subroutine pointer_assignments(p) - integer, pointer :: p ! with [pointer] intent(out) - p => null() ! this is invalid + integer, pointer,intent(out) :: p + p => null() end subroutine pointer_assignments + function pointer_check(p) + integer, pointer,intent(in) :: p + logical :: pointer_check + pointer_check = associated(p) + end function pointer_check end program main module test diff --git a/gcc/testsuite/gfortran.dg/protected_6.f90 b/gcc/testsuite/gfortran.dg/protected_6.f90 index 50729495c8f..5b71f8ba574 100644 --- a/gcc/testsuite/gfortran.dg/protected_6.f90 +++ b/gcc/testsuite/gfortran.dg/protected_6.f90 @@ -27,6 +27,7 @@ program main allocate(ap) ! { dg-error "Assigning to PROTECTED variable" } ap = 73 ! { dg-error "Assigning to PROTECTED variable" } call increment(a,at) ! { dg-error "use-associated with PROTECTED attribute" } + call pointer_assignments(ap) ! { dg-error "is use-associated with PROTECTED attribute" } contains subroutine increment(a1,a3) integer, intent(inout) :: a1, a3 @@ -34,8 +35,8 @@ contains a3 = a3 + 1 end subroutine increment subroutine pointer_assignments(p) - integer, pointer :: p ! with [pointer] intent(out) - p => null() ! this is invalid + integer, pointer,intent (inout) :: p + p => null() end subroutine pointer_assignments end program main -- 2.11.0