diff options
| -rw-r--r-- | gcc/fortran/ChangeLog | 6 | ||||
| -rw-r--r-- | gcc/fortran/resolve.c | 67 | ||||
| -rw-r--r-- | gcc/testsuite/ChangeLog | 5 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/allocate_error_2.f90 | 20 |
4 files changed, 89 insertions, 9 deletions
diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 13cda02..5be47c6 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,9 @@ +2011-01-05 Thomas Koenig <tkoenig@gcc.gnu.org> + + PR fortran/46017 + * resolve.c (resolve_allocate_deallocate): Follow references to + check for duplicate occurence of allocation/deallocation objects. + 2011-01-05 Janus Weil <janus@gcc.gnu.org> PR fortran/47024 diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 9a5dcc1..28fec7d 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -6981,17 +6981,66 @@ resolve_allocate_deallocate (gfc_code *code, const char *fcn) for (p = code->ext.alloc.list; p; p = p->next) { pe = p->expr; - if ((pe->ref && pe->ref->type != REF_COMPONENT) - && (pe->symtree->n.sym->ts.type != BT_DERIVED)) + for (q = p->next; q; q = q->next) { - for (q = p->next; q; q = q->next) + qe = q->expr; + if (pe->symtree->n.sym->name == qe->symtree->n.sym->name) { - qe = q->expr; - if ((qe->ref && qe->ref->type != REF_COMPONENT) - && (qe->symtree->n.sym->ts.type != BT_DERIVED) - && (pe->symtree->n.sym->name == qe->symtree->n.sym->name)) - gfc_error ("Allocate-object at %L also appears at %L", - &pe->where, &qe->where); + /* This is a potential collision. */ + gfc_ref *pr = pe->ref; + gfc_ref *qr = qe->ref; + + /* Follow the references until + a) They start to differ, in which case there is no error; + you can deallocate a%b and a%c in a single statement + b) Both of them stop, which is an error + c) One of them stops, which is also an error. */ + while (1) + { + if (pr == NULL && qr == NULL) + { + gfc_error ("Allocate-object at %L also appears at %L", + &pe->where, &qe->where); + break; + } + else if (pr != NULL && qr == NULL) + { + gfc_error ("Allocate-object at %L is subobject of" + " object at %L", &pe->where, &qe->where); + break; + } + else if (pr == NULL && qr != NULL) + { + gfc_error ("Allocate-object at %L is subobject of" + " object at %L", &qe->where, &pe->where); + break; + } + /* Here, pr != NULL && qr != NULL */ + gcc_assert(pr->type == qr->type); + if (pr->type == REF_ARRAY) + { + /* Handle cases like allocate(v(3)%x(3), v(2)%x(3)), + which are legal. */ + gcc_assert (qr->type == REF_ARRAY); + + if (pr->next && qr->next) + { + gfc_array_ref *par = &(pr->u.ar); + gfc_array_ref *qar = &(qr->u.ar); + if (gfc_dep_compare_expr (par->start[0], + qar->start[0]) != 0) + break; + } + } + else + { + if (pr->u.c.component->name != qr->u.c.component->name) + break; + } + + pr = pr->next; + qr = qr->next; + } } } } diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 4a49afb..208304c 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,8 @@ +2011-01-05 Thomas Koenig <tkoenig@gcc.gnu.org> + + PR fortran/46017 + * gfortran.dg/allocate_error_2.f90: New test. + 2011-01-05 Janus Weil <janus@gcc.gnu.org> PR fortran/47024 diff --git a/gcc/testsuite/gfortran.dg/allocate_error_2.f90 b/gcc/testsuite/gfortran.dg/allocate_error_2.f90 new file mode 100644 index 0000000..1a301de --- /dev/null +++ b/gcc/testsuite/gfortran.dg/allocate_error_2.f90 @@ -0,0 +1,20 @@ +! { dg-do compile } +program main + type t1 + integer, allocatable :: x(:) + integer, allocatable :: y(:) + end type t1 + type(t1), allocatable :: v(:) + allocate (v(3), v(4)) ! { dg-error "Allocate-object at \\(1\\) also appears at \\(2\\)" } + allocate (v(1), v(1)%x(2)) ! { dg-error "Allocate-object at \\(1\\) is subobject of object at \\(2\\)" } + allocate (v(1)%x(2), v(1)) ! { dg-error "Allocate-object at \\(1\\) is subobject of object at \\(2\\)" } + allocate (v(1)%y(2), v(1)%x(1)) + allocate (v(2)%x(3), v(2)%x(3)) ! { dg-error "Allocate-object at \\(1\\) also appears at \\(2\\)" } + allocate (v(1)%x(3), v(2)%x(3)) + deallocate (v, v) ! { dg-error "Allocate-object at \\(1\\) also appears at \\(2\\)" } + deallocate (v, v(1)%x) ! { dg-error "Allocate-object at \\(1\\) is subobject of object at \\(2\\)" } + deallocate (v(1)%x, v) ! { dg-error "Allocate-object at \\(1\\) is subobject of object at \\(2\\)" } + deallocate (v(1)%y, v(1)%x) + deallocate (v(2)%x, v(2)%x) ! { dg-error "Allocate-object at \\(1\\) also appears at \\(2\\)" } + deallocate (v(1)%x, v(2)%x) +end program main |