OSDN Git Service

33f3a613f60b9416ec7c09e8576670e5ce9ceec7
[pf3gnuchains/gcc-fork.git] / gcc / ada / gcc-interface / utils2.c
1 /****************************************************************************
2  *                                                                          *
3  *                         GNAT COMPILER COMPONENTS                         *
4  *                                                                          *
5  *                               U T I L S 2                                *
6  *                                                                          *
7  *                          C Implementation File                           *
8  *                                                                          *
9  *          Copyright (C) 1992-2010, Free Software Foundation, Inc.         *
10  *                                                                          *
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/>.                                          *
20  *                                                                          *
21  * GNAT was originally developed  by the GNAT team at  New York University. *
22  * Extensive contributions were provided by Ada Core Technologies Inc.      *
23  *                                                                          *
24  ****************************************************************************/
25
26 #include "config.h"
27 #include "system.h"
28 #include "coretypes.h"
29 #include "tm.h"
30 #include "tree.h"
31 #include "ggc.h"
32 #include "flags.h"
33 #include "output.h"
34 #include "tree-inline.h"
35
36 #include "ada.h"
37 #include "types.h"
38 #include "atree.h"
39 #include "elists.h"
40 #include "namet.h"
41 #include "nlists.h"
42 #include "snames.h"
43 #include "stringt.h"
44 #include "uintp.h"
45 #include "fe.h"
46 #include "sinfo.h"
47 #include "einfo.h"
48 #include "ada-tree.h"
49 #include "gigi.h"
50
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);
55 \f
56 /* Return the base type of TYPE.  */
57
58 tree
59 get_base_type (tree type)
60 {
61   if (TREE_CODE (type) == RECORD_TYPE
62       && TYPE_JUSTIFIED_MODULAR_P (type))
63     type = TREE_TYPE (TYPE_FIELDS (type));
64
65   while (TREE_TYPE (type)
66          && (TREE_CODE (type) == INTEGER_TYPE
67              || TREE_CODE (type) == REAL_TYPE))
68     type = TREE_TYPE (type);
69
70   return type;
71 }
72 \f
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.  */
76
77 unsigned int
78 known_alignment (tree exp)
79 {
80   unsigned int this_alignment;
81   unsigned int lhs, rhs;
82
83   switch (TREE_CODE (exp))
84     {
85     CASE_CONVERT:
86     case VIEW_CONVERT_EXPR:
87     case NON_LVALUE_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));
91       break;
92
93     case COMPOUND_EXPR:
94       /* The value of a COMPOUND_EXPR is that of it's second operand.  */
95       this_alignment = known_alignment (TREE_OPERAND (exp, 1));
96       break;
97
98     case PLUS_EXPR:
99     case MINUS_EXPR:
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);
105       break;
106
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
111          of the base.  */
112       if (rhs == 0)
113         this_alignment = lhs;
114       else
115         this_alignment = MIN (lhs, rhs);
116       break;
117
118     case COND_EXPR:
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);
123       break;
124
125     case INTEGER_CST:
126       {
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);
131       }
132       break;
133
134     case MULT_EXPR:
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));
139
140       if (lhs == 0)
141         this_alignment = rhs;
142       else if (rhs == 0)
143         this_alignment = lhs;
144       else
145         this_alignment = MIN (lhs * rhs, BIGGEST_ALIGNMENT);
146       break;
147
148     case BIT_AND_EXPR:
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));
154       break;
155
156     case ADDR_EXPR:
157       this_alignment = expr_align (TREE_OPERAND (exp, 0));
158       break;
159
160     case CALL_EXPR:
161       {
162         tree t = maybe_inline_call_in_expr (exp);
163         if (t)
164           return known_alignment (t);
165       }
166
167       /* Fall through... */
168
169     default:
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)));
177       else
178         this_alignment = 0;
179       break;
180     }
181
182   return this_alignment;
183 }
184 \f
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.  */
190
191 static tree
192 find_common_type (tree t1, tree t2)
193 {
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.  */
200
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))))
210     return t1;
211
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)
216     return t1;
217
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
220      lhs type is not.  */
221   if (TREE_CONSTANT (TYPE_SIZE (t2)))
222     return t2;
223
224   /* Otherwise, if the rhs type is non-BLKmode, use it.  */
225   if (TYPE_MODE (t2) != BLKmode)
226     return t2;
227
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.  */
231   return NULL_TREE;
232 }
233 \f
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.
236
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.  */
241
242 static tree
243 compare_arrays (tree result_type, tree a1, tree a2)
244 {
245   tree result = convert (result_type, boolean_true_node);
246   tree a1_is_null = convert (result_type, boolean_false_node);
247   tree a2_is_null = convert (result_type, boolean_false_node);
248   tree t1 = TREE_TYPE (a1);
249   tree t2 = TREE_TYPE (a2);
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;
253
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);
258
259   if (a2_side_effects_p)
260     a2 = gnat_protect_expr (a2);
261
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)
266     {
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;
275       tree nbt, tem;
276       bool btem;
277
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))))
284         {
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;
293         }
294
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))))
300         {
301           tree ub = TYPE_MAX_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (t1)));
302           tree lb = TYPE_MIN_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (t1)));
303
304           comparison = build_binary_op (LT_EXPR, result_type, ub, lb);
305           comparison = SUBSTITUTE_PLACEHOLDER_IN_EXPR (comparison, a1);
306           if (EXPR_P (comparison))
307             SET_EXPR_LOCATION (comparison, input_location);
308
309           length1 = SUBSTITUTE_PLACEHOLDER_IN_EXPR (length1, a1);
310
311           length_zero_p = true;
312           this_a1_is_null = comparison;
313           this_a2_is_null = convert (result_type, boolean_true_node);
314         }
315
316       /* If the length is some other constant value, we know that the
317          this dimension in the first array cannot be superflat, so we
318          can just use its length from the actual stored bounds.  */
319       else if (TREE_CODE (length2) == INTEGER_CST)
320         {
321           ub1 = TYPE_MAX_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (t1)));
322           lb1 = TYPE_MIN_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (t1)));
323           /* Note that we know that UB2 and LB2 are constant and hence
324              cannot contain a PLACEHOLDER_EXPR.  */
325           ub2 = TYPE_MAX_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (t2)));
326           lb2 = TYPE_MIN_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (t2)));
327           nbt = get_base_type (TREE_TYPE (ub1));
328
329           comparison
330             = build_binary_op (EQ_EXPR, result_type,
331                                build_binary_op (MINUS_EXPR, nbt, ub1, lb1),
332                                build_binary_op (MINUS_EXPR, nbt, ub2, lb2));
333           comparison = SUBSTITUTE_PLACEHOLDER_IN_EXPR (comparison, a1);
334           if (EXPR_P (comparison))
335             SET_EXPR_LOCATION (comparison, input_location);
336
337           length1 = SUBSTITUTE_PLACEHOLDER_IN_EXPR (length1, a1);
338
339           this_a1_is_null = build_binary_op (LT_EXPR, result_type, ub1, lb1);
340           if (EXPR_P (this_a1_is_null))
341             SET_EXPR_LOCATION (this_a1_is_null, input_location);
342           this_a2_is_null = convert (result_type, boolean_false_node);
343         }
344
345       /* Otherwise compare the computed lengths.  */
346       else
347         {
348           length1 = SUBSTITUTE_PLACEHOLDER_IN_EXPR (length1, a1);
349           length2 = SUBSTITUTE_PLACEHOLDER_IN_EXPR (length2, a2);
350
351           comparison
352             = build_binary_op (EQ_EXPR, result_type, length1, length2);
353           if (EXPR_P (comparison))
354             SET_EXPR_LOCATION (comparison, input_location);
355
356           this_a1_is_null
357             = build_binary_op (LT_EXPR, result_type, length1,
358                                convert (bt, integer_zero_node));
359           if (EXPR_P (this_a1_is_null))
360             SET_EXPR_LOCATION (this_a1_is_null, input_location);
361
362           this_a2_is_null
363             = build_binary_op (LT_EXPR, result_type, length2,
364                                convert (bt, integer_zero_node));
365           if (EXPR_P (this_a2_is_null))
366             SET_EXPR_LOCATION (this_a2_is_null, input_location);
367         }
368
369       result = build_binary_op (TRUTH_ANDIF_EXPR, result_type,
370                                 result, comparison);
371
372       a1_is_null = build_binary_op (TRUTH_ORIF_EXPR, result_type,
373                                     this_a1_is_null, a1_is_null);
374       a2_is_null = build_binary_op (TRUTH_ORIF_EXPR, result_type,
375                                     this_a2_is_null, a2_is_null);
376
377       t1 = TREE_TYPE (t1);
378       t2 = TREE_TYPE (t2);
379     }
380
381   /* Unless the size of some bound is known to be zero, compare the
382      data in the array.  */
383   if (!length_zero_p)
384     {
385       tree type = find_common_type (TREE_TYPE (a1), TREE_TYPE (a2));
386       tree comparison;
387
388       if (type)
389         {
390           a1 = convert (type, a1),
391           a2 = convert (type, a2);
392         }
393
394       comparison = fold_build2 (EQ_EXPR, result_type, a1, a2);
395       if (EXPR_P (comparison))
396         SET_EXPR_LOCATION (comparison, input_location);
397
398       result
399         = build_binary_op (TRUTH_ANDIF_EXPR, result_type, result, comparison);
400     }
401
402   /* The result is also true if both sizes are zero.  */
403   result = build_binary_op (TRUTH_ORIF_EXPR, result_type,
404                             build_binary_op (TRUTH_ANDIF_EXPR, result_type,
405                                              a1_is_null, a2_is_null),
406                             result);
407
408   /* If either operand has side-effects, they have to be evaluated before
409      starting the comparison above since the place they would be otherwise
410      evaluated could be wrong.  */
411   if (a1_side_effects_p)
412     result = build2 (COMPOUND_EXPR, result_type, a1, result);
413
414   if (a2_side_effects_p)
415     result = build2 (COMPOUND_EXPR, result_type, a2, result);
416
417   return result;
418 }
419 \f
420 /* Compute the result of applying OP_CODE to LHS and RHS, where both are of
421    type TYPE.  We know that TYPE is a modular type with a nonbinary
422    modulus.  */
423
424 static tree
425 nonbinary_modular_operation (enum tree_code op_code, tree type, tree lhs,
426                              tree rhs)
427 {
428   tree modulus = TYPE_MODULUS (type);
429   unsigned int needed_precision = tree_floor_log2 (modulus) + 1;
430   unsigned int precision;
431   bool unsignedp = true;
432   tree op_type = type;
433   tree result;
434
435   /* If this is an addition of a constant, convert it to a subtraction
436      of a constant since we can do that faster.  */
437   if (op_code == PLUS_EXPR && TREE_CODE (rhs) == INTEGER_CST)
438     {
439       rhs = fold_build2 (MINUS_EXPR, type, modulus, rhs);
440       op_code = MINUS_EXPR;
441     }
442
443   /* For the logical operations, we only need PRECISION bits.  For
444      addition and subtraction, we need one more and for multiplication we
445      need twice as many.  But we never want to make a size smaller than
446      our size. */
447   if (op_code == PLUS_EXPR || op_code == MINUS_EXPR)
448     needed_precision += 1;
449   else if (op_code == MULT_EXPR)
450     needed_precision *= 2;
451
452   precision = MAX (needed_precision, TYPE_PRECISION (op_type));
453
454   /* Unsigned will do for everything but subtraction.  */
455   if (op_code == MINUS_EXPR)
456     unsignedp = false;
457
458   /* If our type is the wrong signedness or isn't wide enough, make a new
459      type and convert both our operands to it.  */
460   if (TYPE_PRECISION (op_type) < precision
461       || TYPE_UNSIGNED (op_type) != unsignedp)
462     {
463       /* Copy the node so we ensure it can be modified to make it modular.  */
464       op_type = copy_node (gnat_type_for_size (precision, unsignedp));
465       modulus = convert (op_type, modulus);
466       SET_TYPE_MODULUS (op_type, modulus);
467       TYPE_MODULAR_P (op_type) = 1;
468       lhs = convert (op_type, lhs);
469       rhs = convert (op_type, rhs);
470     }
471
472   /* Do the operation, then we'll fix it up.  */
473   result = fold_build2 (op_code, op_type, lhs, rhs);
474
475   /* For multiplication, we have no choice but to do a full modulus
476      operation.  However, we want to do this in the narrowest
477      possible size.  */
478   if (op_code == MULT_EXPR)
479     {
480       tree div_type = copy_node (gnat_type_for_size (needed_precision, 1));
481       modulus = convert (div_type, modulus);
482       SET_TYPE_MODULUS (div_type, modulus);
483       TYPE_MODULAR_P (div_type) = 1;
484       result = convert (op_type,
485                         fold_build2 (TRUNC_MOD_EXPR, div_type,
486                                      convert (div_type, result), modulus));
487     }
488
489   /* For subtraction, add the modulus back if we are negative.  */
490   else if (op_code == MINUS_EXPR)
491     {
492       result = gnat_protect_expr (result);
493       result = fold_build3 (COND_EXPR, op_type,
494                             fold_build2 (LT_EXPR, boolean_type_node, result,
495                                          convert (op_type, integer_zero_node)),
496                             fold_build2 (PLUS_EXPR, op_type, result, modulus),
497                             result);
498     }
499
500   /* For the other operations, subtract the modulus if we are >= it.  */
501   else
502     {
503       result = gnat_protect_expr (result);
504       result = fold_build3 (COND_EXPR, op_type,
505                             fold_build2 (GE_EXPR, boolean_type_node,
506                                          result, modulus),
507                             fold_build2 (MINUS_EXPR, op_type,
508                                          result, modulus),
509                             result);
510     }
511
512   return convert (type, result);
513 }
514 \f
515 /* Make a binary operation of kind OP_CODE.  RESULT_TYPE is the type
516    desired for the result.  Usually the operation is to be performed
517    in that type.  For MODIFY_EXPR and ARRAY_REF, RESULT_TYPE may be 0
518    in which case the type to be used will be derived from the operands.
519
520    This function is very much unlike the ones for C and C++ since we
521    have already done any type conversion and matching required.  All we
522    have to do here is validate the work done by SEM and handle subtypes.  */
523
524 tree
525 build_binary_op (enum tree_code op_code, tree result_type,
526                  tree left_operand, tree right_operand)
527 {
528   tree left_type  = TREE_TYPE (left_operand);
529   tree right_type = TREE_TYPE (right_operand);
530   tree left_base_type = get_base_type (left_type);
531   tree right_base_type = get_base_type (right_type);
532   tree operation_type = result_type;
533   tree best_type = NULL_TREE;
534   tree modulus, result;
535   bool has_side_effects = false;
536
537   if (operation_type
538       && TREE_CODE (operation_type) == RECORD_TYPE
539       && TYPE_JUSTIFIED_MODULAR_P (operation_type))
540     operation_type = TREE_TYPE (TYPE_FIELDS (operation_type));
541
542   if (operation_type
543       && !AGGREGATE_TYPE_P (operation_type)
544       && TYPE_EXTRA_SUBTYPE_P (operation_type))
545     operation_type = get_base_type (operation_type);
546
547   modulus = (operation_type
548              && TREE_CODE (operation_type) == INTEGER_TYPE
549              && TYPE_MODULAR_P (operation_type)
550              ? TYPE_MODULUS (operation_type) : NULL_TREE);
551
552   switch (op_code)
553     {
554     case INIT_EXPR:
555     case MODIFY_EXPR:
556       /* If there were integral or pointer conversions on the LHS, remove
557          them; we'll be putting them back below if needed.  Likewise for
558          conversions between array and record types, except for justified
559          modular types.  But don't do this if the right operand is not
560          BLKmode (for packed arrays) unless we are not changing the mode.  */
561       while ((CONVERT_EXPR_P (left_operand)
562               || TREE_CODE (left_operand) == VIEW_CONVERT_EXPR)
563              && (((INTEGRAL_TYPE_P (left_type)
564                    || POINTER_TYPE_P (left_type))
565                   && (INTEGRAL_TYPE_P (TREE_TYPE
566                                        (TREE_OPERAND (left_operand, 0)))
567                       || POINTER_TYPE_P (TREE_TYPE
568                                          (TREE_OPERAND (left_operand, 0)))))
569                  || (((TREE_CODE (left_type) == RECORD_TYPE
570                        && !TYPE_JUSTIFIED_MODULAR_P (left_type))
571                       || TREE_CODE (left_type) == ARRAY_TYPE)
572                      && ((TREE_CODE (TREE_TYPE
573                                      (TREE_OPERAND (left_operand, 0)))
574                           == RECORD_TYPE)
575                          || (TREE_CODE (TREE_TYPE
576                                         (TREE_OPERAND (left_operand, 0)))
577                              == ARRAY_TYPE))
578                      && (TYPE_MODE (right_type) == BLKmode
579                          || (TYPE_MODE (left_type)
580                              == TYPE_MODE (TREE_TYPE
581                                            (TREE_OPERAND
582                                             (left_operand, 0))))))))
583         {
584           left_operand = TREE_OPERAND (left_operand, 0);
585           left_type = TREE_TYPE (left_operand);
586         }
587
588       /* If a class-wide type may be involved, force use of the RHS type.  */
589       if ((TREE_CODE (right_type) == RECORD_TYPE
590            || TREE_CODE (right_type) == UNION_TYPE)
591           && TYPE_ALIGN_OK (right_type))
592         operation_type = right_type;
593
594       /* If we are copying between padded objects with compatible types, use
595          the padded view of the objects, this is very likely more efficient.
596          Likewise for a padded object that is assigned a constructor, if we
597          can convert the constructor to the inner type, to avoid putting a
598          VIEW_CONVERT_EXPR on the LHS.  But don't do so if we wouldn't have
599          actually copied anything.  */
600       else if (TYPE_IS_PADDING_P (left_type)
601                && TREE_CONSTANT (TYPE_SIZE (left_type))
602                && ((TREE_CODE (right_operand) == COMPONENT_REF
603                     && TYPE_IS_PADDING_P
604                        (TREE_TYPE (TREE_OPERAND (right_operand, 0)))
605                     && gnat_types_compatible_p
606                        (left_type,
607                         TREE_TYPE (TREE_OPERAND (right_operand, 0))))
608                    || (TREE_CODE (right_operand) == CONSTRUCTOR
609                        && !CONTAINS_PLACEHOLDER_P
610                            (DECL_SIZE (TYPE_FIELDS (left_type)))))
611                && !integer_zerop (TYPE_SIZE (right_type)))
612         operation_type = left_type;
613
614       /* Find the best type to use for copying between aggregate types.  */
615       else if (((TREE_CODE (left_type) == ARRAY_TYPE
616                  && TREE_CODE (right_type) == ARRAY_TYPE)
617                 || (TREE_CODE (left_type) == RECORD_TYPE
618                     && TREE_CODE (right_type) == RECORD_TYPE))
619                && (best_type = find_common_type (left_type, right_type)))
620         operation_type = best_type;
621
622       /* Otherwise use the LHS type.  */
623       else if (!operation_type)
624         operation_type = left_type;
625
626       /* Ensure everything on the LHS is valid.  If we have a field reference,
627          strip anything that get_inner_reference can handle.  Then remove any
628          conversions between types having the same code and mode.  And mark
629          VIEW_CONVERT_EXPRs with TREE_ADDRESSABLE.  When done, we must have
630          either an INDIRECT_REF, a NULL_EXPR or a DECL node.  */
631       result = left_operand;
632       while (true)
633         {
634           tree restype = TREE_TYPE (result);
635
636           if (TREE_CODE (result) == COMPONENT_REF
637               || TREE_CODE (result) == ARRAY_REF
638               || TREE_CODE (result) == ARRAY_RANGE_REF)
639             while (handled_component_p (result))
640               result = TREE_OPERAND (result, 0);
641           else if (TREE_CODE (result) == REALPART_EXPR
642                    || TREE_CODE (result) == IMAGPART_EXPR
643                    || (CONVERT_EXPR_P (result)
644                        && (((TREE_CODE (restype)
645                              == TREE_CODE (TREE_TYPE
646                                            (TREE_OPERAND (result, 0))))
647                              && (TYPE_MODE (TREE_TYPE
648                                             (TREE_OPERAND (result, 0)))
649                                  == TYPE_MODE (restype)))
650                            || TYPE_ALIGN_OK (restype))))
651             result = TREE_OPERAND (result, 0);
652           else if (TREE_CODE (result) == VIEW_CONVERT_EXPR)
653             {
654               TREE_ADDRESSABLE (result) = 1;
655               result = TREE_OPERAND (result, 0);
656             }
657           else
658             break;
659         }
660
661       gcc_assert (TREE_CODE (result) == INDIRECT_REF
662                   || TREE_CODE (result) == NULL_EXPR
663                   || DECL_P (result));
664
665       /* Convert the right operand to the operation type unless it is
666          either already of the correct type or if the type involves a
667          placeholder, since the RHS may not have the same record type.  */
668       if (operation_type != right_type
669           && !CONTAINS_PLACEHOLDER_P (TYPE_SIZE (operation_type)))
670         {
671           right_operand = convert (operation_type, right_operand);
672           right_type = operation_type;
673         }
674
675       /* If the left operand is not of the same type as the operation
676          type, wrap it up in a VIEW_CONVERT_EXPR.  */
677       if (left_type != operation_type)
678         left_operand = unchecked_convert (operation_type, left_operand, false);
679
680       has_side_effects = true;
681       modulus = NULL_TREE;
682       break;
683
684     case ARRAY_REF:
685       if (!operation_type)
686         operation_type = TREE_TYPE (left_type);
687
688       /* ... fall through ... */
689
690     case ARRAY_RANGE_REF:
691       /* First look through conversion between type variants.  Note that
692          this changes neither the operation type nor the type domain.  */
693       if (TREE_CODE (left_operand) == VIEW_CONVERT_EXPR
694           && TYPE_MAIN_VARIANT (TREE_TYPE (TREE_OPERAND (left_operand, 0)))
695              == TYPE_MAIN_VARIANT (left_type))
696         {
697           left_operand = TREE_OPERAND (left_operand, 0);
698           left_type = TREE_TYPE (left_operand);
699         }
700
701       /* For a range, make sure the element type is consistent.  */
702       if (op_code == ARRAY_RANGE_REF
703           && TREE_TYPE (operation_type) != TREE_TYPE (left_type))
704         operation_type = build_array_type (TREE_TYPE (left_type),
705                                            TYPE_DOMAIN (operation_type));
706
707       /* Then convert the right operand to its base type.  This will prevent
708          unneeded sign conversions when sizetype is wider than integer.  */
709       right_operand = convert (right_base_type, right_operand);
710       right_operand = convert (sizetype, right_operand);
711
712       if (!TREE_CONSTANT (right_operand)
713           || !TREE_CONSTANT (TYPE_MIN_VALUE (right_type)))
714         gnat_mark_addressable (left_operand);
715
716       modulus = NULL_TREE;
717       break;
718
719     case TRUTH_ANDIF_EXPR:
720     case TRUTH_ORIF_EXPR:
721     case TRUTH_AND_EXPR:
722     case TRUTH_OR_EXPR:
723     case TRUTH_XOR_EXPR:
724 #ifdef ENABLE_CHECKING
725       gcc_assert (TREE_CODE (get_base_type (result_type)) == BOOLEAN_TYPE);
726 #endif
727       operation_type = left_base_type;
728       left_operand = convert (operation_type, left_operand);
729       right_operand = convert (operation_type, right_operand);
730       break;
731
732     case GE_EXPR:
733     case LE_EXPR:
734     case GT_EXPR:
735     case LT_EXPR:
736     case EQ_EXPR:
737     case NE_EXPR:
738 #ifdef ENABLE_CHECKING
739       gcc_assert (TREE_CODE (get_base_type (result_type)) == BOOLEAN_TYPE);
740 #endif
741       /* If either operand is a NULL_EXPR, just return a new one.  */
742       if (TREE_CODE (left_operand) == NULL_EXPR)
743         return build2 (op_code, result_type,
744                        build1 (NULL_EXPR, integer_type_node,
745                                TREE_OPERAND (left_operand, 0)),
746                        integer_zero_node);
747
748       else if (TREE_CODE (right_operand) == NULL_EXPR)
749         return build2 (op_code, result_type,
750                        build1 (NULL_EXPR, integer_type_node,
751                                TREE_OPERAND (right_operand, 0)),
752                        integer_zero_node);
753
754       /* If either object is a justified modular types, get the
755          fields from within.  */
756       if (TREE_CODE (left_type) == RECORD_TYPE
757           && TYPE_JUSTIFIED_MODULAR_P (left_type))
758         {
759           left_operand = convert (TREE_TYPE (TYPE_FIELDS (left_type)),
760                                   left_operand);
761           left_type = TREE_TYPE (left_operand);
762           left_base_type = get_base_type (left_type);
763         }
764
765       if (TREE_CODE (right_type) == RECORD_TYPE
766           && TYPE_JUSTIFIED_MODULAR_P (right_type))
767         {
768           right_operand = convert (TREE_TYPE (TYPE_FIELDS (right_type)),
769                                   right_operand);
770           right_type = TREE_TYPE (right_operand);
771           right_base_type = get_base_type (right_type);
772         }
773
774       /* If both objects are arrays, compare them specially.  */
775       if ((TREE_CODE (left_type) == ARRAY_TYPE
776            || (TREE_CODE (left_type) == INTEGER_TYPE
777                && TYPE_HAS_ACTUAL_BOUNDS_P (left_type)))
778           && (TREE_CODE (right_type) == ARRAY_TYPE
779               || (TREE_CODE (right_type) == INTEGER_TYPE
780                   && TYPE_HAS_ACTUAL_BOUNDS_P (right_type))))
781         {
782           result = compare_arrays (result_type, left_operand, right_operand);
783
784           if (op_code == NE_EXPR)
785             result = invert_truthvalue (result);
786           else
787             gcc_assert (op_code == EQ_EXPR);
788
789           return result;
790         }
791
792       /* Otherwise, the base types must be the same, unless they are both fat
793          pointer types or record types.  In the latter case, use the best type
794          and convert both operands to that type.  */
795       if (left_base_type != right_base_type)
796         {
797           if (TYPE_IS_FAT_POINTER_P (left_base_type)
798               && TYPE_IS_FAT_POINTER_P (right_base_type))
799             {
800               gcc_assert (TYPE_MAIN_VARIANT (left_base_type)
801                           == TYPE_MAIN_VARIANT (right_base_type));
802               best_type = left_base_type;
803             }
804
805           else if (TREE_CODE (left_base_type) == RECORD_TYPE
806                    && TREE_CODE (right_base_type) == RECORD_TYPE)
807             {
808               /* The only way this is permitted is if both types have the same
809                  name.  In that case, one of them must not be self-referential.
810                  Use it as the best type.  Even better with a fixed size.  */
811               gcc_assert (TYPE_NAME (left_base_type)
812                           && TYPE_NAME (left_base_type)
813                              == TYPE_NAME (right_base_type));
814
815               if (TREE_CONSTANT (TYPE_SIZE (left_base_type)))
816                 best_type = left_base_type;
817               else if (TREE_CONSTANT (TYPE_SIZE (right_base_type)))
818                 best_type = right_base_type;
819               else if (!CONTAINS_PLACEHOLDER_P (TYPE_SIZE (left_base_type)))
820                 best_type = left_base_type;
821               else if (!CONTAINS_PLACEHOLDER_P (TYPE_SIZE (right_base_type)))
822                 best_type = right_base_type;
823               else
824                 gcc_unreachable ();
825             }
826
827           else
828             gcc_unreachable ();
829
830           left_operand = convert (best_type, left_operand);
831           right_operand = convert (best_type, right_operand);
832         }
833       else
834         {
835           left_operand = convert (left_base_type, left_operand);
836           right_operand = convert (right_base_type, right_operand);
837         }
838
839       /* If we are comparing a fat pointer against zero, we just need to
840          compare the data pointer.  */
841       if (TYPE_IS_FAT_POINTER_P (left_base_type)
842           && TREE_CODE (right_operand) == CONSTRUCTOR
843           && integer_zerop (VEC_index (constructor_elt,
844                                        CONSTRUCTOR_ELTS (right_operand),
845                                        0)->value))
846         {
847           left_operand
848             = build_component_ref (left_operand, NULL_TREE,
849                                    TYPE_FIELDS (left_base_type), false);
850           right_operand
851             = convert (TREE_TYPE (left_operand), integer_zero_node);
852         }
853
854       modulus = NULL_TREE;
855       break;
856
857     case LSHIFT_EXPR:
858     case RSHIFT_EXPR:
859     case LROTATE_EXPR:
860     case RROTATE_EXPR:
861        /* The RHS of a shift can be any type.  Also, ignore any modulus
862          (we used to abort, but this is needed for unchecked conversion
863          to modular types).  Otherwise, processing is the same as normal.  */
864       gcc_assert (operation_type == left_base_type);
865       modulus = NULL_TREE;
866       left_operand = convert (operation_type, left_operand);
867       break;
868
869     case BIT_AND_EXPR:
870     case BIT_IOR_EXPR:
871     case BIT_XOR_EXPR:
872       /* For binary modulus, if the inputs are in range, so are the
873          outputs.  */
874       if (modulus && integer_pow2p (modulus))
875         modulus = NULL_TREE;
876       goto common;
877
878     case COMPLEX_EXPR:
879       gcc_assert (TREE_TYPE (result_type) == left_base_type
880                   && TREE_TYPE (result_type) == right_base_type);
881       left_operand = convert (left_base_type, left_operand);
882       right_operand = convert (right_base_type, right_operand);
883       break;
884
885     case TRUNC_DIV_EXPR:   case TRUNC_MOD_EXPR:
886     case CEIL_DIV_EXPR:    case CEIL_MOD_EXPR:
887     case FLOOR_DIV_EXPR:   case FLOOR_MOD_EXPR:
888     case ROUND_DIV_EXPR:   case ROUND_MOD_EXPR:
889       /* These always produce results lower than either operand.  */
890       modulus = NULL_TREE;
891       goto common;
892
893     case POINTER_PLUS_EXPR:
894       gcc_assert (operation_type == left_base_type
895                   && sizetype == right_base_type);
896       left_operand = convert (operation_type, left_operand);
897       right_operand = convert (sizetype, right_operand);
898       break;
899
900     case PLUS_NOMOD_EXPR:
901     case MINUS_NOMOD_EXPR:
902       if (op_code == PLUS_NOMOD_EXPR)
903         op_code = PLUS_EXPR;
904       else
905         op_code = MINUS_EXPR;
906       modulus = NULL_TREE;
907
908       /* ... fall through ... */
909
910     case PLUS_EXPR:
911     case MINUS_EXPR:
912       /* Avoid doing arithmetics in ENUMERAL_TYPE or BOOLEAN_TYPE like the
913          other compilers.  Contrary to C, Ada doesn't allow arithmetics in
914          these types but can generate addition/subtraction for Succ/Pred.  */
915       if (operation_type
916           && (TREE_CODE (operation_type) == ENUMERAL_TYPE
917               || TREE_CODE (operation_type) == BOOLEAN_TYPE))
918         operation_type = left_base_type = right_base_type
919           = gnat_type_for_mode (TYPE_MODE (operation_type),
920                                 TYPE_UNSIGNED (operation_type));
921
922       /* ... fall through ... */
923
924     default:
925     common:
926       /* The result type should be the same as the base types of the
927          both operands (and they should be the same).  Convert
928          everything to the result type.  */
929
930       gcc_assert (operation_type == left_base_type
931                   && left_base_type == right_base_type);
932       left_operand = convert (operation_type, left_operand);
933       right_operand = convert (operation_type, right_operand);
934     }
935
936   if (modulus && !integer_pow2p (modulus))
937     {
938       result = nonbinary_modular_operation (op_code, operation_type,
939                                             left_operand, right_operand);
940       modulus = NULL_TREE;
941     }
942   /* If either operand is a NULL_EXPR, just return a new one.  */
943   else if (TREE_CODE (left_operand) == NULL_EXPR)
944     return build1 (NULL_EXPR, operation_type, TREE_OPERAND (left_operand, 0));
945   else if (TREE_CODE (right_operand) == NULL_EXPR)
946     return build1 (NULL_EXPR, operation_type, TREE_OPERAND (right_operand, 0));
947   else if (op_code == ARRAY_REF || op_code == ARRAY_RANGE_REF)
948     result = fold (build4 (op_code, operation_type, left_operand,
949                            right_operand, NULL_TREE, NULL_TREE));
950   else
951     result
952       = fold_build2 (op_code, operation_type, left_operand, right_operand);
953
954   TREE_SIDE_EFFECTS (result) |= has_side_effects;
955   TREE_CONSTANT (result)
956     |= (TREE_CONSTANT (left_operand) & TREE_CONSTANT (right_operand)
957         && op_code != ARRAY_REF && op_code != ARRAY_RANGE_REF);
958
959   if ((op_code == ARRAY_REF || op_code == ARRAY_RANGE_REF)
960       && TYPE_VOLATILE (operation_type))
961     TREE_THIS_VOLATILE (result) = 1;
962
963   /* If we are working with modular types, perform the MOD operation
964      if something above hasn't eliminated the need for it.  */
965   if (modulus)
966     result = fold_build2 (FLOOR_MOD_EXPR, operation_type, result,
967                           convert (operation_type, modulus));
968
969   if (result_type && result_type != operation_type)
970     result = convert (result_type, result);
971
972   return result;
973 }
974 \f
975 /* Similar, but for unary operations.  */
976
977 tree
978 build_unary_op (enum tree_code op_code, tree result_type, tree operand)
979 {
980   tree type = TREE_TYPE (operand);
981   tree base_type = get_base_type (type);
982   tree operation_type = result_type;
983   tree result;
984   bool side_effects = false;
985
986   if (operation_type
987       && TREE_CODE (operation_type) == RECORD_TYPE
988       && TYPE_JUSTIFIED_MODULAR_P (operation_type))
989     operation_type = TREE_TYPE (TYPE_FIELDS (operation_type));
990
991   if (operation_type
992       && !AGGREGATE_TYPE_P (operation_type)
993       && TYPE_EXTRA_SUBTYPE_P (operation_type))
994     operation_type = get_base_type (operation_type);
995
996   switch (op_code)
997     {
998     case REALPART_EXPR:
999     case IMAGPART_EXPR:
1000       if (!operation_type)
1001         result_type = operation_type = TREE_TYPE (type);
1002       else
1003         gcc_assert (result_type == TREE_TYPE (type));
1004
1005       result = fold_build1 (op_code, operation_type, operand);
1006       break;
1007
1008     case TRUTH_NOT_EXPR:
1009 #ifdef ENABLE_CHECKING
1010       gcc_assert (TREE_CODE (get_base_type (result_type)) == BOOLEAN_TYPE);
1011 #endif
1012       result = invert_truthvalue (operand);
1013       break;
1014
1015     case ATTR_ADDR_EXPR:
1016     case ADDR_EXPR:
1017       switch (TREE_CODE (operand))
1018         {
1019         case INDIRECT_REF:
1020         case UNCONSTRAINED_ARRAY_REF:
1021           result = TREE_OPERAND (operand, 0);
1022
1023           /* Make sure the type here is a pointer, not a reference.
1024              GCC wants pointer types for function addresses.  */
1025           if (!result_type)
1026             result_type = build_pointer_type (type);
1027
1028           /* If the underlying object can alias everything, propagate the
1029              property since we are effectively retrieving the object.  */
1030           if (POINTER_TYPE_P (TREE_TYPE (result))
1031               && TYPE_REF_CAN_ALIAS_ALL (TREE_TYPE (result)))
1032             {
1033               if (TREE_CODE (result_type) == POINTER_TYPE
1034                   && !TYPE_REF_CAN_ALIAS_ALL (result_type))
1035                 result_type
1036                   = build_pointer_type_for_mode (TREE_TYPE (result_type),
1037                                                  TYPE_MODE (result_type),
1038                                                  true);
1039               else if (TREE_CODE (result_type) == REFERENCE_TYPE
1040                        && !TYPE_REF_CAN_ALIAS_ALL (result_type))
1041                 result_type
1042                   = build_reference_type_for_mode (TREE_TYPE (result_type),
1043                                                    TYPE_MODE (result_type),
1044                                                    true);
1045             }
1046           break;
1047
1048         case NULL_EXPR:
1049           result = operand;
1050           TREE_TYPE (result) = type = build_pointer_type (type);
1051           break;
1052
1053         case COMPOUND_EXPR:
1054           /* Fold a compound expression if it has unconstrained array type
1055              since the middle-end cannot handle it.  But we don't it in the
1056              general case because it may introduce aliasing issues if the
1057              first operand is an indirect assignment and the second operand
1058              the corresponding address, e.g. for an allocator.  */
1059           if (TREE_CODE (type) == UNCONSTRAINED_ARRAY_TYPE)
1060             {
1061               result = build_unary_op (ADDR_EXPR, result_type,
1062                                        TREE_OPERAND (operand, 1));
1063               result = build2 (COMPOUND_EXPR, TREE_TYPE (result),
1064                                TREE_OPERAND (operand, 0), result);
1065               break;
1066             }
1067           goto common;
1068
1069         case ARRAY_REF:
1070         case ARRAY_RANGE_REF:
1071         case COMPONENT_REF:
1072         case BIT_FIELD_REF:
1073             /* If this is for 'Address, find the address of the prefix and
1074                add the offset to the field.  Otherwise, do this the normal
1075                way.  */
1076           if (op_code == ATTR_ADDR_EXPR)
1077             {
1078               HOST_WIDE_INT bitsize;
1079               HOST_WIDE_INT bitpos;
1080               tree offset, inner;
1081               enum machine_mode mode;
1082               int unsignedp, volatilep;
1083
1084               inner = get_inner_reference (operand, &bitsize, &bitpos, &offset,
1085                                            &mode, &unsignedp, &volatilep,
1086                                            false);
1087
1088               /* If INNER is a padding type whose field has a self-referential
1089                  size, convert to that inner type.  We know the offset is zero
1090                  and we need to have that type visible.  */
1091               if (TYPE_IS_PADDING_P (TREE_TYPE (inner))
1092                   && CONTAINS_PLACEHOLDER_P
1093                      (TYPE_SIZE (TREE_TYPE (TYPE_FIELDS
1094                                             (TREE_TYPE (inner))))))
1095                 inner = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (inner))),
1096                                  inner);
1097
1098               /* Compute the offset as a byte offset from INNER.  */
1099               if (!offset)
1100                 offset = size_zero_node;
1101
1102               if (bitpos % BITS_PER_UNIT != 0)
1103                 post_error
1104                   ("taking address of object not aligned on storage unit?",
1105                    error_gnat_node);
1106
1107               offset = size_binop (PLUS_EXPR, offset,
1108                                    size_int (bitpos / BITS_PER_UNIT));
1109
1110               /* Take the address of INNER, convert the offset to void *, and
1111                  add then.  It will later be converted to the desired result
1112                  type, if any.  */
1113               inner = build_unary_op (ADDR_EXPR, NULL_TREE, inner);
1114               inner = convert (ptr_void_type_node, inner);
1115               result = build_binary_op (POINTER_PLUS_EXPR, ptr_void_type_node,
1116                                         inner, offset);
1117               result = convert (build_pointer_type (TREE_TYPE (operand)),
1118                                 result);
1119               break;
1120             }
1121           goto common;
1122
1123         case CONSTRUCTOR:
1124           /* If this is just a constructor for a padded record, we can
1125              just take the address of the single field and convert it to
1126              a pointer to our type.  */
1127           if (TYPE_IS_PADDING_P (type))
1128             {
1129               result = VEC_index (constructor_elt,
1130                                   CONSTRUCTOR_ELTS (operand),
1131                                   0)->value;
1132               result = convert (build_pointer_type (TREE_TYPE (operand)),
1133                                 build_unary_op (ADDR_EXPR, NULL_TREE, result));
1134               break;
1135             }
1136
1137           goto common;
1138
1139         case NOP_EXPR:
1140           if (AGGREGATE_TYPE_P (type)
1141               && AGGREGATE_TYPE_P (TREE_TYPE (TREE_OPERAND (operand, 0))))
1142             return build_unary_op (ADDR_EXPR, result_type,
1143                                    TREE_OPERAND (operand, 0));
1144
1145           /* ... fallthru ... */
1146
1147         case VIEW_CONVERT_EXPR:
1148           /* If this just a variant conversion or if the conversion doesn't
1149              change the mode, get the result type from this type and go down.
1150              This is needed for conversions of CONST_DECLs, to eventually get
1151              to the address of their CORRESPONDING_VARs.  */
1152           if ((TYPE_MAIN_VARIANT (type)
1153                == TYPE_MAIN_VARIANT (TREE_TYPE (TREE_OPERAND (operand, 0))))
1154               || (TYPE_MODE (type) != BLKmode
1155                   && (TYPE_MODE (type)
1156                       == TYPE_MODE (TREE_TYPE (TREE_OPERAND (operand, 0))))))
1157             return build_unary_op (ADDR_EXPR,
1158                                    (result_type ? result_type
1159                                     : build_pointer_type (type)),
1160                                    TREE_OPERAND (operand, 0));
1161           goto common;
1162
1163         case CONST_DECL:
1164           operand = DECL_CONST_CORRESPONDING_VAR (operand);
1165
1166           /* ... fall through ... */
1167
1168         default:
1169         common:
1170
1171           /* If we are taking the address of a padded record whose field is
1172              contains a template, take the address of the template.  */
1173           if (TYPE_IS_PADDING_P (type)
1174               && TREE_CODE (TREE_TYPE (TYPE_FIELDS (type))) == RECORD_TYPE
1175               && TYPE_CONTAINS_TEMPLATE_P (TREE_TYPE (TYPE_FIELDS (type))))
1176             {
1177               type = TREE_TYPE (TYPE_FIELDS (type));
1178               operand = convert (type, operand);
1179             }
1180
1181           gnat_mark_addressable (operand);
1182           result = build_fold_addr_expr (operand);
1183         }
1184
1185       TREE_CONSTANT (result) = staticp (operand) || TREE_CONSTANT (operand);
1186       break;
1187
1188     case INDIRECT_REF:
1189       /* If we want to refer to an unconstrained array, use the appropriate
1190          expression to do so.  This will never survive down to the back-end.
1191          But if TYPE is a thin pointer, first convert to a fat pointer.  */
1192       if (TYPE_IS_THIN_POINTER_P (type)
1193           && TYPE_UNCONSTRAINED_ARRAY (TREE_TYPE (type)))
1194         {
1195           operand
1196             = convert (TREE_TYPE (TYPE_UNCONSTRAINED_ARRAY (TREE_TYPE (type))),
1197                        operand);
1198           type = TREE_TYPE (operand);
1199         }
1200
1201       if (TYPE_IS_FAT_POINTER_P (type))
1202         {
1203           result = build1 (UNCONSTRAINED_ARRAY_REF,
1204                            TYPE_UNCONSTRAINED_ARRAY (type), operand);
1205           TREE_READONLY (result)
1206             = TYPE_READONLY (TYPE_UNCONSTRAINED_ARRAY (type));
1207         }
1208
1209       /* If we are dereferencing an ADDR_EXPR, return its operand.  */
1210       else if (TREE_CODE (operand) == ADDR_EXPR)
1211         result = TREE_OPERAND (operand, 0);
1212
1213       /* Otherwise, build and fold the indirect reference.  */
1214       else
1215         {
1216           result = build_fold_indirect_ref (operand);
1217           TREE_READONLY (result) = TYPE_READONLY (TREE_TYPE (type));
1218         }
1219
1220       side_effects
1221         = (!TYPE_IS_FAT_POINTER_P (type) && TYPE_VOLATILE (TREE_TYPE (type)));
1222       break;
1223
1224     case NEGATE_EXPR:
1225     case BIT_NOT_EXPR:
1226       {
1227         tree modulus = ((operation_type
1228                          && TREE_CODE (operation_type) == INTEGER_TYPE
1229                          && TYPE_MODULAR_P (operation_type))
1230                         ? TYPE_MODULUS (operation_type) : NULL_TREE);
1231         int mod_pow2 = modulus && integer_pow2p (modulus);
1232
1233         /* If this is a modular type, there are various possibilities
1234            depending on the operation and whether the modulus is a
1235            power of two or not.  */
1236
1237         if (modulus)
1238           {
1239             gcc_assert (operation_type == base_type);
1240             operand = convert (operation_type, operand);
1241
1242             /* The fastest in the negate case for binary modulus is
1243                the straightforward code; the TRUNC_MOD_EXPR below
1244                is an AND operation.  */
1245             if (op_code == NEGATE_EXPR && mod_pow2)
1246               result = fold_build2 (TRUNC_MOD_EXPR, operation_type,
1247                                     fold_build1 (NEGATE_EXPR, operation_type,
1248                                                  operand),
1249                                     modulus);
1250
1251             /* For nonbinary negate case, return zero for zero operand,
1252                else return the modulus minus the operand.  If the modulus
1253                is a power of two minus one, we can do the subtraction
1254                as an XOR since it is equivalent and faster on most machines. */
1255             else if (op_code == NEGATE_EXPR && !mod_pow2)
1256               {
1257                 if (integer_pow2p (fold_build2 (PLUS_EXPR, operation_type,
1258                                                 modulus,
1259                                                 convert (operation_type,
1260                                                          integer_one_node))))
1261                   result = fold_build2 (BIT_XOR_EXPR, operation_type,
1262                                         operand, modulus);
1263                 else
1264                   result = fold_build2 (MINUS_EXPR, operation_type,
1265                                         modulus, operand);
1266
1267                 result = fold_build3 (COND_EXPR, operation_type,
1268                                       fold_build2 (NE_EXPR,
1269                                                    boolean_type_node,
1270                                                    operand,
1271                                                    convert
1272                                                      (operation_type,
1273                                                       integer_zero_node)),
1274                                       result, operand);
1275               }
1276             else
1277               {
1278                 /* For the NOT cases, we need a constant equal to
1279                    the modulus minus one.  For a binary modulus, we
1280                    XOR against the constant and subtract the operand from
1281                    that constant for nonbinary modulus.  */
1282
1283                 tree cnst = fold_build2 (MINUS_EXPR, operation_type, modulus,
1284                                          convert (operation_type,
1285                                                   integer_one_node));
1286
1287                 if (mod_pow2)
1288                   result = fold_build2 (BIT_XOR_EXPR, operation_type,
1289                                         operand, cnst);
1290                 else
1291                   result = fold_build2 (MINUS_EXPR, operation_type,
1292                                         cnst, operand);
1293               }
1294
1295             break;
1296           }
1297       }
1298
1299       /* ... fall through ... */
1300
1301     default:
1302       gcc_assert (operation_type == base_type);
1303       result = fold_build1 (op_code, operation_type,
1304                             convert (operation_type, operand));
1305     }
1306
1307   if (side_effects)
1308     {
1309       TREE_SIDE_EFFECTS (result) = 1;
1310       if (TREE_CODE (result) == INDIRECT_REF)
1311         TREE_THIS_VOLATILE (result) = TYPE_VOLATILE (TREE_TYPE (result));
1312     }
1313
1314   if (result_type && TREE_TYPE (result) != result_type)
1315     result = convert (result_type, result);
1316
1317   return result;
1318 }
1319 \f
1320 /* Similar, but for COND_EXPR.  */
1321
1322 tree
1323 build_cond_expr (tree result_type, tree condition_operand,
1324                  tree true_operand, tree false_operand)
1325 {
1326   bool addr_p = false;
1327   tree result;
1328
1329   /* The front-end verified that result, true and false operands have
1330      same base type.  Convert everything to the result type.  */
1331   true_operand = convert (result_type, true_operand);
1332   false_operand = convert (result_type, false_operand);
1333
1334   /* If the result type is unconstrained, take the address of the operands and
1335      then dereference the result.  Likewise if the result type is passed by
1336      reference, but this is natively handled in the gimplifier.  */
1337   if (TREE_CODE (result_type) == UNCONSTRAINED_ARRAY_TYPE
1338       || CONTAINS_PLACEHOLDER_P (TYPE_SIZE (result_type)))
1339     {
1340       result_type = build_pointer_type (result_type);
1341       true_operand = build_unary_op (ADDR_EXPR, result_type, true_operand);
1342       false_operand = build_unary_op (ADDR_EXPR, result_type, false_operand);
1343       addr_p = true;
1344     }
1345
1346   result = fold_build3 (COND_EXPR, result_type, condition_operand,
1347                         true_operand, false_operand);
1348
1349   /* If we have a common SAVE_EXPR (possibly surrounded by arithmetics)
1350      in both arms, make sure it gets evaluated by moving it ahead of the
1351      conditional expression.  This is necessary because it is evaluated
1352      in only one place at run time and would otherwise be uninitialized
1353      in one of the arms.  */
1354   true_operand = skip_simple_arithmetic (true_operand);
1355   false_operand = skip_simple_arithmetic (false_operand);
1356
1357   if (true_operand == false_operand && TREE_CODE (true_operand) == SAVE_EXPR)
1358     result = build2 (COMPOUND_EXPR, result_type, true_operand, result);
1359
1360   if (addr_p)
1361     result = build_unary_op (INDIRECT_REF, NULL_TREE, result);
1362
1363   return result;
1364 }
1365
1366 /* Similar, but for RETURN_EXPR.  If RET_VAL is non-null, build a RETURN_EXPR
1367    around the assignment of RET_VAL to RET_OBJ.  Otherwise just build a bare
1368    RETURN_EXPR around RESULT_OBJ, which may be null in this case.  */
1369
1370 tree
1371 build_return_expr (tree ret_obj, tree ret_val)
1372 {
1373   tree result_expr;
1374
1375   if (ret_val)
1376     {
1377       /* The gimplifier explicitly enforces the following invariant:
1378
1379               RETURN_EXPR
1380                   |
1381               MODIFY_EXPR
1382               /        \
1383              /          \
1384          RET_OBJ        ...
1385
1386          As a consequence, type consistency dictates that we use the type
1387          of the RET_OBJ as the operation type.  */
1388       tree operation_type = TREE_TYPE (ret_obj);
1389
1390       /* Convert the right operand to the operation type.  Note that it's the
1391          same transformation as in the MODIFY_EXPR case of build_binary_op,
1392          with the assumption that the type cannot involve a placeholder.  */
1393       if (operation_type != TREE_TYPE (ret_val))
1394         ret_val = convert (operation_type, ret_val);
1395
1396       result_expr = build2 (MODIFY_EXPR, operation_type, ret_obj, ret_val);
1397     }
1398   else
1399     result_expr = ret_obj;
1400
1401   return build1 (RETURN_EXPR, void_type_node, result_expr);
1402 }
1403 \f
1404 /* Build a CALL_EXPR to call FUNDECL with one argument, ARG.  Return
1405    the CALL_EXPR.  */
1406
1407 tree
1408 build_call_1_expr (tree fundecl, tree arg)
1409 {
1410   tree call = build_call_nary (TREE_TYPE (TREE_TYPE (fundecl)),
1411                                build_unary_op (ADDR_EXPR, NULL_TREE, fundecl),
1412                                1, arg);
1413   TREE_SIDE_EFFECTS (call) = 1;
1414   return call;
1415 }
1416
1417 /* Build a CALL_EXPR to call FUNDECL with two arguments, ARG1 & ARG2.  Return
1418    the CALL_EXPR.  */
1419
1420 tree
1421 build_call_2_expr (tree fundecl, tree arg1, tree arg2)
1422 {
1423   tree call = build_call_nary (TREE_TYPE (TREE_TYPE (fundecl)),
1424                                build_unary_op (ADDR_EXPR, NULL_TREE, fundecl),
1425                                2, arg1, arg2);
1426   TREE_SIDE_EFFECTS (call) = 1;
1427   return call;
1428 }
1429
1430 /* Likewise to call FUNDECL with no arguments.  */
1431
1432 tree
1433 build_call_0_expr (tree fundecl)
1434 {
1435   /* We rely on build_call_nary to compute TREE_SIDE_EFFECTS.  This makes
1436      it possible to propagate DECL_IS_PURE on parameterless functions.  */
1437   tree call = build_call_nary (TREE_TYPE (TREE_TYPE (fundecl)),
1438                                build_unary_op (ADDR_EXPR, NULL_TREE, fundecl),
1439                                0);
1440   return call;
1441 }
1442 \f
1443 /* Call a function that raises an exception and pass the line number and file
1444    name, if requested.  MSG says which exception function to call.
1445
1446    GNAT_NODE is the gnat node conveying the source location for which the
1447    error should be signaled, or Empty in which case the error is signaled on
1448    the current ref_file_name/input_line.
1449
1450    KIND says which kind of exception this is for
1451    (N_Raise_{Constraint,Storage,Program}_Error).  */
1452
1453 tree
1454 build_call_raise (int msg, Node_Id gnat_node, char kind)
1455 {
1456   tree fndecl = gnat_raise_decls[msg];
1457   tree label = get_exception_label (kind);
1458   tree filename;
1459   int line_number;
1460   const char *str;
1461   int len;
1462
1463   /* If this is to be done as a goto, handle that case.  */
1464   if (label)
1465     {
1466       Entity_Id local_raise = Get_Local_Raise_Call_Entity ();
1467       tree gnu_result = build1 (GOTO_EXPR, void_type_node, label);
1468
1469       /* If Local_Raise is present, generate
1470          Local_Raise (exception'Identity);  */
1471       if (Present (local_raise))
1472         {
1473           tree gnu_local_raise
1474             = gnat_to_gnu_entity (local_raise, NULL_TREE, 0);
1475           tree gnu_exception_entity
1476             = gnat_to_gnu_entity (Get_RT_Exception_Entity (msg), NULL_TREE, 0);
1477           tree gnu_call
1478             = build_call_1_expr (gnu_local_raise,
1479                                  build_unary_op (ADDR_EXPR, NULL_TREE,
1480                                                  gnu_exception_entity));
1481
1482           gnu_result = build2 (COMPOUND_EXPR, void_type_node,
1483                                gnu_call, gnu_result);}
1484
1485       return gnu_result;
1486     }
1487
1488   str
1489     = (Debug_Flag_NN || Exception_Locations_Suppressed)
1490       ? ""
1491       : (gnat_node != Empty && Sloc (gnat_node) != No_Location)
1492         ? IDENTIFIER_POINTER
1493           (get_identifier (Get_Name_String
1494                            (Debug_Source_Name
1495                             (Get_Source_File_Index (Sloc (gnat_node))))))
1496         : ref_filename;
1497
1498   len = strlen (str);
1499   filename = build_string (len, str);
1500   line_number
1501     = (gnat_node != Empty && Sloc (gnat_node) != No_Location)
1502       ? Get_Logical_Line_Number (Sloc(gnat_node)) : input_line;
1503
1504   TREE_TYPE (filename)
1505     = build_array_type (char_type_node, build_index_type (size_int (len)));
1506
1507   return
1508     build_call_2_expr (fndecl,
1509                        build1 (ADDR_EXPR, build_pointer_type (char_type_node),
1510                                filename),
1511                        build_int_cst (NULL_TREE, line_number));
1512 }
1513 \f
1514 /* qsort comparer for the bit positions of two constructor elements
1515    for record components.  */
1516
1517 static int
1518 compare_elmt_bitpos (const PTR rt1, const PTR rt2)
1519 {
1520   const_tree const elmt1 = * (const_tree const *) rt1;
1521   const_tree const elmt2 = * (const_tree const *) rt2;
1522   const_tree const field1 = TREE_PURPOSE (elmt1);
1523   const_tree const field2 = TREE_PURPOSE (elmt2);
1524   const int ret
1525     = tree_int_cst_compare (bit_position (field1), bit_position (field2));
1526
1527   return ret ? ret : (int) (DECL_UID (field1) - DECL_UID (field2));
1528 }
1529
1530 /* Return a CONSTRUCTOR of TYPE whose list is LIST.  */
1531
1532 tree
1533 gnat_build_constructor (tree type, tree list)
1534 {
1535   bool allconstant = (TREE_CODE (TYPE_SIZE (type)) == INTEGER_CST);
1536   bool side_effects = false;
1537   tree elmt, result;
1538   int n_elmts;
1539
1540   /* Scan the elements to see if they are all constant or if any has side
1541      effects, to let us set global flags on the resulting constructor.  Count
1542      the elements along the way for possible sorting purposes below.  */
1543   for (n_elmts = 0, elmt = list; elmt; elmt = TREE_CHAIN (elmt), n_elmts ++)
1544     {
1545       tree obj = TREE_PURPOSE (elmt);
1546       tree val = TREE_VALUE (elmt);
1547
1548       /* The predicate must be in keeping with output_constructor.  */
1549       if (!TREE_CONSTANT (val)
1550           || (TREE_CODE (type) == RECORD_TYPE
1551               && CONSTRUCTOR_BITFIELD_P (obj)
1552               && !initializer_constant_valid_for_bitfield_p (val))
1553           || !initializer_constant_valid_p (val, TREE_TYPE (val)))
1554         allconstant = false;
1555
1556       if (TREE_SIDE_EFFECTS (val))
1557         side_effects = true;
1558     }
1559
1560   /* For record types with constant components only, sort field list
1561      by increasing bit position.  This is necessary to ensure the
1562      constructor can be output as static data.  */
1563   if (allconstant && TREE_CODE (type) == RECORD_TYPE && n_elmts > 1)
1564     {
1565       /* Fill an array with an element tree per index, and ask qsort to order
1566          them according to what a bitpos comparison function says.  */
1567       tree *gnu_arr = (tree *) alloca (sizeof (tree) * n_elmts);
1568       int i;
1569
1570       for (i = 0, elmt = list; elmt; elmt = TREE_CHAIN (elmt), i++)
1571         gnu_arr[i] = elmt;
1572
1573       qsort (gnu_arr, n_elmts, sizeof (tree), compare_elmt_bitpos);
1574
1575       /* Then reconstruct the list from the sorted array contents.  */
1576       list = NULL_TREE;
1577       for (i = n_elmts - 1; i >= 0; i--)
1578         {
1579           TREE_CHAIN (gnu_arr[i]) = list;
1580           list = gnu_arr[i];
1581         }
1582     }
1583
1584   result = build_constructor_from_list (type, list);
1585   TREE_CONSTANT (result) = TREE_STATIC (result) = allconstant;
1586   TREE_SIDE_EFFECTS (result) = side_effects;
1587   TREE_READONLY (result) = TYPE_READONLY (type) || allconstant;
1588   return result;
1589 }
1590 \f
1591 /* Return a COMPONENT_REF to access a field that is given by COMPONENT,
1592    an IDENTIFIER_NODE giving the name of the field, or FIELD, a FIELD_DECL,
1593    for the field.  Don't fold the result if NO_FOLD_P is true.
1594
1595    We also handle the fact that we might have been passed a pointer to the
1596    actual record and know how to look for fields in variant parts.  */
1597
1598 static tree
1599 build_simple_component_ref (tree record_variable, tree component,
1600                             tree field, bool no_fold_p)
1601 {
1602   tree record_type = TYPE_MAIN_VARIANT (TREE_TYPE (record_variable));
1603   tree ref, inner_variable;
1604
1605   gcc_assert ((TREE_CODE (record_type) == RECORD_TYPE
1606                || TREE_CODE (record_type) == UNION_TYPE
1607                || TREE_CODE (record_type) == QUAL_UNION_TYPE)
1608               && TYPE_SIZE (record_type)
1609               && (component != 0) != (field != 0));
1610
1611   /* If no field was specified, look for a field with the specified name
1612      in the current record only.  */
1613   if (!field)
1614     for (field = TYPE_FIELDS (record_type); field;
1615          field = TREE_CHAIN (field))
1616       if (DECL_NAME (field) == component)
1617         break;
1618
1619   if (!field)
1620     return NULL_TREE;
1621
1622   /* If this field is not in the specified record, see if we can find
1623      something in the record whose original field is the same as this one. */
1624   if (DECL_CONTEXT (field) != record_type)
1625     /* Check if there is a field with name COMPONENT in the record.  */
1626     {
1627       tree new_field;
1628
1629       /* First loop thru normal components.  */
1630       for (new_field = TYPE_FIELDS (record_type); new_field;
1631            new_field = TREE_CHAIN (new_field))
1632         if (SAME_FIELD_P (field, new_field))
1633           break;
1634
1635       /* Next, loop thru DECL_INTERNAL_P components if we haven't found
1636          the component in the first search. Doing this search in 2 steps
1637          is required to avoiding hidden homonymous fields in the
1638          _Parent field.  */
1639       if (!new_field)
1640         for (new_field = TYPE_FIELDS (record_type); new_field;
1641              new_field = TREE_CHAIN (new_field))
1642           if (DECL_INTERNAL_P (new_field))
1643             {
1644               tree field_ref
1645                 = build_simple_component_ref (record_variable,
1646                                               NULL_TREE, new_field, no_fold_p);
1647               ref = build_simple_component_ref (field_ref, NULL_TREE, field,
1648                                                 no_fold_p);
1649
1650               if (ref)
1651                 return ref;
1652             }
1653
1654       field = new_field;
1655     }
1656
1657   if (!field)
1658     return NULL_TREE;
1659
1660   /* If the field's offset has overflowed, do not attempt to access it
1661      as doing so may trigger sanity checks deeper in the back-end.
1662      Note that we don't need to warn since this will be done on trying
1663      to declare the object.  */
1664   if (TREE_CODE (DECL_FIELD_OFFSET (field)) == INTEGER_CST
1665       && TREE_OVERFLOW (DECL_FIELD_OFFSET (field)))
1666     return NULL_TREE;
1667
1668   /* Look through conversion between type variants.  Note that this
1669      is transparent as far as the field is concerned.  */
1670   if (TREE_CODE (record_variable) == VIEW_CONVERT_EXPR
1671       && TYPE_MAIN_VARIANT (TREE_TYPE (TREE_OPERAND (record_variable, 0)))
1672          == record_type)
1673     inner_variable = TREE_OPERAND (record_variable, 0);
1674   else
1675     inner_variable = record_variable;
1676
1677   ref = build3 (COMPONENT_REF, TREE_TYPE (field), inner_variable, field,
1678                 NULL_TREE);
1679
1680   if (TREE_READONLY (record_variable) || TREE_READONLY (field))
1681     TREE_READONLY (ref) = 1;
1682   if (TREE_THIS_VOLATILE (record_variable) || TREE_THIS_VOLATILE (field)
1683       || TYPE_VOLATILE (record_type))
1684     TREE_THIS_VOLATILE (ref) = 1;
1685
1686   if (no_fold_p)
1687     return ref;
1688
1689   /* The generic folder may punt in this case because the inner array type
1690      can be self-referential, but folding is in fact not problematic.  */
1691   else if (TREE_CODE (record_variable) == CONSTRUCTOR
1692            && TYPE_CONTAINS_TEMPLATE_P (TREE_TYPE (record_variable)))
1693     {
1694       VEC(constructor_elt,gc) *elts = CONSTRUCTOR_ELTS (record_variable);
1695       unsigned HOST_WIDE_INT idx;
1696       tree index, value;
1697       FOR_EACH_CONSTRUCTOR_ELT (elts, idx, index, value)
1698         if (index == field)
1699           return value;
1700       return ref;
1701     }
1702
1703   else
1704     return fold (ref);
1705 }
1706 \f
1707 /* Like build_simple_component_ref, except that we give an error if the
1708    reference could not be found.  */
1709
1710 tree
1711 build_component_ref (tree record_variable, tree component,
1712                      tree field, bool no_fold_p)
1713 {
1714   tree ref = build_simple_component_ref (record_variable, component, field,
1715                                          no_fold_p);
1716
1717   if (ref)
1718     return ref;
1719
1720   /* If FIELD was specified, assume this is an invalid user field so raise
1721      Constraint_Error.  Otherwise, we have no type to return so abort.  */
1722   gcc_assert (field);
1723   return build1 (NULL_EXPR, TREE_TYPE (field),
1724                  build_call_raise (CE_Discriminant_Check_Failed, Empty,
1725                                    N_Raise_Constraint_Error));
1726 }
1727 \f
1728 /* Helper for build_call_alloc_dealloc, with arguments to be interpreted
1729    identically.  Process the case where a GNAT_PROC to call is provided.  */
1730
1731 static inline tree
1732 build_call_alloc_dealloc_proc (tree gnu_obj, tree gnu_size, tree gnu_type,
1733                                Entity_Id gnat_proc, Entity_Id gnat_pool)
1734 {
1735   tree gnu_proc = gnat_to_gnu (gnat_proc);
1736   tree gnu_proc_addr = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_proc);
1737   tree gnu_call;
1738
1739   /* The storage pools are obviously always tagged types, but the
1740      secondary stack uses the same mechanism and is not tagged.  */
1741   if (Is_Tagged_Type (Etype (gnat_pool)))
1742     {
1743       /* The size is the third parameter; the alignment is the
1744          same type.  */
1745       Entity_Id gnat_size_type
1746         = Etype (Next_Formal (Next_Formal (First_Formal (gnat_proc))));
1747       tree gnu_size_type = gnat_to_gnu_type (gnat_size_type);
1748
1749       tree gnu_pool = gnat_to_gnu (gnat_pool);
1750       tree gnu_pool_addr = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_pool);
1751       tree gnu_align = size_int (TYPE_ALIGN (gnu_type) / BITS_PER_UNIT);
1752
1753       gnu_size = convert (gnu_size_type, gnu_size);
1754       gnu_align = convert (gnu_size_type, gnu_align);
1755
1756       /* The first arg is always the address of the storage pool; next
1757          comes the address of the object, for a deallocator, then the
1758          size and alignment.  */
1759       if (gnu_obj)
1760         gnu_call = build_call_nary (TREE_TYPE (TREE_TYPE (gnu_proc)),
1761                                     gnu_proc_addr, 4, gnu_pool_addr,
1762                                     gnu_obj, gnu_size, gnu_align);
1763       else
1764         gnu_call = build_call_nary (TREE_TYPE (TREE_TYPE (gnu_proc)),
1765                                     gnu_proc_addr, 3, gnu_pool_addr,
1766                                     gnu_size, gnu_align);
1767     }
1768
1769   /* Secondary stack case.  */
1770   else
1771     {
1772       /* The size is the second parameter.  */
1773       Entity_Id gnat_size_type
1774         = Etype (Next_Formal (First_Formal (gnat_proc)));
1775       tree gnu_size_type = gnat_to_gnu_type (gnat_size_type);
1776
1777       gnu_size = convert (gnu_size_type, gnu_size);
1778
1779       /* The first arg is the address of the object, for a deallocator,
1780          then the size.  */
1781       if (gnu_obj)
1782         gnu_call = build_call_nary (TREE_TYPE (TREE_TYPE (gnu_proc)),
1783                                     gnu_proc_addr, 2, gnu_obj, gnu_size);
1784       else
1785         gnu_call = build_call_nary (TREE_TYPE (TREE_TYPE (gnu_proc)),
1786                                     gnu_proc_addr, 1, gnu_size);
1787     }
1788
1789   TREE_SIDE_EFFECTS (gnu_call) = 1;
1790   return gnu_call;
1791 }
1792
1793 /* Helper for build_call_alloc_dealloc, to build and return an allocator for
1794    DATA_SIZE bytes aimed at containing a DATA_TYPE object, using the default
1795    __gnat_malloc allocator.  Honor DATA_TYPE alignments greater than what the
1796    latter offers.  */
1797
1798 static inline tree
1799 maybe_wrap_malloc (tree data_size, tree data_type, Node_Id gnat_node)
1800 {
1801   /* When the DATA_TYPE alignment is stricter than what malloc offers
1802      (super-aligned case), we allocate an "aligning" wrapper type and return
1803      the address of its single data field with the malloc's return value
1804      stored just in front.  */
1805
1806   unsigned int data_align = TYPE_ALIGN (data_type);
1807   unsigned int default_allocator_alignment
1808       = get_target_default_allocator_alignment () * BITS_PER_UNIT;
1809
1810   tree aligning_type
1811     = ((data_align > default_allocator_alignment)
1812        ? make_aligning_type (data_type, data_align, data_size,
1813                              default_allocator_alignment,
1814                              POINTER_SIZE / BITS_PER_UNIT)
1815        : NULL_TREE);
1816
1817   tree size_to_malloc
1818     = aligning_type ? TYPE_SIZE_UNIT (aligning_type) : data_size;
1819
1820   tree malloc_ptr;
1821
1822   /* On VMS, if 64-bit memory is disabled or pointers are 64-bit and the
1823      allocator size is 32-bit or Convention C, allocate 32-bit memory.  */
1824   if (TARGET_ABI_OPEN_VMS
1825       && (!TARGET_MALLOC64
1826           || (POINTER_SIZE == 64
1827               && (UI_To_Int (Esize (Etype (gnat_node))) == 32
1828                   || Convention (Etype (gnat_node)) == Convention_C))))
1829     malloc_ptr = build_call_1_expr (malloc32_decl, size_to_malloc);
1830   else
1831     malloc_ptr = build_call_1_expr (malloc_decl, size_to_malloc);
1832
1833   if (aligning_type)
1834     {
1835       /* Latch malloc's return value and get a pointer to the aligning field
1836          first.  */
1837       tree storage_ptr = gnat_protect_expr (malloc_ptr);
1838
1839       tree aligning_record_addr
1840         = convert (build_pointer_type (aligning_type), storage_ptr);
1841
1842       tree aligning_record
1843         = build_unary_op (INDIRECT_REF, NULL_TREE, aligning_record_addr);
1844
1845       tree aligning_field
1846         = build_component_ref (aligning_record, NULL_TREE,
1847                                TYPE_FIELDS (aligning_type), false);
1848
1849       tree aligning_field_addr
1850         = build_unary_op (ADDR_EXPR, NULL_TREE, aligning_field);
1851
1852       /* Then arrange to store the allocator's return value ahead
1853          and return.  */
1854       tree storage_ptr_slot_addr
1855         = build_binary_op (POINTER_PLUS_EXPR, ptr_void_type_node,
1856                            convert (ptr_void_type_node, aligning_field_addr),
1857                            size_int (-(HOST_WIDE_INT) POINTER_SIZE
1858                                      / BITS_PER_UNIT));
1859
1860       tree storage_ptr_slot
1861         = build_unary_op (INDIRECT_REF, NULL_TREE,
1862                           convert (build_pointer_type (ptr_void_type_node),
1863                                    storage_ptr_slot_addr));
1864
1865       return
1866         build2 (COMPOUND_EXPR, TREE_TYPE (aligning_field_addr),
1867                 build_binary_op (MODIFY_EXPR, NULL_TREE,
1868                                  storage_ptr_slot, storage_ptr),
1869                 aligning_field_addr);
1870     }
1871   else
1872     return malloc_ptr;
1873 }
1874
1875 /* Helper for build_call_alloc_dealloc, to release a DATA_TYPE object
1876    designated by DATA_PTR using the __gnat_free entry point.  */
1877
1878 static inline tree
1879 maybe_wrap_free (tree data_ptr, tree data_type)
1880 {
1881   /* In the regular alignment case, we pass the data pointer straight to free.
1882      In the superaligned case, we need to retrieve the initial allocator
1883      return value, stored in front of the data block at allocation time.  */
1884
1885   unsigned int data_align = TYPE_ALIGN (data_type);
1886   unsigned int default_allocator_alignment
1887       = get_target_default_allocator_alignment () * BITS_PER_UNIT;
1888
1889   tree free_ptr;
1890
1891   if (data_align > default_allocator_alignment)
1892     {
1893       /* DATA_FRONT_PTR (void *)
1894          = (void *)DATA_PTR - (void *)sizeof (void *))  */
1895       tree data_front_ptr
1896         = build_binary_op
1897           (POINTER_PLUS_EXPR, ptr_void_type_node,
1898            convert (ptr_void_type_node, data_ptr),
1899            size_int (-(HOST_WIDE_INT) POINTER_SIZE / BITS_PER_UNIT));
1900
1901       /* FREE_PTR (void *) = *(void **)DATA_FRONT_PTR  */
1902       free_ptr
1903         = build_unary_op
1904           (INDIRECT_REF, NULL_TREE,
1905            convert (build_pointer_type (ptr_void_type_node), data_front_ptr));
1906     }
1907   else
1908     free_ptr = data_ptr;
1909
1910   return build_call_1_expr (free_decl, free_ptr);
1911 }
1912
1913 /* Build a GCC tree to call an allocation or deallocation function.
1914    If GNU_OBJ is nonzero, it is an object to deallocate.  Otherwise,
1915    generate an allocator.
1916
1917    GNU_SIZE is the number of bytes to allocate and GNU_TYPE is the contained
1918    object type, used to determine the to-be-honored address alignment.
1919    GNAT_PROC, if present, is a procedure to call and GNAT_POOL is the storage
1920    pool to use.  If not present, malloc and free are used.  GNAT_NODE is used
1921    to provide an error location for restriction violation messages.  */
1922
1923 tree
1924 build_call_alloc_dealloc (tree gnu_obj, tree gnu_size, tree gnu_type,
1925                           Entity_Id gnat_proc, Entity_Id gnat_pool,
1926                           Node_Id gnat_node)
1927 {
1928   gnu_size = SUBSTITUTE_PLACEHOLDER_IN_EXPR (gnu_size, gnu_obj);
1929
1930   /* Explicit proc to call ?  This one is assumed to deal with the type
1931      alignment constraints.  */
1932   if (Present (gnat_proc))
1933     return build_call_alloc_dealloc_proc (gnu_obj, gnu_size, gnu_type,
1934                                           gnat_proc, gnat_pool);
1935
1936   /* Otherwise, object to "free" or "malloc" with possible special processing
1937      for alignments stricter than what the default allocator honors.  */
1938   else if (gnu_obj)
1939     return maybe_wrap_free (gnu_obj, gnu_type);
1940   else
1941     {
1942       /* Assert that we no longer can be called with this special pool.  */
1943       gcc_assert (gnat_pool != -1);
1944
1945       /* Check that we aren't violating the associated restriction.  */
1946       if (!(Nkind (gnat_node) == N_Allocator && Comes_From_Source (gnat_node)))
1947         Check_No_Implicit_Heap_Alloc (gnat_node);
1948
1949       return maybe_wrap_malloc (gnu_size, gnu_type, gnat_node);
1950     }
1951 }
1952 \f
1953 /* Build a GCC tree to correspond to allocating an object of TYPE whose
1954    initial value is INIT, if INIT is nonzero.  Convert the expression to
1955    RESULT_TYPE, which must be some type of pointer.  Return the tree.
1956
1957    GNAT_PROC and GNAT_POOL optionally give the procedure to call and
1958    the storage pool to use.  GNAT_NODE is used to provide an error
1959    location for restriction violation messages.  If IGNORE_INIT_TYPE is
1960    true, ignore the type of INIT for the purpose of determining the size;
1961    this will cause the maximum size to be allocated if TYPE is of
1962    self-referential size.  */
1963
1964 tree
1965 build_allocator (tree type, tree init, tree result_type, Entity_Id gnat_proc,
1966                  Entity_Id gnat_pool, Node_Id gnat_node, bool ignore_init_type)
1967 {
1968   tree size = TYPE_SIZE_UNIT (type);
1969   tree result;
1970
1971   /* If the initializer, if present, is a NULL_EXPR, just return a new one.  */
1972   if (init && TREE_CODE (init) == NULL_EXPR)
1973     return build1 (NULL_EXPR, result_type, TREE_OPERAND (init, 0));
1974
1975   /* If RESULT_TYPE is a fat or thin pointer, set SIZE to be the sum of the
1976      sizes of the object and its template.  Allocate the whole thing and
1977      fill in the parts that are known.  */
1978   else if (TYPE_IS_FAT_OR_THIN_POINTER_P (result_type))
1979     {
1980       tree storage_type
1981         = build_unc_object_type_from_ptr (result_type, type,
1982                                           get_identifier ("ALLOC"));
1983       tree template_type = TREE_TYPE (TYPE_FIELDS (storage_type));
1984       tree storage_ptr_type = build_pointer_type (storage_type);
1985       tree storage;
1986       tree template_cons = NULL_TREE;
1987
1988       size = SUBSTITUTE_PLACEHOLDER_IN_EXPR (TYPE_SIZE_UNIT (storage_type),
1989                                              init);
1990
1991       /* If the size overflows, pass -1 so the allocator will raise
1992          storage error.  */
1993       if (TREE_CODE (size) == INTEGER_CST && TREE_OVERFLOW (size))
1994         size = ssize_int (-1);
1995
1996       storage = build_call_alloc_dealloc (NULL_TREE, size, storage_type,
1997                                           gnat_proc, gnat_pool, gnat_node);
1998       storage = convert (storage_ptr_type, gnat_protect_expr (storage));
1999
2000       if (TYPE_IS_PADDING_P (type))
2001         {
2002           type = TREE_TYPE (TYPE_FIELDS (type));
2003           if (init)
2004             init = convert (type, init);
2005         }
2006
2007       /* If there is an initializing expression, make a constructor for
2008          the entire object including the bounds and copy it into the
2009          object.  If there is no initializing expression, just set the
2010          bounds.  */
2011       if (init)
2012         {
2013           template_cons = tree_cons (TREE_CHAIN (TYPE_FIELDS (storage_type)),
2014                                      init, NULL_TREE);
2015           template_cons = tree_cons (TYPE_FIELDS (storage_type),
2016                                      build_template (template_type, type,
2017                                                      init),
2018                                      template_cons);
2019
2020           return convert
2021             (result_type,
2022              build2 (COMPOUND_EXPR, storage_ptr_type,
2023                      build_binary_op
2024                      (MODIFY_EXPR, storage_type,
2025                       build_unary_op (INDIRECT_REF, NULL_TREE,
2026                                       convert (storage_ptr_type, storage)),
2027                       gnat_build_constructor (storage_type, template_cons)),
2028                      convert (storage_ptr_type, storage)));
2029         }
2030       else
2031         return build2
2032           (COMPOUND_EXPR, result_type,
2033            build_binary_op
2034            (MODIFY_EXPR, template_type,
2035             build_component_ref
2036             (build_unary_op (INDIRECT_REF, NULL_TREE,
2037                              convert (storage_ptr_type, storage)),
2038              NULL_TREE, TYPE_FIELDS (storage_type), false),
2039             build_template (template_type, type, NULL_TREE)),
2040            convert (result_type, convert (storage_ptr_type, storage)));
2041     }
2042
2043   /* If we have an initializing expression, see if its size is simpler
2044      than the size from the type.  */
2045   if (!ignore_init_type && init && TYPE_SIZE_UNIT (TREE_TYPE (init))
2046       && (TREE_CODE (TYPE_SIZE_UNIT (TREE_TYPE (init))) == INTEGER_CST
2047           || CONTAINS_PLACEHOLDER_P (size)))
2048     size = TYPE_SIZE_UNIT (TREE_TYPE (init));
2049
2050   /* If the size is still self-referential, reference the initializing
2051      expression, if it is present.  If not, this must have been a
2052      call to allocate a library-level object, in which case we use
2053      the maximum size.  */
2054   if (CONTAINS_PLACEHOLDER_P (size))
2055     {
2056       if (!ignore_init_type && init)
2057         size = substitute_placeholder_in_expr (size, init);
2058       else
2059         size = max_size (size, true);
2060     }
2061
2062   /* If the size overflows, pass -1 so the allocator will raise
2063      storage error.  */
2064   if (TREE_CODE (size) == INTEGER_CST && TREE_OVERFLOW (size))
2065     size = ssize_int (-1);
2066
2067   result = convert (result_type,
2068                     build_call_alloc_dealloc (NULL_TREE, size, type,
2069                                               gnat_proc, gnat_pool,
2070                                               gnat_node));
2071
2072   /* If we have an initial value, protect the new address, assign the value
2073      and return the address with a COMPOUND_EXPR.  */
2074   if (init)
2075     {
2076       result = gnat_protect_expr (result);
2077       result
2078         = build2 (COMPOUND_EXPR, TREE_TYPE (result),
2079                   build_binary_op
2080                   (MODIFY_EXPR, NULL_TREE,
2081                    build_unary_op (INDIRECT_REF,
2082                                    TREE_TYPE (TREE_TYPE (result)), result),
2083                    init),
2084                   result);
2085     }
2086
2087   return convert (result_type, result);
2088 }
2089 \f
2090 /* Fill in a VMS descriptor for EXPR and return a constructor for it.
2091    GNAT_FORMAL is how we find the descriptor record.  GNAT_ACTUAL is
2092    how we derive the source location to raise C_E on an out of range
2093    pointer. */
2094
2095 tree
2096 fill_vms_descriptor (tree expr, Entity_Id gnat_formal, Node_Id gnat_actual)
2097 {
2098   tree parm_decl = get_gnu_tree (gnat_formal);
2099   tree record_type = TREE_TYPE (TREE_TYPE (parm_decl));
2100   tree const_list = NULL_TREE, field;
2101   const bool do_range_check
2102     = strcmp ("MBO",
2103               IDENTIFIER_POINTER (DECL_NAME (TYPE_FIELDS (record_type))));
2104
2105   expr = maybe_unconstrained_array (expr);
2106   gnat_mark_addressable (expr);
2107
2108   for (field = TYPE_FIELDS (record_type); field; field = TREE_CHAIN (field))
2109     {
2110       tree conexpr = convert (TREE_TYPE (field),
2111                               SUBSTITUTE_PLACEHOLDER_IN_EXPR
2112                               (DECL_INITIAL (field), expr));
2113
2114       /* Check to ensure that only 32-bit pointers are passed in
2115          32-bit descriptors */
2116       if (do_range_check
2117           && strcmp (IDENTIFIER_POINTER (DECL_NAME (field)), "POINTER") == 0)
2118         {
2119           tree pointer64type
2120             = build_pointer_type_for_mode (void_type_node, DImode, false);
2121           tree addr64expr = build_unary_op (ADDR_EXPR, pointer64type, expr);
2122           tree malloc64low
2123             = build_int_cstu (long_integer_type_node, 0x80000000);
2124
2125           add_stmt (build3 (COND_EXPR, void_type_node,
2126                             build_binary_op (GE_EXPR, boolean_type_node,
2127                                              convert (long_integer_type_node,
2128                                                       addr64expr),
2129                                              malloc64low),
2130                             build_call_raise (CE_Range_Check_Failed,
2131                                               gnat_actual,
2132                                               N_Raise_Constraint_Error),
2133                             NULL_TREE));
2134         }
2135       const_list = tree_cons (field, conexpr, const_list);
2136     }
2137
2138   return gnat_build_constructor (record_type, nreverse (const_list));
2139 }
2140
2141 /* Indicate that we need to take the address of T and that it therefore
2142    should not be allocated in a register.  Returns true if successful.  */
2143
2144 bool
2145 gnat_mark_addressable (tree t)
2146 {
2147   while (true)
2148     switch (TREE_CODE (t))
2149       {
2150       case ADDR_EXPR:
2151       case COMPONENT_REF:
2152       case ARRAY_REF:
2153       case ARRAY_RANGE_REF:
2154       case REALPART_EXPR:
2155       case IMAGPART_EXPR:
2156       case VIEW_CONVERT_EXPR:
2157       case NON_LVALUE_EXPR:
2158       CASE_CONVERT:
2159         t = TREE_OPERAND (t, 0);
2160         break;
2161
2162       case COMPOUND_EXPR:
2163         t = TREE_OPERAND (t, 1);
2164         break;
2165
2166       case CONSTRUCTOR:
2167         TREE_ADDRESSABLE (t) = 1;
2168         return true;
2169
2170       case VAR_DECL:
2171       case PARM_DECL:
2172       case RESULT_DECL:
2173         TREE_ADDRESSABLE (t) = 1;
2174         return true;
2175
2176       case FUNCTION_DECL:
2177         TREE_ADDRESSABLE (t) = 1;
2178         return true;
2179
2180       case CONST_DECL:
2181         return DECL_CONST_CORRESPONDING_VAR (t)
2182                && gnat_mark_addressable (DECL_CONST_CORRESPONDING_VAR (t));
2183
2184       default:
2185         return true;
2186     }
2187 }
2188 \f
2189 /* Save EXP for later use or reuse.  This is equivalent to save_expr in tree.c
2190    but we know how to handle our own nodes.  */
2191
2192 tree
2193 gnat_save_expr (tree exp)
2194 {
2195   tree type = TREE_TYPE (exp);
2196   enum tree_code code = TREE_CODE (exp);
2197
2198   if (TREE_CONSTANT (exp) || code == SAVE_EXPR || code == NULL_EXPR)
2199     return exp;
2200
2201   if (code == UNCONSTRAINED_ARRAY_REF)
2202     {
2203       tree t = build1 (code, type, gnat_save_expr (TREE_OPERAND (exp, 0)));
2204       TREE_READONLY (t) = TYPE_READONLY (type);
2205       return t;
2206     }
2207
2208   /* If this is a COMPONENT_REF of a fat pointer, save the entire fat pointer.
2209      This may be more efficient, but will also allow us to more easily find
2210      the match for the PLACEHOLDER_EXPR.  */
2211   if (code == COMPONENT_REF
2212       && TYPE_IS_FAT_POINTER_P (TREE_TYPE (TREE_OPERAND (exp, 0))))
2213     return build3 (code, type, gnat_save_expr (TREE_OPERAND (exp, 0)),
2214                    TREE_OPERAND (exp, 1), TREE_OPERAND (exp, 2));
2215
2216   return save_expr (exp);
2217 }
2218
2219 /* Protect EXP for immediate reuse.  This is a variant of gnat_save_expr that
2220    is optimized under the assumption that EXP's value doesn't change before
2221    its subsequent reuse(s) except through its potential reevaluation.  */
2222
2223 tree
2224 gnat_protect_expr (tree exp)
2225 {
2226   tree type = TREE_TYPE (exp);
2227   enum tree_code code = TREE_CODE (exp);
2228
2229   if (TREE_CONSTANT (exp) || code == SAVE_EXPR || code == NULL_EXPR)
2230     return exp;
2231
2232   /* If EXP has no side effects, we theoritically don't need to do anything.
2233      However, we may be recursively passed more and more complex expressions
2234      involving checks which will be reused multiple times and eventually be
2235      unshared for gimplification; in order to avoid a complexity explosion
2236      at that point, we protect any expressions more complex than a simple
2237      arithmetic expression.  */
2238   if (!TREE_SIDE_EFFECTS (exp))
2239     {
2240       tree inner = skip_simple_arithmetic (exp);
2241       if (!EXPR_P (inner) || REFERENCE_CLASS_P (inner))
2242         return exp;
2243     }
2244
2245   /* If this is a conversion, protect what's inside the conversion.  */
2246   if (code == NON_LVALUE_EXPR
2247       || CONVERT_EXPR_CODE_P (code)
2248       || code == VIEW_CONVERT_EXPR)
2249   return build1 (code, type, gnat_protect_expr (TREE_OPERAND (exp, 0)));
2250
2251   /* If we're indirectly referencing something, we only need to protect the
2252      address since the data itself can't change in these situations.  */
2253   if (code == INDIRECT_REF || code == UNCONSTRAINED_ARRAY_REF)
2254     {
2255       tree t = build1 (code, type, gnat_protect_expr (TREE_OPERAND (exp, 0)));
2256       TREE_READONLY (t) = TYPE_READONLY (type);
2257       return t;
2258     }
2259
2260   /* If this is a COMPONENT_REF of a fat pointer, save the entire fat pointer.
2261      This may be more efficient, but will also allow us to more easily find
2262      the match for the PLACEHOLDER_EXPR.  */
2263   if (code == COMPONENT_REF
2264       && TYPE_IS_FAT_POINTER_P (TREE_TYPE (TREE_OPERAND (exp, 0))))
2265     return build3 (code, type, gnat_protect_expr (TREE_OPERAND (exp, 0)),
2266                    TREE_OPERAND (exp, 1), TREE_OPERAND (exp, 2));
2267
2268   /* If this is a fat pointer or something that can be placed in a register,
2269      just make a SAVE_EXPR.  Likewise for a CALL_EXPR as large objects are
2270      returned via invisible reference in most ABIs so the temporary will
2271      directly be filled by the callee.  */
2272   if (TYPE_IS_FAT_POINTER_P (type)
2273       || TYPE_MODE (type) != BLKmode
2274       || code == CALL_EXPR)
2275     return save_expr (exp);
2276
2277   /* Otherwise reference, protect the address and dereference.  */
2278   return
2279     build_unary_op (INDIRECT_REF, type,
2280                     save_expr (build_unary_op (ADDR_EXPR,
2281                                                build_reference_type (type),
2282                                                exp)));
2283 }
2284
2285 /* This is equivalent to stabilize_reference_1 in tree.c but we take an extra
2286    argument to force evaluation of everything.  */
2287
2288 static tree
2289 gnat_stabilize_reference_1 (tree e, bool force)
2290 {
2291   enum tree_code code = TREE_CODE (e);
2292   tree type = TREE_TYPE (e);
2293   tree result;
2294
2295   /* We cannot ignore const expressions because it might be a reference
2296      to a const array but whose index contains side-effects.  But we can
2297      ignore things that are actual constant or that already have been
2298      handled by this function.  */
2299   if (TREE_CONSTANT (e) || code == SAVE_EXPR)
2300     return e;
2301
2302   switch (TREE_CODE_CLASS (code))
2303     {
2304     case tcc_exceptional:
2305     case tcc_declaration:
2306     case tcc_comparison:
2307     case tcc_expression:
2308     case tcc_reference:
2309     case tcc_vl_exp:
2310       /* If this is a COMPONENT_REF of a fat pointer, save the entire
2311          fat pointer.  This may be more efficient, but will also allow
2312          us to more easily find the match for the PLACEHOLDER_EXPR.  */
2313       if (code == COMPONENT_REF
2314           && TYPE_IS_FAT_POINTER_P (TREE_TYPE (TREE_OPERAND (e, 0))))
2315         result
2316           = build3 (code, type,
2317                     gnat_stabilize_reference_1 (TREE_OPERAND (e, 0), force),
2318                     TREE_OPERAND (e, 1), TREE_OPERAND (e, 2));
2319       /* If the expression has side-effects, then encase it in a SAVE_EXPR
2320          so that it will only be evaluated once.  */
2321       /* The tcc_reference and tcc_comparison classes could be handled as
2322          below, but it is generally faster to only evaluate them once.  */
2323       else if (TREE_SIDE_EFFECTS (e) || force)
2324         return save_expr (e);
2325       else
2326         return e;
2327       break;
2328
2329     case tcc_binary:
2330       /* Recursively stabilize each operand.  */
2331       result
2332         = build2 (code, type,
2333                   gnat_stabilize_reference_1 (TREE_OPERAND (e, 0), force),
2334                   gnat_stabilize_reference_1 (TREE_OPERAND (e, 1), force));
2335       break;
2336
2337     case tcc_unary:
2338       /* Recursively stabilize each operand.  */
2339       result
2340         = build1 (code, type,
2341                   gnat_stabilize_reference_1 (TREE_OPERAND (e, 0), force));
2342       break;
2343
2344     default:
2345       gcc_unreachable ();
2346     }
2347
2348   /* See similar handling in gnat_stabilize_reference.  */
2349   TREE_READONLY (result) = TREE_READONLY (e);
2350   TREE_SIDE_EFFECTS (result) |= TREE_SIDE_EFFECTS (e);
2351   TREE_THIS_VOLATILE (result) = TREE_THIS_VOLATILE (e);
2352
2353   return result;
2354 }
2355
2356 /* This is equivalent to stabilize_reference in tree.c but we know how to
2357    handle our own nodes and we take extra arguments.  FORCE says whether to
2358    force evaluation of everything.  We set SUCCESS to true unless we walk
2359    through something we don't know how to stabilize.  */
2360
2361 tree
2362 gnat_stabilize_reference (tree ref, bool force, bool *success)
2363 {
2364   tree type = TREE_TYPE (ref);
2365   enum tree_code code = TREE_CODE (ref);
2366   tree result;
2367
2368   /* Assume we'll success unless proven otherwise.  */
2369   if (success)
2370     *success = true;
2371
2372   switch (code)
2373     {
2374     case CONST_DECL:
2375     case VAR_DECL:
2376     case PARM_DECL:
2377     case RESULT_DECL:
2378       /* No action is needed in this case.  */
2379       return ref;
2380
2381     case ADDR_EXPR:
2382     CASE_CONVERT:
2383     case FLOAT_EXPR:
2384     case FIX_TRUNC_EXPR:
2385     case VIEW_CONVERT_EXPR:
2386       result
2387         = build1 (code, type,
2388                   gnat_stabilize_reference (TREE_OPERAND (ref, 0), force,
2389                                             success));
2390       break;
2391
2392     case INDIRECT_REF:
2393     case UNCONSTRAINED_ARRAY_REF:
2394       result = build1 (code, type,
2395                        gnat_stabilize_reference_1 (TREE_OPERAND (ref, 0),
2396                                                    force));
2397       break;
2398
2399     case COMPONENT_REF:
2400      result = build3 (COMPONENT_REF, type,
2401                       gnat_stabilize_reference (TREE_OPERAND (ref, 0), force,
2402                                                 success),
2403                       TREE_OPERAND (ref, 1), NULL_TREE);
2404       break;
2405
2406     case BIT_FIELD_REF:
2407       result = build3 (BIT_FIELD_REF, type,
2408                        gnat_stabilize_reference (TREE_OPERAND (ref, 0), force,
2409                                                  success),
2410                        gnat_stabilize_reference_1 (TREE_OPERAND (ref, 1),
2411                                                    force),
2412                        gnat_stabilize_reference_1 (TREE_OPERAND (ref, 2),
2413                                                    force));
2414       break;
2415
2416     case ARRAY_REF:
2417     case ARRAY_RANGE_REF:
2418       result = build4 (code, type,
2419                        gnat_stabilize_reference (TREE_OPERAND (ref, 0), force,
2420                                                  success),
2421                        gnat_stabilize_reference_1 (TREE_OPERAND (ref, 1),
2422                                                    force),
2423                        NULL_TREE, NULL_TREE);
2424       break;
2425
2426     case CALL_EXPR:
2427       result = gnat_stabilize_reference_1 (ref, force);
2428       break;
2429
2430     case COMPOUND_EXPR:
2431       result = build2 (COMPOUND_EXPR, type,
2432                        gnat_stabilize_reference (TREE_OPERAND (ref, 0), force,
2433                                                  success),
2434                        gnat_stabilize_reference_1 (TREE_OPERAND (ref, 1),
2435                                                    force));
2436       break;
2437
2438     case CONSTRUCTOR:
2439       /* Constructors with 1 element are used extensively to formally
2440          convert objects to special wrapping types.  */
2441       if (TREE_CODE (type) == RECORD_TYPE
2442           && VEC_length (constructor_elt, CONSTRUCTOR_ELTS (ref)) == 1)
2443         {
2444           tree index
2445             = VEC_index (constructor_elt, CONSTRUCTOR_ELTS (ref), 0)->index;
2446           tree value
2447             = VEC_index (constructor_elt, CONSTRUCTOR_ELTS (ref), 0)->value;
2448           result
2449             = build_constructor_single (type, index,
2450                                         gnat_stabilize_reference_1 (value,
2451                                                                     force));
2452         }
2453       else
2454         {
2455           if (success)
2456             *success = false;
2457           return ref;
2458         }
2459       break;
2460
2461     case ERROR_MARK:
2462       ref = error_mark_node;
2463
2464       /* ...  fall through to failure ... */
2465
2466       /* If arg isn't a kind of lvalue we recognize, make no change.
2467          Caller should recognize the error for an invalid lvalue.  */
2468     default:
2469       if (success)
2470         *success = false;
2471       return ref;
2472     }
2473
2474   /* TREE_THIS_VOLATILE and TREE_SIDE_EFFECTS set on the initial expression
2475      may not be sustained across some paths, such as the way via build1 for
2476      INDIRECT_REF.  We reset those flags here in the general case, which is
2477      consistent with the GCC version of this routine.
2478
2479      Special care should be taken regarding TREE_SIDE_EFFECTS, because some
2480      paths introduce side-effects where there was none initially (e.g. if a
2481      SAVE_EXPR is built) and we also want to keep track of that.  */
2482   TREE_READONLY (result) = TREE_READONLY (ref);
2483   TREE_SIDE_EFFECTS (result) |= TREE_SIDE_EFFECTS (ref);
2484   TREE_THIS_VOLATILE (result) = TREE_THIS_VOLATILE (ref);
2485
2486   return result;
2487 }