This is the mail archive of the fortran@gcc.gnu.org mailing list for the GNU Fortran project.
Index Nav: | [Date Index] [Subject Index] [Author Index] [Thread Index] | |
---|---|---|
Message Nav: | [Date Prev] [Date Next] | [Thread Prev] [Thread Next] |
Other format: | [Raw text] |
Attached patch introduces special cases in the library helper functions of PACK, SPREAD and CSHIFT intrinsics to take care of zero-sized arrays. In current state, both three intrinsics just return garbage when called with zero-sized argument(s).
From my investigations, after that patch only RESHAPE will still
require some tweaking; all other transformational intrinsics are working fine AFAICT. I've had this patch in my tree for long, but didn't post it because I was trying to devise a fix for RESHAPE and submit the whole thing; unfortunately, I haven't yet managed to do that in more than a month, so it's time to submit this partial patch.
Bootstrapped and regtested on i686-linux, comes with a testcase. OK for mainline (and 4.1 after some time)?
Thanks, FX
Index: intrinsics/cshift0.c =================================================================== --- intrinsics/cshift0.c (revision 115644) +++ intrinsics/cshift0.c (working copy) @@ -144,8 +144,8 @@ 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 @@ 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++) Index: intrinsics/pack_generic.c =================================================================== --- intrinsics/pack_generic.c (revision 115644) +++ intrinsics/pack_generic.c (working copy) @@ -195,12 +195,15 @@ 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 @@ mstride0 = mstride[0]; rptr = ret->data; - while (sptr) + while (sptr && mptr) { /* Test this element. */ if (*mptr) @@ -315,14 +318,17 @@ 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 @@ 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->offset = 0; - 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 @@ 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) { Index: intrinsics/spread_generic.c =================================================================== --- intrinsics/spread_generic.c (revision 115644) +++ intrinsics/spread_generic.c (working copy) @@ -101,7 +101,13 @@ } } 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 {
Attachment:
zero_sized.ChangeLog
Description: Binary data
! { dg-do run } ! Transformational functions for zero-sized array and array sections ! Contributed by Francois-Xavier Coudert <coudert@clipper.ens.fr> 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
Index Nav: | [Date Index] [Subject Index] [Author Index] [Thread Index] | |
---|---|---|
Message Nav: | [Date Prev] [Date Next] | [Thread Prev] [Thread Next] |