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   TREE_SIDE_EFFECTS (result) |= has_side_effects;
 964   TREE_CONSTANT (result)
 965     |= (TREE_CONSTANT (left_operand) & TREE_CONSTANT (right_operand)
 966         && op_code != ARRAY_REF && op_code != ARRAY_RANGE_REF);
 967
 968   if ((op_code == ARRAY_REF || op_code == ARRAY_RANGE_REF)
 969       && TYPE_VOLATILE (operation_type))
 970     TREE_THIS_VOLATILE (result) = 1;
 971
 972   /* If we are working with modular types, perform the MOD operation
 973      if something above hasn't eliminated the need for it.  */
 974   if (modulus)
 975     result = fold_build2 (FLOOR_MOD_EXPR, operation_type, result,
 976                           convert (operation_type, modulus));
 977
 978   if (result_type && result_type != operation_type)
 979     result = convert (result_type, result);
 980
 981   return result;
 982 }
 983 \f
 984 /* Similar, but for unary operations.  */
 985
 986 tree
 987 build_unary_op (enum tree_code op_code, tree result_type, tree operand)
 988 {
 989   tree type = TREE_TYPE (operand);
 990   tree base_type = get_base_type (type);
 991   tree operation_type = result_type;
 992   tree result;
 993   bool side_effects = false;
 994
 995   if (operation_type
 996       && TREE_CODE (operation_type) == RECORD_TYPE
 997       && TYPE_JUSTIFIED_MODULAR_P (operation_type))
 998     operation_type = TREE_TYPE (TYPE_FIELDS (operation_type));
 999
1000   if (operation_type
1001       && !AGGREGATE_TYPE_P (operation_type)
1002       && TYPE_EXTRA_SUBTYPE_P (operation_type))
1003     operation_type = get_base_type (operation_type);
1004
1005   switch (op_code)
1006     {
1007     case REALPART_EXPR:
1008     case IMAGPART_EXPR:
1009       if (!operation_type)
1010         result_type = operation_type = TREE_TYPE (type);
1011       else
1012         gcc_assert (result_type == TREE_TYPE (type));
1013
1014       result = fold_build1 (op_code, operation_type, operand);
1015       break;
1016
1017     case TRUTH_NOT_EXPR:
1018 #ifdef ENABLE_CHECKING
1019       gcc_assert (TREE_CODE (get_base_type (result_type)) == BOOLEAN_TYPE);
1020 #endif
1021       result = invert_truthvalue_loc (EXPR_LOCATION (operand), operand);
1022       break;
1023
1024     case ATTR_ADDR_EXPR:
1025     case ADDR_EXPR:
1026       switch (TREE_CODE (operand))
1027         {
1028         case INDIRECT_REF:
1029         case UNCONSTRAINED_ARRAY_REF:
1030           result = TREE_OPERAND (operand, 0);
1031
1032           /* Make sure the type here is a pointer, not a reference.
1033              GCC wants pointer types for function addresses.  */
1034           if (!result_type)
1035             result_type = build_pointer_type (type);
1036
1037           /* If the underlying object can alias everything, propagate the
1038              property since we are effectively retrieving the object.  */
1039           if (POINTER_TYPE_P (TREE_TYPE (result))
1040               && TYPE_REF_CAN_ALIAS_ALL (TREE_TYPE (result)))
1041             {
1042               if (TREE_CODE (result_type) == POINTER_TYPE
1043                   && !TYPE_REF_CAN_ALIAS_ALL (result_type))
1044                 result_type
1045                   = build_pointer_type_for_mode (TREE_TYPE (result_type),
1046                                                  TYPE_MODE (result_type),
1047                                                  true);
1048               else if (TREE_CODE (result_type) == REFERENCE_TYPE
1049                        && !TYPE_REF_CAN_ALIAS_ALL (result_type))
1050                 result_type
1051                   = build_reference_type_for_mode (TREE_TYPE (result_type),
1052                                                    TYPE_MODE (result_type),
1053                                                    true);
1054             }
1055           break;
1056
1057         case NULL_EXPR:
1058           result = operand;
1059           TREE_TYPE (result) = type = build_pointer_type (type);
1060           break;
1061
1062         case COMPOUND_EXPR:
1063           /* Fold a compound expression if it has unconstrained array type
1064              since the middle-end cannot handle it.  But we don't it in the
1065              general case because it may introduce aliasing issues if the
1066              first operand is an indirect assignment and the second operand
1067              the corresponding address, e.g. for an allocator.  */
1068           if (TREE_CODE (type) == UNCONSTRAINED_ARRAY_TYPE)
1069             {
1070               result = build_unary_op (ADDR_EXPR, result_type,
1071                                        TREE_OPERAND (operand, 1));
1072               result = build2 (COMPOUND_EXPR, TREE_TYPE (result),
1073                                TREE_OPERAND (operand, 0), result);
1074               break;
1075             }
1076           goto common;
1077
1078         case ARRAY_REF:
1079         case ARRAY_RANGE_REF:
1080         case COMPONENT_REF:
1081         case BIT_FIELD_REF:
1082             /* If this is for 'Address, find the address of the prefix and add
1083                the offset to the field.  Otherwise, do this the normal way.  */
1084           if (op_code == ATTR_ADDR_EXPR)
1085             {
1086               HOST_WIDE_INT bitsize;
1087               HOST_WIDE_INT bitpos;
1088               tree offset, inner;
1089               enum machine_mode mode;
1090               int unsignedp, volatilep;
1091
1092               inner = get_inner_reference (operand, &bitsize, &bitpos, &offset,
1093                                            &mode, &unsignedp, &volatilep,
1094                                            false);
1095
1096               /* If INNER is a padding type whose field has a self-referential
1097                  size, convert to that inner type.  We know the offset is zero
1098                  and we need to have that type visible.  */
1099               if (TYPE_IS_PADDING_P (TREE_TYPE (inner))
1100                   && CONTAINS_PLACEHOLDER_P
1101                      (TYPE_SIZE (TREE_TYPE (TYPE_FIELDS
1102                                             (TREE_TYPE (inner))))))
1103                 inner = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (inner))),
1104                                  inner);
1105
1106               /* Compute the offset as a byte offset from INNER.  */
1107               if (!offset)
1108                 offset = size_zero_node;
1109
1110               offset = size_binop (PLUS_EXPR, offset,
1111                                    size_int (bitpos / BITS_PER_UNIT));
1112
1113               /* Take the address of INNER, convert the offset to void *, and
1114                  add then.  It will later be converted to the desired result
1115                  type, if any.  */
1116               inner = build_unary_op (ADDR_EXPR, NULL_TREE, inner);
1117               inner = convert (ptr_void_type_node, inner);
1118               result = build_binary_op (POINTER_PLUS_EXPR, ptr_void_type_node,
1119                                         inner, offset);
1120               result = convert (build_pointer_type (TREE_TYPE (operand)),
1121                                 result);
1122               break;
1123             }
1124           goto common;
1125
1126         case CONSTRUCTOR:
1127           /* If this is just a constructor for a padded record, we can
1128              just take the address of the single field and convert it to
1129              a pointer to our type.  */
1130           if (TYPE_IS_PADDING_P (type))
1131             {
1132               result = VEC_index (constructor_elt,
1133                                   CONSTRUCTOR_ELTS (operand),
1134                                   0)->value;
1135               result = convert (build_pointer_type (TREE_TYPE (operand)),
1136                                 build_unary_op (ADDR_EXPR, NULL_TREE, result));
1137               break;
1138             }
1139
1140           goto common;
1141
1142         case NOP_EXPR:
1143           if (AGGREGATE_TYPE_P (type)
1144               && AGGREGATE_TYPE_P (TREE_TYPE (TREE_OPERAND (operand, 0))))
1145             return build_unary_op (ADDR_EXPR, result_type,
1146                                    TREE_OPERAND (operand, 0));
1147
1148           /* ... fallthru ... */
1149
1150         case VIEW_CONVERT_EXPR:
1151           /* If this just a variant conversion or if the conversion doesn't
1152              change the mode, get the result type from this type and go down.
1153              This is needed for conversions of CONST_DECLs, to eventually get
1154              to the address of their CORRESPONDING_VARs.  */
1155           if ((TYPE_MAIN_VARIANT (type)
1156                == TYPE_MAIN_VARIANT (TREE_TYPE (TREE_OPERAND (operand, 0))))
1157               || (TYPE_MODE (type) != BLKmode
1158                   && (TYPE_MODE (type)
1159                       == TYPE_MODE (TREE_TYPE (TREE_OPERAND (operand, 0))))))
1160             return build_unary_op (ADDR_EXPR,
1161                                    (result_type ? result_type
1162                                     : build_pointer_type (type)),
1163                                    TREE_OPERAND (operand, 0));
1164           goto common;
1165
1166         case CONST_DECL:
1167           operand = DECL_CONST_CORRESPONDING_VAR (operand);
1168
1169           /* ... fall through ... */
1170
1171         default:
1172         common:
1173
1174           /* If we are taking the address of a padded record whose field is
1175              contains a template, take the address of the template.  */
1176           if (TYPE_IS_PADDING_P (type)
1177               && TREE_CODE (TREE_TYPE (TYPE_FIELDS (type))) == RECORD_TYPE
1178               && TYPE_CONTAINS_TEMPLATE_P (TREE_TYPE (TYPE_FIELDS (type))))
1179             {
1180               type = TREE_TYPE (TYPE_FIELDS (type));
1181               operand = convert (type, operand);
1182             }
1183
1184           gnat_mark_addressable (operand);
1185           result = build_fold_addr_expr (operand);
1186         }
1187
1188       TREE_CONSTANT (result) = staticp (operand) || TREE_CONSTANT (operand);
1189       break;
1190
1191     case INDIRECT_REF:
1192       /* If we want to refer to an unconstrained array, use the appropriate
1193          expression to do so.  This will never survive down to the back-end.
1194          But if TYPE is a thin pointer, first convert to a fat pointer.  */
1195       if (TYPE_IS_THIN_POINTER_P (type)
1196           && TYPE_UNCONSTRAINED_ARRAY (TREE_TYPE (type)))
1197         {
1198           operand
1199             = convert (TREE_TYPE (TYPE_UNCONSTRAINED_ARRAY (TREE_TYPE (type))),
1200                        operand);
1201           type = TREE_TYPE (operand);
1202         }
1203
1204       if (TYPE_IS_FAT_POINTER_P (type))
1205         {
1206           result = build1 (UNCONSTRAINED_ARRAY_REF,
1207                            TYPE_UNCONSTRAINED_ARRAY (type), operand);
1208           TREE_READONLY (result)
1209             = TYPE_READONLY (TYPE_UNCONSTRAINED_ARRAY (type));
1210         }
1211
1212       /* If we are dereferencing an ADDR_EXPR, return its operand.  */
1213       else if (TREE_CODE (operand) == ADDR_EXPR)
1214         result = TREE_OPERAND (operand, 0);
1215
1216       /* Otherwise, build and fold the indirect reference.  */
1217       else
1218         {
1219           result = build_fold_indirect_ref (operand);
1220           TREE_READONLY (result) = TYPE_READONLY (TREE_TYPE (type));
1221         }
1222
1223       side_effects
1224         = (!TYPE_IS_FAT_POINTER_P (type) && TYPE_VOLATILE (TREE_TYPE (type)));
1225       break;
1226
1227     case NEGATE_EXPR:
1228     case BIT_NOT_EXPR:
1229       {
1230         tree modulus = ((operation_type
1231                          && TREE_CODE (operation_type) == INTEGER_TYPE
1232                          && TYPE_MODULAR_P (operation_type))
1233                         ? TYPE_MODULUS (operation_type) : NULL_TREE);
1234         int mod_pow2 = modulus && integer_pow2p (modulus);
1235
1236         /* If this is a modular type, there are various possibilities
1237            depending on the operation and whether the modulus is a
1238            power of two or not.  */
1239
1240         if (modulus)
1241           {
1242             gcc_assert (operation_type == base_type);
1243             operand = convert (operation_type, operand);
1244
1245             /* The fastest in the negate case for binary modulus is
1246                the straightforward code; the TRUNC_MOD_EXPR below
1247                is an AND operation.  */
1248             if (op_code == NEGATE_EXPR && mod_pow2)
1249               result = fold_build2 (TRUNC_MOD_EXPR, operation_type,
1250                                     fold_build1 (NEGATE_EXPR, operation_type,
1251                                                  operand),
1252                                     modulus);
1253
1254             /* For nonbinary negate case, return zero for zero operand,
1255                else return the modulus minus the operand.  If the modulus
1256                is a power of two minus one, we can do the subtraction
1257                as an XOR since it is equivalent and faster on most machines. */
1258             else if (op_code == NEGATE_EXPR && !mod_pow2)
1259               {
1260                 if (integer_pow2p (fold_build2 (PLUS_EXPR, operation_type,
1261                                                 modulus,
1262                                                 convert (operation_type,
1263                                                          integer_one_node))))
1264                   result = fold_build2 (BIT_XOR_EXPR, operation_type,
1265                                         operand, modulus);
1266                 else
1267                   result = fold_build2 (MINUS_EXPR, operation_type,
1268                                         modulus, operand);
1269
1270                 result = fold_build3 (COND_EXPR, operation_type,
1271                                       fold_build2 (NE_EXPR,
1272                                                    boolean_type_node,
1273                                                    operand,
1274                                                    convert
1275                                                      (operation_type,
1276                                                       integer_zero_node)),
1277                                       result, operand);
1278               }
1279             else
1280               {
1281                 /* For the NOT cases, we need a constant equal to
1282                    the modulus minus one.  For a binary modulus, we
1283                    XOR against the constant and subtract the operand from
1284                    that constant for nonbinary modulus.  */
1285
1286                 tree cnst = fold_build2 (MINUS_EXPR, operation_type, modulus,
1287                                          convert (operation_type,
1288                                                   integer_one_node));
1289
1290                 if (mod_pow2)
1291                   result = fold_build2 (BIT_XOR_EXPR, operation_type,
1292                                         operand, cnst);
1293                 else
1294                   result = fold_build2 (MINUS_EXPR, operation_type,
1295                                         cnst, operand);
1296               }
1297
1298             break;
1299           }
1300       }
1301
1302       /* ... fall through ... */
1303
1304     default:
1305       gcc_assert (operation_type == base_type);
1306       result = fold_build1 (op_code, operation_type,
1307                             convert (operation_type, operand));
1308     }
1309
1310   if (side_effects)
1311     {
1312       TREE_SIDE_EFFECTS (result) = 1;
1313       if (TREE_CODE (result) == INDIRECT_REF)
1314         TREE_THIS_VOLATILE (result) = TYPE_VOLATILE (TREE_TYPE (result));
1315     }
1316
1317   if (result_type && TREE_TYPE (result) != result_type)
1318     result = convert (result_type, result);
1319
1320   return result;
1321 }
1322 \f
1323 /* Similar, but for COND_EXPR.  */
1324
1325 tree
1326 build_cond_expr (tree result_type, tree condition_operand,
1327                  tree true_operand, tree false_operand)
1328 {
1329   bool addr_p = false;
1330   tree result;
1331
1332   /* The front-end verified that result, true and false operands have
1333      same base type.  Convert everything to the result type.  */
1334   true_operand = convert (result_type, true_operand);
1335   false_operand = convert (result_type, false_operand);
1336
1337   /* If the result type is unconstrained, take the address of the operands and
1338      then dereference the result.  Likewise if the result type is passed by
1339      reference, but this is natively handled in the gimplifier.  */
1340   if (TREE_CODE (result_type) == UNCONSTRAINED_ARRAY_TYPE
1341       || CONTAINS_PLACEHOLDER_P (TYPE_SIZE (result_type)))
1342     {
1343       result_type = build_pointer_type (result_type);
1344       true_operand = build_unary_op (ADDR_EXPR, result_type, true_operand);
1345       false_operand = build_unary_op (ADDR_EXPR, result_type, false_operand);
1346       addr_p = true;
1347     }
1348
1349   result = fold_build3 (COND_EXPR, result_type, condition_operand,
1350                         true_operand, false_operand);
1351
1352   /* If we have a common SAVE_EXPR (possibly surrounded by arithmetics)
1353      in both arms, make sure it gets evaluated by moving it ahead of the
1354      conditional expression.  This is necessary because it is evaluated
1355      in only one place at run time and would otherwise be uninitialized
1356      in one of the arms.  */
1357   true_operand = skip_simple_arithmetic (true_operand);
1358   false_operand = skip_simple_arithmetic (false_operand);
1359
1360   if (true_operand == false_operand && TREE_CODE (true_operand) == SAVE_EXPR)
1361     result = build2 (COMPOUND_EXPR, result_type, true_operand, result);
1362
1363   if (addr_p)
1364     result = build_unary_op (INDIRECT_REF, NULL_TREE, result);
1365
1366   return result;
1367 }
1368
1369 /* Similar, but for RETURN_EXPR.  If RET_VAL is non-null, build a RETURN_EXPR
1370    around the assignment of RET_VAL to RET_OBJ.  Otherwise just build a bare
1371    RETURN_EXPR around RESULT_OBJ, which may be null in this case.  */
1372
1373 tree
1374 build_return_expr (tree ret_obj, tree ret_val)
1375 {
1376   tree result_expr;
1377
1378   if (ret_val)
1379     {
1380       /* The gimplifier explicitly enforces the following invariant:
1381
1382               RETURN_EXPR
1383                   |
1384               MODIFY_EXPR
1385               /        \
1386              /          \
1387          RET_OBJ        ...
1388
1389          As a consequence, type consistency dictates that we use the type
1390          of the RET_OBJ as the operation type.  */
1391       tree operation_type = TREE_TYPE (ret_obj);
1392
1393       /* Convert the right operand to the operation type.  Note that it's the
1394          same transformation as in the MODIFY_EXPR case of build_binary_op,
1395          with the assumption that the type cannot involve a placeholder.  */
1396       if (operation_type != TREE_TYPE (ret_val))
1397         ret_val = convert (operation_type, ret_val);
1398
1399       result_expr = build2 (MODIFY_EXPR, operation_type, ret_obj, ret_val);
1400     }
1401   else
1402     result_expr = ret_obj;
1403
1404   return build1 (RETURN_EXPR, void_type_node, result_expr);
1405 }
1406 \f
1407 /* Build a CALL_EXPR to call FUNDECL with one argument, ARG.  Return
1408    the CALL_EXPR.  */
1409
1410 tree
1411 build_call_1_expr (tree fundecl, tree arg)
1412 {
1413   tree call = build_call_nary (TREE_TYPE (TREE_TYPE (fundecl)),
1414                                build_unary_op (ADDR_EXPR, NULL_TREE, fundecl),
1415                                1, arg);
1416   TREE_SIDE_EFFECTS (call) = 1;
1417   return call;
1418 }
1419
1420 /* Build a CALL_EXPR to call FUNDECL with two arguments, ARG1 & ARG2.  Return
1421    the CALL_EXPR.  */
1422
1423 tree
1424 build_call_2_expr (tree fundecl, tree arg1, tree arg2)
1425 {
1426   tree call = build_call_nary (TREE_TYPE (TREE_TYPE (fundecl)),
1427                                build_unary_op (ADDR_EXPR, NULL_TREE, fundecl),
1428                                2, arg1, arg2);
1429   TREE_SIDE_EFFECTS (call) = 1;
1430   return call;
1431 }
1432
1433 /* Likewise to call FUNDECL with no arguments.  */
1434
1435 tree
1436 build_call_0_expr (tree fundecl)
1437 {
1438   /* We rely on build_call_nary to compute TREE_SIDE_EFFECTS.  This makes
1439      it possible to propagate DECL_IS_PURE on parameterless functions.  */
1440   tree call = build_call_nary (TREE_TYPE (TREE_TYPE (fundecl)),
1441                                build_unary_op (ADDR_EXPR, NULL_TREE, fundecl),
1442                                0);
1443   return call;
1444 }
1445 \f
1446 /* Call a function that raises an exception and pass the line number and file
1447    name, if requested.  MSG says which exception function to call.
1448
1449    GNAT_NODE is the gnat node conveying the source location for which the
1450    error should be signaled, or Empty in which case the error is signaled on
1451    the current ref_file_name/input_line.
1452
1453    KIND says which kind of exception this is for
1454    (N_Raise_{Constraint,Storage,Program}_Error).  */
1455
1456 tree
1457 build_call_raise (int msg, Node_Id gnat_node, char kind)
1458 {
1459   tree fndecl = gnat_raise_decls[msg];
1460   tree label = get_exception_label (kind);
1461   tree filename;
1462   int line_number;
1463   const char *str;
1464   int len;
1465
1466   /* If this is to be done as a goto, handle that case.  */
1467   if (label)
1468     {
1469       Entity_Id local_raise = Get_Local_Raise_Call_Entity ();
1470       tree gnu_result = build1 (GOTO_EXPR, void_type_node, label);
1471
1472       /* If Local_Raise is present, generate
1473          Local_Raise (exception'Identity);  */
1474       if (Present (local_raise))
1475         {
1476           tree gnu_local_raise
1477             = gnat_to_gnu_entity (local_raise, NULL_TREE, 0);
1478           tree gnu_exception_entity
1479             = gnat_to_gnu_entity (Get_RT_Exception_Entity (msg), NULL_TREE, 0);
1480           tree gnu_call
1481             = build_call_1_expr (gnu_local_raise,
1482                                  build_unary_op (ADDR_EXPR, NULL_TREE,
1483                                                  gnu_exception_entity));
1484
1485           gnu_result = build2 (COMPOUND_EXPR, void_type_node,
1486                                gnu_call, gnu_result);}
1487
1488       return gnu_result;
1489     }
1490
1491   str
1492     = (Debug_Flag_NN || Exception_Locations_Suppressed)
1493       ? ""
1494       : (gnat_node != Empty && Sloc (gnat_node) != No_Location)
1495         ? IDENTIFIER_POINTER
1496           (get_identifier (Get_Name_String
1497                            (Debug_Source_Name
1498                             (Get_Source_File_Index (Sloc (gnat_node))))))
1499         : ref_filename;
1500
1501   len = strlen (str);
1502   filename = build_string (len, str);
1503   line_number
1504     = (gnat_node != Empty && Sloc (gnat_node) != No_Location)
1505       ? Get_Logical_Line_Number (Sloc(gnat_node)) : input_line;
1506
1507   TREE_TYPE (filename) = build_array_type (unsigned_char_type_node,
1508                                            build_index_type (size_int (len)));
1509
1510   return
1511     build_call_2_expr (fndecl,
1512                        build1 (ADDR_EXPR,
1513                                build_pointer_type (unsigned_char_type_node),
1514                                filename),
1515                        build_int_cst (NULL_TREE, line_number));
1516 }
1517 \f
1518 /* qsort comparer for the bit positions of two constructor elements
1519    for record components.  */
1520
1521 static int
1522 compare_elmt_bitpos (const PTR rt1, const PTR rt2)
1523 {
1524   const constructor_elt * const elmt1 = (const constructor_elt const *) rt1;
1525   const constructor_elt * const elmt2 = (const constructor_elt const *) rt2;
1526   const_tree const field1 = elmt1->index;
1527   const_tree const field2 = elmt2->index;
1528   const int ret
1529     = tree_int_cst_compare (bit_position (field1), bit_position (field2));
1530
1531   return ret ? ret : (int) (DECL_UID (field1) - DECL_UID (field2));
1532 }
1533
1534 /* Return a CONSTRUCTOR of TYPE whose elements are V.  */
1535
1536 tree
1537 gnat_build_constructor (tree type, VEC(constructor_elt,gc) *v)
1538 {
1539   bool allconstant = (TREE_CODE (TYPE_SIZE (type)) == INTEGER_CST);
1540   bool side_effects = false;
1541   tree result, obj, val;
1542   unsigned int n_elmts;
1543
1544   /* Scan the elements to see if they are all constant or if any has side
1545      effects, to let us set global flags on the resulting constructor.  Count
1546      the elements along the way for possible sorting purposes below.  */
1547   FOR_EACH_CONSTRUCTOR_ELT (v, n_elmts, obj, val)
1548     {
1549       /* The predicate must be in keeping with output_constructor.  */
1550       if (!TREE_CONSTANT (val)
1551           || (TREE_CODE (type) == RECORD_TYPE
1552               && CONSTRUCTOR_BITFIELD_P (obj)
1553               && !initializer_constant_valid_for_bitfield_p (val))
1554           || !initializer_constant_valid_p (val, TREE_TYPE (val)))
1555         allconstant = false;
1556
1557       if (TREE_SIDE_EFFECTS (val))
1558         side_effects = true;
1559     }
1560
1561   /* For record types with constant components only, sort field list
1562      by increasing bit position.  This is necessary to ensure the
1563      constructor can be output as static data.  */
1564   if (allconstant && TREE_CODE (type) == RECORD_TYPE && n_elmts > 1)
1565     qsort (VEC_address (constructor_elt, v), n_elmts,
1566            sizeof (constructor_elt), compare_elmt_bitpos);
1567
1568   result = build_constructor (type, v);
1569   TREE_CONSTANT (result) = TREE_STATIC (result) = allconstant;
1570   TREE_SIDE_EFFECTS (result) = side_effects;
1571   TREE_READONLY (result) = TYPE_READONLY (type) || allconstant;
1572   return result;
1573 }
1574 \f
1575 /* Return a COMPONENT_REF to access a field that is given by COMPONENT,
1576    an IDENTIFIER_NODE giving the name of the field, or FIELD, a FIELD_DECL,
1577    for the field.  Don't fold the result if NO_FOLD_P is true.
1578
1579    We also handle the fact that we might have been passed a pointer to the
1580    actual record and know how to look for fields in variant parts.  */
1581
1582 static tree
1583 build_simple_component_ref (tree record_variable, tree component,
1584                             tree field, bool no_fold_p)
1585 {
1586   tree record_type = TYPE_MAIN_VARIANT (TREE_TYPE (record_variable));
1587   tree ref, inner_variable;
1588
1589   gcc_assert ((TREE_CODE (record_type) == RECORD_TYPE
1590                || TREE_CODE (record_type) == UNION_TYPE
1591                || TREE_CODE (record_type) == QUAL_UNION_TYPE)
1592               && TYPE_SIZE (record_type)
1593               && (component != 0) != (field != 0));
1594
1595   /* If no field was specified, look for a field with the specified name
1596      in the current record only.  */
1597   if (!field)
1598     for (field = TYPE_FIELDS (record_type); field;
1599          field = TREE_CHAIN (field))
1600       if (DECL_NAME (field) == component)
1601         break;
1602
1603   if (!field)
1604     return NULL_TREE;
1605
1606   /* If this field is not in the specified record, see if we can find a field
1607      in the specified record whose original field is the same as this one.  */
1608   if (DECL_CONTEXT (field) != record_type)
1609     {
1610       tree new_field;
1611
1612       /* First loop thru normal components.  */
1613       for (new_field = TYPE_FIELDS (record_type); new_field;
1614            new_field = DECL_CHAIN (new_field))
1615         if (SAME_FIELD_P (field, new_field))
1616           break;
1617
1618       /* Next, see if we're looking for an inherited component in an extension.
1619          If so, look thru the extension directly.  */
1620       if (!new_field
1621           && TREE_CODE (record_variable) == VIEW_CONVERT_EXPR
1622           && TYPE_ALIGN_OK (record_type)
1623           && TREE_CODE (TREE_TYPE (TREE_OPERAND (record_variable, 0)))
1624              == RECORD_TYPE
1625           && TYPE_ALIGN_OK (TREE_TYPE (TREE_OPERAND (record_variable, 0))))
1626         {
1627           ref = build_simple_component_ref (TREE_OPERAND (record_variable, 0),
1628                                             NULL_TREE, field, no_fold_p);
1629           if (ref)
1630             return ref;
1631         }
1632
1633       /* Next, loop thru DECL_INTERNAL_P components if we haven't found
1634          the component in the first search. Doing this search in 2 steps
1635          is required to avoiding hidden homonymous fields in the
1636          _Parent field.  */
1637       if (!new_field)
1638         for (new_field = TYPE_FIELDS (record_type); new_field;
1639              new_field = DECL_CHAIN (new_field))
1640           if (DECL_INTERNAL_P (new_field))
1641             {
1642               tree field_ref
1643                 = build_simple_component_ref (record_variable,
1644                                               NULL_TREE, new_field, no_fold_p);
1645               ref = build_simple_component_ref (field_ref, NULL_TREE, field,
1646                                                 no_fold_p);
1647
1648               if (ref)
1649                 return ref;
1650             }
1651
1652       field = new_field;
1653     }
1654
1655   if (!field)
1656     return NULL_TREE;
1657
1658   /* If the field's offset has overflowed, do not attempt to access it
1659      as doing so may trigger sanity checks deeper in the back-end.
1660      Note that we don't need to warn since this will be done on trying
1661      to declare the object.  */
1662   if (TREE_CODE (DECL_FIELD_OFFSET (field)) == INTEGER_CST
1663       && TREE_OVERFLOW (DECL_FIELD_OFFSET (field)))
1664     return NULL_TREE;
1665
1666   /* Look through conversion between type variants.  Note that this
1667      is transparent as far as the field is concerned.  */
1668   if (TREE_CODE (record_variable) == VIEW_CONVERT_EXPR
1669       && TYPE_MAIN_VARIANT (TREE_TYPE (TREE_OPERAND (record_variable, 0)))
1670          == record_type)
1671     inner_variable = TREE_OPERAND (record_variable, 0);
1672   else
1673     inner_variable = record_variable;
1674
1675   ref = build3 (COMPONENT_REF, TREE_TYPE (field), inner_variable, field,
1676                 NULL_TREE);
1677
1678   if (TREE_READONLY (record_variable) || TREE_READONLY (field))
1679     TREE_READONLY (ref) = 1;
1680   if (TREE_THIS_VOLATILE (record_variable) || TREE_THIS_VOLATILE (field)
1681       || TYPE_VOLATILE (record_type))
1682     TREE_THIS_VOLATILE (ref) = 1;
1683
1684   if (no_fold_p)
1685     return ref;
1686
1687   /* The generic folder may punt in this case because the inner array type
1688      can be self-referential, but folding is in fact not problematic.  */
1689   else if (TREE_CODE (record_variable) == CONSTRUCTOR
1690            && TYPE_CONTAINS_TEMPLATE_P (TREE_TYPE (record_variable)))
1691     {
1692       VEC(constructor_elt,gc) *elts = CONSTRUCTOR_ELTS (record_variable);
1693       unsigned HOST_WIDE_INT idx;
1694       tree index, value;
1695       FOR_EACH_CONSTRUCTOR_ELT (elts, idx, index, value)
1696         if (index == field)
1697           return value;
1698       return ref;
1699     }
1700
1701   else
1702     return fold (ref);
1703 }
1704 \f
1705 /* Like build_simple_component_ref, except that we give an error if the
1706    reference could not be found.  */
1707
1708 tree
1709 build_component_ref (tree record_variable, tree component,
1710                      tree field, bool no_fold_p)
1711 {
1712   tree ref = build_simple_component_ref (record_variable, component, field,
1713                                          no_fold_p);
1714
1715   if (ref)
1716     return ref;
1717
1718   /* If FIELD was specified, assume this is an invalid user field so raise
1719      Constraint_Error.  Otherwise, we have no type to return so abort.  */
1720   gcc_assert (field);
1721   return build1 (NULL_EXPR, TREE_TYPE (field),
1722                  build_call_raise (CE_Discriminant_Check_Failed, Empty,
1723                                    N_Raise_Constraint_Error));
1724 }
1725 \f
1726 /* Helper for build_call_alloc_dealloc, with arguments to be interpreted
1727    identically.  Process the case where a GNAT_PROC to call is provided.  */
1728
1729 static inline tree
1730 build_call_alloc_dealloc_proc (tree gnu_obj, tree gnu_size, tree gnu_type,
1731                                Entity_Id gnat_proc, Entity_Id gnat_pool)
1732 {
1733   tree gnu_proc = gnat_to_gnu (gnat_proc);
1734   tree gnu_proc_addr = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_proc);
1735   tree gnu_call;
1736
1737   /* The storage pools are obviously always tagged types, but the
1738      secondary stack uses the same mechanism and is not tagged.  */
1739   if (Is_Tagged_Type (Etype (gnat_pool)))
1740     {
1741       /* The size is the third parameter; the alignment is the
1742          same type.  */
1743       Entity_Id gnat_size_type
1744         = Etype (Next_Formal (Next_Formal (First_Formal (gnat_proc))));
1745       tree gnu_size_type = gnat_to_gnu_type (gnat_size_type);
1746
1747       tree gnu_pool = gnat_to_gnu (gnat_pool);
1748       tree gnu_pool_addr = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_pool);
1749       tree gnu_align = size_int (TYPE_ALIGN (gnu_type) / BITS_PER_UNIT);
1750
1751       gnu_size = convert (gnu_size_type, gnu_size);
1752       gnu_align = convert (gnu_size_type, gnu_align);
1753
1754       /* The first arg is always the address of the storage pool; next
1755          comes the address of the object, for a deallocator, then the
1756          size and alignment.  */
1757       if (gnu_obj)
1758         gnu_call = build_call_nary (TREE_TYPE (TREE_TYPE (gnu_proc)),
1759                                     gnu_proc_addr, 4, gnu_pool_addr,
1760                                     gnu_obj, gnu_size, gnu_align);
1761       else
1762         gnu_call = build_call_nary (TREE_TYPE (TREE_TYPE (gnu_proc)),
1763                                     gnu_proc_addr, 3, gnu_pool_addr,
1764                                     gnu_size, gnu_align);
1765     }
1766
1767   /* Secondary stack case.  */
1768   else
1769     {
1770       /* The size is the second parameter.  */
1771       Entity_Id gnat_size_type
1772         = Etype (Next_Formal (First_Formal (gnat_proc)));
1773       tree gnu_size_type = gnat_to_gnu_type (gnat_size_type);
1774
1775       gnu_size = convert (gnu_size_type, gnu_size);
1776
1777       /* The first arg is the address of the object, for a deallocator,
1778          then the size.  */
1779       if (gnu_obj)
1780         gnu_call = build_call_nary (TREE_TYPE (TREE_TYPE (gnu_proc)),
1781                                     gnu_proc_addr, 2, gnu_obj, gnu_size);
1782       else
1783         gnu_call = build_call_nary (TREE_TYPE (TREE_TYPE (gnu_proc)),
1784                                     gnu_proc_addr, 1, gnu_size);
1785     }
1786
1787   TREE_SIDE_EFFECTS (gnu_call) = 1;
1788   return gnu_call;
1789 }
1790
1791 /* Helper for build_call_alloc_dealloc, to build and return an allocator for
1792    DATA_SIZE bytes aimed at containing a DATA_TYPE object, using the default
1793    __gnat_malloc allocator.  Honor DATA_TYPE alignments greater than what the
1794    latter offers.  */
1795
1796 static inline tree
1797 maybe_wrap_malloc (tree data_size, tree data_type, Node_Id gnat_node)
1798 {
1799   /* When the DATA_TYPE alignment is stricter than what malloc offers
1800      (super-aligned case), we allocate an "aligning" wrapper type and return
1801      the address of its single data field with the malloc's return value
1802      stored just in front.  */
1803
1804   unsigned int data_align = TYPE_ALIGN (data_type);
1805   unsigned int default_allocator_alignment
1806       = get_target_default_allocator_alignment () * BITS_PER_UNIT;
1807
1808   tree aligning_type
1809     = ((data_align > default_allocator_alignment)
1810        ? make_aligning_type (data_type, data_align, data_size,
1811                              default_allocator_alignment,
1812                              POINTER_SIZE / BITS_PER_UNIT)
1813        : NULL_TREE);
1814
1815   tree size_to_malloc
1816     = aligning_type ? TYPE_SIZE_UNIT (aligning_type) : data_size;
1817
1818   tree malloc_ptr;
1819
1820   /* On VMS, if pointers are 64-bit and the allocator size is 32-bit or
1821      Convention C, allocate 32-bit memory.  */
1822   if (TARGET_ABI_OPEN_VMS
1823       && (POINTER_SIZE == 64
1824              && (UI_To_Int (Esize (Etype (gnat_node))) == 32
1825                  || Convention (Etype (gnat_node)) == Convention_C)))
1826     malloc_ptr = build_call_1_expr (malloc32_decl, size_to_malloc);
1827   else
1828     malloc_ptr = build_call_1_expr (malloc_decl, size_to_malloc);
1829
1830   if (aligning_type)
1831     {
1832       /* Latch malloc's return value and get a pointer to the aligning field
1833          first.  */
1834       tree storage_ptr = gnat_protect_expr (malloc_ptr);
1835
1836       tree aligning_record_addr
1837         = convert (build_pointer_type (aligning_type), storage_ptr);
1838
1839       tree aligning_record
1840         = build_unary_op (INDIRECT_REF, NULL_TREE, aligning_record_addr);
1841
1842       tree aligning_field
1843         = build_component_ref (aligning_record, NULL_TREE,
1844                                TYPE_FIELDS (aligning_type), false);
1845
1846       tree aligning_field_addr
1847         = build_unary_op (ADDR_EXPR, NULL_TREE, aligning_field);
1848
1849       /* Then arrange to store the allocator's return value ahead
1850          and return.  */
1851       tree storage_ptr_slot_addr
1852         = build_binary_op (POINTER_PLUS_EXPR, ptr_void_type_node,
1853                            convert (ptr_void_type_node, aligning_field_addr),
1854                            size_int (-(HOST_WIDE_INT) POINTER_SIZE
1855                                      / BITS_PER_UNIT));
1856
1857       tree storage_ptr_slot
1858         = build_unary_op (INDIRECT_REF, NULL_TREE,
1859                           convert (build_pointer_type (ptr_void_type_node),
1860                                    storage_ptr_slot_addr));
1861
1862       return
1863         build2 (COMPOUND_EXPR, TREE_TYPE (aligning_field_addr),
1864                 build_binary_op (MODIFY_EXPR, NULL_TREE,
1865                                  storage_ptr_slot, storage_ptr),
1866                 aligning_field_addr);
1867     }
1868   else
1869     return malloc_ptr;
1870 }
1871
1872 /* Helper for build_call_alloc_dealloc, to release a DATA_TYPE object
1873    designated by DATA_PTR using the __gnat_free entry point.  */
1874
1875 static inline tree
1876 maybe_wrap_free (tree data_ptr, tree data_type)
1877 {
1878   /* In the regular alignment case, we pass the data pointer straight to free.
1879      In the superaligned case, we need to retrieve the initial allocator
1880      return value, stored in front of the data block at allocation time.  */
1881
1882   unsigned int data_align = TYPE_ALIGN (data_type);
1883   unsigned int default_allocator_alignment
1884       = get_target_default_allocator_alignment () * BITS_PER_UNIT;
1885
1886   tree free_ptr;
1887
1888   if (data_align > default_allocator_alignment)
1889     {
1890       /* DATA_FRONT_PTR (void *)
1891          = (void *)DATA_PTR - (void *)sizeof (void *))  */
1892       tree data_front_ptr
1893         = build_binary_op
1894           (POINTER_PLUS_EXPR, ptr_void_type_node,
1895            convert (ptr_void_type_node, data_ptr),
1896            size_int (-(HOST_WIDE_INT) POINTER_SIZE / BITS_PER_UNIT));
1897
1898       /* FREE_PTR (void *) = *(void **)DATA_FRONT_PTR  */
1899       free_ptr
1900         = build_unary_op
1901           (INDIRECT_REF, NULL_TREE,
1902            convert (build_pointer_type (ptr_void_type_node), data_front_ptr));
1903     }
1904   else
1905     free_ptr = data_ptr;
1906
1907   return build_call_1_expr (free_decl, free_ptr);
1908 }
1909
1910 /* Build a GCC tree to call an allocation or deallocation function.
1911    If GNU_OBJ is nonzero, it is an object to deallocate.  Otherwise,
1912    generate an allocator.
1913
1914    GNU_SIZE is the number of bytes to allocate and GNU_TYPE is the contained
1915    object type, used to determine the to-be-honored address alignment.
1916    GNAT_PROC, if present, is a procedure to call and GNAT_POOL is the storage
1917    pool to use.  If not present, malloc and free are used.  GNAT_NODE is used
1918    to provide an error location for restriction violation messages.  */
1919
1920 tree
1921 build_call_alloc_dealloc (tree gnu_obj, tree gnu_size, tree gnu_type,
1922                           Entity_Id gnat_proc, Entity_Id gnat_pool,
1923                           Node_Id gnat_node)
1924 {
1925   gnu_size = SUBSTITUTE_PLACEHOLDER_IN_EXPR (gnu_size, gnu_obj);
1926
1927   /* Explicit proc to call ?  This one is assumed to deal with the type
1928      alignment constraints.  */
1929   if (Present (gnat_proc))
1930     return build_call_alloc_dealloc_proc (gnu_obj, gnu_size, gnu_type,
1931                                           gnat_proc, gnat_pool);
1932
1933   /* Otherwise, object to "free" or "malloc" with possible special processing
1934      for alignments stricter than what the default allocator honors.  */
1935   else if (gnu_obj)
1936     return maybe_wrap_free (gnu_obj, gnu_type);
1937   else
1938     {
1939       /* Assert that we no longer can be called with this special pool.  */
1940       gcc_assert (gnat_pool != -1);
1941
1942       /* Check that we aren't violating the associated restriction.  */
1943       if (!(Nkind (gnat_node) == N_Allocator && Comes_From_Source (gnat_node)))
1944         Check_No_Implicit_Heap_Alloc (gnat_node);
1945
1946       return maybe_wrap_malloc (gnu_size, gnu_type, gnat_node);
1947     }
1948 }
1949 \f
1950 /* Build a GCC tree to correspond to allocating an object of TYPE whose
1951    initial value is INIT, if INIT is nonzero.  Convert the expression to
1952    RESULT_TYPE, which must be some type of pointer.  Return the tree.
1953
1954    GNAT_PROC and GNAT_POOL optionally give the procedure to call and
1955    the storage pool to use.  GNAT_NODE is used to provide an error
1956    location for restriction violation messages.  If IGNORE_INIT_TYPE is
1957    true, ignore the type of INIT for the purpose of determining the size;
1958    this will cause the maximum size to be allocated if TYPE is of
1959    self-referential size.  */
1960
1961 tree
1962 build_allocator (tree type, tree init, tree result_type, Entity_Id gnat_proc,
1963                  Entity_Id gnat_pool, Node_Id gnat_node, bool ignore_init_type)
1964 {
1965   tree size = TYPE_SIZE_UNIT (type);
1966   tree result;
1967
1968   /* If the initializer, if present, is a NULL_EXPR, just return a new one.  */
1969   if (init && TREE_CODE (init) == NULL_EXPR)
1970     return build1 (NULL_EXPR, result_type, TREE_OPERAND (init, 0));
1971
1972   /* If RESULT_TYPE is a fat or thin pointer, set SIZE to be the sum of the
1973      sizes of the object and its template.  Allocate the whole thing and
1974      fill in the parts that are known.  */
1975   else if (TYPE_IS_FAT_OR_THIN_POINTER_P (result_type))
1976     {
1977       tree storage_type
1978         = build_unc_object_type_from_ptr (result_type, type,
1979                                           get_identifier ("ALLOC"), false);
1980       tree template_type = TREE_TYPE (TYPE_FIELDS (storage_type));
1981       tree storage_ptr_type = build_pointer_type (storage_type);
1982       tree storage;
1983
1984       size = SUBSTITUTE_PLACEHOLDER_IN_EXPR (TYPE_SIZE_UNIT (storage_type),
1985                                              init);
1986
1987       /* If the size overflows, pass -1 so the allocator will raise
1988          storage error.  */
1989       if (TREE_CODE (size) == INTEGER_CST && TREE_OVERFLOW (size))
1990         size = ssize_int (-1);
1991
1992       storage = build_call_alloc_dealloc (NULL_TREE, size, storage_type,
1993                                           gnat_proc, gnat_pool, gnat_node);
1994       storage = convert (storage_ptr_type, gnat_protect_expr (storage));
1995
1996       if (TYPE_IS_PADDING_P (type))
1997         {
1998           type = TREE_TYPE (TYPE_FIELDS (type));
1999           if (init)
2000             init = convert (type, init);
2001         }
2002
2003       /* If there is an initializing expression, make a constructor for
2004          the entire object including the bounds and copy it into the
2005          object.  If there is no initializing expression, just set the
2006          bounds.  */
2007       if (init)
2008         {
2009           VEC(constructor_elt,gc) *v = VEC_alloc (constructor_elt, gc, 2);
2010
2011           CONSTRUCTOR_APPEND_ELT (v, TYPE_FIELDS (storage_type),
2012                                   build_template (template_type, type, init));
2013           CONSTRUCTOR_APPEND_ELT (v, DECL_CHAIN (TYPE_FIELDS (storage_type)),
2014                                   init);
2015
2016           return convert
2017             (result_type,
2018              build2 (COMPOUND_EXPR, storage_ptr_type,
2019                      build_binary_op
2020                      (MODIFY_EXPR, storage_type,
2021                       build_unary_op (INDIRECT_REF, NULL_TREE,
2022                                       convert (storage_ptr_type, storage)),
2023                       gnat_build_constructor (storage_type, v)),
2024                      convert (storage_ptr_type, storage)));
2025         }
2026       else
2027         return build2
2028           (COMPOUND_EXPR, result_type,
2029            build_binary_op
2030            (MODIFY_EXPR, template_type,
2031             build_component_ref
2032             (build_unary_op (INDIRECT_REF, NULL_TREE,
2033                              convert (storage_ptr_type, storage)),
2034              NULL_TREE, TYPE_FIELDS (storage_type), false),
2035             build_template (template_type, type, NULL_TREE)),
2036            convert (result_type, convert (storage_ptr_type, storage)));
2037     }
2038
2039   /* If we have an initializing expression, see if its size is simpler
2040      than the size from the type.  */
2041   if (!ignore_init_type && init && TYPE_SIZE_UNIT (TREE_TYPE (init))
2042       && (TREE_CODE (TYPE_SIZE_UNIT (TREE_TYPE (init))) == INTEGER_CST
2043           || CONTAINS_PLACEHOLDER_P (size)))
2044     size = TYPE_SIZE_UNIT (TREE_TYPE (init));
2045
2046   /* If the size is still self-referential, reference the initializing
2047      expression, if it is present.  If not, this must have been a
2048      call to allocate a library-level object, in which case we use
2049      the maximum size.  */
2050   if (CONTAINS_PLACEHOLDER_P (size))
2051     {
2052       if (!ignore_init_type && init)
2053         size = substitute_placeholder_in_expr (size, init);
2054       else
2055         size = max_size (size, true);
2056     }
2057
2058   /* If the size overflows, pass -1 so the allocator will raise
2059      storage error.  */
2060   if (TREE_CODE (size) == INTEGER_CST && TREE_OVERFLOW (size))
2061     size = ssize_int (-1);
2062
2063   result = convert (result_type,
2064                     build_call_alloc_dealloc (NULL_TREE, size, type,
2065                                               gnat_proc, gnat_pool,
2066                                               gnat_node));
2067
2068   /* If we have an initial value, protect the new address, assign the value
2069      and return the address with a COMPOUND_EXPR.  */
2070   if (init)
2071     {
2072       result = gnat_protect_expr (result);
2073       result
2074         = build2 (COMPOUND_EXPR, TREE_TYPE (result),
2075                   build_binary_op
2076                   (MODIFY_EXPR, NULL_TREE,
2077                    build_unary_op (INDIRECT_REF,
2078                                    TREE_TYPE (TREE_TYPE (result)), result),
2079                    init),
2080                   result);
2081     }
2082
2083   return convert (result_type, result);
2084 }
2085 \f
2086 /* Fill in a VMS descriptor for EXPR and return a constructor for it.
2087    GNAT_FORMAL is how we find the descriptor record.  GNAT_ACTUAL is
2088    how we derive the source location to raise C_E on an out of range
2089    pointer. */
2090
2091 tree
2092 fill_vms_descriptor (tree expr, Entity_Id gnat_formal, Node_Id gnat_actual)
2093 {
2094   tree parm_decl = get_gnu_tree (gnat_formal);
2095   tree record_type = TREE_TYPE (TREE_TYPE (parm_decl));
2096   tree field;
2097   const bool do_range_check
2098     = strcmp ("MBO",
2099               IDENTIFIER_POINTER (DECL_NAME (TYPE_FIELDS (record_type))));
2100   VEC(constructor_elt,gc) *v = NULL;
2101
2102   expr = maybe_unconstrained_array (expr);
2103   gnat_mark_addressable (expr);
2104
2105   for (field = TYPE_FIELDS (record_type); field; field = DECL_CHAIN (field))
2106     {
2107       tree conexpr = convert (TREE_TYPE (field),
2108                               SUBSTITUTE_PLACEHOLDER_IN_EXPR
2109                               (DECL_INITIAL (field), expr));
2110
2111       /* Check to ensure that only 32-bit pointers are passed in
2112          32-bit descriptors */
2113       if (do_range_check
2114           && strcmp (IDENTIFIER_POINTER (DECL_NAME (field)), "POINTER") == 0)
2115         {
2116           tree pointer64type
2117             = build_pointer_type_for_mode (void_type_node, DImode, false);
2118           tree addr64expr = build_unary_op (ADDR_EXPR, pointer64type, expr);
2119           tree malloc64low
2120             = build_int_cstu (long_integer_type_node, 0x80000000);
2121
2122           add_stmt (build3 (COND_EXPR, void_type_node,
2123                             build_binary_op (GE_EXPR, boolean_type_node,
2124                                              convert (long_integer_type_node,
2125                                                       addr64expr),
2126                                              malloc64low),
2127                             build_call_raise (CE_Range_Check_Failed,
2128                                               gnat_actual,
2129                                               N_Raise_Constraint_Error),
2130                             NULL_TREE));
2131         }
2132       CONSTRUCTOR_APPEND_ELT (v, field, conexpr);
2133     }
2134
2135   return gnat_build_constructor (record_type, v);
2136 }
2137
2138 /* Indicate that we need to take the address of T and that it therefore
2139    should not be allocated in a register.  Returns true if successful.  */
2140
2141 bool
2142 gnat_mark_addressable (tree t)
2143 {
2144   while (true)
2145     switch (TREE_CODE (t))
2146       {
2147       case ADDR_EXPR:
2148       case COMPONENT_REF:
2149       case ARRAY_REF:
2150       case ARRAY_RANGE_REF:
2151       case REALPART_EXPR:
2152       case IMAGPART_EXPR:
2153       case VIEW_CONVERT_EXPR:
2154       case NON_LVALUE_EXPR:
2155       CASE_CONVERT:
2156         t = TREE_OPERAND (t, 0);
2157         break;
2158
2159       case COMPOUND_EXPR:
2160         t = TREE_OPERAND (t, 1);
2161         break;
2162
2163       case CONSTRUCTOR:
2164         TREE_ADDRESSABLE (t) = 1;
2165         return true;
2166
2167       case VAR_DECL:
2168       case PARM_DECL:
2169       case RESULT_DECL:
2170         TREE_ADDRESSABLE (t) = 1;
2171         return true;
2172
2173       case FUNCTION_DECL:
2174         TREE_ADDRESSABLE (t) = 1;
2175         return true;
2176
2177       case CONST_DECL:
2178         return DECL_CONST_CORRESPONDING_VAR (t)
2179                && gnat_mark_addressable (DECL_CONST_CORRESPONDING_VAR (t));
2180
2181       default:
2182         return true;
2183     }
2184 }
2185 \f
2186 /* Save EXP for later use or reuse.  This is equivalent to save_expr in tree.c
2187    but we know how to handle our own nodes.  */
2188
2189 tree
2190 gnat_save_expr (tree exp)
2191 {
2192   tree type = TREE_TYPE (exp);
2193   enum tree_code code = TREE_CODE (exp);
2194
2195   if (TREE_CONSTANT (exp) || code == SAVE_EXPR || code == NULL_EXPR)
2196     return exp;
2197
2198   if (code == UNCONSTRAINED_ARRAY_REF)
2199     {
2200       tree t = build1 (code, type, gnat_save_expr (TREE_OPERAND (exp, 0)));
2201       TREE_READONLY (t) = TYPE_READONLY (type);
2202       return t;
2203     }
2204
2205   /* If this is a COMPONENT_REF of a fat pointer, save the entire fat pointer.
2206      This may be more efficient, but will also allow us to more easily find
2207      the match for the PLACEHOLDER_EXPR.  */
2208   if (code == COMPONENT_REF
2209       && TYPE_IS_FAT_POINTER_P (TREE_TYPE (TREE_OPERAND (exp, 0))))
2210     return build3 (code, type, gnat_save_expr (TREE_OPERAND (exp, 0)),
2211                    TREE_OPERAND (exp, 1), TREE_OPERAND (exp, 2));
2212
2213   return save_expr (exp);
2214 }
2215
2216 /* Protect EXP for immediate reuse.  This is a variant of gnat_save_expr that
2217    is optimized under the assumption that EXP's value doesn't change before
2218    its subsequent reuse(s) except through its potential reevaluation.  */
2219
2220 tree
2221 gnat_protect_expr (tree exp)
2222 {
2223   tree type = TREE_TYPE (exp);
2224   enum tree_code code = TREE_CODE (exp);
2225
2226   if (TREE_CONSTANT (exp) || code == SAVE_EXPR || code == NULL_EXPR)
2227     return exp;
2228
2229   /* If EXP has no side effects, we theoritically don't need to do anything.
2230      However, we may be recursively passed more and more complex expressions
2231      involving checks which will be reused multiple times and eventually be
2232      unshared for gimplification; in order to avoid a complexity explosion
2233      at that point, we protect any expressions more complex than a simple
2234      arithmetic expression.  */
2235   if (!TREE_SIDE_EFFECTS (exp))
2236     {
2237       tree inner = skip_simple_arithmetic (exp);
2238       if (!EXPR_P (inner) || REFERENCE_CLASS_P (inner))
2239         return exp;
2240     }
2241
2242   /* If this is a conversion, protect what's inside the conversion.  */
2243   if (code == NON_LVALUE_EXPR
2244       || CONVERT_EXPR_CODE_P (code)
2245       || code == VIEW_CONVERT_EXPR)
2246   return build1 (code, type, gnat_protect_expr (TREE_OPERAND (exp, 0)));
2247
2248   /* If we're indirectly referencing something, we only need to protect the
2249      address since the data itself can't change in these situations.  */
2250   if (code == INDIRECT_REF || code == UNCONSTRAINED_ARRAY_REF)
2251     {
2252       tree t = build1 (code, type, gnat_protect_expr (TREE_OPERAND (exp, 0)));
2253       TREE_READONLY (t) = TYPE_READONLY (type);
2254       return t;
2255     }
2256
2257   /* If this is a COMPONENT_REF of a fat pointer, save the entire fat pointer.
2258      This may be more efficient, but will also allow us to more easily find
2259      the match for the PLACEHOLDER_EXPR.  */
2260   if (code == COMPONENT_REF
2261       && TYPE_IS_FAT_POINTER_P (TREE_TYPE (TREE_OPERAND (exp, 0))))
2262     return build3 (code, type, gnat_protect_expr (TREE_OPERAND (exp, 0)),
2263                    TREE_OPERAND (exp, 1), TREE_OPERAND (exp, 2));
2264
2265   /* If this is a fat pointer or something that can be placed in a register,
2266      just make a SAVE_EXPR.  Likewise for a CALL_EXPR as large objects are
2267      returned via invisible reference in most ABIs so the temporary will
2268      directly be filled by the callee.  */
2269   if (TYPE_IS_FAT_POINTER_P (type)
2270       || TYPE_MODE (type) != BLKmode
2271       || code == CALL_EXPR)
2272     return save_expr (exp);
2273
2274   /* Otherwise reference, protect the address and dereference.  */
2275   return
2276     build_unary_op (INDIRECT_REF, type,
2277                     save_expr (build_unary_op (ADDR_EXPR,
2278                                                build_reference_type (type),
2279                                                exp)));
2280 }
2281
2282 /* This is equivalent to stabilize_reference_1 in tree.c but we take an extra
2283    argument to force evaluation of everything.  */
2284
2285 static tree
2286 gnat_stabilize_reference_1 (tree e, bool force)
2287 {
2288   enum tree_code code = TREE_CODE (e);
2289   tree type = TREE_TYPE (e);
2290   tree result;
2291
2292   /* We cannot ignore const expressions because it might be a reference
2293      to a const array but whose index contains side-effects.  But we can
2294      ignore things that are actual constant or that already have been
2295      handled by this function.  */
2296   if (TREE_CONSTANT (e) || code == SAVE_EXPR)
2297     return e;
2298
2299   switch (TREE_CODE_CLASS (code))
2300     {
2301     case tcc_exceptional:
2302     case tcc_declaration:
2303     case tcc_comparison:
2304     case tcc_expression:
2305     case tcc_reference:
2306     case tcc_vl_exp:
2307       /* If this is a COMPONENT_REF of a fat pointer, save the entire
2308          fat pointer.  This may be more efficient, but will also allow
2309          us to more easily find the match for the PLACEHOLDER_EXPR.  */
2310       if (code == COMPONENT_REF
2311           && TYPE_IS_FAT_POINTER_P (TREE_TYPE (TREE_OPERAND (e, 0))))
2312         result
2313           = build3 (code, type,
2314                     gnat_stabilize_reference_1 (TREE_OPERAND (e, 0), force),
2315                     TREE_OPERAND (e, 1), TREE_OPERAND (e, 2));
2316       /* If the expression has side-effects, then encase it in a SAVE_EXPR
2317          so that it will only be evaluated once.  */
2318       /* The tcc_reference and tcc_comparison classes could be handled as
2319          below, but it is generally faster to only evaluate them once.  */
2320       else if (TREE_SIDE_EFFECTS (e) || force)
2321         return save_expr (e);
2322       else
2323         return e;
2324       break;
2325
2326     case tcc_binary:
2327       /* Recursively stabilize each operand.  */
2328       result
2329         = build2 (code, type,
2330                   gnat_stabilize_reference_1 (TREE_OPERAND (e, 0), force),
2331                   gnat_stabilize_reference_1 (TREE_OPERAND (e, 1), force));
2332       break;
2333
2334     case tcc_unary:
2335       /* Recursively stabilize each operand.  */
2336       result
2337         = build1 (code, type,
2338                   gnat_stabilize_reference_1 (TREE_OPERAND (e, 0), force));
2339       break;
2340
2341     default:
2342       gcc_unreachable ();
2343     }
2344
2345   /* See similar handling in gnat_stabilize_reference.  */
2346   TREE_READONLY (result) = TREE_READONLY (e);
2347   TREE_SIDE_EFFECTS (result) |= TREE_SIDE_EFFECTS (e);
2348   TREE_THIS_VOLATILE (result) = TREE_THIS_VOLATILE (e);
2349
2350   return result;
2351 }
2352
2353 /* This is equivalent to stabilize_reference in tree.c but we know how to
2354    handle our own nodes and we take extra arguments.  FORCE says whether to
2355    force evaluation of everything.  We set SUCCESS to true unless we walk
2356    through something we don't know how to stabilize.  */
2357
2358 tree
2359 gnat_stabilize_reference (tree ref, bool force, bool *success)
2360 {
2361   tree type = TREE_TYPE (ref);
2362   enum tree_code code = TREE_CODE (ref);
2363   tree result;
2364
2365   /* Assume we'll success unless proven otherwise.  */
2366   if (success)
2367     *success = true;
2368
2369   switch (code)
2370     {
2371     case CONST_DECL:
2372     case VAR_DECL:
2373     case PARM_DECL:
2374     case RESULT_DECL:
2375       /* No action is needed in this case.  */
2376       return ref;
2377
2378     case ADDR_EXPR:
2379     CASE_CONVERT:
2380     case FLOAT_EXPR:
2381     case FIX_TRUNC_EXPR:
2382     case VIEW_CONVERT_EXPR:
2383       result
2384         = build1 (code, type,
2385                   gnat_stabilize_reference (TREE_OPERAND (ref, 0), force,
2386                                             success));
2387       break;
2388
2389     case INDIRECT_REF:
2390     case UNCONSTRAINED_ARRAY_REF:
2391       result = build1 (code, type,
2392                        gnat_stabilize_reference_1 (TREE_OPERAND (ref, 0),
2393                                                    force));
2394       break;
2395
2396     case COMPONENT_REF:
2397      result = build3 (COMPONENT_REF, type,
2398                       gnat_stabilize_reference (TREE_OPERAND (ref, 0), force,
2399                                                 success),
2400                       TREE_OPERAND (ref, 1), NULL_TREE);
2401       break;
2402
2403     case BIT_FIELD_REF:
2404       result = build3 (BIT_FIELD_REF, type,
2405                        gnat_stabilize_reference (TREE_OPERAND (ref, 0), force,
2406                                                  success),
2407                        gnat_stabilize_reference_1 (TREE_OPERAND (ref, 1),
2408                                                    force),
2409                        gnat_stabilize_reference_1 (TREE_OPERAND (ref, 2),
2410                                                    force));
2411       break;
2412
2413     case ARRAY_REF:
2414     case ARRAY_RANGE_REF:
2415       result = build4 (code, type,
2416                        gnat_stabilize_reference (TREE_OPERAND (ref, 0), force,
2417                                                  success),
2418                        gnat_stabilize_reference_1 (TREE_OPERAND (ref, 1),
2419                                                    force),
2420                        NULL_TREE, NULL_TREE);
2421       break;
2422
2423     case CALL_EXPR:
2424       result = gnat_stabilize_reference_1 (ref, force);
2425       break;
2426
2427     case COMPOUND_EXPR:
2428       result = build2 (COMPOUND_EXPR, type,
2429                        gnat_stabilize_reference (TREE_OPERAND (ref, 0), force,
2430                                                  success),
2431                        gnat_stabilize_reference_1 (TREE_OPERAND (ref, 1),
2432                                                    force));
2433       break;
2434
2435     case CONSTRUCTOR:
2436       /* Constructors with 1 element are used extensively to formally
2437          convert objects to special wrapping types.  */
2438       if (TREE_CODE (type) == RECORD_TYPE
2439           && VEC_length (constructor_elt, CONSTRUCTOR_ELTS (ref)) == 1)
2440         {
2441           tree index
2442             = VEC_index (constructor_elt, CONSTRUCTOR_ELTS (ref), 0)->index;
2443           tree value
2444             = VEC_index (constructor_elt, CONSTRUCTOR_ELTS (ref), 0)->value;
2445           result
2446             = build_constructor_single (type, index,
2447                                         gnat_stabilize_reference_1 (value,
2448                                                                     force));
2449         }
2450       else
2451         {
2452           if (success)
2453             *success = false;
2454           return ref;
2455         }
2456       break;
2457
2458     case ERROR_MARK:
2459       ref = error_mark_node;
2460
2461       /* ...  fall through to failure ... */
2462
2463       /* If arg isn't a kind of lvalue we recognize, make no change.
2464          Caller should recognize the error for an invalid lvalue.  */
2465     default:
2466       if (success)
2467         *success = false;
2468       return ref;
2469     }
2470
2471   /* TREE_THIS_VOLATILE and TREE_SIDE_EFFECTS set on the initial expression
2472      may not be sustained across some paths, such as the way via build1 for
2473      INDIRECT_REF.  We reset those flags here in the general case, which is
2474      consistent with the GCC version of this routine.
2475
2476      Special care should be taken regarding TREE_SIDE_EFFECTS, because some
2477      paths introduce side-effects where there was none initially (e.g. if a
2478      SAVE_EXPR is built) and we also want to keep track of that.  */
2479   TREE_READONLY (result) = TREE_READONLY (ref);
2480   TREE_SIDE_EFFECTS (result) |= TREE_SIDE_EFFECTS (ref);
2481   TREE_THIS_VOLATILE (result) = TREE_THIS_VOLATILE (ref);
2482
2483   return result;
2484 }