1 /* Convert language-specific tree expression to rtl instructions,
2 for GNU CHILL compiler.
3 Copyright (C) 1992, 1993, 1994, 1998, 1999, 2000
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 int len0
= int_size_in_bytes (type0
);
394 int len1
= int_size_in_bytes (type1
);
396 if (len0
< 0 && TYPE_ARRAY_MAX_SIZE (type0
)
397 && TREE_CODE (TYPE_ARRAY_MAX_SIZE (type0
)) == INTEGER_CST
)
398 len0
= TREE_INT_CST_LOW (TYPE_ARRAY_MAX_SIZE (type0
));
400 if (len1
< 0 && TYPE_ARRAY_MAX_SIZE (type1
)
401 && TREE_CODE (TYPE_ARRAY_MAX_SIZE (type1
)) == INTEGER_CST
)
402 len1
= TREE_INT_CST_LOW (TYPE_ARRAY_MAX_SIZE (type1
));
404 if (len0
< 0 || len1
< 0)
405 fatal ("internal error - don't know how much space is needed for concatenation");
406 target
= assign_stack_temp (mode
, len0
+ len1
, 0);
407 preserve_temp_slots (target
);
410 else if (TREE_CODE (type
) == SET_TYPE
)
412 if (target
== NULL_RTX
)
414 target
= assign_stack_temp (mode
, int_size_in_bytes (type
), 0);
415 preserve_temp_slots (target
);
421 if (GET_CODE (target
) == MEM
)
424 targetx
= assign_stack_temp (mode
, GET_MODE_SIZE (mode
), 0);
426 /* expand 1st operand to a pointer to the array */
427 op0
= expand_expr (force_addr_of (exp0
),
428 NULL_RTX
, MEM
, EXPAND_CONST_ADDRESS
);
430 /* expand 2nd operand to a pointer to the array */
431 op1
= expand_expr (force_addr_of (exp1
),
432 NULL_RTX
, MEM
, EXPAND_CONST_ADDRESS
);
434 if (TREE_CODE (type
) == SET_TYPE
)
436 size0
= expand_expr (powersetlen (exp0
),
437 NULL_RTX
, VOIDmode
, 0);
438 size1
= expand_expr (powersetlen (exp1
),
439 NULL_RTX
, VOIDmode
, 0);
441 emit_library_call (gen_rtx(SYMBOL_REF
, Pmode
, "__concatps"),
442 0, Pmode
, 5, XEXP (targetx
, 0), Pmode
,
444 convert_to_mode (TYPE_MODE (sizetype
),
445 size0
, TREE_UNSIGNED (sizetype
)),
446 TYPE_MODE (sizetype
),
448 convert_to_mode (TYPE_MODE (sizetype
),
449 size1
, TREE_UNSIGNED (sizetype
)),
450 TYPE_MODE (sizetype
));
454 /* copy left, then right array to target */
455 emit_library_call (gen_rtx(SYMBOL_REF
, Pmode
, "__concatstring"),
456 0, Pmode
, 5, XEXP (targetx
, 0), Pmode
,
458 convert_to_mode (TYPE_MODE (sizetype
),
459 size0
, TREE_UNSIGNED (sizetype
)),
460 TYPE_MODE (sizetype
),
462 convert_to_mode (TYPE_MODE (sizetype
),
463 size1
, TREE_UNSIGNED (sizetype
)),
464 TYPE_MODE (sizetype
));
466 if (targetx
!= target
)
467 emit_move_insn (target
, targetx
);
471 /* FIXME: the set_length computed below is a compile-time constant;
472 you'll need to re-write that part for VARYING bit arrays, and
473 possibly the set pointer will need to be adjusted to point past
474 the word containing its dynamic length. */
476 /* void __notpowerset (char *out, char *src,
477 unsigned long bitlength) */
481 tree expr
= TREE_OPERAND (exp
, 0);
482 tree tsize
= powersetlen (expr
);
485 if (TREE_CODE (TREE_TYPE (expr
)) != SET_TYPE
)
486 tsize
= fold (build (MULT_EXPR
, sizetype
, tsize
,
487 size_int (BITS_PER_UNIT
)));
489 /* expand 1st operand to a pointer to the set */
490 op0
= expand_expr (force_addr_of (expr
),
491 NULL_RTX
, MEM
, EXPAND_CONST_ADDRESS
);
493 /* build a temp for the result, target is its address */
494 if (target
== NULL_RTX
)
496 target
= assign_stack_temp (TYPE_MODE (TREE_TYPE (exp
)),
497 int_size_in_bytes (TREE_TYPE (exp
)),
499 preserve_temp_slots (target
);
501 if (GET_CODE (target
) == MEM
)
504 targetx
= assign_stack_temp (GET_MODE (target
),
505 GET_MODE_SIZE (GET_MODE (target
)),
507 emit_library_call (gen_rtx(SYMBOL_REF
, Pmode
, "__notpowerset"),
508 0, VOIDmode
, 3, XEXP (targetx
, 0), Pmode
,
510 expand_expr (tsize
, NULL_RTX
, MEM
,
511 EXPAND_CONST_ADDRESS
),
512 TYPE_MODE (long_unsigned_type_node
));
513 if (targetx
!= target
)
514 emit_move_insn (target
, targetx
);
519 lib_func
= "__diffpowerset";
523 lib_func
= "__orpowerset";
527 lib_func
= "__xorpowerset";
530 /* void __diffpowerset (char *out, char *left, char *right,
531 unsigned bitlength) */
533 lib_func
= "__andpowerset";
536 tree expr
= TREE_OPERAND (exp
, 0);
537 tree tsize
= powersetlen (expr
);
540 if (TREE_CODE (TREE_TYPE (expr
)) != SET_TYPE
)
541 tsize
= fold (build (MULT_EXPR
, long_unsigned_type_node
,
543 size_int (BITS_PER_UNIT
)));
545 /* expand 1st operand to a pointer to the set */
546 op0
= expand_expr (force_addr_of (expr
),
547 NULL_RTX
, MEM
, EXPAND_CONST_ADDRESS
);
549 /* expand 2nd operand to a pointer to the set */
550 op1
= expand_expr (force_addr_of (TREE_OPERAND (exp
, 1)),
552 EXPAND_CONST_ADDRESS
);
554 /* FIXME: re-examine this code - the unary operator code above has recently
555 (93/03/12) been changed a lot. Should this code also change? */
556 /* build a temp for the result, target is its address */
557 if (target
== NULL_RTX
)
559 target
= assign_stack_temp (TYPE_MODE (TREE_TYPE (exp
)),
560 int_size_in_bytes (TREE_TYPE (exp
)),
562 preserve_temp_slots (target
);
564 if (GET_CODE (target
) == MEM
)
567 targetx
= assign_stack_temp (GET_MODE (target
),
568 GET_MODE_SIZE (GET_MODE (target
)), 0);
569 emit_library_call (gen_rtx(SYMBOL_REF
, Pmode
, lib_func
),
570 0, VOIDmode
, 4, XEXP (targetx
, 0), Pmode
,
571 op0
, GET_MODE (op0
), op1
, GET_MODE (op1
),
572 expand_expr (tsize
, NULL_RTX
, MEM
,
573 EXPAND_CONST_ADDRESS
),
574 TYPE_MODE (long_unsigned_type_node
));
575 if (target
!= targetx
)
576 emit_move_insn (target
, targetx
);
582 tree set
= TREE_OPERAND (exp
, 1);
583 tree pos
= convert (long_unsigned_type_node
, TREE_OPERAND (exp
, 0));
584 tree set_type
= TREE_TYPE (set
);
585 tree set_length
= discrete_count (TYPE_DOMAIN (set_type
));
586 tree min_val
= convert (long_integer_type_node
,
587 TYPE_MIN_VALUE (TYPE_DOMAIN (set_type
)));
590 /* FIXME: Function-call not needed if pos and width are constant! */
591 if (! mark_addressable (set
))
593 error ("powerset is not addressable");
596 /* we use different functions for bitstrings and powersets */
597 if (CH_BOOLS_TYPE_P (set_type
))
599 build_chill_function_call (
600 lookup_name (get_identifier ("__inbitstring")),
601 tree_cons (NULL_TREE
,
602 convert (long_unsigned_type_node
, pos
),
603 tree_cons (NULL_TREE
,
604 build1 (ADDR_EXPR
, build_pointer_type (set_type
), set
),
605 tree_cons (NULL_TREE
,
606 convert (long_unsigned_type_node
, set_length
),
607 tree_cons (NULL_TREE
, min_val
,
608 tree_cons (NULL_TREE
, force_addr_of (get_chill_filename ()),
609 build_tree_list (NULL_TREE
, get_chill_linenumber ())))))));
612 build_chill_function_call (
613 lookup_name (get_identifier ("__inpowerset")),
614 tree_cons (NULL_TREE
,
615 convert (long_unsigned_type_node
, pos
),
616 tree_cons (NULL_TREE
,
617 build1 (ADDR_EXPR
, build_pointer_type (set_type
), set
),
618 tree_cons (NULL_TREE
,
619 convert (long_unsigned_type_node
, set_length
),
620 build_tree_list (NULL_TREE
, min_val
)))));
621 return expand_expr (fcall
, NULL_RTX
, VOIDmode
, 0);
624 case PACKED_ARRAY_REF
:
626 tree array
= TREE_OPERAND (exp
, 0);
627 tree pos
= save_expr (TREE_OPERAND (exp
, 1));
628 tree array_type
= TREE_TYPE (array
);
629 tree array_length
= discrete_count (TYPE_DOMAIN (array_type
));
630 tree min_val
= convert (long_integer_type_node
,
631 TYPE_MIN_VALUE (TYPE_DOMAIN (array_type
)));
634 /* FIXME: Function-call not needed if pos and width are constant! */
635 /* TODO: make sure this makes sense. */
636 if (! mark_addressable (array
))
638 error ("array is not addressable");
642 build_chill_function_call (
643 lookup_name (get_identifier ("__inpowerset")),
644 tree_cons (NULL_TREE
,
645 convert (long_unsigned_type_node
, pos
),
646 tree_cons (NULL_TREE
,
647 build1 (ADDR_EXPR
, build_pointer_type (array_type
), array
),
648 tree_cons (NULL_TREE
,
649 convert (long_unsigned_type_node
, array_length
),
650 build_tree_list (NULL_TREE
, min_val
)))));
651 return expand_expr (fcall
, NULL_RTX
, VOIDmode
, 0);
657 target
= assign_stack_temp (TYPE_MODE (TREE_TYPE (exp
)),
658 int_size_in_bytes (TREE_TYPE (exp
)), 0);
659 preserve_temp_slots (target
);
661 /* We don't actually need to *do* anything ... */
672 /* Check that the argument list has a length in [min_length .. max_length].
673 (max_length == -1 means "infinite".)
674 If so return the actual length.
675 Otherwise, return an error message and return -1. */
678 check_arglist_length (args
, min_length
, max_length
, name
)
684 int length
= list_length (args
);
685 if (length
< min_length
)
686 error ("Too few arguments in call to `%s'", IDENTIFIER_POINTER (name
));
687 else if (max_length
!= -1 && length
> max_length
)
688 error ("Too many arguments in call to `%s'", IDENTIFIER_POINTER (name
));
695 * This is the code from c-typeck.c, with the C-specific cruft
696 * removed (possibly I just didn't understand it, but it was
697 * apparently simply discarding part of my LIST).
700 internal_build_compound_expr (list
, first_p
)
702 int first_p ATTRIBUTE_UNUSED
;
706 if (TREE_CHAIN (list
) == 0)
707 return TREE_VALUE (list
);
709 rest
= internal_build_compound_expr (TREE_CHAIN (list
), FALSE
);
711 if (! TREE_SIDE_EFFECTS (TREE_VALUE (list
)))
714 return build (COMPOUND_EXPR
, TREE_TYPE (rest
), TREE_VALUE (list
), rest
);
718 /* Given a list of expressions, return a compound expression
719 that performs them all and returns the value of the last of them. */
720 /* FIXME: this should be merged with the C version */
722 build_chill_compound_expr (list
)
725 return internal_build_compound_expr (list
, TRUE
);
728 /* Given an expression PTR for a pointer, return an expression
729 for the value pointed to.
730 do_empty_check is 0, don't perform a NULL pointer check,
734 build_chill_indirect_ref (ptr
, mode
, do_empty_check
)
741 if (ptr
== NULL_TREE
|| TREE_CODE (ptr
) == ERROR_MARK
)
743 if (mode
!= NULL_TREE
&& TREE_CODE (mode
) == ERROR_MARK
)
744 return error_mark_node
;
746 type
= TREE_TYPE (ptr
);
748 if (TREE_CODE (type
) == REFERENCE_TYPE
)
750 type
= TREE_TYPE (type
);
751 ptr
= convert (type
, ptr
);
754 /* check for ptr is really a POINTER */
755 if (TREE_CODE (type
) != POINTER_TYPE
)
757 error ("cannot dereference, not a pointer.");
758 return error_mark_node
;
761 if (mode
&& TREE_CODE (mode
) == IDENTIFIER_NODE
)
763 tree decl
= lookup_name (mode
);
764 if (decl
== NULL_TREE
|| TREE_CODE (decl
) != TYPE_DECL
)
767 error ("missing '.' operator or undefined mode name `%s'.",
768 IDENTIFIER_POINTER (mode
));
770 error ("You have forgotten the '.' operator which must");
771 error (" precede a STRUCT field reference, or `%s' is an undefined mode",
772 IDENTIFIER_POINTER (mode
));
774 return error_mark_node
;
780 mode
= get_type_of (mode
);
781 ptr
= convert (build_pointer_type (mode
), ptr
);
783 else if (type
== ptr_type_node
)
785 error ("Can't dereference PTR value using unary `->'.");
786 return error_mark_node
;
790 ptr
= check_non_null (ptr
);
792 type
= TREE_TYPE (ptr
);
794 if (TREE_CODE (type
) == POINTER_TYPE
)
796 if (TREE_CODE (ptr
) == ADDR_EXPR
798 && (TREE_TYPE (TREE_OPERAND (ptr
, 0))
799 == TREE_TYPE (type
)))
800 return TREE_OPERAND (ptr
, 0);
803 tree t
= TREE_TYPE (type
);
804 register tree ref
= build1 (INDIRECT_REF
,
805 TYPE_MAIN_VARIANT (t
), ptr
);
807 if (TYPE_SIZE (t
) == 0 && TREE_CODE (t
) != ARRAY_TYPE
)
809 error ("dereferencing pointer to incomplete type");
810 return error_mark_node
;
812 if (TREE_CODE (t
) == VOID_TYPE
)
813 warning ("dereferencing `void *' pointer");
815 /* We *must* set TREE_READONLY when dereferencing a pointer to const,
816 so that we get the proper error message if the result is used
817 to assign to. Also, &* is supposed to be a no-op.
818 And ANSI C seems to specify that the type of the result
819 should be the const type. */
820 /* A de-reference of a pointer to const is not a const. It is valid
821 to change it via some other pointer. */
822 TREE_READONLY (ref
) = TYPE_READONLY (t
);
823 TREE_SIDE_EFFECTS (ref
)
824 = TYPE_VOLATILE (t
) || TREE_SIDE_EFFECTS (ptr
) || flag_volatile
;
825 TREE_THIS_VOLATILE (ref
) = TYPE_VOLATILE (t
) || flag_volatile
;
829 else if (TREE_CODE (ptr
) != ERROR_MARK
)
830 error ("invalid type argument of `->'");
831 return error_mark_node
;
834 /* NODE is a COMPONENT_REF whose mode is an IDENTIFIER,
835 which is replaced by the proper FIELD_DECL.
836 Also do the right thing for variant records. */
839 resolve_component_ref (node
)
842 tree datum
= TREE_OPERAND (node
, 0);
843 tree field_name
= TREE_OPERAND (node
, 1);
844 tree type
= TREE_TYPE (datum
);
846 if (TREE_CODE (datum
) == ERROR_MARK
)
847 return error_mark_node
;
848 if (TREE_CODE (type
) == REFERENCE_TYPE
)
850 type
= TREE_TYPE (type
);
851 TREE_OPERAND (node
, 0) = datum
= convert (type
, datum
);
853 if (TREE_CODE (type
) != RECORD_TYPE
)
855 error ("operand of '.' is not a STRUCT");
856 return error_mark_node
;
859 TREE_READONLY (node
) = TREE_READONLY (datum
);
860 TREE_SIDE_EFFECTS (node
) = TREE_SIDE_EFFECTS (datum
);
862 for (field
= TYPE_FIELDS (type
); field
; field
= TREE_CHAIN (field
))
864 if (TREE_CODE (TREE_TYPE (field
)) == UNION_TYPE
)
867 for (variant
= TYPE_FIELDS (TREE_TYPE (field
));
868 variant
; variant
= TREE_CHAIN (variant
))
871 for (vfield
= TYPE_FIELDS (TREE_TYPE (variant
));
872 vfield
; vfield
= TREE_CHAIN (vfield
))
874 if (DECL_NAME (vfield
) == field_name
)
875 { /* Found a variant field */
876 datum
= build (COMPONENT_REF
, TREE_TYPE (field
),
878 datum
= build (COMPONENT_REF
, TREE_TYPE (variant
),
880 TREE_OPERAND (node
, 0) = datum
;
881 TREE_OPERAND (node
, 1) = vfield
;
882 TREE_TYPE (node
) = TREE_TYPE (vfield
);
883 TREE_READONLY (node
) |= TYPE_READONLY (TREE_TYPE (node
));
885 if (flag_testing_tags
)
887 tree tagtest
= NOT IMPLEMENTED
;
888 tree tagf
= ridpointers
[(int) RID_RANGEFAIL
];
889 node
= check_expression (node
, tagtest
,
899 if (DECL_NAME (field
) == field_name
)
900 { /* Found a fixed field */
901 TREE_OPERAND (node
, 1) = field
;
902 TREE_TYPE (node
) = TREE_TYPE (field
);
903 TREE_READONLY (node
) |= TYPE_READONLY (TREE_TYPE (node
));
908 error ("No field named `%s'", IDENTIFIER_POINTER (field_name
));
909 return error_mark_node
;
913 build_component_ref (datum
, field_name
)
914 tree datum
, field_name
;
916 tree node
= build_nt (COMPONENT_REF
, datum
, field_name
);
918 node
= resolve_component_ref (node
);
923 function checks (for build_chill_component_ref) if a given
924 type is really an instance type. CH_IS_INSTANCE_MODE is not
925 strict enough in this case, i.e. SYNMODE foo = STRUCT (a, b UINT)
926 is compatible to INSTANCE. */
929 is_really_instance (type
)
932 tree decl
= TYPE_NAME (type
);
934 if (decl
== NULL_TREE
)
935 /* this is not an instance */
938 if (DECL_NAME (decl
) == ridpointers
[(int)RID_INSTANCE
])
939 /* this is an instance */
942 if (TYPE_FIELDS (type
) == TYPE_FIELDS (instance_type_node
))
943 /* we have a NEWMODE'd instance */
949 /* This function is called by the parse.
950 Here we check if the user tries to access a field in a type which is
951 layouted as a structure but isn't like INSTANCE, BUFFER, EVENT, ASSOCIATION,
952 ACCESS, TEXT, or VARYING array or character string.
953 We don't do this in build_component_ref cause this function gets
954 called from the compiler to access fields in one of the above mentioned
957 build_chill_component_ref (datum
, field_name
)
958 tree datum
, field_name
;
960 tree type
= TREE_TYPE (datum
);
961 if ((type
!= NULL_TREE
&& TREE_CODE (type
) == RECORD_TYPE
) &&
962 ((CH_IS_INSTANCE_MODE (type
) && is_really_instance (type
)) ||
963 CH_IS_BUFFER_MODE (type
) ||
964 CH_IS_EVENT_MODE (type
) || CH_IS_ASSOCIATION_MODE (type
) ||
965 CH_IS_ACCESS_MODE (type
) || CH_IS_TEXT_MODE (type
) ||
966 chill_varying_type_p (type
)))
968 error ("operand of '.' is not a STRUCT");
969 return error_mark_node
;
971 return build_component_ref (datum
, field_name
);
975 * Check for invalid binary operands & unary operands
976 * RIGHT is 1 if checking right operand or unary operand;
977 * it is 0 if checking left operand.
979 * return 1 if the given operand is NOT compatible as the
980 * operand of the given operator
982 * return 0 if they might be compatible
985 invalid_operand (code
, type
, right
)
986 enum chill_tree_code code
;
988 int right
; /* 1 if right operand */
1003 case CONCAT_EXPR
: /* must be static or varying char array */
1004 if (TREE_CODE (type
) == CHAR_TYPE
)
1006 if (TREE_CODE (type
) == ARRAY_TYPE
1007 && TREE_CODE (TREE_TYPE (type
)) == CHAR_TYPE
)
1009 if (!chill_varying_type_p (type
))
1011 if (TREE_CODE (TREE_TYPE (CH_VARYING_ARRAY_TYPE (type
)))
1016 /* note: CHILL conditional expressions (COND_EXPR) won't come
1017 * through here; they're routed straight to C-specific code */
1019 return 0; /* ANYTHING can be compared equal */
1020 case FLOOR_MOD_EXPR
:
1021 if (TREE_CODE (type
) == REAL_TYPE
)
1028 if (TREE_CODE (type
) == SET_TYPE
)
1032 case PACKED_ARRAY_REF
:
1033 if (TREE_CODE (type
) == ARRAY_TYPE
)
1040 switch ((int)TREE_CODE(type
)) /* right operand must be set/bitarray type */
1043 if (TREE_CODE (TREE_TYPE (type
)) == CHAR_TYPE
)
1064 if (chill_varying_type_p (type
)
1065 && TREE_CODE (TREE_TYPE (CH_VARYING_ARRAY_TYPE (type
))) == CHAR_TYPE
)
1069 case REFERENCE_TYPE
:
1080 if (TREE_CODE (type
) == BOOLEAN_TYPE
)
1085 return 0; /* ANYTHING can be compared unequal */
1087 return 0; /* ANYTHING can be converted */
1090 switch ((int)TREE_CODE(type
)) /* left operand must be discrete type */
1093 if (right
|| TREE_CODE (TREE_TYPE (type
)) != BOOLEAN_TYPE
)
1107 case REFERENCE_TYPE
:
1124 case REPLICATE_EXPR
:
1125 switch ((int)TREE_CODE(type
)) /* right operand must be set/bitarray type */
1146 case REFERENCE_TYPE
:
1151 case TRUNC_DIV_EXPR
:
1153 case TRUNC_MOD_EXPR
:
1154 if (TREE_CODE (type
) == REAL_TYPE
)
1157 case TRUTH_ANDIF_EXPR
:
1158 case TRUTH_AND_EXPR
:
1159 case TRUTH_NOT_EXPR
:
1160 case TRUTH_ORIF_EXPR
:
1163 switch ((int)TREE_CODE(type
)) /* left operand must be discrete type */
1179 case REFERENCE_TYPE
:
1191 return 1; /* perhaps you forgot to add a new DEFTREECODE? */
1198 invalid_right_operand (code
, type
)
1199 enum chill_tree_code code
;
1202 return invalid_operand (code
, type
, 1);
1206 build_chill_abs (expr
)
1211 if (TREE_CODE (TREE_TYPE (expr
)) == REAL_TYPE
1212 || discrete_type_p (TREE_TYPE (expr
)))
1213 temp
= fold (build1 (ABS_EXPR
, TREE_TYPE (expr
), expr
));
1216 error("ABS argument must be discrete or real mode");
1217 return error_mark_node
;
1219 /* FIXME: should call
1220 * cond_type_range_exception (temp);
1226 build_chill_abstime (exprlist
)
1229 int mask
= 0, i
, numargs
;
1230 tree args
= NULL_TREE
;
1231 tree filename
, lineno
;
1235 if (exprlist
!= NULL_TREE
&& TREE_CODE (exprlist
) == ERROR_MARK
)
1236 return error_mark_node
;
1238 /* check for integer expressions */
1241 while (tmp
!= NULL_TREE
)
1243 tree exp
= TREE_VALUE (tmp
);
1245 if (exp
== NULL_TREE
|| TREE_CODE (exp
) == ERROR_MARK
)
1247 else if (TREE_CODE (TREE_TYPE (exp
)) != INTEGER_TYPE
)
1249 error ("argument %d to ABSTIME must be of integer type.", i
);
1252 tmp
= TREE_CHAIN (tmp
);
1256 return error_mark_node
;
1258 numargs
= list_length (exprlist
);
1259 for (i
= 0; i
< numargs
; i
++)
1262 /* make it all arguments */
1263 for (i
= numargs
; i
< 6; i
++)
1264 exprlist
= tree_cons (NULL_TREE
, integer_zero_node
, exprlist
);
1266 args
= tree_cons (NULL_TREE
, build_int_2 (mask
, 0), exprlist
);
1268 filename
= force_addr_of (get_chill_filename ());
1269 lineno
= get_chill_linenumber ();
1270 args
= chainon (args
, tree_cons (NULL_TREE
, filename
,
1271 tree_cons (NULL_TREE
, lineno
, NULL_TREE
)));
1273 return build_chill_function_call (
1274 lookup_name (get_identifier ("_abstime")), args
);
1279 build_allocate_memory_call (ptr
, size
)
1284 /* check for ptr is referable */
1285 if (! CH_REFERABLE (ptr
))
1287 error ("parameter 1 must be referable.");
1290 /* check for pointer */
1291 else if (TREE_CODE (TREE_TYPE (ptr
)) != POINTER_TYPE
)
1293 error ("mode mismatch in parameter 1.");
1297 /* check for size > 0 if it is a constant */
1298 if (TREE_CODE (size
) == INTEGER_CST
&& TREE_INT_CST_LOW (size
) <= 0)
1300 error ("parameter 2 must be a positive integer.");
1304 return error_mark_node
;
1306 if (TREE_TYPE (ptr
) != ptr_type_node
)
1307 ptr
= build_chill_cast (ptr_type_node
, ptr
);
1309 return build_chill_function_call (
1310 lookup_name (get_identifier ("_allocate_memory")),
1311 tree_cons (NULL_TREE
, ptr
,
1312 tree_cons (NULL_TREE
, size
,
1313 tree_cons (NULL_TREE
, force_addr_of (get_chill_filename ()),
1314 tree_cons (NULL_TREE
, get_chill_linenumber (),
1320 build_allocate_global_memory_call (ptr
, size
)
1325 /* check for ptr is referable */
1326 if (! CH_REFERABLE (ptr
))
1328 error ("parameter 1 must be referable.");
1331 /* check for pointer */
1332 else if (TREE_CODE (TREE_TYPE (ptr
)) != POINTER_TYPE
)
1334 error ("mode mismatch in parameter 1.");
1338 /* check for size > 0 if it is a constant */
1339 if (TREE_CODE (size
) == INTEGER_CST
&& TREE_INT_CST_LOW (size
) <= 0)
1341 error ("parameter 2 must be a positive integer.");
1345 return error_mark_node
;
1347 if (TREE_TYPE (ptr
) != ptr_type_node
)
1348 ptr
= build_chill_cast (ptr_type_node
, ptr
);
1350 return build_chill_function_call (
1351 lookup_name (get_identifier ("_allocate_global_memory")),
1352 tree_cons (NULL_TREE
, ptr
,
1353 tree_cons (NULL_TREE
, size
,
1354 tree_cons (NULL_TREE
, force_addr_of (get_chill_filename ()),
1355 tree_cons (NULL_TREE
, get_chill_linenumber (),
1361 build_return_memory (ptr
)
1365 if (ptr
== NULL_TREE
|| TREE_CODE (ptr
) == ERROR_MARK
)
1366 return error_mark_node
;
1368 /* check for pointer */
1369 if (TREE_CODE (TREE_TYPE (ptr
)) != POINTER_TYPE
)
1371 error ("mode mismatch in parameter 1.");
1372 return error_mark_node
;
1375 if (TREE_TYPE (ptr
) != ptr_type_node
)
1376 ptr
= build_chill_cast (ptr_type_node
, ptr
);
1378 return build_chill_function_call (
1379 lookup_name (get_identifier ("_return_memory")),
1380 tree_cons (NULL_TREE
, ptr
,
1381 tree_cons (NULL_TREE
, force_addr_of (get_chill_filename ()),
1382 tree_cons (NULL_TREE
, get_chill_linenumber (),
1387 /* Compute the number of runtime members of the
1391 build_chill_card (powerset
)
1397 tree card_func
= lookup_name (get_identifier ("__cardpowerset"));
1399 if (powerset
== NULL_TREE
|| TREE_CODE (powerset
) == ERROR_MARK
)
1400 return error_mark_node
;
1402 if (TREE_CODE (powerset
) == IDENTIFIER_NODE
)
1403 powerset
= lookup_name (powerset
);
1405 if (TREE_CODE (TREE_TYPE(powerset
)) == SET_TYPE
)
1408 /* Do constant folding, if possible. */
1409 if (TREE_CODE (powerset
) == CONSTRUCTOR
1410 && TREE_CONSTANT (powerset
)
1411 && (size
= int_size_in_bytes (TREE_TYPE (powerset
))) >= 0)
1413 int bit_size
= size
* BITS_PER_UNIT
;
1414 char* buffer
= (char*) alloca (bit_size
);
1415 temp
= get_set_constructor_bits (powerset
, buffer
, bit_size
);
1419 for (i
= 0; i
< bit_size
; i
++)
1422 temp
= build_int_2 (count
, 0);
1423 TREE_TYPE (temp
) = TREE_TYPE (TREE_TYPE (card_func
));
1427 temp
= build_chill_function_call (card_func
,
1428 tree_cons (NULL_TREE
, force_addr_of (powerset
),
1429 tree_cons (NULL_TREE
, powersetlen (powerset
), NULL_TREE
)));
1430 /* FIXME: should call
1431 * cond_type_range_exception (op0);
1435 error("CARD argument must be powerset mode");
1436 return error_mark_node
;
1441 /* function to build the type needed for the DESCR-built-in
1444 void build_chill_descr_type ()
1448 if (descr_type
!= NULL_TREE
)
1452 decl1
= build_decl (FIELD_DECL
, get_identifier ("datap"), ptr_type_node
);
1453 decl2
= build_decl (FIELD_DECL
, get_identifier ("len"),
1454 TREE_TYPE (lookup_name (
1455 get_identifier ((ignore_case
|| ! special_UC
) ? "ulong" : "ULONG"))));
1456 TREE_CHAIN (decl1
) = decl2
;
1457 TREE_CHAIN (decl2
) = NULL_TREE
;
1458 decl2
= build_chill_struct_type (decl1
);
1459 descr_type
= build_decl (TYPE_DECL
, get_identifier ("__tmp_DESCR_type"), decl2
);
1460 pushdecl (descr_type
);
1461 DECL_SOURCE_LINE (descr_type
) = 0;
1462 satisfy_decl (descr_type
, 0);
1465 /* build a pointer to a descriptor.
1466 * descriptor = STRUCT (datap PTR,
1468 * This descriptor is build in variable descr_type.
1472 build_chill_descr (expr
)
1477 tree tuple
, decl
, descr_var
, datap
, len
, tmp
;
1480 if (expr
== NULL_TREE
|| TREE_CODE (expr
) == ERROR_MARK
)
1481 return error_mark_node
;
1483 /* check for expression is referable */
1484 if (! CH_REFERABLE (expr
))
1486 error ("expression for DESCR-builtin must be referable.");
1487 return error_mark_node
;
1490 mark_addressable (expr
);
1492 datap
= build1 (ADDR_EXPR
, build_chill_pointer_type (descr_type
), expr
);
1494 datap
= build_chill_arrow_expr (expr
, 1);
1496 len
= size_in_bytes (TREE_TYPE (expr
));
1498 descr_var
= get_unique_identifier ("DESCR");
1499 tuple
= build_nt (CONSTRUCTOR
, NULL_TREE
,
1500 tree_cons (NULL_TREE
, datap
,
1501 tree_cons (NULL_TREE
, len
, NULL_TREE
)));
1503 is_static
= (current_function_decl
== global_function_decl
) && TREE_STATIC (expr
);
1504 decl
= decl_temp1 (descr_var
, TREE_TYPE (descr_type
), is_static
,
1507 tmp
= force_addr_of (decl
);
1509 tmp
= build_chill_arrow_expr (decl
, 1);
1516 /* this function process the builtin's
1517 MILLISECS, SECS, MINUTES, HOURS and DAYS.
1518 The built duration value is in milliseconds. */
1521 build_chill_duration (expr
, multiplier
, fnname
, maxvalue
)
1523 unsigned long multiplier
;
1525 unsigned long maxvalue
;
1529 if (expr
== NULL_TREE
|| TREE_CODE (expr
) == ERROR_MARK
)
1530 return error_mark_node
;
1532 if (TREE_CODE (TREE_TYPE (expr
)) != INTEGER_TYPE
)
1534 error ("argument to `%s' must be of integer type.", IDENTIFIER_POINTER (fnname
));
1535 return error_mark_node
;
1538 temp
= convert (duration_timing_type_node
, expr
);
1539 temp
= fold (build (MULT_EXPR
, duration_timing_type_node
,
1540 temp
, build_int_2 (multiplier
, 0)));
1543 temp
= check_range (temp
, expr
, integer_zero_node
, build_int_2 (maxvalue
, 0));
1548 /* build function call to one of the floating point functions */
1550 build_chill_floatcall (expr
, chillname
, funcname
)
1552 const char *chillname
;
1553 const char *funcname
;
1558 if (expr
== NULL_TREE
|| TREE_CODE (expr
) == ERROR_MARK
)
1559 return error_mark_node
;
1561 /* look if expr is a REAL_TYPE */
1562 type
= TREE_TYPE (expr
);
1563 if (type
== NULL_TREE
|| TREE_CODE (type
) == ERROR_MARK
)
1564 return error_mark_node
;
1565 if (TREE_CODE (type
) != REAL_TYPE
)
1567 error ("argument 1 to `%s' must be of floating point mode", chillname
);
1568 return error_mark_node
;
1570 result
= build_chill_function_call (
1571 lookup_name (get_identifier (funcname
)),
1572 tree_cons (NULL_TREE
, expr
, NULL_TREE
));
1576 /* common function for ALLOCATE and GETSTACK */
1578 build_allocate_getstack (mode
, value
, chill_name
, fnname
, filename
, linenumber
)
1581 const char *chill_name
;
1587 tree expr
= NULL_TREE
;
1588 tree args
, tmpvar
, fncall
, ptr
, outlist
= NULL_TREE
;
1590 if (mode
== NULL_TREE
|| TREE_CODE (mode
) == ERROR_MARK
)
1591 return error_mark_node
;
1593 if (TREE_CODE (mode
) == TYPE_DECL
)
1594 type
= TREE_TYPE (mode
);
1598 /* check if we have a mode */
1599 if (TREE_CODE_CLASS (TREE_CODE (type
)) != 't')
1601 error ("First argument to `%s' must be a mode", chill_name
);
1602 return error_mark_node
;
1605 /* check if we have a value if type is READonly */
1606 if (TYPE_READONLY_PROPERTY (type
) && value
== NULL_TREE
)
1608 error ("READonly modes for %s must have a value", chill_name
);
1609 return error_mark_node
;
1612 if (value
!= NULL_TREE
)
1614 if (TREE_CODE (value
) == ERROR_MARK
)
1615 return error_mark_node
;
1616 expr
= chill_convert_for_assignment (type
, value
, "assignment");
1619 /* build function arguments */
1620 if (filename
== NULL_TREE
)
1621 args
= tree_cons (NULL_TREE
, size_in_bytes (type
), NULL_TREE
);
1623 args
= tree_cons (NULL_TREE
, size_in_bytes (type
),
1624 tree_cons (NULL_TREE
, force_addr_of (filename
),
1625 tree_cons (NULL_TREE
, linenumber
, NULL_TREE
)));
1627 ptr
= build_chill_pointer_type (type
);
1628 tmpvar
= decl_temp1 (get_unique_identifier (chill_name
),
1629 ptr
, 0, NULL_TREE
, 0, 0);
1630 fncall
= build_chill_function_call (
1631 lookup_name (get_identifier (fnname
)), args
);
1632 outlist
= tree_cons (NULL_TREE
,
1633 build_chill_modify_expr (tmpvar
, fncall
), outlist
);
1634 if (expr
== NULL_TREE
)
1636 /* set allocated memory to 0 */
1637 fncall
= build_chill_function_call (
1638 lookup_name (get_identifier ("memset")),
1639 tree_cons (NULL_TREE
, convert (ptr_type_node
, tmpvar
),
1640 tree_cons (NULL_TREE
, integer_zero_node
,
1641 tree_cons (NULL_TREE
, size_in_bytes (type
), NULL_TREE
))));
1642 outlist
= tree_cons (NULL_TREE
, fncall
, outlist
);
1646 /* write the init value to allocated memory */
1647 outlist
= tree_cons (NULL_TREE
,
1648 build_chill_modify_expr (build_chill_indirect_ref (tmpvar
, NULL_TREE
, 0),
1652 outlist
= tree_cons (NULL_TREE
, tmpvar
, outlist
);
1653 result
= build_chill_compound_expr (nreverse (outlist
));
1657 /* process the ALLOCATE built-in */
1659 build_chill_allocate (mode
, value
)
1663 return build_allocate_getstack (mode
, value
, "ALLOCATE", "__allocate",
1664 get_chill_filename (), get_chill_linenumber ());
1667 /* process the GETSTACK built-in */
1669 build_chill_getstack (mode
, value
)
1673 return build_allocate_getstack (mode
, value
, "GETSTACK", "__builtin_alloca",
1674 NULL_TREE
, NULL_TREE
);
1677 /* process the TERMINATE built-in */
1679 build_chill_terminate (ptr
)
1685 if (ptr
== NULL_TREE
|| TREE_CODE (ptr
) == ERROR_MARK
)
1686 return error_mark_node
;
1688 type
= TREE_TYPE (ptr
);
1689 if (type
== NULL_TREE
|| TREE_CODE (type
) != POINTER_TYPE
)
1691 error ("argument to TERMINATE must be a reference primitive value");
1692 return error_mark_node
;
1694 result
= build_chill_function_call (
1695 lookup_name (get_identifier ("__terminate")),
1696 tree_cons (NULL_TREE
, convert (ptr_type_node
, ptr
),
1697 tree_cons (NULL_TREE
, force_addr_of (get_chill_filename ()),
1698 tree_cons (NULL_TREE
, get_chill_linenumber (), NULL_TREE
))));
1702 /* build the type passed to _inttime function */
1704 build_chill_inttime_type ()
1710 idxlist
= build_tree_list (NULL_TREE
,
1711 build_chill_range_type (NULL_TREE
,
1713 build_int_2 (5, 0)));
1714 arrtype
= build_chill_array_type (ptr_type_node
, idxlist
, 0, NULL_TREE
);
1716 decl
= build_decl (TYPE_DECL
, get_identifier ("__tmp_INTTIME_type"), arrtype
);
1718 DECL_SOURCE_LINE (decl
) = 0;
1719 satisfy_decl (decl
, 0);
1723 build_chill_inttime (t
, loclist
)
1726 int had_errors
= 0, cnt
;
1728 tree init
= NULL_TREE
;
1732 if (t
== NULL_TREE
|| TREE_CODE (t
) == ERROR_MARK
)
1733 return error_mark_node
;
1734 if (loclist
== NULL_TREE
|| TREE_CODE (loclist
) == ERROR_MARK
)
1735 return error_mark_node
;
1737 /* check first argument to be NEWMODE TIME */
1738 if (TREE_TYPE (t
) != abs_timing_type_node
)
1740 error ("argument 1 to INTTIME must be of mode TIME.");
1746 while (tmp
!= NULL_TREE
)
1748 tree loc
= TREE_VALUE (tmp
);
1751 int write_error
= 0;
1753 sprintf (errmsg
, "argument %d to INTTIME must be ", cnt
);
1754 p
= errmsg
+ strlen (errmsg
);
1757 if (loc
== NULL_TREE
|| TREE_CODE (loc
) == ERROR_MARK
)
1761 if (! CH_REFERABLE (loc
))
1763 strcpy (p
, "referable");
1768 if (TREE_CODE (TREE_TYPE (loc
)) != INTEGER_TYPE
)
1772 strcpy (p
, " and ");
1775 strcpy (p
, "of integer type");
1779 /* FIXME: what's about ranges can't hold the result ?? */
1781 error ("%s.", errmsg
);
1784 tmp
= TREE_CHAIN (tmp
);
1789 return error_mark_node
;
1791 /* make it always 6 arguments */
1792 numargs
= list_length (loclist
);
1793 for (cnt
= numargs
; cnt
< 6; cnt
++)
1794 init
= tree_cons (NULL_TREE
, null_pointer_node
, init
);
1796 /* append the given one's */
1798 while (tmp
!= NULL_TREE
)
1800 init
= chainon (init
,
1801 build_tree_list (NULL_TREE
,
1802 build_chill_descr (TREE_VALUE (tmp
))));
1803 tmp
= TREE_CHAIN (tmp
);
1806 tuple
= build_nt (CONSTRUCTOR
, NULL_TREE
, init
);
1807 var
= decl_temp1 (get_unique_identifier ("INTTIME"),
1808 TREE_TYPE (lookup_name (get_identifier ("__tmp_INTTIME_type"))),
1811 return build_chill_function_call (
1812 lookup_name (get_identifier ("_inttime")),
1813 tree_cons (NULL_TREE
, t
,
1814 tree_cons (NULL_TREE
, force_addr_of (var
),
1819 /* Compute the runtime length of the given string variable
1823 build_chill_length (expr
)
1830 if (expr
== NULL_TREE
|| TREE_CODE (expr
) == ERROR_MARK
)
1831 return error_mark_node
;
1833 if (TREE_CODE (expr
) == IDENTIFIER_NODE
)
1834 expr
= lookup_name (expr
);
1836 type
= TREE_TYPE (expr
);
1838 if (TREE_CODE(type
) == ERROR_MARK
)
1840 if (chill_varying_type_p (type
))
1842 tree temp
= convert (integer_type_node
,
1843 build_component_ref (expr
, var_length_id
));
1844 /* FIXME: should call
1845 * cond_type_range_exception (temp);
1850 if ((TREE_CODE (type
) == ARRAY_TYPE
||
1851 /* should work for a bitstring too */
1852 (TREE_CODE (type
) == SET_TYPE
&& TREE_CODE (TREE_TYPE (type
)) == BOOLEAN_TYPE
)) &&
1853 integer_zerop (TYPE_MIN_VALUE (TYPE_DOMAIN (type
))))
1855 tree temp
= fold (build (PLUS_EXPR
, chill_integer_type_node
,
1857 TYPE_MAX_VALUE (TYPE_DOMAIN (type
))));
1858 return convert (chill_integer_type_node
, temp
);
1861 if (CH_IS_BUFFER_MODE (type
) || CH_IS_EVENT_MODE (type
))
1863 tree len
= max_queue_size (type
);
1865 if (len
== NULL_TREE
)
1866 len
= integer_minus_one_node
;
1870 if (CH_IS_TEXT_MODE (type
))
1872 if (TREE_CODE (expr
) == TYPE_DECL
)
1874 /* text mode name */
1875 return text_length (type
);
1880 tree temp
= build_component_ref (
1881 build_component_ref (expr
, get_identifier ("tloc")),
1883 return convert (integer_type_node
, temp
);
1887 error("LENGTH argument must be string, buffer, event mode, text location or mode");
1888 return error_mark_node
;
1893 /* Compute the declared minimum/maximum value of the variable,
1894 * expression or declared type
1897 build_chill_lower_or_upper (what
, is_upper
)
1899 int is_upper
; /* o -> LOWER; 1 -> UPPER */
1904 struct ch_class
class;
1906 if (what
== NULL_TREE
|| TREE_CODE (what
) == ERROR_MARK
)
1907 return error_mark_node
;
1909 if (TREE_CODE_CLASS (TREE_CODE (what
)) == 't')
1912 type
= TREE_TYPE (what
);
1913 if (type
== NULL_TREE
)
1916 error ("UPPER argument must have a mode, or be a mode");
1918 error ("LOWER argument must have a mode, or be a mode");
1919 return error_mark_node
;
1921 while (TREE_CODE (type
) == REFERENCE_TYPE
)
1922 type
= TREE_TYPE (type
);
1923 if (chill_varying_type_p (type
))
1924 type
= CH_VARYING_ARRAY_TYPE (type
);
1926 if (discrete_type_p (type
))
1928 tree val
= is_upper
? TYPE_MAX_VALUE (type
) : TYPE_MIN_VALUE (type
);
1929 class.kind
= CH_VALUE_CLASS
;
1931 return convert_to_class (class, val
);
1933 else if (TREE_CODE (type
) == ARRAY_TYPE
|| TREE_CODE (type
) == SET_TYPE
)
1935 if (TYPE_STRING_FLAG (type
))
1937 class.kind
= CH_DERIVED_CLASS
;
1938 class.mode
= integer_type_node
;
1942 class.kind
= CH_VALUE_CLASS
;
1943 class.mode
= TYPE_DOMAIN (type
);
1945 type
= TYPE_DOMAIN (type
);
1946 return convert_to_class (class,
1948 ? TYPE_MAX_VALUE (type
)
1949 : TYPE_MIN_VALUE (type
));
1952 error("UPPER argument must be string, array, mode or integer");
1954 error("LOWER argument must be string, array, mode or integer");
1955 return error_mark_node
;
1961 build_chill_lower (what
)
1964 return build_chill_lower_or_upper (what
, 0);
1968 build_max_min (expr
, max_min
)
1970 int max_min
; /* 0: calculate MIN; 1: calculate MAX */
1974 tree type
, temp
, setminval
;
1978 if (expr
== NULL_TREE
|| TREE_CODE (expr
) == ERROR_MARK
)
1979 return error_mark_node
;
1981 if (TREE_CODE (expr
) == IDENTIFIER_NODE
)
1982 expr
= lookup_name (expr
);
1984 type
= TREE_TYPE (expr
);
1985 set_base_type
= TYPE_DOMAIN (type
);
1986 setminval
= TYPE_MIN_VALUE (set_base_type
);
1988 if (TREE_CODE (type
) != SET_TYPE
)
1990 error("%s argument must be POWERSET mode",
1991 max_min
? "MAX" : "MIN");
1992 return error_mark_node
;
1995 /* find max/min of constant powerset at compile time */
1996 if (TREE_CODE (expr
) == CONSTRUCTOR
&& TREE_CONSTANT (expr
)
1997 && (size_in_bytes
= int_size_in_bytes (type
)) >= 0)
1999 HOST_WIDE_INT min_val
= -1, max_val
= -1;
2000 HOST_WIDE_INT i
, i_hi
= 0;
2001 HOST_WIDE_INT size_in_bits
= size_in_bytes
* BITS_PER_UNIT
;
2002 char *buffer
= (char*) alloca (size_in_bits
);
2004 || get_set_constructor_bits (expr
, buffer
, size_in_bits
))
2006 for (i
= 0; i
< size_in_bits
; i
++)
2016 error ("%s called for empty POWERSET", max_min
? "MAX" : "MIN");
2017 i
= max_min
? max_val
: min_val
;
2018 temp
= TYPE_MIN_VALUE (TYPE_DOMAIN (TREE_TYPE (expr
)));
2019 add_double (i
, i_hi
,
2020 TREE_INT_CST_LOW (temp
), TREE_INT_CST_HIGH (temp
),
2022 temp
= build_int_2 (i
, i_hi
);
2023 TREE_TYPE (temp
) = set_base_type
;
2028 tree parmlist
, filename
, lineno
;
2029 const char *funcname
;
2031 /* set up to call appropriate runtime function */
2033 funcname
= "__flsetpowerset";
2035 funcname
= "__ffsetpowerset";
2037 setminval
= convert (long_integer_type_node
, setminval
);
2038 filename
= force_addr_of (get_chill_filename());
2039 lineno
= get_chill_linenumber();
2040 parmlist
= tree_cons (NULL_TREE
, force_addr_of (expr
),
2041 tree_cons (NULL_TREE
, powersetlen (expr
),
2042 tree_cons (NULL_TREE
, setminval
,
2043 tree_cons (NULL_TREE
, filename
,
2044 build_tree_list (NULL_TREE
, lineno
)))));
2045 temp
= lookup_name (get_identifier (funcname
));
2046 temp
= build_chill_function_call (temp
, parmlist
);
2047 TREE_TYPE (temp
) = set_base_type
;
2055 /* Compute the current runtime maximum value of the powerset
2058 build_chill_max (expr
)
2061 return build_max_min (expr
, 1);
2065 /* Compute the current runtime minimum value of the powerset
2068 build_chill_min (expr
)
2071 return build_max_min (expr
, 0);
2075 /* Build a conversion from the given expression to an INT,
2076 * but only when the expression's type is the same size as
2080 build_chill_num (expr
)
2088 if (expr
== NULL_TREE
|| TREE_CODE(expr
) == ERROR_MARK
)
2089 return error_mark_node
;
2091 if (TREE_CODE (expr
) == IDENTIFIER_NODE
)
2092 expr
= lookup_name (expr
);
2094 expr
= convert_to_discrete (expr
);
2095 if (expr
== NULL_TREE
)
2097 error ("argument to NUM is not discrete");
2098 return error_mark_node
;
2101 /* enumeral types and string slices of length 1 must be kept unsigned */
2102 need_unsigned
= (TREE_CODE (TREE_TYPE (expr
)) == ENUMERAL_TYPE
)
2103 || TREE_UNSIGNED (TREE_TYPE (expr
));
2105 temp
= type_for_size (TYPE_PRECISION (TREE_TYPE (expr
)),
2107 if (temp
== NULL_TREE
)
2109 error ("No integer mode which matches expression's mode");
2110 return integer_zero_node
;
2112 temp
= convert (temp
, expr
);
2114 if (TREE_CONSTANT (temp
))
2116 if (tree_int_cst_lt (temp
,
2117 TYPE_MIN_VALUE (TREE_TYPE (temp
))))
2118 error ("NUM's parameter is below its mode range");
2119 if (tree_int_cst_lt (TYPE_MAX_VALUE (TREE_TYPE (temp
)),
2121 error ("NUM's parameter is above its mode range");
2127 cond_overflow_exception (temp
,
2128 TYPE_MIN_VALUE (TREE_TYPE (temp
)),
2129 TYPE_MAX_VALUE (TREE_TYPE (temp
)));
2133 /* NUM delivers the INT derived class */
2134 CH_DERIVED_FLAG (temp
) = 1;
2143 build_chill_pred_or_succ (expr
, op
)
2145 enum tree_code op
; /* PLUS_EXPR for SUCC; MINUS_EXPR for PRED. */
2147 struct ch_class
class;
2153 if (expr
== NULL_TREE
|| TREE_CODE (expr
) == ERROR_MARK
)
2154 return error_mark_node
;
2156 /* disallow numbered SETs */
2157 if (TREE_CODE (TREE_TYPE (expr
)) == ENUMERAL_TYPE
2158 && CH_ENUM_IS_NUMBERED (TREE_TYPE (expr
)))
2160 error ("Cannot take SUCC or PRED of a numbered SET");
2161 return error_mark_node
;
2164 if (TREE_CODE (TREE_TYPE (expr
)) == POINTER_TYPE
)
2166 if (TREE_TYPE (TREE_TYPE (expr
)) == void_type_node
)
2168 error ("SUCC or PRED must not be done on a PTR.");
2169 return error_mark_node
;
2171 pedwarn ("SUCC or PRED for a reference type is not standard.");
2172 return fold (build (op
, TREE_TYPE (expr
),
2174 size_in_bytes (TREE_TYPE (TREE_TYPE (expr
)))));
2177 expr
= convert_to_discrete (expr
);
2179 if (expr
== NULL_TREE
)
2181 error ("SUCC or PRED argument must be a discrete mode");
2182 return error_mark_node
;
2185 class = chill_expr_class (expr
);
2187 class.mode
= CH_ROOT_MODE (class.mode
);
2189 expr
= convert (etype
, expr
);
2191 /* Exception if expression is already at the
2192 min (PRED)/max(SUCC) valid value for its type. */
2193 cond
= fold (build (op
== PLUS_EXPR
? GE_EXPR
: LE_EXPR
,
2197 op
== PLUS_EXPR
? TYPE_MAX_VALUE (etype
)
2198 : TYPE_MIN_VALUE (etype
))));
2199 if (TREE_CODE (cond
) == INTEGER_CST
2200 && tree_int_cst_equal (cond
, integer_one_node
))
2202 error ("Taking the %s of a value already at its %s value",
2203 op
== PLUS_EXPR
? "SUCC" : "PRED",
2204 op
== PLUS_EXPR
? "maximum" : "minimum");
2205 return error_mark_node
;
2209 expr
= check_expression (expr
, cond
,
2210 ridpointers
[(int) RID_OVERFLOW
]);
2212 expr
= fold (build (op
, etype
, expr
,
2213 convert (etype
, integer_one_node
)));
2214 return convert_to_class (class, expr
);
2217 /* Compute the value of the CHILL `size' operator just
2218 * like the C 'sizeof' operator (code stolen from c-typeck.c)
2219 * TYPE may be a location or mode tree. In pass 1, we build
2220 * a function-call syntax tree; in pass 2, we evaluate it.
2223 build_chill_sizeof (type
)
2229 struct ch_class
class;
2230 enum tree_code code
;
2231 tree signame
= NULL_TREE
;
2233 if (type
== NULL_TREE
|| TREE_CODE (type
) == ERROR_MARK
)
2234 return error_mark_node
;
2236 if (TREE_CODE (type
) == IDENTIFIER_NODE
)
2237 type
= lookup_name (type
);
2239 code
= TREE_CODE (type
);
2240 if (code
== ERROR_MARK
)
2241 return error_mark_node
;
2243 if (TREE_CODE_CLASS (TREE_CODE (type
)) != 't')
2245 if (TREE_CODE (type
) == TYPE_DECL
&& CH_DECL_SIGNAL (type
))
2246 signame
= DECL_NAME (type
);
2247 type
= TREE_TYPE (type
);
2250 if (code
== FUNCTION_TYPE
)
2252 if (pedantic
|| warn_pointer_arith
)
2253 pedwarn ("size applied to a function mode");
2254 return error_mark_node
;
2256 if (code
== VOID_TYPE
)
2258 if (pedantic
|| warn_pointer_arith
)
2259 pedwarn ("sizeof applied to a void mode");
2260 return error_mark_node
;
2262 if (TYPE_SIZE (type
) == 0)
2264 error ("sizeof applied to an incomplete mode");
2265 return error_mark_node
;
2268 temp
= size_binop (CEIL_DIV_EXPR
, TYPE_SIZE_UNIT (type
),
2269 size_int (TYPE_PRECISION (char_type_node
)
2271 if (signame
!= NULL_TREE
)
2273 /* we have a signal definition. This signal may have no
2274 data items specified. The definition however says that
2275 there are data, cause we cannot build a structure without
2276 fields. In this case return 0. */
2277 if (IDENTIFIER_SIGNAL_DATA (signame
) == 0)
2278 temp
= integer_zero_node
;
2281 /* FIXME: should call
2282 * cond_type_range_exception (temp);
2284 class.kind
= CH_DERIVED_CLASS
;
2285 class.mode
= integer_type_node
;
2286 return convert_to_class (class, temp
);
2291 /* Compute the declared maximum value of the variable,
2292 * expression or declared type
2295 build_chill_upper (what
)
2298 return build_chill_lower_or_upper (what
, 1);
2302 * Here at the site of a function/procedure call.. We need to build
2303 * temps for the INOUT and OUT parameters, and copy the actual parameters
2304 * into the temps. After the call, we 'copy back' the values from the
2305 * temps to the actual parameter variables. This somewhat verbose pol-
2306 * icy meets the requirement that the actual parameters are undisturbed
2307 * if the function/procedure causes an exception. They are updated only
2308 * upon a normal return from the function.
2310 * Note: the expr_list, which collects all of the above assignments, etc,
2311 * is built in REVERSE execution order. The list is corrected by nreverse
2312 * inside the build_chill_compound_expr call.
2315 build_chill_function_call (function
, expr
)
2316 tree function
, expr
;
2318 register tree typetail
, valtail
, typelist
;
2319 register tree temp
, actual_args
= NULL_TREE
;
2320 tree name
= NULL_TREE
;
2323 int parmno
= 1; /* parameter number for error message */
2324 int callee_raise_exception
= 0;
2326 /* list of assignments to run after the actual call,
2327 copying from the temps back to the user's variables. */
2328 tree copy_back
= NULL_TREE
;
2330 /* list of expressions to run before the call, copying from
2331 the user's variable to the temps that are passed to the function */
2332 tree expr_list
= NULL_TREE
;
2334 if (function
== NULL_TREE
|| TREE_CODE (function
) == ERROR_MARK
)
2335 return error_mark_node
;
2337 if (expr
!= NULL_TREE
&& TREE_CODE (expr
) == ERROR_MARK
)
2338 return error_mark_node
;
2341 return error_mark_node
;
2343 fntype
= TREE_TYPE (function
);
2344 if (TREE_CODE (function
) == FUNCTION_DECL
)
2346 callee_raise_exception
= TYPE_RAISES_EXCEPTIONS (fntype
) != NULL_TREE
;
2348 /* Differs from default_conversion by not setting TREE_ADDRESSABLE
2349 (because calling an inline function does not mean the function
2350 needs to be separately compiled). */
2351 fntype
= build_type_variant (fntype
,
2352 TREE_READONLY (function
),
2353 TREE_THIS_VOLATILE (function
));
2354 name
= DECL_NAME (function
);
2356 /* check that function is not a PROCESS */
2357 if (CH_DECL_PROCESS (function
))
2359 error ("cannot call a PROCESS, you START a PROCESS");
2360 return error_mark_node
;
2363 function
= build1 (ADDR_EXPR
, build_pointer_type (fntype
), function
);
2365 else if (TREE_CODE (fntype
) == POINTER_TYPE
)
2367 fntype
= TREE_TYPE (fntype
);
2368 callee_raise_exception
= TYPE_RAISES_EXCEPTIONS (fntype
) != NULL_TREE
;
2370 /* Z.200 6.7 Call Action:
2371 "A procedure call causes the EMPTY exception if the
2372 procedure primitive value delivers NULL. */
2373 if (TREE_CODE (function
) != ADDR_EXPR
2374 || TREE_CODE (TREE_OPERAND (function
, 0)) != FUNCTION_DECL
)
2375 function
= check_non_null (function
);
2378 typelist
= TYPE_ARG_TYPES (fntype
);
2379 if (callee_raise_exception
)
2381 /* remove last two arguments from list for subsequent checking.
2382 They will get added automatically after checking */
2383 int len
= list_length (typelist
);
2385 tree newtypelist
= NULL_TREE
;
2386 tree wrk
= typelist
;
2388 for (i
= 0; i
< len
- 3; i
++)
2390 newtypelist
= tree_cons (TREE_PURPOSE (wrk
), TREE_VALUE (wrk
), newtypelist
);
2391 wrk
= TREE_CHAIN (wrk
);
2393 /* add the void_type_node */
2394 newtypelist
= tree_cons (NULL_TREE
, void_type_node
, newtypelist
);
2395 typelist
= nreverse (newtypelist
);
2398 /* Scan the given expressions and types, producing individual
2399 converted arguments and pushing them on ACTUAL_ARGS in
2401 for (valtail
= expr
, typetail
= typelist
;
2402 valtail
!= NULL_TREE
&& typetail
!= NULL_TREE
; parmno
++,
2403 valtail
= TREE_CHAIN (valtail
), typetail
= TREE_CHAIN (typetail
))
2405 register tree actual
= TREE_VALUE (valtail
);
2406 register tree attr
= TREE_PURPOSE (typetail
)
2407 ? TREE_PURPOSE (typetail
) : ridpointers
[(int) RID_IN
];
2408 register tree type
= TREE_VALUE (typetail
);
2410 sprintf (place
, "parameter %d", parmno
);
2412 /* if we have reached void_type_node in typelist we are at the
2413 end of formal parameters and then we have too many actual
2415 if (type
== void_type_node
)
2418 /* check if actual is a TYPE_DECL. FIXME: what else ? */
2419 if (TREE_CODE (actual
) == TYPE_DECL
)
2421 error ("invalid %s", place
);
2422 actual
= error_mark_node
;
2424 /* INOUT or OUT param to handle? */
2425 else if (attr
== ridpointers
[(int) RID_OUT
]
2426 || attr
== ridpointers
[(int)RID_INOUT
])
2430 tree in_actual
= NULL_TREE
, out_actual
;
2432 /* actual parameter must be a location so we can
2433 build a reference to it */
2434 if (!CH_LOCATION_P (actual
))
2436 error ("%s parameter %d must be a location",
2437 (attr
== ridpointers
[(int) RID_OUT
]) ?
2438 "OUT" : "INOUT", parmno
);
2441 if (TYPE_READONLY_PROPERTY (TREE_TYPE (actual
))
2442 || TREE_READONLY (actual
))
2444 error ("%s parameter %d is READ-only",
2445 (attr
== ridpointers
[(int) RID_OUT
]) ?
2446 "OUT" : "INOUT", parmno
);
2450 sprintf (temp_name
, "PARM_%d_%s", parmno
,
2451 (attr
== ridpointers
[(int)RID_OUT
]) ?
2453 parmtmp
= decl_temp1 (get_unique_identifier (temp_name
),
2454 TREE_TYPE (type
), 0, NULL_TREE
, 0, 0);
2455 /* this temp *must not* be optimized into a register */
2456 mark_addressable (parmtmp
);
2458 if (attr
== ridpointers
[(int)RID_INOUT
])
2460 tree in_actual
= chill_convert_for_assignment (TREE_TYPE (type
),
2462 tree tmp
= build_chill_modify_expr (parmtmp
, in_actual
);
2463 expr_list
= tree_cons (NULL_TREE
, tmp
, expr_list
);
2465 if (in_actual
!= error_mark_node
)
2467 /* list of copy back assignments to perform, from the temp
2468 back to the actual parameter */
2469 out_actual
= chill_convert_for_assignment (TREE_TYPE (actual
),
2471 copy_back
= tree_cons (NULL_TREE
,
2472 build_chill_modify_expr (actual
,
2476 /* we can do this because build_chill_function_type
2477 turned these parameters into REFERENCE_TYPEs. */
2478 actual
= build1 (ADDR_EXPR
, type
, parmtmp
);
2480 else if (attr
== ridpointers
[(int) RID_LOC
])
2482 int is_location
= chill_location (actual
);
2485 if (is_location
== 1)
2487 error ("LOC actual parameter %d is a non-referable location",
2489 actual
= error_mark_node
;
2491 else if (! CH_READ_COMPATIBLE (type
, TREE_TYPE (actual
)))
2493 error ("mode mismatch in parameter %d", parmno
);
2494 actual
= error_mark_node
;
2497 actual
= convert (type
, actual
);
2501 sprintf (place
, "parameter_%d", parmno
);
2502 actual
= decl_temp1 (get_identifier (place
),
2503 TREE_TYPE (type
), 0, actual
, 0, 0);
2504 actual
= convert (type
, actual
);
2506 mark_addressable (actual
);
2509 actual
= chill_convert_for_assignment (type
, actual
, place
);
2511 actual_args
= tree_cons (NULL_TREE
, actual
, actual_args
);
2514 if (valtail
!= 0 && TREE_VALUE (valtail
) != void_type_node
)
2517 error ("too many arguments to procedure `%s'",
2518 IDENTIFIER_POINTER (name
));
2520 error ("too many arguments to procedure");
2521 return error_mark_node
;
2523 else if (typetail
!= 0 && TREE_VALUE (typetail
) != void_type_node
)
2526 error ("too few arguments to procedure `%s'",
2527 IDENTIFIER_POINTER (name
));
2529 error ("too few arguments to procedure");
2530 return error_mark_node
;
2533 if (callee_raise_exception
)
2535 /* add linenumber and filename of the caller as arguments */
2536 actual_args
= tree_cons (NULL_TREE
, force_addr_of (get_chill_filename ()),
2538 actual_args
= tree_cons (NULL_TREE
, get_chill_linenumber (), actual_args
);
2541 function_call
= build (CALL_EXPR
, TREE_TYPE (fntype
),
2542 function
, nreverse (actual_args
), NULL_TREE
);
2543 TREE_SIDE_EFFECTS (function_call
) = 1;
2545 if (copy_back
== NULL_TREE
&& expr_list
== NULL_TREE
)
2546 return function_call
; /* no copying to do, either way */
2549 tree result_type
= TREE_TYPE (fntype
);
2550 tree result_tmp
= NULL_TREE
;
2552 /* no result wanted from procedure call */
2553 if (result_type
== NULL_TREE
|| result_type
== void_type_node
)
2554 expr_list
= tree_cons (NULL_TREE
, function_call
, expr_list
);
2557 /* create a temp for the function's result. this is so that we can
2558 evaluate this temp as the last expression in the list, which will
2559 make the function's return value the value of the whole list of
2560 expressions (by the C rules for compound expressions) */
2561 result_tmp
= decl_temp1 (get_unique_identifier ("FUNC_RESULT"),
2562 result_type
, 0, NULL_TREE
, 0, 0);
2563 expr_list
= tree_cons (NULL_TREE
,
2564 build_chill_modify_expr (result_tmp
, function_call
),
2568 expr_list
= chainon (copy_back
, expr_list
);
2570 /* last, but not least, the function's result */
2571 if (result_tmp
!= NULL_TREE
)
2572 expr_list
= tree_cons (NULL_TREE
, result_tmp
, expr_list
);
2573 temp
= build_chill_compound_expr (nreverse (expr_list
));
2578 /* We saw something that looks like a function call,
2579 but if it's pass 1, we're not sure. */
2582 build_generalized_call (func
, args
)
2585 tree type
= TREE_TYPE (func
);
2588 return build (CALL_EXPR
, NULL_TREE
, func
, args
, NULL_TREE
);
2590 /* Handle string repetition */
2591 if (TREE_CODE (func
) == INTEGER_CST
)
2593 if (args
== NULL_TREE
|| TREE_CHAIN (args
) != NULL_TREE
)
2595 error ("syntax error (integer used as function)");
2596 return error_mark_node
;
2598 if (TREE_CODE (args
) == TREE_LIST
)
2599 args
= TREE_VALUE (args
);
2600 return build_chill_repetition_op (func
, args
);
2603 if (args
!= NULL_TREE
)
2605 if (TREE_CODE (args
) == RANGE_EXPR
)
2607 tree lo
= TREE_OPERAND (args
, 0), hi
= TREE_OPERAND (args
, 1);
2608 if (TREE_CODE_CLASS (TREE_CODE (func
)) == 't')
2609 return build_chill_range_type (func
, lo
, hi
);
2611 return build_chill_slice_with_range (func
, lo
, hi
);
2613 else if (TREE_CODE (args
) != TREE_LIST
)
2615 error ("syntax error - missing operator, comma, or '('?");
2616 return error_mark_node
;
2620 if (TREE_CODE (func
) == TYPE_DECL
)
2622 if (CH_DECL_SIGNAL (func
))
2623 return build_signal_descriptor (func
, args
);
2624 func
= TREE_TYPE (func
);
2627 if (TREE_CODE_CLASS (TREE_CODE (func
)) == 't'
2628 && args
!= NULL_TREE
&& TREE_CHAIN (args
) == NULL_TREE
)
2629 return build_chill_cast (func
, TREE_VALUE (args
));
2631 if (TREE_CODE (type
) == FUNCTION_TYPE
2632 || (TREE_CODE (type
) == POINTER_TYPE
2633 && TREE_TYPE (type
) != NULL_TREE
2634 && TREE_CODE (TREE_TYPE (type
)) == FUNCTION_TYPE
))
2636 /* Check for a built-in Chill function. */
2637 if (TREE_CODE (func
) == FUNCTION_DECL
2638 && DECL_BUILT_IN (func
)
2639 && DECL_FUNCTION_CODE (func
) > END_BUILTINS
)
2641 tree fnname
= DECL_NAME (func
);
2642 switch ((enum chill_built_in_function
)DECL_FUNCTION_CODE (func
))
2644 case BUILT_IN_CH_ABS
:
2645 if (check_arglist_length (args
, 1, 1, fnname
) < 0)
2646 return error_mark_node
;
2647 return build_chill_abs (TREE_VALUE (args
));
2648 case BUILT_IN_ABSTIME
:
2649 if (check_arglist_length (args
, 0, 6, fnname
) < 0)
2650 return error_mark_node
;
2651 return build_chill_abstime (args
);
2653 if (check_arglist_length (args
, 1, 1, fnname
) < 0)
2654 return error_mark_node
;
2656 return build_chill_addr_expr (TREE_VALUE (args
), (char *)0);
2658 return build_chill_arrow_expr (TREE_VALUE (args
), 0);
2660 case BUILT_IN_ALLOCATE_GLOBAL_MEMORY
:
2661 if (check_arglist_length (args
, 2, 2, fnname
) < 0)
2662 return error_mark_node
;
2663 return build_allocate_global_memory_call
2665 TREE_VALUE (TREE_CHAIN (args
)));
2666 case BUILT_IN_ALLOCATE
:
2667 if (check_arglist_length (args
, 1, 2, fnname
) < 0)
2668 return error_mark_node
;
2669 return build_chill_allocate (TREE_VALUE (args
),
2670 TREE_CHAIN (args
) == NULL_TREE
? NULL_TREE
: TREE_VALUE (TREE_CHAIN (args
)));
2671 case BUILT_IN_ALLOCATE_MEMORY
:
2672 if (check_arglist_length (args
, 2, 2, fnname
) < 0)
2673 return error_mark_node
;
2674 return build_allocate_memory_call
2676 TREE_VALUE (TREE_CHAIN (args
)));
2677 case BUILT_IN_ASSOCIATE
:
2678 if (check_arglist_length (args
, 2, 3, fnname
) < 0)
2679 return error_mark_node
;
2680 return build_chill_associate
2682 TREE_VALUE (TREE_CHAIN (args
)),
2683 TREE_CHAIN (TREE_CHAIN (args
)));
2684 case BUILT_IN_ARCCOS
:
2685 if (check_arglist_length (args
, 1, 1, fnname
) < 0)
2686 return error_mark_node
;
2687 return build_chill_floatcall (TREE_VALUE (args
),
2688 IDENTIFIER_POINTER (fnname
),
2690 case BUILT_IN_ARCSIN
:
2691 if (check_arglist_length (args
, 1, 1, fnname
) < 0)
2692 return error_mark_node
;
2693 return build_chill_floatcall (TREE_VALUE (args
),
2694 IDENTIFIER_POINTER (fnname
),
2696 case BUILT_IN_ARCTAN
:
2697 if (check_arglist_length (args
, 1, 1, fnname
) < 0)
2698 return error_mark_node
;
2699 return build_chill_floatcall (TREE_VALUE (args
),
2700 IDENTIFIER_POINTER (fnname
),
2703 if (check_arglist_length (args
, 1, 1, fnname
) < 0)
2704 return error_mark_node
;
2705 return build_chill_card (TREE_VALUE (args
));
2706 case BUILT_IN_CONNECT
:
2707 if (check_arglist_length (args
, 3, 5, fnname
) < 0)
2708 return error_mark_node
;
2709 return build_chill_connect
2711 TREE_VALUE (TREE_CHAIN (args
)),
2712 TREE_VALUE (TREE_CHAIN (TREE_CHAIN (args
))),
2713 TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (args
))));
2714 case BUILT_IN_COPY_NUMBER
:
2715 if (check_arglist_length (args
, 1, 1, fnname
) < 0)
2716 return error_mark_node
;
2717 return build_copy_number (TREE_VALUE (args
));
2718 case BUILT_IN_CH_COS
:
2719 if (check_arglist_length (args
, 1, 1, fnname
) < 0)
2720 return error_mark_node
;
2721 return build_chill_floatcall (TREE_VALUE (args
),
2722 IDENTIFIER_POINTER (fnname
),
2724 case BUILT_IN_CREATE
:
2725 if (check_arglist_length (args
, 1, 1, fnname
) < 0)
2726 return error_mark_node
;
2727 return build_chill_create (TREE_VALUE (args
));
2729 if (check_arglist_length (args
, 1, 1, fnname
) < 0)
2730 return error_mark_node
;
2731 return build_chill_duration (TREE_VALUE (args
), DAYS_MULTIPLIER
,
2733 case BUILT_IN_CH_DELETE
:
2734 if (check_arglist_length (args
, 1, 1, fnname
) < 0)
2735 return error_mark_node
;
2736 return build_chill_delete (TREE_VALUE (args
));
2737 case BUILT_IN_DESCR
:
2738 if (check_arglist_length (args
, 1, 1, fnname
) < 0)
2739 return error_mark_node
;
2740 return build_chill_descr (TREE_VALUE (args
));
2741 case BUILT_IN_DISCONNECT
:
2742 if (check_arglist_length (args
, 1, 1, fnname
) < 0)
2743 return error_mark_node
;
2744 return build_chill_disconnect (TREE_VALUE (args
));
2745 case BUILT_IN_DISSOCIATE
:
2746 if (check_arglist_length (args
, 1, 1, fnname
) < 0)
2747 return error_mark_node
;
2748 return build_chill_dissociate (TREE_VALUE (args
));
2750 if (check_arglist_length (args
, 1, 1, fnname
) < 0)
2751 return error_mark_node
;
2752 return build_chill_eoln (TREE_VALUE (args
));
2753 case BUILT_IN_EXISTING
:
2754 if (check_arglist_length (args
, 1, 1, fnname
) < 0)
2755 return error_mark_node
;
2756 return build_chill_existing (TREE_VALUE (args
));
2758 if (check_arglist_length (args
, 1, 1, fnname
) < 0)
2759 return error_mark_node
;
2760 return build_chill_floatcall (TREE_VALUE (args
),
2761 IDENTIFIER_POINTER (fnname
),
2763 case BUILT_IN_GEN_CODE
:
2764 if (check_arglist_length (args
, 1, 1, fnname
) < 0)
2765 return error_mark_node
;
2766 return build_gen_code (TREE_VALUE (args
));
2767 case BUILT_IN_GEN_INST
:
2768 if (check_arglist_length (args
, 2, 2, fnname
) < 0)
2769 return error_mark_node
;
2770 return build_gen_inst (TREE_VALUE (args
),
2771 TREE_VALUE (TREE_CHAIN (args
)));
2772 case BUILT_IN_GEN_PTYPE
:
2773 if (check_arglist_length (args
, 1, 1, fnname
) < 0)
2774 return error_mark_node
;
2775 return build_gen_ptype (TREE_VALUE (args
));
2776 case BUILT_IN_GETASSOCIATION
:
2777 if (check_arglist_length (args
, 1, 1, fnname
) < 0)
2778 return error_mark_node
;
2779 return build_chill_getassociation (TREE_VALUE (args
));
2780 case BUILT_IN_GETSTACK
:
2781 if (check_arglist_length (args
, 1, 2, fnname
) < 0)
2782 return error_mark_node
;
2783 return build_chill_getstack (TREE_VALUE (args
),
2784 TREE_CHAIN (args
) == NULL_TREE
? NULL_TREE
: TREE_VALUE (TREE_CHAIN (args
)));
2785 case BUILT_IN_GETTEXTACCESS
:
2786 if (check_arglist_length (args
, 1, 1, fnname
) < 0)
2787 return error_mark_node
;
2788 return build_chill_gettextaccess (TREE_VALUE (args
));
2789 case BUILT_IN_GETTEXTINDEX
:
2790 if (check_arglist_length (args
, 1, 1, fnname
) < 0)
2791 return error_mark_node
;
2792 return build_chill_gettextindex (TREE_VALUE (args
));
2793 case BUILT_IN_GETTEXTRECORD
:
2794 if (check_arglist_length (args
, 1, 1, fnname
) < 0)
2795 return error_mark_node
;
2796 return build_chill_gettextrecord (TREE_VALUE (args
));
2797 case BUILT_IN_GETUSAGE
:
2798 if (check_arglist_length (args
, 1, 1, fnname
) < 0)
2799 return error_mark_node
;
2800 return build_chill_getusage (TREE_VALUE (args
));
2801 case BUILT_IN_HOURS
:
2802 if (check_arglist_length (args
, 1, 1, fnname
) < 0)
2803 return error_mark_node
;
2804 return build_chill_duration (TREE_VALUE (args
), HOURS_MULTIPLIER
,
2806 case BUILT_IN_INDEXABLE
:
2807 if (check_arglist_length (args
, 1, 1, fnname
) < 0)
2808 return error_mark_node
;
2809 return build_chill_indexable (TREE_VALUE (args
));
2810 case BUILT_IN_INTTIME
:
2811 if (check_arglist_length (args
, 2, 7, fnname
) < 0)
2812 return error_mark_node
;
2813 return build_chill_inttime (TREE_VALUE (args
),
2815 case BUILT_IN_ISASSOCIATED
:
2816 if (check_arglist_length (args
, 1, 1, fnname
) < 0)
2817 return error_mark_node
;
2818 return build_chill_isassociated (TREE_VALUE (args
));
2819 case BUILT_IN_LENGTH
:
2820 if (check_arglist_length (args
, 1, 1, fnname
) < 0)
2821 return error_mark_node
;
2822 return build_chill_length (TREE_VALUE (args
));
2824 if (check_arglist_length (args
, 1, 1, fnname
) < 0)
2825 return error_mark_node
;
2826 return build_chill_floatcall (TREE_VALUE (args
),
2827 IDENTIFIER_POINTER (fnname
),
2830 if (check_arglist_length (args
, 1, 1, fnname
) < 0)
2831 return error_mark_node
;
2832 return build_chill_floatcall (TREE_VALUE (args
),
2833 IDENTIFIER_POINTER (fnname
),
2835 case BUILT_IN_LOWER
:
2836 if (check_arglist_length (args
, 1, 1, fnname
) < 0)
2837 return error_mark_node
;
2838 return build_chill_lower (TREE_VALUE (args
));
2840 if (check_arglist_length (args
, 1, 1, fnname
) < 0)
2841 return error_mark_node
;
2842 return build_chill_max (TREE_VALUE (args
));
2843 case BUILT_IN_MILLISECS
:
2844 if (check_arglist_length (args
, 1, 1, fnname
) < 0)
2845 return error_mark_node
;
2846 return build_chill_duration (TREE_VALUE (args
), MILLISECS_MULTIPLIER
,
2847 fnname
, MILLISECS_MAX
);
2849 if (check_arglist_length (args
, 1, 1, fnname
) < 0)
2850 return error_mark_node
;
2851 return build_chill_min (TREE_VALUE (args
));
2852 case BUILT_IN_MINUTES
:
2853 if (check_arglist_length (args
, 1, 1, fnname
) < 0)
2854 return error_mark_node
;
2855 return build_chill_duration (TREE_VALUE (args
), MINUTES_MULTIPLIER
,
2856 fnname
, MINUTES_MAX
);
2857 case BUILT_IN_MODIFY
:
2858 if (check_arglist_length (args
, 1, -1, fnname
) < 0)
2859 return error_mark_node
;
2860 return build_chill_modify (TREE_VALUE (args
), TREE_CHAIN (args
));
2862 if (check_arglist_length (args
, 1, 1, fnname
) < 0)
2863 return error_mark_node
;
2864 return build_chill_num (TREE_VALUE (args
));
2865 case BUILT_IN_OUTOFFILE
:
2866 if (check_arglist_length (args
, 1, 1, fnname
) < 0)
2867 return error_mark_node
;
2868 return build_chill_outoffile (TREE_VALUE (args
));
2870 if (check_arglist_length (args
, 1, 1, fnname
) < 0)
2871 return error_mark_node
;
2872 return build_chill_pred_or_succ (TREE_VALUE (args
), MINUS_EXPR
);
2873 case BUILT_IN_PROC_TYPE
:
2874 if (check_arglist_length (args
, 1, 1, fnname
) < 0)
2875 return error_mark_node
;
2876 return build_proc_type (TREE_VALUE (args
));
2877 case BUILT_IN_QUEUE_LENGTH
:
2878 if (check_arglist_length (args
, 1, 1, fnname
) < 0)
2879 return error_mark_node
;
2880 return build_queue_length (TREE_VALUE (args
));
2881 case BUILT_IN_READABLE
:
2882 if (check_arglist_length (args
, 1, 1, fnname
) < 0)
2883 return error_mark_node
;
2884 return build_chill_readable (TREE_VALUE (args
));
2885 case BUILT_IN_READRECORD
:
2886 if (check_arglist_length (args
, 1, 3, fnname
) < 0)
2887 return error_mark_node
;
2888 return build_chill_readrecord (TREE_VALUE (args
), TREE_CHAIN (args
));
2889 case BUILT_IN_READTEXT
:
2890 if (check_arglist_length (args
, 2, -1, fnname
) < 0)
2891 return error_mark_node
;
2892 return build_chill_readtext (TREE_VALUE (args
),
2894 case BUILT_IN_RETURN_MEMORY
:
2895 if (check_arglist_length (args
, 1, 1, fnname
) < 0)
2896 return error_mark_node
;
2897 return build_return_memory (TREE_VALUE (args
));
2899 if (check_arglist_length (args
, 1, 1, fnname
) < 0)
2900 return error_mark_node
;
2901 return build_chill_duration (TREE_VALUE (args
), SECS_MULTIPLIER
,
2903 case BUILT_IN_SEQUENCIBLE
:
2904 if (check_arglist_length (args
, 1, 1, fnname
) < 0)
2905 return error_mark_node
;
2906 return build_chill_sequencible (TREE_VALUE (args
));
2907 case BUILT_IN_SETTEXTACCESS
:
2908 if (check_arglist_length (args
, 2, 2, fnname
) < 0)
2909 return error_mark_node
;
2910 return build_chill_settextaccess (TREE_VALUE (args
),
2911 TREE_VALUE (TREE_CHAIN (args
)));
2912 case BUILT_IN_SETTEXTINDEX
:
2913 if (check_arglist_length (args
, 2, 2, fnname
) < 0)
2914 return error_mark_node
;
2915 return build_chill_settextindex (TREE_VALUE (args
),
2916 TREE_VALUE (TREE_CHAIN (args
)));
2917 case BUILT_IN_SETTEXTRECORD
:
2918 if (check_arglist_length (args
, 2, 2, fnname
) < 0)
2919 return error_mark_node
;
2920 return build_chill_settextrecord (TREE_VALUE (args
),
2921 TREE_VALUE (TREE_CHAIN (args
)));
2922 case BUILT_IN_CH_SIN
:
2923 if (check_arglist_length (args
, 1, 1, fnname
) < 0)
2924 return error_mark_node
;
2925 return build_chill_floatcall (TREE_VALUE (args
),
2926 IDENTIFIER_POINTER (fnname
),
2929 if (check_arglist_length (args
, 1, 1, fnname
) < 0)
2930 return error_mark_node
;
2931 return build_chill_sizeof (TREE_VALUE (args
));
2933 if (check_arglist_length (args
, 1, 1, fnname
) < 0)
2934 return error_mark_node
;
2935 return build_chill_floatcall (TREE_VALUE (args
),
2936 IDENTIFIER_POINTER (fnname
),
2939 if (check_arglist_length (args
, 1, 1, fnname
) < 0)
2940 return error_mark_node
;
2941 return build_chill_pred_or_succ (TREE_VALUE (args
), PLUS_EXPR
);
2943 if (check_arglist_length (args
, 1, 1, fnname
) < 0)
2944 return error_mark_node
;
2945 return build_chill_floatcall (TREE_VALUE (args
),
2946 IDENTIFIER_POINTER (fnname
),
2948 case BUILT_IN_TERMINATE
:
2949 if (check_arglist_length (args
, 1, 1, fnname
) < 0)
2950 return error_mark_node
;
2951 return build_chill_terminate (TREE_VALUE (args
));
2952 case BUILT_IN_UPPER
:
2953 if (check_arglist_length (args
, 1, 1, fnname
) < 0)
2954 return error_mark_node
;
2955 return build_chill_upper (TREE_VALUE (args
));
2956 case BUILT_IN_VARIABLE
:
2957 if (check_arglist_length (args
, 1, 1, fnname
) < 0)
2958 return error_mark_node
;
2959 return build_chill_variable (TREE_VALUE (args
));
2960 case BUILT_IN_WRITEABLE
:
2961 if (check_arglist_length (args
, 1, 1, fnname
) < 0)
2962 return error_mark_node
;
2963 return build_chill_writeable (TREE_VALUE (args
));
2964 case BUILT_IN_WRITERECORD
:
2965 if (check_arglist_length (args
, 2, 3, fnname
) < 0)
2966 return error_mark_node
;
2967 return build_chill_writerecord (TREE_VALUE (args
), TREE_CHAIN (args
));
2968 case BUILT_IN_WRITETEXT
:
2969 if (check_arglist_length (args
, 2, -1, fnname
) < 0)
2970 return error_mark_node
;
2971 return build_chill_writetext (TREE_VALUE (args
),
2974 case BUILT_IN_EXPIRED
:
2976 sorry ("unimplemented builtin function `%s'",
2977 IDENTIFIER_POINTER (fnname
));
2980 error ("internal error - bad builtin function `%s'",
2981 IDENTIFIER_POINTER (fnname
));
2984 return build_chill_function_call (func
, args
);
2987 if (chill_varying_type_p (TREE_TYPE (func
)))
2988 type
= TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (type
)));
2990 if (CH_STRING_TYPE_P (type
))
2992 if (args
== NULL_TREE
)
2994 error ("empty expression in string index");
2995 return error_mark_node
;
2997 if (TREE_CHAIN (args
) != NULL
)
2999 error ("only one expression allowed in string index");
3000 return error_mark_node
;
3002 if (flag_old_strings
)
3003 return build_chill_slice_with_length (func
,
3006 else if (CH_BOOLS_TYPE_P (type
))
3007 return build_chill_bitref (func
, args
);
3009 return build_chill_array_ref (func
, args
);
3012 else if (TREE_CODE (type
) == ARRAY_TYPE
)
3013 return build_chill_array_ref (func
, args
);
3015 if (TREE_CODE (func
) != ERROR_MARK
)
3016 error ("invalid: primval ( untyped_exprlist )");
3017 return error_mark_node
;
3020 /* Given a set stored as one bit per char (in BUFFER[0 .. BIT_SIZE-1]),
3021 return a CONTRUCTOR, of type TYPE (a SET_TYPE). */
3023 expand_packed_set (buffer
, bit_size
, type
)
3028 /* The ordinal number corresponding to the first stored bit. */
3029 HOST_WIDE_INT first_bit_no
=
3030 TREE_INT_CST_LOW (TYPE_MIN_VALUE (TYPE_DOMAIN (type
)));
3031 tree list
= NULL_TREE
;
3034 for (i
= 0; i
< bit_size
; i
++)
3038 for (next_0
= i
+ 1;
3039 next_0
< bit_size
&& buffer
[next_0
]; next_0
++)
3041 if (next_0
== i
+ 1)
3042 list
= tree_cons (NULL_TREE
,
3043 build_int_2 (i
+ first_bit_no
, 0), list
);
3046 list
= tree_cons (build_int_2 (i
+ first_bit_no
, 0),
3047 build_int_2 (next_0
- 1 + first_bit_no
, 0), list
);
3048 /* advance i past the range of 1-bits */
3052 list
= build (CONSTRUCTOR
, type
, NULL_TREE
, nreverse (list
));
3053 TREE_CONSTANT (list
) = 1;
3058 * fold a set represented as a CONSTRUCTOR list.
3059 * An empty set has a NULL_TREE in its TREE_OPERAND (set, 1) slot.
3062 fold_set_expr (code
, op0
, op1
)
3063 enum chill_tree_code code
;
3067 char *buffer0
, *buffer1
= NULL
, *bufferr
;
3068 int i
, size0
, size1
, first_unused_bit
;
3070 if (! TREE_CONSTANT (op0
) || TREE_CODE (op0
) != CONSTRUCTOR
)
3074 && (! TREE_CONSTANT (op1
) || TREE_CODE (op1
) != CONSTRUCTOR
))
3077 size0
= int_size_in_bytes (TREE_TYPE (op0
)) * BITS_PER_UNIT
;
3080 error ("operand is variable-size bitstring/power-set");
3081 return error_mark_node
;
3083 buffer0
= (char*) alloca (size0
);
3085 temp
= get_set_constructor_bits (op0
, buffer0
, size0
);
3091 size1
= int_size_in_bytes (TREE_TYPE (op1
)) * BITS_PER_UNIT
;
3094 error ("operand is variable-size bitstring/power-set");
3095 return error_mark_node
;
3099 buffer1
= (char*) alloca (size1
);
3100 temp
= get_set_constructor_bits (op1
, buffer1
, size1
);
3105 bufferr
= (char*) alloca (size0
); /* result buffer */
3111 for (i
= 0; i
< size0
; i
++)
3112 bufferr
[i
] = 1 & ~buffer0
[i
];
3116 for (i
= 0; i
< size0
; i
++)
3117 bufferr
[i
] = buffer0
[i
] & buffer1
[i
];
3121 for (i
= 0; i
< size0
; i
++)
3122 bufferr
[i
] = buffer0
[i
] | buffer1
[i
];
3126 for (i
= 0; i
< size0
; i
++)
3127 bufferr
[i
] = (buffer0
[i
] ^ buffer1
[i
]) & 1;
3131 for (i
= 0; i
< size0
; i
++)
3132 bufferr
[i
] = buffer0
[i
] & ~buffer1
[i
];
3135 /* mask out unused bits. Same as runtime library does. */
3136 first_unused_bit
= TREE_INT_CST_LOW (TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (op0
))))
3137 - TREE_INT_CST_LOW (TYPE_MIN_VALUE (TYPE_DOMAIN (TREE_TYPE (op0
)))) + 1;
3138 for (i
= first_unused_bit
; i
< size0
; i
++)
3140 return expand_packed_set (bufferr
, size0
, TREE_TYPE (op0
));
3142 for (i
= 0; i
< size0
; i
++)
3143 if (buffer0
[i
] != buffer1
[i
])
3144 return boolean_false_node
;
3145 return boolean_true_node
;
3148 for (i
= 0; i
< size0
; i
++)
3149 if (buffer0
[i
] != buffer1
[i
])
3150 return boolean_true_node
;
3151 return boolean_false_node
;
3159 * build a set or bit-array expression. Type-checking is
3163 build_compare_set_expr (code
, op0
, op1
)
3164 enum tree_code code
;
3167 tree result_type
= NULL_TREE
;
3171 /* These conversions are needed if -fold-strings. */
3172 if (TREE_CODE (TREE_TYPE (op0
)) == BOOLEAN_TYPE
)
3174 if (CH_BOOLS_ONE_P (TREE_TYPE (op1
)))
3175 return build_compare_discrete_expr (code
,
3177 convert (boolean_type_node
, op1
));
3179 op0
= convert (bitstring_one_type_node
, op0
);
3181 if (TREE_CODE (TREE_TYPE (op1
)) == BOOLEAN_TYPE
)
3183 if (CH_BOOLS_ONE_P (TREE_TYPE (op0
)))
3184 return build_compare_discrete_expr (code
,
3185 convert (boolean_type_node
, op0
),
3188 op1
= convert (bitstring_one_type_node
, op1
);
3195 tree temp
= fold_set_expr (EQ_EXPR
, op0
, op1
);
3198 fnname
= "__eqpowerset";
3199 goto compare_powerset
;
3204 /* switch operands and fall thru */
3210 fnname
= "__lepowerset";
3211 goto compare_powerset
;
3214 /* switch operands and fall thru */
3220 fnname
= "__ltpowerset";
3221 goto compare_powerset
;
3224 return invert_truthvalue (build_compare_set_expr (EQ_EXPR
, op0
, op1
));
3228 tree tsize
= powersetlen (op0
);
3230 if (TREE_CODE (TREE_TYPE (op0
)) != SET_TYPE
)
3231 tsize
= fold (build (MULT_EXPR
, sizetype
, tsize
,
3232 size_int (BITS_PER_UNIT
)));
3234 return build_chill_function_call (lookup_name (get_identifier (fnname
)),
3235 tree_cons (NULL_TREE
, force_addr_of (op0
),
3236 tree_cons (NULL_TREE
, force_addr_of (op1
),
3237 tree_cons (NULL_TREE
, tsize
, NULL_TREE
))));
3242 if ((int) code
>= (int)LAST_AND_UNUSED_TREE_CODE
)
3244 error ("tree code `%s' unhandled in build_compare_set_expr",
3245 tree_code_name
[(int)code
]);
3246 return error_mark_node
;
3251 return build ((enum tree_code
)code
, result_type
,
3255 /* Convert a varying string (or array) to dynamic non-varying string:
3256 EXP becomes EXP.var_data(0 UP EXP.var_length). */
3259 varying_to_slice (exp
)
3262 if (!chill_varying_type_p (TREE_TYPE (exp
)))
3265 { tree size
, data
, data_domain
, min
;
3266 tree novelty
= CH_NOVELTY (TREE_TYPE (exp
));
3267 exp
= save_if_needed (exp
);
3268 size
= build_component_ref (exp
, var_length_id
);
3269 data
= build_component_ref (exp
, var_data_id
);
3270 TREE_TYPE (data
) = copy_novelty (novelty
, TREE_TYPE (data
));
3271 data_domain
= TYPE_DOMAIN (TREE_TYPE (data
));
3272 if (data_domain
!= NULL_TREE
3273 && TYPE_MIN_VALUE (data_domain
) != NULL_TREE
)
3274 min
= TYPE_MIN_VALUE (data_domain
);
3276 min
= integer_zero_node
;
3277 return build_chill_slice (data
, min
, size
);
3281 /* Convert a scalar argument to a string or array type. This is a subroutine
3282 of `build_concat_expr'. */
3285 scalar_to_string (exp
)
3288 tree type
= TREE_TYPE (exp
);
3290 if (SCALAR_P (type
))
3292 int was_const
= TREE_CONSTANT (exp
);
3293 if (TREE_TYPE (exp
) == char_type_node
)
3294 exp
= convert (string_one_type_node
, exp
);
3295 else if (TREE_TYPE (exp
) == boolean_type_node
)
3296 exp
= convert (bitstring_one_type_node
, exp
);
3298 exp
= convert (build_array_type_for_scalar (type
), exp
);
3299 TREE_CONSTANT (exp
) = was_const
;
3302 return varying_to_slice (exp
);
3305 /* FIXME: Generalize this to general arrays (not just strings),
3306 at least for the compiler-generated case of padding fixed-length arrays. */
3309 build_concat_expr (op0
, op1
)
3312 tree orig_op0
= op0
, orig_op1
= op1
;
3313 tree type0
, type1
, size0
, size1
, res
;
3315 op0
= scalar_to_string (op0
);
3316 type0
= TREE_TYPE (op0
);
3317 op1
= scalar_to_string (op1
);
3318 type1
= TREE_TYPE (op1
);
3319 size1
= size_in_bytes (type1
);
3321 /* try to fold constant string literals */
3322 if (TREE_CODE (op0
) == STRING_CST
3323 && (TREE_CODE (op1
) == STRING_CST
3324 || TREE_CODE (op1
) == UNDEFINED_EXPR
)
3325 && TREE_CODE (size1
) == INTEGER_CST
)
3327 int len0
= TREE_STRING_LENGTH (op0
);
3328 int len1
= TREE_INT_CST_LOW (size1
);
3329 char *result
= xmalloc (len0
+ len1
+ 1);
3330 memcpy (result
, TREE_STRING_POINTER (op0
), len0
);
3331 if (TREE_CODE (op1
) == UNDEFINED_EXPR
)
3332 memset (&result
[len0
], '\0', len1
);
3334 memcpy (&result
[len0
], TREE_STRING_POINTER (op1
), len1
);
3335 return build_chill_string (len0
+ len1
, result
);
3337 else if (TREE_CODE (type0
) == TREE_CODE (type1
))
3340 struct ch_class result_class
;
3341 struct ch_class class0
;
3342 struct ch_class class1
;
3344 class0
= chill_expr_class (orig_op0
);
3345 class1
= chill_expr_class (orig_op1
);
3347 if (TREE_CODE (type0
) == SET_TYPE
)
3349 result_size
= fold (build (PLUS_EXPR
, integer_type_node
,
3350 discrete_count (TYPE_DOMAIN (type0
)),
3351 discrete_count (TYPE_DOMAIN (type1
))));
3352 result_class
.mode
= build_bitstring_type (result_size
);
3356 tree max0
= TYPE_MAX_VALUE (type0
);
3357 tree max1
= TYPE_MAX_VALUE (type1
);
3359 /* new array's dynamic size (in bytes). */
3360 size0
= size_in_bytes (type0
);
3361 /* size1 was computed above. */
3363 result_size
= size_binop (PLUS_EXPR
, size0
, size1
);
3364 /* new array's type. */
3365 result_class
.mode
= build_string_type (char_type_node
, result_size
);
3369 max0
= max0
== 0 ? size0
: convert (sizetype
, max0
);
3370 max1
= max1
== 0 ? size1
: convert (sizetype
, max1
);
3371 TYPE_MAX_VALUE (result_class
.mode
)
3372 = size_binop (PLUS_EXPR
, max0
, max1
);
3376 if (class0
.kind
== CH_VALUE_CLASS
|| class1
.kind
== CH_VALUE_CLASS
)
3378 tree novelty0
= CH_NOVELTY (TREE_TYPE (orig_op0
));
3379 result_class
.kind
= CH_VALUE_CLASS
;
3380 if (class0
.kind
== CH_VALUE_CLASS
&& novelty0
!= NULL_TREE
)
3381 SET_CH_NOVELTY_NONNIL (result_class
.mode
, novelty0
);
3382 else if (class1
.kind
== CH_VALUE_CLASS
)
3383 SET_CH_NOVELTY (result_class
.mode
,
3384 CH_NOVELTY (TREE_TYPE (orig_op1
)));
3387 result_class
.kind
= CH_DERIVED_CLASS
;
3389 if (TREE_CODE (result_class
.mode
) == SET_TYPE
3390 && TREE_CONSTANT (op0
) && TREE_CONSTANT (op1
)
3391 && TREE_CODE (op0
) == CONSTRUCTOR
&& TREE_CODE (op1
) == CONSTRUCTOR
)
3393 HOST_WIDE_INT size0
, size1
; char *buffer
;
3394 size0
= TREE_INT_CST_LOW (TYPE_MAX_VALUE (TYPE_DOMAIN (type0
))) + 1;
3395 size1
= TREE_INT_CST_LOW (TYPE_MAX_VALUE (TYPE_DOMAIN (type1
))) + 1;
3396 buffer
= (char*) alloca (size0
+ size1
);
3397 if (size0
< 0 || size1
< 0
3398 || get_set_constructor_bits (op0
, buffer
, size0
)
3399 || get_set_constructor_bits (op1
, buffer
+ size0
, size1
))
3401 res
= expand_packed_set (buffer
, size0
+ size1
, result_class
.mode
);
3404 res
= build (CONCAT_EXPR
, result_class
.mode
, op0
, op1
);
3405 return convert_to_class (result_class
, res
);
3409 error ("incompatible modes in concat expression");
3410 return error_mark_node
;
3415 * handle varying and fixed array compare operations
3418 build_compare_string_expr (code
, op0
, op1
)
3419 enum tree_code code
;
3422 if (op0
== NULL_TREE
|| TREE_CODE (op0
) == ERROR_MARK
)
3423 return error_mark_node
;
3424 if (op1
== NULL_TREE
|| TREE_CODE (op1
) == ERROR_MARK
)
3425 return error_mark_node
;
3427 if (tree_int_cst_equal (TYPE_SIZE (TREE_TYPE (op0
)),
3428 TYPE_SIZE (TREE_TYPE (op1
)))
3429 && ! chill_varying_type_p (TREE_TYPE (op0
))
3430 && ! chill_varying_type_p (TREE_TYPE (op1
)))
3432 tree size
= size_in_bytes (TREE_TYPE (op0
));
3433 tree temp
= lookup_name (get_identifier ("memcmp"));
3434 temp
= build_chill_function_call (temp
,
3435 tree_cons (NULL_TREE
, force_addr_of (op0
),
3436 tree_cons (NULL_TREE
, force_addr_of (op1
),
3437 tree_cons (NULL_TREE
, size
, NULL_TREE
))));
3438 return build_compare_discrete_expr (code
, temp
, integer_zero_node
);
3444 code
= STRING_EQ_EXPR
;
3447 return invert_truthvalue (build_compare_string_expr (LT_EXPR
, op0
, op1
));
3449 return invert_truthvalue (build_compare_string_expr (LT_EXPR
, op1
, op0
));
3451 return build_compare_string_expr (LT_EXPR
, op1
, op0
);
3453 code
= STRING_LT_EXPR
;
3456 return invert_truthvalue (build_compare_string_expr (EQ_EXPR
, op0
, op1
));
3458 error ("Invalid operation on array of chars");
3459 return error_mark_node
;
3462 return build (code
, boolean_type_node
, op0
, op1
);
3466 compare_records (exp0
, exp1
)
3469 tree type
= TREE_TYPE (exp0
);
3471 int have_variants
= 0;
3473 tree result
= boolean_true_node
;
3475 if (TREE_CODE (type
) != RECORD_TYPE
)
3478 exp0
= save_if_needed (exp0
);
3479 exp1
= save_if_needed (exp1
);
3481 for (field
= TYPE_FIELDS (type
); field
; field
= TREE_CHAIN (field
))
3483 if (DECL_NAME (field
) == NULL_TREE
)
3490 /* in case of -fpack we always do a memcmp */
3491 if (maximum_field_alignment
!= 0)
3493 tree memcmp_func
= lookup_name (get_identifier ("memcmp"));
3494 tree arg1
= force_addr_of (exp0
);
3495 tree arg2
= force_addr_of (exp1
);
3496 tree arg3
= size_in_bytes (type
);
3497 tree fcall
= build_chill_function_call (memcmp_func
,
3498 tree_cons (NULL_TREE
, arg1
,
3499 tree_cons (NULL_TREE
, arg2
,
3500 tree_cons (NULL_TREE
, arg3
, NULL_TREE
))));
3503 warning ("comparison of variant structures is unsafe");
3504 result
= build_chill_binary_op (EQ_EXPR
, fcall
, integer_zero_node
);
3510 sorry ("compare with variant records");
3511 return error_mark_node
;
3514 for (field
= TYPE_FIELDS (type
); field
; field
= TREE_CHAIN (field
))
3516 tree exp0fld
= build_component_ref (exp0
, DECL_NAME (field
));
3517 tree exp1fld
= build_component_ref (exp1
, DECL_NAME (field
));
3518 tree eq_flds
= build_chill_binary_op (EQ_EXPR
, exp0fld
, exp1fld
);
3519 result
= build_chill_binary_op (TRUTH_AND_EXPR
, result
, eq_flds
);
3525 compare_int_csts (op
, val1
, val2
)
3531 tree type1
= TREE_TYPE (val1
);
3532 tree type2
= TREE_TYPE (val2
);
3537 tmp
= val1
; val1
= val2
; val2
= tmp
;
3538 tmp
= type1
; type1
= type2
; type2
= tmp
;
3539 op
= (op
== GT_EXPR
) ? LT_EXPR
: LE_EXPR
;
3540 /* ... fall through ... */
3543 if (!TREE_UNSIGNED (type1
))
3545 if (!TREE_UNSIGNED (type2
))
3546 result
= INT_CST_LT (val1
, val2
);
3547 else if (TREE_INT_CST_HIGH (val1
) < 0)
3550 result
= INT_CST_LT_UNSIGNED (val1
, val2
);
3554 if (!TREE_UNSIGNED (type2
) && TREE_INT_CST_HIGH (val2
) < 0)
3557 result
= INT_CST_LT_UNSIGNED (val1
, val2
);
3559 if (op
== LT_EXPR
|| result
== 1)
3561 /* else fall through ... */
3564 if (TREE_INT_CST_LOW (val1
) == TREE_INT_CST_LOW (val2
)
3565 && TREE_INT_CST_HIGH (val1
) == TREE_INT_CST_HIGH (val2
)
3566 /* They're bitwise equal.
3567 Check for one being negative and the other unsigned. */
3568 && (TREE_INT_CST_HIGH (val2
) >= 0
3569 || TREE_UNSIGNED (TREE_TYPE (val1
))
3570 == TREE_UNSIGNED (TREE_TYPE (val2
))))
3583 /* Build an expression to compare discrete values VAL1 and VAL2.
3584 This does not check that they are discrete, nor that they are
3585 compatible; if you need such checks use build_compare_expr. */
3588 build_compare_discrete_expr (op
, val1
, val2
)
3592 tree type1
= TREE_TYPE (val1
);
3593 tree type2
= TREE_TYPE (val2
);
3596 if (TREE_CODE (val1
) == INTEGER_CST
&& TREE_CODE (val2
) == INTEGER_CST
)
3598 if (compare_int_csts (op
, val1
, val2
))
3599 return boolean_true_node
;
3601 return boolean_false_node
;
3604 if (TREE_UNSIGNED (type1
) != TREE_UNSIGNED (type2
))
3610 tmp
= val1
; val1
= val2
; val2
= tmp
;
3611 tmp
= type1
; type1
= type2
; type2
= tmp
;
3612 op
= (op
== GT_EXPR
) ? LT_EXPR
: LE_EXPR
;
3613 /* ... fall through ... */
3616 if (TREE_UNSIGNED (type2
))
3618 tmp
= build_int_2_wide (0, 0);
3619 TREE_TYPE (tmp
) = type1
;
3620 val1
= save_expr (val1
);
3621 tmp
= fold (build (LT_EXPR
, boolean_type_node
, val1
, tmp
));
3622 if (TYPE_PRECISION (type2
) < TYPE_PRECISION (type1
))
3624 type2
= unsigned_type (type1
);
3625 val2
= convert_to_integer (type2
, val2
);
3627 val1
= convert_to_integer (type2
, val1
);
3628 return fold (build (TRUTH_OR_EXPR
, boolean_type_node
,
3630 fold (build (op
, boolean_type_node
,
3633 unsigned_vs_signed
: /* val1 is unsigned, val2 is signed */
3634 tmp
= build_int_2_wide (0, 0);
3635 TREE_TYPE (tmp
) = type2
;
3636 val2
= save_expr (val2
);
3637 tmp
= fold (build (GE_EXPR
, boolean_type_node
, val2
, tmp
));
3638 if (TYPE_PRECISION (type1
) < TYPE_PRECISION (type2
))
3640 type1
= unsigned_type (type2
);
3641 val1
= convert_to_integer (type1
, val1
);
3643 val2
= convert_to_integer (type1
, val2
);
3644 return fold (build (TRUTH_AND_EXPR
, boolean_type_node
, tmp
,
3645 fold (build (op
, boolean_type_node
,
3648 if (TREE_UNSIGNED (val2
))
3650 tmp
= val1
; val1
= val2
; val2
= tmp
;
3651 tmp
= type1
; type1
= type2
; type2
= tmp
;
3653 goto unsigned_vs_signed
;
3655 tmp
= build_compare_expr (EQ_EXPR
, val1
, val2
);
3656 return build_chill_unary_op (TRUTH_NOT_EXPR
, tmp
);
3661 if (TYPE_PRECISION (type1
) > TYPE_PRECISION (type2
))
3662 val2
= convert (type1
, val2
);
3663 else if (TYPE_PRECISION (type1
) < TYPE_PRECISION (type2
))
3664 val1
= convert (type2
, val1
);
3665 return fold (build (op
, boolean_type_node
, val1
, val2
));
3669 build_compare_expr (op
, val1
, val2
)
3675 val1
= check_have_mode (val1
, "relational expression");
3676 val2
= check_have_mode (val2
, "relational expression");
3677 if (val1
== NULL_TREE
|| TREE_CODE (val1
) == ERROR_MARK
)
3678 return error_mark_node
;
3679 if (val2
== NULL_TREE
|| TREE_CODE (val2
) == ERROR_MARK
)
3680 return error_mark_node
;
3683 return build (op
, NULL_TREE
, val1
, val2
);
3685 if (!CH_COMPATIBLE_CLASSES (val1
, val2
))
3687 error ("incompatible operands to %s", boolean_code_name
[op
]);
3688 return error_mark_node
;
3691 tmp
= CH_ROOT_MODE (TREE_TYPE (val1
));
3692 if (tmp
!= TREE_TYPE (val1
))
3693 val1
= convert (tmp
, val1
);
3694 tmp
= CH_ROOT_MODE (TREE_TYPE (val2
));
3695 if (tmp
!= TREE_TYPE (val2
))
3696 val2
= convert (tmp
, val2
);
3698 type1
= TREE_TYPE (val1
);
3699 type2
= TREE_TYPE (val2
);
3701 if (TREE_CODE (type1
) == SET_TYPE
)
3702 tmp
= build_compare_set_expr (op
, val1
, val2
);
3704 else if (discrete_type_p (type1
))
3705 tmp
= build_compare_discrete_expr (op
, val1
, val2
);
3707 else if (chill_varying_type_p (type1
) || chill_varying_type_p (type2
)
3708 || (TREE_CODE (type1
) == ARRAY_TYPE
3709 && TREE_CODE (TREE_TYPE (type1
)) == CHAR_TYPE
)
3710 || (TREE_CODE (type2
) == ARRAY_TYPE
3711 && TREE_CODE (TREE_TYPE (type2
)) == CHAR_TYPE
) )
3712 tmp
= build_compare_string_expr (op
, val1
, val2
);
3714 else if ((TREE_CODE (type1
) == RECORD_TYPE
3715 || TREE_CODE (type2
) == RECORD_TYPE
)
3716 && (op
== EQ_EXPR
|| op
== NE_EXPR
))
3718 /* This is for handling INSTANCEs being compared against NULL. */
3719 if (val1
== null_pointer_node
)
3720 val1
= convert (type2
, val1
);
3721 if (val2
== null_pointer_node
)
3722 val2
= convert (type1
, val2
);
3724 tmp
= compare_records (val1
, val2
);
3726 tmp
= build_chill_unary_op (TRUTH_NOT_EXPR
, tmp
);
3729 else if (TREE_CODE (type1
) == REAL_TYPE
|| TREE_CODE (type2
) == REAL_TYPE
3730 || (op
== EQ_EXPR
|| op
== NE_EXPR
))
3732 tmp
= build (op
, boolean_type_node
, val1
, val2
);
3733 CH_DERIVED_FLAG (tmp
) = 1; /* Optimization to avoid copy_node. */
3739 error ("relational operator not allowed for this mode");
3740 return error_mark_node
;
3743 if (!CH_DERIVED_FLAG (tmp
))
3745 tmp
= copy_node (tmp
);
3746 CH_DERIVED_FLAG (tmp
) = 1;
3752 finish_chill_binary_op (node
)
3755 tree op0
= check_have_mode (TREE_OPERAND (node
, 0), "binary expression");
3756 tree op1
= check_have_mode (TREE_OPERAND (node
, 1), "binary expression");
3757 tree type0
= TREE_TYPE (op0
);
3758 tree type1
= TREE_TYPE (op1
);
3761 if (TREE_CODE (op0
) == ERROR_MARK
|| TREE_CODE (op1
) == ERROR_MARK
)
3762 return error_mark_node
;
3764 if (UNSATISFIED (op0
) || UNSATISFIED (op1
))
3766 UNSATISFIED_FLAG (node
) = 1;
3770 /* assure that both operands have a type */
3771 if (! type0
&& type1
)
3773 op0
= convert (type1
, op0
);
3774 type0
= TREE_TYPE (op0
);
3776 if (! type1
&& type0
)
3778 op1
= convert (type0
, op1
);
3779 type1
= TREE_TYPE (op1
);
3782 UNSATISFIED_FLAG (node
) = 0;
3785 { int op0f
= TREE_CODE (op0
) == FUNCTION_DECL
;
3786 int op1f
= TREE_CODE (op1
) == FUNCTION_DECL
;
3788 op0
= convert (build_pointer_type (TREE_TYPE (op0
)), op0
);
3790 op1
= convert (build_pointer_type (TREE_TYPE (op1
)), op1
);
3792 && code
!= EQ_EXPR
&& code
!= NE_EXPR
)
3793 error ("Cannot use %s operator on PROC mode variable",
3794 tree_code_name
[(int)code
]);
3797 if (invalid_left_operand (type0
, code
))
3799 error ("invalid left operand of %s", tree_code_name
[(int)code
]);
3800 return error_mark_node
;
3802 if (invalid_right_operand (code
, type1
))
3804 error ("invalid right operand of %s", tree_code_name
[(int)code
]);
3805 return error_mark_node
;
3809 switch (TREE_CODE (node
))
3812 return build_concat_expr (op0
, op1
);
3814 case REPLICATE_EXPR
:
3816 if (!TREE_CONSTANT (op0
) || !TREE_CONSTANT (op1
))
3818 error ("repetition expression must be constant");
3819 return error_mark_node
;
3822 return build_chill_repetition_op (op0
, op1
);
3824 case FLOOR_MOD_EXPR
:
3825 case TRUNC_MOD_EXPR
:
3826 if (TREE_CODE (type0
) != INTEGER_TYPE
)
3828 error ("left argument to MOD/REM operator must be integral");
3829 return error_mark_node
;
3831 if (TREE_CODE (type1
) != INTEGER_TYPE
)
3833 error ("right argument to MOD/REM operator must be integral");
3834 return error_mark_node
;
3839 if (TREE_CODE (type1
) == SET_TYPE
)
3841 tree temp
= fold_set_expr (MINUS_EXPR
, op0
, op1
);
3845 if (TYPE_MODE (type1
) == BLKmode
)
3846 TREE_SET_CODE (node
, SET_DIFF_EXPR
);
3849 op1
= build_chill_unary_op (BIT_NOT_EXPR
, op1
);
3850 TREE_OPERAND (node
, 1) = op1
;
3851 TREE_SET_CODE (node
, BIT_AND_EXPR
);
3856 case TRUNC_DIV_EXPR
:
3857 if (TREE_CODE (type0
) == REAL_TYPE
|| TREE_CODE (type1
) == REAL_TYPE
)
3858 TREE_SET_CODE (node
, RDIV_EXPR
);
3862 if (TYPE_MODE (type1
) == BLKmode
)
3863 TREE_SET_CODE (node
, SET_AND_EXPR
);
3864 goto fold_set_binop
;
3866 if (TYPE_MODE (type1
) == BLKmode
)
3867 TREE_SET_CODE (node
, SET_IOR_EXPR
);
3868 goto fold_set_binop
;
3870 if (TYPE_MODE (type1
) == BLKmode
)
3871 TREE_SET_CODE (node
, SET_XOR_EXPR
);
3872 goto fold_set_binop
;
3878 if (TREE_CODE (type0
) == SET_TYPE
)
3880 tree temp
= fold_set_expr (TREE_CODE (node
), op0
, op1
);
3888 if (TREE_CODE (type1
) != SET_TYPE
|| CH_BOOLS_TYPE_P (type1
))
3890 error ("right operand of IN is not a powerset");
3891 return error_mark_node
;
3893 if (!CH_COMPATIBLE (op0
, TYPE_DOMAIN (type1
)))
3895 error ("left operand of IN incompatible with right operand");
3896 return error_mark_node
;
3898 type0
= CH_ROOT_MODE (type0
);
3899 if (type0
!= TREE_TYPE (op0
))
3900 TREE_OPERAND (node
, 0) = op0
= convert (type0
, op0
);
3901 TREE_TYPE (node
) = boolean_type_node
;
3902 CH_DERIVED_FLAG (node
) = 1;
3904 if (!CH_DERIVED_FLAG (node
))
3906 node
= copy_node (node
);
3907 CH_DERIVED_FLAG (node
) = 1;
3916 return build_compare_expr (TREE_CODE (node
), op0
, op1
);
3921 if (!CH_COMPATIBLE_CLASSES (op0
, op1
))
3923 error ("incompatible operands to %s", tree_code_name
[(int) TREE_CODE (node
)]);
3924 return error_mark_node
;
3927 if (TREE_TYPE (node
) == NULL_TREE
)
3929 struct ch_class
class;
3930 class = CH_ROOT_RESULTING_CLASS (op0
, op1
);
3931 TREE_OPERAND (node
, 0) = op0
= convert_to_class (class, op0
);
3932 type0
= TREE_TYPE (op0
);
3933 TREE_OPERAND (node
, 1) = op1
= convert_to_class (class, op1
);
3934 type1
= TREE_TYPE (op1
);
3935 TREE_TYPE (node
) = class.mode
;
3936 folded
= convert_to_class (class, fold (node
));
3939 folded
= fold (node
);
3942 TREE_CONSTANT (folded
) = TREE_CONSTANT (op0
) & TREE_CONSTANT (op1
);
3944 if (TREE_CODE (node
) == TRUNC_DIV_EXPR
)
3946 if (TREE_CONSTANT (op1
))
3948 if (tree_int_cst_equal (op1
, integer_zero_node
))
3950 error ("division by zero");
3951 return integer_zero_node
;
3954 else if (range_checking
)
3958 build (EQ_EXPR
, boolean_type_node
, op1
, integer_zero_node
);
3959 /* Should this be overflow? */
3960 folded
= check_expression (folded
, test
,
3961 ridpointers
[(int) RID_RANGEFAIL
]);
3969 * This implements the '->' operator, which, like the '&' in C,
3970 * returns a pointer to an object, which has the type of
3971 * pointer-to-that-object.
3973 * FORCE is 0 when we're evaluating a user-level syntactic construct,
3974 * and 1 when we're calling from inside the compiler.
3977 build_chill_arrow_expr (ref
, force
)
3986 error ("-> operator not allow in constant expression");
3987 return error_mark_node
;
3990 if (ref
== NULL_TREE
|| TREE_CODE (ref
) == ERROR_MARK
)
3993 while (TREE_CODE (TREE_TYPE (ref
)) == REFERENCE_TYPE
)
3994 ref
= convert (TREE_TYPE (TREE_TYPE (ref
)), ref
);
3996 if (!force
&& ! CH_LOCATION_P (ref
))
3998 if (TREE_CODE (ref
) == STRING_CST
)
3999 pedwarn ("taking the address of a string literal is non-standard");
4000 else if (TREE_CODE (TREE_TYPE (ref
)) == FUNCTION_TYPE
)
4001 pedwarn ("taking the address of a function is non-standard");
4004 error ("ADDR requires a LOCATION argument");
4005 return error_mark_node
;
4007 /* FIXME: Should we be sure that ref isn't a
4008 function if we're being pedantic? */
4011 addr_type
= build_pointer_type (TREE_TYPE (ref
));
4014 /* This transformation makes chill_expr_class return CH_VALUE_CLASS
4015 when it should return CH_REFERENCE_CLASS. That could be fixed,
4016 but we probably don't want this transformation anyway. */
4017 if (TREE_CODE (ref
) == NOP_EXPR
) /* RETYPE_EXPR */
4020 while (TREE_CODE (ref
) == NOP_EXPR
) /* RETYPE_EXPR */
4021 ref
= TREE_OPERAND (ref
, 0);
4022 mark_addressable (ref
);
4023 addr
= build1 (ADDR_EXPR
,
4024 build_pointer_type (TREE_TYPE (ref
)), ref
);
4025 return build1 (NOP_EXPR
, /* RETYPE_EXPR */
4032 if (! mark_addressable (ref
))
4034 error ("-> expression is not addressable");
4035 return error_mark_node
;
4037 result
= build1 (ADDR_EXPR
, addr_type
, ref
);
4039 && ! (TREE_CODE (ref
) == FUNCTION_DECL
4040 && DECL_CONTEXT (ref
) != 0))
4041 TREE_CONSTANT (result
) = 1;
4047 * This implements the ADDR builtin function, which returns a
4048 * free reference, analogous to the C 'void *'.
4051 build_chill_addr_expr (ref
, errormsg
)
4053 const char *errormsg
;
4055 if (ref
== error_mark_node
)
4058 if (! CH_LOCATION_P (ref
)
4059 && TREE_CODE (TREE_TYPE (ref
)) != FUNCTION_TYPE
)
4061 error ("ADDR parameter must be a LOCATION");
4062 return error_mark_node
;
4064 ref
= build_chill_arrow_expr (ref
, 1);
4066 if (ref
!= NULL_TREE
&& TREE_CODE (ref
) != ERROR_MARK
)
4067 TREE_TYPE (ref
) = ptr_type_node
;
4068 else if (errormsg
== NULL
)
4070 error ("possible internal error in build_chill_arrow_expr");
4071 return error_mark_node
;
4075 error ("%s is not addressable", errormsg
);
4076 return error_mark_node
;
4082 build_chill_binary_op (code
, op0
, op1
)
4083 enum chill_tree_code code
;
4086 register tree result
;
4088 if (op0
== NULL_TREE
|| TREE_CODE (op0
) == ERROR_MARK
)
4089 return error_mark_node
;
4090 if (op1
== NULL_TREE
|| TREE_CODE (op1
) == ERROR_MARK
)
4091 return error_mark_node
;
4093 result
= build (code
, NULL_TREE
, op0
, op1
);
4096 result
= finish_chill_binary_op (result
);
4101 * process a string repetition phrase '(' COUNT ')' STRING
4104 string_char_rep (count
, string
)
4108 int slen
, charindx
, repcnt
;
4115 if (string
== NULL_TREE
|| TREE_CODE (string
) == ERROR_MARK
)
4116 return error_mark_node
;
4118 type
= TREE_TYPE (string
);
4119 slen
= int_size_in_bytes (type
);
4120 temp
= xmalloc (slen
* count
);
4123 if (TREE_CODE (string
) == STRING_CST
)
4124 inp
= TREE_STRING_POINTER (string
);
4125 else /* single character */
4126 ch
= (char)TREE_INT_CST_LOW (string
);
4128 /* copy the string/char COUNT times into the output buffer */
4129 for (outp
= temp
, repcnt
= 0; repcnt
< count
; repcnt
++)
4130 for (charindx
= 0; charindx
< slen
; charindx
++)
4131 *outp
++ = inp
[charindx
];
4132 return build_chill_string (slen
* count
, temp
);
4135 /* Build a bit-string constant containing with the given LENGTH
4136 containing all ones (if VALUE is true), or all zeros (if VALUE is false). */
4139 build_boring_bitstring (length
, value
)
4144 tree list
; /* Value of CONSTRUCTOR_ELTS in the result. */
4145 if (value
&& length
> 0)
4146 list
= tree_cons (integer_zero_node
, size_int (length
- 1), NULL_TREE
);
4150 result
= build (CONSTRUCTOR
,
4151 build_bitstring_type (size_int (length
)),
4154 TREE_CONSTANT (result
) = 1;
4155 CH_DERIVED_FLAG (result
) = 1;
4160 * handle a string repetition, with the syntax:
4161 * ( COUNT ) 'STRING'
4162 * COUNT is required to be constant, positive and folded.
4165 build_chill_repetition_op (count_op
, string
)
4170 tree type
= TREE_TYPE (string
);
4172 if (TREE_CODE (count_op
) != INTEGER_CST
)
4174 error ("repetition count is not an integer constant");
4175 return error_mark_node
;
4178 count
= TREE_INT_CST_LOW (count_op
);
4182 error ("repetition count < 0");
4183 return error_mark_node
;
4185 if (! TREE_CONSTANT (string
))
4187 error ("repetition value not constant");
4188 return error_mark_node
;
4191 if (TREE_CODE (string
) == STRING_CST
)
4192 return string_char_rep (count
, string
);
4194 switch ((int)TREE_CODE (type
))
4197 if (TREE_CODE (string
) == INTEGER_CST
)
4198 return build_boring_bitstring (count
, TREE_INT_CST_LOW (string
));
4199 error ("bitstring repetition of non-constant boolean");
4200 return error_mark_node
;
4203 return string_char_rep (count
, string
);
4206 { int i
, tree_const
= 1;
4207 tree new_list
= NULL_TREE
;
4210 tree domain
= TYPE_DOMAIN (type
);
4212 HOST_WIDE_INT orig_len
;
4214 if (!CH_BOOLS_TYPE_P (type
)) /* cannot replicate a powerset */
4217 orig_length
= discrete_count (domain
);
4219 if (TREE_CODE (string
) != CONSTRUCTOR
|| !TREE_CONSTANT (string
)
4220 || TREE_CODE (orig_length
) != INTEGER_CST
)
4222 error ("string repetition operand is non-constant bitstring");
4223 return error_mark_node
;
4227 orig_len
= TREE_INT_CST_LOW (orig_length
);
4229 /* if the set is empty, this is NULL */
4230 vallist
= TREE_OPERAND (string
, 1);
4232 if (vallist
== NULL_TREE
) /* No bits are set. */
4233 return build_boring_bitstring (count
* orig_len
, 0);
4234 else if (TREE_CHAIN (vallist
) == NULL_TREE
4235 && (TREE_PURPOSE (vallist
) == NULL_TREE
4237 && tree_int_cst_equal (TYPE_MIN_VALUE (domain
),
4238 TREE_VALUE (vallist
)))
4239 : (tree_int_cst_equal (TYPE_MIN_VALUE (domain
),
4240 TREE_PURPOSE (vallist
))
4241 && tree_int_cst_equal (TYPE_MAX_VALUE (domain
),
4242 TREE_VALUE (vallist
)))))
4243 return build_boring_bitstring (count
* orig_len
, 1);
4245 for (i
= 0; i
< count
; i
++)
4247 tree origin
= build_int_2 (i
* orig_len
, 0);
4250 /* scan down the given value list, building
4251 new bit-positions */
4252 for (temp
= vallist
; temp
; temp
= TREE_CHAIN (temp
))
4255 = fold (build (PLUS_EXPR
, TREE_TYPE (origin
),
4256 TREE_VALUE (temp
)));
4257 tree new_purpose
= NULL_TREE
;
4259 if (! TREE_CONSTANT (TREE_VALUE (temp
)))
4261 if (TREE_PURPOSE (temp
))
4263 new_purpose
= fold (build (PLUS_EXPR
, TREE_TYPE (origin
),
4264 origin
, TREE_PURPOSE (temp
)));
4265 if (! TREE_CONSTANT (TREE_PURPOSE (temp
)))
4269 new_list
= tree_cons (new_purpose
,
4270 new_value
, new_list
);
4273 result
= build (CONSTRUCTOR
,
4274 build_bitstring_type (size_int (count
* orig_len
)),
4275 NULL_TREE
, nreverse (new_list
));
4276 TREE_CONSTANT (result
) = tree_const
;
4277 CH_DERIVED_FLAG (result
) = CH_DERIVED_FLAG (string
);
4282 error ("non-char, non-bit string repetition");
4283 return error_mark_node
;
4285 return error_mark_node
;
4289 finish_chill_unary_op (node
)
4292 enum chill_tree_code code
= TREE_CODE (node
);
4293 tree op0
= check_have_mode (TREE_OPERAND (node
, 0), "unary expression");
4294 tree type0
= TREE_TYPE (op0
);
4295 struct ch_class
class;
4297 if (TREE_CODE (op0
) == ERROR_MARK
)
4298 return error_mark_node
;
4299 /* The expression codes of the data types of the arguments tell us
4300 whether the arguments are integers, floating, pointers, etc. */
4302 if (TREE_CODE (type0
) == REFERENCE_TYPE
)
4304 op0
= convert (TREE_TYPE (type0
), op0
);
4305 type0
= TREE_TYPE (op0
);
4308 if (invalid_right_operand (code
, type0
))
4310 error ("invalid operand of %s",
4311 tree_code_name
[(int)code
]);
4312 return error_mark_node
;
4314 switch ((int)TREE_CODE (type0
))
4317 if (TREE_CODE ( TREE_TYPE (type0
)) == BOOLEAN_TYPE
)
4318 code
= SET_NOT_EXPR
;
4321 error ("right operand of %s is not array of boolean",
4322 tree_code_name
[(int)code
]);
4323 return error_mark_node
;
4330 case TRUTH_NOT_EXPR
:
4331 return invert_truthvalue (truthvalue_conversion (op0
));
4334 error ("%s operator applied to boolean variable",
4335 tree_code_name
[(int)code
]);
4336 return error_mark_node
;
4346 tree temp
= fold_set_expr (BIT_NOT_EXPR
, op0
, NULL_TREE
);
4351 code
= SET_NOT_EXPR
;
4356 error ("invalid right operand of %s", tree_code_name
[(int)code
]);
4357 return error_mark_node
;
4362 class = chill_expr_class (op0
);
4364 class.mode
= CH_ROOT_MODE (class.mode
);
4365 TREE_SET_CODE (node
, code
);
4366 TREE_OPERAND (node
, 0) = op0
= convert_to_class (class, op0
);
4367 TREE_TYPE (node
) = TREE_TYPE (op0
);
4369 node
= convert_to_class (class, fold (node
));
4371 /* FIXME: should call
4372 * cond_type_range_exception (op0);
4377 /* op is TRUTH_NOT_EXPR, BIT_NOT_EXPR, or NEGATE_EXPR */
4380 build_chill_unary_op (code
, op0
)
4381 enum chill_tree_code code
;
4384 register tree result
= NULL_TREE
;
4386 if (op0
== NULL_TREE
|| TREE_CODE (op0
) == ERROR_MARK
)
4387 return error_mark_node
;
4389 result
= build1 (code
, NULL_TREE
, op0
);
4392 result
= finish_chill_unary_op (result
);
4397 truthvalue_conversion (expr
)
4400 if (expr
== NULL_TREE
|| TREE_CODE (expr
) == ERROR_MARK
)
4401 return error_mark_node
;
4403 #if 0 /* what about a LE_EXPR (integer_type, integer_type ) */
4404 if (TREE_CODE (TREE_TYPE (expr
)) != BOOLEAN_TYPE
)
4405 error ("non-boolean mode in conditional expression");
4408 switch ((int)TREE_CODE (expr
))
4410 /* It is simpler and generates better code to have only TRUTH_*_EXPR
4411 or comparison expressions as truth values at this level. */
4414 /* A one-bit unsigned bit-field is already acceptable. */
4415 if (1 == TREE_INT_CST_LOW (DECL_SIZE (TREE_OPERAND (expr
, 1)))
4416 && TREE_UNSIGNED (TREE_OPERAND (expr
, 1)))
4422 /* It is simpler and generates better code to have only TRUTH_*_EXPR
4423 or comparison expressions as truth values at this level. */
4424 case NE_EXPR
: case LE_EXPR
: case GE_EXPR
: case LT_EXPR
: case GT_EXPR
:
4425 case TRUTH_ANDIF_EXPR
:
4426 case TRUTH_ORIF_EXPR
:
4427 case TRUTH_AND_EXPR
:
4433 return integer_zerop (expr
) ? boolean_false_node
: boolean_true_node
;
4436 return real_zerop (expr
) ? boolean_false_node
: boolean_true_node
;
4439 if (TREE_SIDE_EFFECTS (TREE_OPERAND (expr
, 0)))
4440 return build (COMPOUND_EXPR
, boolean_type_node
,
4441 TREE_OPERAND (expr
, 0), boolean_true_node
);
4443 return boolean_true_node
;
4449 /* These don't change whether an object is non-zero or zero. */
4450 return truthvalue_conversion (TREE_OPERAND (expr
, 0));
4454 /* These don't change whether an object is zero or non-zero, but
4455 we can't ignore them if their second arg has side-effects. */
4456 if (TREE_SIDE_EFFECTS (TREE_OPERAND (expr
, 1)))
4457 return build (COMPOUND_EXPR
, boolean_type_node
, TREE_OPERAND (expr
, 1),
4458 truthvalue_conversion (TREE_OPERAND (expr
, 0)));
4460 return truthvalue_conversion (TREE_OPERAND (expr
, 0));
4463 /* Distribute the conversion into the arms of a COND_EXPR. */
4464 return fold (build (COND_EXPR
, boolean_type_node
, TREE_OPERAND (expr
, 0),
4465 truthvalue_conversion (TREE_OPERAND (expr
, 1)),
4466 truthvalue_conversion (TREE_OPERAND (expr
, 2))));
4469 /* Don't cancel the effect of a CONVERT_EXPR from a REFERENCE_TYPE,
4470 since that affects how `default_conversion' will behave. */
4471 if (TREE_CODE (TREE_TYPE (expr
)) == REFERENCE_TYPE
4472 || TREE_CODE (TREE_TYPE (TREE_OPERAND (expr
, 0))) == REFERENCE_TYPE
)
4474 /* fall through... */
4476 /* If this is widening the argument, we can ignore it. */
4477 if (TYPE_PRECISION (TREE_TYPE (expr
))
4478 >= TYPE_PRECISION (TREE_TYPE (TREE_OPERAND (expr
, 0))))
4479 return truthvalue_conversion (TREE_OPERAND (expr
, 0));
4484 /* These can be changed into a comparison of the two objects. */
4485 if (TREE_TYPE (TREE_OPERAND (expr
, 0))
4486 == TREE_TYPE (TREE_OPERAND (expr
, 1)))
4487 return build_chill_binary_op (NE_EXPR
, TREE_OPERAND (expr
, 0),
4488 TREE_OPERAND (expr
, 1));
4489 return build_chill_binary_op (NE_EXPR
, TREE_OPERAND (expr
, 0),
4490 fold (build1 (NOP_EXPR
,
4491 TREE_TYPE (TREE_OPERAND (expr
, 0)),
4492 TREE_OPERAND (expr
, 1))));
4495 return build_chill_binary_op (NE_EXPR
, expr
, boolean_false_node
);
4500 * return a folded tree for the powerset's length in bits. If a
4501 * non-set is passed, we assume it's an array or boolean bytes.
4504 powersetlen (powerset
)
4507 if (powerset
== NULL_TREE
|| TREE_CODE (powerset
) == ERROR_MARK
)
4508 return error_mark_node
;
4510 return discrete_count (TYPE_DOMAIN (TREE_TYPE (powerset
)));