]> git.ipfire.org Git - thirdparty/gcc.git/commitdiff
2012-05-11 Thomas Koenig <tkoenig@gcc.gnu.org>
authortkoenig <tkoenig@138bc75d-0d04-0410-961f-82ee72b054a4>
Fri, 11 May 2012 13:56:06 +0000 (13:56 +0000)
committertkoenig <tkoenig@138bc75d-0d04-0410-961f-82ee72b054a4>
Fri, 11 May 2012 13:56:06 +0000 (13:56 +0000)
PR fortran/52537
* frontend-passes.c (optimize_op):  Change
old-style comparison operators to new-style, simplify
switch as a result.
(empty_string):  New function.
(get_len_trim_call):  New function.
(optimize_comparison):  If comparing to an empty string,
use comparison of len_trim to zero.
Use new-style comparison operators only.
(optimize_trim):  Use get_len_trim_call.

2012-05-11  Thomas Koenig  <tkoenig@gcc.gnu.org>

PR fortran/52537
* gfortran.dg/string_compare_4.f90:  New test.

git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@187406 138bc75d-0d04-0410-961f-82ee72b054a4

gcc/fortran/ChangeLog
gcc/fortran/frontend-passes.c
gcc/testsuite/ChangeLog
gcc/testsuite/gfortran.dg/string_compare_4.f90 [new file with mode: 0644]

index a488dcac5672cd58a517b0574fa8985cb85d49b6..e761ef5115401151fdbe71e9cc872c770b681a9f 100644 (file)
@@ -1,3 +1,16 @@
+2012-05-11  Thomas Koenig  <tkoenig@gcc.gnu.org>
+
+       PR fortran/52537
+       * frontend-passes.c (optimize_op):  Change
+       old-style comparison operators to new-style, simplify
+       switch as a result.
+       (empty_string):  New function.
+       (get_len_trim_call):  New function.
+       (optimize_comparison):  If comparing to an empty string,
+       use comparison of len_trim to zero.
+       Use new-style comparison operators only.
+       (optimize_trim):  Use get_len_trim_call.
+
 2012-05-11  Manuel López-Ibáñez  <manu@gcc.gnu.org>
 
        PR 53063
@@ -7,7 +20,7 @@
        (gfc_handle_option): Set it here using handle_generated_option.
 
 2012-05-08  Jan Hubicka  <jh@suse.cz>
-       
+
        * trans-common.c (create_common): Do not fake TREE_ASM_WRITTEN.
        * trans-decl.c (gfc_finish_cray_pointee): Likewise.
 
