diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 9f2f537a924b..aaff962c88f9 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,9 @@ +2005-05-26 Thomas Koenig + + PR libfortran/17283 + * gfortran.fortran-torture/execute/intrinsic_unpack.f90: + Test callee-allocated memory with write statements. + 2005-05-25 Roger Sayle PR middle-end/21709 diff --git a/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_unpack.f90 b/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_unpack.f90 index 807aadf136ff..88f09c321b4d 100644 --- a/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_unpack.f90 +++ b/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_unpack.f90 @@ -2,6 +2,7 @@ program intrinsic_unpack integer, dimension(3, 3) :: a, b logical, dimension(3, 3) :: mask; + character(len=50) line1, line2 integer i mask = reshape ((/.false.,.true.,.false.,.true.,.false.,.false.,& @@ -10,6 +11,9 @@ program intrinsic_unpack b = unpack ((/2, 3, 4/), mask, a) if (any (b .ne. reshape ((/1, 2, 0, 3, 1, 0, 0, 0, 4/), (/3, 3/)))) & call abort + write (line1,'(10I4)') b + write (line2,'(10I4)') unpack((/2, 3, 4/), mask, a) + if (line1 .ne. line2) call abort b = -1 b = unpack ((/2, 3, 4/), mask, 0) if (any (b .ne. reshape ((/0, 2, 0, 3, 0, 0, 0, 0, 4/), (/3, 3/)))) & diff --git a/libgfortran/ChangeLog b/libgfortran/ChangeLog index 94b9b84329b3..8f2e25d9d29f 100644 --- a/libgfortran/ChangeLog +++ b/libgfortran/ChangeLog @@ -1,3 +1,12 @@ +2005-05-26 Thomas Koenig + + PR libfortran/17283 + * intrinsics/unpack_generic.c: Fix name of routine + on top. Update copyright years. + (unpack1): Remove const from return array descriptor. + rs: New variable, for calculating return sizes. + Populate return array descriptor if ret->data is NULL. + 2005-05-22 Peter Wainwright PR libfortran/21376 diff --git a/libgfortran/intrinsics/unpack_generic.c b/libgfortran/intrinsics/unpack_generic.c index 57eb30c6480d..a5c098b0e819 100644 --- a/libgfortran/intrinsics/unpack_generic.c +++ b/libgfortran/intrinsics/unpack_generic.c @@ -1,5 +1,5 @@ -/* Generic implementation of the RESHAPE intrinsic - Copyright 2002 Free Software Foundation, Inc. +/* Generic implementation of the UNPACK intrinsic + Copyright 2002, 2003, 2004, 2005 Free Software Foundation, Inc. Contributed by Paul Brook This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -34,17 +34,18 @@ Boston, MA 02111-1307, USA. */ #include #include "libgfortran.h" -extern void unpack1 (const gfc_array_char *, const gfc_array_char *, +extern void unpack1 (gfc_array_char *, const gfc_array_char *, const gfc_array_l4 *, const gfc_array_char *); iexport_proto(unpack1); void -unpack1 (const gfc_array_char *ret, const gfc_array_char *vector, +unpack1 (gfc_array_char *ret, const gfc_array_char *vector, const gfc_array_l4 *mask, const gfc_array_char *field) { /* r.* indicates the return array. */ index_type rstride[GFC_MAX_DIMENSIONS]; index_type rstride0; + index_type rs; char *rptr; /* v.* indicates the vector array. */ index_type vstride0; @@ -68,17 +69,41 @@ unpack1 (const gfc_array_char *ret, const gfc_array_char *vector, size = GFC_DESCRIPTOR_SIZE (ret); /* A field element size of 0 actually means this is a scalar. */ fsize = GFC_DESCRIPTOR_SIZE (field); - dim = GFC_DESCRIPTOR_RANK (ret); - for (n = 0; n < dim; n++) + if (ret->data == NULL) { - count[n] = 0; - extent[n] = ret->dim[n].ubound + 1 - ret->dim[n].lbound; - rstride[n] = ret->dim[n].stride * size; - fstride[n] = field->dim[n].stride * fsize; - mstride[n] = mask->dim[n].stride; + /* The front end has signalled that we need to populate the + return array descriptor. */ + dim = GFC_DESCRIPTOR_RANK (mask); + rs = 1; + for (n = 0; n < dim; n++) + { + count[n] = 0; + ret->dim[n].stride = rs; + ret->dim[n].lbound = 0; + ret->dim[n].ubound = mask->dim[n].ubound - mask->dim[n].lbound; + extent[n] = ret->dim[n].ubound + 1; + rstride[n] = ret->dim[n].stride * size; + fstride[n] = field->dim[n].stride * fsize; + mstride[n] = mask->dim[n].stride; + rs *= extent[n]; + } + ret->base = 0; + ret->data = internal_malloc_size (rs * size); + } + else + { + dim = GFC_DESCRIPTOR_RANK (ret); + for (n = 0; n < dim; n++) + { + count[n] = 0; + extent[n] = ret->dim[n].ubound + 1 - ret->dim[n].lbound; + rstride[n] = ret->dim[n].stride * size; + fstride[n] = field->dim[n].stride * fsize; + mstride[n] = mask->dim[n].stride; + } + if (rstride[0] == 0) + rstride[0] = size; } - if (rstride[0] == 0) - rstride[0] = size; if (fstride[0] == 0) fstride[0] = fsize; if (mstride[0] == 0)