mirror/gcc
2
0
Fork 0
mirror of git://gcc.gnu.org/git/gcc.git synced 2025-02-06 14:40:31 +08:00
Code Issues Packages Projects Releases Wiki Activity

re PR fortran/17283 (UNPACK issues)

Browse Source 
PR fortran/17283
fortran/
* iresolve.c (gfc_resolve_pack): Choose function depending if mask is
scalar.
libgfortran/
* intrinsics/pack_generic.c (__pack): Allocate memory for return array
if not done by caller.
(__pack_s): New function.
* runtime/memory.c (internal_malloc, internal_malloc64): Allow
allocating zero memory.
testsuite/
* gfortran.fortran-torture/execute/intrinsic_pack.f90: Add more tests.

From-SVN: r88526
This commit is contained in:
Tobias Schlüter 2004-10-04 21:27:29 +02:00 committed by Tobias Schlüter
parent 110aba1432
commit 58c5b409e8
7 changed files with 336 additions and 18 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
gcc/fortran/ChangeLog
View File

@ -1,3 +1,9 @@
2004-10-04 Tobias Schlueter <tobias.schlueter@physik.uni-muenchen.de>
PR fortran/17283
* iresolve.c (gfc_resolve_pack): Choose function depending if mask
is scalar.
2004-10-04 Erik Schnetter <schnetter@aei.mpg.de>
* scanner.c (preprocessor_line): Accept preprocessor lines without

24
gcc/fortran/iresolve.c
View File

@ -1022,15 +1022,33 @@ gfc_resolve_not (gfc_expr * f, gfc_expr * i)
void
gfc_resolve_pack (gfc_expr * f,
gfc_expr * array ATTRIBUTE_UNUSED,
gfc_expr * mask ATTRIBUTE_UNUSED,
gfc_expr * mask,
gfc_expr * vector ATTRIBUTE_UNUSED)
{
static char pack[] = "__pack";
static char pack[] = "__pack",
pack_s[] = "__pack_s";
f->ts = array->ts;
f->rank = 1;
f->value.function.name = pack;
if (mask->rank != 0)
f->value.function.name = pack;
else
{
/* We convert mask to default logical only in the scalar case.
In the array case we can simply read the array as if it were
of type default logical. */
if (mask->ts.kind != gfc_default_logical_kind)
{
gfc_typespec ts;
ts.type = BT_LOGICAL;
ts.kind = gfc_default_logical_kind;
gfc_convert_type (mask, &ts, 2);
}
f->value.function.name = pack_s;
}
}

5
gcc/testsuite/ChangeLog
View File

@ -1,3 +1,8 @@
2004-10-04 Tobias Schlueter <tobias.schlueter@physik.uni-muenchen.de>
PR fortran/17283
* gfortran.fortran-torture/execute/intrinsic_pack.f90: Add more tests.
2004-10-04 Chao-ying Fu <fu@mips.com>
* gcc.dg/vect/pr16105.c: Enable for mipsisa64*-*-*.

15
gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_pack.f90
View File

@ -1,12 +1,25 @@
! Program to test the PACK intrinsic
program intrinsic_pack
integer, parameter :: val(9) = (/0,0,0,0,9,0,0,0,7/)
integer, dimension(3, 3) :: a
integer, dimension(6) :: b
a = reshape ((/0, 0, 0, 0, 9, 0, 0, 0, 7/), (/3, 3/))
a = reshape (val, (/3, 3/))
b = 0
b(1:6:3) = pack (a, a .ne. 0);
if (any (b(1:6:3) .ne. (/9, 7/))) call abort
b = pack (a(2:3, 2:3), a(2:3, 2:3) .ne. 0, (/1, 2, 3, 4, 5, 6/));
if (any (b .ne. (/9, 7, 3, 4, 5, 6/))) call abort
! this is waiting for PR 17756 to be fixed
! call tests_with_temp()
contains
subroutine tests_with_temp
! A few tests which involve a temporary
if (any (pack(a, a.ne.0) .ne. (/9, 7/))) call abort
if (any (pack(a, .true.) .ne. val)) call abort
if (size(pack (a, .false.)) .ne. 0) call abort
if (any (pack(a, .false., (/1,2,3/)).ne. (/1,2,3/))) call abort
end subroutine tests_with_temp
end program

9
libgfortran/ChangeLog
View File

@ -1,3 +1,12 @@
2004-10-04 Tobias Schlueter <tobias.schlueter@physik.uni-muenchen.de>
PR fortran/17283
* intrinsics/pack_generic.c (__pack): Allocate memory for return array
if not done by caller.
(__pack_s): New function.
* runtime/memory.c (internal_malloc, internal_malloc64): Allow
allocating zero memory.
2004-10-04 Paul Brook <paul@codesourcery.com>
Bud Davis <bdavis9659@comcast.net>

