builtin_decl_for_precision (enum built_in_function base_built_in,
int precision)
{
- int i = END_BUILTINS;
+ enum built_in_function i = END_BUILTINS;
gfc_intrinsic_map_t *m;
for (m = gfc_intrinsic_map; m->double_built_in != base_built_in ; m++)
return m->real16_decl;
}
- return (i == END_BUILTINS ? NULL_TREE : built_in_decls[i]);
+ return (i == END_BUILTINS ? NULL_TREE : builtin_decl_explicit (i));
}
m->id != GFC_ISYM_NONE || m->double_built_in != END_BUILTINS; m++)
{
if (m->float_built_in != END_BUILTINS)
- m->real4_decl = built_in_decls[m->float_built_in];
+ m->real4_decl = builtin_decl_explicit (m->float_built_in);
if (m->complex_float_built_in != END_BUILTINS)
- m->complex4_decl = built_in_decls[m->complex_float_built_in];
+ m->complex4_decl = builtin_decl_explicit (m->complex_float_built_in);
if (m->double_built_in != END_BUILTINS)
- m->real8_decl = built_in_decls[m->double_built_in];
+ m->real8_decl = builtin_decl_explicit (m->double_built_in);
if (m->complex_double_built_in != END_BUILTINS)
- m->complex8_decl = built_in_decls[m->complex_double_built_in];
+ m->complex8_decl = builtin_decl_explicit (m->complex_double_built_in);
/* If real(kind=10) exists, it is always long double. */
if (m->long_double_built_in != END_BUILTINS)
- m->real10_decl = built_in_decls[m->long_double_built_in];
+ m->real10_decl = builtin_decl_explicit (m->long_double_built_in);
if (m->complex_long_double_built_in != END_BUILTINS)
- m->complex10_decl = built_in_decls[m->complex_long_double_built_in];
+ m->complex10_decl
+ = builtin_decl_explicit (m->complex_long_double_built_in);
if (!gfc_real16_is_float128)
{
if (m->long_double_built_in != END_BUILTINS)
- m->real16_decl = built_in_decls[m->long_double_built_in];
+ m->real16_decl = builtin_decl_explicit (m->long_double_built_in);
if (m->complex_long_double_built_in != END_BUILTINS)
- m->complex16_decl = built_in_decls[m->complex_long_double_built_in];
+ m->complex16_decl
+ = builtin_decl_explicit (m->complex_long_double_built_in);
}
else if (quad_decls[m->double_built_in] != NULL_TREE)
{
gfc_get_intrinsic_lib_fndecl (gfc_intrinsic_map_t * m, gfc_expr * expr)
{
tree type;
- tree argtypes;
+ VEC(tree,gc) *argtypes;
tree fndecl;
gfc_actual_arglist *actual;
tree *pdecl;
ts->kind);
}
- argtypes = NULL_TREE;
+ argtypes = NULL;
for (actual = expr->value.function.actual; actual; actual = actual->next)
{
type = gfc_typenode_for_spec (&actual->expr->ts);
- argtypes = gfc_chainon_list (argtypes, type);
+ VEC_safe_push (tree, gc, argtypes, type);
}
- argtypes = chainon (argtypes, void_list_node);
- type = build_function_type (gfc_typenode_for_spec (ts), argtypes);
+ type = build_function_type_vec (gfc_typenode_for_spec (ts), argtypes);
fndecl = build_decl (input_location,
FUNCTION_DECL, get_identifier (name), type);
}
+/* Convert the last ref of a scalar coarray from an AR_ELEMENT to an
+ AR_FULL, suitable for the scalarizer. */
+
+static gfc_ss *
+walk_coarray (gfc_expr *e)
+{
+ gfc_ss *ss;
+
+ gcc_assert (gfc_get_corank (e) > 0);
+
+ ss = gfc_walk_expr (e);
+
+ /* Fix scalar coarray. */
+ if (ss == gfc_ss_terminator)
+ {
+ gfc_ref *ref;
+
+ ref = e->ref;
+ while (ref)
+ {
+ if (ref->type == REF_ARRAY
+ && ref->u.ar.codimen > 0)
+ break;
+
+ ref = ref->next;
+ }
+
+ gcc_assert (ref != NULL);
+ if (ref->u.ar.type == AR_ELEMENT)
+ ref->u.ar.type = AR_SECTION;
+ ss = gfc_reverse_ss (gfc_walk_array_ref (ss, e, ref));
+ }
+
+ return ss;
+}
+
+
static void
trans_this_image (gfc_se * se, gfc_expr *expr)
{
/* The case -fcoarray=single is handled elsewhere. */
gcc_assert (gfc_option.coarray != GFC_FCOARRAY_SINGLE);
- gfc_init_coarray_decl ();
+ gfc_init_coarray_decl (false);
/* Argument-free version: THIS_IMAGE(). */
if (expr->value.function.actual->expr == NULL)
/* Obtain the descriptor of the COARRAY. */
gfc_init_se (&argse, NULL);
- ss = gfc_walk_expr (expr->value.function.actual->expr);
+ ss = walk_coarray (expr->value.function.actual->expr);
gcc_assert (ss != gfc_ss_terminator);
- ss->data.info.codimen = corank;
+ argse.want_coarray = 1;
gfc_conv_expr_descriptor (&argse, expr->value.function.actual->expr, ss);
gfc_add_block_to_block (&se->pre, &argse.pre);
gfc_add_block_to_block (&se->post, &argse.post);
gcc_assert (!expr->value.function.actual->next->expr);
gcc_assert (corank > 0);
gcc_assert (se->loop->dimen == 1);
- gcc_assert (se->ss->expr == expr);
+ gcc_assert (se->ss->info->expr == expr);
dim_arg = se->loop->loopvar[0];
dim_arg = fold_build2_loc (input_location, PLUS_EXPR,
gfc_array_index_type, dim_arg,
- gfc_rank_cst[rank]);
+ build_int_cst (TREE_TYPE (dim_arg), 1));
gfc_advance_se_ss_chain (se);
}
else
m = this_images() - 1
i = rank
- min_var = min (corank - 2, dim_arg)
+ min_var = min (rank + corank - 2, rank + dim_arg - 1)
for (;;)
{
extent = gfc_extent(i)
build_int_cst (type, 1));
gfc_add_modify (&se->pre, m, tmp);
- /* min_var = min (rank+corank-2, dim_arg). */
+ /* min_var = min (rank + corank-2, rank + dim_arg - 1). */
+ tmp = fold_build2_loc (input_location, PLUS_EXPR, integer_type_node,
+ fold_convert (integer_type_node, dim_arg),
+ build_int_cst (integer_type_node, rank - 1));
tmp = fold_build2_loc (input_location, MIN_EXPR, integer_type_node,
build_int_cst (integer_type_node, rank + corank - 2),
- fold_convert (integer_type_node, dim_arg));
+ tmp);
gfc_add_modify (&se->pre, min_var, tmp);
/* i = rank. */
build_int_cst (TREE_TYPE (dim_arg), corank));
lbound = gfc_conv_descriptor_lbound_get (desc,
- fold_build2_loc (input_location, PLUS_EXPR,
- gfc_array_index_type, dim_arg,
- gfc_rank_cst[rank - 1]));
+ fold_build2_loc (input_location, PLUS_EXPR,
+ gfc_array_index_type, dim_arg,
+ build_int_cst (TREE_TYPE (dim_arg), rank-1)));
lbound = fold_convert (type, lbound);
tmp = fold_build2_loc (input_location, MINUS_EXPR, type, ml,
/* Obtain the descriptor of the COARRAY. */
gfc_init_se (&argse, NULL);
- ss = gfc_walk_expr (expr->value.function.actual->expr);
+ ss = walk_coarray (expr->value.function.actual->expr);
gcc_assert (ss != gfc_ss_terminator);
- ss->data.info.codimen = corank;
+ argse.want_coarray = 1;
gfc_conv_expr_descriptor (&argse, expr->value.function.actual->expr, ss);
gfc_add_block_to_block (&se->pre, &argse.pre);
gfc_add_block_to_block (&se->post, &argse.post);
num_images = build_int_cst (type, 1);
else
{
- gfc_init_coarray_decl ();
+ gfc_init_coarray_decl (false);
num_images = gfort_gvar_caf_num_images;
}
static void
trans_num_images (gfc_se * se)
{
- gfc_init_coarray_decl ();
+ gfc_init_coarray_decl (false);
se->expr = gfort_gvar_caf_num_images;
}
/* Create an implicit second parameter from the loop variable. */
gcc_assert (!arg2->expr);
gcc_assert (se->loop->dimen == 1);
- gcc_assert (se->ss->expr == expr);
+ gcc_assert (se->ss->info->expr == expr);
gfc_advance_se_ss_chain (se);
bound = se->loop->loopvar[0];
bound = fold_build2_loc (input_location, MINUS_EXPR,
gcc_assert (arg->expr->expr_type == EXPR_VARIABLE);
corank = gfc_get_corank (arg->expr);
- ss = gfc_walk_expr (arg->expr);
+ ss = walk_coarray (arg->expr);
gcc_assert (ss != gfc_ss_terminator);
- ss->data.info.codimen = corank;
gfc_init_se (&argse, NULL);
+ argse.want_coarray = 1;
gfc_conv_expr_descriptor (&argse, arg->expr, ss);
gfc_add_block_to_block (&se->pre, &argse.pre);
gcc_assert (!arg2->expr);
gcc_assert (corank > 0);
gcc_assert (se->loop->dimen == 1);
- gcc_assert (se->ss->expr == expr);
+ gcc_assert (se->ss->info->expr == expr);
bound = se->loop->loopvar[0];
bound = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
{
tree cosize;
- gfc_init_coarray_decl ();
+ gfc_init_coarray_decl (false);
cosize = gfc_conv_descriptor_cosize (desc, arg->expr->rank, corank);
tmp = fold_build2_loc (input_location, MINUS_EXPR,
else if (gfc_option.coarray != GFC_FCOARRAY_SINGLE)
{
/* ubound = lbound + num_images() - 1. */
- gfc_init_coarray_decl ();
+ gfc_init_coarray_decl (false);
tmp = fold_build2_loc (input_location, MINUS_EXPR,
gfc_array_index_type,
gfort_gvar_caf_num_images,
if (FLOAT_TYPE_P (TREE_TYPE (mvar)))
{
isnan = build_call_expr_loc (input_location,
- built_in_decls[BUILT_IN_ISNAN], 1, mvar);
+ builtin_decl_explicit (BUILT_IN_ISNAN),
+ 1, mvar);
tmp = fold_build2_loc (input_location, TRUTH_OR_EXPR,
boolean_type_node, tmp,
fold_convert (boolean_type_node, isnan));
gfc_symbol *sym;
VEC(tree,gc) *append_args;
- gcc_assert (!se->ss || se->ss->expr == expr);
+ gcc_assert (!se->ss || se->ss->info->expr == expr);
if (se->ss)
gcc_assert (expr->rank > 0);
TREE_USED (lab2) = 1;
}
+ /* An offset must be added to the loop
+ counter to obtain the required position. */
+ gcc_assert (loop.from[0]);
+
+ tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
+ gfc_index_one_node, loop.from[0]);
+ gfc_add_modify (&loop.pre, offset, tmp);
+
gfc_mark_ss_chain_used (arrayss, 1);
if (maskss)
gfc_mark_ss_chain_used (maskss, 1);
/* Assign the value to the limit... */
gfc_add_modify (&ifblock, limit, arrayse.expr);
- /* Remember where we are. An offset must be added to the loop
- counter to obtain the required position. */
- if (loop.from[0])
- tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
- gfc_index_one_node, loop.from[0]);
- else
- tmp = gfc_index_one_node;
-
- gfc_add_modify (&block, offset, tmp);
-
if (nonempty == NULL && HONOR_NANS (DECL_MODE (limit)))
{
stmtblock_t ifblock2;
/* Assign the value to the limit... */
gfc_add_modify (&ifblock, limit, arrayse.expr);
- /* Remember where we are. An offset must be added to the loop
- counter to obtain the required position. */
- if (loop.from[0])
- tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
- gfc_index_one_node, loop.from[0]);
- else
- tmp = gfc_index_one_node;
-
- gfc_add_modify (&block, offset, tmp);
-
tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (pos),
loop.loopvar[0], offset);
gfc_add_modify (&ifblock, pos, tmp);
if (argsize <= INT_TYPE_SIZE)
{
arg_type = unsigned_type_node;
- func = built_in_decls[BUILT_IN_CLZ];
+ func = builtin_decl_explicit (BUILT_IN_CLZ);
}
else if (argsize <= LONG_TYPE_SIZE)
{
arg_type = long_unsigned_type_node;
- func = built_in_decls[BUILT_IN_CLZL];
+ func = builtin_decl_explicit (BUILT_IN_CLZL);
}
else if (argsize <= LONG_LONG_TYPE_SIZE)
{
arg_type = long_long_unsigned_type_node;
- func = built_in_decls[BUILT_IN_CLZLL];
+ func = builtin_decl_explicit (BUILT_IN_CLZLL);
}
else
{
where ULL_MAX is the largest value that a ULL_MAX can hold
(0xFFFFFFFFFFFFFFFF for a 64-bit long long type), and ULLSIZE
is the bit-size of the long long type (64 in this example). */
- tree ullsize, ullmax, tmp1, tmp2;
+ tree ullsize, ullmax, tmp1, tmp2, btmp;
ullsize = build_int_cst (result_type, LONG_LONG_TYPE_SIZE);
ullmax = fold_build1_loc (input_location, BIT_NOT_EXPR,
tmp1 = fold_build2_loc (input_location, RSHIFT_EXPR, arg_type,
arg, ullsize);
tmp1 = fold_convert (long_long_unsigned_type_node, tmp1);
+ btmp = builtin_decl_explicit (BUILT_IN_CLZLL);
tmp1 = fold_convert (result_type,
- build_call_expr_loc (input_location,
- built_in_decls[BUILT_IN_CLZLL],
- 1, tmp1));
+ build_call_expr_loc (input_location, btmp, 1, tmp1));
tmp2 = fold_convert (long_long_unsigned_type_node, arg);
+ btmp = builtin_decl_explicit (BUILT_IN_CLZLL);
tmp2 = fold_convert (result_type,
- build_call_expr_loc (input_location,
- built_in_decls[BUILT_IN_CLZLL],
- 1, tmp2));
+ build_call_expr_loc (input_location, btmp, 1, tmp2));
tmp2 = fold_build2_loc (input_location, PLUS_EXPR, result_type,
tmp2, ullsize);
if (argsize <= INT_TYPE_SIZE)
{
arg_type = unsigned_type_node;
- func = built_in_decls[BUILT_IN_CTZ];
+ func = builtin_decl_explicit (BUILT_IN_CTZ);
}
else if (argsize <= LONG_TYPE_SIZE)
{
arg_type = long_unsigned_type_node;
- func = built_in_decls[BUILT_IN_CTZL];
+ func = builtin_decl_explicit (BUILT_IN_CTZL);
}
else if (argsize <= LONG_LONG_TYPE_SIZE)
{
arg_type = long_long_unsigned_type_node;
- func = built_in_decls[BUILT_IN_CTZLL];
+ func = builtin_decl_explicit (BUILT_IN_CTZLL);
}
else
{
where ULL_MAX is the largest value that a ULL_MAX can hold
(0xFFFFFFFFFFFFFFFF for a 64-bit long long type), and ULLSIZE
is the bit-size of the long long type (64 in this example). */
- tree ullsize, ullmax, tmp1, tmp2;
+ tree ullsize, ullmax, tmp1, tmp2, btmp;
ullsize = build_int_cst (result_type, LONG_LONG_TYPE_SIZE);
ullmax = fold_build1_loc (input_location, BIT_NOT_EXPR,
tmp1 = fold_build2_loc (input_location, RSHIFT_EXPR, arg_type,
arg, ullsize);
tmp1 = fold_convert (long_long_unsigned_type_node, tmp1);
+ btmp = builtin_decl_explicit (BUILT_IN_CTZLL);
tmp1 = fold_convert (result_type,
- build_call_expr_loc (input_location,
- built_in_decls[BUILT_IN_CTZLL],
- 1, tmp1));
+ build_call_expr_loc (input_location, btmp, 1, tmp1));
tmp1 = fold_build2_loc (input_location, PLUS_EXPR, result_type,
tmp1, ullsize);
tmp2 = fold_convert (long_long_unsigned_type_node, arg);
+ btmp = builtin_decl_explicit (BUILT_IN_CTZLL);
tmp2 = fold_convert (result_type,
- build_call_expr_loc (input_location,
- built_in_decls[BUILT_IN_CTZLL],
- 1, tmp2));
+ build_call_expr_loc (input_location, btmp, 1, tmp2));
trailz = fold_build3_loc (input_location, COND_EXPR, result_type,
cond, tmp1, tmp2);
if (argsize <= INT_TYPE_SIZE)
{
arg_type = unsigned_type_node;
- func = built_in_decls[parity ? BUILT_IN_PARITY : BUILT_IN_POPCOUNT];
+ func = builtin_decl_explicit (parity
+ ? BUILT_IN_PARITY
+ : BUILT_IN_POPCOUNT);
}
else if (argsize <= LONG_TYPE_SIZE)
{
arg_type = long_unsigned_type_node;
- func = built_in_decls[parity ? BUILT_IN_PARITYL : BUILT_IN_POPCOUNTL];
+ func = builtin_decl_explicit (parity
+ ? BUILT_IN_PARITYL
+ : BUILT_IN_POPCOUNTL);
}
else if (argsize <= LONG_LONG_TYPE_SIZE)
{
arg_type = long_long_unsigned_type_node;
- func = built_in_decls[parity ? BUILT_IN_PARITYLL : BUILT_IN_POPCOUNTLL];
+ func = builtin_decl_explicit (parity
+ ? BUILT_IN_PARITYLL
+ : BUILT_IN_POPCOUNTLL);
}
else
{
as 'long long'. */
gcc_assert (argsize == 2 * LONG_LONG_TYPE_SIZE);
- func = built_in_decls[parity ? BUILT_IN_PARITYLL : BUILT_IN_POPCOUNTLL];
+ func = builtin_decl_explicit (parity
+ ? BUILT_IN_PARITYLL
+ : BUILT_IN_POPCOUNTLL);
/* Convert it to an integer, and store into a variable. */
utype = gfc_build_uint_type (argsize);
gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
se->expr = build_call_expr_loc (input_location,
- built_in_decls[BUILT_IN_ISNAN], 1, arg);
+ builtin_decl_explicit (BUILT_IN_ISNAN),
+ 1, arg);
STRIP_TYPE_NOPS (se->expr);
se->expr = fold_convert (gfc_typenode_for_spec (&expr->ts), se->expr);
}
gfc_actual_arglist *arg;
gfc_se argse;
gfc_ss *ss;
- gfc_ss_info *info;
+ gfc_array_info *info;
stmtblock_t block;
int n;
bool scalar_mold;
info = NULL;
if (se->loop)
- info = &se->ss->data.info;
+ info = &se->ss->info->data.array;
/* Convert SOURCE. The output from this stage is:-
source_bytes = length of the source in bytes
/* Build a destination descriptor, using the pointer, source, as the
data field. */
- gfc_trans_create_temp_array (&se->pre, &se->post, se->loop,
- info, mold_type, NULL_TREE, false, true, false,
- &expr->where);
+ gfc_trans_create_temp_array (&se->pre, &se->post, se->ss, mold_type,
+ NULL_TREE, false, true, false, &expr->where);
/* Cast the pointer to the result. */
tmp = gfc_conv_descriptor_data_get (info->descriptor);
/* Use memcpy to do the transfer. */
tmp = build_call_expr_loc (input_location,
- built_in_decls[BUILT_IN_MEMCPY],
+ builtin_decl_explicit (BUILT_IN_MEMCPY),
3,
tmp,
fold_convert (pvoid_type_node, source),
gfc_add_modify (&block, tmpdecl,
fold_convert (TREE_TYPE (ptr), tmp));
tmp = build_call_expr_loc (input_location,
- built_in_decls[BUILT_IN_MEMCPY], 3,
+ builtin_decl_explicit (BUILT_IN_MEMCPY), 3,
fold_convert (pvoid_type_node, tmpdecl),
fold_convert (pvoid_type_node, ptr),
extent);
/* Use memcpy to do the transfer. */
tmp = gfc_build_addr_expr (NULL_TREE, tmpdecl);
tmp = build_call_expr_loc (input_location,
- built_in_decls[BUILT_IN_MEMCPY], 3,
+ builtin_decl_explicit (BUILT_IN_MEMCPY), 3,
fold_convert (pvoid_type_node, tmp),
fold_convert (pvoid_type_node, ptr),
extent);
fold_convert (gfc_charlen_type_node, count));
tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_charlen_type_node,
tmp, fold_convert (gfc_charlen_type_node, size));
- tmp = fold_build2_loc (input_location, POINTER_PLUS_EXPR, pvoid_type_node,
- fold_convert (pvoid_type_node, dest),
- fold_convert (sizetype, tmp));
+ tmp = fold_build_pointer_plus_loc (input_location,
+ fold_convert (pvoid_type_node, dest), tmp);
tmp = build_call_expr_loc (input_location,
- built_in_decls[BUILT_IN_MEMMOVE], 3, tmp, src,
+ builtin_decl_explicit (BUILT_IN_MEMMOVE),
+ 3, tmp, src,
fold_build2_loc (input_location, MULT_EXPR,
size_type_node, slen,
fold_convert (size_type_node,
break;
case GFC_ISYM_TRANSFER:
- if (se->ss && se->ss->useflags)
+ if (se->ss && se->ss->info->useflags)
/* Access the previously obtained result. */
gfc_conv_tmp_array_ref (se);
else
for (tmp_ss = arg_ss; ; tmp_ss = tmp_ss->next)
{
- if (tmp_ss->type != GFC_SS_SCALAR
- && tmp_ss->type != GFC_SS_REFERENCE)
+ if (tmp_ss->info->type != GFC_SS_SCALAR
+ && tmp_ss->info->type != GFC_SS_REFERENCE)
{
int tmp_dim;
- gfc_ss_info *info;
- info = &tmp_ss->data.info;
- gcc_assert (info->dimen == 2);
+ gcc_assert (tmp_ss->dimen == 2);
/* We just invert dimensions. */
- tmp_dim = info->dim[0];
- info->dim[0] = info->dim[1];
- info->dim[1] = tmp_dim;
+ tmp_dim = tmp_ss->dim[0];
+ tmp_ss->dim[0] = tmp_ss->dim[1];
+ tmp_ss->dim[1] = tmp_dim;
}
/* Stop when tmp_ss points to the last valid element of the chain... */
void
gfc_add_intrinsic_ss_code (gfc_loopinfo * loop ATTRIBUTE_UNUSED, gfc_ss * ss)
{
- switch (ss->expr->value.function.isym->id)
+ switch (ss->info->expr->value.function.isym->id)
{
case GFC_ISYM_UBOUND:
case GFC_ISYM_LBOUND:
static gfc_ss *
gfc_walk_intrinsic_bound (gfc_ss * ss, gfc_expr * expr)
{
- gfc_ss *newss;
-
/* The two argument version returns a scalar. */
if (expr->value.function.actual->next->expr)
return ss;
- newss = gfc_get_ss ();
- newss->type = GFC_SS_INTRINSIC;
- newss->expr = expr;
- newss->next = ss;
- newss->data.info.dimen = 1;
-
- return newss;
+ return gfc_get_array_ss (ss, expr, 1, GFC_SS_INTRINSIC);
}
static gfc_ss *
gfc_walk_intrinsic_libfunc (gfc_ss * ss, gfc_expr * expr)
{
- gfc_ss *newss;
- int n;
-
gcc_assert (expr->rank > 0);
-
- newss = gfc_get_ss ();
- newss->type = GFC_SS_FUNCTION;
- newss->expr = expr;
- newss->next = ss;
- newss->data.info.dimen = expr->rank;
- for (n = 0; n < newss->data.info.dimen; n++)
- newss->data.info.dim[n] = n;
-
- return newss;
+ return gfc_get_array_ss (ss, expr, expr->rank, GFC_SS_FUNCTION);
}
}
-tree
-gfc_conv_intrinsic_move_alloc (gfc_code *code)
+static tree
+conv_intrinsic_atomic_def (gfc_code *code)
+{
+ gfc_se atom, value;
+ stmtblock_t block;
+
+ gfc_init_se (&atom, NULL);
+ gfc_init_se (&value, NULL);
+ gfc_conv_expr (&atom, code->ext.actual->expr);
+ gfc_conv_expr (&value, code->ext.actual->next->expr);
+
+ gfc_init_block (&block);
+ gfc_add_modify (&block, atom.expr,
+ fold_convert (TREE_TYPE (atom.expr), value.expr));
+ return gfc_finish_block (&block);
+}
+
+
+static tree
+conv_intrinsic_atomic_ref (gfc_code *code)
+{
+ gfc_se atom, value;
+ stmtblock_t block;
+
+ gfc_init_se (&atom, NULL);
+ gfc_init_se (&value, NULL);
+ gfc_conv_expr (&value, code->ext.actual->expr);
+ gfc_conv_expr (&atom, code->ext.actual->next->expr);
+
+ gfc_init_block (&block);
+ gfc_add_modify (&block, value.expr,
+ fold_convert (TREE_TYPE (value.expr), atom.expr));
+ return gfc_finish_block (&block);
+}
+
+
+static tree
+conv_intrinsic_move_alloc (gfc_code *code)
{
if (code->ext.actual->expr->rank == 0)
{
/* Scalar arguments: Generate pointer assignments. */
- gfc_expr *from, *to;
+ gfc_expr *from, *to, *deal;
stmtblock_t block;
tree tmp;
+ gfc_se se;
from = code->ext.actual->expr;
to = code->ext.actual->next->expr;
gfc_start_block (&block);
+ /* Deallocate 'TO' argument. */
+ gfc_init_se (&se, NULL);
+ se.want_pointer = 1;
+ deal = gfc_copy_expr (to);
+ if (deal->ts.type == BT_CLASS)
+ gfc_add_data_component (deal);
+ gfc_conv_expr (&se, deal);
+ tmp = gfc_deallocate_scalar_with_status (se.expr, NULL, true,
+ deal, deal->ts);
+ gfc_add_expr_to_block (&block, tmp);
+ gfc_free_expr (deal);
+
if (to->ts.type == BT_CLASS)
tmp = gfc_trans_class_assign (to, from, EXEC_POINTER_ASSIGN);
else
}
+tree
+gfc_conv_intrinsic_subroutine (gfc_code *code)
+{
+ tree res;
+
+ gcc_assert (code->resolved_isym);
+
+ switch (code->resolved_isym->id)
+ {
+ case GFC_ISYM_MOVE_ALLOC:
+ res = conv_intrinsic_move_alloc (code);
+ break;
+
+ case GFC_ISYM_ATOMIC_DEF:
+ res = conv_intrinsic_atomic_def (code);
+ break;
+
+ case GFC_ISYM_ATOMIC_REF:
+ res = conv_intrinsic_atomic_ref (code);
+ break;
+
+ default:
+ res = NULL_TREE;
+ break;
+ }
+
+ return res;
+}
+
#include "gt-fortran-trans-intrinsic.h"