Skip to content

R
riscv-gcc-1
Commit d1a296c1 by Tobias Burnus Committed by Tobias Burnus
Options

check.c (gfc_check_cshift,gfc_check_eoshift,gfc_check_unpack): Add rank checks… 

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  <burnus@net-b.de>

        * 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  <burnus@net-b.de>

        * gfortran.dg/intrinsic_argument_conformance_2.f90: New.
        * gfortran.dg/zero_sized_1.f90: Fix conformance bugs.

From-SVN: r137983
parent 7b901ac4
Showing with 118 additions and 9 deletions
gcc/fortran/ChangeLog
2008-07-19 Tobias Burnus <burnus@net-b.de>
* 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 <ghazi@caip.rutgers.edu>
* gfortran.h (new): Remove macro.
......
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;
}
......
gcc/testsuite/ChangeLog
2008-07-19 Tobias Burnus <burnus@net-b.de>
* gfortran.dg/intrinsic_argument_conformance_2.f90: New.
* gfortran.dg/zero_sized_1.f90: Fix conformance bugs.
2008-07-18 Kris Van Hees <kris.van.hees@oracle.com>
* g++.dg/ext/utf-array.C: Fix broken merge/checkin.
......
gcc/testsuite/gfortran.dg/intrinsic_argument_conformance_2.f90 0 → 100644
! { 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
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
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment