1 /****************************************************************************
3 * GNAT COMPILER COMPONENTS *
7 * C Implementation File *
9 * Copyright (C) 1992-2010, 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"
34 #include "tree-inline.h"
51 static tree find_common_type (tree, 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 /* Return the base type of TYPE. */
59 get_base_type (tree type)
61 if (TREE_CODE (type) == RECORD_TYPE
62 && TYPE_JUSTIFIED_MODULAR_P (type))
63 type = TREE_TYPE (TYPE_FIELDS (type));
65 while (TREE_TYPE (type)
66 && (TREE_CODE (type) == INTEGER_TYPE
67 || TREE_CODE (type) == REAL_TYPE))
68 type = TREE_TYPE (type);
73 /* EXP is a GCC tree representing an address. See if we can find how
74 strictly the object at that address is aligned. Return that alignment
75 in bits. If we don't know anything about the alignment, return 0. */
78 known_alignment (tree exp)
80 unsigned int this_alignment;
81 unsigned int lhs, rhs;
83 switch (TREE_CODE (exp))
86 case VIEW_CONVERT_EXPR:
88 /* Conversions between pointers and integers don't change the alignment
89 of the underlying object. */
90 this_alignment = known_alignment (TREE_OPERAND (exp, 0));
94 /* The value of a COMPOUND_EXPR is that of it's second operand. */
95 this_alignment = known_alignment (TREE_OPERAND (exp, 1));
100 /* If two address are added, the alignment of the result is the
101 minimum of the two alignments. */
102 lhs = known_alignment (TREE_OPERAND (exp, 0));
103 rhs = known_alignment (TREE_OPERAND (exp, 1));
104 this_alignment = MIN (lhs, rhs);
107 case POINTER_PLUS_EXPR:
108 lhs = known_alignment (TREE_OPERAND (exp, 0));
109 rhs = known_alignment (TREE_OPERAND (exp, 1));
110 /* If we don't know the alignment of the offset, we assume that
113 this_alignment = lhs;
115 this_alignment = MIN (lhs, rhs);
119 /* If there is a choice between two values, use the smallest one. */
120 lhs = known_alignment (TREE_OPERAND (exp, 1));
121 rhs = known_alignment (TREE_OPERAND (exp, 2));
122 this_alignment = MIN (lhs, rhs);
127 unsigned HOST_WIDE_INT c = TREE_INT_CST_LOW (exp);
128 /* The first part of this represents the lowest bit in the constant,
129 but it is originally in bytes, not bits. */
130 this_alignment = MIN (BITS_PER_UNIT * (c & -c), BIGGEST_ALIGNMENT);
135 /* If we know the alignment of just one side, use it. Otherwise,
136 use the product of the alignments. */
137 lhs = known_alignment (TREE_OPERAND (exp, 0));
138 rhs = known_alignment (TREE_OPERAND (exp, 1));
141 this_alignment = rhs;
143 this_alignment = lhs;
145 this_alignment = MIN (lhs * rhs, BIGGEST_ALIGNMENT);
149 /* A bit-and expression is as aligned as the maximum alignment of the
150 operands. We typically get here for a complex lhs and a constant
151 negative power of two on the rhs to force an explicit alignment, so
152 don't bother looking at the lhs. */
153 this_alignment = known_alignment (TREE_OPERAND (exp, 1));
157 this_alignment = expr_align (TREE_OPERAND (exp, 0));
162 tree t = maybe_inline_call_in_expr (exp);
164 return known_alignment (t);
167 /* Fall through... */
170 /* For other pointer expressions, we assume that the pointed-to object
171 is at least as aligned as the pointed-to type. Beware that we can
172 have a dummy type here (e.g. a Taft Amendment type), for which the
173 alignment is meaningless and should be ignored. */
174 if (POINTER_TYPE_P (TREE_TYPE (exp))
175 && !TYPE_IS_DUMMY_P (TREE_TYPE (TREE_TYPE (exp))))
176 this_alignment = TYPE_ALIGN (TREE_TYPE (TREE_TYPE (exp)));
182 return this_alignment;
185 /* We have a comparison or assignment operation on two types, T1 and T2, which
186 are either both array types or both record types. T1 is assumed to be for
187 the left hand side operand, and T2 for the right hand side. Return the
188 type that both operands should be converted to for the operation, if any.
189 Otherwise return zero. */
192 find_common_type (tree t1, tree t2)
194 /* ??? As of today, various constructs lead here with types of different
195 sizes even when both constants (e.g. tagged types, packable vs regular
196 component types, padded vs unpadded types, ...). While some of these
197 would better be handled upstream (types should be made consistent before
198 calling into build_binary_op), some others are really expected and we
199 have to be careful. */
201 /* We must prevent writing more than what the target may hold if this is for
202 an assignment and the case of tagged types is handled in build_binary_op
203 so use the lhs type if it is known to be smaller, or of constant size and
204 the rhs type is not, whatever the modes. We also force t1 in case of
205 constant size equality to minimize occurrences of view conversions on the
206 lhs of assignments. */
207 if (TREE_CONSTANT (TYPE_SIZE (t1))
208 && (!TREE_CONSTANT (TYPE_SIZE (t2))
209 || !tree_int_cst_lt (TYPE_SIZE (t2), TYPE_SIZE (t1))))
212 /* Otherwise, if the lhs type is non-BLKmode, use it. Note that we know
213 that we will not have any alignment problems since, if we did, the
214 non-BLKmode type could not have been used. */
215 if (TYPE_MODE (t1) != BLKmode)
218 /* If the rhs type is of constant size, use it whatever the modes. At
219 this point it is known to be smaller, or of constant size and the
221 if (TREE_CONSTANT (TYPE_SIZE (t2)))
224 /* Otherwise, if the rhs type is non-BLKmode, use it. */
225 if (TYPE_MODE (t2) != BLKmode)
228 /* In this case, both types have variable size and BLKmode. It's
229 probably best to leave the "type mismatch" because changing it
230 could cause a bad self-referential reference. */
234 /* Return an expression tree representing an equality comparison of A1 and A2,
235 two objects of type ARRAY_TYPE. The result should be of type RESULT_TYPE.
237 Two arrays are equal in one of two ways: (1) if both have zero length in
238 some dimension (not necessarily the same dimension) or (2) if the lengths
239 in each dimension are equal and the data is equal. We perform the length
240 tests in as efficient a manner as possible. */
243 compare_arrays (tree result_type, tree a1, tree a2)
245 tree t1 = TREE_TYPE (a1);
246 tree t2 = TREE_TYPE (a2);
247 tree result = convert (result_type, integer_one_node);
248 tree a1_is_null = convert (result_type, integer_zero_node);
249 tree a2_is_null = convert (result_type, integer_zero_node);
250 bool a1_side_effects_p = TREE_SIDE_EFFECTS (a1);
251 bool a2_side_effects_p = TREE_SIDE_EFFECTS (a2);
252 bool length_zero_p = false;
254 /* If either operand has side-effects, they have to be evaluated only once
255 in spite of the multiple references to the operand in the comparison. */
256 if (a1_side_effects_p)
257 a1 = gnat_protect_expr (a1);
259 if (a2_side_effects_p)
260 a2 = gnat_protect_expr (a2);
262 /* Process each dimension separately and compare the lengths. If any
263 dimension has a size known to be zero, set SIZE_ZERO_P to 1 to
264 suppress the comparison of the data. */
265 while (TREE_CODE (t1) == ARRAY_TYPE && TREE_CODE (t2) == ARRAY_TYPE)
267 tree lb1 = TYPE_MIN_VALUE (TYPE_DOMAIN (t1));
268 tree ub1 = TYPE_MAX_VALUE (TYPE_DOMAIN (t1));
269 tree lb2 = TYPE_MIN_VALUE (TYPE_DOMAIN (t2));
270 tree ub2 = TYPE_MAX_VALUE (TYPE_DOMAIN (t2));
271 tree bt = get_base_type (TREE_TYPE (lb1));
272 tree length1 = fold_build2 (MINUS_EXPR, bt, ub1, lb1);
273 tree length2 = fold_build2 (MINUS_EXPR, bt, ub2, lb2);
274 tree comparison, this_a1_is_null, this_a2_is_null;
278 /* If the length of the first array is a constant, swap our operands
279 unless the length of the second array is the constant zero.
280 Note that we have set the `length' values to the length - 1. */
281 if (TREE_CODE (length1) == INTEGER_CST
282 && !integer_zerop (fold_build2 (PLUS_EXPR, bt, length2,
283 convert (bt, integer_one_node))))
285 tem = a1, a1 = a2, a2 = tem;
286 tem = t1, t1 = t2, t2 = tem;
287 tem = lb1, lb1 = lb2, lb2 = tem;
288 tem = ub1, ub1 = ub2, ub2 = tem;
289 tem = length1, length1 = length2, length2 = tem;
290 tem = a1_is_null, a1_is_null = a2_is_null, a2_is_null = tem;
291 btem = a1_side_effects_p, a1_side_effects_p = a2_side_effects_p,
292 a2_side_effects_p = btem;
295 /* If the length of this dimension in the second array is the constant
296 zero, we can just go inside the original bounds for the first
297 array and see if last < first. */
298 if (integer_zerop (fold_build2 (PLUS_EXPR, bt, length2,
299 convert (bt, integer_one_node))))
301 tree ub = TYPE_MAX_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (t1)));
302 tree lb = TYPE_MIN_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (t1)));
304 comparison = build_binary_op (LT_EXPR, result_type, ub, lb);
305 comparison = SUBSTITUTE_PLACEHOLDER_IN_EXPR (comparison, a1);
306 length1 = SUBSTITUTE_PLACEHOLDER_IN_EXPR (length1, a1);
308 length_zero_p = true;
309 this_a1_is_null = comparison;
310 this_a2_is_null = convert (result_type, integer_one_node);
313 /* If the length is some other constant value, we know that the
314 this dimension in the first array cannot be superflat, so we
315 can just use its length from the actual stored bounds. */
316 else if (TREE_CODE (length2) == INTEGER_CST)
318 ub1 = TYPE_MAX_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (t1)));
319 lb1 = TYPE_MIN_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (t1)));
320 ub2 = TYPE_MAX_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (t2)));
321 lb2 = TYPE_MIN_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (t2)));
322 nbt = get_base_type (TREE_TYPE (ub1));
325 = build_binary_op (EQ_EXPR, result_type,
326 build_binary_op (MINUS_EXPR, nbt, ub1, lb1),
327 build_binary_op (MINUS_EXPR, nbt, ub2, lb2));
329 /* Note that we know that UB2 and LB2 are constant and hence
330 cannot contain a PLACEHOLDER_EXPR. */
332 comparison = SUBSTITUTE_PLACEHOLDER_IN_EXPR (comparison, a1);
333 length1 = SUBSTITUTE_PLACEHOLDER_IN_EXPR (length1, a1);
335 this_a1_is_null = build_binary_op (LT_EXPR, result_type, ub1, lb1);
336 this_a2_is_null = convert (result_type, integer_zero_node);
339 /* Otherwise compare the computed lengths. */
342 length1 = SUBSTITUTE_PLACEHOLDER_IN_EXPR (length1, a1);
343 length2 = SUBSTITUTE_PLACEHOLDER_IN_EXPR (length2, a2);
346 = build_binary_op (EQ_EXPR, result_type, length1, length2);
349 = build_binary_op (LT_EXPR, result_type, length1,
350 convert (bt, integer_zero_node));
352 = build_binary_op (LT_EXPR, result_type, length2,
353 convert (bt, integer_zero_node));
356 result = build_binary_op (TRUTH_ANDIF_EXPR, result_type,
359 a1_is_null = build_binary_op (TRUTH_ORIF_EXPR, result_type,
360 this_a1_is_null, a1_is_null);
361 a2_is_null = build_binary_op (TRUTH_ORIF_EXPR, result_type,
362 this_a2_is_null, a2_is_null);
368 /* Unless the size of some bound is known to be zero, compare the
369 data in the array. */
372 tree type = find_common_type (TREE_TYPE (a1), TREE_TYPE (a2));
376 a1 = convert (type, a1),
377 a2 = convert (type, a2);
380 result = build_binary_op (TRUTH_ANDIF_EXPR, result_type, result,
381 fold_build2 (EQ_EXPR, result_type, a1, a2));
384 /* The result is also true if both sizes are zero. */
385 result = build_binary_op (TRUTH_ORIF_EXPR, result_type,
386 build_binary_op (TRUTH_ANDIF_EXPR, result_type,
387 a1_is_null, a2_is_null),
390 /* If either operand has side-effects, they have to be evaluated before
391 starting the comparison above since the place they would be otherwise
392 evaluated could be wrong. */
393 if (a1_side_effects_p)
394 result = build2 (COMPOUND_EXPR, result_type, a1, result);
396 if (a2_side_effects_p)
397 result = build2 (COMPOUND_EXPR, result_type, a2, result);
402 /* Compute the result of applying OP_CODE to LHS and RHS, where both are of
403 type TYPE. We know that TYPE is a modular type with a nonbinary
407 nonbinary_modular_operation (enum tree_code op_code, tree type, tree lhs,
410 tree modulus = TYPE_MODULUS (type);
411 unsigned int needed_precision = tree_floor_log2 (modulus) + 1;
412 unsigned int precision;
413 bool unsignedp = true;
417 /* If this is an addition of a constant, convert it to a subtraction
418 of a constant since we can do that faster. */
419 if (op_code == PLUS_EXPR && TREE_CODE (rhs) == INTEGER_CST)
421 rhs = fold_build2 (MINUS_EXPR, type, modulus, rhs);
422 op_code = MINUS_EXPR;
425 /* For the logical operations, we only need PRECISION bits. For
426 addition and subtraction, we need one more and for multiplication we
427 need twice as many. But we never want to make a size smaller than
429 if (op_code == PLUS_EXPR || op_code == MINUS_EXPR)
430 needed_precision += 1;
431 else if (op_code == MULT_EXPR)
432 needed_precision *= 2;
434 precision = MAX (needed_precision, TYPE_PRECISION (op_type));
436 /* Unsigned will do for everything but subtraction. */
437 if (op_code == MINUS_EXPR)
440 /* If our type is the wrong signedness or isn't wide enough, make a new
441 type and convert both our operands to it. */
442 if (TYPE_PRECISION (op_type) < precision
443 || TYPE_UNSIGNED (op_type) != unsignedp)
445 /* Copy the node so we ensure it can be modified to make it modular. */
446 op_type = copy_node (gnat_type_for_size (precision, unsignedp));
447 modulus = convert (op_type, modulus);
448 SET_TYPE_MODULUS (op_type, modulus);
449 TYPE_MODULAR_P (op_type) = 1;
450 lhs = convert (op_type, lhs);
451 rhs = convert (op_type, rhs);
454 /* Do the operation, then we'll fix it up. */
455 result = fold_build2 (op_code, op_type, lhs, rhs);
457 /* For multiplication, we have no choice but to do a full modulus
458 operation. However, we want to do this in the narrowest
460 if (op_code == MULT_EXPR)
462 tree div_type = copy_node (gnat_type_for_size (needed_precision, 1));
463 modulus = convert (div_type, modulus);
464 SET_TYPE_MODULUS (div_type, modulus);
465 TYPE_MODULAR_P (div_type) = 1;
466 result = convert (op_type,
467 fold_build2 (TRUNC_MOD_EXPR, div_type,
468 convert (div_type, result), modulus));
471 /* For subtraction, add the modulus back if we are negative. */
472 else if (op_code == MINUS_EXPR)
474 result = gnat_protect_expr (result);
475 result = fold_build3 (COND_EXPR, op_type,
476 fold_build2 (LT_EXPR, integer_type_node, result,
477 convert (op_type, integer_zero_node)),
478 fold_build2 (PLUS_EXPR, op_type, result, modulus),
482 /* For the other operations, subtract the modulus if we are >= it. */
485 result = gnat_protect_expr (result);
486 result = fold_build3 (COND_EXPR, op_type,
487 fold_build2 (GE_EXPR, integer_type_node,
489 fold_build2 (MINUS_EXPR, op_type,
494 return convert (type, result);
497 /* Make a binary operation of kind OP_CODE. RESULT_TYPE is the type
498 desired for the result. Usually the operation is to be performed
499 in that type. For MODIFY_EXPR and ARRAY_REF, RESULT_TYPE may be 0
500 in which case the type to be used will be derived from the operands.
502 This function is very much unlike the ones for C and C++ since we
503 have already done any type conversion and matching required. All we
504 have to do here is validate the work done by SEM and handle subtypes. */
507 build_binary_op (enum tree_code op_code, tree result_type,
508 tree left_operand, tree right_operand)
510 tree left_type = TREE_TYPE (left_operand);
511 tree right_type = TREE_TYPE (right_operand);
512 tree left_base_type = get_base_type (left_type);
513 tree right_base_type = get_base_type (right_type);
514 tree operation_type = result_type;
515 tree best_type = NULL_TREE;
516 tree modulus, result;
517 bool has_side_effects = false;
520 && TREE_CODE (operation_type) == RECORD_TYPE
521 && TYPE_JUSTIFIED_MODULAR_P (operation_type))
522 operation_type = TREE_TYPE (TYPE_FIELDS (operation_type));
525 && !AGGREGATE_TYPE_P (operation_type)
526 && TYPE_EXTRA_SUBTYPE_P (operation_type))
527 operation_type = get_base_type (operation_type);
529 modulus = (operation_type
530 && TREE_CODE (operation_type) == INTEGER_TYPE
531 && TYPE_MODULAR_P (operation_type)
532 ? TYPE_MODULUS (operation_type) : NULL_TREE);
538 /* If there were integral or pointer conversions on the LHS, remove
539 them; we'll be putting them back below if needed. Likewise for
540 conversions between array and record types, except for justified
541 modular types. But don't do this if the right operand is not
542 BLKmode (for packed arrays) unless we are not changing the mode. */
543 while ((CONVERT_EXPR_P (left_operand)
544 || TREE_CODE (left_operand) == VIEW_CONVERT_EXPR)
545 && (((INTEGRAL_TYPE_P (left_type)
546 || POINTER_TYPE_P (left_type))
547 && (INTEGRAL_TYPE_P (TREE_TYPE
548 (TREE_OPERAND (left_operand, 0)))
549 || POINTER_TYPE_P (TREE_TYPE
550 (TREE_OPERAND (left_operand, 0)))))
551 || (((TREE_CODE (left_type) == RECORD_TYPE
552 && !TYPE_JUSTIFIED_MODULAR_P (left_type))
553 || TREE_CODE (left_type) == ARRAY_TYPE)
554 && ((TREE_CODE (TREE_TYPE
555 (TREE_OPERAND (left_operand, 0)))
557 || (TREE_CODE (TREE_TYPE
558 (TREE_OPERAND (left_operand, 0)))
560 && (TYPE_MODE (right_type) == BLKmode
561 || (TYPE_MODE (left_type)
562 == TYPE_MODE (TREE_TYPE
564 (left_operand, 0))))))))
566 left_operand = TREE_OPERAND (left_operand, 0);
567 left_type = TREE_TYPE (left_operand);
570 /* If a class-wide type may be involved, force use of the RHS type. */
571 if ((TREE_CODE (right_type) == RECORD_TYPE
572 || TREE_CODE (right_type) == UNION_TYPE)
573 && TYPE_ALIGN_OK (right_type))
574 operation_type = right_type;
576 /* If we are copying between padded objects with compatible types, use
577 the padded view of the objects, this is very likely more efficient.
578 Likewise for a padded object that is assigned a constructor, if we
579 can convert the constructor to the inner type, to avoid putting a
580 VIEW_CONVERT_EXPR on the LHS. But don't do so if we wouldn't have
581 actually copied anything. */
582 else if (TYPE_IS_PADDING_P (left_type)
583 && TREE_CONSTANT (TYPE_SIZE (left_type))
584 && ((TREE_CODE (right_operand) == COMPONENT_REF
586 (TREE_TYPE (TREE_OPERAND (right_operand, 0)))
587 && gnat_types_compatible_p
589 TREE_TYPE (TREE_OPERAND (right_operand, 0))))
590 || (TREE_CODE (right_operand) == CONSTRUCTOR
591 && !CONTAINS_PLACEHOLDER_P
592 (DECL_SIZE (TYPE_FIELDS (left_type)))))
593 && !integer_zerop (TYPE_SIZE (right_type)))
594 operation_type = left_type;
596 /* Find the best type to use for copying between aggregate types. */
597 else if (((TREE_CODE (left_type) == ARRAY_TYPE
598 && TREE_CODE (right_type) == ARRAY_TYPE)
599 || (TREE_CODE (left_type) == RECORD_TYPE
600 && TREE_CODE (right_type) == RECORD_TYPE))
601 && (best_type = find_common_type (left_type, right_type)))
602 operation_type = best_type;
604 /* Otherwise use the LHS type. */
605 else if (!operation_type)
606 operation_type = left_type;
608 /* Ensure everything on the LHS is valid. If we have a field reference,
609 strip anything that get_inner_reference can handle. Then remove any
610 conversions between types having the same code and mode. And mark
611 VIEW_CONVERT_EXPRs with TREE_ADDRESSABLE. When done, we must have
612 either an INDIRECT_REF, a NULL_EXPR or a DECL node. */
613 result = left_operand;
616 tree restype = TREE_TYPE (result);
618 if (TREE_CODE (result) == COMPONENT_REF
619 || TREE_CODE (result) == ARRAY_REF
620 || TREE_CODE (result) == ARRAY_RANGE_REF)
621 while (handled_component_p (result))
622 result = TREE_OPERAND (result, 0);
623 else if (TREE_CODE (result) == REALPART_EXPR
624 || TREE_CODE (result) == IMAGPART_EXPR
625 || (CONVERT_EXPR_P (result)
626 && (((TREE_CODE (restype)
627 == TREE_CODE (TREE_TYPE
628 (TREE_OPERAND (result, 0))))
629 && (TYPE_MODE (TREE_TYPE
630 (TREE_OPERAND (result, 0)))
631 == TYPE_MODE (restype)))
632 || TYPE_ALIGN_OK (restype))))
633 result = TREE_OPERAND (result, 0);
634 else if (TREE_CODE (result) == VIEW_CONVERT_EXPR)
636 TREE_ADDRESSABLE (result) = 1;
637 result = TREE_OPERAND (result, 0);
643 gcc_assert (TREE_CODE (result) == INDIRECT_REF
644 || TREE_CODE (result) == NULL_EXPR
647 /* Convert the right operand to the operation type unless it is
648 either already of the correct type or if the type involves a
649 placeholder, since the RHS may not have the same record type. */
650 if (operation_type != right_type
651 && !CONTAINS_PLACEHOLDER_P (TYPE_SIZE (operation_type)))
653 right_operand = convert (operation_type, right_operand);
654 right_type = operation_type;
657 /* If the left operand is not of the same type as the operation
658 type, wrap it up in a VIEW_CONVERT_EXPR. */
659 if (left_type != operation_type)
660 left_operand = unchecked_convert (operation_type, left_operand, false);
662 has_side_effects = true;
668 operation_type = TREE_TYPE (left_type);
670 /* ... fall through ... */
672 case ARRAY_RANGE_REF:
673 /* First look through conversion between type variants. Note that
674 this changes neither the operation type nor the type domain. */
675 if (TREE_CODE (left_operand) == VIEW_CONVERT_EXPR
676 && TYPE_MAIN_VARIANT (TREE_TYPE (TREE_OPERAND (left_operand, 0)))
677 == TYPE_MAIN_VARIANT (left_type))
679 left_operand = TREE_OPERAND (left_operand, 0);
680 left_type = TREE_TYPE (left_operand);
683 /* For a range, make sure the element type is consistent. */
684 if (op_code == ARRAY_RANGE_REF
685 && TREE_TYPE (operation_type) != TREE_TYPE (left_type))
686 operation_type = build_array_type (TREE_TYPE (left_type),
687 TYPE_DOMAIN (operation_type));
689 /* Then convert the right operand to its base type. This will prevent
690 unneeded sign conversions when sizetype is wider than integer. */
691 right_operand = convert (right_base_type, right_operand);
692 right_operand = convert (sizetype, right_operand);
694 if (!TREE_CONSTANT (right_operand)
695 || !TREE_CONSTANT (TYPE_MIN_VALUE (right_type)))
696 gnat_mark_addressable (left_operand);
705 gcc_assert (!POINTER_TYPE_P (left_type));
707 /* ... fall through ... */
711 /* If either operand is a NULL_EXPR, just return a new one. */
712 if (TREE_CODE (left_operand) == NULL_EXPR)
713 return build2 (op_code, result_type,
714 build1 (NULL_EXPR, integer_type_node,
715 TREE_OPERAND (left_operand, 0)),
718 else if (TREE_CODE (right_operand) == NULL_EXPR)
719 return build2 (op_code, result_type,
720 build1 (NULL_EXPR, integer_type_node,
721 TREE_OPERAND (right_operand, 0)),
724 /* If either object is a justified modular types, get the
725 fields from within. */
726 if (TREE_CODE (left_type) == RECORD_TYPE
727 && TYPE_JUSTIFIED_MODULAR_P (left_type))
729 left_operand = convert (TREE_TYPE (TYPE_FIELDS (left_type)),
731 left_type = TREE_TYPE (left_operand);
732 left_base_type = get_base_type (left_type);
735 if (TREE_CODE (right_type) == RECORD_TYPE
736 && TYPE_JUSTIFIED_MODULAR_P (right_type))
738 right_operand = convert (TREE_TYPE (TYPE_FIELDS (right_type)),
740 right_type = TREE_TYPE (right_operand);
741 right_base_type = get_base_type (right_type);
744 /* If both objects are arrays, compare them specially. */
745 if ((TREE_CODE (left_type) == ARRAY_TYPE
746 || (TREE_CODE (left_type) == INTEGER_TYPE
747 && TYPE_HAS_ACTUAL_BOUNDS_P (left_type)))
748 && (TREE_CODE (right_type) == ARRAY_TYPE
749 || (TREE_CODE (right_type) == INTEGER_TYPE
750 && TYPE_HAS_ACTUAL_BOUNDS_P (right_type))))
752 result = compare_arrays (result_type, left_operand, right_operand);
754 if (op_code == NE_EXPR)
755 result = invert_truthvalue (result);
757 gcc_assert (op_code == EQ_EXPR);
762 /* Otherwise, the base types must be the same, unless they are both fat
763 pointer types or record types. In the latter case, use the best type
764 and convert both operands to that type. */
765 if (left_base_type != right_base_type)
767 if (TYPE_IS_FAT_POINTER_P (left_base_type)
768 && TYPE_IS_FAT_POINTER_P (right_base_type))
770 gcc_assert (TYPE_MAIN_VARIANT (left_base_type)
771 == TYPE_MAIN_VARIANT (right_base_type));
772 best_type = left_base_type;
775 else if (TREE_CODE (left_base_type) == RECORD_TYPE
776 && TREE_CODE (right_base_type) == RECORD_TYPE)
778 /* The only way this is permitted is if both types have the same
779 name. In that case, one of them must not be self-referential.
780 Use it as the best type. Even better with a fixed size. */
781 gcc_assert (TYPE_NAME (left_base_type)
782 && TYPE_NAME (left_base_type)
783 == TYPE_NAME (right_base_type));
785 if (TREE_CONSTANT (TYPE_SIZE (left_base_type)))
786 best_type = left_base_type;
787 else if (TREE_CONSTANT (TYPE_SIZE (right_base_type)))
788 best_type = right_base_type;
789 else if (!CONTAINS_PLACEHOLDER_P (TYPE_SIZE (left_base_type)))
790 best_type = left_base_type;
791 else if (!CONTAINS_PLACEHOLDER_P (TYPE_SIZE (right_base_type)))
792 best_type = right_base_type;
800 left_operand = convert (best_type, left_operand);
801 right_operand = convert (best_type, right_operand);
805 left_operand = convert (left_base_type, left_operand);
806 right_operand = convert (right_base_type, right_operand);
809 /* If we are comparing a fat pointer against zero, we just need to
810 compare the data pointer. */
811 if (TYPE_IS_FAT_POINTER_P (left_base_type)
812 && TREE_CODE (right_operand) == CONSTRUCTOR
813 && integer_zerop (VEC_index (constructor_elt,
814 CONSTRUCTOR_ELTS (right_operand),
818 = build_component_ref (left_operand, NULL_TREE,
819 TYPE_FIELDS (left_base_type), false);
821 = convert (TREE_TYPE (left_operand), integer_zero_node);
827 case PREINCREMENT_EXPR:
828 case PREDECREMENT_EXPR:
829 case POSTINCREMENT_EXPR:
830 case POSTDECREMENT_EXPR:
831 /* These operations are not used anymore. */
838 /* The RHS of a shift can be any type. Also, ignore any modulus
839 (we used to abort, but this is needed for unchecked conversion
840 to modular types). Otherwise, processing is the same as normal. */
841 gcc_assert (operation_type == left_base_type);
843 left_operand = convert (operation_type, left_operand);
849 /* For binary modulus, if the inputs are in range, so are the
851 if (modulus && integer_pow2p (modulus))
856 gcc_assert (TREE_TYPE (result_type) == left_base_type
857 && TREE_TYPE (result_type) == right_base_type);
858 left_operand = convert (left_base_type, left_operand);
859 right_operand = convert (right_base_type, right_operand);
862 case TRUNC_DIV_EXPR: case TRUNC_MOD_EXPR:
863 case CEIL_DIV_EXPR: case CEIL_MOD_EXPR:
864 case FLOOR_DIV_EXPR: case FLOOR_MOD_EXPR:
865 case ROUND_DIV_EXPR: case ROUND_MOD_EXPR:
866 /* These always produce results lower than either operand. */
870 case POINTER_PLUS_EXPR:
871 gcc_assert (operation_type == left_base_type
872 && sizetype == right_base_type);
873 left_operand = convert (operation_type, left_operand);
874 right_operand = convert (sizetype, right_operand);
877 case PLUS_NOMOD_EXPR:
878 case MINUS_NOMOD_EXPR:
879 if (op_code == PLUS_NOMOD_EXPR)
882 op_code = MINUS_EXPR;
885 /* ... fall through ... */
889 /* Avoid doing arithmetics in ENUMERAL_TYPE or BOOLEAN_TYPE like the
890 other compilers. Contrary to C, Ada doesn't allow arithmetics in
891 these types but can generate addition/subtraction for Succ/Pred. */
893 && (TREE_CODE (operation_type) == ENUMERAL_TYPE
894 || TREE_CODE (operation_type) == BOOLEAN_TYPE))
895 operation_type = left_base_type = right_base_type
896 = gnat_type_for_mode (TYPE_MODE (operation_type),
897 TYPE_UNSIGNED (operation_type));
899 /* ... fall through ... */
903 /* The result type should be the same as the base types of the
904 both operands (and they should be the same). Convert
905 everything to the result type. */
907 gcc_assert (operation_type == left_base_type
908 && left_base_type == right_base_type);
909 left_operand = convert (operation_type, left_operand);
910 right_operand = convert (operation_type, right_operand);
913 if (modulus && !integer_pow2p (modulus))
915 result = nonbinary_modular_operation (op_code, operation_type,
916 left_operand, right_operand);
919 /* If either operand is a NULL_EXPR, just return a new one. */
920 else if (TREE_CODE (left_operand) == NULL_EXPR)
921 return build1 (NULL_EXPR, operation_type, TREE_OPERAND (left_operand, 0));
922 else if (TREE_CODE (right_operand) == NULL_EXPR)
923 return build1 (NULL_EXPR, operation_type, TREE_OPERAND (right_operand, 0));
924 else if (op_code == ARRAY_REF || op_code == ARRAY_RANGE_REF)
925 result = fold (build4 (op_code, operation_type, left_operand,
926 right_operand, NULL_TREE, NULL_TREE));
929 = fold_build2 (op_code, operation_type, left_operand, right_operand);
931 TREE_SIDE_EFFECTS (result) |= has_side_effects;
932 TREE_CONSTANT (result)
933 |= (TREE_CONSTANT (left_operand) & TREE_CONSTANT (right_operand)
934 && op_code != ARRAY_REF && op_code != ARRAY_RANGE_REF);
936 if ((op_code == ARRAY_REF || op_code == ARRAY_RANGE_REF)
937 && TYPE_VOLATILE (operation_type))
938 TREE_THIS_VOLATILE (result) = 1;
940 /* If we are working with modular types, perform the MOD operation
941 if something above hasn't eliminated the need for it. */
943 result = fold_build2 (FLOOR_MOD_EXPR, operation_type, result,
944 convert (operation_type, modulus));
946 if (result_type && result_type != operation_type)
947 result = convert (result_type, result);
952 /* Similar, but for unary operations. */
955 build_unary_op (enum tree_code op_code, tree result_type, tree operand)
957 tree type = TREE_TYPE (operand);
958 tree base_type = get_base_type (type);
959 tree operation_type = result_type;
961 bool side_effects = false;
964 && TREE_CODE (operation_type) == RECORD_TYPE
965 && TYPE_JUSTIFIED_MODULAR_P (operation_type))
966 operation_type = TREE_TYPE (TYPE_FIELDS (operation_type));
969 && !AGGREGATE_TYPE_P (operation_type)
970 && TYPE_EXTRA_SUBTYPE_P (operation_type))
971 operation_type = get_base_type (operation_type);
978 result_type = operation_type = TREE_TYPE (type);
980 gcc_assert (result_type == TREE_TYPE (type));
982 result = fold_build1 (op_code, operation_type, operand);
986 gcc_assert (result_type == base_type);
987 result = invert_truthvalue (operand);
992 switch (TREE_CODE (operand))
995 case UNCONSTRAINED_ARRAY_REF:
996 result = TREE_OPERAND (operand, 0);
998 /* Make sure the type here is a pointer, not a reference.
999 GCC wants pointer types for function addresses. */
1001 result_type = build_pointer_type (type);
1003 /* If the underlying object can alias everything, propagate the
1004 property since we are effectively retrieving the object. */
1005 if (POINTER_TYPE_P (TREE_TYPE (result))
1006 && TYPE_REF_CAN_ALIAS_ALL (TREE_TYPE (result)))
1008 if (TREE_CODE (result_type) == POINTER_TYPE
1009 && !TYPE_REF_CAN_ALIAS_ALL (result_type))
1011 = build_pointer_type_for_mode (TREE_TYPE (result_type),
1012 TYPE_MODE (result_type),
1014 else if (TREE_CODE (result_type) == REFERENCE_TYPE
1015 && !TYPE_REF_CAN_ALIAS_ALL (result_type))
1017 = build_reference_type_for_mode (TREE_TYPE (result_type),
1018 TYPE_MODE (result_type),
1025 TREE_TYPE (result) = type = build_pointer_type (type);
1029 case ARRAY_RANGE_REF:
1032 /* If this is for 'Address, find the address of the prefix and
1033 add the offset to the field. Otherwise, do this the normal
1035 if (op_code == ATTR_ADDR_EXPR)
1037 HOST_WIDE_INT bitsize;
1038 HOST_WIDE_INT bitpos;
1040 enum machine_mode mode;
1041 int unsignedp, volatilep;
1043 inner = get_inner_reference (operand, &bitsize, &bitpos, &offset,
1044 &mode, &unsignedp, &volatilep,
1047 /* If INNER is a padding type whose field has a self-referential
1048 size, convert to that inner type. We know the offset is zero
1049 and we need to have that type visible. */
1050 if (TYPE_IS_PADDING_P (TREE_TYPE (inner))
1051 && CONTAINS_PLACEHOLDER_P
1052 (TYPE_SIZE (TREE_TYPE (TYPE_FIELDS
1053 (TREE_TYPE (inner))))))
1054 inner = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (inner))),
1057 /* Compute the offset as a byte offset from INNER. */
1059 offset = size_zero_node;
1061 if (bitpos % BITS_PER_UNIT != 0)
1063 ("taking address of object not aligned on storage unit?",
1066 offset = size_binop (PLUS_EXPR, offset,
1067 size_int (bitpos / BITS_PER_UNIT));
1069 /* Take the address of INNER, convert the offset to void *, and
1070 add then. It will later be converted to the desired result
1072 inner = build_unary_op (ADDR_EXPR, NULL_TREE, inner);
1073 inner = convert (ptr_void_type_node, inner);
1074 result = build_binary_op (POINTER_PLUS_EXPR, ptr_void_type_node,
1076 result = convert (build_pointer_type (TREE_TYPE (operand)),
1083 /* If this is just a constructor for a padded record, we can
1084 just take the address of the single field and convert it to
1085 a pointer to our type. */
1086 if (TYPE_IS_PADDING_P (type))
1088 result = VEC_index (constructor_elt,
1089 CONSTRUCTOR_ELTS (operand),
1091 result = convert (build_pointer_type (TREE_TYPE (operand)),
1092 build_unary_op (ADDR_EXPR, NULL_TREE, result));
1099 if (AGGREGATE_TYPE_P (type)
1100 && AGGREGATE_TYPE_P (TREE_TYPE (TREE_OPERAND (operand, 0))))
1101 return build_unary_op (ADDR_EXPR, result_type,
1102 TREE_OPERAND (operand, 0));
1104 /* ... fallthru ... */
1106 case VIEW_CONVERT_EXPR:
1107 /* If this just a variant conversion or if the conversion doesn't
1108 change the mode, get the result type from this type and go down.
1109 This is needed for conversions of CONST_DECLs, to eventually get
1110 to the address of their CORRESPONDING_VARs. */
1111 if ((TYPE_MAIN_VARIANT (type)
1112 == TYPE_MAIN_VARIANT (TREE_TYPE (TREE_OPERAND (operand, 0))))
1113 || (TYPE_MODE (type) != BLKmode
1114 && (TYPE_MODE (type)
1115 == TYPE_MODE (TREE_TYPE (TREE_OPERAND (operand, 0))))))
1116 return build_unary_op (ADDR_EXPR,
1117 (result_type ? result_type
1118 : build_pointer_type (type)),
1119 TREE_OPERAND (operand, 0));
1123 operand = DECL_CONST_CORRESPONDING_VAR (operand);
1125 /* ... fall through ... */
1130 /* If we are taking the address of a padded record whose field is
1131 contains a template, take the address of the template. */
1132 if (TYPE_IS_PADDING_P (type)
1133 && TREE_CODE (TREE_TYPE (TYPE_FIELDS (type))) == RECORD_TYPE
1134 && TYPE_CONTAINS_TEMPLATE_P (TREE_TYPE (TYPE_FIELDS (type))))
1136 type = TREE_TYPE (TYPE_FIELDS (type));
1137 operand = convert (type, operand);
1140 if (type != error_mark_node)
1141 operation_type = build_pointer_type (type);
1143 gnat_mark_addressable (operand);
1144 result = fold_build1 (ADDR_EXPR, operation_type, operand);
1147 TREE_CONSTANT (result) = staticp (operand) || TREE_CONSTANT (operand);
1151 /* If we want to refer to an entire unconstrained array,
1152 make up an expression to do so. This will never survive to
1153 the backend. If TYPE is a thin pointer, first convert the
1154 operand to a fat pointer. */
1155 if (TYPE_IS_THIN_POINTER_P (type)
1156 && TYPE_UNCONSTRAINED_ARRAY (TREE_TYPE (type)))
1159 = convert (TREE_TYPE (TYPE_UNCONSTRAINED_ARRAY (TREE_TYPE (type))),
1161 type = TREE_TYPE (operand);
1164 if (TYPE_IS_FAT_POINTER_P (type))
1166 result = build1 (UNCONSTRAINED_ARRAY_REF,
1167 TYPE_UNCONSTRAINED_ARRAY (type), operand);
1168 TREE_READONLY (result)
1169 = TYPE_READONLY (TYPE_UNCONSTRAINED_ARRAY (type));
1171 else if (TREE_CODE (operand) == ADDR_EXPR)
1172 result = TREE_OPERAND (operand, 0);
1176 result = fold_build1 (op_code, TREE_TYPE (type), operand);
1177 TREE_READONLY (result) = TYPE_READONLY (TREE_TYPE (type));
1181 = (!TYPE_IS_FAT_POINTER_P (type) && TYPE_VOLATILE (TREE_TYPE (type)));
1187 tree modulus = ((operation_type
1188 && TREE_CODE (operation_type) == INTEGER_TYPE
1189 && TYPE_MODULAR_P (operation_type))
1190 ? TYPE_MODULUS (operation_type) : NULL_TREE);
1191 int mod_pow2 = modulus && integer_pow2p (modulus);
1193 /* If this is a modular type, there are various possibilities
1194 depending on the operation and whether the modulus is a
1195 power of two or not. */
1199 gcc_assert (operation_type == base_type);
1200 operand = convert (operation_type, operand);
1202 /* The fastest in the negate case for binary modulus is
1203 the straightforward code; the TRUNC_MOD_EXPR below
1204 is an AND operation. */
1205 if (op_code == NEGATE_EXPR && mod_pow2)
1206 result = fold_build2 (TRUNC_MOD_EXPR, operation_type,
1207 fold_build1 (NEGATE_EXPR, operation_type,
1211 /* For nonbinary negate case, return zero for zero operand,
1212 else return the modulus minus the operand. If the modulus
1213 is a power of two minus one, we can do the subtraction
1214 as an XOR since it is equivalent and faster on most machines. */
1215 else if (op_code == NEGATE_EXPR && !mod_pow2)
1217 if (integer_pow2p (fold_build2 (PLUS_EXPR, operation_type,
1219 convert (operation_type,
1220 integer_one_node))))
1221 result = fold_build2 (BIT_XOR_EXPR, operation_type,
1224 result = fold_build2 (MINUS_EXPR, operation_type,
1227 result = fold_build3 (COND_EXPR, operation_type,
1228 fold_build2 (NE_EXPR,
1233 integer_zero_node)),
1238 /* For the NOT cases, we need a constant equal to
1239 the modulus minus one. For a binary modulus, we
1240 XOR against the constant and subtract the operand from
1241 that constant for nonbinary modulus. */
1243 tree cnst = fold_build2 (MINUS_EXPR, operation_type, modulus,
1244 convert (operation_type,
1248 result = fold_build2 (BIT_XOR_EXPR, operation_type,
1251 result = fold_build2 (MINUS_EXPR, operation_type,
1259 /* ... fall through ... */
1262 gcc_assert (operation_type == base_type);
1263 result = fold_build1 (op_code, operation_type,
1264 convert (operation_type, operand));
1269 TREE_SIDE_EFFECTS (result) = 1;
1270 if (TREE_CODE (result) == INDIRECT_REF)
1271 TREE_THIS_VOLATILE (result) = TYPE_VOLATILE (TREE_TYPE (result));
1274 if (result_type && TREE_TYPE (result) != result_type)
1275 result = convert (result_type, result);
1280 /* Similar, but for COND_EXPR. */
1283 build_cond_expr (tree result_type, tree condition_operand,
1284 tree true_operand, tree false_operand)
1286 bool addr_p = false;
1289 /* The front-end verified that result, true and false operands have
1290 same base type. Convert everything to the result type. */
1291 true_operand = convert (result_type, true_operand);
1292 false_operand = convert (result_type, false_operand);
1294 /* If the result type is unconstrained, take the address of the operands and
1295 then dereference the result. Likewise if the result type is passed by
1296 reference, but this is natively handled in the gimplifier. */
1297 if (TREE_CODE (result_type) == UNCONSTRAINED_ARRAY_TYPE
1298 || CONTAINS_PLACEHOLDER_P (TYPE_SIZE (result_type)))
1300 result_type = build_pointer_type (result_type);
1301 true_operand = build_unary_op (ADDR_EXPR, result_type, true_operand);
1302 false_operand = build_unary_op (ADDR_EXPR, result_type, false_operand);
1306 result = fold_build3 (COND_EXPR, result_type, condition_operand,
1307 true_operand, false_operand);
1309 /* If we have a common SAVE_EXPR (possibly surrounded by arithmetics)
1310 in both arms, make sure it gets evaluated by moving it ahead of the
1311 conditional expression. This is necessary because it is evaluated
1312 in only one place at run time and would otherwise be uninitialized
1313 in one of the arms. */
1314 true_operand = skip_simple_arithmetic (true_operand);
1315 false_operand = skip_simple_arithmetic (false_operand);
1317 if (true_operand == false_operand && TREE_CODE (true_operand) == SAVE_EXPR)
1318 result = build2 (COMPOUND_EXPR, result_type, true_operand, result);
1321 result = build_unary_op (INDIRECT_REF, NULL_TREE, result);
1326 /* Similar, but for RETURN_EXPR. If RET_VAL is non-null, build a RETURN_EXPR
1327 around the assignment of RET_VAL to RET_OBJ. Otherwise just build a bare
1328 RETURN_EXPR around RESULT_OBJ, which may be null in this case. */
1331 build_return_expr (tree ret_obj, tree ret_val)
1337 /* The gimplifier explicitly enforces the following invariant:
1346 As a consequence, type consistency dictates that we use the type
1347 of the RET_OBJ as the operation type. */
1348 tree operation_type = TREE_TYPE (ret_obj);
1350 /* Convert the right operand to the operation type. Note that it's the
1351 same transformation as in the MODIFY_EXPR case of build_binary_op,
1352 with the assumption that the type cannot involve a placeholder. */
1353 if (operation_type != TREE_TYPE (ret_val))
1354 ret_val = convert (operation_type, ret_val);
1356 result_expr = build2 (MODIFY_EXPR, operation_type, ret_obj, ret_val);
1359 result_expr = ret_obj;
1361 return build1 (RETURN_EXPR, void_type_node, result_expr);
1364 /* Build a CALL_EXPR to call FUNDECL with one argument, ARG. Return
1368 build_call_1_expr (tree fundecl, tree arg)
1370 tree call = build_call_nary (TREE_TYPE (TREE_TYPE (fundecl)),
1371 build_unary_op (ADDR_EXPR, NULL_TREE, fundecl),
1373 TREE_SIDE_EFFECTS (call) = 1;
1377 /* Build a CALL_EXPR to call FUNDECL with two arguments, ARG1 & ARG2. Return
1381 build_call_2_expr (tree fundecl, tree arg1, tree arg2)
1383 tree call = build_call_nary (TREE_TYPE (TREE_TYPE (fundecl)),
1384 build_unary_op (ADDR_EXPR, NULL_TREE, fundecl),
1386 TREE_SIDE_EFFECTS (call) = 1;
1390 /* Likewise to call FUNDECL with no arguments. */
1393 build_call_0_expr (tree fundecl)
1395 /* We rely on build_call_nary to compute TREE_SIDE_EFFECTS. This makes
1396 it possible to propagate DECL_IS_PURE on parameterless functions. */
1397 tree call = build_call_nary (TREE_TYPE (TREE_TYPE (fundecl)),
1398 build_unary_op (ADDR_EXPR, NULL_TREE, fundecl),
1403 /* Call a function that raises an exception and pass the line number and file
1404 name, if requested. MSG says which exception function to call.
1406 GNAT_NODE is the gnat node conveying the source location for which the
1407 error should be signaled, or Empty in which case the error is signaled on
1408 the current ref_file_name/input_line.
1410 KIND says which kind of exception this is for
1411 (N_Raise_{Constraint,Storage,Program}_Error). */
1414 build_call_raise (int msg, Node_Id gnat_node, char kind)
1416 tree fndecl = gnat_raise_decls[msg];
1417 tree label = get_exception_label (kind);
1423 /* If this is to be done as a goto, handle that case. */
1426 Entity_Id local_raise = Get_Local_Raise_Call_Entity ();
1427 tree gnu_result = build1 (GOTO_EXPR, void_type_node, label);
1429 /* If Local_Raise is present, generate
1430 Local_Raise (exception'Identity); */
1431 if (Present (local_raise))
1433 tree gnu_local_raise
1434 = gnat_to_gnu_entity (local_raise, NULL_TREE, 0);
1435 tree gnu_exception_entity
1436 = gnat_to_gnu_entity (Get_RT_Exception_Entity (msg), NULL_TREE, 0);
1438 = build_call_1_expr (gnu_local_raise,
1439 build_unary_op (ADDR_EXPR, NULL_TREE,
1440 gnu_exception_entity));
1442 gnu_result = build2 (COMPOUND_EXPR, void_type_node,
1443 gnu_call, gnu_result);}
1449 = (Debug_Flag_NN || Exception_Locations_Suppressed)
1451 : (gnat_node != Empty && Sloc (gnat_node) != No_Location)
1452 ? IDENTIFIER_POINTER
1453 (get_identifier (Get_Name_String
1455 (Get_Source_File_Index (Sloc (gnat_node))))))
1459 filename = build_string (len, str);
1461 = (gnat_node != Empty && Sloc (gnat_node) != No_Location)
1462 ? Get_Logical_Line_Number (Sloc(gnat_node)) : input_line;
1464 TREE_TYPE (filename)
1465 = build_array_type (char_type_node, build_index_type (size_int (len)));
1468 build_call_2_expr (fndecl,
1469 build1 (ADDR_EXPR, build_pointer_type (char_type_node),
1471 build_int_cst (NULL_TREE, line_number));
1474 /* qsort comparer for the bit positions of two constructor elements
1475 for record components. */
1478 compare_elmt_bitpos (const PTR rt1, const PTR rt2)
1480 const_tree const elmt1 = * (const_tree const *) rt1;
1481 const_tree const elmt2 = * (const_tree const *) rt2;
1482 const_tree const field1 = TREE_PURPOSE (elmt1);
1483 const_tree const field2 = TREE_PURPOSE (elmt2);
1485 = tree_int_cst_compare (bit_position (field1), bit_position (field2));
1487 return ret ? ret : (int) (DECL_UID (field1) - DECL_UID (field2));
1490 /* Return a CONSTRUCTOR of TYPE whose list is LIST. */
1493 gnat_build_constructor (tree type, tree list)
1495 bool allconstant = (TREE_CODE (TYPE_SIZE (type)) == INTEGER_CST);
1496 bool side_effects = false;
1500 /* Scan the elements to see if they are all constant or if any has side
1501 effects, to let us set global flags on the resulting constructor. Count
1502 the elements along the way for possible sorting purposes below. */
1503 for (n_elmts = 0, elmt = list; elmt; elmt = TREE_CHAIN (elmt), n_elmts ++)
1505 tree obj = TREE_PURPOSE (elmt);
1506 tree val = TREE_VALUE (elmt);
1508 /* The predicate must be in keeping with output_constructor. */
1509 if (!TREE_CONSTANT (val)
1510 || (TREE_CODE (type) == RECORD_TYPE
1511 && CONSTRUCTOR_BITFIELD_P (obj)
1512 && !initializer_constant_valid_for_bitfield_p (val))
1513 || !initializer_constant_valid_p (val, TREE_TYPE (val)))
1514 allconstant = false;
1516 if (TREE_SIDE_EFFECTS (val))
1517 side_effects = true;
1520 /* For record types with constant components only, sort field list
1521 by increasing bit position. This is necessary to ensure the
1522 constructor can be output as static data. */
1523 if (allconstant && TREE_CODE (type) == RECORD_TYPE && n_elmts > 1)
1525 /* Fill an array with an element tree per index, and ask qsort to order
1526 them according to what a bitpos comparison function says. */
1527 tree *gnu_arr = (tree *) alloca (sizeof (tree) * n_elmts);
1530 for (i = 0, elmt = list; elmt; elmt = TREE_CHAIN (elmt), i++)
1533 qsort (gnu_arr, n_elmts, sizeof (tree), compare_elmt_bitpos);
1535 /* Then reconstruct the list from the sorted array contents. */
1537 for (i = n_elmts - 1; i >= 0; i--)
1539 TREE_CHAIN (gnu_arr[i]) = list;
1544 result = build_constructor_from_list (type, list);
1545 TREE_CONSTANT (result) = TREE_STATIC (result) = allconstant;
1546 TREE_SIDE_EFFECTS (result) = side_effects;
1547 TREE_READONLY (result) = TYPE_READONLY (type) || allconstant;
1551 /* Return a COMPONENT_REF to access a field that is given by COMPONENT,
1552 an IDENTIFIER_NODE giving the name of the field, or FIELD, a FIELD_DECL,
1553 for the field. Don't fold the result if NO_FOLD_P is true.
1555 We also handle the fact that we might have been passed a pointer to the
1556 actual record and know how to look for fields in variant parts. */
1559 build_simple_component_ref (tree record_variable, tree component,
1560 tree field, bool no_fold_p)
1562 tree record_type = TYPE_MAIN_VARIANT (TREE_TYPE (record_variable));
1563 tree ref, inner_variable;
1565 gcc_assert ((TREE_CODE (record_type) == RECORD_TYPE
1566 || TREE_CODE (record_type) == UNION_TYPE
1567 || TREE_CODE (record_type) == QUAL_UNION_TYPE)
1568 && TYPE_SIZE (record_type)
1569 && (component != 0) != (field != 0));
1571 /* If no field was specified, look for a field with the specified name
1572 in the current record only. */
1574 for (field = TYPE_FIELDS (record_type); field;
1575 field = TREE_CHAIN (field))
1576 if (DECL_NAME (field) == component)
1582 /* If this field is not in the specified record, see if we can find
1583 something in the record whose original field is the same as this one. */
1584 if (DECL_CONTEXT (field) != record_type)
1585 /* Check if there is a field with name COMPONENT in the record. */
1589 /* First loop thru normal components. */
1590 for (new_field = TYPE_FIELDS (record_type); new_field;
1591 new_field = TREE_CHAIN (new_field))
1592 if (SAME_FIELD_P (field, new_field))
1595 /* Next, loop thru DECL_INTERNAL_P components if we haven't found
1596 the component in the first search. Doing this search in 2 steps
1597 is required to avoiding hidden homonymous fields in the
1600 for (new_field = TYPE_FIELDS (record_type); new_field;
1601 new_field = TREE_CHAIN (new_field))
1602 if (DECL_INTERNAL_P (new_field))
1605 = build_simple_component_ref (record_variable,
1606 NULL_TREE, new_field, no_fold_p);
1607 ref = build_simple_component_ref (field_ref, NULL_TREE, field,
1620 /* If the field's offset has overflowed, do not attempt to access it
1621 as doing so may trigger sanity checks deeper in the back-end.
1622 Note that we don't need to warn since this will be done on trying
1623 to declare the object. */
1624 if (TREE_CODE (DECL_FIELD_OFFSET (field)) == INTEGER_CST
1625 && TREE_OVERFLOW (DECL_FIELD_OFFSET (field)))
1628 /* Look through conversion between type variants. Note that this
1629 is transparent as far as the field is concerned. */
1630 if (TREE_CODE (record_variable) == VIEW_CONVERT_EXPR
1631 && TYPE_MAIN_VARIANT (TREE_TYPE (TREE_OPERAND (record_variable, 0)))
1633 inner_variable = TREE_OPERAND (record_variable, 0);
1635 inner_variable = record_variable;
1637 ref = build3 (COMPONENT_REF, TREE_TYPE (field), inner_variable, field,
1640 if (TREE_READONLY (record_variable) || TREE_READONLY (field))
1641 TREE_READONLY (ref) = 1;
1642 if (TREE_THIS_VOLATILE (record_variable) || TREE_THIS_VOLATILE (field)
1643 || TYPE_VOLATILE (record_type))
1644 TREE_THIS_VOLATILE (ref) = 1;
1649 /* The generic folder may punt in this case because the inner array type
1650 can be self-referential, but folding is in fact not problematic. */
1651 else if (TREE_CODE (record_variable) == CONSTRUCTOR
1652 && TYPE_CONTAINS_TEMPLATE_P (TREE_TYPE (record_variable)))
1654 VEC(constructor_elt,gc) *elts = CONSTRUCTOR_ELTS (record_variable);
1655 unsigned HOST_WIDE_INT idx;
1657 FOR_EACH_CONSTRUCTOR_ELT (elts, idx, index, value)
1667 /* Like build_simple_component_ref, except that we give an error if the
1668 reference could not be found. */
1671 build_component_ref (tree record_variable, tree component,
1672 tree field, bool no_fold_p)
1674 tree ref = build_simple_component_ref (record_variable, component, field,
1680 /* If FIELD was specified, assume this is an invalid user field so raise
1681 Constraint_Error. Otherwise, we have no type to return so abort. */
1683 return build1 (NULL_EXPR, TREE_TYPE (field),
1684 build_call_raise (CE_Discriminant_Check_Failed, Empty,
1685 N_Raise_Constraint_Error));
1688 /* Helper for build_call_alloc_dealloc, with arguments to be interpreted
1689 identically. Process the case where a GNAT_PROC to call is provided. */
1692 build_call_alloc_dealloc_proc (tree gnu_obj, tree gnu_size, tree gnu_type,
1693 Entity_Id gnat_proc, Entity_Id gnat_pool)
1695 tree gnu_proc = gnat_to_gnu (gnat_proc);
1696 tree gnu_proc_addr = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_proc);
1699 /* The storage pools are obviously always tagged types, but the
1700 secondary stack uses the same mechanism and is not tagged. */
1701 if (Is_Tagged_Type (Etype (gnat_pool)))
1703 /* The size is the third parameter; the alignment is the
1705 Entity_Id gnat_size_type
1706 = Etype (Next_Formal (Next_Formal (First_Formal (gnat_proc))));
1707 tree gnu_size_type = gnat_to_gnu_type (gnat_size_type);
1709 tree gnu_pool = gnat_to_gnu (gnat_pool);
1710 tree gnu_pool_addr = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_pool);
1711 tree gnu_align = size_int (TYPE_ALIGN (gnu_type) / BITS_PER_UNIT);
1713 gnu_size = convert (gnu_size_type, gnu_size);
1714 gnu_align = convert (gnu_size_type, gnu_align);
1716 /* The first arg is always the address of the storage pool; next
1717 comes the address of the object, for a deallocator, then the
1718 size and alignment. */
1720 gnu_call = build_call_nary (TREE_TYPE (TREE_TYPE (gnu_proc)),
1721 gnu_proc_addr, 4, gnu_pool_addr,
1722 gnu_obj, gnu_size, gnu_align);
1724 gnu_call = build_call_nary (TREE_TYPE (TREE_TYPE (gnu_proc)),
1725 gnu_proc_addr, 3, gnu_pool_addr,
1726 gnu_size, gnu_align);
1729 /* Secondary stack case. */
1732 /* The size is the second parameter. */
1733 Entity_Id gnat_size_type
1734 = Etype (Next_Formal (First_Formal (gnat_proc)));
1735 tree gnu_size_type = gnat_to_gnu_type (gnat_size_type);
1737 gnu_size = convert (gnu_size_type, gnu_size);
1739 /* The first arg is the address of the object, for a deallocator,
1742 gnu_call = build_call_nary (TREE_TYPE (TREE_TYPE (gnu_proc)),
1743 gnu_proc_addr, 2, gnu_obj, gnu_size);
1745 gnu_call = build_call_nary (TREE_TYPE (TREE_TYPE (gnu_proc)),
1746 gnu_proc_addr, 1, gnu_size);
1749 TREE_SIDE_EFFECTS (gnu_call) = 1;
1753 /* Helper for build_call_alloc_dealloc, to build and return an allocator for
1754 DATA_SIZE bytes aimed at containing a DATA_TYPE object, using the default
1755 __gnat_malloc allocator. Honor DATA_TYPE alignments greater than what the
1759 maybe_wrap_malloc (tree data_size, tree data_type, Node_Id gnat_node)
1761 /* When the DATA_TYPE alignment is stricter than what malloc offers
1762 (super-aligned case), we allocate an "aligning" wrapper type and return
1763 the address of its single data field with the malloc's return value
1764 stored just in front. */
1766 unsigned int data_align = TYPE_ALIGN (data_type);
1767 unsigned int default_allocator_alignment
1768 = get_target_default_allocator_alignment () * BITS_PER_UNIT;
1771 = ((data_align > default_allocator_alignment)
1772 ? make_aligning_type (data_type, data_align, data_size,
1773 default_allocator_alignment,
1774 POINTER_SIZE / BITS_PER_UNIT)
1778 = aligning_type ? TYPE_SIZE_UNIT (aligning_type) : data_size;
1782 /* On VMS, if 64-bit memory is disabled or pointers are 64-bit and the
1783 allocator size is 32-bit or Convention C, allocate 32-bit memory. */
1784 if (TARGET_ABI_OPEN_VMS
1785 && (!TARGET_MALLOC64
1786 || (POINTER_SIZE == 64
1787 && (UI_To_Int (Esize (Etype (gnat_node))) == 32
1788 || Convention (Etype (gnat_node)) == Convention_C))))
1789 malloc_ptr = build_call_1_expr (malloc32_decl, size_to_malloc);
1791 malloc_ptr = build_call_1_expr (malloc_decl, size_to_malloc);
1795 /* Latch malloc's return value and get a pointer to the aligning field
1797 tree storage_ptr = gnat_protect_expr (malloc_ptr);
1799 tree aligning_record_addr
1800 = convert (build_pointer_type (aligning_type), storage_ptr);
1802 tree aligning_record
1803 = build_unary_op (INDIRECT_REF, NULL_TREE, aligning_record_addr);
1806 = build_component_ref (aligning_record, NULL_TREE,
1807 TYPE_FIELDS (aligning_type), false);
1809 tree aligning_field_addr
1810 = build_unary_op (ADDR_EXPR, NULL_TREE, aligning_field);
1812 /* Then arrange to store the allocator's return value ahead
1814 tree storage_ptr_slot_addr
1815 = build_binary_op (POINTER_PLUS_EXPR, ptr_void_type_node,
1816 convert (ptr_void_type_node, aligning_field_addr),
1817 size_int (-(HOST_WIDE_INT) POINTER_SIZE
1820 tree storage_ptr_slot
1821 = build_unary_op (INDIRECT_REF, NULL_TREE,
1822 convert (build_pointer_type (ptr_void_type_node),
1823 storage_ptr_slot_addr));
1826 build2 (COMPOUND_EXPR, TREE_TYPE (aligning_field_addr),
1827 build_binary_op (MODIFY_EXPR, NULL_TREE,
1828 storage_ptr_slot, storage_ptr),
1829 aligning_field_addr);
1835 /* Helper for build_call_alloc_dealloc, to release a DATA_TYPE object
1836 designated by DATA_PTR using the __gnat_free entry point. */
1839 maybe_wrap_free (tree data_ptr, tree data_type)
1841 /* In the regular alignment case, we pass the data pointer straight to free.
1842 In the superaligned case, we need to retrieve the initial allocator
1843 return value, stored in front of the data block at allocation time. */
1845 unsigned int data_align = TYPE_ALIGN (data_type);
1846 unsigned int default_allocator_alignment
1847 = get_target_default_allocator_alignment () * BITS_PER_UNIT;
1851 if (data_align > default_allocator_alignment)
1853 /* DATA_FRONT_PTR (void *)
1854 = (void *)DATA_PTR - (void *)sizeof (void *)) */
1857 (POINTER_PLUS_EXPR, ptr_void_type_node,
1858 convert (ptr_void_type_node, data_ptr),
1859 size_int (-(HOST_WIDE_INT) POINTER_SIZE / BITS_PER_UNIT));
1861 /* FREE_PTR (void *) = *(void **)DATA_FRONT_PTR */
1864 (INDIRECT_REF, NULL_TREE,
1865 convert (build_pointer_type (ptr_void_type_node), data_front_ptr));
1868 free_ptr = data_ptr;
1870 return build_call_1_expr (free_decl, free_ptr);
1873 /* Build a GCC tree to call an allocation or deallocation function.
1874 If GNU_OBJ is nonzero, it is an object to deallocate. Otherwise,
1875 generate an allocator.
1877 GNU_SIZE is the number of bytes to allocate and GNU_TYPE is the contained
1878 object type, used to determine the to-be-honored address alignment.
1879 GNAT_PROC, if present, is a procedure to call and GNAT_POOL is the storage
1880 pool to use. If not present, malloc and free are used. GNAT_NODE is used
1881 to provide an error location for restriction violation messages. */
1884 build_call_alloc_dealloc (tree gnu_obj, tree gnu_size, tree gnu_type,
1885 Entity_Id gnat_proc, Entity_Id gnat_pool,
1888 gnu_size = SUBSTITUTE_PLACEHOLDER_IN_EXPR (gnu_size, gnu_obj);
1890 /* Explicit proc to call ? This one is assumed to deal with the type
1891 alignment constraints. */
1892 if (Present (gnat_proc))
1893 return build_call_alloc_dealloc_proc (gnu_obj, gnu_size, gnu_type,
1894 gnat_proc, gnat_pool);
1896 /* Otherwise, object to "free" or "malloc" with possible special processing
1897 for alignments stricter than what the default allocator honors. */
1899 return maybe_wrap_free (gnu_obj, gnu_type);
1902 /* Assert that we no longer can be called with this special pool. */
1903 gcc_assert (gnat_pool != -1);
1905 /* Check that we aren't violating the associated restriction. */
1906 if (!(Nkind (gnat_node) == N_Allocator && Comes_From_Source (gnat_node)))
1907 Check_No_Implicit_Heap_Alloc (gnat_node);
1909 return maybe_wrap_malloc (gnu_size, gnu_type, gnat_node);
1913 /* Build a GCC tree to correspond to allocating an object of TYPE whose
1914 initial value is INIT, if INIT is nonzero. Convert the expression to
1915 RESULT_TYPE, which must be some type of pointer. Return the tree.
1917 GNAT_PROC and GNAT_POOL optionally give the procedure to call and
1918 the storage pool to use. GNAT_NODE is used to provide an error
1919 location for restriction violation messages. If IGNORE_INIT_TYPE is
1920 true, ignore the type of INIT for the purpose of determining the size;
1921 this will cause the maximum size to be allocated if TYPE is of
1922 self-referential size. */
1925 build_allocator (tree type, tree init, tree result_type, Entity_Id gnat_proc,
1926 Entity_Id gnat_pool, Node_Id gnat_node, bool ignore_init_type)
1928 tree size = TYPE_SIZE_UNIT (type);
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_IS_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, storage_type,
1957 gnat_proc, gnat_pool, gnat_node);
1958 storage = convert (storage_ptr_type, gnat_protect_expr (storage));
1960 if (TYPE_IS_PADDING_P (type))
1962 type = TREE_TYPE (TYPE_FIELDS (type));
1964 init = convert (type, init);
1967 /* If there is an initializing expression, make a constructor for
1968 the entire object including the bounds and copy it into the
1969 object. If there is no initializing expression, just set the
1973 template_cons = tree_cons (TREE_CHAIN (TYPE_FIELDS (storage_type)),
1975 template_cons = tree_cons (TYPE_FIELDS (storage_type),
1976 build_template (template_type, type,
1982 build2 (COMPOUND_EXPR, storage_ptr_type,
1984 (MODIFY_EXPR, storage_type,
1985 build_unary_op (INDIRECT_REF, NULL_TREE,
1986 convert (storage_ptr_type, storage)),
1987 gnat_build_constructor (storage_type, template_cons)),
1988 convert (storage_ptr_type, storage)));
1992 (COMPOUND_EXPR, result_type,
1994 (MODIFY_EXPR, template_type,
1996 (build_unary_op (INDIRECT_REF, NULL_TREE,
1997 convert (storage_ptr_type, storage)),
1998 NULL_TREE, TYPE_FIELDS (storage_type), false),
1999 build_template (template_type, type, NULL_TREE)),
2000 convert (result_type, convert (storage_ptr_type, storage)));
2003 /* If we have an initializing expression, see if its size is simpler
2004 than the size from the type. */
2005 if (!ignore_init_type && init && TYPE_SIZE_UNIT (TREE_TYPE (init))
2006 && (TREE_CODE (TYPE_SIZE_UNIT (TREE_TYPE (init))) == INTEGER_CST
2007 || CONTAINS_PLACEHOLDER_P (size)))
2008 size = TYPE_SIZE_UNIT (TREE_TYPE (init));
2010 /* If the size is still self-referential, reference the initializing
2011 expression, if it is present. If not, this must have been a
2012 call to allocate a library-level object, in which case we use
2013 the maximum size. */
2014 if (CONTAINS_PLACEHOLDER_P (size))
2016 if (!ignore_init_type && init)
2017 size = substitute_placeholder_in_expr (size, init);
2019 size = max_size (size, true);
2022 /* If the size overflows, pass -1 so the allocator will raise
2024 if (TREE_CODE (size) == INTEGER_CST && TREE_OVERFLOW (size))
2025 size = ssize_int (-1);
2027 result = convert (result_type,
2028 build_call_alloc_dealloc (NULL_TREE, size, type,
2029 gnat_proc, gnat_pool,
2032 /* If we have an initial value, protect the new address, assign the value
2033 and return the address with a COMPOUND_EXPR. */
2036 result = gnat_protect_expr (result);
2038 = build2 (COMPOUND_EXPR, TREE_TYPE (result),
2040 (MODIFY_EXPR, NULL_TREE,
2041 build_unary_op (INDIRECT_REF,
2042 TREE_TYPE (TREE_TYPE (result)), result),
2047 return convert (result_type, result);
2050 /* Fill in a VMS descriptor for EXPR and return a constructor for it.
2051 GNAT_FORMAL is how we find the descriptor record. GNAT_ACTUAL is
2052 how we derive the source location to raise C_E on an out of range
2056 fill_vms_descriptor (tree expr, Entity_Id gnat_formal, Node_Id gnat_actual)
2059 tree parm_decl = get_gnu_tree (gnat_formal);
2060 tree const_list = NULL_TREE;
2061 tree record_type = TREE_TYPE (TREE_TYPE (parm_decl));
2062 int do_range_check =
2064 IDENTIFIER_POINTER (DECL_NAME (TYPE_FIELDS (record_type))));
2066 expr = maybe_unconstrained_array (expr);
2067 gnat_mark_addressable (expr);
2069 for (field = TYPE_FIELDS (record_type); field; field = TREE_CHAIN (field))
2071 tree conexpr = convert (TREE_TYPE (field),
2072 SUBSTITUTE_PLACEHOLDER_IN_EXPR
2073 (DECL_INITIAL (field), expr));
2075 /* Check to ensure that only 32bit pointers are passed in
2076 32bit descriptors */
2077 if (do_range_check &&
2078 strcmp (IDENTIFIER_POINTER (DECL_NAME (field)), "POINTER") == 0)
2080 tree pointer64type =
2081 build_pointer_type_for_mode (void_type_node, DImode, false);
2082 tree addr64expr = build_unary_op (ADDR_EXPR, pointer64type, expr);
2084 build_int_cstu (long_integer_type_node, 0x80000000);
2086 add_stmt (build3 (COND_EXPR, void_type_node,
2087 build_binary_op (GE_EXPR, long_integer_type_node,
2088 convert (long_integer_type_node,
2091 build_call_raise (CE_Range_Check_Failed, gnat_actual,
2092 N_Raise_Constraint_Error),
2095 const_list = tree_cons (field, conexpr, const_list);
2098 return gnat_build_constructor (record_type, nreverse (const_list));
2101 /* Indicate that we need to take the address of T and that it therefore
2102 should not be allocated in a register. Returns true if successful. */
2105 gnat_mark_addressable (tree t)
2108 switch (TREE_CODE (t))
2113 case ARRAY_RANGE_REF:
2116 case VIEW_CONVERT_EXPR:
2117 case NON_LVALUE_EXPR:
2119 t = TREE_OPERAND (t, 0);
2123 TREE_ADDRESSABLE (t) = 1;
2129 TREE_ADDRESSABLE (t) = 1;
2133 TREE_ADDRESSABLE (t) = 1;
2137 return DECL_CONST_CORRESPONDING_VAR (t)
2138 && gnat_mark_addressable (DECL_CONST_CORRESPONDING_VAR (t));
2145 /* Save EXP for later use or reuse. This is equivalent to save_expr in tree.c
2146 but we know how to handle our own nodes. */
2149 gnat_save_expr (tree exp)
2151 tree type = TREE_TYPE (exp);
2152 enum tree_code code = TREE_CODE (exp);
2154 if (TREE_CONSTANT (exp) || code == SAVE_EXPR || code == NULL_EXPR)
2157 if (code == UNCONSTRAINED_ARRAY_REF)
2159 tree t = build1 (code, type, gnat_save_expr (TREE_OPERAND (exp, 0)));
2160 TREE_READONLY (t) = TYPE_READONLY (type);
2164 /* If this is a COMPONENT_REF of a fat pointer, save the entire fat pointer.
2165 This may be more efficient, but will also allow us to more easily find
2166 the match for the PLACEHOLDER_EXPR. */
2167 if (code == COMPONENT_REF
2168 && TYPE_IS_FAT_POINTER_P (TREE_TYPE (TREE_OPERAND (exp, 0))))
2169 return build3 (code, type, gnat_save_expr (TREE_OPERAND (exp, 0)),
2170 TREE_OPERAND (exp, 1), TREE_OPERAND (exp, 2));
2172 return save_expr (exp);
2175 /* Protect EXP for immediate reuse. This is a variant of gnat_save_expr that
2176 is optimized under the assumption that EXP's value doesn't change before
2177 its subsequent reuse(s) except through its potential reevaluation. */
2180 gnat_protect_expr (tree exp)
2182 tree type = TREE_TYPE (exp);
2183 enum tree_code code = TREE_CODE (exp);
2185 if (TREE_CONSTANT (exp) || code == SAVE_EXPR || code == NULL_EXPR)
2188 /* If EXP has no side effects, we theoritically don't need to do anything.
2189 However, we may be recursively passed more and more complex expressions
2190 involving checks which will be reused multiple times and eventually be
2191 unshared for gimplification; in order to avoid a complexity explosion
2192 at that point, we protect any expressions more complex than a simple
2193 arithmetic expression. */
2194 if (!TREE_SIDE_EFFECTS (exp)
2195 && !EXPRESSION_CLASS_P (skip_simple_arithmetic (exp)))
2198 /* If this is a conversion, protect what's inside the conversion. */
2199 if (code == NON_LVALUE_EXPR
2200 || CONVERT_EXPR_CODE_P (code)
2201 || code == VIEW_CONVERT_EXPR)
2202 return build1 (code, type, gnat_protect_expr (TREE_OPERAND (exp, 0)));
2204 /* If we're indirectly referencing something, we only need to protect the
2205 address since the data itself can't change in these situations. */
2206 if (code == INDIRECT_REF || code == UNCONSTRAINED_ARRAY_REF)
2208 tree t = build1 (code, type, gnat_protect_expr (TREE_OPERAND (exp, 0)));
2209 TREE_READONLY (t) = TYPE_READONLY (type);
2213 /* If this is a COMPONENT_REF of a fat pointer, save the entire fat pointer.
2214 This may be more efficient, but will also allow us to more easily find
2215 the match for the PLACEHOLDER_EXPR. */
2216 if (code == COMPONENT_REF
2217 && TYPE_IS_FAT_POINTER_P (TREE_TYPE (TREE_OPERAND (exp, 0))))
2218 return build3 (code, type, gnat_protect_expr (TREE_OPERAND (exp, 0)),
2219 TREE_OPERAND (exp, 1), TREE_OPERAND (exp, 2));
2221 /* If this is a fat pointer or something that can be placed in a register,
2222 just make a SAVE_EXPR. Likewise for a CALL_EXPR as large objects are
2223 returned via invisible reference in most ABIs so the temporary will
2224 directly be filled by the callee. */
2225 if (TYPE_IS_FAT_POINTER_P (type)
2226 || TYPE_MODE (type) != BLKmode
2227 || code == CALL_EXPR)
2228 return save_expr (exp);
2230 /* Otherwise reference, protect the address and dereference. */
2232 build_unary_op (INDIRECT_REF, type,
2233 save_expr (build_unary_op (ADDR_EXPR,
2234 build_reference_type (type),
2238 /* This is equivalent to stabilize_reference_1 in tree.c but we take an extra
2239 argument to force evaluation of everything. */
2242 gnat_stabilize_reference_1 (tree e, bool force)
2244 enum tree_code code = TREE_CODE (e);
2245 tree type = TREE_TYPE (e);
2248 /* We cannot ignore const expressions because it might be a reference
2249 to a const array but whose index contains side-effects. But we can
2250 ignore things that are actual constant or that already have been
2251 handled by this function. */
2252 if (TREE_CONSTANT (e) || code == SAVE_EXPR)
2255 switch (TREE_CODE_CLASS (code))
2257 case tcc_exceptional:
2258 case tcc_declaration:
2259 case tcc_comparison:
2260 case tcc_expression:
2263 /* If this is a COMPONENT_REF of a fat pointer, save the entire
2264 fat pointer. This may be more efficient, but will also allow
2265 us to more easily find the match for the PLACEHOLDER_EXPR. */
2266 if (code == COMPONENT_REF
2267 && TYPE_IS_FAT_POINTER_P (TREE_TYPE (TREE_OPERAND (e, 0))))
2269 = build3 (code, type,
2270 gnat_stabilize_reference_1 (TREE_OPERAND (e, 0), force),
2271 TREE_OPERAND (e, 1), TREE_OPERAND (e, 2));
2272 /* If the expression has side-effects, then encase it in a SAVE_EXPR
2273 so that it will only be evaluated once. */
2274 /* The tcc_reference and tcc_comparison classes could be handled as
2275 below, but it is generally faster to only evaluate them once. */
2276 else if (TREE_SIDE_EFFECTS (e) || force)
2277 return save_expr (e);
2283 /* Recursively stabilize each operand. */
2285 = build2 (code, type,
2286 gnat_stabilize_reference_1 (TREE_OPERAND (e, 0), force),
2287 gnat_stabilize_reference_1 (TREE_OPERAND (e, 1), force));
2291 /* Recursively stabilize each operand. */
2293 = build1 (code, type,
2294 gnat_stabilize_reference_1 (TREE_OPERAND (e, 0), force));
2301 /* See similar handling in gnat_stabilize_reference. */
2302 TREE_READONLY (result) = TREE_READONLY (e);
2303 TREE_SIDE_EFFECTS (result) |= TREE_SIDE_EFFECTS (e);
2304 TREE_THIS_VOLATILE (result) = TREE_THIS_VOLATILE (e);
2309 /* This is equivalent to stabilize_reference in tree.c but we know how to
2310 handle our own nodes and we take extra arguments. FORCE says whether to
2311 force evaluation of everything. We set SUCCESS to true unless we walk
2312 through something we don't know how to stabilize. */
2315 gnat_stabilize_reference (tree ref, bool force, bool *success)
2317 tree type = TREE_TYPE (ref);
2318 enum tree_code code = TREE_CODE (ref);
2321 /* Assume we'll success unless proven otherwise. */
2331 /* No action is needed in this case. */
2337 case FIX_TRUNC_EXPR:
2338 case VIEW_CONVERT_EXPR:
2340 = build1 (code, type,
2341 gnat_stabilize_reference (TREE_OPERAND (ref, 0), force,
2346 case UNCONSTRAINED_ARRAY_REF:
2347 result = build1 (code, type,
2348 gnat_stabilize_reference_1 (TREE_OPERAND (ref, 0),
2353 result = build3 (COMPONENT_REF, type,
2354 gnat_stabilize_reference (TREE_OPERAND (ref, 0), force,
2356 TREE_OPERAND (ref, 1), NULL_TREE);
2360 result = build3 (BIT_FIELD_REF, type,
2361 gnat_stabilize_reference (TREE_OPERAND (ref, 0), force,
2363 gnat_stabilize_reference_1 (TREE_OPERAND (ref, 1),
2365 gnat_stabilize_reference_1 (TREE_OPERAND (ref, 2),
2370 case ARRAY_RANGE_REF:
2371 result = build4 (code, type,
2372 gnat_stabilize_reference (TREE_OPERAND (ref, 0), force,
2374 gnat_stabilize_reference_1 (TREE_OPERAND (ref, 1),
2376 NULL_TREE, NULL_TREE);
2381 result = gnat_stabilize_reference_1 (ref, force);
2385 /* Constructors with 1 element are used extensively to formally
2386 convert objects to special wrapping types. */
2387 if (TREE_CODE (type) == RECORD_TYPE
2388 && VEC_length (constructor_elt, CONSTRUCTOR_ELTS (ref)) == 1)
2391 = VEC_index (constructor_elt, CONSTRUCTOR_ELTS (ref), 0)->index;
2393 = VEC_index (constructor_elt, CONSTRUCTOR_ELTS (ref), 0)->value;
2395 = build_constructor_single (type, index,
2396 gnat_stabilize_reference_1 (value,
2408 ref = error_mark_node;
2410 /* ... fall through to failure ... */
2412 /* If arg isn't a kind of lvalue we recognize, make no change.
2413 Caller should recognize the error for an invalid lvalue. */
2420 /* TREE_THIS_VOLATILE and TREE_SIDE_EFFECTS set on the initial expression
2421 may not be sustained across some paths, such as the way via build1 for
2422 INDIRECT_REF. We reset those flags here in the general case, which is
2423 consistent with the GCC version of this routine.
2425 Special care should be taken regarding TREE_SIDE_EFFECTS, because some
2426 paths introduce side-effects where there was none initially (e.g. if a
2427 SAVE_EXPR is built) and we also want to keep track of that. */
2428 TREE_READONLY (result) = TREE_READONLY (ref);
2429 TREE_SIDE_EFFECTS (result) |= TREE_SIDE_EFFECTS (ref);
2430 TREE_THIS_VOLATILE (result) = TREE_THIS_VOLATILE (ref);