From 3d894fc3f045e430b67aae82aa68dd818816ac90 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Fran=C3=A7ois-Xavier=20Coudert?= Date: Thu, 19 Oct 2006 21:48:50 +0000 Subject: re PR libfortran/27895 (problem with RESHAPE and zero-sized arrays) PR libfortran/27895 * intrinsics/cshift0.c: Special cases for zero-sized arrays. * intrinsics/pack_generic.c: Likewise. * intrinsics/spread_generic.c: Likewise. * gfortran.dg/zero_sized_1.f90: New test. From-SVN: r117890 --- gcc/testsuite/ChangeLog | 11 +- gcc/testsuite/gfortran.dg/zero_sized_1.f90 | 197 +++++++++++++++++++++++++++++ libgfortran/ChangeLog | 7 + libgfortran/intrinsics/cshift0.c | 15 ++- libgfortran/intrinsics/pack_generic.c | 42 +++--- libgfortran/intrinsics/spread_generic.c | 8 +- 6 files changed, 254 insertions(+), 26 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/zero_sized_1.f90 diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index eb5d88fd80c..be06e215328 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,8 @@ +2006-10-19 Francois-Xavier Coudert + + PR libfortran/27895 + * gfortran.dg/zero_sized_1.f90: New test. + 2006-10-19 Eric Botcazou * gcc.dg/div-compare-1.c: New test. @@ -26,10 +31,10 @@ * gfortran.dg/streamio_4.f90: Update test. * gfortran.dg/streamio_11.f90: New test. -2006-10-17 Lee Millward +2006-10-17 Lee Millward - PR c++/27952 - * g++.dg/inherit/virtual1.C: New test. + PR c++/27952 + * g++.dg/inherit/virtual1.C: New test. 2006-10-17 Mark Mitchell diff --git a/gcc/testsuite/gfortran.dg/zero_sized_1.f90 b/gcc/testsuite/gfortran.dg/zero_sized_1.f90 new file mode 100644 index 00000000000..c70bdddd6d7 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/zero_sized_1.f90 @@ -0,0 +1,197 @@ +! { dg-do run } +! Transformational functions for zero-sized array and array sections +! Contributed by Francois-Xavier Coudert + +subroutine test_cshift + real :: tempn(1), tempm(1,2) + real,allocatable :: foo(:),bar(:,:),gee(:,:) + tempn = 2.0 + tempm = 1.0 + allocate(foo(0),bar(2,0),gee(0,7)) + if (any(cshift(foo,dim=1,shift=1)/= 0)) call abort + if (any(cshift(tempn(2:1),dim=1,shift=1)/= 0)) call abort + if (any(cshift(bar,shift=(/1,-1/),dim=1)/= 0)) call abort + if (any(cshift(bar,shift=(/1,-1/),dim=2)/= 0)) call abort + if (any(cshift(gee,shift=(/1,-1/),dim=1)/= 0)) call abort + if (any(cshift(gee,shift=(/1,-1/),dim=2)/= 0)) call abort + if (any(cshift(tempm(5:4,:),shift=(/1,-1/),dim=1)/= 0)) call abort + if (any(cshift(tempm(5:4,:),shift=(/1,-1/),dim=2)/= 0)) call abort + if (any(cshift(tempm(:,5:4),shift=(/1,-1/),dim=1)/= 0)) call abort + if (any(cshift(tempm(:,5:4),shift=(/1,-1/),dim=2)/= 0)) call abort + deallocate(foo,bar,gee) +end + +subroutine test_eoshift + real :: tempn(1), tempm(1,2) + real,allocatable :: foo(:),bar(:,:),gee(:,:) + tempn = 2.0 + tempm = 1.0 + allocate(foo(0),bar(2,0),gee(0,7)) + if (any(eoshift(foo,dim=1,shift=1)/= 0)) call abort + if (any(eoshift(tempn(2:1),dim=1,shift=1)/= 0)) call abort + if (any(eoshift(bar,shift=(/1,-1/),dim=1)/= 0)) call abort + if (any(eoshift(bar,shift=(/1,-1/),dim=2)/= 0)) call abort + if (any(eoshift(gee,shift=(/1,-1/),dim=1)/= 0)) call abort + if (any(eoshift(gee,shift=(/1,-1/),dim=2)/= 0)) call abort + if (any(eoshift(tempm(5:4,:),shift=(/1,-1/),dim=1)/= 0)) call abort + if (any(eoshift(tempm(5:4,:),shift=(/1,-1/),dim=2)/= 0)) call abort + if (any(eoshift(tempm(:,5:4),shift=(/1,-1/),dim=1)/= 0)) call abort + if (any(eoshift(tempm(:,5:4),shift=(/1,-1/),dim=2)/= 0)) call abort + + if (any(eoshift(foo,dim=1,shift=1,boundary=42.0)/= 0)) call abort + if (any(eoshift(tempn(2:1),dim=1,shift=1,boundary=42.0)/= 0)) call abort + if (any(eoshift(bar,shift=(/1,-1/),dim=1,boundary=42.0)/= 0)) call abort + if (any(eoshift(bar,shift=(/1,-1/),dim=2,boundary=42.0)/= 0)) call abort + if (any(eoshift(gee,shift=(/1,-1/),dim=1,boundary=42.0)/= 0)) call abort + if (any(eoshift(gee,shift=(/1,-1/),dim=2,boundary=42.0)/= 0)) call abort + if (any(eoshift(tempm(5:4,:),shift=(/1,-1/),dim=1,boundary=42.0)/= 0)) call abort + if (any(eoshift(tempm(5:4,:),shift=(/1,-1/),dim=2,boundary=42.0)/= 0)) call abort + if (any(eoshift(tempm(:,5:4),shift=(/1,-1/),dim=1,boundary=42.0)/= 0)) call abort + if (any(eoshift(tempm(:,5:4),shift=(/1,-1/),dim=2,boundary=42.0)/= 0)) call abort + + if (any(eoshift(foo,dim=1,shift=1,boundary=(/42.0,-7.0/))/= 0)) call abort + if (any(eoshift(tempn(2:1),dim=1,shift=1,boundary=(/42.0,-7.0/))/= 0)) call abort + if (any(eoshift(bar,shift=(/1,-1/),dim=1,boundary=(/42.0,-7.0/))/= 0)) call abort + if (any(eoshift(bar,shift=(/1,-1/),dim=2,boundary=(/42.0,-7.0/))/= 0)) call abort + if (any(eoshift(gee,shift=(/1,-1/),dim=1,boundary=(/42.0,-7.0/))/= 0)) call abort + if (any(eoshift(gee,shift=(/1,-1/),dim=2,boundary=(/42.0,-7.0/))/= 0)) call abort + if (any(eoshift(tempm(5:4,:),shift=(/1,-1/),dim=1,boundary=(/42.0,-7.0/))/= 0)) call abort + if (any(eoshift(tempm(5:4,:),shift=(/1,-1/),dim=2,boundary=(/42.0,-7.0/))/= 0)) call abort + if (any(eoshift(tempm(:,5:4),shift=(/1,-1/),dim=1,boundary=(/42.0,-7.0/))/= 0)) call abort + if (any(eoshift(tempm(:,5:4),shift=(/1,-1/),dim=2,boundary=(/42.0,-7.0/))/= 0)) call abort + deallocate(foo,bar,gee) +end + +subroutine test_transpose + character(len=1) :: tempn(1,2) + character(len=1),allocatable :: foo(:,:), bar(:,:) + integer :: tempm(1,2) + integer,allocatable :: x(:,:), y(:,:) + tempn = 'a' + allocate(foo(3,0),bar(-2:-4,7:9)) + tempm = -42 + allocate(x(3,0),y(-2:-4,7:9)) + if (any(transpose(tempn(-7:-8,:)) /= 'b')) call abort + if (any(transpose(tempn(:,9:8)) /= 'b')) call abort + if (any(transpose(foo) /= 'b')) call abort + if (any(transpose(bar) /= 'b')) call abort + if (any(transpose(tempm(-7:-8,:)) /= 0)) call abort + if (any(transpose(tempm(:,9:8)) /= 0)) call abort + if (any(transpose(x) /= 0)) call abort + if (any(transpose(y) /= 0)) call abort + deallocate(foo,bar,x,y) +end + +subroutine test_reshape + character(len=1) :: tempn(1,2) + character(len=1),allocatable :: foo(:,:), bar(:,:) + integer :: tempm(1,2) + integer,allocatable :: x(:,:), y(:,:) + tempn = 'b' + tempm = -42 + allocate(foo(3,0),bar(-2:-4,7:9),x(3,0),y(-2:-4,7:9)) + + if (size(reshape(tempn(-7:-8,:),(/3,3/),pad=(/'a'/))) /= 9 .or. & + any(reshape(tempn(-7:-8,:),(/3,3/),pad=(/'a'/)) /= 'a')) call abort + if (size(reshape(tempn(-7:-8,:),(/3,3,3/),pad=(/'a'/))) /= 27 .or. & + any(reshape(tempn(-7:-8,:),(/3,3,3/),pad=(/'a'/)) /= 'a')) call abort + if (size(reshape(tempn(-7:-8,:),(/3,3,3,3,3,3,3/),pad=(/'a'/))) /= 2187 .or. & + any(reshape(tempn(-7:-8,:),(/3,3,3,3,3,3,3/),pad=(/'a'/)) /= 'a')) call abort + if (size(reshape(foo,(/3,3/),pad=(/'a'/))) /= 9 .or. & + any(reshape(foo,(/3,3/),pad=(/'a'/)) /= 'a')) call abort + if (size(reshape(foo,(/3,3,3/),pad=(/'a'/))) /= 27 .or. & + any(reshape(foo,(/3,3,3/),pad=(/'a'/)) /= 'a')) call abort + if (size(reshape(foo,(/3,3,3,3,3,3,3/),pad=(/'a'/))) /= 2187 .or. & + any(reshape(foo,(/3,3,3,3,3,3,3/),pad=(/'a'/)) /= 'a')) call abort + if (size(reshape(bar,(/3,3/),pad=(/'a'/))) /= 9 .or. & + any(reshape(bar,(/3,3/),pad=(/'a'/)) /= 'a')) call abort + if (size(reshape(bar,(/3,3,3/),pad=(/'a'/))) /= 27 .or. & + any(reshape(bar,(/3,3,3/),pad=(/'a'/)) /= 'a')) call abort + if (size(reshape(bar,(/3,3,3,3,3,3,3/),pad=(/'a'/))) /= 2187 .or. & + any(reshape(bar,(/3,3,3,3,3,3,3/),pad=(/'a'/)) /= 'a')) call abort + + if (size(reshape(tempm(-7:-8,:),(/3,3/),pad=(/7/))) /= 9 .or. & + any(reshape(tempm(-7:-8,:),(/3,3/),pad=(/7/)) /= 7)) call abort + if (size(reshape(tempm(-7:-8,:),(/3,3,3/),pad=(/7/))) /= 27 .or. & + any(reshape(tempm(-7:-8,:),(/3,3,3/),pad=(/7/)) /= 7)) call abort + if (size(reshape(tempm(-7:-8,:),(/3,3,3,3,3,3,3/),pad=(/7/))) /= 2187 .or. & + any(reshape(tempm(-7:-8,:),(/3,3,3,3,3,3,3/),pad=(/7/)) /= 7)) call abort + if (size(reshape(x,(/3,3/),pad=(/7/))) /= 9 .or. & + any(reshape(x,(/3,3/),pad=(/7/)) /= 7)) call abort + if (size(reshape(x,(/3,3,3/),pad=(/7/))) /= 27 .or. & + any(reshape(x,(/3,3,3/),pad=(/7/)) /= 7)) call abort + if (size(reshape(x,(/3,3,3,3,3,3,3/),pad=(/7/))) /= 2187 .or. & + any(reshape(x,(/3,3,3,3,3,3,3/),pad=(/7/)) /= 7)) call abort + if (size(reshape(y,(/3,3/),pad=(/7/))) /= 9 .or. & + any(reshape(y,(/3,3/),pad=(/7/)) /= 7)) call abort + if (size(reshape(y,(/3,3,3/),pad=(/7/))) /= 27 .or. & + any(reshape(y,(/3,3,3/),pad=(/7/)) /= 7)) call abort + if (size(reshape(y,(/3,3,3,3,3,3,3/),pad=(/7/))) /= 2187 .or. & + any(reshape(y,(/3,3,3,3,3,3,3/),pad=(/7/)) /= 7)) call abort + + deallocate(foo,bar,x,y) +end + +subroutine test_pack + integer :: tempn(1,5) + integer,allocatable :: foo(:,:) + tempn = 2 + allocate(foo(0,1:7)) + if (size(pack(foo,foo/=0)) /= 0 .or. any(pack(foo,foo/=0) /= -42)) call abort + if (size(pack(foo,foo/=0,(/1,3,4,5,1,0,7,9/))) /= 8 .or. & + sum(pack(foo,foo/=0,(/1,3,4,5,1,0,7,9/))) /= 30) call abort + if (size(pack(tempn(:,-4:-5),tempn(:,-4:-5)/=0)) /= 0 .or. & + any(pack(tempn(:,-4:-5),tempn(:,-4:-5)/=0) /= -42)) call abort + if (size(pack(tempn(:,-4:-5),tempn(:,-4:-5)/=0,(/1,3,4,5,1,0,7,9/))) /= 8 .or. & + sum(pack(tempn(:,-4:-5),tempn(:,-4:-5)/=0,(/1,3,4,5,1,0,7,9/))) /= 30) & + call abort + if (size(pack(foo,.true.)) /= 0 .or. any(pack(foo,.true.) /= -42)) & + call abort + if (size(pack(foo,.true.,(/1,3,4,5,1,0,7,9/))) /= 8 .or. & + sum(pack(foo,.true.,(/1,3,4,5,1,0,7,9/))) /= 30) call abort + if (size(pack(tempn(:,-4:-5),.true.)) /= 0 .or. & + any(pack(foo,.true.) /= -42)) call abort + if (size(pack(tempn(:,-4:-5),.true.,(/1,3,4,5,1,0,7,9/))) /= 8 .or. & + sum(pack(tempn(:,-4:-5),.true.,(/1,3,4,5,1,0,7,9/))) /= 30) call abort + deallocate(foo) +end + +subroutine test_unpack + integer :: tempn(1,5), tempv(5) + integer,allocatable :: foo(:,:), bar(:) + tempn = 2 + tempv = 5 + allocate(foo(0,1:7),bar(0:-1)) + if (any(unpack(tempv,tempv/=0,tempv) /= 5) .or. & + size(unpack(tempv,tempv/=0,tempv)) /= 5) call abort + if (any(unpack(tempv(1:0),tempv/=0,tempv) /= 5) .or. & + size(unpack(tempv(1:0),tempv/=0,tempv)) /= 5) call abort + if (any(unpack(tempv,tempv(1:0)/=0,tempv) /= -47)) call abort + if (any(unpack(tempv(5:4),tempv(1:0)/=0,tempv) /= -47)) call abort + if (any(unpack(bar,foo==foo,foo) /= -47)) call abort + deallocate(foo,bar) +end + +subroutine test_spread + real :: tempn(1) + real,allocatable :: foo(:) + tempn = 2.0 + allocate(foo(0)) + if (any(spread(1,dim=1,ncopies=0) /= -17.0) .or. & + size(spread(1,dim=1,ncopies=0)) /= 0) call abort + if (any(spread(foo,dim=1,ncopies=1) /= -17.0) .or. & + size(spread(foo,dim=1,ncopies=1)) /= 0) call abort + if (any(spread(tempn(2:1),dim=1,ncopies=1) /= -17.0) .or. & + size(spread(tempn(2:1),dim=1,ncopies=1)) /= 0) call abort + deallocate(foo) +end + +program test + call test_cshift + call test_eoshift + call test_transpose + call test_unpack + call test_spread + call test_pack +! call test_reshape +end diff --git a/libgfortran/ChangeLog b/libgfortran/ChangeLog index 9001e2c979e..5a51c53cadb 100644 --- a/libgfortran/ChangeLog +++ b/libgfortran/ChangeLog @@ -1,3 +1,10 @@ +2006-10-19 Francois-Xavier Coudert + + PR libfortran/27895 + * intrinsics/cshift0.c: Special cases for zero-sized arrays. + * intrinsics/pack_generic.c: Likewise. + * intrinsics/spread_generic.c: Likewise. + 2006-10-18 Jerry DeLisle PR libgfortran/29277 diff --git a/libgfortran/intrinsics/cshift0.c b/libgfortran/intrinsics/cshift0.c index 4df90ad0fbb..f2c2219dd30 100644 --- a/libgfortran/intrinsics/cshift0.c +++ b/libgfortran/intrinsics/cshift0.c @@ -1,5 +1,5 @@ /* Generic implementation of the CSHIFT intrinsic - Copyright 2003, 2005 Free Software Foundation, Inc. + Copyright 2003, 2005, 2006 Free Software Foundation, Inc. Contributed by Feng Wang This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -144,8 +144,8 @@ cshift0 (gfc_array_char * ret, const gfc_array_char * array, if (ret->data == NULL) { int i; + index_type arraysize = size0 ((array_t *)array); - ret->data = internal_malloc_size (size * size0 ((array_t *)array)); ret->offset = 0; ret->dtype = array->dtype; for (i = 0; i < GFC_DESCRIPTOR_RANK (array); i++) @@ -156,8 +156,17 @@ cshift0 (gfc_array_char * ret, const gfc_array_char * array, if (i == 0) ret->dim[i].stride = 1; else - ret->dim[i].stride = (ret->dim[i-1].ubound + 1) * ret->dim[i-1].stride; + ret->dim[i].stride = (ret->dim[i-1].ubound + 1) + * ret->dim[i-1].stride; } + + if (arraysize > 0) + ret->data = internal_malloc_size (size * arraysize); + else + { + ret->data = internal_malloc_size (1); + return; + } } for (dim = 0; dim < GFC_DESCRIPTOR_RANK (array); dim++) diff --git a/libgfortran/intrinsics/pack_generic.c b/libgfortran/intrinsics/pack_generic.c index 27a22ec8d54..1b0d7250540 100644 --- a/libgfortran/intrinsics/pack_generic.c +++ b/libgfortran/intrinsics/pack_generic.c @@ -1,5 +1,5 @@ /* Generic implementation of the PACK intrinsic - Copyright (C) 2002, 2004, 2005 Free Software Foundation, Inc. + Copyright (C) 2002, 2004, 2005, 2006 Free Software Foundation, Inc. Contributed by Paul Brook This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -195,12 +195,15 @@ pack_internal (gfc_array_char *ret, const gfc_array_char *array, ret->dim[0].ubound = total - 1; ret->dim[0].stride = 1; - ret->data = internal_malloc_size (size * total); ret->offset = 0; - if (total == 0) - /* In this case, nothing remains to be done. */ - return; + { + /* In this case, nothing remains to be done. */ + ret->data = internal_malloc_size (1); + return; + } + else + ret->data = internal_malloc_size (size * total); } rstride0 = ret->dim[0].stride * size; @@ -210,7 +213,7 @@ pack_internal (gfc_array_char *ret, const gfc_array_char *array, mstride0 = mstride[0]; rptr = ret->data; - while (sptr) + while (sptr && mptr) { /* Test this element. */ if (*mptr) @@ -315,14 +318,17 @@ pack_s_internal (gfc_array_char *ret, const gfc_array_char *array, index_type extent[GFC_MAX_DIMENSIONS]; index_type n; index_type dim; + index_type ssize; index_type nelem; dim = GFC_DESCRIPTOR_RANK (array); + ssize = 1; 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; + ssize *= extent[n]; } if (sstride[0] == 0) sstride[0] = size; @@ -352,25 +358,23 @@ pack_s_internal (gfc_array_char *ret, const gfc_array_char *array, 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_size (0); - ret->offset = 0; - - return; - } + /* The result array will be empty. */ + total = 0; } /* 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 (size * total); ret->offset = 0; + + if (total == 0) + { + ret->data = internal_malloc_size (1); + return; + } + else + ret->data = internal_malloc_size (size * total); } rstride0 = ret->dim[0].stride * size; @@ -384,7 +388,7 @@ pack_s_internal (gfc_array_char *ret, const gfc_array_char *array, 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) + if (*mask && ssize != 0) { while (sptr) { diff --git a/libgfortran/intrinsics/spread_generic.c b/libgfortran/intrinsics/spread_generic.c index cbc5c4985df..9ea6b12ef16 100644 --- a/libgfortran/intrinsics/spread_generic.c +++ b/libgfortran/intrinsics/spread_generic.c @@ -101,7 +101,13 @@ spread_internal (gfc_array_char *ret, const gfc_array_char *source, } } ret->offset = 0; - ret->data = internal_malloc_size (rs * size); + if (rs > 0) + ret->data = internal_malloc_size (rs * size); + else + { + ret->data = internal_malloc_size (1); + return; + } } else { -- cgit v1.2.1