1 /****************************************************************************
3 * GNAT COMPILER COMPONENTS *
7 * C Implementation File *
9 * Copyright (C) 1992-2008, 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 3, 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 along with GCC; see the file COPYING3. If not see *
19 * <http://www.gnu.org/licenses/>. *
21 * GNAT was originally developed by the GNAT team at New York University. *
22 * Extensive contributions were provided by Ada Core Technologies Inc. *
24 ****************************************************************************/
28 #include "coretypes.h"
49 static tree
find_common_type (tree
, tree
);
50 static bool contains_save_expr_p (tree
);
51 static tree
contains_null_expr (tree
);
52 static tree
compare_arrays (tree
, tree
, tree
);
53 static tree
nonbinary_modular_operation (enum tree_code
, tree
, tree
, tree
);
54 static tree
build_simple_component_ref (tree
, tree
, tree
, bool);
56 /* Prepare expr to be an argument of a TRUTH_NOT_EXPR or other logical
59 This preparation consists of taking the ordinary representation of
60 an expression expr and producing a valid tree boolean expression
61 describing whether expr is nonzero. We could simply always do
63 build_binary_op (NE_EXPR, expr, integer_zero_node, 1),
65 but we optimize comparisons, &&, ||, and !.
67 The resulting type should always be the same as the input type.
68 This function is simpler than the corresponding C version since
69 the only possible operands will be things of Boolean type. */
72 gnat_truthvalue_conversion (tree expr
)
74 tree type
= TREE_TYPE (expr
);
76 switch (TREE_CODE (expr
))
78 case EQ_EXPR
: case NE_EXPR
: case LE_EXPR
: case GE_EXPR
:
79 case LT_EXPR
: case GT_EXPR
:
80 case TRUTH_ANDIF_EXPR
:
89 return (integer_zerop (expr
)
90 ? build_int_cst (type
, 0)
91 : build_int_cst (type
, 1));
94 return (real_zerop (expr
)
95 ? fold_convert (type
, integer_zero_node
)
96 : fold_convert (type
, integer_one_node
));
99 /* Distribute the conversion into the arms of a COND_EXPR. */
101 tree arg1
= gnat_truthvalue_conversion (TREE_OPERAND (expr
, 1));
102 tree arg2
= gnat_truthvalue_conversion (TREE_OPERAND (expr
, 2));
103 return fold_build3 (COND_EXPR
, type
, TREE_OPERAND (expr
, 0),
108 return build_binary_op (NE_EXPR
, type
, expr
,
109 fold_convert (type
, integer_zero_node
));
113 /* Return the base type of TYPE. */
116 get_base_type (tree type
)
118 if (TREE_CODE (type
) == RECORD_TYPE
119 && TYPE_JUSTIFIED_MODULAR_P (type
))
120 type
= TREE_TYPE (TYPE_FIELDS (type
));
122 while (TREE_TYPE (type
)
123 && (TREE_CODE (type
) == INTEGER_TYPE
124 || TREE_CODE (type
) == REAL_TYPE
))
125 type
= TREE_TYPE (type
);
130 /* EXP is a GCC tree representing an address. See if we can find how
131 strictly the object at that address is aligned. Return that alignment
132 in bits. If we don't know anything about the alignment, return 0. */
135 known_alignment (tree exp
)
137 unsigned int this_alignment
;
138 unsigned int lhs
, rhs
;
139 unsigned int type_alignment
;
141 /* For pointer expressions, we know that the designated object is always at
142 least as strictly aligned as the designated subtype, so we account for
143 both type and expression information in this case.
145 Beware that we can still get a dummy designated subtype here (e.g. Taft
146 Amendement types), in which the alignment information is meaningless and
149 We always compute a type_alignment value and return the MAX of it
150 compared with what we get from the expression tree. Just set the
151 type_alignment value to 0 when the type information is to be ignored. */
153 = ((POINTER_TYPE_P (TREE_TYPE (exp
))
154 && !TYPE_IS_DUMMY_P (TREE_TYPE (TREE_TYPE (exp
))))
155 ? TYPE_ALIGN (TREE_TYPE (TREE_TYPE (exp
))) : 0);
157 switch (TREE_CODE (exp
))
160 case VIEW_CONVERT_EXPR
:
162 case NON_LVALUE_EXPR
:
163 /* Conversions between pointers and integers don't change the alignment
164 of the underlying object. */
165 this_alignment
= known_alignment (TREE_OPERAND (exp
, 0));
169 /* The value of a COMPOUND_EXPR is that of it's second operand. */
170 this_alignment
= known_alignment (TREE_OPERAND (exp
, 1));
174 case POINTER_PLUS_EXPR
:
176 /* If two address are added, the alignment of the result is the
177 minimum of the two alignments. */
178 lhs
= known_alignment (TREE_OPERAND (exp
, 0));
179 rhs
= known_alignment (TREE_OPERAND (exp
, 1));
180 this_alignment
= MIN (lhs
, rhs
);
184 /* If there is a choice between two values, use the smallest one. */
185 lhs
= known_alignment (TREE_OPERAND (exp
, 1));
186 rhs
= known_alignment (TREE_OPERAND (exp
, 2));
187 this_alignment
= MIN (lhs
, rhs
);
191 /* The first part of this represents the lowest bit in the constant,
192 but is it in bytes, not bits. */
195 * (TREE_INT_CST_LOW (exp
) & - TREE_INT_CST_LOW (exp
)),
200 /* If we know the alignment of just one side, use it. Otherwise,
201 use the product of the alignments. */
202 lhs
= known_alignment (TREE_OPERAND (exp
, 0));
203 rhs
= known_alignment (TREE_OPERAND (exp
, 1));
205 if (lhs
== 0 || rhs
== 0)
206 this_alignment
= MIN (BIGGEST_ALIGNMENT
, MAX (lhs
, rhs
));
208 this_alignment
= MIN (BIGGEST_ALIGNMENT
, lhs
* rhs
);
212 /* A bit-and expression is as aligned as the maximum alignment of the
213 operands. We typically get here for a complex lhs and a constant
214 negative power of two on the rhs to force an explicit alignment, so
215 don't bother looking at the lhs. */
216 this_alignment
= known_alignment (TREE_OPERAND (exp
, 1));
220 this_alignment
= expr_align (TREE_OPERAND (exp
, 0));
228 return MAX (type_alignment
, this_alignment
);
231 /* We have a comparison or assignment operation on two types, T1 and T2,
232 which are both either array types or both record types.
233 Return the type that both operands should be converted to, if any.
234 Otherwise return zero. */
237 find_common_type (tree t1
, tree t2
)
239 /* If either type is non-BLKmode, use it. Note that we know that we will
240 not have any alignment problems since if we did the non-BLKmode
241 type could not have been used. */
242 if (TYPE_MODE (t1
) != BLKmode
)
244 else if (TYPE_MODE (t2
) != BLKmode
)
247 /* If both types have constant size, use the smaller one. Keep returning
248 T1 if we have a tie, to be consistent with the other cases. */
249 if (TREE_CONSTANT (TYPE_SIZE (t1
)) && TREE_CONSTANT (TYPE_SIZE (t2
)))
250 return tree_int_cst_lt (TYPE_SIZE (t2
), TYPE_SIZE (t1
)) ? t2
: t1
;
252 /* Otherwise, if either type has a constant size, use it. */
253 else if (TREE_CONSTANT (TYPE_SIZE (t1
)))
255 else if (TREE_CONSTANT (TYPE_SIZE (t2
)))
258 /* In this case, both types have variable size. It's probably
259 best to leave the "type mismatch" because changing it could
260 case a bad self-referential reference. */
264 /* See if EXP contains a SAVE_EXPR in a position where we would
267 ??? This is a real kludge, but is probably the best approach short
268 of some very general solution. */
271 contains_save_expr_p (tree exp
)
273 switch (TREE_CODE (exp
))
278 case ADDR_EXPR
: case INDIRECT_REF
:
280 case NOP_EXPR
: case CONVERT_EXPR
: case VIEW_CONVERT_EXPR
:
281 return contains_save_expr_p (TREE_OPERAND (exp
, 0));
286 unsigned HOST_WIDE_INT ix
;
288 FOR_EACH_CONSTRUCTOR_VALUE (CONSTRUCTOR_ELTS (exp
), ix
, value
)
289 if (contains_save_expr_p (value
))
299 /* See if EXP contains a NULL_EXPR in an expression we use for sizes. Return
300 it if so. This is used to detect types whose sizes involve computations
301 that are known to raise Constraint_Error. */
304 contains_null_expr (tree exp
)
308 if (TREE_CODE (exp
) == NULL_EXPR
)
311 switch (TREE_CODE_CLASS (TREE_CODE (exp
)))
314 return contains_null_expr (TREE_OPERAND (exp
, 0));
318 tem
= contains_null_expr (TREE_OPERAND (exp
, 0));
322 return contains_null_expr (TREE_OPERAND (exp
, 1));
325 switch (TREE_CODE (exp
))
328 return contains_null_expr (TREE_OPERAND (exp
, 0));
331 tem
= contains_null_expr (TREE_OPERAND (exp
, 0));
335 tem
= contains_null_expr (TREE_OPERAND (exp
, 1));
339 return contains_null_expr (TREE_OPERAND (exp
, 2));
350 /* Return an expression tree representing an equality comparison of
351 A1 and A2, two objects of ARRAY_TYPE. The returned expression should
352 be of type RESULT_TYPE
354 Two arrays are equal in one of two ways: (1) if both have zero length
355 in some dimension (not necessarily the same dimension) or (2) if the
356 lengths in each dimension are equal and the data is equal. We perform the
357 length tests in as efficient a manner as possible. */
360 compare_arrays (tree result_type
, tree a1
, tree a2
)
362 tree t1
= TREE_TYPE (a1
);
363 tree t2
= TREE_TYPE (a2
);
364 tree result
= convert (result_type
, integer_one_node
);
365 tree a1_is_null
= convert (result_type
, integer_zero_node
);
366 tree a2_is_null
= convert (result_type
, integer_zero_node
);
367 bool length_zero_p
= false;
369 /* Process each dimension separately and compare the lengths. If any
370 dimension has a size known to be zero, set SIZE_ZERO_P to 1 to
371 suppress the comparison of the data. */
372 while (TREE_CODE (t1
) == ARRAY_TYPE
&& TREE_CODE (t2
) == ARRAY_TYPE
)
374 tree lb1
= TYPE_MIN_VALUE (TYPE_DOMAIN (t1
));
375 tree ub1
= TYPE_MAX_VALUE (TYPE_DOMAIN (t1
));
376 tree lb2
= TYPE_MIN_VALUE (TYPE_DOMAIN (t2
));
377 tree ub2
= TYPE_MAX_VALUE (TYPE_DOMAIN (t2
));
378 tree bt
= get_base_type (TREE_TYPE (lb1
));
379 tree length1
= fold_build2 (MINUS_EXPR
, bt
, ub1
, lb1
);
380 tree length2
= fold_build2 (MINUS_EXPR
, bt
, ub2
, lb2
);
383 tree comparison
, this_a1_is_null
, this_a2_is_null
;
385 /* If the length of the first array is a constant, swap our operands
386 unless the length of the second array is the constant zero.
387 Note that we have set the `length' values to the length - 1. */
388 if (TREE_CODE (length1
) == INTEGER_CST
389 && !integer_zerop (fold_build2 (PLUS_EXPR
, bt
, length2
,
390 convert (bt
, integer_one_node
))))
392 tem
= a1
, a1
= a2
, a2
= tem
;
393 tem
= t1
, t1
= t2
, t2
= tem
;
394 tem
= lb1
, lb1
= lb2
, lb2
= tem
;
395 tem
= ub1
, ub1
= ub2
, ub2
= tem
;
396 tem
= length1
, length1
= length2
, length2
= tem
;
397 tem
= a1_is_null
, a1_is_null
= a2_is_null
, a2_is_null
= tem
;
400 /* If the length of this dimension in the second array is the constant
401 zero, we can just go inside the original bounds for the first
402 array and see if last < first. */
403 if (integer_zerop (fold_build2 (PLUS_EXPR
, bt
, length2
,
404 convert (bt
, integer_one_node
))))
406 tree ub
= TYPE_MAX_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (t1
)));
407 tree lb
= TYPE_MIN_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (t1
)));
409 comparison
= build_binary_op (LT_EXPR
, result_type
, ub
, lb
);
410 comparison
= SUBSTITUTE_PLACEHOLDER_IN_EXPR (comparison
, a1
);
411 length1
= SUBSTITUTE_PLACEHOLDER_IN_EXPR (length1
, a1
);
413 length_zero_p
= true;
414 this_a1_is_null
= comparison
;
415 this_a2_is_null
= convert (result_type
, integer_one_node
);
418 /* If the length is some other constant value, we know that the
419 this dimension in the first array cannot be superflat, so we
420 can just use its length from the actual stored bounds. */
421 else if (TREE_CODE (length2
) == INTEGER_CST
)
423 ub1
= TYPE_MAX_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (t1
)));
424 lb1
= TYPE_MIN_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (t1
)));
425 ub2
= TYPE_MAX_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (t2
)));
426 lb2
= TYPE_MIN_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (t2
)));
427 nbt
= get_base_type (TREE_TYPE (ub1
));
430 = build_binary_op (EQ_EXPR
, result_type
,
431 build_binary_op (MINUS_EXPR
, nbt
, ub1
, lb1
),
432 build_binary_op (MINUS_EXPR
, nbt
, ub2
, lb2
));
434 /* Note that we know that UB2 and LB2 are constant and hence
435 cannot contain a PLACEHOLDER_EXPR. */
437 comparison
= SUBSTITUTE_PLACEHOLDER_IN_EXPR (comparison
, a1
);
438 length1
= SUBSTITUTE_PLACEHOLDER_IN_EXPR (length1
, a1
);
440 this_a1_is_null
= build_binary_op (LT_EXPR
, result_type
, ub1
, lb1
);
441 this_a2_is_null
= convert (result_type
, integer_zero_node
);
444 /* Otherwise compare the computed lengths. */
447 length1
= SUBSTITUTE_PLACEHOLDER_IN_EXPR (length1
, a1
);
448 length2
= SUBSTITUTE_PLACEHOLDER_IN_EXPR (length2
, a2
);
451 = build_binary_op (EQ_EXPR
, result_type
, length1
, length2
);
454 = build_binary_op (LT_EXPR
, result_type
, length1
,
455 convert (bt
, integer_zero_node
));
457 = build_binary_op (LT_EXPR
, result_type
, length2
,
458 convert (bt
, integer_zero_node
));
461 result
= build_binary_op (TRUTH_ANDIF_EXPR
, result_type
,
464 a1_is_null
= build_binary_op (TRUTH_ORIF_EXPR
, result_type
,
465 this_a1_is_null
, a1_is_null
);
466 a2_is_null
= build_binary_op (TRUTH_ORIF_EXPR
, result_type
,
467 this_a2_is_null
, a2_is_null
);
473 /* Unless the size of some bound is known to be zero, compare the
474 data in the array. */
477 tree type
= find_common_type (TREE_TYPE (a1
), TREE_TYPE (a2
));
480 a1
= convert (type
, a1
), a2
= convert (type
, a2
);
482 result
= build_binary_op (TRUTH_ANDIF_EXPR
, result_type
, result
,
483 fold_build2 (EQ_EXPR
, result_type
, a1
, a2
));
487 /* The result is also true if both sizes are zero. */
488 result
= build_binary_op (TRUTH_ORIF_EXPR
, result_type
,
489 build_binary_op (TRUTH_ANDIF_EXPR
, result_type
,
490 a1_is_null
, a2_is_null
),
493 /* If either operand contains SAVE_EXPRs, they have to be evaluated before
494 starting the comparison above since the place it would be otherwise
495 evaluated would be wrong. */
497 if (contains_save_expr_p (a1
))
498 result
= build2 (COMPOUND_EXPR
, result_type
, a1
, result
);
500 if (contains_save_expr_p (a2
))
501 result
= build2 (COMPOUND_EXPR
, result_type
, a2
, result
);
506 /* Compute the result of applying OP_CODE to LHS and RHS, where both are of
507 type TYPE. We know that TYPE is a modular type with a nonbinary
511 nonbinary_modular_operation (enum tree_code op_code
, tree type
, tree lhs
,
514 tree modulus
= TYPE_MODULUS (type
);
515 unsigned int needed_precision
= tree_floor_log2 (modulus
) + 1;
516 unsigned int precision
;
517 bool unsignedp
= true;
521 /* If this is an addition of a constant, convert it to a subtraction
522 of a constant since we can do that faster. */
523 if (op_code
== PLUS_EXPR
&& TREE_CODE (rhs
) == INTEGER_CST
)
525 rhs
= fold_build2 (MINUS_EXPR
, type
, modulus
, rhs
);
526 op_code
= MINUS_EXPR
;
529 /* For the logical operations, we only need PRECISION bits. For
530 addition and subtraction, we need one more and for multiplication we
531 need twice as many. But we never want to make a size smaller than
533 if (op_code
== PLUS_EXPR
|| op_code
== MINUS_EXPR
)
534 needed_precision
+= 1;
535 else if (op_code
== MULT_EXPR
)
536 needed_precision
*= 2;
538 precision
= MAX (needed_precision
, TYPE_PRECISION (op_type
));
540 /* Unsigned will do for everything but subtraction. */
541 if (op_code
== MINUS_EXPR
)
544 /* If our type is the wrong signedness or isn't wide enough, make a new
545 type and convert both our operands to it. */
546 if (TYPE_PRECISION (op_type
) < precision
547 || TYPE_UNSIGNED (op_type
) != unsignedp
)
549 /* Copy the node so we ensure it can be modified to make it modular. */
550 op_type
= copy_node (gnat_type_for_size (precision
, unsignedp
));
551 modulus
= convert (op_type
, modulus
);
552 SET_TYPE_MODULUS (op_type
, modulus
);
553 TYPE_MODULAR_P (op_type
) = 1;
554 lhs
= convert (op_type
, lhs
);
555 rhs
= convert (op_type
, rhs
);
558 /* Do the operation, then we'll fix it up. */
559 result
= fold_build2 (op_code
, op_type
, lhs
, rhs
);
561 /* For multiplication, we have no choice but to do a full modulus
562 operation. However, we want to do this in the narrowest
564 if (op_code
== MULT_EXPR
)
566 tree div_type
= copy_node (gnat_type_for_size (needed_precision
, 1));
567 modulus
= convert (div_type
, modulus
);
568 SET_TYPE_MODULUS (div_type
, modulus
);
569 TYPE_MODULAR_P (div_type
) = 1;
570 result
= convert (op_type
,
571 fold_build2 (TRUNC_MOD_EXPR
, div_type
,
572 convert (div_type
, result
), modulus
));
575 /* For subtraction, add the modulus back if we are negative. */
576 else if (op_code
== MINUS_EXPR
)
578 result
= save_expr (result
);
579 result
= fold_build3 (COND_EXPR
, op_type
,
580 fold_build2 (LT_EXPR
, integer_type_node
, result
,
581 convert (op_type
, integer_zero_node
)),
582 fold_build2 (PLUS_EXPR
, op_type
, result
, modulus
),
586 /* For the other operations, subtract the modulus if we are >= it. */
589 result
= save_expr (result
);
590 result
= fold_build3 (COND_EXPR
, op_type
,
591 fold_build2 (GE_EXPR
, integer_type_node
,
593 fold_build2 (MINUS_EXPR
, op_type
,
598 return convert (type
, result
);
601 /* Make a binary operation of kind OP_CODE. RESULT_TYPE is the type
602 desired for the result. Usually the operation is to be performed
603 in that type. For MODIFY_EXPR and ARRAY_REF, RESULT_TYPE may be 0
604 in which case the type to be used will be derived from the operands.
606 This function is very much unlike the ones for C and C++ since we
607 have already done any type conversion and matching required. All we
608 have to do here is validate the work done by SEM and handle subtypes. */
611 build_binary_op (enum tree_code op_code
, tree result_type
,
612 tree left_operand
, tree right_operand
)
614 tree left_type
= TREE_TYPE (left_operand
);
615 tree right_type
= TREE_TYPE (right_operand
);
616 tree left_base_type
= get_base_type (left_type
);
617 tree right_base_type
= get_base_type (right_type
);
618 tree operation_type
= result_type
;
619 tree best_type
= NULL_TREE
;
622 bool has_side_effects
= false;
625 && TREE_CODE (operation_type
) == RECORD_TYPE
626 && TYPE_JUSTIFIED_MODULAR_P (operation_type
))
627 operation_type
= TREE_TYPE (TYPE_FIELDS (operation_type
));
630 && !AGGREGATE_TYPE_P (operation_type
)
631 && TYPE_EXTRA_SUBTYPE_P (operation_type
))
632 operation_type
= get_base_type (operation_type
);
634 modulus
= (operation_type
&& TREE_CODE (operation_type
) == INTEGER_TYPE
635 && TYPE_MODULAR_P (operation_type
)
636 ? TYPE_MODULUS (operation_type
) : 0);
641 /* If there were any integral or pointer conversions on LHS, remove
642 them; we'll be putting them back below if needed. Likewise for
643 conversions between array and record types. But don't do this if
644 the right operand is not BLKmode (for packed arrays)
645 unless we are not changing the mode. */
646 while ((TREE_CODE (left_operand
) == CONVERT_EXPR
647 || TREE_CODE (left_operand
) == NOP_EXPR
648 || TREE_CODE (left_operand
) == VIEW_CONVERT_EXPR
)
649 && (((INTEGRAL_TYPE_P (left_type
)
650 || POINTER_TYPE_P (left_type
))
651 && (INTEGRAL_TYPE_P (TREE_TYPE
652 (TREE_OPERAND (left_operand
, 0)))
653 || POINTER_TYPE_P (TREE_TYPE
654 (TREE_OPERAND (left_operand
, 0)))))
655 || (((TREE_CODE (left_type
) == RECORD_TYPE
656 /* Don't remove conversions to justified modular
658 && !TYPE_JUSTIFIED_MODULAR_P (left_type
))
659 || TREE_CODE (left_type
) == ARRAY_TYPE
)
660 && ((TREE_CODE (TREE_TYPE
661 (TREE_OPERAND (left_operand
, 0)))
663 || (TREE_CODE (TREE_TYPE
664 (TREE_OPERAND (left_operand
, 0)))
666 && (TYPE_MODE (right_type
) == BLKmode
667 || (TYPE_MODE (left_type
)
668 == TYPE_MODE (TREE_TYPE
670 (left_operand
, 0))))))))
672 left_operand
= TREE_OPERAND (left_operand
, 0);
673 left_type
= TREE_TYPE (left_operand
);
677 operation_type
= left_type
;
679 /* If we are copying one array or record to another, find the best type
681 if (((TREE_CODE (left_type
) == ARRAY_TYPE
682 && TREE_CODE (right_type
) == ARRAY_TYPE
)
683 || (TREE_CODE (left_type
) == RECORD_TYPE
684 && TREE_CODE (right_type
) == RECORD_TYPE
))
685 && (best_type
= find_common_type (left_type
, right_type
)))
686 operation_type
= best_type
;
688 /* If a class-wide type may be involved, force use of the RHS type. */
689 if ((TREE_CODE (right_type
) == RECORD_TYPE
690 || TREE_CODE (right_type
) == UNION_TYPE
)
691 && TYPE_ALIGN_OK (right_type
))
692 operation_type
= right_type
;
694 /* Ensure everything on the LHS is valid. If we have a field reference,
695 strip anything that get_inner_reference can handle. Then remove any
696 conversions with type types having the same code and mode. Mark
697 VIEW_CONVERT_EXPRs with TREE_ADDRESSABLE. When done, we must have
698 either an INDIRECT_REF or a decl. */
699 result
= left_operand
;
702 tree restype
= TREE_TYPE (result
);
704 if (TREE_CODE (result
) == COMPONENT_REF
705 || TREE_CODE (result
) == ARRAY_REF
706 || TREE_CODE (result
) == ARRAY_RANGE_REF
)
707 while (handled_component_p (result
))
708 result
= TREE_OPERAND (result
, 0);
709 else if (TREE_CODE (result
) == REALPART_EXPR
710 || TREE_CODE (result
) == IMAGPART_EXPR
711 || ((TREE_CODE (result
) == NOP_EXPR
712 || TREE_CODE (result
) == CONVERT_EXPR
)
713 && (((TREE_CODE (restype
)
714 == TREE_CODE (TREE_TYPE
715 (TREE_OPERAND (result
, 0))))
716 && (TYPE_MODE (TREE_TYPE
717 (TREE_OPERAND (result
, 0)))
718 == TYPE_MODE (restype
)))
719 || TYPE_ALIGN_OK (restype
))))
720 result
= TREE_OPERAND (result
, 0);
721 else if (TREE_CODE (result
) == VIEW_CONVERT_EXPR
)
723 TREE_ADDRESSABLE (result
) = 1;
724 result
= TREE_OPERAND (result
, 0);
730 gcc_assert (TREE_CODE (result
) == INDIRECT_REF
731 || TREE_CODE (result
) == NULL_EXPR
|| DECL_P (result
));
733 /* Convert the right operand to the operation type unless
734 it is either already of the correct type or if the type
735 involves a placeholder, since the RHS may not have the same
737 if (operation_type
!= right_type
738 && (!CONTAINS_PLACEHOLDER_P (TYPE_SIZE (operation_type
))))
740 right_operand
= convert (operation_type
, right_operand
);
741 right_type
= operation_type
;
744 /* If the left operand is not the same type as the operation type,
745 surround it in a VIEW_CONVERT_EXPR. */
746 if (left_type
!= operation_type
)
747 left_operand
= unchecked_convert (operation_type
, left_operand
, false);
749 has_side_effects
= true;
755 operation_type
= TREE_TYPE (left_type
);
757 /* ... fall through ... */
759 case ARRAY_RANGE_REF
:
760 /* First look through conversion between type variants. Note that
761 this changes neither the operation type nor the type domain. */
762 if (TREE_CODE (left_operand
) == VIEW_CONVERT_EXPR
763 && TYPE_MAIN_VARIANT (TREE_TYPE (TREE_OPERAND (left_operand
, 0)))
764 == TYPE_MAIN_VARIANT (left_type
))
766 left_operand
= TREE_OPERAND (left_operand
, 0);
767 left_type
= TREE_TYPE (left_operand
);
770 /* Then convert the right operand to its base type. This will
771 prevent unneeded signedness conversions when sizetype is wider than
773 right_operand
= convert (right_base_type
, right_operand
);
774 right_operand
= convert (TYPE_DOMAIN (left_type
), right_operand
);
776 if (!TREE_CONSTANT (right_operand
)
777 || !TREE_CONSTANT (TYPE_MIN_VALUE (right_type
)))
778 gnat_mark_addressable (left_operand
);
787 gcc_assert (!POINTER_TYPE_P (left_type
));
789 /* ... fall through ... */
793 /* If either operand is a NULL_EXPR, just return a new one. */
794 if (TREE_CODE (left_operand
) == NULL_EXPR
)
795 return build2 (op_code
, result_type
,
796 build1 (NULL_EXPR
, integer_type_node
,
797 TREE_OPERAND (left_operand
, 0)),
800 else if (TREE_CODE (right_operand
) == NULL_EXPR
)
801 return build2 (op_code
, result_type
,
802 build1 (NULL_EXPR
, integer_type_node
,
803 TREE_OPERAND (right_operand
, 0)),
806 /* If either object is a justified modular types, get the
807 fields from within. */
808 if (TREE_CODE (left_type
) == RECORD_TYPE
809 && TYPE_JUSTIFIED_MODULAR_P (left_type
))
811 left_operand
= convert (TREE_TYPE (TYPE_FIELDS (left_type
)),
813 left_type
= TREE_TYPE (left_operand
);
814 left_base_type
= get_base_type (left_type
);
817 if (TREE_CODE (right_type
) == RECORD_TYPE
818 && TYPE_JUSTIFIED_MODULAR_P (right_type
))
820 right_operand
= convert (TREE_TYPE (TYPE_FIELDS (right_type
)),
822 right_type
= TREE_TYPE (right_operand
);
823 right_base_type
= get_base_type (right_type
);
826 /* If both objects are arrays, compare them specially. */
827 if ((TREE_CODE (left_type
) == ARRAY_TYPE
828 || (TREE_CODE (left_type
) == INTEGER_TYPE
829 && TYPE_HAS_ACTUAL_BOUNDS_P (left_type
)))
830 && (TREE_CODE (right_type
) == ARRAY_TYPE
831 || (TREE_CODE (right_type
) == INTEGER_TYPE
832 && TYPE_HAS_ACTUAL_BOUNDS_P (right_type
))))
834 result
= compare_arrays (result_type
, left_operand
, right_operand
);
836 if (op_code
== NE_EXPR
)
837 result
= invert_truthvalue (result
);
839 gcc_assert (op_code
== EQ_EXPR
);
844 /* Otherwise, the base types must be the same unless the objects are
845 fat pointers or records. If we have records, use the best type and
846 convert both operands to that type. */
847 if (left_base_type
!= right_base_type
)
849 if (TYPE_FAT_POINTER_P (left_base_type
)
850 && TYPE_FAT_POINTER_P (right_base_type
)
851 && TYPE_MAIN_VARIANT (left_base_type
)
852 == TYPE_MAIN_VARIANT (right_base_type
))
853 best_type
= left_base_type
;
854 else if (TREE_CODE (left_base_type
) == RECORD_TYPE
855 && TREE_CODE (right_base_type
) == RECORD_TYPE
)
857 /* The only way these are permitted to be the same is if both
858 types have the same name. In that case, one of them must
859 not be self-referential. Use that one as the best type.
860 Even better is if one is of fixed size. */
861 gcc_assert (TYPE_NAME (left_base_type
)
862 && (TYPE_NAME (left_base_type
)
863 == TYPE_NAME (right_base_type
)));
865 if (TREE_CONSTANT (TYPE_SIZE (left_base_type
)))
866 best_type
= left_base_type
;
867 else if (TREE_CONSTANT (TYPE_SIZE (right_base_type
)))
868 best_type
= right_base_type
;
869 else if (!CONTAINS_PLACEHOLDER_P (TYPE_SIZE (left_base_type
)))
870 best_type
= left_base_type
;
871 else if (!CONTAINS_PLACEHOLDER_P (TYPE_SIZE (right_base_type
)))
872 best_type
= right_base_type
;
879 left_operand
= convert (best_type
, left_operand
);
880 right_operand
= convert (best_type
, right_operand
);
883 /* If we are comparing a fat pointer against zero, we need to
884 just compare the data pointer. */
885 else if (TYPE_FAT_POINTER_P (left_base_type
)
886 && TREE_CODE (right_operand
) == CONSTRUCTOR
887 && integer_zerop (VEC_index (constructor_elt
,
888 CONSTRUCTOR_ELTS (right_operand
),
892 right_operand
= build_component_ref (left_operand
, NULL_TREE
,
893 TYPE_FIELDS (left_base_type
),
895 left_operand
= convert (TREE_TYPE (right_operand
),
900 left_operand
= convert (left_base_type
, left_operand
);
901 right_operand
= convert (right_base_type
, right_operand
);
907 case PREINCREMENT_EXPR
:
908 case PREDECREMENT_EXPR
:
909 case POSTINCREMENT_EXPR
:
910 case POSTDECREMENT_EXPR
:
911 /* In these, the result type and the left operand type should be the
912 same. Do the operation in the base type of those and convert the
913 right operand (which is an integer) to that type.
915 Note that these operations are only used in loop control where
916 we guarantee that no overflow can occur. So nothing special need
917 be done for modular types. */
919 gcc_assert (left_type
== result_type
);
920 operation_type
= get_base_type (result_type
);
921 left_operand
= convert (operation_type
, left_operand
);
922 right_operand
= convert (operation_type
, right_operand
);
923 has_side_effects
= true;
931 /* The RHS of a shift can be any type. Also, ignore any modulus
932 (we used to abort, but this is needed for unchecked conversion
933 to modular types). Otherwise, processing is the same as normal. */
934 gcc_assert (operation_type
== left_base_type
);
936 left_operand
= convert (operation_type
, left_operand
);
939 case TRUTH_ANDIF_EXPR
:
940 case TRUTH_ORIF_EXPR
:
944 left_operand
= gnat_truthvalue_conversion (left_operand
);
945 right_operand
= gnat_truthvalue_conversion (right_operand
);
951 /* For binary modulus, if the inputs are in range, so are the
953 if (modulus
&& integer_pow2p (modulus
))
959 gcc_assert (TREE_TYPE (result_type
) == left_base_type
960 && TREE_TYPE (result_type
) == right_base_type
);
961 left_operand
= convert (left_base_type
, left_operand
);
962 right_operand
= convert (right_base_type
, right_operand
);
965 case TRUNC_DIV_EXPR
: case TRUNC_MOD_EXPR
:
966 case CEIL_DIV_EXPR
: case CEIL_MOD_EXPR
:
967 case FLOOR_DIV_EXPR
: case FLOOR_MOD_EXPR
:
968 case ROUND_DIV_EXPR
: case ROUND_MOD_EXPR
:
969 /* These always produce results lower than either operand. */
973 case POINTER_PLUS_EXPR
:
974 gcc_assert (operation_type
== left_base_type
975 && sizetype
== right_base_type
);
976 left_operand
= convert (operation_type
, left_operand
);
977 right_operand
= convert (sizetype
, right_operand
);
982 /* The result type should be the same as the base types of the
983 both operands (and they should be the same). Convert
984 everything to the result type. */
986 gcc_assert (operation_type
== left_base_type
987 && left_base_type
== right_base_type
);
988 left_operand
= convert (operation_type
, left_operand
);
989 right_operand
= convert (operation_type
, right_operand
);
992 if (modulus
&& !integer_pow2p (modulus
))
994 result
= nonbinary_modular_operation (op_code
, operation_type
,
995 left_operand
, right_operand
);
998 /* If either operand is a NULL_EXPR, just return a new one. */
999 else if (TREE_CODE (left_operand
) == NULL_EXPR
)
1000 return build1 (NULL_EXPR
, operation_type
, TREE_OPERAND (left_operand
, 0));
1001 else if (TREE_CODE (right_operand
) == NULL_EXPR
)
1002 return build1 (NULL_EXPR
, operation_type
, TREE_OPERAND (right_operand
, 0));
1003 else if (op_code
== ARRAY_REF
|| op_code
== ARRAY_RANGE_REF
)
1004 result
= build4 (op_code
, operation_type
, left_operand
,
1005 right_operand
, NULL_TREE
, NULL_TREE
);
1008 = fold_build2 (op_code
, operation_type
, left_operand
, right_operand
);
1010 TREE_SIDE_EFFECTS (result
) |= has_side_effects
;
1011 TREE_CONSTANT (result
)
1012 |= (TREE_CONSTANT (left_operand
) & TREE_CONSTANT (right_operand
)
1013 && op_code
!= ARRAY_REF
&& op_code
!= ARRAY_RANGE_REF
);
1015 if ((op_code
== ARRAY_REF
|| op_code
== ARRAY_RANGE_REF
)
1016 && TYPE_VOLATILE (operation_type
))
1017 TREE_THIS_VOLATILE (result
) = 1;
1019 /* If we are working with modular types, perform the MOD operation
1020 if something above hasn't eliminated the need for it. */
1022 result
= fold_build2 (FLOOR_MOD_EXPR
, operation_type
, result
,
1023 convert (operation_type
, modulus
));
1025 if (result_type
&& result_type
!= operation_type
)
1026 result
= convert (result_type
, result
);
1031 /* Similar, but for unary operations. */
1034 build_unary_op (enum tree_code op_code
, tree result_type
, tree operand
)
1036 tree type
= TREE_TYPE (operand
);
1037 tree base_type
= get_base_type (type
);
1038 tree operation_type
= result_type
;
1040 bool side_effects
= false;
1043 && TREE_CODE (operation_type
) == RECORD_TYPE
1044 && TYPE_JUSTIFIED_MODULAR_P (operation_type
))
1045 operation_type
= TREE_TYPE (TYPE_FIELDS (operation_type
));
1048 && !AGGREGATE_TYPE_P (operation_type
)
1049 && TYPE_EXTRA_SUBTYPE_P (operation_type
))
1050 operation_type
= get_base_type (operation_type
);
1056 if (!operation_type
)
1057 result_type
= operation_type
= TREE_TYPE (type
);
1059 gcc_assert (result_type
== TREE_TYPE (type
));
1061 result
= fold_build1 (op_code
, operation_type
, operand
);
1064 case TRUTH_NOT_EXPR
:
1065 gcc_assert (result_type
== base_type
);
1066 result
= invert_truthvalue (gnat_truthvalue_conversion (operand
));
1069 case ATTR_ADDR_EXPR
:
1071 switch (TREE_CODE (operand
))
1074 case UNCONSTRAINED_ARRAY_REF
:
1075 result
= TREE_OPERAND (operand
, 0);
1077 /* Make sure the type here is a pointer, not a reference.
1078 GCC wants pointer types for function addresses. */
1080 result_type
= build_pointer_type (type
);
1082 /* If the underlying object can alias everything, propagate the
1083 property since we are effectively retrieving the object. */
1084 if (POINTER_TYPE_P (TREE_TYPE (result
))
1085 && TYPE_REF_CAN_ALIAS_ALL (TREE_TYPE (result
)))
1087 if (TREE_CODE (result_type
) == POINTER_TYPE
1088 && !TYPE_REF_CAN_ALIAS_ALL (result_type
))
1090 = build_pointer_type_for_mode (TREE_TYPE (result_type
),
1091 TYPE_MODE (result_type
),
1093 else if (TREE_CODE (result_type
) == REFERENCE_TYPE
1094 && !TYPE_REF_CAN_ALIAS_ALL (result_type
))
1096 = build_reference_type_for_mode (TREE_TYPE (result_type
),
1097 TYPE_MODE (result_type
),
1104 TREE_TYPE (result
) = type
= build_pointer_type (type
);
1108 case ARRAY_RANGE_REF
:
1111 /* If this is for 'Address, find the address of the prefix and
1112 add the offset to the field. Otherwise, do this the normal
1114 if (op_code
== ATTR_ADDR_EXPR
)
1116 HOST_WIDE_INT bitsize
;
1117 HOST_WIDE_INT bitpos
;
1119 enum machine_mode mode
;
1120 int unsignedp
, volatilep
;
1122 inner
= get_inner_reference (operand
, &bitsize
, &bitpos
, &offset
,
1123 &mode
, &unsignedp
, &volatilep
,
1126 /* If INNER is a padding type whose field has a self-referential
1127 size, convert to that inner type. We know the offset is zero
1128 and we need to have that type visible. */
1129 if (TREE_CODE (TREE_TYPE (inner
)) == RECORD_TYPE
1130 && TYPE_IS_PADDING_P (TREE_TYPE (inner
))
1131 && (CONTAINS_PLACEHOLDER_P
1132 (TYPE_SIZE (TREE_TYPE (TYPE_FIELDS
1133 (TREE_TYPE (inner
)))))))
1134 inner
= convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (inner
))),
1137 /* Compute the offset as a byte offset from INNER. */
1139 offset
= size_zero_node
;
1141 if (bitpos
% BITS_PER_UNIT
!= 0)
1143 ("taking address of object not aligned on storage unit?",
1146 offset
= size_binop (PLUS_EXPR
, offset
,
1147 size_int (bitpos
/ BITS_PER_UNIT
));
1149 /* Take the address of INNER, convert the offset to void *, and
1150 add then. It will later be converted to the desired result
1152 inner
= build_unary_op (ADDR_EXPR
, NULL_TREE
, inner
);
1153 inner
= convert (ptr_void_type_node
, inner
);
1154 result
= build_binary_op (POINTER_PLUS_EXPR
, ptr_void_type_node
,
1156 result
= convert (build_pointer_type (TREE_TYPE (operand
)),
1163 /* If this is just a constructor for a padded record, we can
1164 just take the address of the single field and convert it to
1165 a pointer to our type. */
1166 if (TREE_CODE (type
) == RECORD_TYPE
&& TYPE_IS_PADDING_P (type
))
1168 result
= (VEC_index (constructor_elt
,
1169 CONSTRUCTOR_ELTS (operand
),
1173 result
= convert (build_pointer_type (TREE_TYPE (operand
)),
1174 build_unary_op (ADDR_EXPR
, NULL_TREE
, result
));
1181 if (AGGREGATE_TYPE_P (type
)
1182 && AGGREGATE_TYPE_P (TREE_TYPE (TREE_OPERAND (operand
, 0))))
1183 return build_unary_op (ADDR_EXPR
, result_type
,
1184 TREE_OPERAND (operand
, 0));
1186 /* ... fallthru ... */
1188 case VIEW_CONVERT_EXPR
:
1189 /* If this just a variant conversion or if the conversion doesn't
1190 change the mode, get the result type from this type and go down.
1191 This is needed for conversions of CONST_DECLs, to eventually get
1192 to the address of their CORRESPONDING_VARs. */
1193 if ((TYPE_MAIN_VARIANT (type
)
1194 == TYPE_MAIN_VARIANT (TREE_TYPE (TREE_OPERAND (operand
, 0))))
1195 || (TYPE_MODE (type
) != BLKmode
1196 && (TYPE_MODE (type
)
1197 == TYPE_MODE (TREE_TYPE (TREE_OPERAND (operand
, 0))))))
1198 return build_unary_op (ADDR_EXPR
,
1199 (result_type
? result_type
1200 : build_pointer_type (type
)),
1201 TREE_OPERAND (operand
, 0));
1205 operand
= DECL_CONST_CORRESPONDING_VAR (operand
);
1207 /* ... fall through ... */
1212 /* If we are taking the address of a padded record whose field is
1213 contains a template, take the address of the template. */
1214 if (TREE_CODE (type
) == RECORD_TYPE
1215 && TYPE_IS_PADDING_P (type
)
1216 && TREE_CODE (TREE_TYPE (TYPE_FIELDS (type
))) == RECORD_TYPE
1217 && TYPE_CONTAINS_TEMPLATE_P (TREE_TYPE (TYPE_FIELDS (type
))))
1219 type
= TREE_TYPE (TYPE_FIELDS (type
));
1220 operand
= convert (type
, operand
);
1223 if (type
!= error_mark_node
)
1224 operation_type
= build_pointer_type (type
);
1226 gnat_mark_addressable (operand
);
1227 result
= fold_build1 (ADDR_EXPR
, operation_type
, operand
);
1230 TREE_CONSTANT (result
) = staticp (operand
) || TREE_CONSTANT (operand
);
1234 /* If we want to refer to an entire unconstrained array,
1235 make up an expression to do so. This will never survive to
1236 the backend. If TYPE is a thin pointer, first convert the
1237 operand to a fat pointer. */
1238 if (TYPE_THIN_POINTER_P (type
)
1239 && TYPE_UNCONSTRAINED_ARRAY (TREE_TYPE (type
)))
1242 = convert (TREE_TYPE (TYPE_UNCONSTRAINED_ARRAY (TREE_TYPE (type
))),
1244 type
= TREE_TYPE (operand
);
1247 if (TYPE_FAT_POINTER_P (type
))
1249 result
= build1 (UNCONSTRAINED_ARRAY_REF
,
1250 TYPE_UNCONSTRAINED_ARRAY (type
), operand
);
1251 TREE_READONLY (result
) = TREE_STATIC (result
)
1252 = TYPE_READONLY (TYPE_UNCONSTRAINED_ARRAY (type
));
1254 else if (TREE_CODE (operand
) == ADDR_EXPR
)
1255 result
= TREE_OPERAND (operand
, 0);
1259 result
= fold_build1 (op_code
, TREE_TYPE (type
), operand
);
1260 TREE_READONLY (result
) = TYPE_READONLY (TREE_TYPE (type
));
1264 = (!TYPE_FAT_POINTER_P (type
) && TYPE_VOLATILE (TREE_TYPE (type
)));
1270 tree modulus
= ((operation_type
1271 && TREE_CODE (operation_type
) == INTEGER_TYPE
1272 && TYPE_MODULAR_P (operation_type
))
1273 ? TYPE_MODULUS (operation_type
) : 0);
1274 int mod_pow2
= modulus
&& integer_pow2p (modulus
);
1276 /* If this is a modular type, there are various possibilities
1277 depending on the operation and whether the modulus is a
1278 power of two or not. */
1282 gcc_assert (operation_type
== base_type
);
1283 operand
= convert (operation_type
, operand
);
1285 /* The fastest in the negate case for binary modulus is
1286 the straightforward code; the TRUNC_MOD_EXPR below
1287 is an AND operation. */
1288 if (op_code
== NEGATE_EXPR
&& mod_pow2
)
1289 result
= fold_build2 (TRUNC_MOD_EXPR
, operation_type
,
1290 fold_build1 (NEGATE_EXPR
, operation_type
,
1294 /* For nonbinary negate case, return zero for zero operand,
1295 else return the modulus minus the operand. If the modulus
1296 is a power of two minus one, we can do the subtraction
1297 as an XOR since it is equivalent and faster on most machines. */
1298 else if (op_code
== NEGATE_EXPR
&& !mod_pow2
)
1300 if (integer_pow2p (fold_build2 (PLUS_EXPR
, operation_type
,
1302 convert (operation_type
,
1303 integer_one_node
))))
1304 result
= fold_build2 (BIT_XOR_EXPR
, operation_type
,
1307 result
= fold_build2 (MINUS_EXPR
, operation_type
,
1310 result
= fold_build3 (COND_EXPR
, operation_type
,
1311 fold_build2 (NE_EXPR
,
1316 integer_zero_node
)),
1321 /* For the NOT cases, we need a constant equal to
1322 the modulus minus one. For a binary modulus, we
1323 XOR against the constant and subtract the operand from
1324 that constant for nonbinary modulus. */
1326 tree cnst
= fold_build2 (MINUS_EXPR
, operation_type
, modulus
,
1327 convert (operation_type
,
1331 result
= fold_build2 (BIT_XOR_EXPR
, operation_type
,
1334 result
= fold_build2 (MINUS_EXPR
, operation_type
,
1342 /* ... fall through ... */
1345 gcc_assert (operation_type
== base_type
);
1346 result
= fold_build1 (op_code
, operation_type
,
1347 convert (operation_type
, operand
));
1352 TREE_SIDE_EFFECTS (result
) = 1;
1353 if (TREE_CODE (result
) == INDIRECT_REF
)
1354 TREE_THIS_VOLATILE (result
) = TYPE_VOLATILE (TREE_TYPE (result
));
1357 if (result_type
&& TREE_TYPE (result
) != result_type
)
1358 result
= convert (result_type
, result
);
1363 /* Similar, but for COND_EXPR. */
1366 build_cond_expr (tree result_type
, tree condition_operand
,
1367 tree true_operand
, tree false_operand
)
1370 bool addr_p
= false;
1372 /* The front-end verifies that result, true and false operands have same base
1373 type. Convert everything to the result type. */
1375 true_operand
= convert (result_type
, true_operand
);
1376 false_operand
= convert (result_type
, false_operand
);
1378 /* If the result type is unconstrained, take the address of
1379 the operands and then dereference our result. */
1380 if (TREE_CODE (result_type
) == UNCONSTRAINED_ARRAY_TYPE
1381 || CONTAINS_PLACEHOLDER_P (TYPE_SIZE (result_type
)))
1384 result_type
= build_pointer_type (result_type
);
1385 true_operand
= build_unary_op (ADDR_EXPR
, result_type
, true_operand
);
1386 false_operand
= build_unary_op (ADDR_EXPR
, result_type
, false_operand
);
1389 result
= fold_build3 (COND_EXPR
, result_type
, condition_operand
,
1390 true_operand
, false_operand
);
1392 /* If either operand is a SAVE_EXPR (possibly surrounded by
1393 arithmetic, make sure it gets done. */
1394 true_operand
= skip_simple_arithmetic (true_operand
);
1395 false_operand
= skip_simple_arithmetic (false_operand
);
1397 if (TREE_CODE (true_operand
) == SAVE_EXPR
)
1398 result
= build2 (COMPOUND_EXPR
, result_type
, true_operand
, result
);
1400 if (TREE_CODE (false_operand
) == SAVE_EXPR
)
1401 result
= build2 (COMPOUND_EXPR
, result_type
, false_operand
, result
);
1403 /* ??? Seems the code above is wrong, as it may move ahead of the COND
1404 SAVE_EXPRs with side effects and not shared by both arms. */
1407 result
= build_unary_op (INDIRECT_REF
, NULL_TREE
, result
);
1412 /* Similar, but for RETURN_EXPR. If RESULT_DECL is non-zero, build
1413 a RETURN_EXPR around the assignment of RET_VAL to RESULT_DECL.
1414 If RESULT_DECL is zero, build a bare RETURN_EXPR. */
1417 build_return_expr (tree result_decl
, tree ret_val
)
1423 /* The gimplifier explicitly enforces the following invariant:
1432 As a consequence, type-homogeneity dictates that we use the type
1433 of the RESULT_DECL as the operation type. */
1435 tree operation_type
= TREE_TYPE (result_decl
);
1437 /* Convert the right operand to the operation type. Note that
1438 it's the same transformation as in the MODIFY_EXPR case of
1439 build_binary_op with the additional guarantee that the type
1440 cannot involve a placeholder, since otherwise the function
1441 would use the "target pointer" return mechanism. */
1443 if (operation_type
!= TREE_TYPE (ret_val
))
1444 ret_val
= convert (operation_type
, ret_val
);
1447 = build2 (MODIFY_EXPR
, operation_type
, result_decl
, ret_val
);
1450 result_expr
= NULL_TREE
;
1452 return build1 (RETURN_EXPR
, void_type_node
, result_expr
);
1455 /* Build a CALL_EXPR to call FUNDECL with one argument, ARG. Return
1459 build_call_1_expr (tree fundecl
, tree arg
)
1461 tree call
= build_call_nary (TREE_TYPE (TREE_TYPE (fundecl
)),
1462 build_unary_op (ADDR_EXPR
, NULL_TREE
, fundecl
),
1464 TREE_SIDE_EFFECTS (call
) = 1;
1468 /* Build a CALL_EXPR to call FUNDECL with two arguments, ARG1 & ARG2. Return
1472 build_call_2_expr (tree fundecl
, tree arg1
, tree arg2
)
1474 tree call
= build_call_nary (TREE_TYPE (TREE_TYPE (fundecl
)),
1475 build_unary_op (ADDR_EXPR
, NULL_TREE
, fundecl
),
1477 TREE_SIDE_EFFECTS (call
) = 1;
1481 /* Likewise to call FUNDECL with no arguments. */
1484 build_call_0_expr (tree fundecl
)
1486 /* We rely on build_call_nary to compute TREE_SIDE_EFFECTS. This makes
1487 it possible to propagate DECL_IS_PURE on parameterless functions. */
1488 tree call
= build_call_nary (TREE_TYPE (TREE_TYPE (fundecl
)),
1489 build_unary_op (ADDR_EXPR
, NULL_TREE
, fundecl
),
1494 /* Call a function that raises an exception and pass the line number and file
1495 name, if requested. MSG says which exception function to call.
1497 GNAT_NODE is the gnat node conveying the source location for which the
1498 error should be signaled, or Empty in which case the error is signaled on
1499 the current ref_file_name/input_line.
1501 KIND says which kind of exception this is for
1502 (N_Raise_{Constraint,Storage,Program}_Error). */
1505 build_call_raise (int msg
, Node_Id gnat_node
, char kind
)
1507 tree fndecl
= gnat_raise_decls
[msg
];
1508 tree label
= get_exception_label (kind
);
1514 /* If this is to be done as a goto, handle that case. */
1517 Entity_Id local_raise
= Get_Local_Raise_Call_Entity ();
1518 tree gnu_result
= build1 (GOTO_EXPR
, void_type_node
, label
);
1520 /* If Local_Raise is present, generate
1521 Local_Raise (exception'Identity); */
1522 if (Present (local_raise
))
1524 tree gnu_local_raise
1525 = gnat_to_gnu_entity (local_raise
, NULL_TREE
, 0);
1526 tree gnu_exception_entity
1527 = gnat_to_gnu_entity (Get_RT_Exception_Entity (msg
), NULL_TREE
, 0);
1529 = build_call_1_expr (gnu_local_raise
,
1530 build_unary_op (ADDR_EXPR
, NULL_TREE
,
1531 gnu_exception_entity
));
1533 gnu_result
= build2 (COMPOUND_EXPR
, void_type_node
,
1534 gnu_call
, gnu_result
);}
1540 = (Debug_Flag_NN
|| Exception_Locations_Suppressed
)
1542 : (gnat_node
!= Empty
&& Sloc (gnat_node
) != No_Location
)
1543 ? IDENTIFIER_POINTER
1544 (get_identifier (Get_Name_String
1546 (Get_Source_File_Index (Sloc (gnat_node
))))))
1549 len
= strlen (str
) + 1;
1550 filename
= build_string (len
, str
);
1552 = (gnat_node
!= Empty
&& Sloc (gnat_node
) != No_Location
)
1553 ? Get_Logical_Line_Number (Sloc(gnat_node
)) : input_line
;
1555 TREE_TYPE (filename
)
1556 = build_array_type (char_type_node
,
1557 build_index_type (build_int_cst (NULL_TREE
, len
)));
1560 build_call_2_expr (fndecl
,
1561 build1 (ADDR_EXPR
, build_pointer_type (char_type_node
),
1563 build_int_cst (NULL_TREE
, line_number
));
1566 /* qsort comparer for the bit positions of two constructor elements
1567 for record components. */
1570 compare_elmt_bitpos (const PTR rt1
, const PTR rt2
)
1572 const_tree
const elmt1
= * (const_tree
const *) rt1
;
1573 const_tree
const elmt2
= * (const_tree
const *) rt2
;
1574 const_tree
const field1
= TREE_PURPOSE (elmt1
);
1575 const_tree
const field2
= TREE_PURPOSE (elmt2
);
1577 = tree_int_cst_compare (bit_position (field1
), bit_position (field2
));
1579 return ret
? ret
: (int) (DECL_UID (field1
) - DECL_UID (field2
));
1582 /* Return a CONSTRUCTOR of TYPE whose list is LIST. */
1585 gnat_build_constructor (tree type
, tree list
)
1589 bool allconstant
= (TREE_CODE (TYPE_SIZE (type
)) == INTEGER_CST
);
1590 bool side_effects
= false;
1593 /* Scan the elements to see if they are all constant or if any has side
1594 effects, to let us set global flags on the resulting constructor. Count
1595 the elements along the way for possible sorting purposes below. */
1596 for (n_elmts
= 0, elmt
= list
; elmt
; elmt
= TREE_CHAIN (elmt
), n_elmts
++)
1598 if (!TREE_CONSTANT (TREE_VALUE (elmt
))
1599 || (TREE_CODE (type
) == RECORD_TYPE
1600 && DECL_BIT_FIELD (TREE_PURPOSE (elmt
))
1601 && TREE_CODE (TREE_VALUE (elmt
)) != INTEGER_CST
)
1602 || !initializer_constant_valid_p (TREE_VALUE (elmt
),
1603 TREE_TYPE (TREE_VALUE (elmt
))))
1604 allconstant
= false;
1606 if (TREE_SIDE_EFFECTS (TREE_VALUE (elmt
)))
1607 side_effects
= true;
1609 /* Propagate an NULL_EXPR from the size of the type. We won't ever
1610 be executing the code we generate here in that case, but handle it
1611 specially to avoid the compiler blowing up. */
1612 if (TREE_CODE (type
) == RECORD_TYPE
1614 = contains_null_expr (DECL_SIZE (TREE_PURPOSE (elmt
))))))
1615 return build1 (NULL_EXPR
, type
, TREE_OPERAND (result
, 0));
1618 /* For record types with constant components only, sort field list
1619 by increasing bit position. This is necessary to ensure the
1620 constructor can be output as static data. */
1621 if (allconstant
&& TREE_CODE (type
) == RECORD_TYPE
&& n_elmts
> 1)
1623 /* Fill an array with an element tree per index, and ask qsort to order
1624 them according to what a bitpos comparison function says. */
1625 tree
*gnu_arr
= (tree
*) alloca (sizeof (tree
) * n_elmts
);
1628 for (i
= 0, elmt
= list
; elmt
; elmt
= TREE_CHAIN (elmt
), i
++)
1631 qsort (gnu_arr
, n_elmts
, sizeof (tree
), compare_elmt_bitpos
);
1633 /* Then reconstruct the list from the sorted array contents. */
1635 for (i
= n_elmts
- 1; i
>= 0; i
--)
1637 TREE_CHAIN (gnu_arr
[i
]) = list
;
1642 result
= build_constructor_from_list (type
, list
);
1643 TREE_CONSTANT (result
) = TREE_INVARIANT (result
)
1644 = TREE_STATIC (result
) = allconstant
;
1645 TREE_SIDE_EFFECTS (result
) = side_effects
;
1646 TREE_READONLY (result
) = TYPE_READONLY (type
) || allconstant
;
1650 /* Return a COMPONENT_REF to access a field that is given by COMPONENT,
1651 an IDENTIFIER_NODE giving the name of the field, or FIELD, a FIELD_DECL,
1652 for the field. Don't fold the result if NO_FOLD_P is true.
1654 We also handle the fact that we might have been passed a pointer to the
1655 actual record and know how to look for fields in variant parts. */
1658 build_simple_component_ref (tree record_variable
, tree component
,
1659 tree field
, bool no_fold_p
)
1661 tree record_type
= TYPE_MAIN_VARIANT (TREE_TYPE (record_variable
));
1662 tree ref
, inner_variable
;
1664 gcc_assert ((TREE_CODE (record_type
) == RECORD_TYPE
1665 || TREE_CODE (record_type
) == UNION_TYPE
1666 || TREE_CODE (record_type
) == QUAL_UNION_TYPE
)
1667 && TYPE_SIZE (record_type
)
1668 && (component
!= 0) != (field
!= 0));
1670 /* If no field was specified, look for a field with the specified name
1671 in the current record only. */
1673 for (field
= TYPE_FIELDS (record_type
); field
;
1674 field
= TREE_CHAIN (field
))
1675 if (DECL_NAME (field
) == component
)
1681 /* If this field is not in the specified record, see if we can find
1682 something in the record whose original field is the same as this one. */
1683 if (DECL_CONTEXT (field
) != record_type
)
1684 /* Check if there is a field with name COMPONENT in the record. */
1688 /* First loop thru normal components. */
1690 for (new_field
= TYPE_FIELDS (record_type
); new_field
;
1691 new_field
= TREE_CHAIN (new_field
))
1692 if (field
== new_field
1693 || DECL_ORIGINAL_FIELD (new_field
) == field
1694 || new_field
== DECL_ORIGINAL_FIELD (field
)
1695 || (DECL_ORIGINAL_FIELD (field
)
1696 && (DECL_ORIGINAL_FIELD (field
)
1697 == DECL_ORIGINAL_FIELD (new_field
))))
1700 /* Next, loop thru DECL_INTERNAL_P components if we haven't found
1701 the component in the first search. Doing this search in 2 steps
1702 is required to avoiding hidden homonymous fields in the
1706 for (new_field
= TYPE_FIELDS (record_type
); new_field
;
1707 new_field
= TREE_CHAIN (new_field
))
1708 if (DECL_INTERNAL_P (new_field
))
1711 = build_simple_component_ref (record_variable
,
1712 NULL_TREE
, new_field
, no_fold_p
);
1713 ref
= build_simple_component_ref (field_ref
, NULL_TREE
, field
,
1726 /* If the field's offset has overflowed, do not attempt to access it
1727 as doing so may trigger sanity checks deeper in the back-end.
1728 Note that we don't need to warn since this will be done on trying
1729 to declare the object. */
1730 if (TREE_CODE (DECL_FIELD_OFFSET (field
)) == INTEGER_CST
1731 && TREE_OVERFLOW (DECL_FIELD_OFFSET (field
)))
1734 /* Look through conversion between type variants. Note that this
1735 is transparent as far as the field is concerned. */
1736 if (TREE_CODE (record_variable
) == VIEW_CONVERT_EXPR
1737 && TYPE_MAIN_VARIANT (TREE_TYPE (TREE_OPERAND (record_variable
, 0)))
1739 inner_variable
= TREE_OPERAND (record_variable
, 0);
1741 inner_variable
= record_variable
;
1743 ref
= build3 (COMPONENT_REF
, TREE_TYPE (field
), inner_variable
, field
,
1746 if (TREE_READONLY (record_variable
) || TREE_READONLY (field
))
1747 TREE_READONLY (ref
) = 1;
1748 if (TREE_THIS_VOLATILE (record_variable
) || TREE_THIS_VOLATILE (field
)
1749 || TYPE_VOLATILE (record_type
))
1750 TREE_THIS_VOLATILE (ref
) = 1;
1755 /* The generic folder may punt in this case because the inner array type
1756 can be self-referential, but folding is in fact not problematic. */
1757 else if (TREE_CODE (record_variable
) == CONSTRUCTOR
1758 && TYPE_CONTAINS_TEMPLATE_P (TREE_TYPE (record_variable
)))
1760 VEC(constructor_elt
,gc
) *elts
= CONSTRUCTOR_ELTS (record_variable
);
1761 unsigned HOST_WIDE_INT idx
;
1763 FOR_EACH_CONSTRUCTOR_ELT (elts
, idx
, index
, value
)
1773 /* Like build_simple_component_ref, except that we give an error if the
1774 reference could not be found. */
1777 build_component_ref (tree record_variable
, tree component
,
1778 tree field
, bool no_fold_p
)
1780 tree ref
= build_simple_component_ref (record_variable
, component
, field
,
1786 /* If FIELD was specified, assume this is an invalid user field so
1787 raise constraint error. Otherwise, we can't find the type to return, so
1790 return build1 (NULL_EXPR
, TREE_TYPE (field
),
1791 build_call_raise (CE_Discriminant_Check_Failed
, Empty
,
1792 N_Raise_Constraint_Error
));
1795 /* Build a GCC tree to call an allocation or deallocation function.
1796 If GNU_OBJ is nonzero, it is an object to deallocate. Otherwise,
1797 generate an allocator.
1799 GNU_SIZE is the size of the object in bytes and ALIGN is the alignment in
1800 bits. GNAT_PROC, if present, is a procedure to call and GNAT_POOL is the
1801 storage pool to use. If not preset, malloc and free will be used except
1802 if GNAT_PROC is the "fake" value of -1, in which case we allocate the
1803 object dynamically on the stack frame. */
1806 build_call_alloc_dealloc (tree gnu_obj
, tree gnu_size
, unsigned align
,
1807 Entity_Id gnat_proc
, Entity_Id gnat_pool
,
1810 tree gnu_align
= size_int (align
/ BITS_PER_UNIT
);
1812 gnu_size
= SUBSTITUTE_PLACEHOLDER_IN_EXPR (gnu_size
, gnu_obj
);
1814 if (Present (gnat_proc
))
1816 /* The storage pools are obviously always tagged types, but the
1817 secondary stack uses the same mechanism and is not tagged */
1818 if (Is_Tagged_Type (Etype (gnat_pool
)))
1820 /* The size is the third parameter; the alignment is the
1822 Entity_Id gnat_size_type
1823 = Etype (Next_Formal (Next_Formal (First_Formal (gnat_proc
))));
1824 tree gnu_size_type
= gnat_to_gnu_type (gnat_size_type
);
1825 tree gnu_proc
= gnat_to_gnu (gnat_proc
);
1826 tree gnu_proc_addr
= build_unary_op (ADDR_EXPR
, NULL_TREE
, gnu_proc
);
1827 tree gnu_pool
= gnat_to_gnu (gnat_pool
);
1828 tree gnu_pool_addr
= build_unary_op (ADDR_EXPR
, NULL_TREE
, gnu_pool
);
1831 gnu_size
= convert (gnu_size_type
, gnu_size
);
1832 gnu_align
= convert (gnu_size_type
, gnu_align
);
1834 /* The first arg is always the address of the storage pool; next
1835 comes the address of the object, for a deallocator, then the
1836 size and alignment. */
1838 gnu_call
= build_call_nary (TREE_TYPE (TREE_TYPE (gnu_proc
)),
1839 gnu_proc_addr
, 4, gnu_pool_addr
,
1840 gnu_obj
, gnu_size
, gnu_align
);
1842 gnu_call
= build_call_nary (TREE_TYPE (TREE_TYPE (gnu_proc
)),
1843 gnu_proc_addr
, 3, gnu_pool_addr
,
1844 gnu_size
, gnu_align
);
1845 TREE_SIDE_EFFECTS (gnu_call
) = 1;
1849 /* Secondary stack case. */
1852 /* The size is the second parameter */
1853 Entity_Id gnat_size_type
1854 = Etype (Next_Formal (First_Formal (gnat_proc
)));
1855 tree gnu_size_type
= gnat_to_gnu_type (gnat_size_type
);
1856 tree gnu_proc
= gnat_to_gnu (gnat_proc
);
1857 tree gnu_proc_addr
= build_unary_op (ADDR_EXPR
, NULL_TREE
, gnu_proc
);
1860 gnu_size
= convert (gnu_size_type
, gnu_size
);
1862 /* The first arg is the address of the object, for a
1863 deallocator, then the size */
1865 gnu_call
= build_call_nary (TREE_TYPE (TREE_TYPE (gnu_proc
)),
1866 gnu_proc_addr
, 2, gnu_obj
, gnu_size
);
1868 gnu_call
= build_call_nary (TREE_TYPE (TREE_TYPE (gnu_proc
)),
1869 gnu_proc_addr
, 1, gnu_size
);
1870 TREE_SIDE_EFFECTS (gnu_call
) = 1;
1876 return build_call_1_expr (free_decl
, gnu_obj
);
1878 /* ??? For now, disable variable-sized allocators in the stack since
1879 we can't yet gimplify an ALLOCATE_EXPR. */
1880 else if (gnat_pool
== -1
1881 && TREE_CODE (gnu_size
) == INTEGER_CST
&& !flag_stack_check
)
1883 /* If the size is a constant, we can put it in the fixed portion of
1884 the stack frame to avoid the need to adjust the stack pointer. */
1885 if (TREE_CODE (gnu_size
) == INTEGER_CST
&& !flag_stack_check
)
1888 = build_range_type (NULL_TREE
, size_one_node
, gnu_size
);
1889 tree gnu_array_type
= build_array_type (char_type_node
, gnu_range
);
1891 = create_var_decl (get_identifier ("RETVAL"), NULL_TREE
,
1892 gnu_array_type
, NULL_TREE
, false, false, false,
1893 false, NULL
, gnat_node
);
1895 return convert (ptr_void_type_node
,
1896 build_unary_op (ADDR_EXPR
, NULL_TREE
, gnu_decl
));
1901 return build2 (ALLOCATE_EXPR
, ptr_void_type_node
, gnu_size
, gnu_align
);
1906 if (Nkind (gnat_node
) != N_Allocator
|| !Comes_From_Source (gnat_node
))
1907 Check_No_Implicit_Heap_Alloc (gnat_node
);
1908 return build_call_1_expr (malloc_decl
, gnu_size
);
1912 /* Build a GCC tree to correspond to allocating an object of TYPE whose
1913 initial value is INIT, if INIT is nonzero. Convert the expression to
1914 RESULT_TYPE, which must be some type of pointer. Return the tree.
1915 GNAT_PROC and GNAT_POOL optionally give the procedure to call and
1916 the storage pool to use. GNAT_NODE is used to provide an error
1917 location for restriction violations messages. If IGNORE_INIT_TYPE is
1918 true, ignore the type of INIT for the purpose of determining the size;
1919 this will cause the maximum size to be allocated if TYPE is of
1920 self-referential size. */
1923 build_allocator (tree type
, tree init
, tree result_type
, Entity_Id gnat_proc
,
1924 Entity_Id gnat_pool
, Node_Id gnat_node
, bool ignore_init_type
)
1926 tree size
= TYPE_SIZE_UNIT (type
);
1928 unsigned int default_allocator_alignment
1929 = get_target_default_allocator_alignment () * BITS_PER_UNIT
;
1931 /* If the initializer, if present, is a NULL_EXPR, just return a new one. */
1932 if (init
&& TREE_CODE (init
) == NULL_EXPR
)
1933 return build1 (NULL_EXPR
, result_type
, TREE_OPERAND (init
, 0));
1935 /* If RESULT_TYPE is a fat or thin pointer, set SIZE to be the sum of the
1936 sizes of the object and its template. Allocate the whole thing and
1937 fill in the parts that are known. */
1938 else if (TYPE_FAT_OR_THIN_POINTER_P (result_type
))
1941 = build_unc_object_type_from_ptr (result_type
, type
,
1942 get_identifier ("ALLOC"));
1943 tree template_type
= TREE_TYPE (TYPE_FIELDS (storage_type
));
1944 tree storage_ptr_type
= build_pointer_type (storage_type
);
1946 tree template_cons
= NULL_TREE
;
1948 size
= SUBSTITUTE_PLACEHOLDER_IN_EXPR (TYPE_SIZE_UNIT (storage_type
),
1951 /* If the size overflows, pass -1 so the allocator will raise
1953 if (TREE_CODE (size
) == INTEGER_CST
&& TREE_OVERFLOW (size
))
1954 size
= ssize_int (-1);
1956 storage
= build_call_alloc_dealloc (NULL_TREE
, size
,
1957 TYPE_ALIGN (storage_type
),
1958 gnat_proc
, gnat_pool
, gnat_node
);
1959 storage
= convert (storage_ptr_type
, protect_multiple_eval (storage
));
1961 if (TREE_CODE (type
) == RECORD_TYPE
&& TYPE_IS_PADDING_P (type
))
1963 type
= TREE_TYPE (TYPE_FIELDS (type
));
1966 init
= convert (type
, init
);
1969 /* If there is an initializing expression, make a constructor for
1970 the entire object including the bounds and copy it into the
1971 object. If there is no initializing expression, just set the
1975 template_cons
= tree_cons (TREE_CHAIN (TYPE_FIELDS (storage_type
)),
1977 template_cons
= tree_cons (TYPE_FIELDS (storage_type
),
1978 build_template (template_type
, type
,
1984 build2 (COMPOUND_EXPR
, storage_ptr_type
,
1986 (MODIFY_EXPR
, storage_type
,
1987 build_unary_op (INDIRECT_REF
, NULL_TREE
,
1988 convert (storage_ptr_type
, storage
)),
1989 gnat_build_constructor (storage_type
, template_cons
)),
1990 convert (storage_ptr_type
, storage
)));
1994 (COMPOUND_EXPR
, result_type
,
1996 (MODIFY_EXPR
, template_type
,
1998 (build_unary_op (INDIRECT_REF
, NULL_TREE
,
1999 convert (storage_ptr_type
, storage
)),
2000 NULL_TREE
, TYPE_FIELDS (storage_type
), 0),
2001 build_template (template_type
, type
, NULL_TREE
)),
2002 convert (result_type
, convert (storage_ptr_type
, storage
)));
2005 /* If we have an initializing expression, see if its size is simpler
2006 than the size from the type. */
2007 if (!ignore_init_type
&& init
&& TYPE_SIZE_UNIT (TREE_TYPE (init
))
2008 && (TREE_CODE (TYPE_SIZE_UNIT (TREE_TYPE (init
))) == INTEGER_CST
2009 || CONTAINS_PLACEHOLDER_P (size
)))
2010 size
= TYPE_SIZE_UNIT (TREE_TYPE (init
));
2012 /* If the size is still self-referential, reference the initializing
2013 expression, if it is present. If not, this must have been a
2014 call to allocate a library-level object, in which case we use
2015 the maximum size. */
2016 if (CONTAINS_PLACEHOLDER_P (size
))
2018 if (!ignore_init_type
&& init
)
2019 size
= substitute_placeholder_in_expr (size
, init
);
2021 size
= max_size (size
, true);
2024 /* If the size overflows, pass -1 so the allocator will raise
2026 if (TREE_CODE (size
) == INTEGER_CST
&& TREE_OVERFLOW (size
))
2027 size
= ssize_int (-1);
2029 /* If this is in the default storage pool and the type alignment is larger
2030 than what the default allocator supports, make an "aligning" record type
2031 with room to store a pointer before the field, allocate an object of that
2032 type, store the system's allocator return value just in front of the
2033 field and return the field's address. */
2035 if (No (gnat_proc
) && TYPE_ALIGN (type
) > default_allocator_alignment
)
2037 /* Construct the aligning type with enough room for a pointer ahead
2038 of the field, then allocate. */
2040 = make_aligning_type (type
, TYPE_ALIGN (type
), size
,
2041 default_allocator_alignment
,
2042 POINTER_SIZE
/ BITS_PER_UNIT
);
2044 tree record
, record_addr
;
2047 = build_call_alloc_dealloc (NULL_TREE
, TYPE_SIZE_UNIT (record_type
),
2048 default_allocator_alignment
, Empty
, Empty
,
2052 = convert (build_pointer_type (record_type
),
2053 save_expr (record_addr
));
2055 record
= build_unary_op (INDIRECT_REF
, NULL_TREE
, record_addr
);
2057 /* Our RESULT (the Ada allocator's value) is the super-aligned address
2058 of the internal record field ... */
2060 = build_unary_op (ADDR_EXPR
, NULL_TREE
,
2062 (record
, NULL_TREE
, TYPE_FIELDS (record_type
), 0));
2063 result
= convert (result_type
, result
);
2065 /* ... with the system allocator's return value stored just in
2069 = build_binary_op (POINTER_PLUS_EXPR
, ptr_void_type_node
,
2070 convert (ptr_void_type_node
, result
),
2071 size_int (-POINTER_SIZE
/BITS_PER_UNIT
));
2074 = convert (build_pointer_type (ptr_void_type_node
), ptr_addr
);
2077 = build2 (COMPOUND_EXPR
, TREE_TYPE (result
),
2078 build_binary_op (MODIFY_EXPR
, NULL_TREE
,
2079 build_unary_op (INDIRECT_REF
, NULL_TREE
,
2081 convert (ptr_void_type_node
,
2087 result
= convert (result_type
,
2088 build_call_alloc_dealloc (NULL_TREE
, size
,
2094 /* If we have an initial value, put the new address into a SAVE_EXPR, assign
2095 the value, and return the address. Do this with a COMPOUND_EXPR. */
2099 result
= save_expr (result
);
2101 = build2 (COMPOUND_EXPR
, TREE_TYPE (result
),
2103 (MODIFY_EXPR
, NULL_TREE
,
2104 build_unary_op (INDIRECT_REF
,
2105 TREE_TYPE (TREE_TYPE (result
)), result
),
2110 return convert (result_type
, result
);
2113 /* Fill in a VMS descriptor for EXPR and return a constructor for it.
2114 GNAT_FORMAL is how we find the descriptor record. */
2117 fill_vms_descriptor (tree expr
, Entity_Id gnat_formal
)
2119 tree record_type
= TREE_TYPE (TREE_TYPE (get_gnu_tree (gnat_formal
)));
2121 tree const_list
= NULL_TREE
;
2123 expr
= maybe_unconstrained_array (expr
);
2124 gnat_mark_addressable (expr
);
2126 for (field
= TYPE_FIELDS (record_type
); field
; field
= TREE_CHAIN (field
))
2129 convert (TREE_TYPE (field
),
2130 SUBSTITUTE_PLACEHOLDER_IN_EXPR
2131 (DECL_INITIAL (field
), expr
)),
2134 return gnat_build_constructor (record_type
, nreverse (const_list
));
2137 /* Indicate that we need to make the address of EXPR_NODE and it therefore
2138 should not be allocated in a register. Returns true if successful. */
2141 gnat_mark_addressable (tree expr_node
)
2144 switch (TREE_CODE (expr_node
))
2149 case ARRAY_RANGE_REF
:
2152 case VIEW_CONVERT_EXPR
:
2154 case NON_LVALUE_EXPR
:
2156 expr_node
= TREE_OPERAND (expr_node
, 0);
2160 TREE_ADDRESSABLE (expr_node
) = 1;
2166 TREE_ADDRESSABLE (expr_node
) = 1;
2170 TREE_ADDRESSABLE (expr_node
) = 1;
2174 return (DECL_CONST_CORRESPONDING_VAR (expr_node
)
2175 && (gnat_mark_addressable
2176 (DECL_CONST_CORRESPONDING_VAR (expr_node
))));