Dear all,
the variable_check() failed when one had multiple nested blocks.
I think it worked in 4.5 because that was before PR 46484 got fixed in
4.6. The issue that PR fixed was that the non-variableness of "f" in
"sub" (see below) was not diagnosed. The problem is that the symbol tree
is shared and "sym == sym->result" is also true in "sub":
contains
subroutine sub
...= allocatable(f)
end
function f()
This patch simply allows for more than one level of parent namespace.
Build and regtested on x86-64-linux.
OK for the trunk and for the 4.6 branch?
Tobias
2012-01-23 Tobias Burnus <bur...@net-b.de>
PR fortran/51948
* check.c (variable_check): Fix checking for
result variables and deeply nested BLOCKs.
2012-01-23 Tobias Burnus <bur...@net-b.de>
PR fortran/51948
* gfortran.dg/move_alloc_12.f90: New.
diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c
index cb6b94f..4b72a5f 100644
--- a/gcc/fortran/check.c
+++ b/gcc/fortran/check.c
@@ -521,15 +521,18 @@ variable_check (gfc_expr *e, int n, bool allow_proc)
if (e->expr_type == EXPR_VARIABLE
&& e->symtree->n.sym->attr.flavor != FL_PARAMETER
- && (allow_proc
- || !e->symtree->n.sym->attr.function
- || (e->symtree->n.sym == e->symtree->n.sym->result
- && (e->symtree->n.sym == gfc_current_ns->proc_name
- || (gfc_current_ns->parent
- && e->symtree->n.sym
- == gfc_current_ns->parent->proc_name)))))
+ && (allow_proc || !e->symtree->n.sym->attr.function))
return SUCCESS;
+ if (e->expr_type == EXPR_VARIABLE && e->symtree->n.sym->attr.function
+ && e->symtree->n.sym == e->symtree->n.sym->result)
+ {
+ gfc_namespace *ns;
+ for (ns = gfc_current_ns; ns; ns = ns->parent)
+ if (ns->proc_name == e->symtree->n.sym)
+ return SUCCESS;
+ }
+
gfc_error ("'%s' argument of '%s' intrinsic at %L must be a variable",
gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic, &e->where);
--- /dev/null 2012-01-23 08:22:38.999666895 +0100
+++ gcc/gcc/testsuite/gfortran.dg/move_alloc_12.f90 2012-01-23 14:23:37.000000000 +0100
@@ -0,0 +1,33 @@
+! { dg-do compile }
+!
+! PR fortran/51948
+!
+ type :: t
+ end type t
+contains
+ function func(x, y)
+ class(t) :: y
+ type(t), allocatable :: func
+ type(t), allocatable :: x
+
+ select type (y)
+ type is(t)
+ call move_alloc (x, func)
+ end select
+ end function
+
+ function func2(x, y)
+ class(t) :: y
+ class(t), allocatable :: func2
+ class(t), allocatable :: x
+
+ block
+ block
+ select type (y)
+ type is(t)
+ call move_alloc (x, func2)
+ end select
+ end block
+ end block
+ end function
+end
