aboutsummaryrefslogtreecommitdiff
path: root/gcc/fortran/trans-stmt.cc
diff options
context:
space:
mode:
Diffstat (limited to 'gcc/fortran/trans-stmt.cc')
-rw-r--r--gcc/fortran/trans-stmt.cc522
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);