}
-/* Array transfer statement.
- DEST(1:N) = TRANSFER (SOURCE, MOLD[, SIZE])
- where:
- typeof<DEST> = typeof<MOLD>
- and:
- N = min (sizeof (SOURCE(:)), sizeof (DEST(:)),
+/* Generate code for the TRANSFER intrinsic:
+ For scalar results:
+ DEST = TRANSFER (SOURCE, MOLD)
+ where:
+ typeof<DEST> = typeof<MOLD>
+ and:
+ MOLD is scalar.
+
+ For array results:
+ DEST(1:N) = TRANSFER (SOURCE, MOLD[, SIZE])
+ where:
+ typeof<DEST> = typeof<MOLD>
+ and:
+ N = min (sizeof (SOURCE(:)), sizeof (DEST(:)),
sizeof (DEST(0) * SIZE). */
-
static void
-gfc_conv_intrinsic_array_transfer (gfc_se * se, gfc_expr * expr)
+gfc_conv_intrinsic_transfer (gfc_se * se, gfc_expr * expr)
{
tree tmp;
+ tree tmpdecl;
+ tree ptr;
tree extent;
tree source;
tree source_type;
gfc_ss_info *info;
stmtblock_t block;
int n;
+ bool scalar_mold;
- gcc_assert (se->loop);
- info = &se->ss->data.info;
+ info = NULL;
+ if (se->loop)
+ info = &se->ss->data.info;
/* Convert SOURCE. The output from this stage is:-
source_bytes = length of the source in bytes
source = pointer to the source data. */
arg = expr->value.function.actual;
+
+ /* Ensure double transfer through LOGICAL preserves all
+ the needed bits. */
+ if (arg->expr->expr_type == EXPR_FUNCTION
+ && arg->expr->value.function.esym == NULL
+ && arg->expr->value.function.isym != NULL
+ && arg->expr->value.function.isym->id == GFC_ISYM_TRANSFER
+ && arg->expr->ts.type == BT_LOGICAL
+ && expr->ts.type != arg->expr->ts.type)
+ arg->expr->value.function.name = "__transfer_in_transfer";
+
gfc_init_se (&argse, NULL);
ss = gfc_walk_expr (arg->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
- && arg->expr->ref->u.ar.type == AR_FULL))
+ if (arg->expr->expr_type == EXPR_VARIABLE
+ && arg->expr->ref->u.ar.type != AR_FULL)
{
tmp = build_fold_addr_expr (argse.expr);
gfc_init_se (&argse, NULL);
ss = gfc_walk_expr (arg->expr);
+ scalar_mold = arg->expr->rank == 0;
+
if (ss == gfc_ss_terminator)
{
gfc_conv_expr_reference (&argse, arg->expr);
mold_type = gfc_get_element_type (TREE_TYPE (argse.expr));
}
+ gfc_add_block_to_block (&se->pre, &argse.pre);
+ gfc_add_block_to_block (&se->post, &argse.post);
+
if (strcmp (expr->value.function.name, "__transfer_in_transfer") == 0)
{
/* If this TRANSFER is nested in another TRANSFER, use a type
else
tmp = NULL_TREE;
+ /* Separate array and scalar results. */
+ if (scalar_mold && tmp == NULL_TREE)
+ goto scalar_transfer;
+
size_bytes = gfc_create_var (gfc_array_index_type, NULL);
if (tmp != NULL_TREE)
- {
- 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);
- }
+ tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
+ tmp, dest_word_len);
else
tmp = source_bytes;
se->loop->to[n] = upper;
/* 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! */
-
+ data field. */
gfc_trans_create_temp_array (&se->pre, &se->post, se->loop,
info, mold_type, NULL_TREE, false, true, false,
&expr->where);
3,
tmp,
fold_convert (pvoid_type_node, source),
- size_bytes);
+ fold_build2 (MIN_EXPR, gfc_array_index_type,
+ size_bytes, source_bytes));
gfc_add_expr_to_block (&se->pre, tmp);
se->expr = info->descriptor;
if (expr->ts.type == BT_CHARACTER)
se->string_length = dest_word_len;
-}
+ return;
-/* Scalar transfer statement.
- TRANSFER (source, mold) = memcpy(&tmpdecl, &source, size), tmpdecl. */
+/* Deal with scalar results. */
+scalar_transfer:
+ extent = fold_build2 (MIN_EXPR, gfc_array_index_type,
+ dest_word_len, source_bytes);
-static void
-gfc_conv_intrinsic_transfer (gfc_se * se, gfc_expr * expr)
-{
- gfc_actual_arglist *arg;
- gfc_se argse;
- tree type;
- tree ptr;
- gfc_ss *ss;
- tree tmpdecl, tmp;
+ if (expr->ts.type == BT_CHARACTER)
+ {
+ tree direct;
+ tree indirect;
- /* Get a pointer to the source. */
- arg = expr->value.function.actual;
- ss = gfc_walk_expr (arg->expr);
- gfc_init_se (&argse, NULL);
- if (ss == gfc_ss_terminator)
- gfc_conv_expr_reference (&argse, arg->expr);
- else
- gfc_conv_array_parameter (&argse, arg->expr, ss, 1, NULL, NULL);
- gfc_add_block_to_block (&se->pre, &argse.pre);
- gfc_add_block_to_block (&se->post, &argse.post);
- ptr = argse.expr;
+ ptr = convert (gfc_get_pchar_type (expr->ts.kind), source);
+ tmpdecl = gfc_create_var (gfc_get_pchar_type (expr->ts.kind),
+ "transfer");
- arg = arg->next;
- type = gfc_typenode_for_spec (&expr->ts);
- if (strcmp (expr->value.function.name, "__transfer_in_transfer") == 0)
- {
- /* If this TRANSFER is nested in another TRANSFER, use a type
- that preserves all bits. */
- if (expr->ts.type == BT_LOGICAL)
- type = gfc_get_int_type (expr->ts.kind);
- }
+ /* If source is longer than the destination, use a pointer to
+ the source directly. */
+ gfc_init_block (&block);
+ gfc_add_modify (&block, tmpdecl, ptr);
+ direct = gfc_finish_block (&block);
- if (expr->ts.type == BT_CHARACTER)
- {
- ptr = convert (build_pointer_type (type), ptr);
- gfc_init_se (&argse, NULL);
- gfc_conv_expr (&argse, arg->expr);
- gfc_add_block_to_block (&se->pre, &argse.pre);
- gfc_add_block_to_block (&se->post, &argse.post);
- se->expr = ptr;
- se->string_length = argse.string_length;
+ /* Otherwise, allocate a string with the length of the destination
+ and copy the source into it. */
+ gfc_init_block (&block);
+ tmp = gfc_get_pchar_type (expr->ts.kind);
+ tmp = gfc_call_malloc (&block, tmp, dest_word_len);
+ gfc_add_modify (&block, tmpdecl,
+ fold_convert (TREE_TYPE (ptr), tmp));
+ tmp = build_call_expr (built_in_decls[BUILT_IN_MEMCPY], 3,
+ fold_convert (pvoid_type_node, tmpdecl),
+ fold_convert (pvoid_type_node, ptr),
+ extent);
+ gfc_add_expr_to_block (&block, tmp);
+ indirect = gfc_finish_block (&block);
+
+ /* Wrap it up with the condition. */
+ tmp = fold_build2 (LE_EXPR, boolean_type_node,
+ dest_word_len, source_bytes);
+ tmp = build3_v (COND_EXPR, tmp, direct, indirect);
+ gfc_add_expr_to_block (&se->pre, tmp);
+
+ se->expr = tmpdecl;
+ se->string_length = dest_word_len;
}
else
{
- tree moldsize;
- tmpdecl = gfc_create_var (type, "transfer");
- moldsize = size_in_bytes (type);
+ tmpdecl = gfc_create_var (mold_type, "transfer");
+
+ ptr = convert (build_pointer_type (mold_type), source);
/* Use memcpy to do the transfer. */
tmp = build_fold_addr_expr (tmpdecl);
tmp = build_call_expr (built_in_decls[BUILT_IN_MEMCPY], 3,
fold_convert (pvoid_type_node, tmp),
fold_convert (pvoid_type_node, ptr),
- moldsize);
+ extent);
gfc_add_expr_to_block (&se->pre, tmp);
se->expr = tmpdecl;
gfc_advance_se_ss_chain (se);
}
else
- {
- /* Ensure double transfer through LOGICAL preserves all
- the needed bits. */
- gfc_expr *source = expr->value.function.actual->expr;
- if (source->expr_type == EXPR_FUNCTION
- && source->value.function.esym == NULL
- && source->value.function.isym != NULL
- && source->value.function.isym->id == GFC_ISYM_TRANSFER
- && source->ts.type == BT_LOGICAL
- && expr->ts.type != source->ts.type)
- source->value.function.name = "__transfer_in_transfer";
-
- if (se->ss)
- gfc_conv_intrinsic_array_transfer (se, expr);
- else
- gfc_conv_intrinsic_transfer (se, expr);
- }
+ gfc_conv_intrinsic_transfer (se, expr);
break;
case GFC_ISYM_TTYNAM:
projects / thirdparty / gcc.git / commitdiff
