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