OpenE2K/gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

re PR fortran/19168 (Mismatched KINDs in SELECT CASE constucts is not handled correctly)

Browse Source 
2005-01-16  Steven G. Kargl  <kargls@comcast.net>

	PR 19168
	* resolve.c (check_case_overlap): Typo in comment.
	(validate_case_label_expr):  Fix up kinds of case values
	(resolve_select): Properly handle kind mismatches.
testsuite/
	* gfortran.dg/select_5.f90: New test.

From-SVN: r93725
This commit is contained in:
Steven G. Kargl 2005-01-16 12:51:04 +00:00 committed by Paul Brook
parent 36c028f675
commit 5352b89f60
4 changed files with 80 additions and 11 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
gcc/fortran/ChangeLog
View File

@ -1,3 +1,10 @@
2005-01-16 Steven G. Kargl <kargls@comcast.net>
PR 19168
* resolve.c (check_case_overlap): Typo in comment.
(validate_case_label_expr): Fix up kinds of case values
(resolve_select): Properly handle kind mismatches.
2004-01-16 Paul Brook <paul@codesourcery.com>
PR fortran/17675

62
gcc/fortran/resolve.c
View File

@ -2579,7 +2579,7 @@ check_case_overlap (gfc_case * list)
/* Count this merge. */
nmerges++;
/* Cut the list in two pieces by steppin INSIZE places
/* Cut the list in two pieces by stepping INSIZE places
forward in the list, starting from P. */
psize = 0;
q = p;
@ -2676,32 +2676,38 @@ check_case_overlap (gfc_case * list)
}
/* Check to see if an expression is suitable for use in a CASE
statement. Makes sure that all case expressions are scalar
constants of the same type/kind. Return FAILURE if anything
is wrong. */
/* Check to see if an expression is suitable for use in a CASE statement.
Makes sure that all case expressions are scalar constants of the same
type. Return FAILURE if anything is wrong. */
static try
validate_case_label_expr (gfc_expr * e, gfc_expr * case_expr)
{
gfc_typespec case_ts = case_expr->ts;
if (e == NULL) return SUCCESS;
if (e->ts.type != case_ts.type)
if (e->ts.type != case_expr->ts.type)
{
gfc_error ("Expression in CASE statement at %L must be of type %s",
&e->where, gfc_basic_typename (case_ts.type));
&e->where, gfc_basic_typename (case_expr->ts.type));
return FAILURE;
}
if (e->ts.kind != case_ts.kind)
/* C805 (R808) For a given case-construct, each case-value shall be of
the same type as case-expr. For character type, length differences
are allowed, but the kind type parameters shall be the same. */
if (case_expr->ts.type == BT_CHARACTER && e->ts.kind != case_expr->ts.kind)
{
gfc_error("Expression in CASE statement at %L must be kind %d",
&e->where, case_ts.kind);
&e->where, case_expr->ts.kind);
return FAILURE;
}
/* Convert the case value kind to that of case expression kind, if needed.
FIXME: Should a warning be issued? */
if (e->ts.kind != case_expr->ts.kind)
gfc_convert_type_warn (e, &case_expr->ts, 2, 0);
if (e->rank != 0)
{
gfc_error ("Expression in CASE statement at %L must be scalar",
@ -2784,6 +2790,40 @@ resolve_select (gfc_code * code)
return;
}
/* PR 19168 has a long discussion concerning a mismatch of the kinds
of the SELECT CASE expression and its CASE values. Walk the lists
of case values, and if we find a mismatch, promote case_expr to
the appropriate kind. */
if (type == BT_LOGICAL || type == BT_INTEGER)
{
for (body = code->block; body; body = body->block)
{
/* Walk the case label list. */
for (cp = body->ext.case_list; cp; cp = cp->next)
{
/* Intercept the DEFAULT case. It does not have a kind. */
if (cp->low == NULL && cp->high == NULL)
continue;
/* Unreachable case ranges are discarded, so ignore. */
if (cp->low != NULL && cp->high != NULL
&& cp->low != cp->high
&& gfc_compare_expr (cp->low, cp->high) > 0)
continue;
/* FIXME: Should a warning be issued? */
if (cp->low != NULL
&& case_expr->ts.kind != gfc_kind_max(case_expr, cp->low))
gfc_convert_type_warn (case_expr, &cp->low->ts, 2, 0);
if (cp->high != NULL
&& case_expr->ts.kind != gfc_kind_max(case_expr, cp->high))
gfc_convert_type_warn (case_expr, &cp->high->ts, 2, 0);
}
}
}
/* Assume there is no DEFAULT case. */
default_case = NULL;
head = tail = NULL;

5
gcc/testsuite/ChangeLog
View File

@ -1,3 +1,8 @@
2005-01-16 Steven G. Kargl <kargls@comcast.net>
PR 19168
* gfortran.dg/select_5.f90: New test.
2004-01-16 Paul Brook <paul@codesourcery.com>
* gfortran.dg/common_4.f90: New test.

17
gcc/testsuite/gfortran.dg/select_5.f90 Normal file
View File

@ -0,0 +1,17 @@
! { dg-do run }
! Test mismatched type kinds in a select statement.
program select_5
integer*1 i ! kind = 1, -128 <= i < 127
do i = 1, 3
select case (i)
case (1_4) ! kind = 4, reachable
if (i /= 1_4) call abort
case (2_8) ! kind = 8, reachable
if (i /= 2_8) call abort
case (200) ! kind = 4, unreachable because of range of i
call abort
case default
if (i /= 3) call abort
end select
end do
end program select_5