OSDN Git Service

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