OSDN Git Service

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