{
/* The explicit enum is required to work around inadequacies in the
garbage collection/gengtype parsing mechanism. */
- enum gfc_generic_isym_id id;
+ enum gfc_isym_id id;
/* Enum value from the "language-independent", aka C-centric, part
of gcc, or END_BUILTINS of no such value set. */
gfc_intrinsic_map_t *m;
tree args;
tree fndecl;
- gfc_generic_isym_id id;
+ gfc_isym_id id;
- id = expr->value.function.isym->generic_id;
+ id = expr->value.function.isym->id;
/* Find the entry for this function. */
for (m = gfc_intrinsic_map; m->id != GFC_ISYM_NONE; m++)
{
/* Free the temporary afterwards, if necessary. */
cond = build2 (GT_EXPR, boolean_type_node, len,
build_int_cst (TREE_TYPE (len), 0));
- tmp = build_call_expr (gfor_fndecl_internal_free, 1, var);
+ tmp = gfc_call_free (var);
tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ());
gfc_add_expr_to_block (&se->post, tmp);
/* Free the temporary afterwards, if necessary. */
cond = build2 (GT_EXPR, boolean_type_node, len,
build_int_cst (TREE_TYPE (len), 0));
- tmp = build_call_expr (gfor_fndecl_internal_free, 1, var);
+ tmp = gfc_call_free (var);
tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ());
gfc_add_expr_to_block (&se->post, tmp);
/* Free the temporary afterwards, if necessary. */
cond = build2 (GT_EXPR, boolean_type_node, len,
build_int_cst (TREE_TYPE (len), 0));
- tmp = build_call_expr (gfor_fndecl_internal_free, 1, var);
+ tmp = gfc_call_free (var);
tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ());
gfc_add_expr_to_block (&se->post, tmp);
/* Calls to libgfortran_matmul need to be appended special arguments,
to be able to call the BLAS ?gemm functions if required and possible. */
append_args = NULL_TREE;
- if (expr->value.function.isym->generic_id == GFC_ISYM_MATMUL
+ if (expr->value.function.isym->id == GFC_ISYM_MATMUL
&& sym->ts.type != BT_LOGICAL)
{
tree cint = gfc_get_int_type (gfc_c_int_kind);
/* Initialize the result. */
resvar = gfc_create_var (type, "val");
if (expr->ts.type == BT_LOGICAL)
- tmp = convert (type, integer_zero_node);
+ tmp = build_int_cst (type, 0);
else
tmp = gfc_build_const (type, integer_zero_node);
arg2 = TREE_VALUE (TREE_CHAIN (arg));
arg = TREE_VALUE (arg);
type = TREE_TYPE (arg);
- utype = gfc_unsigned_type (type);
+ utype = unsigned_type_for (type);
width = fold_build1 (ABS_EXPR, TREE_TYPE (arg2), arg2);
/* Obtain the string length from the function used by
trans-array.c(gfc_trans_array_constructor). */
len = NULL_TREE;
- get_array_ctor_strlen (arg->value.constructor, &len);
+ get_array_ctor_strlen (&se->pre, arg->value.constructor, &len);
break;
case EXPR_VARIABLE:
}
+static void
+gfc_conv_intrinsic_sizeof (gfc_se *se, gfc_expr *expr)
+{
+ gfc_expr *arg;
+ gfc_ss *ss;
+ gfc_se argse;
+ tree source;
+ tree source_bytes;
+ tree type;
+ tree tmp;
+ tree lower;
+ tree upper;
+ /*tree stride;*/
+ int n;
+
+ arg = expr->value.function.actual->expr;
+
+ gfc_init_se (&argse, NULL);
+ ss = gfc_walk_expr (arg);
+
+ source_bytes = gfc_create_var (gfc_array_index_type, "bytes");
+
+ if (ss == gfc_ss_terminator)
+ {
+ gfc_conv_expr_reference (&argse, arg);
+ source = argse.expr;
+
+ type = TREE_TYPE (build_fold_indirect_ref (argse.expr));
+
+ /* Obtain the source word length. */
+ if (arg->ts.type == BT_CHARACTER)
+ source_bytes = fold_convert (gfc_array_index_type,
+ argse.string_length);
+ else
+ source_bytes = fold_convert (gfc_array_index_type,
+ size_in_bytes (type));
+ }
+ else
+ {
+ argse.want_pointer = 0;
+ gfc_conv_expr_descriptor (&argse, arg, ss);
+ source = gfc_conv_descriptor_data_get (argse.expr);
+ type = gfc_get_element_type (TREE_TYPE (argse.expr));
+
+ /* Obtain the argument's word length. */
+ if (arg->ts.type == BT_CHARACTER)
+ tmp = fold_convert (gfc_array_index_type, argse.string_length);
+ else
+ tmp = fold_convert (gfc_array_index_type,
+ size_in_bytes (type));
+ gfc_add_modify_expr (&argse.pre, source_bytes, tmp);
+
+ /* Obtain the size of the array in bytes. */
+ for (n = 0; n < arg->rank; n++)
+ {
+ tree idx;
+ idx = gfc_rank_cst[n];
+ lower = gfc_conv_descriptor_lbound (argse.expr, idx);
+ upper = gfc_conv_descriptor_ubound (argse.expr, idx);
+ tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
+ upper, lower);
+ tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
+ tmp, gfc_index_one_node);
+ tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
+ tmp, source_bytes);
+ gfc_add_modify_expr (&argse.pre, source_bytes, tmp);
+ }
+ }
+
+ gfc_add_block_to_block (&se->pre, &argse.pre);
+ se->expr = source_bytes;
+}
+
+
/* Intrinsic string comparison functions. */
- static void
+static void
gfc_conv_intrinsic_strcmp (gfc_se * se, gfc_expr * expr, int op)
{
tree type;
}
-/* A helper function for gfc_conv_intrinsic_array_transfer to compute
- the size of tree expressions in bytes. */
-static tree
-gfc_size_in_bytes (gfc_se *se, gfc_expr *e)
-{
- tree tmp;
-
- if (e->ts.type == BT_CHARACTER)
- tmp = se->string_length;
- else
- {
- if (e->rank)
- {
- tmp = gfc_get_element_type (TREE_TYPE (se->expr));
- tmp = size_in_bytes (tmp);
- }
- else
- tmp = size_in_bytes (TREE_TYPE (TREE_TYPE (se->expr)));
- }
-
- return fold_convert (gfc_array_index_type, tmp);
-}
-
-
/* Array transfer statement.
DEST(1:N) = TRANSFER (SOURCE, MOLD[, SIZE])
where:
tree tmp;
tree extent;
tree source;
+ tree source_type;
tree source_bytes;
+ tree mold_type;
tree dest_word_len;
tree size_words;
tree size_bytes;
gfc_conv_expr_reference (&argse, arg->expr);
source = argse.expr;
+ source_type = TREE_TYPE (build_fold_indirect_ref (argse.expr));
+
/* Obtain the source word length. */
- tmp = gfc_size_in_bytes (&argse, arg->expr);
+ if (arg->expr->ts.type == BT_CHARACTER)
+ tmp = fold_convert (gfc_array_index_type, argse.string_length);
+ else
+ tmp = fold_convert (gfc_array_index_type,
+ size_in_bytes (source_type));
}
else
{
- gfc_init_se (&argse, NULL);
argse.want_pointer = 0;
gfc_conv_expr_descriptor (&argse, arg->expr, ss);
source = gfc_conv_descriptor_data_get (argse.expr);
+ source_type = gfc_get_element_type (TREE_TYPE (argse.expr));
/* Repack the source if not a full variable array. */
if (!(arg->expr->expr_type == EXPR_VARIABLE
/* Free the temporary. */
gfc_start_block (&block);
- tmp = convert (pvoid_type_node, source);
- tmp = build_call_expr (gfor_fndecl_internal_free, 1, tmp);
+ tmp = gfc_call_free (convert (pvoid_type_node, source));
gfc_add_expr_to_block (&block, tmp);
stmt = gfc_finish_block (&block);
}
/* Obtain the source word length. */
- tmp = gfc_size_in_bytes (&argse, arg->expr);
+ if (arg->expr->ts.type == BT_CHARACTER)
+ tmp = fold_convert (gfc_array_index_type, argse.string_length);
+ else
+ tmp = fold_convert (gfc_array_index_type,
+ size_in_bytes (source_type));
/* Obtain the size of the array in bytes. */
extent = gfc_create_var (gfc_array_index_type, NULL);
stride = gfc_conv_descriptor_stride (argse.expr, idx);
lower = gfc_conv_descriptor_lbound (argse.expr, idx);
upper = gfc_conv_descriptor_ubound (argse.expr, idx);
- tmp = build2 (MINUS_EXPR, gfc_array_index_type,
- upper, lower);
+ tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
+ upper, lower);
gfc_add_modify_expr (&argse.pre, extent, tmp);
- tmp = build2 (PLUS_EXPR, gfc_array_index_type,
- extent, gfc_index_one_node);
- tmp = build2 (MULT_EXPR, gfc_array_index_type,
- tmp, source_bytes);
+ tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
+ extent, gfc_index_one_node);
+ tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
+ tmp, source_bytes);
}
}
gfc_add_block_to_block (&se->pre, &argse.pre);
gfc_add_block_to_block (&se->post, &argse.post);
- /* Now convert MOLD. The sole output is:
+ /* Now convert MOLD. The outputs are:
+ mold_type = the TREE type of MOLD
dest_word_len = destination word length in bytes. */
arg = arg->next;
if (ss == gfc_ss_terminator)
{
gfc_conv_expr_reference (&argse, arg->expr);
-
- /* Obtain the source word length. */
- tmp = gfc_size_in_bytes (&argse, arg->expr);
+ mold_type = TREE_TYPE (build_fold_indirect_ref (argse.expr));
}
else
{
gfc_init_se (&argse, NULL);
argse.want_pointer = 0;
gfc_conv_expr_descriptor (&argse, arg->expr, ss);
-
- /* Obtain the source word length. */
- tmp = gfc_size_in_bytes (&argse, arg->expr);
+ mold_type = gfc_get_element_type (TREE_TYPE (argse.expr));
}
+ if (arg->expr->ts.type == BT_CHARACTER)
+ {
+ tmp = fold_convert (gfc_array_index_type, argse.string_length);
+ mold_type = gfc_get_character_type_len (arg->expr->ts.kind, tmp);
+ }
+ else
+ tmp = fold_convert (gfc_array_index_type,
+ size_in_bytes (mold_type));
+
dest_word_len = gfc_create_var (gfc_array_index_type, NULL);
gfc_add_modify_expr (&se->pre, dest_word_len, tmp);
size_bytes = gfc_create_var (gfc_array_index_type, NULL);
if (tmp != NULL_TREE)
{
- tmp = build2 (MULT_EXPR, gfc_array_index_type,
- tmp, dest_word_len);
- tmp = build2 (MIN_EXPR, gfc_array_index_type, tmp, source_bytes);
+ tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
+ tmp, dest_word_len);
+ tmp = fold_build2 (MIN_EXPR, gfc_array_index_type,
+ tmp, source_bytes);
}
else
tmp = source_bytes;
gfc_add_modify_expr (&se->pre, size_bytes, tmp);
gfc_add_modify_expr (&se->pre, size_words,
- build2 (CEIL_DIV_EXPR, gfc_array_index_type,
- size_bytes, dest_word_len));
+ fold_build2 (CEIL_DIV_EXPR, gfc_array_index_type,
+ size_bytes, dest_word_len));
/* Evaluate the bounds of the result. If the loop range exists, we have
to check if it is too large. If so, we modify loop->to be consistent
{
tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
se->loop->to[n], se->loop->from[n]);
- tmp = build2 (PLUS_EXPR, gfc_array_index_type,
- tmp, gfc_index_one_node);
- tmp = build2 (MIN_EXPR, gfc_array_index_type,
- tmp, size_words);
+ tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
+ tmp, gfc_index_one_node);
+ tmp = fold_build2 (MIN_EXPR, gfc_array_index_type,
+ tmp, size_words);
gfc_add_modify_expr (&se->pre, size_words, tmp);
gfc_add_modify_expr (&se->pre, size_bytes,
- build2 (MULT_EXPR, gfc_array_index_type,
- size_words, dest_word_len));
- upper = build2 (PLUS_EXPR, gfc_array_index_type,
- size_words, se->loop->from[n]);
- upper = build2 (MINUS_EXPR, gfc_array_index_type,
- upper, gfc_index_one_node);
+ fold_build2 (MULT_EXPR, gfc_array_index_type,
+ size_words, dest_word_len));
+ upper = fold_build2 (PLUS_EXPR, gfc_array_index_type,
+ size_words, se->loop->from[n]);
+ upper = fold_build2 (MINUS_EXPR, gfc_array_index_type,
+ upper, gfc_index_one_node);
}
else
{
- upper = build2 (MINUS_EXPR, gfc_array_index_type,
- size_words, gfc_index_one_node);
+ upper = fold_build2 (MINUS_EXPR, gfc_array_index_type,
+ size_words, gfc_index_one_node);
se->loop->from[n] = gfc_index_zero_node;
}
/* Build a destination descriptor, using the pointer, source, as the
data field. This is already allocated so set callee_alloc.
FIXME callee_alloc is not set! */
-
- tmp = gfc_typenode_for_spec (&expr->ts);
+
gfc_trans_create_temp_array (&se->pre, &se->post, se->loop,
- info, tmp, false, true, false);
+ info, mold_type, false, true, false);
+
+ /* Cast the pointer to the result. */
+ tmp = gfc_conv_descriptor_data_get (info->descriptor);
+ tmp = fold_convert (pvoid_type_node, tmp);
/* Use memcpy to do the transfer. */
tmp = build_call_expr (built_in_decls[BUILT_IN_MEMCPY],
3,
- gfc_conv_descriptor_data_get (info->descriptor),
+ tmp,
fold_convert (pvoid_type_node, source),
size_bytes);
gfc_add_expr_to_block (&se->pre, tmp);
/* Free the temporary afterwards, if necessary. */
cond = build2 (GT_EXPR, boolean_type_node, len,
build_int_cst (TREE_TYPE (len), 0));
- tmp = build_call_expr (gfor_fndecl_internal_free, 1, var);
+ tmp = gfc_call_free (var);
tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ());
gfc_add_expr_to_block (&se->post, tmp);
static void
gfc_conv_intrinsic_repeat (gfc_se * se, gfc_expr * expr)
{
- tree gfc_int4_type_node = gfc_get_int_type (4);
- tree tmp;
- tree len;
- tree args;
- tree ncopies;
- tree var;
- tree type;
- tree cond;
+ tree args, ncopies, dest, dlen, src, slen, ncopies_type;
+ tree type, cond, tmp, count, exit_label, n, max, largest;
+ stmtblock_t block, body;
+ int i;
+ /* Get the arguments. */
args = gfc_conv_intrinsic_function_args (se, expr);
- len = TREE_VALUE (args);
- tmp = gfc_advance_chain (args, 2);
- ncopies = TREE_VALUE (tmp);
-
- /* Check that ncopies is not negative. */
+ slen = fold_convert (size_type_node, gfc_evaluate_now (TREE_VALUE (args),
+ &se->pre));
+ src = TREE_VALUE (TREE_CHAIN (args));
+ ncopies = TREE_VALUE (TREE_CHAIN (TREE_CHAIN (args)));
ncopies = gfc_evaluate_now (ncopies, &se->pre);
+ ncopies_type = TREE_TYPE (ncopies);
+
+ /* Check that NCOPIES is not negative. */
cond = fold_build2 (LT_EXPR, boolean_type_node, ncopies,
- build_int_cst (TREE_TYPE (ncopies), 0));
+ build_int_cst (ncopies_type, 0));
gfc_trans_runtime_check (cond,
"Argument NCOPIES of REPEAT intrinsic is negative",
&se->pre, &expr->where);
+ /* If the source length is zero, any non negative value of NCOPIES
+ is valid, and nothing happens. */
+ n = gfc_create_var (ncopies_type, "ncopies");
+ cond = fold_build2 (EQ_EXPR, boolean_type_node, slen,
+ build_int_cst (size_type_node, 0));
+ tmp = fold_build3 (COND_EXPR, ncopies_type, cond,
+ build_int_cst (ncopies_type, 0), ncopies);
+ gfc_add_modify_expr (&se->pre, n, tmp);
+ ncopies = n;
+
+ /* Check that ncopies is not too large: ncopies should be less than
+ (or equal to) MAX / slen, where MAX is the maximal integer of
+ the gfc_charlen_type_node type. If slen == 0, we need a special
+ case to avoid the division by zero. */
+ i = gfc_validate_kind (BT_INTEGER, gfc_charlen_int_kind, false);
+ max = gfc_conv_mpz_to_tree (gfc_integer_kinds[i].huge, gfc_charlen_int_kind);
+ max = fold_build2 (TRUNC_DIV_EXPR, size_type_node,
+ fold_convert (size_type_node, max), slen);
+ largest = TYPE_PRECISION (size_type_node) > TYPE_PRECISION (ncopies_type)
+ ? size_type_node : ncopies_type;
+ cond = fold_build2 (GT_EXPR, boolean_type_node,
+ fold_convert (largest, ncopies),
+ fold_convert (largest, max));
+ tmp = fold_build2 (EQ_EXPR, boolean_type_node, slen,
+ build_int_cst (size_type_node, 0));
+ cond = fold_build3 (COND_EXPR, boolean_type_node, tmp, boolean_false_node,
+ cond);
+ gfc_trans_runtime_check (cond,
+ "Argument NCOPIES of REPEAT intrinsic is too large",
+ &se->pre, &expr->where);
+
/* Compute the destination length. */
- len = fold_build2 (MULT_EXPR, gfc_int4_type_node, len, ncopies);
+ dlen = fold_build2 (MULT_EXPR, gfc_charlen_type_node, slen, ncopies);
type = gfc_get_character_type (expr->ts.kind, expr->ts.cl);
- var = gfc_conv_string_tmp (se, build_pointer_type (type), len);
+ dest = gfc_conv_string_tmp (se, build_pointer_type (type), dlen);
+
+ /* Generate the code to do the repeat operation:
+ for (i = 0; i < ncopies; i++)
+ memmove (dest + (i * slen), src, slen); */
+ gfc_start_block (&block);
+ count = gfc_create_var (ncopies_type, "count");
+ gfc_add_modify_expr (&block, count, build_int_cst (ncopies_type, 0));
+ exit_label = gfc_build_label_decl (NULL_TREE);
+
+ /* Start the loop body. */
+ gfc_start_block (&body);
+
+ /* Exit the loop if count >= ncopies. */
+ cond = fold_build2 (GE_EXPR, boolean_type_node, count, ncopies);
+ tmp = build1_v (GOTO_EXPR, exit_label);
+ TREE_USED (exit_label) = 1;
+ tmp = fold_build3 (COND_EXPR, void_type_node, cond, tmp,
+ build_empty_stmt ());
+ gfc_add_expr_to_block (&body, tmp);
- /* Create the argument list and generate the function call. */
- tmp = build_call_expr (gfor_fndecl_string_repeat, 4, var,
- TREE_VALUE (args),
- TREE_VALUE (TREE_CHAIN (args)), ncopies);
+ /* Call memmove (dest + (i*slen), src, slen). */
+ tmp = fold_build2 (MULT_EXPR, gfc_charlen_type_node, slen,
+ fold_convert (gfc_charlen_type_node, count));
+ tmp = fold_build2 (PLUS_EXPR, pchar_type_node, dest,
+ fold_convert (pchar_type_node, tmp));
+ tmp = build_call_expr (built_in_decls[BUILT_IN_MEMMOVE], 3,
+ tmp, src, slen);
+ gfc_add_expr_to_block (&body, tmp);
+
+ /* Increment count. */
+ tmp = build2 (PLUS_EXPR, ncopies_type, count,
+ build_int_cst (TREE_TYPE (count), 1));
+ gfc_add_modify_expr (&body, count, tmp);
+
+ /* Build the loop. */
+ tmp = build1_v (LOOP_EXPR, gfc_finish_block (&body));
+ gfc_add_expr_to_block (&block, tmp);
+
+ /* Add the exit label. */
+ tmp = build1_v (LABEL_EXPR, exit_label);
+ gfc_add_expr_to_block (&block, tmp);
+
+ /* Finish the block. */
+ tmp = gfc_finish_block (&block);
gfc_add_expr_to_block (&se->pre, tmp);
- se->expr = var;
- se->string_length = len;
+ /* Set the result value. */
+ se->expr = dest;
+ se->string_length = dlen;
}
}
}
- switch (expr->value.function.isym->generic_id)
+ switch (expr->value.function.isym->id)
{
case GFC_ISYM_NONE:
gcc_unreachable ();
gfc_conv_intrinsic_size (se, expr);
break;
+ case GFC_ISYM_SIZEOF:
+ gfc_conv_intrinsic_sizeof (se, expr);
+ break;
+
case GFC_ISYM_SUM:
gfc_conv_intrinsic_arith (se, expr, PLUS_EXPR);
break;
void
gfc_add_intrinsic_ss_code (gfc_loopinfo * loop ATTRIBUTE_UNUSED, gfc_ss * ss)
{
- switch (ss->expr->value.function.isym->generic_id)
+ switch (ss->expr->value.function.isym->id)
{
case GFC_ISYM_UBOUND:
case GFC_ISYM_LBOUND:
gcc_assert (expr->expr_type == EXPR_FUNCTION && expr->value.function.isym);
gcc_assert (expr->rank > 0);
- switch (expr->value.function.isym->generic_id)
+ switch (expr->value.function.isym->id)
{
case GFC_ISYM_ALL:
case GFC_ISYM_ANY:
return gfc_walk_intrinsic_libfunc (ss, expr);
/* Special cases. */
- switch (isym->generic_id)
+ switch (isym->id)
{
case GFC_ISYM_LBOUND:
case GFC_ISYM_UBOUND: