trans-openmp.c (gfc_trans_omp_variable): Handle references to parent result.
* trans-openmp.c (gfc_trans_omp_variable): Handle references to parent result. * trans-expr.c (gfc_conv_variable): Remove useless setting of parent_flag, formatting. * testsuite/libgomp.fortran/retval2.f90: New test. From-SVN: r112026
This commit is contained in:
Jakub Jelinek
Jakub Jelinek
parent
4b8ae4dbb7
commit
11a5f60849
|
|
@ -1,5 +1,10 @@
|
|||
2006-03-13 Jakub Jelinek <jakub@redhat.com>
|
||||
|
||||
* trans-openmp.c (gfc_trans_omp_variable): Handle references
|
||||
to parent result.
|
||||
* trans-expr.c (gfc_conv_variable): Remove useless setting
|
||||
of parent_flag, formatting.
|
||||
|
||||
* trans-decl.c (gfc_get_fake_result_decl): Re-add setting of
|
||||
GFC_DECL_RESULT flag.
|
||||
|
||||
|
|
|
|||
|
|
@ -324,34 +324,31 @@ gfc_conv_variable (gfc_se * se, gfc_expr * expr)
|
|||
|
||||
/* Deal with references to a parent results or entries by storing
|
||||
the current_function_decl and moving to the parent_decl. */
|
||||
parent_flag = 0;
|
||||
|
||||
return_value = sym->attr.function && sym->result == sym;
|
||||
alternate_entry = sym->attr.function && sym->attr.entry
|
||||
&& sym->result == sym;
|
||||
&& sym->result == sym;
|
||||
entry_master = sym->attr.result
|
||||
&& sym->ns->proc_name->attr.entry_master
|
||||
&& !gfc_return_by_reference (sym->ns->proc_name);
|
||||
&& sym->ns->proc_name->attr.entry_master
|
||||
&& !gfc_return_by_reference (sym->ns->proc_name);
|
||||
parent_decl = DECL_CONTEXT (current_function_decl);
|
||||
|
||||
if ((se->expr == parent_decl && return_value)
|
||||
|| (sym->ns && sym->ns->proc_name
|
||||
&& sym->ns->proc_name->backend_decl == parent_decl
|
||||
&& (alternate_entry || entry_master)))
|
||||
|| (sym->ns && sym->ns->proc_name
|
||||
&& sym->ns->proc_name->backend_decl == parent_decl
|
||||
&& (alternate_entry || entry_master)))
|
||||
parent_flag = 1;
|
||||
else
|
||||
parent_flag = 0;
|
||||
|
||||
/* Special case for assigning the return value of a function.
|
||||
Self recursive functions must have an explicit return value. */
|
||||
if (sym->attr.function && sym->result == sym
|
||||
&& (se->expr == current_function_decl || parent_flag))
|
||||
if (return_value && (se->expr == current_function_decl || parent_flag))
|
||||
se_expr = gfc_get_fake_result_decl (sym, parent_flag);
|
||||
|
||||
/* Similarly for alternate entry points. */
|
||||
else if (alternate_entry
|
||||
&& (sym->ns->proc_name->backend_decl == current_function_decl
|
||||
|| parent_flag))
|
||||
&& (sym->ns->proc_name->backend_decl == current_function_decl
|
||||
|| parent_flag))
|
||||
{
|
||||
gfc_entry_list *el = NULL;
|
||||
|
||||
|
|
@ -364,8 +361,8 @@ gfc_conv_variable (gfc_se * se, gfc_expr * expr)
|
|||
}
|
||||
|
||||
else if (entry_master
|
||||
&& (sym->ns->proc_name->backend_decl == current_function_decl
|
||||
|| parent_flag))
|
||||
&& (sym->ns->proc_name->backend_decl == current_function_decl
|
||||
|| parent_flag))
|
||||
se_expr = gfc_get_fake_result_decl (sym, parent_flag);
|
||||
|
||||
if (se_expr)
|
||||
|
|
|
|||
|
|
@ -182,40 +182,56 @@ gfc_trans_add_clause (tree node, tree tail)
|
|||
return node;
|
||||
}
|
||||
|
||||
/* TODO make references to parent function results, as done in
|
||||
gfc_conv_variable. */
|
||||
|
||||
static tree
|
||||
gfc_trans_omp_variable (gfc_symbol *sym)
|
||||
{
|
||||
tree t = gfc_get_symbol_decl (sym);
|
||||
tree parent_decl;
|
||||
int parent_flag;
|
||||
bool return_value;
|
||||
bool alternate_entry;
|
||||
bool entry_master;
|
||||
|
||||
return_value = sym->attr.function && sym->result == sym;
|
||||
alternate_entry = sym->attr.function && sym->attr.entry
|
||||
&& sym->result == sym;
|
||||
entry_master = sym->attr.result
|
||||
&& sym->ns->proc_name->attr.entry_master
|
||||
&& !gfc_return_by_reference (sym->ns->proc_name);
|
||||
parent_decl = DECL_CONTEXT (current_function_decl);
|
||||
|
||||
if ((t == parent_decl && return_value)
|
||||
|| (sym->ns && sym->ns->proc_name
|
||||
&& sym->ns->proc_name->backend_decl == parent_decl
|
||||
&& (alternate_entry || entry_master)))
|
||||
parent_flag = 1;
|
||||
else
|
||||
parent_flag = 0;
|
||||
|
||||
/* Special case for assigning the return value of a function.
|
||||
Self recursive functions must have an explicit return value. */
|
||||
if (t == current_function_decl && sym->attr.function
|
||||
&& (sym->result == sym))
|
||||
t = gfc_get_fake_result_decl (sym, 0);
|
||||
if (return_value && (t == current_function_decl || parent_flag))
|
||||
t = gfc_get_fake_result_decl (sym, parent_flag);
|
||||
|
||||
/* Similarly for alternate entry points. */
|
||||
else if (sym->attr.function && sym->attr.entry
|
||||
&& (sym->result == sym)
|
||||
&& sym->ns->proc_name->backend_decl == current_function_decl)
|
||||
else if (alternate_entry
|
||||
&& (sym->ns->proc_name->backend_decl == current_function_decl
|
||||
|| parent_flag))
|
||||
{
|
||||
gfc_entry_list *el = NULL;
|
||||
|
||||
for (el = sym->ns->entries; el; el = el->next)
|
||||
if (sym == el->sym)
|
||||
{
|
||||
t = gfc_get_fake_result_decl (sym, 0);
|
||||
t = gfc_get_fake_result_decl (sym, parent_flag);
|
||||
break;
|
||||
}
|
||||
}
|
||||
|
||||
else if (sym->attr.result
|
||||
&& sym->ns->proc_name->backend_decl == current_function_decl
|
||||
&& sym->ns->proc_name->attr.entry_master
|
||||
&& !gfc_return_by_reference (sym->ns->proc_name))
|
||||
t = gfc_get_fake_result_decl (sym, 0);
|
||||
else if (entry_master
|
||||
&& (sym->ns->proc_name->backend_decl == current_function_decl
|
||||
|| parent_flag))
|
||||
t = gfc_get_fake_result_decl (sym, parent_flag);
|
||||
|
||||
return t;
|
||||
}
|
||||
|
|
@ -408,7 +424,7 @@ gfc_trans_omp_array_reduction (tree c, gfc_symbol *sym, locus where)
|
|||
|
||||
static tree
|
||||
gfc_trans_omp_reduction_list (gfc_namelist *namelist, tree list,
|
||||
enum tree_code reduction_code, locus where)
|
||||
enum tree_code reduction_code, locus where)
|
||||
{
|
||||
for (; namelist != NULL; namelist = namelist->next)
|
||||
if (namelist->sym->attr.referenced)
|
||||
|
|
|
|||
|
|
@ -1,3 +1,7 @@
|
|||
2006-03-13 Jakub Jelinek <jakub@redhat.com>
|
||||
|
||||
* testsuite/libgomp.fortran/retval2.f90: New test.
|
||||
|
||||
2006-03-09 Diego Novillo <dnovillo@redhat.com>
|
||||
|
||||
* testsuite/libgomp.c++: New directory.
|
||||
|
|
|
|||
|
|
@ -0,0 +1,27 @@
|
|||
! { dg-do run }
|
||||
|
||||
function f1 ()
|
||||
real :: f1
|
||||
f1 = 6.5
|
||||
call sub1
|
||||
contains
|
||||
subroutine sub1
|
||||
use omp_lib
|
||||
logical :: l
|
||||
l = .false.
|
||||
!$omp parallel firstprivate (f1) num_threads (2) reduction (.or.:l)
|
||||
l = f1 .ne. 6.5
|
||||
if (omp_get_thread_num () .eq. 0) f1 = 8.5
|
||||
if (omp_get_thread_num () .eq. 1) f1 = 14.5
|
||||
!$omp barrier
|
||||
l = l .or. (omp_get_thread_num () .eq. 0 .and. f1 .ne. 8.5)
|
||||
l = l .or. (omp_get_thread_num () .eq. 1 .and. f1 .ne. 14.5)
|
||||
!$omp end parallel
|
||||
if (l) call abort
|
||||
f1 = -2.5
|
||||
end subroutine sub1
|
||||
end function f1
|
||||
|
||||
real :: f1
|
||||
if (f1 () .ne. -2.5) call abort
|
||||
end
|
||||
Loading…
Reference in New Issue