OSDN Git Service

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