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:
parent
dcde977582
commit
6dd0f30b36
|
@ -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
72
gcc/f/com.c
|
@ -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,
|
||||
|
|
|
@ -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
12
gcc/f/stc.c
|
@ -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
11
gcc/f/ste.c
|
@ -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)",
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
||||
|
||||
|
||||
|
||||
|
|
@ -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
|
||||
|
Loading…
Reference in New Issue