diff options
Diffstat (limited to 'gcc/fortran/trans-stmt.cc')
-rw-r--r-- | gcc/fortran/trans-stmt.cc | 522 |
1 files changed, 414 insertions, 108 deletions
diff --git a/gcc/fortran/trans-stmt.cc b/gcc/fortran/trans-stmt.cc index f16e1e3..f105401 100644 --- a/gcc/fortran/trans-stmt.cc +++ b/gcc/fortran/trans-stmt.cc @@ -19,7 +19,7 @@ You should have received a copy of the GNU General Public License along with GCC; see the file COPYING3. If not see <http://www.gnu.org/licenses/>. */ - +#define INCLUDE_VECTOR #include "config.h" #include "system.h" #include "coretypes.h" @@ -377,6 +377,57 @@ get_intrinsic_for_code (gfc_code *code) } +/* Handle the OpenACC routines acc_attach{,_async} and + acc_detach{,_finalize}{,_async} explicitly. This is required as the + the corresponding device pointee is attached to the corresponding device + pointer, but if a temporary array descriptor is created for the call, + that one is used as pointer instead of the original pointer. */ + +tree +gfc_trans_call_acc_attach_detach (gfc_code *code) +{ + stmtblock_t block; + gfc_se ptr_addr_se, async_se; + tree fn; + + fn = code->resolved_sym->backend_decl; + if (fn == NULL) + { + fn = gfc_get_symbol_decl (code->resolved_sym); + code->resolved_sym->backend_decl = fn; + } + + gfc_start_block (&block); + + gfc_init_se (&ptr_addr_se, NULL); + ptr_addr_se.descriptor_only = 1; + ptr_addr_se.want_pointer = 1; + gfc_conv_expr (&ptr_addr_se, code->ext.actual->expr); + gfc_add_block_to_block (&block, &ptr_addr_se.pre); + if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (ptr_addr_se.expr))) + ptr_addr_se.expr = gfc_conv_descriptor_data_get (ptr_addr_se.expr); + ptr_addr_se.expr = build_fold_addr_expr (ptr_addr_se.expr); + + bool async = code->ext.actual->next != NULL; + if (async) + { + gfc_init_se (&async_se, NULL); + gfc_conv_expr (&async_se, code->ext.actual->next->expr); + fn = build_call_expr_loc (gfc_get_location (&code->loc), fn, 2, + ptr_addr_se.expr, async_se.expr); + } + else + fn = build_call_expr_loc (gfc_get_location (&code->loc), + fn, 1, ptr_addr_se.expr); + gfc_add_expr_to_block (&block, fn); + gfc_add_block_to_block (&block, &ptr_addr_se.post); + if (async) + gfc_add_block_to_block (&block, &async_se.post); + + return gfc_finish_block (&block); +} + + /* Translate the CALL statement. Builds a call to an F95 subroutine. */ tree @@ -392,13 +443,32 @@ gfc_trans_call (gfc_code * code, bool dependency_check, tree tmp; bool is_intrinsic_mvbits; + gcc_assert (code->resolved_sym); + + /* Unfortunately, acc_attach* and acc_detach* need some special treatment for + attaching the the pointee to a pointer as GCC might introduce a temporary + array descriptor, whose data component is then used as to be attached to + pointer. */ + if (flag_openacc + && code->resolved_sym->attr.subroutine + && code->resolved_sym->formal + && code->resolved_sym->formal->sym->ts.type == BT_ASSUMED + && code->resolved_sym->formal->sym->attr.dimension + && code->resolved_sym->formal->sym->as->type == AS_ASSUMED_RANK + && startswith (code->resolved_sym->name, "acc_") + && (!strcmp (code->resolved_sym->name + 4, "attach") + || !strcmp (code->resolved_sym->name + 4, "attach_async") + || !strcmp (code->resolved_sym->name + 4, "detach") + || !strcmp (code->resolved_sym->name + 4, "detach_async") + || !strcmp (code->resolved_sym->name + 4, "detach_finalize") + || !strcmp (code->resolved_sym->name + 4, "detach_finalize_async"))) + return gfc_trans_call_acc_attach_detach (code); + /* A CALL starts a new block because the actual arguments may have to be evaluated first. */ gfc_init_se (&se, NULL); gfc_start_block (&se.pre); - gcc_assert (code->resolved_sym); - ss = gfc_ss_terminator; if (code->resolved_sym->attr.elemental) ss = gfc_walk_elemental_function_args (ss, code->ext.actual, @@ -721,6 +791,15 @@ gfc_trans_stop (gfc_code *code, bool error_stop) return gfc_finish_block (&se.pre); } +tree +trans_exit () +{ + const char *name = gfc_get_string (PREFIX ("exit_i%d"), 4); + gfc_symbol *exsym = gfc_get_intrinsic_sub_symbol (name); + tree tmp = gfc_get_symbol_decl (exsym); + return build_call_expr_loc (input_location, tmp, 1, integer_zero_node); +} + /* Translate the FAIL IMAGE statement. */ tree @@ -730,11 +809,49 @@ gfc_trans_fail_image (gfc_code *code ATTRIBUTE_UNUSED) return build_call_expr_loc (input_location, gfor_fndecl_caf_fail_image, 0); else + return trans_exit (); +} + +void +gfc_trans_sync_stat (struct sync_stat *sync_stat, gfc_se *se, tree *stat, + tree *errmsg, tree *errmsg_len) +{ + gfc_se argse; + + if (sync_stat->stat) { - const char *name = gfc_get_string (PREFIX ("exit_i%d"), 4); - gfc_symbol *exsym = gfc_get_intrinsic_sub_symbol (name); - tree tmp = gfc_get_symbol_decl (exsym); - return build_call_expr_loc (input_location, tmp, 1, integer_zero_node); + gfc_init_se (&argse, NULL); + gfc_conv_expr (&argse, sync_stat->stat); + gfc_add_block_to_block (&se->pre, &argse.pre); + + if (TREE_TYPE (argse.expr) != integer_type_node) + { + tree tstat = gfc_create_var (integer_type_node, "stat"); + TREE_THIS_VOLATILE (tstat) = 1; + gfc_add_modify (&se->pre, tstat, + fold_convert (integer_type_node, argse.expr)); + gfc_add_modify (&se->post, argse.expr, + fold_convert (TREE_TYPE (argse.expr), tstat)); + *stat = build_fold_addr_expr (tstat); + } + else + *stat = build_fold_addr_expr (argse.expr); + } + else + *stat = null_pointer_node; + + if (sync_stat->errmsg) + { + gfc_init_se (&argse, NULL); + gfc_conv_expr_reference (&argse, sync_stat->errmsg); + gfc_add_block_to_block (&se->pre, &argse.pre); + *errmsg = argse.expr; + *errmsg_len = fold_convert (size_type_node, argse.string_length); + } + else + { + *errmsg = null_pointer_node; + *errmsg_len = build_zero_cst (size_type_node); } } @@ -745,38 +862,42 @@ gfc_trans_form_team (gfc_code *code) { if (flag_coarray == GFC_FCOARRAY_LIB) { - gfc_se se; - gfc_se argse1, argse2; - tree team_id, team_type, tmp; + gfc_se se, argse; + tree team_id, team_type, new_index, stat, errmsg, errmsg_len, tmp; gfc_init_se (&se, NULL); - gfc_init_se (&argse1, NULL); - gfc_init_se (&argse2, NULL); - gfc_start_block (&se.pre); + gfc_init_se (&argse, NULL); + + gfc_conv_expr_val (&argse, code->expr1); + team_id = fold_convert (integer_type_node, argse.expr); + gfc_conv_expr_reference (&argse, code->expr2); + team_type = argse.expr; + + /* NEW_INDEX=. */ + if (code->expr3) + { + gfc_conv_expr_reference (&argse, code->expr3); + new_index = argse.expr; + } + else + new_index = null_pointer_node; - gfc_conv_expr_val (&argse1, code->expr1); - gfc_conv_expr_val (&argse2, code->expr2); - team_id = fold_convert (integer_type_node, argse1.expr); - team_type = gfc_build_addr_expr (ppvoid_type_node, argse2.expr); + gfc_add_block_to_block (&se.post, &argse.post); - gfc_add_block_to_block (&se.pre, &argse1.pre); - gfc_add_block_to_block (&se.pre, &argse2.pre); - tmp = build_call_expr_loc (input_location, - gfor_fndecl_caf_form_team, 3, - team_id, team_type, - integer_zero_node); + gfc_trans_sync_stat (&code->ext.sync_stat, &se, &stat, &errmsg, + &errmsg_len); + + gfc_add_block_to_block (&se.pre, &argse.pre); + + tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_form_team, 6, + team_id, team_type, new_index, stat, errmsg, + errmsg_len); gfc_add_expr_to_block (&se.pre, tmp); - gfc_add_block_to_block (&se.pre, &argse1.post); - gfc_add_block_to_block (&se.pre, &argse2.post); + gfc_add_block_to_block (&se.pre, &se.post); return gfc_finish_block (&se.pre); - } + } else - { - const char *name = gfc_get_string (PREFIX ("exit_i%d"), 4); - gfc_symbol *exsym = gfc_get_intrinsic_sub_symbol (name); - tree tmp = gfc_get_symbol_decl (exsym); - return build_call_expr_loc (input_location, tmp, 1, integer_zero_node); - } + return trans_exit (); } /* Translate the CHANGE TEAM statement. */ @@ -786,47 +907,56 @@ gfc_trans_change_team (gfc_code *code) { if (flag_coarray == GFC_FCOARRAY_LIB) { - gfc_se argse; - tree team_type, tmp; + stmtblock_t block; + gfc_se se; + tree team_type, stat, errmsg, errmsg_len, tmp; - gfc_init_se (&argse, NULL); - gfc_conv_expr_val (&argse, code->expr1); - team_type = gfc_build_addr_expr (ppvoid_type_node, argse.expr); + gfc_init_se (&se, NULL); + gfc_start_block (&block); - tmp = build_call_expr_loc (input_location, - gfor_fndecl_caf_change_team, 2, team_type, - integer_zero_node); - gfc_add_expr_to_block (&argse.pre, tmp); - gfc_add_block_to_block (&argse.pre, &argse.post); - return gfc_finish_block (&argse.pre); + gfc_conv_expr_val (&se, code->expr1); + team_type = se.expr; + + gfc_trans_sync_stat (&code->ext.block.sync_stat, &se, &stat, &errmsg, + &errmsg_len); + + tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_change_team, 4, + team_type, stat, errmsg, errmsg_len); + + gfc_add_expr_to_block (&se.pre, tmp); + gfc_add_block_to_block (&se.pre, &se.post); + gfc_add_block_to_block (&block, &se.pre); + gfc_add_expr_to_block (&block, gfc_trans_block_construct (code)); + return gfc_finish_block (&block); } else - { - const char *name = gfc_get_string (PREFIX ("exit_i%d"), 4); - gfc_symbol *exsym = gfc_get_intrinsic_sub_symbol (name); - tree tmp = gfc_get_symbol_decl (exsym); - return build_call_expr_loc (input_location, tmp, 1, integer_zero_node); - } + return trans_exit (); } /* Translate the END TEAM statement. */ tree -gfc_trans_end_team (gfc_code *code ATTRIBUTE_UNUSED) +gfc_trans_end_team (gfc_code *code) { if (flag_coarray == GFC_FCOARRAY_LIB) { - return build_call_expr_loc (input_location, - gfor_fndecl_caf_end_team, 1, - build_int_cst (pchar_type_node, 0)); + gfc_se se; + tree stat, errmsg, errmsg_len, tmp; + + gfc_init_se (&se, NULL); + gfc_start_block (&se.pre); + + gfc_trans_sync_stat (&code->ext.sync_stat, &se, &stat, &errmsg, + &errmsg_len); + + tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_end_team, 3, + stat, errmsg, errmsg_len); + gfc_add_expr_to_block (&se.pre, tmp); + gfc_add_block_to_block (&se.pre, &se.post); + return gfc_finish_block (&se.pre); } else - { - const char *name = gfc_get_string (PREFIX ("exit_i%d"), 4); - gfc_symbol *exsym = gfc_get_intrinsic_sub_symbol (name); - tree tmp = gfc_get_symbol_decl (exsym); - return build_call_expr_loc (input_location, tmp, 1, integer_zero_node); - } + return trans_exit (); } /* Translate the SYNC TEAM statement. */ @@ -836,28 +966,25 @@ gfc_trans_sync_team (gfc_code *code) { if (flag_coarray == GFC_FCOARRAY_LIB) { - gfc_se argse; - tree team_type, tmp; + gfc_se se; + tree team_type, stat, errmsg, errmsg_len, tmp; - gfc_init_se (&argse, NULL); - gfc_conv_expr_val (&argse, code->expr1); - team_type = gfc_build_addr_expr (ppvoid_type_node, argse.expr); + gfc_init_se (&se, NULL); - tmp = build_call_expr_loc (input_location, - gfor_fndecl_caf_sync_team, 2, - team_type, - integer_zero_node); - gfc_add_expr_to_block (&argse.pre, tmp); - gfc_add_block_to_block (&argse.pre, &argse.post); - return gfc_finish_block (&argse.pre); + gfc_conv_expr_val (&se, code->expr1); + team_type = se.expr; + + gfc_trans_sync_stat (&code->ext.sync_stat, &se, &stat, &errmsg, + &errmsg_len); + + tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_sync_team, 4, + team_type, stat, errmsg, errmsg_len); + gfc_add_expr_to_block (&se.pre, tmp); + gfc_add_block_to_block (&se.pre, &se.post); + return gfc_finish_block (&se.pre); } else - { - const char *name = gfc_get_string (PREFIX ("exit_i%d"), 4); - gfc_symbol *exsym = gfc_get_intrinsic_sub_symbol (name); - tree tmp = gfc_get_symbol_decl (exsym); - return build_call_expr_loc (input_location, tmp, 1, integer_zero_node); - } + return trans_exit (); } tree @@ -1280,8 +1407,7 @@ gfc_trans_sync (gfc_code *code, gfc_exec_op type) { tree cond2; tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_num_images, - 2, integer_zero_node, - build_int_cst (integer_type_node, -1)); + 2, null_pointer_node, null_pointer_node); cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node, images2, tmp); cond2 = fold_build2_loc (input_location, LT_EXPR, logical_type_node, @@ -1609,35 +1735,41 @@ gfc_trans_arithmetic_if (gfc_code * code) /* Translate a CRITICAL block. */ + tree gfc_trans_critical (gfc_code *code) -{ - stmtblock_t block; - tree tmp, token = NULL_TREE; + { + stmtblock_t block; + tree tmp, token = NULL_TREE; + tree stat = NULL_TREE, errmsg, errmsg_len; - gfc_start_block (&block); + gfc_start_block (&block); - if (flag_coarray == GFC_FCOARRAY_LIB) - { - tree zero_size = build_zero_cst (size_type_node); - token = gfc_get_symbol_decl (code->resolved_sym); - token = GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE (token)); - tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_lock, 7, - token, zero_size, integer_one_node, - null_pointer_node, null_pointer_node, - null_pointer_node, zero_size); - gfc_add_expr_to_block (&block, tmp); + if (flag_coarray == GFC_FCOARRAY_LIB) + { + gfc_se se; - /* It guarantees memory consistency within the same segment */ - tmp = gfc_build_string_const (strlen ("memory")+1, "memory"), - tmp = build5_loc (input_location, ASM_EXPR, void_type_node, - gfc_build_string_const (1, ""), - NULL_TREE, NULL_TREE, - tree_cons (NULL_TREE, tmp, NULL_TREE), - NULL_TREE); - ASM_VOLATILE_P (tmp) = 1; + gfc_init_se (&se, NULL); + gfc_trans_sync_stat (&code->ext.sync_stat, &se, &stat, &errmsg, + &errmsg_len); + gfc_add_block_to_block (&block, &se.pre); - gfc_add_expr_to_block (&block, tmp); + token = gfc_get_symbol_decl (code->resolved_sym); + token = GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE (token)); + tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_lock, 7, + token, integer_zero_node, integer_one_node, + null_pointer_node, stat, errmsg, errmsg_len); + gfc_add_expr_to_block (&block, tmp); + gfc_add_block_to_block (&block, &se.post); + + /* It guarantees memory consistency within the same segment. */ + tmp = gfc_build_string_const (strlen ("memory") + 1, "memory"), + tmp = build5_loc (input_location, ASM_EXPR, void_type_node, + gfc_build_string_const (1, ""), NULL_TREE, NULL_TREE, + tree_cons (NULL_TREE, tmp, NULL_TREE), NULL_TREE); + ASM_VOLATILE_P (tmp) = 1; + + gfc_add_expr_to_block (&block, tmp); } tmp = gfc_trans_code (code->block->next); @@ -1645,11 +1777,19 @@ gfc_trans_critical (gfc_code *code) if (flag_coarray == GFC_FCOARRAY_LIB) { - tree zero_size = build_zero_cst (size_type_node); - tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_unlock, 6, - token, zero_size, integer_one_node, - null_pointer_node, null_pointer_node, - zero_size); + /* END CRITICAL does not accept STAT or ERRMSG arguments. + * If STAT= is specified for CRITICAL, pass a stat argument to + * _gfortran_caf_lock_unlock to prevent termination in the event of an + * error, but ignore any value assigned to it. + */ + tmp = build_call_expr_loc ( + input_location, gfor_fndecl_caf_unlock, 6, token, integer_zero_node, + integer_one_node, + stat != NULL_TREE + ? gfc_build_addr_expr (NULL, + gfc_create_var (integer_type_node, "stat")) + : null_pointer_node, + null_pointer_node, integer_zero_node); gfc_add_expr_to_block (&block, tmp); /* It guarantees memory consistency within the same segment */ @@ -1981,11 +2121,35 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block) GFC_DECL_PTR_ARRAY_P (sym->backend_decl) = 1; } - if (sym->attr.codimension && !sym->attr.dimension) + if (sym->attr.codimension) se.want_coarray = 1; gfc_conv_expr_descriptor (&se, e); + if (flag_coarray == GFC_FCOARRAY_LIB && sym->attr.codimension) + { + tree token = gfc_conv_descriptor_token (se.expr), + size + = sym->attr.dimension + ? fold_build2 (MULT_EXPR, gfc_array_index_type, + gfc_conv_descriptor_size (se.expr, e->rank), + gfc_conv_descriptor_span_get (se.expr)) + : gfc_conv_descriptor_span_get (se.expr); + /* Create a new token, because in the token the modified descriptor + is stored. The modified descriptor is needed for accesses on the + remote image. In the scalar case, the base address needs to be + associated correctly, which also needs a new token. + The token is freed automatically be the end team statement. */ + gfc_add_expr_to_block ( + &se.pre, + build_call_expr_loc ( + input_location, gfor_fndecl_caf_register, 7, size, + build_int_cst (integer_type_node, GFC_CAF_COARRAY_MAP_EXISTING), + gfc_build_addr_expr (pvoid_type_node, token), + gfc_build_addr_expr (NULL_TREE, se.expr), null_pointer_node, + null_pointer_node, integer_zero_node)); + } + if (sym->ts.type == BT_CHARACTER && !sym->attr.select_type_temporary && sym->ts.u.cl->backend_decl @@ -5093,6 +5257,138 @@ gfc_trans_pointer_assign_need_temp (gfc_expr * expr1, gfc_expr * expr2, } } +/* For saving the outer-variable data when doing + LOCAL and LOCAL_INIT substitution. */ +struct symbol_and_tree_t +{ + gfc_symbol *sym; + gfc_expr *value; + tree decl; + symbol_attribute attr; +}; + +/* Handle the LOCAL and LOCAL_INIT locality specifiers. This has to be + called twice, once with after_body=false - and then after the loop + body has been processed with after_body=true. + + Creates a copy of the variables that appear in the LOCAL and LOCAL_INIT + locality specifiers of 'do concurrent' - and use it in the original + gfc_symbol. The declaration is then reset by after_body=true. + + Variables in LOCAL_INIT are set in every loop iteration. */ + +void +gfc_trans_concurrent_locality_spec (bool after_body, stmtblock_t *body, + std::vector<symbol_and_tree_t> *saved_decls, + gfc_expr_list **locality_list) +{ + if (!locality_list[LOCALITY_LOCAL] && !locality_list[LOCALITY_LOCAL_INIT]) + return; + + if (after_body) + { + for (unsigned i = 0; i < saved_decls->size (); i++) + { + (*saved_decls)[i].sym->backend_decl = (*saved_decls)[i].decl; + (*saved_decls)[i].sym->attr = (*saved_decls)[i].attr; + (*saved_decls)[i].sym->value = (*saved_decls)[i].value; + } + return; + } + + gfc_expr_list *el; + int cnt = 0; + for (int i = 0; i <= 1; i++) + for (el = locality_list[i == 0 ? LOCALITY_LOCAL : LOCALITY_LOCAL_INIT]; + el; el = el->next) + { + gfc_symbol *outer_sym = el->expr->symtree->n.sym; + if (!outer_sym->backend_decl) + outer_sym->backend_decl = gfc_get_symbol_decl (outer_sym); + cnt++; + } + saved_decls->resize (cnt); + + /* The variables have to be created in the scope of the loop body. */ + if (!body->has_scope) + { + gcc_checking_assert (body->head == NULL_TREE); + gfc_start_block (body); + } + gfc_start_saved_local_decls (); + + cnt = 0; + static_assert (LOCALITY_LOCAL_INIT - LOCALITY_LOCAL == 1, "locality_type"); + for (int type = LOCALITY_LOCAL; + type <= LOCALITY_LOCAL_INIT; type++) + for (el = locality_list[type]; el; el = el->next) + { + gfc_symbol *sym = el->expr->symtree->n.sym; + (*saved_decls)[cnt].sym = sym; + (*saved_decls)[cnt].attr = sym->attr; + (*saved_decls)[cnt].value = sym->value; + (*saved_decls)[cnt].decl = sym->backend_decl; + + if (sym->attr.dimension && sym->as->type == AS_ASSUMED_SHAPE) + { + gfc_error ("Sorry, %s specifier at %L for assumed-size array %qs " + "is not yet supported", + type == LOCALITY_LOCAL ? "LOCAL" : "LOCAL_INIT", + &el->expr->where, sym->name); + continue; + } + + gfc_symbol outer_sym = *sym; + + /* Create the inner local variable. */ + sym->backend_decl = NULL; + sym->value = NULL; + sym->attr.save = SAVE_NONE; + sym->attr.value = 0; + sym->attr.dummy = 0; + sym->attr.optional = 0; + + { + /* Slightly ugly hack for adding the decl via add_decl_as_local. */ + gfc_symbol dummy_block_sym; + dummy_block_sym.attr.flavor = FL_LABEL; + gfc_symbol *saved_proc_name = sym->ns->proc_name; + sym->ns->proc_name = &dummy_block_sym; + + gfc_get_symbol_decl (sym); + DECL_SOURCE_LOCATION (sym->backend_decl) + = gfc_get_location (&el->expr->where); + + sym->ns->proc_name = saved_proc_name; + } + + symbol_attribute attr = gfc_expr_attr (el->expr); + if (type == LOCALITY_LOCAL + && !attr.pointer + && sym->ts.type == BT_DERIVED + && gfc_has_default_initializer (sym->ts.u.derived)) + /* Cf. PR fortran/ */ + gfc_error ("Sorry, LOCAL specifier at %L for %qs of derived type with" + " default initializer is not yet supported", + &el->expr->where, sym->name); + if (type == LOCALITY_LOCAL_INIT) + { + /* LOCAL_INIT: local_var = outer_var. */ + gfc_symtree st = *el->expr->symtree; + st.n.sym = &outer_sym; + gfc_expr expr = *el->expr; + expr.symtree = &st; + tree t = (attr.pointer + ? gfc_trans_pointer_assignment (el->expr, &expr) + : gfc_trans_assignment (el->expr, &expr, false, false, + false, false)); + gfc_add_expr_to_block (body, t); + } + cnt++; + } + gfc_stop_saved_local_decls (); +} + /* FORALL and WHERE statements are really nasty, especially when you nest them. All the rhs of a forall assignment must be evaluated before the @@ -5348,9 +5644,19 @@ gfc_trans_forall_1 (gfc_code * code, forall_info * nested_forall_info) gfc_init_block (&body); cycle_label = gfc_build_label_decl (NULL_TREE); code->cycle_label = cycle_label; + + /* Handle LOCAL and LOCAL_INIT. */ + std::vector<symbol_and_tree_t> saved_decls; + gfc_trans_concurrent_locality_spec (false, &body, &saved_decls, + code->ext.concur.locality); + + /* Translate the body. */ tmp = gfc_trans_code (code->block->next); gfc_add_expr_to_block (&body, tmp); + /* Reset locality variables. */ + gfc_trans_concurrent_locality_spec (true, &body, &saved_decls, + code->ext.concur.locality); if (TREE_USED (cycle_label)) { tmp = build1_v (LABEL_EXPR, cycle_label); |