diff options
| -rw-r--r-- | gcc/fortran/ChangeLog | 29 | ||||
| -rw-r--r-- | gcc/fortran/trans-array.c | 219 | ||||
| -rw-r--r-- | gcc/fortran/trans-array.h | 3 | ||||
| -rw-r--r-- | gcc/fortran/trans-const.c | 2 | ||||
| -rw-r--r-- | gcc/fortran/trans-expr.c | 12 | ||||
| -rw-r--r-- | gcc/fortran/trans-types.c | 29 | ||||
| -rw-r--r-- | gcc/fortran/trans-types.h | 1 | ||||
| -rw-r--r-- | gcc/fortran/trans.h | 3 | ||||
| -rw-r--r-- | gcc/testsuite/ChangeLog | 5 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/string_ctor_1.f90 | 49 |
10 files changed, 292 insertions, 60 deletions
diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index f93b3a4..85be102 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -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. diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index b8480fd..5bccd96 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -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; - 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); + + if (ss->expr->ts.type == BT_CHARACTER) + { + 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); } diff --git a/gcc/fortran/trans-array.h b/gcc/fortran/trans-array.h index ee7db9b..9cd0fce 100644 --- a/gcc/fortran/trans-array.h +++ b/gcc/fortran/trans-array.h @@ -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. */ diff --git a/gcc/fortran/trans-const.c b/gcc/fortran/trans-const.c index 25a9459..8ea0d5c 100644 --- a/gcc/fortran/trans-const.c +++ b/gcc/fortran/trans-const.c @@ -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; } diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index 50aa9ca..cbf2dd1 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -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; } diff --git a/gcc/fortran/trans-types.c b/gcc/fortran/trans-types.c index 6fdb84a..e88842d 100644 --- a/gcc/fortran/trans-types.c +++ b/gcc/fortran/trans-types.c @@ -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); diff --git a/gcc/fortran/trans-types.h b/gcc/fortran/trans-types.h index 82eb857..ebab5a1 100644 --- a/gcc/fortran/trans-types.h +++ b/gcc/fortran/trans-types.h @@ -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 *); diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h index b9b467b..5045046 100644 --- a/gcc/fortran/trans.h +++ b/gcc/fortran/trans.h @@ -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. */ diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 4647822..888b38a 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -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 diff --git a/gcc/testsuite/gfortran.dg/string_ctor_1.f90 b/gcc/testsuite/gfortran.dg/string_ctor_1.f90 new file mode 100644 index 0000000..3242ea8 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/string_ctor_1.f90 @@ -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 + |