OpenE2K
/
gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

re PR fortran/17144 (Not Implemented: Character string array constructors / Assignment to char array) 

PR fortran/17144
	* trans-array.c (gfc_trans_allocate_temp_array): Remove
	string_length argument.
	(gfc_trans_array_ctor_element): New function.
	(gfc_trans_array_constructor_subarray): Use it.
	(gfc_trans_array_constructor_value): Ditto.  Handle constant
	character arrays.
	(get_array_ctor_var_strlen, get_array_ctor_strlen): New functions.
	(gfc_trans_array_constructor): Use them.
	(gfc_add_loop_ss_code): Update to new gfc_ss layout.
	(gfc_conv_ss_descriptor): Remember section string length.
	(gfc_conv_scalarized_array_ref): Ditto.  Remove dead code.
	(gfc_conv_resolve_dependencies): Update to new gfc_ss layout.
	(gfc_conv_expr_descriptor): Ditto.
	(gfc_conv_loop_setup): Ditto.  Spelling fixes.
	* trans-array.h (gfc_trans_allocate_temp_array): Update prototype.
	* trans-const.c (gfc_conv_constant):  Update to new gfc_ss layout.
	* trans-expr.c (gfc_conv_component_ref): Turn error into ICE.
	(gfc_conv_variable): Set string_length from section.
	(gfc_conv_function_call): Remove extra argument.
	(gfc_conv_expr, gfc_conv_expr_reference): Update to new gfc_ss layout.
	* trans-types.c (gfc_get_character_type_len): New function.
	(gfc_get_character_type): Use it.
	(gfc_get_dtype): Return zero for internal types.
	* trans-types.h (gfc_get_character_type_len): Add prototype.
	* trans.h (struct gfc_ss): Move string_length out of union.
testsuite/
	* gfortran.dg/string_ctor_1.f90: New test.

From-SVN: r86558
This commit is contained in:
Paul Brook 2004-08-25 16:50:13 +00:00 committed by Paul Brook
parent 923ab88cb2
commit 40f201864f
10 changed files with 292 additions and 60 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

29
gcc/fortran/ChangeLog
View File

@ -1,3 +1,32 @@
2004-08-25 Paul Brook <paul@codesourcery.com>
PR fortran/17144
* trans-array.c (gfc_trans_allocate_temp_array): Remove
string_length argument.
(gfc_trans_array_ctor_element): New function.
(gfc_trans_array_constructor_subarray): Use it.
(gfc_trans_array_constructor_value): Ditto. Handle constant
character arrays.
(get_array_ctor_var_strlen, get_array_ctor_strlen): New functions.
(gfc_trans_array_constructor): Use them.
(gfc_add_loop_ss_code): Update to new gfc_ss layout.
(gfc_conv_ss_descriptor): Remember section string length.
(gfc_conv_scalarized_array_ref): Ditto. Remove dead code.
(gfc_conv_resolve_dependencies): Update to new gfc_ss layout.
(gfc_conv_expr_descriptor): Ditto.
(gfc_conv_loop_setup): Ditto. Spelling fixes.
* trans-array.h (gfc_trans_allocate_temp_array): Update prototype.
* trans-const.c (gfc_conv_constant): Update to new gfc_ss layout.
* trans-expr.c (gfc_conv_component_ref): Turn error into ICE.
(gfc_conv_variable): Set string_length from section.
(gfc_conv_function_call): Remove extra argument.
(gfc_conv_expr, gfc_conv_expr_reference): Update to new gfc_ss layout.
* trans-types.c (gfc_get_character_type_len): New function.
(gfc_get_character_type): Use it.
(gfc_get_dtype): Return zero for internal types.
* trans-types.h (gfc_get_character_type_len): Add prototype.
* trans.h (struct gfc_ss): Move string_length out of union.
2004-08-25 Tobias Schlueter <tobias.schlueter@physik.uni-muenchen.de>
* trans.h (build2_v, build3_v): New macros.

219
gcc/fortran/trans-array.c
View File

