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);
-
+ }\r
+
+\r
+ /* Dereference the expression, where needed. Since characters\r
+ are entirely different from other types, they are treated \r
+ separately. */\r
+ if (sym->ts.type == BT_CHARACTER)\r
+ {\r
+ /* Dereference character pointer dummy arguments\r
+ or results. */
+ if ((sym->attr.pointer || sym->attr.allocatable)\r
+ && ((sym->attr.dummy)\r
+ || (sym->attr.function\r
+ || sym->attr.result)))\r
+ se->expr = gfc_build_indirect_ref (se->expr);\r
+ }\r
+ else\r
+ {\r
+ /* Dereference non-charcter scalar dummy arguments. */
+ if ((sym->attr.dummy) && (!sym->attr.dimension))\r
+ se->expr = gfc_build_indirect_ref (se->expr);\r
+\r
+ /* Dereference scalar hidden result. */
+ if ((gfc_option.flag_f2c && sym->ts.type == BT_COMPLEX)\r
+ && (sym->attr.function || sym->attr.result)\r
+ && (!sym->attr.dimension))\r
+ se->expr = gfc_build_indirect_ref (se->expr);\r
+\r
+ /* Dereference non-character pointer variables. \r
+ These must be dummys or results or scalars. */
+ if ((sym->attr.pointer || sym->attr.allocatable)\r
+ && ((sym->attr.dummy) \r
+ || (sym->attr.function || sym->attr.result)\r
+ || (!sym->attr.dimension)))\r
+ se->expr = gfc_build_indirect_ref (se->expr);\r
+ }\r
+\r
ref = expr->ref;
}
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)
/* 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;
}
}
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);
+\r
+ /* Add string length to argument list. */\r
+ 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);\r
+
/* Set the type of the array. */
tmp = gfc_typenode_for_spec (&sym->ts);
- info->dimen = se->loop->dimen;
+ info->dimen = se->loop->dimen;\r
+
/* Allocate a temporary to store the result. */
gfc_trans_allocate_temp_array (se->loop, info, tmp);
gfc_conv_descriptor_stride (info->descriptor, gfc_rank_cst[0]);
gfc_add_modify_expr (&se->pre, tmp,
convert (TREE_TYPE (tmp), integer_zero_node));
+\r
/* 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);
+\r
+ /* Pass the string length. */\r
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,\r
+ convert (gfc_charlen_type_node, integer_one_node));\r
+ tmp = build_range_type (gfc_array_index_type, gfc_index_zero_node, tmp);\r
+ tmp = build_array_type (gfc_character1_type_node, tmp);\r
+ var = gfc_create_var (build_pointer_type (tmp), "pstr");
+
+ /* Provide an address expression for the function arguments. */\r
+ var = gfc_build_addr_expr (NULL, var);\r
+ }
+ else
+ {
+ var = gfc_conv_string_tmp (se, type, len);\r
+ }
arglist = gfc_chainon_list (arglist, var);
arglist = gfc_chainon_list (arglist,
convert (gfc_charlen_type_node, len));
&& 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);
}
}
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;
+ {\r
+ /* Dereference for character pointer results. */
+ if (sym->attr.pointer || sym->attr.allocatable)
+ se->expr = gfc_build_indirect_ref (var);\r
+ else\r
+ se->expr = var;
+
se->string_length = len;
}
else
}
else
gfc_conv_expr (&lse, expr1);
-
+\r
tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts.type);
gfc_add_expr_to_block (&body, tmp);