re PR fortran/33455 (MERGE intrinsic: Check for same string lengths)

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.

From-SVN: r128647

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)
 {

gcc/testsuite/ChangeLog

 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
 	* gfortran.dg/transfer_check_1.f90: New.
 

gcc/testsuite/gfortran.dg/merge_char_2.f90

+! { 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