fortran ChangeLog entry:

2006-01-09  Feng Wang  <fengwang@nudt.edu.cn>

	PR fortran/12456
	* trans-expr.c (gfc_to_single_character): New function that converts
	string to single character if its length is 1.
	(gfc_build_compare_string):New function that compare string and handle
	single character specially.
	(gfc_conv_expr_op): Use gfc_build_compare_string.
	(gfc_trans_string_copy): Use gfc_to_single_character.
	* trans-intrinsic.c (gfc_conv_intrinsic_strcmp): Use
	gfc_build_compare_string.
	* trans.h (gfc_build_compare_string): Add prototype.

testsuite ChangeLog entry:
2006-01-09  Feng Wang  <fengwang@nudt.edu.cn>

	PR fortran/12456
	* gfortran.dg/single_char_string.f90: New test.

From-SVN: r109489

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 45fb5fe221b2d77a9f592e74840f84abba686884..a745970f38472deca9fd342ad3d9ef02dcd6810e 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,16 @@
+2006-01-09  Feng Wang  <fengwang@nudt.edu.cn>
+
+       PR fortran/12456
+       * trans-expr.c (gfc_to_single_character): New function that converts
+       string to single character if its length is 1.
+       (gfc_build_compare_string):New function that compare string and handle
+       single character specially.
+       (gfc_conv_expr_op): Use gfc_build_compare_string.
+       (gfc_trans_string_copy): Use gfc_to_single_character.
+       * trans-intrinsic.c (gfc_conv_intrinsic_strcmp): Use
+       gfc_build_compare_string.
+       * trans.h (gfc_build_compare_string): Add prototype.
+
 2006-01-09  Feng Wang  <fengwang@nudt.edu.cn>
 
        * simplify.c (gfc_simplify_char): Use UCHAR_MAX instead of literal

diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index f21c0734290827c215ceb555497768afcd92b6be..e46075eaa8d44610c7f3fee0bf558a2c1c022c1c 100644 (file)
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -901,7 +901,6 @@ gfc_conv_concat_op (gfc_se * se, gfc_expr * expr)
   se->string_length = len;
 }
 
-
 /* Translates an op expression. Common (binary) cases are handled by this
    function, others are passed on. Recursion is used in either case.
    We use the fact that (op1.ts == op2.ts) (except for the power
@@ -1043,23 +1042,15 @@ gfc_conv_expr_op (gfc_se * se, gfc_expr * expr)
   gfc_conv_expr (&rse, expr->value.op.op2);
   gfc_add_block_to_block (&se->pre, &rse.pre);
 
-  /* For string comparisons we generate a library call, and compare the return
-     value with 0.  */
   if (checkstring)
     {
       gfc_conv_string_parameter (&lse);
       gfc_conv_string_parameter (&rse);
-      tmp = NULL_TREE;
-      tmp = gfc_chainon_list (tmp, lse.string_length);
-      tmp = gfc_chainon_list (tmp, lse.expr);
-      tmp = gfc_chainon_list (tmp, rse.string_length);
-      tmp = gfc_chainon_list (tmp, rse.expr);
-
-      /* Build a call for the comparison.  */
-      lse.expr = build_function_call_expr (gfor_fndecl_compare_string, tmp);
-      gfc_add_block_to_block (&lse.post, &rse.post);
 
+      lse.expr = gfc_build_compare_string (lse.string_length, lse.expr,
+                                          rse.string_length, rse.expr);
       rse.expr = integer_zero_node;
+      gfc_add_block_to_block (&lse.post, &rse.post);
     }
 
   type = gfc_typenode_for_spec (&expr->ts);
@@ -1078,6 +1069,63 @@ gfc_conv_expr_op (gfc_se * se, gfc_expr * expr)
   gfc_add_block_to_block (&se->post, &lse.post);
 }
 
+/* If a string's length is one, we convert it to a single character.  */
+
+static tree
+gfc_to_single_character (tree len, tree str)
+{
+  gcc_assert (POINTER_TYPE_P (TREE_TYPE (str)));
+
+  if (INTEGER_CST_P (len) && TREE_INT_CST_LOW (len) == 1
+    && TREE_INT_CST_HIGH (len) == 0)
+    {
+      str = fold_convert (pchar_type_node, str);
+      return build_fold_indirect_ref (str);
+    }
+
+  return NULL_TREE;
+}
+
+/* Compare two strings. If they are all single characters, the result is the
+   subtraction of them. Otherwise, we build a library call.  */
+
+tree
+gfc_build_compare_string (tree len1, tree str1, tree len2, tree str2)
+{
+  tree sc1;
+  tree sc2;
+  tree type;
+  tree tmp;
+
+  gcc_assert (POINTER_TYPE_P (TREE_TYPE (str1)));
+  gcc_assert (POINTER_TYPE_P (TREE_TYPE (str2)));
+
+  type = gfc_get_int_type (gfc_default_integer_kind);
+
+  sc1 = gfc_to_single_character (len1, str1);
+  sc2 = gfc_to_single_character (len2, str2);
+
+  /* Deal with single character specially.  */
+  if (sc1 != NULL_TREE && sc2 != NULL_TREE)
+    {
+      sc1 = fold_convert (type, sc1);
+      sc2 = fold_convert (type, sc2);
+      tmp = fold_build2 (MINUS_EXPR, type, sc1, sc2);
+    }
+   else
+    {
+      tmp = NULL_TREE;
+      tmp = gfc_chainon_list (tmp, len1);
+      tmp = gfc_chainon_list (tmp, str1);
+      tmp = gfc_chainon_list (tmp, len2);
+      tmp = gfc_chainon_list (tmp, str2);
+
+      /* Build a call for the comparison.  */
+      tmp = build_function_call_expr (gfor_fndecl_compare_string, tmp);
+    }
+
+  return tmp;
+}
 
 static void
 gfc_conv_function_val (gfc_se * se, gfc_symbol * sym)
