+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
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,
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);
}
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),
continue;
}
+
+
if ((s->type == FFEINFO_basictypeLOGICAL) && (caseobj->range))
{
ffebad_start (FFEBAD_CASE_LOGICAL_RANGE);
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)",
+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
--- /dev/null
+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
+
+
+
+
+
--- /dev/null
+ integer*1 one
+ integer*2 two
+ parameter (one=1)
+ parameter (two=2)
+ select case (I)
+ case (one)
+ case (two)
+ end select
+ end
+
projects / gcc.git / commitdiff