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
6 This file is part of GNU CC.
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)
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.
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. */
36 static int id_cmp
PARAMS ((tree
*, tree
*));
37 static void warn_unhandled
PARAMS ((const char *));
38 static tree adjust_return_value
PARAMS ((tree
, const char *));
39 static tree update_else_range_for_int_const
PARAMS ((tree
, tree
));
40 static tree update_else_range_for_range
PARAMS ((tree
, tree
, tree
));
41 static tree update_else_range_for_range_expr
PARAMS ((tree
, tree
));
42 static tree update_else_range_for_type
PARAMS ((tree
, tree
));
43 static tree compute_else_range
PARAMS ((tree
, tree
, int));
44 static tree check_case_value
PARAMS ((tree
, tree
));
45 static void chill_handle_case_label_range
PARAMS ((tree
, tree
, tree
));
46 static tree chill_handle_multi_case_label_range
PARAMS ((tree
, tree
, tree
));
47 static tree chill_handle_multi_case_else_label
PARAMS ((tree
));
48 static tree chill_handle_multi_case_label
PARAMS ((tree
, tree
));
49 static tree chill_handle_multi_case_label_list
PARAMS ((tree
, tree
));
50 static void print_missing_cases
PARAMS ((tree
, const unsigned char *, long));
52 #define obstack_chunk_alloc xmalloc
53 #define obstack_chunk_free free
55 /* reserved tag definitions */
58 #define TAG_OBJECT "chill_object"
59 #define TAG_CLASS "chill_class"
61 extern int flag_short_enums
;
62 extern int current_nesting_level
;
64 extern struct obstack
*expression_obstack
, permanent_obstack
;
65 extern struct obstack
*current_obstack
, *saveable_obstack
;
67 /* This flag is checked throughout the non-CHILL-specific
69 tree chill_integer_type_node
;
70 tree chill_unsigned_type_node
;
72 /* Never used. Referenced from c-typeck.c, which we use. */
73 int current_function_returns_value
= 0;
74 int current_function_returns_null
= 0;
76 /* data imported from toplev.c */
78 extern char *dump_base_name
;
80 /* set from command line parameter, to exit after
81 grant file written, generating no code. */
82 int grant_only_flag
= 0;
97 print_lang_statistics ()
106 extern int errorcount
, sorrycount
;
108 /* this should be the last action in compiling a module.
109 If there are other actions to be performed at lang_finish
110 please insert before this */
112 /* FIXME: in case of a syntax error, this leaves the grant file incomplete */
113 /* for the moment we print a warning in case of errors and
115 if ((errorcount
|| sorrycount
) && grant_count
)
117 warning ("%d errors, %d sorries, do granting", errorcount
, sorrycount
);
118 errorcount
= sorrycount
= 0;
124 chill_check_decl (decl
)
127 tree type
= TREE_TYPE (decl
);
128 static int alreadyWarned
= 0;
130 if (TREE_CODE (type
) == RECORD_TYPE
) /* && TREE_STATIC_TEMPLATE (type)) */
134 error ("GNU compiler does not support statically allocated objects");
137 error_with_decl (decl
, "`%s' cannot be statically allocated");
141 /* Comparison function for sorting identifiers in RAISES lists.
142 Note that because IDENTIFIER_NODEs are unique, we can sort
143 them by address, saving an indirection. */
148 long diff
= (long)TREE_VALUE (*p1
) - (long)TREE_VALUE (*p2
);
150 return (diff
< 0) ? -1 : (diff
> 0);
153 /* Build the FUNCTION_TYPE or METHOD_TYPE which may raise exceptions
156 build_exception_variant (type
, raises
)
160 tree v
= TYPE_MAIN_VARIANT (type
);
162 int constp
= TYPE_READONLY (type
);
163 int volatilep
= TYPE_VOLATILE (type
);
166 return build_type_variant (v
, constp
, volatilep
);
168 if (TREE_CHAIN (raises
))
169 { /* Sort the list */
170 tree
*a
= (tree
*)alloca ((list_length (raises
)+1) * sizeof (tree
));
171 for (i
= 0, t
= raises
; t
; t
= TREE_CHAIN (t
), i
++)
173 /* NULL terminator for list. */
175 qsort (a
, i
, sizeof (tree
),
176 (int (*) PARAMS ((const void*, const void*))) id_cmp
);
178 TREE_CHAIN (a
[i
]) = a
[i
+1];
182 for (v
= TYPE_NEXT_VARIANT (v
); v
; v
= TYPE_NEXT_VARIANT (v
))
184 if (TYPE_READONLY (v
) != constp
185 || TYPE_VOLATILE (v
) != volatilep
)
189 t2
= TYPE_RAISES_EXCEPTIONS (v
);
192 if (TREE_TYPE (t
) == TREE_TYPE (t2
))
195 t2
= TREE_CHAIN (t2
);
201 /* List of exceptions raised matches previously found list.
203 @@ Nice to free up storage used in consing up the
204 @@ list of exceptions raised. */
208 /* Need to build a new variant. */
209 if (TREE_PERMANENT (type
))
211 push_obstacks_nochange ();
212 end_temporary_allocation ();
213 v
= copy_node (type
);
217 v
= copy_node (type
);
219 TYPE_NEXT_VARIANT (v
) = TYPE_NEXT_VARIANT (type
);
220 TYPE_NEXT_VARIANT (type
) = v
;
221 if (raises
&& ! TREE_PERMANENT (raises
))
223 push_obstacks_nochange ();
224 end_temporary_allocation ();
225 raises
= copy_list (raises
);
228 TYPE_RAISES_EXCEPTIONS (v
) = raises
;
234 build_rts_call (name
, type
, args
)
238 tree decl
= lookup_name (get_identifier (name
));
239 tree converted_args
= NULL_TREE
;
240 tree result
, length
= NULL_TREE
;
242 assert (decl
!= NULL_TREE
);
245 tree arg
= TREE_VALUE (args
);
246 if (TREE_CODE (TREE_TYPE (arg
)) == SET_TYPE
247 || TREE_CODE (TREE_TYPE (arg
)) == ARRAY_TYPE
)
249 length
= size_in_bytes (TREE_TYPE (arg
));
250 arg
= build_chill_addr_expr (arg
, (char *)0);
252 converted_args
= tree_cons (NULL_TREE
, arg
, converted_args
);
253 args
= TREE_CHAIN (args
);
255 if (length
!= NULL_TREE
)
256 converted_args
= tree_cons (NULL_TREE
, length
, converted_args
);
257 converted_args
= nreverse (converted_args
);
258 result
= build_chill_function_call (decl
, converted_args
);
259 if (TREE_CODE (type
) == SET_TYPE
|| TREE_CODE (type
) == ARRAY_TYPE
)
260 result
= build1 (INDIRECT_REF
, type
, result
);
262 result
= convert (type
, result
);
268 * queue name of unhandled exception
269 * to avoid multiple unhandled warnings
270 * in one compilation module
275 struct already_type
*next
;
279 static struct already_type
*already_warned
= 0;
285 struct already_type
*p
= already_warned
;
289 if (!strcmp (p
->name
, ex
))
295 p
= (struct already_type
*)xmalloc (sizeof (struct already_type
));
296 p
->next
= already_warned
;
297 p
->name
= xstrdup (ex
);
299 pedwarn ("causing unhandled exception `%s' (this is flaged only once)", ex
);
303 * build a call to the following function:
304 * void __cause_ex1 (char* ex, const char *file,
305 * const unsigned lineno);
306 * if the exception is handled or
307 * void __unhandled_ex (char *ex, char *file, unsigned lineno)
308 * if the exception is not handled.
311 build_cause_exception (exp_name
, warn_if_unhandled
)
313 int warn_if_unhandled
;
315 /* We don't use build_rts_call() here, because the string (array of char)
316 would be followed by its length in the parameter list built by
317 build_rts_call, and the runtime routine doesn't want a length parameter.*/
318 tree exp_decl
= build_chill_exception_decl (IDENTIFIER_POINTER (exp_name
));
319 tree function
, fname
, lineno
, result
;
320 int handled
= is_handled (exp_name
);
326 if (warn_if_unhandled
)
327 warn_unhandled (IDENTIFIER_POINTER (exp_name
));
328 function
= lookup_name (get_identifier ("__unhandled_ex"));
329 fname
= force_addr_of (get_chill_filename ());
330 lineno
= get_chill_linenumber ();
334 function
= lookup_name (get_identifier ("__cause_ex1"));
335 fname
= force_addr_of (get_chill_filename ());
336 lineno
= get_chill_linenumber ();
339 /* function may propagate this exception */
340 function
= lookup_name (get_identifier ("__cause_ex1"));
341 fname
= lookup_name (get_identifier (CALLER_FILE
));
342 if (fname
== NULL_TREE
)
343 fname
= error_mark_node
;
344 lineno
= lookup_name (get_identifier (CALLER_LINE
));
345 if (lineno
== NULL_TREE
)
346 lineno
= error_mark_node
;
352 build_chill_function_call (function
,
353 tree_cons (NULL_TREE
, build_chill_addr_expr (exp_decl
, (char *)0),
354 tree_cons (NULL_TREE
, fname
,
355 tree_cons (NULL_TREE
, lineno
, NULL_TREE
))));
360 expand_cause_exception (exp_name
)
363 expand_expr_stmt (build_cause_exception (exp_name
, 1));
366 /* If CONDITION is true, raise EXCEPTION (an IDENTIFIER_NODE);
367 otherwise return EXPR. */
370 check_expression (expr
, condition
, exception
)
371 tree expr
, condition
, exception
;
373 if (integer_zerop (condition
))
376 return build (COMPOUND_EXPR
, TREE_TYPE (expr
),
377 fold (build (TRUTH_ANDIF_EXPR
, boolean_type_node
,
378 condition
, build_cause_exception (exception
, 0))),
382 /* Return an expression for VALUE < LO_LIMIT || VALUE > HI_LIMIT,
383 somewhat optimized and with some warnings suppressed.
384 If LO_LIMIT or HI_LIMIT is NULL_TREE, assume that (sub-)test passes. */
387 test_range (value
, lo_limit
, hi_limit
)
388 tree value
, lo_limit
, hi_limit
;
390 if (lo_limit
|| hi_limit
)
392 int old_inhibit_warnings
= inhibit_warnings
;
393 tree lo_check
, hi_check
, check
;
395 /* This is a hack so that `shorten_compare' doesn't warn the
396 user about useless range checks that are too much work to
397 optimize away here. */
398 inhibit_warnings
= 1;
400 lo_check
= lo_limit
?
401 fold (build_compare_discrete_expr (LT_EXPR
, value
, lo_limit
)) :
402 boolean_false_node
; /* fake passing the check */
404 hi_check
= hi_limit
?
405 fold (build_compare_discrete_expr (GT_EXPR
, value
, hi_limit
)) :
406 boolean_false_node
; /* fake passing the check */
408 if (lo_check
== boolean_false_node
)
410 else if (hi_check
== boolean_false_node
)
413 check
= fold (build (TRUTH_ORIF_EXPR
, boolean_type_node
,
414 lo_check
, hi_check
));
416 inhibit_warnings
= old_inhibit_warnings
;
420 return boolean_false_node
;
423 /* Return EXPR, except if range_checking is on, return an expression
424 that also checks that value >= low_limit && value <= hi_limit.
425 If LO_LIMIT or HI_LIMIT is NULL_TREE, assume that test passes. */
428 check_range (expr
, value
, lo_limit
, hi_limit
)
429 tree expr
, value
, lo_limit
, hi_limit
;
431 tree check
= test_range (value
, lo_limit
, hi_limit
);
432 if (!integer_zerop (check
))
434 if (current_function_decl
== NULL_TREE
)
436 if (TREE_CODE (check
) == INTEGER_CST
)
437 error ("range failure (not inside function)");
439 warning ("possible range failure (not inside function)");
443 if (TREE_CODE (check
) == INTEGER_CST
)
444 warning ("expression will always cause RANGEFAIL");
446 expr
= check_expression (expr
, check
,
447 ridpointers
[(int) RID_RANGEFAIL
]);
453 /* Same as EXPR, except raise EMPTY if EXPR is NULL. */
456 check_non_null (expr
)
461 expr
= save_if_needed (expr
);
462 return check_expression (expr
,
463 build_compare_expr (EQ_EXPR
,
464 expr
, null_pointer_node
),
465 ridpointers
[(int) RID_EMPTY
]);
470 /* There are four conditions to generate a runtime check:
471 1) assigning a longer INT to a shorter (signs irrelevant)
472 2) assigning a signed to an unsigned
473 3) assigning an unsigned to a signed of the same size.
474 4) TYPE is a discrete subrange */
477 chill_convert_for_assignment (type
, expr
, place
)
479 const char *place
; /* location description for error messages */
482 tree etype
= TREE_TYPE (expr
);
485 if (type
== NULL_TREE
|| TREE_CODE (type
) == ERROR_MARK
)
486 return error_mark_node
;
487 if (expr
== NULL_TREE
|| TREE_CODE (expr
) == ERROR_MARK
)
489 if (TREE_CODE (expr
) == TYPE_DECL
)
491 error ("right hand side of assignment is a mode");
492 return error_mark_node
;
495 if (! CH_COMPATIBLE (expr
, type
))
497 error ("incompatible modes in %s", place
);
498 return error_mark_node
;
501 if (TREE_CODE (type
) == REFERENCE_TYPE
)
502 ttype
= TREE_TYPE (ttype
);
503 if (etype
&& TREE_CODE (etype
) == REFERENCE_TYPE
)
504 etype
= TREE_TYPE (etype
);
507 && (CH_STRING_TYPE_P (ttype
)
508 || (chill_varying_type_p (ttype
)
509 && CH_STRING_TYPE_P (CH_VARYING_ARRAY_TYPE (ttype
))))
510 && (CH_STRING_TYPE_P (etype
)
511 || (chill_varying_type_p (etype
)
512 && CH_STRING_TYPE_P (CH_VARYING_ARRAY_TYPE (etype
)))))
516 expr
= save_if_needed (expr
);
517 cond
= string_assignment_condition (ttype
, expr
);
518 if (TREE_CODE (cond
) == INTEGER_CST
)
520 if (integer_zerop (cond
))
522 error ("bad string length in %s", place
);
523 return error_mark_node
;
525 /* Otherwise, the condition is always true, so no runtime test. */
527 else if (range_checking
)
528 expr
= check_expression (expr
,
529 invert_truthvalue (cond
),
530 ridpointers
[(int) RID_RANGEFAIL
]);
534 && discrete_type_p (ttype
)
535 && etype
!= NULL_TREE
536 && discrete_type_p (etype
))
538 int cond1
= tree_int_cst_lt (TYPE_SIZE (ttype
),
540 int cond2
= TREE_UNSIGNED (ttype
)
541 && (! TREE_UNSIGNED (etype
));
542 int cond3
= (! TREE_UNSIGNED (type
))
543 && TREE_UNSIGNED (etype
)
544 && tree_int_cst_equal (TYPE_SIZE (ttype
),
546 int cond4
= TREE_TYPE (ttype
)
547 && discrete_type_p (TREE_TYPE (ttype
));
549 if (cond1
|| cond2
|| cond3
|| cond4
)
551 tree type_min
= TYPE_MIN_VALUE (ttype
);
552 tree type_max
= TYPE_MAX_VALUE (ttype
);
554 expr
= save_if_needed (expr
);
555 if (expr
&& type_min
&& type_max
)
556 expr
= check_range (expr
, expr
, type_min
, type_max
);
559 result
= convert (type
, expr
);
561 /* If the type is a array of PACK bits and the expression is an array
562 constructor, then build a CONSTRUCTOR for a bitstring. Bitstrings are
563 zero based, so decrement the value of each CONSTRUCTOR element by the
564 amount of the lower bound of the array. */
565 if (TREE_CODE (type
) == ARRAY_TYPE
&& TYPE_PACKED (type
)
566 && TREE_CODE (result
) == CONSTRUCTOR
)
568 tree domain_min
= TYPE_MIN_VALUE (TYPE_DOMAIN (type
));
569 tree new_list
= NULL_TREE
;
570 unsigned HOST_WIDE_INT index
;
573 for (element
= TREE_OPERAND (result
, 1);
574 element
!= NULL_TREE
;
575 element
= TREE_CHAIN (element
))
577 if (!tree_int_cst_equal (TREE_VALUE (element
), integer_zero_node
))
579 tree purpose
= TREE_PURPOSE (element
);
580 switch (TREE_CODE (purpose
))
584 = tree_cons (NULL_TREE
,
585 fold (build (MINUS_EXPR
, TREE_TYPE (purpose
),
586 purpose
, domain_min
)),
590 for (index
= TREE_INT_CST_LOW (TREE_OPERAND (purpose
, 0));
591 index
<= TREE_INT_CST_LOW (TREE_OPERAND (purpose
, 1));
593 new_list
= tree_cons (NULL_TREE
,
594 fold (build (MINUS_EXPR
,
596 build_int_2 (index
, 0),
605 result
= copy_node (result
);
606 TREE_OPERAND (result
, 1) = nreverse (new_list
);
607 TREE_TYPE (result
) = build_bitstring_type (TYPE_SIZE (type
));
613 /* Check that EXPR has valid type for a RETURN or RESULT expression,
614 converting to the right type. ACTION is "RESULT" or "RETURN". */
617 adjust_return_value (expr
, action
)
621 tree type
= TREE_TYPE (TREE_TYPE (current_function_decl
));
623 if (TREE_CODE (type
) == REFERENCE_TYPE
)
625 if (CH_LOCATION_P (expr
))
627 if (! CH_READ_COMPATIBLE (TREE_TYPE (type
),
630 error ("mode mismatch in %s expression", action
);
631 return error_mark_node
;
633 return convert (type
, expr
);
637 error ("%s expression must be referable", action
);
638 return error_mark_node
;
641 else if (! CH_COMPATIBLE (expr
, type
))
643 error ("mode mismatch in %s expression", action
);
644 return error_mark_node
;
646 return convert (type
, expr
);
650 chill_expand_result (expr
, result_or_return
)
652 int result_or_return
;
655 const char *action_name
= result_or_return
? "RESULT" : "RETURN";
660 if (expr
== NULL_TREE
|| TREE_CODE (expr
) == ERROR_MARK
)
663 CH_FUNCTION_SETS_RESULT (current_function_decl
) = 1;
665 if (chill_at_module_level
|| global_bindings_p ())
666 error ("%s not allowed outside a PROC", action_name
);
668 result_never_set
= 0;
670 if (chill_result_decl
== NULL_TREE
)
672 error ("%s action in PROC with no declared RESULTS", action_name
);
675 type
= TREE_TYPE (chill_result_decl
);
677 if (TREE_CODE (type
) == ERROR_MARK
)
680 expr
= adjust_return_value (expr
, action_name
);
682 expand_expr_stmt (build_chill_modify_expr (chill_result_decl
, expr
));
686 * error if EXPR not NULL and procedure doesn't
687 * have a return type;
688 * warning if EXPR NULL,
689 * procedure *has* a return type, and a previous
690 * RESULT actions hasn't saved a return value.
693 chill_expand_return (expr
, implicit
)
695 int implicit
; /* 1 if an implicit return at end of function. */
699 if (expr
!= NULL_TREE
&& TREE_CODE (expr
) == ERROR_MARK
)
701 if (chill_at_module_level
|| global_bindings_p ())
703 error ("RETURN not allowed outside PROC");
710 result_never_set
= 0;
712 valtype
= TREE_TYPE (TREE_TYPE (current_function_decl
));
713 if (TREE_CODE (valtype
) == VOID_TYPE
)
715 if (expr
!= NULL_TREE
)
716 error ("RETURN with a value, in PROC returning void");
717 expand_null_return ();
719 else if (TREE_CODE (valtype
) != ERROR_MARK
)
721 if (expr
== NULL_TREE
)
723 if (!CH_FUNCTION_SETS_RESULT (current_function_decl
)
725 warning ("RETURN with no value and no RESULT action in procedure");
726 expr
= chill_result_decl
;
729 expr
= adjust_return_value (expr
, "RETURN");
730 expr
= build (MODIFY_EXPR
, valtype
,
731 DECL_RESULT (current_function_decl
),
733 TREE_SIDE_EFFECTS (expr
) = 1;
734 expand_return (expr
);
739 lookup_and_expand_goto (name
)
742 if (name
== NULL_TREE
|| TREE_CODE (name
) == ERROR_MARK
)
746 tree decl
= lookup_name (name
);
747 if (decl
== NULL
|| TREE_CODE (decl
) != LABEL_DECL
)
748 error ("no label named `%s'", IDENTIFIER_POINTER (name
));
749 else if (DECL_CONTEXT (decl
) != current_function_decl
)
750 error ("cannot GOTO label `%s' outside current function",
751 IDENTIFIER_POINTER (name
));
754 TREE_USED (decl
) = 1;
755 expand_goto_except_cleanup (DECL_ACTION_NESTING_LEVEL (decl
));
762 lookup_and_handle_exit (name
)
765 if (name
== NULL_TREE
|| TREE_CODE (name
) == ERROR_MARK
)
769 tree label
= munge_exit_label (name
);
770 tree decl
= lookup_name (label
);
771 if (decl
== NULL
|| TREE_CODE (decl
) != LABEL_DECL
)
772 error ("no EXITable label named `%s'", IDENTIFIER_POINTER (name
));
773 else if (DECL_CONTEXT (decl
) != current_function_decl
)
774 error ("cannot EXIT label `%s' outside current function",
775 IDENTIFIER_POINTER (name
));
778 TREE_USED (decl
) = 1;
779 expand_goto_except_cleanup (DECL_ACTION_NESTING_LEVEL (decl
));
785 /* ELSE-range handling: The else-range is a chain of trees which collectively
786 represent the ranges to be tested for the (ELSE) case label. Each element in
787 the chain represents a range to be tested. The boundaries of the range are
788 represented by INTEGER_CST trees in the PURPOSE and VALUE fields. */
790 /* This function updates the else-range by removing the given integer constant. */
792 update_else_range_for_int_const (else_range
, label
)
793 tree else_range
, label
;
795 int lowval
= 0, highval
= 0;
796 int label_value
= TREE_INT_CST_LOW (label
);
797 tree this_range
, prev_range
, new_range
;
799 /* First, find the range element containing the integer, if it exists. */
800 prev_range
= NULL_TREE
;
801 for (this_range
= else_range
;
802 this_range
!= NULL_TREE
;
803 this_range
= TREE_CHAIN (this_range
))
805 lowval
= TREE_INT_CST_LOW (TREE_PURPOSE (this_range
));
806 highval
= TREE_INT_CST_LOW (TREE_VALUE (this_range
));
807 if (label_value
>= lowval
&& label_value
<= highval
)
809 prev_range
= this_range
;
812 /* If a range element containing the integer was found, then update the range. */
813 if (this_range
!= NULL_TREE
)
815 tree next
= TREE_CHAIN (this_range
);
816 if (label_value
== lowval
)
818 /* The integer is the lower bound of the range element. If it is also the
819 upper bound, then remove this range element, otherwise update it. */
820 if (label_value
== highval
)
822 if (prev_range
== NULL_TREE
)
825 TREE_CHAIN (prev_range
) = next
;
828 TREE_PURPOSE (this_range
) = build_int_2 (label_value
+ 1, 0);
830 else if (label_value
== highval
)
832 /* The integer is the upper bound of the range element, so ajust it. */
833 TREE_VALUE (this_range
) = build_int_2 (label_value
- 1, 0);
837 /* The integer is in the middle of the range element, so split it. */
838 new_range
= tree_cons (
839 build_int_2 (label_value
+ 1, 0), TREE_VALUE (this_range
), next
);
840 TREE_VALUE (this_range
) = build_int_2 (label_value
- 1, 0);
841 TREE_CHAIN (this_range
) = new_range
;
847 /* Update the else-range to remove a range of values/ */
849 update_else_range_for_range (else_range
, low_target
, high_target
)
850 tree else_range
, low_target
, high_target
;
852 tree this_range
, prev_range
, new_range
, next_range
;
853 int low_range_val
= 0, high_range_val
= 0;
854 int low_target_val
= TREE_INT_CST_LOW (low_target
);
855 int high_target_val
= TREE_INT_CST_LOW (high_target
);
857 /* find the first else-range element which overlaps the target range. */
858 prev_range
= NULL_TREE
;
859 for (this_range
= else_range
;
860 this_range
!= NULL_TREE
;
861 this_range
= TREE_CHAIN (this_range
))
863 low_range_val
= TREE_INT_CST_LOW (TREE_PURPOSE (this_range
));
864 high_range_val
= TREE_INT_CST_LOW (TREE_VALUE (this_range
));
865 if ((low_target_val
>= low_range_val
&& low_target_val
<= high_range_val
)
866 || (high_target_val
>= low_range_val
&& high_target_val
<= high_range_val
))
868 prev_range
= this_range
;
870 if (this_range
== NULL_TREE
)
873 /* This first else-range element might be truncated at the top or completely
874 contain the target range. */
875 if (low_range_val
< low_target_val
)
877 next_range
= TREE_CHAIN (this_range
);
878 if (high_range_val
> high_target_val
)
880 new_range
= tree_cons (
881 build_int_2 (high_target_val
+ 1, 0), TREE_VALUE (this_range
), next_range
);
882 TREE_VALUE (this_range
) = build_int_2 (low_target_val
- 1, 0);
883 TREE_CHAIN (this_range
) = new_range
;
887 TREE_VALUE (this_range
) = build_int_2 (low_target_val
- 1, 0);
888 if (next_range
== NULL_TREE
)
891 prev_range
= this_range
;
892 this_range
= next_range
;
893 high_range_val
= TREE_INT_CST_LOW (TREE_VALUE (this_range
));
896 /* There may then follow zero or more else-range elements which are completely
897 contained in the target range. */
898 while (high_range_val
<= high_target_val
)
900 this_range
= TREE_CHAIN (this_range
);
901 if (prev_range
== NULL_TREE
)
902 else_range
= this_range
;
904 TREE_CHAIN (prev_range
) = this_range
;
906 if (this_range
== NULL_TREE
)
908 high_range_val
= TREE_INT_CST_LOW (TREE_VALUE (this_range
));
911 /* Finally, there may be a else-range element which is truncated at the bottom. */
912 low_range_val
= TREE_INT_CST_LOW (TREE_PURPOSE (this_range
));
913 if (low_range_val
<= high_target_val
)
914 TREE_PURPOSE (this_range
) = build_int_2 (high_target_val
+ 1, 0);
920 update_else_range_for_range_expr (else_range
, label
)
921 tree else_range
, label
;
923 if (TREE_OPERAND (label
, 0) == NULL_TREE
)
925 if (TREE_OPERAND (label
, 1) == NULL_TREE
)
926 else_range
= NULL_TREE
; /* (*) -- matches everything */
929 else_range
= update_else_range_for_range (
930 else_range
, TREE_OPERAND (label
, 0), TREE_OPERAND (label
, 1));
936 update_else_range_for_type (else_range
, label
)
937 tree else_range
, label
;
939 tree type
= TREE_TYPE (label
);
940 else_range
= update_else_range_for_range (
941 else_range
, TYPE_MIN_VALUE (type
), TYPE_MAX_VALUE (type
));
946 compute_else_range (selector
, alternatives
, selector_no
)
947 tree selector
, alternatives
;
950 /* Start with an else-range that spans the entire range of the selector type. */
951 tree type
= TREE_TYPE (TREE_VALUE (selector
));
952 tree range
= tree_cons (TYPE_MIN_VALUE (type
), TYPE_MAX_VALUE (type
), NULL_TREE
);
954 /* Now remove the values represented by each case lebel specified for that
955 selector. The remaining range is the else-range. */
956 for ( ; alternatives
!= NULL_TREE
; alternatives
= TREE_CHAIN (alternatives
))
959 tree label_list
= TREE_PURPOSE (alternatives
);
961 for (this_selector
= 0; this_selector
< selector_no
; ++this_selector
)
962 label_list
= TREE_CHAIN (label_list
);
964 for (label
= TREE_VALUE (label_list
);
966 label
= TREE_CHAIN (label
))
968 tree label_value
= TREE_VALUE (label
);
969 if (TREE_CODE (label_value
) == INTEGER_CST
)
970 range
= update_else_range_for_int_const (range
, label_value
);
971 else if (TREE_CODE (label_value
) == RANGE_EXPR
)
972 range
= update_else_range_for_range_expr (range
, label_value
);
973 else if (TREE_CODE (label_value
) == TYPE_DECL
)
974 range
= update_else_range_for_type (range
, label_value
);
976 if (range
== NULL_TREE
)
985 compute_else_ranges (selectors
, alternatives
)
986 tree selectors
, alternatives
;
991 for (selector
= selectors
; selector
!= NULL_TREE
; selector
= TREE_CHAIN (selector
))
993 if (ELSE_LABEL_SPECIFIED (selector
))
994 TREE_PURPOSE (selector
) =
995 compute_else_range (selector
, alternatives
, selector_no
);
1001 check_case_value (label_value
, selector
)
1002 tree label_value
, selector
;
1004 if (TREE_CODE (label_value
) == ERROR_MARK
)
1006 if (TREE_CODE (selector
) == ERROR_MARK
)
1009 /* Z.200 (6.4 Case action) says: "The class of any discrete expression
1010 in the case selector list must be compatible with the corresponding
1011 (by position) class of the resulting list of classes of the case label
1012 list occurrences ...". We don't actually construct the resulting
1013 list of classes, but this test should be more-or-less equivalent.
1015 if (!CH_COMPATIBLE_CLASSES (selector
, label_value
))
1017 error ("case selector not compatible with label");
1018 return error_mark_node
;
1021 /* Strip NON_LVALUE_EXPRs since we aren't using as an lvalue. */
1022 STRIP_TYPE_NOPS (label_value
);
1024 if (TREE_CODE (label_value
) != INTEGER_CST
)
1026 error ("case label does not reduce to an integer constant");
1027 return error_mark_node
;
1030 constant_expression_warning (label_value
);
1035 chill_handle_case_default ()
1038 register tree label
= build_decl (LABEL_DECL
, NULL_TREE
,
1040 int success
= pushcase (NULL_TREE
, 0, label
, &duplicate
);
1043 error ("ELSE label not within a CASE statement");
1045 else if (success
== 2)
1047 error ("multiple default labels found in a CASE statement");
1048 error_with_decl (duplicate
, "this is the first ELSE label");
1053 /* Handle cases label such as (I:J): or (modename): */
1056 chill_handle_case_label_range (min_value
, max_value
, selector
)
1057 tree min_value
, max_value
, selector
;
1059 register tree label
= build_decl (LABEL_DECL
, NULL_TREE
, NULL_TREE
);
1060 min_value
= check_case_value (min_value
, selector
);
1061 max_value
= check_case_value (max_value
, selector
);
1062 if (TREE_CODE (min_value
) != ERROR_MARK
1063 && TREE_CODE (max_value
) != ERROR_MARK
)
1066 int success
= pushcase_range (min_value
, max_value
,
1067 convert
, label
, &duplicate
);
1069 error ("label found outside of CASE statement");
1070 else if (success
== 2)
1072 error ("duplicate CASE value");
1073 error_with_decl (duplicate
, "this is the first entry for that value");
1075 else if (success
== 3)
1076 error ("CASE value out of range");
1077 else if (success
== 4)
1078 error ("empty range");
1079 else if (success
== 5)
1080 error ("label within scope of cleanup or variable array");
1085 chill_handle_case_label (label_value
, selector
)
1086 tree label_value
, selector
;
1088 if (label_value
== NULL_TREE
1089 || TREE_CODE (label_value
) == ERROR_MARK
)
1091 if (TREE_CODE (label_value
) == RANGE_EXPR
)
1093 if (TREE_OPERAND (label_value
, 0) == NULL_TREE
)
1094 chill_handle_case_default (); /* i.e. (ELSE): or (*): */
1096 chill_handle_case_label_range (TREE_OPERAND (label_value
, 0),
1097 TREE_OPERAND (label_value
, 1),
1100 else if (TREE_CODE (label_value
) == TYPE_DECL
)
1102 tree type
= TREE_TYPE (label_value
);
1103 if (! discrete_type_p (type
))
1104 error ("mode in label is not discrete");
1106 chill_handle_case_label_range (TYPE_MIN_VALUE (type
),
1107 TYPE_MAX_VALUE (type
),
1112 register tree label
= build_decl (LABEL_DECL
, NULL_TREE
, NULL_TREE
);
1114 label_value
= check_case_value (label_value
, selector
);
1116 if (TREE_CODE (label_value
) != ERROR_MARK
)
1119 int success
= pushcase (label_value
, convert
, label
, &duplicate
);
1121 error ("label not within a CASE statement");
1122 else if (success
== 2)
1124 error ("duplicate case value");
1125 error_with_decl (duplicate
,
1126 "this is the first entry for that value");
1128 else if (success
== 3)
1129 error ("CASE value out of range");
1130 else if (success
== 4)
1131 error ("empty range");
1132 else if (success
== 5)
1133 error ("label within scope of cleanup or variable array");
1139 chill_handle_single_dimension_case_label (
1140 selector
, label_spec
, expand_exit_needed
, caseaction_flag
1142 tree selector
, label_spec
;
1143 int *expand_exit_needed
, *caseaction_flag
;
1145 tree labels
, one_label
;
1146 int no_completeness_check
= 0;
1148 if (*expand_exit_needed
|| *caseaction_flag
== 1)
1150 expand_exit_something ();
1151 *expand_exit_needed
= 0;
1154 for (labels
= label_spec
; labels
!= NULL_TREE
; labels
= TREE_CHAIN (labels
))
1155 for (one_label
= TREE_VALUE (labels
); one_label
!= NULL_TREE
;
1156 one_label
= TREE_CHAIN (one_label
))
1158 if (TREE_VALUE (one_label
) == case_else_node
)
1159 no_completeness_check
= 1;
1161 chill_handle_case_label (TREE_VALUE (one_label
), selector
);
1164 *caseaction_flag
= 1;
1166 return no_completeness_check
;
1170 chill_handle_multi_case_label_range (low
, high
, selector
)
1171 tree low
, high
, selector
;
1173 tree low_expr
, high_expr
, and_expr
;
1175 int low_target_val
, high_target_val
;
1176 int low_type_val
, high_type_val
;
1178 /* we can eliminate some tests is the low and/or high value in the given range
1179 are outside the range of the selector type. */
1180 low_target_val
= TREE_INT_CST_LOW (low
);
1181 high_target_val
= TREE_INT_CST_LOW (high
);
1182 selector_type
= TREE_TYPE (selector
);
1183 low_type_val
= TREE_INT_CST_LOW (TYPE_MIN_VALUE (selector_type
));
1184 high_type_val
= TREE_INT_CST_LOW (TYPE_MAX_VALUE (selector_type
));
1186 if (low_target_val
> high_type_val
|| high_target_val
< low_type_val
)
1187 return boolean_false_node
; /* selector never in range */
1189 if (low_type_val
>= low_target_val
)
1191 if (high_type_val
<= high_target_val
)
1192 return boolean_true_node
; /* always in the range */
1193 return build_compare_expr (LE_EXPR
, selector
, high
);
1196 if (high_type_val
<= high_target_val
)
1197 return build_compare_expr (GE_EXPR
, selector
, low
);
1199 /* The target range in completely within the range of the selector, but we
1200 might be able to save a test if the upper bound is the same as the lower
1202 if (low_target_val
== high_target_val
)
1203 return build_compare_expr (EQ_EXPR
, selector
, low
);
1205 /* No optimizations possible. Just generate tests against the upper and lower
1206 bound of the target */
1207 low_expr
= build_compare_expr (GE_EXPR
, selector
, low
);
1208 high_expr
= build_compare_expr (LE_EXPR
, selector
, high
);
1209 and_expr
= build_chill_binary_op (TRUTH_ANDIF_EXPR
, low_expr
, high_expr
);
1215 chill_handle_multi_case_else_label (selector
)
1218 tree else_range
, selector_value
, selector_type
;
1219 tree low
, high
, larg
;
1221 else_range
= TREE_PURPOSE (selector
);
1222 if (else_range
== NULL_TREE
)
1223 return boolean_false_node
; /* no values in ELSE range */
1225 /* Test each of the ranges in the else-range chain */
1226 selector_value
= TREE_VALUE (selector
);
1227 selector_type
= TREE_TYPE (selector_value
);
1228 low
= convert (selector_type
, TREE_PURPOSE (else_range
));
1229 high
= convert (selector_type
, TREE_VALUE (else_range
));
1230 larg
= chill_handle_multi_case_label_range (low
, high
, selector_value
);
1232 for (else_range
= TREE_CHAIN (else_range
);
1233 else_range
!= NULL_TREE
;
1234 else_range
= TREE_CHAIN (else_range
))
1237 low
= convert (selector_type
, TREE_PURPOSE (else_range
));
1238 high
= convert (selector_type
, TREE_VALUE (else_range
));
1239 rarg
= chill_handle_multi_case_label_range (low
, high
, selector_value
);
1240 larg
= build_chill_binary_op (TRUTH_ORIF_EXPR
, larg
, rarg
);
1247 chill_handle_multi_case_label (selector
, label
)
1248 tree selector
, label
;
1250 tree expr
= NULL_TREE
;
1252 if (label
== NULL_TREE
|| TREE_CODE (label
) == ERROR_MARK
)
1255 if (TREE_CODE (label
) == INTEGER_CST
)
1257 int target_val
= TREE_INT_CST_LOW (label
);
1258 tree selector_type
= TREE_TYPE (TREE_VALUE (selector
));
1259 int low_type_val
= TREE_INT_CST_LOW (TYPE_MIN_VALUE (selector_type
));
1260 int high_type_val
= TREE_INT_CST_LOW (TYPE_MAX_VALUE (selector_type
));
1261 if (target_val
< low_type_val
|| target_val
> high_type_val
)
1262 expr
= boolean_false_node
;
1264 expr
= build_compare_expr (EQ_EXPR
, TREE_VALUE (selector
), label
);
1266 else if (TREE_CODE (label
) == RANGE_EXPR
)
1268 if (TREE_OPERAND (label
, 0) == NULL_TREE
)
1270 if (TREE_OPERAND (label
, 1) == NULL_TREE
)
1271 expr
= boolean_true_node
; /* (*) -- matches everything */
1273 expr
= chill_handle_multi_case_else_label (selector
);
1277 tree low
= TREE_OPERAND (label
, 0);
1278 tree high
= TREE_OPERAND (label
, 1);
1279 if (TREE_CODE (low
) != INTEGER_CST
)
1281 error ("Lower bound of range must be a discrete literal expression");
1282 expr
= error_mark_node
;
1284 if (TREE_CODE (high
) != INTEGER_CST
)
1286 error ("Upper bound of range must be a discrete literal expression");
1287 expr
= error_mark_node
;
1289 if (expr
!= error_mark_node
)
1291 expr
= chill_handle_multi_case_label_range (
1292 low
, high
, TREE_VALUE (selector
));
1296 else if (TREE_CODE (label
) == TYPE_DECL
)
1298 tree type
= TREE_TYPE (label
);
1299 if (! discrete_type_p (type
))
1301 error ("mode in label is not discrete");
1302 expr
= error_mark_node
;
1305 expr
= chill_handle_multi_case_label_range (
1306 TYPE_MIN_VALUE (type
), TYPE_MAX_VALUE (type
), TREE_VALUE (selector
));
1310 error ("The CASE label is not valid");
1311 expr
= error_mark_node
;
1318 chill_handle_multi_case_label_list (selector
, labels
)
1319 tree selector
, labels
;
1321 tree one_label
, larg
, rarg
;
1323 one_label
= TREE_VALUE (labels
);
1324 larg
= chill_handle_multi_case_label (selector
, TREE_VALUE (one_label
));
1326 for (one_label
= TREE_CHAIN (one_label
);
1327 one_label
!= NULL_TREE
;
1328 one_label
= TREE_CHAIN (one_label
))
1330 rarg
= chill_handle_multi_case_label (selector
, TREE_VALUE (one_label
));
1331 larg
= build_chill_binary_op (TRUTH_ORIF_EXPR
, larg
, rarg
);
1338 build_multi_case_selector_expression (selector_list
, label_spec
)
1339 tree selector_list
, label_spec
;
1341 tree labels
, selector
, larg
, rarg
;
1343 labels
= label_spec
;
1344 selector
= selector_list
;
1345 larg
= chill_handle_multi_case_label_list(selector
, labels
);
1347 for (labels
= TREE_CHAIN (labels
), selector
= TREE_CHAIN (selector
);
1348 labels
!= NULL_TREE
&& selector
!= NULL_TREE
;
1349 labels
= TREE_CHAIN (labels
), selector
= TREE_CHAIN (selector
))
1351 rarg
= chill_handle_multi_case_label_list(selector
, labels
);
1352 larg
= build_chill_binary_op (TRUTH_ANDIF_EXPR
, larg
, rarg
);
1355 if (labels
!= NULL_TREE
|| selector
!= NULL_TREE
)
1356 error ("The number of CASE selectors does not match the number of CASE label lists");
1361 #define BITARRAY_TEST(ARRAY, INDEX) \
1362 ((ARRAY)[(unsigned)(INDEX) / HOST_BITS_PER_CHAR]\
1363 & (1 << ((unsigned)(INDEX) % HOST_BITS_PER_CHAR)))
1364 #define BITARRAY_SET(ARRAY, INDEX) \
1365 ((ARRAY)[(unsigned)(INDEX) / HOST_BITS_PER_CHAR]\
1366 |= 1 << ((unsigned)(INDEX) % HOST_BITS_PER_CHAR))
1368 /* CASES_SEEN is a set (bitarray) of length COUNT.
1369 For each element that is zero, print an error message,
1370 assume the element have the given TYPE. */
1373 print_missing_cases (type
, cases_seen
, count
)
1375 const unsigned char *cases_seen
;
1379 for (i
= 0; i
< count
; i
++)
1381 if (BITARRAY_TEST(cases_seen
, i
) == 0)
1387 const char *err_val_name
= "???";
1388 if (TYPE_MIN_VALUE (t
)
1389 && TREE_CODE (TYPE_MIN_VALUE (t
)) == INTEGER_CST
)
1390 x
+= TREE_INT_CST_LOW (TYPE_MIN_VALUE (t
));
1391 while (TREE_TYPE (t
) != NULL_TREE
)
1393 switch (TREE_CODE (t
))
1397 err_val_name
= x
? "TRUE" : "FALSE";
1402 if ((x
>= ' ' && x
< 127) && x
!= '\'' && x
!= '^')
1403 sprintf (buf
, "'%c'", (char)x
);
1405 sprintf (buf
, "'^(%ld)'", x
);
1408 while (j
< count
&& !BITARRAY_TEST(cases_seen
, j
))
1413 bufptr
+= strlen (bufptr
);
1414 if ((y
>= ' ' && y
< 127) && y
!= '\'' && y
!= '^')
1415 sprintf (bufptr
, "%s:'%c'", buf
, (char)y
);
1417 sprintf (bufptr
, "%s:'^(%ld)'", buf
, y
);
1420 err_val_name
= bufptr
;
1424 for (v
= TYPE_VALUES (t
); v
&& x
; v
= TREE_CHAIN (v
))
1427 err_val_name
= IDENTIFIER_POINTER (TREE_PURPOSE (v
));
1431 while (j
< count
&& !BITARRAY_TEST(cases_seen
, j
))
1434 sprintf (buf
, "%ld", x
);
1436 sprintf (buf
, "%ld:%ld", x
, x
+j
-i
-1);
1441 error ("incomplete CASE - %s not handled", err_val_name
);
1447 check_missing_cases (type
)
1451 /* For each possible selector value. a one iff it has been matched
1452 by a case value alternative. */
1453 unsigned char *cases_seen
;
1454 /* The number of possible selector values. */
1455 HOST_WIDE_INT size
= all_cases_count (type
, &is_sparse
);
1456 HOST_WIDE_INT bytes_needed
1457 = (size
+ HOST_BITS_PER_CHAR
) / HOST_BITS_PER_CHAR
;
1460 warning ("CASE selector with variable range");
1461 else if (size
< 0 || size
> 600000
1462 /* We deliberately use malloc here - not xmalloc. */
1463 || (cases_seen
= (char*) malloc (bytes_needed
)) == NULL
)
1464 warning ("too many cases to do CASE completeness testing");
1467 bzero (cases_seen
, bytes_needed
);
1468 mark_seen_cases (type
, cases_seen
, size
, is_sparse
);
1469 print_missing_cases (type
, cases_seen
, size
);
1475 * We build an expression tree here because, in many contexts,
1476 * we don't know the type of result that's desired. By the
1477 * time we get to expanding the tree, we do know.
1480 build_chill_case_expr (exprlist
, casealtlist_expr
,
1482 tree exprlist
, casealtlist_expr
, optelsecase_expr
;
1484 return build (CASE_EXPR
, NULL_TREE
, exprlist
,
1486 tree_cons (NULL_TREE
,
1492 /* This function transforms the selector_list and alternatives into a COND_EXPR. */
1494 build_chill_multi_dimension_case_expr (selector_list
, alternatives
, else_expr
)
1495 tree selector_list
, alternatives
, else_expr
;
1499 selector_list
= check_case_selector_list (selector_list
);
1501 if (alternatives
== NULL_TREE
)
1504 alternatives
= nreverse (alternatives
);
1505 /* alternatives represents the CASE label specifications and resulting values in
1506 the reverse order in which they appeared.
1507 If there is an ELSE expression, then use it. If there is no
1508 ELSE expression, make the last alternative (which is the first in the list)
1509 into the ELSE expression. This is safe because, if the CASE is complete
1510 (as required), then the last condition need not be checked anyway. */
1511 if (else_expr
!= NULL_TREE
)
1515 expr
= TREE_VALUE (alternatives
);
1516 alternatives
= TREE_CHAIN (alternatives
);
1519 for ( ; alternatives
!= NULL_TREE
; alternatives
= TREE_CHAIN (alternatives
))
1521 tree value
= TREE_VALUE (alternatives
);
1522 tree labels
= TREE_PURPOSE (alternatives
);
1523 tree cond
= build_multi_case_selector_expression(selector_list
, labels
);
1524 expr
= build_nt (COND_EXPR
, cond
, value
, expr
);
1531 /* This is called with the assumption that RHS has been stabilized.
1532 It has one purpose: to iterate through the CHILL list of LHS's */
1534 expand_assignment_action (loclist
, modifycode
, rhs
)
1536 enum chill_tree_code modifycode
;
1539 if (loclist
== NULL_TREE
|| TREE_CODE (loclist
) == ERROR_MARK
1540 || rhs
== NULL_TREE
|| TREE_CODE (rhs
) == ERROR_MARK
)
1543 if (TREE_CHAIN (loclist
) != NULL_TREE
)
1544 { /* Multiple assignment */
1546 if (TREE_TYPE (rhs
) != NULL_TREE
)
1547 rhs
= save_expr (rhs
);
1548 else if (TREE_CODE (rhs
) == CONSTRUCTOR
)
1549 error ("type of tuple cannot be implicit in multiple assignent");
1550 else if (TREE_CODE (rhs
) == CASE_EXPR
|| TREE_CODE (rhs
) == COND_EXPR
)
1551 error ("conditional expression cannot be used in multiple assignent");
1553 error ("internal error - unknown type in multiple assignment");
1555 if (modifycode
!= NOP_EXPR
)
1557 error ("no operator allowed in multiple assignment,");
1558 modifycode
= NOP_EXPR
;
1561 for (target
= TREE_CHAIN (loclist
); target
; target
= TREE_CHAIN (target
))
1563 if (!CH_EQUIVALENT (TREE_TYPE (TREE_VALUE (target
)),
1564 TREE_TYPE (TREE_VALUE (loclist
))))
1567 ("location modes in multiple assignment are not equivalent");
1572 for ( ; loclist
!= NULL_TREE
; loclist
= TREE_CHAIN (loclist
))
1573 chill_expand_assignment (TREE_VALUE (loclist
), modifycode
, rhs
);
1577 chill_expand_assignment (lhs
, modifycode
, rhs
)
1579 enum chill_tree_code modifycode
;
1584 while (TREE_CODE (lhs
) == COMPOUND_EXPR
)
1586 expand_expr (TREE_OPERAND (lhs
, 0), const0_rtx
, VOIDmode
, 0);
1588 lhs
= TREE_OPERAND (lhs
, 1);
1591 if (TREE_CODE (lhs
) == ERROR_MARK
)
1594 /* errors for assignment to BUFFER, EVENT locations.
1595 what about SIGNALs? FIXME: Need similar test in
1596 build_chill_function_call. */
1597 if (TREE_CODE (lhs
) == IDENTIFIER_NODE
)
1599 tree decl
= lookup_name (lhs
);
1602 tree type
= TREE_TYPE (decl
);
1603 if (CH_IS_BUFFER_MODE (type
) || CH_IS_EVENT_MODE (type
))
1605 error ("You may not assign a value to a BUFFER or EVENT location");
1611 if (TYPE_READONLY_PROPERTY (TREE_TYPE (lhs
)) || TREE_READONLY (lhs
))
1613 error ("can't assign value to READonly location");
1616 if (CH_TYPE_NONVALUE_P (TREE_TYPE (lhs
)))
1618 error ("cannot assign to location with non-value property");
1622 if (TREE_CODE (TREE_TYPE (lhs
)) == REFERENCE_TYPE
)
1623 lhs
= convert_from_reference (lhs
);
1625 /* check for lhs is a location */
1629 if (TREE_CODE (loc
) == SLICE_EXPR
)
1630 loc
= TREE_OPERAND (loc
, 0);
1631 else if (TREE_CODE (loc
) == SET_IN_EXPR
)
1632 loc
= TREE_OPERAND (loc
, 1);
1636 if (! CH_LOCATION_P (loc
))
1638 error ("lefthand side of assignment is not a location");
1642 /* If a binary op has been requested, combine the old LHS value with
1643 the RHS producing the value we should actually store into the LHS. */
1645 if (modifycode
!= NOP_EXPR
)
1647 lhs
= stabilize_reference (lhs
);
1648 /* This is to handle border-line cases such
1649 as: LHS OR := [I]. This seems to be permitted
1650 by the letter of Z.200, though it violates
1651 its spirit, since LHS:=LHS OR [I] is
1653 if (TREE_TYPE (rhs
) == NULL_TREE
)
1654 rhs
= convert (TREE_TYPE (lhs
), rhs
);
1655 rhs
= build_chill_binary_op (modifycode
, lhs
, rhs
);
1658 rhs
= chill_convert_for_assignment (TREE_TYPE (lhs
), rhs
, "assignment");
1660 /* handle the LENGTH (vary_array) := expr action */
1662 if (TREE_CODE (loc
) == NOP_EXPR
)
1663 loc
= TREE_OPERAND (loc
, 0);
1664 if (TREE_CODE (loc
) == COMPONENT_REF
1665 && chill_varying_type_p (TREE_TYPE (TREE_OPERAND (loc
, 0)))
1666 && DECL_NAME (TREE_OPERAND (loc
, 1)) == var_length_id
)
1668 expand_varying_length_assignment (TREE_OPERAND (loc
, 0), rhs
);
1670 else if (TREE_CODE (lhs
) == SLICE_EXPR
)
1672 tree func
= lookup_name (get_identifier ("__pscpy"));
1673 tree dst
= TREE_OPERAND (lhs
, 0);
1674 tree dst_offset
= TREE_OPERAND (lhs
, 1);
1675 tree length
= TREE_OPERAND (lhs
, 2);
1676 tree src
, src_offset
;
1677 if (TREE_CODE (rhs
) == SLICE_EXPR
)
1679 src
= TREE_OPERAND (rhs
, 0);
1680 /* Should check that the TREE_OPERAND (src, 0) is
1681 the same as length and powerserlen (src). FIXME */
1682 src_offset
= TREE_OPERAND (rhs
, 1);
1687 src_offset
= integer_zero_node
;
1689 expand_expr_stmt (build_chill_function_call (func
,
1690 tree_cons (NULL_TREE
, force_addr_of (dst
),
1691 tree_cons (NULL_TREE
, powersetlen (dst
),
1692 tree_cons (NULL_TREE
, convert (long_unsigned_type_node
, dst_offset
),
1693 tree_cons (NULL_TREE
, force_addr_of (src
),
1694 tree_cons (NULL_TREE
, powersetlen (src
),
1695 tree_cons (NULL_TREE
, convert (long_unsigned_type_node
, src_offset
),
1696 tree_cons (NULL_TREE
, convert (long_unsigned_type_node
, length
),
1700 else if (TREE_CODE (lhs
) == SET_IN_EXPR
)
1702 tree from_pos
= save_expr (TREE_OPERAND (lhs
, 0));
1703 tree set
= TREE_OPERAND (lhs
, 1);
1704 tree domain
= TYPE_DOMAIN (TREE_TYPE (set
));
1706 = fold (build (PLUS_EXPR
, integer_type_node
,
1707 fold (build (MINUS_EXPR
, integer_type_node
,
1708 TYPE_MAX_VALUE (domain
),
1709 TYPE_MIN_VALUE (domain
))),
1711 tree filename
= force_addr_of (get_chill_filename());
1713 if (TREE_CODE (TREE_TYPE (lhs
)) != BOOLEAN_TYPE
)
1714 sorry("bitstring slice");
1716 build_chill_function_call (lookup_name (
1717 get_identifier ("__setbitpowerset")),
1718 tree_cons (NULL_TREE
, build_chill_addr_expr (set
, "powerset"),
1719 tree_cons (NULL_TREE
, set_length
,
1720 tree_cons (NULL_TREE
, TYPE_MIN_VALUE (domain
),
1721 tree_cons (NULL_TREE
, convert (long_integer_type_node
, from_pos
),
1722 tree_cons (NULL_TREE
, rhs
,
1723 tree_cons (NULL_TREE
, filename
,
1724 tree_cons (NULL_TREE
, get_chill_linenumber(),
1728 /* Handle arrays of packed bitfields. Currently, this is limited to bitfields
1729 which are 1 bit wide, so use the powerset runtime function. */
1730 else if (TREE_CODE (lhs
) == PACKED_ARRAY_REF
)
1732 tree from_pos
= save_expr (TREE_OPERAND (lhs
, 1));
1733 tree array
= TREE_OPERAND (lhs
, 0);
1734 tree domain
= TYPE_DOMAIN (TREE_TYPE (array
));
1735 tree array_length
= powersetlen (array
);
1736 tree filename
= force_addr_of (get_chill_filename());
1738 build_chill_function_call (lookup_name (
1739 get_identifier ("__setbitpowerset")),
1740 tree_cons (NULL_TREE
, build_chill_addr_expr (array
, "packed bitfield array"),
1741 tree_cons (NULL_TREE
, convert (long_unsigned_type_node
, array_length
),
1742 tree_cons (NULL_TREE
, convert (long_integer_type_node
,
1743 TYPE_MIN_VALUE (domain
)),
1744 tree_cons (NULL_TREE
, convert (long_integer_type_node
, from_pos
),
1745 tree_cons (NULL_TREE
, build1 (CONVERT_EXPR
, boolean_type_node
, rhs
),
1746 tree_cons (NULL_TREE
, filename
,
1747 tree_cons (NULL_TREE
, get_chill_linenumber(),
1751 /* The following is probably superceded by the
1752 above code for SET_IN_EXPR. FIXME! */
1753 else if (TREE_CODE (lhs
) == BIT_FIELD_REF
)
1755 tree set
= TREE_OPERAND (lhs
, 0);
1756 tree numbits
= TREE_OPERAND (lhs
, 1);
1757 tree from_pos
= save_expr (TREE_OPERAND (lhs
, 2));
1758 tree domain
= TYPE_DOMAIN (TREE_TYPE (set
));
1760 = fold (build (PLUS_EXPR
, integer_type_node
,
1761 fold (build (MINUS_EXPR
, integer_type_node
,
1762 TYPE_MAX_VALUE (domain
),
1763 TYPE_MIN_VALUE (domain
))),
1765 tree filename
= force_addr_of (get_chill_filename());
1768 switch (TREE_CODE (TREE_TYPE (rhs
)))
1771 to_pos
= fold (build (MINUS_EXPR
, integer_type_node
,
1772 fold (build (PLUS_EXPR
, integer_type_node
,
1773 from_pos
, numbits
)),
1783 if (TREE_CODE (TREE_TYPE (lhs
)) != BOOLEAN_TYPE
)
1784 sorry("bitstring slice");
1786 build_chill_function_call( lookup_name (
1787 get_identifier ("__setbitpowerset")),
1788 tree_cons (NULL_TREE
, build_chill_addr_expr (set
, "powerset"),
1789 tree_cons (NULL_TREE
, set_length
,
1790 tree_cons (NULL_TREE
, TYPE_MIN_VALUE (domain
),
1791 tree_cons (NULL_TREE
, from_pos
,
1792 tree_cons (NULL_TREE
, rhs
,
1793 tree_cons (NULL_TREE
, filename
,
1794 tree_cons (NULL_TREE
, get_chill_linenumber(),
1799 expand_expr_stmt (build_chill_modify_expr (lhs
, rhs
));
1802 /* Also assumes that rhs has been stabilized */
1804 expand_varying_length_assignment (lhs
, rhs
)
1807 tree base_array
, min_domain_val
;
1809 pedwarn ("LENGTH on left-hand-side is non-portable");
1811 if (! CH_LOCATION_P (lhs
))
1813 error ("Can only set LENGTH of array location");
1817 /* cause a RANGE exception if rhs would cause a 'hole' in the array. */
1818 rhs
= valid_array_index_p (lhs
, rhs
, "new array length too large", 1);
1820 base_array
= CH_VARYING_ARRAY_TYPE (TREE_TYPE (lhs
));
1821 min_domain_val
= TYPE_MIN_VALUE (TYPE_DOMAIN (base_array
));
1823 lhs
= build_component_ref (lhs
, var_length_id
);
1824 rhs
= fold (build (MINUS_EXPR
, TREE_TYPE (rhs
), rhs
, min_domain_val
));
1826 expand_expr_stmt (build_chill_modify_expr (lhs
, rhs
));
1835 emit_line_note (input_filename
, lineno
);