@@ -1818,6 +1866,17 @@ gfc_trans_string_copy (stmtblock_t * block, tree dlen, tree dest,
                       tree slen, tree src)
 {
   tree tmp;
+  tree dsc;
+  tree ssc;
+
+  /* Deal with single character specially.  */
+  dsc = gfc_to_single_character (dlen, dest);
+  ssc = gfc_to_single_character (slen, src);
+  if (dsc != NULL_TREE && ssc != NULL_TREE)
+    {
+      gfc_add_modify_expr (block, dsc, ssc);
+      return;
+    }
 
   tmp = NULL_TREE;
   tmp = gfc_chainon_list (tmp, dlen);

diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c
index 699a2947e9346ea8b3e49cc1a94b17670d8ad7ca..4c6d63abf9a9311eec6c1528b8318418d9af1090 100644 (file)
--- a/gcc/fortran/trans-intrinsic.c
+++ b/gcc/fortran/trans-intrinsic.c
@@ -2267,13 +2267,17 @@ gfc_conv_intrinsic_strcmp (gfc_se * se, gfc_expr * expr, int op)
 {
   tree type;
   tree args;
+  tree arg2;
 
   args = gfc_conv_intrinsic_function_args (se, expr);
-  /* Build a call for the comparison.  */
-  se->expr = build_function_call_expr (gfor_fndecl_compare_string, args);
+  arg2 = TREE_CHAIN (TREE_CHAIN (args));
+
+  se->expr = gfc_build_compare_string (TREE_VALUE (args),
+               TREE_VALUE (TREE_CHAIN (args)), TREE_VALUE (arg2),
+               TREE_VALUE (TREE_CHAIN (arg2)));
 
   type = gfc_typenode_for_spec (&expr->ts);
-  se->expr = build2 (op, type, se->expr,
+  se->expr = fold_build2 (op, type, se->expr,
                     build_int_cst (TREE_TYPE (se->expr), 0));
 }
 

diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h
index 2d637bd94063ad48ad86bb6c766aca72e0df0d95..e0b5138d91998e04d39afa9c12469108ba99c000 100644 (file)
--- a/gcc/fortran/trans.h
+++ b/gcc/fortran/trans.h
@@ -268,6 +268,9 @@ void gfc_make_safe_expr (gfc_se * se);
 /* Makes sure se is suitable for passing as a function string parameter.  */
 void gfc_conv_string_parameter (gfc_se * se);
 
+/* Compare two strings.  */
+tree gfc_build_compare_string (tree, tree, tree, tree);
+
 /* Add an item to the end of TREE_LIST.  */
 tree gfc_chainon_list (tree, tree);
 

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 0743d0ad509d44cbf1f0cad9285c77abcd1a4af7..e29aa6e78990e0a17dbb7391a4faa82f1b6f963f 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,7 @@
+2006-01-09  Feng Wang  <fengwang@nudt.edu.cn>
+
+       * gfortran.dg/single_char_string.f90: New test.
+
 2006-01-09  Feng Wang  <fengwang@nudt.edu.cn>
 
        * gfortran.dg/ichar_2.f90: New test.

diff --git a/gcc/testsuite/gfortran.dg/single_char_string.f90 b/gcc/testsuite/gfortran.dg/single_char_string.f90
new file mode 100644 (file)
index 0000000..479456c
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/single_char_string.f90
@@ -0,0 +1,36 @@
+! { dg-do run }
+! { dg-options "-fdump-tree-original" }
+! PR12456 - Optimize string(k:k) as single character.
+
+Program pr12456
+character a
+character b
+character (len=5) :: c
+integer i
+
+b = 'a'
+a = b
+if (a .ne. 'a') call abort()
+if (a .ne. b) call abort()
+c (3:3) = 'a'
+if (c (3:3) .ne. b) call abort ()
+if (c (3:3) .ne. 'a') call abort ()
+if (LGT (a, c (3:3))) call abort ()
+if (LGT (a, 'a')) call abort ()
+
+i = 3
+c (i:i) = 'a'
+if (c (i:i) .ne. b) call abort ()
+if (c (i:i) .ne. 'a') call abort ()
+if (LGT (a, c (i:i))) call abort ()
+
+if (a .gt. char (255)) call abort ()
+end
+
+! There should not be _gfortran_compare_string and _gfortran_copy_string in
+! the dumped file.
+
+! { dg-final { scan-tree-dump-times "_gfortran_compare_string" 0 "original" } }
+! { dg-final { scan-tree-dump-times "_gfortran_copy_string" 0 "original" } }
+
+! { dg-final { cleanup-tree-dump "original" } }