2007-09-21 Tobias Burnus <burnus@net-b.de>

        PR fortran/33455
        * check.c (check_same_strlen): New function.
        (gfc_check_merge): Use it.

2007-09-21  Tobias Burnus  <burnus@net-b.de>

        PR fortran/33455
        * gfortran.dg/merge_char_3.f90: New.

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

diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c
index 5f3f92df4fbfe7b51a387d05afc54b8154e30a1c..6f6a805d8326f55866bebd0bc96d9ee2096946f8 100644 (file)
--- a/gcc/fortran/check.c
+++ b/gcc/fortran/check.c
@@ -400,6 +400,42 @@ identical_dimen_shape (gfc_expr *a, int ai, gfc_expr *b, int bi)
 }
 
 
+/* Check whether two character expressions have the same length;
+   returns SUCCESS if they have or if the length cannot be determined.  */
+
+static try
+check_same_strlen (const gfc_expr *a, const gfc_expr *b, const char *name)
+{
+   long len_a, len_b;
+   len_a = len_b = -1;
+
+   if (a->ts.cl && a->ts.cl->length
+       && a->ts.cl->length->expr_type == EXPR_CONSTANT)
+     len_a = mpz_get_si (a->ts.cl->length->value.integer);
+   else if (a->expr_type == EXPR_CONSTANT
+           && (a->ts.cl == NULL || a->ts.cl->length == NULL))
+     len_a = a->value.character.length;
+   else
+     return SUCCESS;
+
+   if (b->ts.cl && b->ts.cl->length
+       && b->ts.cl->length->expr_type == EXPR_CONSTANT)
+     len_b = mpz_get_si (b->ts.cl->length->value.integer);
+   else if (b->expr_type == EXPR_CONSTANT
+           && (b->ts.cl == NULL || b->ts.cl->length == NULL))
+     len_b = b->value.character.length;
+   else
+     return SUCCESS;
+
+   if (len_a == len_b)
+     return SUCCESS;
+
+   gfc_error ("Unequal character lengths (%ld and %ld) in %s intrinsic "
+             "at %L", len_a, len_b, name, &a->where);
+   return FAILURE;
+}
+
+
 /***** Check functions *****/
 
 /* Check subroutine suitable for intrinsics taking a real argument and
@@ -1823,9 +1859,13 @@ gfc_check_merge (gfc_expr *tsource, gfc_expr *fsource, gfc_expr *mask)
   if (type_check (mask, 2, BT_LOGICAL) == FAILURE)
     return FAILURE;
 
+  if (tsource->ts.type == BT_CHARACTER)
+    return check_same_strlen (tsource, fsource, "MERGE");
+
   return SUCCESS;
 }
 
+
 try
 gfc_check_move_alloc (gfc_expr *from, gfc_expr *to)
 {

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 29b0c26a033a30a92b109d72b27267a5d7bd5a98..a033d187048767d48afdeacf2c34e64f8c571736 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,8 @@
+2007-09-21  Tobias Burnus  <burnus@net-b.de>
+
+       PR fortran/33455
+       * gfortran.dg/merge_char_3.f90: New.
+
 2007-09-21  Tobias Burnus  <burnus@net-b.de>
 
        PR fortran/33037

diff --git a/gcc/testsuite/gfortran.dg/merge_char_2.f90 b/gcc/testsuite/gfortran.dg/merge_char_2.f90
new file mode 100644 (file)
index 0000000..31ace4b
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/merge_char_2.f90
@@ -0,0 +1,16 @@
+! { dg-do compile }
+!
+! See PR fortran/31610
+!
+implicit none
+character(len=2) :: a
+character(len=3) :: b
+print *, merge(a,a,.true.)
+print *, merge(a,'aa',.true.)
+print *, merge('aa',a,.true.)
+print *, merge('aa','bb',.true.)
+print *, merge(a,   b,    .true.)  ! { dg-error "Unequal character lengths" }
+print *, merge(a,   'bbb',.true.)  ! { dg-error "Unequal character lengths" }
+print *, merge('aa',b,    .true.)  ! { dg-error "Unequal character lengths" }
+print *, merge('aa','bbb',.true.)  ! { dg-error "Unequal character lengths" }
+end