+2008-02-03 Paul Thomas <pault@gcc.gnu.org>
+
+ 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 <pault@gcc.gnu.org>
PR fortran/34910
}
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;
}
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;
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;
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 ************/
int omp_workshare_save;
int forall_save;
code_stack frame;
- gfc_alloc *a;
try t;
frame.prev = cs_base;
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;
+2008-02-03 Paul Thomas <pault@gcc.gnu.org>
+
+ 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 <matz@suse.de>
PR target/35045
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
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
--- /dev/null
+! { dg-do compile }
+! This tests that PR32760, in its various manifestations is fixed.
+!
+! Contributed by Harald Anlauf <anlauf@gmx.de>
+!
+! 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" } }
projects / gcc.git / commitdiff