From a9e7fd6a16ffdbec685fac893dd44f1831849cc1 Mon Sep 17 00:00:00 2001 From: pault Date: Sun, 3 Feb 2008 11:29:27 +0000 Subject: 2008-02-03 Paul Thomas PR fortran/32760 * resolve.c (resolve_allocate_deallocate): New function. (resolve_code): Call it for allocate and deallocate. * match.c (gfc_match_allocate, gfc_match_deallocate) : Remove the checking of the STAT tag and put in above new function. * primary,c (match_variable): Do not fix flavor of host associated symbols yet if the type is not known. 2008-02-03 Paul Thomas PR fortran/32760 * gfortran.dg/host_assoc_variable_1.f90: New test. * gfortran.dg/allocate_stat.f90: Change last three error messages. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@132078 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/ChangeLog | 10 +++ gcc/fortran/match.c | 81 +----------------- gcc/fortran/primary.c | 8 ++ gcc/fortran/resolve.c | 95 ++++++++++++++++++---- gcc/testsuite/ChangeLog | 6 ++ gcc/testsuite/gfortran.dg/allocate_stat.f90 | 6 +- .../gfortran.dg/host_assoc_variable_1.f90 | 77 ++++++++++++++++++ 7 files changed, 185 insertions(+), 98 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/host_assoc_variable_1.f90 diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index f426aa24059..33f342391af 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,13 @@ +2008-02-03 Paul Thomas + + PR fortran/32760 + * resolve.c (resolve_allocate_deallocate): New function. + (resolve_code): Call it for allocate and deallocate. + * match.c (gfc_match_allocate, gfc_match_deallocate) : Remove + the checking of the STAT tag and put in above new function. + * primary,c (match_variable): Do not fix flavor of host + associated symbols yet if the type is not known. + 2008-01-31 Paul Thomas PR fortran/34910 diff --git a/gcc/fortran/match.c b/gcc/fortran/match.c index ad636f93f3d..324e52ecee0 100644 --- a/gcc/fortran/match.c +++ b/gcc/fortran/match.c @@ -2235,62 +2235,7 @@ gfc_match_allocate (void) } if (stat != NULL) - { - bool is_variable; - - if (stat->symtree->n.sym->attr.intent == INTENT_IN) - { - gfc_error ("STAT variable '%s' of ALLOCATE statement at %C cannot " - "be INTENT(IN)", stat->symtree->n.sym->name); - goto cleanup; - } - - if (gfc_pure (NULL) && gfc_impure_variable (stat->symtree->n.sym)) - { - gfc_error ("Illegal STAT variable in ALLOCATE statement at %C " - "for a PURE procedure"); - goto cleanup; - } - - is_variable = false; - if (stat->symtree->n.sym->attr.flavor == FL_VARIABLE) - is_variable = true; - else if (stat->symtree->n.sym->attr.function - && stat->symtree->n.sym->result == stat->symtree->n.sym - && (gfc_current_ns->proc_name == stat->symtree->n.sym - || (gfc_current_ns->parent - && gfc_current_ns->parent->proc_name - == stat->symtree->n.sym))) - is_variable = true; - else if (gfc_current_ns->entries - && stat->symtree->n.sym->result == stat->symtree->n.sym) - { - gfc_entry_list *el; - for (el = gfc_current_ns->entries; el; el = el->next) - if (el->sym == stat->symtree->n.sym) - { - is_variable = true; - } - } - else if (gfc_current_ns->parent && gfc_current_ns->parent->entries - && stat->symtree->n.sym->result == stat->symtree->n.sym) - { - gfc_entry_list *el; - for (el = gfc_current_ns->parent->entries; el; el = el->next) - if (el->sym == stat->symtree->n.sym) - { - is_variable = true; - } - } - - if (!is_variable) - { - gfc_error ("STAT expression at %C must be a variable"); - goto cleanup; - } - - gfc_check_do_variable(stat->symtree); - } + gfc_check_do_variable(stat->symtree); if (gfc_match (" )%t") != MATCH_YES) goto syntax; @@ -2432,29 +2377,7 @@ gfc_match_deallocate (void) } if (stat != NULL) - { - if (stat->symtree->n.sym->attr.intent == INTENT_IN) - { - gfc_error ("STAT variable '%s' of DEALLOCATE statement at %C " - "cannot be INTENT(IN)", stat->symtree->n.sym->name); - goto cleanup; - } - - if (gfc_pure(NULL) && gfc_impure_variable (stat->symtree->n.sym)) - { - gfc_error ("Illegal STAT variable in DEALLOCATE statement at %C " - "for a PURE procedure"); - goto cleanup; - } - - if (stat->symtree->n.sym->attr.flavor != FL_VARIABLE) - { - gfc_error ("STAT expression at %C must be a variable"); - goto cleanup; - } - - gfc_check_do_variable(stat->symtree); - } + gfc_check_do_variable(stat->symtree); if (gfc_match (" )%t") != MATCH_YES) goto syntax; diff --git a/gcc/fortran/primary.c b/gcc/fortran/primary.c index 1895ca07f56..8385cb5788e 100644 --- a/gcc/fortran/primary.c +++ b/gcc/fortran/primary.c @@ -2534,6 +2534,14 @@ match_variable (gfc_expr **result, int equiv_flag, int host_flag) if (sym->attr.external || sym->attr.procedure || sym->attr.function || sym->attr.subroutine) flavor = FL_PROCEDURE; + + /* If it is not a procedure, is not typed and is host associated, + we cannot give it a flavor yet. */ + else if (sym->ns == gfc_current_ns->parent + && sym->ts.type == BT_UNKNOWN) + break; + + /* These are definitive indicators that this is a variable. */ else if (gfc_peek_char () != '(' || sym->ts.type != BT_UNKNOWN || sym->attr.pointer || sym->as != NULL) flavor = FL_VARIABLE; diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 833fd27611c..926f0455f48 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -4864,6 +4864,81 @@ check_symbols: return SUCCESS; } +static void +resolve_allocate_deallocate (gfc_code *code, const char *fcn) +{ + gfc_symbol *s = NULL; + gfc_alloc *a; + bool is_variable; + + if (code->expr) + s = code->expr->symtree->n.sym; + + if (s) + { + if (s->attr.intent == INTENT_IN) + gfc_error ("STAT variable '%s' of %s statement at %C cannot " + "be INTENT(IN)", s->name, fcn); + + if (gfc_pure (NULL) && gfc_impure_variable (s)) + gfc_error ("Illegal STAT variable in %s statement at %C " + "for a PURE procedure", fcn); + + is_variable = false; + if (s->attr.flavor == FL_VARIABLE) + is_variable = true; + else if (s->attr.function && s->result == s + && (gfc_current_ns->proc_name == s + || + (gfc_current_ns->parent + && gfc_current_ns->parent->proc_name == s))) + is_variable = true; + else if (gfc_current_ns->entries && s->result == s) + { + gfc_entry_list *el; + for (el = gfc_current_ns->entries; el; el = el->next) + if (el->sym == s) + { + is_variable = true; + } + } + else if (gfc_current_ns->parent && gfc_current_ns->parent->entries + && s->result == s) + { + gfc_entry_list *el; + for (el = gfc_current_ns->parent->entries; el; el = el->next) + if (el->sym == s) + { + is_variable = true; + } + } + + if (s->attr.flavor == FL_UNKNOWN + && gfc_add_flavor (&s->attr, FL_VARIABLE, + s->name, NULL) == SUCCESS) + is_variable = true; + + if (!is_variable) + gfc_error ("STAT tag in %s statement at %L must be " + "a variable", fcn, &code->expr->where); + + } + + if (s && code->expr->ts.type != BT_INTEGER) + gfc_error ("STAT tag in %s statement at %L must be " + "of type INTEGER", fcn, &code->expr->where); + + if (strcmp (fcn, "ALLOCATE") == 0) + { + for (a = code->ext.alloc_list; a; a = a->next) + resolve_allocate_expr (a->expr, code); + } + else + { + for (a = code->ext.alloc_list; a; a = a->next) + resolve_deallocate_expr (a->expr); + } +} /************ SELECT CASE resolution subroutines ************/ @@ -6090,7 +6165,6 @@ resolve_code (gfc_code *code, gfc_namespace *ns) int omp_workshare_save; int forall_save; code_stack frame; - gfc_alloc *a; try t; frame.prev = cs_base; @@ -6275,25 +6349,14 @@ resolve_code (gfc_code *code, gfc_namespace *ns) break; case EXEC_ALLOCATE: - if (t == SUCCESS && code->expr != NULL - && code->expr->ts.type != BT_INTEGER) - gfc_error ("STAT tag in ALLOCATE statement at %L must be " - "of type INTEGER", &code->expr->where); - - for (a = code->ext.alloc_list; a; a = a->next) - resolve_allocate_expr (a->expr, code); + if (t == SUCCESS) + resolve_allocate_deallocate (code, "ALLOCATE"); break; case EXEC_DEALLOCATE: - if (t == SUCCESS && code->expr != NULL - && code->expr->ts.type != BT_INTEGER) - gfc_error - ("STAT tag in DEALLOCATE statement at %L must be of type " - "INTEGER", &code->expr->where); - - for (a = code->ext.alloc_list; a; a = a->next) - resolve_deallocate_expr (a->expr); + if (t == SUCCESS) + resolve_allocate_deallocate (code, "DEALLOCATE"); break; diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 9a2f57050ce..e4760f8951c 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,9 @@ +2008-02-03 Paul Thomas + + PR fortran/32760 + * gfortran.dg/host_assoc_variable_1.f90: New test. + * gfortran.dg/allocate_stat.f90: Change last three error messages. + 2008-02-02 Michael Matz PR target/35045 diff --git a/gcc/testsuite/gfortran.dg/allocate_stat.f90 b/gcc/testsuite/gfortran.dg/allocate_stat.f90 index 94ec4303f81..76626f822bc 100644 --- a/gcc/testsuite/gfortran.dg/allocate_stat.f90 +++ b/gcc/testsuite/gfortran.dg/allocate_stat.f90 @@ -51,7 +51,7 @@ subroutine sub() end interface real, pointer :: gain integer, parameter :: res = 2 - allocate (gain,STAT=func2) ! { dg-error "STAT expression at .1. must be a variable" } + allocate (gain,STAT=func2) ! { dg-error "STAT tag in ALLOCATE statement at .1. must be a variable" } deallocate(gain) end subroutine sub @@ -68,9 +68,9 @@ contains end function one subroutine sub() integer, pointer :: p - allocate(p, stat=one) ! { dg-error "STAT expression at .1. must be a variable" } + allocate(p, stat=one) ! { dg-error "STAT tag in ALLOCATE statement at .1. must be a variable" } if(associated(p)) deallocate(p) - allocate(p, stat=two) ! { dg-error "STAT expression at .1. must be a variable" } + allocate(p, stat=two) ! { dg-error "STAT tag in ALLOCATE statement at .1. must be a variable" } if(associated(p)) deallocate(p) end subroutine sub end module test diff --git a/gcc/testsuite/gfortran.dg/host_assoc_variable_1.f90 b/gcc/testsuite/gfortran.dg/host_assoc_variable_1.f90 new file mode 100644 index 00000000000..1e7adea8894 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/host_assoc_variable_1.f90 @@ -0,0 +1,77 @@ +! { dg-do compile } +! This tests that PR32760, in its various manifestations is fixed. +! +! Contributed by Harald Anlauf +! +! This is the original bug - the frontend tried to fix the flavor of +! 'PRINT' too early so that the compile failed on the subroutine +! declaration. +! +module gfcbug68 + implicit none + public :: print +contains + subroutine foo (i) + integer, intent(in) :: i + print *, i + end subroutine foo + subroutine print (m) + integer, intent(in) :: m + end subroutine print +end module gfcbug68 + +! This version of the bug appears in comment # 21. +! +module m + public :: volatile +contains + subroutine foo + volatile :: bar + end subroutine foo + subroutine volatile + end subroutine volatile +end module + +! This was a problem with the resolution of the STAT parameter in +! ALLOCATE and DEALLOCATE that was exposed in comment #25. +! +module n + public :: integer + private :: istat +contains + subroutine foo + integer, allocatable :: s(:), t(:) + allocate(t(5)) + allocate(s(4), stat=istat) + end subroutine foo + subroutine integer() + end subroutine integer +end module n + +! This is the version of the bug in comment #12 of the PR. +! +module gfcbug68a + implicit none + public :: write +contains + function foo (i) + integer, intent(in) :: i + integer foo + write (*,*) i + foo = i + end function foo + subroutine write (m) + integer, intent(in) :: m + print *, m*m*m + end subroutine write +end module gfcbug68a + +program testit + use gfcbug68a + integer :: i = 27 + integer :: k + k = foo(i) + print *, "in the main:", k + call write(33) +end program testit +! { dg-final { cleanup-modules "gfcbug68 gfcbug68a m n" } } -- cgit v1.2.1