1 /* Implement actions for CHILL.
2 Copyright (C) 1992, 93, 1994, 1998, 1999 Free Software Foundation, Inc.
3 Authors: Per Bothner, Bill Cox, Michael Tiemann, Michael North
5 This file is part of GNU CC.
7 GNU CC is free software; you can redistribute it and/or modify
8 it under the terms of the GNU General Public License as published by
9 the Free Software Foundation; either version 2, or (at your option)
12 GNU CC is distributed in the hope that it will be useful,
13 but WITHOUT ANY WARRANTY; without even the implied warranty of
14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 GNU General Public License for more details.
17 You should have received a copy of the GNU General Public License
18 along with GNU CC; see the file COPYING. If not, write to
19 the Free Software Foundation, 59 Temple Place - Suite 330,
20 Boston, MA 02111-1307, USA. */
35 #define obstack_chunk_alloc xmalloc
36 #define obstack_chunk_free free
38 /* reserved tag definitions */
41 #define TAG_OBJECT "chill_object"
42 #define TAG_CLASS "chill_class"
44 extern int flag_short_enums;
45 extern int current_nesting_level;
47 extern struct obstack *expression_obstack, permanent_obstack;
48 extern struct obstack *current_obstack, *saveable_obstack;
50 /* This flag is checked throughout the non-CHILL-specific
52 tree chill_integer_type_node;
53 tree chill_unsigned_type_node;
55 /* Never used. Referenced from c-typeck.c, which we use. */
56 int current_function_returns_value = 0;
57 int current_function_returns_null = 0;
59 /* data imported from toplev.c */
61 extern char *dump_base_name;
63 /* set from command line parameter, to exit after
64 grant file written, generating no code. */
65 int grant_only_flag = 0;
80 print_lang_statistics ()
89 extern int errorcount, sorrycount;
91 /* this should be the last action in compiling a module.
92 If there are other actions to be performed at lang_finish
93 please insert before this */
95 /* FIXME: in case of a syntax error, this leaves the grant file incomplete */
96 /* for the moment we print a warning in case of errors and
98 if ((errorcount || sorrycount) && grant_count)
100 warning ("%d errors, %d sorries, do granting", errorcount, sorrycount);
101 errorcount = sorrycount = 0;
107 chill_check_decl (decl)
110 tree type = TREE_TYPE (decl);
111 static int alreadyWarned = 0;
113 if (TREE_CODE (type) == RECORD_TYPE) /* && TREE_STATIC_TEMPLATE (type)) */
117 error ("GNU compiler does not support statically allocated objects");
120 error_with_decl (decl, "`%s' cannot be statically allocated");
124 /* Comparison function for sorting identifiers in RAISES lists.
125 Note that because IDENTIFIER_NODEs are unique, we can sort
126 them by address, saving an indirection. */
131 long diff = (long)TREE_VALUE (*p1) - (long)TREE_VALUE (*p2);
133 return (diff < 0) ? -1 : (diff > 0);
136 /* Build the FUNCTION_TYPE or METHOD_TYPE which may raise exceptions
139 build_exception_variant (type, raises)
143 tree v = TYPE_MAIN_VARIANT (type);
145 int constp = TYPE_READONLY (type);
146 int volatilep = TYPE_VOLATILE (type);
149 return build_type_variant (v, constp, volatilep);
151 if (TREE_CHAIN (raises))
152 { /* Sort the list */
153 tree *a = (tree *)alloca ((list_length (raises)+1) * sizeof (tree));
154 for (i = 0, t = raises; t; t = TREE_CHAIN (t), i++)
156 /* NULL terminator for list. */
158 qsort (a, i, sizeof (tree), id_cmp);
160 TREE_CHAIN (a[i]) = a[i+1];
164 for (v = TYPE_NEXT_VARIANT (v); v; v = TYPE_NEXT_VARIANT (v))
166 if (TYPE_READONLY (v) != constp
167 || TYPE_VOLATILE (v) != volatilep)
171 t2 = TYPE_RAISES_EXCEPTIONS (v);
174 if (TREE_TYPE (t) == TREE_TYPE (t2))
177 t2 = TREE_CHAIN (t2);
183 /* List of exceptions raised matches previously found list.
185 @@ Nice to free up storage used in consing up the
186 @@ list of exceptions raised. */
190 /* Need to build a new variant. */
191 if (TREE_PERMANENT (type))
193 push_obstacks_nochange ();
194 end_temporary_allocation ();
195 v = copy_node (type);
199 v = copy_node (type);
201 TYPE_NEXT_VARIANT (v) = TYPE_NEXT_VARIANT (type);
202 TYPE_NEXT_VARIANT (type) = v;
203 if (raises && ! TREE_PERMANENT (raises))
205 push_obstacks_nochange ();
206 end_temporary_allocation ();
207 raises = copy_list (raises);
210 TYPE_RAISES_EXCEPTIONS (v) = raises;
216 build_rts_call (name, type, args)
220 tree decl = lookup_name (get_identifier (name));
221 tree converted_args = NULL_TREE;
222 tree result, length = NULL_TREE;
224 assert (decl != NULL_TREE);
227 tree arg = TREE_VALUE (args);
228 if (TREE_CODE (TREE_TYPE (arg)) == SET_TYPE
229 || TREE_CODE (TREE_TYPE (arg)) == ARRAY_TYPE)
231 length = size_in_bytes (TREE_TYPE (arg));
232 arg = build_chill_addr_expr (arg, (char *)0);
234 converted_args = tree_cons (NULL_TREE, arg, converted_args);
235 args = TREE_CHAIN (args);
237 if (length != NULL_TREE)
238 converted_args = tree_cons (NULL_TREE, length, converted_args);
239 converted_args = nreverse (converted_args);
240 result = build_chill_function_call (decl, converted_args);
241 if (TREE_CODE (type) == SET_TYPE || TREE_CODE (type) == ARRAY_TYPE)
242 result = build1 (INDIRECT_REF, type, result);
244 result = convert (type, result);
250 * queue name of unhandled exception
251 * to avoid multiple unhandled warnings
252 * in one compilation module
257 struct already_type *next;
261 static struct already_type *already_warned = 0;
267 struct already_type *p = already_warned;
271 if (!strcmp (p->name, ex))
277 p = (struct already_type *)xmalloc (sizeof (struct already_type));
278 p->next = already_warned;
279 p->name = (char *)xmalloc (strlen (ex) + 1);
280 strcpy (p->name, ex);
282 pedwarn ("causing unhandled exception `%s' (this is flaged only once)", ex);
286 * build a call to the following function:
287 * void __cause_ex1 (char* ex, const char *file,
288 * const unsigned lineno);
289 * if the exception is handled or
290 * void __unhandled_ex (char *ex, char *file, unsigned lineno)
291 * if the exception is not handled.
294 build_cause_exception (exp_name, warn_if_unhandled)
296 int warn_if_unhandled;
298 /* We don't use build_rts_call() here, because the string (array of char)
299 would be followed by its length in the parameter list built by
300 build_rts_call, and the runtime routine doesn't want a length parameter.*/
301 tree exp_decl = build_chill_exception_decl (IDENTIFIER_POINTER (exp_name));
302 tree function, fname, lineno, result;
303 int handled = is_handled (exp_name);
309 if (warn_if_unhandled)
310 warn_unhandled (IDENTIFIER_POINTER (exp_name));
311 function = lookup_name (get_identifier ("__unhandled_ex"));
312 fname = force_addr_of (get_chill_filename ());
313 lineno = get_chill_linenumber ();
317 function = lookup_name (get_identifier ("__cause_ex1"));
318 fname = force_addr_of (get_chill_filename ());
319 lineno = get_chill_linenumber ();
322 /* function may propagate this exception */
323 function = lookup_name (get_identifier ("__cause_ex1"));
324 fname = lookup_name (get_identifier (CALLER_FILE));
325 if (fname == NULL_TREE)
326 fname = error_mark_node;
327 lineno = lookup_name (get_identifier (CALLER_LINE));
328 if (lineno == NULL_TREE)
329 lineno = error_mark_node;
335 build_chill_function_call (function,
336 tree_cons (NULL_TREE, build_chill_addr_expr (exp_decl, (char *)0),
337 tree_cons (NULL_TREE, fname,
338 tree_cons (NULL_TREE, lineno, NULL_TREE))));
343 expand_cause_exception (exp_name)
346 expand_expr_stmt (build_cause_exception (exp_name, 1));
349 /* If CONDITION is true, raise EXCEPTION (an IDENTIFIER_NODE);
350 otherwise return EXPR. */
353 check_expression (expr, condition, exception)
354 tree expr, condition, exception;
356 if (integer_zerop (condition))
359 return build (COMPOUND_EXPR, TREE_TYPE (expr),
360 fold (build (TRUTH_ANDIF_EXPR, boolean_type_node,
361 condition, build_cause_exception (exception, 0))),
365 /* Return an expression for VALUE < LO_LIMIT || VALUE > HI_LIMIT,
366 somewhat optimized and with some warnings suppressed.
367 If LO_LIMIT or HI_LIMIT is NULL_TREE, assume that (sub-)test passes. */
370 test_range (value, lo_limit, hi_limit)
371 tree value, lo_limit, hi_limit;
373 if (lo_limit || hi_limit)
375 int old_inhibit_warnings = inhibit_warnings;
376 tree lo_check, hi_check, check;
378 /* This is a hack so that `shorten_compare' doesn't warn the
379 user about useless range checks that are too much work to
380 optimize away here. */
381 inhibit_warnings = 1;
383 lo_check = lo_limit ?
384 fold (build_compare_discrete_expr (LT_EXPR, value, lo_limit)) :
385 boolean_false_node; /* fake passing the check */
387 hi_check = hi_limit ?
388 fold (build_compare_discrete_expr (GT_EXPR, value, hi_limit)) :
389 boolean_false_node; /* fake passing the check */
391 if (lo_check == boolean_false_node)
393 else if (hi_check == boolean_false_node)
396 check = fold (build (TRUTH_ORIF_EXPR, boolean_type_node,
397 lo_check, hi_check));
399 inhibit_warnings = old_inhibit_warnings;
403 return boolean_false_node;
406 /* Return EXPR, except if range_checking is on, return an expression
407 that also checks that value >= low_limit && value <= hi_limit.
408 If LO_LIMIT or HI_LIMIT is NULL_TREE, assume that test passes. */
411 check_range (expr, value, lo_limit, hi_limit)
412 tree expr, value, lo_limit, hi_limit;
414 tree check = test_range (value, lo_limit, hi_limit);
415 if (!integer_zerop (check))
417 if (current_function_decl == NULL_TREE)
419 if (TREE_CODE (check) == INTEGER_CST)
420 error ("range failure (not inside function)");
422 warning ("possible range failure (not inside function)");
426 if (TREE_CODE (check) == INTEGER_CST)
427 warning ("expression will always cause RANGEFAIL");
429 expr = check_expression (expr, check,
430 ridpointers[(int) RID_RANGEFAIL]);
436 /* Same as EXPR, except raise EMPTY if EXPR is NULL. */
439 check_non_null (expr)
444 expr = save_if_needed (expr);
445 return check_expression (expr,
446 build_compare_expr (EQ_EXPR,
447 expr, null_pointer_node),
448 ridpointers[(int) RID_EMPTY]);
454 * There are four conditions to generate a runtime check:
455 * 1) assigning a longer INT to a shorter (signs irrelevant)
456 * 2) assigning a signed to an unsigned
457 * 3) assigning an unsigned to a signed of the same size.
458 * 4) TYPE is a discrete subrange
461 chill_convert_for_assignment (type, expr, place)
463 char *place; /* location description for error messages */
466 tree etype = TREE_TYPE (expr);
469 if (type == NULL_TREE || TREE_CODE (type) == ERROR_MARK)
470 return error_mark_node;
471 if (expr == NULL_TREE || TREE_CODE (expr) == ERROR_MARK)
473 if (TREE_CODE (expr) == TYPE_DECL)
475 error ("right hand side of assignment is a mode");
476 return error_mark_node;
479 if (! CH_COMPATIBLE (expr, type))
481 error ("incompatible modes in %s", place);
482 return error_mark_node;
485 if (TREE_CODE (type) == REFERENCE_TYPE)
486 ttype = TREE_TYPE (ttype);
487 if (etype && TREE_CODE (etype) == REFERENCE_TYPE)
488 etype = TREE_TYPE (etype);
491 && (CH_STRING_TYPE_P (ttype)
492 || (chill_varying_type_p (ttype)
493 && CH_STRING_TYPE_P (CH_VARYING_ARRAY_TYPE (ttype))))
494 && (CH_STRING_TYPE_P (etype)
495 || (chill_varying_type_p (etype)
496 && CH_STRING_TYPE_P (CH_VARYING_ARRAY_TYPE (etype)))))
500 expr = save_if_needed (expr);
501 cond = string_assignment_condition (ttype, expr);
502 if (TREE_CODE (cond) == INTEGER_CST)
504 if (integer_zerop (cond))
506 error ("bad string length in %s", place);
507 return error_mark_node;
509 /* Otherwise, the condition is always true, so no runtime test. */
511 else if (range_checking)
512 expr = check_expression (expr,
513 invert_truthvalue (cond),
514 ridpointers[(int) RID_RANGEFAIL]);
518 && discrete_type_p (ttype)
519 && etype != NULL_TREE
520 && discrete_type_p (etype))
522 int cond1 = tree_int_cst_lt (TYPE_SIZE (ttype),
524 int cond2 = TREE_UNSIGNED (ttype)
525 && (! TREE_UNSIGNED (etype));
526 int cond3 = (! TREE_UNSIGNED (type))
527 && TREE_UNSIGNED (etype)
528 && tree_int_cst_equal (TYPE_SIZE (ttype),
530 int cond4 = TREE_TYPE (ttype)
531 && discrete_type_p (TREE_TYPE (ttype));
533 if (cond1 || cond2 || cond3 || cond4)
535 tree type_min = TYPE_MIN_VALUE (ttype);
536 tree type_max = TYPE_MAX_VALUE (ttype);
538 expr = save_if_needed (expr);
539 if (expr && type_min && type_max)
540 expr = check_range (expr, expr, type_min, type_max);
543 result = convert (type, expr);
545 /* If the type is a array of PACK bits and the expression is an array constructor,
546 then build a CONSTRUCTOR for a bitstring. Bitstrings are zero based, so
547 decrement the value of each CONSTRUCTOR element by the amount of the lower
548 bound of the array. */
549 if (TREE_CODE (type) == ARRAY_TYPE && TYPE_PACKED (type)
550 && TREE_CODE (result) == CONSTRUCTOR)
552 tree domain_min = TYPE_MIN_VALUE (TYPE_DOMAIN (type));
553 tree new_list = NULL_TREE;
556 for (element = TREE_OPERAND (result, 1);
557 element != NULL_TREE;
558 element = TREE_CHAIN (element))
560 if (!tree_int_cst_equal (TREE_VALUE (element), integer_zero_node))
562 tree purpose = TREE_PURPOSE (element);
563 switch (TREE_CODE (purpose))
566 new_list = tree_cons (NULL_TREE,
567 size_binop (MINUS_EXPR, purpose, domain_min),
571 for (index = TREE_INT_CST_LOW (TREE_OPERAND (purpose, 0));
572 index <= TREE_INT_CST_LOW (TREE_OPERAND (purpose, 1));
574 new_list = tree_cons (NULL_TREE,
575 size_binop (MINUS_EXPR,
576 build_int_2 (index, 0),
585 result = copy_node (result);
586 TREE_OPERAND (result, 1) = nreverse (new_list);
587 TREE_TYPE (result) = build_bitstring_type (TYPE_SIZE (type));
593 /* Check that EXPR has valid type for a RETURN or RESULT expression,
594 converting to the right type. ACTION is "RESULT" or "RETURN". */
597 adjust_return_value (expr, action)
601 tree type = TREE_TYPE (TREE_TYPE (current_function_decl));
603 if (TREE_CODE (type) == REFERENCE_TYPE)
605 if (CH_LOCATION_P (expr))
607 if (! CH_READ_COMPATIBLE (TREE_TYPE (type),
610 error ("mode mismatch in %s expression", action);
611 return error_mark_node;
613 return convert (type, expr);
617 error ("%s expression must be referable", action);
618 return error_mark_node;
621 else if (! CH_COMPATIBLE (expr, type))
623 error ("mode mismatch in %s expression", action);
624 return error_mark_node;
626 return convert (type, expr);
630 chill_expand_result (expr, result_or_return)
632 int result_or_return;
635 char *action_name = result_or_return ? "RESULT" : "RETURN";
640 if (expr == NULL_TREE || TREE_CODE (expr) == ERROR_MARK)
643 CH_FUNCTION_SETS_RESULT (current_function_decl) = 1;
645 if (chill_at_module_level || global_bindings_p ())
646 error ("%s not allowed outside a PROC", action_name);
648 result_never_set = 0;
650 if (chill_result_decl == NULL_TREE)
652 error ("%s action in PROC with no declared RESULTS", action_name);
655 type = TREE_TYPE (chill_result_decl);
657 if (TREE_CODE (type) == ERROR_MARK)
660 expr = adjust_return_value (expr, action_name);
662 expand_expr_stmt (build_chill_modify_expr (chill_result_decl, expr));
666 * error if EXPR not NULL and procedure doesn't
667 * have a return type;
668 * warning if EXPR NULL,
669 * procedure *has* a return type, and a previous
670 * RESULT actions hasn't saved a return value.
673 chill_expand_return (expr, implicit)
675 int implicit; /* 1 if an implicit return at end of function. */
679 if (expr != NULL_TREE && TREE_CODE (expr) == ERROR_MARK)
681 if (chill_at_module_level || global_bindings_p ())
683 error ("RETURN not allowed outside PROC");
690 result_never_set = 0;
692 valtype = TREE_TYPE (TREE_TYPE (current_function_decl));
693 if (TREE_CODE (valtype) == VOID_TYPE)
695 if (expr != NULL_TREE)
696 error ("RETURN with a value, in PROC returning void");
697 expand_null_return ();
699 else if (TREE_CODE (valtype) != ERROR_MARK)
701 if (expr == NULL_TREE)
703 if (!CH_FUNCTION_SETS_RESULT (current_function_decl)
705 warning ("RETURN with no value and no RESULT action in procedure");
706 expr = chill_result_decl;
709 expr = adjust_return_value (expr, "RETURN");
710 expr = build (MODIFY_EXPR, valtype,
711 DECL_RESULT (current_function_decl),
713 TREE_SIDE_EFFECTS (expr) = 1;
714 expand_return (expr);
719 lookup_and_expand_goto (name)
722 if (name == NULL_TREE || TREE_CODE (name) == ERROR_MARK)
726 tree decl = lookup_name (name);
727 if (decl == NULL || TREE_CODE (decl) != LABEL_DECL)
728 error ("no label named `%s'", IDENTIFIER_POINTER (name));
729 else if (DECL_CONTEXT (decl) != current_function_decl)
730 error ("cannot GOTO label `%s' outside current function",
731 IDENTIFIER_POINTER (name));
734 TREE_USED (decl) = 1;
735 expand_goto_except_cleanup (DECL_ACTION_NESTING_LEVEL (decl));
742 lookup_and_handle_exit (name)
745 if (name == NULL_TREE || TREE_CODE (name) == ERROR_MARK)
749 tree label = munge_exit_label (name);
750 tree decl = lookup_name (label);
751 if (decl == NULL || TREE_CODE (decl) != LABEL_DECL)
752 error ("no EXITable label named `%s'", IDENTIFIER_POINTER (name));
753 else if (DECL_CONTEXT (decl) != current_function_decl)
754 error ("cannot EXIT label `%s' outside current function",
755 IDENTIFIER_POINTER (name));
758 TREE_USED (decl) = 1;
759 expand_goto_except_cleanup (DECL_ACTION_NESTING_LEVEL (decl));
765 /* ELSE-range handling: The else-range is a chain of trees which collectively
766 represent the ranges to be tested for the (ELSE) case label. Each element in
767 the chain represents a range to be tested. The boundaries of the range are
768 represented by INTEGER_CST trees in the PURPOSE and VALUE fields. */
770 /* This function updates the else-range by removing the given integer constant. */
772 update_else_range_for_int_const (else_range, label)
773 tree else_range, label;
776 int label_value = TREE_INT_CST_LOW (label);
777 tree this_range, prev_range, new_range;
779 /* First, find the range element containing the integer, if it exists. */
780 prev_range = NULL_TREE;
781 for (this_range = else_range ;
782 this_range != NULL_TREE;
783 this_range = TREE_CHAIN (this_range))
785 lowval = TREE_INT_CST_LOW (TREE_PURPOSE (this_range));
786 highval = TREE_INT_CST_LOW (TREE_VALUE (this_range));
787 if (label_value >= lowval && label_value <= highval)
789 prev_range = this_range;
792 /* If a range element containing the integer was found, then update the range. */
793 if (this_range != NULL_TREE)
795 tree next = TREE_CHAIN (this_range);
796 if (label_value == lowval)
798 /* The integer is the lower bound of the range element. If it is also the
799 upper bound, then remove this range element, otherwise update it. */
800 if (label_value == highval)
802 if (prev_range == NULL_TREE)
805 TREE_CHAIN (prev_range) = next;
808 TREE_PURPOSE (this_range) = build_int_2 (label_value + 1, 0);
810 else if (label_value == highval)
812 /* The integer is the upper bound of the range element, so ajust it. */
813 TREE_VALUE (this_range) = build_int_2 (label_value - 1, 0);
817 /* The integer is in the middle of the range element, so split it. */
818 new_range = tree_cons (
819 build_int_2 (label_value + 1, 0), TREE_VALUE (this_range), next);
820 TREE_VALUE (this_range) = build_int_2 (label_value - 1, 0);
821 TREE_CHAIN (this_range) = new_range;
827 /* Update the else-range to remove a range of values/ */
829 update_else_range_for_range (else_range, low_target, high_target)
830 tree else_range, low_target, high_target;
832 tree this_range, prev_range, new_range, next_range;
833 int low_range_val, high_range_val;
834 int low_target_val = TREE_INT_CST_LOW (low_target);
835 int high_target_val = TREE_INT_CST_LOW (high_target);
837 /* find the first else-range element which overlaps the target range. */
838 prev_range = NULL_TREE;
839 for (this_range = else_range ;
840 this_range != NULL_TREE;
841 this_range = TREE_CHAIN (this_range))
843 low_range_val = TREE_INT_CST_LOW (TREE_PURPOSE (this_range));
844 high_range_val = TREE_INT_CST_LOW (TREE_VALUE (this_range));
845 if ((low_target_val >= low_range_val && low_target_val <= high_range_val)
846 || (high_target_val >= low_range_val && high_target_val <= high_range_val))
848 prev_range = this_range;
850 if (this_range == NULL_TREE)
853 /* This first else-range element might be truncated at the top or completely
854 contain the target range. */
855 if (low_range_val < low_target_val)
857 next_range = TREE_CHAIN (this_range);
858 if (high_range_val > high_target_val)
860 new_range = tree_cons (
861 build_int_2 (high_target_val + 1, 0), TREE_VALUE (this_range), next_range);
862 TREE_VALUE (this_range) = build_int_2 (low_target_val - 1, 0);
863 TREE_CHAIN (this_range) = new_range;
867 TREE_VALUE (this_range) = build_int_2 (low_target_val - 1, 0);
868 if (next_range == NULL_TREE)
871 prev_range = this_range;
872 this_range = next_range;
873 high_range_val = TREE_INT_CST_LOW (TREE_VALUE (this_range));
876 /* There may then follow zero or more else-range elements which are completely
877 contained in the target range. */
878 while (high_range_val <= high_target_val)
880 this_range = TREE_CHAIN (this_range);
881 if (prev_range == NULL_TREE)
882 else_range = this_range;
884 TREE_CHAIN (prev_range) = this_range;
886 if (this_range == NULL_TREE)
888 high_range_val = TREE_INT_CST_LOW (TREE_VALUE (this_range));
891 /* Finally, there may be a else-range element which is truncated at the bottom. */
892 low_range_val = TREE_INT_CST_LOW (TREE_PURPOSE (this_range));
893 if (low_range_val <= high_target_val)
894 TREE_PURPOSE (this_range) = build_int_2 (high_target_val + 1, 0);
900 update_else_range_for_range_expr (else_range, label)
901 tree else_range, label;
903 if (TREE_OPERAND (label, 0) == NULL_TREE)
905 if (TREE_OPERAND (label, 1) == NULL_TREE)
906 else_range = NULL_TREE; /* (*) -- matches everything */
909 else_range = update_else_range_for_range (
910 else_range, TREE_OPERAND (label, 0), TREE_OPERAND (label, 1));
916 update_else_range_for_type (else_range, label)
917 tree else_range, label;
919 tree type = TREE_TYPE (label);
920 else_range = update_else_range_for_range (
921 else_range, TYPE_MIN_VALUE (type), TYPE_MAX_VALUE (type));
926 compute_else_range (selector, alternatives, selector_no)
927 tree selector, alternatives;
930 /* Start with an else-range that spans the entire range of the selector type. */
931 tree type = TREE_TYPE (TREE_VALUE (selector));
932 tree range = tree_cons (TYPE_MIN_VALUE (type), TYPE_MAX_VALUE (type), NULL_TREE);
934 /* Now remove the values represented by each case lebel specified for that
935 selector. The remaining range is the else-range. */
936 for ( ; alternatives != NULL_TREE; alternatives = TREE_CHAIN (alternatives))
939 tree label_list = TREE_PURPOSE (alternatives);
941 for (this_selector = 0; this_selector < selector_no ; ++this_selector)
942 label_list = TREE_CHAIN (label_list);
944 for (label = TREE_VALUE (label_list);
946 label = TREE_CHAIN (label))
948 tree label_value = TREE_VALUE (label);
949 if (TREE_CODE (label_value) == INTEGER_CST)
950 range = update_else_range_for_int_const (range, label_value);
951 else if (TREE_CODE (label_value) == RANGE_EXPR)
952 range = update_else_range_for_range_expr (range, label_value);
953 else if (TREE_CODE (label_value) == TYPE_DECL)
954 range = update_else_range_for_type (range, label_value);
956 if (range == NULL_TREE)
965 compute_else_ranges (selectors, alternatives)
966 tree selectors, alternatives;
971 for (selector = selectors; selector != NULL_TREE; selector = TREE_CHAIN (selector))
973 if (ELSE_LABEL_SPECIFIED (selector))
974 TREE_PURPOSE (selector) =
975 compute_else_range (selector, alternatives, selector_no);
981 check_case_value (label_value, selector)
982 tree label_value, selector;
984 if (TREE_CODE (label_value) == ERROR_MARK)
986 if (TREE_CODE (selector) == ERROR_MARK)
989 /* Z.200 (6.4 Case action) says: "The class of any discrete expression
990 in the case selector list must be compatible with the corresponding
991 (by position) class of the resulting list of classes of the case label
992 list occurrences ...". We don't actually construct the resulting
993 list of classes, but this test should be more-or-less equivalent.
995 if (!CH_COMPATIBLE_CLASSES (selector, label_value))
997 error ("case selector not compatible with label");
998 return error_mark_node;
1001 /* Strip NON_LVALUE_EXPRs since we aren't using as an lvalue. */
1002 STRIP_TYPE_NOPS (label_value);
1004 if (TREE_CODE (label_value) != INTEGER_CST)
1006 error ("case label does not reduce to an integer constant");
1007 return error_mark_node;
1010 constant_expression_warning (label_value);
1015 chill_handle_case_default ()
1018 register tree label = build_decl (LABEL_DECL, NULL_TREE,
1020 int success = pushcase (NULL_TREE, 0, label, &duplicate);
1023 error ("ELSE label not within a CASE statement");
1025 else if (success == 2)
1027 error ("multiple default labels found in a CASE statement");
1028 error_with_decl (duplicate, "this is the first ELSE label");
1033 /* Handle cases label such as (I:J): or (modename): */
1036 chill_handle_case_label_range (min_value, max_value, selector)
1037 tree min_value, max_value, selector;
1039 register tree label = build_decl (LABEL_DECL, NULL_TREE, NULL_TREE);
1040 min_value = check_case_value (min_value, selector);
1041 max_value = check_case_value (max_value, selector);
1042 if (TREE_CODE (min_value) != ERROR_MARK
1043 && TREE_CODE (max_value) != ERROR_MARK)
1046 int success = pushcase_range (min_value, max_value,
1047 convert, label, &duplicate);
1049 error ("label found outside of CASE statement");
1050 else if (success == 2)
1052 error ("duplicate CASE value");
1053 error_with_decl (duplicate, "this is the first entry for that value");
1055 else if (success == 3)
1056 error ("CASE value out of range");
1057 else if (success == 4)
1058 error ("empty range");
1059 else if (success == 5)
1060 error ("label within scope of cleanup or variable array");
1065 chill_handle_case_label (label_value, selector)
1066 tree label_value, selector;
1068 if (label_value == NULL_TREE
1069 || TREE_CODE (label_value) == ERROR_MARK)
1071 if (TREE_CODE (label_value) == RANGE_EXPR)
1073 if (TREE_OPERAND (label_value, 0) == NULL_TREE)
1074 chill_handle_case_default (); /* i.e. (ELSE): or (*): */
1076 chill_handle_case_label_range (TREE_OPERAND (label_value, 0),
1077 TREE_OPERAND (label_value, 1),
1080 else if (TREE_CODE (label_value) == TYPE_DECL)
1082 tree type = TREE_TYPE (label_value);
1083 if (! discrete_type_p (type))
1084 error ("mode in label is not discrete");
1086 chill_handle_case_label_range (TYPE_MIN_VALUE (type),
1087 TYPE_MAX_VALUE (type),
1092 register tree label = build_decl (LABEL_DECL, NULL_TREE, NULL_TREE);
1094 label_value = check_case_value (label_value, selector);
1096 if (TREE_CODE (label_value) != ERROR_MARK)
1099 int success = pushcase (label_value, convert, label, &duplicate);
1101 error ("label not within a CASE statement");
1102 else if (success == 2)
1104 error ("duplicate case value");
1105 error_with_decl (duplicate,
1106 "this is the first entry for that value");
1108 else if (success == 3)
1109 error ("CASE value out of range");
1110 else if (success == 4)
1111 error ("empty range");
1112 else if (success == 5)
1113 error ("label within scope of cleanup or variable array");
1119 chill_handle_single_dimension_case_label (
1120 selector, label_spec, expand_exit_needed, caseaction_flag
1122 tree selector, label_spec;
1123 int *expand_exit_needed, *caseaction_flag;
1125 tree labels, one_label;
1126 int no_completeness_check = 0;
1128 if (*expand_exit_needed || *caseaction_flag == 1)
1130 expand_exit_something ();
1131 *expand_exit_needed = 0;
1134 for (labels = label_spec; labels != NULL_TREE; labels = TREE_CHAIN (labels))
1135 for (one_label = TREE_VALUE (labels); one_label != NULL_TREE;
1136 one_label = TREE_CHAIN (one_label))
1138 if (TREE_VALUE (one_label) == case_else_node)
1139 no_completeness_check = 1;
1141 chill_handle_case_label (TREE_VALUE (one_label), selector);
1144 *caseaction_flag = 1;
1146 return no_completeness_check;
1150 chill_handle_multi_case_label_range (low, high, selector)
1151 tree low, high, selector;
1153 tree low_expr, high_expr, and_expr;
1155 int low_target_val, high_target_val;
1156 int low_type_val, high_type_val;
1158 /* we can eliminate some tests is the low and/or high value in the given range
1159 are outside the range of the selector type. */
1160 low_target_val = TREE_INT_CST_LOW (low);
1161 high_target_val = TREE_INT_CST_LOW (high);
1162 selector_type = TREE_TYPE (selector);
1163 low_type_val = TREE_INT_CST_LOW (TYPE_MIN_VALUE (selector_type));
1164 high_type_val = TREE_INT_CST_LOW (TYPE_MAX_VALUE (selector_type));
1166 if (low_target_val > high_type_val || high_target_val < low_type_val)
1167 return boolean_false_node; /* selector never in range */
1169 if (low_type_val >= low_target_val)
1171 if (high_type_val <= high_target_val)
1172 return boolean_true_node; /* always in the range */
1173 return build_compare_expr (LE_EXPR, selector, high);
1176 if (high_type_val <= high_target_val)
1177 return build_compare_expr (GE_EXPR, selector, low);
1179 /* The target range in completely within the range of the selector, but we
1180 might be able to save a test if the upper bound is the same as the lower
1182 if (low_target_val == high_target_val)
1183 return build_compare_expr (EQ_EXPR, selector, low);
1185 /* No optimizations possible. Just generate tests against the upper and lower
1186 bound of the target */
1187 low_expr = build_compare_expr (GE_EXPR, selector, low);
1188 high_expr = build_compare_expr (LE_EXPR, selector, high);
1189 and_expr = build_chill_binary_op (TRUTH_ANDIF_EXPR, low_expr, high_expr);
1195 chill_handle_multi_case_else_label (selector)
1198 tree else_range, selector_value, selector_type;
1199 tree low, high, larg;
1201 else_range = TREE_PURPOSE (selector);
1202 if (else_range == NULL_TREE)
1203 return boolean_false_node; /* no values in ELSE range */
1205 /* Test each of the ranges in the else-range chain */
1206 selector_value = TREE_VALUE (selector);
1207 selector_type = TREE_TYPE (selector_value);
1208 low = convert (selector_type, TREE_PURPOSE (else_range));
1209 high = convert (selector_type, TREE_VALUE (else_range));
1210 larg = chill_handle_multi_case_label_range (low, high, selector_value);
1212 for (else_range = TREE_CHAIN (else_range);
1213 else_range != NULL_TREE;
1214 else_range = TREE_CHAIN (else_range))
1217 low = convert (selector_type, TREE_PURPOSE (else_range));
1218 high = convert (selector_type, TREE_VALUE (else_range));
1219 rarg = chill_handle_multi_case_label_range (low, high, selector_value);
1220 larg = build_chill_binary_op (TRUTH_ORIF_EXPR, larg, rarg);
1227 chill_handle_multi_case_label (selector, label)
1228 tree selector, label;
1230 tree expr = NULL_TREE;
1232 if (label == NULL_TREE || TREE_CODE (label) == ERROR_MARK)
1235 if (TREE_CODE (label) == INTEGER_CST)
1237 int target_val = TREE_INT_CST_LOW (label);
1238 tree selector_type = TREE_TYPE (TREE_VALUE (selector));
1239 int low_type_val = TREE_INT_CST_LOW (TYPE_MIN_VALUE (selector_type));
1240 int high_type_val = TREE_INT_CST_LOW (TYPE_MAX_VALUE (selector_type));
1241 if (target_val < low_type_val || target_val > high_type_val)
1242 expr = boolean_false_node;
1244 expr = build_compare_expr (EQ_EXPR, TREE_VALUE (selector), label);
1246 else if (TREE_CODE (label) == RANGE_EXPR)
1248 if (TREE_OPERAND (label, 0) == NULL_TREE)
1250 if (TREE_OPERAND (label, 1) == NULL_TREE)
1251 expr = boolean_true_node; /* (*) -- matches everything */
1253 expr = chill_handle_multi_case_else_label (selector);
1257 tree low = TREE_OPERAND (label, 0);
1258 tree high = TREE_OPERAND (label, 1);
1259 if (TREE_CODE (low) != INTEGER_CST)
1261 error ("Lower bound of range must be a discrete literal expression");
1262 expr = error_mark_node;
1264 if (TREE_CODE (high) != INTEGER_CST)
1266 error ("Upper bound of range must be a discrete literal expression");
1267 expr = error_mark_node;
1269 if (expr != error_mark_node)
1271 expr = chill_handle_multi_case_label_range (
1272 low, high, TREE_VALUE (selector));
1276 else if (TREE_CODE (label) == TYPE_DECL)
1278 tree type = TREE_TYPE (label);
1279 if (! discrete_type_p (type))
1281 error ("mode in label is not discrete");
1282 expr = error_mark_node;
1285 expr = chill_handle_multi_case_label_range (
1286 TYPE_MIN_VALUE (type), TYPE_MAX_VALUE (type), TREE_VALUE (selector));
1290 error ("The CASE label is not valid");
1291 expr = error_mark_node;
1298 chill_handle_multi_case_label_list (selector, labels)
1299 tree selector, labels;
1301 tree one_label, larg, rarg;
1303 one_label = TREE_VALUE (labels);
1304 larg = chill_handle_multi_case_label (selector, TREE_VALUE (one_label));
1306 for (one_label = TREE_CHAIN (one_label);
1307 one_label != NULL_TREE;
1308 one_label = TREE_CHAIN (one_label))
1310 rarg = chill_handle_multi_case_label (selector, TREE_VALUE (one_label));
1311 larg = build_chill_binary_op (TRUTH_ORIF_EXPR, larg, rarg);
1318 build_multi_case_selector_expression (selector_list, label_spec)
1319 tree selector_list, label_spec;
1321 tree labels, selector, larg, rarg;
1323 labels = label_spec;
1324 selector = selector_list;
1325 larg = chill_handle_multi_case_label_list(selector, labels);
1327 for (labels = TREE_CHAIN (labels), selector = TREE_CHAIN (selector);
1328 labels != NULL_TREE && selector != NULL_TREE;
1329 labels = TREE_CHAIN (labels), selector = TREE_CHAIN (selector))
1331 rarg = chill_handle_multi_case_label_list(selector, labels);
1332 larg = build_chill_binary_op (TRUTH_ANDIF_EXPR, larg, rarg);
1335 if (labels != NULL_TREE || selector != NULL_TREE)
1336 error ("The number of CASE selectors does not match the number of CASE label lists");
1341 #define BITARRAY_TEST(ARRAY, INDEX) \
1342 ((ARRAY)[(unsigned)(INDEX) / HOST_BITS_PER_CHAR]\
1343 & (1 << ((unsigned)(INDEX) % HOST_BITS_PER_CHAR)))
1344 #define BITARRAY_SET(ARRAY, INDEX) \
1345 ((ARRAY)[(unsigned)(INDEX) / HOST_BITS_PER_CHAR]\
1346 |= 1 << ((unsigned)(INDEX) % HOST_BITS_PER_CHAR))
1348 /* CASES_SEEN is a set (bitarray) of length COUNT.
1349 For each element that is zero, print an error message,
1350 assume the element have the given TYPE. */
1353 print_missing_cases (type, cases_seen, count)
1355 unsigned char *cases_seen;
1359 for (i = 0; i < count; i++)
1361 if (BITARRAY_TEST(cases_seen, i) == 0)
1367 char *err_val_name = "???";
1368 if (TYPE_MIN_VALUE (t)
1369 && TREE_CODE (TYPE_MIN_VALUE (t)) == INTEGER_CST)
1370 x += TREE_INT_CST_LOW (TYPE_MIN_VALUE (t));
1371 while (TREE_TYPE (t) != NULL_TREE)
1373 switch (TREE_CODE (t))
1377 err_val_name = x ? "TRUE" : "FALSE";
1380 if ((x >= ' ' && x < 127) && x != '\'' && x != '^')
1381 sprintf (buf, "'%c'", (char)x);
1383 sprintf (buf, "'^(%ld)'", x);
1386 while (j < count && !BITARRAY_TEST(cases_seen, j))
1391 err_val_name += strlen (err_val_name);
1392 if ((y >= ' ' && y < 127) && y != '\'' && y != '^')
1393 sprintf (err_val_name, "%s:'%c'", buf, (char)y);
1395 sprintf (err_val_name, "%s:'^(%ld)'", buf, y);
1400 for (v = TYPE_VALUES (t); v && x; v = TREE_CHAIN (v))
1403 err_val_name = IDENTIFIER_POINTER (TREE_PURPOSE (v));
1407 while (j < count && !BITARRAY_TEST(cases_seen, j))
1410 sprintf (buf, "%ld", x);
1412 sprintf (buf, "%ld:%ld", x, x+j-i-1);
1417 error ("incomplete CASE - %s not handled", err_val_name);
1423 check_missing_cases (type)
1427 /* For each possible selector value. a one iff it has been matched
1428 by a case value alternative. */
1429 unsigned char *cases_seen;
1430 /* The number of possible selector values. */
1431 HOST_WIDE_INT size = all_cases_count (type, &is_sparse);
1432 long bytes_needed = (size+HOST_BITS_PER_CHAR)/HOST_BITS_PER_CHAR;
1435 warning ("CASE selector with variable range");
1436 else if (size < 0 || size > 600000
1437 /* We deliberately use malloc here - not xmalloc. */
1438 || (cases_seen = (char*) malloc (bytes_needed)) == NULL)
1439 warning ("too many cases to do CASE completeness testing");
1442 bzero (cases_seen, bytes_needed);
1443 mark_seen_cases (type, cases_seen, size, is_sparse);
1444 print_missing_cases (type, cases_seen, size);
1450 * We build an expression tree here because, in many contexts,
1451 * we don't know the type of result that's desired. By the
1452 * time we get to expanding the tree, we do know.
1455 build_chill_case_expr (exprlist, casealtlist_expr,
1457 tree exprlist, casealtlist_expr, optelsecase_expr;
1459 return build (CASE_EXPR, NULL_TREE, exprlist,
1461 tree_cons (NULL_TREE,
1467 /* This function transforms the selector_list and alternatives into a COND_EXPR. */
1469 build_chill_multi_dimension_case_expr (selector_list, alternatives, else_expr)
1470 tree selector_list, alternatives, else_expr;
1474 selector_list = check_case_selector_list (selector_list);
1476 if (alternatives == NULL_TREE)
1479 alternatives = nreverse (alternatives);
1480 /* alternatives represents the CASE label specifications and resulting values in
1481 the reverse order in which they appeared.
1482 If there is an ELSE expression, then use it. If there is no
1483 ELSE expression, make the last alternative (which is the first in the list)
1484 into the ELSE expression. This is safe because, if the CASE is complete
1485 (as required), then the last condition need not be checked anyway. */
1486 if (else_expr != NULL_TREE)
1490 expr = TREE_VALUE (alternatives);
1491 alternatives = TREE_CHAIN (alternatives);
1494 for ( ; alternatives != NULL_TREE; alternatives = TREE_CHAIN (alternatives))
1496 tree value = TREE_VALUE (alternatives);
1497 tree labels = TREE_PURPOSE (alternatives);
1498 tree cond = build_multi_case_selector_expression(selector_list, labels);
1499 expr = build_nt (COND_EXPR, cond, value, expr);
1506 /* This is called with the assumption that RHS has been stabilized.
1507 It has one purpose: to iterate through the CHILL list of LHS's */
1509 expand_assignment_action (loclist, modifycode, rhs)
1511 enum chill_tree_code modifycode;
1514 if (loclist == NULL_TREE || TREE_CODE (loclist) == ERROR_MARK
1515 || rhs == NULL_TREE || TREE_CODE (rhs) == ERROR_MARK)
1518 if (TREE_CHAIN (loclist) != NULL_TREE)
1519 { /* Multiple assignment */
1521 if (TREE_TYPE (rhs) != NULL_TREE)
1522 rhs = save_expr (rhs);
1523 else if (TREE_CODE (rhs) == CONSTRUCTOR)
1524 error ("type of tuple cannot be implicit in multiple assignent");
1525 else if (TREE_CODE (rhs) == CASE_EXPR || TREE_CODE (rhs) == COND_EXPR)
1526 error ("conditional expression cannot be used in multiple assignent");
1528 error ("internal error - unknown type in multiple assignment");
1530 if (modifycode != NOP_EXPR)
1532 error ("no operator allowed in multiple assignment,");
1533 modifycode = NOP_EXPR;
1536 for (target = TREE_CHAIN (loclist); target; target = TREE_CHAIN (target))
1538 if (!CH_EQUIVALENT (TREE_TYPE (TREE_VALUE (target)),
1539 TREE_TYPE (TREE_VALUE (loclist))))
1542 ("location modes in multiple assignment are not equivalent");
1547 for ( ; loclist != NULL_TREE; loclist = TREE_CHAIN (loclist))
1548 chill_expand_assignment (TREE_VALUE (loclist), modifycode, rhs);
1552 chill_expand_assignment (lhs, modifycode, rhs)
1554 enum chill_tree_code modifycode;
1559 while (TREE_CODE (lhs) == COMPOUND_EXPR)
1561 expand_expr (TREE_OPERAND (lhs, 0), const0_rtx, VOIDmode, 0);
1563 lhs = TREE_OPERAND (lhs, 1);
1566 if (TREE_CODE (lhs) == ERROR_MARK)
1569 /* errors for assignment to BUFFER, EVENT locations.
1570 what about SIGNALs? FIXME: Need similar test in
1571 build_chill_function_call. */
1572 if (TREE_CODE (lhs) == IDENTIFIER_NODE)
1574 tree decl = lookup_name (lhs);
1577 tree type = TREE_TYPE (decl);
1578 if (CH_IS_BUFFER_MODE (type) || CH_IS_EVENT_MODE (type))
1580 error ("You may not assign a value to a BUFFER or EVENT location");
1586 if (TYPE_READONLY_PROPERTY (TREE_TYPE (lhs)) || TREE_READONLY (lhs))
1588 error ("can't assign value to READonly location");
1591 if (CH_TYPE_NONVALUE_P (TREE_TYPE (lhs)))
1593 error ("cannot assign to location with non-value property");
1597 if (TREE_CODE (TREE_TYPE (lhs)) == REFERENCE_TYPE)
1598 lhs = convert_from_reference (lhs);
1600 /* check for lhs is a location */
1604 if (TREE_CODE (loc) == SLICE_EXPR)
1605 loc = TREE_OPERAND (loc, 0);
1606 else if (TREE_CODE (loc) == SET_IN_EXPR)
1607 loc = TREE_OPERAND (loc, 1);
1611 if (! CH_LOCATION_P (loc))
1613 error ("lefthand side of assignment is not a location");
1617 /* If a binary op has been requested, combine the old LHS value with
1618 the RHS producing the value we should actually store into the LHS. */
1620 if (modifycode != NOP_EXPR)
1622 lhs = stabilize_reference (lhs);
1623 /* This is to handle border-line cases such
1624 as: LHS OR := [I]. This seems to be permitted
1625 by the letter of Z.200, though it violates
1626 its spirit, since LHS:=LHS OR [I] is
1628 if (TREE_TYPE (rhs) == NULL_TREE)
1629 rhs = convert (TREE_TYPE (lhs), rhs);
1630 rhs = build_chill_binary_op (modifycode, lhs, rhs);
1633 rhs = chill_convert_for_assignment (TREE_TYPE (lhs), rhs, "assignment");
1635 /* handle the LENGTH (vary_array) := expr action */
1637 if (TREE_CODE (loc) == NOP_EXPR)
1638 loc = TREE_OPERAND (loc, 0);
1639 if (TREE_CODE (loc) == COMPONENT_REF
1640 && chill_varying_type_p (TREE_TYPE (TREE_OPERAND (loc, 0)))
1641 && DECL_NAME (TREE_OPERAND (loc, 1)) == var_length_id)
1643 expand_varying_length_assignment (TREE_OPERAND (loc, 0), rhs);
1645 else if (TREE_CODE (lhs) == SLICE_EXPR)
1647 tree func = lookup_name (get_identifier ("__pscpy"));
1648 tree dst = TREE_OPERAND (lhs, 0);
1649 tree dst_offset = TREE_OPERAND (lhs, 1);
1650 tree length = TREE_OPERAND (lhs, 2);
1651 tree src, src_offset;
1652 if (TREE_CODE (rhs) == SLICE_EXPR)
1654 src = TREE_OPERAND (rhs, 0);
1655 /* Should check that the TREE_OPERAND (src, 0) is
1656 the same as length and powerserlen (src). FIXME */
1657 src_offset = TREE_OPERAND (rhs, 1);
1662 src_offset = integer_zero_node;
1664 expand_expr_stmt (build_chill_function_call (func,
1665 tree_cons (NULL_TREE, force_addr_of (dst),
1666 tree_cons (NULL_TREE, powersetlen (dst),
1667 tree_cons (NULL_TREE, convert (long_unsigned_type_node, dst_offset),
1668 tree_cons (NULL_TREE, force_addr_of (src),
1669 tree_cons (NULL_TREE, powersetlen (src),
1670 tree_cons (NULL_TREE, convert (long_unsigned_type_node, src_offset),
1671 tree_cons (NULL_TREE, convert (long_unsigned_type_node, length),
1675 else if (TREE_CODE (lhs) == SET_IN_EXPR)
1677 tree from_pos = save_expr (TREE_OPERAND (lhs, 0));
1678 tree set = TREE_OPERAND (lhs, 1);
1679 tree domain = TYPE_DOMAIN (TREE_TYPE (set));
1680 tree set_length = size_binop (PLUS_EXPR,
1681 size_binop (MINUS_EXPR,
1682 TYPE_MAX_VALUE (domain),
1683 TYPE_MIN_VALUE (domain)),
1685 tree filename = force_addr_of (get_chill_filename());
1687 if (TREE_CODE (TREE_TYPE (lhs)) != BOOLEAN_TYPE)
1688 sorry("bitstring slice");
1690 build_chill_function_call (lookup_name (
1691 get_identifier ("__setbitpowerset")),
1692 tree_cons (NULL_TREE, build_chill_addr_expr (set, "powerset"),
1693 tree_cons (NULL_TREE, set_length,
1694 tree_cons (NULL_TREE, TYPE_MIN_VALUE (domain),
1695 tree_cons (NULL_TREE, convert (long_integer_type_node, from_pos),
1696 tree_cons (NULL_TREE, rhs,
1697 tree_cons (NULL_TREE, filename,
1698 tree_cons (NULL_TREE, get_chill_linenumber(),
1702 /* Handle arrays of packed bitfields. Currently, this is limited to bitfields
1703 which are 1 bit wide, so use the powerset runtime function. */
1704 else if (TREE_CODE (lhs) == PACKED_ARRAY_REF)
1706 tree from_pos = save_expr (TREE_OPERAND (lhs, 1));
1707 tree array = TREE_OPERAND (lhs, 0);
1708 tree domain = TYPE_DOMAIN (TREE_TYPE (array));
1709 tree array_length = powersetlen (array);
1710 tree filename = force_addr_of (get_chill_filename());
1712 build_chill_function_call (lookup_name (
1713 get_identifier ("__setbitpowerset")),
1714 tree_cons (NULL_TREE, build_chill_addr_expr (array, "packed bitfield array"),
1715 tree_cons (NULL_TREE, convert (long_unsigned_type_node, array_length),
1716 tree_cons (NULL_TREE, convert (long_integer_type_node,
1717 TYPE_MIN_VALUE (domain)),
1718 tree_cons (NULL_TREE, convert (long_integer_type_node, from_pos),
1719 tree_cons (NULL_TREE, build1 (CONVERT_EXPR, boolean_type_node, rhs),
1720 tree_cons (NULL_TREE, filename,
1721 tree_cons (NULL_TREE, get_chill_linenumber(),
1725 /* The following is probably superceded by the
1726 above code for SET_IN_EXPR. FIXME! */
1727 else if (TREE_CODE (lhs) == BIT_FIELD_REF)
1729 tree set = TREE_OPERAND (lhs, 0);
1730 tree numbits = TREE_OPERAND (lhs, 1);
1731 tree from_pos = save_expr (TREE_OPERAND (lhs, 2));
1732 tree domain = TYPE_DOMAIN (TREE_TYPE (set));
1733 tree set_length = size_binop (PLUS_EXPR,
1734 size_binop (MINUS_EXPR,
1735 TYPE_MAX_VALUE (domain),
1736 TYPE_MIN_VALUE (domain)),
1738 tree filename = force_addr_of (get_chill_filename());
1740 switch (TREE_CODE (TREE_TYPE (rhs)))
1743 to_pos = size_binop (MINUS_EXPR,
1744 size_binop (PLUS_EXPR, from_pos, numbits),
1754 if (TREE_CODE (TREE_TYPE (lhs)) != BOOLEAN_TYPE)
1755 sorry("bitstring slice");
1757 build_chill_function_call( lookup_name (
1758 get_identifier ("__setbitpowerset")),
1759 tree_cons (NULL_TREE, build_chill_addr_expr (set, "powerset"),
1760 tree_cons (NULL_TREE, set_length,
1761 tree_cons (NULL_TREE, TYPE_MIN_VALUE (domain),
1762 tree_cons (NULL_TREE, from_pos,
1763 tree_cons (NULL_TREE, rhs,
1764 tree_cons (NULL_TREE, filename,
1765 tree_cons (NULL_TREE, get_chill_linenumber(),
1770 expand_expr_stmt (build_chill_modify_expr (lhs, rhs));
1773 /* Also assumes that rhs has been stabilized */
1775 expand_varying_length_assignment (lhs, rhs)
1778 tree base_array, min_domain_val;
1780 pedwarn ("LENGTH on left-hand-side is non-portable");
1782 if (! CH_LOCATION_P (lhs))
1784 error ("Can only set LENGTH of array location");
1788 /* cause a RANGE exception if rhs would cause a 'hole' in the array. */
1789 rhs = valid_array_index_p (lhs, rhs, "new array length too large", 1);
1791 base_array = CH_VARYING_ARRAY_TYPE (TREE_TYPE (lhs));
1792 min_domain_val = TYPE_MIN_VALUE (TYPE_DOMAIN (base_array));
1794 lhs = build_component_ref (lhs, var_length_id);
1795 rhs = size_binop (MINUS_EXPR, rhs, min_domain_val);
1797 expand_expr_stmt (build_chill_modify_expr (lhs, rhs));
1806 emit_line_note (input_filename, lineno);