procyberian/gcc
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

trans.h (gfc_string_to_single_character): New prototype.

Browse source 
* trans.h (gfc_string_to_single_character): New prototype.
	* trans-expr.c (string_to_single_character): Renamed to ...
	(gfc_string_to_single_character): ... this.  No longer static.
	(gfc_conv_scalar_char_value, gfc_build_compare_string,
	gfc_trans_string_copy): Adjust callers.
	* config-lang.in (gtfiles): Add fortran/trans-stmt.c.
	* trans-stmt.c: Include ggc.h and gt-fortran-trans-stmt.h.
	(select_struct): Move to toplevel, add GTY(()).
	(gfc_trans_character_select): Optimize SELECT CASE
	with character length 1.

	* gfortran.dg/select_char_2.f90: New test.

From-SVN: r162226
This commit is contained in:
Jakub Jelinek 2010-07-15 18:09:48 +02:00 • committed by Jakub Jelinek
parent ef8fc6c2ef
commit d2886bc744
7 changed files with 237 additions and 30 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

13
gcc/fortran/ChangeLog
View file

@ -1,3 +1,16 @@
2010-07-15 Jakub Jelinek <jakub@redhat.com>
* trans.h (gfc_string_to_single_character): New prototype.
* trans-expr.c (string_to_single_character): Renamed to ...
(gfc_string_to_single_character): ... this. No longer static.
(gfc_conv_scalar_char_value, gfc_build_compare_string,
gfc_trans_string_copy): Adjust callers.
* config-lang.in (gtfiles): Add fortran/trans-stmt.c.
* trans-stmt.c: Include ggc.h and gt-fortran-trans-stmt.h.
(select_struct): Move to toplevel, add GTY(()).
(gfc_trans_character_select): Optimize SELECT CASE
with character length 1.
2010-07-15 Nathan Froyd <froydnj@codesourcery.com>
* f95-lang.c: Carefully replace TREE_CHAIN with DECL_CHAIN.

2
gcc/fortran/config-lang.in
View file

@ -29,5 +29,5 @@ compilers="f951\$(exeext)"
target_libs=target-libgfortran
gtfiles="\$(srcdir)/fortran/f95-lang.c \$(srcdir)/fortran/trans-decl.c \$(srcdir)/fortran/trans-intrinsic.c \$(srcdir)/fortran/trans-io.c \$(srcdir)/fortran/trans-types.c \$(srcdir)/fortran/trans-types.h \$(srcdir)/fortran/trans.h \$(srcdir)/fortran/trans-const.h"
gtfiles="\$(srcdir)/fortran/f95-lang.c \$(srcdir)/fortran/trans-decl.c \$(srcdir)/fortran/trans-intrinsic.c \$(srcdir)/fortran/trans-io.c \$(srcdir)/fortran/trans-stmt.c \$(srcdir)/fortran/trans-types.c \$(srcdir)/fortran/trans-types.h \$(srcdir)/fortran/trans.h \$(srcdir)/fortran/trans-const.h"

16
gcc/fortran/trans-expr.c
View file

