1 /****************************************************************************
3 * GNAT COMPILER COMPONENTS *
7 * C Implementation File *
9 * Copyright (C) 1992-2006, Free Software Foundation, Inc. *
11 * GNAT is free software; you can redistribute it and/or modify it under *
12 * terms of the GNU General Public License as published by the Free Soft- *
13 * ware Foundation; either version 2, or (at your option) any later ver- *
14 * sion. GNAT is distributed in the hope that it will be useful, but WITH- *
15 * OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY *
16 * or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License *
17 * for more details. You should have received a copy of the GNU General *
18 * Public License distributed with GNAT; see file COPYING. If not, write *
19 * to the Free Software Foundation, 51 Franklin Street, Fifth Floor, *
20 * Boston, MA 02110-1301, USA. *
22 * GNAT was originally developed by the GNAT team at New York University. *
23 * Extensive contributions were provided by Ada Core Technologies Inc. *
25 ****************************************************************************/
29 #include "coretypes.h"
50 static tree
find_common_type (tree
, tree
);
51 static bool contains_save_expr_p (tree
);
52 static tree
contains_null_expr (tree
);
53 static tree
compare_arrays (tree
, tree
, tree
);
54 static tree
nonbinary_modular_operation (enum tree_code
, tree
, tree
, tree
);
55 static tree
build_simple_component_ref (tree
, tree
, tree
, bool);
57 /* Prepare expr to be an argument of a TRUTH_NOT_EXPR or other logical
60 This preparation consists of taking the ordinary representation of
61 an expression expr and producing a valid tree boolean expression
62 describing whether expr is nonzero. We could simply always do
64 build_binary_op (NE_EXPR, expr, integer_zero_node, 1),
66 but we optimize comparisons, &&, ||, and !.
68 The resulting type should always be the same as the input type.
69 This function is simpler than the corresponding C version since
70 the only possible operands will be things of Boolean type. */
73 gnat_truthvalue_conversion (tree expr
)
75 tree type
= TREE_TYPE (expr
);
77 switch (TREE_CODE (expr
))
79 case EQ_EXPR
: case NE_EXPR
: case LE_EXPR
: case GE_EXPR
:
80 case LT_EXPR
: case GT_EXPR
:
81 case TRUTH_ANDIF_EXPR
:
90 return (integer_zerop (expr
) ? convert (type
, integer_zero_node
)
91 : convert (type
, integer_one_node
));
94 return (real_zerop (expr
) ? convert (type
, integer_zero_node
)
95 : convert (type
, integer_one_node
));
98 /* Distribute the conversion into the arms of a COND_EXPR. */
100 (build3 (COND_EXPR
, type
, TREE_OPERAND (expr
, 0),
101 gnat_truthvalue_conversion (TREE_OPERAND (expr
, 1)),
102 gnat_truthvalue_conversion (TREE_OPERAND (expr
, 2))));
105 return build_binary_op (NE_EXPR
, type
, expr
,
106 convert (type
, integer_zero_node
));
110 /* Return the base type of TYPE. */
113 get_base_type (tree type
)
115 if (TREE_CODE (type
) == RECORD_TYPE
116 && TYPE_JUSTIFIED_MODULAR_P (type
))
117 type
= TREE_TYPE (TYPE_FIELDS (type
));
119 while (TREE_TYPE (type
)
120 && (TREE_CODE (type
) == INTEGER_TYPE
121 || TREE_CODE (type
) == REAL_TYPE
))
122 type
= TREE_TYPE (type
);
127 /* Likewise, but only return types known to the Ada source. */
129 get_ada_base_type (tree type
)
131 while (TREE_TYPE (type
)
132 && (TREE_CODE (type
) == INTEGER_TYPE
133 || TREE_CODE (type
) == REAL_TYPE
)
134 && !TYPE_EXTRA_SUBTYPE_P (type
))
135 type
= TREE_TYPE (type
);
140 /* EXP is a GCC tree representing an address. See if we can find how
141 strictly the object at that address is aligned. Return that alignment
142 in bits. If we don't know anything about the alignment, return 0. */
145 known_alignment (tree exp
)
147 unsigned int this_alignment
;
148 unsigned int lhs
, rhs
;
149 unsigned int type_alignment
;
151 /* For pointer expressions, we know that the designated object is always at
152 least as strictly aligned as the designated subtype, so we account for
153 both type and expression information in this case.
155 Beware that we can still get a dummy designated subtype here (e.g. Taft
156 Amendement types), in which the alignment information is meaningless and
159 We always compute a type_alignment value and return the MAX of it
160 compared with what we get from the expression tree. Just set the
161 type_alignment value to 0 when the type information is to be ignored. */
163 = ((POINTER_TYPE_P (TREE_TYPE (exp
))
164 && !TYPE_IS_DUMMY_P (TREE_TYPE (TREE_TYPE (exp
))))
165 ? TYPE_ALIGN (TREE_TYPE (TREE_TYPE (exp
))) : 0);
167 switch (TREE_CODE (exp
))
171 case NON_LVALUE_EXPR
:
172 /* Conversions between pointers and integers don't change the alignment
173 of the underlying object. */
174 this_alignment
= known_alignment (TREE_OPERAND (exp
, 0));
179 /* If two address are added, the alignment of the result is the
180 minimum of the two alignments. */
181 lhs
= known_alignment (TREE_OPERAND (exp
, 0));
182 rhs
= known_alignment (TREE_OPERAND (exp
, 1));
183 this_alignment
= MIN (lhs
, rhs
);
187 /* The first part of this represents the lowest bit in the constant,
188 but is it in bytes, not bits. */
191 * (TREE_INT_CST_LOW (exp
) & - TREE_INT_CST_LOW (exp
)),
196 /* If we know the alignment of just one side, use it. Otherwise,
197 use the product of the alignments. */
198 lhs
= known_alignment (TREE_OPERAND (exp
, 0));
199 rhs
= known_alignment (TREE_OPERAND (exp
, 1));
201 if (lhs
== 0 || rhs
== 0)
202 this_alignment
= MIN (BIGGEST_ALIGNMENT
, MAX (lhs
, rhs
));
204 this_alignment
= MIN (BIGGEST_ALIGNMENT
, lhs
* rhs
);
208 this_alignment
= expr_align (TREE_OPERAND (exp
, 0));
216 return MAX (type_alignment
, this_alignment
);
219 /* We have a comparison or assignment operation on two types, T1 and T2,
220 which are both either array types or both record types.
221 Return the type that both operands should be converted to, if any.
222 Otherwise return zero. */
225 find_common_type (tree t1
, tree t2
)
227 /* If either type is non-BLKmode, use it. Note that we know that we will
228 not have any alignment problems since if we did the non-BLKmode
229 type could not have been used. */
230 if (TYPE_MODE (t1
) != BLKmode
)
232 else if (TYPE_MODE (t2
) != BLKmode
)
235 /* If both types have constant size, use the smaller one. */
236 if (TREE_CONSTANT (TYPE_SIZE (t1
)) && TREE_CONSTANT (TYPE_SIZE (t2
)))
237 return tree_int_cst_lt (TYPE_SIZE (t1
), TYPE_SIZE (t2
)) ? t1
: t2
;
239 /* Otherwise, if either type has a constant size, use it. */
240 else if (TREE_CONSTANT (TYPE_SIZE (t1
)))
242 else if (TREE_CONSTANT (TYPE_SIZE (t2
)))
245 /* In this case, both types have variable size. It's probably
246 best to leave the "type mismatch" because changing it could
247 case a bad self-referential reference. */
251 /* See if EXP contains a SAVE_EXPR in a position where we would
254 ??? This is a real kludge, but is probably the best approach short
255 of some very general solution. */
258 contains_save_expr_p (tree exp
)
260 switch (TREE_CODE (exp
))
265 case ADDR_EXPR
: case INDIRECT_REF
:
267 case NOP_EXPR
: case CONVERT_EXPR
: case VIEW_CONVERT_EXPR
:
268 return contains_save_expr_p (TREE_OPERAND (exp
, 0));
273 unsigned HOST_WIDE_INT ix
;
275 FOR_EACH_CONSTRUCTOR_VALUE (CONSTRUCTOR_ELTS (exp
), ix
, value
)
276 if (contains_save_expr_p (value
))
286 /* See if EXP contains a NULL_EXPR in an expression we use for sizes. Return
287 it if so. This is used to detect types whose sizes involve computations
288 that are known to raise Constraint_Error. */
291 contains_null_expr (tree exp
)
295 if (TREE_CODE (exp
) == NULL_EXPR
)
298 switch (TREE_CODE_CLASS (TREE_CODE (exp
)))
301 return contains_null_expr (TREE_OPERAND (exp
, 0));
305 tem
= contains_null_expr (TREE_OPERAND (exp
, 0));
309 return contains_null_expr (TREE_OPERAND (exp
, 1));
312 switch (TREE_CODE (exp
))
315 return contains_null_expr (TREE_OPERAND (exp
, 0));
318 tem
= contains_null_expr (TREE_OPERAND (exp
, 0));
322 tem
= contains_null_expr (TREE_OPERAND (exp
, 1));
326 return contains_null_expr (TREE_OPERAND (exp
, 2));
337 /* Return an expression tree representing an equality comparison of
338 A1 and A2, two objects of ARRAY_TYPE. The returned expression should
339 be of type RESULT_TYPE
341 Two arrays are equal in one of two ways: (1) if both have zero length
342 in some dimension (not necessarily the same dimension) or (2) if the
343 lengths in each dimension are equal and the data is equal. We perform the
344 length tests in as efficient a manner as possible. */
347 compare_arrays (tree result_type
, tree a1
, tree a2
)
349 tree t1
= TREE_TYPE (a1
);
350 tree t2
= TREE_TYPE (a2
);
351 tree result
= convert (result_type
, integer_one_node
);
352 tree a1_is_null
= convert (result_type
, integer_zero_node
);
353 tree a2_is_null
= convert (result_type
, integer_zero_node
);
354 bool length_zero_p
= false;
356 /* Process each dimension separately and compare the lengths. If any
357 dimension has a size known to be zero, set SIZE_ZERO_P to 1 to
358 suppress the comparison of the data. */
359 while (TREE_CODE (t1
) == ARRAY_TYPE
&& TREE_CODE (t2
) == ARRAY_TYPE
)
361 tree lb1
= TYPE_MIN_VALUE (TYPE_DOMAIN (t1
));
362 tree ub1
= TYPE_MAX_VALUE (TYPE_DOMAIN (t1
));
363 tree lb2
= TYPE_MIN_VALUE (TYPE_DOMAIN (t2
));
364 tree ub2
= TYPE_MAX_VALUE (TYPE_DOMAIN (t2
));
365 tree bt
= get_base_type (TREE_TYPE (lb1
));
366 tree length1
= fold (build2 (MINUS_EXPR
, bt
, ub1
, lb1
));
367 tree length2
= fold (build2 (MINUS_EXPR
, bt
, ub2
, lb2
));
370 tree comparison
, this_a1_is_null
, this_a2_is_null
;
372 /* If the length of the first array is a constant, swap our operands
373 unless the length of the second array is the constant zero.
374 Note that we have set the `length' values to the length - 1. */
375 if (TREE_CODE (length1
) == INTEGER_CST
376 && !integer_zerop (fold (build2 (PLUS_EXPR
, bt
, length2
,
377 convert (bt
, integer_one_node
)))))
379 tem
= a1
, a1
= a2
, a2
= tem
;
380 tem
= t1
, t1
= t2
, t2
= tem
;
381 tem
= lb1
, lb1
= lb2
, lb2
= tem
;
382 tem
= ub1
, ub1
= ub2
, ub2
= tem
;
383 tem
= length1
, length1
= length2
, length2
= tem
;
384 tem
= a1_is_null
, a1_is_null
= a2_is_null
, a2_is_null
= tem
;
387 /* If the length of this dimension in the second array is the constant
388 zero, we can just go inside the original bounds for the first
389 array and see if last < first. */
390 if (integer_zerop (fold (build2 (PLUS_EXPR
, bt
, length2
,
391 convert (bt
, integer_one_node
)))))
393 tree ub
= TYPE_MAX_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (t1
)));
394 tree lb
= TYPE_MIN_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (t1
)));
396 comparison
= build_binary_op (LT_EXPR
, result_type
, ub
, lb
);
397 comparison
= SUBSTITUTE_PLACEHOLDER_IN_EXPR (comparison
, a1
);
398 length1
= SUBSTITUTE_PLACEHOLDER_IN_EXPR (length1
, a1
);
400 length_zero_p
= true;
401 this_a1_is_null
= comparison
;
402 this_a2_is_null
= convert (result_type
, integer_one_node
);
405 /* If the length is some other constant value, we know that the
406 this dimension in the first array cannot be superflat, so we
407 can just use its length from the actual stored bounds. */
408 else if (TREE_CODE (length2
) == INTEGER_CST
)
410 ub1
= TYPE_MAX_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (t1
)));
411 lb1
= TYPE_MIN_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (t1
)));
412 ub2
= TYPE_MAX_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (t2
)));
413 lb2
= TYPE_MIN_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (t2
)));
414 nbt
= get_base_type (TREE_TYPE (ub1
));
417 = build_binary_op (EQ_EXPR
, result_type
,
418 build_binary_op (MINUS_EXPR
, nbt
, ub1
, lb1
),
419 build_binary_op (MINUS_EXPR
, nbt
, ub2
, lb2
));
421 /* Note that we know that UB2 and LB2 are constant and hence
422 cannot contain a PLACEHOLDER_EXPR. */
424 comparison
= SUBSTITUTE_PLACEHOLDER_IN_EXPR (comparison
, a1
);
425 length1
= SUBSTITUTE_PLACEHOLDER_IN_EXPR (length1
, a1
);
427 this_a1_is_null
= build_binary_op (LT_EXPR
, result_type
, ub1
, lb1
);
428 this_a2_is_null
= convert (result_type
, integer_zero_node
);
431 /* Otherwise compare the computed lengths. */
434 length1
= SUBSTITUTE_PLACEHOLDER_IN_EXPR (length1
, a1
);
435 length2
= SUBSTITUTE_PLACEHOLDER_IN_EXPR (length2
, a2
);
438 = build_binary_op (EQ_EXPR
, result_type
, length1
, length2
);
441 = build_binary_op (LT_EXPR
, result_type
, length1
,
442 convert (bt
, integer_zero_node
));
444 = build_binary_op (LT_EXPR
, result_type
, length2
,
445 convert (bt
, integer_zero_node
));
448 result
= build_binary_op (TRUTH_ANDIF_EXPR
, result_type
,
451 a1_is_null
= build_binary_op (TRUTH_ORIF_EXPR
, result_type
,
452 this_a1_is_null
, a1_is_null
);
453 a2_is_null
= build_binary_op (TRUTH_ORIF_EXPR
, result_type
,
454 this_a2_is_null
, a2_is_null
);
460 /* Unless the size of some bound is known to be zero, compare the
461 data in the array. */
464 tree type
= find_common_type (TREE_TYPE (a1
), TREE_TYPE (a2
));
467 a1
= convert (type
, a1
), a2
= convert (type
, a2
);
469 result
= build_binary_op (TRUTH_ANDIF_EXPR
, result_type
, result
,
470 fold (build2 (EQ_EXPR
, result_type
, a1
, a2
)));
474 /* The result is also true if both sizes are zero. */
475 result
= build_binary_op (TRUTH_ORIF_EXPR
, result_type
,
476 build_binary_op (TRUTH_ANDIF_EXPR
, result_type
,
477 a1_is_null
, a2_is_null
),
480 /* If either operand contains SAVE_EXPRs, they have to be evaluated before
481 starting the comparison above since the place it would be otherwise
482 evaluated would be wrong. */
484 if (contains_save_expr_p (a1
))
485 result
= build2 (COMPOUND_EXPR
, result_type
, a1
, result
);
487 if (contains_save_expr_p (a2
))
488 result
= build2 (COMPOUND_EXPR
, result_type
, a2
, result
);
493 /* Compute the result of applying OP_CODE to LHS and RHS, where both are of
494 type TYPE. We know that TYPE is a modular type with a nonbinary
498 nonbinary_modular_operation (enum tree_code op_code
, tree type
, tree lhs
,
501 tree modulus
= TYPE_MODULUS (type
);
502 unsigned int needed_precision
= tree_floor_log2 (modulus
) + 1;
503 unsigned int precision
;
504 bool unsignedp
= true;
508 /* If this is an addition of a constant, convert it to a subtraction
509 of a constant since we can do that faster. */
510 if (op_code
== PLUS_EXPR
&& TREE_CODE (rhs
) == INTEGER_CST
)
511 rhs
= fold (build2 (MINUS_EXPR
, type
, modulus
, rhs
)), op_code
= MINUS_EXPR
;
513 /* For the logical operations, we only need PRECISION bits. For
514 addition and subtraction, we need one more and for multiplication we
515 need twice as many. But we never want to make a size smaller than
517 if (op_code
== PLUS_EXPR
|| op_code
== MINUS_EXPR
)
518 needed_precision
+= 1;
519 else if (op_code
== MULT_EXPR
)
520 needed_precision
*= 2;
522 precision
= MAX (needed_precision
, TYPE_PRECISION (op_type
));
524 /* Unsigned will do for everything but subtraction. */
525 if (op_code
== MINUS_EXPR
)
528 /* If our type is the wrong signedness or isn't wide enough, make a new
529 type and convert both our operands to it. */
530 if (TYPE_PRECISION (op_type
) < precision
531 || TYPE_UNSIGNED (op_type
) != unsignedp
)
533 /* Copy the node so we ensure it can be modified to make it modular. */
534 op_type
= copy_node (gnat_type_for_size (precision
, unsignedp
));
535 modulus
= convert (op_type
, modulus
);
536 SET_TYPE_MODULUS (op_type
, modulus
);
537 TYPE_MODULAR_P (op_type
) = 1;
538 lhs
= convert (op_type
, lhs
);
539 rhs
= convert (op_type
, rhs
);
542 /* Do the operation, then we'll fix it up. */
543 result
= fold (build2 (op_code
, op_type
, lhs
, rhs
));
545 /* For multiplication, we have no choice but to do a full modulus
546 operation. However, we want to do this in the narrowest
548 if (op_code
== MULT_EXPR
)
550 tree div_type
= copy_node (gnat_type_for_size (needed_precision
, 1));
551 modulus
= convert (div_type
, modulus
);
552 SET_TYPE_MODULUS (div_type
, modulus
);
553 TYPE_MODULAR_P (div_type
) = 1;
554 result
= convert (op_type
,
555 fold (build2 (TRUNC_MOD_EXPR
, div_type
,
556 convert (div_type
, result
), modulus
)));
559 /* For subtraction, add the modulus back if we are negative. */
560 else if (op_code
== MINUS_EXPR
)
562 result
= save_expr (result
);
563 result
= fold (build3 (COND_EXPR
, op_type
,
564 build2 (LT_EXPR
, integer_type_node
, result
,
565 convert (op_type
, integer_zero_node
)),
566 fold (build2 (PLUS_EXPR
, op_type
,
571 /* For the other operations, subtract the modulus if we are >= it. */
574 result
= save_expr (result
);
575 result
= fold (build3 (COND_EXPR
, op_type
,
576 build2 (GE_EXPR
, integer_type_node
,
578 fold (build2 (MINUS_EXPR
, op_type
,
583 return convert (type
, result
);
586 /* Make a binary operation of kind OP_CODE. RESULT_TYPE is the type
587 desired for the result. Usually the operation is to be performed
588 in that type. For MODIFY_EXPR and ARRAY_REF, RESULT_TYPE may be 0
589 in which case the type to be used will be derived from the operands.
591 This function is very much unlike the ones for C and C++ since we
592 have already done any type conversion and matching required. All we
593 have to do here is validate the work done by SEM and handle subtypes. */
596 build_binary_op (enum tree_code op_code
, tree result_type
,
597 tree left_operand
, tree right_operand
)
599 tree left_type
= TREE_TYPE (left_operand
);
600 tree right_type
= TREE_TYPE (right_operand
);
601 tree left_base_type
= get_base_type (left_type
);
602 tree right_base_type
= get_base_type (right_type
);
603 tree operation_type
= result_type
;
604 tree best_type
= NULL_TREE
;
607 bool has_side_effects
= false;
610 && TREE_CODE (operation_type
) == RECORD_TYPE
611 && TYPE_JUSTIFIED_MODULAR_P (operation_type
))
612 operation_type
= TREE_TYPE (TYPE_FIELDS (operation_type
));
615 && !AGGREGATE_TYPE_P (operation_type
)
616 && TYPE_EXTRA_SUBTYPE_P (operation_type
))
617 operation_type
= get_base_type (operation_type
);
619 modulus
= (operation_type
&& TREE_CODE (operation_type
) == INTEGER_TYPE
620 && TYPE_MODULAR_P (operation_type
)
621 ? TYPE_MODULUS (operation_type
) : 0);
626 /* If there were any integral or pointer conversions on LHS, remove
627 them; we'll be putting them back below if needed. Likewise for
628 conversions between array and record types. But don't do this if
629 the right operand is not BLKmode (for packed arrays)
630 unless we are not changing the mode. */
631 while ((TREE_CODE (left_operand
) == CONVERT_EXPR
632 || TREE_CODE (left_operand
) == NOP_EXPR
633 || TREE_CODE (left_operand
) == VIEW_CONVERT_EXPR
)
634 && (((INTEGRAL_TYPE_P (left_type
)
635 || POINTER_TYPE_P (left_type
))
636 && (INTEGRAL_TYPE_P (TREE_TYPE
637 (TREE_OPERAND (left_operand
, 0)))
638 || POINTER_TYPE_P (TREE_TYPE
639 (TREE_OPERAND (left_operand
, 0)))))
640 || (((TREE_CODE (left_type
) == RECORD_TYPE
641 /* Don't remove conversions to justified modular
643 && !TYPE_JUSTIFIED_MODULAR_P (left_type
))
644 || TREE_CODE (left_type
) == ARRAY_TYPE
)
645 && ((TREE_CODE (TREE_TYPE
646 (TREE_OPERAND (left_operand
, 0)))
648 || (TREE_CODE (TREE_TYPE
649 (TREE_OPERAND (left_operand
, 0)))
651 && (TYPE_MODE (right_type
) == BLKmode
652 || (TYPE_MODE (left_type
)
653 == TYPE_MODE (TREE_TYPE
655 (left_operand
, 0))))))))
657 left_operand
= TREE_OPERAND (left_operand
, 0);
658 left_type
= TREE_TYPE (left_operand
);
662 operation_type
= left_type
;
664 /* If we are copying one array or record to another, find the best type
666 if (((TREE_CODE (left_type
) == ARRAY_TYPE
667 && TREE_CODE (right_type
) == ARRAY_TYPE
)
668 || (TREE_CODE (left_type
) == RECORD_TYPE
669 && TREE_CODE (right_type
) == RECORD_TYPE
))
670 && (best_type
= find_common_type (left_type
, right_type
)))
671 operation_type
= best_type
;
673 /* If a class-wide type may be involved, force use of the RHS type. */
674 if ((TREE_CODE (right_type
) == RECORD_TYPE
675 || TREE_CODE (right_type
) == UNION_TYPE
)
676 && TYPE_ALIGN_OK (right_type
))
677 operation_type
= right_type
;
679 /* Ensure everything on the LHS is valid. If we have a field reference,
680 strip anything that get_inner_reference can handle. Then remove any
681 conversions with type types having the same code and mode. Mark
682 VIEW_CONVERT_EXPRs with TREE_ADDRESSABLE. When done, we must have
683 either an INDIRECT_REF or a decl. */
684 result
= left_operand
;
687 tree restype
= TREE_TYPE (result
);
689 if (TREE_CODE (result
) == COMPONENT_REF
690 || TREE_CODE (result
) == ARRAY_REF
691 || TREE_CODE (result
) == ARRAY_RANGE_REF
)
692 while (handled_component_p (result
))
693 result
= TREE_OPERAND (result
, 0);
694 else if (TREE_CODE (result
) == REALPART_EXPR
695 || TREE_CODE (result
) == IMAGPART_EXPR
696 || ((TREE_CODE (result
) == NOP_EXPR
697 || TREE_CODE (result
) == CONVERT_EXPR
)
698 && (((TREE_CODE (restype
)
699 == TREE_CODE (TREE_TYPE
700 (TREE_OPERAND (result
, 0))))
701 && (TYPE_MODE (TREE_TYPE
702 (TREE_OPERAND (result
, 0)))
703 == TYPE_MODE (restype
)))
704 || TYPE_ALIGN_OK (restype
))))
705 result
= TREE_OPERAND (result
, 0);
706 else if (TREE_CODE (result
) == VIEW_CONVERT_EXPR
)
708 TREE_ADDRESSABLE (result
) = 1;
709 result
= TREE_OPERAND (result
, 0);
715 gcc_assert (TREE_CODE (result
) == INDIRECT_REF
716 || TREE_CODE (result
) == NULL_EXPR
|| DECL_P (result
));
718 /* Convert the right operand to the operation type unless
719 it is either already of the correct type or if the type
720 involves a placeholder, since the RHS may not have the same
722 if (operation_type
!= right_type
723 && (!CONTAINS_PLACEHOLDER_P (TYPE_SIZE (operation_type
))))
725 right_operand
= convert (operation_type
, right_operand
);
726 right_type
= operation_type
;
729 /* If the left operand is not the same type as the operation type,
730 surround it in a VIEW_CONVERT_EXPR. */
731 if (left_type
!= operation_type
)
732 left_operand
= unchecked_convert (operation_type
, left_operand
, false);
734 has_side_effects
= true;
740 operation_type
= TREE_TYPE (left_type
);
742 /* ... fall through ... */
744 case ARRAY_RANGE_REF
:
746 /* First convert the right operand to its base type. This will
747 prevent unneeded signedness conversions when sizetype is wider than
749 right_operand
= convert (right_base_type
, right_operand
);
750 right_operand
= convert (TYPE_DOMAIN (left_type
), right_operand
);
752 if (!TREE_CONSTANT (right_operand
)
753 || !TREE_CONSTANT (TYPE_MIN_VALUE (right_type
)))
754 gnat_mark_addressable (left_operand
);
763 gcc_assert (!POINTER_TYPE_P (left_type
));
765 /* ... fall through ... */
769 /* If either operand is a NULL_EXPR, just return a new one. */
770 if (TREE_CODE (left_operand
) == NULL_EXPR
)
771 return build2 (op_code
, result_type
,
772 build1 (NULL_EXPR
, integer_type_node
,
773 TREE_OPERAND (left_operand
, 0)),
776 else if (TREE_CODE (right_operand
) == NULL_EXPR
)
777 return build2 (op_code
, result_type
,
778 build1 (NULL_EXPR
, integer_type_node
,
779 TREE_OPERAND (right_operand
, 0)),
782 /* If either object is a justified modular types, get the
783 fields from within. */
784 if (TREE_CODE (left_type
) == RECORD_TYPE
785 && TYPE_JUSTIFIED_MODULAR_P (left_type
))
787 left_operand
= convert (TREE_TYPE (TYPE_FIELDS (left_type
)),
789 left_type
= TREE_TYPE (left_operand
);
790 left_base_type
= get_base_type (left_type
);
793 if (TREE_CODE (right_type
) == RECORD_TYPE
794 && TYPE_JUSTIFIED_MODULAR_P (right_type
))
796 right_operand
= convert (TREE_TYPE (TYPE_FIELDS (right_type
)),
798 right_type
= TREE_TYPE (right_operand
);
799 right_base_type
= get_base_type (right_type
);
802 /* If both objects are arrays, compare them specially. */
803 if ((TREE_CODE (left_type
) == ARRAY_TYPE
804 || (TREE_CODE (left_type
) == INTEGER_TYPE
805 && TYPE_HAS_ACTUAL_BOUNDS_P (left_type
)))
806 && (TREE_CODE (right_type
) == ARRAY_TYPE
807 || (TREE_CODE (right_type
) == INTEGER_TYPE
808 && TYPE_HAS_ACTUAL_BOUNDS_P (right_type
))))
810 result
= compare_arrays (result_type
, left_operand
, right_operand
);
812 if (op_code
== NE_EXPR
)
813 result
= invert_truthvalue (result
);
815 gcc_assert (op_code
== EQ_EXPR
);
820 /* Otherwise, the base types must be the same unless the objects are
821 records. If we have records, use the best type and convert both
822 operands to that type. */
823 if (left_base_type
!= right_base_type
)
825 if (TREE_CODE (left_base_type
) == RECORD_TYPE
826 && TREE_CODE (right_base_type
) == RECORD_TYPE
)
828 /* The only way these are permitted to be the same is if both
829 types have the same name. In that case, one of them must
830 not be self-referential. Use that one as the best type.
831 Even better is if one is of fixed size. */
832 best_type
= NULL_TREE
;
834 gcc_assert (TYPE_NAME (left_base_type
)
835 && (TYPE_NAME (left_base_type
)
836 == TYPE_NAME (right_base_type
)));
838 if (TREE_CONSTANT (TYPE_SIZE (left_base_type
)))
839 best_type
= left_base_type
;
840 else if (TREE_CONSTANT (TYPE_SIZE (right_base_type
)))
841 best_type
= right_base_type
;
842 else if (!CONTAINS_PLACEHOLDER_P (TYPE_SIZE (left_base_type
)))
843 best_type
= left_base_type
;
844 else if (!CONTAINS_PLACEHOLDER_P (TYPE_SIZE (right_base_type
)))
845 best_type
= right_base_type
;
849 left_operand
= convert (best_type
, left_operand
);
850 right_operand
= convert (best_type
, right_operand
);
856 /* If we are comparing a fat pointer against zero, we need to
857 just compare the data pointer. */
858 else if (TYPE_FAT_POINTER_P (left_base_type
)
859 && TREE_CODE (right_operand
) == CONSTRUCTOR
860 && integer_zerop (VEC_index (constructor_elt
,
861 CONSTRUCTOR_ELTS (right_operand
),
865 right_operand
= build_component_ref (left_operand
, NULL_TREE
,
866 TYPE_FIELDS (left_base_type
),
868 left_operand
= convert (TREE_TYPE (right_operand
),
873 left_operand
= convert (left_base_type
, left_operand
);
874 right_operand
= convert (right_base_type
, right_operand
);
880 case PREINCREMENT_EXPR
:
881 case PREDECREMENT_EXPR
:
882 case POSTINCREMENT_EXPR
:
883 case POSTDECREMENT_EXPR
:
884 /* In these, the result type and the left operand type should be the
885 same. Do the operation in the base type of those and convert the
886 right operand (which is an integer) to that type.
888 Note that these operations are only used in loop control where
889 we guarantee that no overflow can occur. So nothing special need
890 be done for modular types. */
892 gcc_assert (left_type
== result_type
);
893 operation_type
= get_base_type (result_type
);
894 left_operand
= convert (operation_type
, left_operand
);
895 right_operand
= convert (operation_type
, right_operand
);
896 has_side_effects
= true;
904 /* The RHS of a shift can be any type. Also, ignore any modulus
905 (we used to abort, but this is needed for unchecked conversion
906 to modular types). Otherwise, processing is the same as normal. */
907 gcc_assert (operation_type
== left_base_type
);
909 left_operand
= convert (operation_type
, left_operand
);
912 case TRUTH_ANDIF_EXPR
:
913 case TRUTH_ORIF_EXPR
:
917 left_operand
= gnat_truthvalue_conversion (left_operand
);
918 right_operand
= gnat_truthvalue_conversion (right_operand
);
924 /* For binary modulus, if the inputs are in range, so are the
926 if (modulus
&& integer_pow2p (modulus
))
932 gcc_assert (TREE_TYPE (result_type
) == left_base_type
933 && TREE_TYPE (result_type
) == right_base_type
);
934 left_operand
= convert (left_base_type
, left_operand
);
935 right_operand
= convert (right_base_type
, right_operand
);
938 case TRUNC_DIV_EXPR
: case TRUNC_MOD_EXPR
:
939 case CEIL_DIV_EXPR
: case CEIL_MOD_EXPR
:
940 case FLOOR_DIV_EXPR
: case FLOOR_MOD_EXPR
:
941 case ROUND_DIV_EXPR
: case ROUND_MOD_EXPR
:
942 /* These always produce results lower than either operand. */
948 /* The result type should be the same as the base types of the
949 both operands (and they should be the same). Convert
950 everything to the result type. */
952 gcc_assert (operation_type
== left_base_type
953 && left_base_type
== right_base_type
);
954 left_operand
= convert (operation_type
, left_operand
);
955 right_operand
= convert (operation_type
, right_operand
);
958 if (modulus
&& !integer_pow2p (modulus
))
960 result
= nonbinary_modular_operation (op_code
, operation_type
,
961 left_operand
, right_operand
);
964 /* If either operand is a NULL_EXPR, just return a new one. */
965 else if (TREE_CODE (left_operand
) == NULL_EXPR
)
966 return build1 (NULL_EXPR
, operation_type
, TREE_OPERAND (left_operand
, 0));
967 else if (TREE_CODE (right_operand
) == NULL_EXPR
)
968 return build1 (NULL_EXPR
, operation_type
, TREE_OPERAND (right_operand
, 0));
969 else if (op_code
== ARRAY_REF
|| op_code
== ARRAY_RANGE_REF
)
970 result
= fold (build4 (op_code
, operation_type
, left_operand
,
971 right_operand
, NULL_TREE
, NULL_TREE
));
974 = fold (build2 (op_code
, operation_type
, left_operand
, right_operand
));
976 TREE_SIDE_EFFECTS (result
) |= has_side_effects
;
977 TREE_CONSTANT (result
)
978 |= (TREE_CONSTANT (left_operand
) & TREE_CONSTANT (right_operand
)
979 && op_code
!= ARRAY_REF
&& op_code
!= ARRAY_RANGE_REF
);
981 if ((op_code
== ARRAY_REF
|| op_code
== ARRAY_RANGE_REF
)
982 && TYPE_VOLATILE (operation_type
))
983 TREE_THIS_VOLATILE (result
) = 1;
985 /* If we are working with modular types, perform the MOD operation
986 if something above hasn't eliminated the need for it. */
988 result
= fold (build2 (FLOOR_MOD_EXPR
, operation_type
, result
,
989 convert (operation_type
, modulus
)));
991 if (result_type
&& result_type
!= operation_type
)
992 result
= convert (result_type
, result
);
997 /* Similar, but for unary operations. */
1000 build_unary_op (enum tree_code op_code
, tree result_type
, tree operand
)
1002 tree type
= TREE_TYPE (operand
);
1003 tree base_type
= get_base_type (type
);
1004 tree operation_type
= result_type
;
1006 bool side_effects
= false;
1009 && TREE_CODE (operation_type
) == RECORD_TYPE
1010 && TYPE_JUSTIFIED_MODULAR_P (operation_type
))
1011 operation_type
= TREE_TYPE (TYPE_FIELDS (operation_type
));
1014 && !AGGREGATE_TYPE_P (operation_type
)
1015 && TYPE_EXTRA_SUBTYPE_P (operation_type
))
1016 operation_type
= get_base_type (operation_type
);
1022 if (!operation_type
)
1023 result_type
= operation_type
= TREE_TYPE (type
);
1025 gcc_assert (result_type
== TREE_TYPE (type
));
1027 result
= fold (build1 (op_code
, operation_type
, operand
));
1030 case TRUTH_NOT_EXPR
:
1031 gcc_assert (result_type
== base_type
);
1032 result
= invert_truthvalue (gnat_truthvalue_conversion (operand
));
1035 case ATTR_ADDR_EXPR
:
1037 switch (TREE_CODE (operand
))
1040 case UNCONSTRAINED_ARRAY_REF
:
1041 result
= TREE_OPERAND (operand
, 0);
1043 /* Make sure the type here is a pointer, not a reference.
1044 GCC wants pointer types for function addresses. */
1046 result_type
= build_pointer_type (type
);
1051 TREE_TYPE (result
) = type
= build_pointer_type (type
);
1055 case ARRAY_RANGE_REF
:
1058 /* If this is for 'Address, find the address of the prefix and
1059 add the offset to the field. Otherwise, do this the normal
1061 if (op_code
== ATTR_ADDR_EXPR
)
1063 HOST_WIDE_INT bitsize
;
1064 HOST_WIDE_INT bitpos
;
1066 enum machine_mode mode
;
1067 int unsignedp
, volatilep
;
1069 inner
= get_inner_reference (operand
, &bitsize
, &bitpos
, &offset
,
1070 &mode
, &unsignedp
, &volatilep
,
1073 /* If INNER is a padding type whose field has a self-referential
1074 size, convert to that inner type. We know the offset is zero
1075 and we need to have that type visible. */
1076 if (TREE_CODE (TREE_TYPE (inner
)) == RECORD_TYPE
1077 && TYPE_IS_PADDING_P (TREE_TYPE (inner
))
1078 && (CONTAINS_PLACEHOLDER_P
1079 (TYPE_SIZE (TREE_TYPE (TYPE_FIELDS
1080 (TREE_TYPE (inner
)))))))
1081 inner
= convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (inner
))),
1084 /* Compute the offset as a byte offset from INNER. */
1086 offset
= size_zero_node
;
1088 if (bitpos
% BITS_PER_UNIT
!= 0)
1090 ("taking address of object not aligned on storage unit?",
1093 offset
= size_binop (PLUS_EXPR
, offset
,
1094 size_int (bitpos
/ BITS_PER_UNIT
));
1096 /* Take the address of INNER, convert the offset to void *, and
1097 add then. It will later be converted to the desired result
1099 inner
= build_unary_op (ADDR_EXPR
, NULL_TREE
, inner
);
1100 inner
= convert (ptr_void_type_node
, inner
);
1101 offset
= convert (ptr_void_type_node
, offset
);
1102 result
= build_binary_op (PLUS_EXPR
, ptr_void_type_node
,
1104 result
= convert (build_pointer_type (TREE_TYPE (operand
)),
1111 /* If this is just a constructor for a padded record, we can
1112 just take the address of the single field and convert it to
1113 a pointer to our type. */
1114 if (TREE_CODE (type
) == RECORD_TYPE
&& TYPE_IS_PADDING_P (type
))
1116 result
= (VEC_index (constructor_elt
,
1117 CONSTRUCTOR_ELTS (operand
),
1121 result
= convert (build_pointer_type (TREE_TYPE (operand
)),
1122 build_unary_op (ADDR_EXPR
, NULL_TREE
, result
));
1129 if (AGGREGATE_TYPE_P (type
)
1130 && AGGREGATE_TYPE_P (TREE_TYPE (TREE_OPERAND (operand
, 0))))
1131 return build_unary_op (ADDR_EXPR
, result_type
,
1132 TREE_OPERAND (operand
, 0));
1134 /* ... fallthru ... */
1136 case VIEW_CONVERT_EXPR
:
1137 /* If this just a variant conversion or if the conversion doesn't
1138 change the mode, get the result type from this type and go down.
1139 This is needed for conversions of CONST_DECLs, to eventually get
1140 to the address of their CORRESPONDING_VARs. */
1141 if ((TYPE_MAIN_VARIANT (type
)
1142 == TYPE_MAIN_VARIANT (TREE_TYPE (TREE_OPERAND (operand
, 0))))
1143 || (TYPE_MODE (type
) != BLKmode
1144 && (TYPE_MODE (type
)
1145 == TYPE_MODE (TREE_TYPE (TREE_OPERAND (operand
, 0))))))
1146 return build_unary_op (ADDR_EXPR
,
1147 (result_type
? result_type
1148 : build_pointer_type (type
)),
1149 TREE_OPERAND (operand
, 0));
1153 operand
= DECL_CONST_CORRESPONDING_VAR (operand
);
1155 /* ... fall through ... */
1160 /* If we are taking the address of a padded record whose field is
1161 contains a template, take the address of the template. */
1162 if (TREE_CODE (type
) == RECORD_TYPE
1163 && TYPE_IS_PADDING_P (type
)
1164 && TREE_CODE (TREE_TYPE (TYPE_FIELDS (type
))) == RECORD_TYPE
1165 && TYPE_CONTAINS_TEMPLATE_P (TREE_TYPE (TYPE_FIELDS (type
))))
1167 type
= TREE_TYPE (TYPE_FIELDS (type
));
1168 operand
= convert (type
, operand
);
1171 if (type
!= error_mark_node
)
1172 operation_type
= build_pointer_type (type
);
1174 gnat_mark_addressable (operand
);
1175 result
= fold (build1 (ADDR_EXPR
, operation_type
, operand
));
1178 TREE_CONSTANT (result
) = staticp (operand
) || TREE_CONSTANT (operand
);
1182 /* If we want to refer to an entire unconstrained array,
1183 make up an expression to do so. This will never survive to
1184 the backend. If TYPE is a thin pointer, first convert the
1185 operand to a fat pointer. */
1186 if (TYPE_THIN_POINTER_P (type
)
1187 && TYPE_UNCONSTRAINED_ARRAY (TREE_TYPE (type
)))
1190 = convert (TREE_TYPE (TYPE_UNCONSTRAINED_ARRAY (TREE_TYPE (type
))),
1192 type
= TREE_TYPE (operand
);
1195 if (TYPE_FAT_POINTER_P (type
))
1197 result
= build1 (UNCONSTRAINED_ARRAY_REF
,
1198 TYPE_UNCONSTRAINED_ARRAY (type
), operand
);
1199 TREE_READONLY (result
) = TREE_STATIC (result
)
1200 = TYPE_READONLY (TYPE_UNCONSTRAINED_ARRAY (type
));
1202 else if (TREE_CODE (operand
) == ADDR_EXPR
)
1203 result
= TREE_OPERAND (operand
, 0);
1207 result
= fold (build1 (op_code
, TREE_TYPE (type
), operand
));
1208 TREE_READONLY (result
) = TYPE_READONLY (TREE_TYPE (type
));
1212 = (!TYPE_FAT_POINTER_P (type
) && TYPE_VOLATILE (TREE_TYPE (type
)));
1218 tree modulus
= ((operation_type
1219 && TREE_CODE (operation_type
) == INTEGER_TYPE
1220 && TYPE_MODULAR_P (operation_type
))
1221 ? TYPE_MODULUS (operation_type
) : 0);
1222 int mod_pow2
= modulus
&& integer_pow2p (modulus
);
1224 /* If this is a modular type, there are various possibilities
1225 depending on the operation and whether the modulus is a
1226 power of two or not. */
1230 gcc_assert (operation_type
== base_type
);
1231 operand
= convert (operation_type
, operand
);
1233 /* The fastest in the negate case for binary modulus is
1234 the straightforward code; the TRUNC_MOD_EXPR below
1235 is an AND operation. */
1236 if (op_code
== NEGATE_EXPR
&& mod_pow2
)
1237 result
= fold (build2 (TRUNC_MOD_EXPR
, operation_type
,
1238 fold (build1 (NEGATE_EXPR
, operation_type
,
1242 /* For nonbinary negate case, return zero for zero operand,
1243 else return the modulus minus the operand. If the modulus
1244 is a power of two minus one, we can do the subtraction
1245 as an XOR since it is equivalent and faster on most machines. */
1246 else if (op_code
== NEGATE_EXPR
&& !mod_pow2
)
1248 if (integer_pow2p (fold (build2 (PLUS_EXPR
, operation_type
,
1250 convert (operation_type
,
1251 integer_one_node
)))))
1252 result
= fold (build2 (BIT_XOR_EXPR
, operation_type
,
1255 result
= fold (build2 (MINUS_EXPR
, operation_type
,
1258 result
= fold (build3 (COND_EXPR
, operation_type
,
1259 fold (build2 (NE_EXPR
,
1264 integer_zero_node
))),
1269 /* For the NOT cases, we need a constant equal to
1270 the modulus minus one. For a binary modulus, we
1271 XOR against the constant and subtract the operand from
1272 that constant for nonbinary modulus. */
1274 tree cnst
= fold (build2 (MINUS_EXPR
, operation_type
, modulus
,
1275 convert (operation_type
,
1276 integer_one_node
)));
1279 result
= fold (build2 (BIT_XOR_EXPR
, operation_type
,
1282 result
= fold (build2 (MINUS_EXPR
, operation_type
,
1290 /* ... fall through ... */
1293 gcc_assert (operation_type
== base_type
);
1294 result
= fold (build1 (op_code
, operation_type
, convert (operation_type
,
1300 TREE_SIDE_EFFECTS (result
) = 1;
1301 if (TREE_CODE (result
) == INDIRECT_REF
)
1302 TREE_THIS_VOLATILE (result
) = TYPE_VOLATILE (TREE_TYPE (result
));
1305 if (result_type
&& TREE_TYPE (result
) != result_type
)
1306 result
= convert (result_type
, result
);
1311 /* Similar, but for COND_EXPR. */
1314 build_cond_expr (tree result_type
, tree condition_operand
,
1315 tree true_operand
, tree false_operand
)
1318 bool addr_p
= false;
1320 /* The front-end verifies that result, true and false operands have same base
1321 type. Convert everything to the result type. */
1323 true_operand
= convert (result_type
, true_operand
);
1324 false_operand
= convert (result_type
, false_operand
);
1326 /* If the result type is unconstrained, take the address of
1327 the operands and then dereference our result. */
1328 if (TREE_CODE (result_type
) == UNCONSTRAINED_ARRAY_TYPE
1329 || CONTAINS_PLACEHOLDER_P (TYPE_SIZE (result_type
)))
1332 result_type
= build_pointer_type (result_type
);
1333 true_operand
= build_unary_op (ADDR_EXPR
, result_type
, true_operand
);
1334 false_operand
= build_unary_op (ADDR_EXPR
, result_type
, false_operand
);
1337 result
= fold (build3 (COND_EXPR
, result_type
, condition_operand
,
1338 true_operand
, false_operand
));
1340 /* If either operand is a SAVE_EXPR (possibly surrounded by
1341 arithmetic, make sure it gets done. */
1342 true_operand
= skip_simple_arithmetic (true_operand
);
1343 false_operand
= skip_simple_arithmetic (false_operand
);
1345 if (TREE_CODE (true_operand
) == SAVE_EXPR
)
1346 result
= build2 (COMPOUND_EXPR
, result_type
, true_operand
, result
);
1348 if (TREE_CODE (false_operand
) == SAVE_EXPR
)
1349 result
= build2 (COMPOUND_EXPR
, result_type
, false_operand
, result
);
1351 /* ??? Seems the code above is wrong, as it may move ahead of the COND
1352 SAVE_EXPRs with side effects and not shared by both arms. */
1355 result
= build_unary_op (INDIRECT_REF
, NULL_TREE
, result
);
1360 /* Similar, but for RETURN_EXPR. If RESULT_DECL is non-zero, build
1361 a RETURN_EXPR around the assignment of RET_VAL to RESULT_DECL.
1362 If RESULT_DECL is zero, build a bare RETURN_EXPR. */
1365 build_return_expr (tree result_decl
, tree ret_val
)
1371 /* The gimplifier explicitly enforces the following invariant:
1380 As a consequence, type-homogeneity dictates that we use the type
1381 of the RESULT_DECL as the operation type. */
1383 tree operation_type
= TREE_TYPE (result_decl
);
1385 /* Convert the right operand to the operation type. Note that
1386 it's the same transformation as in the MODIFY_EXPR case of
1387 build_binary_op with the additional guarantee that the type
1388 cannot involve a placeholder, since otherwise the function
1389 would use the "target pointer" return mechanism. */
1391 if (operation_type
!= TREE_TYPE (ret_val
))
1392 ret_val
= convert (operation_type
, ret_val
);
1395 = build2 (MODIFY_EXPR
, operation_type
, result_decl
, ret_val
);
1398 result_expr
= NULL_TREE
;
1400 return build1 (RETURN_EXPR
, void_type_node
, result_expr
);
1403 /* Build a CALL_EXPR to call FUNDECL with one argument, ARG. Return
1407 build_call_1_expr (tree fundecl
, tree arg
)
1409 tree call
= build3 (CALL_EXPR
, TREE_TYPE (TREE_TYPE (fundecl
)),
1410 build_unary_op (ADDR_EXPR
, NULL_TREE
, fundecl
),
1411 chainon (NULL_TREE
, build_tree_list (NULL_TREE
, arg
)),
1414 TREE_SIDE_EFFECTS (call
) = 1;
1419 /* Build a CALL_EXPR to call FUNDECL with two arguments, ARG1 & ARG2. Return
1423 build_call_2_expr (tree fundecl
, tree arg1
, tree arg2
)
1425 tree call
= build3 (CALL_EXPR
, TREE_TYPE (TREE_TYPE (fundecl
)),
1426 build_unary_op (ADDR_EXPR
, NULL_TREE
, fundecl
),
1427 chainon (chainon (NULL_TREE
,
1428 build_tree_list (NULL_TREE
, arg1
)),
1429 build_tree_list (NULL_TREE
, arg2
)),
1432 TREE_SIDE_EFFECTS (call
) = 1;
1437 /* Likewise to call FUNDECL with no arguments. */
1440 build_call_0_expr (tree fundecl
)
1442 tree call
= build3 (CALL_EXPR
, TREE_TYPE (TREE_TYPE (fundecl
)),
1443 build_unary_op (ADDR_EXPR
, NULL_TREE
, fundecl
),
1444 NULL_TREE
, NULL_TREE
);
1446 TREE_SIDE_EFFECTS (call
) = 1;
1451 /* Call a function that raises an exception and pass the line number and file
1452 name, if requested. MSG says which exception function to call.
1454 GNAT_NODE is the gnat node conveying the source location for which the
1455 error should be signaled, or Empty in which case the error is signaled on
1456 the current ref_file_name/input_line. */
1459 build_call_raise (int msg
, Node_Id gnat_node
)
1461 tree fndecl
= gnat_raise_decls
[msg
];
1464 = (Debug_Flag_NN
|| Exception_Locations_Suppressed
)
1466 : (gnat_node
!= Empty
)
1467 ? IDENTIFIER_POINTER
1468 (get_identifier (Get_Name_String
1470 (Get_Source_File_Index (Sloc (gnat_node
))))))
1473 int len
= strlen (str
) + 1;
1474 tree filename
= build_string (len
, str
);
1477 = (gnat_node
!= Empty
)
1478 ? Get_Logical_Line_Number (Sloc(gnat_node
)) : input_line
;
1480 TREE_TYPE (filename
)
1481 = build_array_type (char_type_node
,
1482 build_index_type (build_int_cst (NULL_TREE
, len
)));
1485 build_call_2_expr (fndecl
,
1486 build1 (ADDR_EXPR
, build_pointer_type (char_type_node
),
1488 build_int_cst (NULL_TREE
, line_number
));
1491 /* qsort comparer for the bit positions of two constructor elements
1492 for record components. */
1495 compare_elmt_bitpos (const PTR rt1
, const PTR rt2
)
1497 tree elmt1
= * (tree
*) rt1
;
1498 tree elmt2
= * (tree
*) rt2
;
1500 tree pos_field1
= bit_position (TREE_PURPOSE (elmt1
));
1501 tree pos_field2
= bit_position (TREE_PURPOSE (elmt2
));
1503 if (tree_int_cst_equal (pos_field1
, pos_field2
))
1505 else if (tree_int_cst_lt (pos_field1
, pos_field2
))
1511 /* Return a CONSTRUCTOR of TYPE whose list is LIST. */
1514 gnat_build_constructor (tree type
, tree list
)
1518 bool allconstant
= (TREE_CODE (TYPE_SIZE (type
)) == INTEGER_CST
);
1519 bool side_effects
= false;
1522 /* Scan the elements to see if they are all constant or if any has side
1523 effects, to let us set global flags on the resulting constructor. Count
1524 the elements along the way for possible sorting purposes below. */
1525 for (n_elmts
= 0, elmt
= list
; elmt
; elmt
= TREE_CHAIN (elmt
), n_elmts
++)
1527 if (!TREE_CONSTANT (TREE_VALUE (elmt
))
1528 || (TREE_CODE (type
) == RECORD_TYPE
1529 && DECL_BIT_FIELD (TREE_PURPOSE (elmt
))
1530 && TREE_CODE (TREE_VALUE (elmt
)) != INTEGER_CST
)
1531 || !initializer_constant_valid_p (TREE_VALUE (elmt
),
1532 TREE_TYPE (TREE_VALUE (elmt
))))
1533 allconstant
= false;
1535 if (TREE_SIDE_EFFECTS (TREE_VALUE (elmt
)))
1536 side_effects
= true;
1538 /* Propagate an NULL_EXPR from the size of the type. We won't ever
1539 be executing the code we generate here in that case, but handle it
1540 specially to avoid the cmpiler blowing up. */
1541 if (TREE_CODE (type
) == RECORD_TYPE
1543 = contains_null_expr (DECL_SIZE (TREE_PURPOSE (elmt
))))))
1544 return build1 (NULL_EXPR
, type
, TREE_OPERAND (result
, 0));
1547 /* For record types with constant components only, sort field list
1548 by increasing bit position. This is necessary to ensure the
1549 constructor can be output as static data, which the gimplifier
1550 might force in various circumstances. */
1551 if (allconstant
&& TREE_CODE (type
) == RECORD_TYPE
&& n_elmts
> 1)
1553 /* Fill an array with an element tree per index, and ask qsort to order
1554 them according to what a bitpos comparison function says. */
1556 tree
*gnu_arr
= (tree
*) alloca (sizeof (tree
) * n_elmts
);
1559 for (i
= 0, elmt
= list
; elmt
; elmt
= TREE_CHAIN (elmt
), i
++)
1562 qsort (gnu_arr
, n_elmts
, sizeof (tree
), compare_elmt_bitpos
);
1564 /* Then reconstruct the list from the sorted array contents. */
1567 for (i
= n_elmts
- 1; i
>= 0; i
--)
1569 TREE_CHAIN (gnu_arr
[i
]) = list
;
1574 result
= build_constructor_from_list (type
, list
);
1575 TREE_CONSTANT (result
) = TREE_INVARIANT (result
)
1576 = TREE_STATIC (result
) = allconstant
;
1577 TREE_SIDE_EFFECTS (result
) = side_effects
;
1578 TREE_READONLY (result
) = TYPE_READONLY (type
) || allconstant
;
1582 /* Return a COMPONENT_REF to access a field that is given by COMPONENT,
1583 an IDENTIFIER_NODE giving the name of the field, or FIELD, a FIELD_DECL,
1584 for the field. Don't fold the result if NO_FOLD_P is true.
1586 We also handle the fact that we might have been passed a pointer to the
1587 actual record and know how to look for fields in variant parts. */
1590 build_simple_component_ref (tree record_variable
, tree component
,
1591 tree field
, bool no_fold_p
)
1593 tree record_type
= TYPE_MAIN_VARIANT (TREE_TYPE (record_variable
));
1596 gcc_assert ((TREE_CODE (record_type
) == RECORD_TYPE
1597 || TREE_CODE (record_type
) == UNION_TYPE
1598 || TREE_CODE (record_type
) == QUAL_UNION_TYPE
)
1599 && TYPE_SIZE (record_type
)
1600 && (component
!= 0) != (field
!= 0));
1602 /* If no field was specified, look for a field with the specified name
1603 in the current record only. */
1605 for (field
= TYPE_FIELDS (record_type
); field
;
1606 field
= TREE_CHAIN (field
))
1607 if (DECL_NAME (field
) == component
)
1613 /* If this field is not in the specified record, see if we can find
1614 something in the record whose original field is the same as this one. */
1615 if (DECL_CONTEXT (field
) != record_type
)
1616 /* Check if there is a field with name COMPONENT in the record. */
1620 /* First loop thru normal components. */
1622 for (new_field
= TYPE_FIELDS (record_type
); new_field
;
1623 new_field
= TREE_CHAIN (new_field
))
1624 if (field
== new_field
1625 || DECL_ORIGINAL_FIELD (new_field
) == field
1626 || new_field
== DECL_ORIGINAL_FIELD (field
)
1627 || (DECL_ORIGINAL_FIELD (field
)
1628 && (DECL_ORIGINAL_FIELD (field
)
1629 == DECL_ORIGINAL_FIELD (new_field
))))
1632 /* Next, loop thru DECL_INTERNAL_P components if we haven't found
1633 the component in the first search. Doing this search in 2 steps
1634 is required to avoiding hidden homonymous fields in the
1638 for (new_field
= TYPE_FIELDS (record_type
); new_field
;
1639 new_field
= TREE_CHAIN (new_field
))
1640 if (DECL_INTERNAL_P (new_field
))
1643 = build_simple_component_ref (record_variable
,
1644 NULL_TREE
, new_field
, no_fold_p
);
1645 ref
= build_simple_component_ref (field_ref
, NULL_TREE
, field
,
1658 /* If the field's offset has overflowed, do not attempt to access it
1659 as doing so may trigger sanity checks deeper in the back-end.
1660 Note that we don't need to warn since this will be done on trying
1661 to declare the object. */
1662 if (TREE_CODE (DECL_FIELD_OFFSET (field
)) == INTEGER_CST
1663 && TREE_CONSTANT_OVERFLOW (DECL_FIELD_OFFSET (field
)))
1666 /* It would be nice to call "fold" here, but that can lose a type
1667 we need to tag a PLACEHOLDER_EXPR with, so we can't do it. */
1668 ref
= build3 (COMPONENT_REF
, TREE_TYPE (field
), record_variable
, field
,
1671 if (TREE_READONLY (record_variable
) || TREE_READONLY (field
))
1672 TREE_READONLY (ref
) = 1;
1673 if (TREE_THIS_VOLATILE (record_variable
) || TREE_THIS_VOLATILE (field
)
1674 || TYPE_VOLATILE (record_type
))
1675 TREE_THIS_VOLATILE (ref
) = 1;
1677 return no_fold_p
? ref
: fold (ref
);
1680 /* Like build_simple_component_ref, except that we give an error if the
1681 reference could not be found. */
1684 build_component_ref (tree record_variable
, tree component
,
1685 tree field
, bool no_fold_p
)
1687 tree ref
= build_simple_component_ref (record_variable
, component
, field
,
1693 /* If FIELD was specified, assume this is an invalid user field so
1694 raise constraint error. Otherwise, we can't find the type to return, so
1697 return build1 (NULL_EXPR
, TREE_TYPE (field
),
1698 build_call_raise (CE_Discriminant_Check_Failed
, Empty
));
1701 /* Build a GCC tree to call an allocation or deallocation function.
1702 If GNU_OBJ is nonzero, it is an object to deallocate. Otherwise,
1703 generate an allocator.
1705 GNU_SIZE is the size of the object in bytes and ALIGN is the alignment in
1706 bits. GNAT_PROC, if present, is a procedure to call and GNAT_POOL is the
1707 storage pool to use. If not preset, malloc and free will be used except
1708 if GNAT_PROC is the "fake" value of -1, in which case we allocate the
1709 object dynamically on the stack frame. */
1712 build_call_alloc_dealloc (tree gnu_obj
, tree gnu_size
, unsigned align
,
1713 Entity_Id gnat_proc
, Entity_Id gnat_pool
,
1716 tree gnu_align
= size_int (align
/ BITS_PER_UNIT
);
1718 gnu_size
= SUBSTITUTE_PLACEHOLDER_IN_EXPR (gnu_size
, gnu_obj
);
1720 if (Present (gnat_proc
))
1722 /* The storage pools are obviously always tagged types, but the
1723 secondary stack uses the same mechanism and is not tagged */
1724 if (Is_Tagged_Type (Etype (gnat_pool
)))
1726 /* The size is the third parameter; the alignment is the
1728 Entity_Id gnat_size_type
1729 = Etype (Next_Formal (Next_Formal (First_Formal (gnat_proc
))));
1730 tree gnu_size_type
= gnat_to_gnu_type (gnat_size_type
);
1731 tree gnu_proc
= gnat_to_gnu (gnat_proc
);
1732 tree gnu_proc_addr
= build_unary_op (ADDR_EXPR
, NULL_TREE
, gnu_proc
);
1733 tree gnu_pool
= gnat_to_gnu (gnat_pool
);
1734 tree gnu_pool_addr
= build_unary_op (ADDR_EXPR
, NULL_TREE
, gnu_pool
);
1735 tree gnu_args
= NULL_TREE
;
1738 /* The first arg is always the address of the storage pool; next
1739 comes the address of the object, for a deallocator, then the
1740 size and alignment. */
1742 = chainon (gnu_args
, build_tree_list (NULL_TREE
, gnu_pool_addr
));
1746 = chainon (gnu_args
, build_tree_list (NULL_TREE
, gnu_obj
));
1749 = chainon (gnu_args
,
1750 build_tree_list (NULL_TREE
,
1751 convert (gnu_size_type
, gnu_size
)));
1753 = chainon (gnu_args
,
1754 build_tree_list (NULL_TREE
,
1755 convert (gnu_size_type
, gnu_align
)));
1757 gnu_call
= build3 (CALL_EXPR
, TREE_TYPE (TREE_TYPE (gnu_proc
)),
1758 gnu_proc_addr
, gnu_args
, NULL_TREE
);
1759 TREE_SIDE_EFFECTS (gnu_call
) = 1;
1763 /* Secondary stack case. */
1766 /* The size is the second parameter */
1767 Entity_Id gnat_size_type
1768 = Etype (Next_Formal (First_Formal (gnat_proc
)));
1769 tree gnu_size_type
= gnat_to_gnu_type (gnat_size_type
);
1770 tree gnu_proc
= gnat_to_gnu (gnat_proc
);
1771 tree gnu_proc_addr
= build_unary_op (ADDR_EXPR
, NULL_TREE
, gnu_proc
);
1772 tree gnu_args
= NULL_TREE
;
1775 /* The first arg is the address of the object, for a
1776 deallocator, then the size */
1779 = chainon (gnu_args
, build_tree_list (NULL_TREE
, gnu_obj
));
1782 = chainon (gnu_args
,
1783 build_tree_list (NULL_TREE
,
1784 convert (gnu_size_type
, gnu_size
)));
1786 gnu_call
= build3 (CALL_EXPR
, TREE_TYPE (TREE_TYPE (gnu_proc
)),
1787 gnu_proc_addr
, gnu_args
, NULL_TREE
);
1788 TREE_SIDE_EFFECTS (gnu_call
) = 1;
1794 return build_call_1_expr (free_decl
, gnu_obj
);
1796 /* ??? For now, disable variable-sized allocators in the stack since
1797 we can't yet gimplify an ALLOCATE_EXPR. */
1798 else if (gnat_pool
== -1
1799 && TREE_CODE (gnu_size
) == INTEGER_CST
&& !flag_stack_check
)
1801 /* If the size is a constant, we can put it in the fixed portion of
1802 the stack frame to avoid the need to adjust the stack pointer. */
1803 if (TREE_CODE (gnu_size
) == INTEGER_CST
&& !flag_stack_check
)
1806 = build_range_type (NULL_TREE
, size_one_node
, gnu_size
);
1807 tree gnu_array_type
= build_array_type (char_type_node
, gnu_range
);
1809 = create_var_decl (get_identifier ("RETVAL"), NULL_TREE
,
1810 gnu_array_type
, NULL_TREE
, false, false, false,
1811 false, NULL
, gnat_node
);
1813 return convert (ptr_void_type_node
,
1814 build_unary_op (ADDR_EXPR
, NULL_TREE
, gnu_decl
));
1819 return build2 (ALLOCATE_EXPR
, ptr_void_type_node
, gnu_size
, gnu_align
);
1824 if (Nkind (gnat_node
) != N_Allocator
|| !Comes_From_Source (gnat_node
))
1825 Check_No_Implicit_Heap_Alloc (gnat_node
);
1826 return build_call_1_expr (malloc_decl
, gnu_size
);
1830 /* Build a GCC tree to correspond to allocating an object of TYPE whose
1831 initial value is INIT, if INIT is nonzero. Convert the expression to
1832 RESULT_TYPE, which must be some type of pointer. Return the tree.
1833 GNAT_PROC and GNAT_POOL optionally give the procedure to call and
1834 the storage pool to use. GNAT_NODE is used to provide an error
1835 location for restriction violations messages. If IGNORE_INIT_TYPE is
1836 true, ignore the type of INIT for the purpose of determining the size;
1837 this will cause the maximum size to be allocated if TYPE is of
1838 self-referential size. */
1841 build_allocator (tree type
, tree init
, tree result_type
, Entity_Id gnat_proc
,
1842 Entity_Id gnat_pool
, Node_Id gnat_node
, bool ignore_init_type
)
1844 tree size
= TYPE_SIZE_UNIT (type
);
1847 /* If the initializer, if present, is a NULL_EXPR, just return a new one. */
1848 if (init
&& TREE_CODE (init
) == NULL_EXPR
)
1849 return build1 (NULL_EXPR
, result_type
, TREE_OPERAND (init
, 0));
1851 /* If RESULT_TYPE is a fat or thin pointer, set SIZE to be the sum of the
1852 sizes of the object and its template. Allocate the whole thing and
1853 fill in the parts that are known. */
1854 else if (TYPE_FAT_OR_THIN_POINTER_P (result_type
))
1857 = build_unc_object_type_from_ptr (result_type
, type
,
1858 get_identifier ("ALLOC"));
1859 tree template_type
= TREE_TYPE (TYPE_FIELDS (storage_type
));
1860 tree storage_ptr_type
= build_pointer_type (storage_type
);
1862 tree template_cons
= NULL_TREE
;
1864 size
= SUBSTITUTE_PLACEHOLDER_IN_EXPR (TYPE_SIZE_UNIT (storage_type
),
1867 /* If the size overflows, pass -1 so the allocator will raise
1869 if (TREE_CODE (size
) == INTEGER_CST
&& TREE_OVERFLOW (size
))
1870 size
= ssize_int (-1);
1872 storage
= build_call_alloc_dealloc (NULL_TREE
, size
,
1873 TYPE_ALIGN (storage_type
),
1874 gnat_proc
, gnat_pool
, gnat_node
);
1875 storage
= convert (storage_ptr_type
, protect_multiple_eval (storage
));
1877 if (TREE_CODE (type
) == RECORD_TYPE
&& TYPE_IS_PADDING_P (type
))
1879 type
= TREE_TYPE (TYPE_FIELDS (type
));
1882 init
= convert (type
, init
);
1885 /* If there is an initializing expression, make a constructor for
1886 the entire object including the bounds and copy it into the
1887 object. If there is no initializing expression, just set the
1891 template_cons
= tree_cons (TREE_CHAIN (TYPE_FIELDS (storage_type
)),
1893 template_cons
= tree_cons (TYPE_FIELDS (storage_type
),
1894 build_template (template_type
, type
,
1900 build2 (COMPOUND_EXPR
, storage_ptr_type
,
1902 (MODIFY_EXPR
, storage_type
,
1903 build_unary_op (INDIRECT_REF
, NULL_TREE
,
1904 convert (storage_ptr_type
, storage
)),
1905 gnat_build_constructor (storage_type
, template_cons
)),
1906 convert (storage_ptr_type
, storage
)));
1910 (COMPOUND_EXPR
, result_type
,
1912 (MODIFY_EXPR
, template_type
,
1914 (build_unary_op (INDIRECT_REF
, NULL_TREE
,
1915 convert (storage_ptr_type
, storage
)),
1916 NULL_TREE
, TYPE_FIELDS (storage_type
), 0),
1917 build_template (template_type
, type
, NULL_TREE
)),
1918 convert (result_type
, convert (storage_ptr_type
, storage
)));
1921 /* If we have an initializing expression, see if its size is simpler
1922 than the size from the type. */
1923 if (!ignore_init_type
&& init
&& TYPE_SIZE_UNIT (TREE_TYPE (init
))
1924 && (TREE_CODE (TYPE_SIZE_UNIT (TREE_TYPE (init
))) == INTEGER_CST
1925 || CONTAINS_PLACEHOLDER_P (size
)))
1926 size
= TYPE_SIZE_UNIT (TREE_TYPE (init
));
1928 /* If the size is still self-referential, reference the initializing
1929 expression, if it is present. If not, this must have been a
1930 call to allocate a library-level object, in which case we use
1931 the maximum size. */
1932 if (CONTAINS_PLACEHOLDER_P (size
))
1934 if (!ignore_init_type
&& init
)
1935 size
= substitute_placeholder_in_expr (size
, init
);
1937 size
= max_size (size
, true);
1940 /* If the size overflows, pass -1 so the allocator will raise
1942 if (TREE_CODE (size
) == INTEGER_CST
&& TREE_OVERFLOW (size
))
1943 size
= ssize_int (-1);
1945 /* If this is a type whose alignment is larger than the
1946 biggest we support in normal alignment and this is in
1947 the default storage pool, make an "aligning type", allocate
1948 it, point to the field we need, and return that. */
1949 if (TYPE_ALIGN (type
) > BIGGEST_ALIGNMENT
1952 tree new_type
= make_aligning_type (type
, TYPE_ALIGN (type
), size
);
1954 result
= build_call_alloc_dealloc (NULL_TREE
, TYPE_SIZE_UNIT (new_type
),
1955 BIGGEST_ALIGNMENT
, Empty
,
1957 result
= save_expr (result
);
1958 result
= convert (build_pointer_type (new_type
), result
);
1959 result
= build_unary_op (INDIRECT_REF
, NULL_TREE
, result
);
1960 result
= build_component_ref (result
, NULL_TREE
,
1961 TYPE_FIELDS (new_type
), 0);
1962 result
= convert (result_type
,
1963 build_unary_op (ADDR_EXPR
, NULL_TREE
, result
));
1966 result
= convert (result_type
,
1967 build_call_alloc_dealloc (NULL_TREE
, size
,
1973 /* If we have an initial value, put the new address into a SAVE_EXPR, assign
1974 the value, and return the address. Do this with a COMPOUND_EXPR. */
1978 result
= save_expr (result
);
1980 = build2 (COMPOUND_EXPR
, TREE_TYPE (result
),
1982 (MODIFY_EXPR
, NULL_TREE
,
1983 build_unary_op (INDIRECT_REF
,
1984 TREE_TYPE (TREE_TYPE (result
)), result
),
1989 return convert (result_type
, result
);
1992 /* Fill in a VMS descriptor for EXPR and return a constructor for it.
1993 GNAT_FORMAL is how we find the descriptor record. */
1996 fill_vms_descriptor (tree expr
, Entity_Id gnat_formal
)
1998 tree record_type
= TREE_TYPE (TREE_TYPE (get_gnu_tree (gnat_formal
)));
2000 tree const_list
= NULL_TREE
;
2002 expr
= maybe_unconstrained_array (expr
);
2003 gnat_mark_addressable (expr
);
2005 for (field
= TYPE_FIELDS (record_type
); field
; field
= TREE_CHAIN (field
))
2008 convert (TREE_TYPE (field
),
2009 SUBSTITUTE_PLACEHOLDER_IN_EXPR
2010 (DECL_INITIAL (field
), expr
)),
2013 return gnat_build_constructor (record_type
, nreverse (const_list
));
2016 /* Indicate that we need to make the address of EXPR_NODE and it therefore
2017 should not be allocated in a register. Returns true if successful. */
2020 gnat_mark_addressable (tree expr_node
)
2023 switch (TREE_CODE (expr_node
))
2028 case ARRAY_RANGE_REF
:
2031 case VIEW_CONVERT_EXPR
:
2033 case NON_LVALUE_EXPR
:
2035 expr_node
= TREE_OPERAND (expr_node
, 0);
2039 TREE_ADDRESSABLE (expr_node
) = 1;
2045 TREE_ADDRESSABLE (expr_node
) = 1;
2049 TREE_ADDRESSABLE (expr_node
) = 1;
2053 return (DECL_CONST_CORRESPONDING_VAR (expr_node
)
2054 && (gnat_mark_addressable
2055 (DECL_CONST_CORRESPONDING_VAR (expr_node
))));