OSDN Git Service

* config/alpha/vms.h (INCLUDE_DEFAULTS): Add /gnu/lib/gcc-lib/include.
[pf3gnuchains/gcc-fork.git] / gcc / ch / actions.c
1 /* Implement actions for CHILL.
2    Copyright (C) 1992, 1993, 1994, 1998, 1999, 2000
3    Free Software Foundation, Inc.
4    Authors: Per Bothner, Bill Cox, Michael Tiemann, Michael North
5
6 This file is part of GNU CC.
7
8 GNU CC is free software; you can redistribute it and/or modify
9 it under the terms of the GNU General Public License as published by
10 the Free Software Foundation; either version 2, or (at your option)
11 any later version.
12
13 GNU CC is distributed in the hope that it will be useful,
14 but WITHOUT ANY WARRANTY; without even the implied warranty of
15 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
16 GNU General Public License for more details.
17
18 You should have received a copy of the GNU General Public License
19 along with GNU CC; see the file COPYING.  If not, write to
20 the Free Software Foundation, 59 Temple Place - Suite 330,
21 Boston, MA 02111-1307, USA.  */
22
23 #include "config.h"
24 #include "system.h"
25 #include "tree.h"
26 #include "rtl.h"
27 #include "expr.h"
28 #include "ch-tree.h"
29 #include "lex.h"
30 #include "flags.h"
31 #include "actions.h"
32 #include "obstack.h"
33 #include "assert.h"
34 #include "toplev.h"
35 #include "diagnostic.h"
36
37 static int id_cmp PARAMS ((tree *, tree *));
38 static void warn_unhandled PARAMS ((const char *));
39 static tree adjust_return_value PARAMS ((tree, const char *));
40 static tree update_else_range_for_int_const PARAMS ((tree, tree));
41 static tree update_else_range_for_range PARAMS ((tree, tree, tree));
42 static tree update_else_range_for_range_expr PARAMS ((tree, tree));
43 static tree update_else_range_for_type PARAMS ((tree, tree));
44 static tree compute_else_range PARAMS ((tree, tree, int));
45 static tree check_case_value PARAMS ((tree, tree));
46 static void chill_handle_case_label_range PARAMS ((tree, tree, tree));
47 static tree chill_handle_multi_case_label_range PARAMS ((tree, tree, tree));
48 static tree chill_handle_multi_case_else_label PARAMS ((tree));
49 static tree chill_handle_multi_case_label PARAMS ((tree, tree));
50 static tree chill_handle_multi_case_label_list PARAMS ((tree, tree));
51 static void print_missing_cases PARAMS ((tree, const unsigned char *, long));
52
53 #define obstack_chunk_alloc xmalloc
54 #define obstack_chunk_free free
55
56 /* reserved tag definitions */
57
58 #define TYPE_ID                 "id"
59 #define TAG_OBJECT              "chill_object"
60 #define TAG_CLASS               "chill_class"
61
62 extern int flag_short_enums;
63 extern int current_nesting_level;
64
65 extern struct obstack *expression_obstack, permanent_obstack;
66 extern struct obstack *current_obstack, *saveable_obstack;
67
68 /* This flag is checked throughout the non-CHILL-specific
69    in the front end. */
70 tree chill_integer_type_node;
71 tree chill_unsigned_type_node;
72
73 /* Never used.  Referenced from c-typeck.c, which we use. */
74 int current_function_returns_value = 0;
75 int current_function_returns_null = 0;
76
77 /* data imported from toplev.c  */
78
79 extern char *dump_base_name;
80
81 /* set from command line parameter, to exit after 
82    grant file written, generating no code. */
83 int grant_only_flag = 0;
84 \f
85 const char *
86 lang_identify ()
87 {
88   return "chill";
89 }
90
91
92 void
93 init_chill ()
94 {
95 }
96
97 void
98 print_lang_statistics ()
99 {
100 }
101
102
103 void
104 lang_finish ()
105 {
106 #if 0
107     extern int errorcount, sorrycount;
108
109     /* this should be the last action in compiling a module.
110        If there are other actions to be performed at lang_finish
111        please insert before this */
112
113     /* FIXME: in case of a syntax error, this leaves the grant file incomplete */
114     /* for the moment we print a warning in case of errors and 
115        continue granting */
116     if ((errorcount || sorrycount) && grant_count)
117       {
118         warning ("%d errors, %d sorries, do granting", errorcount, sorrycount);
119         errorcount = sorrycount = 0;
120       }
121 #endif
122 }
123
124 void
125 chill_check_decl (decl)
126      tree decl;
127 {
128   tree type = TREE_TYPE (decl);
129   static int alreadyWarned = 0;
130
131   if (TREE_CODE (type) == RECORD_TYPE) /* && TREE_STATIC_TEMPLATE (type)) */
132     {
133       if (!alreadyWarned)
134         {
135           error ("GNU compiler does not support statically allocated objects");          
136           alreadyWarned = 1;
137         }
138       error_with_decl (decl, "`%s' cannot be statically allocated");
139     }
140 }
141 \f
142 /* Comparison function for sorting identifiers in RAISES lists.
143    Note that because IDENTIFIER_NODEs are unique, we can sort
144    them by address, saving an indirection.  */
145 static int
146 id_cmp (p1, p2)
147      tree *p1, *p2;
148 {
149   long diff = (long)TREE_VALUE (*p1) - (long)TREE_VALUE (*p2);
150
151   return (diff < 0) ? -1 : (diff > 0);
152 }
153
154 /* Build the FUNCTION_TYPE or METHOD_TYPE which may raise exceptions
155    listed in RAISES.  */
156 tree
157 build_exception_variant (type, raises)
158      tree type, raises;
159 {
160   int i;
161   tree v = TYPE_MAIN_VARIANT (type);
162   tree t, t2;
163   int constp    = TYPE_READONLY (type);
164   int volatilep = TYPE_VOLATILE (type);
165
166   if (!raises)
167     return build_type_variant (v, constp, volatilep);
168
169   if (TREE_CHAIN (raises))
170     { /* Sort the list */
171       tree *a = (tree *)alloca ((list_length (raises)+1) * sizeof (tree));
172       for (i = 0, t = raises; t; t = TREE_CHAIN (t), i++)
173         a[i] = t;
174       /* NULL terminator for list.  */
175       a[i] = NULL_TREE;
176       qsort (a, i, sizeof (tree),
177              (int (*) PARAMS ((const void*, const void*))) id_cmp);
178       while (i--)
179         TREE_CHAIN (a[i]) = a[i+1];
180       raises = a[0];
181     }
182
183   for (v = TYPE_NEXT_VARIANT (v); v; v = TYPE_NEXT_VARIANT (v))
184     {
185       if (TYPE_READONLY (v) != constp
186           || TYPE_VOLATILE (v) != volatilep)
187         continue;
188
189       t = raises;
190       t2 = TYPE_RAISES_EXCEPTIONS (v);
191       while (t && t2)
192         {
193           if (TREE_TYPE (t) == TREE_TYPE (t2))
194             {
195               t = TREE_CHAIN (t);
196               t2 = TREE_CHAIN (t2);
197             }
198           else break;
199         }
200       if (t || t2)
201         continue;
202       /* List of exceptions raised matches previously found list.
203
204          @@ Nice to free up storage used in consing up the
205          @@ list of exceptions raised.  */
206       return v;
207     }
208
209   /* Need to build a new variant.  */
210   if (TREE_PERMANENT (type))
211     {
212       push_obstacks_nochange ();
213       end_temporary_allocation ();
214       v = copy_node (type);
215       pop_obstacks ();
216     }
217   else
218     v = copy_node (type);
219
220   TYPE_NEXT_VARIANT (v) = TYPE_NEXT_VARIANT (type);
221   TYPE_NEXT_VARIANT (type) = v;
222   if (raises && ! TREE_PERMANENT (raises))
223     {
224       push_obstacks_nochange ();
225       end_temporary_allocation ();
226       raises = copy_list (raises);
227       pop_obstacks ();
228     }
229   TYPE_RAISES_EXCEPTIONS (v) = raises;
230   return v;
231 }
232 #if 0
233 \f
234 tree
235 build_rts_call (name, type, args)
236      const char *name;
237      tree type, args;
238 {
239   tree decl = lookup_name (get_identifier (name));
240   tree converted_args = NULL_TREE;
241   tree result, length = NULL_TREE;
242
243   assert (decl != NULL_TREE);
244   while (args)
245     {
246       tree arg = TREE_VALUE (args);
247       if (TREE_CODE (TREE_TYPE (arg)) == SET_TYPE
248           || TREE_CODE (TREE_TYPE (arg)) == ARRAY_TYPE)
249         {
250           length = size_in_bytes (TREE_TYPE (arg));
251           arg = build_chill_addr_expr (arg, (char *)0);
252         }
253       converted_args = tree_cons (NULL_TREE, arg, converted_args);
254       args = TREE_CHAIN (args);
255     }
256   if (length != NULL_TREE)
257     converted_args = tree_cons (NULL_TREE, length, converted_args);
258   converted_args = nreverse (converted_args);
259   result = build_chill_function_call (decl, converted_args);
260   if (TREE_CODE (type) == SET_TYPE || TREE_CODE (type) == ARRAY_TYPE)
261     result = build1 (INDIRECT_REF, type, result);
262   else
263     result = convert (type, result);
264   return result;
265 }
266 #endif
267
268 /*
269  * queue name of unhandled exception
270  * to avoid multiple unhandled warnings
271  * in one compilation module
272  */
273
274 struct already_type
275 {
276   struct already_type *next;
277   char *name;
278 };
279
280 static struct already_type *already_warned = 0;
281
282 static void
283 warn_unhandled (ex)
284      const char *ex;
285 {
286   struct already_type *p = already_warned;
287
288   while (p)
289     {
290       if (!strcmp (p->name, ex))
291         return;
292       p = p->next;
293     }
294   
295   /* not yet warned */
296   p = (struct already_type *)xmalloc (sizeof (struct already_type));
297   p->next = already_warned;
298   p->name = xstrdup (ex);
299   already_warned = p;
300   pedwarn ("causing unhandled exception `%s' (this is flaged only once)", ex);
301 }
302
303 /*
304  * build a call to the following function:
305  *   void   __cause_ex1 (char* ex, const char *file, 
306  *                       const unsigned lineno);
307  * if the exception is handled or
308  *   void __unhandled_ex (char *ex, char *file, unsigned lineno)
309  * if the exception is not handled.
310  */
311 tree
312 build_cause_exception (exp_name, warn_if_unhandled)
313      tree exp_name;
314      int warn_if_unhandled;
315 {
316   /* We don't use build_rts_call() here, because the string (array of char)
317      would be followed by its length in the parameter list built by
318      build_rts_call, and the runtime routine doesn't want a length parameter.*/
319   tree exp_decl = build_chill_exception_decl (IDENTIFIER_POINTER (exp_name));
320   tree function, fname, lineno, result;
321   int handled = is_handled (exp_name);
322
323   switch (handled)
324     {
325     case 0:
326       /* no handler */
327       if (warn_if_unhandled)
328         warn_unhandled (IDENTIFIER_POINTER (exp_name));
329       function = lookup_name (get_identifier ("__unhandled_ex"));
330       fname = force_addr_of (get_chill_filename ());
331       lineno = get_chill_linenumber ();
332       break;
333     case 1:
334       /* local handler */
335       function = lookup_name (get_identifier ("__cause_ex1"));
336       fname = force_addr_of (get_chill_filename ());
337       lineno = get_chill_linenumber ();
338       break;
339     case 2:
340       /* function may propagate this exception */
341       function = lookup_name (get_identifier ("__cause_ex1"));
342       fname = lookup_name (get_identifier (CALLER_FILE));
343       if (fname == NULL_TREE)
344         fname = error_mark_node;
345       lineno = lookup_name (get_identifier (CALLER_LINE));
346       if (lineno == NULL_TREE)
347         lineno = error_mark_node;
348       break;
349     default:
350       abort();
351     }
352   result =
353     build_chill_function_call (function,
354       tree_cons (NULL_TREE, build_chill_addr_expr (exp_decl, (char *)0),
355         tree_cons (NULL_TREE,  fname,
356           tree_cons (NULL_TREE, lineno, NULL_TREE))));
357   return result;
358 }
359
360 void
361 expand_cause_exception (exp_name)
362      tree exp_name;
363 {
364   expand_expr_stmt (build_cause_exception (exp_name, 1));
365 }
366
367 /* If CONDITION is true, raise EXCEPTION (an IDENTIFIER_NODE);
368    otherwise return EXPR. */
369
370 tree
371 check_expression (expr, condition, exception)
372      tree expr, condition, exception;
373 {
374   if (integer_zerop (condition))
375     return expr;
376   else
377     return build (COMPOUND_EXPR, TREE_TYPE (expr),
378                   fold (build (TRUTH_ANDIF_EXPR, boolean_type_node,
379                                condition, build_cause_exception (exception, 0))),
380                   expr);
381 }
382
383 /* Return an expression for VALUE < LO_LIMIT || VALUE > HI_LIMIT,
384    somewhat optimized and with some warnings suppressed.
385    If LO_LIMIT or HI_LIMIT is NULL_TREE, assume that (sub-)test passes.  */
386
387 tree
388 test_range (value, lo_limit, hi_limit)
389      tree value, lo_limit, hi_limit;
390 {
391   if (lo_limit || hi_limit)
392     {
393       int old_inhibit_warnings = inhibit_warnings;
394       tree lo_check, hi_check, check;
395
396       /* This is a hack so that `shorten_compare' doesn't warn the
397          user about useless range checks that are too much work to
398          optimize away here.  */
399       inhibit_warnings = 1;
400
401       lo_check = lo_limit ? 
402         fold (build_compare_discrete_expr (LT_EXPR, value, lo_limit)) :
403           boolean_false_node;   /* fake passing the check */
404
405       hi_check = hi_limit ? 
406         fold (build_compare_discrete_expr (GT_EXPR, value, hi_limit)) :
407           boolean_false_node;   /* fake passing the check */
408
409       if (lo_check == boolean_false_node)
410         check = hi_check;
411       else if (hi_check == boolean_false_node)
412         check = lo_check;
413       else
414         check = fold (build (TRUTH_ORIF_EXPR, boolean_type_node,
415                              lo_check, hi_check));
416
417       inhibit_warnings = old_inhibit_warnings;
418       return check;
419     }
420   else
421     return boolean_false_node;
422 }
423
424 /* Return EXPR, except if range_checking is on, return an expression
425    that also checks that value >= low_limit && value <= hi_limit.
426    If LO_LIMIT or HI_LIMIT is NULL_TREE, assume that test passes.  */
427
428 tree
429 check_range (expr, value, lo_limit, hi_limit)
430      tree expr, value, lo_limit, hi_limit;
431 {
432   tree check = test_range (value, lo_limit, hi_limit);
433   if (!integer_zerop (check))
434     {
435       if (current_function_decl == NULL_TREE)
436         {
437           if (TREE_CODE (check) == INTEGER_CST)
438             error ("range failure (not inside function)");
439           else
440             warning ("possible range failure (not inside function)");
441         }
442       else
443         {
444           if (TREE_CODE (check) == INTEGER_CST)
445             warning ("expression will always cause RANGEFAIL");
446           if (range_checking)
447             expr = check_expression (expr, check,
448                                      ridpointers[(int) RID_RANGEFAIL]);
449         }
450     }
451   return expr;
452 }
453
454 /* Same as EXPR, except raise EMPTY if EXPR is NULL. */
455
456 tree
457 check_non_null (expr)
458      tree expr;
459 {
460   if (empty_checking)
461     {
462       expr = save_if_needed (expr);
463       return check_expression (expr,
464                                build_compare_expr (EQ_EXPR,
465                                                    expr, null_pointer_node),
466                                ridpointers[(int) RID_EMPTY]);
467     }
468   return expr;
469 }
470 \f
471 /*  There are four conditions to generate a runtime check:
472     1) assigning a longer INT to a shorter (signs irrelevant)
473     2) assigning a signed to an unsigned
474     3) assigning an unsigned to a signed of the same size.
475     4) TYPE is a discrete subrange  */
476
477 tree
478 chill_convert_for_assignment (type, expr, place)
479      tree type, expr;
480      const char *place; /* location description for error messages */
481 {
482   tree ttype = type;
483   tree etype = TREE_TYPE (expr);
484   tree result;
485
486   if (type == NULL_TREE || TREE_CODE (type) == ERROR_MARK)
487     return error_mark_node;
488   if (expr == NULL_TREE || TREE_CODE (expr) == ERROR_MARK)
489     return expr;
490   if (TREE_CODE (expr) == TYPE_DECL)
491     {
492       error ("right hand side of assignment is a mode");
493       return error_mark_node;
494     }
495
496   if (! CH_COMPATIBLE (expr, type))
497     {
498       error ("incompatible modes in %s", place);
499       return error_mark_node;
500     }
501
502   if (TREE_CODE (type) == REFERENCE_TYPE)
503     ttype = TREE_TYPE (ttype);
504   if (etype && TREE_CODE (etype) == REFERENCE_TYPE)
505     etype = TREE_TYPE (etype);
506
507   if (etype
508       && (CH_STRING_TYPE_P (ttype)
509           || (chill_varying_type_p (ttype)
510               && CH_STRING_TYPE_P (CH_VARYING_ARRAY_TYPE (ttype))))
511       && (CH_STRING_TYPE_P (etype)
512           || (chill_varying_type_p (etype)
513               && CH_STRING_TYPE_P (CH_VARYING_ARRAY_TYPE (etype)))))
514     {
515       tree cond;
516       if (range_checking)
517         expr = save_if_needed (expr);
518       cond = string_assignment_condition (ttype, expr);
519       if (TREE_CODE (cond) == INTEGER_CST)
520         {
521           if (integer_zerop (cond))
522             {
523               error ("bad string length in %s", place);
524               return error_mark_node;
525             }
526           /* Otherwise, the condition is always true, so no runtime test. */
527         }
528       else if (range_checking)
529         expr = check_expression (expr,
530                                  invert_truthvalue (cond),
531                                  ridpointers[(int) RID_RANGEFAIL]);
532     }
533
534   if (range_checking 
535       && discrete_type_p (ttype) 
536       && etype != NULL_TREE
537       && discrete_type_p (etype))
538     {
539       int cond1 = tree_int_cst_lt (TYPE_SIZE (ttype),
540                                    TYPE_SIZE (etype));
541       int cond2 = TREE_UNSIGNED (ttype) 
542                   && (! TREE_UNSIGNED (etype));
543       int cond3 = (! TREE_UNSIGNED (type))
544                   && TREE_UNSIGNED (etype) 
545                   && tree_int_cst_equal (TYPE_SIZE (ttype),
546                                          TYPE_SIZE (etype));
547       int cond4 = TREE_TYPE (ttype) 
548                   && discrete_type_p (TREE_TYPE (ttype));
549
550       if (cond1 || cond2 || cond3 || cond4)
551         {
552           tree type_min = TYPE_MIN_VALUE (ttype);
553           tree type_max = TYPE_MAX_VALUE (ttype);
554
555           expr = save_if_needed (expr);
556           if (expr && type_min && type_max)
557             expr = check_range (expr, expr, type_min, type_max);
558         }
559     }
560   result = convert (type, expr);
561
562   /* If the type is a array of PACK bits and the expression is an array
563      constructor, then build a CONSTRUCTOR for a bitstring.  Bitstrings are
564      zero based, so decrement the value of each CONSTRUCTOR element by the
565      amount of the lower bound of the array.  */
566   if (TREE_CODE (type) == ARRAY_TYPE && TYPE_PACKED (type)
567       && TREE_CODE (result) == CONSTRUCTOR)
568     {
569       tree domain_min = TYPE_MIN_VALUE (TYPE_DOMAIN (type));
570       tree new_list = NULL_TREE;
571       unsigned HOST_WIDE_INT index;
572       tree element;
573
574       for (element = TREE_OPERAND (result, 1);
575            element != NULL_TREE;
576            element = TREE_CHAIN (element))
577         {
578           if (!tree_int_cst_equal (TREE_VALUE (element), integer_zero_node))
579             {
580               tree purpose = TREE_PURPOSE (element);
581               switch (TREE_CODE (purpose))
582                 {
583                 case INTEGER_CST:
584                   new_list
585                     = tree_cons (NULL_TREE,
586                                  fold (build (MINUS_EXPR, TREE_TYPE (purpose),
587                                               purpose, domain_min)),
588                                  new_list);
589                   break;
590                 case RANGE_EXPR:
591                   for (index = TREE_INT_CST_LOW (TREE_OPERAND (purpose, 0));
592                        index <= TREE_INT_CST_LOW (TREE_OPERAND (purpose, 1));
593                        index++)
594                     new_list = tree_cons (NULL_TREE,
595                                           fold (build (MINUS_EXPR,
596                                                        integer_type_node,
597                                                        build_int_2 (index, 0),
598                                                        domain_min)),
599                                           new_list);
600                   break;
601                 default:
602                   abort ();
603                 }
604             }
605         }
606       result = copy_node (result);
607       TREE_OPERAND (result, 1) = nreverse (new_list);
608       TREE_TYPE (result) = build_bitstring_type (TYPE_SIZE (type));
609     }
610
611   return result;
612 }
613 \f
614 /* Check that EXPR has valid type for a RETURN or RESULT expression,
615    converting to the right type.  ACTION is "RESULT" or "RETURN". */
616
617 static tree
618 adjust_return_value (expr, action)
619      tree expr;
620      const char *action;
621 {
622   tree type = TREE_TYPE (TREE_TYPE (current_function_decl));
623
624   if (TREE_CODE (type) == REFERENCE_TYPE)
625     {
626       if (CH_LOCATION_P (expr))
627         {
628           if (! CH_READ_COMPATIBLE (TREE_TYPE (type), 
629                                     TREE_TYPE (expr)))
630             {
631               error ("mode mismatch in %s expression", action);
632               return error_mark_node;
633             }
634           return convert (type, expr);
635         }
636       else
637         {
638           error ("%s expression must be referable", action);
639           return error_mark_node;
640         }
641     }
642   else if (! CH_COMPATIBLE (expr, type))
643     {
644       error ("mode mismatch in %s expression", action);
645       return error_mark_node;
646     }
647   return convert (type, expr);
648 }
649 \f
650 void
651 chill_expand_result (expr, result_or_return)
652      tree expr;
653      int result_or_return;
654 {
655   tree type;
656   const char *action_name = result_or_return ? "RESULT" : "RETURN";
657   
658   if (pass == 1)
659     return;
660
661   if (expr == NULL_TREE || TREE_CODE (expr) == ERROR_MARK)
662     return;
663
664   CH_FUNCTION_SETS_RESULT (current_function_decl) = 1;
665
666   if (chill_at_module_level || global_bindings_p ())
667     error ("%s not allowed outside a PROC", action_name);
668
669   result_never_set = 0;
670
671   if (chill_result_decl == NULL_TREE)
672     {
673       error ("%s action in PROC with no declared RESULTS", action_name);
674       return;
675     }
676   type = TREE_TYPE (chill_result_decl);
677
678   if (TREE_CODE (type) == ERROR_MARK)
679     return;
680
681   expr = adjust_return_value (expr, action_name);
682
683   expand_expr_stmt (build_chill_modify_expr (chill_result_decl, expr));
684 }
685 \f
686 /*
687  * error if EXPR not NULL and procedure doesn't
688  * have a return type; 
689  * warning if EXPR NULL,
690  * procedure *has* a return type, and a previous
691  * RESULT actions hasn't saved a return value.
692  */
693 void
694 chill_expand_return (expr, implicit)
695      tree expr;
696      int implicit; /* 1 if an implicit return at end of function. */
697 {
698   tree valtype;
699
700   if (expr != NULL_TREE && TREE_CODE (expr) == ERROR_MARK)
701     return;
702   if (chill_at_module_level || global_bindings_p ())
703     {
704       error ("RETURN not allowed outside PROC");
705       return;
706     }
707
708   if (pass == 1)
709     return;
710
711   result_never_set = 0;
712
713   valtype = TREE_TYPE (TREE_TYPE (current_function_decl));
714   if (TREE_CODE (valtype) == VOID_TYPE)
715     {
716       if (expr != NULL_TREE)
717         error ("RETURN with a value, in PROC returning void");
718       expand_null_return ();
719     }
720   else if (TREE_CODE (valtype) != ERROR_MARK)
721     {
722       if (expr == NULL_TREE)
723         {
724           if (!CH_FUNCTION_SETS_RESULT (current_function_decl)
725               && !implicit)
726             warning ("RETURN with no value and no RESULT action in procedure");
727           expr = chill_result_decl;
728         }
729       else
730         expr = adjust_return_value (expr, "RETURN");
731       expr = build (MODIFY_EXPR, valtype,
732                     DECL_RESULT (current_function_decl),
733                     expr);
734       TREE_SIDE_EFFECTS (expr) = 1;
735       expand_return (expr);
736     }
737 }
738
739 void
740 lookup_and_expand_goto (name)
741      tree name;
742 {
743   if (name == NULL_TREE ||  TREE_CODE (name) == ERROR_MARK)
744     return;
745   if (!ignoring)
746     {
747       tree decl = lookup_name (name);
748       if (decl == NULL || TREE_CODE (decl) != LABEL_DECL)
749         error ("no label named `%s'", IDENTIFIER_POINTER (name));
750       else if (DECL_CONTEXT (decl) != current_function_decl)
751         error ("cannot GOTO label `%s' outside current function",
752                IDENTIFIER_POINTER (name));
753       else
754         {
755           TREE_USED (decl) = 1;
756           expand_goto_except_cleanup (DECL_ACTION_NESTING_LEVEL (decl));
757           expand_goto (decl);
758         }
759     }
760 }
761
762 void
763 lookup_and_handle_exit (name)
764      tree name;
765 {
766   if (name == NULL_TREE ||  TREE_CODE (name) == ERROR_MARK)
767     return;
768   if (!ignoring)
769     {
770       tree label = munge_exit_label (name);
771       tree decl = lookup_name (label);
772       if (decl == NULL || TREE_CODE (decl) != LABEL_DECL)
773         error ("no EXITable label named `%s'", IDENTIFIER_POINTER (name));
774       else if (DECL_CONTEXT (decl) != current_function_decl)
775         error ("cannot EXIT label `%s' outside current function",
776                IDENTIFIER_POINTER (name));
777       else
778         {
779           TREE_USED (decl) = 1;
780           expand_goto_except_cleanup (DECL_ACTION_NESTING_LEVEL (decl));
781           expand_goto (decl);
782         }
783     }
784 }
785 \f
786 /* ELSE-range handling: The else-range is a chain of trees which collectively
787    represent the ranges to be tested for the (ELSE) case label. Each element in
788    the chain represents a range to be tested. The boundaries of the range are
789    represented by INTEGER_CST trees in the PURPOSE and VALUE fields. */
790
791 /* This function updates the else-range by removing the given integer constant. */
792 static tree
793 update_else_range_for_int_const (else_range, label)
794      tree else_range, label;
795 {
796   int  lowval = 0, highval = 0;
797   int  label_value = TREE_INT_CST_LOW (label);
798   tree this_range, prev_range, new_range;
799
800   /* First, find the range element containing the integer, if it exists. */
801   prev_range = NULL_TREE;
802   for (this_range = else_range ;
803        this_range != NULL_TREE;
804        this_range = TREE_CHAIN (this_range))
805     {
806       lowval  = TREE_INT_CST_LOW (TREE_PURPOSE (this_range));
807       highval = TREE_INT_CST_LOW (TREE_VALUE (this_range));
808       if (label_value >= lowval && label_value <= highval)
809         break;
810       prev_range = this_range;
811     }
812
813   /* If a range element containing the integer was found, then update the range. */
814   if (this_range != NULL_TREE)
815     {
816       tree next = TREE_CHAIN (this_range);
817       if (label_value == lowval)
818         {
819           /* The integer is the lower bound of the range element. If it is also the
820              upper bound, then remove this range element, otherwise update it. */
821           if (label_value == highval)
822             {
823               if (prev_range == NULL_TREE)
824                 else_range = next;
825               else
826                 TREE_CHAIN (prev_range) = next;
827             }
828           else
829             TREE_PURPOSE (this_range) = build_int_2 (label_value + 1, 0);
830         }
831       else if (label_value == highval)
832         {
833           /* The integer is the upper bound of the range element, so ajust it. */
834           TREE_VALUE (this_range) = build_int_2 (label_value - 1, 0);
835         }
836       else
837         {
838           /* The integer is in the middle of the range element, so split it. */
839           new_range = tree_cons (
840             build_int_2 (label_value + 1, 0), TREE_VALUE (this_range), next);
841           TREE_VALUE (this_range) = build_int_2 (label_value - 1, 0);
842           TREE_CHAIN (this_range) = new_range;
843         }
844     }
845   return else_range;
846 }
847
848 /* Update the else-range to remove a range of values/ */
849 static tree
850 update_else_range_for_range (else_range, low_target, high_target)
851      tree else_range, low_target, high_target;
852 {
853   tree this_range, prev_range, new_range, next_range;
854   int  low_range_val = 0, high_range_val = 0;
855   int  low_target_val  = TREE_INT_CST_LOW (low_target);
856   int  high_target_val = TREE_INT_CST_LOW (high_target);
857
858   /* find the first else-range element which overlaps the target range. */
859   prev_range = NULL_TREE;
860   for (this_range = else_range ;
861        this_range != NULL_TREE;
862        this_range = TREE_CHAIN (this_range))
863     {
864       low_range_val  = TREE_INT_CST_LOW (TREE_PURPOSE (this_range));
865       high_range_val = TREE_INT_CST_LOW (TREE_VALUE (this_range));
866       if ((low_target_val >= low_range_val && low_target_val <= high_range_val)
867           || (high_target_val >= low_range_val && high_target_val <= high_range_val))
868         break;
869       prev_range = this_range;
870     }
871   if (this_range == NULL_TREE)
872     return else_range;
873
874   /* This first else-range element might be truncated at the top or completely
875      contain the target range. */
876   if (low_range_val < low_target_val)
877     {
878       next_range = TREE_CHAIN (this_range);
879       if (high_range_val > high_target_val)
880         {
881           new_range = tree_cons (
882             build_int_2 (high_target_val + 1, 0), TREE_VALUE (this_range), next_range);
883           TREE_VALUE (this_range) = build_int_2 (low_target_val - 1, 0);
884           TREE_CHAIN (this_range) = new_range;
885           return else_range;
886         }
887
888       TREE_VALUE (this_range) = build_int_2 (low_target_val - 1, 0);
889       if (next_range == NULL_TREE)
890         return else_range;
891
892       prev_range = this_range;
893       this_range = next_range;
894       high_range_val = TREE_INT_CST_LOW (TREE_VALUE (this_range));
895     }
896
897   /* There may then follow zero or more else-range elements which are completely
898      contained in the target range. */
899   while (high_range_val <= high_target_val)
900     {
901       this_range = TREE_CHAIN (this_range);
902       if (prev_range == NULL_TREE)
903         else_range = this_range;
904       else
905         TREE_CHAIN (prev_range) = this_range;
906
907       if (this_range == NULL_TREE)
908         return else_range;
909       high_range_val = TREE_INT_CST_LOW (TREE_VALUE (this_range));
910     }
911
912   /* Finally, there may be a else-range element which is truncated at the bottom. */
913   low_range_val = TREE_INT_CST_LOW (TREE_PURPOSE (this_range));
914   if (low_range_val <= high_target_val)
915     TREE_PURPOSE (this_range) = build_int_2 (high_target_val + 1, 0);
916
917   return else_range;
918 }
919
920 static tree
921 update_else_range_for_range_expr (else_range, label)
922      tree else_range, label;
923 {
924   if (TREE_OPERAND (label, 0) == NULL_TREE)
925     {
926       if (TREE_OPERAND (label, 1) == NULL_TREE)
927         else_range = NULL_TREE; /* (*) -- matches everything */
928     }
929   else
930     else_range = update_else_range_for_range (
931       else_range, TREE_OPERAND (label, 0), TREE_OPERAND (label, 1));
932
933   return else_range;
934 }
935
936 static tree
937 update_else_range_for_type (else_range, label)
938      tree else_range, label;
939 {
940   tree type = TREE_TYPE (label);
941   else_range = update_else_range_for_range (
942     else_range, TYPE_MIN_VALUE (type), TYPE_MAX_VALUE (type));
943   return else_range;
944 }
945
946 static tree
947 compute_else_range (selector, alternatives, selector_no)
948      tree selector, alternatives;
949      int selector_no;
950 {
951   /* Start with an else-range that spans the entire range of the selector type. */
952   tree type = TREE_TYPE (TREE_VALUE (selector));
953   tree range = tree_cons (TYPE_MIN_VALUE (type), TYPE_MAX_VALUE (type), NULL_TREE);
954
955   /* Now remove the values represented by each case lebel specified for that
956      selector. The remaining range is the else-range. */
957   for ( ; alternatives != NULL_TREE; alternatives = TREE_CHAIN (alternatives))
958     {
959       tree label;
960       tree label_list = TREE_PURPOSE (alternatives);
961       int  this_selector;
962       for (this_selector = 0; this_selector < selector_no ; ++this_selector)
963         label_list = TREE_CHAIN (label_list);
964
965       for (label = TREE_VALUE (label_list);
966            label != NULL_TREE;
967            label = TREE_CHAIN (label))
968         {
969           tree label_value = TREE_VALUE (label);
970           if (TREE_CODE (label_value) == INTEGER_CST)
971             range = update_else_range_for_int_const (range, label_value);
972           else if (TREE_CODE (label_value) == RANGE_EXPR)
973             range = update_else_range_for_range_expr (range, label_value);
974           else if (TREE_CODE (label_value) == TYPE_DECL)
975             range = update_else_range_for_type (range, label_value);
976
977           if (range == NULL_TREE)
978             break;
979         }
980     }
981
982   return range;
983 }
984
985 void
986 compute_else_ranges (selectors, alternatives)
987      tree selectors, alternatives;
988 {
989   tree selector;
990   int selector_no = 0;
991
992   for (selector = selectors; selector != NULL_TREE; selector = TREE_CHAIN (selector))
993     {
994       if (ELSE_LABEL_SPECIFIED (selector))
995         TREE_PURPOSE (selector) =
996           compute_else_range (selector, alternatives, selector_no);
997       selector_no++;
998     }
999 }
1000
1001 static tree
1002 check_case_value (label_value, selector)
1003      tree label_value, selector;
1004 {
1005   if (TREE_CODE (label_value) == ERROR_MARK)
1006     return label_value;
1007   if (TREE_CODE (selector) == ERROR_MARK)
1008     return selector;    
1009
1010   /* Z.200 (6.4 Case action) says:  "The class of any discrete expression
1011      in the case selector list must be compatible with the corresponding
1012      (by position) class of the resulting list of classes of the case label
1013      list occurrences ...".  We don't actually construct the resulting
1014      list of classes, but this test should be more-or-less equivalent.
1015      I think... */
1016   if (!CH_COMPATIBLE_CLASSES (selector, label_value))
1017     {
1018       error ("case selector not compatible with label");
1019       return error_mark_node;
1020     }
1021
1022   /* Strip NON_LVALUE_EXPRs since we aren't using as an lvalue.  */
1023   STRIP_TYPE_NOPS (label_value);
1024
1025   if (TREE_CODE (label_value) != INTEGER_CST)
1026     {
1027       error ("case label does not reduce to an integer constant");
1028       return error_mark_node;
1029     }
1030
1031   constant_expression_warning (label_value);
1032   return label_value;
1033 }
1034
1035 void
1036 chill_handle_case_default ()
1037 {
1038   tree duplicate;
1039   register tree label = build_decl (LABEL_DECL, NULL_TREE, 
1040                                     NULL_TREE);
1041   int success = pushcase (NULL_TREE, 0, label, &duplicate);
1042
1043   if (success == 1)
1044     error ("ELSE label not within a CASE statement");
1045 #if 0
1046   else if (success == 2)
1047     {
1048       error ("multiple default labels found in a CASE statement"); 
1049       error_with_decl (duplicate, "this is the first ELSE label");
1050     }
1051 #endif
1052 }
1053 \f
1054 /* Handle cases label such as (I:J):  or (modename): */
1055
1056 static void
1057 chill_handle_case_label_range (min_value, max_value, selector)
1058      tree min_value, max_value, selector;
1059 {
1060   register tree label = build_decl (LABEL_DECL, NULL_TREE, NULL_TREE);
1061   min_value = check_case_value (min_value, selector);
1062   max_value = check_case_value (max_value, selector);
1063   if (TREE_CODE (min_value) != ERROR_MARK
1064       && TREE_CODE (max_value) != ERROR_MARK)
1065     {
1066       tree duplicate;
1067       int success = pushcase_range (min_value, max_value,
1068                                     convert, label, &duplicate);
1069       if (success == 1)
1070         error ("label found outside of CASE statement");
1071       else if (success == 2)
1072         {
1073           error ("duplicate CASE value");
1074           error_with_decl (duplicate, "this is the first entry for that value");
1075         }
1076       else if (success == 3)
1077         error ("CASE value out of range");
1078       else if (success == 4)
1079         error ("empty range");
1080       else if (success == 5)
1081         error ("label within scope of cleanup or variable array");
1082     }
1083 }
1084
1085 void
1086 chill_handle_case_label (label_value, selector)
1087      tree label_value, selector;
1088 {
1089   if (label_value == NULL_TREE 
1090       || TREE_CODE (label_value) == ERROR_MARK)
1091     return;
1092   if (TREE_CODE (label_value) == RANGE_EXPR)
1093     {
1094       if (TREE_OPERAND (label_value, 0) == NULL_TREE)
1095         chill_handle_case_default ();  /* i.e. (ELSE): or (*): */
1096       else
1097         chill_handle_case_label_range (TREE_OPERAND (label_value, 0),
1098                                        TREE_OPERAND (label_value, 1),
1099                                        selector);
1100     }
1101   else if (TREE_CODE (label_value) == TYPE_DECL)
1102     {
1103       tree type = TREE_TYPE (label_value);
1104       if (! discrete_type_p (type))
1105         error ("mode in label is not discrete");
1106       else
1107         chill_handle_case_label_range (TYPE_MIN_VALUE (type),
1108                                        TYPE_MAX_VALUE (type),
1109                                        selector);
1110     }
1111   else
1112     {
1113       register tree label = build_decl (LABEL_DECL, NULL_TREE, NULL_TREE);
1114
1115       label_value = check_case_value (label_value, selector);
1116
1117       if (TREE_CODE (label_value) != ERROR_MARK)
1118         {
1119           tree duplicate;
1120           int success = pushcase (label_value, convert, label, &duplicate);
1121           if (success == 1)
1122             error ("label not within a CASE statement");
1123           else if (success == 2)
1124             {
1125               error ("duplicate case value");
1126               error_with_decl (duplicate, 
1127                                "this is the first entry for that value");
1128             }
1129           else if (success == 3)
1130             error ("CASE value out of range");
1131           else if (success == 4)
1132             error ("empty range");
1133           else if (success == 5)
1134             error ("label within scope of cleanup or variable array");
1135         }
1136     }
1137 }
1138
1139 int
1140 chill_handle_single_dimension_case_label (
1141   selector, label_spec, expand_exit_needed, caseaction_flag
1142 )
1143   tree selector, label_spec;
1144   int *expand_exit_needed, *caseaction_flag;
1145 {
1146   tree labels, one_label;
1147   int  no_completeness_check = 0;
1148
1149   if (*expand_exit_needed || *caseaction_flag == 1)
1150     {
1151       expand_exit_something ();
1152       *expand_exit_needed = 0;
1153     }
1154
1155   for (labels = label_spec; labels != NULL_TREE; labels = TREE_CHAIN (labels))
1156     for (one_label = TREE_VALUE (labels); one_label != NULL_TREE;
1157          one_label = TREE_CHAIN (one_label))
1158       {
1159         if (TREE_VALUE (one_label) == case_else_node)
1160           no_completeness_check = 1;
1161
1162         chill_handle_case_label (TREE_VALUE (one_label), selector);
1163       }
1164
1165   *caseaction_flag = 1;
1166
1167   return no_completeness_check;
1168 }
1169
1170 static tree
1171 chill_handle_multi_case_label_range (low, high, selector)
1172   tree low, high, selector;
1173 {
1174   tree low_expr, high_expr, and_expr;
1175   tree selector_type;
1176   int  low_target_val, high_target_val;
1177   int  low_type_val, high_type_val;
1178
1179   /* we can eliminate some tests is the low and/or high value in the given range
1180      are outside the range of the selector type. */
1181   low_target_val  = TREE_INT_CST_LOW (low);
1182   high_target_val = TREE_INT_CST_LOW (high);
1183   selector_type   = TREE_TYPE (selector);
1184   low_type_val    = TREE_INT_CST_LOW (TYPE_MIN_VALUE (selector_type));
1185   high_type_val   = TREE_INT_CST_LOW (TYPE_MAX_VALUE (selector_type));
1186
1187   if (low_target_val > high_type_val || high_target_val < low_type_val)
1188     return boolean_false_node; /* selector never in range */
1189
1190   if (low_type_val >= low_target_val)
1191     {
1192       if (high_type_val <= high_target_val)
1193         return boolean_true_node; /* always in the range */
1194       return build_compare_expr (LE_EXPR, selector, high);
1195     }
1196
1197   if (high_type_val <= high_target_val)
1198     return build_compare_expr (GE_EXPR, selector, low);
1199
1200   /* The target range in completely within the range of the selector, but we
1201      might be able to save a test if the upper bound is the same as the lower
1202      bound. */
1203   if (low_target_val == high_target_val)
1204     return build_compare_expr (EQ_EXPR, selector, low);
1205
1206   /* No optimizations possible. Just generate tests against the upper and lower
1207      bound of the target */
1208   low_expr  = build_compare_expr (GE_EXPR, selector, low);
1209   high_expr = build_compare_expr (LE_EXPR, selector, high);
1210   and_expr  = build_chill_binary_op (TRUTH_ANDIF_EXPR, low_expr, high_expr);
1211
1212   return and_expr;
1213 }
1214
1215 static tree
1216 chill_handle_multi_case_else_label (selector)
1217      tree selector;
1218 {
1219   tree else_range, selector_value, selector_type;
1220   tree low, high, larg;
1221
1222   else_range = TREE_PURPOSE (selector);
1223   if (else_range == NULL_TREE)
1224     return boolean_false_node; /* no values in ELSE range */
1225
1226   /* Test each of the ranges in the else-range chain */
1227   selector_value = TREE_VALUE (selector);
1228   selector_type  = TREE_TYPE (selector_value);
1229   low  = convert (selector_type, TREE_PURPOSE (else_range));
1230   high = convert (selector_type, TREE_VALUE (else_range));
1231   larg = chill_handle_multi_case_label_range (low, high, selector_value);
1232
1233   for (else_range = TREE_CHAIN (else_range);
1234        else_range != NULL_TREE;
1235        else_range = TREE_CHAIN (else_range))
1236     {
1237       tree rarg;
1238       low  = convert (selector_type, TREE_PURPOSE (else_range));
1239       high = convert (selector_type, TREE_VALUE (else_range));
1240       rarg = chill_handle_multi_case_label_range (low, high, selector_value);
1241       larg = build_chill_binary_op (TRUTH_ORIF_EXPR, larg, rarg);
1242     }
1243
1244   return larg;
1245 }
1246
1247 static tree
1248 chill_handle_multi_case_label (selector, label)
1249   tree selector, label;
1250 {
1251   tree expr = NULL_TREE;
1252
1253   if (label == NULL_TREE || TREE_CODE (label) == ERROR_MARK)
1254     return NULL_TREE;
1255
1256   if (TREE_CODE (label) == INTEGER_CST)
1257     {
1258       int  target_val = TREE_INT_CST_LOW (label);
1259       tree selector_type = TREE_TYPE (TREE_VALUE (selector));
1260       int  low_type_val  = TREE_INT_CST_LOW (TYPE_MIN_VALUE (selector_type));
1261       int  high_type_val = TREE_INT_CST_LOW (TYPE_MAX_VALUE (selector_type));
1262       if (target_val < low_type_val || target_val > high_type_val)
1263         expr = boolean_false_node;
1264       else
1265         expr = build_compare_expr (EQ_EXPR, TREE_VALUE (selector), label);
1266     }
1267   else if (TREE_CODE (label) == RANGE_EXPR)
1268     {
1269       if (TREE_OPERAND (label, 0) == NULL_TREE)
1270         {
1271           if (TREE_OPERAND (label, 1) == NULL_TREE)
1272             expr = boolean_true_node; /* (*) -- matches everything */
1273           else
1274             expr = chill_handle_multi_case_else_label (selector);
1275         }
1276       else
1277         {
1278           tree low = TREE_OPERAND (label, 0);
1279           tree high = TREE_OPERAND (label, 1);
1280           if (TREE_CODE (low) != INTEGER_CST)
1281             {
1282               error ("lower bound of range must be a discrete literal expression");
1283               expr = error_mark_node;
1284             }
1285           if (TREE_CODE (high) != INTEGER_CST)
1286             {
1287               error ("upper bound of range must be a discrete literal expression");
1288               expr = error_mark_node;
1289             }
1290           if (expr != error_mark_node)
1291             {
1292               expr = chill_handle_multi_case_label_range (
1293                        low, high, TREE_VALUE (selector));
1294             }
1295         }
1296     }
1297   else if (TREE_CODE (label) == TYPE_DECL)
1298     {
1299       tree type = TREE_TYPE (label);
1300       if (! discrete_type_p (type))
1301         {
1302           error ("mode in label is not discrete");
1303           expr = error_mark_node;
1304         }
1305       else
1306         expr = chill_handle_multi_case_label_range (
1307                  TYPE_MIN_VALUE (type), TYPE_MAX_VALUE (type), TREE_VALUE (selector));
1308     }
1309   else
1310     {
1311       error ("CASE label is not valid");
1312       expr = error_mark_node;
1313     }
1314
1315   return expr;
1316 }
1317
1318 static tree
1319 chill_handle_multi_case_label_list (selector, labels)
1320   tree selector, labels;
1321 {
1322   tree one_label, larg, rarg;
1323
1324   one_label = TREE_VALUE (labels);
1325   larg = chill_handle_multi_case_label (selector, TREE_VALUE (one_label));
1326
1327   for (one_label = TREE_CHAIN (one_label);
1328        one_label != NULL_TREE;
1329        one_label = TREE_CHAIN (one_label))
1330     {
1331       rarg = chill_handle_multi_case_label (selector, TREE_VALUE (one_label));
1332       larg = build_chill_binary_op (TRUTH_ORIF_EXPR, larg, rarg);
1333     }
1334
1335   return larg;
1336 }
1337
1338 tree
1339 build_multi_case_selector_expression (selector_list, label_spec)
1340   tree selector_list, label_spec;
1341 {
1342   tree labels, selector, larg, rarg;
1343
1344   labels   = label_spec;
1345   selector = selector_list;
1346   larg = chill_handle_multi_case_label_list(selector, labels);
1347
1348   for (labels = TREE_CHAIN (labels), selector = TREE_CHAIN (selector);
1349        labels != NULL_TREE && selector != NULL_TREE;
1350        labels = TREE_CHAIN (labels), selector = TREE_CHAIN (selector))
1351     {
1352       rarg = chill_handle_multi_case_label_list(selector, labels);
1353       larg = build_chill_binary_op (TRUTH_ANDIF_EXPR, larg, rarg);
1354     }
1355
1356   if (labels != NULL_TREE || selector != NULL_TREE)
1357     error ("number of CASE selectors does not match the number of CASE label lists");
1358
1359   return larg;
1360 }
1361
1362 #define BITARRAY_TEST(ARRAY, INDEX) \
1363   ((ARRAY)[(unsigned)(INDEX) / HOST_BITS_PER_CHAR]\
1364                           & (1 << ((unsigned)(INDEX) % HOST_BITS_PER_CHAR)))
1365 #define BITARRAY_SET(ARRAY, INDEX) \
1366   ((ARRAY)[(unsigned)(INDEX) / HOST_BITS_PER_CHAR]\
1367                           |= 1 << ((unsigned)(INDEX) % HOST_BITS_PER_CHAR))
1368
1369 /* CASES_SEEN is a set (bitarray) of length COUNT.
1370    For each element that is zero, print an error message,
1371    assume the element have the given TYPE. */
1372
1373 static void
1374 print_missing_cases (type, cases_seen, count)
1375      tree type;
1376      const unsigned char *cases_seen;
1377      long count;
1378 {
1379   long i;
1380   for (i = 0;  i < count; i++)
1381     {
1382       if (BITARRAY_TEST(cases_seen, i) == 0)
1383         {
1384           char buf[20];
1385           long x = i;
1386           long j;
1387           tree t = type;
1388           const char *err_val_name = "???";
1389           if (TYPE_MIN_VALUE (t)
1390               && TREE_CODE (TYPE_MIN_VALUE (t)) == INTEGER_CST)
1391             x += TREE_INT_CST_LOW (TYPE_MIN_VALUE (t));
1392           while (TREE_TYPE (t) != NULL_TREE)
1393             t = TREE_TYPE (t);
1394           switch (TREE_CODE (t))
1395             {
1396               tree v;
1397             case BOOLEAN_TYPE:
1398               err_val_name = x ? "TRUE" : "FALSE";
1399               break;
1400             case CHAR_TYPE:
1401               {
1402                 char *bufptr;
1403                 if ((x >= ' ' && x < 127) && x != '\'' && x != '^')
1404                   sprintf (buf, "'%c'", (char)x);
1405                 else
1406                   sprintf (buf, "'^(%ld)'", x);
1407                 bufptr = buf;
1408                 j = i;
1409                 while (j < count && !BITARRAY_TEST(cases_seen, j))
1410                   j++;
1411                 if (j > i + 1)
1412                   {
1413                     long y = x+j-i-1;
1414                     bufptr += strlen (bufptr);
1415                     if ((y >= ' ' && y < 127) && y != '\'' && y != '^')
1416                       sprintf (bufptr, "%s:'%c'", buf, (char)y);
1417                     else
1418                       sprintf (bufptr, "%s:'^(%ld)'", buf, y);
1419                     i = j - 1;      
1420                   }
1421                 err_val_name = bufptr;
1422               }
1423               break;
1424             case ENUMERAL_TYPE:
1425               for (v = TYPE_VALUES (t);  v && x;  v = TREE_CHAIN (v))
1426                 x--;
1427               if (v)
1428                 err_val_name = IDENTIFIER_POINTER (TREE_PURPOSE (v));
1429               break;
1430             default:
1431               j = i;
1432               while (j < count && !BITARRAY_TEST(cases_seen, j))
1433                 j++;
1434               if (j == i + 1)
1435                 sprintf (buf, "%ld", x);
1436               else
1437                 sprintf (buf, "%ld:%ld", x, x+j-i-1);
1438               i = j - 1;      
1439               err_val_name = buf;
1440               break;
1441             }
1442           error ("incomplete CASE - %s not handled", err_val_name);
1443         }
1444     }
1445 }
1446
1447 void
1448 check_missing_cases (type)
1449      tree type;
1450 {
1451   int is_sparse;
1452   /* For each possible selector value. a one iff it has been matched
1453      by a case value alternative. */
1454   unsigned char *cases_seen;
1455   /* The number of possible selector values. */
1456   HOST_WIDE_INT size = all_cases_count (type, &is_sparse);
1457   HOST_WIDE_INT bytes_needed
1458     = (size + HOST_BITS_PER_CHAR) / HOST_BITS_PER_CHAR;
1459
1460   if (size == -1)
1461     warning ("CASE selector with variable range");
1462   else if (size < 0 || size > 600000
1463            /* We deliberately use malloc here - not xmalloc. */
1464            || (cases_seen = (char*) malloc (bytes_needed)) == NULL)
1465     warning ("too many cases to do CASE completeness testing");
1466   else
1467     {
1468       memset (cases_seen, 0, bytes_needed);
1469       mark_seen_cases (type, cases_seen, size, is_sparse);
1470       print_missing_cases (type, cases_seen, size);
1471       free (cases_seen);
1472     }
1473 }
1474
1475 /*
1476  * We build an expression tree here because, in many contexts,
1477  * we don't know the type of result that's desired.  By the
1478  * time we get to expanding the tree, we do know.
1479  */
1480 tree
1481 build_chill_case_expr (exprlist, casealtlist_expr,
1482                        optelsecase_expr)
1483      tree exprlist, casealtlist_expr, optelsecase_expr;
1484 {
1485   return build (CASE_EXPR, NULL_TREE, exprlist,
1486                 optelsecase_expr ?
1487                   tree_cons (NULL_TREE,
1488                              optelsecase_expr,
1489                              casealtlist_expr) :
1490                   casealtlist_expr);
1491 }
1492
1493 /* This function transforms the selector_list and alternatives into a COND_EXPR. */
1494 tree
1495 build_chill_multi_dimension_case_expr (selector_list, alternatives, else_expr)
1496   tree selector_list, alternatives, else_expr;
1497 {
1498   tree expr;
1499
1500   selector_list = check_case_selector_list (selector_list);
1501
1502   if (alternatives == NULL_TREE)
1503     return NULL_TREE;
1504
1505   alternatives = nreverse (alternatives);
1506   /* alternatives represents the CASE label specifications and resulting values in
1507      the reverse order in which they appeared.
1508      If there is an ELSE expression, then use it. If there is no
1509      ELSE expression, make the last alternative (which is the first in the list)
1510      into the ELSE expression. This is safe because, if the CASE is complete
1511      (as required), then the last condition need not be checked anyway. */
1512   if (else_expr != NULL_TREE)
1513     expr = else_expr;
1514   else
1515     {
1516       expr = TREE_VALUE (alternatives);
1517       alternatives = TREE_CHAIN (alternatives);
1518     }
1519
1520   for ( ; alternatives != NULL_TREE; alternatives = TREE_CHAIN (alternatives))
1521     { 
1522       tree value  = TREE_VALUE (alternatives);
1523       tree labels = TREE_PURPOSE (alternatives);
1524       tree cond   = build_multi_case_selector_expression(selector_list, labels);
1525       expr = build_nt (COND_EXPR, cond, value, expr);
1526     }
1527
1528   return expr;
1529 }
1530
1531 \f
1532 /* This is called with the assumption that RHS has been stabilized.  
1533    It has one purpose:  to iterate through the CHILL list of LHS's */
1534 void
1535 expand_assignment_action (loclist, modifycode, rhs)
1536      tree loclist;
1537      enum chill_tree_code modifycode;
1538      tree rhs;
1539 {
1540   if (loclist == NULL_TREE || TREE_CODE (loclist) == ERROR_MARK
1541       || rhs == NULL_TREE  || TREE_CODE (rhs) == ERROR_MARK)
1542     return;
1543
1544   if (TREE_CHAIN (loclist) != NULL_TREE)
1545     { /* Multiple assignment */
1546       tree target;
1547       if (TREE_TYPE (rhs) != NULL_TREE)
1548         rhs = save_expr (rhs);
1549       else if (TREE_CODE (rhs) == CONSTRUCTOR)
1550         error ("type of tuple cannot be implicit in multiple assignent");
1551       else if (TREE_CODE (rhs) == CASE_EXPR || TREE_CODE (rhs) == COND_EXPR)
1552         error ("conditional expression cannot be used in multiple assignent");
1553       else
1554         error ("internal error - unknown type in multiple assignment");
1555
1556       if (modifycode != NOP_EXPR)
1557         {
1558           error ("no operator allowed in multiple assignment,");
1559           modifycode = NOP_EXPR;
1560         }
1561
1562       for (target = TREE_CHAIN (loclist); target; target = TREE_CHAIN (target))
1563         {
1564           if (!CH_EQUIVALENT (TREE_TYPE (TREE_VALUE (target)),
1565                               TREE_TYPE (TREE_VALUE (loclist))))
1566             {
1567               error
1568                 ("location modes in multiple assignment are not equivalent");
1569               break;
1570             }
1571         }
1572     }
1573   for ( ; loclist != NULL_TREE; loclist = TREE_CHAIN (loclist))
1574     chill_expand_assignment (TREE_VALUE (loclist), modifycode, rhs);
1575 }
1576
1577 void
1578 chill_expand_assignment (lhs, modifycode, rhs)
1579      tree lhs;
1580      enum chill_tree_code modifycode;
1581      tree rhs;
1582 {
1583   tree loc;
1584
1585   while (TREE_CODE (lhs) == COMPOUND_EXPR)
1586     {
1587       expand_expr (TREE_OPERAND (lhs, 0), const0_rtx, VOIDmode, 0);
1588       emit_queue ();
1589       lhs = TREE_OPERAND (lhs, 1);
1590     }
1591
1592   if (TREE_CODE (lhs) == ERROR_MARK)
1593     return;
1594
1595   /* errors for assignment to BUFFER, EVENT locations.
1596      what about SIGNALs? FIXME: Need similar test in
1597      build_chill_function_call. */
1598   if (TREE_CODE (lhs) == IDENTIFIER_NODE)
1599     {
1600       tree decl = lookup_name (lhs);
1601       if (decl)
1602         {
1603           tree type = TREE_TYPE (decl);
1604           if (CH_IS_BUFFER_MODE (type) || CH_IS_EVENT_MODE (type))
1605             {
1606               error ("you may not assign a value to a BUFFER or EVENT location");
1607               return;
1608             }
1609         }
1610     }
1611
1612   if (TYPE_READONLY_PROPERTY (TREE_TYPE (lhs)) || TREE_READONLY (lhs))
1613     {
1614       error ("can't assign value to READonly location");
1615       return;
1616     }
1617   if (CH_TYPE_NONVALUE_P (TREE_TYPE (lhs)))
1618     {
1619       error ("cannot assign to location with non-value property");
1620       return;
1621     }
1622
1623   if (TREE_CODE (TREE_TYPE (lhs)) == REFERENCE_TYPE)
1624     lhs = convert_from_reference (lhs);
1625
1626   /* check for lhs is a location */
1627   loc = lhs;
1628   while (1)
1629     {
1630       if (TREE_CODE (loc) == SLICE_EXPR)
1631         loc = TREE_OPERAND (loc, 0);
1632       else if (TREE_CODE (loc) == SET_IN_EXPR)
1633         loc = TREE_OPERAND (loc, 1);
1634       else
1635         break;
1636     }
1637   if (! CH_LOCATION_P (loc))
1638     {
1639       error ("lefthand side of assignment is not a location");
1640       return;
1641     }
1642
1643   /* If a binary op has been requested, combine the old LHS value with
1644      the RHS producing the value we should actually store into the LHS. */
1645
1646   if (modifycode != NOP_EXPR)
1647     {
1648       lhs = stabilize_reference (lhs);
1649       /* This is to handle border-line cases such
1650          as: LHS OR := [I].  This seems to be permitted
1651          by the letter of Z.200, though it violates
1652          its spirit, since LHS:=LHS OR [I] is
1653          *not* legal. */
1654       if (TREE_TYPE (rhs) == NULL_TREE)
1655         rhs = convert (TREE_TYPE (lhs), rhs);
1656       rhs = build_chill_binary_op (modifycode, lhs, rhs);
1657     }
1658
1659   rhs = chill_convert_for_assignment (TREE_TYPE (lhs), rhs, "assignment");
1660
1661   /* handle the LENGTH (vary_array) := expr action */
1662   loc = lhs;
1663   if (TREE_CODE (loc) == NOP_EXPR)
1664     loc = TREE_OPERAND (loc, 0);
1665   if (TREE_CODE (loc) == COMPONENT_REF
1666       && chill_varying_type_p (TREE_TYPE (TREE_OPERAND (loc, 0)))
1667       && DECL_NAME (TREE_OPERAND (loc, 1)) == var_length_id)
1668     {
1669       expand_varying_length_assignment (TREE_OPERAND (loc, 0), rhs);
1670     }
1671   else if (TREE_CODE (lhs) == SLICE_EXPR)
1672     {
1673       tree func = lookup_name (get_identifier ("__pscpy"));
1674       tree dst = TREE_OPERAND (lhs, 0);
1675       tree dst_offset = TREE_OPERAND (lhs, 1);
1676       tree length = TREE_OPERAND (lhs, 2);
1677       tree src, src_offset;
1678       if (TREE_CODE (rhs) == SLICE_EXPR)
1679         {
1680           src = TREE_OPERAND (rhs, 0);
1681           /* Should check that the TREE_OPERAND (src, 0) is
1682              the same as length and powerserlen (src).  FIXME */
1683           src_offset = TREE_OPERAND (rhs, 1);
1684         }
1685       else
1686         {
1687           src = rhs;
1688           src_offset = integer_zero_node;
1689         }
1690       expand_expr_stmt (build_chill_function_call (func,
1691         tree_cons (NULL_TREE, force_addr_of (dst),
1692           tree_cons (NULL_TREE, powersetlen (dst),
1693             tree_cons (NULL_TREE, convert (long_unsigned_type_node, dst_offset),
1694               tree_cons (NULL_TREE, force_addr_of (src),
1695                 tree_cons (NULL_TREE, powersetlen (src),
1696                   tree_cons (NULL_TREE, convert (long_unsigned_type_node, src_offset),
1697                     tree_cons (NULL_TREE, convert (long_unsigned_type_node, length),
1698                        NULL_TREE)))))))));
1699     }
1700
1701   else if (TREE_CODE (lhs) == SET_IN_EXPR)
1702     {
1703       tree from_pos = save_expr (TREE_OPERAND (lhs, 0));
1704       tree set = TREE_OPERAND (lhs, 1);
1705       tree domain = TYPE_DOMAIN (TREE_TYPE (set));
1706       tree set_length
1707         = fold (build (PLUS_EXPR, integer_type_node,
1708                        fold (build (MINUS_EXPR, integer_type_node,
1709                                     TYPE_MAX_VALUE (domain),
1710                                     TYPE_MIN_VALUE (domain))),
1711                        integer_one_node));
1712       tree filename = force_addr_of (get_chill_filename());
1713       
1714       if (TREE_CODE (TREE_TYPE (lhs)) != BOOLEAN_TYPE)
1715         sorry("bitstring slice");
1716       expand_expr_stmt (
1717         build_chill_function_call (lookup_name (
1718           get_identifier ("__setbitpowerset")),
1719               tree_cons (NULL_TREE, build_chill_addr_expr (set, "powerset"),
1720                   tree_cons (NULL_TREE, set_length,
1721                     tree_cons (NULL_TREE, TYPE_MIN_VALUE (domain),
1722                       tree_cons (NULL_TREE, convert (long_integer_type_node, from_pos),
1723                         tree_cons (NULL_TREE, rhs,
1724                           tree_cons (NULL_TREE, filename,
1725                             tree_cons (NULL_TREE, get_chill_linenumber(),
1726                               NULL_TREE)))))))));
1727     }
1728
1729   /* Handle arrays of packed bitfields. Currently, this is limited to bitfields
1730      which are 1 bit wide, so use the powerset runtime function. */
1731   else if (TREE_CODE (lhs) == PACKED_ARRAY_REF)
1732     {
1733       tree from_pos = save_expr (TREE_OPERAND (lhs, 1));
1734       tree array = TREE_OPERAND (lhs, 0);
1735       tree domain = TYPE_DOMAIN (TREE_TYPE (array));
1736       tree array_length = powersetlen (array);
1737       tree filename = force_addr_of (get_chill_filename());
1738       expand_expr_stmt (
1739         build_chill_function_call (lookup_name (
1740           get_identifier ("__setbitpowerset")),
1741             tree_cons (NULL_TREE, build_chill_addr_expr (array, "packed bitfield array"),
1742                 tree_cons (NULL_TREE, convert (long_unsigned_type_node, array_length),
1743                   tree_cons (NULL_TREE, convert (long_integer_type_node,
1744                                                  TYPE_MIN_VALUE (domain)),
1745                     tree_cons (NULL_TREE, convert (long_integer_type_node, from_pos),
1746                       tree_cons (NULL_TREE, build1 (CONVERT_EXPR, boolean_type_node, rhs),
1747                         tree_cons (NULL_TREE, filename,
1748                           tree_cons (NULL_TREE, get_chill_linenumber(),
1749                             NULL_TREE)))))))));
1750     }
1751
1752   /* The following is probably superseded by the
1753      above code for SET_IN_EXPR. FIXME! */
1754   else if (TREE_CODE (lhs) == BIT_FIELD_REF)
1755     {
1756       tree set = TREE_OPERAND (lhs, 0);
1757       tree numbits = TREE_OPERAND (lhs, 1);
1758       tree from_pos = save_expr (TREE_OPERAND (lhs, 2));
1759       tree domain = TYPE_DOMAIN (TREE_TYPE (set));
1760       tree set_length
1761         = fold (build (PLUS_EXPR, integer_type_node,
1762                        fold (build (MINUS_EXPR, integer_type_node,
1763                                     TYPE_MAX_VALUE (domain),
1764                                     TYPE_MIN_VALUE (domain))),
1765                        integer_one_node));
1766       tree filename = force_addr_of (get_chill_filename());
1767       tree to_pos;
1768
1769       switch (TREE_CODE (TREE_TYPE (rhs)))
1770         {
1771         case SET_TYPE:
1772           to_pos = fold (build (MINUS_EXPR, integer_type_node,
1773                                 fold (build (PLUS_EXPR, integer_type_node,
1774                                              from_pos, numbits)),
1775                                 integer_one_node));
1776           break;
1777         case BOOLEAN_TYPE:
1778           to_pos = from_pos;
1779           break;
1780         default:
1781           abort ();
1782         }
1783       
1784       if (TREE_CODE (TREE_TYPE (lhs)) != BOOLEAN_TYPE)
1785         sorry("bitstring slice");
1786       expand_expr_stmt (
1787           build_chill_function_call( lookup_name (
1788               get_identifier ("__setbitpowerset")),
1789                 tree_cons (NULL_TREE, build_chill_addr_expr (set, "powerset"),
1790                   tree_cons (NULL_TREE, set_length,
1791                     tree_cons (NULL_TREE, TYPE_MIN_VALUE (domain),
1792                       tree_cons (NULL_TREE, from_pos,
1793                         tree_cons (NULL_TREE, rhs,
1794                           tree_cons (NULL_TREE, filename,
1795                             tree_cons (NULL_TREE, get_chill_linenumber(),
1796                               NULL_TREE)))))))));
1797     }
1798
1799   else
1800     expand_expr_stmt (build_chill_modify_expr (lhs, rhs));
1801 }
1802 \f
1803 /* Also assumes that rhs has been stabilized */
1804 void
1805 expand_varying_length_assignment (lhs, rhs)
1806      tree lhs, rhs;
1807 {
1808   tree base_array, min_domain_val;
1809
1810   pedwarn ("LENGTH on left-hand-side is non-portable");
1811       
1812   if (! CH_LOCATION_P (lhs))
1813     {
1814       error ("can only set LENGTH of array location");
1815       return;
1816     }
1817
1818   /* cause a RANGE exception if rhs would cause a 'hole' in the array. */
1819   rhs = valid_array_index_p (lhs, rhs, "new array length too large", 1);
1820
1821   base_array     = CH_VARYING_ARRAY_TYPE (TREE_TYPE (lhs));
1822   min_domain_val = TYPE_MIN_VALUE (TYPE_DOMAIN (base_array));
1823
1824   lhs = build_component_ref (lhs, var_length_id);
1825   rhs = fold (build (MINUS_EXPR, TREE_TYPE (rhs), rhs, min_domain_val));
1826
1827   expand_expr_stmt (build_chill_modify_expr (lhs, rhs));
1828 }
1829 \f
1830 void
1831 push_action ()
1832 {
1833   push_handler ();
1834   if (ignoring)
1835     return;
1836   emit_line_note (input_filename, lineno);
1837 }