[patch, libfortran] PR 17283 unpack issues
Thomas Koenig
Thomas.Koenig@online.de
Tue May 24 21:20:00 GMT 2005
This fixes the temporary allocation issues with unpack.
Regression-tested on mainline and 4.0. OK to commit?
Thomas
2005-05-22 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-22 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.
-------------- next part --------------
Index: unpack_generic.c
===================================================================
RCS file: /cvs/gcc/gcc/libgfortran/intrinsics/unpack_generic.c,v
retrieving revision 1.6
diff -c -p -r1.6 unpack_generic.c
*** unpack_generic.c 12 Jan 2005 21:27:30 -0000 1.6
--- unpack_generic.c 24 May 2005 21:00:06 -0000
***************
*** 1,5 ****
! /* Generic implementation of the RESHAPE intrinsic
! Copyright 2002 Free Software Foundation, Inc.
Contributed by Paul Brook <paul@nowt.org>
This file is part of the GNU Fortran 95 runtime library (libgfortran).
--- 1,5 ----
! /* 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).
*************** Boston, MA 02111-1307, USA. */
*** 34,50 ****
#include <string.h>
#include "libgfortran.h"
! extern void unpack1 (const 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,
const gfc_array_l4 *mask, const gfc_array_char *field)
{
/* r.* indicates the return array. */
index_type rstride[GFC_MAX_DIMENSIONS];
index_type rstride0;
char *rptr;
/* v.* indicates the vector array. */
index_type vstride0;
--- 34,51 ----
#include <string.h>
#include "libgfortran.h"
! extern void unpack1 (gfc_array_char *, const gfc_array_char *,
const gfc_array_l4 *, const gfc_array_char *);
iexport_proto(unpack1);
void
! 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;
*************** unpack1 (const gfc_array_char *ret, cons
*** 68,84 ****
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++)
{
! 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 (fstride[0] == 0)
fstride[0] = fsize;
if (mstride[0] == 0)
--- 69,109 ----
size = GFC_DESCRIPTOR_SIZE (ret);
/* A field element size of 0 actually means this is a scalar. */
fsize = GFC_DESCRIPTOR_SIZE (field);
! if (ret->data == NULL)
{
! /* 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 (fstride[0] == 0)
fstride[0] = fsize;
if (mstride[0] == 0)
-------------- next part --------------
Index: gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_unpack.f90
===================================================================
RCS file: /cvs/gcc/gcc/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_unpack.f90,v
retrieving revision 1.2
diff -c -r1.2 intrinsic_unpack.f90
*** gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_unpack.f90 13 May 2004 06:40:53 -0000 1.2
--- gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_unpack.f90 23 May 2005 20:36:47 -0000
***************
*** 2,7 ****
--- 2,8 ----
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,15 ****
--- 11,19 ----
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/)))) &
More information about the Fortran
mailing list