aboutsummaryrefslogtreecommitdiff
path: root/gcc
diff options
context:
space:
mode:
Diffstat (limited to 'gcc')
-rw-r--r--gcc/fortran/trans-array.c3
-rw-r--r--gcc/fortran/trans-expr.c144
2 files changed, 108 insertions, 39 deletions
diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c
index 6dc33d3..047f8bc 100644
--- a/gcc/fortran/trans-array.c
+++ b/gcc/fortran/trans-array.c
@@ -2342,7 +2342,7 @@ gfc_conv_resolve_dependencies (gfc_loopinfo * loop, gfc_ss * dest,
loop->temp_ss->type = GFC_SS_TEMP;
loop->temp_ss->data.temp.type =
gfc_get_element_type (TREE_TYPE (dest->data.info.descriptor));
- loop->temp_ss->string_length = NULL_TREE;
+ loop->temp_ss->string_length = dest->string_length;
loop->temp_ss->data.temp.dimen = loop->dimen;
loop->temp_ss->next = gfc_ss_terminator;
gfc_add_ss_to_loop (loop, loop->temp_ss);
@@ -3617,6 +3617,7 @@ gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss)
loop.temp_ss->type = GFC_SS_TEMP;
loop.temp_ss->next = gfc_ss_terminator;
loop.temp_ss->data.temp.type = gfc_typenode_for_spec (&expr->ts);
+
/* ... which can hold our string, if present. */
if (expr->ts.type == BT_CHARACTER)
se->string_length = loop.temp_ss->string_length
diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index 52a532d..c04efd2 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -354,30 +354,43 @@ gfc_conv_variable (gfc_se * se, gfc_expr * expr)
se->expr = gfc_build_addr_expr (NULL, se->expr);
}
return;
- }
-
- /* Dereference scalar dummy variables. */
- if (sym->attr.dummy
- && sym->ts.type != BT_CHARACTER
- && !sym->attr.dimension)
- se->expr = gfc_build_indirect_ref (se->expr);
-
- /* Dereference scalar hidden result. */
- if (gfc_option.flag_f2c
- && (sym->attr.function || sym->attr.result)
- && sym->ts.type == BT_COMPLEX
- && !sym->attr.dimension)
- se->expr = gfc_build_indirect_ref (se->expr);
-
- /* Dereference pointer variables. */
- if ((sym->attr.pointer || sym->attr.allocatable)
- && (sym->attr.dummy
- || sym->attr.result
- || sym->attr.function
- || !sym->attr.dimension)
- && sym->ts.type != BT_CHARACTER)
- se->expr = gfc_build_indirect_ref (se->expr);
-
+ }
+
+
+ /* Dereference the expression, where needed. Since characters
+ are entirely different from other types, they are treated
+ separately. */
+ if (sym->ts.type == BT_CHARACTER)
+ {
+ /* Dereference character pointer dummy arguments
+ or results. */
+ if ((sym->attr.pointer || sym->attr.allocatable)
+ && ((sym->attr.dummy)
+ || (sym->attr.function
+ || sym->attr.result)))
+ se->expr = gfc_build_indirect_ref (se->expr);
+ }
+ else
+ {
+ /* Dereference non-charcter scalar dummy arguments. */
+ if ((sym->attr.dummy) && (!sym->attr.dimension))
+ se->expr = gfc_build_indirect_ref (se->expr);
+
+ /* Dereference scalar hidden result. */
+ if ((gfc_option.flag_f2c && sym->ts.type == BT_COMPLEX)
+ && (sym->attr.function || sym->attr.result)
+ && (!sym->attr.dimension))
+ se->expr = gfc_build_indirect_ref (se->expr);
+
+ /* Dereference non-character pointer variables.
+ These must be dummys or results or scalars. */
+ if ((sym->attr.pointer || sym->attr.allocatable)
+ && ((sym->attr.dummy)
+ || (sym->attr.function || sym->attr.result)
+ || (!sym->attr.dimension)))
+ se->expr = gfc_build_indirect_ref (se->expr);
+ }
+
ref = expr->ref;
}
@@ -1083,6 +1096,15 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
var = NULL_TREE;
len = NULL_TREE;
+ /* Obtain the string length now because it is needed often below. */
+ if (sym->ts.type == BT_CHARACTER)
+ {
+ gcc_assert (sym->ts.cl && sym->ts.cl->length
+ && sym->ts.cl->length->expr_type == EXPR_CONSTANT);
+ len = gfc_conv_mpz_to_tree
+ (sym->ts.cl->length->value.integer, sym->ts.cl->length->ts.kind);
+ }
+
if (se->ss != NULL)
{
if (!sym->attr.elemental)
@@ -1097,6 +1119,9 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
/* Access the previously obtained result. */
gfc_conv_tmp_array_ref (se);
gfc_advance_se_ss_chain (se);
+
+ /* Bundle in the string length. */
+ se->string_length=len;
return;
}
}
@@ -1108,14 +1133,26 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
byref = gfc_return_by_reference (sym);
if (byref)
{
- if (se->direct_byref)
- arglist = gfc_chainon_list (arglist, se->expr);
+ if (se->direct_byref)
+ {
+ arglist = gfc_chainon_list (arglist, se->expr);
+
+ /* Add string length to argument list. */
+ if (sym->ts.type == BT_CHARACTER)
+ {
+ sym->ts.cl->backend_decl = len;
+ arglist = gfc_chainon_list (arglist,
+ convert (gfc_charlen_type_node, len));
+ }
+ }
else if (sym->result->attr.dimension)
{
- gcc_assert (se->loop && se->ss);
+ gcc_assert (se->loop && se->ss);
+
/* Set the type of the array. */
tmp = gfc_typenode_for_spec (&sym->ts);
- info->dimen = se->loop->dimen;
+ info->dimen = se->loop->dimen;
+
/* Allocate a temporary to store the result. */
gfc_trans_allocate_temp_array (se->loop, info, tmp);
@@ -1124,22 +1161,46 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
gfc_conv_descriptor_stride (info->descriptor, gfc_rank_cst[0]);
gfc_add_modify_expr (&se->pre, tmp,
convert (TREE_TYPE (tmp), integer_zero_node));
+
/* Pass the temporary as the first argument. */
tmp = info->descriptor;
tmp = gfc_build_addr_expr (NULL, tmp);
arglist = gfc_chainon_list (arglist, tmp);
+
+ /* Add string length to argument list. */
+ if (sym->ts.type == BT_CHARACTER)
+ {
+ sym->ts.cl->backend_decl = len;
+ arglist = gfc_chainon_list (arglist,
+ convert (gfc_charlen_type_node, len));
+ }
+
}
else if (sym->ts.type == BT_CHARACTER)
{
- gcc_assert (sym->ts.cl && sym->ts.cl->length
- && sym->ts.cl->length->expr_type == EXPR_CONSTANT);
- len = gfc_conv_mpz_to_tree
- (sym->ts.cl->length->value.integer, sym->ts.cl->length->ts.kind);
+
+ /* Pass the string length. */
sym->ts.cl->backend_decl = len;
type = gfc_get_character_type (sym->ts.kind, sym->ts.cl);
type = build_pointer_type (type);
- var = gfc_conv_string_tmp (se, type, len);
+ /* Return an address to a char[4]* temporary for character pointers. */
+ if (sym->attr.pointer || sym->attr.allocatable)
+ {
+ /* Build char[4] * pstr. */
+ tmp = fold_build2 (MINUS_EXPR, gfc_charlen_type_node, len,
+ convert (gfc_charlen_type_node, integer_one_node));
+ tmp = build_range_type (gfc_array_index_type, gfc_index_zero_node, tmp);
+ tmp = build_array_type (gfc_character1_type_node, tmp);
+ var = gfc_create_var (build_pointer_type (tmp), "pstr");
+
+ /* Provide an address expression for the function arguments. */
+ var = gfc_build_addr_expr (NULL, var);
+ }
+ else
+ {
+ var = gfc_conv_string_tmp (se, type, len);
+ }
arglist = gfc_chainon_list (arglist, var);
arglist = gfc_chainon_list (arglist,
convert (gfc_charlen_type_node, len));
@@ -1205,8 +1266,8 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
&& arg->expr->expr_type != EXPR_NULL)
{
/* Scalar pointer dummy args require an extra level of
- indirection. The null pointer already contains
- this level of indirection. */
+ indirection. The null pointer already contains
+ this level of indirection. */
parmse.expr = gfc_build_addr_expr (NULL, parmse.expr);
}
}
@@ -1299,10 +1360,17 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
gfc_trans_runtime_check (tmp, gfc_strconst_fault, &se->pre);
}
se->expr = info->descriptor;
+ /* Bundle in the string length. */
+ se->string_length = len;
}
else if (sym->ts.type == BT_CHARACTER)
- {
- se->expr = var;
+ {
+ /* Dereference for character pointer results. */
+ if (sym->attr.pointer || sym->attr.allocatable)
+ se->expr = gfc_build_indirect_ref (var);
+ else
+ se->expr = var;
+
se->string_length = len;
}
else
@@ -2229,7 +2297,7 @@ gfc_trans_assignment (gfc_expr * expr1, gfc_expr * expr2)
}
else
gfc_conv_expr (&lse, expr1);
-
+
tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts.type);
gfc_add_expr_to_block (&body, tmp);
generated by cgit v1.1 at 2025-05-28 04:50:08 +0000