@ -527,7 +527,7 @@ gfc_trans_allocate_array_storage (gfc_loopinfo * loop, gfc_ss_info * info,
tree
gfc_trans_allocate_temp_array (gfc_loopinfo * loop, gfc_ss_info * info,
tree eltype, tree string_length)
tree eltype)
{
tree type;
tree desc;
@ -617,10 +617,6 @@ gfc_trans_allocate_temp_array (gfc_loopinfo * loop, gfc_ss_info * info,
size = gfc_evaluate_now (size, &loop->pre);
}
/* TODO: Where does the string length go? */
if (string_length)
gfc_todo_error ("temporary arrays of strings");
/* Get the size of the array. */
nelem = size;
if (size)
@ -651,6 +647,55 @@ gfc_put_offset_into_var (stmtblock_t * pblock, tree * poffset,
}
/* Assign an element of an array constructor. */
static void
gfc_trans_array_ctor_element (stmtblock_t * pblock, tree pointer,
tree offset, gfc_se * se, gfc_expr * expr)
{
tree tmp;
tree args;
gfc_conv_expr (se, expr);
/* Store the value. */
tmp = gfc_build_indirect_ref (pointer);
tmp = gfc_build_array_ref (tmp, offset);
if (expr->ts.type == BT_CHARACTER)
{
gfc_conv_string_parameter (se);
if (POINTER_TYPE_P (TREE_TYPE (tmp)))
{
/* The temporary is an array of pointers. */
se->expr = fold_convert (TREE_TYPE (tmp), se->expr);
gfc_add_modify_expr (&se->pre, tmp, se->expr);
}
else
{
/* The temporary is an array of string values. */
tmp = gfc_build_addr_expr (pchar_type_node, tmp);
/* We know the temporary and the value will be the same length,
so can use memcpy. */
args = gfc_chainon_list (NULL_TREE, tmp);
args = gfc_chainon_list (args, se->expr);
args = gfc_chainon_list (args, se->string_length);
tmp = built_in_decls[BUILT_IN_MEMCPY];
tmp = gfc_build_function_call (tmp, args);
gfc_add_expr_to_block (&se->pre, tmp);
}
}
else
{
/* TODO: Should the frontend already have done this conversion? */
se->expr = fold_convert (TREE_TYPE (tmp), se->expr);
gfc_add_modify_expr (&se->pre, tmp, se->expr);
}
gfc_add_block_to_block (pblock, &se->pre);
gfc_add_block_to_block (pblock, &se->post);
}
/* Add the contents of an array to the constructor. */
static void
@ -688,21 +733,17 @@ gfc_trans_array_constructor_subarray (stmtblock_t * pblock,
gfc_copy_loopinfo_to_se (&se, &loop);
se.ss = ss;
gfc_conv_expr (&se, expr);
gfc_add_block_to_block (&body, &se.pre);
if (expr->ts.type == BT_CHARACTER)
gfc_todo_error ("character arrays in constructors");
/* Store the value. */
tmp = gfc_build_indirect_ref (pointer);
tmp = gfc_build_array_ref (tmp, *poffset);
gfc_add_modify_expr (&body, tmp, se.expr);
gfc_trans_array_ctor_element (&body, pointer, *poffset, &se, expr);
assert (se.ss == gfc_ss_terminator);
/* Increment the offset. */
tmp = build2 (PLUS_EXPR, gfc_array_index_type, *poffset, gfc_index_one_node);
gfc_add_modify_expr (&body, *poffset, tmp);
/* Finish the loop. */
gfc_add_block_to_block (&body, &se.post);
assert (se.ss == gfc_ss_terminator);
gfc_trans_scalarizing_loops (&loop, &body);
gfc_add_block_to_block (&loop.pre, &loop.post);
tmp = gfc_finish_block (&loop.pre);
@ -720,7 +761,6 @@ gfc_trans_array_constructor_value (stmtblock_t * pblock, tree type,
tree * poffset, tree * offsetvar)
{
tree tmp;
tree ref;
stmtblock_t body;
tree loopbody;
gfc_se se;
@ -763,14 +803,8 @@ gfc_trans_array_constructor_value (stmtblock_t * pblock, tree type,
{
/* Scalar values. */
gfc_init_se (&se, NULL);
gfc_conv_expr (&se, c->expr);
gfc_add_block_to_block (&body, &se.pre);
ref = gfc_build_indirect_ref (pointer);
ref = gfc_build_array_ref (ref, *poffset);
gfc_add_modify_expr (&body, ref,
fold_convert (TREE_TYPE (ref), se.expr));
gfc_add_block_to_block (&body, &se.post);
gfc_trans_array_ctor_element (&body, pointer, *poffset, &se,
c->expr);
*poffset = fold (build2 (PLUS_EXPR, gfc_array_index_type,
*poffset, gfc_index_one_node));
@ -791,6 +825,16 @@ gfc_trans_array_constructor_value (stmtblock_t * pblock, tree type,
{
gfc_init_se (&se, NULL);
gfc_conv_constant (&se, p->expr);
if (p->expr->ts.type == BT_CHARACTER
&& POINTER_TYPE_P (TREE_TYPE (TREE_TYPE
(TREE_TYPE (pointer)))))
{
/* For constant character array constructors we build
an array of pointers. */
se.expr = gfc_build_addr_expr (pchar_type_node,
se.expr);
}
list = tree_cons (NULL_TREE, se.expr, list);
c = p;
p = p->next;
@ -974,6 +1018,86 @@ gfc_get_array_cons_size (mpz_t * size, gfc_constructor * c)
}
/* Figure out the string length of a variable reference expression.
Used by get_array_ctor_strlen. */
static void
get_array_ctor_var_strlen (gfc_expr * expr, tree * len)
{
gfc_ref *ref;
gfc_typespec *ts;
/* Don't bother if we already know the length is a constant. */
if (*len && INTEGER_CST_P (*len))
return;
ts = &expr->symtree->n.sym->ts;
for (ref = expr->ref; ref; ref = ref->next)
{
switch (ref->type)
{
case REF_ARRAY:
/* Array references don't change teh sting length. */
break;
case COMPONENT_REF:
/* Use the length of the component. */
ts = &ref->u.c.component->ts;
break;
default:
/* TODO: Substrings are tricky because we can't evaluate the
expression more than once. For now we just give up, and hope
we can figure it out elsewhere. */
return;
}
}
*len = ts->cl->backend_decl;
}
/* Figure out the string length of a character array constructor.
Returns TRUE if all elements are character constants. */
static bool
get_array_ctor_strlen (gfc_constructor * c, tree * len)
{
bool is_const;
is_const = TRUE;
for (; c; c = c->next)
{
switch (c->expr->expr_type)
{
case EXPR_CONSTANT:
if (!(*len && INTEGER_CST_P (*len)))
*len = build_int_cstu (gfc_strlen_type_node,
c->expr->value.character.length);
break;
case EXPR_ARRAY:
if (!get_array_ctor_strlen (c->expr->value.constructor, len))
is_const = FALSE;
break;
case EXPR_VARIABLE:
is_const = false;
get_array_ctor_var_strlen (c->expr, len);
break;
default:
is_const = FALSE;
/* TODO: For now we just ignore anything we don't know how to
handle, and hope we can figure it out a different way. */
break;
}
}
return is_const;
}
/* Array constructors are handled by constructing a temporary, then using that
within the scalarization loop. This is not optimal, but seems by far the
simplest method. */
@ -986,13 +1110,28 @@ gfc_trans_array_constructor (gfc_loopinfo * loop, gfc_ss * ss)
tree desc;
tree size;
tree type;
bool const_string;
ss->data.info.dimen = loop->dimen;
if (ss->expr->ts.type == BT_CHARACTER)
gfc_todo_error ("Character string array constructors");
type = gfc_typenode_for_spec (&ss->expr->ts);
ss->data.info.dimen = loop->dimen;
size =
gfc_trans_allocate_temp_array (loop, &ss->data.info, type, NULL_TREE);
{
const_string = get_array_ctor_strlen (ss->expr->value.constructor,
&ss->string_length);
if (!ss->string_length)
gfc_todo_error ("complex character array constructors");
type = gfc_get_character_type_len (ss->expr->ts.kind, ss->string_length);
if (const_string)
type = build_pointer_type (type);
}
else
{
const_string = TRUE;
type = gfc_typenode_for_spec (&ss->expr->ts);
}
size = gfc_trans_allocate_temp_array (loop, &ss->data.info, type);
desc = ss->data.info.descriptor;
offset = gfc_index_zero_node;
@ -1057,7 +1196,7 @@ gfc_add_loop_ss_code (gfc_loopinfo * loop, gfc_ss * ss, bool subscript)
gfc_add_block_to_block (&loop->post, &se.post);
ss->data.scalar.expr = se.expr;
ss->data.scalar.string_length = se.string_length;
ss->string_length = se.string_length;
break;
case GFC_SS_REFERENCE:
@ -1068,7 +1207,7 @@ gfc_add_loop_ss_code (gfc_loopinfo * loop, gfc_ss * ss, bool subscript)
gfc_add_block_to_block (&loop->post, &se.post);
ss->data.scalar.expr = gfc_evaluate_now (se.expr, &loop->pre);
ss->data.scalar.string_length = se.string_length;
ss->string_length = se.string_length;
break;
case GFC_SS_SECTION:
@ -1129,6 +1268,7 @@ gfc_conv_ss_descriptor (stmtblock_t * block, gfc_ss * ss, int base)
gfc_conv_expr_lhs (&se, ss->expr);
gfc_add_block_to_block (block, &se.pre);
ss->data.info.descriptor = se.expr;
ss->string_length = se.string_length;
if (base)
{
@ -1496,11 +1636,7 @@ gfc_conv_scalarized_array_ref (gfc_se * se, gfc_array_ref * ar)
void
gfc_conv_tmp_array_ref (gfc_se * se)
{
tree desc;
desc = se->ss->data.info.descriptor;
/* TODO: We need the string length for string variables. */
se->string_length = se->ss->string_length;
gfc_conv_scalarized_array_ref (se, NULL);
}
@ -2247,7 +2383,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->data.temp.string_length = NULL_TREE;
loop->temp_ss->string_length = NULL_TREE;
loop->temp_ss->data.temp.dimen = loop->dimen;
loop->temp_ss->next = gfc_ss_terminator;
gfc_add_ss_to_loop (loop, loop->temp_ss);
@ -2295,7 +2431,7 @@ gfc_conv_loop_setup (gfc_loopinfo * loop)
if (ss->type == GFC_SS_CONSTRUCTOR)
{
/* An unknown size constructor will always be rank one.
Higher rank constructors will wither have known shape,
Higher rank constructors will either have known shape,
or still be wrapped in a call to reshape. */
assert (loop->dimen == 1);
/* Try to figure out the size of the constructor. */
@ -2337,7 +2473,7 @@ gfc_conv_loop_setup (gfc_loopinfo * loop)
*/
if (!specinfo)
loopspec[n] = ss;
/* TODO: Is != contructor correct? */
/* TODO: Is != constructor correct? */
else if (loopspec[n]->type != GFC_SS_CONSTRUCTOR)
{
if (integer_onep (info->stride[n])
@ -2433,13 +2569,12 @@ gfc_conv_loop_setup (gfc_loopinfo * loop)
{
assert (loop->temp_ss->type == GFC_SS_TEMP);
tmp = loop->temp_ss->data.temp.type;
len = loop->temp_ss->data.temp.string_length;
len = loop->temp_ss->string_length;
n = loop->temp_ss->data.temp.dimen;
memset (&loop->temp_ss->data.info, 0, sizeof (gfc_ss_info));
loop->temp_ss->type = GFC_SS_SECTION;
loop->temp_ss->data.info.dimen = n;
gfc_trans_allocate_temp_array (loop, &loop->temp_ss->data.info,
tmp, len);
gfc_trans_allocate_temp_array (loop, &loop->temp_ss->data.info, tmp);
}
for (n = 0; n < loop->temp_dim; n++)
@ -3502,10 +3637,10 @@ gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss)
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->data.temp.string_length
se->string_length = loop.temp_ss->string_length
= TYPE_SIZE_UNIT (loop.temp_ss->data.temp.type);
else
loop.temp_ss->data.temp.string_length = NULL;
loop.temp_ss->string_length = NULL;
loop.temp_ss->data.temp.dimen = loop.dimen;
gfc_add_ss_to_loop (&loop, loop.temp_ss);
}

3
gcc/fortran/trans-array.h
View File

@ -27,8 +27,7 @@ tree gfc_array_deallocate (tree);
void gfc_array_allocate (gfc_se *, gfc_ref *, tree);
/* Generate code to allocate a temporary array. */
tree gfc_trans_allocate_temp_array (gfc_loopinfo *, gfc_ss_info *, tree,
tree);
tree gfc_trans_allocate_temp_array (gfc_loopinfo *, gfc_ss_info *, tree);
/* Generate function entry code for allocation of compiler allocated array
variables. */

2
gcc/fortran/trans-const.c
View File

@ -353,7 +353,7 @@ gfc_conv_constant (gfc_se * se, gfc_expr * expr)
assert (se->ss->expr == expr);
se->expr = se->ss->data.scalar.expr;
se->string_length = se->ss->data.scalar.string_length;
se->string_length = se->ss->string_length;
gfc_advance_se_ss_chain (se);
return;
}

12
gcc/fortran/trans-expr.c
View File

@ -231,9 +231,8 @@ gfc_conv_component_ref (gfc_se * se, gfc_ref * ref)
if (c->ts.type == BT_CHARACTER)
{
tmp = c->ts.cl->backend_decl;
assert (tmp);
if (!INTEGER_CST_P (tmp))
gfc_todo_error ("Unknown length character component");
/* Components must always be constant length. */
assert (tmp && INTEGER_CST_P (tmp));
se->string_length = tmp;
}
@ -260,6 +259,7 @@ gfc_conv_variable (gfc_se * se, gfc_expr * expr)
/* A scalarized term. We already know the descriptor. */
se->expr = se->ss->data.info.descriptor;
se->string_length = se->ss->string_length;
ref = se->ss->data.info.ref;
}
else
@ -1040,7 +1040,7 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
tmp = gfc_typenode_for_spec (&sym->ts);
info->dimen = se->loop->dimen;
/* Allocate a temporary to store the result. */
gfc_trans_allocate_temp_array (se->loop, info, tmp, NULL_TREE);
gfc_trans_allocate_temp_array (se->loop, info, tmp);
/* Zero the first stride to indicate a temporary. */
tmp =
@ -1711,7 +1711,7 @@ gfc_conv_expr (gfc_se * se, gfc_expr * expr)
/* Substitute a scalar expression evaluated outside the scalarization
loop. */
se->expr = se->ss->data.scalar.expr;
se->string_length = se->ss->data.scalar.string_length;
se->string_length = se->ss->string_length;
gfc_advance_se_ss_chain (se);
return;
}
@ -1799,7 +1799,7 @@ gfc_conv_expr_reference (gfc_se * se, gfc_expr * expr)
&& se->ss->type == GFC_SS_REFERENCE)
{
se->expr = se->ss->data.scalar.expr;
se->string_length = se->ss->data.scalar.string_length;
se->string_length = se->ss->string_length;
gfc_advance_se_ss_chain (se);
return;
}

29
gcc/fortran/trans-types.c
View File

@ -267,15 +267,14 @@ gfc_get_logical_type (int kind)
}
}
/* Get a type node for a character kind. */
/* Create a character type with the given kind and length. */
tree
gfc_get_character_type (int kind, gfc_charlen * cl)
gfc_get_character_type_len (int kind, tree len)
{
tree base;
tree type;
tree len;
tree bounds;
tree type;
switch (kind)
{
@ -287,14 +286,25 @@ gfc_get_character_type (int kind, gfc_charlen * cl)
fatal_error ("character kind=%d not available", kind);
}
len = (cl == 0) ? NULL_TREE : cl->backend_decl;
bounds = build_range_type (gfc_array_index_type, gfc_index_one_node, len);
type = build_array_type (base, bounds);
TYPE_STRING_FLAG (type) = 1;
return type;
}
/* Get a type node for a character kind. */
tree
gfc_get_character_type (int kind, gfc_charlen * cl)
{
tree len;
len = (cl == NULL) ? NULL_TREE : cl->backend_decl;
return gfc_get_character_type_len (kind, len);
}
/* Covert a basic type. This will be an array for character types. */
@ -480,6 +490,9 @@ gfc_is_nodesc_array (gfc_symbol * sym)
return 1;
}
/* Create an array descriptor type. */
static tree
gfc_build_array_type (tree type, gfc_array_spec * as)
{
@ -584,7 +597,9 @@ gfc_get_dtype (tree type, int rank)
break;
default:
abort ();
/* TODO: Don't do dtype for temporary descriptorless arrays. */
/* We can strange array types for temporary arrays. */
return gfc_index_zero_node;
}
assert (rank <= GFC_DTYPE_RANK_MASK);

1
gcc/fortran/trans-types.h
View File

@ -112,6 +112,7 @@ tree gfc_get_real_type (int);
tree gfc_get_complex_type (int);
tree gfc_get_logical_type (int);
tree gfc_get_character_type (int, gfc_charlen *);
tree gfc_get_character_type_len (int, tree);
tree gfc_sym_type (gfc_symbol *);
tree gfc_typenode_for_spec (gfc_typespec *);

3
gcc/fortran/trans.h
View File

@ -162,13 +162,13 @@ typedef struct gfc_ss
gfc_ss_type type;
gfc_expr *expr;
mpz_t *shape;
tree string_length;
union
{
/* If type is GFC_SS_SCALAR or GFC_SS_REFERENCE. */
struct
{
tree expr;
tree string_length;
}
scalar;
@ -179,7 +179,6 @@ typedef struct gfc_ss
assigned expression. */
int dimen;
tree type;
tree string_length;
}
temp;
/* All other types. */

5
gcc/testsuite/ChangeLog
View File

@ -1,3 +1,8 @@
2004-08-25 Paul Brook <paul@codesourcery.com>
PR fortran/17144
* gfortran.dg/string_ctor_1.f90: New test.
2004-08-25 Kriang Lerdsuwanakij <lerdsuwa@users.sourceforge.net>
PR c++/14428

49
gcc/testsuite/gfortran.dg/string_ctor_1.f90 Normal file
View File

@ -0,0 +1,49 @@
! { dg-do run }
! Program to test character array constructors.
! PR17144
subroutine test1 (n, t, u)
integer n
character(len=n) :: s(2)
character(len=*) :: t
character(len=*) :: u
! A variable array constructor.
s = (/t, u/)
! An array constructor as part of an expression.
if (any (s .ne. (/"Hell", "Worl"/))) call abort
end subroutine
subroutine test2
character*5 :: s(2)
! A constant array constructor
s = (/"Hello", "World"/)
if ((s(1) .ne. "Hello") .or. (s(2) .ne. "World")) call abort
end subroutine
subroutine test3
character*1 s(26)
character*26 t
integer i
! A large array constructor
s = (/'a', 'b', 'c', 'd', 'e', 'f', 'g', 'h', 'i', 'j', 'k', 'l', 'm', &
'n', 'o', 'p', 'q', 'r', 's', 't', 'u', 'v', 'w', 'x', 'y', 'z'/)
do i=1, 26
t(i:i) = s(i)
end do
! Assignment with dependency
s = (/(s(27-i), i=1, 26)/)
do i=1, 26
t(i:i) = s(i)
end do
if (t .ne. "zyxwvutsrqponmlkjihgfedcba") call abort
end subroutine
program string_ctor_1
call test1 (4, "Hello", "World")
call test2
call test3
end program