From bab651ad74c5b68cbb1405fe407934d1d9f8aa77 Mon Sep 17 00:00:00 2001 From: Paul Thomas Date: Tue, 5 Dec 2006 19:32:59 +0000 Subject: [PATCH] re PR fortran/29912 ([4.1 only] Gfortran: string array functions behaving incorrectly...) 2006-12-05 Paul Thomas PR fortran/29912 * trans-expr.c (gfc_trans_arrayfunc_assign): Return NULL if the lhs and rhs character lengths are not constant and equal for character array valued functions. 2006-12-05 Paul Thomas PR fortran/29912 * gfortran.dg/char_result_12.f90: New test. From-SVN: r119554 --- gcc/fortran/ChangeLog | 7 +++++ gcc/fortran/trans-expr.c | 17 +++++++++++ gcc/testsuite/ChangeLog | 5 ++++ gcc/testsuite/gfortran.dg/char_result_12.f90 | 31 ++++++++++++++++++++ 4 files changed, 60 insertions(+) create mode 100644 gcc/testsuite/gfortran.dg/char_result_12.f90 diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index eeaaa481b2a4..a65b4a731960 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,10 @@ +2006-12-05 Paul Thomas + + PR fortran/29912 + * trans-expr.c (gfc_trans_arrayfunc_assign): Return NULL if the + lhs and rhs character lengths are not constant and equal for + character array valued functions. + 2006-12-04 Tobias Burnus PR fortran/29962 diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index 3505236ab477..7c064ffd827f 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -3382,6 +3382,23 @@ gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2) || expr2->symtree->n.sym->attr.allocatable) return NULL; + /* Character array functions need temporaries unless the + character lengths are the same. */ + if (expr2->ts.type == BT_CHARACTER && expr2->rank > 0) + { + if (expr1->ts.cl->length == NULL + || expr1->ts.cl->length->expr_type != EXPR_CONSTANT) + return NULL; + + if (expr2->ts.cl->length == NULL + || expr2->ts.cl->length->expr_type != EXPR_CONSTANT) + return NULL; + + if (mpz_cmp (expr1->ts.cl->length->value.integer, + expr2->ts.cl->length->value.integer) != 0) + return NULL; + } + /* Check that no LHS component references appear during an array reference. This is needed because we do not have the means to span any arbitrary stride with an array descriptor. This check diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 0d6d81449024..363e298502a2 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,8 @@ +2006-12-05 Paul Thomas + + PR fortran/29912 + * gfortran.dg/char_result_12.f90: New test. + 2006-12-05 Richard Guenther * gcc.dg/vect/vect.exp: Add support for -fno-math-errno tests. diff --git a/gcc/testsuite/gfortran.dg/char_result_12.f90 b/gcc/testsuite/gfortran.dg/char_result_12.f90 new file mode 100644 index 000000000000..b6ddfc089ac3 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/char_result_12.f90 @@ -0,0 +1,31 @@ +! { dg-do run } +! Tests the fix for PR29912, in which the call to JETTER +! would cause a segfault beause a temporary was not being written. +! +! COntributed by Philip Mason +! + program testat + character(len=4) :: ctemp(2) + character(len=512) :: temper(2) + ! + !------------------------ + !'This was OK.' + !------------------------ + temper(1) = 'doncaster' + temper(2) = 'uxbridge' + ctemp = temper + if (any (ctemp /= ["donc", "uxbr"])) call abort () + ! + !------------------------ + !'This went a bit wrong.' + !------------------------ + ctemp = jetter(1,2) + if (any (ctemp /= ["donc", "uxbr"])) call abort () + + contains + function jetter(id1,id2) + character(len=512) :: jetter(id1:id2) + jetter(id1) = 'doncaster' + jetter(id2) = 'uxbridge' + end function jetter + end program testat -- 2.47.2