From 90d3112688947ecc4ded8bc8a64c224ed39f7a45 Mon Sep 17 00:00:00 2001 From: Tobias Burnus Date: Fri, 21 Sep 2007 12:44:20 +0200 Subject: [PATCH] re PR fortran/33455 (MERGE intrinsic: Check for same string lengths) 2007-09-21 Tobias Burnus PR fortran/33455 * check.c (check_same_strlen): New function. (gfc_check_merge): Use it. 2007-09-21 Tobias Burnus PR fortran/33455 * gfortran.dg/merge_char_3.f90: New. From-SVN: r128647 --- gcc/fortran/check.c | 40 ++++++++++++++++++++++ gcc/testsuite/ChangeLog | 5 +++ gcc/testsuite/gfortran.dg/merge_char_2.f90 | 16 +++++++++ 3 files changed, 61 insertions(+) create mode 100644 gcc/testsuite/gfortran.dg/merge_char_2.f90 diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c index 5f3f92df4fb..6f6a805d832 100644 --- 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 29b0c26a033..a033d187048 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,8 @@ +2007-09-21 Tobias Burnus + + PR fortran/33455 + * gfortran.dg/merge_char_3.f90: New. + 2007-09-21 Tobias Burnus 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 index 00000000000..31ace4b8e16 --- /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