From b6b4c3ef5f103c7f35a3a6140ceaa504ebf54adc Mon Sep 17 00:00:00 2001 From: tkoenig Date: Fri, 15 Apr 2005 20:06:17 +0000 Subject: [PATCH] 2005-04-15 Thomas Koenig PR libfortran/18495 * intrinsics/spread_generic.c (spread): Remove const from return array descriptor. New variables: rrank (rank of return array), rs (for calculating the size of the return array), srank (rank of the source array). Generate runtime error if the dim= argument is larger than the rank of the return array. Generate runtime error if the needed rank of the return array is larger than 7. If ret->data is null, populate the return array descriptor and initialize the variables for the actual operation. Otherwise, set ret->dim[0].stride to one if it is zero. Change second, independent use of variable dim to srank. 2005-04-15 Thomas Koenig PR libfortran/18495 * gfortran.fortran-torture/execute/intrinsic_spread.f90: Test callee-allocated version of return array with a write statement. Test spread with a temporary with another write statement. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@98208 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/testsuite/ChangeLog | 8 ++ .../execute/intrinsic_spread.f90 | 7 ++ libgfortran/ChangeLog | 17 ++++ libgfortran/intrinsics/spread_generic.c | 98 +++++++++++++++++----- 4 files changed, 107 insertions(+), 23 deletions(-) diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 41a3508..594aae1 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,11 @@ +2005-04-15 Thomas Koenig + + PR libfortran/18495 + * gfortran.fortran-torture/execute/intrinsic_spread.f90: + Test callee-allocated version of return array with a write + statement. + Test spread with a temporary with another write statement. + 2005-04-15 Kazu Hirata PR tree-optimization/21031 diff --git a/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_spread.f90 b/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_spread.f90 index 50b66ff..2308a1d 100644 --- a/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_spread.f90 +++ b/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_spread.f90 @@ -1,10 +1,17 @@ program foo integer, dimension (2, 3) :: a integer, dimension (2, 2, 3) :: b + character (len=80) line1, line2, line3 a = reshape ((/1, 2, 3, 4, 5, 6/), (/2, 3/)) b = spread (a, 1, 2) if (any (b .ne. reshape ((/1, 1, 2, 2, 3, 3, 4, 4, 5, 5, 6, 6/), & (/2, 2, 3/)))) & call abort + write(line1, 9000) b + write(line2, 9000) spread (a, 1, 2) + if (line1 /= line2) call abort + write(line3, 9000) spread (a, 1, 2) + 0 + if (line1 /= line2) call abort +9000 format(12I3) end program diff --git a/libgfortran/ChangeLog b/libgfortran/ChangeLog index 5553575..9fc0b63 100644 --- a/libgfortran/ChangeLog +++ b/libgfortran/ChangeLog @@ -1,3 +1,20 @@ +2005-04-15 Thomas Koenig + + PR libfortran/18495 + * intrinsics/spread_generic.c (spread): Remove const from + return array descriptor. + New variables: rrank (rank of return array), rs (for + calculating the size of the return array), srank (rank + of the source array). + Generate runtime error if the dim= argument is larger than + the rank of the return array. + Generate runtime error if the needed rank of the return + array is larger than 7. + If ret->data is null, populate the return array descriptor + and initialize the variables for the actual operation. + Otherwise, set ret->dim[0].stride to one if it is zero. + Change second, independent use of variable dim to srank. + 2005-04-12 Mike Stump * configure: Regenerate. diff --git a/libgfortran/intrinsics/spread_generic.c b/libgfortran/intrinsics/spread_generic.c index e40739e..7dcabf6 100644 --- a/libgfortran/intrinsics/spread_generic.c +++ b/libgfortran/intrinsics/spread_generic.c @@ -34,23 +34,26 @@ Boston, MA 02111-1307, USA. */ #include #include "libgfortran.h" -extern void spread (const gfc_array_char *, const gfc_array_char *, +extern void spread (gfc_array_char *, const gfc_array_char *, const index_type *, const index_type *); export_proto(spread); void -spread (const gfc_array_char *ret, const gfc_array_char *source, +spread (gfc_array_char *ret, const gfc_array_char *source, const index_type *along, const index_type *pncopies) { /* r.* indicates the return array. */ index_type rstride[GFC_MAX_DIMENSIONS - 1]; index_type rstride0; index_type rdelta; + index_type rrank; + index_type rs; char *rptr; char *dest; /* s.* indicates the source array. */ index_type sstride[GFC_MAX_DIMENSIONS - 1]; index_type sstride0; + index_type srank; const char *sptr; index_type count[GFC_MAX_DIMENSIONS - 1]; @@ -60,34 +63,83 @@ spread (const gfc_array_char *ret, const gfc_array_char *source, index_type size; index_type ncopies; + srank = GFC_DESCRIPTOR_RANK(source); + + rrank = srank + 1; + if (rrank > GFC_MAX_DIMENSIONS) + runtime_error ("return rank too large in spread()"); + + if (*along > rrank) + runtime_error ("dim outside of rank in spread()"); + + ncopies = *pncopies; + size = GFC_DESCRIPTOR_SIZE (source); - dim = 0; - for (n = 0; n < GFC_DESCRIPTOR_RANK (ret); n++) + if (ret->data == NULL) { - if (n == *along - 1) - { - rdelta = ret->dim[n].stride * size; - } - else - { - count[dim] = 0; - extent[dim] = source->dim[dim].ubound + 1 - source->dim[dim].lbound; - sstride[dim] = source->dim[dim].stride * size; - rstride[dim] = ret->dim[n].stride * size; - dim++; - } + /* The front end has signalled that we need to populate the + return array descriptor. */ + ret->dtype = (source->dtype & ~GFC_DTYPE_RANK_MASK) | rrank; + dim = 0; + rs = 1; + for (n = 0; n < rrank; n++) + { + ret->dim[n].stride = rs; + ret->dim[n].lbound = 0; + if (n == *along - 1) + { + ret->dim[n].ubound = ncopies - 1; + rdelta = rs * size; + rs *= ncopies; + } + else + { + count[dim] = 0; + extent[dim] = source->dim[dim].ubound + 1 + - source->dim[dim].lbound; + sstride[dim] = source->dim[dim].stride * size; + rstride[dim] = rs * size; + + ret->dim[n].ubound = extent[dim]-1; + rs *= extent[dim]; + dim++; + } + } + ret->base = 0; + ret->data = internal_malloc_size (rs * size); } - dim = GFC_DESCRIPTOR_RANK (source); - if (sstride[0] == 0) - sstride[0] = size; - if (rstride[0] == 0) - rstride[0] = size; + else + { + dim = 0; + if (GFC_DESCRIPTOR_RANK(ret) != rrank) + runtime_error ("rank mismatch in spread()"); + if (ret->dim[0].stride == 0) + ret->dim[0].stride = 1; + + for (n = 0; n < rrank; n++) + { + if (n == *along - 1) + { + rdelta = ret->dim[n].stride * size; + } + else + { + count[dim] = 0; + extent[dim] = source->dim[dim].ubound + 1 + - source->dim[dim].lbound; + sstride[dim] = source->dim[dim].stride * size; + rstride[dim] = ret->dim[n].stride * size; + dim++; + } + } + if (sstride[0] == 0) + sstride[0] = size; + } sstride0 = sstride[0]; rstride0 = rstride[0]; rptr = ret->data; sptr = source->data; - ncopies = *pncopies; while (sptr) { @@ -113,7 +165,7 @@ spread (const gfc_array_char *ret, const gfc_array_char *source, sptr -= sstride[n] * extent[n]; rptr -= rstride[n] * extent[n]; n++; - if (n >= dim) + if (n >= srank) { /* Break out of the loop. */ sptr = NULL; -- 2.7.4