1 /* Convert language-specific tree expression to rtl instructions,
2 for GNU CHILL compiler.
3 Copyright (C) 1992, 1993, 1994, 1998, 1999, 2000, 2001
4 Free Software Foundation, Inc.
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 extern char **boolean_code_name
;
37 extern int flag_old_strings
;
38 extern int ignore_case
;
39 extern int special_UC
;
41 /* definitions for duration built-ins */
42 #define MILLISECS_MULTIPLIER 1
43 #define SECS_MULTIPLIER MILLISECS_MULTIPLIER * 1000
44 #define MINUTES_MULTIPLIER SECS_MULTIPLIER * 60
45 #define HOURS_MULTIPLIER MINUTES_MULTIPLIER * 60
46 #define DAYS_MULTIPLIER HOURS_MULTIPLIER * 24
48 /* the maximum value for each of the calls */
49 #define MILLISECS_MAX 0xffffffff
50 #define SECS_MAX 4294967
51 #define MINUTES_MAX 71582
52 #define HOURS_MAX 1193
55 /* forward declarations */
56 static rtx chill_expand_expr
PARAMS ((tree
, rtx
, enum machine_mode
,
57 enum expand_modifier
));
58 static tree chill_expand_case_expr
PARAMS ((tree
));
59 static int check_arglist_length
PARAMS ((tree
, int, int, tree
));
60 static tree internal_build_compound_expr
PARAMS ((tree
, int));
61 static int is_really_instance
PARAMS ((tree
));
62 static int invalid_operand
PARAMS ((enum chill_tree_code
,
64 static int invalid_right_operand
PARAMS ((enum chill_tree_code
, tree
));
65 static tree build_chill_abstime
PARAMS ((tree
));
66 static tree build_allocate_memory_call
PARAMS ((tree
, tree
));
67 static tree build_allocate_global_memory_call
PARAMS ((tree
, tree
));
68 static tree build_return_memory
PARAMS ((tree
));
69 static tree build_chill_duration
PARAMS ((tree
, unsigned long,
70 tree
, unsigned long));
71 static tree build_chill_floatcall
PARAMS ((tree
, const char *,
73 static tree build_allocate_getstack
PARAMS ((tree
, tree
, const char *,
74 const char *, tree
, tree
));
75 static tree build_chill_allocate
PARAMS ((tree
, tree
));
76 static tree build_chill_getstack
PARAMS ((tree
, tree
));
77 static tree build_chill_terminate
PARAMS ((tree
));
78 static tree build_chill_inttime
PARAMS ((tree
, tree
));
79 static tree build_chill_lower_or_upper
PARAMS ((tree
, int));
80 static tree build_max_min
PARAMS ((tree
, int));
81 static tree build_chill_pred_or_succ
PARAMS ((tree
, enum tree_code
));
82 static tree expand_packed_set
PARAMS ((const char *, int, tree
));
83 static tree fold_set_expr
PARAMS ((enum chill_tree_code
,
85 static tree build_compare_set_expr
PARAMS ((enum tree_code
, tree
, tree
));
86 static tree scalar_to_string
PARAMS ((tree
));
87 static tree build_concat_expr
PARAMS ((tree
, tree
));
88 static tree build_compare_string_expr
PARAMS ((enum tree_code
, tree
, tree
));
89 static tree compare_records
PARAMS ((tree
, tree
));
90 static tree string_char_rep
PARAMS ((int, tree
));
91 static tree build_boring_bitstring
PARAMS ((long, int));
93 /* variable to hold the type the DESCR built-in returns */
94 static tree descr_type
= NULL_TREE
;
97 /* called from ch-lex.l */
101 lang_expand_expr
= chill_expand_expr
;
104 /* Take the address of something that needs to be passed by reference. */
106 force_addr_of (value
)
109 /* FIXME. Move to memory, if needed. */
110 if (TREE_CODE (value
) == INDIRECT_REF
)
111 return convert_to_pointer (ptr_type_node
, TREE_OPERAND (value
, 0));
112 mark_addressable (value
);
113 return build1 (ADDR_EXPR
, ptr_type_node
, value
);
116 /* Check that EXP has a known type. */
119 check_have_mode (exp
, context
)
123 if (TREE_CODE (exp
) != ERROR_MARK
&& TREE_TYPE (exp
) == NULL_TREE
)
125 if (TREE_CODE (exp
) == CONSTRUCTOR
)
126 error ("tuple without specified mode not allowed in %s", context
);
127 else if (TREE_CODE (exp
) == COND_EXPR
|| TREE_CODE (exp
) == CASE_EXPR
)
128 error ("conditional expression not allowed in %s", context
);
130 error ("internal error: unknown expression mode in %s", context
);
132 return error_mark_node
;
137 /* Check that EXP is discrete. Handle conversion if flag_old_strings. */
140 check_case_selector (exp
)
143 if (exp
!= NULL_TREE
&& TREE_TYPE (exp
) != NULL_TREE
)
144 exp
= convert_to_discrete (exp
);
147 error ("CASE selector is not a discrete expression");
148 return error_mark_node
;
152 check_case_selector_list (list
)
155 tree selector
, exp
, return_list
= NULL_TREE
;
157 for (selector
= list
; selector
!= NULL_TREE
; selector
= TREE_CHAIN (selector
))
159 exp
= check_case_selector (TREE_VALUE (selector
));
160 if (exp
== error_mark_node
)
162 return_list
= error_mark_node
;
165 return_list
= tree_cons (TREE_PURPOSE (selector
), exp
, return_list
);
168 return nreverse(return_list
);
172 chill_expand_case_expr (expr
)
175 tree selector_list
= TREE_OPERAND (expr
, 0), selector
;
176 tree alternatives
= TREE_OPERAND (expr
, 1);
177 tree type
= TREE_TYPE (expr
);
181 if (TREE_CODE (selector_list
) != TREE_LIST
182 || TREE_CODE (alternatives
) != TREE_LIST
)
184 if (TREE_CHAIN (selector_list
) != NULL_TREE
)
187 /* make a temp for the case result */
188 result
= decl_temp1 (get_unique_identifier ("CASE_EXPR"),
189 type
, 0, NULL_TREE
, 0, 0);
191 selector
= check_case_selector (TREE_VALUE (selector_list
));
193 expand_start_case (1, selector
, TREE_TYPE (selector
), "CASE expression");
195 alternatives
= nreverse (alternatives
);
196 for ( ; alternatives
!= NULL_TREE
; alternatives
= TREE_CHAIN (alternatives
))
198 tree labels
= TREE_PURPOSE (alternatives
), t
;
200 if (labels
== NULL_TREE
)
202 chill_handle_case_default ();
208 if (labels
!= NULL_TREE
)
210 for (label
= TREE_VALUE (labels
);
211 label
!= NULL_TREE
; label
= TREE_CHAIN (label
))
212 chill_handle_case_label (TREE_VALUE (label
), selector
);
213 labels
= TREE_CHAIN (labels
);
214 if (labels
!= NULL_TREE
)
215 error ("The number of CASE selectors does not match the number of CASE label lists");
220 t
= build (MODIFY_EXPR
, type
, result
,
221 convert (type
, TREE_VALUE (alternatives
)));
222 TREE_SIDE_EFFECTS (t
) = 1;
223 expand_expr_stmt (t
);
224 expand_exit_something ();
229 chill_handle_case_default ();
230 expand_exit_something ();
235 check_missing_cases (TREE_TYPE (selector
));
238 expand_end_case (selector
);
242 /* Hook used by expand_expr to expand CHILL-specific tree codes. */
245 chill_expand_expr (exp
, target
, tmode
, modifier
)
248 enum machine_mode tmode
;
249 enum expand_modifier modifier
;
251 tree type
= TREE_TYPE (exp
);
252 register enum machine_mode mode
= TYPE_MODE (type
);
253 register enum tree_code code
= TREE_CODE (exp
);
254 rtx original_target
= target
;
256 int ignore
= target
== const0_rtx
;
257 const char *lib_func
; /* name of library routine */
260 target
= 0, original_target
= 0;
262 /* No sense saving up arithmetic to be done
263 if it's all in the wrong mode to form part of an address.
264 And force_operand won't know whether to sign-extend or zero-extend. */
266 if (mode
!= Pmode
&& modifier
== EXPAND_SUM
)
267 modifier
= EXPAND_NORMAL
;
274 rtx func
= gen_rtx (SYMBOL_REF
, Pmode
,
275 code
== STRING_EQ_EXPR
? "__eqstring"
277 tree exp0
= TREE_OPERAND (exp
, 0);
278 tree exp1
= TREE_OPERAND (exp
, 1);
280 rtx op0
, op1
, siz0
, siz1
;
281 if (chill_varying_type_p (TREE_TYPE (exp0
)))
283 exp0
= save_if_needed (exp0
);
284 size0
= convert (integer_type_node
,
285 build_component_ref (exp0
, var_length_id
));
286 exp0
= build_component_ref (exp0
, var_data_id
);
289 size0
= size_in_bytes (TREE_TYPE (exp0
));
290 if (chill_varying_type_p (TREE_TYPE (exp1
)))
292 exp1
= save_if_needed (exp1
);
293 size1
= convert (integer_type_node
,
294 build_component_ref (exp1
, var_length_id
));
295 exp1
= build_component_ref (exp1
, var_data_id
);
298 size1
= size_in_bytes (TREE_TYPE (exp1
));
300 op0
= expand_expr (force_addr_of (exp0
),
301 NULL_RTX
, MEM
, EXPAND_CONST_ADDRESS
);
302 op1
= expand_expr (force_addr_of (exp1
),
303 NULL_RTX
, MEM
, EXPAND_CONST_ADDRESS
);
304 siz0
= expand_expr (size0
, NULL_RTX
, VOIDmode
, 0);
305 siz1
= expand_expr (size1
, NULL_RTX
, VOIDmode
, 0);
306 return emit_library_call_value (func
, target
,
309 siz0
, TYPE_MODE (sizetype
),
311 siz1
, TYPE_MODE (sizetype
));
315 return expand_expr (chill_expand_case_expr (exp
),
316 NULL_RTX
, VOIDmode
, 0);
322 tree array
= TREE_OPERAND (exp
, 0);
323 tree min_value
= TREE_OPERAND (exp
, 1);
324 tree length
= TREE_OPERAND (exp
, 2);
325 tree new_type
= TREE_TYPE (exp
);
326 tree temp
= decl_temp1 (get_unique_identifier ("BITSTRING"),
327 new_type
, 0, NULL_TREE
, 0, 0);
328 if (! CH_REFERABLE (array
) && TYPE_MODE (TREE_TYPE (array
)) != BLKmode
)
329 array
= decl_temp1 (get_unique_identifier ("BSTRINGVAL"),
330 TREE_TYPE (array
), 0, array
, 0, 0);
331 func_call
= build_chill_function_call (
332 lookup_name (get_identifier ("__psslice")),
333 tree_cons (NULL_TREE
,
334 build_chill_addr_expr (temp
, (char *)0),
335 tree_cons (NULL_TREE
, length
,
336 tree_cons (NULL_TREE
,
337 force_addr_of (array
),
338 tree_cons (NULL_TREE
, powersetlen (array
),
339 tree_cons (NULL_TREE
, convert (integer_type_node
, min_value
),
340 tree_cons (NULL_TREE
, length
, NULL_TREE
)))))));
341 expand_expr (func_call
, const0_rtx
, VOIDmode
, 0);
343 return expand_expr (temp
, ignore
? const0_rtx
: target
,
347 /* void __concatstring (char *out, char *left, unsigned left_len,
348 char *right, unsigned right_len) */
351 tree exp0
= TREE_OPERAND (exp
, 0);
352 tree exp1
= TREE_OPERAND (exp
, 1);
353 rtx size0
= NULL_RTX
, size1
= NULL_RTX
;
356 if (TREE_CODE (exp1
) == UNDEFINED_EXPR
)
358 if (TYPE_MODE (TREE_TYPE (exp0
)) == BLKmode
359 && TYPE_MODE (TREE_TYPE (exp
)) == BLKmode
)
361 rtx temp
= expand_expr (exp0
, target
, tmode
, modifier
);
362 if (temp
== target
|| target
== NULL_RTX
)
364 emit_block_move (target
, temp
, expr_size (exp0
),
365 TYPE_ALIGN (TREE_TYPE(exp0
)));
370 exp0
= force_addr_of (exp0
);
371 exp0
= convert (build_pointer_type (TREE_TYPE (exp
)), exp0
);
372 exp0
= build1 (INDIRECT_REF
, TREE_TYPE (exp
), exp0
);
373 return expand_expr (exp0
,
374 NULL_RTX
, Pmode
, EXPAND_CONST_ADDRESS
);
378 if (TREE_CODE (type
) == ARRAY_TYPE
)
380 /* No need to handle scalars or varying strings here, since that
381 was done in convert or build_concat_expr. */
382 size0
= expand_expr (size_in_bytes (TREE_TYPE (exp0
)),
383 NULL_RTX
, Pmode
, EXPAND_CONST_ADDRESS
);
385 size1
= expand_expr (size_in_bytes (TREE_TYPE (exp1
)),
386 NULL_RTX
, Pmode
, EXPAND_CONST_ADDRESS
);
388 /* build a temp for the result, target is its address */
389 if (target
== NULL_RTX
)
391 tree type0
= TREE_TYPE (exp0
);
392 tree type1
= TREE_TYPE (exp1
);
393 HOST_WIDE_INT len0
= int_size_in_bytes (type0
);
394 HOST_WIDE_INT len1
= int_size_in_bytes (type1
);
396 if (len0
< 0 && TYPE_ARRAY_MAX_SIZE (type0
)
397 && host_integerp (TYPE_ARRAY_MAX_SIZE (type0
), 1))
398 len0
= tree_low_cst (TYPE_ARRAY_MAX_SIZE (type0
), 1);
400 if (len1
< 0 && TYPE_ARRAY_MAX_SIZE (type1
)
401 && host_integerp (TYPE_ARRAY_MAX_SIZE (type1
), 1))
402 len1
= tree_low_cst (TYPE_ARRAY_MAX_SIZE (type1
), 1);
404 if (len0
< 0 || len1
< 0)
407 target
= assign_stack_temp (mode
, len0
+ len1
, 0);
408 preserve_temp_slots (target
);
411 else if (TREE_CODE (type
) == SET_TYPE
)
413 if (target
== NULL_RTX
)
415 target
= assign_stack_temp (mode
, int_size_in_bytes (type
), 0);
416 preserve_temp_slots (target
);
422 if (GET_CODE (target
) == MEM
)
425 targetx
= assign_stack_temp (mode
, GET_MODE_SIZE (mode
), 0);
427 /* expand 1st operand to a pointer to the array */
428 op0
= expand_expr (force_addr_of (exp0
),
429 NULL_RTX
, MEM
, EXPAND_CONST_ADDRESS
);
431 /* expand 2nd operand to a pointer to the array */
432 op1
= expand_expr (force_addr_of (exp1
),
433 NULL_RTX
, MEM
, EXPAND_CONST_ADDRESS
);
435 if (TREE_CODE (type
) == SET_TYPE
)
437 size0
= expand_expr (powersetlen (exp0
),
438 NULL_RTX
, VOIDmode
, 0);
439 size1
= expand_expr (powersetlen (exp1
),
440 NULL_RTX
, VOIDmode
, 0);
442 emit_library_call (gen_rtx(SYMBOL_REF
, Pmode
, "__concatps"),
443 0, Pmode
, 5, XEXP (targetx
, 0), Pmode
,
445 convert_to_mode (TYPE_MODE (sizetype
),
446 size0
, TREE_UNSIGNED (sizetype
)),
447 TYPE_MODE (sizetype
),
449 convert_to_mode (TYPE_MODE (sizetype
),
450 size1
, TREE_UNSIGNED (sizetype
)),
451 TYPE_MODE (sizetype
));
455 /* copy left, then right array to target */
456 emit_library_call (gen_rtx(SYMBOL_REF
, Pmode
, "__concatstring"),
457 0, Pmode
, 5, XEXP (targetx
, 0), Pmode
,
459 convert_to_mode (TYPE_MODE (sizetype
),
460 size0
, TREE_UNSIGNED (sizetype
)),
461 TYPE_MODE (sizetype
),
463 convert_to_mode (TYPE_MODE (sizetype
),
464 size1
, TREE_UNSIGNED (sizetype
)),
465 TYPE_MODE (sizetype
));
467 if (targetx
!= target
)
468 emit_move_insn (target
, targetx
);
472 /* FIXME: the set_length computed below is a compile-time constant;
473 you'll need to re-write that part for VARYING bit arrays, and
474 possibly the set pointer will need to be adjusted to point past
475 the word containing its dynamic length. */
477 /* void __notpowerset (char *out, char *src,
478 unsigned long bitlength) */
482 tree expr
= TREE_OPERAND (exp
, 0);
483 tree tsize
= powersetlen (expr
);
486 if (TREE_CODE (TREE_TYPE (expr
)) != SET_TYPE
)
487 tsize
= fold (build (MULT_EXPR
, sizetype
, tsize
,
488 size_int (BITS_PER_UNIT
)));
490 /* expand 1st operand to a pointer to the set */
491 op0
= expand_expr (force_addr_of (expr
),
492 NULL_RTX
, MEM
, EXPAND_CONST_ADDRESS
);
494 /* build a temp for the result, target is its address */
495 if (target
== NULL_RTX
)
497 target
= assign_stack_temp (TYPE_MODE (TREE_TYPE (exp
)),
498 int_size_in_bytes (TREE_TYPE (exp
)),
500 preserve_temp_slots (target
);
502 if (GET_CODE (target
) == MEM
)
505 targetx
= assign_stack_temp (GET_MODE (target
),
506 GET_MODE_SIZE (GET_MODE (target
)),
508 emit_library_call (gen_rtx(SYMBOL_REF
, Pmode
, "__notpowerset"),
509 0, VOIDmode
, 3, XEXP (targetx
, 0), Pmode
,
511 expand_expr (tsize
, NULL_RTX
, MEM
,
512 EXPAND_CONST_ADDRESS
),
513 TYPE_MODE (long_unsigned_type_node
));
514 if (targetx
!= target
)
515 emit_move_insn (target
, targetx
);
520 lib_func
= "__diffpowerset";
524 lib_func
= "__orpowerset";
528 lib_func
= "__xorpowerset";
531 /* void __diffpowerset (char *out, char *left, char *right,
532 unsigned bitlength) */
534 lib_func
= "__andpowerset";
537 tree expr
= TREE_OPERAND (exp
, 0);
538 tree tsize
= powersetlen (expr
);
541 if (TREE_CODE (TREE_TYPE (expr
)) != SET_TYPE
)
542 tsize
= fold (build (MULT_EXPR
, long_unsigned_type_node
,
544 size_int (BITS_PER_UNIT
)));
546 /* expand 1st operand to a pointer to the set */
547 op0
= expand_expr (force_addr_of (expr
),
548 NULL_RTX
, MEM
, EXPAND_CONST_ADDRESS
);
550 /* expand 2nd operand to a pointer to the set */
551 op1
= expand_expr (force_addr_of (TREE_OPERAND (exp
, 1)),
553 EXPAND_CONST_ADDRESS
);
555 /* FIXME: re-examine this code - the unary operator code above has recently
556 (93/03/12) been changed a lot. Should this code also change? */
557 /* build a temp for the result, target is its address */
558 if (target
== NULL_RTX
)
560 target
= assign_stack_temp (TYPE_MODE (TREE_TYPE (exp
)),
561 int_size_in_bytes (TREE_TYPE (exp
)),
563 preserve_temp_slots (target
);
565 if (GET_CODE (target
) == MEM
)
568 targetx
= assign_stack_temp (GET_MODE (target
),
569 GET_MODE_SIZE (GET_MODE (target
)), 0);
570 emit_library_call (gen_rtx(SYMBOL_REF
, Pmode
, lib_func
),
571 0, VOIDmode
, 4, XEXP (targetx
, 0), Pmode
,
572 op0
, GET_MODE (op0
), op1
, GET_MODE (op1
),
573 expand_expr (tsize
, NULL_RTX
, MEM
,
574 EXPAND_CONST_ADDRESS
),
575 TYPE_MODE (long_unsigned_type_node
));
576 if (target
!= targetx
)
577 emit_move_insn (target
, targetx
);
583 tree set
= TREE_OPERAND (exp
, 1);
584 tree pos
= convert (long_unsigned_type_node
, TREE_OPERAND (exp
, 0));
585 tree set_type
= TREE_TYPE (set
);
586 tree set_length
= discrete_count (TYPE_DOMAIN (set_type
));
587 tree min_val
= convert (long_integer_type_node
,
588 TYPE_MIN_VALUE (TYPE_DOMAIN (set_type
)));
591 /* FIXME: Function-call not needed if pos and width are constant! */
592 if (! mark_addressable (set
))
594 error ("powerset is not addressable");
597 /* we use different functions for bitstrings and powersets */
598 if (CH_BOOLS_TYPE_P (set_type
))
600 build_chill_function_call (
601 lookup_name (get_identifier ("__inbitstring")),
602 tree_cons (NULL_TREE
,
603 convert (long_unsigned_type_node
, pos
),
604 tree_cons (NULL_TREE
,
605 build1 (ADDR_EXPR
, build_pointer_type (set_type
), set
),
606 tree_cons (NULL_TREE
,
607 convert (long_unsigned_type_node
, set_length
),
608 tree_cons (NULL_TREE
, min_val
,
609 tree_cons (NULL_TREE
, force_addr_of (get_chill_filename ()),
610 build_tree_list (NULL_TREE
, get_chill_linenumber ())))))));
613 build_chill_function_call (
614 lookup_name (get_identifier ("__inpowerset")),
615 tree_cons (NULL_TREE
,
616 convert (long_unsigned_type_node
, pos
),
617 tree_cons (NULL_TREE
,
618 build1 (ADDR_EXPR
, build_pointer_type (set_type
), set
),
619 tree_cons (NULL_TREE
,
620 convert (long_unsigned_type_node
, set_length
),
621 build_tree_list (NULL_TREE
, min_val
)))));
622 return expand_expr (fcall
, NULL_RTX
, VOIDmode
, 0);
625 case PACKED_ARRAY_REF
:
627 tree array
= TREE_OPERAND (exp
, 0);
628 tree pos
= save_expr (TREE_OPERAND (exp
, 1));
629 tree array_type
= TREE_TYPE (array
);
630 tree array_length
= discrete_count (TYPE_DOMAIN (array_type
));
631 tree min_val
= convert (long_integer_type_node
,
632 TYPE_MIN_VALUE (TYPE_DOMAIN (array_type
)));
635 /* FIXME: Function-call not needed if pos and width are constant! */
636 /* TODO: make sure this makes sense. */
637 if (! mark_addressable (array
))
639 error ("array is not addressable");
643 build_chill_function_call (
644 lookup_name (get_identifier ("__inpowerset")),
645 tree_cons (NULL_TREE
,
646 convert (long_unsigned_type_node
, pos
),
647 tree_cons (NULL_TREE
,
648 build1 (ADDR_EXPR
, build_pointer_type (array_type
), array
),
649 tree_cons (NULL_TREE
,
650 convert (long_unsigned_type_node
, array_length
),
651 build_tree_list (NULL_TREE
, min_val
)))));
652 return expand_expr (fcall
, NULL_RTX
, VOIDmode
, 0);
658 target
= assign_stack_temp (TYPE_MODE (TREE_TYPE (exp
)),
659 int_size_in_bytes (TREE_TYPE (exp
)), 0);
660 preserve_temp_slots (target
);
662 /* We don't actually need to *do* anything ... */
673 /* Check that the argument list has a length in [min_length .. max_length].
674 (max_length == -1 means "infinite".)
675 If so return the actual length.
676 Otherwise, return an error message and return -1. */
679 check_arglist_length (args
, min_length
, max_length
, name
)
685 int length
= list_length (args
);
686 if (length
< min_length
)
687 error ("Too few arguments in call to `%s'", IDENTIFIER_POINTER (name
));
688 else if (max_length
!= -1 && length
> max_length
)
689 error ("Too many arguments in call to `%s'", IDENTIFIER_POINTER (name
));
696 * This is the code from c-typeck.c, with the C-specific cruft
697 * removed (possibly I just didn't understand it, but it was
698 * apparently simply discarding part of my LIST).
701 internal_build_compound_expr (list
, first_p
)
703 int first_p ATTRIBUTE_UNUSED
;
707 if (TREE_CHAIN (list
) == 0)
708 return TREE_VALUE (list
);
710 rest
= internal_build_compound_expr (TREE_CHAIN (list
), FALSE
);
712 if (! TREE_SIDE_EFFECTS (TREE_VALUE (list
)))
715 return build (COMPOUND_EXPR
, TREE_TYPE (rest
), TREE_VALUE (list
), rest
);
719 /* Given a list of expressions, return a compound expression
720 that performs them all and returns the value of the last of them. */
721 /* FIXME: this should be merged with the C version */
723 build_chill_compound_expr (list
)
726 return internal_build_compound_expr (list
, TRUE
);
729 /* Given an expression PTR for a pointer, return an expression
730 for the value pointed to.
731 do_empty_check is 0, don't perform a NULL pointer check,
735 build_chill_indirect_ref (ptr
, mode
, do_empty_check
)
742 if (ptr
== NULL_TREE
|| TREE_CODE (ptr
) == ERROR_MARK
)
744 if (mode
!= NULL_TREE
&& TREE_CODE (mode
) == ERROR_MARK
)
745 return error_mark_node
;
747 type
= TREE_TYPE (ptr
);
749 if (TREE_CODE (type
) == REFERENCE_TYPE
)
751 type
= TREE_TYPE (type
);
752 ptr
= convert (type
, ptr
);
755 /* check for ptr is really a POINTER */
756 if (TREE_CODE (type
) != POINTER_TYPE
)
758 error ("cannot dereference, not a pointer.");
759 return error_mark_node
;
762 if (mode
&& TREE_CODE (mode
) == IDENTIFIER_NODE
)
764 tree decl
= lookup_name (mode
);
765 if (decl
== NULL_TREE
|| TREE_CODE (decl
) != TYPE_DECL
)
768 error ("missing '.' operator or undefined mode name `%s'.",
769 IDENTIFIER_POINTER (mode
));
771 error ("You have forgotten the '.' operator which must");
772 error (" precede a STRUCT field reference, or `%s' is an undefined mode",
773 IDENTIFIER_POINTER (mode
));
775 return error_mark_node
;
781 mode
= get_type_of (mode
);
782 ptr
= convert (build_pointer_type (mode
), ptr
);
784 else if (type
== ptr_type_node
)
786 error ("Can't dereference PTR value using unary `->'.");
787 return error_mark_node
;
791 ptr
= check_non_null (ptr
);
793 type
= TREE_TYPE (ptr
);
795 if (TREE_CODE (type
) == POINTER_TYPE
)
797 if (TREE_CODE (ptr
) == ADDR_EXPR
799 && (TREE_TYPE (TREE_OPERAND (ptr
, 0))
800 == TREE_TYPE (type
)))
801 return TREE_OPERAND (ptr
, 0);
804 tree t
= TREE_TYPE (type
);
805 register tree ref
= build1 (INDIRECT_REF
,
806 TYPE_MAIN_VARIANT (t
), ptr
);
808 if (TYPE_SIZE (t
) == 0 && TREE_CODE (t
) != ARRAY_TYPE
)
810 error ("dereferencing pointer to incomplete type");
811 return error_mark_node
;
813 if (TREE_CODE (t
) == VOID_TYPE
)
814 warning ("dereferencing `void *' pointer");
816 /* We *must* set TREE_READONLY when dereferencing a pointer to const,
817 so that we get the proper error message if the result is used
818 to assign to. Also, &* is supposed to be a no-op.
819 And ANSI C seems to specify that the type of the result
820 should be the const type. */
821 /* A de-reference of a pointer to const is not a const. It is valid
822 to change it via some other pointer. */
823 TREE_READONLY (ref
) = TYPE_READONLY (t
);
824 TREE_SIDE_EFFECTS (ref
)
825 = TYPE_VOLATILE (t
) || TREE_SIDE_EFFECTS (ptr
) || flag_volatile
;
826 TREE_THIS_VOLATILE (ref
) = TYPE_VOLATILE (t
) || flag_volatile
;
830 else if (TREE_CODE (ptr
) != ERROR_MARK
)
831 error ("invalid type argument of `->'");
832 return error_mark_node
;
835 /* NODE is a COMPONENT_REF whose mode is an IDENTIFIER,
836 which is replaced by the proper FIELD_DECL.
837 Also do the right thing for variant records. */
840 resolve_component_ref (node
)
843 tree datum
= TREE_OPERAND (node
, 0);
844 tree field_name
= TREE_OPERAND (node
, 1);
845 tree type
= TREE_TYPE (datum
);
847 if (TREE_CODE (datum
) == ERROR_MARK
)
848 return error_mark_node
;
849 if (TREE_CODE (type
) == REFERENCE_TYPE
)
851 type
= TREE_TYPE (type
);
852 TREE_OPERAND (node
, 0) = datum
= convert (type
, datum
);
854 if (TREE_CODE (type
) != RECORD_TYPE
)
856 error ("operand of '.' is not a STRUCT");
857 return error_mark_node
;
860 TREE_READONLY (node
) = TREE_READONLY (datum
);
861 TREE_SIDE_EFFECTS (node
) = TREE_SIDE_EFFECTS (datum
);
863 for (field
= TYPE_FIELDS (type
); field
; field
= TREE_CHAIN (field
))
865 if (TREE_CODE (TREE_TYPE (field
)) == UNION_TYPE
)
868 for (variant
= TYPE_FIELDS (TREE_TYPE (field
));
869 variant
; variant
= TREE_CHAIN (variant
))
872 for (vfield
= TYPE_FIELDS (TREE_TYPE (variant
));
873 vfield
; vfield
= TREE_CHAIN (vfield
))
875 if (DECL_NAME (vfield
) == field_name
)
876 { /* Found a variant field */
877 datum
= build (COMPONENT_REF
, TREE_TYPE (field
),
879 datum
= build (COMPONENT_REF
, TREE_TYPE (variant
),
881 TREE_OPERAND (node
, 0) = datum
;
882 TREE_OPERAND (node
, 1) = vfield
;
883 TREE_TYPE (node
) = TREE_TYPE (vfield
);
884 TREE_READONLY (node
) |= TYPE_READONLY (TREE_TYPE (node
));
886 if (flag_testing_tags
)
888 tree tagtest
= NOT IMPLEMENTED
;
889 tree tagf
= ridpointers
[(int) RID_RANGEFAIL
];
890 node
= check_expression (node
, tagtest
,
900 if (DECL_NAME (field
) == field_name
)
901 { /* Found a fixed field */
902 TREE_OPERAND (node
, 1) = field
;
903 TREE_TYPE (node
) = TREE_TYPE (field
);
904 TREE_READONLY (node
) |= TYPE_READONLY (TREE_TYPE (node
));
909 error ("No field named `%s'", IDENTIFIER_POINTER (field_name
));
910 return error_mark_node
;
914 build_component_ref (datum
, field_name
)
915 tree datum
, field_name
;
917 tree node
= build_nt (COMPONENT_REF
, datum
, field_name
);
919 node
= resolve_component_ref (node
);
924 function checks (for build_chill_component_ref) if a given
925 type is really an instance type. CH_IS_INSTANCE_MODE is not
926 strict enough in this case, i.e. SYNMODE foo = STRUCT (a, b UINT)
927 is compatible to INSTANCE. */
930 is_really_instance (type
)
933 tree decl
= TYPE_NAME (type
);
935 if (decl
== NULL_TREE
)
936 /* this is not an instance */
939 if (DECL_NAME (decl
) == ridpointers
[(int)RID_INSTANCE
])
940 /* this is an instance */
943 if (TYPE_FIELDS (type
) == TYPE_FIELDS (instance_type_node
))
944 /* we have a NEWMODE'd instance */
950 /* This function is called by the parse.
951 Here we check if the user tries to access a field in a type which is
952 layouted as a structure but isn't like INSTANCE, BUFFER, EVENT, ASSOCIATION,
953 ACCESS, TEXT, or VARYING array or character string.
954 We don't do this in build_component_ref cause this function gets
955 called from the compiler to access fields in one of the above mentioned
958 build_chill_component_ref (datum
, field_name
)
959 tree datum
, field_name
;
961 tree type
= TREE_TYPE (datum
);
962 if ((type
!= NULL_TREE
&& TREE_CODE (type
) == RECORD_TYPE
) &&
963 ((CH_IS_INSTANCE_MODE (type
) && is_really_instance (type
)) ||
964 CH_IS_BUFFER_MODE (type
) ||
965 CH_IS_EVENT_MODE (type
) || CH_IS_ASSOCIATION_MODE (type
) ||
966 CH_IS_ACCESS_MODE (type
) || CH_IS_TEXT_MODE (type
) ||
967 chill_varying_type_p (type
)))
969 error ("operand of '.' is not a STRUCT");
970 return error_mark_node
;
972 return build_component_ref (datum
, field_name
);
976 * Check for invalid binary operands & unary operands
977 * RIGHT is 1 if checking right operand or unary operand;
978 * it is 0 if checking left operand.
980 * return 1 if the given operand is NOT compatible as the
981 * operand of the given operator
983 * return 0 if they might be compatible
986 invalid_operand (code
, type
, right
)
987 enum chill_tree_code code
;
989 int right
; /* 1 if right operand */
1004 case CONCAT_EXPR
: /* must be static or varying char array */
1005 if (TREE_CODE (type
) == CHAR_TYPE
)
1007 if (TREE_CODE (type
) == ARRAY_TYPE
1008 && TREE_CODE (TREE_TYPE (type
)) == CHAR_TYPE
)
1010 if (!chill_varying_type_p (type
))
1012 if (TREE_CODE (TREE_TYPE (CH_VARYING_ARRAY_TYPE (type
)))
1017 /* note: CHILL conditional expressions (COND_EXPR) won't come
1018 * through here; they're routed straight to C-specific code */
1020 return 0; /* ANYTHING can be compared equal */
1021 case FLOOR_MOD_EXPR
:
1022 if (TREE_CODE (type
) == REAL_TYPE
)
1029 if (TREE_CODE (type
) == SET_TYPE
)
1033 case PACKED_ARRAY_REF
:
1034 if (TREE_CODE (type
) == ARRAY_TYPE
)
1041 switch ((int)TREE_CODE(type
)) /* right operand must be set/bitarray type */
1044 if (TREE_CODE (TREE_TYPE (type
)) == CHAR_TYPE
)
1065 if (chill_varying_type_p (type
)
1066 && TREE_CODE (TREE_TYPE (CH_VARYING_ARRAY_TYPE (type
))) == CHAR_TYPE
)
1070 case REFERENCE_TYPE
:
1081 if (TREE_CODE (type
) == BOOLEAN_TYPE
)
1086 return 0; /* ANYTHING can be compared unequal */
1088 return 0; /* ANYTHING can be converted */
1091 switch ((int)TREE_CODE(type
)) /* left operand must be discrete type */
1094 if (right
|| TREE_CODE (TREE_TYPE (type
)) != BOOLEAN_TYPE
)
1108 case REFERENCE_TYPE
:
1125 case REPLICATE_EXPR
:
1126 switch ((int)TREE_CODE(type
)) /* right operand must be set/bitarray type */
1147 case REFERENCE_TYPE
:
1152 case TRUNC_DIV_EXPR
:
1154 case TRUNC_MOD_EXPR
:
1155 if (TREE_CODE (type
) == REAL_TYPE
)
1158 case TRUTH_ANDIF_EXPR
:
1159 case TRUTH_AND_EXPR
:
1160 case TRUTH_NOT_EXPR
:
1161 case TRUTH_ORIF_EXPR
:
1164 switch ((int)TREE_CODE(type
)) /* left operand must be discrete type */
1180 case REFERENCE_TYPE
:
1192 return 1; /* perhaps you forgot to add a new DEFTREECODE? */
1199 invalid_right_operand (code
, type
)
1200 enum chill_tree_code code
;
1203 return invalid_operand (code
, type
, 1);
1207 build_chill_abs (expr
)
1212 if (TREE_CODE (TREE_TYPE (expr
)) == REAL_TYPE
1213 || discrete_type_p (TREE_TYPE (expr
)))
1214 temp
= fold (build1 (ABS_EXPR
, TREE_TYPE (expr
), expr
));
1217 error("ABS argument must be discrete or real mode");
1218 return error_mark_node
;
1220 /* FIXME: should call
1221 * cond_type_range_exception (temp);
1227 build_chill_abstime (exprlist
)
1230 int mask
= 0, i
, numargs
;
1231 tree args
= NULL_TREE
;
1232 tree filename
, lineno
;
1236 if (exprlist
!= NULL_TREE
&& TREE_CODE (exprlist
) == ERROR_MARK
)
1237 return error_mark_node
;
1239 /* check for integer expressions */
1242 while (tmp
!= NULL_TREE
)
1244 tree exp
= TREE_VALUE (tmp
);
1246 if (exp
== NULL_TREE
|| TREE_CODE (exp
) == ERROR_MARK
)
1248 else if (TREE_CODE (TREE_TYPE (exp
)) != INTEGER_TYPE
)
1250 error ("argument %d to ABSTIME must be of integer type.", i
);
1253 tmp
= TREE_CHAIN (tmp
);
1257 return error_mark_node
;
1259 numargs
= list_length (exprlist
);
1260 for (i
= 0; i
< numargs
; i
++)
1263 /* make it all arguments */
1264 for (i
= numargs
; i
< 6; i
++)
1265 exprlist
= tree_cons (NULL_TREE
, integer_zero_node
, exprlist
);
1267 args
= tree_cons (NULL_TREE
, build_int_2 (mask
, 0), exprlist
);
1269 filename
= force_addr_of (get_chill_filename ());
1270 lineno
= get_chill_linenumber ();
1271 args
= chainon (args
, tree_cons (NULL_TREE
, filename
,
1272 tree_cons (NULL_TREE
, lineno
, NULL_TREE
)));
1274 return build_chill_function_call (
1275 lookup_name (get_identifier ("_abstime")), args
);
1280 build_allocate_memory_call (ptr
, size
)
1285 /* check for ptr is referable */
1286 if (! CH_REFERABLE (ptr
))
1288 error ("parameter 1 must be referable.");
1291 /* check for pointer */
1292 else if (TREE_CODE (TREE_TYPE (ptr
)) != POINTER_TYPE
)
1294 error ("mode mismatch in parameter 1.");
1298 /* check for size > 0 if it is a constant */
1299 if (TREE_CODE (size
) == INTEGER_CST
&& TREE_INT_CST_LOW (size
) <= 0)
1301 error ("parameter 2 must be a positive integer.");
1305 return error_mark_node
;
1307 if (TREE_TYPE (ptr
) != ptr_type_node
)
1308 ptr
= build_chill_cast (ptr_type_node
, ptr
);
1310 return build_chill_function_call (
1311 lookup_name (get_identifier ("_allocate_memory")),
1312 tree_cons (NULL_TREE
, ptr
,
1313 tree_cons (NULL_TREE
, size
,
1314 tree_cons (NULL_TREE
, force_addr_of (get_chill_filename ()),
1315 tree_cons (NULL_TREE
, get_chill_linenumber (),
1321 build_allocate_global_memory_call (ptr
, size
)
1326 /* check for ptr is referable */
1327 if (! CH_REFERABLE (ptr
))
1329 error ("parameter 1 must be referable.");
1332 /* check for pointer */
1333 else if (TREE_CODE (TREE_TYPE (ptr
)) != POINTER_TYPE
)
1335 error ("mode mismatch in parameter 1.");
1339 /* check for size > 0 if it is a constant */
1340 if (TREE_CODE (size
) == INTEGER_CST
&& TREE_INT_CST_LOW (size
) <= 0)
1342 error ("parameter 2 must be a positive integer.");
1346 return error_mark_node
;
1348 if (TREE_TYPE (ptr
) != ptr_type_node
)
1349 ptr
= build_chill_cast (ptr_type_node
, ptr
);
1351 return build_chill_function_call (
1352 lookup_name (get_identifier ("_allocate_global_memory")),
1353 tree_cons (NULL_TREE
, ptr
,
1354 tree_cons (NULL_TREE
, size
,
1355 tree_cons (NULL_TREE
, force_addr_of (get_chill_filename ()),
1356 tree_cons (NULL_TREE
, get_chill_linenumber (),
1362 build_return_memory (ptr
)
1366 if (ptr
== NULL_TREE
|| TREE_CODE (ptr
) == ERROR_MARK
)
1367 return error_mark_node
;
1369 /* check for pointer */
1370 if (TREE_CODE (TREE_TYPE (ptr
)) != POINTER_TYPE
)
1372 error ("mode mismatch in parameter 1.");
1373 return error_mark_node
;
1376 if (TREE_TYPE (ptr
) != ptr_type_node
)
1377 ptr
= build_chill_cast (ptr_type_node
, ptr
);
1379 return build_chill_function_call (
1380 lookup_name (get_identifier ("_return_memory")),
1381 tree_cons (NULL_TREE
, ptr
,
1382 tree_cons (NULL_TREE
, force_addr_of (get_chill_filename ()),
1383 tree_cons (NULL_TREE
, get_chill_linenumber (),
1388 /* Compute the number of runtime members of the
1392 build_chill_card (powerset
)
1398 tree card_func
= lookup_name (get_identifier ("__cardpowerset"));
1400 if (powerset
== NULL_TREE
|| TREE_CODE (powerset
) == ERROR_MARK
)
1401 return error_mark_node
;
1403 if (TREE_CODE (powerset
) == IDENTIFIER_NODE
)
1404 powerset
= lookup_name (powerset
);
1406 if (TREE_CODE (TREE_TYPE(powerset
)) == SET_TYPE
)
1409 /* Do constant folding, if possible. */
1410 if (TREE_CODE (powerset
) == CONSTRUCTOR
1411 && TREE_CONSTANT (powerset
)
1412 && (size
= int_size_in_bytes (TREE_TYPE (powerset
))) >= 0)
1414 int bit_size
= size
* BITS_PER_UNIT
;
1415 char* buffer
= (char*) alloca (bit_size
);
1416 temp
= get_set_constructor_bits (powerset
, buffer
, bit_size
);
1420 for (i
= 0; i
< bit_size
; i
++)
1423 temp
= build_int_2 (count
, 0);
1424 TREE_TYPE (temp
) = TREE_TYPE (TREE_TYPE (card_func
));
1428 temp
= build_chill_function_call (card_func
,
1429 tree_cons (NULL_TREE
, force_addr_of (powerset
),
1430 tree_cons (NULL_TREE
, powersetlen (powerset
), NULL_TREE
)));
1431 /* FIXME: should call
1432 * cond_type_range_exception (op0);
1436 error("CARD argument must be powerset mode");
1437 return error_mark_node
;
1442 /* function to build the type needed for the DESCR-built-in
1445 void build_chill_descr_type ()
1449 if (descr_type
!= NULL_TREE
)
1453 decl1
= build_decl (FIELD_DECL
, get_identifier ("datap"), ptr_type_node
);
1454 decl2
= build_decl (FIELD_DECL
, get_identifier ("len"),
1455 TREE_TYPE (lookup_name (
1456 get_identifier ((ignore_case
|| ! special_UC
) ? "ulong" : "ULONG"))));
1457 TREE_CHAIN (decl1
) = decl2
;
1458 TREE_CHAIN (decl2
) = NULL_TREE
;
1459 decl2
= build_chill_struct_type (decl1
);
1460 descr_type
= build_decl (TYPE_DECL
, get_identifier ("__tmp_DESCR_type"), decl2
);
1461 pushdecl (descr_type
);
1462 DECL_SOURCE_LINE (descr_type
) = 0;
1463 satisfy_decl (descr_type
, 0);
1466 /* build a pointer to a descriptor.
1467 * descriptor = STRUCT (datap PTR,
1469 * This descriptor is build in variable descr_type.
1473 build_chill_descr (expr
)
1478 tree tuple
, decl
, descr_var
, datap
, len
, tmp
;
1481 if (expr
== NULL_TREE
|| TREE_CODE (expr
) == ERROR_MARK
)
1482 return error_mark_node
;
1484 /* check for expression is referable */
1485 if (! CH_REFERABLE (expr
))
1487 error ("expression for DESCR-builtin must be referable.");
1488 return error_mark_node
;
1491 mark_addressable (expr
);
1493 datap
= build1 (ADDR_EXPR
, build_chill_pointer_type (descr_type
), expr
);
1495 datap
= build_chill_arrow_expr (expr
, 1);
1497 len
= size_in_bytes (TREE_TYPE (expr
));
1499 descr_var
= get_unique_identifier ("DESCR");
1500 tuple
= build_nt (CONSTRUCTOR
, NULL_TREE
,
1501 tree_cons (NULL_TREE
, datap
,
1502 tree_cons (NULL_TREE
, len
, NULL_TREE
)));
1504 is_static
= (current_function_decl
== global_function_decl
) && TREE_STATIC (expr
);
1505 decl
= decl_temp1 (descr_var
, TREE_TYPE (descr_type
), is_static
,
1508 tmp
= force_addr_of (decl
);
1510 tmp
= build_chill_arrow_expr (decl
, 1);
1517 /* this function process the builtin's
1518 MILLISECS, SECS, MINUTES, HOURS and DAYS.
1519 The built duration value is in milliseconds. */
1522 build_chill_duration (expr
, multiplier
, fnname
, maxvalue
)
1524 unsigned long multiplier
;
1526 unsigned long maxvalue
;
1530 if (expr
== NULL_TREE
|| TREE_CODE (expr
) == ERROR_MARK
)
1531 return error_mark_node
;
1533 if (TREE_CODE (TREE_TYPE (expr
)) != INTEGER_TYPE
)
1535 error ("argument to `%s' must be of integer type.", IDENTIFIER_POINTER (fnname
));
1536 return error_mark_node
;
1539 temp
= convert (duration_timing_type_node
, expr
);
1540 temp
= fold (build (MULT_EXPR
, duration_timing_type_node
,
1541 temp
, build_int_2 (multiplier
, 0)));
1544 temp
= check_range (temp
, expr
, integer_zero_node
, build_int_2 (maxvalue
, 0));
1549 /* build function call to one of the floating point functions */
1551 build_chill_floatcall (expr
, chillname
, funcname
)
1553 const char *chillname
;
1554 const char *funcname
;
1559 if (expr
== NULL_TREE
|| TREE_CODE (expr
) == ERROR_MARK
)
1560 return error_mark_node
;
1562 /* look if expr is a REAL_TYPE */
1563 type
= TREE_TYPE (expr
);
1564 if (type
== NULL_TREE
|| TREE_CODE (type
) == ERROR_MARK
)
1565 return error_mark_node
;
1566 if (TREE_CODE (type
) != REAL_TYPE
)
1568 error ("argument 1 to `%s' must be of floating point mode", chillname
);
1569 return error_mark_node
;
1571 result
= build_chill_function_call (
1572 lookup_name (get_identifier (funcname
)),
1573 tree_cons (NULL_TREE
, expr
, NULL_TREE
));
1577 /* common function for ALLOCATE and GETSTACK */
1579 build_allocate_getstack (mode
, value
, chill_name
, fnname
, filename
, linenumber
)
1582 const char *chill_name
;
1588 tree expr
= NULL_TREE
;
1589 tree args
, tmpvar
, fncall
, ptr
, outlist
= NULL_TREE
;
1591 if (mode
== NULL_TREE
|| TREE_CODE (mode
) == ERROR_MARK
)
1592 return error_mark_node
;
1594 if (TREE_CODE (mode
) == TYPE_DECL
)
1595 type
= TREE_TYPE (mode
);
1599 /* check if we have a mode */
1600 if (TREE_CODE_CLASS (TREE_CODE (type
)) != 't')
1602 error ("First argument to `%s' must be a mode", chill_name
);
1603 return error_mark_node
;
1606 /* check if we have a value if type is READonly */
1607 if (TYPE_READONLY_PROPERTY (type
) && value
== NULL_TREE
)
1609 error ("READonly modes for %s must have a value", chill_name
);
1610 return error_mark_node
;
1613 if (value
!= NULL_TREE
)
1615 if (TREE_CODE (value
) == ERROR_MARK
)
1616 return error_mark_node
;
1617 expr
= chill_convert_for_assignment (type
, value
, "assignment");
1620 /* build function arguments */
1621 if (filename
== NULL_TREE
)
1622 args
= tree_cons (NULL_TREE
, size_in_bytes (type
), NULL_TREE
);
1624 args
= tree_cons (NULL_TREE
, size_in_bytes (type
),
1625 tree_cons (NULL_TREE
, force_addr_of (filename
),
1626 tree_cons (NULL_TREE
, linenumber
, NULL_TREE
)));
1628 ptr
= build_chill_pointer_type (type
);
1629 tmpvar
= decl_temp1 (get_unique_identifier (chill_name
),
1630 ptr
, 0, NULL_TREE
, 0, 0);
1631 fncall
= build_chill_function_call (
1632 lookup_name (get_identifier (fnname
)), args
);
1633 outlist
= tree_cons (NULL_TREE
,
1634 build_chill_modify_expr (tmpvar
, fncall
), outlist
);
1635 if (expr
== NULL_TREE
)
1637 /* set allocated memory to 0 */
1638 fncall
= build_chill_function_call (
1639 lookup_name (get_identifier ("memset")),
1640 tree_cons (NULL_TREE
, convert (ptr_type_node
, tmpvar
),
1641 tree_cons (NULL_TREE
, integer_zero_node
,
1642 tree_cons (NULL_TREE
, size_in_bytes (type
), NULL_TREE
))));
1643 outlist
= tree_cons (NULL_TREE
, fncall
, outlist
);
1647 /* write the init value to allocated memory */
1648 outlist
= tree_cons (NULL_TREE
,
1649 build_chill_modify_expr (build_chill_indirect_ref (tmpvar
, NULL_TREE
, 0),
1653 outlist
= tree_cons (NULL_TREE
, tmpvar
, outlist
);
1654 result
= build_chill_compound_expr (nreverse (outlist
));
1658 /* process the ALLOCATE built-in */
1660 build_chill_allocate (mode
, value
)
1664 return build_allocate_getstack (mode
, value
, "ALLOCATE", "__allocate",
1665 get_chill_filename (), get_chill_linenumber ());
1668 /* process the GETSTACK built-in */
1670 build_chill_getstack (mode
, value
)
1674 return build_allocate_getstack (mode
, value
, "GETSTACK", "__builtin_alloca",
1675 NULL_TREE
, NULL_TREE
);
1678 /* process the TERMINATE built-in */
1680 build_chill_terminate (ptr
)
1686 if (ptr
== NULL_TREE
|| TREE_CODE (ptr
) == ERROR_MARK
)
1687 return error_mark_node
;
1689 type
= TREE_TYPE (ptr
);
1690 if (type
== NULL_TREE
|| TREE_CODE (type
) != POINTER_TYPE
)
1692 error ("argument to TERMINATE must be a reference primitive value");
1693 return error_mark_node
;
1695 result
= build_chill_function_call (
1696 lookup_name (get_identifier ("__terminate")),
1697 tree_cons (NULL_TREE
, convert (ptr_type_node
, ptr
),
1698 tree_cons (NULL_TREE
, force_addr_of (get_chill_filename ()),
1699 tree_cons (NULL_TREE
, get_chill_linenumber (), NULL_TREE
))));
1703 /* build the type passed to _inttime function */
1705 build_chill_inttime_type ()
1711 idxlist
= build_tree_list (NULL_TREE
,
1712 build_chill_range_type (NULL_TREE
,
1714 build_int_2 (5, 0)));
1715 arrtype
= build_chill_array_type (ptr_type_node
, idxlist
, 0, NULL_TREE
);
1717 decl
= build_decl (TYPE_DECL
, get_identifier ("__tmp_INTTIME_type"), arrtype
);
1719 DECL_SOURCE_LINE (decl
) = 0;
1720 satisfy_decl (decl
, 0);
1724 build_chill_inttime (t
, loclist
)
1727 int had_errors
= 0, cnt
;
1729 tree init
= NULL_TREE
;
1733 if (t
== NULL_TREE
|| TREE_CODE (t
) == ERROR_MARK
)
1734 return error_mark_node
;
1735 if (loclist
== NULL_TREE
|| TREE_CODE (loclist
) == ERROR_MARK
)
1736 return error_mark_node
;
1738 /* check first argument to be NEWMODE TIME */
1739 if (TREE_TYPE (t
) != abs_timing_type_node
)
1741 error ("argument 1 to INTTIME must be of mode TIME.");
1747 while (tmp
!= NULL_TREE
)
1749 tree loc
= TREE_VALUE (tmp
);
1752 int write_error
= 0;
1754 sprintf (errmsg
, "argument %d to INTTIME must be ", cnt
);
1755 p
= errmsg
+ strlen (errmsg
);
1758 if (loc
== NULL_TREE
|| TREE_CODE (loc
) == ERROR_MARK
)
1762 if (! CH_REFERABLE (loc
))
1764 strcpy (p
, "referable");
1769 if (TREE_CODE (TREE_TYPE (loc
)) != INTEGER_TYPE
)
1773 strcpy (p
, " and ");
1776 strcpy (p
, "of integer type");
1780 /* FIXME: what's about ranges can't hold the result ?? */
1782 error ("%s.", errmsg
);
1785 tmp
= TREE_CHAIN (tmp
);
1790 return error_mark_node
;
1792 /* make it always 6 arguments */
1793 numargs
= list_length (loclist
);
1794 for (cnt
= numargs
; cnt
< 6; cnt
++)
1795 init
= tree_cons (NULL_TREE
, null_pointer_node
, init
);
1797 /* append the given one's */
1799 while (tmp
!= NULL_TREE
)
1801 init
= chainon (init
,
1802 build_tree_list (NULL_TREE
,
1803 build_chill_descr (TREE_VALUE (tmp
))));
1804 tmp
= TREE_CHAIN (tmp
);
1807 tuple
= build_nt (CONSTRUCTOR
, NULL_TREE
, init
);
1808 var
= decl_temp1 (get_unique_identifier ("INTTIME"),
1809 TREE_TYPE (lookup_name (get_identifier ("__tmp_INTTIME_type"))),
1812 return build_chill_function_call (
1813 lookup_name (get_identifier ("_inttime")),
1814 tree_cons (NULL_TREE
, t
,
1815 tree_cons (NULL_TREE
, force_addr_of (var
),
1820 /* Compute the runtime length of the given string variable
1824 build_chill_length (expr
)
1831 if (expr
== NULL_TREE
|| TREE_CODE (expr
) == ERROR_MARK
)
1832 return error_mark_node
;
1834 if (TREE_CODE (expr
) == IDENTIFIER_NODE
)
1835 expr
= lookup_name (expr
);
1837 type
= TREE_TYPE (expr
);
1839 if (TREE_CODE(type
) == ERROR_MARK
)
1841 if (chill_varying_type_p (type
))
1843 tree temp
= convert (integer_type_node
,
1844 build_component_ref (expr
, var_length_id
));
1845 /* FIXME: should call
1846 * cond_type_range_exception (temp);
1851 if ((TREE_CODE (type
) == ARRAY_TYPE
||
1852 /* should work for a bitstring too */
1853 (TREE_CODE (type
) == SET_TYPE
&& TREE_CODE (TREE_TYPE (type
)) == BOOLEAN_TYPE
)) &&
1854 integer_zerop (TYPE_MIN_VALUE (TYPE_DOMAIN (type
))))
1856 tree temp
= fold (build (PLUS_EXPR
, chill_integer_type_node
,
1858 TYPE_MAX_VALUE (TYPE_DOMAIN (type
))));
1859 return convert (chill_integer_type_node
, temp
);
1862 if (CH_IS_BUFFER_MODE (type
) || CH_IS_EVENT_MODE (type
))
1864 tree len
= max_queue_size (type
);
1866 if (len
== NULL_TREE
)
1867 len
= integer_minus_one_node
;
1871 if (CH_IS_TEXT_MODE (type
))
1873 if (TREE_CODE (expr
) == TYPE_DECL
)
1875 /* text mode name */
1876 return text_length (type
);
1881 tree temp
= build_component_ref (
1882 build_component_ref (expr
, get_identifier ("tloc")),
1884 return convert (integer_type_node
, temp
);
1888 error("LENGTH argument must be string, buffer, event mode, text location or mode");
1889 return error_mark_node
;
1894 /* Compute the declared minimum/maximum value of the variable,
1895 * expression or declared type
1898 build_chill_lower_or_upper (what
, is_upper
)
1900 int is_upper
; /* o -> LOWER; 1 -> UPPER */
1905 struct ch_class
class;
1907 if (what
== NULL_TREE
|| TREE_CODE (what
) == ERROR_MARK
)
1908 return error_mark_node
;
1910 if (TREE_CODE_CLASS (TREE_CODE (what
)) == 't')
1913 type
= TREE_TYPE (what
);
1914 if (type
== NULL_TREE
)
1917 error ("UPPER argument must have a mode, or be a mode");
1919 error ("LOWER argument must have a mode, or be a mode");
1920 return error_mark_node
;
1922 while (TREE_CODE (type
) == REFERENCE_TYPE
)
1923 type
= TREE_TYPE (type
);
1924 if (chill_varying_type_p (type
))
1925 type
= CH_VARYING_ARRAY_TYPE (type
);
1927 if (discrete_type_p (type
))
1929 tree val
= is_upper
? TYPE_MAX_VALUE (type
) : TYPE_MIN_VALUE (type
);
1930 class.kind
= CH_VALUE_CLASS
;
1932 return convert_to_class (class, val
);
1934 else if (TREE_CODE (type
) == ARRAY_TYPE
|| TREE_CODE (type
) == SET_TYPE
)
1936 if (TYPE_STRING_FLAG (type
))
1938 class.kind
= CH_DERIVED_CLASS
;
1939 class.mode
= integer_type_node
;
1943 class.kind
= CH_VALUE_CLASS
;
1944 class.mode
= TYPE_DOMAIN (type
);
1946 type
= TYPE_DOMAIN (type
);
1947 return convert_to_class (class,
1949 ? TYPE_MAX_VALUE (type
)
1950 : TYPE_MIN_VALUE (type
));
1953 error("UPPER argument must be string, array, mode or integer");
1955 error("LOWER argument must be string, array, mode or integer");
1956 return error_mark_node
;
1962 build_chill_lower (what
)
1965 return build_chill_lower_or_upper (what
, 0);
1969 build_max_min (expr
, max_min
)
1971 int max_min
; /* 0: calculate MIN; 1: calculate MAX */
1975 tree type
, temp
, setminval
;
1979 if (expr
== NULL_TREE
|| TREE_CODE (expr
) == ERROR_MARK
)
1980 return error_mark_node
;
1982 if (TREE_CODE (expr
) == IDENTIFIER_NODE
)
1983 expr
= lookup_name (expr
);
1985 type
= TREE_TYPE (expr
);
1986 set_base_type
= TYPE_DOMAIN (type
);
1987 setminval
= TYPE_MIN_VALUE (set_base_type
);
1989 if (TREE_CODE (type
) != SET_TYPE
)
1991 error("%s argument must be POWERSET mode",
1992 max_min
? "MAX" : "MIN");
1993 return error_mark_node
;
1996 /* find max/min of constant powerset at compile time */
1997 if (TREE_CODE (expr
) == CONSTRUCTOR
&& TREE_CONSTANT (expr
)
1998 && (size_in_bytes
= int_size_in_bytes (type
)) >= 0)
2000 HOST_WIDE_INT min_val
= -1, max_val
= -1;
2001 HOST_WIDE_INT i
, i_hi
= 0;
2002 HOST_WIDE_INT size_in_bits
= size_in_bytes
* BITS_PER_UNIT
;
2003 char *buffer
= (char*) alloca (size_in_bits
);
2005 || get_set_constructor_bits (expr
, buffer
, size_in_bits
))
2007 for (i
= 0; i
< size_in_bits
; i
++)
2017 error ("%s called for empty POWERSET", max_min
? "MAX" : "MIN");
2018 i
= max_min
? max_val
: min_val
;
2019 temp
= TYPE_MIN_VALUE (TYPE_DOMAIN (TREE_TYPE (expr
)));
2020 add_double (i
, i_hi
,
2021 TREE_INT_CST_LOW (temp
), TREE_INT_CST_HIGH (temp
),
2023 temp
= build_int_2 (i
, i_hi
);
2024 TREE_TYPE (temp
) = set_base_type
;
2029 tree parmlist
, filename
, lineno
;
2030 const char *funcname
;
2032 /* set up to call appropriate runtime function */
2034 funcname
= "__flsetpowerset";
2036 funcname
= "__ffsetpowerset";
2038 setminval
= convert (long_integer_type_node
, setminval
);
2039 filename
= force_addr_of (get_chill_filename());
2040 lineno
= get_chill_linenumber();
2041 parmlist
= tree_cons (NULL_TREE
, force_addr_of (expr
),
2042 tree_cons (NULL_TREE
, powersetlen (expr
),
2043 tree_cons (NULL_TREE
, setminval
,
2044 tree_cons (NULL_TREE
, filename
,
2045 build_tree_list (NULL_TREE
, lineno
)))));
2046 temp
= lookup_name (get_identifier (funcname
));
2047 temp
= build_chill_function_call (temp
, parmlist
);
2048 TREE_TYPE (temp
) = set_base_type
;
2056 /* Compute the current runtime maximum value of the powerset
2059 build_chill_max (expr
)
2062 return build_max_min (expr
, 1);
2066 /* Compute the current runtime minimum value of the powerset
2069 build_chill_min (expr
)
2072 return build_max_min (expr
, 0);
2076 /* Build a conversion from the given expression to an INT,
2077 * but only when the expression's type is the same size as
2081 build_chill_num (expr
)
2089 if (expr
== NULL_TREE
|| TREE_CODE(expr
) == ERROR_MARK
)
2090 return error_mark_node
;
2092 if (TREE_CODE (expr
) == IDENTIFIER_NODE
)
2093 expr
= lookup_name (expr
);
2095 expr
= convert_to_discrete (expr
);
2096 if (expr
== NULL_TREE
)
2098 error ("argument to NUM is not discrete");
2099 return error_mark_node
;
2102 /* enumeral types and string slices of length 1 must be kept unsigned */
2103 need_unsigned
= (TREE_CODE (TREE_TYPE (expr
)) == ENUMERAL_TYPE
)
2104 || TREE_UNSIGNED (TREE_TYPE (expr
));
2106 temp
= type_for_size (TYPE_PRECISION (TREE_TYPE (expr
)),
2108 if (temp
== NULL_TREE
)
2110 error ("No integer mode which matches expression's mode");
2111 return integer_zero_node
;
2113 temp
= convert (temp
, expr
);
2115 if (TREE_CONSTANT (temp
))
2117 if (tree_int_cst_lt (temp
,
2118 TYPE_MIN_VALUE (TREE_TYPE (temp
))))
2119 error ("NUM's parameter is below its mode range");
2120 if (tree_int_cst_lt (TYPE_MAX_VALUE (TREE_TYPE (temp
)),
2122 error ("NUM's parameter is above its mode range");
2128 cond_overflow_exception (temp
,
2129 TYPE_MIN_VALUE (TREE_TYPE (temp
)),
2130 TYPE_MAX_VALUE (TREE_TYPE (temp
)));
2134 /* NUM delivers the INT derived class */
2135 CH_DERIVED_FLAG (temp
) = 1;
2144 build_chill_pred_or_succ (expr
, op
)
2146 enum tree_code op
; /* PLUS_EXPR for SUCC; MINUS_EXPR for PRED. */
2148 struct ch_class
class;
2154 if (expr
== NULL_TREE
|| TREE_CODE (expr
) == ERROR_MARK
)
2155 return error_mark_node
;
2157 /* disallow numbered SETs */
2158 if (TREE_CODE (TREE_TYPE (expr
)) == ENUMERAL_TYPE
2159 && CH_ENUM_IS_NUMBERED (TREE_TYPE (expr
)))
2161 error ("Cannot take SUCC or PRED of a numbered SET");
2162 return error_mark_node
;
2165 if (TREE_CODE (TREE_TYPE (expr
)) == POINTER_TYPE
)
2167 if (TREE_TYPE (TREE_TYPE (expr
)) == void_type_node
)
2169 error ("SUCC or PRED must not be done on a PTR.");
2170 return error_mark_node
;
2172 pedwarn ("SUCC or PRED for a reference type is not standard.");
2173 return fold (build (op
, TREE_TYPE (expr
),
2175 size_in_bytes (TREE_TYPE (TREE_TYPE (expr
)))));
2178 expr
= convert_to_discrete (expr
);
2180 if (expr
== NULL_TREE
)
2182 error ("SUCC or PRED argument must be a discrete mode");
2183 return error_mark_node
;
2186 class = chill_expr_class (expr
);
2188 class.mode
= CH_ROOT_MODE (class.mode
);
2190 expr
= convert (etype
, expr
);
2192 /* Exception if expression is already at the
2193 min (PRED)/max(SUCC) valid value for its type. */
2194 cond
= fold (build (op
== PLUS_EXPR
? GE_EXPR
: LE_EXPR
,
2198 op
== PLUS_EXPR
? TYPE_MAX_VALUE (etype
)
2199 : TYPE_MIN_VALUE (etype
))));
2200 if (TREE_CODE (cond
) == INTEGER_CST
2201 && tree_int_cst_equal (cond
, integer_one_node
))
2203 error ("Taking the %s of a value already at its %s value",
2204 op
== PLUS_EXPR
? "SUCC" : "PRED",
2205 op
== PLUS_EXPR
? "maximum" : "minimum");
2206 return error_mark_node
;
2210 expr
= check_expression (expr
, cond
,
2211 ridpointers
[(int) RID_OVERFLOW
]);
2213 expr
= fold (build (op
, etype
, expr
,
2214 convert (etype
, integer_one_node
)));
2215 return convert_to_class (class, expr
);
2218 /* Compute the value of the CHILL `size' operator just
2219 * like the C 'sizeof' operator (code stolen from c-typeck.c)
2220 * TYPE may be a location or mode tree. In pass 1, we build
2221 * a function-call syntax tree; in pass 2, we evaluate it.
2224 build_chill_sizeof (type
)
2230 struct ch_class
class;
2231 enum tree_code code
;
2232 tree signame
= NULL_TREE
;
2234 if (type
== NULL_TREE
|| TREE_CODE (type
) == ERROR_MARK
)
2235 return error_mark_node
;
2237 if (TREE_CODE (type
) == IDENTIFIER_NODE
)
2238 type
= lookup_name (type
);
2240 code
= TREE_CODE (type
);
2241 if (code
== ERROR_MARK
)
2242 return error_mark_node
;
2244 if (TREE_CODE_CLASS (TREE_CODE (type
)) != 't')
2246 if (TREE_CODE (type
) == TYPE_DECL
&& CH_DECL_SIGNAL (type
))
2247 signame
= DECL_NAME (type
);
2248 type
= TREE_TYPE (type
);
2251 if (code
== FUNCTION_TYPE
)
2253 if (pedantic
|| warn_pointer_arith
)
2254 pedwarn ("size applied to a function mode");
2255 return error_mark_node
;
2257 if (code
== VOID_TYPE
)
2259 if (pedantic
|| warn_pointer_arith
)
2260 pedwarn ("sizeof applied to a void mode");
2261 return error_mark_node
;
2263 if (TYPE_SIZE (type
) == 0)
2265 error ("sizeof applied to an incomplete mode");
2266 return error_mark_node
;
2269 temp
= size_binop (CEIL_DIV_EXPR
, TYPE_SIZE_UNIT (type
),
2270 size_int (TYPE_PRECISION (char_type_node
)
2272 if (signame
!= NULL_TREE
)
2274 /* we have a signal definition. This signal may have no
2275 data items specified. The definition however says that
2276 there are data, cause we cannot build a structure without
2277 fields. In this case return 0. */
2278 if (IDENTIFIER_SIGNAL_DATA (signame
) == 0)
2279 temp
= integer_zero_node
;
2282 /* FIXME: should call
2283 * cond_type_range_exception (temp);
2285 class.kind
= CH_DERIVED_CLASS
;
2286 class.mode
= integer_type_node
;
2287 return convert_to_class (class, temp
);
2292 /* Compute the declared maximum value of the variable,
2293 * expression or declared type
2296 build_chill_upper (what
)
2299 return build_chill_lower_or_upper (what
, 1);
2303 * Here at the site of a function/procedure call.. We need to build
2304 * temps for the INOUT and OUT parameters, and copy the actual parameters
2305 * into the temps. After the call, we 'copy back' the values from the
2306 * temps to the actual parameter variables. This somewhat verbose pol-
2307 * icy meets the requirement that the actual parameters are undisturbed
2308 * if the function/procedure causes an exception. They are updated only
2309 * upon a normal return from the function.
2311 * Note: the expr_list, which collects all of the above assignments, etc,
2312 * is built in REVERSE execution order. The list is corrected by nreverse
2313 * inside the build_chill_compound_expr call.
2316 build_chill_function_call (function
, expr
)
2317 tree function
, expr
;
2319 register tree typetail
, valtail
, typelist
;
2320 register tree temp
, actual_args
= NULL_TREE
;
2321 tree name
= NULL_TREE
;
2324 int parmno
= 1; /* parameter number for error message */
2325 int callee_raise_exception
= 0;
2327 /* list of assignments to run after the actual call,
2328 copying from the temps back to the user's variables. */
2329 tree copy_back
= NULL_TREE
;
2331 /* list of expressions to run before the call, copying from
2332 the user's variable to the temps that are passed to the function */
2333 tree expr_list
= NULL_TREE
;
2335 if (function
== NULL_TREE
|| TREE_CODE (function
) == ERROR_MARK
)
2336 return error_mark_node
;
2338 if (expr
!= NULL_TREE
&& TREE_CODE (expr
) == ERROR_MARK
)
2339 return error_mark_node
;
2342 return error_mark_node
;
2344 fntype
= TREE_TYPE (function
);
2345 if (TREE_CODE (function
) == FUNCTION_DECL
)
2347 callee_raise_exception
= TYPE_RAISES_EXCEPTIONS (fntype
) != NULL_TREE
;
2349 /* Differs from default_conversion by not setting TREE_ADDRESSABLE
2350 (because calling an inline function does not mean the function
2351 needs to be separately compiled). */
2352 fntype
= build_type_variant (fntype
,
2353 TREE_READONLY (function
),
2354 TREE_THIS_VOLATILE (function
));
2355 name
= DECL_NAME (function
);
2357 /* check that function is not a PROCESS */
2358 if (CH_DECL_PROCESS (function
))
2360 error ("cannot call a PROCESS, you START a PROCESS");
2361 return error_mark_node
;
2364 function
= build1 (ADDR_EXPR
, build_pointer_type (fntype
), function
);
2366 else if (TREE_CODE (fntype
) == POINTER_TYPE
)
2368 fntype
= TREE_TYPE (fntype
);
2369 callee_raise_exception
= TYPE_RAISES_EXCEPTIONS (fntype
) != NULL_TREE
;
2371 /* Z.200 6.7 Call Action:
2372 "A procedure call causes the EMPTY exception if the
2373 procedure primitive value delivers NULL. */
2374 if (TREE_CODE (function
) != ADDR_EXPR
2375 || TREE_CODE (TREE_OPERAND (function
, 0)) != FUNCTION_DECL
)
2376 function
= check_non_null (function
);
2379 typelist
= TYPE_ARG_TYPES (fntype
);
2380 if (callee_raise_exception
)
2382 /* remove last two arguments from list for subsequent checking.
2383 They will get added automatically after checking */
2384 int len
= list_length (typelist
);
2386 tree newtypelist
= NULL_TREE
;
2387 tree wrk
= typelist
;
2389 for (i
= 0; i
< len
- 3; i
++)
2391 newtypelist
= tree_cons (TREE_PURPOSE (wrk
), TREE_VALUE (wrk
), newtypelist
);
2392 wrk
= TREE_CHAIN (wrk
);
2394 /* add the void_type_node */
2395 newtypelist
= tree_cons (NULL_TREE
, void_type_node
, newtypelist
);
2396 typelist
= nreverse (newtypelist
);
2399 /* Scan the given expressions and types, producing individual
2400 converted arguments and pushing them on ACTUAL_ARGS in
2402 for (valtail
= expr
, typetail
= typelist
;
2403 valtail
!= NULL_TREE
&& typetail
!= NULL_TREE
; parmno
++,
2404 valtail
= TREE_CHAIN (valtail
), typetail
= TREE_CHAIN (typetail
))
2406 register tree actual
= TREE_VALUE (valtail
);
2407 register tree attr
= TREE_PURPOSE (typetail
)
2408 ? TREE_PURPOSE (typetail
) : ridpointers
[(int) RID_IN
];
2409 register tree type
= TREE_VALUE (typetail
);
2411 sprintf (place
, "parameter %d", parmno
);
2413 /* if we have reached void_type_node in typelist we are at the
2414 end of formal parameters and then we have too many actual
2416 if (type
== void_type_node
)
2419 /* check if actual is a TYPE_DECL. FIXME: what else ? */
2420 if (TREE_CODE (actual
) == TYPE_DECL
)
2422 error ("invalid %s", place
);
2423 actual
= error_mark_node
;
2425 /* INOUT or OUT param to handle? */
2426 else if (attr
== ridpointers
[(int) RID_OUT
]
2427 || attr
== ridpointers
[(int)RID_INOUT
])
2431 tree in_actual
= NULL_TREE
, out_actual
;
2433 /* actual parameter must be a location so we can
2434 build a reference to it */
2435 if (!CH_LOCATION_P (actual
))
2437 error ("%s parameter %d must be a location",
2438 (attr
== ridpointers
[(int) RID_OUT
]) ?
2439 "OUT" : "INOUT", parmno
);
2442 if (TYPE_READONLY_PROPERTY (TREE_TYPE (actual
))
2443 || TREE_READONLY (actual
))
2445 error ("%s parameter %d is READ-only",
2446 (attr
== ridpointers
[(int) RID_OUT
]) ?
2447 "OUT" : "INOUT", parmno
);
2451 sprintf (temp_name
, "PARM_%d_%s", parmno
,
2452 (attr
== ridpointers
[(int)RID_OUT
]) ?
2454 parmtmp
= decl_temp1 (get_unique_identifier (temp_name
),
2455 TREE_TYPE (type
), 0, NULL_TREE
, 0, 0);
2456 /* this temp *must not* be optimized into a register */
2457 mark_addressable (parmtmp
);
2459 if (attr
== ridpointers
[(int)RID_INOUT
])
2461 tree in_actual
= chill_convert_for_assignment (TREE_TYPE (type
),
2463 tree tmp
= build_chill_modify_expr (parmtmp
, in_actual
);
2464 expr_list
= tree_cons (NULL_TREE
, tmp
, expr_list
);
2466 if (in_actual
!= error_mark_node
)
2468 /* list of copy back assignments to perform, from the temp
2469 back to the actual parameter */
2470 out_actual
= chill_convert_for_assignment (TREE_TYPE (actual
),
2472 copy_back
= tree_cons (NULL_TREE
,
2473 build_chill_modify_expr (actual
,
2477 /* we can do this because build_chill_function_type
2478 turned these parameters into REFERENCE_TYPEs. */
2479 actual
= build1 (ADDR_EXPR
, type
, parmtmp
);
2481 else if (attr
== ridpointers
[(int) RID_LOC
])
2483 int is_location
= chill_location (actual
);
2486 if (is_location
== 1)
2488 error ("LOC actual parameter %d is a non-referable location",
2490 actual
= error_mark_node
;
2492 else if (! CH_READ_COMPATIBLE (type
, TREE_TYPE (actual
)))
2494 error ("mode mismatch in parameter %d", parmno
);
2495 actual
= error_mark_node
;
2498 actual
= convert (type
, actual
);
2502 sprintf (place
, "parameter_%d", parmno
);
2503 actual
= decl_temp1 (get_identifier (place
),
2504 TREE_TYPE (type
), 0, actual
, 0, 0);
2505 actual
= convert (type
, actual
);
2507 mark_addressable (actual
);
2510 actual
= chill_convert_for_assignment (type
, actual
, place
);
2512 actual_args
= tree_cons (NULL_TREE
, actual
, actual_args
);
2515 if (valtail
!= 0 && TREE_VALUE (valtail
) != void_type_node
)
2518 error ("too many arguments to procedure `%s'",
2519 IDENTIFIER_POINTER (name
));
2521 error ("too many arguments to procedure");
2522 return error_mark_node
;
2524 else if (typetail
!= 0 && TREE_VALUE (typetail
) != void_type_node
)
2527 error ("too few arguments to procedure `%s'",
2528 IDENTIFIER_POINTER (name
));
2530 error ("too few arguments to procedure");
2531 return error_mark_node
;
2534 if (callee_raise_exception
)
2536 /* add linenumber and filename of the caller as arguments */
2537 actual_args
= tree_cons (NULL_TREE
, force_addr_of (get_chill_filename ()),
2539 actual_args
= tree_cons (NULL_TREE
, get_chill_linenumber (), actual_args
);
2542 function_call
= build (CALL_EXPR
, TREE_TYPE (fntype
),
2543 function
, nreverse (actual_args
), NULL_TREE
);
2544 TREE_SIDE_EFFECTS (function_call
) = 1;
2546 if (copy_back
== NULL_TREE
&& expr_list
== NULL_TREE
)
2547 return function_call
; /* no copying to do, either way */
2550 tree result_type
= TREE_TYPE (fntype
);
2551 tree result_tmp
= NULL_TREE
;
2553 /* no result wanted from procedure call */
2554 if (result_type
== NULL_TREE
|| result_type
== void_type_node
)
2555 expr_list
= tree_cons (NULL_TREE
, function_call
, expr_list
);
2558 /* create a temp for the function's result. this is so that we can
2559 evaluate this temp as the last expression in the list, which will
2560 make the function's return value the value of the whole list of
2561 expressions (by the C rules for compound expressions) */
2562 result_tmp
= decl_temp1 (get_unique_identifier ("FUNC_RESULT"),
2563 result_type
, 0, NULL_TREE
, 0, 0);
2564 expr_list
= tree_cons (NULL_TREE
,
2565 build_chill_modify_expr (result_tmp
, function_call
),
2569 expr_list
= chainon (copy_back
, expr_list
);
2571 /* last, but not least, the function's result */
2572 if (result_tmp
!= NULL_TREE
)
2573 expr_list
= tree_cons (NULL_TREE
, result_tmp
, expr_list
);
2574 temp
= build_chill_compound_expr (nreverse (expr_list
));
2579 /* We saw something that looks like a function call,
2580 but if it's pass 1, we're not sure. */
2583 build_generalized_call (func
, args
)
2586 tree type
= TREE_TYPE (func
);
2589 return build (CALL_EXPR
, NULL_TREE
, func
, args
, NULL_TREE
);
2591 /* Handle string repetition */
2592 if (TREE_CODE (func
) == INTEGER_CST
)
2594 if (args
== NULL_TREE
|| TREE_CHAIN (args
) != NULL_TREE
)
2596 error ("syntax error (integer used as function)");
2597 return error_mark_node
;
2599 if (TREE_CODE (args
) == TREE_LIST
)
2600 args
= TREE_VALUE (args
);
2601 return build_chill_repetition_op (func
, args
);
2604 if (args
!= NULL_TREE
)
2606 if (TREE_CODE (args
) == RANGE_EXPR
)
2608 tree lo
= TREE_OPERAND (args
, 0), hi
= TREE_OPERAND (args
, 1);
2609 if (TREE_CODE_CLASS (TREE_CODE (func
)) == 't')
2610 return build_chill_range_type (func
, lo
, hi
);
2612 return build_chill_slice_with_range (func
, lo
, hi
);
2614 else if (TREE_CODE (args
) != TREE_LIST
)
2616 error ("syntax error - missing operator, comma, or '('?");
2617 return error_mark_node
;
2621 if (TREE_CODE (func
) == TYPE_DECL
)
2623 if (CH_DECL_SIGNAL (func
))
2624 return build_signal_descriptor (func
, args
);
2625 func
= TREE_TYPE (func
);
2628 if (TREE_CODE_CLASS (TREE_CODE (func
)) == 't'
2629 && args
!= NULL_TREE
&& TREE_CHAIN (args
) == NULL_TREE
)
2630 return build_chill_cast (func
, TREE_VALUE (args
));
2632 if (TREE_CODE (type
) == FUNCTION_TYPE
2633 || (TREE_CODE (type
) == POINTER_TYPE
2634 && TREE_TYPE (type
) != NULL_TREE
2635 && TREE_CODE (TREE_TYPE (type
)) == FUNCTION_TYPE
))
2637 /* Check for a built-in Chill function. */
2638 if (TREE_CODE (func
) == FUNCTION_DECL
2639 && DECL_BUILT_IN (func
)
2640 && DECL_FUNCTION_CODE (func
) > END_BUILTINS
)
2642 tree fnname
= DECL_NAME (func
);
2643 switch ((enum chill_built_in_function
)DECL_FUNCTION_CODE (func
))
2645 case BUILT_IN_CH_ABS
:
2646 if (check_arglist_length (args
, 1, 1, fnname
) < 0)
2647 return error_mark_node
;
2648 return build_chill_abs (TREE_VALUE (args
));
2649 case BUILT_IN_ABSTIME
:
2650 if (check_arglist_length (args
, 0, 6, fnname
) < 0)
2651 return error_mark_node
;
2652 return build_chill_abstime (args
);
2654 if (check_arglist_length (args
, 1, 1, fnname
) < 0)
2655 return error_mark_node
;
2657 return build_chill_addr_expr (TREE_VALUE (args
), (char *)0);
2659 return build_chill_arrow_expr (TREE_VALUE (args
), 0);
2661 case BUILT_IN_ALLOCATE_GLOBAL_MEMORY
:
2662 if (check_arglist_length (args
, 2, 2, fnname
) < 0)
2663 return error_mark_node
;
2664 return build_allocate_global_memory_call
2666 TREE_VALUE (TREE_CHAIN (args
)));
2667 case BUILT_IN_ALLOCATE
:
2668 if (check_arglist_length (args
, 1, 2, fnname
) < 0)
2669 return error_mark_node
;
2670 return build_chill_allocate (TREE_VALUE (args
),
2671 TREE_CHAIN (args
) == NULL_TREE
? NULL_TREE
: TREE_VALUE (TREE_CHAIN (args
)));
2672 case BUILT_IN_ALLOCATE_MEMORY
:
2673 if (check_arglist_length (args
, 2, 2, fnname
) < 0)
2674 return error_mark_node
;
2675 return build_allocate_memory_call
2677 TREE_VALUE (TREE_CHAIN (args
)));
2678 case BUILT_IN_ASSOCIATE
:
2679 if (check_arglist_length (args
, 2, 3, fnname
) < 0)
2680 return error_mark_node
;
2681 return build_chill_associate
2683 TREE_VALUE (TREE_CHAIN (args
)),
2684 TREE_CHAIN (TREE_CHAIN (args
)));
2685 case BUILT_IN_ARCCOS
:
2686 if (check_arglist_length (args
, 1, 1, fnname
) < 0)
2687 return error_mark_node
;
2688 return build_chill_floatcall (TREE_VALUE (args
),
2689 IDENTIFIER_POINTER (fnname
),
2691 case BUILT_IN_ARCSIN
:
2692 if (check_arglist_length (args
, 1, 1, fnname
) < 0)
2693 return error_mark_node
;
2694 return build_chill_floatcall (TREE_VALUE (args
),
2695 IDENTIFIER_POINTER (fnname
),
2697 case BUILT_IN_ARCTAN
:
2698 if (check_arglist_length (args
, 1, 1, fnname
) < 0)
2699 return error_mark_node
;
2700 return build_chill_floatcall (TREE_VALUE (args
),
2701 IDENTIFIER_POINTER (fnname
),
2704 if (check_arglist_length (args
, 1, 1, fnname
) < 0)
2705 return error_mark_node
;
2706 return build_chill_card (TREE_VALUE (args
));
2707 case BUILT_IN_CONNECT
:
2708 if (check_arglist_length (args
, 3, 5, fnname
) < 0)
2709 return error_mark_node
;
2710 return build_chill_connect
2712 TREE_VALUE (TREE_CHAIN (args
)),
2713 TREE_VALUE (TREE_CHAIN (TREE_CHAIN (args
))),
2714 TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (args
))));
2715 case BUILT_IN_COPY_NUMBER
:
2716 if (check_arglist_length (args
, 1, 1, fnname
) < 0)
2717 return error_mark_node
;
2718 return build_copy_number (TREE_VALUE (args
));
2719 case BUILT_IN_CH_COS
:
2720 if (check_arglist_length (args
, 1, 1, fnname
) < 0)
2721 return error_mark_node
;
2722 return build_chill_floatcall (TREE_VALUE (args
),
2723 IDENTIFIER_POINTER (fnname
),
2725 case BUILT_IN_CREATE
:
2726 if (check_arglist_length (args
, 1, 1, fnname
) < 0)
2727 return error_mark_node
;
2728 return build_chill_create (TREE_VALUE (args
));
2730 if (check_arglist_length (args
, 1, 1, fnname
) < 0)
2731 return error_mark_node
;
2732 return build_chill_duration (TREE_VALUE (args
), DAYS_MULTIPLIER
,
2734 case BUILT_IN_CH_DELETE
:
2735 if (check_arglist_length (args
, 1, 1, fnname
) < 0)
2736 return error_mark_node
;
2737 return build_chill_delete (TREE_VALUE (args
));
2738 case BUILT_IN_DESCR
:
2739 if (check_arglist_length (args
, 1, 1, fnname
) < 0)
2740 return error_mark_node
;
2741 return build_chill_descr (TREE_VALUE (args
));
2742 case BUILT_IN_DISCONNECT
:
2743 if (check_arglist_length (args
, 1, 1, fnname
) < 0)
2744 return error_mark_node
;
2745 return build_chill_disconnect (TREE_VALUE (args
));
2746 case BUILT_IN_DISSOCIATE
:
2747 if (check_arglist_length (args
, 1, 1, fnname
) < 0)
2748 return error_mark_node
;
2749 return build_chill_dissociate (TREE_VALUE (args
));
2751 if (check_arglist_length (args
, 1, 1, fnname
) < 0)
2752 return error_mark_node
;
2753 return build_chill_eoln (TREE_VALUE (args
));
2754 case BUILT_IN_EXISTING
:
2755 if (check_arglist_length (args
, 1, 1, fnname
) < 0)
2756 return error_mark_node
;
2757 return build_chill_existing (TREE_VALUE (args
));
2759 if (check_arglist_length (args
, 1, 1, fnname
) < 0)
2760 return error_mark_node
;
2761 return build_chill_floatcall (TREE_VALUE (args
),
2762 IDENTIFIER_POINTER (fnname
),
2764 case BUILT_IN_GEN_CODE
:
2765 if (check_arglist_length (args
, 1, 1, fnname
) < 0)
2766 return error_mark_node
;
2767 return build_gen_code (TREE_VALUE (args
));
2768 case BUILT_IN_GEN_INST
:
2769 if (check_arglist_length (args
, 2, 2, fnname
) < 0)
2770 return error_mark_node
;
2771 return build_gen_inst (TREE_VALUE (args
),
2772 TREE_VALUE (TREE_CHAIN (args
)));
2773 case BUILT_IN_GEN_PTYPE
:
2774 if (check_arglist_length (args
, 1, 1, fnname
) < 0)
2775 return error_mark_node
;
2776 return build_gen_ptype (TREE_VALUE (args
));
2777 case BUILT_IN_GETASSOCIATION
:
2778 if (check_arglist_length (args
, 1, 1, fnname
) < 0)
2779 return error_mark_node
;
2780 return build_chill_getassociation (TREE_VALUE (args
));
2781 case BUILT_IN_GETSTACK
:
2782 if (check_arglist_length (args
, 1, 2, fnname
) < 0)
2783 return error_mark_node
;
2784 return build_chill_getstack (TREE_VALUE (args
),
2785 TREE_CHAIN (args
) == NULL_TREE
? NULL_TREE
: TREE_VALUE (TREE_CHAIN (args
)));
2786 case BUILT_IN_GETTEXTACCESS
:
2787 if (check_arglist_length (args
, 1, 1, fnname
) < 0)
2788 return error_mark_node
;
2789 return build_chill_gettextaccess (TREE_VALUE (args
));
2790 case BUILT_IN_GETTEXTINDEX
:
2791 if (check_arglist_length (args
, 1, 1, fnname
) < 0)
2792 return error_mark_node
;
2793 return build_chill_gettextindex (TREE_VALUE (args
));
2794 case BUILT_IN_GETTEXTRECORD
:
2795 if (check_arglist_length (args
, 1, 1, fnname
) < 0)
2796 return error_mark_node
;
2797 return build_chill_gettextrecord (TREE_VALUE (args
));
2798 case BUILT_IN_GETUSAGE
:
2799 if (check_arglist_length (args
, 1, 1, fnname
) < 0)
2800 return error_mark_node
;
2801 return build_chill_getusage (TREE_VALUE (args
));
2802 case BUILT_IN_HOURS
:
2803 if (check_arglist_length (args
, 1, 1, fnname
) < 0)
2804 return error_mark_node
;
2805 return build_chill_duration (TREE_VALUE (args
), HOURS_MULTIPLIER
,
2807 case BUILT_IN_INDEXABLE
:
2808 if (check_arglist_length (args
, 1, 1, fnname
) < 0)
2809 return error_mark_node
;
2810 return build_chill_indexable (TREE_VALUE (args
));
2811 case BUILT_IN_INTTIME
:
2812 if (check_arglist_length (args
, 2, 7, fnname
) < 0)
2813 return error_mark_node
;
2814 return build_chill_inttime (TREE_VALUE (args
),
2816 case BUILT_IN_ISASSOCIATED
:
2817 if (check_arglist_length (args
, 1, 1, fnname
) < 0)
2818 return error_mark_node
;
2819 return build_chill_isassociated (TREE_VALUE (args
));
2820 case BUILT_IN_LENGTH
:
2821 if (check_arglist_length (args
, 1, 1, fnname
) < 0)
2822 return error_mark_node
;
2823 return build_chill_length (TREE_VALUE (args
));
2825 if (check_arglist_length (args
, 1, 1, fnname
) < 0)
2826 return error_mark_node
;
2827 return build_chill_floatcall (TREE_VALUE (args
),
2828 IDENTIFIER_POINTER (fnname
),
2831 if (check_arglist_length (args
, 1, 1, fnname
) < 0)
2832 return error_mark_node
;
2833 return build_chill_floatcall (TREE_VALUE (args
),
2834 IDENTIFIER_POINTER (fnname
),
2836 case BUILT_IN_LOWER
:
2837 if (check_arglist_length (args
, 1, 1, fnname
) < 0)
2838 return error_mark_node
;
2839 return build_chill_lower (TREE_VALUE (args
));
2841 if (check_arglist_length (args
, 1, 1, fnname
) < 0)
2842 return error_mark_node
;
2843 return build_chill_max (TREE_VALUE (args
));
2844 case BUILT_IN_MILLISECS
:
2845 if (check_arglist_length (args
, 1, 1, fnname
) < 0)
2846 return error_mark_node
;
2847 return build_chill_duration (TREE_VALUE (args
), MILLISECS_MULTIPLIER
,
2848 fnname
, MILLISECS_MAX
);
2850 if (check_arglist_length (args
, 1, 1, fnname
) < 0)
2851 return error_mark_node
;
2852 return build_chill_min (TREE_VALUE (args
));
2853 case BUILT_IN_MINUTES
:
2854 if (check_arglist_length (args
, 1, 1, fnname
) < 0)
2855 return error_mark_node
;
2856 return build_chill_duration (TREE_VALUE (args
), MINUTES_MULTIPLIER
,
2857 fnname
, MINUTES_MAX
);
2858 case BUILT_IN_MODIFY
:
2859 if (check_arglist_length (args
, 1, -1, fnname
) < 0)
2860 return error_mark_node
;
2861 return build_chill_modify (TREE_VALUE (args
), TREE_CHAIN (args
));
2863 if (check_arglist_length (args
, 1, 1, fnname
) < 0)
2864 return error_mark_node
;
2865 return build_chill_num (TREE_VALUE (args
));
2866 case BUILT_IN_OUTOFFILE
:
2867 if (check_arglist_length (args
, 1, 1, fnname
) < 0)
2868 return error_mark_node
;
2869 return build_chill_outoffile (TREE_VALUE (args
));
2871 if (check_arglist_length (args
, 1, 1, fnname
) < 0)
2872 return error_mark_node
;
2873 return build_chill_pred_or_succ (TREE_VALUE (args
), MINUS_EXPR
);
2874 case BUILT_IN_PROC_TYPE
:
2875 if (check_arglist_length (args
, 1, 1, fnname
) < 0)
2876 return error_mark_node
;
2877 return build_proc_type (TREE_VALUE (args
));
2878 case BUILT_IN_QUEUE_LENGTH
:
2879 if (check_arglist_length (args
, 1, 1, fnname
) < 0)
2880 return error_mark_node
;
2881 return build_queue_length (TREE_VALUE (args
));
2882 case BUILT_IN_READABLE
:
2883 if (check_arglist_length (args
, 1, 1, fnname
) < 0)
2884 return error_mark_node
;
2885 return build_chill_readable (TREE_VALUE (args
));
2886 case BUILT_IN_READRECORD
:
2887 if (check_arglist_length (args
, 1, 3, fnname
) < 0)
2888 return error_mark_node
;
2889 return build_chill_readrecord (TREE_VALUE (args
), TREE_CHAIN (args
));
2890 case BUILT_IN_READTEXT
:
2891 if (check_arglist_length (args
, 2, -1, fnname
) < 0)
2892 return error_mark_node
;
2893 return build_chill_readtext (TREE_VALUE (args
),
2895 case BUILT_IN_RETURN_MEMORY
:
2896 if (check_arglist_length (args
, 1, 1, fnname
) < 0)
2897 return error_mark_node
;
2898 return build_return_memory (TREE_VALUE (args
));
2900 if (check_arglist_length (args
, 1, 1, fnname
) < 0)
2901 return error_mark_node
;
2902 return build_chill_duration (TREE_VALUE (args
), SECS_MULTIPLIER
,
2904 case BUILT_IN_SEQUENCIBLE
:
2905 if (check_arglist_length (args
, 1, 1, fnname
) < 0)
2906 return error_mark_node
;
2907 return build_chill_sequencible (TREE_VALUE (args
));
2908 case BUILT_IN_SETTEXTACCESS
:
2909 if (check_arglist_length (args
, 2, 2, fnname
) < 0)
2910 return error_mark_node
;
2911 return build_chill_settextaccess (TREE_VALUE (args
),
2912 TREE_VALUE (TREE_CHAIN (args
)));
2913 case BUILT_IN_SETTEXTINDEX
:
2914 if (check_arglist_length (args
, 2, 2, fnname
) < 0)
2915 return error_mark_node
;
2916 return build_chill_settextindex (TREE_VALUE (args
),
2917 TREE_VALUE (TREE_CHAIN (args
)));
2918 case BUILT_IN_SETTEXTRECORD
:
2919 if (check_arglist_length (args
, 2, 2, fnname
) < 0)
2920 return error_mark_node
;
2921 return build_chill_settextrecord (TREE_VALUE (args
),
2922 TREE_VALUE (TREE_CHAIN (args
)));
2923 case BUILT_IN_CH_SIN
:
2924 if (check_arglist_length (args
, 1, 1, fnname
) < 0)
2925 return error_mark_node
;
2926 return build_chill_floatcall (TREE_VALUE (args
),
2927 IDENTIFIER_POINTER (fnname
),
2930 if (check_arglist_length (args
, 1, 1, fnname
) < 0)
2931 return error_mark_node
;
2932 return build_chill_sizeof (TREE_VALUE (args
));
2934 if (check_arglist_length (args
, 1, 1, fnname
) < 0)
2935 return error_mark_node
;
2936 return build_chill_floatcall (TREE_VALUE (args
),
2937 IDENTIFIER_POINTER (fnname
),
2940 if (check_arglist_length (args
, 1, 1, fnname
) < 0)
2941 return error_mark_node
;
2942 return build_chill_pred_or_succ (TREE_VALUE (args
), PLUS_EXPR
);
2944 if (check_arglist_length (args
, 1, 1, fnname
) < 0)
2945 return error_mark_node
;
2946 return build_chill_floatcall (TREE_VALUE (args
),
2947 IDENTIFIER_POINTER (fnname
),
2949 case BUILT_IN_TERMINATE
:
2950 if (check_arglist_length (args
, 1, 1, fnname
) < 0)
2951 return error_mark_node
;
2952 return build_chill_terminate (TREE_VALUE (args
));
2953 case BUILT_IN_UPPER
:
2954 if (check_arglist_length (args
, 1, 1, fnname
) < 0)
2955 return error_mark_node
;
2956 return build_chill_upper (TREE_VALUE (args
));
2957 case BUILT_IN_VARIABLE
:
2958 if (check_arglist_length (args
, 1, 1, fnname
) < 0)
2959 return error_mark_node
;
2960 return build_chill_variable (TREE_VALUE (args
));
2961 case BUILT_IN_WRITEABLE
:
2962 if (check_arglist_length (args
, 1, 1, fnname
) < 0)
2963 return error_mark_node
;
2964 return build_chill_writeable (TREE_VALUE (args
));
2965 case BUILT_IN_WRITERECORD
:
2966 if (check_arglist_length (args
, 2, 3, fnname
) < 0)
2967 return error_mark_node
;
2968 return build_chill_writerecord (TREE_VALUE (args
), TREE_CHAIN (args
));
2969 case BUILT_IN_WRITETEXT
:
2970 if (check_arglist_length (args
, 2, -1, fnname
) < 0)
2971 return error_mark_node
;
2972 return build_chill_writetext (TREE_VALUE (args
),
2975 case BUILT_IN_EXPIRED
:
2977 sorry ("unimplemented builtin function `%s'",
2978 IDENTIFIER_POINTER (fnname
));
2981 error ("internal error - bad builtin function `%s'",
2982 IDENTIFIER_POINTER (fnname
));
2985 return build_chill_function_call (func
, args
);
2988 if (chill_varying_type_p (TREE_TYPE (func
)))
2989 type
= TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (type
)));
2991 if (CH_STRING_TYPE_P (type
))
2993 if (args
== NULL_TREE
)
2995 error ("empty expression in string index");
2996 return error_mark_node
;
2998 if (TREE_CHAIN (args
) != NULL
)
3000 error ("only one expression allowed in string index");
3001 return error_mark_node
;
3003 if (flag_old_strings
)
3004 return build_chill_slice_with_length (func
,
3007 else if (CH_BOOLS_TYPE_P (type
))
3008 return build_chill_bitref (func
, args
);
3010 return build_chill_array_ref (func
, args
);
3013 else if (TREE_CODE (type
) == ARRAY_TYPE
)
3014 return build_chill_array_ref (func
, args
);
3016 if (TREE_CODE (func
) != ERROR_MARK
)
3017 error ("invalid: primval ( untyped_exprlist )");
3018 return error_mark_node
;
3021 /* Given a set stored as one bit per char (in BUFFER[0 .. BIT_SIZE-1]),
3022 return a CONTRUCTOR, of type TYPE (a SET_TYPE). */
3024 expand_packed_set (buffer
, bit_size
, type
)
3029 /* The ordinal number corresponding to the first stored bit. */
3030 HOST_WIDE_INT first_bit_no
=
3031 TREE_INT_CST_LOW (TYPE_MIN_VALUE (TYPE_DOMAIN (type
)));
3032 tree list
= NULL_TREE
;
3035 for (i
= 0; i
< bit_size
; i
++)
3039 for (next_0
= i
+ 1;
3040 next_0
< bit_size
&& buffer
[next_0
]; next_0
++)
3042 if (next_0
== i
+ 1)
3043 list
= tree_cons (NULL_TREE
,
3044 build_int_2 (i
+ first_bit_no
, 0), list
);
3047 list
= tree_cons (build_int_2 (i
+ first_bit_no
, 0),
3048 build_int_2 (next_0
- 1 + first_bit_no
, 0), list
);
3049 /* advance i past the range of 1-bits */
3053 list
= build (CONSTRUCTOR
, type
, NULL_TREE
, nreverse (list
));
3054 TREE_CONSTANT (list
) = 1;
3059 * fold a set represented as a CONSTRUCTOR list.
3060 * An empty set has a NULL_TREE in its TREE_OPERAND (set, 1) slot.
3063 fold_set_expr (code
, op0
, op1
)
3064 enum chill_tree_code code
;
3068 char *buffer0
, *buffer1
= NULL
, *bufferr
;
3069 int i
, size0
, size1
, first_unused_bit
;
3071 if (! TREE_CONSTANT (op0
) || TREE_CODE (op0
) != CONSTRUCTOR
)
3075 && (! TREE_CONSTANT (op1
) || TREE_CODE (op1
) != CONSTRUCTOR
))
3078 size0
= int_size_in_bytes (TREE_TYPE (op0
)) * BITS_PER_UNIT
;
3081 error ("operand is variable-size bitstring/power-set");
3082 return error_mark_node
;
3084 buffer0
= (char*) alloca (size0
);
3086 temp
= get_set_constructor_bits (op0
, buffer0
, size0
);
3092 size1
= int_size_in_bytes (TREE_TYPE (op1
)) * BITS_PER_UNIT
;
3095 error ("operand is variable-size bitstring/power-set");
3096 return error_mark_node
;
3100 buffer1
= (char*) alloca (size1
);
3101 temp
= get_set_constructor_bits (op1
, buffer1
, size1
);
3106 bufferr
= (char*) alloca (size0
); /* result buffer */
3112 for (i
= 0; i
< size0
; i
++)
3113 bufferr
[i
] = 1 & ~buffer0
[i
];
3117 for (i
= 0; i
< size0
; i
++)
3118 bufferr
[i
] = buffer0
[i
] & buffer1
[i
];
3122 for (i
= 0; i
< size0
; i
++)
3123 bufferr
[i
] = buffer0
[i
] | buffer1
[i
];
3127 for (i
= 0; i
< size0
; i
++)
3128 bufferr
[i
] = (buffer0
[i
] ^ buffer1
[i
]) & 1;
3132 for (i
= 0; i
< size0
; i
++)
3133 bufferr
[i
] = buffer0
[i
] & ~buffer1
[i
];
3136 /* mask out unused bits. Same as runtime library does. */
3137 first_unused_bit
= TREE_INT_CST_LOW (TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (op0
))))
3138 - TREE_INT_CST_LOW (TYPE_MIN_VALUE (TYPE_DOMAIN (TREE_TYPE (op0
)))) + 1;
3139 for (i
= first_unused_bit
; i
< size0
; i
++)
3141 return expand_packed_set (bufferr
, size0
, TREE_TYPE (op0
));
3143 for (i
= 0; i
< size0
; i
++)
3144 if (buffer0
[i
] != buffer1
[i
])
3145 return boolean_false_node
;
3146 return boolean_true_node
;
3149 for (i
= 0; i
< size0
; i
++)
3150 if (buffer0
[i
] != buffer1
[i
])
3151 return boolean_true_node
;
3152 return boolean_false_node
;
3160 * build a set or bit-array expression. Type-checking is
3164 build_compare_set_expr (code
, op0
, op1
)
3165 enum tree_code code
;
3168 tree result_type
= NULL_TREE
;
3172 /* These conversions are needed if -fold-strings. */
3173 if (TREE_CODE (TREE_TYPE (op0
)) == BOOLEAN_TYPE
)
3175 if (CH_BOOLS_ONE_P (TREE_TYPE (op1
)))
3176 return build_compare_discrete_expr (code
,
3178 convert (boolean_type_node
, op1
));
3180 op0
= convert (bitstring_one_type_node
, op0
);
3182 if (TREE_CODE (TREE_TYPE (op1
)) == BOOLEAN_TYPE
)
3184 if (CH_BOOLS_ONE_P (TREE_TYPE (op0
)))
3185 return build_compare_discrete_expr (code
,
3186 convert (boolean_type_node
, op0
),
3189 op1
= convert (bitstring_one_type_node
, op1
);
3196 tree temp
= fold_set_expr (EQ_EXPR
, op0
, op1
);
3199 fnname
= "__eqpowerset";
3200 goto compare_powerset
;
3205 /* switch operands and fall thru */
3211 fnname
= "__lepowerset";
3212 goto compare_powerset
;
3215 /* switch operands and fall thru */
3221 fnname
= "__ltpowerset";
3222 goto compare_powerset
;
3225 return invert_truthvalue (build_compare_set_expr (EQ_EXPR
, op0
, op1
));
3229 tree tsize
= powersetlen (op0
);
3231 if (TREE_CODE (TREE_TYPE (op0
)) != SET_TYPE
)
3232 tsize
= fold (build (MULT_EXPR
, sizetype
, tsize
,
3233 size_int (BITS_PER_UNIT
)));
3235 return build_chill_function_call (lookup_name (get_identifier (fnname
)),
3236 tree_cons (NULL_TREE
, force_addr_of (op0
),
3237 tree_cons (NULL_TREE
, force_addr_of (op1
),
3238 tree_cons (NULL_TREE
, tsize
, NULL_TREE
))));
3243 if ((int) code
>= (int)LAST_AND_UNUSED_TREE_CODE
)
3245 error ("tree code `%s' unhandled in build_compare_set_expr",
3246 tree_code_name
[(int)code
]);
3247 return error_mark_node
;
3252 return build ((enum tree_code
)code
, result_type
,
3256 /* Convert a varying string (or array) to dynamic non-varying string:
3257 EXP becomes EXP.var_data(0 UP EXP.var_length). */
3260 varying_to_slice (exp
)
3263 if (!chill_varying_type_p (TREE_TYPE (exp
)))
3266 { tree size
, data
, data_domain
, min
;
3267 tree novelty
= CH_NOVELTY (TREE_TYPE (exp
));
3268 exp
= save_if_needed (exp
);
3269 size
= build_component_ref (exp
, var_length_id
);
3270 data
= build_component_ref (exp
, var_data_id
);
3271 TREE_TYPE (data
) = copy_novelty (novelty
, TREE_TYPE (data
));
3272 data_domain
= TYPE_DOMAIN (TREE_TYPE (data
));
3273 if (data_domain
!= NULL_TREE
3274 && TYPE_MIN_VALUE (data_domain
) != NULL_TREE
)
3275 min
= TYPE_MIN_VALUE (data_domain
);
3277 min
= integer_zero_node
;
3278 return build_chill_slice (data
, min
, size
);
3282 /* Convert a scalar argument to a string or array type. This is a subroutine
3283 of `build_concat_expr'. */
3286 scalar_to_string (exp
)
3289 tree type
= TREE_TYPE (exp
);
3291 if (SCALAR_P (type
))
3293 int was_const
= TREE_CONSTANT (exp
);
3294 if (TREE_TYPE (exp
) == char_type_node
)
3295 exp
= convert (string_one_type_node
, exp
);
3296 else if (TREE_TYPE (exp
) == boolean_type_node
)
3297 exp
= convert (bitstring_one_type_node
, exp
);
3299 exp
= convert (build_array_type_for_scalar (type
), exp
);
3300 TREE_CONSTANT (exp
) = was_const
;
3303 return varying_to_slice (exp
);
3306 /* FIXME: Generalize this to general arrays (not just strings),
3307 at least for the compiler-generated case of padding fixed-length arrays. */
3310 build_concat_expr (op0
, op1
)
3313 tree orig_op0
= op0
, orig_op1
= op1
;
3314 tree type0
, type1
, size0
, size1
, res
;
3316 op0
= scalar_to_string (op0
);
3317 type0
= TREE_TYPE (op0
);
3318 op1
= scalar_to_string (op1
);
3319 type1
= TREE_TYPE (op1
);
3320 size1
= size_in_bytes (type1
);
3322 /* try to fold constant string literals */
3323 if (TREE_CODE (op0
) == STRING_CST
3324 && (TREE_CODE (op1
) == STRING_CST
3325 || TREE_CODE (op1
) == UNDEFINED_EXPR
)
3326 && TREE_CODE (size1
) == INTEGER_CST
)
3328 int len0
= TREE_STRING_LENGTH (op0
);
3329 int len1
= TREE_INT_CST_LOW (size1
);
3330 char *result
= xmalloc (len0
+ len1
+ 1);
3331 memcpy (result
, TREE_STRING_POINTER (op0
), len0
);
3332 if (TREE_CODE (op1
) == UNDEFINED_EXPR
)
3333 memset (&result
[len0
], '\0', len1
);
3335 memcpy (&result
[len0
], TREE_STRING_POINTER (op1
), len1
);
3336 return build_chill_string (len0
+ len1
, result
);
3338 else if (TREE_CODE (type0
) == TREE_CODE (type1
))
3341 struct ch_class result_class
;
3342 struct ch_class class0
;
3343 struct ch_class class1
;
3345 class0
= chill_expr_class (orig_op0
);
3346 class1
= chill_expr_class (orig_op1
);
3348 if (TREE_CODE (type0
) == SET_TYPE
)
3350 result_size
= fold (build (PLUS_EXPR
, integer_type_node
,
3351 discrete_count (TYPE_DOMAIN (type0
)),
3352 discrete_count (TYPE_DOMAIN (type1
))));
3353 result_class
.mode
= build_bitstring_type (result_size
);
3357 tree max0
= TYPE_MAX_VALUE (type0
);
3358 tree max1
= TYPE_MAX_VALUE (type1
);
3360 /* new array's dynamic size (in bytes). */
3361 size0
= size_in_bytes (type0
);
3362 /* size1 was computed above. */
3364 result_size
= size_binop (PLUS_EXPR
, size0
, size1
);
3365 /* new array's type. */
3366 result_class
.mode
= build_string_type (char_type_node
, result_size
);
3370 max0
= max0
== 0 ? size0
: convert (sizetype
, max0
);
3371 max1
= max1
== 0 ? size1
: convert (sizetype
, max1
);
3372 TYPE_MAX_VALUE (result_class
.mode
)
3373 = size_binop (PLUS_EXPR
, max0
, max1
);
3377 if (class0
.kind
== CH_VALUE_CLASS
|| class1
.kind
== CH_VALUE_CLASS
)
3379 tree novelty0
= CH_NOVELTY (TREE_TYPE (orig_op0
));
3380 result_class
.kind
= CH_VALUE_CLASS
;
3381 if (class0
.kind
== CH_VALUE_CLASS
&& novelty0
!= NULL_TREE
)
3382 SET_CH_NOVELTY_NONNIL (result_class
.mode
, novelty0
);
3383 else if (class1
.kind
== CH_VALUE_CLASS
)
3384 SET_CH_NOVELTY (result_class
.mode
,
3385 CH_NOVELTY (TREE_TYPE (orig_op1
)));
3388 result_class
.kind
= CH_DERIVED_CLASS
;
3390 if (TREE_CODE (result_class
.mode
) == SET_TYPE
3391 && TREE_CONSTANT (op0
) && TREE_CONSTANT (op1
)
3392 && TREE_CODE (op0
) == CONSTRUCTOR
&& TREE_CODE (op1
) == CONSTRUCTOR
)
3394 HOST_WIDE_INT size0
, size1
; char *buffer
;
3395 size0
= TREE_INT_CST_LOW (TYPE_MAX_VALUE (TYPE_DOMAIN (type0
))) + 1;
3396 size1
= TREE_INT_CST_LOW (TYPE_MAX_VALUE (TYPE_DOMAIN (type1
))) + 1;
3397 buffer
= (char*) alloca (size0
+ size1
);
3398 if (size0
< 0 || size1
< 0
3399 || get_set_constructor_bits (op0
, buffer
, size0
)
3400 || get_set_constructor_bits (op1
, buffer
+ size0
, size1
))
3402 res
= expand_packed_set (buffer
, size0
+ size1
, result_class
.mode
);
3405 res
= build (CONCAT_EXPR
, result_class
.mode
, op0
, op1
);
3406 return convert_to_class (result_class
, res
);
3410 error ("incompatible modes in concat expression");
3411 return error_mark_node
;
3416 * handle varying and fixed array compare operations
3419 build_compare_string_expr (code
, op0
, op1
)
3420 enum tree_code code
;
3423 if (op0
== NULL_TREE
|| TREE_CODE (op0
) == ERROR_MARK
)
3424 return error_mark_node
;
3425 if (op1
== NULL_TREE
|| TREE_CODE (op1
) == ERROR_MARK
)
3426 return error_mark_node
;
3428 if (tree_int_cst_equal (TYPE_SIZE (TREE_TYPE (op0
)),
3429 TYPE_SIZE (TREE_TYPE (op1
)))
3430 && ! chill_varying_type_p (TREE_TYPE (op0
))
3431 && ! chill_varying_type_p (TREE_TYPE (op1
)))
3433 tree size
= size_in_bytes (TREE_TYPE (op0
));
3434 tree temp
= lookup_name (get_identifier ("memcmp"));
3435 temp
= build_chill_function_call (temp
,
3436 tree_cons (NULL_TREE
, force_addr_of (op0
),
3437 tree_cons (NULL_TREE
, force_addr_of (op1
),
3438 tree_cons (NULL_TREE
, size
, NULL_TREE
))));
3439 return build_compare_discrete_expr (code
, temp
, integer_zero_node
);
3445 code
= STRING_EQ_EXPR
;
3448 return invert_truthvalue (build_compare_string_expr (LT_EXPR
, op0
, op1
));
3450 return invert_truthvalue (build_compare_string_expr (LT_EXPR
, op1
, op0
));
3452 return build_compare_string_expr (LT_EXPR
, op1
, op0
);
3454 code
= STRING_LT_EXPR
;
3457 return invert_truthvalue (build_compare_string_expr (EQ_EXPR
, op0
, op1
));
3459 error ("Invalid operation on array of chars");
3460 return error_mark_node
;
3463 return build (code
, boolean_type_node
, op0
, op1
);
3467 compare_records (exp0
, exp1
)
3470 tree type
= TREE_TYPE (exp0
);
3472 int have_variants
= 0;
3474 tree result
= boolean_true_node
;
3476 if (TREE_CODE (type
) != RECORD_TYPE
)
3479 exp0
= save_if_needed (exp0
);
3480 exp1
= save_if_needed (exp1
);
3482 for (field
= TYPE_FIELDS (type
); field
; field
= TREE_CHAIN (field
))
3484 if (DECL_NAME (field
) == NULL_TREE
)
3491 /* in case of -fpack we always do a memcmp */
3492 if (maximum_field_alignment
!= 0)
3494 tree memcmp_func
= lookup_name (get_identifier ("memcmp"));
3495 tree arg1
= force_addr_of (exp0
);
3496 tree arg2
= force_addr_of (exp1
);
3497 tree arg3
= size_in_bytes (type
);
3498 tree fcall
= build_chill_function_call (memcmp_func
,
3499 tree_cons (NULL_TREE
, arg1
,
3500 tree_cons (NULL_TREE
, arg2
,
3501 tree_cons (NULL_TREE
, arg3
, NULL_TREE
))));
3504 warning ("comparison of variant structures is unsafe");
3505 result
= build_chill_binary_op (EQ_EXPR
, fcall
, integer_zero_node
);
3511 sorry ("compare with variant records");
3512 return error_mark_node
;
3515 for (field
= TYPE_FIELDS (type
); field
; field
= TREE_CHAIN (field
))
3517 tree exp0fld
= build_component_ref (exp0
, DECL_NAME (field
));
3518 tree exp1fld
= build_component_ref (exp1
, DECL_NAME (field
));
3519 tree eq_flds
= build_chill_binary_op (EQ_EXPR
, exp0fld
, exp1fld
);
3520 result
= build_chill_binary_op (TRUTH_AND_EXPR
, result
, eq_flds
);
3526 compare_int_csts (op
, val1
, val2
)
3532 tree type1
= TREE_TYPE (val1
);
3533 tree type2
= TREE_TYPE (val2
);
3538 tmp
= val1
; val1
= val2
; val2
= tmp
;
3539 tmp
= type1
; type1
= type2
; type2
= tmp
;
3540 op
= (op
== GT_EXPR
) ? LT_EXPR
: LE_EXPR
;
3541 /* ... fall through ... */
3544 if (!TREE_UNSIGNED (type1
))
3546 if (!TREE_UNSIGNED (type2
))
3547 result
= INT_CST_LT (val1
, val2
);
3548 else if (TREE_INT_CST_HIGH (val1
) < 0)
3551 result
= INT_CST_LT_UNSIGNED (val1
, val2
);
3555 if (!TREE_UNSIGNED (type2
) && TREE_INT_CST_HIGH (val2
) < 0)
3558 result
= INT_CST_LT_UNSIGNED (val1
, val2
);
3560 if (op
== LT_EXPR
|| result
== 1)
3562 /* else fall through ... */
3565 if (TREE_INT_CST_LOW (val1
) == TREE_INT_CST_LOW (val2
)
3566 && TREE_INT_CST_HIGH (val1
) == TREE_INT_CST_HIGH (val2
)
3567 /* They're bitwise equal.
3568 Check for one being negative and the other unsigned. */
3569 && (TREE_INT_CST_HIGH (val2
) >= 0
3570 || TREE_UNSIGNED (TREE_TYPE (val1
))
3571 == TREE_UNSIGNED (TREE_TYPE (val2
))))
3584 /* Build an expression to compare discrete values VAL1 and VAL2.
3585 This does not check that they are discrete, nor that they are
3586 compatible; if you need such checks use build_compare_expr. */
3589 build_compare_discrete_expr (op
, val1
, val2
)
3593 tree type1
= TREE_TYPE (val1
);
3594 tree type2
= TREE_TYPE (val2
);
3597 if (TREE_CODE (val1
) == INTEGER_CST
&& TREE_CODE (val2
) == INTEGER_CST
)
3599 if (compare_int_csts (op
, val1
, val2
))
3600 return boolean_true_node
;
3602 return boolean_false_node
;
3605 if (TREE_UNSIGNED (type1
) != TREE_UNSIGNED (type2
))
3611 tmp
= val1
; val1
= val2
; val2
= tmp
;
3612 tmp
= type1
; type1
= type2
; type2
= tmp
;
3613 op
= (op
== GT_EXPR
) ? LT_EXPR
: LE_EXPR
;
3614 /* ... fall through ... */
3617 if (TREE_UNSIGNED (type2
))
3619 tmp
= build_int_2_wide (0, 0);
3620 TREE_TYPE (tmp
) = type1
;
3621 val1
= save_expr (val1
);
3622 tmp
= fold (build (LT_EXPR
, boolean_type_node
, val1
, tmp
));
3623 if (TYPE_PRECISION (type2
) < TYPE_PRECISION (type1
))
3625 type2
= unsigned_type (type1
);
3626 val2
= convert_to_integer (type2
, val2
);
3628 val1
= convert_to_integer (type2
, val1
);
3629 return fold (build (TRUTH_OR_EXPR
, boolean_type_node
,
3631 fold (build (op
, boolean_type_node
,
3634 unsigned_vs_signed
: /* val1 is unsigned, val2 is signed */
3635 tmp
= build_int_2_wide (0, 0);
3636 TREE_TYPE (tmp
) = type2
;
3637 val2
= save_expr (val2
);
3638 tmp
= fold (build (GE_EXPR
, boolean_type_node
, val2
, tmp
));
3639 if (TYPE_PRECISION (type1
) < TYPE_PRECISION (type2
))
3641 type1
= unsigned_type (type2
);
3642 val1
= convert_to_integer (type1
, val1
);
3644 val2
= convert_to_integer (type1
, val2
);
3645 return fold (build (TRUTH_AND_EXPR
, boolean_type_node
, tmp
,
3646 fold (build (op
, boolean_type_node
,
3649 if (TREE_UNSIGNED (val2
))
3651 tmp
= val1
; val1
= val2
; val2
= tmp
;
3652 tmp
= type1
; type1
= type2
; type2
= tmp
;
3654 goto unsigned_vs_signed
;
3656 tmp
= build_compare_expr (EQ_EXPR
, val1
, val2
);
3657 return build_chill_unary_op (TRUTH_NOT_EXPR
, tmp
);
3662 if (TYPE_PRECISION (type1
) > TYPE_PRECISION (type2
))
3663 val2
= convert (type1
, val2
);
3664 else if (TYPE_PRECISION (type1
) < TYPE_PRECISION (type2
))
3665 val1
= convert (type2
, val1
);
3666 return fold (build (op
, boolean_type_node
, val1
, val2
));
3670 build_compare_expr (op
, val1
, val2
)
3676 val1
= check_have_mode (val1
, "relational expression");
3677 val2
= check_have_mode (val2
, "relational expression");
3678 if (val1
== NULL_TREE
|| TREE_CODE (val1
) == ERROR_MARK
)
3679 return error_mark_node
;
3680 if (val2
== NULL_TREE
|| TREE_CODE (val2
) == ERROR_MARK
)
3681 return error_mark_node
;
3684 return build (op
, NULL_TREE
, val1
, val2
);
3686 if (!CH_COMPATIBLE_CLASSES (val1
, val2
))
3688 error ("incompatible operands to %s", boolean_code_name
[op
]);
3689 return error_mark_node
;
3692 tmp
= CH_ROOT_MODE (TREE_TYPE (val1
));
3693 if (tmp
!= TREE_TYPE (val1
))
3694 val1
= convert (tmp
, val1
);
3695 tmp
= CH_ROOT_MODE (TREE_TYPE (val2
));
3696 if (tmp
!= TREE_TYPE (val2
))
3697 val2
= convert (tmp
, val2
);
3699 type1
= TREE_TYPE (val1
);
3700 type2
= TREE_TYPE (val2
);
3702 if (TREE_CODE (type1
) == SET_TYPE
)
3703 tmp
= build_compare_set_expr (op
, val1
, val2
);
3705 else if (discrete_type_p (type1
))
3706 tmp
= build_compare_discrete_expr (op
, val1
, val2
);
3708 else if (chill_varying_type_p (type1
) || chill_varying_type_p (type2
)
3709 || (TREE_CODE (type1
) == ARRAY_TYPE
3710 && TREE_CODE (TREE_TYPE (type1
)) == CHAR_TYPE
)
3711 || (TREE_CODE (type2
) == ARRAY_TYPE
3712 && TREE_CODE (TREE_TYPE (type2
)) == CHAR_TYPE
) )
3713 tmp
= build_compare_string_expr (op
, val1
, val2
);
3715 else if ((TREE_CODE (type1
) == RECORD_TYPE
3716 || TREE_CODE (type2
) == RECORD_TYPE
)
3717 && (op
== EQ_EXPR
|| op
== NE_EXPR
))
3719 /* This is for handling INSTANCEs being compared against NULL. */
3720 if (val1
== null_pointer_node
)
3721 val1
= convert (type2
, val1
);
3722 if (val2
== null_pointer_node
)
3723 val2
= convert (type1
, val2
);
3725 tmp
= compare_records (val1
, val2
);
3727 tmp
= build_chill_unary_op (TRUTH_NOT_EXPR
, tmp
);
3730 else if (TREE_CODE (type1
) == REAL_TYPE
|| TREE_CODE (type2
) == REAL_TYPE
3731 || (op
== EQ_EXPR
|| op
== NE_EXPR
))
3733 tmp
= build (op
, boolean_type_node
, val1
, val2
);
3734 CH_DERIVED_FLAG (tmp
) = 1; /* Optimization to avoid copy_node. */
3740 error ("relational operator not allowed for this mode");
3741 return error_mark_node
;
3744 if (!CH_DERIVED_FLAG (tmp
))
3746 tmp
= copy_node (tmp
);
3747 CH_DERIVED_FLAG (tmp
) = 1;
3753 finish_chill_binary_op (node
)
3756 tree op0
= check_have_mode (TREE_OPERAND (node
, 0), "binary expression");
3757 tree op1
= check_have_mode (TREE_OPERAND (node
, 1), "binary expression");
3758 tree type0
= TREE_TYPE (op0
);
3759 tree type1
= TREE_TYPE (op1
);
3762 if (TREE_CODE (op0
) == ERROR_MARK
|| TREE_CODE (op1
) == ERROR_MARK
)
3763 return error_mark_node
;
3765 if (UNSATISFIED (op0
) || UNSATISFIED (op1
))
3767 UNSATISFIED_FLAG (node
) = 1;
3771 /* assure that both operands have a type */
3772 if (! type0
&& type1
)
3774 op0
= convert (type1
, op0
);
3775 type0
= TREE_TYPE (op0
);
3777 if (! type1
&& type0
)
3779 op1
= convert (type0
, op1
);
3780 type1
= TREE_TYPE (op1
);
3783 UNSATISFIED_FLAG (node
) = 0;
3786 { int op0f
= TREE_CODE (op0
) == FUNCTION_DECL
;
3787 int op1f
= TREE_CODE (op1
) == FUNCTION_DECL
;
3789 op0
= convert (build_pointer_type (TREE_TYPE (op0
)), op0
);
3791 op1
= convert (build_pointer_type (TREE_TYPE (op1
)), op1
);
3793 && code
!= EQ_EXPR
&& code
!= NE_EXPR
)
3794 error ("Cannot use %s operator on PROC mode variable",
3795 tree_code_name
[(int)code
]);
3798 if (invalid_left_operand (type0
, code
))
3800 error ("invalid left operand of %s", tree_code_name
[(int)code
]);
3801 return error_mark_node
;
3803 if (invalid_right_operand (code
, type1
))
3805 error ("invalid right operand of %s", tree_code_name
[(int)code
]);
3806 return error_mark_node
;
3810 switch (TREE_CODE (node
))
3813 return build_concat_expr (op0
, op1
);
3815 case REPLICATE_EXPR
:
3817 if (!TREE_CONSTANT (op0
) || !TREE_CONSTANT (op1
))
3819 error ("repetition expression must be constant");
3820 return error_mark_node
;
3823 return build_chill_repetition_op (op0
, op1
);
3825 case FLOOR_MOD_EXPR
:
3826 case TRUNC_MOD_EXPR
:
3827 if (TREE_CODE (type0
) != INTEGER_TYPE
)
3829 error ("left argument to MOD/REM operator must be integral");
3830 return error_mark_node
;
3832 if (TREE_CODE (type1
) != INTEGER_TYPE
)
3834 error ("right argument to MOD/REM operator must be integral");
3835 return error_mark_node
;
3840 if (TREE_CODE (type1
) == SET_TYPE
)
3842 tree temp
= fold_set_expr (MINUS_EXPR
, op0
, op1
);
3846 if (TYPE_MODE (type1
) == BLKmode
)
3847 TREE_SET_CODE (node
, SET_DIFF_EXPR
);
3850 op1
= build_chill_unary_op (BIT_NOT_EXPR
, op1
);
3851 TREE_OPERAND (node
, 1) = op1
;
3852 TREE_SET_CODE (node
, BIT_AND_EXPR
);
3857 case TRUNC_DIV_EXPR
:
3858 if (TREE_CODE (type0
) == REAL_TYPE
|| TREE_CODE (type1
) == REAL_TYPE
)
3859 TREE_SET_CODE (node
, RDIV_EXPR
);
3863 if (TYPE_MODE (type1
) == BLKmode
)
3864 TREE_SET_CODE (node
, SET_AND_EXPR
);
3865 goto fold_set_binop
;
3867 if (TYPE_MODE (type1
) == BLKmode
)
3868 TREE_SET_CODE (node
, SET_IOR_EXPR
);
3869 goto fold_set_binop
;
3871 if (TYPE_MODE (type1
) == BLKmode
)
3872 TREE_SET_CODE (node
, SET_XOR_EXPR
);
3873 goto fold_set_binop
;
3879 if (TREE_CODE (type0
) == SET_TYPE
)
3881 tree temp
= fold_set_expr (TREE_CODE (node
), op0
, op1
);
3889 if (TREE_CODE (type1
) != SET_TYPE
|| CH_BOOLS_TYPE_P (type1
))
3891 error ("right operand of IN is not a powerset");
3892 return error_mark_node
;
3894 if (!CH_COMPATIBLE (op0
, TYPE_DOMAIN (type1
)))
3896 error ("left operand of IN incompatible with right operand");
3897 return error_mark_node
;
3899 type0
= CH_ROOT_MODE (type0
);
3900 if (type0
!= TREE_TYPE (op0
))
3901 TREE_OPERAND (node
, 0) = op0
= convert (type0
, op0
);
3902 TREE_TYPE (node
) = boolean_type_node
;
3903 CH_DERIVED_FLAG (node
) = 1;
3905 if (!CH_DERIVED_FLAG (node
))
3907 node
= copy_node (node
);
3908 CH_DERIVED_FLAG (node
) = 1;
3917 return build_compare_expr (TREE_CODE (node
), op0
, op1
);
3922 if (!CH_COMPATIBLE_CLASSES (op0
, op1
))
3924 error ("incompatible operands to %s", tree_code_name
[(int) TREE_CODE (node
)]);
3925 return error_mark_node
;
3928 if (TREE_TYPE (node
) == NULL_TREE
)
3930 struct ch_class
class;
3931 class = CH_ROOT_RESULTING_CLASS (op0
, op1
);
3932 TREE_OPERAND (node
, 0) = op0
= convert_to_class (class, op0
);
3933 type0
= TREE_TYPE (op0
);
3934 TREE_OPERAND (node
, 1) = op1
= convert_to_class (class, op1
);
3935 type1
= TREE_TYPE (op1
);
3936 TREE_TYPE (node
) = class.mode
;
3937 folded
= convert_to_class (class, fold (node
));
3940 folded
= fold (node
);
3943 TREE_CONSTANT (folded
) = TREE_CONSTANT (op0
) & TREE_CONSTANT (op1
);
3945 if (TREE_CODE (node
) == TRUNC_DIV_EXPR
)
3947 if (TREE_CONSTANT (op1
))
3949 if (tree_int_cst_equal (op1
, integer_zero_node
))
3951 error ("division by zero");
3952 return integer_zero_node
;
3955 else if (range_checking
)
3959 build (EQ_EXPR
, boolean_type_node
, op1
, integer_zero_node
);
3960 /* Should this be overflow? */
3961 folded
= check_expression (folded
, test
,
3962 ridpointers
[(int) RID_RANGEFAIL
]);
3970 * This implements the '->' operator, which, like the '&' in C,
3971 * returns a pointer to an object, which has the type of
3972 * pointer-to-that-object.
3974 * FORCE is 0 when we're evaluating a user-level syntactic construct,
3975 * and 1 when we're calling from inside the compiler.
3978 build_chill_arrow_expr (ref
, force
)
3987 error ("-> operator not allow in constant expression");
3988 return error_mark_node
;
3991 if (ref
== NULL_TREE
|| TREE_CODE (ref
) == ERROR_MARK
)
3994 while (TREE_CODE (TREE_TYPE (ref
)) == REFERENCE_TYPE
)
3995 ref
= convert (TREE_TYPE (TREE_TYPE (ref
)), ref
);
3997 if (!force
&& ! CH_LOCATION_P (ref
))
3999 if (TREE_CODE (ref
) == STRING_CST
)
4000 pedwarn ("taking the address of a string literal is non-standard");
4001 else if (TREE_CODE (TREE_TYPE (ref
)) == FUNCTION_TYPE
)
4002 pedwarn ("taking the address of a function is non-standard");
4005 error ("ADDR requires a LOCATION argument");
4006 return error_mark_node
;
4008 /* FIXME: Should we be sure that ref isn't a
4009 function if we're being pedantic? */
4012 addr_type
= build_pointer_type (TREE_TYPE (ref
));
4015 /* This transformation makes chill_expr_class return CH_VALUE_CLASS
4016 when it should return CH_REFERENCE_CLASS. That could be fixed,
4017 but we probably don't want this transformation anyway. */
4018 if (TREE_CODE (ref
) == NOP_EXPR
) /* RETYPE_EXPR */
4021 while (TREE_CODE (ref
) == NOP_EXPR
) /* RETYPE_EXPR */
4022 ref
= TREE_OPERAND (ref
, 0);
4023 mark_addressable (ref
);
4024 addr
= build1 (ADDR_EXPR
,
4025 build_pointer_type (TREE_TYPE (ref
)), ref
);
4026 return build1 (NOP_EXPR
, /* RETYPE_EXPR */
4033 if (! mark_addressable (ref
))
4035 error ("-> expression is not addressable");
4036 return error_mark_node
;
4038 result
= build1 (ADDR_EXPR
, addr_type
, ref
);
4040 && ! (TREE_CODE (ref
) == FUNCTION_DECL
4041 && DECL_CONTEXT (ref
) != 0))
4042 TREE_CONSTANT (result
) = 1;
4048 * This implements the ADDR builtin function, which returns a
4049 * free reference, analogous to the C 'void *'.
4052 build_chill_addr_expr (ref
, errormsg
)
4054 const char *errormsg
;
4056 if (ref
== error_mark_node
)
4059 if (! CH_LOCATION_P (ref
)
4060 && TREE_CODE (TREE_TYPE (ref
)) != FUNCTION_TYPE
)
4062 error ("ADDR parameter must be a LOCATION");
4063 return error_mark_node
;
4065 ref
= build_chill_arrow_expr (ref
, 1);
4067 if (ref
!= NULL_TREE
&& TREE_CODE (ref
) != ERROR_MARK
)
4068 TREE_TYPE (ref
) = ptr_type_node
;
4069 else if (errormsg
== NULL
)
4071 error ("possible internal error in build_chill_arrow_expr");
4072 return error_mark_node
;
4076 error ("%s is not addressable", errormsg
);
4077 return error_mark_node
;
4083 build_chill_binary_op (code
, op0
, op1
)
4084 enum chill_tree_code code
;
4087 register tree result
;
4089 if (op0
== NULL_TREE
|| TREE_CODE (op0
) == ERROR_MARK
)
4090 return error_mark_node
;
4091 if (op1
== NULL_TREE
|| TREE_CODE (op1
) == ERROR_MARK
)
4092 return error_mark_node
;
4094 result
= build (code
, NULL_TREE
, op0
, op1
);
4097 result
= finish_chill_binary_op (result
);
4102 * process a string repetition phrase '(' COUNT ')' STRING
4105 string_char_rep (count
, string
)
4109 int slen
, charindx
, repcnt
;
4116 if (string
== NULL_TREE
|| TREE_CODE (string
) == ERROR_MARK
)
4117 return error_mark_node
;
4119 type
= TREE_TYPE (string
);
4120 slen
= int_size_in_bytes (type
);
4121 temp
= xmalloc (slen
* count
);
4124 if (TREE_CODE (string
) == STRING_CST
)
4125 inp
= TREE_STRING_POINTER (string
);
4126 else /* single character */
4127 ch
= (char)TREE_INT_CST_LOW (string
);
4129 /* copy the string/char COUNT times into the output buffer */
4130 for (outp
= temp
, repcnt
= 0; repcnt
< count
; repcnt
++)
4131 for (charindx
= 0; charindx
< slen
; charindx
++)
4132 *outp
++ = inp
[charindx
];
4133 return build_chill_string (slen
* count
, temp
);
4136 /* Build a bit-string constant containing with the given LENGTH
4137 containing all ones (if VALUE is true), or all zeros (if VALUE is false). */
4140 build_boring_bitstring (length
, value
)
4145 tree list
; /* Value of CONSTRUCTOR_ELTS in the result. */
4146 if (value
&& length
> 0)
4147 list
= tree_cons (integer_zero_node
, size_int (length
- 1), NULL_TREE
);
4151 result
= build (CONSTRUCTOR
,
4152 build_bitstring_type (size_int (length
)),
4155 TREE_CONSTANT (result
) = 1;
4156 CH_DERIVED_FLAG (result
) = 1;
4161 * handle a string repetition, with the syntax:
4162 * ( COUNT ) 'STRING'
4163 * COUNT is required to be constant, positive and folded.
4166 build_chill_repetition_op (count_op
, string
)
4171 tree type
= TREE_TYPE (string
);
4173 if (TREE_CODE (count_op
) != INTEGER_CST
)
4175 error ("repetition count is not an integer constant");
4176 return error_mark_node
;
4179 count
= TREE_INT_CST_LOW (count_op
);
4183 error ("repetition count < 0");
4184 return error_mark_node
;
4186 if (! TREE_CONSTANT (string
))
4188 error ("repetition value not constant");
4189 return error_mark_node
;
4192 if (TREE_CODE (string
) == STRING_CST
)
4193 return string_char_rep (count
, string
);
4195 switch ((int)TREE_CODE (type
))
4198 if (TREE_CODE (string
) == INTEGER_CST
)
4199 return build_boring_bitstring (count
, TREE_INT_CST_LOW (string
));
4200 error ("bitstring repetition of non-constant boolean");
4201 return error_mark_node
;
4204 return string_char_rep (count
, string
);
4207 { int i
, tree_const
= 1;
4208 tree new_list
= NULL_TREE
;
4211 tree domain
= TYPE_DOMAIN (type
);
4213 HOST_WIDE_INT orig_len
;
4215 if (!CH_BOOLS_TYPE_P (type
)) /* cannot replicate a powerset */
4218 orig_length
= discrete_count (domain
);
4220 if (TREE_CODE (string
) != CONSTRUCTOR
|| !TREE_CONSTANT (string
)
4221 || TREE_CODE (orig_length
) != INTEGER_CST
)
4223 error ("string repetition operand is non-constant bitstring");
4224 return error_mark_node
;
4228 orig_len
= TREE_INT_CST_LOW (orig_length
);
4230 /* if the set is empty, this is NULL */
4231 vallist
= TREE_OPERAND (string
, 1);
4233 if (vallist
== NULL_TREE
) /* No bits are set. */
4234 return build_boring_bitstring (count
* orig_len
, 0);
4235 else if (TREE_CHAIN (vallist
) == NULL_TREE
4236 && (TREE_PURPOSE (vallist
) == NULL_TREE
4238 && tree_int_cst_equal (TYPE_MIN_VALUE (domain
),
4239 TREE_VALUE (vallist
)))
4240 : (tree_int_cst_equal (TYPE_MIN_VALUE (domain
),
4241 TREE_PURPOSE (vallist
))
4242 && tree_int_cst_equal (TYPE_MAX_VALUE (domain
),
4243 TREE_VALUE (vallist
)))))
4244 return build_boring_bitstring (count
* orig_len
, 1);
4246 for (i
= 0; i
< count
; i
++)
4248 tree origin
= build_int_2 (i
* orig_len
, 0);
4251 /* scan down the given value list, building
4252 new bit-positions */
4253 for (temp
= vallist
; temp
; temp
= TREE_CHAIN (temp
))
4256 = fold (build (PLUS_EXPR
, TREE_TYPE (origin
),
4257 TREE_VALUE (temp
)));
4258 tree new_purpose
= NULL_TREE
;
4260 if (! TREE_CONSTANT (TREE_VALUE (temp
)))
4262 if (TREE_PURPOSE (temp
))
4264 new_purpose
= fold (build (PLUS_EXPR
, TREE_TYPE (origin
),
4265 origin
, TREE_PURPOSE (temp
)));
4266 if (! TREE_CONSTANT (TREE_PURPOSE (temp
)))
4270 new_list
= tree_cons (new_purpose
,
4271 new_value
, new_list
);
4274 result
= build (CONSTRUCTOR
,
4275 build_bitstring_type (size_int (count
* orig_len
)),
4276 NULL_TREE
, nreverse (new_list
));
4277 TREE_CONSTANT (result
) = tree_const
;
4278 CH_DERIVED_FLAG (result
) = CH_DERIVED_FLAG (string
);
4283 error ("non-char, non-bit string repetition");
4284 return error_mark_node
;
4286 return error_mark_node
;
4290 finish_chill_unary_op (node
)
4293 enum chill_tree_code code
= TREE_CODE (node
);
4294 tree op0
= check_have_mode (TREE_OPERAND (node
, 0), "unary expression");
4295 tree type0
= TREE_TYPE (op0
);
4296 struct ch_class
class;
4298 if (TREE_CODE (op0
) == ERROR_MARK
)
4299 return error_mark_node
;
4300 /* The expression codes of the data types of the arguments tell us
4301 whether the arguments are integers, floating, pointers, etc. */
4303 if (TREE_CODE (type0
) == REFERENCE_TYPE
)
4305 op0
= convert (TREE_TYPE (type0
), op0
);
4306 type0
= TREE_TYPE (op0
);
4309 if (invalid_right_operand (code
, type0
))
4311 error ("invalid operand of %s",
4312 tree_code_name
[(int)code
]);
4313 return error_mark_node
;
4315 switch ((int)TREE_CODE (type0
))
4318 if (TREE_CODE ( TREE_TYPE (type0
)) == BOOLEAN_TYPE
)
4319 code
= SET_NOT_EXPR
;
4322 error ("right operand of %s is not array of boolean",
4323 tree_code_name
[(int)code
]);
4324 return error_mark_node
;
4331 case TRUTH_NOT_EXPR
:
4332 return invert_truthvalue (truthvalue_conversion (op0
));
4335 error ("%s operator applied to boolean variable",
4336 tree_code_name
[(int)code
]);
4337 return error_mark_node
;
4347 tree temp
= fold_set_expr (BIT_NOT_EXPR
, op0
, NULL_TREE
);
4352 code
= SET_NOT_EXPR
;
4357 error ("invalid right operand of %s", tree_code_name
[(int)code
]);
4358 return error_mark_node
;
4363 class = chill_expr_class (op0
);
4365 class.mode
= CH_ROOT_MODE (class.mode
);
4366 TREE_SET_CODE (node
, code
);
4367 TREE_OPERAND (node
, 0) = op0
= convert_to_class (class, op0
);
4368 TREE_TYPE (node
) = TREE_TYPE (op0
);
4370 node
= convert_to_class (class, fold (node
));
4372 /* FIXME: should call
4373 * cond_type_range_exception (op0);
4378 /* op is TRUTH_NOT_EXPR, BIT_NOT_EXPR, or NEGATE_EXPR */
4381 build_chill_unary_op (code
, op0
)
4382 enum chill_tree_code code
;
4385 register tree result
= NULL_TREE
;
4387 if (op0
== NULL_TREE
|| TREE_CODE (op0
) == ERROR_MARK
)
4388 return error_mark_node
;
4390 result
= build1 (code
, NULL_TREE
, op0
);
4393 result
= finish_chill_unary_op (result
);
4398 truthvalue_conversion (expr
)
4401 if (expr
== NULL_TREE
|| TREE_CODE (expr
) == ERROR_MARK
)
4402 return error_mark_node
;
4404 #if 0 /* what about a LE_EXPR (integer_type, integer_type ) */
4405 if (TREE_CODE (TREE_TYPE (expr
)) != BOOLEAN_TYPE
)
4406 error ("non-boolean mode in conditional expression");
4409 switch ((int)TREE_CODE (expr
))
4411 /* It is simpler and generates better code to have only TRUTH_*_EXPR
4412 or comparison expressions as truth values at this level. */
4415 /* A one-bit unsigned bit-field is already acceptable. */
4416 if (1 == TREE_INT_CST_LOW (DECL_SIZE (TREE_OPERAND (expr
, 1)))
4417 && TREE_UNSIGNED (TREE_OPERAND (expr
, 1)))
4423 /* It is simpler and generates better code to have only TRUTH_*_EXPR
4424 or comparison expressions as truth values at this level. */
4425 case NE_EXPR
: case LE_EXPR
: case GE_EXPR
: case LT_EXPR
: case GT_EXPR
:
4426 case TRUTH_ANDIF_EXPR
:
4427 case TRUTH_ORIF_EXPR
:
4428 case TRUTH_AND_EXPR
:
4434 return integer_zerop (expr
) ? boolean_false_node
: boolean_true_node
;
4437 return real_zerop (expr
) ? boolean_false_node
: boolean_true_node
;
4440 if (TREE_SIDE_EFFECTS (TREE_OPERAND (expr
, 0)))
4441 return build (COMPOUND_EXPR
, boolean_type_node
,
4442 TREE_OPERAND (expr
, 0), boolean_true_node
);
4444 return boolean_true_node
;
4450 /* These don't change whether an object is non-zero or zero. */
4451 return truthvalue_conversion (TREE_OPERAND (expr
, 0));
4455 /* These don't change whether an object is zero or non-zero, but
4456 we can't ignore them if their second arg has side-effects. */
4457 if (TREE_SIDE_EFFECTS (TREE_OPERAND (expr
, 1)))
4458 return build (COMPOUND_EXPR
, boolean_type_node
, TREE_OPERAND (expr
, 1),
4459 truthvalue_conversion (TREE_OPERAND (expr
, 0)));
4461 return truthvalue_conversion (TREE_OPERAND (expr
, 0));
4464 /* Distribute the conversion into the arms of a COND_EXPR. */
4465 return fold (build (COND_EXPR
, boolean_type_node
, TREE_OPERAND (expr
, 0),
4466 truthvalue_conversion (TREE_OPERAND (expr
, 1)),
4467 truthvalue_conversion (TREE_OPERAND (expr
, 2))));
4470 /* Don't cancel the effect of a CONVERT_EXPR from a REFERENCE_TYPE,
4471 since that affects how `default_conversion' will behave. */
4472 if (TREE_CODE (TREE_TYPE (expr
)) == REFERENCE_TYPE
4473 || TREE_CODE (TREE_TYPE (TREE_OPERAND (expr
, 0))) == REFERENCE_TYPE
)
4475 /* fall through... */
4477 /* If this is widening the argument, we can ignore it. */
4478 if (TYPE_PRECISION (TREE_TYPE (expr
))
4479 >= TYPE_PRECISION (TREE_TYPE (TREE_OPERAND (expr
, 0))))
4480 return truthvalue_conversion (TREE_OPERAND (expr
, 0));
4485 /* These can be changed into a comparison of the two objects. */
4486 if (TREE_TYPE (TREE_OPERAND (expr
, 0))
4487 == TREE_TYPE (TREE_OPERAND (expr
, 1)))
4488 return build_chill_binary_op (NE_EXPR
, TREE_OPERAND (expr
, 0),
4489 TREE_OPERAND (expr
, 1));
4490 return build_chill_binary_op (NE_EXPR
, TREE_OPERAND (expr
, 0),
4491 fold (build1 (NOP_EXPR
,
4492 TREE_TYPE (TREE_OPERAND (expr
, 0)),
4493 TREE_OPERAND (expr
, 1))));
4496 return build_chill_binary_op (NE_EXPR
, expr
, boolean_false_node
);
4501 * return a folded tree for the powerset's length in bits. If a
4502 * non-set is passed, we assume it's an array or boolean bytes.
4505 powersetlen (powerset
)
4508 if (powerset
== NULL_TREE
|| TREE_CODE (powerset
) == ERROR_MARK
)
4509 return error_mark_node
;
4511 return discrete_count (TYPE_DOMAIN (TREE_TYPE (powerset
)));