aboutsummaryrefslogtreecommitdiff
path: root/gcc/fortran/trans-expr.c
diff options
context:
space:
mode:
Diffstat (limited to 'gcc/fortran/trans-expr.c')
-rw-r--r--gcc/fortran/trans-expr.c161
1 files changed, 122 insertions, 39 deletions
diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index 563e840..482e8b1 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -977,7 +977,7 @@ gfc_conv_string_tmp (gfc_se * se, tree type, tree len)
tmp = fold_build2 (MINUS_EXPR, gfc_charlen_type_node, len,
build_int_cst (gfc_charlen_type_node, 1));
tmp = build_range_type (gfc_array_index_type, gfc_index_zero_node, tmp);
- tmp = build_array_type (gfc_character1_type_node, tmp);
+ tmp = build_array_type (TREE_TYPE (TREE_TYPE (type)), tmp);
var = gfc_create_var (tmp, "str");
var = gfc_build_addr_expr (type, var);
}
@@ -985,7 +985,10 @@ gfc_conv_string_tmp (gfc_se * se, tree type, tree len)
{
/* Allocate a temporary to hold the result. */
var = gfc_create_var (type, "pstr");
- tmp = gfc_call_malloc (&se->pre, type, len);
+ tmp = gfc_call_malloc (&se->pre, type,
+ fold_build2 (MULT_EXPR, TREE_TYPE (len), len,
+ fold_convert (TREE_TYPE (len),
+ TYPE_SIZE (type))));
gfc_add_modify_expr (&se->pre, var, tmp);
/* Free the temporary afterwards. */
@@ -1008,6 +1011,7 @@ gfc_conv_concat_op (gfc_se * se, gfc_expr * expr)
gcc_assert (expr->value.op.op1->ts.type == BT_CHARACTER
&& expr->value.op.op2->ts.type == BT_CHARACTER);
+ gcc_assert (expr->value.op.op1->ts.kind == expr->value.op.op2->ts.kind);
gfc_init_se (&lse, se);
gfc_conv_expr (&lse, expr->value.op.op1);
@@ -1238,14 +1242,14 @@ gfc_conv_expr_op (gfc_se * se, gfc_expr * expr)
/* If a string's length is one, we convert it to a single character. */
static tree
-gfc_to_single_character (tree len, tree str)
+string_to_single_character (tree len, tree str, int kind)
{
gcc_assert (POINTER_TYPE_P (TREE_TYPE (str)));
if (INTEGER_CST_P (len) && TREE_INT_CST_LOW (len) == 1
- && TREE_INT_CST_HIGH (len) == 0)
+ && TREE_INT_CST_HIGH (len) == 0)
{
- str = fold_convert (pchar_type_node, str);
+ str = fold_convert (gfc_get_pchar_type (kind), str);
return build_fold_indirect_ref (str);
}
@@ -1293,18 +1297,21 @@ gfc_conv_scalar_char_value (gfc_symbol *sym, gfc_se *se, gfc_expr **expr)
{
if ((*expr)->ref == NULL)
{
- se->expr = gfc_to_single_character
+ se->expr = string_to_single_character
(build_int_cst (integer_type_node, 1),
- gfc_build_addr_expr (pchar_type_node,
+ gfc_build_addr_expr (gfc_get_pchar_type ((*expr)->ts.kind),
gfc_get_symbol_decl
- ((*expr)->symtree->n.sym)));
+ ((*expr)->symtree->n.sym)),
+ (*expr)->ts.kind);
}
else
{
gfc_conv_variable (se, *expr);
- se->expr = gfc_to_single_character
+ se->expr = string_to_single_character
(build_int_cst (integer_type_node, 1),
- gfc_build_addr_expr (pchar_type_node, se->expr));
+ gfc_build_addr_expr (gfc_get_pchar_type ((*expr)->ts.kind),
+ se->expr),
+ (*expr)->ts.kind);
}
}
}
@@ -1324,8 +1331,8 @@ gfc_build_compare_string (tree len1, tree str1, tree len2, tree str2, int kind)
gcc_assert (POINTER_TYPE_P (TREE_TYPE (str1)));
gcc_assert (POINTER_TYPE_P (TREE_TYPE (str2)));
- sc1 = gfc_to_single_character (len1, str1);
- sc2 = gfc_to_single_character (len2, str2);
+ sc1 = string_to_single_character (len1, str1, kind);
+ sc2 = string_to_single_character (len2, str2, kind);
if (sc1 != NULL_TREE && sc2 != NULL_TREE)
{
@@ -2827,11 +2834,77 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
}
+/* Fill a character string with spaces. */
+
+static tree
+fill_with_spaces (tree start, tree type, tree size)
+{
+ stmtblock_t block, loop;
+ tree i, el, exit_label, cond, tmp;
+
+ /* For a simple char type, we can call memset(). */
+ if (compare_tree_int (TYPE_SIZE_UNIT (type), 1) == 0)
+ return build_call_expr (built_in_decls[BUILT_IN_MEMSET], 3, start,
+ build_int_cst (gfc_get_int_type (gfc_c_int_kind),
+ lang_hooks.to_target_charset (' ')),
+ size);
+
+ /* Otherwise, we use a loop:
+ for (el = start, i = size; i > 0; el--, i+= TYPE_SIZE_UNIT (type))
+ *el = (type) ' ';
+ */
+
+ /* Initialize variables. */
+ gfc_init_block (&block);
+ i = gfc_create_var (sizetype, "i");
+ gfc_add_modify_expr (&block, i, fold_convert (sizetype, size));
+ el = gfc_create_var (build_pointer_type (type), "el");
+ gfc_add_modify_expr (&block, el, fold_convert (TREE_TYPE (el), start));
+ exit_label = gfc_build_label_decl (NULL_TREE);
+ TREE_USED (exit_label) = 1;
+
+
+ /* Loop body. */
+ gfc_init_block (&loop);
+
+ /* Exit condition. */
+ cond = fold_build2 (LE_EXPR, boolean_type_node, i,
+ fold_convert (sizetype, integer_zero_node));
+ tmp = build1_v (GOTO_EXPR, exit_label);
+ tmp = fold_build3 (COND_EXPR, void_type_node, cond, tmp, build_empty_stmt ());
+ gfc_add_expr_to_block (&loop, tmp);
+
+ /* Assignment. */
+ gfc_add_modify_expr (&loop, fold_build1 (INDIRECT_REF, type, el),
+ build_int_cst (type,
+ lang_hooks.to_target_charset (' ')));
+
+ /* Increment loop variables. */
+ gfc_add_modify_expr (&loop, i, fold_build2 (MINUS_EXPR, sizetype, i,
+ TYPE_SIZE_UNIT (type)));
+ gfc_add_modify_expr (&loop, el, fold_build2 (POINTER_PLUS_EXPR,
+ TREE_TYPE (el), el,
+ TYPE_SIZE_UNIT (type)));
+
+ /* Making the loop... actually loop! */
+ tmp = gfc_finish_block (&loop);
+ tmp = build1_v (LOOP_EXPR, tmp);
+ gfc_add_expr_to_block (&block, tmp);
+
+ /* The exit label. */
+ tmp = build1_v (LABEL_EXPR, exit_label);
+ gfc_add_expr_to_block (&block, tmp);
+
+
+ return gfc_finish_block (&block);
+}
+
+
/* Generate code to copy a string. */
void
gfc_trans_string_copy (stmtblock_t * block, tree dlength, tree dest,
- tree slength, tree src)
+ int dkind, tree slength, tree src, int skind)
{
tree tmp, dlen, slen;
tree dsc;
@@ -2841,12 +2914,15 @@ gfc_trans_string_copy (stmtblock_t * block, tree dlength, tree dest,
tree tmp2;
tree tmp3;
tree tmp4;
+ tree chartype;
stmtblock_t tempblock;
+ gcc_assert (dkind == skind);
+
if (slength != NULL_TREE)
{
slen = fold_convert (size_type_node, gfc_evaluate_now (slength, block));
- ssc = gfc_to_single_character (slen, src);
+ ssc = string_to_single_character (slen, src, skind);
}
else
{
@@ -2857,7 +2933,7 @@ gfc_trans_string_copy (stmtblock_t * block, tree dlength, tree dest,
if (dlength != NULL_TREE)
{
dlen = fold_convert (size_type_node, gfc_evaluate_now (dlength, block));
- dsc = gfc_to_single_character (slen, dest);
+ dsc = string_to_single_character (slen, dest, dkind);
}
else
{
@@ -2866,14 +2942,14 @@ gfc_trans_string_copy (stmtblock_t * block, tree dlength, tree dest,
}
if (slength != NULL_TREE && POINTER_TYPE_P (TREE_TYPE (src)))
- ssc = gfc_to_single_character (slen, src);
+ ssc = string_to_single_character (slen, src, skind);
if (dlength != NULL_TREE && POINTER_TYPE_P (TREE_TYPE (dest)))
- dsc = gfc_to_single_character (dlen, dest);
+ dsc = string_to_single_character (dlen, dest, dkind);
/* Assign directly if the types are compatible. */
if (dsc != NULL_TREE && ssc != NULL_TREE
- && TREE_TYPE (dsc) == TREE_TYPE (ssc))
+ && TREE_TYPE (dsc) == TREE_TYPE (ssc))
{
gfc_add_modify_expr (block, dsc, ssc);
return;
@@ -2906,6 +2982,14 @@ gfc_trans_string_copy (stmtblock_t * block, tree dlength, tree dest,
We're now doing it here for better optimization, but the logic
is the same. */
+ /* For non-default character kinds, we have to multiply the string
+ length by the base type size. */
+ chartype = gfc_get_char_type (dkind);
+ slen = fold_build2 (MULT_EXPR, size_type_node, slen,
+ TYPE_SIZE_UNIT (chartype));
+ dlen = fold_build2 (MULT_EXPR, size_type_node, dlen,
+ TYPE_SIZE_UNIT (chartype));
+
if (dlength)
dest = fold_convert (pvoid_type_node, dest);
else
@@ -2927,12 +3011,9 @@ gfc_trans_string_copy (stmtblock_t * block, tree dlength, tree dest,
tmp4 = fold_build2 (POINTER_PLUS_EXPR, TREE_TYPE (dest), dest,
fold_convert (sizetype, slen));
- tmp4 = build_call_expr (built_in_decls[BUILT_IN_MEMSET], 3,
- tmp4,
- build_int_cst (gfc_get_int_type (gfc_c_int_kind),
- lang_hooks.to_target_charset (' ')),
- fold_build2 (MINUS_EXPR, TREE_TYPE(dlen),
- dlen, slen));
+ tmp4 = fill_with_spaces (tmp4, chartype,
+ fold_build2 (MINUS_EXPR, TREE_TYPE(dlen),
+ dlen, slen));
gfc_init_block (&tempblock);
gfc_add_expr_to_block (&tempblock, tmp3);
@@ -2994,7 +3075,7 @@ gfc_conv_statement_function (gfc_se * se, gfc_expr * expr)
tree arglen;
gcc_assert (fsym->ts.cl && fsym->ts.cl->length
- && fsym->ts.cl->length->expr_type == EXPR_CONSTANT);
+ && fsym->ts.cl->length->expr_type == EXPR_CONSTANT);
arglen = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
tmp = gfc_build_addr_expr (build_pointer_type (type),
@@ -3005,8 +3086,8 @@ gfc_conv_statement_function (gfc_se * se, gfc_expr * expr)
gfc_add_block_to_block (&se->pre, &lse.pre);
gfc_add_block_to_block (&se->pre, &rse.pre);
- gfc_trans_string_copy (&se->pre, arglen, tmp, rse.string_length,
- rse.expr);
+ gfc_trans_string_copy (&se->pre, arglen, tmp, fsym->ts.kind,
+ rse.string_length, rse.expr, fsym->ts.kind);
gfc_add_block_to_block (&se->pre, &lse.post);
gfc_add_block_to_block (&se->pre, &rse.post);
}
@@ -3042,7 +3123,8 @@ gfc_conv_statement_function (gfc_se * se, gfc_expr * expr)
tmp = gfc_create_var (type, sym->name);
tmp = gfc_build_addr_expr (build_pointer_type (type), tmp);
gfc_trans_string_copy (&se->pre, sym->ts.cl->backend_decl, tmp,
- se->string_length, se->expr);
+ sym->ts.kind, se->string_length, se->expr,
+ sym->ts.kind);
se->expr = tmp;
}
se->string_length = sym->ts.cl->backend_decl;
@@ -3501,17 +3583,14 @@ static void
gfc_conv_substring_expr (gfc_se * se, gfc_expr * expr)
{
gfc_ref *ref;
- char *s;
ref = expr->ref;
gcc_assert (ref == NULL || ref->type == REF_SUBSTRING);
- gcc_assert (expr->ts.kind == gfc_default_character_kind);
- s = gfc_widechar_to_char (expr->value.character.string,
- expr->value.character.length);
- se->expr = gfc_build_string_const (expr->value.character.length, s);
- gfc_free (s);
+ se->expr = gfc_build_wide_string_const (expr->ts.kind,
+ expr->value.character.length,
+ expr->value.character.string);
se->string_length = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se->expr)));
TYPE_STRING_FLAG (TREE_TYPE (se->expr)) = 1;
@@ -3824,15 +3903,18 @@ gfc_conv_string_parameter (gfc_se * se)
if (TREE_CODE (se->expr) == STRING_CST)
{
- se->expr = gfc_build_addr_expr (pchar_type_node, se->expr);
+ type = TREE_TYPE (TREE_TYPE (se->expr));
+ se->expr = gfc_build_addr_expr (build_pointer_type (type), se->expr);
return;
}
- type = TREE_TYPE (se->expr);
- if (TYPE_STRING_FLAG (type))
+ if (TYPE_STRING_FLAG (TREE_TYPE (se->expr)))
{
if (TREE_CODE (se->expr) != INDIRECT_REF)
- se->expr = gfc_build_addr_expr (pchar_type_node, se->expr);
+ {
+ type = TREE_TYPE (se->expr);
+ se->expr = gfc_build_addr_expr (build_pointer_type (type), se->expr);
+ }
else
{
type = gfc_get_character_type_len (gfc_default_character_kind,
@@ -3881,7 +3963,8 @@ gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, gfc_typespec ts,
rlen = rse->string_length;
}
- gfc_trans_string_copy (&block, llen, lse->expr, rlen, rse->expr);
+ gfc_trans_string_copy (&block, llen, lse->expr, ts.kind, rlen,
+ rse->expr, ts.kind);
}
else if (ts.type == BT_DERIVED && ts.derived->attr.alloc_comp)
{
generated by cgit v1.1 at 2025-04-29 09:45:08 +0000