OpenE2K/gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

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

Browse Source 
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
This commit is contained in:
Tobias Burnus 2007-09-21 12:44:20 +02:00 committed by Tobias Burnus
parent 92ebaacd31
commit 90d3112688
3 changed files with 61 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

40
gcc/fortran/check.c
View File

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

5
gcc/testsuite/ChangeLog
View File

@ -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

16
gcc/testsuite/gfortran.dg/merge_char_2.f90 Normal file
View File

@ -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