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