mirror/gcc
2
0
Fork 0
mirror of git://gcc.gnu.org/git/gcc.git synced 2025-03-19 03:20:28 +08:00
Code Issues Packages Projects Releases Wiki Activity

re PR fortran/17283 (UNPACK issues)

Browse Source 
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
This commit is contained in:
Thomas Koenig 2005-05-26 06:26:17 +00:00 committed by Thomas Koenig
parent c10166c437
commit ba4a3d54ba
4 changed files with 57 additions and 13 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
gcc/testsuite/ChangeLog
View File

@ -1,3 +1,9 @@
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-25 Roger Sayle <roger@eyesopen.com>
PR middle-end/21709

4
gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_unpack.f90
View File

@ -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/)))) &

9
libgfortran/ChangeLog
View File

@ -1,3 +1,12 @@
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.
2005-05-22 Peter Wainwright <prw@ceiriog1.demon.co.uk>
PR libfortran/21376

51
libgfortran/intrinsics/unpack_generic.c
View File

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