diff options
| author | Thomas Koenig <Thomas.Koenig@online.de> | 2005-05-26 06:26:17 +0000 |
|---|---|---|
| committer | Thomas Koenig <tkoenig@gcc.gnu.org> | 2005-05-26 06:26:17 +0000 |
| commit | ba4a3d54bac34bb261bacffd774d9810d679d971 (patch) | |
| tree | 2dfb829db3fc4cd9eef650e2f573a400e0c914ee /libgfortran/intrinsics/unpack_generic.c | |
| parent | c10166c437ce15a119b663ac153a6bbcddb1ce84 (diff) | |
| download | gcc-ba4a3d54bac34bb261bacffd774d9810d679d971.tar.gz | |
re PR fortran/17283 (UNPACK issues)
2005-05-26 Thomas Koenig <Thomas.Koenig@online.de>
PR libfortran/17283
* gfortran.fortran-torture/execute/intrinsic_unpack.f90:
Test callee-allocated memory with write statements.
2005-05-26 Thomas Koenig <Thomas.Koenig@online.de>
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.
From-SVN: r100189
Diffstat (limited to 'libgfortran/intrinsics/unpack_generic.c')
| -rw-r--r-- | libgfortran/intrinsics/unpack_generic.c | 51 |
1 files changed, 38 insertions, 13 deletions
diff --git a/libgfortran/intrinsics/unpack_generic.c b/libgfortran/intrinsics/unpack_generic.c index 57eb30c6480..a5c098b0e81 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 <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -34,17 +34,18 @@ Boston, MA 02111-1307, USA. */ #include <string.h> #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) |