From 07818af47b961b903aee005f6771e14730d3e003 Mon Sep 17 00:00:00 2001 From: Thomas Koenig Date: Fri, 24 Dec 2010 08:42:04 +0000 Subject: [PATCH] re PR fortran/31821 (character pointer => target(range) should detect if lengths don't match) 2010-12-24 Thomas Koenig PR fortran/31821 * check.c (gfc_var_strlen): New function, also including substring references. (gfc_check_same_strlen): Use gfc_var_strlen. 2010-12-24 Thomas Koenig PR fortran/31821 * gfortran.dg/char_pointer_assign_6.f90: New test. From-SVN: r168224 --- gcc/fortran/ChangeLog | 7 ++ gcc/fortran/check.c | 79 +++++++++++++------ gcc/testsuite/ChangeLog | 5 ++ .../gfortran.dg/char_pointer_assign_6.f90 | 11 +++ 4 files changed, 77 insertions(+), 25 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/char_pointer_assign_6.f90 diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 4ffb3e3d6d0..980d1b1a127 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,10 @@ +2010-12-24 Thomas Koenig + + PR fortran/31821 + * check.c (gfc_var_strlen): New function, also including + substring references. + (gfc_check_same_strlen): Use gfc_var_strlen. + 2010-12-23 Mikael Morin PR fortran/46978 diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c index ceea6f313e4..20163f99a55 100644 --- a/gcc/fortran/check.c +++ b/gcc/fortran/check.c @@ -635,40 +635,69 @@ identical_dimen_shape (gfc_expr *a, int ai, gfc_expr *b, int bi) return ret; } +/* Calculate the length of a character variable, including substrings. + Strip away parentheses if necessary. Return -1 if no length could + be determined. */ + +static long +gfc_var_strlen (const gfc_expr *a) +{ + gfc_ref *ra; + + while (a->expr_type == EXPR_OP && a->value.op.op == INTRINSIC_PARENTHESES) + a = a->value.op.op1; + + for (ra = a->ref; ra != NULL && ra->type != REF_SUBSTRING; ra = ra->next) + ; + + if (ra) + { + long start_a, end_a; + + if (ra->u.ss.start->expr_type == EXPR_CONSTANT + && ra->u.ss.end->expr_type == EXPR_CONSTANT) + { + start_a = mpz_get_si (ra->u.ss.start->value.integer); + end_a = mpz_get_si (ra->u.ss.end->value.integer); + return end_a - start_a + 1; + } + else if (gfc_dep_compare_expr (ra->u.ss.start, ra->u.ss.end) == 0) + return 1; + else + return -1; + } + + if (a->ts.u.cl && a->ts.u.cl->length + && a->ts.u.cl->length->expr_type == EXPR_CONSTANT) + return mpz_get_si (a->ts.u.cl->length->value.integer); + else if (a->expr_type == EXPR_CONSTANT + && (a->ts.u.cl == NULL || a->ts.u.cl->length == NULL)) + return a->value.character.length; + else + return -1; + +} /* Check whether two character expressions have the same length; - returns SUCCESS if they have or if the length cannot be determined. */ + returns SUCCESS if they have or if the length cannot be determined, + otherwise return FAILURE and raise a gfc_error. */ gfc_try gfc_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.u.cl && a->ts.u.cl->length - && a->ts.u.cl->length->expr_type == EXPR_CONSTANT) - len_a = mpz_get_si (a->ts.u.cl->length->value.integer); - else if (a->expr_type == EXPR_CONSTANT - && (a->ts.u.cl == NULL || a->ts.u.cl->length == NULL)) - len_a = a->value.character.length; + len_a = gfc_var_strlen(a); + len_b = gfc_var_strlen(b); + + if (len_a == -1 || len_b == -1 || len_a == len_b) + return SUCCESS; else - return SUCCESS; - - if (b->ts.u.cl && b->ts.u.cl->length - && b->ts.u.cl->length->expr_type == EXPR_CONSTANT) - len_b = mpz_get_si (b->ts.u.cl->length->value.integer); - else if (b->expr_type == EXPR_CONSTANT - && (b->ts.u.cl == NULL || b->ts.u.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/%ld) in %s at %L", - len_a, len_b, name, &a->where); - return FAILURE; + { + gfc_error ("Unequal character lengths (%ld/%ld) in %s at %L", + len_a, len_b, name, &a->where); + return FAILURE; + } } diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index f695502c715..bd527d7a4a3 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,8 @@ +2010-12-24 Thomas Koenig + + PR fortran/31821 + * gfortran.dg/char_pointer_assign_6.f90: New test. + 2010-12-22 Sebastian Pop PR tree-optimization/46758 diff --git a/gcc/testsuite/gfortran.dg/char_pointer_assign_6.f90 b/gcc/testsuite/gfortran.dg/char_pointer_assign_6.f90 new file mode 100644 index 00000000000..cd90bfc06e3 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/char_pointer_assign_6.f90 @@ -0,0 +1,11 @@ +! { dg-do compile } +! PR 31821 +program main + character (len=4), pointer:: s1 + character (len=20), pointer :: p1 + character (len=4) :: c + s1 = 'abcd' + p1 => s1(2:3) ! { dg-error "Unequal character lengths \\(20/2\\)" } + p1 => c(1:) ! { dg-error "Unequal character lengths \\(20/4\\)" } + p1 => c(:4) ! { dg-error "Unequal character lengths \\(20/4\\)" } +end