287
libgfortran/intrinsics/pack_generic.c
View File

@ -1,5 +1,5 @@
/* Generic implementation of the RESHAPE intrinsic
Copyright 2002 Free Software Foundation, Inc.
/* Generic implementation of the PACK intrinsic
Copyright (C) 2002, 2004 Free Software Foundation, Inc.
Contributed by Paul Brook <paul@nowt.org>
This file is part of the GNU Fortran 95 runtime library (libgfor).
@ -25,9 +25,49 @@ Boston, MA 02111-1307, USA. */
#include <string.h>
#include "libgfortran.h"
/* PACK is specified as follows:
13.14.80 PACK (ARRAY, MASK, [VECTOR])
Description: Pack an array into an array of rank one under the
control of a mask.
Class: Transformational fucntion.
Arguments:
ARRAY may be of any type. It shall not be scalar.
MASK shall be of type LOGICAL. It shall be conformable with ARRAY.
VECTOR (optional) shall be of the same type and type parameters
as ARRAY. VECTOR shall have at least as many elements as
there are true elements in MASK. If MASK is a scalar
with the value true, VECTOR shall have at least as many
elements as there are in ARRAY.
Result Characteristics: The result is an array of rank one with the
same type and type parameters as ARRAY. If VECTOR is present, the
result size is that of VECTOR; otherwise, the result size is the
number /t/ of true elements in MASK unless MASK is scalar with the
value true, in which case the result size is the size of ARRAY.
Result Value: Element /i/ of the result is the element of ARRAY
that corresponds to the /i/th true element of MASK, taking elements
in array element order, for /i/ = 1, 2, ..., /t/. If VECTOR is
present and has size /n/ > /t/, element /i/ of the result has the
value VECTOR(/i/), for /i/ = /t/ + 1, ..., /n/.
Examples: The nonzero elements of an array M with the value
| 0 0 0 |
| 9 0 0 | may be "gathered" by the function PACK. The result of
| 0 0 7 |
PACK (M, MASK = M.NE.0) is [9,7] and the result of PACK (M, M.NE.0,
VECTOR = (/ 2,4,6,8,10,12 /)) is [9,7,6,8,10,12].
There are two variants of the PACK intrinsic: one, where MASK is
array valued, and the other one where MASK is scalar. */
void
__pack (const gfc_array_char * ret, const gfc_array_char * array,
const gfc_array_l4 * mask, const gfc_array_char * vector)
__pack (gfc_array_char * ret, const gfc_array_char * array,
const gfc_array_l4 * mask, const gfc_array_char * vector)
{
/* r.* indicates the return array. */
index_type rstride0;
@ -62,12 +102,6 @@ __pack (const gfc_array_char * ret, const gfc_array_char * array,
if (mstride[0] == 0)
mstride[0] = 1;
rstride0 = ret->dim[0].stride * size;
if (rstride0 == 0)
rstride0 = size;
sstride0 = sstride[0];
mstride0 = mstride[0];
rptr = ret->data;
sptr = array->data;
mptr = mask->data;
@ -82,6 +116,94 @@ __pack (const gfc_array_char * ret, const gfc_array_char * array,
mptr = GFOR_POINTER_L8_TO_L4 (mptr);
}
if (ret->data == NULL)
{
/* Allocate the memory for the result. */
int total;
if (vector != NULL)
{
/* The return array will have as many
elements as there are in VECTOR. */
total = vector->dim[0].ubound + 1 - vector->dim[0].lbound;
}
else
{
/* We have to count the true elements in MASK. */
/* TODO: We could speed up pack easily in the case of only
few .TRUE. entries in MASK, by keeping track of where we
would be in the source array during the initial traversal
of MASK, and caching the pointers to those elements. Then,
supposed the number of elements is small enough, we would
only have to traverse the list, and copy those elements
into the result array. In the case of datatypes which fit
in one of the integer types we could also cache the
value instead of a pointer to it.
This approach might be bad from the point of view of
cache behavior in the case where our cache is not big
enough to hold all elements that have to be copied. */
const GFC_LOGICAL_4 *m = mptr;
total = 0;
while (m)
{
/* Test this element. */
if (*m)
total++;
/* Advance to the next element. */
m += mstride[0];
count[0]++;
n = 0;
while (count[n] == extent[n])
{
/* When we get to the end of a dimension, reset it
and increment the next dimension. */
count[n] = 0;
/* We could precalculate this product, but this is a
less frequently used path so proabably not worth
it. */
m -= mstride[n] * extent[n];
n++;
if (n >= dim)
{
/* Break out of the loop. */
m = NULL;
break;
}
else
{
count[n]++;
mptr += mstride[n];
}
}
}
}
/* Setup the array descriptor. */
ret->dim[0].lbound = 0;
ret->dim[0].ubound = total - 1;
ret->dim[0].stride = 1;
ret->data = internal_malloc (size * total);
ret->base = 0;
if (total == 0)
/* In this case, nothing remains to be done. */
return;
}
rstride0 = ret->dim[0].stride * size;
if (rstride0 == 0)
rstride0 = size;
sstride0 = sstride[0];
mstride0 = mstride[0];
rptr = ret->data;
while (sptr)
{
/* Test this element. */
@ -144,3 +266,148 @@ __pack (const gfc_array_char * ret, const gfc_array_char * array,
}
}
void
__pack_s (gfc_array_char * ret, const gfc_array_char * array,
const GFC_LOGICAL_4 * mask, const gfc_array_char * vector)
{
/* r.* indicates the return array. */
index_type rstride0;
char *rptr;
/* s.* indicates the source array. */
index_type sstride[GFC_MAX_DIMENSIONS];
index_type sstride0;
const char *sptr;
index_type count[GFC_MAX_DIMENSIONS];
index_type extent[GFC_MAX_DIMENSIONS];
index_type n;
index_type dim;
index_type size;
index_type nelem;
size = GFC_DESCRIPTOR_SIZE (array);
dim = GFC_DESCRIPTOR_RANK (array);
for (n = 0; n < dim; n++)
{
count[n] = 0;
extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound;
sstride[n] = array->dim[n].stride * size;
}
if (sstride[0] == 0)
sstride[0] = size;
sstride0 = sstride[0];
sptr = array->data;
if (ret->data == NULL)
{
/* Allocate the memory for the result. */
int total;
if (vector != NULL)
{
/* The return array will have as many elements as there are
in vector. */
total = vector->dim[0].ubound + 1 - vector->dim[0].lbound;
}
else
{
if (*mask)
{
/* The result array will have as many elements as the input
array. */
total = extent[0];
for (n = 1; n < dim; n++)
total *= extent[n];
}
else
{
/* The result array will be empty. */
ret->dim[0].lbound = 0;
ret->dim[0].ubound = -1;
ret->dim[0].stride = 1;
ret->data = internal_malloc (0);
ret->base = 0;
return;
}
}
/* Setup the array descriptor. */
ret->dim[0].lbound = 0;
ret->dim[0].ubound = total - 1;
ret->dim[0].stride = 1;
ret->data = internal_malloc (size * total);
ret->base = 0;
}
rstride0 = ret->dim[0].stride * size;
if (rstride0 == 0)
rstride0 = size;
rptr = ret->data;
/* The remaining possibilities are now:
If MASK is .TRUE., we have to copy the source array into the
result array. We then have to fill it up with elements from VECTOR.
If MASK is .FALSE., we have to copy VECTOR into the result
array. If VECTOR were not present we would have already returned. */
if (*mask)
{
while (sptr)
{
/* Add this element. */
memcpy (rptr, sptr, size);
rptr += rstride0;
/* Advance to the next element. */
sptr += sstride0;
count[0]++;
n = 0;
while (count[n] == extent[n])
{
/* When we get to the end of a dimension, reset it and
increment the next dimension. */
count[n] = 0;
/* We could precalculate these products, but this is a
less frequently used path so proabably not worth it. */
sptr -= sstride[n] * extent[n];
n++;
if (n >= dim)
{
/* Break out of the loop. */
sptr = NULL;
break;
}
else
{
count[n]++;
sptr += sstride[n];
}
}
}
}
/* Add any remaining elements from VECTOR. */
if (vector)
{
n = vector->dim[0].ubound + 1 - vector->dim[0].lbound;
nelem = ((rptr - ret->data) / rstride0);
if (n > nelem)
{
sstride0 = vector->dim[0].stride * size;
if (sstride0 == 0)
sstride0 = size;
sptr = vector->data + sstride0 * nelem;
n -= nelem;
while (n--)
{
memcpy (rptr, sptr, size);
rptr += rstride0;
sptr += sstride0;
}
}
}
}

8
libgfortran/runtime/memory.c
View File

@ -165,8 +165,8 @@ internal_malloc (GFC_INTEGER_4 size)
{
#ifdef GFC_CHECK_MEMORY
/* Under normal circumstances, this is _never_ going to happen! */
if (size <= 0)
runtime_error ("Attempt to allocate a non-positive amount of memory.");
if (size < 0)
runtime_error ("Attempt to allocate a negative amount of memory.");
#endif
return internal_malloc_size ((size_t) size);
@ -178,8 +178,8 @@ internal_malloc64 (GFC_INTEGER_8 size)
{
#ifdef GFC_CHECK_MEMORY
/* Under normal circumstances, this is _never_ going to happen! */
if (size <= 0)
runtime_error ("Attempt to allocate a non-positive amount of memory.");
if (size < 0)
runtime_error ("Attempt to allocate a negative amount of memory.");
#endif
return internal_malloc_size ((size_t) size);
}