Skip to content

R
riscv-gcc-1
Commit c224550f by Steven G. Kargl Committed by Paul Brook
Options

resolve.c (compare_case): Cleanup. 

2005-01-14  Steven G. Kargl  <kargls@comcast.net>

	* resolve.c (compare_case): Cleanup.
testsuite/
	* gfortran.dg/select_1.f90: New test.
	* gfortran.dg/select_2.f90: New test.
	* gfortran.dg/select_3.f90: New test.
	* gfortran.dg/select_4.f90: New test.

From-SVN: r93640
parent 08a0c536
Showing with 96 additions and 98 deletions
gcc/fortran/ChangeLog
2005-01-14 Steven G. Kargl <kargls@comcast.net>
* resolve.c (compare_case): Cleanup.
2005-01-14 Steven G. Kargl <kargls@comcast.net>
* resolve.c (compare_case): Give arguments correct type.
2005-01-13 Kazu Hirata <kazu@cs.umass.edu>
......
gcc/fortran/resolve.c
......@@ -2493,85 +2493,52 @@ resolve_allocate_expr (gfc_expr * e)
/* Callback function for our mergesort variant. Determines interval
overlaps for CASEs. Return <0 if op1 < op2, 0 for overlap, >0 for
op1 > op2. Assumes we're not dealing with the default case. */
op1 > op2. Assumes we're not dealing with the default case.
We have op1 = (:L), (K:L) or (K:) and op2 = (:N), (M:N) or (M:).
There are nine situations to check. */
static int
compare_cases (const gfc_case * op1, const gfc_case * op2)
{
int retval;
if (op1->low == NULL) /* op1 = (:N) */
if (op1->low == NULL) /* op1 = (:L) */
{
if (op2->low == NULL) /* op2 = (:M), so overlap. */
return 0;
else if (op2->high == NULL) /* op2 = (M:) */
{
if (gfc_compare_expr (op1->high, op2->low) < 0)
return -1; /* N < M */
else
return 0;
}
else /* op2 = (L:M) */
{
if (gfc_compare_expr (op1->high, op2->low) < 0)
return -1; /* N < L */
else
return 0;
}
/* op2 = (:N), so overlap. */
retval = 0;
/* op2 = (M:) or (M:N), L < M */
if (op2->low != NULL
&& gfc_compare_expr (op1->high, op2->low) < 0)
retval = -1;
}
else if (op1->high == NULL) /* op1 = (N:) */
else if (op1->high == NULL) /* op1 = (K:) */
{
if (op2->low == NULL) /* op2 = (:M) */
{
if (gfc_compare_expr (op1->low, op2->high) > 0)
return 1; /* N > M */
else
return 0;
}
else if (op2->high == NULL) /* op2 = (M:), so overlap. */
return 0;
else /* op2 = (L:M) */
{
if (gfc_compare_expr (op1->low, op2->high) > 0)
return 1; /* N > M */
else
return 0;
}
/* op2 = (M:), so overlap. */
retval = 0;
/* op2 = (:N) or (M:N), K > N */
if (op2->high != NULL
&& gfc_compare_expr (op1->low, op2->high) > 0)
retval = 1;
}
else /* op1 = (N:P) */
else /* op1 = (K:L) */
{
if (op2->low == NULL) /* op2 = (:M) */
{
if (gfc_compare_expr (op1->low, op2->high) > 0)
return 1; /* N > M */
else
return 0;
}
else if (op2->high == NULL) /* op2 = (M:) */
if (op2->low == NULL) /* op2 = (:N), K > N */
retval = (gfc_compare_expr (op1->low, op2->high) > 0) ? 1 : 0;
else if (op2->high == NULL) /* op2 = (M:), L < M */
retval = (gfc_compare_expr (op1->high, op2->low) < 0) ? -1 : 0;
else /* op2 = (M:N) */
{
retval = 0;
/* L < M */
if (gfc_compare_expr (op1->high, op2->low) < 0)
return -1; /* P < M */
else
return 0;
}
else /* op2 = (L:M) */
{
if (gfc_compare_expr (op1->high, op2->low) < 0)
return -1; /* P < L */
if (gfc_compare_expr (op1->low, op2->high) > 0)
return 1; /* N > M */
return 0;
retval = -1;
/* K > N */
else if (gfc_compare_expr (op1->low, op2->high) > 0)
retval = 1;
}
}
return retval;
}
......
gcc/testsuite/ChangeLog
2005-01-14 Steven G. Kargl <kargls@comcast.net>
* gfortran.dg/select_1.f90: New test.
* gfortran.dg/select_2.f90: New test.
* gfortran.dg/select_3.f90: New test.
* gfortran.dg/select_4.f90: New test.
2005-01-14 Jakub Jelinek <jakub@redhat.com>
PR middle-end/19084
......
gcc/testsuite/gfortran.dg/select_1.f90 0 → 100644
! { dg-do run }
! Simple test for SELECT CASE
!
program select_2
integer i
do i = 1, 5
select case(i)
case (1)
if (i /= 1) call abort
case (2:3)
if (i /= 2 .and. i /= 3) call abort
case (4)
if (i /= 4) call abort
case default
if (i /= 5) call abort
end select
end do
end program select_2
gcc/testsuite/gfortran.dg/select_2.f90
! { dg-do run }
! Simple test for SELECT CASE
! Simple test program to see if gfortran eliminates the 'case (3:2)'
! statement. This is an unreachable CASE because the range is empty.
!
program select_2
program select_3
integer i
do i = 1, 4
select case(i)
case (1)
if (i /= 1) call abort
case (2:3)
if (i /= 2 .and. i /= 3) call abort
case (3:2)
call abort
case (4)
if (i /= 4) call abort
case default
call abort
if (i /= 2 .and. i /= 3) call abort
end select
end do
end program select_2
end program select_3
gcc/testsuite/gfortran.dg/select_3.f90
! [dg-do run }
! Simple test program to see if gfortran eliminates the 'case (3:2)'
! statement. This is an unreachable CASE because the range is empty.
! { dg-do run }
! Short test program with a CASE statement that uses a range.
!
program select_3
program select_4
integer i
do i = 1, 4
do i = 1, 34, 4
select case(i)
case (1)
if (i /= 1) call abort
case (3:2)
call abort
case (4)
if (i /= 4) call abort
case (:5)
if (i /= 1 .and. i /= 5) call abort
case (13:21)
if (i /= 13 .and. i /= 17 .and. i /= 21) call abort
case (29:)
if (i /= 29 .and. i /= 33) call abort
case default
if (i /= 2 .and. i /= 3) call abort
if (i /= 9 .and. i /= 25) call abort
end select
end do
end program select_3
end program select_4
gcc/testsuite/gfortran.dg/select_4.f90
! { dg-do run }
! Short test program with a CASE statement that uses a range.
! { dg-do compile }
! Check for overlapping case range diagnostics.
!
program select_4
program select_5
integer i
do i = 1, 40, 4
select case(i)
case (:5)
if (i /= 1 .and. i /= 5) call abort
case (20:30)
if (i /= 21 .and. i /= 25 .and. i /= 29) call abort
case (34:)
if (i /= 37) call abort
end select
end do
end program select_4
select case(i)
case (20:30)
case (25:) ! { dg-error "overlaps with CASE" "" }
end select
select case(i)
case (30)
case (25:) ! { dg-error "overlaps with CASE" "" }
end select
select case(i)
case (20:30)
case (25) ! { dg-error "overlaps with CASE" "" }
end select
end program select_5
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