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

com.c (ffecom_constantunion_with_type): New function. 

2003-03-22  Bud Davis  <bdavis9659@comcast.net>

	* com.c (ffecom_constantunion_with_type): New function.
	* com.h (ffecom_constantunion_with_type): Declare.
	* stc.c (ffestc_R810): Check for kind type.
	* ste.c (ffeste_R810): Use ffecom_constantunion_with_type
	to discern SELECT CASE variables.

From-SVN: r64709
This commit is contained in:
Bud Davis 2003-03-22 13:01:08 +00:00 committed by Toon Moene
parent dcde977582
commit 6dd0f30b36
8 changed files with 284 additions and 9 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
gcc/f/ChangeLog
View File

@ -1,3 +1,11 @@
2003-03-22 Bud Davis <bdavis9659@comcast.net>
* com.c (ffecom_constantunion_with_type): New function.
* com.h (ffecom_constantunion_with_type): Declare.
* stc.c (ffestc_R810): Check for kind type.
* ste.c (ffeste_R810): Use ffecom_constantunion_with_type
to discern SELECT CASE variables.
2003-03-15 Roger Sayle <roger@eyesopen.com>
* stb.c (ffestb_R100110_): Allow the number before the X format

72
gcc/f/com.c
View File

@ -10591,6 +10591,78 @@ ffecom_constantunion (ffebldConstantUnion *cu, ffeinfoBasictype bt,
return item;
}
/* Transform constant-union to tree, with the type known. */
tree
ffecom_constantunion_with_type (ffebldConstantUnion *cu,
tree tree_type, ffebldConst ct)
{
tree item;
int val;
switch (ct)
{
#if FFETARGET_okINTEGER1
case FFEBLD_constINTEGER1:
val = ffebld_cu_val_integer1 (*cu);
item = build_int_2 (val, (val < 0) ? -1 : 0);
break;
#endif
#if FFETARGET_okINTEGER2
case FFEBLD_constINTEGER2:
val = ffebld_cu_val_integer2 (*cu);
item = build_int_2 (val, (val < 0) ? -1 : 0);
break;
#endif
#if FFETARGET_okINTEGER3
case FFEBLD_constINTEGER3:
val = ffebld_cu_val_integer3 (*cu);
item = build_int_2 (val, (val < 0) ? -1 : 0);
break;
#endif
#if FFETARGET_okINTEGER4
case FFEBLD_constINTEGER4:
val = ffebld_cu_val_integer4 (*cu);
item = build_int_2 (val, (val < 0) ? -1 : 0);
break;
#endif
#if FFETARGET_okLOGICAL1
case FFEBLD_constLOGICAL1:
val = ffebld_cu_val_logical1 (*cu);
item = build_int_2 (val, (val < 0) ? -1 : 0);
break;
#endif
#if FFETARGET_okLOGICAL2
case FFEBLD_constLOGICAL2:
val = ffebld_cu_val_logical2 (*cu);
item = build_int_2 (val, (val < 0) ? -1 : 0);
break;
#endif
#if FFETARGET_okLOGICAL3
case FFEBLD_constLOGICAL3:
val = ffebld_cu_val_logical3 (*cu);
item = build_int_2 (val, (val < 0) ? -1 : 0);
break;
#endif
#if FFETARGET_okLOGICAL4
case FFEBLD_constLOGICAL4:
val = ffebld_cu_val_logical4 (*cu);
item = build_int_2 (val, (val < 0) ? -1 : 0);
break;
#endif
default:
assert ("constant type not supported"==NULL);
return error_mark_node;
break;
}
TREE_TYPE (item) = tree_type;
TREE_CONSTANT (item) = 1;
return item;
}
/* Transform expression into constant tree.
If the expression can be transformed into a tree that is constant,

2
gcc/f/com.h
View File

@ -210,6 +210,8 @@ tree ffecom_arg_expr (ffebld expr, tree *length);
tree ffecom_arg_ptr_to_const_expr (ffebld expr, tree *length);
tree ffecom_arg_ptr_to_expr (ffebld expr, tree *length);
tree ffecom_call_gfrt (ffecomGfrt ix, tree args, tree hook);
tree ffecom_constantunion_with_type (ffebldConstantUnion *cu,
tree tree_type,ffebldConst ct);
tree ffecom_constantunion (ffebldConstantUnion *cu, ffeinfoBasictype bt,
ffeinfoKindtype kt, tree tree_type);
tree ffecom_const_expr (ffebld expr);

12
gcc/f/stc.c
View File

@ -9197,11 +9197,17 @@ ffestc_R810 (ffesttCaseList cases, ffelexToken name)
}
if (((caseobj->expr1 != NULL)
&& ((ffeinfo_basictype (ffebld_info (caseobj->expr1))
!= s->type)))
!= s->type)
|| ((ffeinfo_kindtype (ffebld_info (caseobj->expr1))
!= s->kindtype)
&& (ffeinfo_kindtype (ffebld_info (caseobj->expr1)) != FFEINFO_kindtypeINTEGER1 ))
|| ((caseobj->range)
&& (caseobj->expr2 != NULL)
&& ((ffeinfo_basictype (ffebld_info (caseobj->expr2))
!= s->type))))
!= s->type)
|| ((ffeinfo_kindtype (ffebld_info (caseobj->expr2))
!= s->kindtype)
&& (ffeinfo_kindtype (ffebld_info (caseobj->expr2)) != FFEINFO_kindtypeINTEGER1)))))))
{
ffebad_start (FFEBAD_CASE_TYPE_DISAGREE);
ffebad_here (0, ffelex_token_where_line (caseobj->t),
@ -9212,6 +9218,8 @@ ffestc_R810 (ffesttCaseList cases, ffelexToken name)
continue;
}
if ((s->type == FFEINFO_basictypeLOGICAL) && (caseobj->range))
{
ffebad_start (FFEBAD_CASE_LOGICAL_RANGE);

11
gcc/f/ste.c
View File

@ -2711,21 +2711,18 @@ ffeste_R810 (ffestw block, unsigned long casenum)
do
{
texprlow = (c->low == NULL) ? NULL_TREE
: ffecom_constantunion (&ffebld_constant_union (c->low), s->type,
s->kindtype,
ffecom_tree_type[s->type][s->kindtype]);
: ffecom_constantunion_with_type (&ffebld_constant_union (c->low),
ffecom_tree_type[s->type][s->kindtype],c->low->consttype);
if (c->low != c->high)
{
texprhigh = (c->high == NULL) ? NULL_TREE
: ffecom_constantunion (&ffebld_constant_union (c->high),
s->type, s->kindtype,
ffecom_tree_type[s->type][s->kindtype]);
: ffecom_constantunion_with_type (&ffebld_constant_union (c->high),
ffecom_tree_type[s->type][s->kindtype],c->high->consttype);
pushok = pushcase_range (texprlow, texprhigh, convert,
tlabel, &duplicate);
}
else
pushok = pushcase (texprlow, convert, tlabel, &duplicate);
assert((pushok != 2) || (pushok != 0));
if (pushok == 2)
{
ffebad_start_msg ("SELECT (at %0) has duplicate cases -- check integer overflow of CASE(s)",

5
gcc/testsuite/ChangeLog
View File

@ -1,3 +1,8 @@
2003-03-22 Bud Davis <bdavis9659@comcast.net>
* g77.f-torture/execute/select.f: New test.
* g77.f-torture/noncompile/select_no_compile.f: New test.
2003-03-21 Nathan Sidwell <nathan@codesourcery.com>
PR c++/9898

173
gcc/testsuite/g77.f-torture/execute/select.f Normal file
View File

@ -0,0 +1,173 @@
C integer byte case with integer byte parameters as case(s)
subroutine ib
integer *1 a /1/
integer *1 one,two,three
parameter (one=1,two=2,three=3)
select case (a)
case (one)
case (two)
call abort
case (three)
call abort
case default
call abort
end select
print*,'normal ib'
end
C integer halfword case with integer halfword parameters
subroutine ih
integer *2 a /1/
integer *2 one,two,three
parameter (one=1,two=2,three=3)
select case (a)
case (one)
case (two)
call abort
case (three)
call abort
case default
call abort
end select
print*,'normal ih'
end
C integer case with integer parameters
subroutine iw
integer *4 a /1/
integer *4 one,two,three
parameter (one=1,two=2,three=3)
select case (a)
case (one)
case (two)
call abort
case (three)
call abort
case default
call abort
end select
print*,'normal iw'
end
C integer double case with integer double parameters
subroutine id
integer *8 a /1/
integer *8 one,two,three
parameter (one=1,two=2,three=3)
select case (a)
case (one)
case (two)
call abort
case (three)
call abort
case default
call abort
end select
print*,'normal id'
end
C integer byte select with integer case
subroutine ib_mixed
integer*1 s /1/
select case (s)
case (1)
case (2)
call abort
end select
print*,'ib ok'
end
C integer halfword with integer case
subroutine ih_mixed
integer*2 s /1/
select case (s)
case (1)
case default
call abort
end select
print*,'ih ok'
end
C integer word with integer case
subroutine iw_mixed
integer s /5/
select case (s)
case (1)
call abort
case (2)
call abort
case (3)
call abort
case (4)
call abort
case (5)
C
case (6)
call abort
case default
call abort
end select
print*,'iw ok'
end
C integer doubleword with integer case
subroutine id_mixed
integer *8 s /1024/
select case (s)
case (1)
call abort
case (1023)
call abort
case (1025)
call abort
case (1024)
C
end select
print*,'i8 ok'
end
subroutine l1_mixed
logical*1 s /.TRUE./
select case (s)
case (.TRUE.)
case (.FALSE.)
call abort
end select
print*,'l1 ok'
end
subroutine l2_mixed
logical*2 s /.FALSE./
select case (s)
case (.TRUE.)
call abort
case (.FALSE.)
end select
print*,'lh ok'
end
subroutine l4_mixed
logical*4 s /.TRUE./
select case (s)
case (.FALSE.)
call abort
case (.TRUE.)
end select
print*,'lw ok'
end
subroutine l8_mixed
logical*8 s /.TRUE./
select case (s)
case (.TRUE.)
case (.FALSE.)
call abort
end select
print*,'ld ok'
end
C main
C -- regression cases
call ib
call ih
call iw
call id
C -- new functionality
call ib_mixed
call ih_mixed
call iw_mixed
call id_mixed
end

10
gcc/testsuite/g77.f-torture/noncompile/select_no_compile.f Normal file
View File

@ -0,0 +1,10 @@
integer*1 one
integer*2 two
parameter (one=1)
parameter (two=2)
select case (I)
case (one)
case (two)
end select
end