@ -1389,8 +1389,8 @@ 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
string_to_single_character (tree len, tree str, int kind)
tree
gfc_string_to_single_character (tree len, tree str, int kind)
{
gcc_assert (POINTER_TYPE_P (TREE_TYPE (str)));
@ -1475,7 +1475,7 @@ gfc_conv_scalar_char_value (gfc_symbol *sym, gfc_se *se, gfc_expr **expr)
{
if ((*expr)->ref == NULL)
{
se->expr = string_to_single_character
se->expr = gfc_string_to_single_character
(build_int_cst (integer_type_node, 1),
gfc_build_addr_expr (gfc_get_pchar_type ((*expr)->ts.kind),
gfc_get_symbol_decl
@ -1485,7 +1485,7 @@ gfc_conv_scalar_char_value (gfc_symbol *sym, gfc_se *se, gfc_expr **expr)
else
{
gfc_conv_variable (se, *expr);
se->expr = string_to_single_character
se->expr = gfc_string_to_single_character
(build_int_cst (integer_type_node, 1),
gfc_build_addr_expr (gfc_get_pchar_type ((*expr)->ts.kind),
se->expr),
@ -1544,8 +1544,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 = string_to_single_character (len1, str1, kind);
sc2 = string_to_single_character (len2, str2, kind);
sc1 = gfc_string_to_single_character (len1, str1, kind);
sc2 = gfc_string_to_single_character (len2, str2, kind);
if (sc1 != NULL_TREE && sc2 != NULL_TREE)
{
@ -3618,7 +3618,7 @@ gfc_trans_string_copy (stmtblock_t * block, tree dlength, tree dest,
if (slength != NULL_TREE)
{
slen = fold_convert (size_type_node, gfc_evaluate_now (slength, block));
ssc = string_to_single_character (slen, src, skind);
ssc = gfc_string_to_single_character (slen, src, skind);
}
else
{
@ -3629,7 +3629,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 = string_to_single_character (dlen, dest, dkind);
dsc = gfc_string_to_single_character (dlen, dest, dkind);
}
else
{

186
gcc/fortran/trans-stmt.c
View file

@ -34,6 +34,7 @@ along with GCC; see the file COPYING3. If not see
#include "trans-const.h"
#include "arith.h"
#include "dependency.h"
#include "ggc.h"
typedef struct iter_info
{
@ -1594,6 +1595,10 @@ gfc_trans_logical_select (gfc_code * code)
}
/* The jump table types are stored in static variables to avoid
constructing them from scratch every single time. */
static GTY(()) tree select_struct[2];
/* Translate the SELECT CASE construct for CHARACTER case expressions.
Instead of generating compares and jumps, it is far simpler to
generate a data structure describing the cases in order and call a
@ -1610,18 +1615,171 @@ gfc_trans_character_select (gfc_code *code)
stmtblock_t block, body;
gfc_case *cp, *d;
gfc_code *c;
gfc_se se;
gfc_se se, expr1se;
int n, k;
VEC(constructor_elt,gc) *inits = NULL;
tree pchartype = gfc_get_pchar_type (code->expr1->ts.kind);
/* The jump table types are stored in static variables to avoid
constructing them from scratch every single time. */
static tree select_struct[2];
static tree ss_string1[2], ss_string1_len[2];
static tree ss_string2[2], ss_string2_len[2];
static tree ss_target[2];
tree pchartype = gfc_get_pchar_type (code->expr1->ts.kind);
cp = code->block->ext.case_list;
while (cp->left != NULL)
cp = cp->left;
/* Generate the body */
gfc_start_block (&block);
gfc_init_se (&expr1se, NULL);
gfc_conv_expr_reference (&expr1se, code->expr1);
gfc_add_block_to_block (&block, &expr1se.pre);
end_label = gfc_build_label_decl (NULL_TREE);
gfc_init_block (&body);
/* Attempt to optimize length 1 selects. */
if (expr1se.string_length == integer_one_node)
{
for (d = cp; d; d = d->right)
{
int i;
if (d->low)
{
gcc_assert (d->low->expr_type == EXPR_CONSTANT
&& d->low->ts.type == BT_CHARACTER);
if (d->low->value.character.length > 1)
{
for (i = 1; i < d->low->value.character.length; i++)
if (d->low->value.character.string[i] != ' ')
break;
if (i != d->low->value.character.length)
{
if (optimize && d->high && i == 1)
{
gcc_assert (d->high->expr_type == EXPR_CONSTANT
&& d->high->ts.type == BT_CHARACTER);
if (d->high->value.character.length > 1
&& (d->low->value.character.string[0]
== d->high->value.character.string[0])
&& d->high->value.character.string[1] != ' '
&& ((d->low->value.character.string[1] < ' ')
== (d->high->value.character.string[1]
< ' ')))
continue;
}
break;
}
}
}
if (d->high)
{
gcc_assert (d->high->expr_type == EXPR_CONSTANT
&& d->high->ts.type == BT_CHARACTER);
if (d->high->value.character.length > 1)
{
for (i = 1; i < d->high->value.character.length; i++)
if (d->high->value.character.string[i] != ' ')
break;
if (i != d->high->value.character.length)
break;
}
}
}
if (d == NULL)
{
tree ctype = gfc_get_char_type (code->expr1->ts.kind);
for (c = code->block; c; c = c->block)
{
for (cp = c->ext.case_list; cp; cp = cp->next)
{
tree low, high;
tree label;
gfc_char_t r;
/* Assume it's the default case. */
low = high = NULL_TREE;
if (cp->low)
{
/* CASE ('ab') or CASE ('ab':'az') will never match
any length 1 character. */
if (cp->low->value.character.length > 1
&& cp->low->value.character.string[1] != ' ')
continue;
if (cp->low->value.character.length > 0)
r = cp->low->value.character.string[0];
else
r = ' ';
low = build_int_cst (ctype, r);
/* If there's only a lower bound, set the high bound
to the maximum value of the case expression. */
if (!cp->high)
high = TYPE_MAX_VALUE (ctype);
}
if (cp->high)
{
if (!cp->low
|| (cp->low->value.character.string[0]
!= cp->high->value.character.string[0]))
{
if (cp->high->value.character.length > 0)
r = cp->high->value.character.string[0];
else
r = ' ';
high = build_int_cst (ctype, r);
}
/* Unbounded case. */
if (!cp->low)
low = TYPE_MIN_VALUE (ctype);
}
/* Build a label. */
label = gfc_build_label_decl (NULL_TREE);
/* Add this case label.
Add parameter 'label', make it match GCC backend. */
tmp = fold_build3 (CASE_LABEL_EXPR, void_type_node,
low, high, label);
gfc_add_expr_to_block (&body, tmp);
}
/* Add the statements for this case. */
tmp = gfc_trans_code (c->next);
gfc_add_expr_to_block (&body, tmp);
/* Break to the end of the construct. */
tmp = build1_v (GOTO_EXPR, end_label);
gfc_add_expr_to_block (&body, tmp);
}
tmp = gfc_string_to_single_character (expr1se.string_length,
expr1se.expr,
code->expr1->ts.kind);
case_num = gfc_create_var (ctype, "case_num");
gfc_add_modify (&block, case_num, tmp);
gfc_add_block_to_block (&block, &expr1se.post);
tmp = gfc_finish_block (&body);
tmp = build3_v (SWITCH_EXPR, case_num, tmp, NULL_TREE);
gfc_add_expr_to_block (&block, tmp);
tmp = build1_v (LABEL_EXPR, end_label);
gfc_add_expr_to_block (&block, tmp);
return gfc_finish_block (&block);
}
}
if (code->expr1->ts.kind == 1)
k = 0;
@ -1661,20 +1819,10 @@ gfc_trans_character_select (gfc_code *code)
gfc_finish_type (select_struct[k]);
}
cp = code->block->ext.case_list;
while (cp->left != NULL)
cp = cp->left;
n = 0;
for (d = cp; d; d = d->right)
d->n = n++;
end_label = gfc_build_label_decl (NULL_TREE);
/* Generate the body */
gfc_start_block (&block);
gfc_init_block (&body);
for (c = code->block; c; c = c->block)
{
for (d = c->ext.case_list; d; d = d->next)
@ -1695,7 +1843,7 @@ gfc_trans_character_select (gfc_code *code)
}
/* Generate the structure describing the branches */
for(d = cp; d; d = d->right)
for (d = cp; d; d = d->right)
{
VEC(constructor_elt,gc) *node = NULL;
@ -1752,11 +1900,6 @@ gfc_trans_character_select (gfc_code *code)
/* Build the library call */
init = gfc_build_addr_expr (pvoid_type_node, init);
gfc_init_se (&se, NULL);
gfc_conv_expr_reference (&se, code->expr1);
gfc_add_block_to_block (&block, &se.pre);
if (code->expr1->ts.kind == 1)
fndecl = gfor_fndecl_select_string;
else if (code->expr1->ts.kind == 4)
@ -1766,11 +1909,11 @@ gfc_trans_character_select (gfc_code *code)
tmp = build_call_expr_loc (input_location,
fndecl, 4, init, build_int_cst (NULL_TREE, n),
se.expr, se.string_length);
expr1se.expr, expr1se.string_length);
case_num = gfc_create_var (integer_type_node, "case_num");
gfc_add_modify (&block, case_num, tmp);
gfc_add_block_to_block (&block, &se.post);
gfc_add_block_to_block (&block, &expr1se.post);
tmp = gfc_finish_block (&body);
tmp = build3_v (SWITCH_EXPR, case_num, tmp, NULL_TREE);
@ -4494,3 +4637,4 @@ gfc_trans_deallocate (gfc_code *code)
return gfc_finish_block (&block);
}
#include "gt-fortran-trans-stmt.h"

1
gcc/fortran/trans.h
View file

@ -322,6 +322,7 @@ void gfc_conv_expr_type (gfc_se * se, gfc_expr *, tree);
/* trans-expr.c */
void gfc_conv_scalar_char_value (gfc_symbol *sym, gfc_se *se, gfc_expr **expr);
tree gfc_string_to_single_character (tree len, tree str, int kind);
/* Find the decl containing the auxiliary variables for assigned variables. */
void gfc_conv_label_variable (gfc_se * se, gfc_expr * expr);

4
gcc/testsuite/ChangeLog
View file

@ -1,3 +1,7 @@
2010-07-15 Jakub Jelinek <jakub@redhat.com>
* gfortran.dg/select_char_2.f90: New test.
2010-07-15 Nathan Froyd <froydnj@codesourcery.com>
* g++.dg/plugin/attribute_plugin.c: Carefully replace TREE_CHAIN

45
gcc/testsuite/gfortran.dg/select_char_2.f90 Normal file
View file

@ -0,0 +1,45 @@
! { dg-do run }
! { dg-options "-O -fdump-tree-original" }
if (foo ('E') .ne. 1) call abort
if (foo ('e') .ne. 1) call abort
if (foo ('f') .ne. 2) call abort
if (foo ('g') .ne. 2) call abort
if (foo ('h') .ne. 2) call abort
if (foo ('Q') .ne. 3) call abort
if (foo (' ') .ne. 4) call abort
if (bar ('e') .ne. 1) call abort
if (bar ('f') .ne. 3) call abort
contains
function foo (c)
character :: c
integer :: foo
select case (c)
case ('E','e')
foo = 1
case ('f':'h ')
foo = 2
case default
foo = 3
case ('')
foo = 4
end select
end function
function bar (c)
character :: c
integer :: bar
select case (c)
case ('ea':'ez')
bar = 2
case ('e')
bar = 1
case default
bar = 3
case ('fd')
bar = 4
end select
end function
end
! { dg-final { scan-tree-dump-not "_gfortran_select_string" "original" } }
! { dg-final { cleanup-tree-dump "original" } }