diff options
| author | Tobias Burnus <burnus@net-b.de> | 2007-09-21 12:44:20 +0200 |
|---|---|---|
| committer | Tobias Burnus <burnus@gcc.gnu.org> | 2007-09-21 12:44:20 +0200 |
| commit | 90d3112688947ecc4ded8bc8a64c224ed39f7a45 (patch) | |
| tree | 7f81f43011fdc3e72495a6e8b725ca246d9917d3 /gcc | |
| parent | 92ebaacd31b79e0be6eea759c2f66bbb020b3235 (diff) | |
| download | gcc-90d3112688947ecc4ded8bc8a64c224ed39f7a45.zip gcc-90d3112688947ecc4ded8bc8a64c224ed39f7a45.tar.gz gcc-90d3112688947ecc4ded8bc8a64c224ed39f7a45.tar.bz2 | |
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
Diffstat (limited to 'gcc')
| -rw-r--r-- | gcc/fortran/check.c | 40 | ||||
| -rw-r--r-- | gcc/testsuite/ChangeLog | 5 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/merge_char_2.f90 | 16 |
3 files changed, 61 insertions, 0 deletions
diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c index 5f3f92d..6f6a805 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 29b0c26..a033d18 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,5 +1,10 @@ 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. 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 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 |