/* Intrinsic translation
- Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
+ Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
Free Software Foundation, Inc.
Contributed by Paul Brook <paul@nowt.org>
and Steven Bosscher <s.bosscher@student.tudelft.nl>
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));
}
C99-like library functions. For now, we only handle __float128
q-suffixed functions. */
- tree tmp, func_0, func_1, func_2, func_cabs, func_frexp;
+ tree type, complex_type, func_1, func_2, func_cabs, func_frexp;
tree func_lround, func_llround, func_scalbn, func_cpow;
memset (quad_decls, 0, sizeof(tree) * (END_BUILTINS + 1));
- /* type (*) (void) */
- func_0 = build_function_type (float128_type_node, void_list_node);
+ type = float128_type_node;
+ complex_type = complex_float128_type_node;
/* type (*) (type) */
- tmp = tree_cons (NULL_TREE, float128_type_node, void_list_node);
- func_1 = build_function_type (float128_type_node, tmp);
+ func_1 = build_function_type_list (type, type, NULL_TREE);
/* long (*) (type) */
- func_lround = build_function_type (long_integer_type_node, tmp);
+ func_lround = build_function_type_list (long_integer_type_node,
+ type, NULL_TREE);
/* long long (*) (type) */
- func_llround = build_function_type (long_long_integer_type_node, tmp);
+ func_llround = build_function_type_list (long_long_integer_type_node,
+ type, NULL_TREE);
/* type (*) (type, type) */
- tmp = tree_cons (NULL_TREE, float128_type_node, tmp);
- func_2 = build_function_type (float128_type_node, tmp);
+ func_2 = build_function_type_list (type, type, type, NULL_TREE);
/* type (*) (type, &int) */
- tmp = tree_cons (NULL_TREE, float128_type_node, void_list_node);
- tmp = tree_cons (NULL_TREE, build_pointer_type (integer_type_node), tmp);
- func_frexp = build_function_type (float128_type_node, tmp);
+ func_frexp
+ = build_function_type_list (type,
+ type,
+ build_pointer_type (integer_type_node),
+ NULL_TREE);
/* type (*) (type, int) */
- tmp = tree_cons (NULL_TREE, float128_type_node, void_list_node);
- tmp = tree_cons (NULL_TREE, integer_type_node, tmp);
- func_scalbn = build_function_type (float128_type_node, tmp);
+ func_scalbn = build_function_type_list (type,
+ type, integer_type_node, NULL_TREE);
/* type (*) (complex type) */
- tmp = tree_cons (NULL_TREE, complex_float128_type_node, void_list_node);
- func_cabs = build_function_type (float128_type_node, tmp);
+ func_cabs = build_function_type_list (type, complex_type, NULL_TREE);
/* complex type (*) (complex type, complex type) */
- tmp = tree_cons (NULL_TREE, complex_float128_type_node, tmp);
- func_cpow = build_function_type (complex_float128_type_node, tmp);
+ func_cpow
+ = build_function_type_list (complex_type,
+ complex_type, complex_type, NULL_TREE);
#define DEFINE_MATH_BUILTIN(ID, NAME, ARGTYPE)
#define DEFINE_MATH_BUILTIN_C(ID, NAME, ARGTYPE)
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);
se->expr = fold_convert (type, res);
}
+
+/* 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)
+{
+ stmtblock_t loop;
+ tree type, desc, dim_arg, cond, tmp, m, loop_var, exit_label, min_var,
+ lbound, ubound, extent, ml;
+ gfc_se argse;
+ gfc_ss *ss;
+ int rank, corank;
+
+ /* The case -fcoarray=single is handled elsewhere. */
+ gcc_assert (gfc_option.coarray != GFC_FCOARRAY_SINGLE);
+
+ gfc_init_coarray_decl (false);
+
+ /* Argument-free version: THIS_IMAGE(). */
+ if (expr->value.function.actual->expr == NULL)
+ {
+ se->expr = gfort_gvar_caf_this_image;
+ return;
+ }
+
+ /* Coarray-argument version: THIS_IMAGE(coarray [, dim]). */
+
+ type = gfc_get_int_type (gfc_default_integer_kind);
+ corank = gfc_get_corank (expr->value.function.actual->expr);
+ rank = expr->value.function.actual->expr->rank;
+
+ /* Obtain the descriptor of the COARRAY. */
+ gfc_init_se (&argse, NULL);
+ ss = walk_coarray (expr->value.function.actual->expr);
+ gcc_assert (ss != gfc_ss_terminator);
+ 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);
+ desc = argse.expr;
+
+ if (se->ss)
+ {
+ /* Create an implicit second parameter from the loop variable. */
+ gcc_assert (!expr->value.function.actual->next->expr);
+ gcc_assert (corank > 0);
+ gcc_assert (se->loop->dimen == 1);
+ 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,
+ build_int_cst (TREE_TYPE (dim_arg), 1));
+ gfc_advance_se_ss_chain (se);
+ }
+ else
+ {
+ /* Use the passed DIM= argument. */
+ gcc_assert (expr->value.function.actual->next->expr);
+ gfc_init_se (&argse, NULL);
+ gfc_conv_expr_type (&argse, expr->value.function.actual->next->expr,
+ gfc_array_index_type);
+ gfc_add_block_to_block (&se->pre, &argse.pre);
+ dim_arg = argse.expr;
+
+ if (INTEGER_CST_P (dim_arg))
+ {
+ int hi, co_dim;
+
+ hi = TREE_INT_CST_HIGH (dim_arg);
+ co_dim = TREE_INT_CST_LOW (dim_arg);
+ if (hi || co_dim < 1
+ || co_dim > GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc)))
+ gfc_error ("'dim' argument of %s intrinsic at %L is not a valid "
+ "dimension index", expr->value.function.isym->name,
+ &expr->where);
+ }
+ else if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
+ {
+ dim_arg = gfc_evaluate_now (dim_arg, &se->pre);
+ cond = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
+ dim_arg,
+ build_int_cst (TREE_TYPE (dim_arg), 1));
+ tmp = gfc_rank_cst[GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc))];
+ tmp = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
+ dim_arg, tmp);
+ cond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
+ boolean_type_node, cond, tmp);
+ gfc_trans_runtime_check (true, false, cond, &se->pre, &expr->where,
+ gfc_msg_fault);
+ }
+ }
+
+ /* Used algorithm; cf. Fortran 2008, C.10. Note, due to the scalarizer,
+ one always has a dim_arg argument.
+
+ m = this_images() - 1
+ i = rank
+ min_var = min (rank + corank - 2, rank + dim_arg - 1)
+ for (;;)
+ {
+ extent = gfc_extent(i)
+ ml = m
+ m = m/extent
+ if (i >= min_var)
+ goto exit_label
+ i++
+ }
+ exit_label:
+ sub(dim_arg) = (dim_arg < corank) ? ml - m*extent + lcobound(dim_arg)
+ : m + lcobound(corank)
+ */
+
+ m = gfc_create_var (type, NULL);
+ ml = gfc_create_var (type, NULL);
+ loop_var = gfc_create_var (integer_type_node, NULL);
+ min_var = gfc_create_var (integer_type_node, NULL);
+
+ /* m = this_image () - 1. */
+ tmp = fold_convert (type, gfort_gvar_caf_this_image);
+ tmp = fold_build2_loc (input_location, MINUS_EXPR, type, tmp,
+ build_int_cst (type, 1));
+ gfc_add_modify (&se->pre, m, tmp);
+
+ /* 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),
+ tmp);
+ gfc_add_modify (&se->pre, min_var, tmp);
+
+ /* i = rank. */
+ tmp = build_int_cst (integer_type_node, rank);
+ gfc_add_modify (&se->pre, loop_var, tmp);
+
+ exit_label = gfc_build_label_decl (NULL_TREE);
+ TREE_USED (exit_label) = 1;
+
+ /* Loop body. */
+ gfc_init_block (&loop);
+
+ /* ml = m. */
+ gfc_add_modify (&loop, ml, m);
+
+ /* extent = ... */
+ lbound = gfc_conv_descriptor_lbound_get (desc, loop_var);
+ ubound = gfc_conv_descriptor_ubound_get (desc, loop_var);
+ extent = gfc_conv_array_extent_dim (lbound, ubound, NULL);
+ extent = fold_convert (type, extent);
+
+ /* m = m/extent. */
+ gfc_add_modify (&loop, m,
+ fold_build2_loc (input_location, TRUNC_DIV_EXPR, type,
+ m, extent));
+
+ /* Exit condition: if (i >= min_var) goto exit_label. */
+ cond = fold_build2_loc (input_location, GE_EXPR, boolean_type_node, loop_var,
+ min_var);
+ tmp = build1_v (GOTO_EXPR, exit_label);
+ tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, tmp,
+ build_empty_stmt (input_location));
+ gfc_add_expr_to_block (&loop, tmp);
+
+ /* Increment loop variable: i++. */
+ gfc_add_modify (&loop, loop_var,
+ fold_build2_loc (input_location, PLUS_EXPR, integer_type_node,
+ loop_var,
+ build_int_cst (integer_type_node, 1)));
+
+ /* Making the loop... actually loop! */
+ tmp = gfc_finish_block (&loop);
+ tmp = build1_v (LOOP_EXPR, tmp);
+ gfc_add_expr_to_block (&se->pre, tmp);
+
+ /* The exit label. */
+ tmp = build1_v (LABEL_EXPR, exit_label);
+ gfc_add_expr_to_block (&se->pre, tmp);
+
+ /* sub(co_dim) = (co_dim < corank) ? ml - m*extent + lcobound(dim_arg)
+ : m + lcobound(corank) */
+
+ cond = fold_build2_loc (input_location, LT_EXPR, boolean_type_node, dim_arg,
+ 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,
+ build_int_cst (TREE_TYPE (dim_arg), rank-1)));
+ lbound = fold_convert (type, lbound);
+
+ tmp = fold_build2_loc (input_location, MINUS_EXPR, type, ml,
+ fold_build2_loc (input_location, MULT_EXPR, type,
+ m, extent));
+ tmp = fold_build2_loc (input_location, PLUS_EXPR, type, tmp, lbound);
+
+ se->expr = fold_build3_loc (input_location, COND_EXPR, type, cond, tmp,
+ fold_build2_loc (input_location, PLUS_EXPR, type,
+ m, lbound));
+}
+
+
+static void
+trans_image_index (gfc_se * se, gfc_expr *expr)
+{
+ tree num_images, cond, coindex, type, lbound, ubound, desc, subdesc,
+ tmp, invalid_bound;
+ gfc_se argse, subse;
+ gfc_ss *ss, *subss;
+ int rank, corank, codim;
+
+ type = gfc_get_int_type (gfc_default_integer_kind);
+ corank = gfc_get_corank (expr->value.function.actual->expr);
+ rank = expr->value.function.actual->expr->rank;
+
+ /* Obtain the descriptor of the COARRAY. */
+ gfc_init_se (&argse, NULL);
+ ss = walk_coarray (expr->value.function.actual->expr);
+ gcc_assert (ss != gfc_ss_terminator);
+ 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);
+ desc = argse.expr;
+
+ /* Obtain a handle to the SUB argument. */
+ gfc_init_se (&subse, NULL);
+ subss = gfc_walk_expr (expr->value.function.actual->next->expr);
+ gcc_assert (subss != gfc_ss_terminator);
+ gfc_conv_expr_descriptor (&subse, expr->value.function.actual->next->expr,
+ subss);
+ gfc_add_block_to_block (&se->pre, &subse.pre);
+ gfc_add_block_to_block (&se->post, &subse.post);
+ subdesc = build_fold_indirect_ref_loc (input_location,
+ gfc_conv_descriptor_data_get (subse.expr));
+
+ /* Fortran 2008 does not require that the values remain in the cobounds,
+ thus we need explicitly check this - and return 0 if they are exceeded. */
+
+ lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[rank+corank-1]);
+ tmp = gfc_build_array_ref (subdesc, gfc_rank_cst[corank-1], NULL);
+ invalid_bound = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
+ fold_convert (gfc_array_index_type, tmp),
+ lbound);
+
+ for (codim = corank + rank - 2; codim >= rank; codim--)
+ {
+ lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[codim]);
+ ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[codim]);
+ tmp = gfc_build_array_ref (subdesc, gfc_rank_cst[codim-rank], NULL);
+ cond = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
+ fold_convert (gfc_array_index_type, tmp),
+ lbound);
+ invalid_bound = fold_build2_loc (input_location, TRUTH_OR_EXPR,
+ boolean_type_node, invalid_bound, cond);
+ cond = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
+ fold_convert (gfc_array_index_type, tmp),
+ ubound);
+ invalid_bound = fold_build2_loc (input_location, TRUTH_OR_EXPR,
+ boolean_type_node, invalid_bound, cond);
+ }
+
+ invalid_bound = gfc_unlikely (invalid_bound);
+
+
+ /* See Fortran 2008, C.10 for the following algorithm. */
+
+ /* coindex = sub(corank) - lcobound(n). */
+ coindex = fold_convert (gfc_array_index_type,
+ gfc_build_array_ref (subdesc, gfc_rank_cst[corank-1],
+ NULL));
+ lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[rank+corank-1]);
+ coindex = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
+ fold_convert (gfc_array_index_type, coindex),
+ lbound);
+
+ for (codim = corank + rank - 2; codim >= rank; codim--)
+ {
+ tree extent, ubound;
+
+ /* coindex = coindex*extent(codim) + sub(codim) - lcobound(codim). */
+ lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[codim]);
+ ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[codim]);
+ extent = gfc_conv_array_extent_dim (lbound, ubound, NULL);
+
+ /* coindex *= extent. */
+ coindex = fold_build2_loc (input_location, MULT_EXPR,
+ gfc_array_index_type, coindex, extent);
+
+ /* coindex += sub(codim). */
+ tmp = gfc_build_array_ref (subdesc, gfc_rank_cst[codim-rank], NULL);
+ coindex = fold_build2_loc (input_location, PLUS_EXPR,
+ gfc_array_index_type, coindex,
+ fold_convert (gfc_array_index_type, tmp));
+
+ /* coindex -= lbound(codim). */
+ lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[codim]);
+ coindex = fold_build2_loc (input_location, MINUS_EXPR,
+ gfc_array_index_type, coindex, lbound);
+ }
+
+ coindex = fold_build2_loc (input_location, PLUS_EXPR, type,
+ fold_convert(type, coindex),
+ build_int_cst (type, 1));
+
+ /* Return 0 if "coindex" exceeds num_images(). */
+
+ if (gfc_option.coarray == GFC_FCOARRAY_SINGLE)
+ num_images = build_int_cst (type, 1);
+ else
+ {
+ gfc_init_coarray_decl (false);
+ num_images = gfort_gvar_caf_num_images;
+ }
+
+ tmp = gfc_create_var (type, NULL);
+ gfc_add_modify (&se->pre, tmp, coindex);
+
+ cond = fold_build2_loc (input_location, GT_EXPR, boolean_type_node, tmp,
+ num_images);
+ cond = fold_build2_loc (input_location, TRUTH_OR_EXPR, boolean_type_node,
+ cond,
+ fold_convert (boolean_type_node, invalid_bound));
+ se->expr = fold_build3_loc (input_location, COND_EXPR, type, cond,
+ build_int_cst (type, 0), tmp);
+}
+
+
+static void
+trans_num_images (gfc_se * se)
+{
+ gfc_init_coarray_decl (false);
+ se->expr = gfort_gvar_caf_num_images;
+}
+
+
/* Evaluate a single upper or lower bound. */
/* TODO: bound intrinsic generates way too much unnecessary code. */
/* 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,
else
{
/* use the passed argument. */
- gcc_assert (arg->next->expr);
+ gcc_assert (arg2->expr);
gfc_init_se (&argse, NULL);
- gfc_conv_expr_type (&argse, arg->next->expr, gfc_array_index_type);
+ gfc_conv_expr_type (&argse, arg2->expr, gfc_array_index_type);
gfc_add_block_to_block (&se->pre, &argse.pre);
bound = argse.expr;
/* Convert from one based to zero based. */
static void
+conv_intrinsic_cobound (gfc_se * se, gfc_expr * expr)
+{
+ gfc_actual_arglist *arg;
+ gfc_actual_arglist *arg2;
+ gfc_se argse;
+ gfc_ss *ss;
+ tree bound, resbound, resbound2, desc, cond, tmp;
+ tree type;
+ int corank;
+
+ gcc_assert (expr->value.function.isym->id == GFC_ISYM_LCOBOUND
+ || expr->value.function.isym->id == GFC_ISYM_UCOBOUND
+ || expr->value.function.isym->id == GFC_ISYM_THIS_IMAGE);
+
+ arg = expr->value.function.actual;
+ arg2 = arg->next;
+
+ gcc_assert (arg->expr->expr_type == EXPR_VARIABLE);
+ corank = gfc_get_corank (arg->expr);
+
+ ss = walk_coarray (arg->expr);
+ gcc_assert (ss != gfc_ss_terminator);
+ 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);
+ gfc_add_block_to_block (&se->post, &argse.post);
+ desc = argse.expr;
+
+ if (se->ss)
+ {
+ /* Create an implicit second parameter from the loop variable. */
+ gcc_assert (!arg2->expr);
+ gcc_assert (corank > 0);
+ gcc_assert (se->loop->dimen == 1);
+ gcc_assert (se->ss->info->expr == expr);
+
+ bound = se->loop->loopvar[0];
+ bound = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
+ bound, gfc_rank_cst[arg->expr->rank]);
+ gfc_advance_se_ss_chain (se);
+ }
+ else
+ {
+ /* use the passed argument. */
+ gcc_assert (arg2->expr);
+ gfc_init_se (&argse, NULL);
+ gfc_conv_expr_type (&argse, arg2->expr, gfc_array_index_type);
+ gfc_add_block_to_block (&se->pre, &argse.pre);
+ bound = argse.expr;
+
+ if (INTEGER_CST_P (bound))
+ {
+ int hi, low;
+
+ hi = TREE_INT_CST_HIGH (bound);
+ low = TREE_INT_CST_LOW (bound);
+ if (hi || low < 1 || low > GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc)))
+ gfc_error ("'dim' argument of %s intrinsic at %L is not a valid "
+ "dimension index", expr->value.function.isym->name,
+ &expr->where);
+ }
+ else if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
+ {
+ bound = gfc_evaluate_now (bound, &se->pre);
+ cond = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
+ bound, build_int_cst (TREE_TYPE (bound), 1));
+ tmp = gfc_rank_cst[GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc))];
+ tmp = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
+ bound, tmp);
+ cond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
+ boolean_type_node, cond, tmp);
+ gfc_trans_runtime_check (true, false, cond, &se->pre, &expr->where,
+ gfc_msg_fault);
+ }
+
+
+ /* Substract 1 to get to zero based and add dimensions. */
+ switch (arg->expr->rank)
+ {
+ case 0:
+ bound = fold_build2_loc (input_location, MINUS_EXPR,
+ gfc_array_index_type, bound,
+ gfc_index_one_node);
+ case 1:
+ break;
+ default:
+ bound = fold_build2_loc (input_location, PLUS_EXPR,
+ gfc_array_index_type, bound,
+ gfc_rank_cst[arg->expr->rank - 1]);
+ }
+ }
+
+ resbound = gfc_conv_descriptor_lbound_get (desc, bound);
+
+ /* Handle UCOBOUND with special handling of the last codimension. */
+ if (expr->value.function.isym->id == GFC_ISYM_UCOBOUND)
+ {
+ /* Last codimension: For -fcoarray=single just return
+ the lcobound - otherwise add
+ ceiling (real (num_images ()) / real (size)) - 1
+ = (num_images () + size - 1) / size - 1
+ = (num_images - 1) / size(),
+ where size is the product of the extent of all but the last
+ codimension. */
+
+ if (gfc_option.coarray != GFC_FCOARRAY_SINGLE && corank > 1)
+ {
+ tree cosize;
+
+ gfc_init_coarray_decl (false);
+ cosize = gfc_conv_descriptor_cosize (desc, arg->expr->rank, corank);
+
+ tmp = fold_build2_loc (input_location, MINUS_EXPR,
+ gfc_array_index_type,
+ gfort_gvar_caf_num_images,
+ build_int_cst (gfc_array_index_type, 1));
+ tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
+ gfc_array_index_type, tmp,
+ fold_convert (gfc_array_index_type, cosize));
+ resbound = fold_build2_loc (input_location, PLUS_EXPR,
+ gfc_array_index_type, resbound, tmp);
+ }
+ else if (gfc_option.coarray != GFC_FCOARRAY_SINGLE)
+ {
+ /* ubound = lbound + num_images() - 1. */
+ gfc_init_coarray_decl (false);
+ tmp = fold_build2_loc (input_location, MINUS_EXPR,
+ gfc_array_index_type,
+ gfort_gvar_caf_num_images,
+ build_int_cst (gfc_array_index_type, 1));
+ resbound = fold_build2_loc (input_location, PLUS_EXPR,
+ gfc_array_index_type, resbound, tmp);
+ }
+
+ if (corank > 1)
+ {
+ cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
+ bound,
+ build_int_cst (TREE_TYPE (bound),
+ arg->expr->rank + corank - 1));
+
+ resbound2 = gfc_conv_descriptor_ubound_get (desc, bound);
+ se->expr = fold_build3_loc (input_location, COND_EXPR,
+ gfc_array_index_type, cond,
+ resbound, resbound2);
+ }
+ else
+ se->expr = resbound;
+ }
+ else
+ se->expr = resbound;
+
+ type = gfc_typenode_for_spec (&expr->ts);
+ se->expr = convert (type, se->expr);
+}
+
+
+static void
gfc_conv_intrinsic_abs (gfc_se * se, gfc_expr * expr)
{
tree arg, cabs;
}
}
+/* DSHIFTL(I,J,S) = (I << S) | (J >> (BITSIZE(J) - S))
+ DSHIFTR(I,J,S) = (I << (BITSIZE(I) - S)) | (J >> S)
+ where the right shifts are logical (i.e. 0's are shifted in).
+ Because SHIFT_EXPR's want shifts strictly smaller than the integral
+ type width, we have to special-case both S == 0 and S == BITSIZE(J):
+ DSHIFTL(I,J,0) = I
+ DSHIFTL(I,J,BITSIZE) = J
+ DSHIFTR(I,J,0) = J
+ DSHIFTR(I,J,BITSIZE) = I. */
+
+static void
+gfc_conv_intrinsic_dshift (gfc_se * se, gfc_expr * expr, bool dshiftl)
+{
+ tree type, utype, stype, arg1, arg2, shift, res, left, right;
+ tree args[3], cond, tmp;
+ int bitsize;
+
+ gfc_conv_intrinsic_function_args (se, expr, args, 3);
+
+ gcc_assert (TREE_TYPE (args[0]) == TREE_TYPE (args[1]));
+ type = TREE_TYPE (args[0]);
+ bitsize = TYPE_PRECISION (type);
+ utype = unsigned_type_for (type);
+ stype = TREE_TYPE (args[2]);
+
+ arg1 = gfc_evaluate_now (args[0], &se->pre);
+ arg2 = gfc_evaluate_now (args[1], &se->pre);
+ shift = gfc_evaluate_now (args[2], &se->pre);
+
+ /* The generic case. */
+ tmp = fold_build2_loc (input_location, MINUS_EXPR, stype,
+ build_int_cst (stype, bitsize), shift);
+ left = fold_build2_loc (input_location, LSHIFT_EXPR, type,
+ arg1, dshiftl ? shift : tmp);
+
+ right = fold_build2_loc (input_location, RSHIFT_EXPR, utype,
+ fold_convert (utype, arg2), dshiftl ? tmp : shift);
+ right = fold_convert (type, right);
+
+ res = fold_build2_loc (input_location, BIT_IOR_EXPR, type, left, right);
+
+ /* Special cases. */
+ cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, shift,
+ build_int_cst (stype, 0));
+ res = fold_build3_loc (input_location, COND_EXPR, type, cond,
+ dshiftl ? arg1 : arg2, res);
+
+ cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, shift,
+ build_int_cst (stype, bitsize));
+ res = fold_build3_loc (input_location, COND_EXPR, type, cond,
+ dshiftl ? arg2 : arg1, res);
+
+ se->expr = res;
+}
+
+
/* Positive difference DIM (x, y) = ((x - y) < 0) ? 0 : x - y. */
static void
arg[0] = fold_build1_loc (input_location, NOP_EXPR, type, arg[0]);
gfc_add_modify (&se->pre, var, arg[0]);
se->expr = gfc_build_addr_expr (build_pointer_type (type), var);
- se->string_length = integer_one_node;
+ se->string_length = build_int_cst (gfc_charlen_type_node, 1);
}
args = XALLOCAVEC (tree, num_args);
var = gfc_create_var (pchar_type_node, "pstr");
- len = gfc_create_var (gfc_get_int_type (8), "len");
+ len = gfc_create_var (gfc_charlen_type_node, "len");
gfc_conv_intrinsic_function_args (se, expr, &args[2], num_args - 2);
args[0] = gfc_build_addr_expr (NULL_TREE, var);
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));
args[0] = gfc_build_addr_expr (NULL_TREE, len);
var = gfc_create_var (gfc_get_pchar_type (expr->ts.kind), "pstr");
args[1] = gfc_build_addr_expr (ppvoid_type_node, var);
- args[2] = build_int_cst (NULL_TREE, op);
- args[3] = build_int_cst (NULL_TREE, nargs / 2);
+ args[2] = build_int_cst (integer_type_node, op);
+ args[3] = build_int_cst (integer_type_node, nargs / 2);
if (expr->ts.kind == 1)
function = gfor_fndecl_string_minmax;
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);
gfc_conv_procedure_call (se, sym, expr->value.function.actual, expr,
append_args);
- gfc_free (sym);
+ gfc_free_symbol (sym);
}
/* ANY and ALL intrinsics. ANY->op == NE_EXPR, ALL->op == EQ_EXPR.
}
limit = gfc_create_var (gfc_typenode_for_spec (&arrayexpr->ts), "limit");
- n = gfc_validate_kind (arrayexpr->ts.type, arrayexpr->ts.kind, false);
switch (arrayexpr->ts.type)
{
case BT_REAL:
- if (HONOR_INFINITIES (DECL_MODE (limit)))
- {
- REAL_VALUE_TYPE real;
- real_inf (&real);
- tmp = build_real (TREE_TYPE (limit), real);
- }
- else
- tmp = gfc_conv_mpfr_to_tree (gfc_real_kinds[n].huge,
- arrayexpr->ts.kind, 0);
+ tmp = gfc_build_inf_or_huge (TREE_TYPE (limit), arrayexpr->ts.kind);
break;
case BT_INTEGER:
+ n = gfc_validate_kind (arrayexpr->ts.type, arrayexpr->ts.kind, false);
tmp = gfc_conv_mpz_to_tree (gfc_integer_kinds[n].huge,
arrayexpr->ts.kind);
break;
se->expr = convert (type, tmp);
}
+
+/* Generate code for BGE, BGT, BLE and BLT intrinsics. */
+static void
+gfc_conv_intrinsic_bitcomp (gfc_se * se, gfc_expr * expr, enum tree_code op)
+{
+ tree args[2];
+
+ gfc_conv_intrinsic_function_args (se, expr, args, 2);
+
+ /* Convert both arguments to the unsigned type of the same size. */
+ args[0] = fold_convert (unsigned_type_for (TREE_TYPE (args[0])), args[0]);
+ args[1] = fold_convert (unsigned_type_for (TREE_TYPE (args[1])), args[1]);
+
+ /* If they have unequal type size, convert to the larger one. */
+ if (TYPE_PRECISION (TREE_TYPE (args[0]))
+ > TYPE_PRECISION (TREE_TYPE (args[1])))
+ args[1] = fold_convert (TREE_TYPE (args[0]), args[1]);
+ else if (TYPE_PRECISION (TREE_TYPE (args[1]))
+ > TYPE_PRECISION (TREE_TYPE (args[0])))
+ args[0] = fold_convert (TREE_TYPE (args[1]), args[0]);
+
+ /* Now, we compare them. */
+ se->expr = fold_build2_loc (input_location, op, boolean_type_node,
+ args[0], args[1]);
+}
+
+
/* Generate code to perform the specified operation. */
static void
gfc_conv_intrinsic_bitop (gfc_se * se, gfc_expr * expr, enum tree_code op)
se->expr = fold_build2_loc (input_location, BIT_AND_EXPR, type, tmp, mask);
}
-/* RSHIFT (I, SHIFT) = I >> SHIFT
- LSHIFT (I, SHIFT) = I << SHIFT */
static void
-gfc_conv_intrinsic_rlshift (gfc_se * se, gfc_expr * expr, int right_shift)
+gfc_conv_intrinsic_shift (gfc_se * se, gfc_expr * expr, bool right_shift,
+ bool arithmetic)
{
- tree args[2];
+ tree args[2], type, num_bits, cond;
gfc_conv_intrinsic_function_args (se, expr, args, 2);
+ args[0] = gfc_evaluate_now (args[0], &se->pre);
+ args[1] = gfc_evaluate_now (args[1], &se->pre);
+ type = TREE_TYPE (args[0]);
+
+ if (!arithmetic)
+ args[0] = fold_convert (unsigned_type_for (type), args[0]);
+ else
+ gcc_assert (right_shift);
+
se->expr = fold_build2_loc (input_location,
right_shift ? RSHIFT_EXPR : LSHIFT_EXPR,
TREE_TYPE (args[0]), args[0], args[1]);
+
+ if (!arithmetic)
+ se->expr = fold_convert (type, se->expr);
+
+ /* The Fortran standard allows shift widths <= BIT_SIZE(I), whereas
+ gcc requires a shift width < BIT_SIZE(I), so we have to catch this
+ special case. */
+ num_bits = build_int_cst (TREE_TYPE (args[1]), TYPE_PRECISION (type));
+ cond = fold_build2_loc (input_location, GE_EXPR, boolean_type_node,
+ args[1], num_bits);
+
+ se->expr = fold_build3_loc (input_location, COND_EXPR, type, cond,
+ build_int_cst (type, 0), se->expr);
}
/* ISHFT (I, SHIFT) = (abs (shift) >= BIT_SIZE (i))
rrot);
}
+
/* LEADZ (i) = (i == 0) ? BIT_SIZE (i)
: __builtin_clz(i) - (BIT_SIZE('int') - BIT_SIZE(i))
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
{
- gcc_assert (argsize == 128);
+ gcc_assert (argsize == 2 * LONG_LONG_TYPE_SIZE);
arg_type = gfc_build_uint_type (argsize);
- func = gfor_fndecl_clz128;
+ func = NULL_TREE;
}
/* Convert the actual argument twice: first, to the unsigned type of the
function. But the return type is of the default INTEGER kind. */
arg = fold_convert (gfc_build_uint_type (argsize), arg);
arg = fold_convert (arg_type, arg);
+ arg = gfc_evaluate_now (arg, &se->pre);
result_type = gfc_get_int_type (gfc_default_integer_kind);
/* Compute LEADZ for the case i .ne. 0. */
- s = TYPE_PRECISION (arg_type) - argsize;
- tmp = fold_convert (result_type, build_call_expr_loc (input_location, func,
- 1, arg));
- leadz = fold_build2_loc (input_location, MINUS_EXPR, result_type,
- tmp, build_int_cst (result_type, s));
+ if (func)
+ {
+ s = TYPE_PRECISION (arg_type) - argsize;
+ tmp = fold_convert (result_type,
+ build_call_expr_loc (input_location, func,
+ 1, arg));
+ leadz = fold_build2_loc (input_location, MINUS_EXPR, result_type,
+ tmp, build_int_cst (result_type, s));
+ }
+ else
+ {
+ /* We end up here if the argument type is larger than 'long long'.
+ We generate this code:
+
+ if (x & (ULL_MAX << ULL_SIZE) != 0)
+ return clzll ((unsigned long long) (x >> ULLSIZE));
+ else
+ return ULL_SIZE + clzll ((unsigned long long) x);
+ 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, btmp;
+
+ ullsize = build_int_cst (result_type, LONG_LONG_TYPE_SIZE);
+ ullmax = fold_build1_loc (input_location, BIT_NOT_EXPR,
+ long_long_unsigned_type_node,
+ build_int_cst (long_long_unsigned_type_node,
+ 0));
+
+ cond = fold_build2_loc (input_location, LSHIFT_EXPR, arg_type,
+ fold_convert (arg_type, ullmax), ullsize);
+ cond = fold_build2_loc (input_location, BIT_AND_EXPR, arg_type,
+ arg, cond);
+ cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
+ cond, build_int_cst (arg_type, 0));
+
+ 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, 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, btmp, 1, tmp2));
+ tmp2 = fold_build2_loc (input_location, PLUS_EXPR, result_type,
+ tmp2, ullsize);
+
+ leadz = fold_build3_loc (input_location, COND_EXPR, result_type,
+ cond, tmp1, tmp2);
+ }
/* Build BIT_SIZE. */
bit_size = build_int_cst (result_type, argsize);
bit_size, leadz);
}
+
/* TRAILZ(i) = (i == 0) ? BIT_SIZE (i) : __builtin_ctz(i)
The conditional expression is necessary because the result of TRAILZ(0)
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
{
- gcc_assert (argsize == 128);
+ gcc_assert (argsize == 2 * LONG_LONG_TYPE_SIZE);
arg_type = gfc_build_uint_type (argsize);
- func = gfor_fndecl_ctz128;
+ func = NULL_TREE;
}
/* Convert the actual argument twice: first, to the unsigned type of the
function. But the return type is of the default INTEGER kind. */
arg = fold_convert (gfc_build_uint_type (argsize), arg);
arg = fold_convert (arg_type, arg);
+ arg = gfc_evaluate_now (arg, &se->pre);
result_type = gfc_get_int_type (gfc_default_integer_kind);
/* Compute TRAILZ for the case i .ne. 0. */
- trailz = fold_convert (result_type, build_call_expr_loc (input_location,
- func, 1, arg));
+ if (func)
+ trailz = fold_convert (result_type, build_call_expr_loc (input_location,
+ func, 1, arg));
+ else
+ {
+ /* We end up here if the argument type is larger than 'long long'.
+ We generate this code:
+
+ if ((x & ULL_MAX) == 0)
+ return ULL_SIZE + ctzll ((unsigned long long) (x >> ULLSIZE));
+ else
+ return ctzll ((unsigned long long) x);
+
+ 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, btmp;
+
+ ullsize = build_int_cst (result_type, LONG_LONG_TYPE_SIZE);
+ ullmax = fold_build1_loc (input_location, BIT_NOT_EXPR,
+ long_long_unsigned_type_node,
+ build_int_cst (long_long_unsigned_type_node, 0));
+
+ cond = fold_build2_loc (input_location, BIT_AND_EXPR, arg_type, arg,
+ fold_convert (arg_type, ullmax));
+ cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, cond,
+ build_int_cst (arg_type, 0));
+
+ 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, 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, btmp, 1, tmp2));
+
+ trailz = fold_build3_loc (input_location, COND_EXPR, result_type,
+ cond, tmp1, tmp2);
+ }
/* Build BIT_SIZE. */
bit_size = build_int_cst (result_type, argsize);
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);
sym = gfc_get_symbol_for_expr (expr);
gfc_conv_procedure_call (se, sym, expr->value.function.actual, expr,
append_args);
- gfc_free (sym);
+ free (sym);
}
switch (arg->expr_type)
{
case EXPR_CONSTANT:
- len = build_int_cst (NULL_TREE, arg->value.character.length);
+ len = build_int_cst (gfc_charlen_type_node, arg->value.character.length);
break;
case EXPR_ARRAY:
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);
}
}
+/* MERGE_BITS (I, J, MASK) = (I & MASK) | (I & (~MASK)). */
+
+static void
+gfc_conv_intrinsic_merge_bits (gfc_se * se, gfc_expr * expr)
+{
+ tree args[3], mask, type;
+
+ gfc_conv_intrinsic_function_args (se, expr, args, 3);
+ mask = gfc_evaluate_now (args[2], &se->pre);
+
+ type = TREE_TYPE (args[0]);
+ gcc_assert (TREE_TYPE (args[1]) == type);
+ gcc_assert (TREE_TYPE (mask) == type);
+
+ args[0] = fold_build2_loc (input_location, BIT_AND_EXPR, type, args[0], mask);
+ args[1] = fold_build2_loc (input_location, BIT_AND_EXPR, type, args[1],
+ fold_build1_loc (input_location, BIT_NOT_EXPR,
+ type, mask));
+ se->expr = fold_build2_loc (input_location, BIT_IOR_EXPR, type,
+ args[0], args[1]);
+}
+
+
+/* MASKL(n) = n == 0 ? 0 : (~0) << (BIT_SIZE - n)
+ MASKR(n) = n == BIT_SIZE ? ~0 : ~((~0) << n) */
+
+static void
+gfc_conv_intrinsic_mask (gfc_se * se, gfc_expr * expr, int left)
+{
+ tree arg, allones, type, utype, res, cond, bitsize;
+ int i;
+
+ gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
+ arg = gfc_evaluate_now (arg, &se->pre);
+
+ type = gfc_get_int_type (expr->ts.kind);
+ utype = unsigned_type_for (type);
+
+ i = gfc_validate_kind (BT_INTEGER, expr->ts.kind, false);
+ bitsize = build_int_cst (TREE_TYPE (arg), gfc_integer_kinds[i].bit_size);
+
+ allones = fold_build1_loc (input_location, BIT_NOT_EXPR, utype,
+ build_int_cst (utype, 0));
+
+ if (left)
+ {
+ /* Left-justified mask. */
+ res = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (arg),
+ bitsize, arg);
+ res = fold_build2_loc (input_location, LSHIFT_EXPR, utype, allones,
+ fold_convert (utype, res));
+
+ /* Special case arg == 0, because SHIFT_EXPR wants a shift strictly
+ smaller than type width. */
+ cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, arg,
+ build_int_cst (TREE_TYPE (arg), 0));
+ res = fold_build3_loc (input_location, COND_EXPR, utype, cond,
+ build_int_cst (utype, 0), res);
+ }
+ else
+ {
+ /* Right-justified mask. */
+ res = fold_build2_loc (input_location, LSHIFT_EXPR, utype, allones,
+ fold_convert (utype, arg));
+ res = fold_build1_loc (input_location, BIT_NOT_EXPR, utype, res);
+
+ /* Special case agr == bit_size, because SHIFT_EXPR wants a shift
+ strictly smaller than type width. */
+ cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
+ arg, bitsize);
+ res = fold_build3_loc (input_location, COND_EXPR, utype,
+ cond, allones, res);
+ }
+
+ se->expr = fold_convert (type, res);
+}
+
+
/* FRACTION (s) is translated into frexp (s, &dummy_int). */
static void
gfc_conv_intrinsic_fraction (gfc_se * se, gfc_expr * expr)
nextafter = gfc_builtin_decl_for_float_kind (BUILT_IN_NEXTAFTER, expr->ts.kind);
copysign = gfc_builtin_decl_for_float_kind (BUILT_IN_COPYSIGN, expr->ts.kind);
- huge_val = gfc_builtin_decl_for_float_kind (BUILT_IN_HUGE_VAL, expr->ts.kind);
type = gfc_typenode_for_spec (&expr->ts);
gfc_conv_intrinsic_function_args (se, expr, args, 2);
- tmp = build_call_expr_loc (input_location, copysign, 2,
- build_call_expr_loc (input_location, huge_val, 0),
+
+ huge_val = gfc_build_inf_or_huge (type, expr->ts.kind);
+ tmp = build_call_expr_loc (input_location, copysign, 2, huge_val,
fold_convert (type, args[1]));
se->expr = build_call_expr_loc (input_location, nextafter, 2,
fold_convert (type, args[0]), tmp);
stmtblock_t block;
k = gfc_validate_kind (BT_REAL, expr->ts.kind, false);
- prec = build_int_cst (NULL_TREE, gfc_real_kinds[k].digits);
- emin = build_int_cst (NULL_TREE, gfc_real_kinds[k].min_exponent - 1);
+ prec = build_int_cst (integer_type_node, gfc_real_kinds[k].digits);
+ emin = build_int_cst (integer_type_node, gfc_real_kinds[k].min_exponent - 1);
tiny = gfc_conv_mpfr_to_tree (gfc_real_kinds[k].tiny, expr->ts.kind, 0);
frexp = gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP, expr->ts.kind);
gfc_add_expr_to_block (&block, tmp);
tmp = fold_build2_loc (input_location, MINUS_EXPR, integer_type_node,
- build_int_cst (NULL_TREE, prec), e);
+ build_int_cst (integer_type_node, prec), e);
tmp = build_call_expr_loc (input_location, scalbn, 2, x, tmp);
gfc_add_modify (&block, x, tmp);
stmt = gfc_finish_block (&block);
if (ss == gfc_ss_terminator)
{
if (arg->ts.type == BT_CLASS)
- gfc_add_component_ref (arg, "$data");
+ gfc_add_data_component (arg);
gfc_conv_expr_reference (&argse, arg);
{
if (arg->ts.type == BT_CLASS)
{
- gfc_add_component_ref (arg, "$vptr");
- gfc_add_component_ref (arg, "$size");
+ gfc_add_vptr_component (arg);
+ gfc_add_size_component (arg);
gfc_conv_expr (&argse, arg);
tmp = fold_convert (result_type, argse.expr);
goto done;
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,
+ se->ss, mold_type, NULL_TREE, false, true, false,
&expr->where);
/* Cast the pointer to the result. */
/* 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),
se->expr = info->descriptor;
if (expr->ts.type == BT_CHARACTER)
- se->string_length = dest_word_len;
+ se->string_length = fold_convert (gfc_charlen_type_node, dest_word_len);
return;
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);
/* Allocatable scalar. */
arg1se.want_pointer = 1;
if (arg1->expr->ts.type == BT_CLASS)
- gfc_add_component_ref (arg1->expr, "$data");
+ gfc_add_data_component (arg1->expr);
gfc_conv_expr (&arg1se, arg1->expr);
tmp = arg1se.expr;
}
gfc_init_se (&arg2se, NULL);
arg1 = expr->value.function.actual;
if (arg1->expr->ts.type == BT_CLASS)
- gfc_add_component_ref (arg1->expr, "$data");
+ gfc_add_data_component (arg1->expr);
arg2 = arg1->next;
ss1 = gfc_walk_expr (arg1->expr);
{
/* An optional target. */
if (arg2->expr->ts.type == BT_CLASS)
- gfc_add_component_ref (arg2->expr, "$data");
+ gfc_add_data_component (arg2->expr);
ss2 = gfc_walk_expr (arg2->expr);
nonzero_charlen = NULL_TREE;
if (a->ts.type == BT_CLASS)
{
- gfc_add_component_ref (a, "$vptr");
- gfc_add_component_ref (a, "$hash");
+ gfc_add_vptr_component (a);
+ gfc_add_hash_component (a);
}
else if (a->ts.type == BT_DERIVED)
a = gfc_get_int_expr (gfc_default_integer_kind, NULL,
if (b->ts.type == BT_CLASS)
{
- gfc_add_component_ref (b, "$vptr");
- gfc_add_component_ref (b, "$hash");
+ gfc_add_vptr_component (b);
+ gfc_add_hash_component (b);
}
else if (b->ts.type == BT_DERIVED)
b = gfc_get_int_expr (gfc_default_integer_kind, NULL,
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,
name = &expr->value.function.name[2];
- if (expr->rank > 0 && !expr->inline_noncopying_intrinsic)
+ if (expr->rank > 0)
{
lib = gfc_is_intrinsic_libcall (expr);
if (lib != 0)
gfc_conv_intrinsic_btest (se, expr);
break;
+ case GFC_ISYM_BGE:
+ gfc_conv_intrinsic_bitcomp (se, expr, GE_EXPR);
+ break;
+
+ case GFC_ISYM_BGT:
+ gfc_conv_intrinsic_bitcomp (se, expr, GT_EXPR);
+ break;
+
+ case GFC_ISYM_BLE:
+ gfc_conv_intrinsic_bitcomp (se, expr, LE_EXPR);
+ break;
+
+ case GFC_ISYM_BLT:
+ gfc_conv_intrinsic_bitcomp (se, expr, LT_EXPR);
+ break;
+
case GFC_ISYM_ACHAR:
case GFC_ISYM_CHAR:
gfc_conv_intrinsic_char (se, expr);
gfc_conv_intrinsic_dprod (se, expr);
break;
+ case GFC_ISYM_DSHIFTL:
+ gfc_conv_intrinsic_dshift (se, expr, true);
+ break;
+
+ case GFC_ISYM_DSHIFTR:
+ gfc_conv_intrinsic_dshift (se, expr, false);
+ break;
+
case GFC_ISYM_FDATE:
gfc_conv_intrinsic_fdate (se, expr);
break;
break;
case GFC_ISYM_LSHIFT:
- gfc_conv_intrinsic_rlshift (se, expr, 0);
+ gfc_conv_intrinsic_shift (se, expr, false, false);
break;
case GFC_ISYM_RSHIFT:
- gfc_conv_intrinsic_rlshift (se, expr, 1);
+ gfc_conv_intrinsic_shift (se, expr, true, true);
+ break;
+
+ case GFC_ISYM_SHIFTA:
+ gfc_conv_intrinsic_shift (se, expr, true, true);
+ break;
+
+ case GFC_ISYM_SHIFTL:
+ gfc_conv_intrinsic_shift (se, expr, false, false);
+ break;
+
+ case GFC_ISYM_SHIFTR:
+ gfc_conv_intrinsic_shift (se, expr, true, false);
break;
case GFC_ISYM_ISHFT:
gfc_conv_intrinsic_bound (se, expr, 0);
break;
+ case GFC_ISYM_LCOBOUND:
+ conv_intrinsic_cobound (se, expr);
+ break;
+
case GFC_ISYM_TRANSPOSE:
- if (se->ss && se->ss->useflags)
- {
- gfc_conv_tmp_array_ref (se);
- gfc_advance_se_ss_chain (se);
- }
- else
- gfc_conv_array_transpose (se, expr->value.function.actual->expr);
+ /* The scalarizer has already been set up for reversed dimension access
+ order ; now we just get the argument value normally. */
+ gfc_conv_expr (se, expr->value.function.actual->expr);
break;
case GFC_ISYM_LEN:
gfc_conv_intrinsic_strcmp (se, expr, LT_EXPR);
break;
+ case GFC_ISYM_MASKL:
+ gfc_conv_intrinsic_mask (se, expr, 1);
+ break;
+
+ case GFC_ISYM_MASKR:
+ gfc_conv_intrinsic_mask (se, expr, 0);
+ break;
+
case GFC_ISYM_MAX:
if (expr->ts.type == BT_CHARACTER)
gfc_conv_intrinsic_minmax_char (se, expr, 1);
gfc_conv_intrinsic_merge (se, expr);
break;
+ case GFC_ISYM_MERGE_BITS:
+ gfc_conv_intrinsic_merge_bits (se, expr);
+ break;
+
case GFC_ISYM_MIN:
if (expr->ts.type == BT_CHARACTER)
gfc_conv_intrinsic_minmax_char (se, expr, -1);
break;
case GFC_ISYM_TRANSFER:
- if (se->ss && se->ss->useflags)
- {
- /* Access the previously obtained result. */
- gfc_conv_tmp_array_ref (se);
- gfc_advance_se_ss_chain (se);
- }
+ if (se->ss && se->ss->info->useflags)
+ /* Access the previously obtained result. */
+ gfc_conv_tmp_array_ref (se);
else
gfc_conv_intrinsic_transfer (se, expr);
break;
gfc_conv_intrinsic_bound (se, expr, 1);
break;
+ case GFC_ISYM_UCOBOUND:
+ conv_intrinsic_cobound (se, expr);
+ break;
+
case GFC_ISYM_XOR:
gfc_conv_intrinsic_bitop (se, expr, BIT_XOR_EXPR);
break;
gfc_conv_intrinsic_loc (se, expr);
break;
+ case GFC_ISYM_THIS_IMAGE:
+ /* For num_images() == 1, handle as LCOBOUND. */
+ if (expr->value.function.actual->expr
+ && gfc_option.coarray == GFC_FCOARRAY_SINGLE)
+ conv_intrinsic_cobound (se, expr);
+ else
+ trans_this_image (se, expr);
+ break;
+
+ case GFC_ISYM_IMAGE_INDEX:
+ trans_image_index (se, expr);
+ break;
+
+ case GFC_ISYM_NUM_IMAGES:
+ trans_num_images (se);
+ break;
+
case GFC_ISYM_ACCESS:
case GFC_ISYM_CHDIR:
case GFC_ISYM_CHMOD:
}
+static gfc_ss *
+walk_inline_intrinsic_transpose (gfc_ss *ss, gfc_expr *expr)
+{
+ gfc_ss *arg_ss, *tmp_ss;
+ gfc_actual_arglist *arg;
+
+ arg = expr->value.function.actual;
+
+ gcc_assert (arg->expr);
+
+ arg_ss = gfc_walk_subexpr (gfc_ss_terminator, arg->expr);
+ gcc_assert (arg_ss != gfc_ss_terminator);
+
+ for (tmp_ss = arg_ss; ; tmp_ss = tmp_ss->next)
+ {
+ if (tmp_ss->info->type != GFC_SS_SCALAR
+ && tmp_ss->info->type != GFC_SS_REFERENCE)
+ {
+ int tmp_dim;
+
+ gcc_assert (tmp_ss->dimen == 2);
+
+ /* We just invert dimensions. */
+ 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... */
+ if (tmp_ss->next == gfc_ss_terminator)
+ break;
+ }
+
+ /* ... so that we can attach the rest of the chain to it. */
+ tmp_ss->next = ss;
+
+ return arg_ss;
+}
+
+
+static gfc_ss *
+walk_inline_intrinsic_function (gfc_ss * ss, gfc_expr * expr)
+{
+
+ switch (expr->value.function.isym->id)
+ {
+ case GFC_ISYM_TRANSPOSE:
+ return walk_inline_intrinsic_transpose (ss, expr);
+
+ default:
+ gcc_unreachable ();
+ }
+ gcc_unreachable ();
+}
+
+
/* This generates code to execute before entering the scalarization loop.
Currently does nothing. */
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:
+ case GFC_ISYM_UCOBOUND:
+ case GFC_ISYM_LCOBOUND:
+ case GFC_ISYM_THIS_IMAGE:
break;
default:
}
-/* UBOUND and LBOUND intrinsics with one parameter are expanded into code
- inside the scalarization loop. */
+/* The LBOUND, LCOBOUND, UBOUND and UCOBOUND intrinsics with one parameter
+ are expanded into code inside the scalarization loop. */
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;
-
gcc_assert (expr->rank > 0);
+ return gfc_get_array_ss (ss, expr, expr->rank, GFC_SS_FUNCTION);
+}
+
+
+/* Return whether the function call expression EXPR will be expanded
+ inline by gfc_conv_intrinsic_function. */
+
+bool
+gfc_inline_intrinsic_function_p (gfc_expr *expr)
+{
+ if (!expr->value.function.isym)
+ return false;
- newss = gfc_get_ss ();
- newss->type = GFC_SS_FUNCTION;
- newss->expr = expr;
- newss->next = ss;
- newss->data.info.dimen = expr->rank;
+ switch (expr->value.function.isym->id)
+ {
+ case GFC_ISYM_TRANSPOSE:
+ return true;
- return newss;
+ default:
+ return false;
+ }
}
gcc_assert (expr->expr_type == EXPR_FUNCTION && expr->value.function.isym);
gcc_assert (expr->rank > 0);
+ if (gfc_inline_intrinsic_function_p (expr))
+ return 0;
+
switch (expr->value.function.isym->id)
{
case GFC_ISYM_ALL:
case GFC_ISYM_SUM:
case GFC_ISYM_SHAPE:
case GFC_ISYM_SPREAD:
- case GFC_ISYM_TRANSPOSE:
case GFC_ISYM_YN2:
/* Ignore absent optional parameters. */
return 1;
gcc_assert (isym);
if (isym->elemental)
- return gfc_walk_elemental_function_args (ss, expr->value.function.actual, GFC_SS_SCALAR);
+ return gfc_walk_elemental_function_args (ss, expr->value.function.actual,
+ GFC_SS_SCALAR);
if (expr->rank == 0)
return ss;
+ if (gfc_inline_intrinsic_function_p (expr))
+ return walk_inline_intrinsic_function (ss, expr);
+
if (gfc_is_intrinsic_libcall (expr))
return gfc_walk_intrinsic_libfunc (ss, expr);
switch (isym->id)
{
case GFC_ISYM_LBOUND:
+ case GFC_ISYM_LCOBOUND:
case GFC_ISYM_UBOUND:
+ case GFC_ISYM_UCOBOUND:
+ case GFC_ISYM_THIS_IMAGE:
return gfc_walk_intrinsic_bound (ss, expr);
case GFC_ISYM_TRANSFER:
}
-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"
OSDN Git Service
