From 58c5b409e89f4250bddf1ba114b3058d4dfab718 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Tobias=20Schl=C3=BCter?= Date: Mon, 4 Oct 2004 21:27:29 +0200 Subject: [PATCH] re PR fortran/17283 (UNPACK issues) 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 --- gcc/fortran/ChangeLog | 6 + gcc/fortran/iresolve.c | 24 +- gcc/testsuite/ChangeLog | 5 + .../execute/intrinsic_pack.f90 | 15 +- libgfortran/ChangeLog | 9 + libgfortran/intrinsics/pack_generic.c | 287 +++++++++++++++++- libgfortran/runtime/memory.c | 8 +- 7 files changed, 336 insertions(+), 18 deletions(-) diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index d1bc71d73c01..204e8eb5c314 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,9 @@ +2004-10-04 Tobias Schlueter + + PR fortran/17283 + * iresolve.c (gfc_resolve_pack): Choose function depending if mask + is scalar. + 2004-10-04 Erik Schnetter * scanner.c (preprocessor_line): Accept preprocessor lines without diff --git a/gcc/fortran/iresolve.c b/gcc/fortran/iresolve.c index 201b3f962e27..36597fa6d844 100644 --- a/gcc/fortran/iresolve.c +++ b/gcc/fortran/iresolve.c @@ -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; + } } diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 9949feaadbf0..0587e7fa07a2 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,8 @@ +2004-10-04 Tobias Schlueter + + PR fortran/17283 + * gfortran.fortran-torture/execute/intrinsic_pack.f90: Add more tests. + 2004-10-04 Chao-ying Fu * gcc.dg/vect/pr16105.c: Enable for mipsisa64*-*-*. diff --git a/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_pack.f90 b/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_pack.f90 index 565446e4e8b7..427fe55ef14f 100644 --- a/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_pack.f90 +++ b/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_pack.f90 @@ -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 diff --git a/libgfortran/ChangeLog b/libgfortran/ChangeLog index c9567d763356..0c2b3818bc61 100644 --- a/libgfortran/ChangeLog +++ b/libgfortran/ChangeLog @@ -1,3 +1,12 @@ +2004-10-04 Tobias Schlueter + + 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 Bud Davis diff --git a/libgfortran/intrinsics/pack_generic.c b/libgfortran/intrinsics/pack_generic.c index 08c022e4e746..301948e7e86d 100644 --- a/libgfortran/intrinsics/pack_generic.c +++ b/libgfortran/intrinsics/pack_generic.c @@ -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 This file is part of the GNU Fortran 95 runtime library (libgfor). @@ -25,9 +25,49 @@ Boston, MA 02111-1307, USA. */ #include #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; + } + } + } +} diff --git a/libgfortran/runtime/memory.c b/libgfortran/runtime/memory.c index ca5eb15244bd..5b146000b8d5 100644 --- a/libgfortran/runtime/memory.c +++ b/libgfortran/runtime/memory.c @@ -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); }