From d1a296c11ab091c896267dee5a3d831731fd3143 Mon Sep 17 00:00:00 2001 From: Tobias Burnus Date: Sat, 19 Jul 2008 19:20:26 +0200 Subject: [PATCH] check.c (gfc_check_cshift,gfc_check_eoshift,gfc_check_unpack): Add rank checks for cshift's shift and eoshift's shift and boundary args. 2008-07-19 Tobias Burnus * check.c (gfc_check_cshift,gfc_check_eoshift,gfc_check_unpack): Add rank checks for cshift's shift and eoshift's shift and boundary args. (gfc_check_unpack): Add rank and shape tests for unpack. 2008-07-19 Tobias Burnus * gfortran.dg/intrinsic_argument_conformance_2.f90: New. * gfortran.dg/zero_sized_1.f90: Fix conformance bugs. From-SVN: r137983 --- gcc/fortran/ChangeLog | 6 ++ gcc/fortran/check.c | 62 +++++++++++++++++-- gcc/testsuite/ChangeLog | 5 ++ .../intrinsic_argument_conformance_2.f90 | 44 +++++++++++++ gcc/testsuite/gfortran.dg/zero_sized_1.f90 | 10 +-- 5 files changed, 118 insertions(+), 9 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/intrinsic_argument_conformance_2.f90 diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 87279c4131e..6077028231a 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,9 @@ +2008-07-19 Tobias Burnus + + * check.c (gfc_check_cshift,gfc_check_eoshift,gfc_check_unpack): Add rank + checks for cshift's shift and eoshift's shift and boundary args. + (gfc_check_unpack): Add rank and shape tests for unpack. + 2008-07-19 Kaveh R. Ghazi * gfortran.h (new): Remove macro. diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c index c0f9891bd98..4132d83a785 100644 --- a/gcc/fortran/check.c +++ b/gcc/fortran/check.c @@ -876,11 +876,16 @@ gfc_check_cshift (gfc_expr *array, gfc_expr *shift, gfc_expr *dim) if (scalar_check (shift, 1) == FAILURE) return FAILURE; } - else + else if (shift->rank != array->rank - 1 && shift->rank != 0) { - /* TODO: more requirements on shift parameter. */ + gfc_error ("SHIFT argument at %L of CSHIFT must have rank %d or be a " + "scalar", &shift->where, array->rank - 1); + return FAILURE; } + /* TODO: Add shape conformance check between array (w/o dimension dim) + and shift. */ + if (dim_check (dim, 2, true) == FAILURE) return FAILURE; @@ -1037,17 +1042,45 @@ gfc_check_eoshift (gfc_expr *array, gfc_expr *shift, gfc_expr *boundary, if (scalar_check (shift, 2) == FAILURE) return FAILURE; } - else + else if (shift->rank != array->rank - 1 && shift->rank != 0) { - /* TODO: more weird restrictions on shift. */ + gfc_error ("SHIFT argument at %L of EOSHIFT must have rank %d or be a " + "scalar", &shift->where, array->rank - 1); + return FAILURE; } + /* TODO: Add shape conformance check between array (w/o dimension dim) + and shift. */ + if (boundary != NULL) { if (same_type_check (array, 0, boundary, 2) == FAILURE) return FAILURE; - /* TODO: more restrictions on boundary. */ + if (array->rank == 1) + { + if (scalar_check (boundary, 2) == FAILURE) + return FAILURE; + } + else if (boundary->rank != array->rank - 1 && boundary->rank != 0) + { + gfc_error ("BOUNDARY argument at %L of EOSHIFT must have rank %d or be " + "a scalar", &boundary->where, array->rank - 1); + return FAILURE; + } + + if (shift->rank == boundary->rank) + { + int i; + for (i = 0; i < shift->rank; i++) + if (! identical_dimen_shape (shift, i, boundary, i)) + { + gfc_error ("Different shape in dimension %d for SHIFT and " + "BOUNDARY arguments of EOSHIFT at %L", shift->rank, + &boundary->where); + return FAILURE; + } + } } if (dim_check (dim, 4, true) == FAILURE) @@ -2886,6 +2919,25 @@ gfc_check_unpack (gfc_expr *vector, gfc_expr *mask, gfc_expr *field) if (same_type_check (vector, 0, field, 2) == FAILURE) return FAILURE; + if (mask->rank != field->rank && field->rank != 0) + { + gfc_error ("FIELD argument at %L of UNPACK must have the same rank as " + "MASK or be a scalar", &field->where); + return FAILURE; + } + + if (mask->rank == field->rank) + { + int i; + for (i = 0; i < field->rank; i++) + if (! identical_dimen_shape (mask, i, field, i)) + { + gfc_error ("Different shape in dimension %d for MASK and FIELD " + "arguments of UNPACK at %L", mask->rank, &field->where); + return FAILURE; + } + } + return SUCCESS; } diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 338edcd9dee..105edc4ccf4 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,8 @@ +2008-07-19 Tobias Burnus + + * gfortran.dg/intrinsic_argument_conformance_2.f90: New. + * gfortran.dg/zero_sized_1.f90: Fix conformance bugs. + 2008-07-18 Kris Van Hees * g++.dg/ext/utf-array.C: Fix broken merge/checkin. diff --git a/gcc/testsuite/gfortran.dg/intrinsic_argument_conformance_2.f90 b/gcc/testsuite/gfortran.dg/intrinsic_argument_conformance_2.f90 new file mode 100644 index 00000000000..44a4b39f742 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/intrinsic_argument_conformance_2.f90 @@ -0,0 +1,44 @@ +! { dg-do compile } +! Some CSHIFT, EOSHIFT and UNPACK conformance tests +! +program main + implicit none + real, dimension(1) :: a1, b1, c1 + real, dimension(1,1) :: a2, b2, c2 + real, dimension(1,0) :: a, b, c + real :: tempn(1), tempv(5) + real,allocatable :: foo(:) + allocate(foo(0)) + tempn = 2.0 + + a1 = 0 + a2 = 0 + c1 = 0 + a2 = 0 + + b1 = cshift (a1,1) + b1 = cshift (a1,(/1/)) ! { dg-error "must be a scalar" } + b1 = eoshift (a1,1) + b2 = eoshift (a1,c1(1)) ! { dg-error "must be INTEGER" } + b1 = eoshift (a1,(/1/)) ! { dg-error "must be a scalar" } + b1 = eoshift (a1,1,boundary=c1) ! { dg-error "must be a scalar" } + b1 = eoshift (a1,(/1/), boundary=c2) ! { dg-error "must be a scalar" } + + b2 = cshift (a2,1) + b2 = cshift (a2,(/1/)) + b2 = cshift (a2,reshape([1],[1,1])) ! { dg-error "have rank 1 or be a scalar" } + b2 = eoshift (a2,1) + b2 = eoshift (a2,c1) ! { dg-error "must be INTEGER" } + b2 = eoshift (a2,(/1/)) + b2 = eoshift (a2,reshape([1],[1,1]), boundary=c1) ! { dg-error "have rank 1 or be a scalar" } + b2 = eoshift (a2,1,boundary=c2(:,:)) ! { dg-error "have rank 1 or be a scalar" } + b2 = eoshift (a2,(/1/), boundary=c2(:,:)) ! { dg-error "have rank 1 or be a scalar" } + + b = eoshift (a,(/1/), boundary=c(1,:)) ! { dg-error "Different shape in dimension 1" } + + if (any(eoshift(foo,dim=1,shift=1,boundary=(/42.0,-7.0/))/= 0)) call abort() ! { dg-error "must be a scalar" } + if (any(eoshift(tempn(2:1),dim=1,shift=1,boundary=(/42.0,-7.0/))/= 0)) call abort() ! { dg-error "must be a scalar" } + + if (any(unpack(tempv,tempv(1:0)/=0,tempv) /= -47)) call abort() ! { dg-error "Different shape" } + if (any(unpack(tempv(5:4),tempv(1:0)/=0,tempv) /= -47)) call abort() ! { dg-error "Different shape" } +end program main diff --git a/gcc/testsuite/gfortran.dg/zero_sized_1.f90 b/gcc/testsuite/gfortran.dg/zero_sized_1.f90 index 224b2c007d3..5461fb1a7f0 100644 --- a/gcc/testsuite/gfortran.dg/zero_sized_1.f90 +++ b/gcc/testsuite/gfortran.dg/zero_sized_1.f90 @@ -49,8 +49,8 @@ subroutine test_eoshift 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(foo,dim=1,shift=1,boundary=42.0)/= 0)) call abort + if (any(eoshift(tempn(2:1),dim=1,shift=1,boundary=-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 @@ -159,15 +159,17 @@ end subroutine test_unpack integer :: tempn(1,5), tempv(5) integer,allocatable :: foo(:,:), bar(:) + integer :: zero tempn = 2 tempv = 5 + zero = 0 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(tempv,tempv(1:zero)/=0,tempv) /= -47)) call abort + if (any(unpack(tempv(5:4),tempv(1:zero)/=0,tempv) /= -47)) call abort if (any(unpack(bar,foo==foo,foo) /= -47)) call abort deallocate(foo,bar) end -- 2.30.2