@@ -299,6 +299,7 @@ void gfc_conv_expr_type (gfc_se * se, gf
/* 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);
@@ -1389,8 +1389,8 @@ gfc_conv_expr_op (gfc_se * se, gfc_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 *
{
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 *
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, tre
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 * blo
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 * blo
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
{
@@ -1610,7 +1610,7 @@ gfc_trans_character_select (gfc_code *co
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;
@@ -1623,6 +1623,141 @@ gfc_trans_character_select (gfc_code *co
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)
+ {
+ if (d->low->expr_type != EXPR_CONSTANT
+ || d->low->ts.type != BT_CHARACTER)
+ break;
+ 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)
+ break;
+ }
+ }
+ if (d->high)
+ {
+ if (d->high->expr_type != EXPR_CONSTANT
+ || d->high->ts.type != BT_CHARACTER)
+ break;
+ 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)
+ {
+ 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;
else if (code->expr1->ts.kind == 4)
@@ -1661,20 +1796,10 @@ gfc_trans_character_select (gfc_code *co
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)
@@ -1694,7 +1819,7 @@ gfc_trans_character_select (gfc_code *co
}
/* 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;
@@ -1751,11 +1876,6 @@ gfc_trans_character_select (gfc_code *co
/* 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)
@@ -1765,11 +1885,11 @@ gfc_trans_character_select (gfc_code *co
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);
@@ -0,0 +1,23 @@
+ 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
+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
+end