index 92a3f8fb3b273f5bc7eb500cfc36a1fdbdb05bb7..5361d86c5435f3ddf0128dbc5ed90ac876191845 100644 (file)
@@ -806,20 +806,45 @@ optimize_op (gfc_expr *e)
 {
   gfc_intrinsic_op op = e->value.op.op;
 
+  /* Only use new-style comparisions.  */
+  switch(op)
+    {
+    case INTRINSIC_EQ_OS:
+      op = INTRINSIC_EQ;
+      break;
+
+    case INTRINSIC_GE_OS:
+      op = INTRINSIC_GE;
+      break;
+
+    case INTRINSIC_LE_OS:
+      op = INTRINSIC_LE;
+      break;
+
+    case INTRINSIC_NE_OS:
+      op = INTRINSIC_NE;
+      break;
+
+    case INTRINSIC_GT_OS:
+      op = INTRINSIC_GT;
+      break;
+
+    case INTRINSIC_LT_OS:
+      op = INTRINSIC_LT;
+      break;
+
+    default:
+      break;
+    }
+
   switch (op)
     {
     case INTRINSIC_EQ:
-    case INTRINSIC_EQ_OS:
     case INTRINSIC_GE:
-    case INTRINSIC_GE_OS:
     case INTRINSIC_LE:
-    case INTRINSIC_LE_OS:
     case INTRINSIC_NE:
-    case INTRINSIC_NE_OS:
     case INTRINSIC_GT:
-    case INTRINSIC_GT_OS:
     case INTRINSIC_LT:
-    case INTRINSIC_LT_OS:
       return optimize_comparison (e, op);
 
     default:
@@ -829,6 +854,63 @@ optimize_op (gfc_expr *e)
   return false;
 }
 
+
+/* Return true if a constant string contains only blanks.  */
+
+static bool
+empty_string (gfc_expr *e)
+{
+  int i;
+
+  if (e->ts.type != BT_CHARACTER || e->expr_type != EXPR_CONSTANT)
+    return false;
+
+  for (i=0; i < e->value.character.length; i++)
+    {
+      if (e->value.character.string[i] != ' ')
+       return false;
+    }
+
+  return true;
+}
+
+
+/* Insert a call to the intrinsic len_trim. Use a different name for
+   the symbol tree so we don't run into trouble when the user has
+   renamed len_trim for some reason.  */
+
+static gfc_expr*
+get_len_trim_call (gfc_expr *str, int kind)
+{
+  gfc_expr *fcn;
+  gfc_actual_arglist *actual_arglist, *next;
+
+  fcn = gfc_get_expr ();
+  fcn->expr_type = EXPR_FUNCTION;
+  fcn->value.function.isym = gfc_intrinsic_function_by_id (GFC_ISYM_LEN_TRIM);
+  actual_arglist = gfc_get_actual_arglist ();
+  actual_arglist->expr = str;
+  next = gfc_get_actual_arglist ();
+  next->expr = gfc_get_int_expr (gfc_default_integer_kind, NULL, kind);
+  actual_arglist->next = next;
+
+  fcn->value.function.actual = actual_arglist;
+  fcn->where = str->where;
+  fcn->ts.type = BT_INTEGER;
+  fcn->ts.kind = gfc_charlen_int_kind;
+
+  gfc_get_sym_tree ("__internal_len_trim", current_ns, &fcn->symtree, false);
+  fcn->symtree->n.sym->ts = fcn->ts;
+  fcn->symtree->n.sym->attr.flavor = FL_PROCEDURE;
+  fcn->symtree->n.sym->attr.function = 1;
+  fcn->symtree->n.sym->attr.elemental = 1;
+  fcn->symtree->n.sym->attr.referenced = 1;
+  fcn->symtree->n.sym->attr.access = ACCESS_PRIVATE;
+  gfc_commit_symbol (fcn->symtree->n.sym);
+
+  return fcn;
+}
+
 /* Optimize expressions for equality.  */
 
 static bool
@@ -872,6 +954,45 @@ optimize_comparison (gfc_expr *e, gfc_intrinsic_op op)
   if (e->rank > 0)
     return change;
 
+  /* Replace a == '' with len_trim(a) == 0 and a /= '' with
+     len_trim(a) != 0 */
+  if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER
+      && (op == INTRINSIC_EQ || op == INTRINSIC_NE))
+    {
+      bool empty_op1, empty_op2;
+      empty_op1 = empty_string (op1);
+      empty_op2 = empty_string (op2);
+
+      if (empty_op1 || empty_op2)
+       {
+         gfc_expr *fcn;
+         gfc_expr *zero;
+         gfc_expr *str;
+
+         /* This can only happen when an error for comparing
+            characters of different kinds has already been issued.  */
+         if (empty_op1 && empty_op2)
+           return false;
+
+         zero = gfc_get_int_expr (gfc_charlen_int_kind, &e->where, 0);
+         str = empty_op1 ? op2 : op1;
+
+         fcn = get_len_trim_call (str, gfc_charlen_int_kind);
+
+
+         if (empty_op1)
+           gfc_free_expr (op1);
+         else
+           gfc_free_expr (op2);
+
+         op1 = fcn;
+         op2 = zero;
+         e->value.op.op1 = fcn;
+         e->value.op.op2 = zero;
+       }
+    }
+
+
   /* Don't compare REAL or COMPLEX expressions when honoring NaNs.  */
 
   if (flag_finite_math_only
@@ -945,32 +1066,26 @@ optimize_comparison (gfc_expr *e, gfc_intrinsic_op op)
          switch (op)
            {
            case INTRINSIC_EQ:
-           case INTRINSIC_EQ_OS:
              result = eq == 0;
              break;
              
            case INTRINSIC_GE:
-           case INTRINSIC_GE_OS:
              result = eq >= 0;
              break;
 
            case INTRINSIC_LE:
-           case INTRINSIC_LE_OS:
              result = eq <= 0;
              break;
 
            case INTRINSIC_NE:
-           case INTRINSIC_NE_OS:
              result = eq != 0;
              break;
 
            case INTRINSIC_GT:
-           case INTRINSIC_GT_OS:
              result = eq > 0;
              break;
 
            case INTRINSIC_LT:
-           case INTRINSIC_LT_OS:
              result = eq < 0;
              break;
              
@@ -1002,7 +1117,6 @@ optimize_trim (gfc_expr *e)
   gfc_expr *a;
   gfc_ref *ref;
   gfc_expr *fcn;
-  gfc_actual_arglist *actual_arglist, *next;
   gfc_ref **rr = NULL;
 
   /* Don't do this optimization within an argument list, because
@@ -1051,17 +1165,7 @@ optimize_trim (gfc_expr *e)
 
   /* Build the function call to len_trim(x, gfc_defaul_integer_kind).  */
 
-  fcn = gfc_get_expr ();
-  fcn->expr_type = EXPR_FUNCTION;
-  fcn->value.function.isym =
-    gfc_intrinsic_function_by_id (GFC_ISYM_LEN_TRIM);
-  actual_arglist = gfc_get_actual_arglist ();
-  actual_arglist->expr = gfc_copy_expr (e);
-  next = gfc_get_actual_arglist ();
-  next->expr = gfc_get_int_expr (gfc_default_integer_kind, NULL,
-                                gfc_default_integer_kind);
-  actual_arglist->next = next;
-  fcn->value.function.actual = actual_arglist;
+  fcn = get_len_trim_call (gfc_copy_expr (e), gfc_default_integer_kind);
 
   /* Set the end of the reference to the call to len_trim.  */
 
index 30e519426f8a40acad1f80a3881be4b84002b803..526e3971fc949606de715e78cfd37a951a98a6a3 100644 (file)
@@ -1,3 +1,8 @@
+2012-05-11  Thomas Koenig  <tkoenig@gcc.gnu.org>
+
+       PR fortran/52537
+       * gfortran.dg/string_compare_4.f90:  New test.
+
 2012-05-11  Rainer Orth  <ro@CeBiTec.Uni-Bielefeld.DE>
 
        * g++.dg/debug/dwarf2/nested-3.C: Allow for ! comments.
diff --git a/gcc/testsuite/gfortran.dg/string_compare_4.f90 b/gcc/testsuite/gfortran.dg/string_compare_4.f90
new file mode 100644 (file)
index 0000000..80f1057
--- /dev/null
@@ -0,0 +1,20 @@
+! { dg-do compile }
+! { dg-options "-ffrontend-optimize -fdump-fortran-original" }
+! PR fortran/52537 - optimize comparisons with empty strings
+program main
+  implicit none
+  character(len=10) :: a
+  character(len=30) :: line
+  line = 'x'
+  read (unit=line,fmt='(A)') a
+  if (trim(a) == '') print *,"empty"
+  call foo(a)
+  if (trim(a) == '    ') print *,"empty"
+contains
+  subroutine foo(b)
+    character(*) :: b
+    if (b /= '   ') print *,"full"
+  end subroutine foo
+end program main
+! { dg-final { scan-tree-dump-times "_gfortran_string_len_trim" 3 "original" } }
+! { dg-final { cleanup-tree-dump "original" } }